amelia
/
ahc


{-# LANGUAGE GeneralizedNewtypeDeriving #-}

{-# LANGUAGE TypeFamilies #-}

module Main.Rules where


import Control.DeepSeq (deepseq)

import Control.Concurrent

import Control.Exception

import Control.Monad


import Crypto.Hash.SHA1 as Sha1


import qualified Data.ByteString.Lazy as Lbs

import qualified Data.Text.Lazy.IO as Lt

import Data.ByteString (ByteString)

import qualified Data.Text as T

import Data.Foldable (for_)


import Development.Shake.FilePath

import Development.Shake.Classes

import Development.Shake


import Errors


import Frontend.Lexer.Wrapper (runAlex)

import Frontend.Autogen.Parser

import Frontend.Parser.Posn

import Frontend.Syntax.Var

import Frontend.Syntax


import GHC.Generics (Generic)


import Main.Queries


import Rename.Types (FqVar, ModuleId(..), RenamedMod)

import qualified Rename.Types as Rv

import Rename.Rename


import System.IO


import Text.Show.Pretty


findModuleOracle :: Rules ()

findModuleOracle = void $ addOracleCache find where

 find :: AhcModuleFilepath -> Action String

 find (AhcModuleFilepath our_fp (ModId id (Posn sl sc) pe)) = go "" id where

 go fp xs | T.null xs || not (T.singleton '.' `T.isInfixOf` xs) = do

 fp <- pure (fp </> T.unpack xs <.> "hs")

 t <- doesFileExist fp

 unless t . liftIO . throwIO $

 emptyError { errorMessage = "file does not exist:"

 , errorFilename = our_fp

 , errorBegin = Posn sl (sc + length fp)

 , errorEnd = pe

 }

 pure fp


 go fp xs = do

 (x, xs) <- pure $ T.span (/= '.') xs

 ex <- doesDirectoryExist (T.unpack x)

 unless ex . liftIO . throwIO $

 emptyError { errorMessage = "directory in module path does not exist:"

 , errorFilename = our_fp

 , errorBegin = Posn sl (sc + length fp)

 , errorEnd = Posn sl (sc + length fp + T.length x)

 }

 go (fp </> T.unpack x) xs


 find _ = undefined


parserOracle :: Rules (String -> Action (FeModule ParsedVar))

parserOracle = fmap (. AhcParsedModule) $ addOracleCache (parse . ahcpmFilePath) where

 parse :: String -> Action (FeModule ParsedVar)

 parse fpath = do

 need [fpath]

 fileContents <- liftIO $ Lt.readFile fpath


 let mod = runAlex fpath fileContents parseMod

 () <- liftIO . evaluate $ rnf mod


 case mod of

 Left e -> liftIO $ throwIO e

 Right x -> pure x


renamerOracle :: Rules (String -> Action RenamedMod)

renamerOracle = fmap (. AhcRenamedModule) $ addOracleCache (rename . ahcrnFilePath) where

 rename :: String -> Action RenamedMod

 rename fpath = do

 mod <- askOracle (AhcParsedModule fpath) :: Action (FeModule ParsedVar)

 hash <- askOracle (AhcModuleHash fpath)

 mvar <- liftIO $ newMVar mempty

 let

 modid = ModuleId { Rv.moduleName = varId $ Frontend.Syntax.moduleName mod

 , moduleHash = hash

 , moduleFp = fpath

 }

 rnctx = RenameCtx { rcOurModId = modid

 , rcOurFilePath = fpath

 , rcScope = mempty

 , rcThisModule = mvar

 , rcSpanStart = Posn 1 1

 , rcSpanEnd = Posn 1 1

 }

 runRename (renameModule mod) rnctx


hashOracle :: Rules (String -> Action ByteString)

hashOracle = fmap (. AhcModuleHash) . addOracleCache $ \(AhcModuleHash fp) -> do

 need [fp]

 fileContents <- liftIO $ Lbs.readFile fp

 pure (Sha1.hashlazy fileContents)


compilerRules :: [String] -> Rules ()

compilerRules wanted_mods = do

 findModuleOracle

 parser <- parserOracle

 hash <- hashOracle

 rename <- renamerOracle


 action $ do

 for_ wanted_mods $ \path -> do

 ast <- rename path

 liftIO $ pPrint ast