git.iko.soy/rowtype-yoga/purescript-native
on f5548b1 help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/Make.hs
376 lines 15 kB history raw
1-----------------------------------------------------------------------------
2--
3-- Module : Make
4-- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
5-- License : MIT (http://opensource.org/licenses/MIT)
6--
7-- Maintainer : Phil Freeman <paf31@cantab.net>
8-- Stability : experimental
9-- Portability :
10--
11-- |
12--
13-----------------------------------------------------------------------------
15{-# LANGUAGE DataKinds #-}
16{-# LANGUAGE FlexibleContexts #-}
17{-# LANGUAGE GeneralizedNewtypeDeriving #-}
18{-# LANGUAGE TupleSections #-}
19{-# LANGUAGE RankNTypes #-}
20{-# LANGUAGE RecordWildCards #-}
21{-# LANGUAGE ScopedTypeVariables #-}
22{-# LANGUAGE MultiParamTypeClasses #-}
23{-# LANGUAGE TypeFamilies #-}
25module Language.PureScript.Make
26 (
27 -- * Make API
28 RebuildPolicy(..)
29 , ProgressMessage(..), renderProgressMessage
30 , MakeActions(..)
31 , Externs()
32 , make
34 -- * Implementation of Make API using files on disk
35 , Make(..)
36 , runMake
37 , buildMakeActions
38 ) where
40import Prelude ()
41import Prelude.Compat
43import Control.Monad hiding (sequence)
44import Control.Monad.Error.Class (MonadError(..))
45import Control.Monad.Writer.Class (MonadWriter(..))
46import Control.Monad.Trans.Class (MonadTrans(..))
47import Control.Monad.Trans.Except
48import Control.Monad.IO.Class
49import Control.Monad.Reader (MonadReader(..), ReaderT(..))
50import Control.Monad.Logger
51import Control.Monad.Supply
52import Control.Monad.Base (MonadBase(..))
53import Control.Monad.Trans.Control (MonadBaseControl(..))
55import Control.Concurrent.Lifted as C
57import Data.List (foldl', sort)
58import Data.Maybe (fromMaybe, catMaybes)
59import Data.Time.Clock
60import Data.String (fromString)
61import Data.Foldable (for_)
62import Data.Traversable (for)
63import Data.Version (showVersion)
64import Data.Aeson (encode, decode)
65import qualified Data.ByteString.Lazy as B
66import qualified Data.ByteString.UTF8 as BU8
67import qualified Data.Set as S
68import qualified Data.Map as M
70import System.Directory
71 (doesFileExist, getModificationTime, createDirectoryIfMissing)
72import System.FilePath ((</>), takeDirectory)
73import System.IO.Error (tryIOError)
74import System.IO.UTF8 (readUTF8File, writeUTF8File)
76import Language.PureScript.Crash
77import Language.PureScript.AST
78import Language.PureScript.Externs
79import Language.PureScript.Environment
80import Language.PureScript.Errors
81import Language.PureScript.Linter
82import Language.PureScript.ModuleDependencies
83import Language.PureScript.Names
84import Language.PureScript.Options
85import Language.PureScript.Pretty
86import Language.PureScript.Renamer
87import Language.PureScript.Sugar
88import Language.PureScript.TypeChecker
89import qualified Language.PureScript.Constants as C
91import qualified Language.PureScript.CodeGen.JS as J
92import qualified Language.PureScript.CoreFn as CF
93import qualified Paths_purescript as Paths
95-- | Progress messages from the make process
96data ProgressMessage
97 = CompilingModule ModuleName
98 deriving (Show, Read, Eq, Ord)
100-- | Render a progress message
101renderProgressMessage :: ProgressMessage -> String
102renderProgressMessage (CompilingModule mn) = "Compiling " ++ runModuleName mn
104-- | Actions that require implementations when running in "make" mode.
105--
106-- This type exists to make two things abstract:
107--
108-- * The particular backend being used (Javascript, C++11, etc.)
109--
110-- * The details of how files are read/written etc.
111--
112data MakeActions m = MakeActions {
113 -- |
114 -- Get the timestamp for the input file(s) for a module. If there are multiple
115 -- files (.purs and foreign files, for example) the timestamp should be for
116 -- the most recently modified file.
117 --
118 getInputTimestamp :: ModuleName -> m (Either RebuildPolicy (Maybe UTCTime))
119 -- |
120 -- Get the timestamp for the output files for a module. This should be the
121 -- timestamp for the oldest modified file, or Nothing if any of the required
122 -- output files are missing.
123 --
124 , getOutputTimestamp :: ModuleName -> m (Maybe UTCTime)
125 -- |
126 -- Read the externs file for a module as a string and also return the actual
127 -- path for the file.
128 , readExterns :: ModuleName -> m (FilePath, Externs)
129 -- |
130 -- Run the code generator for the module and write any required output files.
131 --
132 , codegen :: CF.Module CF.Ann -> Environment -> Externs -> SupplyT m ()
133 -- |
134 -- Respond to a progress update.
135 --
136 , progress :: ProgressMessage -> m ()
137 }
139-- |
140-- Generated code for an externs file.
141--
142type Externs = String
144-- |
145-- Determines when to rebuild a module
146--
147data RebuildPolicy
148 -- | Never rebuild this module
149 = RebuildNever
150 -- | Always rebuild this module
151 | RebuildAlways deriving (Show, Read, Eq, Ord)
153-- |
154-- Compiles in "make" mode, compiling each module separately to a js files and an externs file
155--
156-- If timestamps have not changed, the externs file can be used to provide the module's types without
157-- having to typecheck the module again.
158--
159make :: forall m. (Functor m, Applicative m, Monad m, MonadBaseControl IO m, MonadReader Options m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
160 => MakeActions m
161 -> [Module]
162 -> m Environment
163make MakeActions{..} ms = do
164 checkModuleNamesAreUnique
166 (sorted, graph) <- sortModules ms
168 barriers <- zip (map getModuleName sorted) <$> replicateM (length ms) ((,) <$> C.newEmptyMVar <*> C.newEmptyMVar)
170 for_ sorted $ \m -> fork $ do
171 let deps = fromMaybe (internalError "make: module not found in dependency graph.") (lookup (getModuleName m) graph)
172 buildModule barriers (importPrim m) (deps `inOrderOf` map getModuleName sorted)
174 -- Wait for all threads to complete, and collect errors.
175 errors <- catMaybes <$> for barriers (takeMVar . snd . snd)
177 -- All threads have completed, rethrow any caught errors.
178 unless (null errors) $ throwError (mconcat errors)
180 -- Bundle up all the externs and return them as an Environment
181 (_, externs) <- unzip . fromMaybe (internalError "make: externs were missing but no errors reported.") . sequence <$> for barriers (takeMVar . fst . snd)
182 return $ foldl' (flip applyExternsFileToEnvironment) initEnvironment externs
184 where
185 checkModuleNamesAreUnique :: m ()
186 checkModuleNamesAreUnique =
187 case findDuplicate (map getModuleName ms) of
188 Nothing -> return ()
189 Just mn -> throwError . errorMessage $ DuplicateModuleName mn
191 -- Verify that a list of values has unique keys
192 findDuplicate :: (Ord a) => [a] -> Maybe a
193 findDuplicate = go . sort
194 where
195 go (x : y : xs)
196 | x == y = Just x
197 | otherwise = go (y : xs)
198 go _ = Nothing
200 -- Sort a list so its elements appear in the same order as in another list.
201 inOrderOf :: (Ord a) => [a] -> [a] -> [a]
202 inOrderOf xs ys = let s = S.fromList xs in filter (`S.member` s) ys
204 buildModule :: [(ModuleName, (C.MVar (Maybe (MultipleErrors, ExternsFile)), C.MVar (Maybe MultipleErrors)))] -> Module -> [ModuleName] -> m ()
205 buildModule barriers m@(Module _ _ moduleName _ _) deps = flip catchError (markComplete Nothing . Just) $ do
206 -- We need to wait for dependencies to be built, before checking if the current
207 -- module should be rebuilt, so the first thing to do is to wait on the
208 -- MVars for the module's dependencies.
209 mexterns <- fmap unzip . sequence <$> traverse (readMVar . fst . fromMaybe (internalError "make: no barrier") . flip lookup barriers) deps
211 case mexterns of
212 Just (_, externs) -> do
213 outputTimestamp <- getOutputTimestamp moduleName
214 dependencyTimestamp <- maximumMaybe <$> traverse (fmap shouldExist . getOutputTimestamp) deps
215 inputTimestamp <- getInputTimestamp moduleName
217 let shouldRebuild = case (inputTimestamp, dependencyTimestamp, outputTimestamp) of
218 (Right (Just t1), Just t3, Just t2) -> t1 > t2 || t3 > t2
219 (Right (Just t1), Nothing, Just t2) -> t1 > t2
220 (Left RebuildNever, _, Just _) -> False
221 _ -> True
223 let rebuild = do
224 (exts, warnings) <- listen $ do
225 progress $ CompilingModule moduleName
226 let env = foldl' (flip applyExternsFileToEnvironment) initEnvironment externs
227 lint m
228 ([desugared], nextVar) <- runSupplyT 0 $ desugar externs [m]
229 (checked@(Module ss coms _ elaborated exps), env') <- 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 -> return $ Just $ J.JSApp (J.JSVar "require") [J.JSStringLiteral "./foreign"]
342 Nothing | requiresForeign m -> throwError . errorMessage $ MissingFFIModule mn
343 | otherwise -> return Nothing
344 pjs <- prettyPrintJS <$> J.moduleToJs m foreignInclude
345 let filePath = runModuleName mn
346 jsFile = outputDir </> filePath </> "index.js"
347 externsFile = outputDir </> filePath </> "externs.json"
348 foreignFile = outputDir </> filePath </> "foreign.js"
349 prefix = ["Generated by psc version " ++ showVersion Paths.version | usePrefix]
350 js = unlines $ map ("// " ++) prefix ++ [pjs]
351 lift $ do
352 writeTextFile jsFile (fromString js)
353 for_ (mn `M.lookup` foreigns) (readTextFile >=> writeTextFile foreignFile)
354 writeTextFile externsFile exts
356 requiresForeign :: CF.Module a -> Bool
357 requiresForeign = not . null . CF.moduleForeign
359 getTimestamp :: FilePath -> Make (Maybe UTCTime)
360 getTimestamp path = makeIO (const (ErrorMessage [] $ CannotGetFileInfo path)) $ do
361 exists <- doesFileExist path
362 traverse (const $ getModificationTime path) $ guard exists
364 readTextFile :: FilePath -> Make String
365 readTextFile path = makeIO (const (ErrorMessage [] $ CannotReadFile path)) $ readUTF8File path
367 writeTextFile :: FilePath -> String -> Make ()
368 writeTextFile path text = makeIO (const (ErrorMessage [] $ CannotWriteFile path)) $ do
369 mkdirp path
370 writeUTF8File path text
371 where
372 mkdirp :: FilePath -> IO ()
373 mkdirp = createDirectoryIfMissing True . takeDirectory
375 progress :: ProgressMessage -> Make ()
376 progress = liftIO . putStrLn . renderProgressMessage