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