56fdde4 · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

on golang help sign in

Use a global variable supply

56fdde4Phil Freeman12 years ago

psc-make/Main.hs+1−1

compare with golang

unifiedsplit

@@ -45,7 +45,7 @@ readInput input = fmap collect $ forM input $ \inputFile -> do

45 collect :: [(FilePath, Either ParseError [P.Module])] -> Either ParseError [(FilePath, P.Module)]

46 collect = fmap concat . sequence . map (\(fp, e) -> fmap (map ((,) fp)) e)

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)

50runMake :: Make a -> IO (Either String a)

51runMake = runErrorT . unMake

purescript.cabal+2−3

@@ -34,8 +34,8 @@ library

34 Language.PureScript.Errors

35 Language.PureScript.Kinds

36 Language.PureScript.Names

37+ Language.PureScript.Supply

37 Language.PureScript.Types

38 Language.PureScript.Types

38− Language.PureScript.Scope

39 Language.PureScript.Traversals

40 Language.PureScript.TypeClassDictionaries

41 Language.PureScript.DeadCodeElimination

@@ -53,7 +53,6 @@ library

53 Language.PureScript.CodeGen.Externs

54 Language.PureScript.CodeGen.JS

55 Language.PureScript.CodeGen.JS.AST

56− Language.PureScript.CodeGen.Monad

57 Language.PureScript.Optimizer

56 Language.PureScript.Optimizer

58 Language.PureScript.Optimizer.Common

57 Language.PureScript.Optimizer.Common

59 Language.PureScript.Optimizer.MagicDo

58 Language.PureScript.Optimizer.MagicDo

@@ -136,7 +135,7 @@ executable hierarchy

136

135

137test-suite tests

136test-suite tests

138 build-depends: base >=4 && <5, containers -any, directory -any,

137 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,

140 transformers -any, utf8-string -any, process -any

139 transformers -any, utf8-string -any, process -any

141 type: exitcode-stdio-1.0

140 type: exitcode-stdio-1.0

142 main-is: Main.hs

141 main-is: Main.hs

src/Language/PureScript.hs+16−15

@@ -30,6 +30,7 @@ import Language.PureScript.ModuleDependencies as P

30import Language.PureScript.Environment as P

31import Language.PureScript.Errors as P

32import Language.PureScript.DeadCodeElimination as P

33+import Language.PureScript.Supply as P

34import qualified Language.PureScript.Constants as C

35import qualified Language.PureScript.Constants as C

@@ -40,7 +41,7 @@ import Data.Maybe (fromJust, fromMaybe)

40import Control.Monad.Error

41import Control.Monad.Error

41import Control.Monad.State.Lazy

42import Control.Monad.State.Lazy

42import Control.Arrow ((&&&))

43import Control.Arrow ((&&&))

43−import Control.Applicative ((<$>))

44+import Control.Applicative

44import qualified Data.Map as M

45import qualified Data.Map as M

45import qualified Data.Set as S

46import qualified Data.Set as S

46import System.FilePath (pathSeparator)

47import System.FilePath (pathSeparator)

@@ -70,14 +71,14 @@ compile = compile' initEnvironment

70compile' :: Environment -> Options -> [Module] -> Either String (String, String, Environment)

71compile' :: Environment -> Options -> [Module] -> Either String (String, String, Environment)

71compile' env opts ms = do

72compile' env opts ms = do

72 (sorted, _) <- sortModules $ if optionsNoPrelude opts then ms else (map importPrelude ms)

