git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Move codegen out of make
commitb1385d974e890f1be82498952c32dbb7ea14cfb8 authorGary Burgess <gary.burgess@gmail.com> dateFri 8 May 2015, 01:29 (11 years ago) parentd928713
3 files changed+67−56
compare with golang
unifiedsplit
psc-make/Main.hs+46−7 purescript.cabal+1−1 src/Language/PureScript.hs+20−48
psc-make/Main.hs+46−7
@@ -23,18 +23,23 @@ import Control.Monad.Trans.Except
2323import Control.Monad.Reader
2424import Control.Monad.Writer
2525
26−import Data.Version (showVersion)
26+import Data.Maybe (fromMaybe)
27+import Data.Time.Clock
2728import Data.Traversable (traverse)
29+import Data.Version (showVersion)
30+import qualified Data.Map as M
2831
2932import Options.Applicative as Opts
3033
3134import System.Directory
3235 (doesFileExist, getModificationTime, createDirectoryIfMissing)
33−import System.FilePath (takeDirectory)
36+import System.FilePath ((</>), takeDirectory)
3437import System.Exit (exitSuccess, exitFailure)
3538import System.IO.Error (tryIOError)
3639
3740import qualified Language.PureScript as P
41+import qualified Language.PureScript.CodeGen.JS as J
42+import qualified Language.PureScript.CoreFn as CoreFn
3843import qualified Paths_purescript as Paths
3944
4045
@@ -77,6 +82,11 @@ instance P.MonadMake Make where
7782 writeFile path text
7883 progress = liftIO . putStrLn
7984
85+-- Traverse (Either e) instance (base 4.7)
86+traverseEither :: Applicative f => (a -> f b) -> Either e a -> f (Either e b)
87+traverseEither _ (Left x) = pure (Left x)
88+traverseEither f (Right y) = Right <$> f y
89+
8090compile :: PSCMakeOptions -> IO ()
8191compile (PSCMakeOptions input outputDir opts usePrefix) = do
8292 modules <- P.parseModulesFromFiles (either (const "") id) <$> readInput (InputOptions (P.optionsNoPrelude opts) input)
@@ -85,19 +95,48 @@ compile (PSCMakeOptions input outputDir opts usePrefix) = do
8595 print err
8696 exitFailure
8797 Right ms -> do
88− e <- runMake opts $ P.make outputDir ms prefix
98+ e <- runMake opts $ P.make getInputTimestamp getOutputTimestamp readExterns codegen ms
8999 case e of
90100 Left errs -> do
91101 putStrLn (P.prettyPrintMultipleErrors (P.optionsVerboseErrors opts) errs)
92102 exitFailure
93103 Right (_, warnings) -> do
94− when (P.nonEmpty warnings) $
104+ when (P.nonEmpty warnings) $
95105 putStrLn (P.prettyPrintMultipleWarnings (P.optionsVerboseErrors opts) warnings)
96106 exitSuccess
97107 where
98− prefix = if usePrefix
99− then ["Generated by psc-make version " ++ showVersion Paths.version]
100− else []
108+ prefix = if usePrefix
109+ then ["Generated by psc-make version " ++ showVersion Paths.version]
110+ else []
111+
112+ filePathMap = M.empty -- M.fromList (map (\(fp, Module _ mn _ _) -> (mn, fp)) ms)
113+
114+ getInputTimestamp :: P.ModuleName -> Make (Either P.RebuildPolicy (Maybe UTCTime))
115+ getInputTimestamp mn = do
116+ let inputFile = fromMaybe (error "Module has no filename in 'make'") $ M.lookup mn filePathMap
117+ traverseEither P.getTimestamp inputFile
118+
119+ getOutputTimestamp :: P.ModuleName -> Make (Maybe UTCTime)
120+ getOutputTimestamp mn = do
121+ let filePath = P.runModuleName mn
122+ jsFile = outputDir </> filePath </> "index.js"
123+ externsFile = outputDir </> filePath </> "externs.purs"
124+ min <$> P.getTimestamp jsFile <*> P.getTimestamp externsFile
125+
126+ readExterns :: P.ModuleName -> Make (FilePath, String)
127+ readExterns mn = do
128+ let path = outputDir </> P.runModuleName mn </> "externs.purs"
129+ (path, ) <$> P.readTextFile path
130+
131+ codegen :: CoreFn.Module CoreFn.Ann -> String -> P.Environment -> Integer -> Make ()
132+ codegen m exts env nextVar = do
133+ let filePath = P.runModuleName $ CoreFn.moduleName m
134+ jsFile = outputDir </> filePath </> "index.js"
135+ externsFile = outputDir </> filePath </> "externs.purs"
136+ pjs <- P.evalSupplyT nextVar $ P.prettyPrintJS <$> J.moduleToJs m Nothing
137+ let js = unlines $ map ("// " ++) prefix ++ [pjs]
138+ P.writeTextFile jsFile js
139+ P.writeTextFile externsFile exts
101140
102141mkdirp :: FilePath -> IO ()
103142mkdirp = createDirectoryIfMissing True . takeDirectory
purescript.cabal+1−1
@@ -155,7 +155,7 @@ executable psc
155155executable psc-make
156156 build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,
157157 mtl -any, optparse-applicative >= 0.10.0, parsec -any, purescript -any,
158− transformers -any, transformers-compat -any
158+ time -any, transformers -any, transformers-compat -any
159159 main-is: Main.hs
160160 buildable: True
161161 hs-source-dirs: psc-make
src/Language/PureScript.hs+20−48
@@ -41,8 +41,7 @@ import Control.Monad
4141import Control.Monad.Error.Class (MonadError(..))
4242import Control.Monad.Reader
4343import Control.Monad.Writer
44−
45−import System.FilePath ((</>))
44+import Control.Monad.Supply.Class (fresh)
4645
4746import Language.PureScript.AST as P
4847import Language.PureScript.Comments as P
@@ -144,11 +143,6 @@ data RebuildPolicy
144143 -- | Always rebuild this module
145144 | RebuildAlways deriving (Show, Eq, Ord)
146145
147−-- Traverse (Either e) instance (base 4.7)
148−traverseEither :: Applicative f => (a -> f b) -> Either e a -> f (Either e b)
149−traverseEither _ (Left x) = pure (Left x)
150−traverseEither f (Right y) = Right <$> f y
151−
152146-- |
153147-- Compiles in "make" mode, compiling each module separately to a js files and an externs file
154148--
@@ -156,67 +150,46 @@ traverseEither f (Right y) = Right <$> f y
156150-- having to typecheck the module again.
157151--
158152make :: forall m. (Functor m, Applicative m, Monad m, MonadMake m)
159− => FilePath -> [(Either RebuildPolicy FilePath, Module)] -> [String] -> m Environment
160−make outputDir ms prefix = do
153+ => (ModuleName -> m (Either RebuildPolicy (Maybe UTCTime)))
154+ -> (ModuleName -> m (Maybe UTCTime))
155+ -> (ModuleName -> m (FilePath, String))
156+ -> (CoreFn.Module CoreFn.Ann -> String -> Environment -> Integer -> m ())
157+ -> [(Either RebuildPolicy FilePath, Module)]
158+ -> m Environment
159+make getInputTimestamp getOutputTimestamp readExterns codegen ms = do
161160 noPrelude <- asks optionsNoPrelude
162161 unless noPrelude (checkPreludeIsDefined (map snd ms))
163− let filePathMap = M.fromList (map (\(fp, Module _ mn _ _) -> (mn, fp)) ms)
164−
165162 (sorted, graph) <- sortModules $ map importPrim $ if noPrelude then map snd ms else map (importPrelude . snd) ms
166−
167163 mapM_ lint sorted
168−
169164 toRebuild <- foldM (\s (Module _ moduleName' _ _) -> do
170− let filePath = runModuleName moduleName'
171−
172− jsFile = outputDir </> filePath </> "index.js"
173− externsFile = outputDir </> filePath </> "externs.purs"
174− inputFile = fromMaybe (error "Module has no filename in 'make'") $ M.lookup moduleName' filePathMap
175−
176− jsTimestamp <- getTimestamp jsFile
177− externsTimestamp <- getTimestamp externsFile
178− inputTimestamp <- traverseEither getTimestamp inputFile
179−
180− return $ case (inputTimestamp, jsTimestamp, externsTimestamp) of
181− (Right (Just t1), Just t2, Just t3) | t1 < min t2 t3 -> s
182− (Left RebuildNever, Just _, Just _) -> s
165+ inputTimestamp <- getInputTimestamp moduleName'
166+ outputTimestamp <- getOutputTimestamp moduleName'
167+ return $ case (inputTimestamp, outputTimestamp) of
168+ (Right (Just t1), Just t2) | t1 < t2 -> s
169+ (Left RebuildNever, Just _) -> s
183170 _ -> S.insert moduleName' s) S.empty sorted
184171
185172 marked <- rebuildIfNecessary (reverseDependencies graph) toRebuild sorted
186−
187173 (desugared, nextVar) <- runSupplyT 0 $ zip (map fst marked) <$> desugar (map snd marked)
188−
189174 evalSupplyT nextVar $ go initEnvironment desugared
190−
191175 where
176+
192177 go :: Environment -> [(Bool, Module)] -> SupplyT m Environment
193178 go env [] = return env
194179 go env ((False, m) : ms') = do
195180 (_, env') <- lift . runCheck' env $ typeCheckModule Nothing m
196−
197181 go env' ms'
198182 go env ((True, m@(Module coms moduleName' _ exps)) : ms') = do
199− let filePath = runModuleName moduleName'
200− jsFile = outputDir </> filePath </> "index.js"
201− externsFile = outputDir </> filePath </> "externs.purs"
202183
203184 lift . progress $ "Compiling " ++ runModuleName moduleName'
204−
205185 (Module _ _ elaborated _, env') <- lift . runCheck' env $ typeCheckModule Nothing m
206−
207186 regrouped <- createBindingGroups moduleName' . collapseBindingGroups $ elaborated
208−
209187 let mod' = Module coms moduleName' regrouped exps
210188 corefn = CoreFn.moduleToCoreFn env' mod'
211189 [renamed] = renameInModules [corefn]
212−
213− pjs <- prettyPrintJS <$> moduleToJs renamed Nothing
214− let js = unlines $ map ("// " ++) prefix ++ [pjs]
215− let exts = unlines $ map ("-- " ++) prefix ++ [moduleToPs mod' env']
216−
217− lift $ writeTextFile jsFile js
218− lift $ writeTextFile externsFile exts
219−
190+ let exts = moduleToPs mod' env'
191+ nextVar <- fresh
192+ lift $ codegen renamed exts env' nextVar
220193 go env' ms'
221194
222195 rebuildIfNecessary :: M.Map ModuleName [ModuleName] -> S.Set ModuleName -> [Module] -> m [(Bool, Module)]
@@ -226,12 +199,11 @@ make outputDir ms prefix = do
226199 toRebuild' = toRebuild `S.union` S.fromList deps
227200 (:) (True, m) <$> rebuildIfNecessary graph toRebuild' ms'
228201 rebuildIfNecessary graph toRebuild (Module _ moduleName' _ _ : ms') = do
229− let externsFile = outputDir </> runModuleName moduleName' </> "externs.purs"
230− externs <- readTextFile externsFile
231− externsModules <- fmap (map snd) . alterErrors $ P.parseModulesFromFiles id [(externsFile, externs)]
202+ (path, externs) <- readExterns moduleName'
203+ externsModules <- fmap (map snd) . alterErrors $ P.parseModulesFromFiles id [(path, externs)]
232204 case externsModules of
233205 [m'@(Module _ moduleName'' _ _)] | moduleName'' == moduleName' -> (:) (False, m') <$> rebuildIfNecessary graph toRebuild ms'
234− _ -> throwError . errorMessage . InvalidExternsFile $ externsFile
206+ _ -> throwError . errorMessage . InvalidExternsFile $ path
235207 where
236208 alterErrors = flip catchError $ \(MultipleErrors errs) ->
237209 throwError . MultipleErrors $ flip map errs $ \e -> case e of