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