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