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