Skip to content

Commit c6e0ff3

Browse files
paf31paf31
committed
Extract MonadSupply class and mtl-ify the Sugar modules
1 parent 7bc1490 commit c6e0ff3

14 files changed

Lines changed: 176 additions & 121 deletions

File tree

‎purescript.cabal‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -96,7 +96,6 @@ library
9696
Language.PureScript.Sugar.Operators
9797
Language.PureScript.Sugar.TypeClasses
9898
Language.PureScript.Sugar.TypeDeclarations
99-
Language.PureScript.Supply
10099
Language.PureScript.Traversals
101100
Language.PureScript.TypeChecker
102101
Language.PureScript.TypeChecker.Entailment
@@ -112,6 +111,8 @@ library
112111
Language.PureScript.Types
113112

114113
Control.Monad.Unify
114+
Control.Monad.Supply
115+
Control.Monad.Supply.Class
115116
exposed: True
116117
buildable: True
117118
hs-source-dirs: src

src/Language/PureScript/Supply.hs renamed to src/Control/Monad/Supply.hs

Lines changed: 2 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,6 @@
11
-----------------------------------------------------------------------------
22
--
3-
-- Module : Language.PureScript.Supply
3+
-- Module : Control.Monad.Supply
44
-- Copyright : (c) Phil Freeman 2014
55
-- License : MIT
66
--
@@ -18,7 +18,7 @@
1818
{-# LANGUAGE MultiParamTypeClasses #-}
1919
{-# LANGUAGE UndecidableInstances #-}
2020

21-
module Language.PureScript.Supply where
21+
module Control.Monad.Supply where
2222

2323
import Data.Functor.Identity
2424

@@ -42,15 +42,6 @@ runSupply n = runIdentity . runSupplyT n
4242
evalSupply :: Integer -> Supply a -> a
4343
evalSupply n = runIdentity . evalSupplyT n
4444

45-
fresh :: (Monad m) => SupplyT m Integer
46-
fresh = SupplyT $ do
47-
n <- get
48-
put (n + 1)
49-
return n
50-
51-
freshName :: (Functor m, Monad m) => SupplyT m String
52-
freshName = ('_' :) . show <$> fresh
53-
5445
instance (MonadError e m) => MonadError e (SupplyT m) where
5546
throwError = SupplyT . throwError
5647
catchError e f = SupplyT $ catchError (unSupplyT e) (unSupplyT . f)

‎src/Control/Monad/Supply/Class.hs‎

Lines changed: 36 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,36 @@
1+
-----------------------------------------------------------------------------
2+
--
3+
-- Module : Control.Monad.Supply.Class
4+
-- Copyright : (c) PureScript 2015
5+
-- License : MIT
6+
--
7+
-- Maintainer : Phil Freeman <paf31@cantab.net>
8+
-- Stability : experimental
9+
-- Portability :
10+
--
11+
-- |
12+
-- A class for monads supporting a supply of fresh names
13+
--
14+
-----------------------------------------------------------------------------
15+
16+
{-# LANGUAGE MultiParamTypeClasses #-}
17+
18+
module Control.Monad.Supply.Class where
19+
20+
import Control.Monad.Supply
21+
import Control.Monad.State
22+
23+
class (Monad m) => MonadSupply m where
24+
fresh :: m Integer
25+
26+
instance (Monad m) => MonadSupply (SupplyT m) where
27+
fresh = SupplyT $ do
28+
n <- get
29+
put (n + 1)
30+
return n
31+
32+
instance (MonadSupply m) => MonadSupply (StateT s m) where
33+
fresh = lift fresh
34+
35+
freshName :: (MonadSupply m) => m String
36+
freshName = liftM (('_' :) . show) fresh

‎src/Language/PureScript.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -48,7 +48,7 @@ import Language.PureScript.Parser as P
4848
import Language.PureScript.Pretty as P
4949
import Language.PureScript.Renamer as P
5050
import Language.PureScript.Sugar as P
51-
import Language.PureScript.Supply as P
51+
import Control.Monad.Supply as P
5252
import Language.PureScript.TypeChecker as P
5353
import Language.PureScript.Types as P
5454
import qualified Language.PureScript.CoreFn as CoreFn

‎src/Language/PureScript/CodeGen/JS.hs‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -29,14 +29,15 @@ import Control.Applicative
2929
import Control.Arrow ((&&&))
3030
import Control.Monad (foldM, replicateM, forM)
3131
import Control.Monad.Reader (MonadReader, asks, lift)
32+
import Control.Monad.Supply
33+
import Control.Monad.Supply.Class
3234

3335
import Language.PureScript.CodeGen.JS.AST as AST
3436
import Language.PureScript.CodeGen.JS.Common as Common
3537
import Language.PureScript.CoreFn
3638
import Language.PureScript.Names
3739
import Language.PureScript.CodeGen.JS.Optimizer
3840
import Language.PureScript.Options
39-
import Language.PureScript.Supply
4041
import Language.PureScript.Traversals (sndM)
4142
import qualified Language.PureScript.Constants as C
4243

‎src/Language/PureScript/Sugar.hs‎

Lines changed: 10 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -13,15 +13,18 @@
1313
--
1414
-----------------------------------------------------------------------------
1515

16+
{-# LANGUAGE FlexibleContexts #-}
17+
1618
module Language.PureScript.Sugar (desugar, module S) where
1719

1820
import Control.Monad
1921
import Control.Category ((>>>))
20-
import Control.Monad.Trans.Class
22+
import Control.Applicative
23+
import Control.Monad.Error.Class
24+
import Control.Monad.Supply.Class
2125

2226
import Language.PureScript.AST
2327
import Language.PureScript.Errors
24-
import Language.PureScript.Supply
2528

2629
import Language.PureScript.Sugar.BindingGroups as S
2730
import Language.PureScript.Sugar.CaseDeclarations as S
@@ -55,14 +58,14 @@ import Language.PureScript.Sugar.TypeDeclarations as S
5558
--
5659
-- * Group mutually recursive value and data declarations into binding groups.
5760
--
58-
desugar :: [Module] -> SupplyT (Either ErrorStack) [Module]
61+
desugar :: (Applicative m, MonadSupply m, MonadError ErrorStack m) => [Module] -> m [Module]
5962
desugar = map removeSignedLiterals
6063
>>> mapM desugarObjectConstructors
6164
>=> mapM desugarOperatorSections
6265
>=> mapM desugarDoModule
6366
>=> desugarCasesModule
64-
>=> lift . (desugarTypeDeclarationsModule
65-
>=> desugarImports
66-
>=> rebracket)
67+
>=> desugarTypeDeclarationsModule
68+
>=> desugarImports
69+
>=> rebracket
6770
>=> desugarTypeClasses
68-
>=> lift . createBindingGroupsModule
71+
>=> createBindingGroupsModule

‎src/Language/PureScript/Sugar/BindingGroups.hs‎

Lines changed: 15 additions & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -14,6 +14,8 @@
1414
--
1515
-----------------------------------------------------------------------------
1616

17+
{-# LANGUAGE FlexibleContexts #-}
18+
1719
module Language.PureScript.Sugar.BindingGroups (
1820
createBindingGroups,
1921
createBindingGroupsModule,
@@ -24,8 +26,9 @@ module Language.PureScript.Sugar.BindingGroups (
2426
import Data.Graph
2527
import Data.List (nub, intersect)
2628
import Data.Maybe (isJust, mapMaybe)
27-
import Control.Applicative ((<$>), (<*>), pure)
29+
import Control.Applicative
2830
import Control.Monad ((<=<))
31+
import Control.Monad.Error.Class
2932

3033
import qualified Data.Set as S
3134

@@ -38,7 +41,7 @@ import Language.PureScript.Errors
3841
-- |
3942
-- Replace all sets of mutually-recursive declarations in a module with binding groups
4043
--
41-
createBindingGroupsModule :: [Module] -> Either ErrorStack [Module]
44+
createBindingGroupsModule :: (Functor m, Applicative m, MonadError ErrorStack m) => [Module] -> m [Module]
4245
createBindingGroupsModule = mapM $ \(Module name ds exps) -> Module name <$> createBindingGroups name ds <*> pure exps
4346

4447
-- |
@@ -47,20 +50,20 @@ createBindingGroupsModule = mapM $ \(Module name ds exps) -> Module name <$> cre
4750
collapseBindingGroupsModule :: [Module] -> [Module]
4851
collapseBindingGroupsModule = map $ \(Module name ds exps) -> Module name (collapseBindingGroups ds) exps
4952

50-
createBindingGroups :: ModuleName -> [Declaration] -> Either ErrorStack [Declaration]
53+
createBindingGroups :: (Functor m, Applicative m, MonadError ErrorStack m) => ModuleName -> [Declaration] -> m [Declaration]
5154
createBindingGroups moduleName = mapM f <=< handleDecls
5255

5356
where
5457
(f, _, _) = everywhereOnValuesTopDownM return handleExprs return
5558

56-
handleExprs :: Expr -> Either ErrorStack Expr
59+
handleExprs :: (Functor m, MonadError ErrorStack m) => Expr -> m Expr
5760
handleExprs (Let ds val) = flip Let val <$> handleDecls ds
5861
handleExprs other = return other
5962

6063
-- |
6164
-- Replace all sets of mutually-recursive declarations with binding groups
6265
--
63-
handleDecls :: [Declaration] -> Either ErrorStack [Declaration]
66+
handleDecls :: (Functor m, MonadError ErrorStack m) => [Declaration] -> m [Declaration]
6467
handleDecls ds = do
6568
let values = filter isValueDecl ds
6669
dataDecls = filter isDataDecl ds
@@ -151,7 +154,7 @@ getProperName _ = error "Expected DataDeclaration"
151154
-- Convert a group of mutually-recursive dependencies into a BindingGroupDeclaration (or simple ValueDeclaration).
152155
--
153156
--
154-
toBindingGroup :: ModuleName -> SCC Declaration -> Either ErrorStack Declaration
157+
toBindingGroup :: (Functor m, MonadError ErrorStack m) => ModuleName -> SCC Declaration -> m Declaration
155158
toBindingGroup _ (AcyclicSCC d) = return d
156159
toBindingGroup _ (CyclicSCC [d]) = return d
157160
toBindingGroup moduleName (CyclicSCC ds') =
@@ -172,24 +175,24 @@ toBindingGroup moduleName (CyclicSCC ds') =
172175
valueVerts :: [(Declaration, Ident, [Ident])]
173176
valueVerts = map (\d -> (d, getIdent d, usedImmediateIdents moduleName d `intersect` idents)) ds'
174177

175-
toBinding :: SCC Declaration -> Either ErrorStack (Ident, NameKind, Expr)
178+
toBinding :: (MonadError ErrorStack m) => SCC Declaration -> m (Ident, NameKind, Expr)
176179
toBinding (AcyclicSCC d) = return $ fromValueDecl d
177180
toBinding (CyclicSCC ~(d:ds)) = cycleError d ds
178181

179-
cycleError :: Declaration -> [Declaration] -> Either ErrorStack a
182+
cycleError :: (MonadError ErrorStack m) => Declaration -> [Declaration] -> m a
180183
cycleError (PositionedDeclaration p _ d) ds = rethrowWithPosition p $ cycleError d ds
181-
cycleError (ValueDeclaration n _ _ (Right e)) [] = Left $
184+
cycleError (ValueDeclaration n _ _ (Right e)) [] = throwError $
182185
mkErrorStack ("Cycle in definition of " ++ show n) (Just (ExprError e))
183186
cycleError d ds@(_:_) = rethrow (mkCompileError ("The following are not yet defined here: " ++ unwords (map (show . getIdent) ds)) Nothing `combineErrors`) $ cycleError d []
184187
cycleError _ _ = error "Expected ValueDeclaration"
185188

186-
toDataBindingGroup :: SCC Declaration -> Either ErrorStack Declaration
189+
toDataBindingGroup :: (MonadError ErrorStack m) => SCC Declaration -> m Declaration
187190
toDataBindingGroup (AcyclicSCC d) = return d
188191
toDataBindingGroup (CyclicSCC [d]) = case isTypeSynonym d of
189-
Just pn -> Left $ mkErrorStack ("Cycle in type synonym " ++ show pn) Nothing
192+
Just pn -> throwError $ mkErrorStack ("Cycle in type synonym " ++ show pn) Nothing
190193
_ -> return d
191194
toDataBindingGroup (CyclicSCC ds')
192-
| all (isJust . isTypeSynonym) ds' = Left $ mkErrorStack "Cycle in type synonyms" Nothing
195+
| all (isJust . isTypeSynonym) ds' = throwError $ mkErrorStack "Cycle in type synonyms" Nothing
193196
| otherwise = return $ DataBindingGroupDeclaration ds'
194197

195198
isTypeSynonym :: Declaration -> Maybe ProperName

‎src/Language/PureScript/Sugar/CaseDeclarations.hs‎

Lines changed: 11 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -14,6 +14,8 @@
1414
--
1515
-----------------------------------------------------------------------------
1616

17+
{-# LANGUAGE FlexibleContexts #-}
18+
1719
module Language.PureScript.Sugar.CaseDeclarations (
1820
desugarCases,
1921
desugarCasesModule
@@ -24,12 +26,13 @@ import Data.List (nub, groupBy)
2426
import Control.Applicative
2527
import Control.Monad ((<=<), forM, join, unless, replicateM)
2628
import Control.Monad.Except (throwError)
29+
import Control.Monad.Error.Class (MonadError)
30+
import Control.Monad.Supply.Class
2731

2832
import Language.PureScript.Names
2933
import Language.PureScript.AST
3034
import Language.PureScript.Environment
3135
import Language.PureScript.Errors
32-
import Language.PureScript.Supply
3336
import Language.PureScript.Traversals
3437
import Language.PureScript.TypeChecker.Monad (guardWith)
3538

@@ -41,17 +44,17 @@ isLeft (Right _) = False
4144
-- |
4245
-- Replace all top-level binders in a module with case expressions.
4346
--
44-
desugarCasesModule :: [Module] -> SupplyT (Either ErrorStack) [Module]
47+
desugarCasesModule :: (Functor m, Applicative m, MonadSupply m, MonadError ErrorStack m) => [Module] -> m [Module]
4548
desugarCasesModule ms = forM ms $ \(Module name ds exps) ->
4649
rethrow (mkCompileError ("Error in module " ++ show name) Nothing `combineErrors`) $
4750
Module name <$> (desugarCases <=< desugarAbs $ ds) <*> pure exps
4851

49-
desugarAbs :: [Declaration] -> SupplyT (Either ErrorStack) [Declaration]
52+
desugarAbs :: (Functor m, Applicative m, MonadSupply m, MonadError ErrorStack m) => [Declaration] -> m [Declaration]
5053
desugarAbs = flip parU f
5154
where
5255
(f, _, _) = everywhereOnValuesM return replace return
5356

54-
replace :: Expr -> SupplyT (Either ErrorStack) Expr
57+
replace :: (Functor m, Applicative m, MonadSupply m, MonadError ErrorStack m) => Expr -> m Expr
5558
replace (Abs (Right binder) val) = do
5659
ident <- Ident <$> freshName
5760
return $ Abs (Left ident) $ Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] (Right val)]
@@ -60,10 +63,10 @@ desugarAbs = flip parU f
6063
-- |
6164
-- Replace all top-level binders with case expressions.
6265
--
63-
desugarCases :: [Declaration] -> SupplyT (Either ErrorStack) [Declaration]
66+
desugarCases :: (Functor m, Applicative m, MonadSupply m, MonadError ErrorStack m) => [Declaration] -> m [Declaration]
6467
desugarCases = desugarRest <=< fmap join . flip parU toDecls . groupBy inSameGroup
6568
where
66-
desugarRest :: [Declaration] -> SupplyT (Either ErrorStack) [Declaration]
69+
desugarRest :: (Functor m, Applicative m, MonadSupply m, MonadError ErrorStack m) => [Declaration] -> m [Declaration]
6770
desugarRest (TypeInstanceDeclaration name constraints className tys ds : rest) =
6871
(:) <$> (TypeInstanceDeclaration name constraints className tys <$> desugarCases ds) <*> desugarRest rest
6972
desugarRest (ValueDeclaration name nameKind bs result : rest) =
@@ -86,7 +89,7 @@ inSameGroup (PositionedDeclaration _ _ d1) d2 = inSameGroup d1 d2
8689
inSameGroup d1 (PositionedDeclaration _ _ d2) = inSameGroup d1 d2
8790
inSameGroup _ _ = False
8891

89-
toDecls :: [Declaration] -> SupplyT (Either ErrorStack) [Declaration]
92+
toDecls :: (Functor m, Applicative m, MonadSupply m, MonadError ErrorStack m) => [Declaration] -> m [Declaration]
9093
toDecls [ValueDeclaration ident nameKind bs (Right val)] | all isVarBinder bs = do
9194
let args = map (\(VarBinder arg) -> arg) bs
9295
body = foldr (Abs . Left) val args
@@ -114,7 +117,7 @@ toTuple (ValueDeclaration _ _ bs result) = (bs, result)
114117
toTuple (PositionedDeclaration _ _ d) = toTuple d
115118
toTuple _ = error "Not a value declaration"
116119

117-
makeCaseDeclaration :: Ident -> [([Binder], Either [(Guard, Expr)] Expr)] -> SupplyT (Either ErrorStack) Declaration
120+
makeCaseDeclaration :: (Functor m, Applicative m, MonadSupply m, MonadError ErrorStack m) => Ident -> [([Binder], Either [(Guard, Expr)] Expr)] -> m Declaration
118121
makeCaseDeclaration ident alternatives = do
119122
let argPattern = length . fst . head $ alternatives
120123
args <- map Ident <$> replicateM argPattern freshName

‎src/Language/PureScript/Sugar/DoNotation.hs‎

Lines changed: 11 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -14,28 +14,31 @@
1414
--
1515
-----------------------------------------------------------------------------
1616

17+
{-# LANGUAGE FlexibleContexts #-}
18+
{-# LANGUAGE ScopedTypeVariables #-}
19+
1720
module Language.PureScript.Sugar.DoNotation (
1821
desugarDoModule
1922
) where
2023

2124
import Language.PureScript.Names
2225
import Language.PureScript.AST
2326
import Language.PureScript.Errors
24-
import Language.PureScript.Supply
2527

2628
import qualified Language.PureScript.Constants as C
2729

2830
import Control.Applicative
29-
import Control.Monad.Trans.Class
31+
import Control.Monad.Error.Class
32+
import Control.Monad.Supply.Class
3033

3134
-- |
3235
-- Replace all @DoNotationBind@ and @DoNotationValue@ constructors with applications of the Prelude.(>>=) function,
3336
-- and all @DoNotationLet@ constructors with let expressions.
3437
--
35-
desugarDoModule :: Module -> SupplyT (Either ErrorStack) Module
38+
desugarDoModule :: forall m. (Applicative m, MonadSupply m, MonadError ErrorStack m) => Module -> m Module
3639
desugarDoModule (Module mn ds exts) = Module mn <$> parU ds desugarDo <*> pure exts
3740

38-
desugarDo :: Declaration -> SupplyT (Either ErrorStack) Declaration
41+
desugarDo :: forall m. (Applicative m, MonadSupply m, MonadError ErrorStack m) => Declaration -> m Declaration
3942
desugarDo (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> (rethrowWithPosition pos $ desugarDo d)
4043
desugarDo d =
4144
let (f, _, _) = everywhereOnValuesM return replace return
@@ -47,18 +50,18 @@ desugarDo d =
4750
bind :: Expr
4851
bind = Var (Qualified (Just prelude) (Op (C.>>=)))
4952

50-
replace :: Expr -> SupplyT (Either ErrorStack) Expr
53+
replace :: Expr -> m Expr
5154
replace (Do els) = go els
5255
replace (PositionedValue pos com v) = PositionedValue pos com <$> rethrowWithPosition pos (replace v)
5356
replace other = return other
5457

55-
go :: [DoNotationElement] -> SupplyT (Either ErrorStack) Expr
58+
go :: [DoNotationElement] -> m Expr
5659
go [] = error "The impossible happened in desugarDo"
5760
go [DoNotationValue val] = return val
5861
go (DoNotationValue val : rest) = do
5962
rest' <- go rest
6063
return $ App (App bind val) (Abs (Left (Ident C.__unused)) rest')
61-
go [DoNotationBind _ _] = lift $ Left $ mkErrorStack "Bind statement cannot be the last statement in a do block" Nothing
64+
go [DoNotationBind _ _] = throwError $ mkErrorStack "Bind statement cannot be the last statement in a do block" Nothing
6265
go (DoNotationBind NullBinder val : rest) = go (DoNotationValue val : rest)
6366
go (DoNotationBind (VarBinder ident) val : rest) = do
6467
rest' <- go rest
@@ -67,7 +70,7 @@ desugarDo d =
6770
rest' <- go rest
6871
ident <- Ident <$> freshName
6972
return $ App (App bind val) (Abs (Left ident) (Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] (Right rest')]))
70-
go [DoNotationLet _] = lift $ Left $ mkErrorStack "Let statement cannot be the last statement in a do block" Nothing
73+
go [DoNotationLet _] = throwError $ mkErrorStack "Let statement cannot be the last statement in a do block" Nothing
7174
go (DoNotationLet ds : rest) = do
7275
rest' <- go rest
7376
return $ Let ds rest'

0 commit comments

Comments
 (0)