ce67c05 · rowtype-yoga/purescript-native

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

on golang help sign in

Use MonadSupply in code gen

ce67c05Phil Freeman12 years ago

src/Control/Monad/Supply.hs+5−6

compare with golang

unifiedsplit

@@ -25,8 +25,11 @@ import Data.Functor.Identity

25import Control.Applicative

26import Control.Monad.State

27import Control.Monad.Except

28+import Control.Monad.Reader

29+import Control.Monad.Writer

29−newtype SupplyT m a = SupplyT { unSupplyT :: StateT Integer m a } deriving (Functor, Applicative, Monad, MonadTrans)

31+newtype SupplyT m a = SupplyT { unSupplyT :: StateT Integer m a }

32+ deriving (Functor, Applicative, Monad, MonadTrans, MonadError e, MonadWriter w, MonadReader r)

31runSupplyT :: Integer -> SupplyT m a -> m (a, Integer)

34runSupplyT :: Integer -> SupplyT m a -> m (a, Integer)

32runSupplyT n = flip runStateT n . unSupplyT

35runSupplyT n = flip runStateT n . unSupplyT

@@ -40,8 +43,4 @@ runSupply :: Integer -> Supply a -> (a, Integer)

40runSupply n = runIdentity . runSupplyT n

43runSupply n = runIdentity . runSupplyT n

42evalSupply :: Integer -> Supply a -> a

45evalSupply :: Integer -> Supply a -> a

43−evalSupply n = runIdentity . evalSupplyT n

46+evalSupply n = runIdentity . evalSupplyT n

44−

45−instance (MonadError e m) => MonadError e (SupplyT m) where

46− throwError = SupplyT . throwError

47− catchError e f = SupplyT $ catchError (unSupplyT e) (unSupplyT . f)

src/Language/PureScript.hs+18−7

@@ -13,9 +13,21 @@

13--

14-----------------------------------------------------------------------------

