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