git.iko.soy/rowtype-yoga/purescript-native
on b3bb653 help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/Make.hs
389 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 #-}
24{-# LANGUAGE CPP #-}
26module Language.PureScript.Make
27 (
28 -- * Make API
29 RebuildPolicy(..)
30 , ProgressMessage(..), renderProgressMessage
31 , MakeActions(..)
32 , Externs()
33 , make
35 -- * Implementation of Make API using files on disk
36 , Make(..)
37 , runMake
38 , buildMakeActions
39 ) where
41#if __GLASGOW_HASKELL__ < 710
42import Control.Applicative
43#endif
44import Control.Monad
45import Control.Monad.Error.Class (MonadError(..))
46import Control.Monad.Writer.Class (MonadWriter(..))
47import Control.Monad.Trans.Except
48import Control.Monad.Reader
49import Control.Monad.Logger
50import Control.Monad.Supply
51import Control.Monad.Base (MonadBase(..))
52import Control.Monad.Trans.Control (MonadBaseControl(..))
54import Control.Concurrent.Lifted as C
56import Data.List (foldl', sort)
57import Data.Maybe (fromMaybe, catMaybes)
58import Data.Time.Clock
59import Data.String (fromString)
60import Data.Foldable (for_)
61#if __GLASGOW_HASKELL__ < 710
62import Data.Traversable (traverse)
63#endif
64import Data.Traversable (for)
65import Data.Version (showVersion)
66import Data.Aeson (encode, decode)
67import qualified Data.ByteString.Lazy as B
68import qualified Data.Set as S
69import qualified Data.Map as M
71import System.Directory
72 (doesFileExist, getModificationTime, createDirectoryIfMissing)
73import System.FilePath ((</>), takeDirectory)
74import System.IO.Error (tryIOError)
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, B.ByteString)
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 = B.ByteString
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 (warnings, externs) <- unzip . fromMaybe (internalError "make: externs were missing but no errors reported.") . sequence <$> for barriers (takeMVar . fst . snd)
182 tell (mconcat warnings)
183 return $ foldl' (flip applyExternsFileToEnvironment) initEnvironment externs
185 where
186 checkModuleNamesAreUnique :: m ()
187 checkModuleNamesAreUnique =
188 case findDuplicate (map getModuleName ms) of
189 Nothing -> return ()
190 Just mn -> throwError . errorMessage $ DuplicateModuleName mn
192 -- Verify that a list of values has unique keys
193 findDuplicate :: (Ord a) => [a] -> Maybe a
194 findDuplicate = go . sort
195 where
196 go (x : y : xs)
197 | x == y = Just x
198 | otherwise = go (y : xs)
199 go _ = Nothing
201 -- Sort a list so its elements appear in the same order as in another list.
202 inOrderOf :: (Ord a) => [a] -> [a] -> [a]
203 inOrderOf xs ys = let s = S.fromList xs in filter (`S.member` s) ys
205 buildModule :: [(ModuleName, (C.MVar (Maybe (MultipleErrors, ExternsFile)), C.MVar (Maybe MultipleErrors)))] -> Module -> [ModuleName] -> m ()
206 buildModule barriers m@(Module _ _ moduleName _ _) deps = flip catchError (markComplete Nothing . Just) $ do
207 -- We need to wait for dependencies to be built, before checking if the current
208 -- module should be rebuilt, so the first thing to do is to wait on the
209 -- MVars for the module's dependencies.
210 mexterns <- fmap unzip . sequence <$> mapM (readMVar . fst . fromMaybe (internalError "make: no barrier") . flip lookup barriers) deps
212 case mexterns of
213 Just (_, externs) -> do
214 outputTimestamp <- getOutputTimestamp moduleName
215 dependencyTimestamp <- maximumMaybe <$> mapM (fmap shouldExist . getOutputTimestamp) deps
216 inputTimestamp <- getInputTimestamp moduleName
218 let shouldRebuild = case (inputTimestamp, dependencyTimestamp, outputTimestamp) of
219 (Right (Just t1), Just t3, Just t2) -> t1 > t2 || t3 > t2
220 (Right (Just t1), Nothing, Just t2) -> t1 > t2
221 (Left RebuildNever, _, Just _) -> False
222 _ -> True
224 let rebuild = do
225 (exts, warnings) <- listen $ do
226 progress $ CompilingModule moduleName
227 let env = foldl' (flip applyExternsFileToEnvironment) initEnvironment externs
228 lint m
229 ([desugared], nextVar) <- runSupplyT 0 $ desugar externs [m]
230 (checked@(Module ss coms _ elaborated exps), env') <- runCheck' env $ typeCheckModule desugared
231 checkExhaustiveModule env' checked
232 regrouped <- createBindingGroups moduleName . collapseBindingGroups $ elaborated
233 let mod' = Module ss coms moduleName regrouped exps
234 corefn = CF.moduleToCoreFn env' mod'
235 [renamed] = renameInModules [corefn]
236 exts = moduleToExternsFile mod' env'
237 evalSupplyT nextVar $ codegen renamed env' $ encode exts
238 return exts
239 markComplete (Just (warnings, exts)) Nothing
241 if shouldRebuild
242 then rebuild
243 else do
244 mexts <- decodeExterns . snd <$> readExterns moduleName
245 case mexts of
246 Just exts -> markComplete (Just (mempty, exts)) Nothing
247 Nothing -> rebuild
248 Nothing -> markComplete Nothing Nothing
249 where
250 markComplete :: Maybe (MultipleErrors, ExternsFile) -> Maybe MultipleErrors -> m ()
251 markComplete externs errors = do
252 putMVar (fst $ fromMaybe (internalError "make: no barrier") $ lookup moduleName barriers) externs
253 putMVar (snd $ fromMaybe (internalError "make: no barrier") $ lookup moduleName barriers) errors
255 maximumMaybe :: (Ord a) => [a] -> Maybe a
256 maximumMaybe [] = Nothing
257 maximumMaybe xs = Just $ maximum xs
259 -- Make sure a dependency exists
260 shouldExist :: Maybe UTCTime -> UTCTime
261 shouldExist (Just t) = t
262 shouldExist _ = internalError "make: dependency should already have been built."
264 decodeExterns :: B.ByteString -> Maybe ExternsFile
265 decodeExterns bs = do
266 externs <- decode bs
267 guard $ efVersion externs == showVersion Paths.version
268 return externs
270-- |
271-- Add an import declaration for a module if it does not already explicitly import it.
272--
273addDefaultImport :: ModuleName -> Module -> Module
274addDefaultImport toImport m@(Module ss coms mn decls exps) =
275 if isExistingImport `any` decls || mn == toImport then m
276 else Module ss coms mn (ImportDeclaration toImport Implicit Nothing : decls) exps
277 where
278 isExistingImport (ImportDeclaration mn' _ _) | mn' == toImport = True
279 isExistingImport (PositionedDeclaration _ _ d) = isExistingImport d
280 isExistingImport _ = False
282importPrim :: Module -> Module
283importPrim = addDefaultImport (ModuleName [ProperName C.prim])
285-- |
286-- A monad for running make actions
287--
288newtype Make a = Make { unMake :: ReaderT Options (ExceptT MultipleErrors (Logger MultipleErrors)) a }
289 deriving (Functor, Applicative, Monad, MonadIO, MonadError MultipleErrors, MonadWriter MultipleErrors, MonadReader Options)
291instance MonadBase IO Make where
292 liftBase = liftIO
294instance MonadBaseControl IO Make where
295 type StM Make a = Either MultipleErrors a
296 liftBaseWith f = Make $ liftBaseWith $ \q -> f (q . unMake)
297 restoreM = Make . restoreM
299-- |
300-- Execute a 'Make' monad, returning either errors, or the result of the compile plus any warnings.
301--
302runMake :: Options -> Make a -> IO (Either MultipleErrors a, MultipleErrors)
303runMake opts = runLogger' . runExceptT . flip runReaderT opts . unMake
305makeIO :: (IOError -> ErrorMessage) -> IO a -> Make a
306makeIO f io = do
307 e <- liftIO $ tryIOError io
308 either (throwError . singleError . f) return e
310-- Traverse (Either e) instance (base 4.7)
311traverseEither :: Applicative f => (a -> f b) -> Either e a -> f (Either e b)
312traverseEither _ (Left x) = pure (Left x)
313traverseEither f (Right y) = Right <$> f y
315-- |
316-- A set of make actions that read and write modules from the given directory.
317--
318buildMakeActions :: FilePath -- ^ the output directory
319 -> M.Map ModuleName (Either RebuildPolicy FilePath) -- ^ a map between module names and paths to the file containing the PureScript module
320 -> M.Map ModuleName FilePath -- ^ a map between module name and the file containing the foreign javascript for the module
321 -> Bool -- ^ Generate a prefix comment?
322 -> MakeActions Make
323buildMakeActions outputDir filePathMap foreigns usePrefix =
324 MakeActions getInputTimestamp getOutputTimestamp readExterns codegen progress
325 where
327 getInputTimestamp :: ModuleName -> Make (Either RebuildPolicy (Maybe UTCTime))
328 getInputTimestamp mn = do
329 let path = fromMaybe (internalError "Module has no filename in 'make'") $ M.lookup mn filePathMap
330 e1 <- traverseEither getTimestamp path
331 fPath <- maybe (return Nothing) getTimestamp $ M.lookup mn foreigns
332 return $ fmap (max fPath) e1
334 getOutputTimestamp :: ModuleName -> Make (Maybe UTCTime)
335 getOutputTimestamp mn = do
336 let filePath = runModuleName mn
337 jsFile = outputDir </> filePath </> "index.js"
338 externsFile = outputDir </> filePath </> "externs.json"
339 min <$> getTimestamp jsFile <*> getTimestamp externsFile
341 readExterns :: ModuleName -> Make (FilePath, B.ByteString)
342 readExterns mn = do
343 let path = outputDir </> runModuleName mn </> "externs.json"
344 (path, ) <$> readTextFile path
346 codegen :: CF.Module CF.Ann -> Environment -> Externs -> SupplyT Make ()
347 codegen m _ exts = do
348 let mn = CF.moduleName m
349 foreignInclude <- case mn `M.lookup` foreigns of
350 Just path
351 | not $ requiresForeign m -> do
352 tell $ errorMessage $ UnnecessaryFFIModule mn path
353 return Nothing
354 | otherwise -> return $ Just $ J.JSApp (J.JSVar "require") [J.JSStringLiteral "./foreign"]
355 Nothing | requiresForeign m -> throwError . errorMessage $ MissingFFIModule mn
356 | otherwise -> return Nothing
357 pjs <- prettyPrintJS <$> J.moduleToJs m foreignInclude
358 let filePath = runModuleName mn
359 jsFile = outputDir </> filePath </> "index.js"
360 externsFile = outputDir </> filePath </> "externs.json"
361 foreignFile = outputDir </> filePath </> "foreign.js"
362 prefix = ["Generated by psc version " ++ showVersion Paths.version | usePrefix]
363 js = unlines $ map ("// " ++) prefix ++ [pjs]
364 lift $ do
365 writeTextFile jsFile (fromString js)
366 for_ (mn `M.lookup` foreigns) (readTextFile >=> writeTextFile foreignFile)
367 writeTextFile externsFile exts
369 requiresForeign :: CF.Module a -> Bool
370 requiresForeign = not . null . CF.moduleForeign
372 getTimestamp :: FilePath -> Make (Maybe UTCTime)
373 getTimestamp path = makeIO (const (ErrorMessage [] $ CannotGetFileInfo path)) $ do
374 exists <- doesFileExist path
375 traverse (const $ getModificationTime path) $ guard exists
377 readTextFile :: FilePath -> Make B.ByteString
378 readTextFile path = makeIO (const (ErrorMessage [] $ CannotReadFile path)) $ B.readFile path
380 writeTextFile :: FilePath -> B.ByteString -> Make ()
381 writeTextFile path text = makeIO (const (ErrorMessage [] $ CannotWriteFile path)) $ do
382 mkdirp path
383 B.writeFile path text
384 where
385 mkdirp :: FilePath -> IO ()
386 mkdirp = createDirectoryIfMissing True . takeDirectory
388 progress :: ProgressMessage -> Make ()
389 progress = liftIO . putStrLn . renderProgressMessage