ea531ab · rowtype-yoga/purescript-native

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

Merge pull request #898 from purescript/supply

Extract MonadSupply class and mtl-ify the Sugar modules

commitea531ab9ae7f82f41e74369010b0c9fc0af63ee4 authorPhil Freeman <paf31@cantab.net> dateSat 21 Feb 2015, 09:22 (12 years ago) parentdd4ca07 4eaadff

14 files changed+230−170

compare with golang

unifiedsplit

purescript.cabal+2−1

@@ -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 → src/Control/Monad/Supply.hsrenamed+7−20

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

@@ -14,19 +14,19 @@

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

1515

1616{-# LANGUAGE GeneralizedNewtypeDeriving #-}

17−{-# LANGUAGE FlexibleInstances #-}

18−{-# LANGUAGE MultiParamTypeClasses #-}

19−{-# LANGUAGE UndecidableInstances #-}

2017

21−module Language.PureScript.Supply where

18+module Control.Monad.Supply where

2219

2320import Data.Functor.Identity

2421

2522import Control.Applicative

2623import Control.Monad.State

2724import Control.Monad.Except

25+import Control.Monad.Reader

26+import Control.Monad.Writer

2827

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

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

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

3030

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

3232runSupplyT n = flip runStateT n . unSupplyT

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

4040runSupply n = runIdentity . runSupplyT n

4141

4242evalSupply :: Integer -> Supply a -> a

43−evalSupply n = runIdentity . evalSupplyT n

44−

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−

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

55− throwError = SupplyT . throwError

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

43+evalSupply n = runIdentity . evalSupplyT n

src/Control/Monad/Supply/Class.hsnew file+36

@@ -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+19−8

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

@@ -48,7 +60,7 @@ import Language.PureScript.Parser as P

4860import Language.PureScript.Pretty as P

4961import Language.PureScript.Renamer as P

5062import Language.PureScript.Sugar as P

51−import Language.PureScript.Supply as P

63+import Control.Monad.Supply as P

5264import Language.PureScript.TypeChecker as P

5365import Language.PureScript.Types as P

5466import qualified Language.PureScript.CoreFn as CoreFn

@@ -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+33−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,7 +31,8 @@ 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)

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

35+import Control.Monad.Supply.Class

3236

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

3438import Language.PureScript.CodeGen.JS.Common as Common

@@ -36,7 +40,6 @@ import Language.PureScript.CoreFn

3640import Language.PureScript.Names

3741import Language.PureScript.CodeGen.JS.Optimizer

3842import Language.PureScript.Options

39−import Language.PureScript.Supply

4043import Language.PureScript.Traversals (sndM)

4144import qualified Language.PureScript.Constants as C

4245

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

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

4548-- module.

4649--

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

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

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

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

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

50− additional <- lift $ asks optionsAdditional

51− 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

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

5356 jsDecls <- mapM (bindToJs name) decls

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

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

5558 let isModuleEmpty = null exps

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

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

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

7982-- |

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

8184--

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

83− => 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]

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

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

8689

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

9093--

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

9295--

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

94− => 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

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

96− withoutComment <- lift $ asks optionsNoComments

99+ withoutComment <- asks optionsNoComments

97100 if withoutComment

98101 then nonRecToJS m i (modifyAnn removeComments e)

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

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

125128-- |

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

127130--

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

129− => 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

130133valueToJs m (Literal _ l) =

131134 literalToValueJS m l

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

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

194197 in return $ iife ctor [ constructor

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

196199 ]

200+

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

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

199203

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

201− => 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

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

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

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

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

208212-- |

209213-- Shallow copy an object.

210214--

211−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

212216extendObj obj sts = do

213217 newObj <- freshName

214218 key <- freshName

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

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

246250-- and guards.

247251--

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

249− => 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

250254bindersToJs m binders vals = do

251255 valNames <- replicateM (length vals) freshName

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

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

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

257261 []

258262 where

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

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

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

261264 go _ done [] = return done

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

263266 done'' <- go vs done' bs

264267 binderToJs m v done'' b

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

266269

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

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

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

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

270272 cond' <- valueToJs m cond

271273 done <- valueToJs m val

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

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

277279-- binder.

278280--

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

280− => 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]

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

282284binderToJs m varName done (LiteralBinder _ l) =

283285 literalToBinderJS m varName done l

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

294296 (JSBlock js)

295297 Nothing]

296298 where

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

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

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

299300 go [] done' = return done'

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

301302 argVar <- freshName

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

325326 js <- binderToJs m varName done binder

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

327328

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

329− => 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]

330331literalToBinderJS _ varName done (NumericLiteral num) =

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

332333literalToBinderJS _ varName done (StringLiteral str) =

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

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

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

339340 where

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

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

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

342342 go done' [] = return done'

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

344344 propVar <- freshName

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

349349 js <- go done 0 bs

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

351351 where

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

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

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

354353 go done' _ [] = return done'

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

356355 elVar <- freshName

src/Language/PureScript/Sugar.hs+10−7

@@ -13,15 +13,18 @@

1313--

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

1515

16+{-# LANGUAGE FlexibleContexts #-}

17+

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

1719

1820import Control.Monad

1921import 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

2226import Language.PureScript.AST

2327import Language.PureScript.Errors

24−import Language.PureScript.Supply

2528

2629import Language.PureScript.Sugar.BindingGroups as S

2730import 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]

5962desugar = 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+15−12

@@ -14,6 +14,8 @@

1414--

1515-----------------------------------------------------------------------------

1616

