git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Use a global variable supply
commit56fdde4a67acd3580e1006a2b83722769abf485a authorPhil Freeman <paf31@cantab.net> dateWed 21 May 2014, 12:11 (12 years ago) parent894a03c
11 files changed+213−284
compare with golang
unifiedsplit
psc-make/Main.hs+1−1 purescript.cabal+2−3 src/Language/PureScript.hs+16−15 src/Language/PureScript/CodeGen/JS.hs+100−93 src/Language/PureScript/CodeGen/Monad.hs−43 src/Language/PureScript/Scope.hs−84 src/Language/PureScript/Sugar.hs+8−7 src/Language/PureScript/Sugar/CaseDeclarations.hs+22−25 src/Language/PureScript/Sugar/DoNotation.hs+9−9 src/Language/PureScript/Sugar/TypeClasses.hs+5−4 src/Language/PureScript/Supply.hs+50
psc-make/Main.hs+1−1
@@ -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
5050runMake :: Make a -> IO (Either String a)
5151runMake = runErrorT . unMake
purescript.cabal+2−3
@@ -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
137136test-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+16−15
@@ -30,6 +30,7 @@ import Language.PureScript.ModuleDependencies as P
3030import Language.PureScript.Environment as P
3131import Language.PureScript.Errors as P
3232import Language.PureScript.DeadCodeElimination as P
33+import Language.PureScript.Supply as P
3334
3435import qualified Language.PureScript.Constants as C
3536
@@ -40,7 +41,7 @@ import Data.Maybe (fromJust, fromMaybe)
4041import Control.Monad.Error
4142import Control.Monad.State.Lazy
4243import Control.Arrow ((&&&))
43−import Control.Applicative ((<$>))
44+import Control.Applicative
4445import qualified Data.Map as M
4546import qualified Data.Set as S
4647import System.FilePath (pathSeparator)
@@ -70,14 +71,14 @@ compile = compile' initEnvironment
7071compile' :: Environment -> Options -> [Module] -> Either String (String, String, Environment)
7172compile' 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
169170make outputDir opts ms = do
170171 let filePathMap = M.fromList (map (\(fp, Module mn _ _) -> (mn, fp)) ms)
171172
@@ -188,15 +189,15 @@ 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
@@ -204,18 +205,18 @@ make outputDir opts ms = do
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
src/Language/PureScript/CodeGen/JS.hs+100−93
@@ -23,26 +23,25 @@ module Language.PureScript.CodeGen.JS (
2323 isIdent
2424) where
2525
26−import Data.Maybe (fromJust, fromMaybe, mapMaybe)
26+import Data.Maybe (catMaybes, fromJust, fromMaybe)
2727import Data.Function (on)
2828import Data.List (nub, (\\))
2929
30−import Control.Arrow (second)
3130import Control.Monad (replicateM, forM)
31+import Control.Applicative
3232
3333import qualified Data.Map as M
3434
3535import Language.PureScript.Names
3636import Language.PureScript.Declarations
37−import Language.PureScript.CodeGen.Monad
3837import Language.PureScript.Options
3938import Language.PureScript.CodeGen.JS.AST as AST
4039import Language.PureScript.Types
4140import Language.PureScript.Optimizer
4241import Language.PureScript.CodeGen.Common
4342import Language.PureScript.Environment
44−
45−import qualified Language.PureScript.Scope as S
43+import Language.PureScript.Supply
44+import Language.PureScript.Traversals (sndM)
4645
4746-- |
4847-- Different types of modules which are supported
@@ -53,22 +52,23 @@ data ModuleType = CommonJS | Globals
5352-- Generate code in the simplified Javascript intermediate representation for all declarations in a
5453-- module.
5554--
56−moduleToJs :: ModuleType -> Options -> Module -> Environment -> [JS]
57−moduleToJs mt opts (Module name decls (Just exps)) env = case mt of
58− CommonJS -> moduleBody ++ [JSAssignment (JSAccessor "exports" (JSVar "module")) moduleExports]
59− Globals | not isModuleEmpty ->
60− [ JSVariableIntroduction (fromJust (optionsBrowserNamespace opts))
61− (Just (JSBinary Or (JSVar (fromJust (optionsBrowserNamespace opts))) (JSObjectLiteral [])) )
62− , JSAssignment (JSAccessor (moduleNameToJs name) (JSVar (fromJust (optionsBrowserNamespace opts))))
63− (JSApp (JSFunction Nothing [] (JSBlock (moduleBody ++ [JSReturn moduleExports]))) [])
64− ]
65− _ -> []
66− where
67− isModuleEmpty = null jsDecls
68− moduleBody = JSStringLiteral "use strict" : jsImports ++ jsDecls
69− moduleExports = JSObjectLiteral $ concatMap exportToJs exps
70− jsDecls = (concat $ mapMaybe (\decl -> fmap (map $ optimize opts) $ declToJs opts name decl env) decls)
71− jsImports = map (importToJs mt opts) . (\\ [name]) . nub $ concatMap imports decls
55+moduleToJs :: (Functor m, Applicative m, Monad m) => ModuleType -> Options -> Module -> Environment -> SupplyT m [JS]
56+moduleToJs mt opts (Module name decls (Just exps)) env = do
57+ let jsImports = map (importToJs mt opts) . (\\ [name]) . nub $ concatMap imports decls
58+ jsDecls <- mapM (\decl -> declToJs opts name decl env) decls
59+ let optimized = concat $ map (map $ optimize opts) $ catMaybes jsDecls
60+ let isModuleEmpty = null optimized
61+ let moduleBody = JSStringLiteral "use strict" : jsImports ++ optimized
62+ let moduleExports = JSObjectLiteral $ concatMap exportToJs exps
63+ return $ case mt of
64+ CommonJS -> moduleBody ++ [JSAssignment (JSAccessor "exports" (JSVar "module")) moduleExports]
65+ Globals | not isModuleEmpty ->
66+ [ JSVariableIntroduction (fromJust (optionsBrowserNamespace opts))
67+ (Just (JSBinary Or (JSVar (fromJust (optionsBrowserNamespace opts))) (JSObjectLiteral [])) )
68+ , JSAssignment (JSAccessor (moduleNameToJs name) (JSVar (fromJust (optionsBrowserNamespace opts))))
69+ (JSApp (JSFunction Nothing [] (JSBlock (moduleBody ++ [JSReturn moduleExports]))) [])
70+ ]
71+ _ -> []
7272moduleToJs _ _ _ _ = error "Exports should have been elaborated in name desugaring"
7373
7474importToJs :: ModuleType -> Options -> ModuleName -> JS
@@ -91,14 +91,17 @@ imports =
9191-- |
9292-- Generate code in the simplified Javascript intermediate representation for a declaration
9393--
94−declToJs :: Options -> ModuleName -> Declaration -> Environment -> Maybe [JS]
95−declToJs opts mp (ValueDeclaration ident _ _ _ val) e =
96− Just [JSVariableIntroduction (identToJs ident) (Just (valueToJs opts mp e val))]
97−declToJs opts mp (BindingGroupDeclaration vals) e =
98− Just $ flip concatMap vals $ \(ident, _, val) ->
99− [JSVariableIntroduction (identToJs ident) (Just (valueToJs opts mp e val))]
100−declToJs _ mp (DataDeclaration _ _ ctors) _ =
101− Just $ flip concatMap ctors $ \(pn@(ProperName ctor), tys) ->
94+declToJs :: (Functor m, Applicative m, Monad m) => Options -> ModuleName -> Declaration -> Environment -> SupplyT m (Maybe [JS])
95+declToJs opts mp (ValueDeclaration ident _ _ _ val) e = do
96+ js <- valueToJs opts mp e val
97+ return $ Just [JSVariableIntroduction (identToJs ident) (Just js)]
98+declToJs opts mp (BindingGroupDeclaration vals) e = do
99+ jss <- flip mapM vals $ \(ident, _, val) -> do
100+ js <- valueToJs opts mp e val
101+ return $ JSVariableIntroduction (identToJs ident) (Just js)
102+ return $ Just jss
103+declToJs _ mp (DataDeclaration _ _ ctors) _ = do
104+ return $ Just $ flip concatMap ctors $ \(pn@(ProperName ctor), tys) ->
102105 [JSVariableIntroduction ctor (Just (go pn 0 tys []))]
103106 where
104107 go :: ProperName -> Integer -> [Type] -> [JS] -> JS
@@ -107,10 +110,12 @@ declToJs _ mp (DataDeclaration _ _ ctors) _ =
107110 go pn index (_ : tys') values =
108111 JSFunction Nothing ["value" ++ show index]
109112 (JSBlock [JSReturn (go pn (index + 1) tys' (JSVar ("value" ++ show index) : values))])
110−declToJs opts mp (DataBindingGroupDeclaration ds) e = Just $ concat $ mapMaybe (flip (declToJs opts mp) e) ds
111−declToJs _ _ (ExternDeclaration _ _ (Just js) _) _ = Just [js]
113+declToJs opts mp (DataBindingGroupDeclaration ds) e = do
114+ jss <- mapM (\decl -> declToJs opts mp decl e) ds
115+ return $ Just $ concat $ catMaybes jss
116+declToJs _ _ (ExternDeclaration _ _ (Just js) _) _ = return $ Just [js]
112117declToJs opts mp (PositionedDeclaration _ d) e = declToJs opts mp d e
113−declToJs _ _ _ _ = Nothing
118+declToJs _ _ _ _ = return Nothing
114119
115120-- |
116121-- Generate key//value pairs for an object literal exporting values from a module.
@@ -144,22 +149,35 @@ accessorString prop | isIdent prop = JSAccessor prop
144149-- |
145150-- Generate code in the simplified Javascript intermediate representation for a value or expression.
146151--
147−valueToJs :: Options -> ModuleName -> Environment -> Value -> JS
148−valueToJs _ _ _ (NumericLiteral n) = JSNumericLiteral n
149−valueToJs _ _ _ (StringLiteral s) = JSStringLiteral s
150−valueToJs _ _ _ (BooleanLiteral b) = JSBooleanLiteral b
151−valueToJs opts m e (ArrayLiteral xs) = JSArrayLiteral (map (valueToJs opts m e) xs)
152−valueToJs opts m e (ObjectLiteral ps) = JSObjectLiteral (map (second (valueToJs opts m e)) ps)
153−valueToJs opts m e (ObjectUpdate o ps) = extendObj (valueToJs opts m e o) (map (second (valueToJs opts m e)) ps)
154−valueToJs _ m _ (Constructor name) = qualifiedToJS m (Ident . runProperName) name
155−valueToJs opts m e (Case values binders) = bindersToJs opts m e binders (map (valueToJs opts m e) values)
156−valueToJs opts m e (IfThenElse cond th el) = JSConditional (valueToJs opts m e cond) (valueToJs opts m e th) (valueToJs opts m e el)
157−valueToJs opts m e (Accessor prop val) = accessorString prop (valueToJs opts m e val)
158−valueToJs opts m e (App val arg) = JSApp (valueToJs opts m e val) [valueToJs opts m e arg]
159−valueToJs opts m e (Let ds val) = JSApp (JSFunction Nothing [] (JSBlock (concat (mapMaybe (flip (declToJs opts m) e) ds) ++ [JSReturn $ valueToJs opts m e val]))) []
160−valueToJs opts m e (Abs (Left arg) val) = JSFunction Nothing [identToJs arg] (JSBlock [JSReturn (valueToJs opts m (bindName m arg e) val)])
161−valueToJs opts m e (TypedValue _ (Abs (Left arg) val) ty) | optionsPerformRuntimeTypeChecks opts = let arg' = identToJs arg in JSFunction Nothing [arg'] (JSBlock $ runtimeTypeChecks arg' ty ++ [JSReturn (valueToJs opts m e val)])
162−valueToJs _ m _ (Var ident) = varToJs m ident
152+valueToJs :: (Functor m, Applicative m, Monad m) => Options -> ModuleName -> Environment -> Value -> SupplyT m JS
153+valueToJs _ _ _ (NumericLiteral n) = return $ JSNumericLiteral n
154+valueToJs _ _ _ (StringLiteral s) = return $ JSStringLiteral s
155+valueToJs _ _ _ (BooleanLiteral b) = return $ JSBooleanLiteral b
156+valueToJs opts m e (ArrayLiteral xs) = JSArrayLiteral <$> mapM (valueToJs opts m e) xs
157+valueToJs opts m e (ObjectLiteral ps) = JSObjectLiteral <$> mapM (sndM (valueToJs opts m e)) ps
158+valueToJs opts m e (ObjectUpdate o ps) = do
159+ obj <- valueToJs opts m e o
160+ sts <- mapM (sndM (valueToJs opts m e)) ps
161+ extendObj obj sts
162+valueToJs _ m _ (Constructor name) = return $ qualifiedToJS m (Ident . runProperName) name
163+valueToJs opts m e (Case values binders) = do
164+ vals <- mapM (valueToJs opts m e) values
165+ bindersToJs opts m e binders vals
166+valueToJs opts m e (IfThenElse cond th el) = JSConditional <$> valueToJs opts m e cond <*> valueToJs opts m e th <*> valueToJs opts m e el
167+valueToJs opts m e (Accessor prop val) = accessorString prop <$> valueToJs opts m e val
168+valueToJs opts m e (App val arg) = JSApp <$> valueToJs opts m e val <*> (return <$> valueToJs opts m e arg)
169+valueToJs opts m e (Let ds val) = do
170+ decls <- concat . catMaybes <$> mapM (flip (declToJs opts m) e) ds
171+ ret <- valueToJs opts m e val
172+ return $ JSApp (JSFunction Nothing [] (JSBlock (decls ++ [JSReturn ret]))) []
173+valueToJs opts m e (Abs (Left arg) val) = do
174+ ret <- valueToJs opts m (bindName m arg e) val
175+ return $ JSFunction Nothing [identToJs arg] (JSBlock [JSReturn ret])
176+valueToJs opts m e (TypedValue _ (Abs (Left arg) val) ty) | optionsPerformRuntimeTypeChecks opts = do
177+ let arg' = identToJs arg
178+ ret <- valueToJs opts m e val
179+ return $ JSFunction Nothing [arg'] (JSBlock $ runtimeTypeChecks arg' ty ++ [JSReturn ret])
180+valueToJs _ m _ (Var ident) = return $ varToJs m ident
163181valueToJs opts m e (TypedValue _ val _) = valueToJs opts m e val
164182valueToJs opts m e (PositionedValue _ val) = valueToJs opts m e val
165183valueToJs _ _ _ (TypeClassDictionary _ _ _) = error "Type class dictionary was not replaced"
@@ -168,20 +186,22 @@ valueToJs _ _ _ _ = error "Invalid argument to valueToJs"
168186-- |
169187-- Shallow copy an object.
170188--
171−extendObj :: JS -> [(String, JS)] -> JS
172−extendObj obj sts = JSApp (JSFunction Nothing [] block) []
189+extendObj :: (Functor m, Applicative m, Monad m) => JS -> [(String, JS)] -> SupplyT m JS
190+extendObj obj sts = do
191+ newObj <- freshName
192+ key <- freshName
193+ let
194+ jsKey = JSVar key
195+ jsNewObj = JSVar newObj
196+ block = JSBlock (objAssign:copy:extend ++ [JSReturn jsNewObj])
197+ objAssign = JSVariableIntroduction newObj (Just $ JSObjectLiteral [])
198+ copy = JSForIn key obj $ JSBlock [JSIfElse cond assign Nothing]
199+ cond = JSApp (JSAccessor "hasOwnProperty" obj) [jsKey]
200+ assign = JSBlock [JSAssignment (JSIndexer jsKey jsNewObj) (JSIndexer jsKey obj)]
201+ stToAssign (s, js) = JSAssignment (JSAccessor s jsNewObj) js
202+ extend = map stToAssign sts
203+ return $ JSApp (JSFunction Nothing [] block) []
173204 where
174− [newObj, key] = take 2 . map identToJs . S.unusedNames $ used
175− used = usedNamesJS obj ++ concatMap (usedNamesJS . snd) sts
176− jsKey = JSVar key
177− jsNewObj = JSVar newObj
178− block = JSBlock (objAssign:copy:extend ++ [JSReturn jsNewObj])
179− objAssign = JSVariableIntroduction newObj (Just $ JSObjectLiteral [])
180− copy = JSForIn key obj $ JSBlock [JSIfElse cond assign Nothing]
181− cond = JSApp (JSAccessor "hasOwnProperty" obj) [jsKey]
182− assign = JSBlock [JSAssignment (JSIndexer jsKey jsNewObj) (JSIndexer jsKey obj)]
183− stToAssign (s, js) = JSAssignment (JSAccessor s jsNewObj) js
184− extend = map stToAssign sts
185205
186206-- |
187207-- Temporarily extends the environment with a single local variable name
@@ -198,7 +218,6 @@ bindNames m idents env = env { names = M.fromList [ ((m, ident), (noType, LocalV
198218 where
199219 noType = error "Temporary lambda variable type was read"
200220
201−
202221-- |
203222-- Generate code in the simplified Javascript intermediate representation for runtime type checks.
204223--
@@ -251,42 +270,30 @@ qualifiedToJS _ f (Qualified _ a) = JSVar $ identToJs (f a)
251270-- Generate code in the simplified Javascript intermediate representation for pattern match binders
252271-- and guards.
253272--
254−bindersToJs :: Options -> ModuleName -> Environment -> [CaseAlternative] -> [JS] -> JS
255−bindersToJs opts m e binders vals = runGen (map identToJs (S.unusedNames usedNames)) $ do
256− valNames <- replicateM (length vals) fresh
257− jss <- forM binders $ \(CaseAlternative bs grd result) -> go valNames [JSReturn (valueToJs opts m (bindNames m (concatMap binderNames bs) e) result)] bs grd
273+bindersToJs :: (Functor m, Applicative m, Monad m) => Options -> ModuleName -> Environment -> [CaseAlternative] -> [JS] -> SupplyT m JS
274+bindersToJs opts m e binders vals = do
275+ valNames <- replicateM (length vals) freshName
276+ jss <- forM binders $ \(CaseAlternative bs grd result) -> do
277+ ret <- valueToJs opts m (bindNames m (concatMap binderNames bs) e) result
278+ go valNames [JSReturn ret] bs grd
258279 return $ JSApp (JSFunction Nothing valNames (JSBlock (concat jss ++ [JSThrow (JSStringLiteral "Failed pattern match")])))
259280 vals
260281 where
261− usedNames = concatMap usedNamesJS vals ++ concatMap S.usedNamesCaseAlternative binders
262−
263− go :: [String] -> [JS] -> [Binder] -> Maybe Guard -> Gen [JS]
282+ go :: (Functor m, Applicative m, Monad m) => [String] -> [JS] -> [Binder] -> Maybe Guard -> SupplyT m [JS]
264283 go _ done [] Nothing = return done
265− go _ done [] (Just cond) = return [JSIfElse (valueToJs opts m e cond) (JSBlock done) Nothing]
284+ go _ done [] (Just cond) = do
285+ cond' <- valueToJs opts m e cond
286+ return [JSIfElse cond' (JSBlock done) Nothing]
266287 go (v:vs) done' (b:bs) grd = do
267288 done'' <- go vs done' bs grd
268289 binderToJs m e v done'' b
269290 go _ _ _ _ = error "Invalid arguments to bindersToJs"
270291
271−-- |
272−-- Gather all used names appearing inside a value
273−--
274−usedNamesJS :: JS -> [Ident]
275−usedNamesJS val = nub $ everythingOnJS (++) namesJS val
276− where
277− namesJS (JSVar name) = [Ident name]
278− namesJS (JSFunction (Just name) args _) = Ident name : map Ident args
279− namesJS (JSFunction Nothing args _) = map Ident args
280− namesJS (JSVariableIntroduction name _) = [Ident name]
281− namesJS (JSFor name _ _ _) = [Ident name]
282− namesJS (JSForIn name _ _) = [Ident name]
283− namesJS _ = []
284−
285292-- |
286293-- Generate code in the simplified Javascript intermediate representation for a pattern match
287294-- binder.
288295--
289−binderToJs :: ModuleName -> Environment -> String -> [JS] -> Binder -> Gen [JS]
296+binderToJs :: (Functor m, Applicative m, Monad m) => ModuleName -> Environment -> String -> [JS] -> Binder -> SupplyT m [JS]
290297binderToJs _ _ _ done NullBinder = return done
291298binderToJs _ _ varName done (StringBinder str) =
292299 return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSStringLiteral str)) (JSBlock done) Nothing]
@@ -308,19 +315,19 @@ binderToJs m e varName done (ConstructorBinder ctor bs) = do
308315 (JSBlock js)
309316 Nothing]
310317 where
311− go :: Integer -> [JS] -> [Binder] -> Gen [JS]
318+ go :: (Functor m, Applicative m, Monad m) => Integer -> [JS] -> [Binder] -> SupplyT m [JS]
312319 go _ done' [] = return done'
313320 go index done' (binder:bs') = do
314− argVar <- fresh
321+ argVar <- freshName
315322 done'' <- go (index + 1) done' bs'
316323 js <- binderToJs m e argVar done'' binder
317324 return (JSVariableIntroduction argVar (Just (JSIndexer (JSNumericLiteral (Left index)) (JSAccessor "values" (JSVar varName)))) : js)
318325binderToJs m e varName done (ObjectBinder bs) = go done bs
319326 where
320− go :: [JS] -> [(String, Binder)] -> Gen [JS]
327+ go :: (Functor m, Applicative m, Monad m) => [JS] -> [(String, Binder)] -> SupplyT m [JS]
321328 go done' [] = return done'
322329 go done' ((prop, binder):bs') = do
323− propVar <- fresh
330+ propVar <- freshName
324331 done'' <- go done' bs'
325332 js <- binderToJs m e propVar done'' binder
326333 return (JSVariableIntroduction propVar (Just (accessorString prop (JSVar varName))) : js)
@@ -328,16 +335,16 @@ binderToJs m e varName done (ArrayBinder bs) = do
328335 js <- go done 0 bs
329336 return [JSIfElse (JSBinary EqualTo (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (Left (fromIntegral $ length bs)))) (JSBlock js) Nothing]
330337 where
331− go :: [JS] -> Integer -> [Binder] -> Gen [JS]
338+ go :: (Functor m, Applicative m, Monad m) => [JS] -> Integer -> [Binder] -> SupplyT m [JS]
332339 go done' _ [] = return done'
333340 go done' index (binder:bs') = do
334− elVar <- fresh
341+ elVar <- freshName
335342 done'' <- go done' (index + 1) bs'
336343 js <- binderToJs m e elVar done'' binder
337344 return (JSVariableIntroduction elVar (Just (JSIndexer (JSNumericLiteral (Left index)) (JSVar varName))) : js)
338345binderToJs m e varName done (ConsBinder headBinder tailBinder) = do
339− headVar <- fresh
340− tailVar <- fresh
346+ headVar <- freshName
347+ tailVar <- freshName
341348 js1 <- binderToJs m e headVar done headBinder
342349 js2 <- binderToJs m e tailVar js1 tailBinder
343350 return [JSIfElse (JSBinary GreaterThan (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (Left 0))) (JSBlock
src/Language/PureScript/CodeGen/Monad.hsdeleted−43
@@ -1,43 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.CodeGen.Monad
4−-- Copyright : (c) Phil Freeman 2013
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−-- Code generation monad
13−--
14−-- This monad provides a supply of fresh names which can be used to create variables.
15−--
16−-----------------------------------------------------------------------------
17−
18−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
19−
20−module Language.PureScript.CodeGen.Monad where
21−
22−import Control.Monad.State
23−import Control.Applicative
24−
25−-- |
26−-- Code generation monad data type
27−--
28−newtype Gen a = Gen { unGen :: State [String] a } deriving (Functor, Applicative, Monad, MonadState [String])
29−
30−-- |
31−-- Run a computation in the code generation monad
32−--
33−runGen :: [String] -> Gen a -> a
34−runGen names = flip evalState names . unGen
35−
36−-- |
37−-- Generate a fresh name
38−--
39−fresh :: Gen String
40−fresh = do
41− (s:ss) <- get
42− put ss
43− return s
src/Language/PureScript/Scope.hsdeleted−84
@@ -1,84 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.Scope
4−-- Copyright : (c) Phil Freeman 2013
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−-- Utility functions for working with names in scope
13−--
14−-----------------------------------------------------------------------------
15−
16−module Language.PureScript.Scope (
17− usedNamesDecl,
18− usedNamesValue,
19− usedNamesBinder,
20− usedNamesCaseAlternative,
21− usedNamesDoNotationElement,
22− unusedNames
23−) where
24−
25−import Data.List ((\\), nub)
26−
27−import Language.PureScript.Declarations
28−import Language.PureScript.Names
29−
30−usedNames :: (Declaration -> [Ident], Value -> [Ident], Binder -> [Ident], CaseAlternative -> [Ident], DoNotationElement -> [Ident])
31−usedNames = everythingOnValues (++) f g h (const []) (const [])
32− where
33− f :: Declaration -> [Ident]
34− f (ValueDeclaration name _ _ _ _) = [name]
35− f _ = []
36−
37− g :: Value -> [Ident]
38− g (Abs (Left arg) _) = [arg]
39− g (Var (Qualified Nothing name)) = [name]
40− g _ = []
41−
42− h :: Binder -> [Ident]
43− h (VarBinder name) = [name]
44− h _ = []
45−
46−-- |
47−-- Gather all used names appearing inside a declaration
48−--
49−usedNamesDecl :: Declaration -> [Ident]
50−usedNamesDecl = let (f, _, _, _, _) = usedNames in nub . f
51−
52−-- |
53−-- Gather all used names appearing inside a value
54−--
55−usedNamesValue :: Value -> [Ident]
56−usedNamesValue = let (_, f, _, _, _) = usedNames in nub . f
57−
58−-- |
59−-- Gather all used names appearing inside a binder
60−--
61−usedNamesBinder :: Binder -> [Ident]
62−usedNamesBinder = let (_, _, f, _, _) = usedNames in nub . f
63−
64−-- |
65−-- Gather all used names appearing inside a case alternative
66−--
67−usedNamesCaseAlternative :: CaseAlternative -> [Ident]
68−usedNamesCaseAlternative = let (_, _, _, f, _) = usedNames in nub . f
69−
70−-- |
71−-- Gather all used names appearing inside a do notation element
72−--
73−usedNamesDoNotationElement :: DoNotationElement -> [Ident]
74−usedNamesDoNotationElement = let (_, _, _, _, f) = usedNames in nub . f
75−
76−-- |
77−-- Generate a set of names which are unused inside a value, of the form @_{n}@ for an integer @n@
78−--
79−unusedNames :: [Ident] -> [Ident]
80−unusedNames allNames =
81− let
82− varNames = map (Ident . ('_' :) . show) ([1..] :: [Int])
83− in
84− varNames \\ allNames
src/Language/PureScript/Sugar.hs+8−7
@@ -16,9 +16,12 @@
1616module Language.PureScript.Sugar (desugar, module S) where
1717
1818import Control.Monad
19+import Control.Category ((>>>))
20+import Control.Monad.Trans.Class
1921
2022import Language.PureScript.Declarations
2123import Language.PureScript.Errors
24+import Language.PureScript.Supply
2225
2326import Language.PureScript.Sugar.Operators as S
2427import Language.PureScript.Sugar.DoNotation as S
@@ -28,8 +31,6 @@ import Language.PureScript.Sugar.BindingGroups as S
2831import Language.PureScript.Sugar.TypeClasses as S
2932import Language.PureScript.Sugar.Names as S
3033
31−import Control.Category ((>>>))
32−
3334-- |
3435-- The desugaring pipeline proceeds as follows:
3536--
@@ -47,12 +48,12 @@ import Control.Category ((>>>))
4748--
4849-- * Qualify any unqualified names and types
4950--
50−desugar :: [Module] -> Either ErrorStack [Module]
51+desugar :: [Module] -> SupplyT (Either ErrorStack) [Module]
5152desugar = map removeSignedLiterals
5253 >>> mapM desugarDoModule
5354 >=> desugarCasesModule
54− >=> desugarTypeDeclarationsModule
55− >=> desugarImports
56− >=> rebracket
55+ >=> lift . (desugarTypeDeclarationsModule
56+ >=> desugarImports
57+ >=> rebracket)
5758 >=> desugarTypeClasses
58− >=> createBindingGroupsModule
59+ >=> lift . createBindingGroupsModule
src/Language/PureScript/Sugar/CaseDeclarations.hs+22−25
@@ -23,43 +23,41 @@ import Data.Monoid ((<>))
2323import Data.List (groupBy)
2424
2525import Control.Applicative
26−import Control.Monad ((<=<), forM, join, unless)
26+import Control.Monad ((<=<), forM, join, unless, replicateM)
2727import Control.Monad.Error.Class
2828
2929import Language.PureScript.Names
3030import Language.PureScript.Declarations
31−import Language.PureScript.Scope
3231import Language.PureScript.Environment
3332import Language.PureScript.Errors
33+import Language.PureScript.Supply
3434
3535-- |
3636-- Replace all top-level binders in a module with case expressions.
3737--
38−desugarCasesModule :: [Module] -> Either ErrorStack [Module]
38+desugarCasesModule :: [Module] -> SupplyT (Either ErrorStack) [Module]
3939desugarCasesModule ms = forM ms $ \(Module name ds exps) ->
4040 rethrow (strMsg ("Error in module " ++ show name) <>) $
41− Module name <$> (desugarCases . desugarAbs $ ds) <*> pure exps
41+ Module name <$> (desugarCases <=< desugarAbs $ ds) <*> pure exps
4242
43−desugarAbs :: [Declaration] -> [Declaration]
44−desugarAbs = map f
43+desugarAbs :: [Declaration] -> SupplyT (Either ErrorStack) [Declaration]
44+desugarAbs = mapM f
4545 where
46− (f, _, _) = everywhereOnValues id replace id
46+ (f, _, _) = everywhereOnValuesM return replace return
4747
48− replace (Abs (Right binder) val) =
49− let
50− used = usedNamesBinder binder ++ usedNamesValue val
51− ident = head $ unusedNames used
52− in
53− Abs (Left ident) $ Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] Nothing val]
54− replace other = other
48+ replace :: Value -> SupplyT (Either ErrorStack) Value
49+ replace (Abs (Right binder) val) = do
50+ ident <- Ident <$> freshName
51+ return $ Abs (Left ident) $ Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] Nothing val]
52+ replace other = return other
5553
5654-- |
5755-- Replace all top-level binders with case expressions.
5856--
59−desugarCases :: [Declaration] -> Either ErrorStack [Declaration]
57+desugarCases :: [Declaration] -> SupplyT (Either ErrorStack) [Declaration]
6058desugarCases = desugarRest <=< fmap join . mapM toDecls . groupBy inSameGroup
6159 where
62− desugarRest :: [Declaration] -> Either ErrorStack [Declaration]
60+ desugarRest :: [Declaration] -> SupplyT (Either ErrorStack) [Declaration]
6361 desugarRest (TypeInstanceDeclaration name constraints className tys ds : rest) =
6462 (:) <$> (TypeInstanceDeclaration name constraints className tys <$> desugarCases ds) <*> desugarRest rest
6563 desugarRest (ValueDeclaration name nameKind bs g val : rest) =
@@ -80,7 +78,7 @@ inSameGroup (PositionedDeclaration _ d1) d2 = inSameGroup d1 d2
8078inSameGroup d1 (PositionedDeclaration _ d2) = inSameGroup d1 d2
8179inSameGroup _ _ = False
8280
83−toDecls :: [Declaration] -> Either ErrorStack [Declaration]
81+toDecls :: [Declaration] -> SupplyT (Either ErrorStack) [Declaration]
8482toDecls [ValueDeclaration ident nameKind bs Nothing val] | all isVarBinder bs = do
8583 let args = map (\(VarBinder arg) -> arg) bs
8684 body = foldr (Abs . Left) val args
@@ -89,7 +87,8 @@ toDecls ds@(ValueDeclaration ident _ bs _ _ : _) = do
8987 let tuples = map toTuple ds
9088 unless (all ((== length bs) . length . fst) tuples) $
9189 throwError $ mkErrorStack ("Argument list lengths differ in declaration " ++ show ident) Nothing
92− return [makeCaseDeclaration ident tuples]
90+ caseDecl <- makeCaseDeclaration ident tuples
91+ return [caseDecl]
9392toDecls (PositionedDeclaration pos d : ds) = do
9493 (d' : ds') <- rethrowWithPosition pos $ toDecls (d : ds)
9594 return (PositionedDeclaration pos d' : ds')
@@ -104,15 +103,13 @@ toTuple (ValueDeclaration _ _ bs g val) = (bs, (g, val))
104103toTuple (PositionedDeclaration _ d) = toTuple d
105104toTuple _ = error "Not a value declaration"
106105
107−makeCaseDeclaration :: Ident -> [([Binder], (Maybe Guard, Value))] -> Declaration
108−makeCaseDeclaration ident alternatives =
106+makeCaseDeclaration :: Ident -> [([Binder], (Maybe Guard, Value))] -> SupplyT (Either ErrorStack) Declaration
107+makeCaseDeclaration ident alternatives = do
108+ let argPattern = length . fst . head $ alternatives
109+ args <- map Ident <$> replicateM argPattern freshName
109110 let
110− argPattern = length . fst . head $ alternatives
111− args = take argPattern $ unusedNames used
112− used = concatMap (\(bs, (grd, val)) -> concatMap usedNamesBinder bs ++ maybe [] usedNamesValue grd ++ usedNamesValue val) alternatives
113111 vars = map (Var . Qualified Nothing) args
114112 binders = [ CaseAlternative bs g val | (bs, (g, val)) <- alternatives ]
115113 value = foldr (Abs . Left) (Case vars binders) args
116− in
117− ValueDeclaration ident Value [] Nothing value
114+ return $ ValueDeclaration ident Value [] Nothing value
118115
src/Language/PureScript/Sugar/DoNotation.hs+9−9
@@ -19,22 +19,23 @@ module Language.PureScript.Sugar.DoNotation (
1919) where
2020
2121import Language.PureScript.Names
22−import Language.PureScript.Scope
2322import Language.PureScript.Declarations
2423import Language.PureScript.Errors
24+import Language.PureScript.Supply
2525
2626import qualified Language.PureScript.Constants as C
2727
2828import Control.Applicative
29+import Control.Monad.Trans.Class
2930
3031-- |
3132-- Replace all @DoNotationBind@ and @DoNotationValue@ constructors with applications of the Prelude.(>>=) function,
3233-- and all @DoNotationLet@ constructors with let expressions.
3334--
34−desugarDoModule :: Module -> Either ErrorStack Module
35+desugarDoModule :: Module -> SupplyT (Either ErrorStack) Module
3536desugarDoModule (Module mn ds exts) = Module mn <$> mapM desugarDo ds <*> pure exts
3637
37−desugarDo :: Declaration -> Either ErrorStack Declaration
38+desugarDo :: Declaration -> SupplyT (Either ErrorStack) Declaration
3839desugarDo (PositionedDeclaration pos d) = (PositionedDeclaration pos) <$> (rethrowWithPosition pos $ desugarDo d)
3940desugarDo d =
4041 let (f, _, _) = everywhereOnValuesM return replace return
@@ -46,28 +47,27 @@ desugarDo d =
4647 bind :: Value
4748 bind = Var (Qualified (Just prelude) (Op (C.>>=)))
4849
49− replace :: Value -> Either ErrorStack Value
50+ replace :: Value -> SupplyT (Either ErrorStack) Value
5051 replace (Do els) = go els
5152 replace (PositionedValue pos v) = PositionedValue pos <$> rethrowWithPosition pos (replace v)
5253 replace other = return other
5354
54− go :: [DoNotationElement] -> Either ErrorStack Value
55+ go :: [DoNotationElement] -> SupplyT (Either ErrorStack) Value
5556 go [] = error "The impossible happened in desugarDo"
5657 go [DoNotationValue val] = return val
5758 go (DoNotationValue val : rest) = do
5859 rest' <- go rest
5960 return $ App (App bind val) (Abs (Left (Ident "_")) rest')
60− go [DoNotationBind _ _] = Left $ mkErrorStack "Bind statement cannot be the last statement in a do block" Nothing
61+ go [DoNotationBind _ _] = lift $ Left $ mkErrorStack "Bind statement cannot be the last statement in a do block" Nothing
6162 go (DoNotationBind NullBinder val : rest) = go (DoNotationValue val : rest)
6263 go (DoNotationBind (VarBinder ident) val : rest) = do
6364 rest' <- go rest
6465 return $ App (App bind val) (Abs (Left ident) rest')
6566 go (DoNotationBind binder val : rest) = do
6667 rest' <- go rest
67− let used = concatMap usedNamesDoNotationElement rest
68− ident = head $ unusedNames used
68+ ident <- Ident <$> freshName
6969 return $ App (App bind val) (Abs (Left ident) (Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] Nothing rest']))
70− go [DoNotationLet _] = Left $ mkErrorStack "Let statement cannot be the last statement in a do block" Nothing
70+ go [DoNotationLet _] = lift $ Left $ mkErrorStack "Let statement cannot be the last statement in a do block" Nothing
7171 go (DoNotationLet ds : rest) = do
7272 rest' <- go rest
7373 return $ Let ds rest'
src/Language/PureScript/Sugar/TypeClasses.hs+5−4
@@ -24,6 +24,7 @@ import Language.PureScript.Types
2424import Language.PureScript.Sugar.CaseDeclarations
2525import Language.PureScript.Environment
2626import Language.PureScript.Errors
27+import Language.PureScript.Supply
2728import Language.PureScript.Pretty.Types (prettyPrintTypeAtom)
2829
2930import qualified Language.PureScript.Constants as C
@@ -40,13 +41,13 @@ import qualified Data.Map as M
4041
4142type MemberMap = M.Map (ModuleName, ProperName) Declaration
4243
43−type Desugar = StateT MemberMap (Either ErrorStack)
44+type Desugar = StateT MemberMap (SupplyT (Either ErrorStack))
4445
4546-- |
4647-- Add type synonym declarations for type class dictionary types, and value declarations for type class
4748-- instance dictionary expressions.
4849--
49−desugarTypeClasses :: [Module] -> Either ErrorStack [Module]
50+desugarTypeClasses :: [Module] -> SupplyT (Either ErrorStack) [Module]
5051desugarTypeClasses = flip evalStateT M.empty . mapM desugarModule
5152
5253desugarModule :: Module -> Desugar Module
@@ -160,7 +161,7 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =
160161 m <- get
161162
162163 -- Lookup the type arguments and member types for the type class
163− (TypeClassDeclaration _ args implies tyDecls) <- lift $
164+ (TypeClassDeclaration _ args implies tyDecls) <- lift . lift $
164165 maybe (Left $ mkErrorStack ("Type class " ++ show className ++ " is undefined") Nothing) Right $
165166 M.lookup (qualify mn className) m
166167
@@ -203,7 +204,7 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =
203204
204205 memberToNameAndValue :: [(Ident, Type)] -> Declaration -> Desugar (Ident, Value)
205206 memberToNameAndValue tys' d@(ValueDeclaration ident _ _ _ _) = do
206− _ <- lift . maybe (Left $ mkErrorStack ("Type class does not define member '" ++ show ident ++ "'") Nothing) Right $ lookup ident tys'
207+ _ <- lift . lift . maybe (Left $ mkErrorStack ("Type class does not define member '" ++ show ident ++ "'") Nothing) Right $ lookup ident tys'
207208 let memberValue = typeInstanceDictionaryEntryValue d
208209 return (ident, memberValue)
209210 memberToNameAndValue tys' (PositionedDeclaration pos d) = rethrowWithPosition pos $ do
src/Language/PureScript/Supply.hsnew file+50
@@ -0,0 +1,50 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Supply
4+-- Copyright : (c) Phil Freeman 2014
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- Fresh variable supply
13+--
14+-----------------------------------------------------------------------------
15+
16+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
17+{-# LANGUAGE FlexibleInstances #-}
18+{-# LANGUAGE MultiParamTypeClasses #-}
19+{-# LANGUAGE UndecidableInstances #-}
20+
21+module Language.PureScript.Supply where
22+
23+import Data.Functor.Identity
24+
25+import Control.Applicative
26+import Control.Monad.State
27+import Control.Monad.Error.Class
28+
29+newtype SupplyT m a = SupplyT { unSupplyT :: StateT Integer m a } deriving (Functor, Applicative, Monad, MonadTrans)
30+
31+runSupplyT :: Integer -> SupplyT m a -> m (a, Integer)
32+runSupplyT n = flip runStateT n . unSupplyT
33+
34+type Supply = SupplyT Identity
35+
36+runSupply :: Integer -> Supply a -> (a, Integer)
37+runSupply n = runIdentity . runSupplyT n
38+
39+fresh :: (Monad m) => SupplyT m Integer
40+fresh = SupplyT $ do
41+ n <- get
42+ put (n + 1)
43+ return n
44+
45+freshName :: (Functor m, Monad m) => SupplyT m String
46+freshName = ('_' :) . show <$> fresh
47+
48+instance (MonadError e m) => MonadError e (SupplyT m) where
49+ throwError = SupplyT . throwError
50+ catchError e f = SupplyT $ catchError (unSupplyT e) (unSupplyT . f)