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