git.iko.soy/rowtype-yoga/purescript-native
on 103cbf8 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.Monoid (mempty, mconcat)
63import Data.Traversable (traverse)
64#endif
65import Data.Traversable (for)
66import Data.Version (showVersion)
67import Data.Aeson (encode, decode)
68import qualified Data.ByteString.Lazy as B
69import qualified Data.Set as S
70import qualified Data.Map as M
72import System.Directory
73 (doesFileExist, getModificationTime, createDirectoryIfMissing)
74import System.FilePath ((</>), takeDirectory)
75import System.IO.Error (tryIOError)
77import Language.PureScript.Crash
78import Language.PureScript.AST
79import Language.PureScript.Externs
80import Language.PureScript.Environment
81import Language.PureScript.Errors
82import Language.PureScript.Linter
83import Language.PureScript.ModuleDependencies
84import Language.PureScript.Names
85import Language.PureScript.Options
86import Language.PureScript.Pretty
87import Language.PureScript.Renamer
88import Language.PureScript.Sugar
89import Language.PureScript.TypeChecker
90import qualified Language.PureScript.Constants as C
92import qualified Language.PureScript.CodeGen.JS as J
93import qualified Language.PureScript.CoreFn as CF
94import qualified Paths_purescript as Paths
96-- | Progress messages from the make process
97data ProgressMessage
98 = CompilingModule ModuleName
99 deriving (Show, Read, Eq, Ord)
101-- | Render a progress message
102renderProgressMessage :: ProgressMessage -> String
103renderProgressMessage (CompilingModule mn) = "Compiling " ++ runModuleName mn
105-- | Actions that require implementations when running in "make" mode.
106--
107-- This type exists to make two things abstract:
108--
109-- * The particular backend being used (Javascript, C++11, etc.)
110--
111-- * The details of how files are read/written etc.
112--
113data MakeActions m = MakeActions {
114 -- |
115 -- Get the timestamp for the input file(s) for a module. If there are multiple
116 -- files (.purs and foreign files, for example) the timestamp should be for
117 -- the most recently modified file.
118 --
119 getInputTimestamp :: ModuleName -> m (Either RebuildPolicy (Maybe UTCTime))
120 -- |
121 -- Get the timestamp for the output files for a module. This should be the
122 -- timestamp for the oldest modified file, or Nothing if any of the required
123 -- output files are missing.
124 --
125 , getOutputTimestamp :: ModuleName -> m (Maybe UTCTime)
126 -- |
127 -- Read the externs file for a module as a string and also return the actual
128 -- path for the file.
129 , readExterns :: ModuleName -> m (FilePath, B.ByteString)
130 -- |
131 -- Run the code generator for the module and write any required output files.
132 --
133 , codegen :: CF.Module CF.Ann -> Environment -> Externs -> SupplyT m ()
134 -- |
135 -- Respond to a progress update.
136 --
137 , progress :: ProgressMessage -> m ()
138 }
140-- |
141-- Generated code for an externs file.
142--
143type Externs = B.ByteString
145-- |
146-- Determines when to rebuild a module
147--
148data RebuildPolicy
149 -- | Never rebuild this module
150 = RebuildNever
151 -- | Always rebuild this module
152 | RebuildAlways deriving (Show, Read, Eq, Ord)
154-- |
155-- Compiles in "make" mode, compiling each module separately to a js files and an externs file
156--
157-- If timestamps have not changed, the externs file can be used to provide the module's types without
158-- having to typecheck the module again.
159--
160make :: forall m. (Functor m, Applicative m, Monad m, MonadBaseControl IO m, MonadReader Options m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
161 => MakeActions m
162 -> [Module]
163 -> m Environment
164make MakeActions{..} ms = do
165 checkModuleNamesAreUnique
167 (sorted, graph) <- sortModules ms
169 barriers <- zip (map getModuleName sorted) <$> replicateM (length ms) ((,) <$> C.newEmptyMVar <*> C.newEmptyMVar)
171 for_ sorted $ \m -> fork $ do
172 let deps = fromMaybe (internalError "make: module not found in dependency graph.") (lookup (getModuleName m) graph)
173 buildModule barriers (importPrim m) (deps `inOrderOf` map getModuleName sorted)
175 -- Wait for all threads to complete, and collect errors.
176 errors <- catMaybes <$> for barriers (takeMVar . snd . snd)
178 -- All threads have completed, rethrow any caught errors.
179 unless (null errors) $ throwError (mconcat errors)
181 -- Bundle up all the externs and return them as an Environment
182 (_, externs) <- unzip . fromMaybe (internalError "make: externs were missing but no errors reported.") . sequence <$> for barriers (takeMVar . fst . snd)
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