git.iko.soy/rowtype-yoga/purescript-native
on 532e62d help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/Make.hs
313 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 (Module _ _ elaborated _, env') <- lift . runCheck' env $ typeCheckModule Nothing m
165 regrouped <- createBindingGroups moduleName' . collapseBindingGroups $ elaborated
166 let mod' = Module coms moduleName' regrouped exps
167 corefn = CF.moduleToCoreFn env' mod'
168 [renamed] = renameInModules [corefn]
169 exts = moduleToPs mod' env'
170 nextVar <- fresh
171 lift $ codegen renamed env' nextVar exts
172 go env' ms'
174 rebuildIfNecessary :: M.Map ModuleName [ModuleName] -> S.Set ModuleName -> [Module] -> m [(Bool, Module)]
175 rebuildIfNecessary _ _ [] = return []
176 rebuildIfNecessary graph toRebuild (m@(Module _ moduleName' _ _) : ms') | moduleName' `S.member` toRebuild = do
177 let deps = fromMaybe [] $ moduleName' `M.lookup` graph
178 toRebuild' = toRebuild `S.union` S.fromList deps
179 (:) (True, m) <$> rebuildIfNecessary graph toRebuild' ms'
180 rebuildIfNecessary graph toRebuild (Module _ moduleName' _ _ : ms') = do
181 (path, externs) <- readExterns moduleName'
182 externsModules <- fmap (map snd) . alterErrors $ parseModulesFromFiles id [(path, externs)]
183 case externsModules of
184 [m'@(Module _ moduleName'' _ _)] | moduleName'' == moduleName' -> (:) (False, m') <$> rebuildIfNecessary graph toRebuild ms'
185 _ -> throwError . errorMessage . InvalidExternsFile $ path
186 where
187 alterErrors = flip catchError $ \(MultipleErrors errs) ->
188 throwError . MultipleErrors $ flip map errs $ \e -> case e of
189 SimpleErrorWrapper (ErrorParsingModule err) -> SimpleErrorWrapper (ErrorParsingExterns err)
190 _ -> e
192reverseDependencies :: ModuleGraph -> M.Map ModuleName [ModuleName]
193reverseDependencies g = combine [ (dep, mn) | (mn, deps) <- g, dep <- deps ]
194 where
195 combine :: (Ord a) => [(a, b)] -> M.Map a [b]
196 combine = M.fromList . map ((fst . head) &&& map snd) . groupBy ((==) `on` fst) . sortBy (compare `on` fst)
198-- |
199-- Add an import declaration for a module if it does not already explicitly import it.
200--
201addDefaultImport :: ModuleName -> Module -> Module
202addDefaultImport toImport m@(Module coms mn decls exps) =
203 if isExistingImport `any` decls || mn == toImport then m
204 else Module coms mn (ImportDeclaration toImport Implicit Nothing : decls) exps
205 where
206 isExistingImport (ImportDeclaration mn' _ _) | mn' == toImport = True
207 isExistingImport (PositionedDeclaration _ _ d) = isExistingImport d
208 isExistingImport _ = False
210importPrim :: Module -> Module
211importPrim = addDefaultImport (ModuleName [ProperName C.prim])
213-- |
214-- A monad for running make actions
215--
216newtype Make a = Make { unMake :: ReaderT Options (WriterT MultipleErrors (ExceptT MultipleErrors IO)) a }
217 deriving (Functor, Applicative, Monad, MonadIO, MonadError MultipleErrors, MonadWriter MultipleErrors, MonadReader Options)
219-- |
220-- Execute a 'Make' monad, returning either errors, or the result of the compile plus any warnings.
221--
222runMake :: Options -> Make a -> IO (Either MultipleErrors (a, MultipleErrors))
223runMake opts = runExceptT . runWriterT . flip runReaderT opts . unMake
225makeIO :: (IOError -> ErrorMessage) -> IO a -> Make a
226makeIO f io = do
227 e <- liftIO $ tryIOError io
228 either (throwError . singleError . f) return e
230-- Traverse (Either e) instance (base 4.7)
231traverseEither :: Applicative f => (a -> f b) -> Either e a -> f (Either e b)
232traverseEither _ (Left x) = pure (Left x)
233traverseEither f (Right y) = Right <$> f y
235-- |
236-- A set of make actions that read and write modules from the given directory.
237--
238buildMakeActions :: FilePath -- ^ the output directory
239 -> M.Map ModuleName (Either RebuildPolicy String) -- ^ a map between module names and paths to the file containing the PureScript module
240 -> M.Map ModuleName (FilePath, ForeignJS) -- ^ a map between module name and the file containing the foreign javascript for the module
241 -> Bool -- ^ Generate a prefix comment?
242 -> MakeActions Make
243buildMakeActions outputDir filePathMap foreigns usePrefix =
244 MakeActions getInputTimestamp getOutputTimestamp readExterns codegen progress
245 where
247 getInputTimestamp :: ModuleName -> Make (Either RebuildPolicy (Maybe UTCTime))
248 getInputTimestamp mn = do
249 let path = fromMaybe (error "Module has no filename in 'make'") $ M.lookup mn filePathMap
250 e1 <- traverseEither getTimestamp path
251 fPath <- maybe (return Nothing) (getTimestamp . fst) $ M.lookup mn foreigns
252 return $ fmap (max fPath) e1
254 getOutputTimestamp :: ModuleName -> Make (Maybe UTCTime)
255 getOutputTimestamp mn = do
256 let filePath = runModuleName mn
257 jsFile = outputDir </> filePath </> "index.js"
258 externsFile = outputDir </> filePath </> "externs.purs"
259 min <$> getTimestamp jsFile <*> getTimestamp externsFile
261 readExterns :: ModuleName -> Make (FilePath, String)
262 readExterns mn = do
263 let path = outputDir </> runModuleName mn </> "externs.purs"
264 (path, ) <$> readTextFile path
266 codegen :: CF.Module CF.Ann -> Environment -> SupplyVar -> Externs -> Make ()
267 codegen m _ nextVar exts = do
268 let mn = CF.moduleName m
269 foreignInclude <- case mn `M.lookup` foreigns of
270 Just (path, _)
271 | not $ requiresForeign m -> do
272 tell $ errorMessage $ UnnecessaryFFIModule mn path
273 return Nothing
274 | otherwise -> return $ Just $ J.JSApp (J.JSVar "require") [J.JSStringLiteral "./foreign"]
275 Nothing | requiresForeign m -> throwError . errorMessage $ MissingFFIModule mn
276 | otherwise -> return Nothing
277 pjs <- evalSupplyT nextVar $ prettyPrintJS <$> J.moduleToJs m foreignInclude
278 let filePath = runModuleName mn
279 jsFile = outputDir </> filePath </> "index.js"
280 externsFile = outputDir </> filePath </> "externs.purs"
281 foreignFile = outputDir </> filePath </> "foreign.js"
282 prefix = ["Generated by psc version " ++ showVersion Paths.version | usePrefix]
283 js = unlines $ map ("// " ++) prefix ++ [pjs]
284 writeTextFile jsFile js
285 maybe (return ()) (writeTextFile foreignFile . snd) $ mn `M.lookup` foreigns
286 writeTextFile externsFile exts
288 requiresForeign :: CF.Module a -> Bool
289 requiresForeign = not . null . CF.moduleForeign
291 getTimestamp :: FilePath -> Make (Maybe UTCTime)
292 getTimestamp path = makeIO (const (SimpleErrorWrapper $ CannotGetFileInfo path)) $ do
293 exists <- doesFileExist path
294 traverse (const $ getModificationTime path) $ guard exists
296 readTextFile :: FilePath -> Make String
297 readTextFile path = do
298 verboseErrorsEnabled <- asks optionsVerboseErrors
299 makeIO (const (SimpleErrorWrapper $ CannotReadFile path)) $ do
300 when verboseErrorsEnabled $ putStrLn $ "Reading " ++ path
301 readFile path
303 writeTextFile :: FilePath -> String -> Make ()
304 writeTextFile path text = makeIO (const (SimpleErrorWrapper $ CannotWriteFile path)) $ do
305 mkdirp path
306 putStrLn $ "Writing " ++ path
307 writeFile path text
308 where
309 mkdirp :: FilePath -> IO ()
310 mkdirp = createDirectoryIfMissing True . takeDirectory
312 progress :: String -> Make ()
313 progress = liftIO . putStrLn