module Language.PureScript.Make
(
RebuildPolicy(..)
, ProgressMessage(..), renderProgressMessage
, MakeActions(..)
, Externs()
, make
, Make(..)
, runMake
, buildMakeActions
) where
import Prelude ()
import Prelude.Compat
import Control.Monad hiding (sequence)
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.Writer.Class (MonadWriter(..))
import Control.Monad.Trans.Class (MonadTrans(..))
import Control.Monad.Trans.Except
import Control.Monad.IO.Class
import Control.Monad.Reader (MonadReader(..), ReaderT(..))
import Control.Monad.Logger
import Control.Monad.Supply
import Control.Monad.Base (MonadBase(..))
import Control.Monad.Trans.Control (MonadBaseControl(..))
import Control.Concurrent.Lifted as C
import Data.List (foldl', sort)
import Data.Maybe (fromMaybe, catMaybes)
import Data.Time.Clock
import Data.String (fromString)
import Data.Foldable (for_)
import Data.Traversable (for)
import Data.Version (showVersion)
import Data.Aeson (encode, decode)
import qualified Data.ByteString.Lazy as B
import qualified Data.ByteString.UTF8 as BU8
import qualified Data.Set as S
import qualified Data.Map as M
import System.Directory
(doesFileExist, getModificationTime, createDirectoryIfMissing)
import System.FilePath ((</>), takeDirectory)
import System.IO.Error (tryIOError)
import System.IO.UTF8 (readUTF8File, writeUTF8File)
import Language.PureScript.Crash
import Language.PureScript.AST
import Language.PureScript.Externs
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.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, Read, 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, Externs)
, codegen :: CF.Module CF.Ann -> Environment -> Externs -> SupplyT m ()
, progress :: ProgressMessage -> m ()
}
type Externs = String
data RebuildPolicy
= RebuildNever
| RebuildAlways deriving (Show, Read, Eq, Ord)
make :: forall m. (Functor m, Applicative m, Monad m, MonadBaseControl IO m, MonadReader Options m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
=> MakeActions m
-> [Module]
-> m Environment
make MakeActions{..} ms = do
checkModuleNamesAreUnique
(sorted, graph) <- sortModules ms
barriers <- zip (map getModuleName sorted) <$> replicateM (length ms) ((,) <$> C.newEmptyMVar <*> C.newEmptyMVar)
for_ sorted $ \m -> fork $ do
let deps = fromMaybe (internalError "make: module not found in dependency graph.") (lookup (getModuleName m) graph)
buildModule barriers (importPrim m) (deps `inOrderOf` map getModuleName sorted)
errors <- catMaybes <$> for barriers (takeMVar . snd . snd)
unless (null errors) $ throwError (mconcat errors)
(_, externs) <- unzip . fromMaybe (internalError "make: externs were missing but no errors reported.") . sequence <$> for barriers (takeMVar . fst . snd)
return $ foldl' (flip applyExternsFileToEnvironment) initEnvironment externs
where
checkModuleNamesAreUnique :: m ()
checkModuleNamesAreUnique =
case findDuplicate (map getModuleName ms) of
Nothing -> return ()
Just mn -> throwError . errorMessage $ DuplicateModuleName mn
findDuplicate :: (Ord a) => [a] -> Maybe a
findDuplicate = go . sort
where
go (x : y : xs)
| x == y = Just x
| otherwise = go (y : xs)
go _ = Nothing
inOrderOf :: (Ord a) => [a] -> [a] -> [a]
inOrderOf xs ys = let s = S.fromList xs in filter (`S.member` s) ys
buildModule :: [(ModuleName, (C.MVar (Maybe (MultipleErrors, ExternsFile)), C.MVar (Maybe MultipleErrors)))] -> Module -> [ModuleName] -> m ()
buildModule barriers m@(Module _ _ moduleName _ _) deps = flip catchError (markComplete Nothing . Just) $ do
mexterns <- fmap unzip . sequence <$> traverse (readMVar . fst . fromMaybe (internalError "make: no barrier") . flip lookup barriers) deps
case mexterns of
Just (_, externs) -> do
outputTimestamp <- getOutputTimestamp moduleName
dependencyTimestamp <- maximumMaybe <$> traverse (fmap shouldExist . getOutputTimestamp) deps
inputTimestamp <- getInputTimestamp moduleName
let shouldRebuild = case (inputTimestamp, dependencyTimestamp, outputTimestamp) of
(Right (Just t1), Just t3, Just t2) -> t1 > t2 || t3 > t2
(Right (Just t1), Nothing, Just t2) -> t1 > t2
(Left RebuildNever, _, Just _) -> False
_ -> True
let rebuild = do
(exts, warnings) <- listen $ do
progress $ CompilingModule moduleName
let env = foldl' (flip applyExternsFileToEnvironment) initEnvironment externs
lint m
((checked@(Module ss coms _ elaborated exps), env'), nextVar) <- runSupplyT 0 $ do
[desugared] <- desugar externs [m]
runCheck' env $ typeCheckModule desugared
checkExhaustiveModule env' checked
regrouped <- createBindingGroups moduleName . collapseBindingGroups $ elaborated
let mod' = Module ss coms moduleName regrouped exps
corefn = CF.moduleToCoreFn env' mod'
[renamed] = renameInModules [corefn]
exts = moduleToExternsFile mod' env'
evalSupplyT nextVar . codegen renamed env' . BU8.toString . B.toStrict . encode $ exts
return exts
markComplete (Just (warnings, exts)) Nothing
if shouldRebuild
then rebuild
else do
mexts <- decodeExterns . snd <$> readExterns moduleName
case mexts of
Just exts -> markComplete (Just (mempty, exts)) Nothing
Nothing -> rebuild
Nothing -> markComplete Nothing Nothing
where
markComplete :: Maybe (MultipleErrors, ExternsFile) -> Maybe MultipleErrors -> m ()
markComplete externs errors = do
putMVar (fst $ fromMaybe (internalError "make: no barrier") $ lookup moduleName barriers) externs
putMVar (snd $ fromMaybe (internalError "make: no barrier") $ lookup moduleName barriers) errors
maximumMaybe :: (Ord a) => [a] -> Maybe a
maximumMaybe [] = Nothing
maximumMaybe xs = Just $ maximum xs
shouldExist :: Maybe UTCTime -> UTCTime
shouldExist (Just t) = t
shouldExist _ = internalError "make: dependency should already have been built."
decodeExterns :: Externs -> Maybe ExternsFile
decodeExterns bs = do
externs <- decode (fromString bs)
guard $ efVersion externs == showVersion Paths.version
return externs
importPrim :: Module -> Module
importPrim = addDefaultImport (ModuleName [ProperName C.prim])
newtype Make a = Make { unMake :: ReaderT Options (ExceptT MultipleErrors (Logger MultipleErrors)) a }
deriving (Functor, Applicative, Monad, MonadIO, MonadError MultipleErrors, MonadWriter MultipleErrors, MonadReader Options)
instance MonadBase IO Make where
liftBase = liftIO
instance MonadBaseControl IO Make where
type StM Make a = Either MultipleErrors a
liftBaseWith f = Make $ liftBaseWith $ \q -> f (q . unMake)
restoreM = Make . restoreM
runMake :: Options -> Make a -> IO (Either MultipleErrors a, MultipleErrors)
runMake opts = runLogger' . runExceptT . 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 (internalError "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.json"
min <$> getTimestamp jsFile <*> getTimestamp externsFile
readExterns :: ModuleName -> Make (FilePath, Externs)
readExterns mn = do
let path = outputDir </> runModuleName mn </> "externs.json"
(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.json"
foreignFile = outputDir </> filePath </> "foreign.js"
prefix = ["Generated by psc version " ++ showVersion Paths.version | usePrefix]
js = unlines $ map ("// " ++) prefix ++ [pjs]
lift $ do
writeTextFile jsFile (fromString 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 (ErrorMessage [] $ CannotGetFileInfo path)) $ do
exists <- doesFileExist path
traverse (const $ getModificationTime path) $ guard exists
readTextFile :: FilePath -> Make String
readTextFile path = makeIO (const (ErrorMessage [] $ CannotReadFile path)) $ readUTF8File path
writeTextFile :: FilePath -> String -> Make ()
writeTextFile path text = makeIO (const (ErrorMessage [] $ CannotWriteFile path)) $ do
mkdirp path
writeUTF8File path text
where
mkdirp :: FilePath -> IO ()
mkdirp = createDirectoryIfMissing True . takeDirectory
progress :: ProgressMessage -> Make ()
progress = liftIO . putStrLn . renderProgressMessage