git.iko.soy/rowtype-yoga/purescript-native
on d49ac41 help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/Make.hs
471 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 let filePath = T.unpack (runModuleName mn)
330 jsFile = outputDir </> filePath </> "index.js"
331 externsFile = outputDir </> filePath </> "externs.json"
332 min <$> getTimestamp jsFile <*> getTimestamp externsFile
334 readExterns :: ModuleName -> Make (FilePath, Externs)
335 readExterns mn = do
336 let path = outputDir </> T.unpack (runModuleName mn) </> "externs.json"
337 (path, ) <$> readTextFile path
339 codegen :: CF.Module CF.Ann -> Environment -> Externs -> SupplyT Make ()
340 codegen m _ exts = do
341 let mn = CF.moduleName m
342 foreignInclude <- case mn `M.lookup` foreigns of
343 Just path
344 | not $ requiresForeign m -> do
345 tell $ errorMessage $ UnnecessaryFFIModule mn path
346 return Nothing
347 | otherwise -> do
348 checkForeignDecls m path
349 return $ Just $ J.JSApp Nothing (J.JSVar Nothing "require") [J.JSStringLiteral Nothing "./foreign"]
350 Nothing | requiresForeign m -> throwError . errorMessage $ MissingFFIModule mn
351 | otherwise -> return Nothing
352 rawJs <- J.moduleToJs m foreignInclude
353 dir <- lift $ makeIO (const (ErrorMessage [] $ CannotGetFileInfo ".")) getCurrentDirectory
354 sourceMaps <- lift $ asks optionsSourceMaps
355 let (pjs, mappings) = if sourceMaps then prettyPrintJSWithSourceMaps rawJs else (prettyPrintJS rawJs, [])
356 let filePath = T.unpack (runModuleName mn)
357 jsFile = outputDir </> filePath </> "index.js"
358 mapFile = outputDir </> filePath </> "index.js.map"
359 externsFile = outputDir </> filePath </> "externs.json"
360 foreignFile = outputDir </> filePath </> "foreign.js"
361 prefix = ["Generated by psc version " <> T.pack (showVersion Paths.version) | usePrefix]
362 js = T.unlines $ map ("// " <>) prefix ++ [pjs]
363 mapRef = if sourceMaps then "//# sourceMappingURL=index.js.map\n" else ""
364 lift $ do
365 writeTextFile jsFile (B.fromStrict $ TE.encodeUtf8 $ js <> mapRef)
366 for_ (mn `M.lookup` foreigns) (readTextFile >=> writeTextFile foreignFile)
367 writeTextFile externsFile exts
368 lift $ when sourceMaps $ genSourceMap dir mapFile (length prefix) mappings
369 dumpCoreFn <- lift $ asks optionsDumpCoreFn
370 when dumpCoreFn $ do
371 let coreFnFile = outputDir </> filePath </> "corefn.json"
372 let jsonPayload = CFJ.moduleToJSON Paths.version m
373 let json = Aeson.object [ (runModuleName mn, jsonPayload) ]
374 lift $ writeTextFile coreFnFile (encode json)
376 genSourceMap :: String -> String -> Int -> [SMap] -> Make ()
377 genSourceMap dir mapFile extraLines mappings = do
378 let pathToDir = iterate (".." </>) ".." !! length (splitPath $ normalise outputDir)
379 sourceFile = case mappings of
380 (SMap file _ _ : _) -> Just $ pathToDir </> makeRelative dir (T.unpack file)
381 _ -> Nothing
382 let rawMapping = SourceMapping { smFile = "index.js", smSourceRoot = Nothing, smMappings =
383 map (\(SMap _ orig gen) -> Mapping {
384 mapOriginal = Just $ convertPos $ add 0 (-1) orig
385 , mapSourceFile = sourceFile
386 , mapGenerated = convertPos $ add (extraLines+1) 0 gen
387 , mapName = Nothing
388 }) mappings
389 }
390 let mapping = generate rawMapping
391 writeTextFile mapFile (encode mapping)
392 where
393 add :: Int -> Int -> SourcePos -> SourcePos
394 add n m (SourcePos n' m') = SourcePos (n+n') (m+m')
396 convertPos :: SourcePos -> Pos
397 convertPos SourcePos { sourcePosLine = l, sourcePosColumn = c } =
398 Pos { posLine = fromIntegral l, posColumn = fromIntegral c }
400 requiresForeign :: CF.Module a -> Bool
401 requiresForeign = not . null . CF.moduleForeign
403 getTimestamp :: FilePath -> Make (Maybe UTCTime)
404 getTimestamp path = makeIO (const (ErrorMessage [] $ CannotGetFileInfo path)) $ do
405 exists <- doesFileExist path
406 traverse (const $ getModificationTime path) $ guard exists
408 writeTextFile :: FilePath -> B.ByteString -> Make ()
409 writeTextFile path text = makeIO (const (ErrorMessage [] $ CannotWriteFile path)) $ do
410 mkdirp path
411 B.writeFile path text
412 where
413 mkdirp :: FilePath -> IO ()
414 mkdirp = createDirectoryIfMissing True . takeDirectory
416 progress :: ProgressMessage -> Make ()
417 progress = liftIO . putStrLn . renderProgressMessage
419-- | Check that the declarations in a given PureScript module match with those
420-- in its corresponding foreign module.
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 (BU8.toString (B.toStrict 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 (T.unpack (runModuleName mname))
452 errorInvalidForeignIdentifiers :: [String] -> SupplyT Make a
453 errorInvalidForeignIdentifiers =
454 throwError . mconcat . map (errorMessage . InvalidFFIIdentifier mname . T.pack)
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 -- We ignore the error message here, just being told it's an invalid
465 -- identifier should be enough.
466 parseIdent :: String -> Either String Ident
467 parseIdent str = try (T.pack str)
468 where
469 try s = either (const (Left str)) Right $ do
470 ts <- PSParser.lex "" s
471 PSParser.runTokenParser "" (PSParser.parseIdent <* Parsec.eof) ts