git.iko.soy/rowtype-yoga/purescript-native
on f1dfe1e help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/Make.hs
397 lines 16 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.Monad hiding (sequence)
29import Control.Monad.Error.Class (MonadError(..))
30import Control.Monad.Writer.Class (MonadWriter(..))
31import Control.Monad.Trans.Class (MonadTrans(..))
32import Control.Monad.Trans.Except
33import Control.Monad.IO.Class
34import Control.Monad.Reader (MonadReader(..), ReaderT(..), asks)
35import Control.Monad.Logger
36import Control.Monad.Supply
37import Control.Monad.Base (MonadBase(..))
38import Control.Monad.Trans.Control (MonadBaseControl(..))
40import Control.Concurrent.Lifted as C
42import Data.List (foldl', sort)
43import Data.Maybe (fromMaybe, catMaybes)
44import Data.Time.Clock
45import Data.String (fromString)
46import Data.Foldable (for_)
47import Data.Traversable (for)
48import Data.Version (showVersion)
49import Data.Aeson (encode, decode)
50import qualified Data.ByteString.Lazy as B
51import qualified Data.ByteString.UTF8 as BU8
52import qualified Data.Set as S
53import qualified Data.Map as M
55import SourceMap.Types
56import SourceMap
58import System.Directory
59 (doesFileExist, getModificationTime, createDirectoryIfMissing, getCurrentDirectory)
60import System.FilePath ((</>), takeDirectory, makeRelative, splitPath, normalise)
61import System.IO.Error (tryIOError)
62import System.IO.UTF8 (readUTF8File, writeUTF8File)
64import Language.PureScript.Crash
65import Language.PureScript.AST
66import Language.PureScript.Externs
67import Language.PureScript.Environment
68import Language.PureScript.Errors
69import Language.PureScript.Linter
70import Language.PureScript.ModuleDependencies
71import Language.PureScript.Names
72import Language.PureScript.Options
73import Language.PureScript.Pretty
74import Language.PureScript.Pretty.Common(SMap(..))
75import Language.PureScript.Renamer
76import Language.PureScript.Sugar
77import Language.PureScript.TypeChecker
78import qualified Language.PureScript.Constants as C
80import qualified Language.PureScript.CodeGen.JS as J
81import qualified Language.PureScript.CoreFn as CF
82import qualified Paths_purescript as Paths
84-- | Progress messages from the make process
85data ProgressMessage
86 = CompilingModule ModuleName
87 deriving (Show, Read, Eq, Ord)
89-- | Render a progress message
90renderProgressMessage :: ProgressMessage -> String
91renderProgressMessage (CompilingModule mn) = "Compiling " ++ runModuleName mn
93-- | Actions that require implementations when running in "make" mode.
94--
95-- This type exists to make two things abstract:
96--
97-- * The particular backend being used (Javascript, C++11, etc.)
98--
99-- * The details of how files are read/written etc.
100--
101data MakeActions m = MakeActions {
102 -- |
103 -- Get the timestamp for the input file(s) for a module. If there are multiple
104 -- files (.purs and foreign files, for example) the timestamp should be for
105 -- the most recently modified file.
106 --
107 getInputTimestamp :: ModuleName -> m (Either RebuildPolicy (Maybe UTCTime))
108 -- |
109 -- Get the timestamp for the output files for a module. This should be the
110 -- timestamp for the oldest modified file, or Nothing if any of the required
111 -- output files are missing.
112 --
113 , getOutputTimestamp :: ModuleName -> m (Maybe UTCTime)
114 -- |
115 -- Read the externs file for a module as a string and also return the actual
116 -- path for the file.
117 , readExterns :: ModuleName -> m (FilePath, Externs)
118 -- |
119 -- Run the code generator for the module and write any required output files.
120 --
121 , codegen :: CF.Module CF.Ann -> Environment -> Externs -> SupplyT m ()
122 -- |
123 -- Respond to a progress update.
124 --
125 , progress :: ProgressMessage -> m ()
126 }
128-- |
129-- Generated code for an externs file.
130--
131type Externs = String
133-- |
134-- Determines when to rebuild a module
135--
136data RebuildPolicy
137 -- | Never rebuild this module
138 = RebuildNever
139 -- | Always rebuild this module
140 | RebuildAlways deriving (Show, Read, Eq, Ord)
142-- |
143-- Compiles in "make" mode, compiling each module separately to a js files and an externs file
144--
145-- If timestamps have not changed, the externs file can be used to provide the module's types without
146-- having to typecheck the module again.
147--
148make :: forall m. (Monad m, MonadBaseControl IO m, MonadReader Options m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
149 => MakeActions m
150 -> [Module]
151 -> m Environment
152make MakeActions{..} ms = do
153 checkModuleNamesAreUnique
155 (sorted, graph) <- sortModules ms
157 barriers <- zip (map getModuleName sorted) <$> replicateM (length ms) ((,) <$> C.newEmptyMVar <*> C.newEmptyMVar)
159 for_ sorted $ \m -> fork $ do
160 let deps = fromMaybe (internalError "make: module not found in dependency graph.") (lookup (getModuleName m) graph)
161 buildModule barriers (importPrim m) (deps `inOrderOf` map getModuleName sorted)
163 -- Wait for all threads to complete, and collect errors.
164 errors <- catMaybes <$> for barriers (takeMVar . snd . snd)
166 -- All threads have completed, rethrow any caught errors.
167 unless (null errors) $ throwError (mconcat errors)
169 -- Bundle up all the externs and return them as an Environment
170 (_, externs) <- unzip . fromMaybe (internalError "make: externs were missing but no errors reported.") . sequence <$> for barriers (takeMVar . fst . snd)
171 return $ foldl' (flip applyExternsFileToEnvironment) initEnvironment externs
173 where
174 checkModuleNamesAreUnique :: m ()
175 checkModuleNamesAreUnique =
176 case findDuplicate (map getModuleName ms) of
177 Nothing -> return ()
178 Just mn -> throwError . errorMessage $ DuplicateModuleName mn
180 -- Verify that a list of values has unique keys
181 findDuplicate :: (Ord a) => [a] -> Maybe a
182 findDuplicate = go . sort
183 where
184 go (x : y : xs)
185 | x == y = Just x
186 | otherwise = go (y : xs)
187 go _ = Nothing
189 -- Sort a list so its elements appear in the same order as in another list.
190 inOrderOf :: (Ord a) => [a] -> [a] -> [a]
191 inOrderOf xs ys = let s = S.fromList xs in filter (`S.member` s) ys
193 buildModule :: [(ModuleName, (C.MVar (Maybe (MultipleErrors, ExternsFile)), C.MVar (Maybe MultipleErrors)))] -> Module -> [ModuleName] -> m ()
194 buildModule barriers m@(Module _ _ moduleName _ _) deps = flip catchError (markComplete Nothing . Just) $ do
195 -- We need to wait for dependencies to be built, before checking if the current
196 -- module should be rebuilt, so the first thing to do is to wait on the
197 -- MVars for the module's dependencies.
198 mexterns <- fmap unzip . sequence <$> traverse (readMVar . fst . fromMaybe (internalError "make: no barrier") . flip lookup barriers) deps
200 case mexterns of
201 Just (_, externs) -> do
202 outputTimestamp <- getOutputTimestamp moduleName
203 dependencyTimestamp <- maximumMaybe <$> traverse (fmap shouldExist . getOutputTimestamp) deps
204 inputTimestamp <- getInputTimestamp moduleName
206 let shouldRebuild = case (inputTimestamp, dependencyTimestamp, outputTimestamp) of
207 (Right (Just t1), Just t3, Just t2) -> t1 > t2 || t3 > t2
208 (Right (Just t1), Nothing, Just t2) -> t1 > t2
209 (Left RebuildNever, _, Just _) -> False
210 _ -> True
212 let rebuild = do
213 (exts, warnings) <- listen $ do
214 progress $ CompilingModule moduleName
215 let env = foldl' (flip applyExternsFileToEnvironment) initEnvironment externs
216 lint m
217 ((checked@(Module ss coms _ elaborated exps), env'), nextVar) <- runSupplyT 0 $ do
218 [desugared] <- desugar externs [m]
219 runCheck' env $ typeCheckModule desugared
220 checkExhaustiveModule env' checked
221 regrouped <- createBindingGroups moduleName . collapseBindingGroups $ elaborated
222 let mod' = Module ss coms moduleName regrouped exps
223 corefn = CF.moduleToCoreFn env' mod'
224 [renamed] = renameInModules [corefn]
225 exts = moduleToExternsFile mod' env'
226 evalSupplyT nextVar . codegen renamed env' . BU8.toString . B.toStrict . encode $ exts
227 return exts
228 markComplete (Just (warnings, exts)) Nothing
230 if shouldRebuild
231 then rebuild
232 else do
233 mexts <- decodeExterns . snd <$> readExterns moduleName
234 case mexts of
235 Just exts -> markComplete (Just (mempty, exts)) Nothing
236 Nothing -> rebuild
237 Nothing -> markComplete Nothing Nothing
238 where
239 markComplete :: Maybe (MultipleErrors, ExternsFile) -> Maybe MultipleErrors -> m ()
240 markComplete externs errors = do
241 putMVar (fst $ fromMaybe (internalError "make: no barrier") $ lookup moduleName barriers) externs
242 putMVar (snd $ fromMaybe (internalError "make: no barrier") $ lookup moduleName barriers) errors
244 maximumMaybe :: (Ord a) => [a] -> Maybe a
245 maximumMaybe [] = Nothing
246 maximumMaybe xs = Just $ maximum xs
248 -- Make sure a dependency exists
249 shouldExist :: Maybe UTCTime -> UTCTime
250 shouldExist (Just t) = t
251 shouldExist _ = internalError "make: dependency should already have been built."
253 decodeExterns :: Externs -> Maybe ExternsFile
254 decodeExterns bs = do
255 externs <- decode (fromString bs)
256 guard $ efVersion externs == showVersion Paths.version
257 return externs
259importPrim :: Module -> Module
260importPrim = addDefaultImport (ModuleName [ProperName C.prim])
262-- |
263-- A monad for running make actions
264--
265newtype Make a = Make { unMake :: ReaderT Options (ExceptT MultipleErrors (Logger MultipleErrors)) a }
266 deriving (Functor, Applicative, Monad, MonadIO, MonadError MultipleErrors, MonadWriter MultipleErrors, MonadReader Options)
268instance MonadBase IO Make where
269 liftBase = liftIO
271instance MonadBaseControl IO Make where
272 type StM Make a = Either MultipleErrors a
273 liftBaseWith f = Make $ liftBaseWith $ \q -> f (q . unMake)
274 restoreM = Make . restoreM
276-- |
277-- Execute a 'Make' monad, returning either errors, or the result of the compile plus any warnings.
278--
279runMake :: Options -> Make a -> IO (Either MultipleErrors a, MultipleErrors)
280runMake opts = runLogger' . runExceptT . flip runReaderT opts . unMake
282makeIO :: (IOError -> ErrorMessage) -> IO a -> Make a
283makeIO f io = do
284 e <- liftIO $ tryIOError io
285 either (throwError . singleError . f) return e
287-- Traverse (Either e) instance (base 4.7)
288traverseEither :: Applicative f => (a -> f b) -> Either e a -> f (Either e b)
289traverseEither _ (Left x) = pure (Left x)
290traverseEither f (Right y) = Right <$> f y
292-- |
293-- A set of make actions that read and write modules from the given directory.
294--
295buildMakeActions :: FilePath -- ^ the output directory
296 -> M.Map ModuleName (Either RebuildPolicy FilePath) -- ^ a map between module names and paths to the file containing the PureScript module
297 -> M.Map ModuleName FilePath -- ^ a map between module name and the file containing the foreign javascript for the module
298 -> Bool -- ^ Generate a prefix comment?
299 -> MakeActions Make
300buildMakeActions outputDir filePathMap foreigns usePrefix =
301 MakeActions getInputTimestamp getOutputTimestamp readExterns codegen progress
302 where
304 getInputTimestamp :: ModuleName -> Make (Either RebuildPolicy (Maybe UTCTime))
305 getInputTimestamp mn = do
306 let path = fromMaybe (internalError "Module has no filename in 'make'") $ M.lookup mn filePathMap
307 e1 <- traverseEither getTimestamp path
308 fPath <- maybe (return Nothing) getTimestamp $ M.lookup mn foreigns
309 return $ fmap (max fPath) e1
311 getOutputTimestamp :: ModuleName -> Make (Maybe UTCTime)
312 getOutputTimestamp mn = do
313 let filePath = runModuleName mn
314 jsFile = outputDir </> filePath </> "index.js"
315 externsFile = outputDir </> filePath </> "externs.json"
316 min <$> getTimestamp jsFile <*> getTimestamp externsFile
318 readExterns :: ModuleName -> Make (FilePath, Externs)
319 readExterns mn = do
320 let path = outputDir </> runModuleName mn </> "externs.json"
321 (path, ) <$> readTextFile path
323 codegen :: CF.Module CF.Ann -> Environment -> Externs -> SupplyT Make ()
324 codegen m _ exts = do
325 let mn = CF.moduleName m
326 foreignInclude <- case mn `M.lookup` foreigns of
327 Just path
328 | not $ requiresForeign m -> do
329 tell $ errorMessage $ UnnecessaryFFIModule mn path
330 return Nothing
331 | otherwise -> return $ Just $ J.JSApp Nothing (J.JSVar Nothing "require") [J.JSStringLiteral Nothing "./foreign"]
332 Nothing | requiresForeign m -> throwError . errorMessage $ MissingFFIModule mn
333 | otherwise -> return Nothing
334 rawJs <- J.moduleToJs m foreignInclude
335 dir <- lift $ makeIO (const (ErrorMessage [] $ CannotGetFileInfo ".")) getCurrentDirectory
336 sourceMaps <- lift $ asks optionsSourceMaps
337 let (pjs, mappings) = if sourceMaps then prettyPrintJSWithSourceMaps rawJs else (prettyPrintJS rawJs, [])
338 let filePath = runModuleName mn
339 jsFile = outputDir </> filePath </> "index.js"
340 mapFile = outputDir </> filePath </> "index.js.map"
341 externsFile = outputDir </> filePath </> "externs.json"
342 foreignFile = outputDir </> filePath </> "foreign.js"
343 prefix = ["Generated by psc version " ++ showVersion Paths.version | usePrefix]
344 js = unlines $ map ("// " ++) prefix ++ [pjs]
345 mapRef = if sourceMaps then "//# sourceMappingURL=index.js.map\n" else ""
346 lift $ do
347 writeTextFile jsFile (fromString $ js ++ mapRef)
348 for_ (mn `M.lookup` foreigns) (readTextFile >=> writeTextFile foreignFile)
349 writeTextFile externsFile exts
350 lift $ when sourceMaps $ genSourceMap dir mapFile (length prefix) mappings
352 genSourceMap :: String -> String -> Int -> [SMap] -> Make ()
353 genSourceMap dir mapFile extraLines mappings = do
354 let pathToDir = iterate (".." </>) ".." !! length (splitPath $ normalise outputDir)
355 sourceFile = case mappings of
356 ((SMap file _ _):_) -> Just $ pathToDir </> makeRelative dir file
357 _ -> Nothing
358 let rawMapping = SourceMapping { smFile = "index.js", smSourceRoot = Nothing, smMappings =
359 map (\(SMap _ orig gen) -> Mapping {
360 mapOriginal = Just $ convertPos $ add 0 (-1) orig
361 , mapSourceFile = sourceFile
362 , mapGenerated = convertPos $ add (extraLines+1) 0 gen
363 , mapName = Nothing
364 }) $
365 mappings
366 }
367 let mapping = generate rawMapping
368 writeTextFile mapFile $ BU8.toString . B.toStrict . encode $ mapping
369 where
370 add :: Int -> Int -> SourcePos -> SourcePos
371 add n m (SourcePos n' m') = SourcePos (n+n') (m+m')
373 convertPos :: SourcePos -> Pos
374 convertPos SourcePos { sourcePosLine = l, sourcePosColumn = c } =
375 Pos { posLine = fromIntegral l, posColumn = fromIntegral c }
377 requiresForeign :: CF.Module a -> Bool
378 requiresForeign = not . null . CF.moduleForeign
380 getTimestamp :: FilePath -> Make (Maybe UTCTime)
381 getTimestamp path = makeIO (const (ErrorMessage [] $ CannotGetFileInfo path)) $ do
382 exists <- doesFileExist path
383 traverse (const $ getModificationTime path) $ guard exists
385 readTextFile :: FilePath -> Make String
386 readTextFile path = makeIO (const (ErrorMessage [] $ CannotReadFile path)) $ readUTF8File path
388 writeTextFile :: FilePath -> String -> Make ()
389 writeTextFile path text = makeIO (const (ErrorMessage [] $ CannotWriteFile path)) $ do
390 mkdirp path
391 writeUTF8File path text
392 where
393 mkdirp :: FilePath -> IO ()
394 mkdirp = createDirectoryIfMissing True . takeDirectory
396 progress :: ProgressMessage -> Make ()
397 progress = liftIO . putStrLn . renderProgressMessage