git.iko.soy/rowtype-yoga/purescript-native
on 6cb50ee help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/Make.hs
452 lines 18 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.Time.Clock
46import Data.String (fromString)
47import Data.Foldable (for_)
48import Data.Traversable (for)
49import Data.Version (showVersion)
50import Data.Aeson (encode, decode)
51import qualified Data.ByteString.Lazy as B
52import qualified Data.ByteString.UTF8 as BU8
53import qualified Data.Set as S
54import qualified Data.Map as M
56import qualified Text.Parsec as Parsec
58import SourceMap.Types
59import SourceMap
61import System.Directory
62 (doesFileExist, getModificationTime, createDirectoryIfMissing, getCurrentDirectory)
63import System.FilePath ((</>), takeDirectory, makeRelative, splitPath, normalise)
64import System.IO.Error (tryIOError)
65import System.IO.UTF8 (readUTF8File, writeUTF8File)
67import qualified Language.JavaScript.Parser as JS
69import Language.PureScript.Crash
70import Language.PureScript.AST
71import Language.PureScript.Externs
72import Language.PureScript.Environment
73import Language.PureScript.Errors
74import Language.PureScript.Linter
75import Language.PureScript.ModuleDependencies
76import Language.PureScript.Names
77import Language.PureScript.Options
78import Language.PureScript.Pretty
79import Language.PureScript.Pretty.Common(SMap(..))
80import Language.PureScript.Renamer
81import Language.PureScript.Sugar
82import Language.PureScript.TypeChecker
83import qualified Language.PureScript.Constants as C
84import qualified Language.PureScript.Bundle as Bundle
85import qualified Language.PureScript.Parser as PSParser
87import qualified Language.PureScript.CodeGen.JS as J
88import qualified Language.PureScript.CoreFn as CF
89import qualified Paths_purescript as Paths
91-- | Progress messages from the make process
92data ProgressMessage
93 = CompilingModule ModuleName
94 deriving (Show, Read, Eq, Ord)
96-- | Render a progress message
97renderProgressMessage :: ProgressMessage -> String
98renderProgressMessage (CompilingModule mn) = "Compiling " ++ runModuleName mn
100-- | Actions that require implementations when running in "make" mode.
101--
102-- This type exists to make two things abstract:
103--
104-- * The particular backend being used (Javascript, C++11, etc.)
105--
106-- * The details of how files are read/written etc.
107--
108data MakeActions m = MakeActions {
109 -- |
110 -- Get the timestamp for the input file(s) for a module. If there are multiple
111 -- files (.purs and foreign files, for example) the timestamp should be for
112 -- the most recently modified file.
113 --
114 getInputTimestamp :: ModuleName -> m (Either RebuildPolicy (Maybe UTCTime))
115 -- |
116 -- Get the timestamp for the output files for a module. This should be the
117 -- timestamp for the oldest modified file, or Nothing if any of the required
118 -- output files are missing.
119 --
120 , getOutputTimestamp :: ModuleName -> m (Maybe UTCTime)
121 -- |
122 -- Read the externs file for a module as a string and also return the actual
123 -- path for the file.
124 , readExterns :: ModuleName -> m (FilePath, Externs)
125 -- |
126 -- Run the code generator for the module and write any required output files.
127 --
128 , codegen :: CF.Module CF.Ann -> Environment -> Externs -> SupplyT m ()
129 -- |
130 -- Respond to a progress update.
131 --
132 , progress :: ProgressMessage -> m ()
133 }
135-- |
136-- Generated code for an externs file.
137--
138type Externs = String
140-- |
141-- Determines when to rebuild a module
142--
143data RebuildPolicy
144 -- | Never rebuild this module
145 = RebuildNever
146 -- | Always rebuild this module
147 | RebuildAlways deriving (Show, Read, Eq, Ord)
149-- |
150-- Compiles in "make" mode, compiling each module separately to a js files and an externs file
151--
152-- If timestamps have not changed, the externs file can be used to provide the module's types without
153-- having to typecheck the module again.
154--
155make :: forall m. (Monad m, MonadBaseControl IO m, MonadReader Options m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
156 => MakeActions m
157 -> [Module]
158 -> m Environment
159make MakeActions{..} ms = do
160 requirePath <- asks optionsRequirePath
161 when (isJust requirePath) $ tell $ errorMessage DeprecatedRequirePath
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 $ foldl' (flip applyExternsFileToEnvironment) initEnvironment externs
183 where
184 checkModuleNamesAreUnique :: m ()
185 checkModuleNamesAreUnique =
186 case findDuplicate (map getModuleName ms) of
187 Nothing -> return ()
188 Just mn -> throwError . errorMessage $ DuplicateModuleName mn
190 -- Verify that a list of values has unique keys
191 findDuplicate :: (Ord a) => [a] -> Maybe a
192 findDuplicate = go . sort
193 where
194 go (x : y : xs)
195 | x == y = Just x
196 | otherwise = go (y : xs)
197 go _ = Nothing
199 -- Sort a list so its elements appear in the same order as in another list.
200 inOrderOf :: (Ord a) => [a] -> [a] -> [a]
201 inOrderOf xs ys = let s = S.fromList xs in filter (`S.member` s) ys
203 buildModule :: [(ModuleName, (C.MVar (Maybe (MultipleErrors, ExternsFile)), C.MVar (Maybe MultipleErrors)))] -> Module -> [ModuleName] -> m ()
204 buildModule barriers m@(Module _ _ moduleName _ _) deps = flip catchError (markComplete Nothing . Just) $ do
205 -- We need to wait for dependencies to be built, before checking if the current
206 -- module should be rebuilt, so the first thing to do is to wait on the
207 -- MVars for the module's dependencies.
208 mexterns <- fmap unzip . sequence <$> traverse (readMVar . fst . fromMaybe (internalError "make: no barrier") . flip lookup barriers) deps
210 case mexterns of
211 Just (_, externs) -> do
212 outputTimestamp <- getOutputTimestamp moduleName
213 dependencyTimestamp <- maximumMaybe <$> traverse (fmap shouldExist . getOutputTimestamp) deps
214 inputTimestamp <- getInputTimestamp moduleName
216 let shouldRebuild = case (inputTimestamp, dependencyTimestamp, outputTimestamp) of
217 (Right (Just t1), Just t3, Just t2) -> t1 > t2 || t3 > t2
218 (Right (Just t1), Nothing, Just t2) -> t1 > t2
219 (Left RebuildNever, _, Just _) -> False
220 _ -> True
222 let rebuild = do
223 (exts, warnings) <- listen $ do
224 progress $ CompilingModule moduleName
225 let env = foldl' (flip applyExternsFileToEnvironment) initEnvironment externs
226 lint m
227 ((checked@(Module ss coms _ elaborated exps), env'), nextVar) <- runSupplyT 0 $ do
228 [desugared] <- desugar externs [m]
229 runCheck' env $ typeCheckModule desugared
230 checkExhaustiveModule env' checked
231 regrouped <- createBindingGroups moduleName . collapseBindingGroups $ elaborated
232 let mod' = Module ss coms moduleName regrouped exps
233 corefn = CF.moduleToCoreFn env' mod'
234 [renamed] = renameInModules [corefn]
235 exts = moduleToExternsFile mod' env'
236 evalSupplyT nextVar . codegen renamed env' . BU8.toString . B.toStrict . encode $ exts
237 return exts
238 markComplete (Just (warnings, exts)) Nothing
240 if shouldRebuild
241 then rebuild
242 else do
243 mexts <- decodeExterns . snd <$> readExterns moduleName
244 case mexts of
245 Just exts -> markComplete (Just (mempty, exts)) Nothing
246 Nothing -> rebuild
247 Nothing -> markComplete Nothing Nothing
248 where
249 markComplete :: Maybe (MultipleErrors, ExternsFile) -> Maybe MultipleErrors -> m ()
250 markComplete externs errors = do
251 putMVar (fst $ fromMaybe (internalError "make: no barrier") $ lookup moduleName barriers) externs
252 putMVar (snd $ fromMaybe (internalError "make: no barrier") $ lookup moduleName barriers) errors
254 maximumMaybe :: (Ord a) => [a] -> Maybe a
255 maximumMaybe [] = Nothing
256 maximumMaybe xs = Just $ maximum xs
258 -- Make sure a dependency exists
259 shouldExist :: Maybe UTCTime -> UTCTime
260 shouldExist (Just t) = t
261 shouldExist _ = internalError "make: dependency should already have been built."
263 decodeExterns :: Externs -> Maybe ExternsFile
264 decodeExterns bs = do
265 externs <- decode (fromString bs)
266 guard $ efVersion externs == showVersion Paths.version
267 return externs
269importPrim :: Module -> Module
270importPrim = addDefaultImport (ModuleName [ProperName C.prim])
272-- |
273-- A monad for running make actions
274--
275newtype Make a = Make { unMake :: ReaderT Options (ExceptT MultipleErrors (Logger MultipleErrors)) a }
276 deriving (Functor, Applicative, Monad, MonadIO, MonadError MultipleErrors, MonadWriter MultipleErrors, MonadReader Options)
278instance MonadBase IO Make where
279 liftBase = liftIO
281instance MonadBaseControl IO Make where
282 type StM Make a = Either MultipleErrors a
283 liftBaseWith f = Make $ liftBaseWith $ \q -> f (q . unMake)
284 restoreM = Make . restoreM
286-- |
287-- Execute a 'Make' monad, returning either errors, or the result of the compile plus any warnings.
288--
289runMake :: Options -> Make a -> IO (Either MultipleErrors a, MultipleErrors)
290runMake opts = runLogger' . runExceptT . flip runReaderT opts . unMake
292makeIO :: (IOError -> ErrorMessage) -> IO a -> Make a
293makeIO f io = do
294 e <- liftIO $ tryIOError io
295 either (throwError . singleError . f) return e
297-- Traverse (Either e) instance (base 4.7)
298traverseEither :: Applicative f => (a -> f b) -> Either e a -> f (Either e b)
299traverseEither _ (Left x) = pure (Left x)
300traverseEither f (Right y) = Right <$> f y
302-- |
303-- A set of make actions that read and write modules from the given directory.
304--
305buildMakeActions :: FilePath -- ^ the output directory
306 -> M.Map ModuleName (Either RebuildPolicy FilePath) -- ^ a map between module names and paths to the file containing the PureScript module
307 -> M.Map ModuleName FilePath -- ^ a map between module name and the file containing the foreign javascript for the module
308 -> Bool -- ^ Generate a prefix comment?
309 -> MakeActions Make
310buildMakeActions outputDir filePathMap foreigns usePrefix =
311 MakeActions getInputTimestamp getOutputTimestamp readExterns codegen progress
312 where
314 getInputTimestamp :: ModuleName -> Make (Either RebuildPolicy (Maybe UTCTime))
315 getInputTimestamp mn = do
316 let path = fromMaybe (internalError "Module has no filename in 'make'") $ M.lookup mn filePathMap
317 e1 <- traverseEither getTimestamp path
318 fPath <- maybe (return Nothing) getTimestamp $ M.lookup mn foreigns
319 return $ fmap (max fPath) e1
321 getOutputTimestamp :: ModuleName -> Make (Maybe UTCTime)
322 getOutputTimestamp mn = do
323 let filePath = runModuleName mn
324 jsFile = outputDir </> filePath </> "index.js"
325 externsFile = outputDir </> filePath </> "externs.json"
326 min <$> getTimestamp jsFile <*> getTimestamp externsFile
328 readExterns :: ModuleName -> Make (FilePath, Externs)
329 readExterns mn = do
330 let path = outputDir </> runModuleName mn </> "externs.json"
331 (path, ) <$> readTextFile path
333 codegen :: CF.Module CF.Ann -> Environment -> Externs -> SupplyT Make ()
334 codegen m _ exts = do
335 let mn = CF.moduleName m
336 foreignInclude <- case mn `M.lookup` foreigns of
337 Just path
338 | not $ requiresForeign m -> do
339 tell $ errorMessage $ UnnecessaryFFIModule mn path
340 return Nothing
341 | otherwise -> do
342 checkForeignDecls m path
343 return $ Just $ J.JSApp Nothing (J.JSVar Nothing "require") [J.JSStringLiteral Nothing "./foreign"]
344 Nothing | requiresForeign m -> throwError . errorMessage $ MissingFFIModule mn
345 | otherwise -> return Nothing
346 rawJs <- J.moduleToJs m foreignInclude
347 dir <- lift $ makeIO (const (ErrorMessage [] $ CannotGetFileInfo ".")) getCurrentDirectory
348 sourceMaps <- lift $ asks optionsSourceMaps
349 let (pjs, mappings) = if sourceMaps then prettyPrintJSWithSourceMaps rawJs else (prettyPrintJS rawJs, [])
350 let filePath = runModuleName mn
351 jsFile = outputDir </> filePath </> "index.js"
352 mapFile = outputDir </> filePath </> "index.js.map"
353 externsFile = outputDir </> filePath </> "externs.json"
354 foreignFile = outputDir </> filePath </> "foreign.js"
355 prefix = ["Generated by psc version " ++ showVersion Paths.version | usePrefix]
356 js = unlines $ map ("// " ++) prefix ++ [pjs]
357 mapRef = if sourceMaps then "//# sourceMappingURL=index.js.map\n" else ""
358 lift $ do
359 writeTextFile jsFile (fromString $ js ++ mapRef)
360 for_ (mn `M.lookup` foreigns) (readTextFile >=> writeTextFile foreignFile)
361 writeTextFile externsFile exts
362 lift $ when sourceMaps $ genSourceMap dir mapFile (length prefix) mappings
364 genSourceMap :: String -> String -> Int -> [SMap] -> Make ()
365 genSourceMap dir mapFile extraLines mappings = do
366 let pathToDir = iterate (".." </>) ".." !! length (splitPath $ normalise outputDir)
367 sourceFile = case mappings of
368 ((SMap file _ _):_) -> Just $ pathToDir </> makeRelative dir file
369 _ -> Nothing
370 let rawMapping = SourceMapping { smFile = "index.js", smSourceRoot = Nothing, smMappings =
371 map (\(SMap _ orig gen) -> Mapping {
372 mapOriginal = Just $ convertPos $ add 0 (-1) orig
373 , mapSourceFile = sourceFile
374 , mapGenerated = convertPos $ add (extraLines+1) 0 gen
375 , mapName = Nothing
376 }) mappings
377 }
378 let mapping = generate rawMapping
379 writeTextFile mapFile $ BU8.toString . B.toStrict . encode $ mapping
380 where
381 add :: Int -> Int -> SourcePos -> SourcePos
382 add n m (SourcePos n' m') = SourcePos (n+n') (m+m')
384 convertPos :: SourcePos -> Pos
385 convertPos SourcePos { sourcePosLine = l, sourcePosColumn = c } =
386 Pos { posLine = fromIntegral l, posColumn = fromIntegral c }
388 requiresForeign :: CF.Module a -> Bool
389 requiresForeign = not . null . CF.moduleForeign
391 getTimestamp :: FilePath -> Make (Maybe UTCTime)
392 getTimestamp path = makeIO (const (ErrorMessage [] $ CannotGetFileInfo path)) $ do
393 exists <- doesFileExist path
394 traverse (const $ getModificationTime path) $ guard exists
396 writeTextFile :: FilePath -> String -> Make ()
397 writeTextFile path text = makeIO (const (ErrorMessage [] $ CannotWriteFile path)) $ do
398 mkdirp path
399 writeUTF8File path text
400 where
401 mkdirp :: FilePath -> IO ()
402 mkdirp = createDirectoryIfMissing True . takeDirectory
404 progress :: ProgressMessage -> Make ()
405 progress = liftIO . putStrLn . renderProgressMessage
407readTextFile :: FilePath -> Make String
408readTextFile path = makeIO (const (ErrorMessage [] $ CannotReadFile path)) $ readUTF8File path
410-- |
411-- Check that the declarations in a given PureScript module match with those
412-- in its corresponding foreign module.
413--
414checkForeignDecls :: CF.Module ann -> FilePath -> SupplyT Make ()
415checkForeignDecls m path = do
416 jsStr <- lift $ readTextFile path
417 js <- either (errorParsingModule . Bundle.UnableToParseModule) pure $ JS.parse jsStr path
419 foreignIdentsStrs <- either errorParsingModule pure $ getExps js
420 let foreignIdents =
421 either
422 (internalError . ("checkForeignDecls: unexpected idents: " ++) . show)
423 S.fromList
424 (traverse parseIdent 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 -- TODO: Handling for parenthesised operators should be removed after 0.9.
447 parseIdent :: String -> Either String Ident
448 parseIdent str = try str <|> try ("(" ++ str ++ ")")
449 where
450 try s = either (Left . show) Right $ do
451 ts <- PSParser.lex "" s
452 PSParser.runTokenParser "" (PSParser.parseIdent <* Parsec.eof) ts