Skip to content

Commit ce67c05

Browse files
paf31paf31
committed
Use MonadSupply in code gen
1 parent c6e0ff3 commit ce67c05

File tree

3 files changed

+55
-47
lines changed

3 files changed

+55
-47
lines changed

‎src/Control/Monad/Supply.hs‎

Lines changed: 5 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -25,8 +25,11 @@ import Data.Functor.Identity
2525
import Control.Applicative
2626
import Control.Monad.State
2727
import 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

3134
runSupplyT :: Integer -> SupplyT m a -> m (a, Integer)
3235
runSupplyT n = flip runStateT n . unSupplyT
@@ -40,8 +43,4 @@ runSupply :: Integer -> Supply a -> (a, Integer)
4043
runSupply n = runIdentity . runSupplyT n
4144

4245
evalSupply :: 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‎

Lines changed: 18 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -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

2032
import Data.FileEmbed (embedFile)
2133
import 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
159171
make 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‎

Lines changed: 32 additions & 34 deletions
Original file line numberDiff line numberDiff line change
@@ -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

1821
module Language.PureScript.CodeGen.JS (
1922
module AST,
@@ -28,8 +31,7 @@ import qualified Data.Traversable as T (traverse)
2831
import Control.Applicative
2932
import Control.Arrow ((&&&))
3033
import 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)
3335
import Control.Monad.Supply.Class
3436

3537
import 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]
5052
moduleToJs (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]
8587
bindToJs mp (NonRec ident val) = return <$> nonRecToJS mp ident val
8688
bindToJs 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
9698
nonRecToJS 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
131133
valueToJs m (Literal _ l) =
132134
literalToValueJS m l
133135
valueToJs 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+
198201
iife :: String -> [JS] -> JS
199202
iife 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
203206
literalToValueJS _ (NumericLiteral n) = return $ JSNumericLiteral n
204207
literalToValueJS _ (StringLiteral s) = return $ JSStringLiteral s
205208
literalToValueJS _ (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
213216
extendObj 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
251254
bindersToJs 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]
282283
binderToJs _ _ done (NullBinder{}) = return done
283284
binderToJs 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]
331331
literalToBinderJS _ varName done (NumericLiteral num) =
332332
return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSNumericLiteral num)) (JSBlock done) Nothing]
333333
literalToBinderJS _ varName done (StringLiteral str) =
@@ -338,8 +338,7 @@ literalToBinderJS _ varName done (BooleanLiteral False) =
338338
return [JSIfElse (JSUnary Not (JSVar varName)) (JSBlock done) Nothing]
339339
literalToBinderJS 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

0 commit comments

Comments
 (0)