git.iko.soy/rowtype-yoga/purescript-native
on 0e7c936 help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/Make.hs
471 lines 19 kB history raw
1{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3{-# LANGUAGE TupleSections #-}
4{-# LANGUAGE RankNTypes #-}
5{-# LANGUAGE RecordWildCards #-}
6{-# LANGUAGE ScopedTypeVariables #-}
7{-# LANGUAGE MultiParamTypeClasses #-}
8{-# LANGUAGE TypeFamilies #-}
10module Language.PureScript.Make
11 (
12 -- * Make API
13 RebuildPolicy(..)
14 , ProgressMessage(..), renderProgressMessage
15 , MakeActions(..)
16 , Externs()
17 , rebuildModule
18 , make
20 -- * Implementation of Make API using files on disk
21 , Make(..)
22 , runMake
23 , buildMakeActions
24 ) where
26import Prelude ()
27import Prelude.Compat
29import Control.Applicative ((<|>))
30import Control.Monad hiding (sequence)
31import Control.Monad.Error.Class (MonadError(..))
32import Control.Monad.Writer.Class (MonadWriter(..))
33import Control.Monad.Trans.Class (MonadTrans(..))
34import Control.Monad.Trans.Except
35import Control.Monad.IO.Class
36import Control.Monad.Reader (MonadReader(..), ReaderT(..), asks)
37import Control.Monad.Logger
38import Control.Monad.Supply
39import Control.Monad.Base (MonadBase(..))
40import Control.Monad.Trans.Control (MonadBaseControl(..))
42import Control.Concurrent.Lifted as C
44import Data.List (foldl', sort)
45import Data.Maybe (fromMaybe, catMaybes)
46import Data.Either (partitionEithers)
47import Data.Time.Clock
48import Data.String (fromString)
49import Data.Foldable (for_)
50import Data.Traversable (for)
51import Data.Version (showVersion)
52import Data.Aeson (encode, decode)
53import qualified Data.ByteString.Lazy as B
54import qualified Data.ByteString.UTF8 as BU8
55import qualified Data.Set as S
56import qualified Data.Map as M
58import qualified Text.Parsec as Parsec
60import SourceMap.Types
61import SourceMap
63import System.Directory
64 (doesFileExist, getModificationTime, createDirectoryIfMissing, getCurrentDirectory)
65import System.FilePath ((</>), takeDirectory, makeRelative, splitPath, normalise)
66import System.IO.Error (tryIOError)
67import System.IO.UTF8 (readUTF8File, writeUTF8File)
69import qualified Language.JavaScript.Parser as JS
71import Language.PureScript.Crash
72import Language.PureScript.AST
73import Language.PureScript.Externs
74import Language.PureScript.Environment
75import Language.PureScript.Errors
76import Language.PureScript.Linter
77import Language.PureScript.ModuleDependencies
78import Language.PureScript.Names
79import Language.PureScript.Options
80import Language.PureScript.Pretty
81import Language.PureScript.Pretty.Common(SMap(..))
82import Language.PureScript.Renamer
83import Language.PureScript.Sugar
84import Language.PureScript.TypeChecker
85import qualified Language.PureScript.Constants as C
86import qualified Language.PureScript.Bundle as Bundle
87import qualified Language.PureScript.Parser as PSParser
89import qualified Language.PureScript.CodeGen.JS as J
90import qualified Language.PureScript.CoreFn as CF
91import qualified Paths_purescript as Paths
93-- | Progress messages from the make process
94data ProgressMessage
95 = CompilingModule ModuleName
96 deriving (Show, Read, Eq, Ord)
98-- | Render a progress message
99renderProgressMessage :: ProgressMessage -> String
100renderProgressMessage (CompilingModule mn) = "Compiling " ++ runModuleName mn
102-- | Actions that require implementations when running in "make" mode.
103--
104-- This type exists to make two things abstract:
105--
106-- * The particular backend being used (Javascript, C++11, etc.)
107--
108-- * The details of how files are read/written etc.
109--
110data MakeActions m = MakeActions {
111 -- |
112 -- Get the timestamp for the input file(s) for a module. If there are multiple
113 -- files (.purs and foreign files, for example) the timestamp should be for
114 -- the most recently modified file.
115 --
116 getInputTimestamp :: ModuleName -> m (Either RebuildPolicy (Maybe UTCTime))
117 -- |
118 -- Get the timestamp for the output files for a module. This should be the
119 -- timestamp for the oldest modified file, or Nothing if any of the required
120 -- output files are missing.
121 --
122 , getOutputTimestamp :: ModuleName -> m (Maybe UTCTime)
123 -- |
124 -- Read the externs file for a module as a string and also return the actual
125 -- path for the file.
126 , readExterns :: ModuleName -> m (FilePath, Externs)
127 -- |
128 -- Run the code generator for the module and write any required output files.
129 --
130 , codegen :: CF.Module CF.Ann -> Environment -> Externs -> SupplyT m ()
131 -- |
132 -- Respond to a progress update.
133 --
134 , progress :: ProgressMessage -> m ()
135 }
137-- |
138-- Generated code for an externs file.
139--
140type Externs = String
142-- |
143-- Determines when to rebuild a module
144--
145data RebuildPolicy
146 -- | Never rebuild this module
147 = RebuildNever
148 -- | Always rebuild this module
149 | RebuildAlways deriving (Show, Read, Eq, Ord)
151-- | Rebuild a single module
152rebuildModule :: forall m. (Monad m, MonadBaseControl IO m, MonadReader Options m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
153 => MakeActions m
154 -> [ExternsFile]
155 -> Module
156 -> m ExternsFile
157rebuildModule MakeActions{..} externs m@(Module _ _ moduleName _ _) = do
158 progress $ CompilingModule moduleName
159 let env = foldl' (flip applyExternsFileToEnvironment) initEnvironment externs
160 lint m
161 ((Module ss coms _ elaborated exps, env'), nextVar) <- runSupplyT 0 $ do
162 [desugared] <- desugar externs [m]
163 runCheck' env $ typeCheckModule desugared
164 regrouped <- createBindingGroups moduleName . collapseBindingGroups $ elaborated
165 let mod' = Module ss coms moduleName regrouped exps
166 corefn = CF.moduleToCoreFn env' mod'
167 [renamed] = renameInModules [corefn]
168 exts = moduleToExternsFile mod' env'
169 evalSupplyT nextVar . codegen renamed env' . BU8.toString . B.toStrict . encode $ exts
170 return exts
172-- |
173-- Compiles in "make" mode, compiling each module separately to a js files and an externs file
174--
175-- If timestamps have not changed, the externs file can be used to provide the module's types without
176-- having to typecheck the module again.
177--
178make :: forall m. (Monad m, MonadBaseControl IO m, MonadReader Options m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
179 => MakeActions m
180 -> [Module]
181 -> m Environment
182make ma@MakeActions{..} ms = do
183 checkModuleNamesAreUnique
185 (sorted, graph) <- sortModules ms
187 barriers <- zip (map getModuleName sorted) <$> replicateM (length ms) ((,) <$> C.newEmptyMVar <*> C.newEmptyMVar)
189 for_ sorted $ \m -> fork $ do
190 let deps = fromMaybe (internalError "make: module not found in dependency graph.") (lookup (getModuleName m) graph)
191 buildModule barriers (importPrim m) (deps `inOrderOf` map getModuleName sorted)
193 -- Wait for all threads to complete, and collect errors.
194 errors <- catMaybes <$> for barriers (takeMVar . snd . snd)
196 -- All threads have completed, rethrow any caught errors.
197 unless (null errors) $ throwError (mconcat errors)
199 -- Bundle up all the externs and return them as an Environment
200 (_, externs) <- unzip . fromMaybe (internalError "make: externs were missing but no errors reported.") . sequence <$> for barriers (takeMVar . fst . snd)
201 return $ foldl' (flip applyExternsFileToEnvironment) initEnvironment externs
203 where
204 checkModuleNamesAreUnique :: m ()
205 checkModuleNamesAreUnique =
206 case findDuplicate (map getModuleName ms) of
207 Nothing -> return ()
208 Just mn -> throwError . errorMessage $ DuplicateModuleName mn
210 -- Verify that a list of values has unique keys
211 findDuplicate :: (Ord a) => [a] -> Maybe a
212 findDuplicate = go . sort
213 where
214 go (x : y : xs)
215 | x == y = Just x
216 | otherwise = go (y : xs)
217 go _ = Nothing
219 -- Sort a list so its elements appear in the same order as in another list.
220 inOrderOf :: (Ord a) => [a] -> [a] -> [a]
221 inOrderOf xs ys = let s = S.fromList xs in filter (`S.member` s) ys
223 buildModule :: [(ModuleName, (C.MVar (Maybe (MultipleErrors, ExternsFile)), C.MVar (Maybe MultipleErrors)))] -> Module -> [ModuleName] -> m ()
224 buildModule barriers m@(Module _ _ moduleName _ _) deps = flip catchError (markComplete Nothing . Just) $ do
225 -- We need to wait for dependencies to be built, before checking if the current
226 -- module should be rebuilt, so the first thing to do is to wait on the
227 -- MVars for the module's dependencies.
228 mexterns <- fmap unzip . sequence <$> traverse (readMVar . fst . fromMaybe (internalError "make: no barrier") . flip lookup barriers) deps
230 case mexterns of
231 Just (_, externs) -> do
232 outputTimestamp <- getOutputTimestamp moduleName
233 dependencyTimestamp <- maximumMaybe <$> traverse (fmap shouldExist . getOutputTimestamp) deps
234 inputTimestamp <- getInputTimestamp moduleName
236 let shouldRebuild = case (inputTimestamp, dependencyTimestamp, outputTimestamp) of
237 (Right (Just t1), Just t3, Just t2) -> t1 > t2 || t3 > t2
238 (Right (Just t1), Nothing, Just t2) -> t1 > t2
239 (Left RebuildNever, _, Just _) -> False
240 _ -> True
242 let rebuild = do
243 (exts, warnings) <- listen $ rebuildModule ma externs m
244 markComplete (Just (warnings, exts)) Nothing
246 if shouldRebuild
247 then rebuild
248 else do
249 mexts <- decodeExterns . snd <$> readExterns moduleName
250 case mexts of
251 Just exts -> markComplete (Just (mempty, exts)) Nothing
252 Nothing -> rebuild
253 Nothing -> markComplete Nothing Nothing
254 where
255 markComplete :: Maybe (MultipleErrors, ExternsFile) -> Maybe MultipleErrors -> m ()
256 markComplete externs errors = do
257 putMVar (fst $ fromMaybe (internalError "make: no barrier") $ lookup moduleName barriers) externs
258 putMVar (snd $ fromMaybe (internalError "make: no barrier") $ lookup moduleName barriers) errors
260 maximumMaybe :: (Ord a) => [a] -> Maybe a
261 maximumMaybe [] = Nothing
262 maximumMaybe xs = Just $ maximum xs
264 -- Make sure a dependency exists
265 shouldExist :: Maybe UTCTime -> UTCTime
266 shouldExist (Just t) = t
267 shouldExist _ = internalError "make: dependency should already have been built."
269 decodeExterns :: Externs -> Maybe ExternsFile
270 decodeExterns bs = do
271 externs <- decode (fromString bs)
272 guard $ efVersion externs == showVersion Paths.version
273 return externs
275importPrim :: Module -> Module
276importPrim = addDefaultImport (ModuleName [ProperName C.prim])
278-- |
279-- A monad for running make actions
280--
281newtype Make a = Make { unMake :: ReaderT Options (ExceptT MultipleErrors (Logger MultipleErrors)) a }
282 deriving (Functor, Applicative, Monad, MonadIO, MonadError MultipleErrors, MonadWriter MultipleErrors, MonadReader Options)
284instance MonadBase IO Make where
285 liftBase = liftIO
287instance MonadBaseControl IO Make where
288 type StM Make a = Either MultipleErrors a
289 liftBaseWith f = Make $ liftBaseWith $ \q -> f (q . unMake)
290 restoreM = Make . restoreM
292-- |
293-- Execute a 'Make' monad, returning either errors, or the result of the compile plus any warnings.
294--
295runMake :: Options -> Make a -> IO (Either MultipleErrors a, MultipleErrors)
296runMake opts = runLogger' . runExceptT . flip runReaderT opts . unMake
298makeIO :: (IOError -> ErrorMessage) -> IO a -> Make a
299makeIO f io = do
300 e <- liftIO $ tryIOError io
301 either (throwError . singleError . f) return e
303-- Traverse (Either e) instance (base 4.7)
304traverseEither :: Applicative f => (a -> f b) -> Either e a -> f (Either e b)
305traverseEither _ (Left x) = pure (Left x)
306traverseEither f (Right y) = Right <$> f y
308-- |
309-- A set of make actions that read and write modules from the given directory.
310--
311buildMakeActions :: FilePath -- ^ the output directory
312 -> M.Map ModuleName (Either RebuildPolicy FilePath) -- ^ a map between module names and paths to the file containing the PureScript module
313 -> M.Map ModuleName FilePath -- ^ a map between module name and the file containing the foreign javascript for the module
314 -> Bool -- ^ 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 <- traverseEither 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 = 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 </> 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 = 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 " ++ showVersion Paths.version | usePrefix]
362 js = unlines $ map ("// " ++) prefix ++ [pjs]
363 mapRef = if sourceMaps then "//# sourceMappingURL=index.js.map\n" else ""
364 lift $ do
365 writeTextFile jsFile (fromString $ 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
370 genSourceMap :: String -> String -> Int -> [SMap] -> Make ()
371 genSourceMap dir mapFile extraLines mappings = do
372 let pathToDir = iterate (".." </>) ".." !! length (splitPath $ normalise outputDir)
373 sourceFile = case mappings of
374 ((SMap file _ _):_) -> Just $ pathToDir </> makeRelative dir file
375 _ -> Nothing
376 let rawMapping = SourceMapping { smFile = "index.js", smSourceRoot = Nothing, smMappings =
377 map (\(SMap _ orig gen) -> Mapping {
378 mapOriginal = Just $ convertPos $ add 0 (-1) orig
379 , mapSourceFile = sourceFile
380 , mapGenerated = convertPos $ add (extraLines+1) 0 gen
381 , mapName = Nothing
382 }) mappings
383 }
384 let mapping = generate rawMapping
385 writeTextFile mapFile $ BU8.toString . B.toStrict . encode $ mapping
386 where
387 add :: Int -> Int -> SourcePos -> SourcePos
388 add n m (SourcePos n' m') = SourcePos (n+n') (m+m')
390 convertPos :: SourcePos -> Pos
391 convertPos SourcePos { sourcePosLine = l, sourcePosColumn = c } =
392 Pos { posLine = fromIntegral l, posColumn = fromIntegral c }
394 requiresForeign :: CF.Module a -> Bool
395 requiresForeign = not . null . CF.moduleForeign
397 getTimestamp :: FilePath -> Make (Maybe UTCTime)
398 getTimestamp path = makeIO (const (ErrorMessage [] $ CannotGetFileInfo path)) $ do
399 exists <- doesFileExist path
400 traverse (const $ getModificationTime path) $ guard exists
402 writeTextFile :: FilePath -> String -> Make ()
403 writeTextFile path text = makeIO (const (ErrorMessage [] $ CannotWriteFile path)) $ do
404 mkdirp path
405 writeUTF8File path text
406 where
407 mkdirp :: FilePath -> IO ()
408 mkdirp = createDirectoryIfMissing True . takeDirectory
410 progress :: ProgressMessage -> Make ()
411 progress = liftIO . putStrLn . renderProgressMessage
413readTextFile :: FilePath -> Make String
414readTextFile path = makeIO (const (ErrorMessage [] $ CannotReadFile path)) $ readUTF8File path
416-- |
417-- Check that the declarations in a given PureScript module match with those
418-- in its corresponding foreign module.
419--
420checkForeignDecls :: CF.Module ann -> FilePath -> SupplyT Make ()
421checkForeignDecls m path = do
422 jsStr <- lift $ readTextFile path
423 js <- either (errorParsingModule . Bundle.UnableToParseModule) pure $ JS.parse jsStr path
425 foreignIdentsStrs <- either errorParsingModule pure $ getExps js
426 foreignIdents <- either
427 errorInvalidForeignIdentifiers
428 (pure . S.fromList)
429 (parseIdents foreignIdentsStrs)
430 let importedIdents = S.fromList $ map fst (CF.moduleForeign m)
432 let unusedFFI = foreignIdents S.\\ importedIdents
433 unless (null unusedFFI) $
434 tell . errorMessage . UnusedFFIImplementations mname $
435 S.toList unusedFFI
437 let missingFFI = importedIdents S.\\ foreignIdents
438 unless (null missingFFI) $
439 throwError . errorMessage . MissingFFIImplementations mname $
440 S.toList missingFFI
442 where
443 mname = CF.moduleName m
445 errorParsingModule :: Bundle.ErrorMessage -> SupplyT Make a
446 errorParsingModule = throwError . errorMessage . ErrorParsingFFIModule path . Just
448 getExps :: JS.JSAST -> Either Bundle.ErrorMessage [String]
449 getExps = Bundle.getExportedIdentifiers (runModuleName mname)
451 errorInvalidForeignIdentifiers :: [String] -> SupplyT Make a
452 errorInvalidForeignIdentifiers =
453 throwError . mconcat . map (errorMessage . InvalidFFIIdentifier mname)
455 parseIdents :: [String] -> Either [String] [Ident]
456 parseIdents strs =
457 case partitionEithers (map parseIdent strs) of
458 ([], idents) ->
459 Right idents
460 (errs, _) ->
461 Left errs
463 -- TODO: Handling for parenthesised operators should be removed after 0.9.
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 str <|> try ("(" ++ 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