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