git.iko.soy/rowtype-yoga/purescript-native
on 8b01085 help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/Make.hs
475 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, isJust)
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 ((checked@(Module ss coms _ elaborated exps), env'), nextVar) <- runSupplyT 0 $ do
162 [desugared] <- desugar externs [m]
163 runCheck' env $ typeCheckModule desugared
164 checkExhaustiveModule env' checked
165 regrouped <- createBindingGroups moduleName . collapseBindingGroups $ elaborated
166 let mod' = Module ss coms moduleName regrouped exps
167 corefn = CF.moduleToCoreFn env' mod'
168 [renamed] = renameInModules [corefn]
169 exts = moduleToExternsFile mod' env'
170 evalSupplyT nextVar . codegen renamed env' . BU8.toString . B.toStrict . encode $ exts
171 return exts
173-- |
174-- Compiles in "make" mode, compiling each module separately to a js files and an externs file
175--
176-- If timestamps have not changed, the externs file can be used to provide the module's types without
177-- having to typecheck the module again.
178--
179make :: forall m. (Monad m, MonadBaseControl IO m, MonadReader Options m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
180 => MakeActions m
181 -> [Module]
182 -> m Environment
183make ma@MakeActions{..} ms = do
184 requirePath <- asks optionsRequirePath
185 when (isJust requirePath) $ tell $ errorMessage DeprecatedRequirePath
187 checkModuleNamesAreUnique
189 (sorted, graph) <- sortModules ms
191 barriers <- zip (map getModuleName sorted) <$> replicateM (length ms) ((,) <$> C.newEmptyMVar <*> C.newEmptyMVar)
193 for_ sorted $ \m -> fork $ do
194 let deps = fromMaybe (internalError "make: module not found in dependency graph.") (lookup (getModuleName m) graph)
195 buildModule barriers (importPrim m) (deps `inOrderOf` map getModuleName sorted)
197 -- Wait for all threads to complete, and collect errors.
198 errors <- catMaybes <$> for barriers (takeMVar . snd . snd)
200 -- All threads have completed, rethrow any caught errors.
201 unless (null errors) $ throwError (mconcat errors)
203 -- Bundle up all the externs and return them as an Environment
204 (_, externs) <- unzip . fromMaybe (internalError "make: externs were missing but no errors reported.") . sequence <$> for barriers (takeMVar . fst . snd)
205 return $ foldl' (flip applyExternsFileToEnvironment) initEnvironment externs
207 where
208 checkModuleNamesAreUnique :: m ()
209 checkModuleNamesAreUnique =
210 case findDuplicate (map getModuleName ms) of
211 Nothing -> return ()
212 Just mn -> throwError . errorMessage $ DuplicateModuleName mn
214 -- Verify that a list of values has unique keys
215 findDuplicate :: (Ord a) => [a] -> Maybe a
216 findDuplicate = go . sort
217 where
218 go (x : y : xs)
219 | x == y = Just x
220 | otherwise = go (y : xs)
221 go _ = Nothing
223 -- Sort a list so its elements appear in the same order as in another list.
224 inOrderOf :: (Ord a) => [a] -> [a] -> [a]
225 inOrderOf xs ys = let s = S.fromList xs in filter (`S.member` s) ys
227 buildModule :: [(ModuleName, (C.MVar (Maybe (MultipleErrors, ExternsFile)), C.MVar (Maybe MultipleErrors)))] -> Module -> [ModuleName] -> m ()
228 buildModule barriers m@(Module _ _ moduleName _ _) deps = flip catchError (markComplete Nothing . Just) $ do
229 -- We need to wait for dependencies to be built, before checking if the current
230 -- module should be rebuilt, so the first thing to do is to wait on the
231 -- MVars for the module's dependencies.
232 mexterns <- fmap unzip . sequence <$> traverse (readMVar . fst . fromMaybe (internalError "make: no barrier") . flip lookup barriers) deps
234 case mexterns of
235 Just (_, externs) -> do
236 outputTimestamp <- getOutputTimestamp moduleName
237 dependencyTimestamp <- maximumMaybe <$> traverse (fmap shouldExist . getOutputTimestamp) deps
238 inputTimestamp <- getInputTimestamp moduleName
240 let shouldRebuild = case (inputTimestamp, dependencyTimestamp, outputTimestamp) of
241 (Right (Just t1), Just t3, Just t2) -> t1 > t2 || t3 > t2
242 (Right (Just t1), Nothing, Just t2) -> t1 > t2
243 (Left RebuildNever, _, Just _) -> False
244 _ -> True
246 let rebuild = do
247 (exts, warnings) <- listen $ rebuildModule ma externs m
248 markComplete (Just (warnings, exts)) Nothing
250 if shouldRebuild
251 then rebuild
252 else do
253 mexts <- decodeExterns . snd <$> readExterns moduleName
254 case mexts of
255 Just exts -> markComplete (Just (mempty, exts)) Nothing
256 Nothing -> rebuild
257 Nothing -> markComplete Nothing Nothing
258 where
259 markComplete :: Maybe (MultipleErrors, ExternsFile) -> Maybe MultipleErrors -> m ()
260 markComplete externs errors = do
261 putMVar (fst $ fromMaybe (internalError "make: no barrier") $ lookup moduleName barriers) externs
262 putMVar (snd $ fromMaybe (internalError "make: no barrier") $ lookup moduleName barriers) errors
264 maximumMaybe :: (Ord a) => [a] -> Maybe a
265 maximumMaybe [] = Nothing
266 maximumMaybe xs = Just $ maximum xs
268 -- Make sure a dependency exists
269 shouldExist :: Maybe UTCTime -> UTCTime
270 shouldExist (Just t) = t
271 shouldExist _ = internalError "make: dependency should already have been built."
273 decodeExterns :: Externs -> Maybe ExternsFile
274 decodeExterns bs = do
275 externs <- decode (fromString bs)
276 guard $ efVersion externs == showVersion Paths.version
277 return externs
279importPrim :: Module -> Module
280importPrim = addDefaultImport (ModuleName [ProperName C.prim])
282-- |
283-- A monad for running make actions
284--
285newtype Make a = Make { unMake :: ReaderT Options (ExceptT MultipleErrors (Logger MultipleErrors)) a }
286 deriving (Functor, Applicative, Monad, MonadIO, MonadError MultipleErrors, MonadWriter MultipleErrors, MonadReader Options)
288instance MonadBase IO Make where
289 liftBase = liftIO
291instance MonadBaseControl IO Make where
292 type StM Make a = Either MultipleErrors a
293 liftBaseWith f = Make $ liftBaseWith $ \q -> f (q . unMake)
294 restoreM = Make . restoreM
296-- |
297-- Execute a 'Make' monad, returning either errors, or the result of the compile plus any warnings.
298--
299runMake :: Options -> Make a -> IO (Either MultipleErrors a, MultipleErrors)
300runMake opts = runLogger' . runExceptT . flip runReaderT opts . unMake
302makeIO :: (IOError -> ErrorMessage) -> IO a -> Make a
303makeIO f io = do
304 e <- liftIO $ tryIOError io
305 either (throwError . singleError . f) return e
307-- Traverse (Either e) instance (base 4.7)
308traverseEither :: Applicative f => (a -> f b) -> Either e a -> f (Either e b)
309traverseEither _ (Left x) = pure (Left x)
310traverseEither f (Right y) = Right <$> f y
312-- |
313-- A set of make actions that read and write modules from the given directory.
314--
315buildMakeActions :: FilePath -- ^ the output directory
316 -> M.Map ModuleName (Either RebuildPolicy FilePath) -- ^ a map between module names and paths to the file containing the PureScript module
317 -> M.Map ModuleName FilePath -- ^ a map between module name and the file containing the foreign javascript for the module
318 -> Bool -- ^ Generate a prefix comment?
319 -> MakeActions Make
320buildMakeActions outputDir filePathMap foreigns usePrefix =
321 MakeActions getInputTimestamp getOutputTimestamp readExterns codegen progress
322 where
324 getInputTimestamp :: ModuleName -> Make (Either RebuildPolicy (Maybe UTCTime))
325 getInputTimestamp mn = do
326 let path = fromMaybe (internalError "Module has no filename in 'make'") $ M.lookup mn filePathMap
327 e1 <- traverseEither getTimestamp path
328 fPath <- maybe (return Nothing) getTimestamp $ M.lookup mn foreigns
329 return $ fmap (max fPath) e1
331 getOutputTimestamp :: ModuleName -> Make (Maybe UTCTime)
332 getOutputTimestamp mn = do
333 let filePath = runModuleName mn
334 jsFile = outputDir </> filePath </> "index.js"
335 externsFile = outputDir </> filePath </> "externs.json"
336 min <$> getTimestamp jsFile <*> getTimestamp externsFile
338 readExterns :: ModuleName -> Make (FilePath, Externs)
339 readExterns mn = do
340 let path = outputDir </> runModuleName mn </> "externs.json"
341 (path, ) <$> readTextFile path
343 codegen :: CF.Module CF.Ann -> Environment -> Externs -> SupplyT Make ()
344 codegen m _ exts = do
345 let mn = CF.moduleName m
346 foreignInclude <- case mn `M.lookup` foreigns of
347 Just path
348 | not $ requiresForeign m -> do
349 tell $ errorMessage $ UnnecessaryFFIModule mn path
350 return Nothing
351 | otherwise -> do
352 checkForeignDecls m path
353 return $ Just $ J.JSApp Nothing (J.JSVar Nothing "require") [J.JSStringLiteral Nothing "./foreign"]
354 Nothing | requiresForeign m -> throwError . errorMessage $ MissingFFIModule mn
355 | otherwise -> return Nothing
356 rawJs <- J.moduleToJs m foreignInclude
357 dir <- lift $ makeIO (const (ErrorMessage [] $ CannotGetFileInfo ".")) getCurrentDirectory
358 sourceMaps <- lift $ asks optionsSourceMaps
359 let (pjs, mappings) = if sourceMaps then prettyPrintJSWithSourceMaps rawJs else (prettyPrintJS rawJs, [])
360 let filePath = runModuleName mn
361 jsFile = outputDir </> filePath </> "index.js"
362 mapFile = outputDir </> filePath </> "index.js.map"
363 externsFile = outputDir </> filePath </> "externs.json"
364 foreignFile = outputDir </> filePath </> "foreign.js"
365 prefix = ["Generated by psc version " ++ showVersion Paths.version | usePrefix]
366 js = unlines $ map ("// " ++) prefix ++ [pjs]
367 mapRef = if sourceMaps then "//# sourceMappingURL=index.js.map\n" else ""
368 lift $ do
369 writeTextFile jsFile (fromString $ js ++ mapRef)
370 for_ (mn `M.lookup` foreigns) (readTextFile >=> writeTextFile foreignFile)
371 writeTextFile externsFile exts
372 lift $ when sourceMaps $ genSourceMap dir mapFile (length prefix) mappings
374 genSourceMap :: String -> String -> Int -> [SMap] -> Make ()
375 genSourceMap dir mapFile extraLines mappings = do
376 let pathToDir = iterate (".." </>) ".." !! length (splitPath $ normalise outputDir)
377 sourceFile = case mappings of
378 ((SMap file _ _):_) -> Just $ pathToDir </> makeRelative dir file
379 _ -> Nothing
380 let rawMapping = SourceMapping { smFile = "index.js", smSourceRoot = Nothing, smMappings =
381 map (\(SMap _ orig gen) -> Mapping {
382 mapOriginal = Just $ convertPos $ add 0 (-1) orig
383 , mapSourceFile = sourceFile
384 , mapGenerated = convertPos $ add (extraLines+1) 0 gen
385 , mapName = Nothing
386 }) mappings
387 }
388 let mapping = generate rawMapping
389 writeTextFile mapFile $ BU8.toString . B.toStrict . encode $ mapping
390 where
391 add :: Int -> Int -> SourcePos -> SourcePos
392 add n m (SourcePos n' m') = SourcePos (n+n') (m+m')
394 convertPos :: SourcePos -> Pos
395 convertPos SourcePos { sourcePosLine = l, sourcePosColumn = c } =
396 Pos { posLine = fromIntegral l, posColumn = fromIntegral c }
398 requiresForeign :: CF.Module a -> Bool
399 requiresForeign = not . null . CF.moduleForeign
401 getTimestamp :: FilePath -> Make (Maybe UTCTime)
402 getTimestamp path = makeIO (const (ErrorMessage [] $ CannotGetFileInfo path)) $ do
403 exists <- doesFileExist path
404 traverse (const $ getModificationTime path) $ guard exists
406 writeTextFile :: FilePath -> String -> Make ()
407 writeTextFile path text = makeIO (const (ErrorMessage [] $ CannotWriteFile path)) $ do
408 mkdirp path
409 writeUTF8File path text
410 where
411 mkdirp :: FilePath -> IO ()
412 mkdirp = createDirectoryIfMissing True . takeDirectory
414 progress :: ProgressMessage -> Make ()
415 progress = liftIO . putStrLn . renderProgressMessage
417readTextFile :: FilePath -> Make String
418readTextFile path = makeIO (const (ErrorMessage [] $ CannotReadFile path)) $ readUTF8File path
420-- |
421-- Check that the declarations in a given PureScript module match with those
422-- in its corresponding foreign module.
423--
424checkForeignDecls :: CF.Module ann -> FilePath -> SupplyT Make ()
425checkForeignDecls m path = do
426 jsStr <- lift $ readTextFile path
427 js <- either (errorParsingModule . Bundle.UnableToParseModule) pure $ JS.parse jsStr path
429 foreignIdentsStrs <- either errorParsingModule pure $ getExps js
430 foreignIdents <- either
431 errorInvalidForeignIdentifiers
432 (pure . S.fromList)
433 (parseIdents foreignIdentsStrs)
434 let importedIdents = S.fromList $ map fst (CF.moduleForeign m)
436 let unusedFFI = foreignIdents S.\\ importedIdents
437 unless (null unusedFFI) $
438 tell . errorMessage . UnusedFFIImplementations mname $
439 S.toList unusedFFI
441 let missingFFI = importedIdents S.\\ foreignIdents
442 unless (null missingFFI) $
443 throwError . errorMessage . MissingFFIImplementations mname $
444 S.toList missingFFI
446 where
447 mname = CF.moduleName m
449 errorParsingModule :: Bundle.ErrorMessage -> SupplyT Make a
450 errorParsingModule = throwError . errorMessage . ErrorParsingFFIModule path . Just
452 getExps :: JS.JSAST -> Either Bundle.ErrorMessage [String]
453 getExps = Bundle.getExportedIdentifiers (runModuleName mname)
455 errorInvalidForeignIdentifiers :: [String] -> SupplyT Make a
456 errorInvalidForeignIdentifiers =
457 throwError . mconcat . map (errorMessage . InvalidFFIIdentifier mname)
459 parseIdents :: [String] -> Either [String] [Ident]
460 parseIdents strs =
461 case partitionEithers (map parseIdent strs) of
462 ([], idents) ->
463 Right idents
464 (errs, _) ->
465 Left errs
467 -- TODO: Handling for parenthesised operators should be removed after 0.9.
468 -- We ignore the error message here, just being told it's an invalid
469 -- identifier should be enough.
470 parseIdent :: String -> Either String Ident
471 parseIdent str = try str <|> try ("(" ++ str ++ ")")
472 where
473 try s = either (const (Left str)) Right $ do
474 ts <- PSParser.lex "" s
475 PSParser.runTokenParser "" (PSParser.parseIdent <* Parsec.eof) ts