73 (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

74 (elaborated, env') <- runCheck' opts env $ forM desugared $ typeCheckModule mainModuleIdent

75 (elaborated, env') <- runCheck' opts env $ forM desugared $ typeCheckModule mainModuleIdent

75 regrouped <- stringifyErrorStack True $ createBindingGroupsModule . collapseBindingGroupsModule $ elaborated

76 regrouped <- stringifyErrorStack True $ createBindingGroupsModule . collapseBindingGroupsModule $ elaborated

76 let entryPoints = moduleNameFromString `map` optionsModules opts

77 let entryPoints = moduleNameFromString `map` optionsModules opts

77 let elim = if null entryPoints then regrouped else eliminateDeadCode entryPoints regrouped

78 let elim = if null entryPoints then regrouped else eliminateDeadCode entryPoints regrouped

78 let codeGenModules = moduleNameFromString `map` optionsCodeGenModules opts

79 let codeGenModules = moduleNameFromString `map` optionsCodeGenModules opts

79 let modulesToCodeGen = if null codeGenModules then elim else filter (\(Module mn _ _) -> mn `elem` codeGenModules) elim

80 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

81 let exts = intercalate "\n" . map (`moduleToPs` env') $ modulesToCodeGen

82 let exts = intercalate "\n" . map (`moduleToPs` env') $ modulesToCodeGen

82 js' <- generateMain env' opts js

83 js' <- generateMain env' opts js

83 return (prettyPrintJS js', exts, env')

84 return (prettyPrintJS js', exts, env')

@@ -165,7 +166,7 @@ class MonadMake m where

165-- If timestamps have not changed, the externs file can be used to provide the module's types without

166-- If timestamps have not changed, the externs file can be used to provide the module's types without

166-- having to typecheck the module again.

167-- having to typecheck the module again.

167--

168--

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

169make outputDir opts ms = do

170make outputDir opts ms = do

170 let filePathMap = M.fromList (map (\(fp, Module mn _ _) -> (mn, fp)) ms)

171 let filePathMap = M.fromList (map (\(fp, Module mn _ _) -> (mn, fp)) ms)

171

172

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

188

189

189 marked <- rebuildIfNecessary (reverseDependencies graph) toRebuild sorted

190 marked <- rebuildIfNecessary (reverseDependencies graph) toRebuild sorted

190

191

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)

192

193

193− go initEnvironment desugared

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

194

195

195 where

196 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

197 go env [] = return env

198 go env [] = return env

198 go env ((False, m) : ms') = do

199 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

200

201

201 go env' ms'

202 go env' ms'

202 go env ((True, m@(Module moduleName' _ exps)) : ms') = do

203 go env ((True, m@(Module moduleName' _ exps)) : ms') = do

@@ -204,18 +205,18 @@ make outputDir opts ms = do

204 jsFile = outputDir ++ pathSeparator : filePath ++ pathSeparator : "index.js"

205 jsFile = outputDir ++ pathSeparator : filePath ++ pathSeparator : "index.js"

205 externsFile = outputDir ++ pathSeparator : filePath ++ pathSeparator : "externs.purs"

206 externsFile = outputDir ++ pathSeparator : filePath ++ pathSeparator : "externs.purs"

206

207

207− progress $ "Compiling " ++ runModuleName moduleName'

208+ lift . progress $ "Compiling " ++ runModuleName moduleName'

208

209

209− (Module _ elaborated _, env') <- liftError . runCheck' opts env $ typeCheckModule Nothing m

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

210

211

211− regrouped <- liftError . stringifyErrorStack True . createBindingGroups moduleName' . collapseBindingGroups $ elaborated

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

212

213

213 let mod' = Module moduleName' regrouped exps

214 let mod' = Module moduleName' regrouped exps

214− js = prettyPrintJS $ moduleToJs CommonJS opts mod' env'

215+ js <- prettyPrintJS <$> moduleToJs CommonJS opts mod' env'

215− exts = moduleToPs mod' env'

216+ let exts = moduleToPs mod' env'

216

217

217− writeTextFile jsFile js

218+ lift $ writeTextFile jsFile js

218− writeTextFile externsFile exts

219+ lift $ writeTextFile externsFile exts

219

220

220 go env' ms'

221 go env' ms'

221

222

src/Language/PureScript/CodeGen/JS.hs+100−93

@@ -23,26 +23,25 @@ module Language.PureScript.CodeGen.JS (

23 isIdent

24) where

26−import Data.Maybe (fromJust, fromMaybe, mapMaybe)

26+import Data.Maybe (catMaybes, fromJust, fromMaybe)

27import Data.Function (on)

28import Data.List (nub, (\\))

30−import Control.Arrow (second)

31import Control.Monad (replicateM, forM)

30import Control.Monad (replicateM, forM)

31+import Control.Applicative

33import qualified Data.Map as M

35import Language.PureScript.Names

36import Language.PureScript.Declarations

37−import Language.PureScript.CodeGen.Monad

38import Language.PureScript.Options

37import Language.PureScript.Options

39import Language.PureScript.CodeGen.JS.AST as AST

38import Language.PureScript.CodeGen.JS.AST as AST

40import Language.PureScript.Types

39import Language.PureScript.Types

41import Language.PureScript.Optimizer

40import Language.PureScript.Optimizer

42import Language.PureScript.CodeGen.Common

41import Language.PureScript.CodeGen.Common

43import Language.PureScript.Environment

42import Language.PureScript.Environment

44−

43+import Language.PureScript.Supply

45−import qualified Language.PureScript.Scope as S

44+import Language.PureScript.Traversals (sndM)

47-- |

46-- |

48-- Different types of modules which are supported

47-- Different types of modules which are supported

@@ -53,22 +52,23 @@ data ModuleType = CommonJS | Globals

53-- Generate code in the simplified Javascript intermediate representation for all declarations in a

52-- Generate code in the simplified Javascript intermediate representation for all declarations in a

54-- module.

53-- module.

55--

54--

56−moduleToJs :: ModuleType -> Options -> Module -> Environment -> [JS]

55+moduleToJs :: (Functor m, Applicative m, Monad m) => ModuleType -> Options -> Module -> Environment -> SupplyT m [JS]

57−moduleToJs mt opts (Module name decls (Just exps)) env = case mt of

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

58− CommonJS -> moduleBody ++ [JSAssignment (JSAccessor "exports" (JSVar "module")) moduleExports]

64+ CommonJS -> moduleBody ++ [JSAssignment (JSAccessor "exports" (JSVar "module")) moduleExports]

59− Globals | not isModuleEmpty ->

65+ Globals | not isModuleEmpty ->

60− [ JSVariableIntroduction (fromJust (optionsBrowserNamespace opts))

66+ [ JSVariableIntroduction (fromJust (optionsBrowserNamespace opts))

61− (Just (JSBinary Or (JSVar (fromJust (optionsBrowserNamespace opts))) (JSObjectLiteral [])) )

67+ (Just (JSBinary Or (JSVar (fromJust (optionsBrowserNamespace opts))) (JSObjectLiteral [])) )

62− , JSAssignment (JSAccessor (moduleNameToJs name) (JSVar (fromJust (optionsBrowserNamespace opts))))

68+ , JSAssignment (JSAccessor (moduleNameToJs name) (JSVar (fromJust (optionsBrowserNamespace opts))))

63− (JSApp (JSFunction Nothing [] (JSBlock (moduleBody ++ [JSReturn moduleExports]))) [])

69+ (JSApp (JSFunction Nothing [] (JSBlock (moduleBody ++ [JSReturn moduleExports]))) [])

64− ]

70+ ]

65− _ -> []

71+ _ -> []

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

72moduleToJs _ _ _ _ = error "Exports should have been elaborated in name desugaring"

74importToJs :: ModuleType -> Options -> ModuleName -> JS

@@ -91,14 +91,17 @@ imports =

91-- |

92-- Generate code in the simplified Javascript intermediate representation for a declaration

93--

94−declToJs :: Options -> ModuleName -> Declaration -> Environment -> Maybe [JS]

94+declToJs :: (Functor m, Applicative m, Monad m) => Options -> ModuleName -> Declaration -> Environment -> SupplyT m (Maybe [JS])

95−declToJs opts mp (ValueDeclaration ident _ _ _ val) e =

95+declToJs opts mp (ValueDeclaration ident _ _ _ val) e = do

96+ js <- valueToJs opts mp e val

96− Just [JSVariableIntroduction (identToJs ident) (Just (valueToJs opts mp e val))]

97+ return $ Just [JSVariableIntroduction (identToJs ident) (Just js)]

97−declToJs opts mp (BindingGroupDeclaration vals) e =

98+declToJs opts mp (BindingGroupDeclaration vals) e = do

98− Just $ flip concatMap vals $ \(ident, _, val) ->

99+ jss <- flip mapM vals $ \(ident, _, val) -> do

100+ js <- valueToJs opts mp e val

99− [JSVariableIntroduction (identToJs ident) (Just (valueToJs opts mp e val))]

101+ return $ JSVariableIntroduction (identToJs ident) (Just js)

102+ return $ Just jss

100−declToJs _ mp (DataDeclaration _ _ ctors) _ =

103+declToJs _ mp (DataDeclaration _ _ ctors) _ = do

101− Just $ flip concatMap ctors $ \(pn@(ProperName ctor), tys) ->

104+ return $ Just $ flip concatMap ctors $ \(pn@(ProperName ctor), tys) ->

102 [JSVariableIntroduction ctor (Just (go pn 0 tys []))]

105 [JSVariableIntroduction ctor (Just (go pn 0 tys []))]

103 where

106 where

104 go :: ProperName -> Integer -> [Type] -> [JS] -> JS

107 go :: ProperName -> Integer -> [Type] -> [JS] -> JS

@@ -107,10 +110,12 @@ declToJs _ mp (DataDeclaration _ _ ctors) _ =

107 go pn index (_ : tys') values =

110 go pn index (_ : tys') values =

108 JSFunction Nothing ["value" ++ show index]

111 JSFunction Nothing ["value" ++ show index]

109 (JSBlock [JSReturn (go pn (index + 1) tys' (JSVar ("value" ++ show index) : values))])

112 (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

113+declToJs opts mp (DataBindingGroupDeclaration ds) e = do

114+ jss <- mapM (\decl -> declToJs opts mp decl e) ds

115+ return $ Just $ concat $ catMaybes jss

111−declToJs _ _ (ExternDeclaration _ _ (Just js) _) _ = Just [js]

116+declToJs _ _ (ExternDeclaration _ _ (Just js) _) _ = return $ Just [js]

112declToJs opts mp (PositionedDeclaration _ d) e = declToJs opts mp d e

117declToJs opts mp (PositionedDeclaration _ d) e = declToJs opts mp d e

113−declToJs _ _ _ _ = Nothing

118+declToJs _ _ _ _ = return Nothing

114

119

115-- |

120-- |

116-- Generate key//value pairs for an object literal exporting values from a module.

121-- Generate key//value pairs for an object literal exporting values from a module.

@@ -144,22 +149,35 @@ accessorString prop | isIdent prop = JSAccessor prop

144-- |

149-- |

145-- Generate code in the simplified Javascript intermediate representation for a value or expression.

150-- Generate code in the simplified Javascript intermediate representation for a value or expression.

146--

151--

147−valueToJs :: Options -> ModuleName -> Environment -> Value -> JS

152+valueToJs :: (Functor m, Applicative m, Monad m) => Options -> ModuleName -> Environment -> Value -> SupplyT m JS

148−valueToJs _ _ _ (NumericLiteral n) = JSNumericLiteral n

153+valueToJs _ _ _ (NumericLiteral n) = return $ JSNumericLiteral n

149−valueToJs _ _ _ (StringLiteral s) = JSStringLiteral s

154+valueToJs _ _ _ (StringLiteral s) = return $ JSStringLiteral s

150−valueToJs _ _ _ (BooleanLiteral b) = JSBooleanLiteral b

155+valueToJs _ _ _ (BooleanLiteral b) = return $ JSBooleanLiteral b

151−valueToJs opts m e (ArrayLiteral xs) = JSArrayLiteral (map (valueToJs opts m e) xs)

156+valueToJs opts m e (ArrayLiteral xs) = JSArrayLiteral <$> mapM (valueToJs opts m e) xs

152−valueToJs opts m e (ObjectLiteral ps) = JSObjectLiteral (map (second (valueToJs opts m e)) ps)

157+valueToJs opts m e (ObjectLiteral ps) = JSObjectLiteral <$> mapM (sndM (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)

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

154−valueToJs _ m _ (Constructor name) = qualifiedToJS m (Ident . runProperName) name

162+valueToJs _ m _ (Constructor name) = return $ qualifiedToJS m (Ident . runProperName) name

155−valueToJs opts m e (Case values binders) = bindersToJs opts m e binders (map (valueToJs opts m e) values)

163+valueToJs opts m e (Case values binders) = do

164+ vals <- mapM (valueToJs opts m e) values

165+ bindersToJs opts m e binders vals

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)

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

157−valueToJs opts m e (Accessor prop val) = accessorString prop (valueToJs opts m e val)

167+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]

168+valueToJs opts m e (App val arg) = JSApp <$> valueToJs opts m e val <*> (return <$> 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]))) []

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

160−valueToJs opts m e (Abs (Left arg) val) = JSFunction Nothing [identToJs arg] (JSBlock [JSReturn (valueToJs opts m (bindName m arg e) val)])

174+ ret <- valueToJs opts m (bindName m arg e) val

175+ return $ JSFunction Nothing [identToJs arg] (JSBlock [JSReturn ret])

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)])

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])

162−valueToJs _ m _ (Var ident) = varToJs m ident

180+valueToJs _ m _ (Var ident) = return $ varToJs m ident

163valueToJs opts m e (TypedValue _ val _) = valueToJs opts m e val

181valueToJs opts m e (TypedValue _ val _) = valueToJs opts m e val

164valueToJs opts m e (PositionedValue _ val) = valueToJs opts m e val

182valueToJs opts m e (PositionedValue _ val) = valueToJs opts m e val

165valueToJs _ _ _ (TypeClassDictionary _ _ _) = error "Type class dictionary was not replaced"

183valueToJs _ _ _ (TypeClassDictionary _ _ _) = error "Type class dictionary was not replaced"

@@ -168,20 +186,22 @@ valueToJs _ _ _ _ = error "Invalid argument to valueToJs"

168-- |

186-- |

169-- Shallow copy an object.

187-- Shallow copy an object.

170--

188--

171−extendObj :: JS -> [(String, JS)] -> JS

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

172−extendObj obj sts = JSApp (JSFunction Nothing [] block) []

203+ return $ JSApp (JSFunction Nothing [] block) []

173 where

204 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

185

205

186-- |

206-- |

187-- Temporarily extends the environment with a single local variable name

207-- 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

198 where

218 where

199 noType = error "Temporary lambda variable type was read"

219 noType = error "Temporary lambda variable type was read"

200

220

201−

202-- |

221-- |

203-- Generate code in the simplified Javascript intermediate representation for runtime type checks.

222-- Generate code in the simplified Javascript intermediate representation for runtime type checks.

204--

223--

@@ -251,42 +270,30 @@ qualifiedToJS _ f (Qualified _ a) = JSVar $ identToJs (f a)

251-- Generate code in the simplified Javascript intermediate representation for pattern match binders

270-- Generate code in the simplified Javascript intermediate representation for pattern match binders

252-- and guards.

271-- and guards.

253--

272--

254−bindersToJs :: Options -> ModuleName -> Environment -> [CaseAlternative] -> [JS] -> JS

273+bindersToJs :: (Functor m, Applicative m, Monad m) => Options -> ModuleName -> Environment -> [CaseAlternative] -> [JS] -> SupplyT m JS

255−bindersToJs opts m e binders vals = runGen (map identToJs (S.unusedNames usedNames)) $ do

274+bindersToJs opts m e binders vals = do

256− valNames <- replicateM (length vals) fresh

275+ valNames <- replicateM (length vals) freshName

276+ jss <- forM binders $ \(CaseAlternative bs grd result) -> do

257− jss <- forM binders $ \(CaseAlternative bs grd result) -> go valNames [JSReturn (valueToJs opts m (bindNames m (concatMap binderNames bs) e) result)] bs grd

277+ ret <- valueToJs opts m (bindNames m (concatMap binderNames bs) e) result

278+ go valNames [JSReturn ret] bs grd

258 return $ JSApp (JSFunction Nothing valNames (JSBlock (concat jss ++ [JSThrow (JSStringLiteral "Failed pattern match")])))

279 return $ JSApp (JSFunction Nothing valNames (JSBlock (concat jss ++ [JSThrow (JSStringLiteral "Failed pattern match")])))

259 vals

280 vals

260 where

281 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]

264 go _ done [] Nothing = return done

283 go _ done [] Nothing = return done

284+ go _ done [] (Just cond) = do

265− go _ done [] (Just cond) = return [JSIfElse (valueToJs opts m e cond) (JSBlock done) Nothing]

285+ cond' <- valueToJs opts m e cond

286+ return [JSIfElse cond' (JSBlock done) Nothing]

266 go (v:vs) done' (b:bs) grd = do

287 go (v:vs) done' (b:bs) grd = do

267 done'' <- go vs done' bs grd

288 done'' <- go vs done' bs grd

268 binderToJs m e v done'' b

289 binderToJs m e v done'' b

269 go _ _ _ _ = error "Invalid arguments to bindersToJs"

290 go _ _ _ _ = error "Invalid arguments to bindersToJs"

270

291

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−

285-- |

292-- |

286-- Generate code in the simplified Javascript intermediate representation for a pattern match

293-- Generate code in the simplified Javascript intermediate representation for a pattern match

287-- binder.

294-- binder.

288--

295--

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]

290binderToJs _ _ _ done NullBinder = return done

297binderToJs _ _ _ done NullBinder = return done

291binderToJs _ _ varName done (StringBinder str) =

298binderToJs _ _ varName done (StringBinder str) =

292 return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSStringLiteral str)) (JSBlock done) Nothing]

299 return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSStringLiteral str)) (JSBlock done) Nothing]

