git.iko.soy/rowtype-yoga/purescript-native
on f065d07 help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/Make.hs
312 lines 12 kB history raw
1-----------------------------------------------------------------------------
2--
3-- Module : Make
4-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5-- License : 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 , MakeActions(..)
28 , SupplyVar()
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
46import Control.Monad.Supply.Class (fresh)
48import Data.Function (on)
49import Data.List (sortBy, groupBy)
50import Data.Maybe (fromMaybe)
51import Data.Time.Clock
52import Data.Foldable (for_)
53import Data.Traversable (traverse)
54import Data.Version (showVersion)
55import qualified Data.Map as M
56import qualified Data.Set as S
58import System.Directory
59 (doesFileExist, getModificationTime, createDirectoryIfMissing)
60import System.FilePath ((</>), takeDirectory)
61import System.IO.Error (tryIOError)
64import Language.PureScript.AST
65import Language.PureScript.CodeGen.Externs (moduleToPs)
66import Language.PureScript.Environment
67import Language.PureScript.Errors
68import Language.PureScript.Linter
69import Language.PureScript.ModuleDependencies
70import Language.PureScript.Names
71import Language.PureScript.Options
72import Language.PureScript.Parser
73import Language.PureScript.Pretty
74import Language.PureScript.Renamer
75import Language.PureScript.Sugar
76import Language.PureScript.TypeChecker
77import qualified Language.PureScript.Constants as C
79import qualified Language.PureScript.CodeGen.JS as J
80import qualified Language.PureScript.CoreFn as CF
81import qualified Paths_purescript as Paths
83-- |
84-- Actions that require implementations when running in "make" mode.
85--
86data MakeActions m = MakeActions {
87 -- |
88 -- Get the timestamp for the input file(s) for a module. If there are multiple
89 -- files (.purs and foreign files, for example) the timestamp should be for
90 -- the most recently modified file.
91 --
92 getInputTimestamp :: ModuleName -> m (Either RebuildPolicy (Maybe UTCTime))
93 -- |
94 -- Get the timestamp for the output files for a module. This should be the
95 -- timestamp for the oldest modified file, or Nothing if any of the required
96 -- output files are missing.
97 --
98 , getOutputTimestamp :: ModuleName -> m (Maybe UTCTime)
99 -- |
100 -- Read the externs file for a module as a string and also return the actual
101 -- path for the file.
102 , readExterns :: ModuleName -> m (FilePath, String)
103 -- |
104 -- Run the code generator for the module and write any required output files.
105 --
106 , codegen :: CF.Module CF.Ann -> Environment -> SupplyVar -> Externs -> m ()
107 -- |
108 -- Respond to a progress update.
109 --
110 , progress :: String -> m ()
111 }
113-- |
114-- Generated code for an externs file.
115--
116type Externs = String
118-- |
119-- A value to be used in the Supply monad.
120--
121type SupplyVar = Integer
123-- |
124-- Determines when to rebuild a module
125--
126data RebuildPolicy
127 -- | Never rebuild this module
128 = RebuildNever
129 -- | Always rebuild this module
130 | RebuildAlways deriving (Show, Eq, Ord)
132-- |
133-- Compiles in "make" mode, compiling each module separately to a js files and an externs file
134--
135-- If timestamps have not changed, the externs file can be used to provide the module's types without
136-- having to typecheck the module again.
137--
138make :: forall m. (Functor m, Applicative m, Monad m, MonadReader Options m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
139 => MakeActions m
140 -> [Module]
141 -> m Environment
142make MakeActions{..} ms = do
143 (sorted, graph) <- sortModules $ map importPrim ms
144 toRebuild <- foldM (\s (Module _ moduleName' _ _) -> do
145 inputTimestamp <- getInputTimestamp moduleName'
146 outputTimestamp <- getOutputTimestamp moduleName'
147 return $ case (inputTimestamp, outputTimestamp) of
148 (Right (Just t1), Just t2) | t1 < t2 -> s
149 (Left RebuildNever, Just _) -> s
150 _ -> S.insert moduleName' s) S.empty sorted
152 marked <- rebuildIfNecessary (reverseDependencies graph) toRebuild sorted
153 for_ marked $ \(willRebuild, m) -> when willRebuild (lint m)
154 (desugared, nextVar) <- runSupplyT 0 $ zip (map fst marked) <$> desugar (map snd marked)
155 evalSupplyT nextVar $ go initEnvironment desugared
156 where
158 go :: Environment -> [(Bool, Module)] -> SupplyT m Environment
159 go env [] = return env
160 go env ((False, m) : ms') = do
161 (_, env') <- lift . runCheck' env $ typeCheckModule Nothing m
162 go env' ms'
163 go env ((True, m@(Module coms moduleName' _ exps)) : ms') = do
164 lift $ progress $ "Compiling " ++ runModuleName moduleName'
165 (checked@(Module _ _ elaborated _), env') <- lift . runCheck' env $ typeCheckModule Nothing m
166 checkExhaustiveModule env' checked
167 regrouped <- createBindingGroups moduleName' . collapseBindingGroups $ elaborated
168 let mod' = Module coms moduleName' regrouped exps
169 corefn = CF.moduleToCoreFn env' mod'
170 [renamed] = renameInModules [corefn]
171 exts = moduleToPs mod' env'
172 nextVar <- fresh
173 lift $ codegen renamed env' nextVar exts
174 go env' ms'
176 rebuildIfNecessary :: M.Map ModuleName [ModuleName] -> S.Set ModuleName -> [Module] -> m [(Bool, Module)]
177 rebuildIfNecessary _ _ [] = return []
178 rebuildIfNecessary graph toRebuild (m@(Module _ moduleName' _ _) : ms') | moduleName' `S.member` toRebuild = do
179 let deps = fromMaybe [] $ moduleName' `M.lookup` graph
180 toRebuild' = toRebuild `S.union` S.fromList deps
181 (:) (True, m) <$> rebuildIfNecessary graph toRebuild' ms'
182 rebuildIfNecessary graph toRebuild (Module _ moduleName' _ _ : ms') = do
183 (path, externs) <- readExterns moduleName'
184 externsModules <- fmap (map snd) . alterErrors $ parseModulesFromFiles id [(path, externs)]
185 case externsModules of
186 [m'@(Module _ moduleName'' _ _)] | moduleName'' == moduleName' -> (:) (False, m') <$> rebuildIfNecessary graph toRebuild ms'
187 _ -> throwError . errorMessage . InvalidExternsFile $ path
188 where
189 alterErrors = flip catchError $ \(MultipleErrors errs) ->
190 throwError . MultipleErrors $ flip map errs $ \e -> case e of
191 SimpleErrorWrapper (ErrorParsingModule err) -> SimpleErrorWrapper (ErrorParsingExterns err)
192 _ -> e
194reverseDependencies :: ModuleGraph -> M.Map ModuleName [ModuleName]
195reverseDependencies g = combine [ (dep, mn) | (mn, deps) <- g, dep <- deps ]
196 where
197 combine :: (Ord a) => [(a, b)] -> M.Map a [b]
198 combine = M.fromList . map ((fst . head) &&& map snd) . groupBy ((==) `on` fst) . sortBy (compare `on` fst)
200-- |
201-- Add an import declaration for a module if it does not already explicitly import it.
202--
203addDefaultImport :: ModuleName -> Module -> Module
204addDefaultImport toImport m@(Module coms mn decls exps) =
205 if isExistingImport `any` decls || mn == toImport then m
206 else Module coms mn (ImportDeclaration toImport Implicit Nothing : decls) exps
207 where
208 isExistingImport (ImportDeclaration mn' _ _) | mn' == toImport = True
209 isExistingImport (PositionedDeclaration _ _ d) = isExistingImport d
210 isExistingImport _ = False
212importPrim :: Module -> Module
213importPrim = addDefaultImport (ModuleName [ProperName C.prim])
215-- |
216-- A monad for running make actions
217--
218newtype Make a = Make { unMake :: ReaderT Options (WriterT MultipleErrors (ExceptT MultipleErrors IO)) a }
219 deriving (Functor, Applicative, Monad, MonadIO, MonadError MultipleErrors, MonadWriter MultipleErrors, MonadReader Options)
221-- |
222-- Execute a 'Make' monad, returning either errors, or the result of the compile plus any warnings.
223--
224runMake :: Options -> Make a -> IO (Either MultipleErrors (a, MultipleErrors))
225runMake opts = runExceptT . runWriterT . flip runReaderT opts . unMake
227makeIO :: (IOError -> ErrorMessage) -> IO a -> Make a
228makeIO f io = do
229 e <- liftIO $ tryIOError io
230 either (throwError . singleError . f) return e
232-- Traverse (Either e) instance (base 4.7)
233traverseEither :: Applicative f => (a -> f b) -> Either e a -> f (Either e b)
234traverseEither _ (Left x) = pure (Left x)
235traverseEither f (Right y) = Right <$> f y
237-- |
238-- A set of make actions that read and write modules from the given directory.
239--
240buildMakeActions :: FilePath -- ^ the output directory
241 -> M.Map ModuleName (Either RebuildPolicy String) -- ^ a map between module names and paths to the file containing the PureScript module
242 -> M.Map ModuleName (FilePath, ForeignJS) -- ^ a map between module name and the file containing the foreign javascript for the module
243 -> Bool -- ^ Generate a prefix comment?
244 -> MakeActions Make
245buildMakeActions outputDir filePathMap foreigns usePrefix =
246 MakeActions getInputTimestamp getOutputTimestamp readExterns codegen progress
247 where
249 getInputTimestamp :: ModuleName -> Make (Either RebuildPolicy (Maybe UTCTime))
250 getInputTimestamp mn = do
251 let path = fromMaybe (error "Module has no filename in 'make'") $ M.lookup mn filePathMap
252 e1 <- traverseEither getTimestamp path
253 fPath <- maybe (return Nothing) (getTimestamp . fst) $ M.lookup mn foreigns
254 return $ fmap (max fPath) e1
256 getOutputTimestamp :: ModuleName -> Make (Maybe UTCTime)
257 getOutputTimestamp mn = do
258 let filePath = runModuleName mn
259 jsFile = outputDir </> filePath </> "index.js"
260 externsFile = outputDir </> filePath </> "externs.purs"
261 min <$> getTimestamp jsFile <*> getTimestamp externsFile
263 readExterns :: ModuleName -> Make (FilePath, String)
264 readExterns mn = do
265 let path = outputDir </> runModuleName mn </> "externs.purs"
266 (path, ) <$> readTextFile path
268 codegen :: CF.Module CF.Ann -> Environment -> SupplyVar -> Externs -> Make ()
269 codegen m _ nextVar exts = do
270 let mn = CF.moduleName m
271 foreignInclude <- case mn `M.lookup` foreigns of
272 Just (path, _)
273 | not $ requiresForeign m -> do
274 tell $ errorMessage $ UnnecessaryFFIModule mn path
275 return Nothing
276 | otherwise -> return $ Just $ J.JSApp (J.JSVar "require") [J.JSStringLiteral "./foreign"]
277 Nothing | requiresForeign m -> throwError . errorMessage $ MissingFFIModule mn
278 | otherwise -> return Nothing
279 pjs <- evalSupplyT nextVar $ prettyPrintJS <$> J.moduleToJs m foreignInclude
280 let filePath = runModuleName mn
281 jsFile = outputDir </> filePath </> "index.js"
282 externsFile = outputDir </> filePath </> "externs.purs"
283 foreignFile = outputDir </> filePath </> "foreign.js"
284 prefix = ["Generated by psc version " ++ showVersion Paths.version | usePrefix]
285 js = unlines $ map ("// " ++) prefix ++ [pjs]
286 verboseErrorsEnabled <- asks optionsVerboseErrors
287 when verboseErrorsEnabled $ progress $ "Writing " ++ jsFile
288 writeTextFile jsFile js
289 maybe (return ()) (writeTextFile foreignFile . snd) $ mn `M.lookup` foreigns
290 writeTextFile externsFile exts
292 requiresForeign :: CF.Module a -> Bool
293 requiresForeign = not . null . CF.moduleForeign
295 getTimestamp :: FilePath -> Make (Maybe UTCTime)
296 getTimestamp path = makeIO (const (SimpleErrorWrapper $ CannotGetFileInfo path)) $ do
297 exists <- doesFileExist path
298 traverse (const $ getModificationTime path) $ guard exists
300 readTextFile :: FilePath -> Make String
301 readTextFile path = makeIO (const (SimpleErrorWrapper $ CannotReadFile path)) $ readFile path
303 writeTextFile :: FilePath -> String -> Make ()
304 writeTextFile path text = makeIO (const (SimpleErrorWrapper $ CannotWriteFile path)) $ do
305 mkdirp path
306 writeFile path text
307 where
308 mkdirp :: FilePath -> IO ()
309 mkdirp = createDirectoryIfMissing True . takeDirectory
311 progress :: String -> Make ()
312 progress = liftIO . putStrLn