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