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