module Language.PureScript.Make
(
RebuildPolicy(..)
, ProgressMessage(..), renderProgressMessage
, MakeActions(..)
, Externs()
, make
, Make(..)
, runMake
, buildMakeActions
) where
import Control.Applicative
import Control.Arrow ((&&&))
import Control.Monad
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.Trans.Except
import Control.Monad.Reader
import Control.Monad.Writer
import Control.Monad.Supply
import Data.Function (on)
import Data.List (sortBy, groupBy)
import Data.Maybe (fromMaybe)
import Data.Time.Clock
import Data.Foldable (for_)
import Data.Traversable (traverse)
import Data.Version (showVersion)
import qualified Data.Map as M
import qualified Data.Set as S
import System.Directory
(doesFileExist, getModificationTime, createDirectoryIfMissing)
import System.FilePath ((</>), takeDirectory)
import System.IO.Error (tryIOError)
import Language.PureScript.AST
import Language.PureScript.CodeGen.Externs (moduleToPs)
import Language.PureScript.Environment
import Language.PureScript.Errors
import Language.PureScript.Linter
import Language.PureScript.ModuleDependencies
import Language.PureScript.Names
import Language.PureScript.Options
import Language.PureScript.Parser
import Language.PureScript.Pretty
import Language.PureScript.Renamer
import Language.PureScript.Sugar
import Language.PureScript.TypeChecker
import qualified Language.PureScript.Constants as C
import qualified Language.PureScript.CodeGen.JS as J
import qualified Language.PureScript.CoreFn as CF
import qualified Paths_purescript as Paths
data ProgressMessage
= CompilingModule ModuleName
deriving (Show, Eq, Ord)
renderProgressMessage :: ProgressMessage -> String
renderProgressMessage (CompilingModule mn) = "Compiling " ++ runModuleName mn
data MakeActions m = MakeActions {
getInputTimestamp :: ModuleName -> m (Either RebuildPolicy (Maybe UTCTime))
, getOutputTimestamp :: ModuleName -> m (Maybe UTCTime)
, readExterns :: ModuleName -> m (FilePath, String)
, codegen :: CF.Module CF.Ann -> Environment -> Externs -> SupplyT m ()
, progress :: ProgressMessage -> m ()
}
type Externs = String
data RebuildPolicy
= RebuildNever
| RebuildAlways deriving (Show, Eq, Ord)
make :: forall m. (Functor m, Applicative m, Monad m, MonadReader Options m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
=> MakeActions m
-> [Module]
-> m Environment
make MakeActions{..} ms = do
(sorted, graph) <- sortModules $ map importPrim ms
toRebuild <- foldM (\s (Module _ moduleName' _ _) -> do
inputTimestamp <- getInputTimestamp moduleName'
outputTimestamp <- getOutputTimestamp moduleName'
return $ case (inputTimestamp, outputTimestamp) of
(Right (Just t1), Just t2) | t1 < t2 -> s
(Left RebuildNever, Just _) -> s
_ -> S.insert moduleName' s) S.empty sorted
marked <- rebuildIfNecessary (reverseDependencies graph) toRebuild sorted
for_ marked $ \(willRebuild, m) -> when willRebuild (lint m)
(desugared, nextVar) <- runSupplyT 0 $ zip (map fst marked) <$> desugar (map snd marked)
evalSupplyT nextVar $ go initEnvironment desugared
where
go :: Environment -> [(Bool, Module)] -> SupplyT m Environment
go env [] = return env
go env ((False, m) : ms') = do
(_, env') <- lift . runCheck' env $ typeCheckModule Nothing m
go env' ms'
go env ((True, m@(Module coms moduleName' _ exps)) : ms') = do
lift . progress $ CompilingModule moduleName'
(checked@(Module _ _ elaborated _), env') <- lift . runCheck' env $ typeCheckModule Nothing m
checkExhaustiveModule env' checked
regrouped <- createBindingGroups moduleName' . collapseBindingGroups $ elaborated
let mod' = Module coms moduleName' regrouped exps
corefn = CF.moduleToCoreFn env' mod'
[renamed] = renameInModules [corefn]
exts = moduleToPs mod' env'
codegen renamed env' exts
go env' ms'
rebuildIfNecessary :: M.Map ModuleName [ModuleName] -> S.Set ModuleName -> [Module] -> m [(Bool, Module)]
rebuildIfNecessary _ _ [] = return []
rebuildIfNecessary graph toRebuild (m@(Module _ moduleName' _ _) : ms') | moduleName' `S.member` toRebuild = do
let deps = fromMaybe [] $ moduleName' `M.lookup` graph
toRebuild' = toRebuild `S.union` S.fromList deps
(:) (True, m) <$> rebuildIfNecessary graph toRebuild' ms'
rebuildIfNecessary graph toRebuild (Module _ moduleName' _ _ : ms') = do
(path, externs) <- readExterns moduleName'
externsModules <- fmap (map snd) . alterErrors $ parseModulesFromFiles id [(path, externs)]
case externsModules of
[m'@(Module _ moduleName'' _ _)] | moduleName'' == moduleName' -> (:) (False, m') <$> rebuildIfNecessary graph toRebuild ms'
_ -> throwError . errorMessage . InvalidExternsFile $ path
where
alterErrors = flip catchError $ \(MultipleErrors errs) ->
throwError . MultipleErrors $ flip map errs $ \e -> case e of
SimpleErrorWrapper (ErrorParsingModule err) -> SimpleErrorWrapper (ErrorParsingExterns err)
_ -> e
reverseDependencies :: ModuleGraph -> M.Map ModuleName [ModuleName]
reverseDependencies g = combine [ (dep, mn) | (mn, deps) <- g, dep <- deps ]
where
combine :: (Ord a) => [(a, b)] -> M.Map a [b]
combine = M.fromList . map ((fst . head) &&& map snd) . groupBy ((==) `on` fst) . sortBy (compare `on` fst)
addDefaultImport :: ModuleName -> Module -> Module
addDefaultImport toImport m@(Module coms mn decls exps) =
if isExistingImport `any` decls || mn == toImport then m
else Module coms mn (ImportDeclaration toImport Implicit Nothing : decls) exps
where
isExistingImport (ImportDeclaration mn' _ _) | mn' == toImport = True
isExistingImport (PositionedDeclaration _ _ d) = isExistingImport d
isExistingImport _ = False
importPrim :: Module -> Module
importPrim = addDefaultImport (ModuleName [ProperName C.prim])
newtype Make a = Make { unMake :: ReaderT Options (WriterT MultipleErrors (ExceptT MultipleErrors IO)) a }
deriving (Functor, Applicative, Monad, MonadIO, MonadError MultipleErrors, MonadWriter MultipleErrors, MonadReader Options)
runMake :: Options -> Make a -> IO (Either MultipleErrors (a, MultipleErrors))
runMake opts = runExceptT . runWriterT . flip runReaderT opts . unMake
makeIO :: (IOError -> ErrorMessage) -> IO a -> Make a
makeIO f io = do
e <- liftIO $ tryIOError io
either (throwError . singleError . f) return e
traverseEither :: Applicative f => (a -> f b) -> Either e a -> f (Either e b)
traverseEither _ (Left x) = pure (Left x)
traverseEither f (Right y) = Right <$> f y
buildMakeActions :: FilePath
-> M.Map ModuleName (Either RebuildPolicy FilePath)
-> M.Map ModuleName FilePath
-> Bool
-> MakeActions Make
buildMakeActions outputDir filePathMap foreigns usePrefix =
MakeActions getInputTimestamp getOutputTimestamp readExterns codegen progress
where
getInputTimestamp :: ModuleName -> Make (Either RebuildPolicy (Maybe UTCTime))
getInputTimestamp mn = do
let path = fromMaybe (error "Module has no filename in 'make'") $ M.lookup mn filePathMap
e1 <- traverseEither getTimestamp path
fPath <- maybe (return Nothing) getTimestamp $ M.lookup mn foreigns
return $ fmap (max fPath) e1
getOutputTimestamp :: ModuleName -> Make (Maybe UTCTime)
getOutputTimestamp mn = do
let filePath = runModuleName mn
jsFile = outputDir </> filePath </> "index.js"
externsFile = outputDir </> filePath </> "externs.purs"
min <$> getTimestamp jsFile <*> getTimestamp externsFile
readExterns :: ModuleName -> Make (FilePath, String)
readExterns mn = do
let path = outputDir </> runModuleName mn </> "externs.purs"
(path, ) <$> readTextFile path
codegen :: CF.Module CF.Ann -> Environment -> Externs -> SupplyT Make ()
codegen m _ exts = do
let mn = CF.moduleName m
foreignInclude <- case mn `M.lookup` foreigns of
Just path
| not $ requiresForeign m -> do
tell $ errorMessage $ UnnecessaryFFIModule mn path
return Nothing
| otherwise -> return $ Just $ J.JSApp (J.JSVar "require") [J.JSStringLiteral "./foreign"]
Nothing | requiresForeign m -> throwError . errorMessage $ MissingFFIModule mn
| otherwise -> return Nothing
pjs <- prettyPrintJS <$> J.moduleToJs m foreignInclude
let filePath = runModuleName mn
jsFile = outputDir </> filePath </> "index.js"
externsFile = outputDir </> filePath </> "externs.purs"
foreignFile = outputDir </> filePath </> "foreign.js"
prefix = ["Generated by psc version " ++ showVersion Paths.version | usePrefix]
js = unlines $ map ("// " ++) prefix ++ [pjs]
lift $ do
writeTextFile jsFile js
for_ (mn `M.lookup` foreigns) (readTextFile >=> writeTextFile foreignFile)
writeTextFile externsFile exts
requiresForeign :: CF.Module a -> Bool
requiresForeign = not . null . CF.moduleForeign
getTimestamp :: FilePath -> Make (Maybe UTCTime)
getTimestamp path = makeIO (const (SimpleErrorWrapper $ CannotGetFileInfo path)) $ do
exists <- doesFileExist path
traverse (const $ getModificationTime path) $ guard exists
readTextFile :: FilePath -> Make String
readTextFile path = makeIO (const (SimpleErrorWrapper $ CannotReadFile path)) $ readFile path
writeTextFile :: FilePath -> String -> Make ()
writeTextFile path text = makeIO (const (SimpleErrorWrapper $ CannotWriteFile path)) $ do
mkdirp path
writeFile path text
where
mkdirp :: FilePath -> IO ()
mkdirp = createDirectoryIfMissing True . takeDirectory
progress :: ProgressMessage -> Make ()
progress = liftIO . putStrLn . renderProgressMessage