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