ce67c05 · rowtype-yoga/purescript-native

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

Use MonadSupply in code gen

commitce67c05b850c8d3e940f789fff4cd0271551f86f authorPhil Freeman <paf31@cantab.net> dateFri 20 Feb 2015, 21:38 (12 years ago) parentc6e0ff3

3 files changed+55−47

compare with golang

unifiedsplit

src/Control/Monad/Supply.hs+5−6 src/Language/PureScript.hs+18−7 src/Language/PureScript/CodeGen/JS.hs+32−34

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

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

2525import Control.Applicative

2626import Control.Monad.State

2727import Control.Monad.Except

28+import Control.Monad.Reader

29+import Control.Monad.Writer

2830

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)

3033

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

3235runSupplyT n = flip runStateT n . unSupplyT

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

4043runSupply n = runIdentity . runSupplyT n

4144

4245evalSupply :: Integer -> Supply a -> a

43−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)

46+evalSupply n = runIdentity . evalSupplyT n

src/Language/PureScript.hs+18−7

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

1313--

1414-----------------------------------------------------------------------------

1515

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

17−

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

16+{-# LANGUAGE DataKinds #-}

17+{-# LANGUAGE QuasiQuotes #-}

18+{-# LANGUAGE TemplateHaskell #-}

19+{-# LANGUAGE FlexibleContexts #-}

20+{-# LANGUAGE ScopedTypeVariables #-}

21+

22+module Language.PureScript

23+ ( module P

24+ , compile

25+ , compile'

26+ , RebuildPolicy(..)

27+ , MonadMake(..)

28+ , make

29+ , prelude

30+ ) where

1931

2032import Data.FileEmbed (embedFile)

2133import Data.Function (on)

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

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

155167-- having to typecheck the module again.

156168--

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

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

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

159171make outputDir ms prefix = do

160172 noPrelude <- asks optionsNoPrelude

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

185197 evalSupplyT nextVar $ go initEnvironment desugared

186198

187199 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

190201 go env [] = return env

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

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

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

216227

217228 go env' ms'

218229

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

220231 rebuildIfNecessary _ _ [] = return []

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

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

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

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

1313--

1414-----------------------------------------------------------------------------

1515

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

16+{-# LANGUAGE GADTs #-}

17+{-# LANGUAGE ViewPatterns #-}

18+{-# LANGUAGE FlexibleContexts #-}

19+{-# LANGUAGE ScopedTypeVariables #-}

1720

1821module Language.PureScript.CodeGen.JS (

1922 module AST,

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

2831import Control.Applicative

2932import Control.Arrow ((&&&))

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

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

32−import Control.Monad.Supply

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

3335import Control.Monad.Supply.Class

3436

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

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

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

4648-- module.

4749--

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

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

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

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

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

51− additional <- lift $ asks optionsAdditional

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

53+ additional <- asks optionsAdditional

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

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

5456 jsDecls <- mapM (bindToJs name) decls

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

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

5658 let isModuleEmpty = null exps

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

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

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

8082-- |

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

8284--

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

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

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

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

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

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

8789

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

9193--

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

9395--

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

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

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

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

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

97− withoutComment <- lift $ asks optionsNoComments

99+ withoutComment <- asks optionsNoComments

98100 if withoutComment

99101 then nonRecToJS m i (modifyAnn removeComments e)

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

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

126128-- |

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

128130--

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

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

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

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

131133valueToJs m (Literal _ l) =

132134 literalToValueJS m l

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

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

195197 in return $ iife ctor [ constructor

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

197199 ]

200+

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

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

200203

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

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

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

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

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

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

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

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

209212-- |

210213-- Shallow copy an object.

211214--

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

213216extendObj obj sts = do

214217 newObj <- freshName

215218 key <- freshName

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

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

247250-- and guards.

248251--

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

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

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

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

251254bindersToJs m binders vals = do

252255 valNames <- replicateM (length vals) freshName

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

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

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

258261 []

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

262264 go _ done [] = return done

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

264266 done'' <- go vs done' bs

265267 binderToJs m v done'' b

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

267269

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]

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

271272 cond' <- valueToJs m cond

272273 done <- valueToJs m val

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

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

278279-- binder.

279280--

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

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

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

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

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

283284binderToJs m varName done (LiteralBinder _ l) =

284285 literalToBinderJS m varName done l

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

295296 (JSBlock js)

296297 Nothing]

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

300300 go [] done' = return done'

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

302302 argVar <- freshName

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

326326 js <- binderToJs m varName done binder

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

328328

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

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

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

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

331331literalToBinderJS _ varName done (NumericLiteral num) =

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

333333literalToBinderJS _ varName done (StringLiteral str) =

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

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

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

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

343342 go done' [] = return done'

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

345344 propVar <- freshName

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

350349 js <- go done 0 bs

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

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

355353 go done' _ [] = return done'

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

357355 elVar <- freshName