17+{-# LANGUAGE FlexibleContexts #-}

18+

1719module Language.PureScript.Sugar.BindingGroups (

1820 createBindingGroups,

1921 createBindingGroupsModule,

@@ -24,8 +26,9 @@ module Language.PureScript.Sugar.BindingGroups (

2426import Data.Graph

2527import Data.List (nub, intersect)

2628import Data.Maybe (isJust, mapMaybe)

27−import Control.Applicative ((<$>), (<*>), pure)

29+import Control.Applicative

2830import Control.Monad ((<=<))

31+import Control.Monad.Error.Class

2932

3033import 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]

4245createBindingGroupsModule = 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

4750collapseBindingGroupsModule :: [Module] -> [Module]

4851collapseBindingGroupsModule = 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]

5154createBindingGroups 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

155158toBindingGroup _ (AcyclicSCC d) = return d

156159toBindingGroup _ (CyclicSCC [d]) = return d

157160toBindingGroup 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

187190toDataBindingGroup (AcyclicSCC d) = return d

188191toDataBindingGroup (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

191194toDataBindingGroup (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

195198isTypeSynonym :: Declaration -> Maybe ProperName

src/Language/PureScript/Sugar/CaseDeclarations.hs+11−8

@@ -14,6 +14,8 @@

1414--

1515-----------------------------------------------------------------------------

1616

17+{-# LANGUAGE FlexibleContexts #-}

18+

1719module Language.PureScript.Sugar.CaseDeclarations (

1820 desugarCases,

1921 desugarCasesModule

@@ -24,12 +26,13 @@ import Data.List (nub, groupBy)

2426import Control.Applicative

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

2628import Control.Monad.Except (throwError)

29+import Control.Monad.Error.Class (MonadError)

30+import Control.Monad.Supply.Class

2731

2832import Language.PureScript.Names

2933import Language.PureScript.AST

3034import Language.PureScript.Environment

3135import Language.PureScript.Errors

32−import Language.PureScript.Supply

3336import Language.PureScript.Traversals

3437import 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]

4548desugarCasesModule 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]

5053desugarAbs = 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]

6467desugarCases = 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

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

8790inSameGroup _ _ = False

8891

89−toDecls :: [Declaration] -> SupplyT (Either ErrorStack) [Declaration]

92+toDecls :: (Functor m, Applicative m, MonadSupply m, MonadError ErrorStack m) => [Declaration] -> m [Declaration]

9093toDecls [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)

114117toTuple (PositionedDeclaration _ _ d) = toTuple d

115118toTuple _ = 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

118121makeCaseDeclaration ident alternatives = do

119122 let argPattern = length . fst . head $ alternatives

120123 args <- map Ident <$> replicateM argPattern freshName

src/Language/PureScript/Sugar/DoNotation.hs+11−8

@@ -14,6 +14,9 @@

1414--

1515-----------------------------------------------------------------------------

1616

17+{-# LANGUAGE FlexibleContexts #-}

18+{-# LANGUAGE ScopedTypeVariables #-}

19+

1720module Language.PureScript.Sugar.DoNotation (

1821 desugarDoModule

1922) where

@@ -21,21 +24,21 @@ module Language.PureScript.Sugar.DoNotation (

2124import Language.PureScript.Names

2225import Language.PureScript.AST

2326import Language.PureScript.Errors

24−import Language.PureScript.Supply

2527

2628import qualified Language.PureScript.Constants as C

2729

2830import 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

3639desugarDoModule (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

3942desugarDo (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> (rethrowWithPosition pos $ desugarDo d)

4043desugarDo 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'

src/Language/PureScript/Sugar/Names.hs+43−40

@@ -12,6 +12,9 @@

1212--

1313-----------------------------------------------------------------------------

1414

15+{-# LANGUAGE FlexibleContexts #-}

16+{-# LANGUAGE ScopedTypeVariables #-}

17+

1518module Language.PureScript.Sugar.Names (

1619 desugarImports

1720) where

@@ -84,7 +87,7 @@ data ImportEnvironment = ImportEnvironment

8487-- Updates the exports for a module from the global environment. If the module was not previously

8588-- present in the global environment, it is created.

8689--

87−updateExportedModule :: ExportEnvironment -> ModuleName -> (Exports -> Either ErrorStack Exports) -> Either ErrorStack ExportEnvironment

90+updateExportedModule :: (Applicative m, MonadError ErrorStack m) => ExportEnvironment -> ModuleName -> (Exports -> m Exports) -> m ExportEnvironment

8891updateExportedModule env mn update = do

8992 let exports = fromMaybe (error "Module was undefined in updateExportedModule") $ mn `M.lookup` env

9093 exports' <- update exports

@@ -93,7 +96,7 @@ updateExportedModule env mn update = do

9396-- |

9497-- Adds an empty module to an ExportEnvironment.

9598--

96−addEmptyModule :: ExportEnvironment -> ModuleName -> Either ErrorStack ExportEnvironment

99+addEmptyModule :: (Applicative m, MonadError ErrorStack m) => ExportEnvironment -> ModuleName -> m ExportEnvironment

97100addEmptyModule env name =

98101 if name `M.member` env

99102 then throwError $ mkErrorStack ("Module '" ++ show name ++ "' has been defined more than once") Nothing

@@ -102,7 +105,7 @@ addEmptyModule env name =

102105-- |

103106-- Adds a type belonging to a module to the export environment.

104107--

105−addType :: ExportEnvironment -> ModuleName -> ProperName -> [ProperName] -> Either ErrorStack ExportEnvironment

108+addType :: (Applicative m, MonadError ErrorStack m) => ExportEnvironment -> ModuleName -> ProperName -> [ProperName] -> m ExportEnvironment

106109addType env mn name dctors = updateExportedModule env mn $ \m -> do

107110 let exTypes = exportedTypes m

108111 let exDctors = snd `concatMap` exTypes

@@ -117,7 +120,7 @@ addType env mn name dctors = updateExportedModule env mn $ \m -> do

117120-- |

118121-- Adds a class to the export environment.

119122--

120−addTypeClass :: ExportEnvironment -> ModuleName -> ProperName -> Either ErrorStack ExportEnvironment

123+addTypeClass :: (Applicative m, MonadError ErrorStack m) => ExportEnvironment -> ModuleName -> ProperName -> m ExportEnvironment

121124addTypeClass env mn name = updateExportedModule env mn $ \m -> do

122125 let exTypes = exportedTypes m

123126 let exDctors = snd `concatMap` exTypes

@@ -129,7 +132,7 @@ addTypeClass env mn name = updateExportedModule env mn $ \m -> do

129132-- |

130133-- Adds a class to the export environment.

131134--

132−addValue :: ExportEnvironment -> ModuleName -> Ident -> Either ErrorStack ExportEnvironment

135+addValue :: (Applicative m, MonadError ErrorStack m) => ExportEnvironment -> ModuleName -> Ident -> m ExportEnvironment

133136addValue env mn name = updateExportedModule env mn $ \m -> do

134137 values <- addExport "value" (exportedValues m) name

135138 return $ m { exportedValues = values }

@@ -138,7 +141,7 @@ addValue env mn name = updateExportedModule env mn $ \m -> do

138141-- Adds an entry to a list of exports unless it is already present, in which case an error is

139142-- returned.

140143--

141−addExport :: (Eq a, Show a) => String -> [a] -> a -> Either ErrorStack [a]

144+addExport :: (Applicative m, MonadError ErrorStack m, Eq a, Show a) => String -> [a] -> a -> m [a]

142145addExport what exports name =

143146 if name `elem` exports

144147 then throwMultipleDefError what name

@@ -147,7 +150,7 @@ addExport what exports name =

147150-- |

148151-- Replaces all local names with qualified names within a set of modules.

149152--

150−desugarImports :: [Module] -> Either ErrorStack [Module]

153+desugarImports :: forall m. (Applicative m, MonadError ErrorStack m) => [Module] -> m [Module]

151154desugarImports modules = do

152155 unfilteredExports <- findExports modules

153156 exports <- foldM filterModuleExports unfilteredExports modules

@@ -157,13 +160,13 @@ desugarImports modules = do

157160 -- Filters the exports for a module in the global exports environment so that only explicitly

158161 -- exported members remain. If the module does not explicitly export anything, everything is

159162 -- exported.

160− filterModuleExports :: ExportEnvironment -> Module -> Either ErrorStack ExportEnvironment

163+ filterModuleExports :: ExportEnvironment -> Module -> m ExportEnvironment

161164 filterModuleExports env (Module mn _ (Just exps)) = filterExports mn exps env

162165 filterModuleExports env _ = return env

163166

164167 -- Rename and check all the names within a module. We tweak the global exports environment so

165168 -- the module has access to an unfiltered list of its own members.

166− renameInModule' :: ExportEnvironment -> ExportEnvironment -> Module -> Either ErrorStack Module

169+ renameInModule' :: ExportEnvironment -> ExportEnvironment -> Module -> m Module

167170 renameInModule' unfilteredExports exports m@(Module mn _ _) =

168171 rethrow (mkCompileError ("Error in module " ++ show mn) Nothing `combineErrors`) $ do

169172 let env = M.update (\_ -> M.lookup mn unfilteredExports) mn exports

@@ -202,13 +205,13 @@ elaborateImports (Module mn decls exps) = Module mn decls' exps

202205-- Replaces all local names with qualified names within a module and checks that all existing

203206-- qualified names are valid.

204207--

205−renameInModule :: ImportEnvironment -> ExportEnvironment -> Module -> Either ErrorStack Module

208+renameInModule :: forall m. (Applicative m, MonadError ErrorStack m) => ImportEnvironment -> ExportEnvironment -> Module -> m Module

206209renameInModule imports exports (Module mn decls exps) =

207210 Module mn <$> parU decls go <*> pure exps

208211 where

209212 (go, _, _, _, _) = everywhereWithContextOnValuesM (Nothing, []) updateDecl updateValue updateBinder updateCase defS

210213

211− updateDecl :: (Maybe SourceSpan, [Ident]) -> Declaration -> Either ErrorStack ((Maybe SourceSpan, [Ident]), Declaration)

214+ updateDecl :: (Maybe SourceSpan, [Ident]) -> Declaration -> m ((Maybe SourceSpan, [Ident]), Declaration)

212215 updateDecl (_, bound) d@(PositionedDeclaration pos _ _) = return ((Just pos, bound), d)

213216 updateDecl (pos, bound) (DataDeclaration dtype name args dctors) =

214217 (,) (pos, bound) <$> (DataDeclaration dtype name args <$> mapM (sndM (mapM (updateTypesEverywhere pos))) dctors)

@@ -226,7 +229,7 @@ renameInModule imports exports (Module mn decls exps) =

226229 (,) (pos, name : bound) <$> (ExternDeclaration fit name js <$> updateTypesEverywhere pos ty)

227230 updateDecl s d = return (s, d)

228231

229− updateValue :: (Maybe SourceSpan, [Ident]) -> Expr -> Either ErrorStack ((Maybe SourceSpan, [Ident]), Expr)

232+ updateValue :: (Maybe SourceSpan, [Ident]) -> Expr -> m ((Maybe SourceSpan, [Ident]), Expr)

230233 updateValue (_, bound) v@(PositionedValue pos' _ _) = return ((Just pos', bound), v)

231234 updateValue (pos, bound) (Abs (Left arg) val') = return ((pos, arg : bound), Abs (Left arg) val')

232235 updateValue (pos, bound) (Let ds val') = do

@@ -244,12 +247,12 @@ renameInModule imports exports (Module mn decls exps) =

244247 updateValue s@(pos, _) (TypedValue check val ty) = (,) s <$> (TypedValue check val <$> updateTypesEverywhere pos ty)

245248 updateValue s v = return (s, v)

246249

247− updateBinder :: (Maybe SourceSpan, [Ident]) -> Binder -> Either ErrorStack ((Maybe SourceSpan, [Ident]), Binder)

250+ updateBinder :: (Maybe SourceSpan, [Ident]) -> Binder -> m ((Maybe SourceSpan, [Ident]), Binder)

248251 updateBinder (_, bound) v@(PositionedBinder pos _ _) = return ((Just pos, bound), v)

249252 updateBinder s@(pos, _) (ConstructorBinder name b) = (,) s <$> (ConstructorBinder <$> updateDataConstructorName name pos <*> pure b)

250253 updateBinder s v = return (s, v)

251254

252− updateCase :: (Maybe SourceSpan, [Ident]) -> CaseAlternative -> Either ErrorStack ((Maybe SourceSpan, [Ident]), CaseAlternative)

255+ updateCase :: (Maybe SourceSpan, [Ident]) -> CaseAlternative -> m ((Maybe SourceSpan, [Ident]), CaseAlternative)

253256 updateCase (pos, bound) c@(CaseAlternative bs _) = return ((pos, concatMap binderNames bs ++ bound), c)

254257

255258 letBoundVariable :: Declaration -> Maybe Ident

@@ -257,10 +260,10 @@ renameInModule imports exports (Module mn decls exps) =

257260 letBoundVariable (PositionedDeclaration _ _ d) = letBoundVariable d

258261 letBoundVariable _ = Nothing

259262

260− updateTypesEverywhere :: Maybe SourceSpan -> Type -> Either ErrorStack Type

263+ updateTypesEverywhere :: Maybe SourceSpan -> Type -> m Type

261264 updateTypesEverywhere pos0 = everywhereOnTypesM (updateType pos0)

262265 where

263− updateType :: Maybe SourceSpan -> Type -> Either ErrorStack Type

266+ updateType :: Maybe SourceSpan -> Type -> m Type

264267 updateType pos (TypeConstructor name) = TypeConstructor <$> updateTypeName name pos

265268 updateType pos (SaturatedTypeSynonym name tys) = SaturatedTypeSynonym <$> updateTypeName name pos <*> pure tys

266269 updateType pos (ConstrainedType cs t) = ConstrainedType <$> updateConstraints pos cs <*> pure t

@@ -280,7 +283,7 @@ renameInModule imports exports (Module mn decls exps) =

280283 -> (Exports -> a -> Bool)

281284 -> Qualified a

282285 -> Maybe SourceSpan

283− -> Either ErrorStack (Qualified a)

286+ -> m (Qualified a)

284287 update t getI checkE qname@(Qualified mn' name) pos = positioned $ case (M.lookup qname imports', mn') of

285288 (Just qname', _) -> return qname'

286289 (Nothing, Just mn'') -> do

@@ -299,13 +302,13 @@ renameInModule imports exports (Module mn decls exps) =

299302 Just pos' -> rethrowWithPosition pos' err

300303

301304 -- Gets the exports for a module, or an error message if the module doesn't exist

302− getExports :: ModuleName -> Either ErrorStack Exports

305+ getExports :: ModuleName -> m Exports

303306 getExports mn' = maybe (throwError $ mkErrorStack ("Unknown module '" ++ show mn' ++ "'") Nothing) return $ M.lookup mn' exports

304307

305308-- |

306309-- Finds all exported declarations in a set of modules.

307310--

308−findExports :: [Module] -> Either ErrorStack ExportEnvironment

311+findExports :: forall m. (Applicative m, MonadError ErrorStack m) => [Module] -> m ExportEnvironment

309312findExports = foldM addModule $ M.singleton (ModuleName [ProperName C.prim]) primExports

310313 where

311314

@@ -315,13 +318,13 @@ findExports = foldM addModule $ M.singleton (ModuleName [ProperName C.prim]) pri

315318 mkTypeEntry (Qualified _ name) = (name, [])

316319

317320 -- Add all of the exported declarations from a module to the global export environment

318− addModule :: ExportEnvironment -> Module -> Either ErrorStack ExportEnvironment

321+ addModule :: ExportEnvironment -> Module -> m ExportEnvironment

319322 addModule env (Module mn ds _) = do

320323 env' <- addEmptyModule env mn

321324 rethrow (mkCompileError ("Error in module " ++ show mn) Nothing `combineErrors`) $ foldM (addDecl mn) env' ds

322325

323326 -- Add a declaration from a module to the global export environment

324− addDecl :: ModuleName -> ExportEnvironment -> Declaration -> Either ErrorStack ExportEnvironment

327+ addDecl :: ModuleName -> ExportEnvironment -> Declaration -> m ExportEnvironment

325328 addDecl mn env (TypeClassDeclaration tcn _ _ ds) = do

326329 env' <- addTypeClass env mn tcn

327330 foldM go env' ds

@@ -341,7 +344,7 @@ findExports = foldM addModule $ M.singleton (ModuleName [ProperName C.prim]) pri

341344-- Filters the exports for a module to ensure only explicit exports are kept in the global exports

342345-- environment.

343346--

344−filterExports :: ModuleName -> [DeclarationRef] -> ExportEnvironment -> Either ErrorStack ExportEnvironment

347+filterExports :: forall m. (Applicative m, MonadError ErrorStack m) => ModuleName -> [DeclarationRef] -> ExportEnvironment -> m ExportEnvironment

345348filterExports mn exps env = do

346349 let moduleExports = fromMaybe (error "Module is missing") (mn `M.lookup` env)

347350 moduleExports' <- rethrow (mkCompileError ("Error in module " ++ show mn) Nothing `combineErrors`) $ filterModule moduleExports

@@ -349,7 +352,7 @@ filterExports mn exps env = do

349352 where

350353

351354 -- Filter the exports for the specific module

352− filterModule :: Exports -> Either ErrorStack Exports

355+ filterModule :: Exports -> m Exports

353356 filterModule exported = do

354357 types' <- foldM (filterTypes $ exportedTypes exported) [] exps

355358 values <- foldM (filterValues $ exportedValues exported) [] exps

@@ -358,7 +361,7 @@ filterExports mn exps env = do

358361

359362 -- Ensure the exported types and data constructors exist in the module and add them to the set of

360363 -- exports

361− filterTypes :: [(ProperName, [ProperName])] -> [(ProperName, [ProperName])] -> DeclarationRef -> Either ErrorStack [(ProperName, [ProperName])]

364+ filterTypes :: [(ProperName, [ProperName])] -> [(ProperName, [ProperName])] -> DeclarationRef -> m [(ProperName, [ProperName])]

362365 filterTypes expTys result (PositionedDeclarationRef pos _ r) = rethrowWithPosition pos $ filterTypes expTys result r

363366 filterTypes expTys result (TypeRef name expDcons) = do

364367 dcons <- maybe (throwError $ mkErrorStack ("Cannot export undefined type '" ++ show name ++ "'") Nothing) return $ name `lookup` expTys

@@ -367,14 +370,14 @@ filterExports mn exps env = do

367370 filterTypes _ result _ = return result

368371

369372 -- Ensure the exported data constructors exists for a type and add them to the list of exports

370− filterDcons :: ProperName -> [ProperName] -> [ProperName] -> ProperName -> Either ErrorStack [ProperName]

373+ filterDcons :: ProperName -> [ProperName] -> [ProperName] -> ProperName -> m [ProperName]

371374 filterDcons tcon exps' result name =

372375 if name `elem` exps'

373376 then return $ name : result

374377 else throwError $ mkErrorStack ("Cannot export undefined data constructor '" ++ show name ++ "' for type '" ++ show tcon ++ "'") Nothing

375378

376379 -- Ensure the exported classes exist in the module and add them to the set of exports

377− filterClasses :: [ProperName] -> [ProperName] -> DeclarationRef -> Either ErrorStack [ProperName]

380+ filterClasses :: [ProperName] -> [ProperName] -> DeclarationRef -> m [ProperName]

378381 filterClasses exps' result (PositionedDeclarationRef pos _ r) = rethrowWithPosition pos $ filterClasses exps' result r

379382 filterClasses exps' result (TypeClassRef name) =

380383 if name `elem` exps'

@@ -383,7 +386,7 @@ filterExports mn exps env = do

383386 filterClasses _ result _ = return result

384387

385388 -- Ensure the exported values exist in the module and add them to the set of exports

386− filterValues :: [Ident] -> [Ident] -> DeclarationRef -> Either ErrorStack [Ident]

389+ filterValues :: [Ident] -> [Ident] -> DeclarationRef -> m [Ident]

387390 filterValues exps' result (PositionedDeclarationRef pos _ r) = rethrowWithPosition pos $ filterValues exps' result r

388391 filterValues exps' result (ValueRef name) =

389392 if name `elem` exps'

@@ -405,7 +408,7 @@ findImports = foldl (findImports' Nothing) M.empty

405408-- |

406409-- Constructs a local environment for a module.

407410--

408−resolveImports :: ExportEnvironment -> Module -> Either ErrorStack ImportEnvironment

411+resolveImports :: forall m. (Applicative m, MonadError ErrorStack m) => ExportEnvironment -> Module -> m ImportEnvironment

409412resolveImports env (Module currentModule decls _) =

410413 foldM resolveImport' (ImportEnvironment M.empty M.empty M.empty M.empty) (M.toList scope)

411414 where

@@ -416,7 +419,7 @@ resolveImports env (Module currentModule decls _) =

416419 scope :: M.Map ModuleName (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)

417420 scope = M.insert currentModule (Nothing, Unqualified, Nothing) (findImports decls)

418421

419− resolveImport' :: ImportEnvironment -> (ModuleName, (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)) -> Either ErrorStack ImportEnvironment

422+ resolveImport' :: ImportEnvironment -> (ModuleName, (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)) -> m ImportEnvironment

420423 resolveImport' imp (mn, (pos, typ, impQual)) = do

421424 modExports <- positioned $ maybe (throwError $ mkErrorStack ("Cannot import unknown module '" ++ show mn ++ "'") Nothing) return $ mn `M.lookup` env

422425 positioned $ resolveImport currentModule mn modExports imp impQual typ

@@ -428,19 +431,19 @@ resolveImports env (Module currentModule decls _) =

428431-- |

429432-- Extends the local environment for a module by resolving an import of another module.

430433--

431−resolveImport :: ModuleName -> ModuleName -> Exports -> ImportEnvironment -> Maybe ModuleName -> ImportDeclarationType -> Either ErrorStack ImportEnvironment

434+resolveImport :: forall m. (Applicative m, MonadError ErrorStack m) => ModuleName -> ModuleName -> Exports -> ImportEnvironment -> Maybe ModuleName -> ImportDeclarationType -> m ImportEnvironment

432435resolveImport currentModule importModule exps imps impQual =

433436 resolveByType

434437 where

435438

436− resolveByType :: ImportDeclarationType -> Either ErrorStack ImportEnvironment

439+ resolveByType :: ImportDeclarationType -> m ImportEnvironment

437440 resolveByType Unqualified = importAll importExplicit

438441 resolveByType (Qualifying explImports) = (checkedRefs >=> foldM importExplicit imps) explImports

439442 resolveByType (Hiding hiddenImports) = do

440443 hiddenImports' <- checkedRefs hiddenImports

441444 importAll (importNonHidden hiddenImports')

442445

443− importNonHidden :: [DeclarationRef] -> ImportEnvironment -> DeclarationRef -> Either ErrorStack ImportEnvironment

446+ importNonHidden :: [DeclarationRef] -> ImportEnvironment -> DeclarationRef -> m ImportEnvironment

444447 importNonHidden hidden m ref =

445448 if isHidden hidden ref

446449 then return m

@@ -459,14 +462,14 @@ resolveImport currentModule importModule exps imps impQual =

459462 isHidden hidden ref = ref `elem` hidden

460463

461464 -- Import all symbols

462− importAll :: (ImportEnvironment -> DeclarationRef -> Either ErrorStack ImportEnvironment) -> Either ErrorStack ImportEnvironment

465+ importAll :: (ImportEnvironment -> DeclarationRef -> m ImportEnvironment) -> m ImportEnvironment

463466 importAll importer = do

464467 imp' <- foldM (\m (name, dctors) -> importer m (TypeRef name (Just dctors))) imps (exportedTypes exps)

465468 imp'' <- foldM (\m name -> importer m (ValueRef name)) imp' (exportedValues exps)

466469 foldM (\m name -> importer m (TypeClassRef name)) imp'' (exportedTypeClasses exps)

467470

468471 -- Import something explicitly

469− importExplicit :: ImportEnvironment -> DeclarationRef -> Either ErrorStack ImportEnvironment

472+ importExplicit :: ImportEnvironment -> DeclarationRef -> m ImportEnvironment

470473 importExplicit imp (PositionedDeclarationRef pos _ r) = rethrowWithPosition pos $ importExplicit imp r

471474 importExplicit imp (ValueRef name) = do

472475 values' <- updateImports (importedValues imp) name

@@ -483,7 +486,7 @@ resolveImport currentModule importModule exps imps impQual =

483486 importExplicit _ _ = error "Invalid argument to importExplicit"

484487

485488 -- Check if DeclarationRef points to an existent symbol

486− checkedRefs :: [DeclarationRef] -> Either ErrorStack [DeclarationRef]

489+ checkedRefs :: [DeclarationRef] -> m [DeclarationRef]

487490 checkedRefs = mapM check

488491 where

489492 check (PositionedDeclarationRef pos _ r) =

@@ -504,7 +507,7 @@ resolveImport currentModule importModule exps imps impQual =

504507 allExportedDataConstructors name = fromMaybe [] $ name `lookup` exportedTypes exps

505508

506509 -- Add something to the ImportEnvironment if it does not already exist there

507− updateImports :: (Ord a, Show a) => M.Map (Qualified a) (Qualified a) -> a -> Either ErrorStack (M.Map (Qualified a) (Qualified a))

510+ updateImports :: (Ord a, Show a) => M.Map (Qualified a) (Qualified a) -> a -> m (M.Map (Qualified a) (Qualified a))

508511 updateImports m name = case M.lookup (Qualified impQual name) m of

509512 Nothing -> return $ M.insert (Qualified impQual name) (Qualified (Just importModule) name) m

510513 Just (Qualified Nothing _) -> error "Invalid state in updateImports"

@@ -521,11 +524,11 @@ resolveImport currentModule importModule exps imps impQual =

521524

522525 -- Ensure that an explicitly imported data constructor exists for the type it is being imported

523526 -- from

524− checkDctorExists :: [ProperName] -> ProperName -> Either ErrorStack ProperName

527+ checkDctorExists :: [ProperName] -> ProperName -> m ProperName

525528 checkDctorExists = checkImportExists "data constructor"

526529

527530 -- Check that an explicitly imported item exists in the module it is being imported from

528− checkImportExists :: (Eq a, Show a) => String -> [a] -> a -> Either ErrorStack a

531+ checkImportExists :: (Eq a, Show a) => String -> [a] -> a -> m a

529532 checkImportExists t exports item =

530533 if item `elem` exports

531534 then return item

@@ -534,7 +537,7 @@ resolveImport currentModule importModule exps imps impQual =

534537-- |

535538-- Raises an error for when there is more than one definition for something.

536539--

537−throwMultipleDefError :: (Show a) => String -> a -> Either ErrorStack b

540+throwMultipleDefError :: (Applicative m, MonadError ErrorStack m, Show a) => String -> a -> m b

538541throwMultipleDefError what name = throwError $

539542 mkErrorStack ("Multiple definitions for " ++ what ++ " '" ++ show name ++ "'") Nothing

540543

@@ -542,7 +545,7 @@ throwMultipleDefError what name = throwError $

542545-- Raises an error for when there is a conflicting definition for something, for example, a type

543546-- class and data constructor of the same name.

544547--

545−throwConflictingDefError :: (Show a) => String -> String -> a -> Either ErrorStack b

548+throwConflictingDefError :: (Applicative m, MonadError ErrorStack m, Show a) => String -> String -> a -> m b

546549throwConflictingDefError what1 what2 name = throwError $

547550 mkErrorStack (what1 ++ " '" ++ show name ++ "' cannot be defined in the same module as a " ++ what2 ++ " of the same name") Nothing

548551

src/Language/PureScript/Sugar/ObjectWildcards.hs+10−6

@@ -12,12 +12,17 @@

1212--

1313-----------------------------------------------------------------------------

1414

15+{-# LANGUAGE FlexibleContexts #-}

16+{-# LANGUAGE ScopedTypeVariables #-}

17+

1518module Language.PureScript.Sugar.ObjectWildcards (

1619 desugarObjectConstructors

1720) where

1821

1922import Control.Applicative

2023import Control.Arrow (second)

24+import Control.Monad.Error.Class

25+import Control.Monad.Supply.Class

2126

2227import Data.List (partition)

2328import Data.Maybe (isJust, fromJust, catMaybes)

@@ -25,16 +30,15 @@ import Data.Maybe (isJust, fromJust, catMaybes)

2530import Language.PureScript.AST

2631import Language.PureScript.Errors

2732import Language.PureScript.Names

28−import Language.PureScript.Supply

2933

30−desugarObjectConstructors :: Module -> SupplyT (Either ErrorStack) Module

34+desugarObjectConstructors :: forall m. (Applicative m, MonadSupply m, MonadError ErrorStack m) => Module -> m Module

3135desugarObjectConstructors (Module mn ds exts) = Module mn <$> mapM desugarDecl ds <*> pure exts

3236 where

3337

34− desugarDecl :: Declaration -> SupplyT (Either ErrorStack) Declaration

38+ desugarDecl :: Declaration -> m Declaration

3539 (desugarDecl, _, _) = everywhereOnValuesM return desugarExpr return

3640

37− desugarExpr :: Expr -> SupplyT (Either ErrorStack) Expr

41+ desugarExpr :: Expr -> m Expr

3842 desugarExpr (ObjectConstructor ps) = wrapLambda ObjectLiteral ps

3943 desugarExpr (ObjectUpdater (Just obj) ps) = wrapLambda (ObjectUpdate obj) ps

4044 desugarExpr (ObjectUpdater Nothing ps) = do

@@ -45,7 +49,7 @@ desugarObjectConstructors (Module mn ds exts) = Module mn <$> mapM desugarDecl d

4549 return $ Abs (Left arg) (Accessor prop (Var (Qualified Nothing arg)))

4650 desugarExpr e = return e

4751

48− wrapLambda :: ([(String, Expr)] -> Expr) -> [(String, Maybe Expr)] -> SupplyT (Either ErrorStack) Expr

52+ wrapLambda :: ([(String, Expr)] -> Expr) -> [(String, Maybe Expr)] -> m Expr

4953 wrapLambda mkVal ps =

5054 let (props, args) = partition (isJust . snd) ps

5155 in if null args

@@ -54,7 +58,7 @@ desugarObjectConstructors (Module mn ds exts) = Module mn <$> mapM desugarDecl d

5458 (args', ps') <- unzip <$> mapM mkProp ps

5559 return $ foldr (Abs . Left) (mkVal ps') (catMaybes args')

5660

57− mkProp :: (String, Maybe Expr) -> SupplyT (Either ErrorStack) (Maybe Ident, (String, Expr))

61+ mkProp :: (String, Maybe Expr) -> m (Maybe Ident, (String, Expr))

5862 mkProp (name, Just e) = return (Nothing, (name, e))

5963 mkProp (name, Nothing) = do

6064 arg <- Ident <$> freshName

src/Language/PureScript/Sugar/Operators.hs+14−12

@@ -17,7 +17,9 @@

1717--

1818-----------------------------------------------------------------------------

1919

20−{-# LANGUAGE Rank2Types, FlexibleContexts #-}

20+{-# LANGUAGE Rank2Types #-}

21+{-# LANGUAGE FlexibleContexts #-}

22+{-# LANGUAGE ScopedTypeVariables #-}

2123

2224module Language.PureScript.Sugar.Operators (

2325 rebracket,

@@ -28,11 +30,11 @@ module Language.PureScript.Sugar.Operators (

2830import Language.PureScript.AST

2931import Language.PureScript.Errors

3032import Language.PureScript.Names

31−import Language.PureScript.Supply

3233

3334import Control.Applicative

3435import Control.Monad.State

3536import Control.Monad.Except

37+import Control.Monad.Supply.Class

3638

3739import Data.Function (on)

3840import Data.Functor.Identity

@@ -47,7 +49,7 @@ import qualified Language.PureScript.Constants as C

4749-- |

4850-- Remove explicit parentheses and reorder binary operator applications

4951--

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

52+rebracket :: (Applicative m, MonadError ErrorStack m) => [Module] -> m [Module]

5153rebracket ms = do

5254 let fixities = concatMap collectFixities ms

5355 ensureNoDuplicates $ map (\(i, pos, _) -> (i, pos)) fixities

@@ -62,7 +64,7 @@ removeSignedLiterals (Module mn ds exts) = Module mn (map f' ds) exts

6264 go (UnaryMinus val) = App (Var (Qualified (Just (ModuleName [ProperName C.prelude])) (Ident C.negate))) val

6365 go other = other

6466

65−rebracketModule :: [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]] -> Module -> Either ErrorStack Module

67+rebracketModule :: (Applicative m, MonadError ErrorStack m) => [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]] -> Module -> m Module

6668rebracketModule opTable (Module mn ds exts) =

6769 let (f, _, _) = everywhereOnValuesTopDownM return (matchOperators opTable) return

6870 in Module mn <$> (map removeParens <$> parU ds f) <*> pure exts

@@ -83,7 +85,7 @@ collectFixities (Module moduleName ds _) = concatMap collect ds

8385 collect FixityDeclaration{} = error "Fixity without srcpos info"

8486 collect _ = []

8587

86−ensureNoDuplicates :: [(Qualified Ident, SourceSpan)] -> Either ErrorStack ()

88+ensureNoDuplicates :: (MonadError ErrorStack m) => [(Qualified Ident, SourceSpan)] -> m ()

8789ensureNoDuplicates m = go $ sortBy (compare `on` fst) m

8890 where

8991 go [] = return ()

@@ -106,17 +108,17 @@ customOperatorTable fixities =

106108

107109type Chain = [Either Expr Expr]

108110

109−matchOperators :: [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]] -> Expr -> Either ErrorStack Expr

111+matchOperators :: forall m. (MonadError ErrorStack m) => [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]] -> Expr -> m Expr

110112matchOperators ops = parseChains

111113 where

112− parseChains :: Expr -> Either ErrorStack Expr

114+ parseChains :: Expr -> m Expr

113115 parseChains b@BinaryNoParens{} = bracketChain (extendChain b)

114116 parseChains other = return other

115117 extendChain :: Expr -> Chain

116118 extendChain (BinaryNoParens op l r) = Left l : Right op : extendChain r

117119 extendChain other = [Left other]

118− bracketChain :: Chain -> Either ErrorStack Expr

119− bracketChain = either (Left . (`mkErrorStack` Nothing) . show) Right . P.parse (P.buildExpressionParser opTable parseValue <* P.eof) "operator expression"

120+ bracketChain :: Chain -> m Expr

121+ bracketChain = either (throwError . (`mkErrorStack` Nothing) . show) return . P.parse (P.buildExpressionParser opTable parseValue <* P.eof) "operator expression"

120122 opTable = [P.Infix (P.try (parseTicks >>= \op -> return (\t1 t2 -> App (App op t1) t2))) P.AssocLeft]

121123 : map (map (\(name, f, a) -> P.Infix (P.try (matchOp name) >> return f) (toAssoc a))) ops

122124 ++ [[ P.Infix (P.try (parseOp >>= \ident -> return (\t1 t2 -> App (App (Var ident) t1) t2))) P.AssocLeft ]]

@@ -149,14 +151,14 @@ matchOp op = do

149151 ident <- parseOp

150152 guard $ ident == op

151153

152−desugarOperatorSections :: Module -> SupplyT (Either ErrorStack) Module

154+desugarOperatorSections :: forall m. (Applicative m, MonadSupply m, MonadError ErrorStack m) => Module -> m Module

153155desugarOperatorSections (Module mn ds exts) = Module mn <$> mapM goDecl ds <*> pure exts

154156 where

155157

156− goDecl :: Declaration -> SupplyT (Either ErrorStack) Declaration

158+ goDecl :: Declaration -> m Declaration

157159 (goDecl, _, _) = everywhereOnValuesM return goExpr return

158160

159− goExpr :: Expr -> SupplyT (Either ErrorStack) Expr

161+ goExpr :: Expr -> m Expr

160162 goExpr (OperatorSection op (Left val)) = return $ App op val

161163 goExpr (OperatorSection op (Right val)) = do

162164 arg <- Ident <$> freshName

src/Language/PureScript/Sugar/TypeClasses.hs+13−11

@@ -14,6 +14,8 @@

1414--

1515-----------------------------------------------------------------------------

1616

17+{-# LANGUAGE FlexibleContexts #-}

18+

1719module Language.PureScript.Sugar.TypeClasses

1820 ( desugarTypeClasses

1921 , typeClassMemberName

@@ -27,7 +29,7 @@ import Language.PureScript.Kinds

2729import Language.PureScript.Names

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

2931import Language.PureScript.Sugar.CaseDeclarations

30−import Language.PureScript.Supply

32+import Control.Monad.Supply.Class

3133import Language.PureScript.Types

3234

3335import qualified Language.PureScript.Constants as C

@@ -43,16 +45,16 @@ import qualified Data.Map as M

4345

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

4547

46−type Desugar = StateT MemberMap (SupplyT (Either ErrorStack))

48+type Desugar = StateT MemberMap

4749

4850-- |

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

5052-- instance dictionary expressions.

5153--

52−desugarTypeClasses :: [Module] -> SupplyT (Either ErrorStack) [Module]

54+desugarTypeClasses :: (Functor m, Applicative m, MonadSupply m, MonadError ErrorStack m) => [Module] -> m [Module]

5355desugarTypeClasses = flip evalStateT M.empty . mapM desugarModule

5456

55−desugarModule :: Module -> Desugar Module

57+desugarModule :: (Functor m, Applicative m, MonadSupply m, MonadError ErrorStack m) => Module -> Desugar m Module

5658desugarModule (Module name decls (Just exps)) = do

5759 (newExpss, declss) <- unzip <$> parU decls (desugarDecl name exps)

5860 return $ Module name (concat declss) $ Just (exps ++ catMaybes newExpss)

@@ -152,7 +154,7 @@ desugarModule _ = error "Exports should have been elaborated in name desugaring"

152154-- return new Sub(fooString, "");

153155-- };

154156-}

155−desugarDecl :: ModuleName -> [DeclarationRef] -> Declaration -> Desugar (Maybe DeclarationRef, [Declaration])

157+desugarDecl :: (Functor m, Applicative m, MonadSupply m, MonadError ErrorStack m) => ModuleName -> [DeclarationRef] -> Declaration -> Desugar m (Maybe DeclarationRef, [Declaration])

156158desugarDecl mn exps = go

157159 where

158160 go d@(TypeClassDeclaration name args implies members) = do

@@ -160,7 +162,7 @@ desugarDecl mn exps = go

160162 return (Nothing, d : typeClassDictionaryDeclaration name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members)

161163 go d@(ExternInstanceDeclaration name _ className tys) = return (expRef name className tys, [d])

162164 go d@(TypeInstanceDeclaration name deps className tys members) = do

163− desugared <- lift $ desugarCases members

165+ desugared <- desugarCases members

164166 dictDecl <- typeInstanceDictionaryDeclaration name mn deps className tys desugared

165167 return (expRef name className tys, [d, dictDecl])

166168 go (PositionedDeclaration pos com d) = do

@@ -222,14 +224,14 @@ typeClassMemberToDictionaryAccessor _ _ _ _ = error "Invalid declaration in type

222224unit :: Type

223225unit = TypeApp tyObject REmpty

224226

225−typeInstanceDictionaryDeclaration :: Ident -> ModuleName -> [Constraint] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar Declaration

227+typeInstanceDictionaryDeclaration :: (Functor m, Applicative m, MonadSupply m, MonadError ErrorStack m) => Ident -> ModuleName -> [Constraint] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar m Declaration

226228typeInstanceDictionaryDeclaration name mn deps className tys decls =

227229 rethrow (mkCompileError ("Error in type class instance " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys) ++ ":") Nothing `combineErrors`) $ do

228230 m <- get

229231

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

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

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

233+ (TypeClassDeclaration _ args implies tyDecls) <-

234+ maybe (throwError $ mkErrorStack ("Type class " ++ show className ++ " is undefined") Nothing) return $

233235 M.lookup (qualify mn className) m

234236

235237 case mapMaybe declName tyDecls \\ mapMaybe declName decls of

@@ -268,9 +270,9 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =

268270 declName (TypeDeclaration ident _) = Just ident

269271 declName _ = Nothing

270272

271− memberToValue :: [(Ident, Type)] -> Declaration -> Desugar Expr

273+ memberToValue :: (Functor m, Applicative m, MonadSupply m, MonadError ErrorStack m) => [(Ident, Type)] -> Declaration -> Desugar m Expr

272274 memberToValue tys' (ValueDeclaration ident _ [] (Right val)) = do

273− _ <- lift . lift . maybe (Left $ mkErrorStack ("Type class does not define member '" ++ show ident ++ "'") Nothing) Right $ lookup ident tys'

275+ _ <- maybe (throwError $ mkErrorStack ("Type class does not define member '" ++ show ident ++ "'") Nothing) return $ lookup ident tys'

274276 return val

275277 memberToValue tys' (PositionedDeclaration pos com d) = rethrowWithPosition pos $ do

276278 val <- memberToValue tys' d

src/Language/PureScript/Sugar/TypeDeclarations.hs+6−3

@@ -14,6 +14,8 @@

1414--

1515-----------------------------------------------------------------------------

1616

17+{-# LANGUAGE FlexibleContexts #-}

18+

1719module Language.PureScript.Sugar.TypeDeclarations (

1820 desugarTypeDeclarations,

1921 desugarTypeDeclarationsModule

@@ -22,6 +24,7 @@ module Language.PureScript.Sugar.TypeDeclarations (

2224import Control.Applicative

2325import Control.Monad (forM)

2426import Control.Monad.Except (throwError)

27+import Control.Monad.Error.Class (MonadError)

2528

2629import Language.PureScript.AST

2730import Language.PureScript.Names

@@ -32,7 +35,7 @@ import Language.PureScript.Traversals

3235-- |

3336-- Replace all top level type declarations in a module with type annotations

3437--

35−desugarTypeDeclarationsModule :: [Module] -> Either ErrorStack [Module]

38+desugarTypeDeclarationsModule :: (Functor m, Applicative m, MonadError ErrorStack m) => [Module] -> m [Module]

3639desugarTypeDeclarationsModule ms = forM ms $ \(Module name ds exps) ->

3740 rethrow (mkCompileError ("Error in module " ++ show name) Nothing `combineErrors`) $

3841 Module name <$> desugarTypeDeclarations ds <*> pure exps

@@ -40,7 +43,7 @@ desugarTypeDeclarationsModule ms = forM ms $ \(Module name ds exps) ->

4043-- |

4144-- Replace all top level type declarations with type annotations

4245--

43−desugarTypeDeclarations :: [Declaration] -> Either ErrorStack [Declaration]

46+desugarTypeDeclarations :: (Functor m, Applicative m, MonadError ErrorStack m) => [Declaration] -> m [Declaration]

4447desugarTypeDeclarations (PositionedDeclaration pos com d : ds) = do

4548 (d' : ds') <- rethrowWithPosition pos $ desugarTypeDeclarations (d : ds)

4649 return (PositionedDeclaration pos com d' : ds')

@@ -48,7 +51,7 @@ desugarTypeDeclarations (TypeDeclaration name ty : d : rest) = do

4851 (_, nameKind, val) <- fromValueDeclaration d

4952 desugarTypeDeclarations (ValueDeclaration name nameKind [] (Right (TypedValue True val ty)) : rest)

5053 where

51− fromValueDeclaration :: Declaration -> Either ErrorStack (Ident, NameKind, Expr)

54+ fromValueDeclaration :: (Functor m, Applicative m, MonadError ErrorStack m) => Declaration -> m (Ident, NameKind, Expr)

5255 fromValueDeclaration (ValueDeclaration name' nameKind [] (Right val)) | name == name' = return (name', nameKind, val)

5356 fromValueDeclaration (PositionedDeclaration pos com d') = do

5457 (ident, nameKind, val) <- rethrowWithPosition pos $ fromValueDeclaration d'