{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
module Fay.Compiler.Import
( startCompile
, compileWith
) where
import Fay.Compiler.Prelude
import Fay.Compiler.Misc
import Fay.Compiler.Parse
import Fay.Config
import qualified Fay.Exts as F
import Fay.Exts.NoAnnotation (unAnn)
import Fay.Types
import Control.Monad.Except (throwError)
import Control.Monad.RWS (ask, get, gets, lift, listen, modify)
import Language.Haskell.Exts hiding (name)
import System.Directory
import System.FilePath
startCompile :: (FilePath -> String -> Compile a) -> FilePath -> Compile a
startCompile compileModule filein = do
modify $ \s -> s { stateImported = [] }
fmap fst . listen $ compileModuleFromFile compileModule filein
compileWith
:: (Monoid a, Semigroup a)
=> FilePath
-> (a -> F.Module -> Compile a)
-> (FilePath -> String -> Compile a)
-> (F.X -> F.Module -> IO (Either CompileError F.Module))
-> String
-> Compile (a, CompileState, CompileWriter)
compileWith filepath with compileModule before from = do
rd <- ask
st <- get
res <- Compile . lift . lift $
runCompileModule
rd
st
(parseResult (throwError . uncurry ParseError)
(\mod' -> do
mod@(Module _ _ _ imports _) <-
either throwError return =<< io (before F.noI mod')
res <- foldr (<>) mempty <$> mapM (compileImport compileModule) imports
modify $ \s -> s { stateModuleName = unAnn $ F.moduleName mod }
with res mod
)
(parseFay filepath from))
either throwError return res
compileModuleFromFile
:: (FilePath -> String -> Compile a)
-> FilePath
-> Compile a
compileModuleFromFile compileModule fp = io (readFile fp) >>= compileModule fp
compileModuleFromName
:: Monoid a
=> (FilePath -> String -> Compile a)
-> F.ModuleName
-> Compile a
compileModuleFromName compileModule nm =
unlessImported nm compileModule
where
unlessImported
:: Monoid a
=> ModuleName l
-> (FilePath -> String -> Compile a)
-> Compile a
unlessImported (ModuleName _ "Fay.Types") _ = return mempty
unlessImported (unAnn -> name) importIt = do
imported <- gets stateImported
case lookup name imported of
Just _ -> return mempty
Nothing -> do
dirs <- configDirectoryIncludePaths <$> config id
(filepath,contents) <- findImport dirs name
modify $ \s -> s { stateImported = (name,filepath) : imported }
importIt filepath contents
compileImport
:: Monoid a
=> (FilePath -> String -> Compile a)
-> F.ImportDecl
-> Compile a
compileImport compileModule i = case i of
ImportDecl _ _ _ _ _ (Just "base") _ _ -> return mempty
ImportDecl _ name _ _ _ _ _ _ -> compileModuleFromName compileModule name
findImport :: [FilePath] -> ModuleName a -> Compile (FilePath,String)
findImport alldirs (unAnn -> mname) = go alldirs mname where
go :: [FilePath] -> ModuleName a -> Compile (FilePath,String)
go _ (ModuleName _ "Fay.Types") = return ("Fay/Types.hs", "newtype Fay a = Fay (Identity a)\n\nnewtype Identity a = Identity a")
go (dir:dirs) name = do
exists <- io (doesFileExist path)
if exists
then (path,) . stdlibHack <$> io (readFile path)
else go dirs name
where
path = dir </> replace '.' '/' (prettyPrint name) ++ ".hs"
replace c r = map (\x -> if x == c then r else x)
go [] name =
throwError $ Couldn'tFindImport (unAnn name) alldirs
stdlibHack = case mname of
ModuleName _ "Fay.FFI" -> const "module Fay.FFI where\n\ndata Nullable a = Nullable a | Null\n\ndata Defined a = Defined a | Undefined"
_ -> id