git.iko.soy/rowtype-yoga/purescript-native
on 3aa0748 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 #-}
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.Crash
76import Language.PureScript.AST
77import Language.PureScript.Externs
78import Language.PureScript.Environment
79import Language.PureScript.Errors
80import Language.PureScript.Linter
81import Language.PureScript.ModuleDependencies
82import Language.PureScript.Names
83import Language.PureScript.Options
84import Language.PureScript.Pretty
85import Language.PureScript.Renamer
86import Language.PureScript.Sugar
87import Language.PureScript.TypeChecker
88import qualified Language.PureScript.Constants as C
90import qualified Language.PureScript.CodeGen.JS as J
91import qualified Language.PureScript.CoreFn as CF
92import qualified Paths_purescript as Paths
94-- | Progress messages from the make process
95data ProgressMessage
96 = CompilingModule ModuleName
97 deriving (Show, Read, Eq, Ord)
99-- | Render a progress message
100renderProgressMessage :: ProgressMessage -> String
101renderProgressMessage (CompilingModule mn) = "Compiling " ++ runModuleName mn
103-- | Actions that require implementations when running in "make" mode.
104--
105-- This type exists to make two things abstract:
106--
107-- * The particular backend being used (Javascript, C++11, etc.)
108--
109-- * The details of how files are read/written etc.
110--
111data MakeActions m = MakeActions {
112 -- |
113 -- Get the timestamp for the input file(s) for a module. If there are multiple
114 -- files (.purs and foreign files, for example) the timestamp should be for
115 -- the most recently modified file.
116 --
117 getInputTimestamp :: ModuleName -> m (Either RebuildPolicy (Maybe UTCTime))
118 -- |
119 -- Get the timestamp for the output files for a module. This should be the
120 -- timestamp for the oldest modified file, or Nothing if any of the required
121 -- output files are missing.
122 --
123 , getOutputTimestamp :: ModuleName -> m (Maybe UTCTime)
124 -- |
125 -- Read the externs file for a module as a string and also return the actual
126 -- path for the file.
127 , readExterns :: ModuleName -> m (FilePath, B.ByteString)
128 -- |
129 -- Run the code generator for the module and write any required output files.
130 --
131 , codegen :: CF.Module CF.Ann -> Environment -> Externs -> SupplyT m ()
132 -- |
133 -- Respond to a progress update.
134 --
135 , progress :: ProgressMessage -> m ()
136 }
138-- |
139-- Generated code for an externs file.
140--
141type Externs = B.ByteString
143-- |
144-- Determines when to rebuild a module
145--
146data RebuildPolicy
147 -- | Never rebuild this module
148 = RebuildNever
149 -- | Always rebuild this module
150 | RebuildAlways deriving (Show, Read, Eq, Ord)
152-- |
153-- Compiles in "make" mode, compiling each module separately to a js files and an externs file
154--
155-- If timestamps have not changed, the externs file can be used to provide the module's types without
156-- having to typecheck the module again.
157--
158make :: forall m. (Functor m, Applicative m, Monad m, MonadBaseControl IO m, MonadReader Options m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
159 => MakeActions m
160 -> [Module]
161 -> m Environment
162make MakeActions{..} ms = do
163 checkModuleNamesAreUnique
165 (sorted, graph) <- sortModules ms
167 barriers <- zip (map getModuleName sorted) <$> replicateM (length ms) ((,) <$> C.newEmptyMVar <*> C.newEmptyMVar)
169 for_ sorted $ \m -> fork $ do
170 let deps = fromMaybe (internalError "make: module not found in dependency graph.") (lookup (getModuleName m) graph)
171 buildModule barriers (importPrim m) (deps `inOrderOf` map getModuleName sorted)
173 -- Wait for all threads to complete, and collect errors.
174 errors <- catMaybes <$> for barriers (takeMVar . snd . snd)
176 -- All threads have completed, rethrow any caught errors.
177 unless (null errors) $ throwError (mconcat errors)
179 -- Bundle up all the externs and return them as an Environment
180 (warnings, externs) <- unzip . fromMaybe (internalError "make: externs were missing but no errors reported.") . sequence <$> for barriers (takeMVar . fst . snd)
181 tell (mconcat warnings)
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 <$> mapM (readMVar . fst . fromMaybe (internalError "make: no barrier") . flip lookup barriers) deps
211 outputTimestamp <- getOutputTimestamp moduleName
212 dependencyTimestamp <- maximumMaybe <$> mapM (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 =
222 case mexterns of
223 Just (_, externs) -> 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' $ encode exts
237 return exts
238 markComplete (Just (warnings, exts)) Nothing
239 Nothing -> markComplete Nothing 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 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 :: B.ByteString -> Maybe ExternsFile
264 decodeExterns bs = do
265 externs <- decode 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 : 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 (WriterT MultipleErrors (ExceptT MultipleErrors IO)) 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, MultipleErrors)
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 = runExceptT . runWriterT . 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, B.ByteString)
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 B.ByteString
377 readTextFile path = makeIO (const (ErrorMessage [] $ CannotReadFile path)) $ B.readFile path
379 writeTextFile :: FilePath -> B.ByteString -> Make ()
380 writeTextFile path text = makeIO (const (ErrorMessage [] $ CannotWriteFile path)) $ do
381 mkdirp path
382 B.writeFile path text
383 where
384 mkdirp :: FilePath -> IO ()
385 mkdirp = createDirectoryIfMissing True . takeDirectory
387 progress :: ProgressMessage -> Make ()
388 progress = liftIO . putStrLn . renderProgressMessage