@@ -308,19 +315,19 @@ binderToJs m e varName done (ConstructorBinder ctor bs) = do

308 (JSBlock js)

315 (JSBlock js)

309 Nothing]

316 Nothing]

310 where

317 where

311− go :: Integer -> [JS] -> [Binder] -> Gen [JS]

318+ go :: (Functor m, Applicative m, Monad m) => Integer -> [JS] -> [Binder] -> SupplyT m [JS]

312 go _ done' [] = return done'

319 go _ done' [] = return done'

313 go index done' (binder:bs') = do

320 go index done' (binder:bs') = do

314− argVar <- fresh

321+ argVar <- freshName

315 done'' <- go (index + 1) done' bs'

322 done'' <- go (index + 1) done' bs'

316 js <- binderToJs m e argVar done'' binder

323 js <- binderToJs m e argVar done'' binder

317 return (JSVariableIntroduction argVar (Just (JSIndexer (JSNumericLiteral (Left index)) (JSAccessor "values" (JSVar varName)))) : js)

324 return (JSVariableIntroduction argVar (Just (JSIndexer (JSNumericLiteral (Left index)) (JSAccessor "values" (JSVar varName)))) : js)

318binderToJs m e varName done (ObjectBinder bs) = go done bs

325binderToJs m e varName done (ObjectBinder bs) = go done bs

