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