git.iko.soy/rowtype-yoga/purescript-native
on 51ccb1d help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/Make.hs
464 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 ) 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-- Traverse (Either e) instance (base 4.7)
301traverseEither :: Applicative f => (a -> f b) -> Either e a -> f (Either e b)
302traverseEither _ (Left x) = pure (Left x)
303traverseEither f (Right y) = Right <$> f y
305-- |
306-- A set of make actions that read and write modules from the given directory.
307--
308buildMakeActions :: FilePath -- ^ the output directory
309 -> M.Map ModuleName (Either RebuildPolicy FilePath) -- ^ a map between module names and paths to the file containing the PureScript module
310 -> M.Map ModuleName FilePath -- ^ a map between module name and the file containing the foreign javascript for the module
311 -> Bool -- ^ Generate a prefix comment?
312 -> MakeActions Make
313buildMakeActions outputDir filePathMap foreigns usePrefix =
314 MakeActions getInputTimestamp getOutputTimestamp readExterns codegen progress
315 where
317 getInputTimestamp :: ModuleName -> Make (Either RebuildPolicy (Maybe UTCTime))
318 getInputTimestamp mn = do
319 let path = fromMaybe (internalError "Module has no filename in 'make'") $ M.lookup mn filePathMap
320 e1 <- traverseEither getTimestamp path
321 fPath <- maybe (return Nothing) getTimestamp $ M.lookup mn foreigns
322 return $ fmap (max fPath) e1
324 getOutputTimestamp :: ModuleName -> Make (Maybe UTCTime)
325 getOutputTimestamp mn = do
326 let filePath = runModuleName mn
327 jsFile = outputDir </> filePath </> "index.js"
328 externsFile = outputDir </> filePath </> "externs.json"
329 min <$> getTimestamp jsFile <*> getTimestamp externsFile
331 readExterns :: ModuleName -> Make (FilePath, Externs)
332 readExterns mn = do
333 let path = outputDir </> runModuleName mn </> "externs.json"
334 (path, ) <$> readTextFile path
336 codegen :: CF.Module CF.Ann -> Environment -> Externs -> SupplyT Make ()
337 codegen m _ exts = do
338 let mn = CF.moduleName m
339 foreignInclude <- case mn `M.lookup` foreigns of
340 Just path
341 | not $ requiresForeign m -> do
342 tell $ errorMessage $ UnnecessaryFFIModule mn path
343 return Nothing
344 | otherwise -> do
345 checkForeignDecls m path
346 return $ Just $ J.JSApp Nothing (J.JSVar Nothing "require") [J.JSStringLiteral Nothing "./foreign"]
347 Nothing | requiresForeign m -> throwError . errorMessage $ MissingFFIModule mn
348 | otherwise -> return Nothing
349 rawJs <- J.moduleToJs m foreignInclude
350 dir <- lift $ makeIO (const (ErrorMessage [] $ CannotGetFileInfo ".")) getCurrentDirectory
351 sourceMaps <- lift $ asks optionsSourceMaps
352 let (pjs, mappings) = if sourceMaps then prettyPrintJSWithSourceMaps rawJs else (prettyPrintJS rawJs, [])
353 let filePath = runModuleName mn
354 jsFile = outputDir </> filePath </> "index.js"
355 mapFile = outputDir </> filePath </> "index.js.map"
356 externsFile = outputDir </> filePath </> "externs.json"
357 foreignFile = outputDir </> filePath </> "foreign.js"
358 prefix = ["Generated by psc version " ++ showVersion Paths.version | usePrefix]
359 js = unlines $ map ("// " ++) prefix ++ [pjs]
360 mapRef = if sourceMaps then "//# sourceMappingURL=index.js.map\n" else ""
361 lift $ do
362 writeTextFile jsFile (fromString $ js ++ mapRef)
363 for_ (mn `M.lookup` foreigns) (readTextFile >=> writeTextFile foreignFile)
364 writeTextFile externsFile exts
365 lift $ when sourceMaps $ genSourceMap dir mapFile (length prefix) mappings
367 genSourceMap :: String -> String -> Int -> [SMap] -> Make ()
368 genSourceMap dir mapFile extraLines mappings = do
369 let pathToDir = iterate (".." </>) ".." !! length (splitPath $ normalise outputDir)
370 sourceFile = case mappings of
371 (SMap file _ _ : _) -> Just $ pathToDir </> makeRelative dir file
372 _ -> Nothing
373 let rawMapping = SourceMapping { smFile = "index.js", smSourceRoot = Nothing, smMappings =
374 map (\(SMap _ orig gen) -> Mapping {
375 mapOriginal = Just $ convertPos $ add 0 (-1) orig
376 , mapSourceFile = sourceFile
377 , mapGenerated = convertPos $ add (extraLines+1) 0 gen
378 , mapName = Nothing
379 }) mappings
380 }
381 let mapping = generate rawMapping
382 writeTextFile mapFile $ BU8.toString . B.toStrict . encode $ mapping
383 where
384 add :: Int -> Int -> SourcePos -> SourcePos
385 add n m (SourcePos n' m') = SourcePos (n+n') (m+m')
387 convertPos :: SourcePos -> Pos
388 convertPos SourcePos { sourcePosLine = l, sourcePosColumn = c } =
389 Pos { posLine = fromIntegral l, posColumn = fromIntegral c }
391 requiresForeign :: CF.Module a -> Bool
392 requiresForeign = not . null . CF.moduleForeign
394 getTimestamp :: FilePath -> Make (Maybe UTCTime)
395 getTimestamp path = makeIO (const (ErrorMessage [] $ CannotGetFileInfo path)) $ do
396 exists <- doesFileExist path
397 traverse (const $ getModificationTime path) $ guard exists
399 writeTextFile :: FilePath -> String -> Make ()
400 writeTextFile path text = makeIO (const (ErrorMessage [] $ CannotWriteFile path)) $ do
401 mkdirp path
402 writeUTF8File path text
403 where
404 mkdirp :: FilePath -> IO ()
405 mkdirp = createDirectoryIfMissing True . takeDirectory
407 progress :: ProgressMessage -> Make ()
408 progress = liftIO . putStrLn . renderProgressMessage
410-- |
411-- Check that the declarations in a given PureScript module match with those
412-- in its corresponding foreign module.
413--
414checkForeignDecls :: CF.Module ann -> FilePath -> SupplyT Make ()
415checkForeignDecls m path = do
416 jsStr <- lift $ readTextFile path
417 js <- either (errorParsingModule . Bundle.UnableToParseModule) pure $ JS.parse jsStr path
419 foreignIdentsStrs <- either errorParsingModule pure $ getExps js
420 foreignIdents <- either
421 errorInvalidForeignIdentifiers
422 (pure . S.fromList)
423 (parseIdents foreignIdentsStrs)
424 let importedIdents = S.fromList $ map fst (CF.moduleForeign m)
426 let unusedFFI = foreignIdents S.\\ importedIdents
427 unless (null unusedFFI) $
428 tell . errorMessage . UnusedFFIImplementations mname $
429 S.toList unusedFFI
431 let missingFFI = importedIdents S.\\ foreignIdents
432 unless (null missingFFI) $
433 throwError . errorMessage . MissingFFIImplementations mname $
434 S.toList missingFFI
436 where
437 mname = CF.moduleName m
439 errorParsingModule :: Bundle.ErrorMessage -> SupplyT Make a
440 errorParsingModule = throwError . errorMessage . ErrorParsingFFIModule path . Just
442 getExps :: JS.JSAST -> Either Bundle.ErrorMessage [String]
443 getExps = Bundle.getExportedIdentifiers (runModuleName mname)
445 errorInvalidForeignIdentifiers :: [String] -> SupplyT Make a
446 errorInvalidForeignIdentifiers =
447 throwError . mconcat . map (errorMessage . InvalidFFIIdentifier mname)
449 parseIdents :: [String] -> Either [String] [Ident]
450 parseIdents strs =
451 case partitionEithers (map parseIdent strs) of
452 ([], idents) ->
453 Right idents
454 (errs, _) ->
455 Left errs
457 -- We ignore the error message here, just being told it's an invalid
458 -- identifier should be enough.
459 parseIdent :: String -> Either String Ident
460 parseIdent str = try str
461 where
462 try s = either (const (Left str)) Right $ do
463 ts <- PSParser.lex "" s
464 PSParser.runTokenParser "" (PSParser.parseIdent <* Parsec.eof) ts