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