git.iko.soy/rowtype-yoga/purescript-native
on 8c7cc69 help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/Make.hs
363 lines 14 kB history raw
1{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4{-# LANGUAGE TupleSections #-}
5{-# LANGUAGE RankNTypes #-}
6{-# LANGUAGE RecordWildCards #-}
7{-# LANGUAGE ScopedTypeVariables #-}
8{-# LANGUAGE MultiParamTypeClasses #-}
9{-# LANGUAGE TypeFamilies #-}
11module Language.PureScript.Make
12 (
13 -- * Make API
14 RebuildPolicy(..)
15 , ProgressMessage(..), renderProgressMessage
16 , MakeActions(..)
17 , Externs()
18 , make
20 -- * Implementation of Make API using files on disk
21 , Make(..)
22 , runMake
23 , buildMakeActions
24 ) where
26import Prelude ()
27import Prelude.Compat
29import Control.Monad hiding (sequence)
30import Control.Monad.Error.Class (MonadError(..))
31import Control.Monad.Writer.Class (MonadWriter(..))
32import Control.Monad.Trans.Class (MonadTrans(..))
33import Control.Monad.Trans.Except
34import Control.Monad.IO.Class
35import Control.Monad.Reader (MonadReader(..), ReaderT(..))
36import Control.Monad.Logger
37import Control.Monad.Supply
38import Control.Monad.Base (MonadBase(..))
39import Control.Monad.Trans.Control (MonadBaseControl(..))
41import Control.Concurrent.Lifted as C
43import Data.List (foldl', sort)
44import Data.Maybe (fromMaybe, catMaybes)
45import Data.Time.Clock
46import Data.String (fromString)
47import Data.Foldable (for_)
48import Data.Traversable (for)
49import Data.Version (showVersion)
50import Data.Aeson (encode, decode)
51import qualified Data.ByteString.Lazy as B
52import qualified Data.ByteString.UTF8 as BU8
53import qualified Data.Set as S
54import qualified Data.Map as M
56import System.Directory
57 (doesFileExist, getModificationTime, createDirectoryIfMissing)
58import System.FilePath ((</>), takeDirectory)
59import System.IO.Error (tryIOError)
60import System.IO.UTF8 (readUTF8File, writeUTF8File)
62import Language.PureScript.Crash
63import Language.PureScript.AST
64import Language.PureScript.Externs
65import Language.PureScript.Environment
66import Language.PureScript.Errors
67import Language.PureScript.Linter
68import Language.PureScript.ModuleDependencies
69import Language.PureScript.Names
70import Language.PureScript.Options
71import Language.PureScript.Pretty
72import Language.PureScript.Renamer
73import Language.PureScript.Sugar
74import Language.PureScript.TypeChecker
75import qualified Language.PureScript.Constants as C
77import qualified Language.PureScript.CodeGen.JS as J
78import qualified Language.PureScript.CoreFn as CF
79import qualified Paths_purescript as Paths
81-- | Progress messages from the make process
82data ProgressMessage
83 = CompilingModule ModuleName
84 deriving (Show, Read, Eq, Ord)
86-- | Render a progress message
87renderProgressMessage :: ProgressMessage -> String
88renderProgressMessage (CompilingModule mn) = "Compiling " ++ runModuleName mn
90-- | Actions that require implementations when running in "make" mode.
91--
92-- This type exists to make two things abstract:
93--
94-- * The particular backend being used (Javascript, C++11, etc.)
95--
96-- * The details of how files are read/written etc.
97--
98data MakeActions m = MakeActions {
99 -- |
100 -- Get the timestamp for the input file(s) for a module. If there are multiple
101 -- files (.purs and foreign files, for example) the timestamp should be for
102 -- the most recently modified file.
103 --
104 getInputTimestamp :: ModuleName -> m (Either RebuildPolicy (Maybe UTCTime))
105 -- |
106 -- Get the timestamp for the output files for a module. This should be the
107 -- timestamp for the oldest modified file, or Nothing if any of the required
108 -- output files are missing.
109 --
110 , getOutputTimestamp :: ModuleName -> m (Maybe UTCTime)
111 -- |
112 -- Read the externs file for a module as a string and also return the actual
113 -- path for the file.
114 , readExterns :: ModuleName -> m (FilePath, Externs)
115 -- |
116 -- Run the code generator for the module and write any required output files.
117 --
118 , codegen :: CF.Module CF.Ann -> Environment -> Externs -> SupplyT m ()
119 -- |
120 -- Respond to a progress update.
121 --
122 , progress :: ProgressMessage -> m ()
123 }
125-- |
126-- Generated code for an externs file.
127--
128type Externs = String
130-- |
131-- Determines when to rebuild a module
132--
133data RebuildPolicy
134 -- | Never rebuild this module
135 = RebuildNever
136 -- | Always rebuild this module
137 | RebuildAlways deriving (Show, Read, Eq, Ord)
139-- |
140-- Compiles in "make" mode, compiling each module separately to a js files and an externs file
141--
142-- If timestamps have not changed, the externs file can be used to provide the module's types without
143-- having to typecheck the module again.
144--
145make :: forall m. (Functor m, Applicative m, Monad m, MonadBaseControl IO m, MonadReader Options m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
146 => MakeActions m
147 -> [Module]
148 -> m Environment
149make MakeActions{..} ms = do
150 checkModuleNamesAreUnique
152 (sorted, graph) <- sortModules ms
154 barriers <- zip (map getModuleName sorted) <$> replicateM (length ms) ((,) <$> C.newEmptyMVar <*> C.newEmptyMVar)
156 for_ sorted $ \m -> fork $ do
157 let deps = fromMaybe (internalError "make: module not found in dependency graph.") (lookup (getModuleName m) graph)
158 buildModule barriers (importPrim m) (deps `inOrderOf` map getModuleName sorted)
160 -- Wait for all threads to complete, and collect errors.
161 errors <- catMaybes <$> for barriers (takeMVar . snd . snd)
163 -- All threads have completed, rethrow any caught errors.
164 unless (null errors) $ throwError (mconcat errors)
166 -- Bundle up all the externs and return them as an Environment
167 (_, externs) <- unzip . fromMaybe (internalError "make: externs were missing but no errors reported.") . sequence <$> for barriers (takeMVar . fst . snd)
168 return $ foldl' (flip applyExternsFileToEnvironment) initEnvironment externs
170 where
171 checkModuleNamesAreUnique :: m ()
172 checkModuleNamesAreUnique =
173 case findDuplicate (map getModuleName ms) of
174 Nothing -> return ()
175 Just mn -> throwError . errorMessage $ DuplicateModuleName mn
177 -- Verify that a list of values has unique keys
178 findDuplicate :: (Ord a) => [a] -> Maybe a
179 findDuplicate = go . sort
180 where
181 go (x : y : xs)
182 | x == y = Just x
183 | otherwise = go (y : xs)
184 go _ = Nothing
186 -- Sort a list so its elements appear in the same order as in another list.
187 inOrderOf :: (Ord a) => [a] -> [a] -> [a]
188 inOrderOf xs ys = let s = S.fromList xs in filter (`S.member` s) ys
190 buildModule :: [(ModuleName, (C.MVar (Maybe (MultipleErrors, ExternsFile)), C.MVar (Maybe MultipleErrors)))] -> Module -> [ModuleName] -> m ()
191 buildModule barriers m@(Module _ _ moduleName _ _) deps = flip catchError (markComplete Nothing . Just) $ do
192 -- We need to wait for dependencies to be built, before checking if the current
193 -- module should be rebuilt, so the first thing to do is to wait on the
194 -- MVars for the module's dependencies.
195 mexterns <- fmap unzip . sequence <$> traverse (readMVar . fst . fromMaybe (internalError "make: no barrier") . flip lookup barriers) deps
197 case mexterns of
198 Just (_, externs) -> do
199 outputTimestamp <- getOutputTimestamp moduleName
200 dependencyTimestamp <- maximumMaybe <$> traverse (fmap shouldExist . getOutputTimestamp) deps
201 inputTimestamp <- getInputTimestamp moduleName
203 let shouldRebuild = case (inputTimestamp, dependencyTimestamp, outputTimestamp) of
204 (Right (Just t1), Just t3, Just t2) -> t1 > t2 || t3 > t2
205 (Right (Just t1), Nothing, Just t2) -> t1 > t2
206 (Left RebuildNever, _, Just _) -> False
207 _ -> True
209 let rebuild = do
210 (exts, warnings) <- listen $ do
211 progress $ CompilingModule moduleName
212 let env = foldl' (flip applyExternsFileToEnvironment) initEnvironment externs
213 lint m
214 ((checked@(Module ss coms _ elaborated exps), env'), nextVar) <- runSupplyT 0 $ do
215 [desugared] <- desugar externs [m]
216 runCheck' env $ typeCheckModule desugared
217 checkExhaustiveModule env' checked
218 regrouped <- createBindingGroups moduleName . collapseBindingGroups $ elaborated
219 let mod' = Module ss coms moduleName regrouped exps
220 corefn = CF.moduleToCoreFn env' mod'
221 [renamed] = renameInModules [corefn]
222 exts = moduleToExternsFile mod' env'
223 evalSupplyT nextVar . codegen renamed env' . BU8.toString . B.toStrict . encode $ exts
224 return exts
225 markComplete (Just (warnings, exts)) Nothing
227 if shouldRebuild
228 then rebuild
229 else do
230 mexts <- decodeExterns . snd <$> readExterns moduleName
231 case mexts of
232 Just exts -> markComplete (Just (mempty, exts)) Nothing
233 Nothing -> rebuild
234 Nothing -> markComplete Nothing Nothing
235 where
236 markComplete :: Maybe (MultipleErrors, ExternsFile) -> Maybe MultipleErrors -> m ()
237 markComplete externs errors = do
238 putMVar (fst $ fromMaybe (internalError "make: no barrier") $ lookup moduleName barriers) externs
239 putMVar (snd $ fromMaybe (internalError "make: no barrier") $ lookup moduleName barriers) errors
241 maximumMaybe :: (Ord a) => [a] -> Maybe a
242 maximumMaybe [] = Nothing
243 maximumMaybe xs = Just $ maximum xs
245 -- Make sure a dependency exists
246 shouldExist :: Maybe UTCTime -> UTCTime
247 shouldExist (Just t) = t
248 shouldExist _ = internalError "make: dependency should already have been built."
250 decodeExterns :: Externs -> Maybe ExternsFile
251 decodeExterns bs = do
252 externs <- decode (fromString bs)
253 guard $ efVersion externs == showVersion Paths.version
254 return externs
256importPrim :: Module -> Module
257importPrim = addDefaultImport (ModuleName [ProperName C.prim])
259-- |
260-- A monad for running make actions
261--
262newtype Make a = Make { unMake :: ReaderT Options (ExceptT MultipleErrors (Logger MultipleErrors)) a }
263 deriving (Functor, Applicative, Monad, MonadIO, MonadError MultipleErrors, MonadWriter MultipleErrors, MonadReader Options)
265instance MonadBase IO Make where
266 liftBase = liftIO
268instance MonadBaseControl IO Make where
269 type StM Make a = Either MultipleErrors a
270 liftBaseWith f = Make $ liftBaseWith $ \q -> f (q . unMake)
271 restoreM = Make . restoreM
273-- |
274-- Execute a 'Make' monad, returning either errors, or the result of the compile plus any warnings.
275--
276runMake :: Options -> Make a -> IO (Either MultipleErrors a, MultipleErrors)
277runMake opts = runLogger' . runExceptT . flip runReaderT opts . unMake
279makeIO :: (IOError -> ErrorMessage) -> IO a -> Make a
280makeIO f io = do
281 e <- liftIO $ tryIOError io
282 either (throwError . singleError . f) return e
284-- Traverse (Either e) instance (base 4.7)
285traverseEither :: Applicative f => (a -> f b) -> Either e a -> f (Either e b)
286traverseEither _ (Left x) = pure (Left x)
287traverseEither f (Right y) = Right <$> f y
289-- |
290-- A set of make actions that read and write modules from the given directory.
291--
292buildMakeActions :: FilePath -- ^ the output directory
293 -> M.Map ModuleName (Either RebuildPolicy FilePath) -- ^ a map between module names and paths to the file containing the PureScript module
294 -> M.Map ModuleName FilePath -- ^ a map between module name and the file containing the foreign javascript for the module
295 -> Bool -- ^ Generate a prefix comment?
296 -> MakeActions Make
297buildMakeActions outputDir filePathMap foreigns usePrefix =
298 MakeActions getInputTimestamp getOutputTimestamp readExterns codegen progress
299 where
301 getInputTimestamp :: ModuleName -> Make (Either RebuildPolicy (Maybe UTCTime))
302 getInputTimestamp mn = do
303 let path = fromMaybe (internalError "Module has no filename in 'make'") $ M.lookup mn filePathMap
304 e1 <- traverseEither getTimestamp path
305 fPath <- maybe (return Nothing) getTimestamp $ M.lookup mn foreigns
306 return $ fmap (max fPath) e1
308 getOutputTimestamp :: ModuleName -> Make (Maybe UTCTime)
309 getOutputTimestamp mn = do
310 let filePath = runModuleName mn
311 jsFile = outputDir </> filePath </> "index.js"
312 externsFile = outputDir </> filePath </> "externs.json"
313 min <$> getTimestamp jsFile <*> getTimestamp externsFile
315 readExterns :: ModuleName -> Make (FilePath, Externs)
316 readExterns mn = do
317 let path = outputDir </> runModuleName mn </> "externs.json"
318 (path, ) <$> readTextFile path
320 codegen :: CF.Module CF.Ann -> Environment -> Externs -> SupplyT Make ()
321 codegen m _ exts = do
322 let mn = CF.moduleName m
323 foreignInclude <- case mn `M.lookup` foreigns of
324 Just path
325 | not $ requiresForeign m -> do
326 tell $ errorMessage $ UnnecessaryFFIModule mn path
327 return Nothing
328 | otherwise -> return $ Just $ J.JSApp (J.JSVar "require") [J.JSStringLiteral "./foreign"]
329 Nothing | requiresForeign m -> throwError . errorMessage $ MissingFFIModule mn
330 | otherwise -> return Nothing
331 pjs <- prettyPrintJS <$> J.moduleToJs m foreignInclude
332 let filePath = runModuleName mn
333 jsFile = outputDir </> filePath </> "index.js"
334 externsFile = outputDir </> filePath </> "externs.json"
335 foreignFile = outputDir </> filePath </> "foreign.js"
336 prefix = ["Generated by psc version " ++ showVersion Paths.version | usePrefix]
337 js = unlines $ map ("// " ++) prefix ++ [pjs]
338 lift $ do
339 writeTextFile jsFile (fromString js)
340 for_ (mn `M.lookup` foreigns) (readTextFile >=> writeTextFile foreignFile)
341 writeTextFile externsFile exts
343 requiresForeign :: CF.Module a -> Bool
344 requiresForeign = not . null . CF.moduleForeign
346 getTimestamp :: FilePath -> Make (Maybe UTCTime)
347 getTimestamp path = makeIO (const (ErrorMessage [] $ CannotGetFileInfo path)) $ do
348 exists <- doesFileExist path
349 traverse (const $ getModificationTime path) $ guard exists
351 readTextFile :: FilePath -> Make String
352 readTextFile path = makeIO (const (ErrorMessage [] $ CannotReadFile path)) $ readUTF8File path
354 writeTextFile :: FilePath -> String -> Make ()
355 writeTextFile path text = makeIO (const (ErrorMessage [] $ CannotWriteFile path)) $ do
356 mkdirp path
357 writeUTF8File path text
358 where
359 mkdirp :: FilePath -> IO ()
360 mkdirp = createDirectoryIfMissing True . takeDirectory
362 progress :: ProgressMessage -> Make ()
363 progress = liftIO . putStrLn . renderProgressMessage