git.iko.soy/rowtype-yoga/purescript-native
on e6e1f2a help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/Make.hs
317 lines 13 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 #-}
23module Language.PureScript.Make
24 (
25 -- * Make API
26 RebuildPolicy(..)
27 , ProgressMessage(..), renderProgressMessage
28 , MakeActions(..)
29 , Externs()
30 , make
32 -- * Implementation of Make API using files on disk
33 , Make(..)
34 , runMake
35 , buildMakeActions
36 ) where
38import Control.Applicative
39import Control.Arrow ((&&&))
40import Control.Monad
41import Control.Monad.Error.Class (MonadError(..))
42import Control.Monad.Trans.Except
43import Control.Monad.Reader
44import Control.Monad.Writer
45import Control.Monad.Supply
47import Data.Function (on)
48import Data.List (sortBy, groupBy)
49import Data.Maybe (fromMaybe)
50import Data.Time.Clock
51import Data.Foldable (for_)
52import Data.Traversable (traverse)
53import Data.Version (showVersion)
54import qualified Data.Map as M
55import qualified Data.Set as S
57import System.Directory
58 (doesFileExist, getModificationTime, createDirectoryIfMissing)
59import System.FilePath ((</>), takeDirectory)
60import System.IO.Error (tryIOError)
62import Language.PureScript.AST
63import Language.PureScript.CodeGen.Externs (moduleToPs)
64import Language.PureScript.Environment
65import Language.PureScript.Errors
66import Language.PureScript.Linter
67import Language.PureScript.ModuleDependencies
68import Language.PureScript.Names
69import Language.PureScript.Options
70import Language.PureScript.Parser
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, 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, String)
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, 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, MonadReader Options m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
146 => MakeActions m
147 -> [Module]
148 -> m Environment
149make MakeActions{..} ms = do
150 (sorted, graph) <- sortModules $ map importPrim ms
151 toRebuild <- foldM (\s (Module _ _ moduleName' _ _) -> do
152 inputTimestamp <- getInputTimestamp moduleName'
153 outputTimestamp <- getOutputTimestamp moduleName'
154 return $ case (inputTimestamp, outputTimestamp) of
155 (Right (Just t1), Just t2) | t1 < t2 -> s
156 (Left RebuildNever, Just _) -> s
157 _ -> S.insert moduleName' s) S.empty sorted
159 marked <- rebuildIfNecessary (reverseDependencies graph) toRebuild sorted
160 for_ marked $ \(willRebuild, m) -> when willRebuild (lint m)
161 (desugared, nextVar) <- runSupplyT 0 $ zip (map fst marked) <$> desugar (map snd marked)
162 evalSupplyT nextVar $ go initEnvironment desugared
163 where
165 go :: Environment -> [(Bool, Module)] -> SupplyT m Environment
166 go env [] = return env
167 go env ((False, m) : ms') = do
168 (_, env') <- lift . runCheck' env $ typeCheckModule Nothing m
169 go env' ms'
170 go env ((True, m@(Module ss coms moduleName' _ exps)) : ms') = do
171 lift . progress $ CompilingModule moduleName'
172 (checked@(Module _ _ _ elaborated _), env') <- lift . runCheck' env $ typeCheckModule Nothing m
173 checkExhaustiveModule env' checked
174 regrouped <- createBindingGroups moduleName' . collapseBindingGroups $ elaborated
175 let mod' = Module ss coms moduleName' regrouped exps
176 corefn = CF.moduleToCoreFn env' mod'
177 [renamed] = renameInModules [corefn]
178 exts = moduleToPs mod' env'
179 codegen renamed env' exts
180 go env' ms'
182 rebuildIfNecessary :: M.Map ModuleName [ModuleName] -> S.Set ModuleName -> [Module] -> m [(Bool, Module)]
183 rebuildIfNecessary _ _ [] = return []
184 rebuildIfNecessary graph toRebuild (m@(Module _ _ moduleName' _ _) : ms') | moduleName' `S.member` toRebuild = do
185 let deps = fromMaybe [] $ moduleName' `M.lookup` graph
186 toRebuild' = toRebuild `S.union` S.fromList deps
187 (:) (True, m) <$> rebuildIfNecessary graph toRebuild' ms'
188 rebuildIfNecessary graph toRebuild (Module _ _ moduleName' _ _ : ms') = do
189 (path, externs) <- readExterns moduleName'
190 externsModules <- fmap (map snd) . alterErrors $ parseModulesFromFiles id [(path, externs)]
191 case externsModules of
192 [m'@(Module _ _ moduleName'' _ _)] | moduleName'' == moduleName' -> (:) (False, m') <$> rebuildIfNecessary graph toRebuild ms'
193 _ -> throwError . errorMessage . InvalidExternsFile $ path
194 where
195 alterErrors = flip catchError $ \(MultipleErrors errs) ->
196 throwError . MultipleErrors $ flip map errs $ \e -> case e of
197 SimpleErrorWrapper (ErrorParsingModule err) -> SimpleErrorWrapper (ErrorParsingExterns err)
198 _ -> e
200reverseDependencies :: ModuleGraph -> M.Map ModuleName [ModuleName]
201reverseDependencies g = combine [ (dep, mn) | (mn, deps) <- g, dep <- deps ]
202 where
203 combine :: (Ord a) => [(a, b)] -> M.Map a [b]
204 combine = M.fromList . map ((fst . head) &&& map snd) . groupBy ((==) `on` fst) . sortBy (compare `on` fst)
206-- |
207-- Add an import declaration for a module if it does not already explicitly import it.
208--
209addDefaultImport :: ModuleName -> Module -> Module
210addDefaultImport toImport m@(Module ss coms mn decls exps) =
211 if isExistingImport `any` decls || mn == toImport then m
212 else Module ss coms mn (ImportDeclaration toImport Implicit Nothing : decls) exps
213 where
214 isExistingImport (ImportDeclaration mn' _ _) | mn' == toImport = True
215 isExistingImport (PositionedDeclaration _ _ d) = isExistingImport d
216 isExistingImport _ = False
218importPrim :: Module -> Module
219importPrim = addDefaultImport (ModuleName [ProperName C.prim])
221-- |
222-- A monad for running make actions
223--
224newtype Make a = Make { unMake :: ReaderT Options (WriterT MultipleErrors (ExceptT MultipleErrors IO)) a }
225 deriving (Functor, Applicative, Monad, MonadIO, MonadError MultipleErrors, MonadWriter MultipleErrors, MonadReader Options)
227-- |
228-- Execute a 'Make' monad, returning either errors, or the result of the compile plus any warnings.
229--
230runMake :: Options -> Make a -> IO (Either MultipleErrors (a, MultipleErrors))
231runMake opts = runExceptT . runWriterT . flip runReaderT opts . unMake
233makeIO :: (IOError -> ErrorMessage) -> IO a -> Make a
234makeIO f io = do
235 e <- liftIO $ tryIOError io
236 either (throwError . singleError . f) return e
238-- Traverse (Either e) instance (base 4.7)
239traverseEither :: Applicative f => (a -> f b) -> Either e a -> f (Either e b)
240traverseEither _ (Left x) = pure (Left x)
241traverseEither f (Right y) = Right <$> f y
243-- |
244-- A set of make actions that read and write modules from the given directory.
245--
246buildMakeActions :: FilePath -- ^ the output directory
247 -> M.Map ModuleName (Either RebuildPolicy FilePath) -- ^ a map between module names and paths to the file containing the PureScript module
248 -> M.Map ModuleName FilePath -- ^ a map between module name and the file containing the foreign javascript for the module
249 -> Bool -- ^ Generate a prefix comment?
250 -> MakeActions Make
251buildMakeActions outputDir filePathMap foreigns usePrefix =
252 MakeActions getInputTimestamp getOutputTimestamp readExterns codegen progress
253 where
255 getInputTimestamp :: ModuleName -> Make (Either RebuildPolicy (Maybe UTCTime))
256 getInputTimestamp mn = do
257 let path = fromMaybe (error "Module has no filename in 'make'") $ M.lookup mn filePathMap
258 e1 <- traverseEither getTimestamp path
259 fPath <- maybe (return Nothing) getTimestamp $ M.lookup mn foreigns
260 return $ fmap (max fPath) e1
262 getOutputTimestamp :: ModuleName -> Make (Maybe UTCTime)
263 getOutputTimestamp mn = do
264 let filePath = runModuleName mn
265 jsFile = outputDir </> filePath </> "index.js"
266 externsFile = outputDir </> filePath </> "externs.purs"
267 min <$> getTimestamp jsFile <*> getTimestamp externsFile
269 readExterns :: ModuleName -> Make (FilePath, String)
270 readExterns mn = do
271 let path = outputDir </> runModuleName mn </> "externs.purs"
272 (path, ) <$> readTextFile path
274 codegen :: CF.Module CF.Ann -> Environment -> Externs -> SupplyT Make ()
275 codegen m _ exts = do
276 let mn = CF.moduleName m
277 foreignInclude <- case mn `M.lookup` foreigns of
278 Just path
279 | not $ requiresForeign m -> do
280 tell $ errorMessage $ UnnecessaryFFIModule mn path
281 return Nothing
282 | otherwise -> return $ Just $ J.JSApp (J.JSVar "require") [J.JSStringLiteral "./foreign"]
283 Nothing | requiresForeign m -> throwError . errorMessage $ MissingFFIModule mn
284 | otherwise -> return Nothing
285 pjs <- prettyPrintJS <$> J.moduleToJs m foreignInclude
286 let filePath = runModuleName mn
287 jsFile = outputDir </> filePath </> "index.js"
288 externsFile = outputDir </> filePath </> "externs.purs"
289 foreignFile = outputDir </> filePath </> "foreign.js"
290 prefix = ["Generated by psc version " ++ showVersion Paths.version | usePrefix]
291 js = unlines $ map ("// " ++) prefix ++ [pjs]
292 lift $ do
293 writeTextFile jsFile js
294 for_ (mn `M.lookup` foreigns) (readTextFile >=> writeTextFile foreignFile)
295 writeTextFile externsFile exts
297 requiresForeign :: CF.Module a -> Bool
298 requiresForeign = not . null . CF.moduleForeign
300 getTimestamp :: FilePath -> Make (Maybe UTCTime)
301 getTimestamp path = makeIO (const (SimpleErrorWrapper $ CannotGetFileInfo path)) $ do
302 exists <- doesFileExist path
303 traverse (const $ getModificationTime path) $ guard exists
305 readTextFile :: FilePath -> Make String
306 readTextFile path = makeIO (const (SimpleErrorWrapper $ CannotReadFile path)) $ readFile path
308 writeTextFile :: FilePath -> String -> Make ()
309 writeTextFile path text = makeIO (const (SimpleErrorWrapper $ CannotWriteFile path)) $ do
310 mkdirp path
311 writeFile path text
312 where
313 mkdirp :: FilePath -> IO ()
314 mkdirp = createDirectoryIfMissing True . takeDirectory
316 progress :: ProgressMessage -> Make ()
317 progress = liftIO . putStrLn . renderProgressMessage