319 where

326 where

320− go :: [JS] -> [(String, Binder)] -> Gen [JS]

327+ go :: (Functor m, Applicative m, Monad m) => [JS] -> [(String, Binder)] -> SupplyT m [JS]

321 go done' [] = return done'

328 go done' [] = return done'

322 go done' ((prop, binder):bs') = do

329 go done' ((prop, binder):bs') = do

323− propVar <- fresh

330+ propVar <- freshName

324 done'' <- go done' bs'

331 done'' <- go done' bs'

325 js <- binderToJs m e propVar done'' binder

332 js <- binderToJs m e propVar done'' binder

326 return (JSVariableIntroduction propVar (Just (accessorString prop (JSVar varName))) : js)

333 return (JSVariableIntroduction propVar (Just (accessorString prop (JSVar varName))) : js)

@@ -328,16 +335,16 @@ binderToJs m e varName done (ArrayBinder bs) = do

328 js <- go done 0 bs

335 js <- go done 0 bs

329 return [JSIfElse (JSBinary EqualTo (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (Left (fromIntegral $ length bs)))) (JSBlock js) Nothing]

336 return [JSIfElse (JSBinary EqualTo (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (Left (fromIntegral $ length bs)))) (JSBlock js) Nothing]

330 where

337 where

331− go :: [JS] -> Integer -> [Binder] -> Gen [JS]

