git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Move the make code from psc into the purescript library
532e62dJohn Lenz
psc/Main.hs+1−1
compare with golang
unifiedsplit
@@ -36,7 +36,7 @@ import System.FilePath.Glob (glob)
36import qualified Language.PureScript as P
36import qualified Language.PureScript as P
37import qualified Paths_purescript as Paths
37import qualified Paths_purescript as Paths
38
38
39−import Make
39+import Language.PureScript.Make
40
40
41data PSCMakeOptions = PSCMakeOptions
41data PSCMakeOptions = PSCMakeOptions
42 { pscmInput :: [FilePath]
42 { pscmInput :: [FilePath]
psc/Make.hsdeleted−140
@@ -1,140 +0,0 @@
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−-----------------------------------------------------------------------------
14−
15−{-# LANGUAGE DataKinds #-}
16−{-# LANGUAGE FlexibleContexts #-}
17−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
18−{-# LANGUAGE TupleSections #-}
19−
20−module Make
21− ( Make(..)
22− , runMake
23− , buildMakeActions
24− ) where
25−
26−import Control.Applicative
27−import Control.Monad
28−import Control.Monad.Error.Class (MonadError(..))
29−import Control.Monad.Trans.Except
30−import Control.Monad.Reader
31−import Control.Monad.Writer
32−
33−import Data.Maybe (fromMaybe)
34−import Data.Time.Clock
35−import Data.Traversable (traverse)
36−import Data.Version (showVersion)
37−import qualified Data.Map as M
38−
39−import System.Directory
40− (doesFileExist, getModificationTime, createDirectoryIfMissing)
41−import System.FilePath ((</>), takeDirectory)
42−import System.IO.Error (tryIOError)
43−
44−import qualified Language.PureScript as P
45−import qualified Language.PureScript.CodeGen.JS as J
46−import qualified Language.PureScript.CoreFn as CF
47−import qualified Paths_purescript as Paths
48−
49−newtype Make a = Make { unMake :: ReaderT P.Options (WriterT P.MultipleErrors (ExceptT P.MultipleErrors IO)) a }
50− deriving (Functor, Applicative, Monad, MonadIO, MonadError P.MultipleErrors, MonadWriter P.MultipleErrors, MonadReader P.Options)
51−
52−runMake :: P.Options -> Make a -> IO (Either P.MultipleErrors (a, P.MultipleErrors))
53−runMake opts = runExceptT . runWriterT . flip runReaderT opts . unMake
54−
55−makeIO :: (IOError -> P.ErrorMessage) -> IO a -> Make a
56−makeIO f io = do
57− e <- liftIO $ tryIOError io
58− either (throwError . P.singleError . f) return e
59−
60−-- Traverse (Either e) instance (base 4.7)
61−traverseEither :: Applicative f => (a -> f b) -> Either e a -> f (Either e b)
62−traverseEither _ (Left x) = pure (Left x)
63−traverseEither f (Right y) = Right <$> f y
64−
65−buildMakeActions :: FilePath
66− -> M.Map P.ModuleName (Either P.RebuildPolicy String)
67− -> M.Map P.ModuleName (FilePath, P.ForeignJS)
68− -> Bool
69− -> P.MakeActions Make
70−buildMakeActions outputDir filePathMap foreigns usePrefix =
71− P.MakeActions getInputTimestamp getOutputTimestamp readExterns codegen progress
72− where
73−
74− getInputTimestamp :: P.ModuleName -> Make (Either P.RebuildPolicy (Maybe UTCTime))
75− getInputTimestamp mn = do
76− let path = fromMaybe (error "Module has no filename in 'make'") $ M.lookup mn filePathMap
77− e1 <- traverseEither getTimestamp path
78− fPath <- maybe (return Nothing) (getTimestamp . fst) $ M.lookup mn foreigns
79− return $ fmap (max fPath) e1
80−
81− getOutputTimestamp :: P.ModuleName -> Make (Maybe UTCTime)
82− getOutputTimestamp mn = do
83− let filePath = P.runModuleName mn
84− jsFile = outputDir </> filePath </> "index.js"
85− externsFile = outputDir </> filePath </> "externs.purs"
86− min <$> getTimestamp jsFile <*> getTimestamp externsFile
87−
88− readExterns :: P.ModuleName -> Make (FilePath, String)
89− readExterns mn = do
90− let path = outputDir </> P.runModuleName mn </> "externs.purs"
91− (path, ) <$> readTextFile path
92−
93− codegen :: CF.Module CF.Ann -> P.Environment -> P.SupplyVar -> P.Externs -> Make ()
94− codegen m _ nextVar exts = do
95− let mn = CF.moduleName m
96− foreignInclude <- case mn `M.lookup` foreigns of
97− Just (path, _)
98− | not $ requiresForeign m -> do
99− tell $ P.errorMessage $ P.UnnecessaryFFIModule mn path
100− return Nothing
101− | otherwise -> return $ Just $ J.JSApp (J.JSVar "require") [J.JSStringLiteral "./foreign"]
102− Nothing | requiresForeign m -> throwError . P.errorMessage $ P.MissingFFIModule mn
103− | otherwise -> return Nothing
104− pjs <- P.evalSupplyT nextVar $ P.prettyPrintJS <$> J.moduleToJs m foreignInclude
105− let filePath = P.runModuleName mn
106− jsFile = outputDir </> filePath </> "index.js"
107− externsFile = outputDir </> filePath </> "externs.purs"
108− foreignFile = outputDir </> filePath </> "foreign.js"
109− prefix = ["Generated by psc version " ++ showVersion Paths.version | usePrefix]
110− js = unlines $ map ("// " ++) prefix ++ [pjs]
111− writeTextFile jsFile js
112− maybe (return ()) (writeTextFile foreignFile . snd) $ mn `M.lookup` foreigns
113− writeTextFile externsFile exts
114−
115− requiresForeign :: CF.Module a -> Bool
116− requiresForeign = not . null . CF.moduleForeign
117−
118− getTimestamp :: FilePath -> Make (Maybe UTCTime)
119− getTimestamp path = makeIO (const (P.SimpleErrorWrapper $ P.CannotGetFileInfo path)) $ do
120− exists <- doesFileExist path
121− traverse (const $ getModificationTime path) $ guard exists
122−
123− readTextFile :: FilePath -> Make String
124− readTextFile path = do
125− verboseErrorsEnabled <- asks P.optionsVerboseErrors
126− makeIO (const (P.SimpleErrorWrapper $ P.CannotReadFile path)) $ do
127− when verboseErrorsEnabled $ putStrLn $ "Reading " ++ path
128− readFile path
129−
130− writeTextFile :: FilePath -> String -> Make ()
131− writeTextFile path text = makeIO (const (P.SimpleErrorWrapper $ P.CannotWriteFile path)) $ do
132− mkdirp path
133− putStrLn $ "Writing " ++ path
134− writeFile path text
135− where
136− mkdirp :: FilePath -> IO ()
137− mkdirp = createDirectoryIfMissing True . takeDirectory
138−
139− progress :: String -> Make ()
140− progress = liftIO . putStrLn
purescript.cabal+1−1
@@ -83,6 +83,7 @@ library
83 Language.PureScript.Errors
83 Language.PureScript.Errors
84 Language.PureScript.Kinds
84 Language.PureScript.Kinds
85 Language.PureScript.Linter
85 Language.PureScript.Linter
86+ Language.PureScript.Make
86 Language.PureScript.ModuleDependencies
87 Language.PureScript.ModuleDependencies
87 Language.PureScript.Names
88 Language.PureScript.Names
88 Language.PureScript.Options
89 Language.PureScript.Options
@@ -152,7 +153,6 @@ executable psc
152 main-is: Main.hs
153 main-is: Main.hs
153 buildable: True
154 buildable: True
154 hs-source-dirs: psc
155 hs-source-dirs: psc
155− other-modules: Make
156 ghc-options: -Wall -O2 -fno-warn-unused-do-bind
156 ghc-options: -Wall -O2 -fno-warn-unused-do-bind
157
157
158executable psci
158executable psci
src/Language/PureScript.hs+1−153
@@ -20,37 +20,18 @@
20
20
21module Language.PureScript
21module Language.PureScript
22 ( module P
22 ( module P
23− , RebuildPolicy(..)
24− , MakeActions(..)
25− , SupplyVar()
26− , Externs()
27− , make
28 , version
23 , version
29 ) where
24 ) where
30
25
31−import Data.Function (on)
32−import Data.List (sortBy, groupBy)
33−import Data.Maybe (fromMaybe)
34−import Data.Time.Clock
35import Data.Version (Version)
26import Data.Version (Version)
36−import qualified Data.Map as M
37−import qualified Data.Set as S
38−
39−import Control.Applicative
40−import Control.Arrow ((&&&))
41−import Control.Monad
42−import Control.Monad.Error.Class (MonadError(..))
43−import Control.Monad.Reader
44−import Control.Monad.Writer
45−import Control.Monad.Supply.Class (fresh)
46
27
47import Language.PureScript.AST as P
28import Language.PureScript.AST as P
48import Language.PureScript.Comments as P
29import Language.PureScript.Comments as P
49−import Language.PureScript.CodeGen.Externs (moduleToPs)
50import Language.PureScript.Environment as P
30import Language.PureScript.Environment as P
51import Language.PureScript.Errors as P
31import Language.PureScript.Errors as P
52import Language.PureScript.Kinds as P
32import Language.PureScript.Kinds as P
53import Language.PureScript.Linter as P
33import Language.PureScript.Linter as P
34+import Language.PureScript.Make as P
54import Language.PureScript.ModuleDependencies as P
35import Language.PureScript.ModuleDependencies as P
55import Language.PureScript.Names as P
36import Language.PureScript.Names as P
56import Language.PureScript.Options as P
37import Language.PureScript.Options as P
@@ -61,141 +42,8 @@ import Language.PureScript.Sugar as P
61import Control.Monad.Supply as P
42import Control.Monad.Supply as P
62import Language.PureScript.TypeChecker as P
43import Language.PureScript.TypeChecker as P
63import Language.PureScript.Types as P
44import Language.PureScript.Types as P
64−import qualified Language.PureScript.CoreFn as CoreFn
65−import qualified Language.PureScript.Constants as C
66
45
67import qualified Paths_purescript as Paths
46import qualified Paths_purescript as Paths
68
47
69−-- |
70−-- Actions that require implementations when running in "make" mode.
71−--
72−data MakeActions m = MakeActions {
73− -- |
74− -- Get the timestamp for the input file(s) for a module. If there are multiple
75− -- files (.purs and foreign files, for example) the timestamp should be for
76− -- the most recently modified file.
77− --
78− getInputTimestamp :: ModuleName -> m (Either RebuildPolicy (Maybe UTCTime))
79− -- |
80− -- Get the timestamp for the output files for a module. This should be the
81− -- timestamp for the oldest modified file, or Nothing if any of the required
82− -- output files are missing.
83− --
84− , getOutputTimestamp :: ModuleName -> m (Maybe UTCTime)
85− -- |
86− -- Read the externs file for a module as a string and also return the actual
87− -- path for the file.
88− , readExterns :: ModuleName -> m (FilePath, String)
89− -- |
90− -- Run the code generator for the module and write any required output files.
91− --
92− , codegen :: CoreFn.Module CoreFn.Ann -> Environment -> SupplyVar -> Externs -> m ()
93− -- |
94− -- Respond to a progress update.
95− --
96− , progress :: String -> m ()
97− }
98−
99−-- |
100−-- Generated code for an externs file.
101−--
102−type Externs = String
103−
104−-- |
105−-- A value to be used in the Supply monad.
106−--
107−type SupplyVar = Integer
108−
109−-- |
110−-- Determines when to rebuild a module
111−--
112−data RebuildPolicy
113− -- | Never rebuild this module
114− = RebuildNever
115− -- | Always rebuild this module
116− | RebuildAlways deriving (Show, Eq, Ord)
117−
118−-- |
119−-- Compiles in "make" mode, compiling each module separately to a js files and an externs file
120−--
121−-- If timestamps have not changed, the externs file can be used to provide the module's types without
122−-- having to typecheck the module again.
123−--
124−make :: forall m. (Functor m, Applicative m, Monad m, MonadReader P.Options m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
125− => MakeActions m
126− -> [(Either RebuildPolicy FilePath, Module)]
127− -> m Environment
128−make MakeActions{..} ms = do
129− (sorted, graph) <- sortModules $ map (importPrim . snd) ms
130− mapM_ lint sorted
131− toRebuild <- foldM (\s (Module _ moduleName' _ _) -> do
132− inputTimestamp <- getInputTimestamp moduleName'
133− outputTimestamp <- getOutputTimestamp moduleName'
134− return $ case (inputTimestamp, outputTimestamp) of
135− (Right (Just t1), Just t2) | t1 < t2 -> s
136− (Left RebuildNever, Just _) -> s
137− _ -> S.insert moduleName' s) S.empty sorted
138−
139− marked <- rebuildIfNecessary (reverseDependencies graph) toRebuild sorted
140− (desugared, nextVar) <- runSupplyT 0 $ zip (map fst marked) <$> desugar (map snd marked)
141− evalSupplyT nextVar $ go initEnvironment desugared
142− where
143−
144− go :: Environment -> [(Bool, Module)] -> SupplyT m Environment
145− go env [] = return env
146− go env ((False, m) : ms') = do
147− (_, env') <- lift . runCheck' env $ typeCheckModule Nothing m
148− go env' ms'
149− go env ((True, m@(Module coms moduleName' _ exps)) : ms') = do
150− lift $ progress $ "Compiling " ++ runModuleName moduleName'
151− (Module _ _ elaborated _, env') <- lift . runCheck' env $ typeCheckModule Nothing m
152− regrouped <- createBindingGroups moduleName' . collapseBindingGroups $ elaborated
153− let mod' = Module coms moduleName' regrouped exps
154− corefn = CoreFn.moduleToCoreFn env' mod'
155− [renamed] = renameInModules [corefn]
156− exts = moduleToPs mod' env'
157− nextVar <- fresh
158− lift $ codegen renamed env' nextVar exts
159− go env' ms'
160−
161− rebuildIfNecessary :: M.Map ModuleName [ModuleName] -> S.Set ModuleName -> [Module] -> m [(Bool, Module)]
162− rebuildIfNecessary _ _ [] = return []
163− rebuildIfNecessary graph toRebuild (m@(Module _ moduleName' _ _) : ms') | moduleName' `S.member` toRebuild = do
164− let deps = fromMaybe [] $ moduleName' `M.lookup` graph
165− toRebuild' = toRebuild `S.union` S.fromList deps
166− (:) (True, m) <$> rebuildIfNecessary graph toRebuild' ms'
167− rebuildIfNecessary graph toRebuild (Module _ moduleName' _ _ : ms') = do
168− (path, externs) <- readExterns moduleName'
169− externsModules <- fmap (map snd) . alterErrors $ P.parseModulesFromFiles id [(path, externs)]
170− case externsModules of
171− [m'@(Module _ moduleName'' _ _)] | moduleName'' == moduleName' -> (:) (False, m') <$> rebuildIfNecessary graph toRebuild ms'
172− _ -> throwError . errorMessage . InvalidExternsFile $ path
173− where
174− alterErrors = flip catchError $ \(MultipleErrors errs) ->
175− throwError . MultipleErrors $ flip map errs $ \e -> case e of
176− SimpleErrorWrapper (ErrorParsingModule err) -> SimpleErrorWrapper (ErrorParsingExterns err)
177− _ -> e
178−
179−reverseDependencies :: ModuleGraph -> M.Map ModuleName [ModuleName]
180−reverseDependencies g = combine [ (dep, mn) | (mn, deps) <- g, dep <- deps ]
181− where
182− combine :: (Ord a) => [(a, b)] -> M.Map a [b]
183− combine = M.fromList . map ((fst . head) &&& map snd) . groupBy ((==) `on` fst) . sortBy (compare `on` fst)
184−
185−-- |
186−-- Add an import declaration for a module if it does not already explicitly import it.
187−--
188−addDefaultImport :: ModuleName -> Module -> Module
189−addDefaultImport toImport m@(Module coms mn decls exps) =
190− if isExistingImport `any` decls || mn == toImport then m
191− else Module coms mn (ImportDeclaration toImport Implicit Nothing : decls) exps
192− where
193− isExistingImport (ImportDeclaration mn' _ _) | mn' == toImport = True
194− isExistingImport (PositionedDeclaration _ _ d) = isExistingImport d
195− isExistingImport _ = False
196−
197−importPrim :: Module -> Module
198−importPrim = addDefaultImport (ModuleName [ProperName C.prim])
199−
200version :: Version
48version :: Version
201version = Paths.version
49version = Paths.version
src/Language/PureScript/Make.hsnew file+313
@@ -0,0 +1,313 @@
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+-----------------------------------------------------------------------------
14+
15+{-# LANGUAGE DataKinds #-}
16+{-# LANGUAGE FlexibleContexts #-}
17+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
18+{-# LANGUAGE TupleSections #-}
19+{-# LANGUAGE RankNTypes #-}
20+{-# LANGUAGE RecordWildCards #-}
21+{-# LANGUAGE ScopedTypeVariables #-}
22+
23+module Language.PureScript.Make
24+ (
25+ -- * Make API
26+ RebuildPolicy(..)
27+ , MakeActions(..)
28+ , SupplyVar()
29+ , Externs()
30+ , make
31+
32+ -- * Implementation of Make API using files on disk
33+ , Make(..)
34+ , runMake
35+ , buildMakeActions
36+ ) where
37+
38+import Control.Applicative
39+import Control.Arrow ((&&&))
40+import Control.Monad
41+import Control.Monad.Error.Class (MonadError(..))
42+import Control.Monad.Trans.Except
43+import Control.Monad.Reader
44+import Control.Monad.Writer
45+import Control.Monad.Supply
46+import Control.Monad.Supply.Class (fresh)
47+
48+import Data.Function (on)
49+import Data.List (sortBy, groupBy)
50+import Data.Maybe (fromMaybe)
51+import Data.Time.Clock
52+import Data.Traversable (traverse)
53+import Data.Version (showVersion)
54+import qualified Data.Map as M
55+import qualified Data.Set as S
56+
57+import System.Directory
58+ (doesFileExist, getModificationTime, createDirectoryIfMissing)
59+import System.FilePath ((</>), takeDirectory)
60+import System.IO.Error (tryIOError)
61+
62+
63+import Language.PureScript.AST
64+import Language.PureScript.CodeGen.Externs (moduleToPs)
65+import Language.PureScript.Environment
66+import Language.PureScript.Errors
67+import Language.PureScript.Linter
68+import Language.PureScript.ModuleDependencies
69+import Language.PureScript.Names
70+import Language.PureScript.Options
71+import Language.PureScript.Parser
72+import Language.PureScript.Pretty
73+import Language.PureScript.Renamer
74+import Language.PureScript.Sugar
75+import Language.PureScript.TypeChecker
76+import qualified Language.PureScript.Constants as C
77+
78+import qualified Language.PureScript.CodeGen.JS as J
79+import qualified Language.PureScript.CoreFn as CF
80+import qualified Paths_purescript as Paths
81+
82+-- |
83+-- Actions that require implementations when running in "make" mode.
84+--
85+data 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+ }
111+
112+-- |
113+-- Generated code for an externs file.
114+--
115+type Externs = String
116+
117+-- |
118+-- A value to be used in the Supply monad.
119+--
120+type SupplyVar = Integer
121+
122+-- |
123+-- Determines when to rebuild a module
124+--
125+data RebuildPolicy
126+ -- | Never rebuild this module
127+ = RebuildNever
128+ -- | Always rebuild this module
129+ | RebuildAlways deriving (Show, Eq, Ord)
130+
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+--
137+make :: 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
141+make 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
151+
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
156+
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'
173+
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
191+
192+reverseDependencies :: ModuleGraph -> M.Map ModuleName [ModuleName]
193+reverseDependencies 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)
197+
198+-- |
199+-- Add an import declaration for a module if it does not already explicitly import it.
200+--
201+addDefaultImport :: ModuleName -> Module -> Module
202+addDefaultImport 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
209+
210+importPrim :: Module -> Module
211+importPrim = addDefaultImport (ModuleName [ProperName C.prim])
212+
213+-- |
214+-- A monad for running make actions
215+--
216+newtype Make a = Make { unMake :: ReaderT Options (WriterT MultipleErrors (ExceptT MultipleErrors IO)) a }
217+ deriving (Functor, Applicative, Monad, MonadIO, MonadError MultipleErrors, MonadWriter MultipleErrors, MonadReader Options)
218+
219+-- |
220+-- Execute a 'Make' monad, returning either errors, or the result of the compile plus any warnings.
221+--
222+runMake :: Options -> Make a -> IO (Either MultipleErrors (a, MultipleErrors))
223+runMake opts = runExceptT . runWriterT . flip runReaderT opts . unMake
224+
225+makeIO :: (IOError -> ErrorMessage) -> IO a -> Make a
226+makeIO f io = do
227+ e <- liftIO $ tryIOError io
228+ either (throwError . singleError . f) return e
229+
230+-- Traverse (Either e) instance (base 4.7)
231+traverseEither :: Applicative f => (a -> f b) -> Either e a -> f (Either e b)
232+traverseEither _ (Left x) = pure (Left x)
233+traverseEither f (Right y) = Right <$> f y
234+
235+-- |
236+-- A set of make actions that read and write modules from the given directory.
237+--
238+buildMakeActions :: 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
243+buildMakeActions outputDir filePathMap foreigns usePrefix =
244+ MakeActions getInputTimestamp getOutputTimestamp readExterns codegen progress
245+ where
246+
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
253+
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
260+
261+ readExterns :: ModuleName -> Make (FilePath, String)
262+ readExterns mn = do
263+ let path = outputDir </> runModuleName mn </> "externs.purs"
264+ (path, ) <$> readTextFile path
265+
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
287+
288+ requiresForeign :: CF.Module a -> Bool
289+ requiresForeign = not . null . CF.moduleForeign
290+
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
295+
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
302+
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
311+
312+ progress :: String -> Make ()
313+ progress = liftIO . putStrLn