git.iko.soy/rowtype-yoga/purescript-native
on e9f5706 help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/Make.hs
388 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
269-- |
270-- Add an import declaration for a module if it does not already explicitly import it.
271--
272addDefaultImport :: ModuleName -> Module -> Module
273addDefaultImport toImport m@(Module ss coms mn decls exps) =
274 if isExistingImport `any` decls || mn == toImport then m
275 else Module ss coms mn (ImportDeclaration toImport Implicit Nothing False : decls) exps
276 where
277 isExistingImport (ImportDeclaration mn' _ _ _) | mn' == toImport = True
278 isExistingImport (PositionedDeclaration _ _ d) = isExistingImport d
279 isExistingImport _ = False
281importPrim :: Module -> Module
282importPrim = addDefaultImport (ModuleName [ProperName C.prim])
284-- |
285-- A monad for running make actions
286--
287newtype Make a = Make { unMake :: ReaderT Options (ExceptT MultipleErrors (Logger MultipleErrors)) a }
288 deriving (Functor, Applicative, Monad, MonadIO, MonadError MultipleErrors, MonadWriter MultipleErrors, MonadReader Options)
290instance MonadBase IO Make where
291 liftBase = liftIO
293instance MonadBaseControl IO Make where
294 type StM Make a = Either MultipleErrors a
295 liftBaseWith f = Make $ liftBaseWith $ \q -> f (q . unMake)
296 restoreM = Make . restoreM
298-- |
299-- Execute a 'Make' monad, returning either errors, or the result of the compile plus any warnings.
300--
301runMake :: Options -> Make a -> IO (Either MultipleErrors a, MultipleErrors)
302runMake opts = runLogger' . runExceptT . flip runReaderT opts . unMake
304makeIO :: (IOError -> ErrorMessage) -> IO a -> Make a
305makeIO f io = do
306 e <- liftIO $ tryIOError io
307 either (throwError . singleError . f) return e
309-- Traverse (Either e) instance (base 4.7)
310traverseEither :: Applicative f => (a -> f b) -> Either e a -> f (Either e b)
311traverseEither _ (Left x) = pure (Left x)
312traverseEither f (Right y) = Right <$> f y
314-- |
315-- A set of make actions that read and write modules from the given directory.
316--
317buildMakeActions :: FilePath -- ^ the output directory
318 -> M.Map ModuleName (Either RebuildPolicy FilePath) -- ^ a map between module names and paths to the file containing the PureScript module
319 -> M.Map ModuleName FilePath -- ^ a map between module name and the file containing the foreign javascript for the module
320 -> Bool -- ^ Generate a prefix comment?
321 -> MakeActions Make
322buildMakeActions outputDir filePathMap foreigns usePrefix =
323 MakeActions getInputTimestamp getOutputTimestamp readExterns codegen progress
324 where
326 getInputTimestamp :: ModuleName -> Make (Either RebuildPolicy (Maybe UTCTime))
327 getInputTimestamp mn = do
328 let path = fromMaybe (internalError "Module has no filename in 'make'") $ M.lookup mn filePathMap
329 e1 <- traverseEither getTimestamp path
330 fPath <- maybe (return Nothing) getTimestamp $ M.lookup mn foreigns
331 return $ fmap (max fPath) e1
333 getOutputTimestamp :: ModuleName -> Make (Maybe UTCTime)
334 getOutputTimestamp mn = do
335 let filePath = runModuleName mn
336 jsFile = outputDir </> filePath </> "index.js"
337 externsFile = outputDir </> filePath </> "externs.json"
338 min <$> getTimestamp jsFile <*> getTimestamp externsFile
340 readExterns :: ModuleName -> Make (FilePath, Externs)
341 readExterns mn = do
342 let path = outputDir </> runModuleName mn </> "externs.json"
343 (path, ) <$> readTextFile path
345 codegen :: CF.Module CF.Ann -> Environment -> Externs -> SupplyT Make ()
346 codegen m _ exts = do
347 let mn = CF.moduleName m
348 foreignInclude <- case mn `M.lookup` foreigns of
349 Just path
350 | not $ requiresForeign m -> do
351 tell $ errorMessage $ UnnecessaryFFIModule mn path
352 return Nothing
353 | otherwise -> return $ Just $ J.JSApp (J.JSVar "require") [J.JSStringLiteral "./foreign"]
354 Nothing | requiresForeign m -> throwError . errorMessage $ MissingFFIModule mn
355 | otherwise -> return Nothing
356 pjs <- prettyPrintJS <$> J.moduleToJs m foreignInclude
357 let filePath = runModuleName mn
358 jsFile = outputDir </> filePath </> "index.js"
359 externsFile = outputDir </> filePath </> "externs.json"
360 foreignFile = outputDir </> filePath </> "foreign.js"
361 prefix = ["Generated by psc version " ++ showVersion Paths.version | usePrefix]
362 js = unlines $ map ("// " ++) prefix ++ [pjs]
363 lift $ do
364 writeTextFile jsFile (fromString js)
365 for_ (mn `M.lookup` foreigns) (readTextFile >=> writeTextFile foreignFile)
366 writeTextFile externsFile exts
368 requiresForeign :: CF.Module a -> Bool
369 requiresForeign = not . null . CF.moduleForeign
371 getTimestamp :: FilePath -> Make (Maybe UTCTime)
372 getTimestamp path = makeIO (const (ErrorMessage [] $ CannotGetFileInfo path)) $ do
373 exists <- doesFileExist path
374 traverse (const $ getModificationTime path) $ guard exists
376 readTextFile :: FilePath -> Make String
377 readTextFile path = makeIO (const (ErrorMessage [] $ CannotReadFile path)) $ readUTF8File path
379 writeTextFile :: FilePath -> String -> Make ()
380 writeTextFile path text = makeIO (const (ErrorMessage [] $ CannotWriteFile path)) $ do
381 mkdirp path
382 writeUTF8File path text
383 where
384 mkdirp :: FilePath -> IO ()
385 mkdirp = createDirectoryIfMissing True . takeDirectory
387 progress :: ProgressMessage -> Make ()
388 progress = liftIO . putStrLn . renderProgressMessage