Skip to content

Commit 56fdde4

Browse files
paf31paf31
committed
Use a global variable supply
1 parent 894a03c commit 56fdde4

File tree

11 files changed

+213
-284
lines changed

11 files changed

+213
-284
lines changed

‎psc-make/Main.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -45,7 +45,7 @@ readInput input = fmap collect $ forM input $ \inputFile -> do
4545
collect :: [(FilePath, Either ParseError [P.Module])] -> Either ParseError [(FilePath, P.Module)]
4646
collect = fmap concat . sequence . map (\(fp, e) -> fmap (map ((,) fp)) e)
4747

48-
newtype Make a = Make { unMake :: ErrorT String IO a } deriving (Functor, Monad, MonadIO, MonadError String)
48+
newtype Make a = Make { unMake :: ErrorT String IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadError String)
4949

5050
runMake :: Make a -> IO (Either String a)
5151
runMake = runErrorT . unMake

‎purescript.cabal‎

Lines changed: 2 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -34,8 +34,8 @@ library
3434
Language.PureScript.Errors
3535
Language.PureScript.Kinds
3636
Language.PureScript.Names
37+
Language.PureScript.Supply
3738
Language.PureScript.Types
38-
Language.PureScript.Scope
3939
Language.PureScript.Traversals
4040
Language.PureScript.TypeClassDictionaries
4141
Language.PureScript.DeadCodeElimination
@@ -53,7 +53,6 @@ library
5353
Language.PureScript.CodeGen.Externs
5454
Language.PureScript.CodeGen.JS
5555
Language.PureScript.CodeGen.JS.AST
56-
Language.PureScript.CodeGen.Monad
5756
Language.PureScript.Optimizer
5857
Language.PureScript.Optimizer.Common
5958
Language.PureScript.Optimizer.MagicDo
@@ -136,7 +135,7 @@ executable hierarchy
136135

137136
test-suite tests
138137
build-depends: base >=4 && <5, containers -any, directory -any,
139-
filepath -any, mtl -any, parsec -any, purescript -any,
138+
filepath -any, mtl -any, parsec -any, purescript -any,
140139
transformers -any, utf8-string -any, process -any
141140
type: exitcode-stdio-1.0
142141
main-is: Main.hs

‎src/Language/PureScript.hs‎

Lines changed: 16 additions & 15 deletions
Original file line numberDiff line numberDiff line change
@@ -30,6 +30,7 @@ import Language.PureScript.ModuleDependencies as P
3030
import Language.PureScript.Environment as P
3131
import Language.PureScript.Errors as P
3232
import Language.PureScript.DeadCodeElimination as P
33+
import Language.PureScript.Supply as P
3334

3435
import qualified Language.PureScript.Constants as C
3536

