module Language.PureScript.Make
(
RebuildPolicy(..)
, MakeActions(..)
, SupplyVar()
, 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 Control.Monad.Supply.Class (fresh)
import Data.Function (on)
import Data.List (sortBy, groupBy)
import Data.Maybe (fromMaybe)
import Data.Time.Clock
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 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 -> SupplyVar -> Externs -> m ()
, progress :: String -> m ()
}
type Externs = String
type SupplyVar = Integer
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
mapM_ lint sorted
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
(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 $ "Compiling " ++ runModuleName 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'
nextVar <- fresh
lift $ codegen renamed env' nextVar 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 String)
-> M.Map ModuleName (FilePath, ForeignJS)
-> 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 . fst) $ 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 -> SupplyVar -> Externs -> Make ()
codegen m _ nextVar 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 <- evalSupplyT nextVar $ 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]
verboseErrorsEnabled <- asks optionsVerboseErrors
when verboseErrorsEnabled $ progress $ "Writing " ++ jsFile
writeTextFile jsFile js
maybe (return ()) (writeTextFile foreignFile . snd) $ mn `M.lookup` foreigns
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 :: String -> Make ()
progress = liftIO . putStrLn