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