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