338+ go :: (Functor m, Applicative m, Monad m) => [JS] -> Integer -> [Binder] -> SupplyT m [JS]

332 go done' _ [] = return done'

339 go done' _ [] = return done'

333 go done' index (binder:bs') = do

340 go done' index (binder:bs') = do

334− elVar <- fresh

341+ elVar <- freshName

335 done'' <- go done' (index + 1) bs'

342 done'' <- go done' (index + 1) bs'

336 js <- binderToJs m e elVar done'' binder

343 js <- binderToJs m e elVar done'' binder

337 return (JSVariableIntroduction elVar (Just (JSIndexer (JSNumericLiteral (Left index)) (JSVar varName))) : js)

344 return (JSVariableIntroduction elVar (Just (JSIndexer (JSNumericLiteral (Left index)) (JSVar varName))) : js)

338binderToJs m e varName done (ConsBinder headBinder tailBinder) = do

345binderToJs m e varName done (ConsBinder headBinder tailBinder) = do

339− headVar <- fresh

346+ headVar <- freshName

340− tailVar <- fresh

347+ tailVar <- freshName

341 js1 <- binderToJs m e headVar done headBinder

348 js1 <- binderToJs m e headVar done headBinder

342 js2 <- binderToJs m e tailVar js1 tailBinder

349 js2 <- binderToJs m e tailVar js1 tailBinder

