git.iko.soy/rowtype-yoga/purescript-native
on 38034d2 help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/Make.hs
387 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 (warnings, externs) <- unzip . fromMaybe (error "make: externs were missing but no errors reported.") . sequence <$> for barriers (takeMVar . fst . snd)
180 tell (mconcat warnings)
181 return $ foldl' (flip applyExternsFileToEnvironment) initEnvironment externs
183 where
184 checkModuleNamesAreUnique :: m ()
185 checkModuleNamesAreUnique =
186 case findDuplicate (map getModuleName ms) of
187 Nothing -> return ()
188 Just mn -> throwError . errorMessage $ DuplicateModuleName mn
190 -- Verify that a list of values has unique keys
191 findDuplicate :: (Ord a) => [a] -> Maybe a
192 findDuplicate = go . sort
193 where
194 go (x : y : xs)
195 | x == y = Just x
196 | otherwise = go (y : xs)
197 go _ = Nothing
199 -- Sort a list so its elements appear in the same order as in another list.
200 inOrderOf :: (Ord a) => [a] -> [a] -> [a]
201 inOrderOf xs ys = let s = S.fromList xs in filter (`S.member` s) ys
203 buildModule :: [(ModuleName, (C.MVar (Maybe (MultipleErrors, ExternsFile)), C.MVar (Maybe MultipleErrors)))] -> Module -> [ModuleName] -> m ()
204 buildModule barriers m@(Module _ _ moduleName _ _) deps = flip catchError (markComplete Nothing . Just) $ do
205 -- We need to wait for dependencies to be built, before checking if the current
206 -- module should be rebuilt, so the first thing to do is to wait on the
207 -- MVars for the module's dependencies.
208 mexterns <- fmap unzip . sequence <$> mapM (readMVar . fst . fromMaybe (error "make: no barrier") . flip lookup barriers) deps
210 outputTimestamp <- getOutputTimestamp moduleName
211 dependencyTimestamp <- maximumMaybe <$> mapM (fmap shouldExist . getOutputTimestamp) deps
212 inputTimestamp <- getInputTimestamp moduleName
214 let shouldRebuild = case (inputTimestamp, dependencyTimestamp, outputTimestamp) of
215 (Right (Just t1), Just t3, Just t2) -> t1 > t2 || t3 > t2
216 (Right (Just t1), Nothing, Just t2) -> t1 > t2
217 (Left RebuildNever, _, Just _) -> False
218 _ -> True
220 let rebuild =
221 case mexterns of
222 Just (_, externs) -> do
223 (exts, warnings) <- listen $ do
224 progress $ CompilingModule moduleName
225 let env = foldl' (flip applyExternsFileToEnvironment) initEnvironment externs
226 lint m
227 ([desugared], nextVar) <- runSupplyT 0 $ desugar externs [m]
228 (checked@(Module ss coms _ elaborated exps), env') <- runCheck' env $ typeCheckModule desugared
229 checkExhaustiveModule env' checked
230 regrouped <- createBindingGroups moduleName . collapseBindingGroups $ elaborated
231 let mod' = Module ss coms moduleName regrouped exps
232 corefn = CF.moduleToCoreFn env' mod'
233 [renamed] = renameInModules [corefn]
234 exts = moduleToExternsFile mod' env'
235 evalSupplyT nextVar $ codegen renamed env' $ encode exts
236 return exts
237 markComplete (Just (warnings, exts)) Nothing
238 Nothing -> markComplete Nothing 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 where
248 markComplete :: Maybe (MultipleErrors, ExternsFile) -> Maybe MultipleErrors -> m ()
249 markComplete externs errors = do
250 putMVar (fst $ fromMaybe (error "make: no barrier") $ lookup moduleName barriers) externs
251 putMVar (snd $ fromMaybe (error "make: no barrier") $ lookup moduleName barriers) errors
253 maximumMaybe :: (Ord a) => [a] -> Maybe a
254 maximumMaybe [] = Nothing
255 maximumMaybe xs = Just $ maximum xs
257 -- Make sure a dependency exists
258 shouldExist :: Maybe UTCTime -> UTCTime
259 shouldExist (Just t) = t
260 shouldExist _ = error "make: dependency should already have been built."
262 decodeExterns :: B.ByteString -> Maybe ExternsFile
263 decodeExterns bs = do
264 externs <- decode bs
265 guard $ efVersion externs == showVersion Paths.version
266 return externs
268-- |
269-- Add an import declaration for a module if it does not already explicitly import it.
270--
271addDefaultImport :: ModuleName -> Module -> Module
272addDefaultImport toImport m@(Module ss coms mn decls exps) =
273 if isExistingImport `any` decls || mn == toImport then m
274 else Module ss coms mn (ImportDeclaration toImport Implicit Nothing : decls) exps
275 where
276 isExistingImport (ImportDeclaration mn' _ _) | mn' == toImport = True
277 isExistingImport (PositionedDeclaration _ _ d) = isExistingImport d
278 isExistingImport _ = False
280importPrim :: Module -> Module
281importPrim = addDefaultImport (ModuleName [ProperName C.prim])
283-- |
284-- A monad for running make actions
285--
286newtype Make a = Make { unMake :: ReaderT Options (WriterT MultipleErrors (ExceptT MultipleErrors IO)) a }
287 deriving (Functor, Applicative, Monad, MonadIO, MonadError MultipleErrors, MonadWriter MultipleErrors, MonadReader Options)
289instance MonadBase IO Make where
290 liftBase = liftIO
292instance MonadBaseControl IO Make where
293 type StM Make a = Either MultipleErrors (a, MultipleErrors)
294 liftBaseWith f = Make $ liftBaseWith $ \q -> f (q . unMake)
295 restoreM = Make . restoreM
297-- |
298-- Execute a 'Make' monad, returning either errors, or the result of the compile plus any warnings.
299--
300runMake :: Options -> Make a -> IO (Either MultipleErrors (a, MultipleErrors))
301runMake opts = runExceptT . runWriterT . flip runReaderT opts . unMake
303makeIO :: (IOError -> ErrorMessage) -> IO a -> Make a
304makeIO f io = do
305 e <- liftIO $ tryIOError io
306 either (throwError . singleError . f) return e
308-- Traverse (Either e) instance (base 4.7)
309traverseEither :: Applicative f => (a -> f b) -> Either e a -> f (Either e b)
310traverseEither _ (Left x) = pure (Left x)
311traverseEither f (Right y) = Right <$> f y
313-- |
314-- A set of make actions that read and write modules from the given directory.
315--
316buildMakeActions :: FilePath -- ^ the output directory
317 -> M.Map ModuleName (Either RebuildPolicy FilePath) -- ^ a map between module names and paths to the file containing the PureScript module
318 -> M.Map ModuleName FilePath -- ^ a map between module name and the file containing the foreign javascript for the module
319 -> Bool -- ^ Generate a prefix comment?
320 -> MakeActions Make
321buildMakeActions outputDir filePathMap foreigns usePrefix =
322 MakeActions getInputTimestamp getOutputTimestamp readExterns codegen progress
323 where
325 getInputTimestamp :: ModuleName -> Make (Either RebuildPolicy (Maybe UTCTime))
326 getInputTimestamp mn = do
327 let path = fromMaybe (error "Module has no filename in 'make'") $ M.lookup mn filePathMap
328 e1 <- traverseEither getTimestamp path
329 fPath <- maybe (return Nothing) getTimestamp $ M.lookup mn foreigns
330 return $ fmap (max fPath) e1
332 getOutputTimestamp :: ModuleName -> Make (Maybe UTCTime)
333 getOutputTimestamp mn = do
334 let filePath = runModuleName mn
335 jsFile = outputDir </> filePath </> "index.js"
336 externsFile = outputDir </> filePath </> "externs.json"
337 min <$> getTimestamp jsFile <*> getTimestamp externsFile
339 readExterns :: ModuleName -> Make (FilePath, B.ByteString)
340 readExterns mn = do
341 let path = outputDir </> runModuleName mn </> "externs.json"
342 (path, ) <$> readTextFile path
344 codegen :: CF.Module CF.Ann -> Environment -> Externs -> SupplyT Make ()
345 codegen m _ exts = do
346 let mn = CF.moduleName m
347 foreignInclude <- case mn `M.lookup` foreigns of
348 Just path
349 | not $ requiresForeign m -> do
350 tell $ errorMessage $ UnnecessaryFFIModule mn path
351 return Nothing
352 | otherwise -> return $ Just $ J.JSApp (J.JSVar "require") [J.JSStringLiteral "./foreign"]
353 Nothing | requiresForeign m -> throwError . errorMessage $ MissingFFIModule mn
354 | otherwise -> return Nothing
355 pjs <- prettyPrintJS <$> J.moduleToJs m foreignInclude
356 let filePath = runModuleName mn
357 jsFile = outputDir </> filePath </> "index.js"
358 externsFile = outputDir </> filePath </> "externs.json"
359 foreignFile = outputDir </> filePath </> "foreign.js"
360 prefix = ["Generated by psc version " ++ showVersion Paths.version | usePrefix]
361 js = unlines $ map ("// " ++) prefix ++ [pjs]
362 lift $ do
363 writeTextFile jsFile (fromString js)
364 for_ (mn `M.lookup` foreigns) (readTextFile >=> writeTextFile foreignFile)
365 writeTextFile externsFile exts
367 requiresForeign :: CF.Module a -> Bool
368 requiresForeign = not . null . CF.moduleForeign
370 getTimestamp :: FilePath -> Make (Maybe UTCTime)
371 getTimestamp path = makeIO (const (ErrorMessage [] $ CannotGetFileInfo path)) $ do
372 exists <- doesFileExist path
373 traverse (const $ getModificationTime path) $ guard exists
375 readTextFile :: FilePath -> Make B.ByteString
376 readTextFile path = makeIO (const (ErrorMessage [] $ CannotReadFile path)) $ B.readFile path
378 writeTextFile :: FilePath -> B.ByteString -> Make ()
379 writeTextFile path text = makeIO (const (ErrorMessage [] $ CannotWriteFile path)) $ do
380 mkdirp path
381 B.writeFile path text
382 where
383 mkdirp :: FilePath -> IO ()
384 mkdirp = createDirectoryIfMissing True . takeDirectory
386 progress :: ProgressMessage -> Make ()
387 progress = liftIO . putStrLn . renderProgressMessage