ea531ab · rowtype-yoga/purescript-native

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

on golang help sign in

Merge pull request #898 from purescript/supply

ea531abPhil Freeman12 years ago

purescript.cabal+2−1

compare with golang

unifiedsplit

@@ -96,7 +96,6 @@ library

96 Language.PureScript.Sugar.Operators

97 Language.PureScript.Sugar.TypeClasses

98 Language.PureScript.Sugar.TypeDeclarations

99− Language.PureScript.Supply

100 Language.PureScript.Traversals

99 Language.PureScript.Traversals

101 Language.PureScript.TypeChecker

100 Language.PureScript.TypeChecker

102 Language.PureScript.TypeChecker.Entailment

101 Language.PureScript.TypeChecker.Entailment

@@ -112,6 +111,8 @@ library

112 Language.PureScript.Types

111 Language.PureScript.Types

113

112

114 Control.Monad.Unify

113 Control.Monad.Unify

114+ Control.Monad.Supply

115+ Control.Monad.Supply.Class

115 exposed: True

116 exposed: True

116 buildable: True

117 buildable: True

117 hs-source-dirs: src

118 hs-source-dirs: src

src/Language/PureScript/Supply.hs → src/Control/Monad/Supply.hsrenamed+7−20

@@ -1,6 +1,6 @@

1-----------------------------------------------------------------------------

2--

3−-- Module : Language.PureScript.Supply

3+-- Module : Control.Monad.Supply

4-- Copyright : (c) Phil Freeman 2014

5-- License : MIT

6--

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

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