343 return [JSIfElse (JSBinary GreaterThan (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (Left 0))) (JSBlock

350 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 @@

16module Language.PureScript.Sugar (desugar, module S) where

18import Control.Monad

19+import Control.Category ((>>>))

20+import Control.Monad.Trans.Class

20import Language.PureScript.Declarations

22import Language.PureScript.Declarations

21import Language.PureScript.Errors

23import Language.PureScript.Errors

24+import Language.PureScript.Supply

23import Language.PureScript.Sugar.Operators as S

26import Language.PureScript.Sugar.Operators as S

24import Language.PureScript.Sugar.DoNotation as S

27import Language.PureScript.Sugar.DoNotation as S

@@ -28,8 +31,6 @@ import Language.PureScript.Sugar.BindingGroups as S

28import Language.PureScript.Sugar.TypeClasses as S

31import Language.PureScript.Sugar.TypeClasses as S

29import Language.PureScript.Sugar.Names as S

32import Language.PureScript.Sugar.Names as S

31−import Control.Category ((>>>))

32−

33-- |

34-- |

34-- The desugaring pipeline proceeds as follows:

35-- The desugaring pipeline proceeds as follows:

35--

36--

@@ -47,12 +48,12 @@ import Control.Category ((>>>))

47--

48--

48-- * Qualify any unqualified names and types

49-- * Qualify any unqualified names and types

49--

50--

50−desugar :: [Module] -> Either ErrorStack [Module]

51+desugar :: [Module] -> SupplyT (Either ErrorStack) [Module]

51desugar = map removeSignedLiterals

52desugar = map removeSignedLiterals

52 >>> mapM desugarDoModule

53 >>> mapM desugarDoModule

53 >=> desugarCasesModule

54 >=> desugarCasesModule

54− >=> desugarTypeDeclarationsModule

55+ >=> lift . (desugarTypeDeclarationsModule

55− >=> desugarImports

56+ >=> desugarImports

56− >=> rebracket

57+ >=> rebracket)

57 >=> desugarTypeClasses

58 >=> desugarTypeClasses

58− >=> createBindingGroupsModule

59+ >=> lift . createBindingGroupsModule

src/Language/PureScript/Sugar/CaseDeclarations.hs+22−25

@@ -23,43 +23,41 @@ import Data.Monoid ((<>))

23import Data.List (groupBy)

25import Control.Applicative

26−import Control.Monad ((<=<), forM, join, unless)

26+import Control.Monad ((<=<), forM, join, unless, replicateM)

27import Control.Monad.Error.Class

29import Language.PureScript.Names

30import Language.PureScript.Declarations

31−import Language.PureScript.Scope

32import Language.PureScript.Environment

31import Language.PureScript.Environment

33import Language.PureScript.Errors

32import Language.PureScript.Errors

33+import Language.PureScript.Supply

35-- |

36-- Replace all top-level binders in a module with case expressions.

37--

38−desugarCasesModule :: [Module] -> Either ErrorStack [Module]

38+desugarCasesModule :: [Module] -> SupplyT (Either ErrorStack) [Module]

39desugarCasesModule ms = forM ms $ \(Module name ds exps) ->

40 rethrow (strMsg ("Error in module " ++ show name) <>) $

41− Module name <$> (desugarCases . desugarAbs $ ds) <*> pure exps

41+ Module name <$> (desugarCases <=< desugarAbs $ ds) <*> pure exps

43−desugarAbs :: [Declaration] -> [Declaration]

43+desugarAbs :: [Declaration] -> SupplyT (Either ErrorStack) [Declaration]

44−desugarAbs = map f

44+desugarAbs = mapM f

45 where

46− (f, _, _) = everywhereOnValues id replace id

46+ (f, _, _) = everywhereOnValuesM return replace return

48+ replace :: Value -> SupplyT (Either ErrorStack) Value

48− replace (Abs (Right binder) val) =

49+ replace (Abs (Right binder) val) = do

49− let

50+ ident <- Ident <$> freshName

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]

51+ return $ Abs (Left ident) $ Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] Nothing val]

54− replace other = other

52+ replace other = return other

56-- |

54-- |

57-- Replace all top-level binders with case expressions.

55-- Replace all top-level binders with case expressions.

58--

56--

59−desugarCases :: [Declaration] -> Either ErrorStack [Declaration]

57+desugarCases :: [Declaration] -> SupplyT (Either ErrorStack) [Declaration]

60desugarCases = desugarRest <=< fmap join . mapM toDecls . groupBy inSameGroup

58desugarCases = desugarRest <=< fmap join . mapM toDecls . groupBy inSameGroup

61 where

59 where

62− desugarRest :: [Declaration] -> Either ErrorStack [Declaration]

60+ desugarRest :: [Declaration] -> SupplyT (Either ErrorStack) [Declaration]

63 desugarRest (TypeInstanceDeclaration name constraints className tys ds : rest) =

61 desugarRest (TypeInstanceDeclaration name constraints className tys ds : rest) =

64 (:) <$> (TypeInstanceDeclaration name constraints className tys <$> desugarCases ds) <*> desugarRest rest

62 (:) <$> (TypeInstanceDeclaration name constraints className tys <$> desugarCases ds) <*> desugarRest rest

65 desugarRest (ValueDeclaration name nameKind bs g val : rest) =

63 desugarRest (ValueDeclaration name nameKind bs g val : rest) =

@@ -80,7 +78,7 @@ inSameGroup (PositionedDeclaration _ d1) d2 = inSameGroup d1 d2

