module Language.PureScript.Make
(
RebuildPolicy(..)
, ProgressMessage(..), renderProgressMessage
, MakeActions(..)
, Externs()
, rebuildModule
, make
, Make(..)
, runMake
, makeIO
, readTextFile
, buildMakeActions
, inferForeignModules
) where
import Prelude.Compat
import Control.Concurrent.Lifted as C
import Control.Monad hiding (sequence)
import Control.Monad.Base (MonadBase(..))
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.IO.Class
import Control.Monad.Logger
import Control.Monad.Reader (MonadReader(..), ReaderT(..), asks)
import Control.Monad.Supply
import Control.Monad.Trans.Class (MonadTrans(..))
import Control.Monad.Trans.Control (MonadBaseControl(..))
import Control.Monad.Trans.Except
import Control.Monad.Writer.Class (MonadWriter(..))
import Data.Aeson (encode, decode)
import qualified Data.Aeson as Aeson
import Data.Either (partitionEithers)
import Data.Function (on)
import Data.Foldable (for_)
import Data.List (foldl', sortBy, groupBy)
import Data.Maybe (fromMaybe, catMaybes)
import Data.Monoid ((<>))
import Data.Time.Clock
import Data.Traversable (for)
import Data.Version (showVersion)
import qualified Data.ByteString.Lazy as B
import qualified Data.ByteString.UTF8 as BU8
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Language.PureScript.AST
import Language.PureScript.Crash
import Language.PureScript.Environment
import Language.PureScript.Errors
import Language.PureScript.Externs
import Language.PureScript.Linter
import Language.PureScript.ModuleDependencies
import Language.PureScript.Names
import Language.PureScript.Options
import Language.PureScript.Pretty.Common (SMap(..))
import Language.PureScript.Renamer
import Language.PureScript.Sugar
import Language.PureScript.TypeChecker
import qualified Language.JavaScript.Parser as JS
import qualified Language.PureScript.Bundle as Bundle
import qualified Language.PureScript.CodeGen.JS as J
import Language.PureScript.CodeGen.JS.Printer
import qualified Language.PureScript.Constants as C
import qualified Language.PureScript.CoreFn as CF
import qualified Language.PureScript.CoreFn.ToJSON as CFJ
import qualified Language.PureScript.CoreImp.AST as Imp
import qualified Language.PureScript.Parser as PSParser
import qualified Paths_purescript as Paths
import SourceMap
import SourceMap.Types
import System.Directory (doesFileExist, getModificationTime, createDirectoryIfMissing, getCurrentDirectory)
import System.FilePath ((</>), takeDirectory, makeRelative, splitPath, normalise, replaceExtension)
import System.IO.Error (tryIOError)
import qualified Text.Parsec as Parsec
data ProgressMessage
= CompilingModule ModuleName
deriving (Show, Eq, Ord)
renderProgressMessage :: ProgressMessage -> String
renderProgressMessage (CompilingModule mn) = "Compiling " ++ T.unpack (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 = B.ByteString
data RebuildPolicy
= RebuildNever
| RebuildAlways deriving (Show, Eq, Ord)
rebuildModule
:: forall m
. (Monad m, MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
=> MakeActions m
-> [ExternsFile]
-> Module
-> m ExternsFile
rebuildModule MakeActions{..} externs m@(Module _ _ moduleName _ _) = do
progress $ CompilingModule moduleName
let env = foldl' (flip applyExternsFileToEnvironment) initEnvironment externs
withPrim = importPrim m
lint withPrim
((Module ss coms _ elaborated exps, env'), nextVar) <- runSupplyT 0 $ do
[desugared] <- desugar externs [withPrim]
runCheck' (emptyCheckState env) $ typeCheckModule desugared
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' . encode $ exts
return exts
make :: forall m. (Monad m, MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
=> MakeActions m
-> [Module]
-> m [ExternsFile]
make ma@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 externs
where
checkModuleNamesAreUnique :: m ()
checkModuleNamesAreUnique =
for_ (findDuplicates getModuleName ms) $ \mss ->
throwError . flip foldMap mss $ \ms' ->
let mn = getModuleName (head ms')
in errorMessage $ DuplicateModule mn (map getModuleSourceSpan ms')
findDuplicates :: Ord b => (a -> b) -> [a] -> Maybe [[a]]
findDuplicates f xs =
case filter ((> 1) . length) . groupBy ((==) `on` f) . sortBy (compare `on` f) $ xs of
[] -> Nothing
xss -> Just xss
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 $ rebuildModule ma externs m
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 bs
guard $ T.unpack (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
readTextFile :: FilePath -> Make B.ByteString
readTextFile path = makeIO (const (ErrorMessage [] $ CannotReadFile path)) $ B.readFile path
inferForeignModules
:: forall m
. MonadIO m
=> M.Map ModuleName (Either RebuildPolicy FilePath)
-> m (M.Map ModuleName FilePath)
inferForeignModules =
fmap (M.mapMaybe id) . traverse inferForeignModule
where
inferForeignModule :: Either RebuildPolicy FilePath -> m (Maybe FilePath)
inferForeignModule (Left _) = return Nothing
inferForeignModule (Right path) = do
let jsFile = replaceExtension path "js"
exists <- liftIO $ doesFileExist jsFile
if exists
then return (Just jsFile)
else return Nothing
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 <- traverse getTimestamp path
fPath <- maybe (return Nothing) getTimestamp $ M.lookup mn foreigns
return $ fmap (max fPath) e1
getOutputTimestamp :: ModuleName -> Make (Maybe UTCTime)
getOutputTimestamp mn = do
dumpCoreFn <- asks optionsDumpCoreFn
let filePath = T.unpack (runModuleName mn)
jsFile = outputDir </> filePath </> "index.js"
externsFile = outputDir </> filePath </> "externs.json"
coreFnFile = outputDir </> filePath </> "corefn.json"
min3 js exts coreFn
| dumpCoreFn = min (min js exts) coreFn
| otherwise = min js exts
min3 <$> getTimestamp jsFile <*> getTimestamp externsFile <*> getTimestamp coreFnFile
readExterns :: ModuleName -> Make (FilePath, Externs)
readExterns mn = do
let path = outputDir </> T.unpack (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 -> do
checkForeignDecls m path
return $ Just $ Imp.App Nothing (Imp.Var Nothing "require") [Imp.StringLiteral Nothing "./foreign"]
Nothing | requiresForeign m -> throwError . errorMessage $ MissingFFIModule mn
| otherwise -> return Nothing
rawJs <- J.moduleToJs m foreignInclude
dir <- lift $ makeIO (const (ErrorMessage [] $ CannotGetFileInfo ".")) getCurrentDirectory
sourceMaps <- lift $ asks optionsSourceMaps
let (pjs, mappings) = if sourceMaps then prettyPrintJSWithSourceMaps rawJs else (prettyPrintJS rawJs, [])
let filePath = T.unpack (runModuleName mn)
jsFile = outputDir </> filePath </> "index.js"
mapFile = outputDir </> filePath </> "index.js.map"
externsFile = outputDir </> filePath </> "externs.json"
foreignFile = outputDir </> filePath </> "foreign.js"
prefix = ["Generated by purs version " <> T.pack (showVersion Paths.version) | usePrefix]
js = T.unlines $ map ("// " <>) prefix ++ [pjs]
mapRef = if sourceMaps then "//# sourceMappingURL=index.js.map\n" else ""
lift $ do
writeTextFile jsFile (B.fromStrict $ TE.encodeUtf8 $ js <> mapRef)
for_ (mn `M.lookup` foreigns) (readTextFile >=> writeTextFile foreignFile)
writeTextFile externsFile exts
lift $ when sourceMaps $ genSourceMap dir mapFile (length prefix) mappings
dumpCoreFn <- lift $ asks optionsDumpCoreFn
when dumpCoreFn $ do
let coreFnFile = outputDir </> filePath </> "corefn.json"
let jsonPayload = CFJ.moduleToJSON Paths.version m
let json = Aeson.object [ (runModuleName mn, jsonPayload) ]
lift $ writeTextFile coreFnFile (encode json)
genSourceMap :: String -> String -> Int -> [SMap] -> Make ()
genSourceMap dir mapFile extraLines mappings = do
let pathToDir = iterate (".." </>) ".." !! length (splitPath $ normalise outputDir)
sourceFile = case mappings of
(SMap file _ _ : _) -> Just $ pathToDir </> makeRelative dir (T.unpack file)
_ -> Nothing
let rawMapping = SourceMapping { smFile = "index.js", smSourceRoot = Nothing, smMappings =
map (\(SMap _ orig gen) -> Mapping {
mapOriginal = Just $ convertPos $ add 0 (1) orig
, mapSourceFile = sourceFile
, mapGenerated = convertPos $ add (extraLines+1) 0 gen
, mapName = Nothing
}) mappings
}
let mapping = generate rawMapping
writeTextFile mapFile (encode mapping)
where
add :: Int -> Int -> SourcePos -> SourcePos
add n m (SourcePos n' m') = SourcePos (n+n') (m+m')
convertPos :: SourcePos -> Pos
convertPos SourcePos { sourcePosLine = l, sourcePosColumn = c } =
Pos { posLine = fromIntegral l, posColumn = fromIntegral c }
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
writeTextFile :: FilePath -> B.ByteString -> Make ()
writeTextFile path text = makeIO (const (ErrorMessage [] $ CannotWriteFile path)) $ do
mkdirp path
B.writeFile path text
where
mkdirp :: FilePath -> IO ()
mkdirp = createDirectoryIfMissing True . takeDirectory
progress :: ProgressMessage -> Make ()
progress = liftIO . putStrLn . renderProgressMessage
checkForeignDecls :: CF.Module ann -> FilePath -> SupplyT Make ()
checkForeignDecls m path = do
jsStr <- lift $ readTextFile path
js <- either (errorParsingModule . Bundle.UnableToParseModule) pure $ JS.parse (BU8.toString (B.toStrict jsStr)) path
foreignIdentsStrs <- either errorParsingModule pure $ getExps js
foreignIdents <- either
errorInvalidForeignIdentifiers
(pure . S.fromList)
(parseIdents foreignIdentsStrs)
let importedIdents = S.fromList $ map fst (CF.moduleForeign m)
let unusedFFI = foreignIdents S.\\ importedIdents
unless (null unusedFFI) $
tell . errorMessage . UnusedFFIImplementations mname $
S.toList unusedFFI
let missingFFI = importedIdents S.\\ foreignIdents
unless (null missingFFI) $
throwError . errorMessage . MissingFFIImplementations mname $
S.toList missingFFI
where
mname = CF.moduleName m
errorParsingModule :: Bundle.ErrorMessage -> SupplyT Make a
errorParsingModule = throwError . errorMessage . ErrorParsingFFIModule path . Just
getExps :: JS.JSAST -> Either Bundle.ErrorMessage [String]
getExps = Bundle.getExportedIdentifiers (T.unpack (runModuleName mname))
errorInvalidForeignIdentifiers :: [String] -> SupplyT Make a
errorInvalidForeignIdentifiers =
throwError . mconcat . map (errorMessage . InvalidFFIIdentifier mname . T.pack)
parseIdents :: [String] -> Either [String] [Ident]
parseIdents strs =
case partitionEithers (map parseIdent strs) of
([], idents) ->
Right idents
(errs, _) ->
Left errs
parseIdent :: String -> Either String Ident
parseIdent str = try (T.pack str)
where
try s = either (const (Left str)) Right $ do
ts <- PSParser.lex "" s
PSParser.runTokenParser "" (PSParser.parseIdent <* Parsec.eof) ts