@@ -40,7 +41,7 @@ import Data.Maybe (fromJust, fromMaybe)
4041
import Control.Monad.Error
4142
import Control.Monad.State.Lazy
4243
import Control.Arrow ((&&&))
43-
import Control.Applicative ((<$>))
44+
import Control.Applicative
4445
import qualified Data.Map as M
4546
import qualified Data.Set as S
4647
import System.FilePath (pathSeparator)
@@ -70,14 +71,14 @@ compile = compile' initEnvironment
7071
compile' :: Environment -> Options -> [Module] -> Either String (String, String, Environment)
7172
compile' env opts ms = do
7273
(sorted, _) <- sortModules $ if optionsNoPrelude opts then ms else (map importPrelude ms)
73-
desugared <- stringifyErrorStack True $ desugar sorted
74+
(desugared, nextVar) <- stringifyErrorStack True $ runSupplyT 0 $ desugar sorted
7475
(elaborated, env') <- runCheck' opts env $ forM desugared $ typeCheckModule mainModuleIdent
7576
regrouped <- stringifyErrorStack True $ createBindingGroupsModule . collapseBindingGroupsModule $ elaborated
7677
let entryPoints = moduleNameFromString `map` optionsModules opts
7778
let elim = if null entryPoints then regrouped else eliminateDeadCode entryPoints regrouped
7879
let codeGenModules = moduleNameFromString `map` optionsCodeGenModules opts
7980
let modulesToCodeGen = if null codeGenModules then elim else filter (\(Module mn _ _) -> mn `elem` codeGenModules) elim
80-
let js = concatMap (\m -> moduleToJs Globals opts m env') modulesToCodeGen
81+
let (js, _) = runSupply nextVar $ concat <$> mapM (\m -> moduleToJs Globals opts m env') modulesToCodeGen
8182
let exts = intercalate "\n" . map (`moduleToPs` env') $ modulesToCodeGen
8283
js' <- generateMain env' opts js
8384
return (prettyPrintJS js', exts, env')
@@ -165,7 +166,7 @@ class MonadMake m where
165166
-- If timestamps have not changed, the externs file can be used to provide the module's types without
166167
-- having to typecheck the module again.
167168
--
168-
make :: (Functor m, Monad m, MonadMake m) => FilePath -> Options -> [(FilePath, Module)] -> m Environment
169+
make :: (Functor m, Applicative m, Monad m, MonadMake m) => FilePath -> Options -> [(FilePath, Module)] -> m Environment
169170
make outputDir opts ms = do
170171
let filePathMap = M.fromList (map (\(fp, Module mn _ _) -> (mn, fp)) ms)
171172

@@ -188,34 +189,34 @@ make outputDir opts ms = do
188189

189190
marked <- rebuildIfNecessary (reverseDependencies graph) toRebuild sorted
190191

191-
desugared <- liftError $ stringifyErrorStack True $ zip (map fst marked) <$> desugar (map snd marked)
192+
(desugared, nextVar) <- liftError $ stringifyErrorStack True $ runSupplyT 0 $ zip (map fst marked) <$> desugar (map snd marked)
192193

193-
go initEnvironment desugared
194+
fst <$> runSupplyT nextVar (go initEnvironment desugared)
194195

195196
where
196-
go :: (Functor m, Monad m, MonadMake m) => Environment -> [(Bool, Module)] -> m Environment
197+
go :: (Functor m, Applicative m, Monad m, MonadMake m) => Environment -> [(Bool, Module)] -> SupplyT m Environment
197198
go env [] = return env
198199
go env ((False, m) : ms') = do
199-
(_, env') <- liftError . runCheck' opts env $ typeCheckModule Nothing m
200+
(_, env') <- lift . liftError . runCheck' opts env $ typeCheckModule Nothing m
200201

201202
go env' ms'
202203
go env ((True, m@(Module moduleName' _ exps)) : ms') = do
203204
let filePath = runModuleName moduleName'
204205
jsFile = outputDir ++ pathSeparator : filePath ++ pathSeparator : "index.js"
205206
externsFile = outputDir ++ pathSeparator : filePath ++ pathSeparator : "externs.purs"
206207

207-
progress $ "Compiling " ++ runModuleName moduleName'
208+
lift . progress $ "Compiling " ++ runModuleName moduleName'
208209

209-
(Module _ elaborated _, env') <- liftError . runCheck' opts env $ typeCheckModule Nothing m
210+
(Module _ elaborated _, env') <- lift . liftError . runCheck' opts env $ typeCheckModule Nothing m
210211

211-
regrouped <- liftError . stringifyErrorStack True . createBindingGroups moduleName' . collapseBindingGroups $ elaborated
212+
regrouped <- lift . liftError . stringifyErrorStack True . createBindingGroups moduleName' . collapseBindingGroups $ elaborated
212213

213214
let mod' = Module moduleName' regrouped exps
214-
js = prettyPrintJS $ moduleToJs CommonJS opts mod' env'
215-
exts = moduleToPs mod' env'
215+
js <- prettyPrintJS <$> moduleToJs CommonJS opts mod' env'
216+
let exts = moduleToPs mod' env'
216217

217-
writeTextFile jsFile js
218-
writeTextFile externsFile exts
218+
lift $ writeTextFile jsFile js
219+
lift $ writeTextFile externsFile exts
219220

220221
go env' ms'
221222

0 commit comments

Comments
 (0)