16{-# LANGUAGE GeneralizedNewtypeDeriving #-}

17−{-# LANGUAGE FlexibleInstances #-}

18−{-# LANGUAGE MultiParamTypeClasses #-}

19−{-# LANGUAGE UndecidableInstances #-}

21−module Language.PureScript.Supply where

18+module Control.Monad.Supply where

23import Data.Functor.Identity

20import Data.Functor.Identity

25import Control.Applicative

22import Control.Applicative

26import Control.Monad.State

23import Control.Monad.State

27import Control.Monad.Except

24import Control.Monad.Except

25+import Control.Monad.Reader

26+import Control.Monad.Writer

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)

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

32runSupplyT n = flip runStateT n . unSupplyT

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

40runSupply n = runIdentity . runSupplyT n

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

43−evalSupply n = runIdentity . evalSupplyT n

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)

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

13--

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

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

16+{-# LANGUAGE DataKinds #-}

17−

17+{-# LANGUAGE QuasiQuotes #-}

18+{-# LANGUAGE TemplateHaskell #-}

19+{-# LANGUAGE FlexibleContexts #-}

20+{-# LANGUAGE ScopedTypeVariables #-}

21+

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

22+module Language.PureScript

23+ ( module P

24+ , compile

25+ , compile'

26+ , RebuildPolicy(..)

27+ , MonadMake(..)

28+ , make

29+ , prelude

30+ ) where

20import Data.FileEmbed (embedFile)

32import Data.FileEmbed (embedFile)

21import Data.Function (on)

33import Data.Function (on)

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

48import Language.PureScript.Pretty as P

60import Language.PureScript.Pretty as P

49import Language.PureScript.Renamer as P

61import Language.PureScript.Renamer as P

50import Language.PureScript.Sugar as P

62import Language.PureScript.Sugar as P

51−import Language.PureScript.Supply as P

63+import Control.Monad.Supply as P

52import Language.PureScript.TypeChecker as P

64import Language.PureScript.TypeChecker as P

53import Language.PureScript.Types as P

65import Language.PureScript.Types as P

54import qualified Language.PureScript.CoreFn as CoreFn

66import qualified Language.PureScript.CoreFn as CoreFn

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

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

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

155-- having to typecheck the module again.

167-- having to typecheck the module again.

156--

168--

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

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

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

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

159make outputDir ms prefix = do

171make outputDir ms prefix = do

160 noPrelude <- asks optionsNoPrelude

172 noPrelude <- asks optionsNoPrelude

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

185 evalSupplyT nextVar $ go initEnvironment desugared

197 evalSupplyT nextVar $ go initEnvironment desugared

186

198

187 where

199 where

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

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

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

190 go env [] = return env

201 go env [] = return env

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

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

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

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

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

216

227

217 go env' ms'

228 go env' ms'

218

229

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

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

220 rebuildIfNecessary _ _ [] = return []

231 rebuildIfNecessary _ _ [] = return []

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

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

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

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

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

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

13--

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

16+{-# LANGUAGE GADTs #-}

17+{-# LANGUAGE ViewPatterns #-}

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

18+{-# LANGUAGE FlexibleContexts #-}

19+{-# LANGUAGE ScopedTypeVariables #-}

18module Language.PureScript.CodeGen.JS (

21module Language.PureScript.CodeGen.JS (

19 module AST,

22 module AST,

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

28import Control.Applicative

31import Control.Applicative

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

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

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

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

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

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

35+import Control.Monad.Supply.Class

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

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

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

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

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

36import Language.PureScript.Names

40import Language.PureScript.Names

37import Language.PureScript.CodeGen.JS.Optimizer

41import Language.PureScript.CodeGen.JS.Optimizer

38import Language.PureScript.Options

42import Language.PureScript.Options

39−import Language.PureScript.Supply

40import Language.PureScript.Traversals (sndM)

43import Language.PureScript.Traversals (sndM)

41import qualified Language.PureScript.Constants as C

44import qualified Language.PureScript.Constants as C

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

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

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

45-- module.

48-- module.

46--

49--

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

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

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

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

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

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

50− additional <- lift $ asks optionsAdditional

53+ additional <- asks optionsAdditional

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

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

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

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

53 jsDecls <- mapM (bindToJs name) decls

56 jsDecls <- mapM (bindToJs name) decls

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

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

55 let isModuleEmpty = null exps

58 let isModuleEmpty = null exps

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

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

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

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

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

79-- |

82-- |

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

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

81--

84--

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

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

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

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

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

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

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

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

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

90--

93--

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

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

92--

95--

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

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

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

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

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

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

96− withoutComment <- lift $ asks optionsNoComments

99+ withoutComment <- asks optionsNoComments

97 if withoutComment

100 if withoutComment

98 then nonRecToJS m i (modifyAnn removeComments e)

101 then nonRecToJS m i (modifyAnn removeComments e)

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

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

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

125-- |

128-- |

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

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

127--

130--

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

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

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

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

130valueToJs m (Literal _ l) =

133valueToJs m (Literal _ l) =

131 literalToValueJS m l

134 literalToValueJS m l

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

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

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

194 in return $ iife ctor [ constructor

197 in return $ iife ctor [ constructor

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

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

196 ]

199 ]

200+

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

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

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

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

199

203

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

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

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

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

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

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

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

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

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

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

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

208-- |

212-- |

209-- Shallow copy an object.

213-- Shallow copy an object.

210--

214--

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

212extendObj obj sts = do

216extendObj obj sts = do

213 newObj <- freshName

217 newObj <- freshName

214 key <- freshName

218 key <- freshName

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

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

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

246-- and guards.

250-- and guards.

247--

251--

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

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

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

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

250bindersToJs m binders vals = do

254bindersToJs m binders vals = do

251 valNames <- replicateM (length vals) freshName

255 valNames <- replicateM (length vals) freshName

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

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

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

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

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

257 []

261 []

258 where

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

261 go _ done [] = return done

264 go _ done [] = return done

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

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

263 done'' <- go vs done' bs

266 done'' <- go vs done' bs

264 binderToJs m v done'' b

267 binderToJs m v done'' b

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

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

266

269

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]

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

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

270 cond' <- valueToJs m cond

272 cond' <- valueToJs m cond

271 done <- valueToJs m val

273 done <- valueToJs m val

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

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

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

277-- binder.

279-- binder.

278--

280--

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

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

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

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

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

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

282binderToJs m varName done (LiteralBinder _ l) =

284binderToJs m varName done (LiteralBinder _ l) =

283 literalToBinderJS m varName done l

285 literalToBinderJS m varName done l

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

294 (JSBlock js)

296 (JSBlock js)

295 Nothing]

297 Nothing]

296 where

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

299 go [] done' = return done'

300 go [] done' = return done'

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

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

301 argVar <- freshName

302 argVar <- freshName

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

325 js <- binderToJs m varName done binder

326 js <- binderToJs m varName done binder

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

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

327

328

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

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

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

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

330literalToBinderJS _ varName done (NumericLiteral num) =

331literalToBinderJS _ varName done (NumericLiteral num) =

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

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

332literalToBinderJS _ varName done (StringLiteral str) =

333literalToBinderJS _ varName done (StringLiteral str) =

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

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

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

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

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

339 where

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

342 go done' [] = return done'

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

344 propVar <- freshName

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

349 js <- go done 0 bs

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

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

354 go done' _ [] = return done'

353 go done' _ [] = return done'

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

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

356 elVar <- freshName

355 elVar <- freshName

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

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

13--

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

16+{-# LANGUAGE FlexibleContexts #-}

17+

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

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

18import Control.Monad

20import Control.Monad

19import Control.Category ((>>>))

21import Control.Category ((>>>))

20−import Control.Monad.Trans.Class

22+import Control.Applicative

23+import Control.Monad.Error.Class

24+import Control.Monad.Supply.Class

22import Language.PureScript.AST

26import Language.PureScript.AST

23import Language.PureScript.Errors

27import Language.PureScript.Errors

24−import Language.PureScript.Supply

26import Language.PureScript.Sugar.BindingGroups as S

29import Language.PureScript.Sugar.BindingGroups as S

27import Language.PureScript.Sugar.CaseDeclarations as S

30import Language.PureScript.Sugar.CaseDeclarations as S

@@ -55,14 +58,14 @@ import Language.PureScript.Sugar.TypeDeclarations as S

55--

58--

56-- * Group mutually recursive value and data declarations into binding groups.

59-- * Group mutually recursive value and data declarations into binding groups.

57--

60--

58−desugar :: [Module] -> SupplyT (Either ErrorStack) [Module]

61+desugar :: (Applicative m, MonadSupply m, MonadError ErrorStack m) => [Module] -> m [Module]

59desugar = map removeSignedLiterals

62desugar = map removeSignedLiterals

60 >>> mapM desugarObjectConstructors

63 >>> mapM desugarObjectConstructors

61 >=> mapM desugarOperatorSections

64 >=> mapM desugarOperatorSections

62 >=> mapM desugarDoModule

65 >=> mapM desugarDoModule

63 >=> desugarCasesModule

66 >=> desugarCasesModule

64− >=> lift . (desugarTypeDeclarationsModule

67+ >=> desugarTypeDeclarationsModule

65− >=> desugarImports

68+ >=> desugarImports

66− >=> rebracket)

69+ >=> rebracket

67 >=> desugarTypeClasses

70 >=> desugarTypeClasses

68− >=> lift . createBindingGroupsModule

71+ >=> createBindingGroupsModule

src/Language/PureScript/Sugar/BindingGroups.hs+15−12

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

14--

15-----------------------------------------------------------------------------

17+{-# LANGUAGE FlexibleContexts #-}

18+

17module Language.PureScript.Sugar.BindingGroups (

19module Language.PureScript.Sugar.BindingGroups (

18 createBindingGroups,

20 createBindingGroups,

19 createBindingGroupsModule,

21 createBindingGroupsModule,

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

24import Data.Graph

26import Data.Graph

25import Data.List (nub, intersect)

27import Data.List (nub, intersect)

26import Data.Maybe (isJust, mapMaybe)

28import Data.Maybe (isJust, mapMaybe)

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

29+import Control.Applicative

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

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

31+import Control.Monad.Error.Class

30import qualified Data.Set as S

33import qualified Data.Set as S

@@ -38,7 +41,7 @@ import Language.PureScript.Errors

38-- |

41-- |

39-- Replace all sets of mutually-recursive declarations in a module with binding groups

42-- Replace all sets of mutually-recursive declarations in a module with binding groups

40--

43--

41−createBindingGroupsModule :: [Module] -> Either ErrorStack [Module]

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

42createBindingGroupsModule = mapM $ \(Module name ds exps) -> Module name <$> createBindingGroups name ds <*> pure exps

45createBindingGroupsModule = mapM $ \(Module name ds exps) -> Module name <$> createBindingGroups name ds <*> pure exps

44-- |

47-- |

@@ -47,20 +50,20 @@ createBindingGroupsModule = mapM $ \(Module name ds exps) -> Module name <$> cre

47collapseBindingGroupsModule :: [Module] -> [Module]

50collapseBindingGroupsModule :: [Module] -> [Module]

48collapseBindingGroupsModule = map $ \(Module name ds exps) -> Module name (collapseBindingGroups ds) exps

51collapseBindingGroupsModule = map $ \(Module name ds exps) -> Module name (collapseBindingGroups ds) exps

50−createBindingGroups :: ModuleName -> [Declaration] -> Either ErrorStack [Declaration]

53+createBindingGroups :: (Functor m, Applicative m, MonadError ErrorStack m) => ModuleName -> [Declaration] -> m [Declaration]

51createBindingGroups moduleName = mapM f <=< handleDecls

54createBindingGroups moduleName = mapM f <=< handleDecls

53 where

56 where

54 (f, _, _) = everywhereOnValuesTopDownM return handleExprs return

57 (f, _, _) = everywhereOnValuesTopDownM return handleExprs return

56− handleExprs :: Expr -> Either ErrorStack Expr

59+ handleExprs :: (Functor m, MonadError ErrorStack m) => Expr -> m Expr

57 handleExprs (Let ds val) = flip Let val <$> handleDecls ds

60 handleExprs (Let ds val) = flip Let val <$> handleDecls ds

58 handleExprs other = return other

61 handleExprs other = return other

60 -- |

63 -- |

61 -- Replace all sets of mutually-recursive declarations with binding groups

64 -- Replace all sets of mutually-recursive declarations with binding groups

62 --

65 --

63− handleDecls :: [Declaration] -> Either ErrorStack [Declaration]

66+ handleDecls :: (Functor m, MonadError ErrorStack m) => [Declaration] -> m [Declaration]

64 handleDecls ds = do

67 handleDecls ds = do

65 let values = filter isValueDecl ds

68 let values = filter isValueDecl ds

66 dataDecls = filter isDataDecl ds

69 dataDecls = filter isDataDecl ds

@@ -151,7 +154,7 @@ getProperName _ = error "Expected DataDeclaration"

151-- Convert a group of mutually-recursive dependencies into a BindingGroupDeclaration (or simple ValueDeclaration).

154-- Convert a group of mutually-recursive dependencies into a BindingGroupDeclaration (or simple ValueDeclaration).

152--

155--

153--

156--

154−toBindingGroup :: ModuleName -> SCC Declaration -> Either ErrorStack Declaration

157+toBindingGroup :: (Functor m, MonadError ErrorStack m) => ModuleName -> SCC Declaration -> m Declaration

155toBindingGroup _ (AcyclicSCC d) = return d

158toBindingGroup _ (AcyclicSCC d) = return d

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

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

157toBindingGroup moduleName (CyclicSCC ds') =

160toBindingGroup moduleName (CyclicSCC ds') =

@@ -172,24 +175,24 @@ toBindingGroup moduleName (CyclicSCC ds') =

172 valueVerts :: [(Declaration, Ident, [Ident])]

175 valueVerts :: [(Declaration, Ident, [Ident])]

173 valueVerts = map (\d -> (d, getIdent d, usedImmediateIdents moduleName d `intersect` idents)) ds'

176 valueVerts = map (\d -> (d, getIdent d, usedImmediateIdents moduleName d `intersect` idents)) ds'

174

177

175− toBinding :: SCC Declaration -> Either ErrorStack (Ident, NameKind, Expr)

178+ toBinding :: (MonadError ErrorStack m) => SCC Declaration -> m (Ident, NameKind, Expr)

176 toBinding (AcyclicSCC d) = return $ fromValueDecl d

179 toBinding (AcyclicSCC d) = return $ fromValueDecl d

177 toBinding (CyclicSCC ~(d:ds)) = cycleError d ds

180 toBinding (CyclicSCC ~(d:ds)) = cycleError d ds

178

181

179− cycleError :: Declaration -> [Declaration] -> Either ErrorStack a

182+ cycleError :: (MonadError ErrorStack m) => Declaration -> [Declaration] -> m a

180 cycleError (PositionedDeclaration p _ d) ds = rethrowWithPosition p $ cycleError d ds

183 cycleError (PositionedDeclaration p _ d) ds = rethrowWithPosition p $ cycleError d ds

181− cycleError (ValueDeclaration n _ _ (Right e)) [] = Left $

184+ cycleError (ValueDeclaration n _ _ (Right e)) [] = throwError $

182 mkErrorStack ("Cycle in definition of " ++ show n) (Just (ExprError e))

185 mkErrorStack ("Cycle in definition of " ++ show n) (Just (ExprError e))

183 cycleError d ds@(_:_) = rethrow (mkCompileError ("The following are not yet defined here: " ++ unwords (map (show . getIdent) ds)) Nothing `combineErrors`) $ cycleError d []

186 cycleError d ds@(_:_) = rethrow (mkCompileError ("The following are not yet defined here: " ++ unwords (map (show . getIdent) ds)) Nothing `combineErrors`) $ cycleError d []

184 cycleError _ _ = error "Expected ValueDeclaration"

187 cycleError _ _ = error "Expected ValueDeclaration"

185

188

186−toDataBindingGroup :: SCC Declaration -> Either ErrorStack Declaration

189+toDataBindingGroup :: (MonadError ErrorStack m) => SCC Declaration -> m Declaration

187toDataBindingGroup (AcyclicSCC d) = return d

190toDataBindingGroup (AcyclicSCC d) = return d

188toDataBindingGroup (CyclicSCC [d]) = case isTypeSynonym d of

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

190 _ -> return d

193 _ -> return d

191toDataBindingGroup (CyclicSCC ds')

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

193 | otherwise = return $ DataBindingGroupDeclaration ds'

196 | otherwise = return $ DataBindingGroupDeclaration ds'

194

197

195isTypeSynonym :: Declaration -> Maybe ProperName

198isTypeSynonym :: Declaration -> Maybe ProperName

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

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

14--

15-----------------------------------------------------------------------------

17+{-# LANGUAGE FlexibleContexts #-}

18+

17module Language.PureScript.Sugar.CaseDeclarations (

19module Language.PureScript.Sugar.CaseDeclarations (

18 desugarCases,

20 desugarCases,

19 desugarCasesModule

21 desugarCasesModule

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

24import Control.Applicative

26import Control.Applicative

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

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

26import Control.Monad.Except (throwError)

28import Control.Monad.Except (throwError)

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

30+import Control.Monad.Supply.Class

28import Language.PureScript.Names

32import Language.PureScript.Names

29import Language.PureScript.AST

33import Language.PureScript.AST

30import Language.PureScript.Environment

34import Language.PureScript.Environment

31import Language.PureScript.Errors

35import Language.PureScript.Errors

32−import Language.PureScript.Supply

33import Language.PureScript.Traversals

36import Language.PureScript.Traversals

34import Language.PureScript.TypeChecker.Monad (guardWith)

37import Language.PureScript.TypeChecker.Monad (guardWith)

@@ -41,17 +44,17 @@ isLeft (Right _) = False

41-- |

44-- |

42-- Replace all top-level binders in a module with case expressions.

45-- Replace all top-level binders in a module with case expressions.

43--

46--

44−desugarCasesModule :: [Module] -> SupplyT (Either ErrorStack) [Module]

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

45desugarCasesModule ms = forM ms $ \(Module name ds exps) ->

48desugarCasesModule ms = forM ms $ \(Module name ds exps) ->

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

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

47 Module name <$> (desugarCases <=< desugarAbs $ ds) <*> pure exps

50 Module name <$> (desugarCases <=< desugarAbs $ ds) <*> pure exps

49−desugarAbs :: [Declaration] -> SupplyT (Either ErrorStack) [Declaration]

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

50desugarAbs = flip parU f

53desugarAbs = flip parU f

51 where

54 where

52 (f, _, _) = everywhereOnValuesM return replace return

55 (f, _, _) = everywhereOnValuesM return replace return

54− replace :: Expr -> SupplyT (Either ErrorStack) Expr

57+ replace :: (Functor m, Applicative m, MonadSupply m, MonadError ErrorStack m) => Expr -> m Expr

55 replace (Abs (Right binder) val) = do

58 replace (Abs (Right binder) val) = do

56 ident <- Ident <$> freshName

59 ident <- Ident <$> freshName

57 return $ Abs (Left ident) $ Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] (Right val)]

60 return $ Abs (Left ident) $ Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] (Right val)]

@@ -60,10 +63,10 @@ desugarAbs = flip parU f

60-- |

63-- |

61-- Replace all top-level binders with case expressions.

64-- Replace all top-level binders with case expressions.

62--

65--

63−desugarCases :: [Declaration] -> SupplyT (Either ErrorStack) [Declaration]

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

64desugarCases = desugarRest <=< fmap join . flip parU toDecls . groupBy inSameGroup

67desugarCases = desugarRest <=< fmap join . flip parU toDecls . groupBy inSameGroup

65 where

68 where

66− desugarRest :: [Declaration] -> SupplyT (Either ErrorStack) [Declaration]

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

67 desugarRest (TypeInstanceDeclaration name constraints className tys ds : rest) =

70 desugarRest (TypeInstanceDeclaration name constraints className tys ds : rest) =

68 (:) <$> (TypeInstanceDeclaration name constraints className tys <$> desugarCases ds) <*> desugarRest rest

71 (:) <$> (TypeInstanceDeclaration name constraints className tys <$> desugarCases ds) <*> desugarRest rest

69 desugarRest (ValueDeclaration name nameKind bs result : rest) =

72 desugarRest (ValueDeclaration name nameKind bs result : rest) =

@@ -86,7 +89,7 @@ inSameGroup (PositionedDeclaration _ _ d1) d2 = inSameGroup d1 d2

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

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

87inSameGroup _ _ = False

90inSameGroup _ _ = False

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

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

90toDecls [ValueDeclaration ident nameKind bs (Right val)] | all isVarBinder bs = do

93toDecls [ValueDeclaration ident nameKind bs (Right val)] | all isVarBinder bs = do

91 let args = map (\(VarBinder arg) -> arg) bs

94 let args = map (\(VarBinder arg) -> arg) bs

92 body = foldr (Abs . Left) val args

95 body = foldr (Abs . Left) val args

@@ -114,7 +117,7 @@ toTuple (ValueDeclaration _ _ bs result) = (bs, result)

114toTuple (PositionedDeclaration _ _ d) = toTuple d

117toTuple (PositionedDeclaration _ _ d) = toTuple d

115toTuple _ = error "Not a value declaration"

118toTuple _ = error "Not a value declaration"

116

119

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

118makeCaseDeclaration ident alternatives = do

121makeCaseDeclaration ident alternatives = do

119 let argPattern = length . fst . head $ alternatives

122 let argPattern = length . fst . head $ alternatives

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

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

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

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

14--

15-----------------------------------------------------------------------------

17+{-# LANGUAGE FlexibleContexts #-}

18+{-# LANGUAGE ScopedTypeVariables #-}

19+

17module Language.PureScript.Sugar.DoNotation (

20module Language.PureScript.Sugar.DoNotation (

18 desugarDoModule

21 desugarDoModule

19) where

22) where

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

21import Language.PureScript.Names

24import Language.PureScript.Names

22import Language.PureScript.AST

25import Language.PureScript.AST

23import Language.PureScript.Errors

26import Language.PureScript.Errors

24−import Language.PureScript.Supply

26import qualified Language.PureScript.Constants as C

28import qualified Language.PureScript.Constants as C

28import Control.Applicative

30import Control.Applicative

29−import Control.Monad.Trans.Class

31+import Control.Monad.Error.Class

32+import Control.Monad.Supply.Class

31-- |

34-- |

32-- Replace all @DoNotationBind@ and @DoNotationValue@ constructors with applications of the Prelude.(>>=) function,

35-- Replace all @DoNotationBind@ and @DoNotationValue@ constructors with applications of the Prelude.(>>=) function,

33-- and all @DoNotationLet@ constructors with let expressions.

36-- and all @DoNotationLet@ constructors with let expressions.

34--

37--

35−desugarDoModule :: Module -> SupplyT (Either ErrorStack) Module

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

36desugarDoModule (Module mn ds exts) = Module mn <$> parU ds desugarDo <*> pure exts

39desugarDoModule (Module mn ds exts) = Module mn <$> parU ds desugarDo <*> pure exts

38−desugarDo :: Declaration -> SupplyT (Either ErrorStack) Declaration

41+desugarDo :: forall m. (Applicative m, MonadSupply m, MonadError ErrorStack m) => Declaration -> m Declaration

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

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

40desugarDo d =

43desugarDo d =

41 let (f, _, _) = everywhereOnValuesM return replace return

44 let (f, _, _) = everywhereOnValuesM return replace return

@@ -47,18 +50,18 @@ desugarDo d =

47 bind :: Expr

50 bind :: Expr

48 bind = Var (Qualified (Just prelude) (Op (C.>>=)))

51 bind = Var (Qualified (Just prelude) (Op (C.>>=)))

50− replace :: Expr -> SupplyT (Either ErrorStack) Expr

53+ replace :: Expr -> m Expr

51 replace (Do els) = go els

54 replace (Do els) = go els

52 replace (PositionedValue pos com v) = PositionedValue pos com <$> rethrowWithPosition pos (replace v)

55 replace (PositionedValue pos com v) = PositionedValue pos com <$> rethrowWithPosition pos (replace v)

53 replace other = return other

56 replace other = return other

55− go :: [DoNotationElement] -> SupplyT (Either ErrorStack) Expr

58+ go :: [DoNotationElement] -> m Expr

56 go [] = error "The impossible happened in desugarDo"

59 go [] = error "The impossible happened in desugarDo"

57 go [DoNotationValue val] = return val

60 go [DoNotationValue val] = return val

58 go (DoNotationValue val : rest) = do

61 go (DoNotationValue val : rest) = do

59 rest' <- go rest

62 rest' <- go rest

60 return $ App (App bind val) (Abs (Left (Ident C.__unused)) rest')

63 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

62 go (DoNotationBind NullBinder val : rest) = go (DoNotationValue val : rest)

65 go (DoNotationBind NullBinder val : rest) = go (DoNotationValue val : rest)

63 go (DoNotationBind (VarBinder ident) val : rest) = do

66 go (DoNotationBind (VarBinder ident) val : rest) = do

64 rest' <- go rest

67 rest' <- go rest

@@ -67,7 +70,7 @@ desugarDo d =

67 rest' <- go rest

70 rest' <- go rest

68 ident <- Ident <$> freshName

71 ident <- Ident <$> freshName

69 return $ App (App bind val) (Abs (Left ident) (Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] (Right rest')]))

72 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

71 go (DoNotationLet ds : rest) = do

74 go (DoNotationLet ds : rest) = do

72 rest' <- go rest

75 rest' <- go rest

73 return $ Let ds rest'

76 return $ Let ds rest'

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

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

12--

13-----------------------------------------------------------------------------

15+{-# LANGUAGE FlexibleContexts #-}

16+{-# LANGUAGE ScopedTypeVariables #-}

17+

15module Language.PureScript.Sugar.Names (

18module Language.PureScript.Sugar.Names (

16 desugarImports

19 desugarImports

17) where

20) where

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

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

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

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

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

86--

89--

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

88updateExportedModule env mn update = do

91updateExportedModule env mn update = do

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

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

90 exports' <- update exports

93 exports' <- update exports

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

93-- |

96-- |

94-- Adds an empty module to an ExportEnvironment.

97-- Adds an empty module to an ExportEnvironment.

95--

98--

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

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

97addEmptyModule env name =

100addEmptyModule env name =

98 if name `M.member` env

101 if name `M.member` env

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

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

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

102-- |

105-- |

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

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

104--

107--

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

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

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

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

107 let exTypes = exportedTypes m

110 let exTypes = exportedTypes m

108 let exDctors = snd `concatMap` exTypes

111 let exDctors = snd `concatMap` exTypes

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

117-- |

120-- |

118-- Adds a class to the export environment.

121-- Adds a class to the export environment.

119--

122--

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

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

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

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

122 let exTypes = exportedTypes m

125 let exTypes = exportedTypes m

123 let exDctors = snd `concatMap` exTypes

126 let exDctors = snd `concatMap` exTypes

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

129-- |

132-- |

130-- Adds a class to the export environment.

133-- Adds a class to the export environment.

131--

134--

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

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

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

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

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

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

135 return $ m { exportedValues = values }

138 return $ m { exportedValues = values }

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

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

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

139-- returned.

142-- returned.

140--

143--

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]

142addExport what exports name =

145addExport what exports name =

143 if name `elem` exports

146 if name `elem` exports

144 then throwMultipleDefError what name

147 then throwMultipleDefError what name

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

147-- |

150-- |

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

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

149--

152--

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

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

151desugarImports modules = do

154desugarImports modules = do

152 unfilteredExports <- findExports modules

155 unfilteredExports <- findExports modules

153 exports <- foldM filterModuleExports unfilteredExports modules

156 exports <- foldM filterModuleExports unfilteredExports modules

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

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

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

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

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

159 -- exported.

162 -- exported.

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

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

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

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

162 filterModuleExports env _ = return env

165 filterModuleExports env _ = return env

163

166

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

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

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

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

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

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

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

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

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

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

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

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

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

203-- qualified names are valid.

206-- qualified names are valid.

204--

207--

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

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

206renameInModule imports exports (Module mn decls exps) =

209renameInModule imports exports (Module mn decls exps) =

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

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

208 where

211 where

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

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

210

213

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

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

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

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

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

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

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

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

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

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

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

227 updateDecl s d = return (s, d)

230 updateDecl s d = return (s, d)

228

231

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

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

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

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

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

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

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

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

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

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

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

245 updateValue s v = return (s, v)

248 updateValue s v = return (s, v)

246

249

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

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

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

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

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

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

250 updateBinder s v = return (s, v)

253 updateBinder s v = return (s, v)

251

254

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

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

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

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

254

257

255 letBoundVariable :: Declaration -> Maybe Ident

258 letBoundVariable :: Declaration -> Maybe Ident

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

257 letBoundVariable (PositionedDeclaration _ _ d) = letBoundVariable d

260 letBoundVariable (PositionedDeclaration _ _ d) = letBoundVariable d

258 letBoundVariable _ = Nothing

261 letBoundVariable _ = Nothing

259

262

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

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

261 updateTypesEverywhere pos0 = everywhereOnTypesM (updateType pos0)

264 updateTypesEverywhere pos0 = everywhereOnTypesM (updateType pos0)

262 where

265 where

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

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

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

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

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

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

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

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

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

280 -> (Exports -> a -> Bool)

283 -> (Exports -> a -> Bool)

281 -> Qualified a

284 -> Qualified a

282 -> Maybe SourceSpan

285 -> Maybe SourceSpan

283− -> Either ErrorStack (Qualified a)

286+ -> m (Qualified a)

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

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

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

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

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

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

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

299 Just pos' -> rethrowWithPosition pos' err

302 Just pos' -> rethrowWithPosition pos' err

300

303

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

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

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

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

304

307

305-- |

308-- |

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

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

307--

310--

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

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

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

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

310 where

313 where

311

314

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

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

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

316

319

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

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

319 addModule env (Module mn ds _) = do

322 addModule env (Module mn ds _) = do

320 env' <- addEmptyModule env mn

323 env' <- addEmptyModule env mn

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

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

322

325

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

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

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

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

326 env' <- addTypeClass env mn tcn

329 env' <- addTypeClass env mn tcn

327 foldM go env' ds

330 foldM go env' ds

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

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

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

342-- environment.

345-- environment.

343--

346--

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

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

345filterExports mn exps env = do

348filterExports mn exps env = do

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

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

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

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

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

349 where

352 where

350

353

351 -- Filter the exports for the specific module

354 -- Filter the exports for the specific module

352− filterModule :: Exports -> Either ErrorStack Exports

355+ filterModule :: Exports -> m Exports

353 filterModule exported = do

356 filterModule exported = do

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

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

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

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

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

358

361

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

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

360 -- exports

363 -- exports

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

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

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

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

363 filterTypes expTys result (TypeRef name expDcons) = do

366 filterTypes expTys result (TypeRef name expDcons) = do

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

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

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

367 filterTypes _ result _ = return result

370 filterTypes _ result _ = return result

368

371

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

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

371 filterDcons tcon exps' result name =

374 filterDcons tcon exps' result name =

372 if name `elem` exps'

375 if name `elem` exps'

373 then return $ name : result

376 then return $ name : result

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

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

375

378

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

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

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

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

379 filterClasses exps' result (TypeClassRef name) =

382 filterClasses exps' result (TypeClassRef name) =

380 if name `elem` exps'

383 if name `elem` exps'

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

383 filterClasses _ result _ = return result

386 filterClasses _ result _ = return result

384

387

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

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

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

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

388 filterValues exps' result (ValueRef name) =

391 filterValues exps' result (ValueRef name) =

389 if name `elem` exps'

392 if name `elem` exps'

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

405-- |

408-- |

406-- Constructs a local environment for a module.

409-- Constructs a local environment for a module.

407--

410--

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

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

409resolveImports env (Module currentModule decls _) =

412resolveImports env (Module currentModule decls _) =

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

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

411 where

414 where

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

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

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

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

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

418

421

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

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

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

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

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

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

422 positioned $ resolveImport currentModule mn modExports imp impQual typ

425 positioned $ resolveImport currentModule mn modExports imp impQual typ

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

428-- |

431-- |

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

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

430--

433--

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

432resolveImport currentModule importModule exps imps impQual =

435resolveImport currentModule importModule exps imps impQual =

433 resolveByType

436 resolveByType

434 where

437 where

435

438

436− resolveByType :: ImportDeclarationType -> Either ErrorStack ImportEnvironment

439+ resolveByType :: ImportDeclarationType -> m ImportEnvironment

437 resolveByType Unqualified = importAll importExplicit

440 resolveByType Unqualified = importAll importExplicit

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

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

439 resolveByType (Hiding hiddenImports) = do

442 resolveByType (Hiding hiddenImports) = do

440 hiddenImports' <- checkedRefs hiddenImports

443 hiddenImports' <- checkedRefs hiddenImports

441 importAll (importNonHidden hiddenImports')

444 importAll (importNonHidden hiddenImports')

442

445

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

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

444 importNonHidden hidden m ref =

447 importNonHidden hidden m ref =

445 if isHidden hidden ref

448 if isHidden hidden ref

446 then return m

449 then return m

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

459 isHidden hidden ref = ref `elem` hidden

462 isHidden hidden ref = ref `elem` hidden

460

463

461 -- Import all symbols

464 -- Import all symbols

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

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

463 importAll importer = do

466 importAll importer = do

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

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

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

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

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

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

467

470

468 -- Import something explicitly

471 -- Import something explicitly

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

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

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

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

471 importExplicit imp (ValueRef name) = do

474 importExplicit imp (ValueRef name) = do

472 values' <- updateImports (importedValues imp) name

475 values' <- updateImports (importedValues imp) name

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

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

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

484

487

485 -- Check if DeclarationRef points to an existent symbol

488 -- Check if DeclarationRef points to an existent symbol

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

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

487 checkedRefs = mapM check

490 checkedRefs = mapM check

488 where

491 where

489 check (PositionedDeclarationRef pos _ r) =

492 check (PositionedDeclarationRef pos _ r) =

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

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

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

505

508

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

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

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

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

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

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

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

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

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

521

524

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

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

523 -- from

526 -- from

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

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

525 checkDctorExists = checkImportExists "data constructor"

528 checkDctorExists = checkImportExists "data constructor"

526

529

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

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

529 checkImportExists t exports item =

532 checkImportExists t exports item =

530 if item `elem` exports

533 if item `elem` exports

531 then return item

534 then return item

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

534-- |

537-- |

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

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

536--

539--

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

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

538throwMultipleDefError what name = throwError $

541throwMultipleDefError what name = throwError $

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

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

540

543

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

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

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

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

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

544--

547--

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

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

546throwConflictingDefError what1 what2 name = throwError $

549throwConflictingDefError what1 what2 name = throwError $

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

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

548

551

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

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

12--

13-----------------------------------------------------------------------------

15+{-# LANGUAGE FlexibleContexts #-}

16+{-# LANGUAGE ScopedTypeVariables #-}

17+

15module Language.PureScript.Sugar.ObjectWildcards (

18module Language.PureScript.Sugar.ObjectWildcards (

16 desugarObjectConstructors

19 desugarObjectConstructors

17) where

20) where

19import Control.Applicative

22import Control.Applicative

20import Control.Arrow (second)

23import Control.Arrow (second)

24+import Control.Monad.Error.Class

25+import Control.Monad.Supply.Class

22import Data.List (partition)

27import Data.List (partition)

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

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

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

25import Language.PureScript.AST

30import Language.PureScript.AST

26import Language.PureScript.Errors

31import Language.PureScript.Errors

27import Language.PureScript.Names

32import Language.PureScript.Names

28−import Language.PureScript.Supply

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

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

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

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

32 where

36 where

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

38+ desugarDecl :: Declaration -> m Declaration

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

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

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

41+ desugarExpr :: Expr -> m Expr

38 desugarExpr (ObjectConstructor ps) = wrapLambda ObjectLiteral ps

42 desugarExpr (ObjectConstructor ps) = wrapLambda ObjectLiteral ps

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

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

40 desugarExpr (ObjectUpdater Nothing ps) = do

44 desugarExpr (ObjectUpdater Nothing ps) = do

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

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

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

46 desugarExpr e = return e

50 desugarExpr e = return e

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

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

49 wrapLambda mkVal ps =

53 wrapLambda mkVal ps =

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

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

51 in if null args

55 in if null args

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

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

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

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

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

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

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

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

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

59 mkProp (name, Nothing) = do

63 mkProp (name, Nothing) = do

60 arg <- Ident <$> freshName

64 arg <- Ident <$> freshName

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

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

17--

18-----------------------------------------------------------------------------

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

20+{-# LANGUAGE Rank2Types #-}

21+{-# LANGUAGE FlexibleContexts #-}

22+{-# LANGUAGE ScopedTypeVariables #-}

22module Language.PureScript.Sugar.Operators (

24module Language.PureScript.Sugar.Operators (

23 rebracket,

25 rebracket,

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

28import Language.PureScript.AST

30import Language.PureScript.AST

29import Language.PureScript.Errors

31import Language.PureScript.Errors

30import Language.PureScript.Names

32import Language.PureScript.Names

31−import Language.PureScript.Supply

33import Control.Applicative

34import Control.Applicative

34import Control.Monad.State

35import Control.Monad.State

35import Control.Monad.Except

36import Control.Monad.Except

37+import Control.Monad.Supply.Class

37import Data.Function (on)

39import Data.Function (on)

38import Data.Functor.Identity

40import Data.Functor.Identity

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

47-- |

49-- |

48-- Remove explicit parentheses and reorder binary operator applications

50-- Remove explicit parentheses and reorder binary operator applications

49--

51--

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

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

51rebracket ms = do

53rebracket ms = do

52 let fixities = concatMap collectFixities ms

54 let fixities = concatMap collectFixities ms

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

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

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

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

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

63 go other = other

65 go other = other

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

66rebracketModule opTable (Module mn ds exts) =

68rebracketModule opTable (Module mn ds exts) =

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

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

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

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

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

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

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

84 collect _ = []

86 collect _ = []

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

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

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

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

88 where

90 where

89 go [] = return ()

91 go [] = return ()

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

106

108

107type Chain = [Either Expr Expr]

109type Chain = [Either Expr Expr]

108

110

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

110matchOperators ops = parseChains

112matchOperators ops = parseChains

111 where

113 where

112− parseChains :: Expr -> Either ErrorStack Expr

114+ parseChains :: Expr -> m Expr

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

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

114 parseChains other = return other

116 parseChains other = return other

115 extendChain :: Expr -> Chain

117 extendChain :: Expr -> Chain

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

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

117 extendChain other = [Left other]

119 extendChain other = [Left other]

118− bracketChain :: Chain -> Either ErrorStack Expr

120+ bracketChain :: Chain -> m Expr

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

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

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

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

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

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

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

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

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

149 ident <- parseOp

151 ident <- parseOp

150 guard $ ident == op

152 guard $ ident == op

151

153

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

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

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

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

154 where

156 where

155

157

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

158+ goDecl :: Declaration -> m Declaration

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

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

158

160

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

161+ goExpr :: Expr -> m Expr

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

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

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

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

162 arg <- Ident <$> freshName

164 arg <- Ident <$> freshName

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

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

14--

15-----------------------------------------------------------------------------

17+{-# LANGUAGE FlexibleContexts #-}

18+

17module Language.PureScript.Sugar.TypeClasses

19module Language.PureScript.Sugar.TypeClasses

18 ( desugarTypeClasses

20 ( desugarTypeClasses

19 , typeClassMemberName

21 , typeClassMemberName

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

27import Language.PureScript.Names

29import Language.PureScript.Names

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

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

29import Language.PureScript.Sugar.CaseDeclarations

31import Language.PureScript.Sugar.CaseDeclarations

30−import Language.PureScript.Supply

32+import Control.Monad.Supply.Class

31import Language.PureScript.Types

33import Language.PureScript.Types

33import qualified Language.PureScript.Constants as C

35import qualified Language.PureScript.Constants as C

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

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

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

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

48+type Desugar = StateT MemberMap

48-- |

50-- |

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

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

50-- instance dictionary expressions.

52-- instance dictionary expressions.

51--

53--

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

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

53desugarTypeClasses = flip evalStateT M.empty . mapM desugarModule

55desugarTypeClasses = flip evalStateT M.empty . mapM desugarModule

55−desugarModule :: Module -> Desugar Module

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

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

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

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

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

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

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

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

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

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

153-- };

155-- };

154-}

156-}

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

156desugarDecl mn exps = go

158desugarDecl mn exps = go

157 where

159 where

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

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

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

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

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

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

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

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

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

163− desugared <- lift $ desugarCases members

165+ desugared <- desugarCases members

164 dictDecl <- typeInstanceDictionaryDeclaration name mn deps className tys desugared

166 dictDecl <- typeInstanceDictionaryDeclaration name mn deps className tys desugared

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

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

166 go (PositionedDeclaration pos com d) = do

168 go (PositionedDeclaration pos com d) = do

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

222unit :: Type

224unit :: Type

223unit = TypeApp tyObject REmpty

225unit = TypeApp tyObject REmpty

224

226

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

226typeInstanceDictionaryDeclaration name mn deps className tys decls =

228typeInstanceDictionaryDeclaration name mn deps className tys decls =

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

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

228 m <- get

230 m <- get

229

231

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

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

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

233+ (TypeClassDeclaration _ args implies tyDecls) <-

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

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

233 M.lookup (qualify mn className) m

235 M.lookup (qualify mn className) m

234

236

235 case mapMaybe declName tyDecls \\ mapMaybe declName decls of

237 case mapMaybe declName tyDecls \\ mapMaybe declName decls of

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

268 declName (TypeDeclaration ident _) = Just ident

270 declName (TypeDeclaration ident _) = Just ident

269 declName _ = Nothing

271 declName _ = Nothing

270

272

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

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

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

274 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'

274 return val

276 return val

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

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

276 val <- memberToValue tys' d

278 val <- memberToValue tys' d

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

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

14--

15-----------------------------------------------------------------------------

17+{-# LANGUAGE FlexibleContexts #-}

18+

17module Language.PureScript.Sugar.TypeDeclarations (

19module Language.PureScript.Sugar.TypeDeclarations (

18 desugarTypeDeclarations,

20 desugarTypeDeclarations,

19 desugarTypeDeclarationsModule

21 desugarTypeDeclarationsModule

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

22import Control.Applicative

24import Control.Applicative

23import Control.Monad (forM)

25import Control.Monad (forM)

24import Control.Monad.Except (throwError)

26import Control.Monad.Except (throwError)

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

26import Language.PureScript.AST

29import Language.PureScript.AST

27import Language.PureScript.Names

30import Language.PureScript.Names

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

32-- |

35-- |

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

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

34--

37--

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

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

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

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

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

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

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

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

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

40-- |

43-- |

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

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

42--

45--

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

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

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

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

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

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

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

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

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

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

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

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

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

50 where

53 where

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

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

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

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

53 fromValueDeclaration (PositionedDeclaration pos com d') = do

56 fromValueDeclaration (PositionedDeclaration pos com d') = do

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

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