16−{-# LANGUAGE DataKinds, QuasiQuotes, TemplateHaskell, FlexibleContexts #-}

16+{-# LANGUAGE DataKinds #-}

17−

17+{-# LANGUAGE QuasiQuotes #-}

18+{-# LANGUAGE TemplateHaskell #-}

19+{-# LANGUAGE FlexibleContexts #-}

20+{-# LANGUAGE ScopedTypeVariables #-}

21+

18−module Language.PureScript (module P, compile, compile', RebuildPolicy(..), MonadMake(..), make, prelude) where

22+module Language.PureScript

23+ ( module P

24+ , compile

25+ , compile'

26+ , RebuildPolicy(..)

27+ , MonadMake(..)

28+ , make

29+ , prelude

30+ ) where

20import Data.FileEmbed (embedFile)

32import Data.FileEmbed (embedFile)

21import Data.Function (on)

33import Data.Function (on)

@@ -154,7 +166,7 @@ traverseEither f (Right y) = Right <$> f y

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

155-- having to typecheck the module again.

167-- having to typecheck the module again.

156--

168--

157−make :: (Functor m, Applicative m, Monad m, MonadMake m)

169+make :: forall m. (Functor m, Applicative m, Monad m, MonadMake m)

158 => FilePath -> [(Either RebuildPolicy FilePath, Module)] -> [String] -> m Environment

170 => FilePath -> [(Either RebuildPolicy FilePath, Module)] -> [String] -> m Environment

159make outputDir ms prefix = do

171make outputDir ms prefix = do

160 noPrelude <- asks optionsNoPrelude

172 noPrelude <- asks optionsNoPrelude

@@ -185,8 +197,7 @@ make outputDir ms prefix = do

185 evalSupplyT nextVar $ go initEnvironment desugared

197 evalSupplyT nextVar $ go initEnvironment desugared

186

198

187 where

199 where

188− go :: (Functor m, Applicative m, Monad m, MonadMake m)

189− => Environment -> [(Bool, Module)] -> SupplyT m Environment

200+ go :: Environment -> [(Bool, Module)] -> SupplyT m Environment

190 go env [] = return env

201 go env [] = return env

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

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

192 (_, env') <- lift . runCheck' env $ typeCheckModule Nothing m

203 (_, env') <- lift . runCheck' env $ typeCheckModule Nothing m

@@ -216,7 +227,7 @@ make outputDir ms prefix = do

216

227

217 go env' ms'

228 go env' ms'

218

229

219− rebuildIfNecessary :: (Functor m, Monad m, MonadMake m) => M.Map ModuleName [ModuleName] -> S.Set ModuleName -> [Module] -> m [(Bool, Module)]

230+ rebuildIfNecessary :: M.Map ModuleName [ModuleName] -> S.Set ModuleName -> [Module] -> m [(Bool, Module)]

220 rebuildIfNecessary _ _ [] = return []

231 rebuildIfNecessary _ _ [] = return []

221 rebuildIfNecessary graph toRebuild (m@(Module moduleName' _ _) : ms') | moduleName' `S.member` toRebuild = do

232 rebuildIfNecessary graph toRebuild (m@(Module moduleName' _ _) : ms') | moduleName' `S.member` toRebuild = do

222 let deps = fromMaybe [] $ moduleName' `M.lookup` graph

233 let deps = fromMaybe [] $ moduleName' `M.lookup` graph

src/Language/PureScript/CodeGen/JS.hs+32−34

@@ -13,7 +13,10 @@

13--

14-----------------------------------------------------------------------------

16+{-# LANGUAGE GADTs #-}

17+{-# LANGUAGE ViewPatterns #-}

16−{-# LANGUAGE GADTs, ViewPatterns, FlexibleContexts #-}

18+{-# LANGUAGE FlexibleContexts #-}

19+{-# LANGUAGE ScopedTypeVariables #-}

18module Language.PureScript.CodeGen.JS (

21module Language.PureScript.CodeGen.JS (

19 module AST,

22 module AST,

@@ -28,8 +31,7 @@ import qualified Data.Traversable as T (traverse)

28import Control.Applicative

31import Control.Applicative

29import Control.Arrow ((&&&))

32import Control.Arrow ((&&&))

30import Control.Monad (foldM, replicateM, forM)

33import Control.Monad (foldM, replicateM, forM)

31−import Control.Monad.Reader (MonadReader, asks, lift)

34+import Control.Monad.Reader (MonadReader, asks)

32−import Control.Monad.Supply

33import Control.Monad.Supply.Class

35import Control.Monad.Supply.Class

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

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

@@ -45,14 +47,14 @@ import qualified Language.PureScript.Constants as C

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

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

46-- module.

48-- module.

47--

49--

48−moduleToJs :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)

50+moduleToJs :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m, MonadSupply m)

49− => Module Ann -> SupplyT m [JS]

51+ => Module Ann -> m [JS]

50moduleToJs (Module name imps exps foreigns decls) = do

52moduleToJs (Module name imps exps foreigns decls) = do

51− additional <- lift $ asks optionsAdditional

53+ additional <- asks optionsAdditional

52− jsImports <- lift . T.traverse importToJs . delete (ModuleName [ProperName C.prim]) . (\\ [name]) $ imps

54+ jsImports <- T.traverse importToJs . delete (ModuleName [ProperName C.prim]) . (\\ [name]) $ imps

53 let foreigns' = mapMaybe (\(_, js, _) -> js) foreigns

55 let foreigns' = mapMaybe (\(_, js, _) -> js) foreigns

54 jsDecls <- mapM (bindToJs name) decls

56 jsDecls <- mapM (bindToJs name) decls

55− optimized <- lift $ T.traverse (T.traverse optimize) jsDecls

57+ optimized <- T.traverse (T.traverse optimize) jsDecls

56 let isModuleEmpty = null exps

58 let isModuleEmpty = null exps

57 let moduleBody = JSStringLiteral "use strict" : jsImports ++ foreigns' ++ concat optimized

59 let moduleBody = JSStringLiteral "use strict" : jsImports ++ foreigns' ++ concat optimized

58 let exps' = JSObjectLiteral $ map (runIdent &&& JSVar . identToJs) exps

60 let exps' = JSObjectLiteral $ map (runIdent &&& JSVar . identToJs) exps

@@ -80,8 +82,8 @@ importToJs mn = do

80-- |

82-- |

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

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

82--

84--

83−bindToJs :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)

85+bindToJs :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m, MonadSupply m)

84− => ModuleName -> Bind Ann -> SupplyT m [JS]

86+ => ModuleName -> Bind Ann -> m [JS]

85bindToJs mp (NonRec ident val) = return <$> nonRecToJS mp ident val

87bindToJs mp (NonRec ident val) = return <$> nonRecToJS mp ident val

86bindToJs mp (Rec vals) = forM vals (uncurry (nonRecToJS mp))

88bindToJs mp (Rec vals) = forM vals (uncurry (nonRecToJS mp))

@@ -91,10 +93,10 @@ bindToJs mp (Rec vals) = forM vals (uncurry (nonRecToJS mp))

91--

93--

92-- The main purpose of this function is to handle code generation for comments.

94-- The main purpose of this function is to handle code generation for comments.

93--

95--

94−nonRecToJS :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)

96+nonRecToJS :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m, MonadSupply m)

95− => ModuleName -> Ident -> Expr Ann -> SupplyT m JS

97+ => ModuleName -> Ident -> Expr Ann -> m JS

96nonRecToJS m i e@(extractAnn -> (_, com, _, _)) | not (null com) = do

98nonRecToJS m i e@(extractAnn -> (_, com, _, _)) | not (null com) = do

97− withoutComment <- lift $ asks optionsNoComments

99+ withoutComment <- asks optionsNoComments

98 if withoutComment

100 if withoutComment

99 then nonRecToJS m i (modifyAnn removeComments e)

101 then nonRecToJS m i (modifyAnn removeComments e)

100 else JSComment com <$> nonRecToJS m i (modifyAnn removeComments e)

102 else JSComment com <$> nonRecToJS m i (modifyAnn removeComments e)

@@ -126,8 +128,8 @@ accessorString prop | identNeedsEscaping prop = JSIndexer (JSStringLiteral prop)

126-- |

128-- |

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

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

128--

130--

129−valueToJs :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)

131+valueToJs :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m, MonadSupply m)

130− => ModuleName -> Expr Ann -> SupplyT m JS

132+ => ModuleName -> Expr Ann -> m JS

131valueToJs m (Literal _ l) =

133valueToJs m (Literal _ l) =

132 literalToValueJS m l

134 literalToValueJS m l

133valueToJs m (Var (_, _, _, Just (IsConstructor _ [])) name) =

135valueToJs m (Var (_, _, _, Just (IsConstructor _ [])) name) =

@@ -195,11 +197,12 @@ valueToJs _ (Constructor _ _ (ProperName ctor) fields) =

195 in return $ iife ctor [ constructor

197 in return $ iife ctor [ constructor

196 , JSAssignment (JSAccessor "create" (JSVar ctor)) createFn

198 , JSAssignment (JSAccessor "create" (JSVar ctor)) createFn

197 ]

199 ]

200+

198iife :: String -> [JS] -> JS

201iife :: String -> [JS] -> JS

199iife v exprs = JSApp (JSFunction Nothing [] (JSBlock $ exprs ++ [JSReturn $ JSVar v])) []

202iife v exprs = JSApp (JSFunction Nothing [] (JSBlock $ exprs ++ [JSReturn $ JSVar v])) []

200

203

201−literalToValueJS :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)

204+literalToValueJS :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m, MonadSupply m)

202− => ModuleName -> Literal (Expr Ann) -> SupplyT m JS

205+ => ModuleName -> Literal (Expr Ann) -> m JS

203literalToValueJS _ (NumericLiteral n) = return $ JSNumericLiteral n

206literalToValueJS _ (NumericLiteral n) = return $ JSNumericLiteral n

204literalToValueJS _ (StringLiteral s) = return $ JSStringLiteral s

207literalToValueJS _ (StringLiteral s) = return $ JSStringLiteral s

205literalToValueJS _ (BooleanLiteral b) = return $ JSBooleanLiteral b

208literalToValueJS _ (BooleanLiteral b) = return $ JSBooleanLiteral b

@@ -209,7 +212,7 @@ literalToValueJS m (ObjectLiteral ps) = JSObjectLiteral <$> mapM (sndM (valueToJ

209-- |

212-- |

210-- Shallow copy an object.

213-- Shallow copy an object.

211--

214--

212−extendObj :: (Functor m, Applicative m, Monad m) => JS -> [(String, JS)] -> SupplyT m JS

215+extendObj :: (Applicative m, Monad m, MonadSupply m) => JS -> [(String, JS)] -> m JS

213extendObj obj sts = do

216extendObj obj sts = do

214 newObj <- freshName

217 newObj <- freshName

215 key <- freshName

218 key <- freshName

@@ -246,8 +249,8 @@ qualifiedToJS _ f (Qualified _ a) = JSVar $ identToJs (f a)

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

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

247-- and guards.

250-- and guards.

248--

251--

249−bindersToJs :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)

252+bindersToJs :: forall m mode. (Functor m, Applicative m, Monad m, MonadReader (Options mode) m, MonadSupply m)

250− => ModuleName -> [CaseAlternative Ann] -> [JS] -> SupplyT m JS

253+ => ModuleName -> [CaseAlternative Ann] -> [JS] -> m JS

251bindersToJs m binders vals = do

254bindersToJs m binders vals = do

252 valNames <- replicateM (length vals) freshName

255 valNames <- replicateM (length vals) freshName

253 let assignments = zipWith JSVariableIntroduction valNames (map Just vals)

256 let assignments = zipWith JSVariableIntroduction valNames (map Just vals)

@@ -257,16 +260,14 @@ bindersToJs m binders vals = do

257 return $ JSApp (JSFunction Nothing [] (JSBlock (assignments ++ concat jss ++ [JSThrow $ JSUnary JSNew $ JSApp (JSVar "Error") [JSStringLiteral "Failed pattern match"]])))

260 return $ JSApp (JSFunction Nothing [] (JSBlock (assignments ++ concat jss ++ [JSThrow $ JSUnary JSNew $ JSApp (JSVar "Error") [JSStringLiteral "Failed pattern match"]])))

258 []

261 []

259 where

262 where

260− go :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)

261− => [String] -> [JS] -> [Binder Ann] -> SupplyT m [JS]

263+ go :: [String] -> [JS] -> [Binder Ann] -> m [JS]

262 go _ done [] = return done

264 go _ done [] = return done

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

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

264 done'' <- go vs done' bs

266 done'' <- go vs done' bs

265 binderToJs m v done'' b

267 binderToJs m v done'' b

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

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

267

269

268− guardsToJs :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)

269− => Either [(Guard Ann, Expr Ann)] (Expr Ann) -> SupplyT m [JS]

270+ guardsToJs :: Either [(Guard Ann, Expr Ann)] (Expr Ann) -> m [JS]

270 guardsToJs (Left gs) = forM gs $ \(cond, val) -> do

271 guardsToJs (Left gs) = forM gs $ \(cond, val) -> do

271 cond' <- valueToJs m cond

272 cond' <- valueToJs m cond

272 done <- valueToJs m val

273 done <- valueToJs m val

@@ -277,8 +278,8 @@ bindersToJs m binders vals = do

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

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

278-- binder.

279-- binder.

279--

280--

280−binderToJs :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)

281+binderToJs :: forall m mode. (Functor m, Applicative m, Monad m, MonadReader (Options mode) m, MonadSupply m)

281− => ModuleName -> String -> [JS] -> Binder Ann -> SupplyT m [JS]

282+ => ModuleName -> String -> [JS] -> Binder Ann -> m [JS]

282binderToJs _ _ done (NullBinder{}) = return done

283binderToJs _ _ done (NullBinder{}) = return done

283binderToJs m varName done (LiteralBinder _ l) =

284binderToJs m varName done (LiteralBinder _ l) =

284 literalToBinderJS m varName done l

285 literalToBinderJS m varName done l

@@ -295,8 +296,7 @@ binderToJs m varName done (ConstructorBinder (_, _, _, Just (IsConstructor ctorT

295 (JSBlock js)

296 (JSBlock js)

296 Nothing]

297 Nothing]

297 where

298 where

298− go :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)

299− => [(Ident, Binder Ann)] -> [JS] -> SupplyT m [JS]

299+ go :: [(Ident, Binder Ann)] -> [JS] -> m [JS]

300 go [] done' = return done'

301 go ((field, binder) : remain) done' = do

302 argVar <- freshName

@@ -326,8 +326,8 @@ binderToJs m varName done (NamedBinder _ ident binder) = do

326 js <- binderToJs m varName done binder

327 return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : js)

328

329−literalToBinderJS :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)

329+literalToBinderJS :: forall m mode. (Functor m, Applicative m, Monad m, MonadReader (Options mode) m, MonadSupply m)

330− => ModuleName -> String -> [JS] -> Literal (Binder Ann) -> SupplyT m [JS]

330+ => ModuleName -> String -> [JS] -> Literal (Binder Ann) -> m [JS]

331literalToBinderJS _ varName done (NumericLiteral num) =

332 return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSNumericLiteral num)) (JSBlock done) Nothing]

333literalToBinderJS _ varName done (StringLiteral str) =

@@ -338,8 +338,7 @@ literalToBinderJS _ varName done (BooleanLiteral False) =

338 return [JSIfElse (JSUnary Not (JSVar varName)) (JSBlock done) Nothing]

339literalToBinderJS m varName done (ObjectLiteral bs) = go done bs

340 where

341− go :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)

342− => [JS] -> [(String, Binder Ann)] -> SupplyT m [JS]

341+ go :: [JS] -> [(String, Binder Ann)] -> m [JS]

343 go done' [] = return done'

342 go done' [] = return done'

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

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

345 propVar <- freshName

344 propVar <- freshName

@@ -350,8 +349,7 @@ literalToBinderJS m varName done (ArrayLiteral bs) = do

350 js <- go done 0 bs

349 js <- go done 0 bs

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

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

352 where

351 where

353− go :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)

354− => [JS] -> Integer -> [Binder Ann] -> SupplyT m [JS]

352+ go :: [JS] -> Integer -> [Binder Ann] -> m [JS]

355 go done' _ [] = return done'

353 go done' _ [] = return done'

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

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

357 elVar <- freshName

355 elVar <- freshName