git.iko.soy/rowtype-yoga/purescript-native
on a628008 help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/Make.hs
469 lines 19 kB history raw
1{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2{-# LANGUAGE TypeFamilies #-}
4module Language.PureScript.Make
5 (
6 -- * Make API
7 RebuildPolicy(..)
8 , ProgressMessage(..), renderProgressMessage
9 , MakeActions(..)
10 , Externs()
11 , rebuildModule
12 , make
14 -- * Implementation of Make API using files on disk
15 , Make(..)
16 , runMake
17 , makeIO
18 , readTextFile
19 , buildMakeActions
20 , inferForeignModules
21 ) where
23import Prelude.Compat
25import Control.Concurrent.Lifted as C
26import Control.Monad hiding (sequence)
27import Control.Monad.Base (MonadBase(..))
28import Control.Monad.Error.Class (MonadError(..))
29import Control.Monad.IO.Class
30import Control.Monad.Logger
31import Control.Monad.Reader (MonadReader(..), ReaderT(..), asks)
32import Control.Monad.Supply
33import Control.Monad.Trans.Class (MonadTrans(..))
34import Control.Monad.Trans.Control (MonadBaseControl(..))
35import Control.Monad.Trans.Except
36import Control.Monad.Writer.Class (MonadWriter(..))
38import Data.Aeson (encode, decode)
39import Data.Either (partitionEithers)
40import Data.Foldable (for_)
41import Data.List (foldl', sort)
42import Data.Maybe (fromMaybe, catMaybes)
43import Data.String (fromString)
44import Data.Time.Clock
45import Data.Traversable (for)
46import Data.Version (showVersion)
47import qualified Data.ByteString.Lazy as B
48import qualified Data.ByteString.UTF8 as BU8
49import qualified Data.Map as M
50import qualified Data.Set as S
52import Language.PureScript.AST
53import Language.PureScript.Crash
54import Language.PureScript.Environment
55import Language.PureScript.Errors
56import Language.PureScript.Externs
57import Language.PureScript.Linter
58import Language.PureScript.ModuleDependencies
59import Language.PureScript.Names
60import Language.PureScript.Options
61import Language.PureScript.Pretty
62import Language.PureScript.Pretty.Common(SMap(..))
63import Language.PureScript.Renamer
64import Language.PureScript.Sugar
65import Language.PureScript.TypeChecker
66import qualified Language.JavaScript.Parser as JS
67import qualified Language.PureScript.Bundle as Bundle
68import qualified Language.PureScript.CodeGen.JS as J
69import qualified Language.PureScript.Constants as C
70import qualified Language.PureScript.CoreFn as CF
71import qualified Language.PureScript.Parser as PSParser
73import qualified Paths_purescript as Paths
75import SourceMap
76import SourceMap.Types
78import System.Directory (doesFileExist, getModificationTime, createDirectoryIfMissing, getCurrentDirectory)
79import System.FilePath ((</>), takeDirectory, makeRelative, splitPath, normalise, replaceExtension)
80import System.IO.Error (tryIOError)
81import System.IO.UTF8 (readUTF8File, writeUTF8File)
83import qualified Text.Parsec as Parsec
85-- | Progress messages from the make process
86data ProgressMessage
87 = CompilingModule ModuleName
88 deriving (Show, Read, Eq, Ord)
90-- | Render a progress message
91renderProgressMessage :: ProgressMessage -> String
92renderProgressMessage (CompilingModule mn) = "Compiling " ++ runModuleName mn
94-- | Actions that require implementations when running in "make" mode.
95--
96-- This type exists to make two things abstract:
97--
98-- * The particular backend being used (Javascript, C++11, etc.)
99--
100-- * The details of how files are read/written etc.
101--
102data MakeActions m = MakeActions
103 { getInputTimestamp :: ModuleName -> m (Either RebuildPolicy (Maybe UTCTime))
104 -- ^ Get the timestamp for the input file(s) for a module. If there are multiple
105 -- files (@.purs@ and foreign files, for example) the timestamp should be for
106 -- the most recently modified file.
107 , getOutputTimestamp :: ModuleName -> m (Maybe UTCTime)
108 -- ^ Get the timestamp for the output files for a module. This should be the
109 -- timestamp for the oldest modified file, or 'Nothing' if any of the required
110 -- output files are missing.
111 , readExterns :: ModuleName -> m (FilePath, Externs)
112 -- ^ Read the externs file for a module as a string and also return the actual
113 -- path for the file.
114 , codegen :: CF.Module CF.Ann -> Environment -> Externs -> SupplyT m ()
115 -- ^ Run the code generator for the module and write any required output files.
116 , progress :: ProgressMessage -> m ()
117 -- ^ Respond to a progress update.
118 }
120-- |
121-- Generated code for an externs file.
122--
123type Externs = String
125-- |
126-- Determines when to rebuild a module
127--
128data RebuildPolicy
129 -- | Never rebuild this module
130 = RebuildNever
131 -- | Always rebuild this module
132 | RebuildAlways deriving (Show, Read, Eq, Ord)
134-- | Rebuild a single module
135rebuildModule :: forall m. (Monad m, MonadBaseControl IO m, MonadReader Options m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
136 => MakeActions m
137 -> [ExternsFile]
138 -> Module
139 -> m ExternsFile
140rebuildModule MakeActions{..} externs m@(Module _ _ moduleName _ _) = do
141 progress $ CompilingModule moduleName
142 let env = foldl' (flip applyExternsFileToEnvironment) initEnvironment externs
143 withPrim = importPrim m
144 lint withPrim
145 ((Module ss coms _ elaborated exps, env'), nextVar) <- runSupplyT 0 $ do
146 [desugared] <- desugar externs [withPrim]
147 runCheck' env $ typeCheckModule desugared
148 regrouped <- createBindingGroups moduleName . collapseBindingGroups $ elaborated
149 let mod' = Module ss coms moduleName regrouped exps
150 corefn = CF.moduleToCoreFn env' mod'
151 [renamed] = renameInModules [corefn]
152 exts = moduleToExternsFile mod' env'
153 evalSupplyT nextVar . codegen renamed env' . BU8.toString . B.toStrict . encode $ exts
154 return exts
156-- |
157-- Compiles in "make" mode, compiling each module separately to a js files and an externs file
158--
159-- If timestamps have not changed, the externs file can be used to provide the module's types without
160-- having to typecheck the module again.
161--
162make :: forall m. (Monad m, MonadBaseControl IO m, MonadReader Options m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
163 => MakeActions m
164 -> [Module]
165 -> m [ExternsFile]
166make ma@MakeActions{..} ms = do
167 checkModuleNamesAreUnique
169 (sorted, graph) <- sortModules ms
171 barriers <- zip (map getModuleName sorted) <$> replicateM (length ms) ((,) <$> C.newEmptyMVar <*> C.newEmptyMVar)
173 for_ sorted $ \m -> fork $ do
174 let deps = fromMaybe (internalError "make: module not found in dependency graph.") (lookup (getModuleName m) graph)
175 buildModule barriers (importPrim m) (deps `inOrderOf` map getModuleName sorted)
177 -- Wait for all threads to complete, and collect errors.
178 errors <- catMaybes <$> for barriers (takeMVar . snd . snd)
180 -- All threads have completed, rethrow any caught errors.
181 unless (null errors) $ throwError (mconcat errors)
183 -- Bundle up all the externs and return them as an Environment
184 (_, externs) <- unzip . fromMaybe (internalError "make: externs were missing but no errors reported.") . sequence <$> for barriers (takeMVar . fst . snd)
185 return externs
187 where
188 checkModuleNamesAreUnique :: m ()
189 checkModuleNamesAreUnique =
190 case findDuplicate (map getModuleName ms) of
191 Nothing -> return ()
192 Just mn -> throwError . errorMessage $ DuplicateModuleName mn
194 -- Verify that a list of values has unique keys
195 findDuplicate :: (Ord a) => [a] -> Maybe a
196 findDuplicate = go . sort
197 where
198 go (x : y : xs)
199 | x == y = Just x
200 | otherwise = go (y : xs)
201 go _ = Nothing
203 -- Sort a list so its elements appear in the same order as in another list.
204 inOrderOf :: (Ord a) => [a] -> [a] -> [a]
205 inOrderOf xs ys = let s = S.fromList xs in filter (`S.member` s) ys
207 buildModule :: [(ModuleName, (C.MVar (Maybe (MultipleErrors, ExternsFile)), C.MVar (Maybe MultipleErrors)))] -> Module -> [ModuleName] -> m ()
208 buildModule barriers m@(Module _ _ moduleName _ _) deps = flip catchError (markComplete Nothing . Just) $ do
209 -- We need to wait for dependencies to be built, before checking if the current
210 -- module should be rebuilt, so the first thing to do is to wait on the
211 -- MVars for the module's dependencies.
212 mexterns <- fmap unzip . sequence <$> traverse (readMVar . fst . fromMaybe (internalError "make: no barrier") . flip lookup barriers) deps
214 case mexterns of
215 Just (_, externs) -> do
216 outputTimestamp <- getOutputTimestamp moduleName
217 dependencyTimestamp <- maximumMaybe <$> traverse (fmap shouldExist . getOutputTimestamp) deps
218 inputTimestamp <- getInputTimestamp moduleName
220 let shouldRebuild = case (inputTimestamp, dependencyTimestamp, outputTimestamp) of
221 (Right (Just t1), Just t3, Just t2) -> t1 > t2 || t3 > t2
222 (Right (Just t1), Nothing, Just t2) -> t1 > t2
223 (Left RebuildNever, _, Just _) -> False
224 _ -> True
226 let rebuild = do
227 (exts, warnings) <- listen $ rebuildModule ma externs m
228 markComplete (Just (warnings, exts)) Nothing
230 if shouldRebuild
231 then rebuild
232 else do
233 mexts <- decodeExterns . snd <$> readExterns moduleName
234 case mexts of
235 Just exts -> markComplete (Just (mempty, exts)) Nothing
236 Nothing -> rebuild
237 Nothing -> markComplete Nothing Nothing
238 where
239 markComplete :: Maybe (MultipleErrors, ExternsFile) -> Maybe MultipleErrors -> m ()
240 markComplete externs errors = do
241 putMVar (fst $ fromMaybe (internalError "make: no barrier") $ lookup moduleName barriers) externs
242 putMVar (snd $ fromMaybe (internalError "make: no barrier") $ lookup moduleName barriers) errors
244 maximumMaybe :: (Ord a) => [a] -> Maybe a
245 maximumMaybe [] = Nothing
246 maximumMaybe xs = Just $ maximum xs
248 -- Make sure a dependency exists
249 shouldExist :: Maybe UTCTime -> UTCTime
250 shouldExist (Just t) = t
251 shouldExist _ = internalError "make: dependency should already have been built."
253 decodeExterns :: Externs -> Maybe ExternsFile
254 decodeExterns bs = do
255 externs <- decode (fromString bs)
256 guard $ efVersion externs == showVersion Paths.version
257 return externs
259importPrim :: Module -> Module
260importPrim = addDefaultImport (ModuleName [ProperName C.prim])
262-- |
263-- A monad for running make actions
264--
265newtype Make a = Make { unMake :: ReaderT Options (ExceptT MultipleErrors (Logger MultipleErrors)) a }
266 deriving (Functor, Applicative, Monad, MonadIO, MonadError MultipleErrors, MonadWriter MultipleErrors, MonadReader Options)
268instance MonadBase IO Make where
269 liftBase = liftIO
271instance MonadBaseControl IO Make where
272 type StM Make a = Either MultipleErrors a
273 liftBaseWith f = Make $ liftBaseWith $ \q -> f (q . unMake)
274 restoreM = Make . restoreM
276-- |
277-- Execute a 'Make' monad, returning either errors, or the result of the compile plus any warnings.
278--
279runMake :: Options -> Make a -> IO (Either MultipleErrors a, MultipleErrors)
280runMake opts = runLogger' . runExceptT . flip runReaderT opts . unMake
282makeIO :: (IOError -> ErrorMessage) -> IO a -> Make a
283makeIO f io = do
284 e <- liftIO $ tryIOError io
285 either (throwError . singleError . f) return e
287-- | Read a text file in the 'Make' monad, capturing any errors using the
288-- 'MonadError' instance.
289readTextFile :: FilePath -> Make String
290readTextFile path = makeIO (const (ErrorMessage [] $ CannotReadFile path)) $ readUTF8File path
292-- | Infer the module name for a module by looking for the same filename with
293-- a .js extension.
294inferForeignModules
295 :: forall m
296 . MonadIO m
297 => M.Map ModuleName (Either RebuildPolicy FilePath)
298 -> m (M.Map ModuleName FilePath)
299inferForeignModules = fmap (M.mapMaybe id) . traverse inferForeignModule
300 where
301 inferForeignModule :: Either RebuildPolicy FilePath -> m (Maybe FilePath)
302 inferForeignModule (Left _) = return Nothing
303 inferForeignModule (Right path) = do
304 let jsFile = replaceExtension path "js"
305 exists <- liftIO $ doesFileExist jsFile
306 if exists
307 then return (Just jsFile)
308 else return Nothing
310-- |
311-- A set of make actions that read and write modules from the given directory.
312--
313buildMakeActions :: FilePath -- ^ the output directory
314 -> M.Map ModuleName (Either RebuildPolicy FilePath) -- ^ a map between module names and paths to the file containing the PureScript module
315 -> M.Map ModuleName FilePath -- ^ a map between module name and the file containing the foreign javascript for the module
316 -> Bool -- ^ Generate a prefix comment?
317 -> MakeActions Make
318buildMakeActions outputDir filePathMap foreigns usePrefix =
319 MakeActions getInputTimestamp getOutputTimestamp readExterns codegen progress
320 where
322 getInputTimestamp :: ModuleName -> Make (Either RebuildPolicy (Maybe UTCTime))
323 getInputTimestamp mn = do
324 let path = fromMaybe (internalError "Module has no filename in 'make'") $ M.lookup mn filePathMap
325 e1 <- traverse getTimestamp path
326 fPath <- maybe (return Nothing) getTimestamp $ M.lookup mn foreigns
327 return $ fmap (max fPath) e1
329 getOutputTimestamp :: ModuleName -> Make (Maybe UTCTime)
330 getOutputTimestamp mn = do
331 let filePath = runModuleName mn
332 jsFile = outputDir </> filePath </> "index.js"
333 externsFile = outputDir </> filePath </> "externs.json"
334 min <$> getTimestamp jsFile <*> getTimestamp externsFile
336 readExterns :: ModuleName -> Make (FilePath, Externs)
337 readExterns mn = do
338 let path = outputDir </> runModuleName mn </> "externs.json"
339 (path, ) <$> readTextFile path
341 codegen :: CF.Module CF.Ann -> Environment -> Externs -> SupplyT Make ()
342 codegen m _ exts = do
343 let mn = CF.moduleName m
344 foreignInclude <- case mn `M.lookup` foreigns of
345 Just path
346 | not $ requiresForeign m -> do
347 tell $ errorMessage $ UnnecessaryFFIModule mn path
348 return Nothing
349 | otherwise -> do
350 checkForeignDecls m path
351 return $ Just $ J.JSApp Nothing (J.JSVar Nothing "require") [J.JSStringLiteral Nothing "./foreign"]
352 Nothing | requiresForeign m -> throwError . errorMessage $ MissingFFIModule mn
353 | otherwise -> return Nothing
354 rawJs <- J.moduleToJs m foreignInclude
355 dir <- lift $ makeIO (const (ErrorMessage [] $ CannotGetFileInfo ".")) getCurrentDirectory
356 sourceMaps <- lift $ asks optionsSourceMaps
357 let (pjs, mappings) = if sourceMaps then prettyPrintJSWithSourceMaps rawJs else (prettyPrintJS rawJs, [])
358 let filePath = runModuleName mn
359 jsFile = outputDir </> filePath </> "index.js"
360 mapFile = outputDir </> filePath </> "index.js.map"
361 externsFile = outputDir </> filePath </> "externs.json"
362 foreignFile = outputDir </> filePath </> "foreign.js"
363 prefix = ["Generated by psc version " ++ showVersion Paths.version | usePrefix]
364 js = unlines $ map ("// " ++) prefix ++ [pjs]
365 mapRef = if sourceMaps then "//# sourceMappingURL=index.js.map\n" else ""
366 lift $ do
367 writeTextFile jsFile (fromString $ js ++ mapRef)
368 for_ (mn `M.lookup` foreigns) (readTextFile >=> writeTextFile foreignFile)
369 writeTextFile externsFile exts
370 lift $ when sourceMaps $ genSourceMap dir mapFile (length prefix) mappings
372 genSourceMap :: String -> String -> Int -> [SMap] -> Make ()
373 genSourceMap dir mapFile extraLines mappings = do
374 let pathToDir = iterate (".." </>) ".." !! length (splitPath $ normalise outputDir)
375 sourceFile = case mappings of
376 (SMap file _ _ : _) -> Just $ pathToDir </> makeRelative dir file
377 _ -> Nothing
378 let rawMapping = SourceMapping { smFile = "index.js", smSourceRoot = Nothing, smMappings =
379 map (\(SMap _ orig gen) -> Mapping {
380 mapOriginal = Just $ convertPos $ add 0 (-1) orig
381 , mapSourceFile = sourceFile
382 , mapGenerated = convertPos $ add (extraLines+1) 0 gen
383 , mapName = Nothing
384 }) mappings
385 }
386 let mapping = generate rawMapping
387 writeTextFile mapFile $ BU8.toString . B.toStrict . encode $ mapping
388 where
389 add :: Int -> Int -> SourcePos -> SourcePos
390 add n m (SourcePos n' m') = SourcePos (n+n') (m+m')
392 convertPos :: SourcePos -> Pos
393 convertPos SourcePos { sourcePosLine = l, sourcePosColumn = c } =
394 Pos { posLine = fromIntegral l, posColumn = fromIntegral c }
396 requiresForeign :: CF.Module a -> Bool
397 requiresForeign = not . null . CF.moduleForeign
399 getTimestamp :: FilePath -> Make (Maybe UTCTime)
400 getTimestamp path = makeIO (const (ErrorMessage [] $ CannotGetFileInfo path)) $ do
401 exists <- doesFileExist path
402 traverse (const $ getModificationTime path) $ guard exists
404 writeTextFile :: FilePath -> String -> Make ()
405 writeTextFile path text = makeIO (const (ErrorMessage [] $ CannotWriteFile path)) $ do
406 mkdirp path
407 writeUTF8File path text
408 where
409 mkdirp :: FilePath -> IO ()
410 mkdirp = createDirectoryIfMissing True . takeDirectory
412 progress :: ProgressMessage -> Make ()
413 progress = liftIO . putStrLn . renderProgressMessage
415-- |
416-- Check that the declarations in a given PureScript module match with those
417-- in its corresponding foreign module.
418--
419checkForeignDecls :: CF.Module ann -> FilePath -> SupplyT Make ()
420checkForeignDecls m path = do
421 jsStr <- lift $ readTextFile path
422 js <- either (errorParsingModule . Bundle.UnableToParseModule) pure $ JS.parse jsStr path
424 foreignIdentsStrs <- either errorParsingModule pure $ getExps js
425 foreignIdents <- either
426 errorInvalidForeignIdentifiers
427 (pure . S.fromList)
428 (parseIdents foreignIdentsStrs)
429 let importedIdents = S.fromList $ map fst (CF.moduleForeign m)
431 let unusedFFI = foreignIdents S.\\ importedIdents
432 unless (null unusedFFI) $
433 tell . errorMessage . UnusedFFIImplementations mname $
434 S.toList unusedFFI
436 let missingFFI = importedIdents S.\\ foreignIdents
437 unless (null missingFFI) $
438 throwError . errorMessage . MissingFFIImplementations mname $
439 S.toList missingFFI
441 where
442 mname = CF.moduleName m
444 errorParsingModule :: Bundle.ErrorMessage -> SupplyT Make a
445 errorParsingModule = throwError . errorMessage . ErrorParsingFFIModule path . Just
447 getExps :: JS.JSAST -> Either Bundle.ErrorMessage [String]
448 getExps = Bundle.getExportedIdentifiers (runModuleName mname)
450 errorInvalidForeignIdentifiers :: [String] -> SupplyT Make a
451 errorInvalidForeignIdentifiers =
452 throwError . mconcat . map (errorMessage . InvalidFFIIdentifier mname)
454 parseIdents :: [String] -> Either [String] [Ident]
455 parseIdents strs =
456 case partitionEithers (map parseIdent strs) of
457 ([], idents) ->
458 Right idents
459 (errs, _) ->
460 Left errs
462 -- We ignore the error message here, just being told it's an invalid
463 -- identifier should be enough.
464 parseIdent :: String -> Either String Ident
465 parseIdent str = try str
466 where
467 try s = either (const (Left str)) Right $ do
468 ts <- PSParser.lex "" s
469 PSParser.runTokenParser "" (PSParser.parseIdent <* Parsec.eof) ts