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