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