git.iko.soy/rowtype-yoga/purescript-native
on 6d1b5ec help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/Make.hs
360 lines 14 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')
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 (sorted, graph) <- sortModules ms
164 barriers <- zip (map getModuleName sorted) <$> replicateM (length ms) ((,) <$> C.newEmptyMVar <*> C.newEmptyMVar)
166 for_ sorted $ \m -> fork $ do
167 let deps = fromMaybe (error "make: module not found in dependency graph.") (lookup (getModuleName m) graph)
168 buildModule barriers (importPrim m) (deps `inOrderOf` map getModuleName sorted)
170 -- Wait for all threads to complete, and collect errors.
171 errors <- catMaybes <$> for barriers (takeMVar . snd . snd)
173 -- All threads have completed, rethrow any caught errors.
174 unless (null errors) $ throwError (mconcat errors)
176 -- Bundle up all the externs and return them as an Environment
177 externs <- sequence <$> for barriers (takeMVar . fst . snd)
178 return $ foldl' (flip applyExternsFileToEnvironment) initEnvironment (fromMaybe (error "make: externs were missing but no errors reported.") externs)
180 where
181 -- Sort a list so its elements appear in the same order as in another list.
182 inOrderOf :: (Ord a) => [a] -> [a] -> [a]
183 inOrderOf xs ys = let s = S.fromList xs in filter (`S.member` s) ys
185 buildModule :: [(ModuleName, (C.MVar (Maybe ExternsFile), C.MVar (Maybe MultipleErrors)))] -> Module -> [ModuleName] -> m ()
186 buildModule barriers m@(Module _ _ moduleName _ _) deps = flip catchError (markComplete Nothing . Just) $ do
187 outputTimestamp <- getOutputTimestamp moduleName
188 dependencyTimestamp <- maximumMaybe <$> mapM (fmap shouldExist . getOutputTimestamp) deps
189 inputTimestamp <- getInputTimestamp moduleName
191 let shouldRebuild = case (inputTimestamp, dependencyTimestamp, outputTimestamp) of
192 (Right (Just t1), Just t3, Just t2) -> t1 > t2 || t3 > t2
193 (Right (Just t1), Nothing, Just t2) -> t1 > t2
194 (Left RebuildNever, _, Just _) -> False
195 _ -> True
197 exts <- if shouldRebuild
198 then do
199 mexterns <- sequence <$> mapM (readMVar . fst . fromMaybe (error "make: no barrier") . flip lookup barriers) deps
201 for mexterns $ \externs -> do
202 progress $ CompilingModule moduleName
203 let env = foldl' (flip applyExternsFileToEnvironment) initEnvironment externs
204 lint m
205 ([desugared], nextVar) <- runSupplyT 0 $ desugar externs [m]
206 (checked@(Module ss coms _ elaborated exps), env') <- runCheck' env $ typeCheckModule Nothing desugared
207 checkExhaustiveModule env' checked
208 regrouped <- createBindingGroups moduleName . collapseBindingGroups $ elaborated
209 let mod' = Module ss coms moduleName regrouped exps
210 corefn = CF.moduleToCoreFn env' mod'
211 [renamed] = renameInModules [corefn]
212 exts = moduleToExternsFile mod' env'
213 evalSupplyT nextVar $ codegen renamed env' $ encode exts
214 return exts
215 else do
216 mexts <- decodeExterns . snd <$> readExterns moduleName
217 return $ Just $ fromMaybe (error "make: externs files are out of date. Try 'rm output/*/externs.json'.") mexts
219 markComplete exts Nothing
220 where
221 markComplete :: Maybe ExternsFile -> Maybe MultipleErrors -> m ()
222 markComplete externs errors = do
223 putMVar (fst $ fromMaybe (error "make: no barrier") $ lookup moduleName barriers) externs
224 putMVar (snd $ fromMaybe (error "make: no barrier") $ lookup moduleName barriers) errors
226 maximumMaybe :: (Ord a) => [a] -> Maybe a
227 maximumMaybe [] = Nothing
228 maximumMaybe xs = Just $ maximum xs
230 -- Make sure a dependency exists
231 shouldExist :: Maybe UTCTime -> UTCTime
232 shouldExist (Just t) = t
233 shouldExist _ = error "make: dependency should already have been built."
235 decodeExterns :: B.ByteString -> Maybe ExternsFile
236 decodeExterns bs = do
237 externs <- decode bs
238 guard $ efVersion externs == showVersion Paths.version
239 return externs
241-- |
242-- Add an import declaration for a module if it does not already explicitly import it.
243--
244addDefaultImport :: ModuleName -> Module -> Module
245addDefaultImport toImport m@(Module ss coms mn decls exps) =
246 if isExistingImport `any` decls || mn == toImport then m
247 else Module ss coms mn (ImportDeclaration toImport Implicit Nothing : decls) exps
248 where
249 isExistingImport (ImportDeclaration mn' _ _) | mn' == toImport = True
250 isExistingImport (PositionedDeclaration _ _ d) = isExistingImport d
251 isExistingImport _ = False
253importPrim :: Module -> Module
254importPrim = addDefaultImport (ModuleName [ProperName C.prim])
256-- |
257-- A monad for running make actions
258--
259newtype Make a = Make { unMake :: ReaderT Options (WriterT MultipleErrors (ExceptT MultipleErrors IO)) a }
260 deriving (Functor, Applicative, Monad, MonadIO, MonadError MultipleErrors, MonadWriter MultipleErrors, MonadReader Options)
262instance MonadBase IO Make where
263 liftBase = liftIO
265instance MonadBaseControl IO Make where
266 type StM Make a = Either MultipleErrors (a, MultipleErrors)
267 liftBaseWith f = Make $ liftBaseWith $ \q -> f (q . unMake)
268 restoreM = Make . restoreM
270-- |
271-- Execute a 'Make' monad, returning either errors, or the result of the compile plus any warnings.
272--
273runMake :: Options -> Make a -> IO (Either MultipleErrors (a, MultipleErrors))
274runMake opts = runExceptT . runWriterT . flip runReaderT opts . unMake
276makeIO :: (IOError -> ErrorMessage) -> IO a -> Make a
277makeIO f io = do
278 e <- liftIO $ tryIOError io
279 either (throwError . singleError . f) return e
281-- Traverse (Either e) instance (base 4.7)
282traverseEither :: Applicative f => (a -> f b) -> Either e a -> f (Either e b)
283traverseEither _ (Left x) = pure (Left x)
284traverseEither f (Right y) = Right <$> f y
286-- |
287-- A set of make actions that read and write modules from the given directory.
288--
289buildMakeActions :: FilePath -- ^ the output directory
290 -> M.Map ModuleName (Either RebuildPolicy FilePath) -- ^ a map between module names and paths to the file containing the PureScript module
291 -> M.Map ModuleName FilePath -- ^ a map between module name and the file containing the foreign javascript for the module
292 -> Bool -- ^ Generate a prefix comment?
293 -> MakeActions Make
294buildMakeActions outputDir filePathMap foreigns usePrefix =
295 MakeActions getInputTimestamp getOutputTimestamp readExterns codegen progress
296 where
298 getInputTimestamp :: ModuleName -> Make (Either RebuildPolicy (Maybe UTCTime))
299 getInputTimestamp mn = do
300 let path = fromMaybe (error "Module has no filename in 'make'") $ M.lookup mn filePathMap
301 e1 <- traverseEither getTimestamp path
302 fPath <- maybe (return Nothing) getTimestamp $ M.lookup mn foreigns
303 return $ fmap (max fPath) e1
305 getOutputTimestamp :: ModuleName -> Make (Maybe UTCTime)
306 getOutputTimestamp mn = do
307 let filePath = runModuleName mn
308 jsFile = outputDir </> filePath </> "index.js"
309 externsFile = outputDir </> filePath </> "externs.json"
310 min <$> getTimestamp jsFile <*> getTimestamp externsFile
312 readExterns :: ModuleName -> Make (FilePath, B.ByteString)
313 readExterns mn = do
314 let path = outputDir </> runModuleName mn </> "externs.json"
315 (path, ) <$> readTextFile path
317 codegen :: CF.Module CF.Ann -> Environment -> Externs -> SupplyT Make ()
318 codegen m _ exts = do
319 let mn = CF.moduleName m
320 foreignInclude <- case mn `M.lookup` foreigns of
321 Just path
322 | not $ requiresForeign m -> do
323 tell $ errorMessage $ UnnecessaryFFIModule mn path
324 return Nothing
325 | otherwise -> return $ Just $ J.JSApp (J.JSVar "require") [J.JSStringLiteral "./foreign"]
326 Nothing | requiresForeign m -> throwError . errorMessage $ MissingFFIModule mn
327 | otherwise -> return Nothing
328 pjs <- prettyPrintJS <$> J.moduleToJs m foreignInclude
329 let filePath = runModuleName mn
330 jsFile = outputDir </> filePath </> "index.js"
331 externsFile = outputDir </> filePath </> "externs.json"
332 foreignFile = outputDir </> filePath </> "foreign.js"
333 prefix = ["Generated by psc version " ++ showVersion Paths.version | usePrefix]
334 js = unlines $ map ("// " ++) prefix ++ [pjs]
335 lift $ do
336 writeTextFile jsFile (fromString js)
337 for_ (mn `M.lookup` foreigns) (readTextFile >=> writeTextFile foreignFile)
338 writeTextFile externsFile exts
340 requiresForeign :: CF.Module a -> Bool
341 requiresForeign = not . null . CF.moduleForeign
343 getTimestamp :: FilePath -> Make (Maybe UTCTime)
344 getTimestamp path = makeIO (const (SimpleErrorWrapper $ CannotGetFileInfo path)) $ do
345 exists <- doesFileExist path
346 traverse (const $ getModificationTime path) $ guard exists
348 readTextFile :: FilePath -> Make B.ByteString
349 readTextFile path = makeIO (const (SimpleErrorWrapper $ CannotReadFile path)) $ B.readFile path
351 writeTextFile :: FilePath -> B.ByteString -> Make ()
352 writeTextFile path text = makeIO (const (SimpleErrorWrapper $ CannotWriteFile path)) $ do
353 mkdirp path
354 B.writeFile path text
355 where
356 mkdirp :: FilePath -> IO ()
357 mkdirp = createDirectoryIfMissing True . takeDirectory
359 progress :: ProgressMessage -> Make ()
360 progress = liftIO . putStrLn . renderProgressMessage