git.iko.soy/rowtype-yoga/purescript-native
on bfc986c help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/Make.hs
384 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.Trans.Except
47import Control.Monad.Reader
48import Control.Monad.Writer.Strict
49import Control.Monad.Supply
50import Control.Monad.Base (MonadBase(..))
51import Control.Monad.Trans.Control (MonadBaseControl(..))
53import Control.Concurrent.Lifted as C
55import Data.List (foldl', sort)
56import Data.Maybe (fromMaybe, catMaybes)
57import Data.Time.Clock
58import Data.String (fromString)
59import Data.Foldable (for_)
60#if __GLASGOW_HASKELL__ < 710
61import Data.Traversable (traverse)
62#endif
63import Data.Traversable (for)
64import Data.Version (showVersion)
65import Data.Aeson (encode, decode)
66import qualified Data.ByteString.Lazy as B
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)
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 (error "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 <- sequence <$> for barriers (takeMVar . fst . snd)
180 return $ foldl' (flip applyExternsFileToEnvironment) initEnvironment (fromMaybe (error "make: externs were missing but no errors reported.") 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 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 <- sequence <$> mapM (readMVar . fst . fromMaybe (error "make: no barrier") . flip lookup barriers) deps
209 outputTimestamp <- getOutputTimestamp moduleName
210 dependencyTimestamp <- maximumMaybe <$> mapM (fmap shouldExist . getOutputTimestamp) deps
211 inputTimestamp <- getInputTimestamp moduleName
213 let shouldRebuild = case (inputTimestamp, dependencyTimestamp, outputTimestamp) of
214 (Right (Just t1), Just t3, Just t2) -> t1 > t2 || t3 > t2
215 (Right (Just t1), Nothing, Just t2) -> t1 > t2
216 (Left RebuildNever, _, Just _) -> False
217 _ -> True
219 let rebuild =
220 case mexterns of
221 Just externs -> do
222 progress $ CompilingModule moduleName
223 let env = foldl' (flip applyExternsFileToEnvironment) initEnvironment externs
224 lint m
225 ([desugared], nextVar) <- runSupplyT 0 $ desugar externs [m]
226 (checked@(Module ss coms _ elaborated exps), env') <- runCheck' env $ typeCheckModule desugared
227 checkExhaustiveModule env' checked
228 regrouped <- createBindingGroups moduleName . collapseBindingGroups $ elaborated
229 let mod' = Module ss coms moduleName regrouped exps
230 corefn = CF.moduleToCoreFn env' mod'
231 [renamed] = renameInModules [corefn]
232 exts = moduleToExternsFile mod' env'
233 evalSupplyT nextVar $ codegen renamed env' $ encode exts
234 markComplete (Just exts) Nothing
235 Nothing -> markComplete Nothing Nothing
237 if shouldRebuild
238 then rebuild
239 else do
240 mexts <- decodeExterns . snd <$> readExterns moduleName
241 case mexts of
242 Just exts -> markComplete (Just exts) Nothing
243 Nothing -> rebuild
244 where
245 markComplete :: Maybe ExternsFile -> Maybe MultipleErrors -> m ()
246 markComplete externs errors = do
247 putMVar (fst $ fromMaybe (error "make: no barrier") $ lookup moduleName barriers) externs
248 putMVar (snd $ fromMaybe (error "make: no barrier") $ lookup moduleName barriers) errors
250 maximumMaybe :: (Ord a) => [a] -> Maybe a
251 maximumMaybe [] = Nothing
252 maximumMaybe xs = Just $ maximum xs
254 -- Make sure a dependency exists
255 shouldExist :: Maybe UTCTime -> UTCTime
256 shouldExist (Just t) = t
257 shouldExist _ = error "make: dependency should already have been built."
259 decodeExterns :: B.ByteString -> Maybe ExternsFile
260 decodeExterns bs = do
261 externs <- decode bs
262 guard $ efVersion externs == showVersion Paths.version
263 return externs
265-- |
266-- Add an import declaration for a module if it does not already explicitly import it.
267--
268addDefaultImport :: ModuleName -> Module -> Module
269addDefaultImport toImport m@(Module ss coms mn decls exps) =
270 if isExistingImport `any` decls || mn == toImport then m
271 else Module ss coms mn (ImportDeclaration toImport Implicit Nothing : decls) exps
272 where
273 isExistingImport (ImportDeclaration mn' _ _) | mn' == toImport = True
274 isExistingImport (PositionedDeclaration _ _ d) = isExistingImport d
275 isExistingImport _ = False
277importPrim :: Module -> Module
278importPrim = addDefaultImport (ModuleName [ProperName C.prim])
280-- |
281-- A monad for running make actions
282--
283newtype Make a = Make { unMake :: ReaderT Options (WriterT MultipleErrors (ExceptT MultipleErrors IO)) a }
284 deriving (Functor, Applicative, Monad, MonadIO, MonadError MultipleErrors, MonadWriter MultipleErrors, MonadReader Options)
286instance MonadBase IO Make where
287 liftBase = liftIO
289instance MonadBaseControl IO Make where
290 type StM Make a = Either MultipleErrors (a, MultipleErrors)
291 liftBaseWith f = Make $ liftBaseWith $ \q -> f (q . unMake)
292 restoreM = Make . restoreM
294-- |
295-- Execute a 'Make' monad, returning either errors, or the result of the compile plus any warnings.
296--
297runMake :: Options -> Make a -> IO (Either MultipleErrors (a, MultipleErrors))
298runMake opts = runExceptT . runWriterT . flip runReaderT opts . unMake
300makeIO :: (IOError -> ErrorMessage) -> IO a -> Make a
301makeIO f io = do
302 e <- liftIO $ tryIOError io
303 either (throwError . singleError . f) return e
305-- Traverse (Either e) instance (base 4.7)
306traverseEither :: Applicative f => (a -> f b) -> Either e a -> f (Either e b)
307traverseEither _ (Left x) = pure (Left x)
308traverseEither f (Right y) = Right <$> f y
310-- |
311-- A set of make actions that read and write modules from the given directory.
312--
313buildMakeActions :: FilePath -- ^ the output directory
314 -> M.Map ModuleName (Either RebuildPolicy FilePath) -- ^ a map between module names and paths to the file containing the PureScript module
315 -> M.Map ModuleName FilePath -- ^ a map between module name and the file containing the foreign javascript for the module
316 -> Bool -- ^ Generate a prefix comment?
317 -> MakeActions Make
318buildMakeActions outputDir filePathMap foreigns usePrefix =
319 MakeActions getInputTimestamp getOutputTimestamp readExterns codegen progress
320 where
322 getInputTimestamp :: ModuleName -> Make (Either RebuildPolicy (Maybe UTCTime))
323 getInputTimestamp mn = do
324 let path = fromMaybe (error "Module has no filename in 'make'") $ M.lookup mn filePathMap
325 e1 <- traverseEither getTimestamp path
326 fPath <- maybe (return Nothing) getTimestamp $ M.lookup mn foreigns
327 return $ fmap (max fPath) e1
329 getOutputTimestamp :: ModuleName -> Make (Maybe UTCTime)
330 getOutputTimestamp mn = do
331 let filePath = runModuleName mn
332 jsFile = outputDir </> filePath </> "index.js"
333 externsFile = outputDir </> filePath </> "externs.json"
334 min <$> getTimestamp jsFile <*> getTimestamp externsFile
336 readExterns :: ModuleName -> Make (FilePath, B.ByteString)
337 readExterns mn = do
338 let path = outputDir </> runModuleName mn </> "externs.json"
339 (path, ) <$> readTextFile path
341 codegen :: CF.Module CF.Ann -> Environment -> Externs -> SupplyT Make ()
342 codegen m _ exts = do
343 let mn = CF.moduleName m
344 foreignInclude <- case mn `M.lookup` foreigns of
345 Just path
346 | not $ requiresForeign m -> do
347 tell $ errorMessage $ UnnecessaryFFIModule mn path
348 return Nothing
349 | otherwise -> return $ Just $ J.JSApp (J.JSVar "require") [J.JSStringLiteral "./foreign"]
350 Nothing | requiresForeign m -> throwError . errorMessage $ MissingFFIModule mn
351 | otherwise -> return Nothing
352 pjs <- prettyPrintJS <$> J.moduleToJs m foreignInclude
353 let filePath = runModuleName mn
354 jsFile = outputDir </> filePath </> "index.js"
355 externsFile = outputDir </> filePath </> "externs.json"
356 foreignFile = outputDir </> filePath </> "foreign.js"
357 prefix = ["Generated by psc version " ++ showVersion Paths.version | usePrefix]
358 js = unlines $ map ("// " ++) prefix ++ [pjs]
359 lift $ do
360 writeTextFile jsFile (fromString js)
361 for_ (mn `M.lookup` foreigns) (readTextFile >=> writeTextFile foreignFile)
362 writeTextFile externsFile exts
364 requiresForeign :: CF.Module a -> Bool
365 requiresForeign = not . null . CF.moduleForeign
367 getTimestamp :: FilePath -> Make (Maybe UTCTime)
368 getTimestamp path = makeIO (const (ErrorMessage [] $ CannotGetFileInfo path)) $ do
369 exists <- doesFileExist path
370 traverse (const $ getModificationTime path) $ guard exists
372 readTextFile :: FilePath -> Make B.ByteString
373 readTextFile path = makeIO (const (ErrorMessage [] $ CannotReadFile path)) $ B.readFile path
375 writeTextFile :: FilePath -> B.ByteString -> Make ()
376 writeTextFile path text = makeIO (const (ErrorMessage [] $ CannotWriteFile path)) $ do
377 mkdirp path
378 B.writeFile path text
379 where
380 mkdirp :: FilePath -> IO ()
381 mkdirp = createDirectoryIfMissing True . takeDirectory
383 progress :: ProgressMessage -> Make ()
384 progress = liftIO . putStrLn . renderProgressMessage