80inSameGroup d1 (PositionedDeclaration _ d2) = inSameGroup d1 d2

78inSameGroup d1 (PositionedDeclaration _ d2) = inSameGroup d1 d2

81inSameGroup _ _ = False

79inSameGroup _ _ = False

83−toDecls :: [Declaration] -> Either ErrorStack [Declaration]

81+toDecls :: [Declaration] -> SupplyT (Either ErrorStack) [Declaration]

84toDecls [ValueDeclaration ident nameKind bs Nothing val] | all isVarBinder bs = do

82toDecls [ValueDeclaration ident nameKind bs Nothing val] | all isVarBinder bs = do

85 let args = map (\(VarBinder arg) -> arg) bs

83 let args = map (\(VarBinder arg) -> arg) bs

86 body = foldr (Abs . Left) val args

84 body = foldr (Abs . Left) val args

@@ -89,7 +87,8 @@ toDecls ds@(ValueDeclaration ident _ bs _ _ : _) = do

89 let tuples = map toTuple ds

87 let tuples = map toTuple ds

90 unless (all ((== length bs) . length . fst) tuples) $

88 unless (all ((== length bs) . length . fst) tuples) $

91 throwError $ mkErrorStack ("Argument list lengths differ in declaration " ++ show ident) Nothing

89 throwError $ mkErrorStack ("Argument list lengths differ in declaration " ++ show ident) Nothing

92− return [makeCaseDeclaration ident tuples]

90+ caseDecl <- makeCaseDeclaration ident tuples

91+ return [caseDecl]

93toDecls (PositionedDeclaration pos d : ds) = do

92toDecls (PositionedDeclaration pos d : ds) = do

94 (d' : ds') <- rethrowWithPosition pos $ toDecls (d : ds)

93 (d' : ds') <- rethrowWithPosition pos $ toDecls (d : ds)

95 return (PositionedDeclaration pos d' : ds')

94 return (PositionedDeclaration pos d' : ds')

@@ -104,15 +103,13 @@ toTuple (ValueDeclaration _ _ bs g val) = (bs, (g, val))

104toTuple (PositionedDeclaration _ d) = toTuple d

103toTuple (PositionedDeclaration _ d) = toTuple d

105toTuple _ = error "Not a value declaration"

104toTuple _ = error "Not a value declaration"

106

105

107−makeCaseDeclaration :: Ident -> [([Binder], (Maybe Guard, Value))] -> Declaration

106+makeCaseDeclaration :: Ident -> [([Binder], (Maybe Guard, Value))] -> SupplyT (Either ErrorStack) Declaration

108−makeCaseDeclaration ident alternatives =

107+makeCaseDeclaration ident alternatives = do

108+ let argPattern = length . fst . head $ alternatives

109+ args <- map Ident <$> replicateM argPattern freshName

109 let

110 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

113 vars = map (Var . Qualified Nothing) args

111 vars = map (Var . Qualified Nothing) args

114 binders = [ CaseAlternative bs g val | (bs, (g, val)) <- alternatives ]

112 binders = [ CaseAlternative bs g val | (bs, (g, val)) <- alternatives ]

115 value = foldr (Abs . Left) (Case vars binders) args

113 value = foldr (Abs . Left) (Case vars binders) args

116− in

117− ValueDeclaration ident Value [] Nothing value

114+ return $ ValueDeclaration ident Value [] Nothing value

118

115

src/Language/PureScript/Sugar/DoNotation.hs+9−9

@@ -19,22 +19,23 @@ module Language.PureScript.Sugar.DoNotation (

19) where

21import Language.PureScript.Names

22−import Language.PureScript.Scope

23import Language.PureScript.Declarations

22import Language.PureScript.Declarations

24import Language.PureScript.Errors

23import Language.PureScript.Errors

24+import Language.PureScript.Supply

26import qualified Language.PureScript.Constants as C

28import Control.Applicative

29+import Control.Monad.Trans.Class

30-- |

31-- |

31-- Replace all @DoNotationBind@ and @DoNotationValue@ constructors with applications of the Prelude.(>>=) function,

32-- Replace all @DoNotationBind@ and @DoNotationValue@ constructors with applications of the Prelude.(>>=) function,

32-- and all @DoNotationLet@ constructors with let expressions.

33-- and all @DoNotationLet@ constructors with let expressions.

33--

34--

34−desugarDoModule :: Module -> Either ErrorStack Module

35+desugarDoModule :: Module -> SupplyT (Either ErrorStack) Module

35desugarDoModule (Module mn ds exts) = Module mn <$> mapM desugarDo ds <*> pure exts

36desugarDoModule (Module mn ds exts) = Module mn <$> mapM desugarDo ds <*> pure exts

37−desugarDo :: Declaration -> Either ErrorStack Declaration

38+desugarDo :: Declaration -> SupplyT (Either ErrorStack) Declaration

38desugarDo (PositionedDeclaration pos d) = (PositionedDeclaration pos) <$> (rethrowWithPosition pos $ desugarDo d)

39desugarDo (PositionedDeclaration pos d) = (PositionedDeclaration pos) <$> (rethrowWithPosition pos $ desugarDo d)

39desugarDo d =

40desugarDo d =

40 let (f, _, _) = everywhereOnValuesM return replace return

41 let (f, _, _) = everywhereOnValuesM return replace return

