git.iko.soy/rowtype-yoga/purescript-native
on d5d0adf help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/Make.hs
362 lines 14 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(..))
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 System.Directory
56 (doesFileExist, getModificationTime, createDirectoryIfMissing)
57import System.FilePath ((</>), takeDirectory)
58import System.IO.Error (tryIOError)
59import System.IO.UTF8 (readUTF8File, writeUTF8File)
61import Language.PureScript.Crash
62import Language.PureScript.AST
63import Language.PureScript.Externs
64import Language.PureScript.Environment
65import Language.PureScript.Errors
66import Language.PureScript.Linter
67import Language.PureScript.ModuleDependencies
68import Language.PureScript.Names
69import Language.PureScript.Options
70import Language.PureScript.Pretty
71import Language.PureScript.Renamer
72import Language.PureScript.Sugar
73import Language.PureScript.TypeChecker
74import qualified Language.PureScript.Constants as C
76import qualified Language.PureScript.CodeGen.JS as J
77import qualified Language.PureScript.CoreFn as CF
78import qualified Paths_purescript as Paths
80-- | Progress messages from the make process
81data ProgressMessage
82 = CompilingModule ModuleName
83 deriving (Show, Read, Eq, Ord)
85-- | Render a progress message
86renderProgressMessage :: ProgressMessage -> String
87renderProgressMessage (CompilingModule mn) = "Compiling " ++ runModuleName mn
89-- | Actions that require implementations when running in "make" mode.
90--
91-- This type exists to make two things abstract:
92--
93-- * The particular backend being used (Javascript, C++11, etc.)
94--
95-- * The details of how files are read/written etc.
96--
97data MakeActions m = MakeActions {
98 -- |
99 -- Get the timestamp for the input file(s) for a module. If there are multiple
100 -- files (.purs and foreign files, for example) the timestamp should be for
101 -- the most recently modified file.
102 --
103 getInputTimestamp :: ModuleName -> m (Either RebuildPolicy (Maybe UTCTime))
104 -- |
105 -- Get the timestamp for the output files for a module. This should be the
106 -- timestamp for the oldest modified file, or Nothing if any of the required
107 -- output files are missing.
108 --
109 , getOutputTimestamp :: ModuleName -> m (Maybe UTCTime)
110 -- |
111 -- Read the externs file for a module as a string and also return the actual
112 -- path for the file.
113 , readExterns :: ModuleName -> m (FilePath, Externs)
114 -- |
115 -- Run the code generator for the module and write any required output files.
116 --
117 , codegen :: CF.Module CF.Ann -> Environment -> Externs -> SupplyT m ()
118 -- |
119 -- Respond to a progress update.
120 --
121 , progress :: ProgressMessage -> m ()
122 }
124-- |
125-- Generated code for an externs file.
126--
127type Externs = String
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, Read, Eq, Ord)
138-- |
139-- Compiles in "make" mode, compiling each module separately to a js files and an externs file
140--
141-- If timestamps have not changed, the externs file can be used to provide the module's types without
142-- having to typecheck the module again.
143--
144make :: forall m. (Functor m, Applicative m, Monad m, MonadBaseControl IO m, MonadReader Options m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
145 => MakeActions m
146 -> [Module]
147 -> m Environment
148make MakeActions{..} ms = do
149 checkModuleNamesAreUnique
151 (sorted, graph) <- sortModules ms
153 barriers <- zip (map getModuleName sorted) <$> replicateM (length ms) ((,) <$> C.newEmptyMVar <*> C.newEmptyMVar)
155 for_ sorted $ \m -> fork $ do
156 let deps = fromMaybe (internalError "make: module not found in dependency graph.") (lookup (getModuleName m) graph)
157 buildModule barriers (importPrim m) (deps `inOrderOf` map getModuleName sorted)
159 -- Wait for all threads to complete, and collect errors.
160 errors <- catMaybes <$> for barriers (takeMVar . snd . snd)
162 -- All threads have completed, rethrow any caught errors.
163 unless (null errors) $ throwError (mconcat errors)
165 -- Bundle up all the externs and return them as an Environment
166 (_, externs) <- unzip . fromMaybe (internalError "make: externs were missing but no errors reported.") . sequence <$> for barriers (takeMVar . fst . snd)
167 return $ foldl' (flip applyExternsFileToEnvironment) initEnvironment externs
169 where
170 checkModuleNamesAreUnique :: m ()
171 checkModuleNamesAreUnique =
172 case findDuplicate (map getModuleName ms) of
173 Nothing -> return ()
174 Just mn -> throwError . errorMessage $ DuplicateModuleName mn
176 -- Verify that a list of values has unique keys
177 findDuplicate :: (Ord a) => [a] -> Maybe a
178 findDuplicate = go . sort
179 where
180 go (x : y : xs)
181 | x == y = Just x
182 | otherwise = go (y : xs)
183 go _ = Nothing
185 -- Sort a list so its elements appear in the same order as in another list.
186 inOrderOf :: (Ord a) => [a] -> [a] -> [a]
187 inOrderOf xs ys = let s = S.fromList xs in filter (`S.member` s) ys
189 buildModule :: [(ModuleName, (C.MVar (Maybe (MultipleErrors, ExternsFile)), C.MVar (Maybe MultipleErrors)))] -> Module -> [ModuleName] -> m ()
190 buildModule barriers m@(Module _ _ moduleName _ _) deps = flip catchError (markComplete Nothing . Just) $ do
191 -- We need to wait for dependencies to be built, before checking if the current
192 -- module should be rebuilt, so the first thing to do is to wait on the
193 -- MVars for the module's dependencies.
194 mexterns <- fmap unzip . sequence <$> traverse (readMVar . fst . fromMaybe (internalError "make: no barrier") . flip lookup barriers) deps
196 case mexterns of
197 Just (_, externs) -> do
198 outputTimestamp <- getOutputTimestamp moduleName
199 dependencyTimestamp <- maximumMaybe <$> traverse (fmap shouldExist . getOutputTimestamp) deps
200 inputTimestamp <- getInputTimestamp moduleName
202 let shouldRebuild = case (inputTimestamp, dependencyTimestamp, outputTimestamp) of
203 (Right (Just t1), Just t3, Just t2) -> t1 > t2 || t3 > t2
204 (Right (Just t1), Nothing, Just t2) -> t1 > t2
205 (Left RebuildNever, _, Just _) -> False
206 _ -> True
208 let rebuild = do
209 (exts, warnings) <- listen $ do
210 progress $ CompilingModule moduleName
211 let env = foldl' (flip applyExternsFileToEnvironment) initEnvironment externs
212 lint m
213 ((checked@(Module ss coms _ elaborated exps), env'), nextVar) <- runSupplyT 0 $ do
214 [desugared] <- desugar externs [m]
215 runCheck' env $ typeCheckModule desugared
216 checkExhaustiveModule env' checked
217 regrouped <- createBindingGroups moduleName . collapseBindingGroups $ elaborated
218 let mod' = Module ss coms moduleName regrouped exps
219 corefn = CF.moduleToCoreFn env' mod'
220 [renamed] = renameInModules [corefn]
221 exts = moduleToExternsFile mod' env'
222 evalSupplyT nextVar . codegen renamed env' . BU8.toString . B.toStrict . encode $ exts
223 return exts
224 markComplete (Just (warnings, exts)) Nothing
226 if shouldRebuild
227 then rebuild
228 else do
229 mexts <- decodeExterns . snd <$> readExterns moduleName
230 case mexts of
231 Just exts -> markComplete (Just (mempty, exts)) Nothing
232 Nothing -> rebuild
233 Nothing -> markComplete Nothing Nothing
234 where
235 markComplete :: Maybe (MultipleErrors, ExternsFile) -> Maybe MultipleErrors -> m ()
236 markComplete externs errors = do
237 putMVar (fst $ fromMaybe (internalError "make: no barrier") $ lookup moduleName barriers) externs
238 putMVar (snd $ fromMaybe (internalError "make: no barrier") $ lookup moduleName barriers) errors
240 maximumMaybe :: (Ord a) => [a] -> Maybe a
241 maximumMaybe [] = Nothing
242 maximumMaybe xs = Just $ maximum xs
244 -- Make sure a dependency exists
245 shouldExist :: Maybe UTCTime -> UTCTime
246 shouldExist (Just t) = t
247 shouldExist _ = internalError "make: dependency should already have been built."
249 decodeExterns :: Externs -> Maybe ExternsFile
250 decodeExterns bs = do
251 externs <- decode (fromString bs)
252 guard $ efVersion externs == showVersion Paths.version
253 return externs
255importPrim :: Module -> Module
256importPrim = addDefaultImport (ModuleName [ProperName C.prim])
258-- |
259-- A monad for running make actions
260--
261newtype Make a = Make { unMake :: ReaderT Options (ExceptT MultipleErrors (Logger MultipleErrors)) a }
262 deriving (Functor, Applicative, Monad, MonadIO, MonadError MultipleErrors, MonadWriter MultipleErrors, MonadReader Options)
264instance MonadBase IO Make where
265 liftBase = liftIO
267instance MonadBaseControl IO Make where
268 type StM Make a = Either MultipleErrors a
269 liftBaseWith f = Make $ liftBaseWith $ \q -> f (q . unMake)
270 restoreM = Make . restoreM
272-- |
273-- Execute a 'Make' monad, returning either errors, or the result of the compile plus any warnings.
274--
275runMake :: Options -> Make a -> IO (Either MultipleErrors a, MultipleErrors)
276runMake opts = runLogger' . runExceptT . flip runReaderT opts . unMake
278makeIO :: (IOError -> ErrorMessage) -> IO a -> Make a
279makeIO f io = do
280 e <- liftIO $ tryIOError io
281 either (throwError . singleError . f) return e
283-- Traverse (Either e) instance (base 4.7)
284traverseEither :: Applicative f => (a -> f b) -> Either e a -> f (Either e b)
285traverseEither _ (Left x) = pure (Left x)
286traverseEither f (Right y) = Right <$> f y
288-- |
289-- A set of make actions that read and write modules from the given directory.
290--
291buildMakeActions :: FilePath -- ^ the output directory
292 -> M.Map ModuleName (Either RebuildPolicy FilePath) -- ^ a map between module names and paths to the file containing the PureScript module
293 -> M.Map ModuleName FilePath -- ^ a map between module name and the file containing the foreign javascript for the module
294 -> Bool -- ^ Generate a prefix comment?
295 -> MakeActions Make
296buildMakeActions outputDir filePathMap foreigns usePrefix =
297 MakeActions getInputTimestamp getOutputTimestamp readExterns codegen progress
298 where
300 getInputTimestamp :: ModuleName -> Make (Either RebuildPolicy (Maybe UTCTime))
301 getInputTimestamp mn = do
302 let path = fromMaybe (internalError "Module has no filename in 'make'") $ M.lookup mn filePathMap
303 e1 <- traverseEither getTimestamp path
304 fPath <- maybe (return Nothing) getTimestamp $ M.lookup mn foreigns
305 return $ fmap (max fPath) e1
307 getOutputTimestamp :: ModuleName -> Make (Maybe UTCTime)
308 getOutputTimestamp mn = do
309 let filePath = runModuleName mn
310 jsFile = outputDir </> filePath </> "index.js"
311 externsFile = outputDir </> filePath </> "externs.json"
312 min <$> getTimestamp jsFile <*> getTimestamp externsFile
314 readExterns :: ModuleName -> Make (FilePath, Externs)
315 readExterns mn = do
316 let path = outputDir </> runModuleName mn </> "externs.json"
317 (path, ) <$> readTextFile path
319 codegen :: CF.Module CF.Ann -> Environment -> Externs -> SupplyT Make ()
320 codegen m _ exts = do
321 let mn = CF.moduleName m
322 foreignInclude <- case mn `M.lookup` foreigns of
323 Just path
324 | not $ requiresForeign m -> do
325 tell $ errorMessage $ UnnecessaryFFIModule mn path
326 return Nothing
327 | otherwise -> return $ Just $ J.JSApp (J.JSVar "require") [J.JSStringLiteral "./foreign"]
328 Nothing | requiresForeign m -> throwError . errorMessage $ MissingFFIModule mn
329 | otherwise -> return Nothing
330 pjs <- prettyPrintJS <$> J.moduleToJs m foreignInclude
331 let filePath = runModuleName mn
332 jsFile = outputDir </> filePath </> "index.js"
333 externsFile = outputDir </> filePath </> "externs.json"
334 foreignFile = outputDir </> filePath </> "foreign.js"
335 prefix = ["Generated by psc version " ++ showVersion Paths.version | usePrefix]
336 js = unlines $ map ("// " ++) prefix ++ [pjs]
337 lift $ do
338 writeTextFile jsFile (fromString js)
339 for_ (mn `M.lookup` foreigns) (readTextFile >=> writeTextFile foreignFile)
340 writeTextFile externsFile exts
342 requiresForeign :: CF.Module a -> Bool
343 requiresForeign = not . null . CF.moduleForeign
345 getTimestamp :: FilePath -> Make (Maybe UTCTime)
346 getTimestamp path = makeIO (const (ErrorMessage [] $ CannotGetFileInfo path)) $ do
347 exists <- doesFileExist path
348 traverse (const $ getModificationTime path) $ guard exists
350 readTextFile :: FilePath -> Make String
351 readTextFile path = makeIO (const (ErrorMessage [] $ CannotReadFile path)) $ readUTF8File path
353 writeTextFile :: FilePath -> String -> Make ()
354 writeTextFile path text = makeIO (const (ErrorMessage [] $ CannotWriteFile path)) $ do
355 mkdirp path
356 writeUTF8File path text
357 where
358 mkdirp :: FilePath -> IO ()
359 mkdirp = createDirectoryIfMissing True . takeDirectory
361 progress :: ProgressMessage -> Make ()
362 progress = liftIO . putStrLn . renderProgressMessage