@@ -46,28 +47,27 @@ desugarDo d =

46 bind :: Value

47 bind :: Value

47 bind = Var (Qualified (Just prelude) (Op (C.>>=)))

48 bind = Var (Qualified (Just prelude) (Op (C.>>=)))

49− replace :: Value -> Either ErrorStack Value

50+ replace :: Value -> SupplyT (Either ErrorStack) Value

50 replace (Do els) = go els

51 replace (Do els) = go els

51 replace (PositionedValue pos v) = PositionedValue pos <$> rethrowWithPosition pos (replace v)

52 replace (PositionedValue pos v) = PositionedValue pos <$> rethrowWithPosition pos (replace v)

52 replace other = return other

53 replace other = return other

54− go :: [DoNotationElement] -> Either ErrorStack Value

55+ go :: [DoNotationElement] -> SupplyT (Either ErrorStack) Value

55 go [] = error "The impossible happened in desugarDo"

56 go [] = error "The impossible happened in desugarDo"

56 go [DoNotationValue val] = return val

57 go [DoNotationValue val] = return val

57 go (DoNotationValue val : rest) = do

58 go (DoNotationValue val : rest) = do

58 rest' <- go rest

59 rest' <- go rest

59 return $ App (App bind val) (Abs (Left (Ident "_")) rest')

60 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

61 go (DoNotationBind NullBinder val : rest) = go (DoNotationValue val : rest)

62 go (DoNotationBind NullBinder val : rest) = go (DoNotationValue val : rest)

62 go (DoNotationBind (VarBinder ident) val : rest) = do

63 go (DoNotationBind (VarBinder ident) val : rest) = do

63 rest' <- go rest

64 rest' <- go rest

64 return $ App (App bind val) (Abs (Left ident) rest')

65 return $ App (App bind val) (Abs (Left ident) rest')

65 go (DoNotationBind binder val : rest) = do

66 go (DoNotationBind binder val : rest) = do

66 rest' <- go rest

67 rest' <- go rest

67− let used = concatMap usedNamesDoNotationElement rest

68+ ident <- Ident <$> freshName

68− ident = head $ unusedNames used

69 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

71 go (DoNotationLet ds : rest) = do

72 rest' <- go rest

73 return $ Let ds rest'

src/Language/PureScript/Sugar/TypeClasses.hs+5−4

@@ -24,6 +24,7 @@ import Language.PureScript.Types

24import Language.PureScript.Sugar.CaseDeclarations

25import Language.PureScript.Environment

26import Language.PureScript.Errors

27+import Language.PureScript.Supply

27import Language.PureScript.Pretty.Types (prettyPrintTypeAtom)

28import Language.PureScript.Pretty.Types (prettyPrintTypeAtom)

29import qualified Language.PureScript.Constants as C

30import qualified Language.PureScript.Constants as C

@@ -40,13 +41,13 @@ import qualified Data.Map as M

41type MemberMap = M.Map (ModuleName, ProperName) Declaration

42type MemberMap = M.Map (ModuleName, ProperName) Declaration

43−type Desugar = StateT MemberMap (Either ErrorStack)

44+type Desugar = StateT MemberMap (SupplyT (Either ErrorStack))

45-- |

46-- |

46-- Add type synonym declarations for type class dictionary types, and value declarations for type class

47-- Add type synonym declarations for type class dictionary types, and value declarations for type class

47-- instance dictionary expressions.

48-- instance dictionary expressions.

48--

49--

49−desugarTypeClasses :: [Module] -> Either ErrorStack [Module]

50+desugarTypeClasses :: [Module] -> SupplyT (Either ErrorStack) [Module]

50desugarTypeClasses = flip evalStateT M.empty . mapM desugarModule

51desugarTypeClasses = flip evalStateT M.empty . mapM desugarModule

52desugarModule :: Module -> Desugar Module

53desugarModule :: Module -> Desugar Module

@@ -160,7 +161,7 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =

160 m <- get

161 m <- get

161

162

162 -- Lookup the type arguments and member types for the type class

163 -- Lookup the type arguments and member types for the type class

163− (TypeClassDeclaration _ args implies tyDecls) <- lift $

164+ (TypeClassDeclaration _ args implies tyDecls) <- lift . lift $

164 maybe (Left $ mkErrorStack ("Type class " ++ show className ++ " is undefined") Nothing) Right $

165 maybe (Left $ mkErrorStack ("Type class " ++ show className ++ " is undefined") Nothing) Right $

165 M.lookup (qualify mn className) m

166 M.lookup (qualify mn className) m

166

167

@@ -203,7 +204,7 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =

203

204

204 memberToNameAndValue :: [(Ident, Type)] -> Declaration -> Desugar (Ident, Value)

205 memberToNameAndValue :: [(Ident, Type)] -> Declaration -> Desugar (Ident, Value)

205 memberToNameAndValue tys' d@(ValueDeclaration ident _ _ _ _) = do

206 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'

207 let memberValue = typeInstanceDictionaryEntryValue d

208 let memberValue = typeInstanceDictionaryEntryValue d

208 return (ident, memberValue)

209 return (ident, memberValue)

209 memberToNameAndValue tys' (PositionedDeclaration pos d) = rethrowWithPosition pos $ do

210 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)