e5655c8 · rowtype-yoga/purescript-native

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

on golang help sign in

Use generic Literal in the AST

e5655c8Gary Burgess11 years ago

psci/PSCi.hs+1−1

compare with golang

unifiedsplit

@@ -214,7 +214,7 @@ handleDecls :: [P.Declaration] -> PSCI ()

214handleDecls ds = do

215 st <- PSCI $ lift get

216 let st' = updateLets ds st

217− let m = createTemporaryModule False st' (P.ObjectLiteral [])

217+ let m = createTemporaryModule False st' (P.Literal (P.ObjectLiteral []))

218 e <- psciIO . runMake $ make st' [m]

219 case e of

220 Left err -> PSCI $ printErrors err

purescript.cabal+1−1

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

96 Language.PureScript.AST.Binders

97 Language.PureScript.AST.Declarations

98 Language.PureScript.AST.Operators

99+ Language.PureScript.AST.Literals

99 Language.PureScript.AST.SourcePos

100 Language.PureScript.AST.SourcePos

100 Language.PureScript.AST.Traversals

101 Language.PureScript.AST.Traversals

101 Language.PureScript.AST.Exported

102 Language.PureScript.AST.Exported

@@ -119,7 +120,6 @@ library

119 Language.PureScript.CoreFn.Binders

120 Language.PureScript.CoreFn.Binders

120 Language.PureScript.CoreFn.Desugar

121 Language.PureScript.CoreFn.Desugar

121 Language.PureScript.CoreFn.Expr

122 Language.PureScript.CoreFn.Expr

122− Language.PureScript.CoreFn.Literals

123 Language.PureScript.CoreFn.Meta

124 Language.PureScript.CoreFn.Module

125 Language.PureScript.CoreFn.Traversals

src/Language/PureScript/AST.hs+4−14

@@ -1,24 +1,14 @@

1−-----------------------------------------------------------------------------

1+-- |

2+-- The initial PureScript AST

2--

3--

3−-- Module : Language.PureScript.AST

5−-- License : MIT

6−--

7−-- Maintainer : Phil Freeman <paf31@cantab.net>

8−-- Stability : experimental

9−-- Portability :

10−--

11−-- | The initial PureScript AST

12−--

13−-----------------------------------------------------------------------------

14−

15module Language.PureScript.AST (

4module Language.PureScript.AST (

16 module AST

5 module AST

17) where

6) where

19import Language.PureScript.AST.Binders as AST

8import Language.PureScript.AST.Binders as AST

20import Language.PureScript.AST.Declarations as AST

9import Language.PureScript.AST.Declarations as AST

10+import Language.PureScript.AST.Exported as AST

11+import Language.PureScript.AST.Literals as AST

21import Language.PureScript.AST.Operators as AST

12import Language.PureScript.AST.Operators as AST

22import Language.PureScript.AST.SourcePos as AST

13import Language.PureScript.AST.SourcePos as AST

23import Language.PureScript.AST.Traversals as AST

14import Language.PureScript.AST.Traversals as AST

24−import Language.PureScript.AST.Exported as AST

src/Language/PureScript/AST/Binders.hs+7−24

@@ -4,6 +4,7 @@

4module Language.PureScript.AST.Binders where

6import Language.PureScript.AST.SourcePos

7+import Language.PureScript.AST.Literals

7import Language.PureScript.Names

8import Language.PureScript.Names

8import Language.PureScript.Comments

9import Language.PureScript.Comments

9import Language.PureScript.Types

10import Language.PureScript.Types

@@ -17,21 +18,9 @@ data Binder

17 --

18 --

18 = NullBinder

19 = NullBinder

19 -- |

20 -- |

20− -- A binder which matches a boolean literal

21+ -- A binder which matches a literal

21 --

22 --

22− | BooleanBinder Bool

23+ | LiteralBinder (Literal Binder)

23− -- |

24− -- A binder which matches a string literal

25− --

26− | StringBinder String

27− -- |

28− -- A binder which matches a character literal

29− --

30− | CharBinder Char

31− -- |

32− -- A binder which matches a numeric literal

33− --

34− | NumberBinder (Either Integer Double)

35 -- |

24 -- |

36 -- A binder which binds an identifier

25 -- A binder which binds an identifier

37 --

26 --

@@ -59,14 +48,6 @@ data Binder

59 --

48 --

60 | ParensInBinder Binder

49 | ParensInBinder Binder

61 -- |

50 -- |

62− -- A binder which matches a record and binds its properties

63− --

64− | ObjectBinder [(String, Binder)]

65− -- |

66− -- A binder which matches an array and binds its elements

67− --

68− | ArrayBinder [Binder]

69− -- |

70 -- A binder which binds its input to an identifier

51 -- A binder which binds its input to an identifier

71 --

52 --

72 | NamedBinder Ident Binder

53 | NamedBinder Ident Binder

@@ -86,13 +67,15 @@ data Binder

86binderNames :: Binder -> [Ident]

67binderNames :: Binder -> [Ident]

87binderNames = go []

68binderNames = go []

88 where

69 where

70+ go ns (LiteralBinder b) = lit ns b

89 go ns (VarBinder name) = name : ns

71 go ns (VarBinder name) = name : ns

90 go ns (ConstructorBinder _ bs) = foldl go ns bs

72 go ns (ConstructorBinder _ bs) = foldl go ns bs

91 go ns (BinaryNoParensBinder b1 b2 b3) = foldl go ns [b1, b2, b3]

73 go ns (BinaryNoParensBinder b1 b2 b3) = foldl go ns [b1, b2, b3]

92 go ns (ParensInBinder b) = go ns b

74 go ns (ParensInBinder b) = go ns b

93− go ns (ObjectBinder bs) = foldl go ns (map snd bs)

94− go ns (ArrayBinder bs) = foldl go ns bs

95 go ns (NamedBinder name b) = go (name : ns) b

75 go ns (NamedBinder name b) = go (name : ns) b

96 go ns (PositionedBinder _ _ b) = go ns b

76 go ns (PositionedBinder _ _ b) = go ns b

97 go ns (TypedBinder _ b) = go ns b

77 go ns (TypedBinder _ b) = go ns b

98 go ns _ = ns

78 go ns _ = ns

79+ lit ns (ObjectLiteral bs) = foldl go ns (map snd bs)

80+ lit ns (ArrayLiteral bs) = foldl go ns bs

81+ lit ns _ = ns

src/Language/PureScript/AST/Declarations.hs+3−22

@@ -19,6 +19,7 @@ import qualified Data.Map as M

19import Control.Monad.Identity

21import Language.PureScript.AST.Binders

22+import Language.PureScript.AST.Literals

22import Language.PureScript.AST.Operators

23import Language.PureScript.AST.Operators

23import Language.PureScript.AST.SourcePos

24import Language.PureScript.AST.SourcePos

24import Language.PureScript.Types

25import Language.PureScript.Types

@@ -309,21 +310,9 @@ type Guard = Expr

309--

310--

310data Expr

311data Expr

311 -- |

312 -- |

312− -- A numeric literal

313+ -- A literal value

313 --

314 --

314− = NumericLiteral (Either Integer Double)

315+ = Literal (Literal Expr)

315− -- |

316− -- A string literal

317− --

318− | StringLiteral String

319− -- |

320− -- A character literal

321− --

322− | CharLiteral Char

323− -- |

324− -- A boolean literal

325− --

326− | BooleanLiteral Bool

327 -- |

316 -- |

328 -- A prefix -, will be desugared

317 -- A prefix -, will be desugared

329 --

318 --

@@ -347,14 +336,6 @@ data Expr

347 --

336 --

348 | OperatorSection Expr (Either Expr Expr)

337 | OperatorSection Expr (Either Expr Expr)

349 -- |

338 -- |

350− -- An array literal

351− --

352− | ArrayLiteral [Expr]

353− -- |

354− -- An object literal

355− --

356− | ObjectLiteral [(String, Expr)]

357− -- |

358 -- An object property getter (e.g. `_.x`). This will be removed during

339 -- An object property getter (e.g. `_.x`). This will be removed during

359 -- desugaring and expanded into a lambda that reads a property from an object.

340 -- desugaring and expanded into a lambda that reads a property from an object.

360 --

341 --

src/Language/PureScript/CoreFn/Literals.hs → src/Language/PureScript/AST/Literals.hsrenamed+2−2

@@ -3,7 +3,7 @@

3-- |

4-- The core functional representation for literal values.

5--

6−module Language.PureScript.CoreFn.Literals where

6+module Language.PureScript.AST.Literals where

8-- |

9-- Data type for literal values. Parameterised so it can be used for Exprs and

@@ -34,4 +34,4 @@ data Literal a

34 -- An object literal

35 --

36 | ObjectLiteral [(String, a)]

37− deriving (Show, Read, Functor)

37+ deriving (Eq, Ord, Show, Read, Functor)

src/Language/PureScript/AST/Traversals.hs+195−105

@@ -1,17 +1,8 @@

1−-----------------------------------------------------------------------------

1+{-# LANGUAGE ScopedTypeVariables #-}

2−--

3−-- Module : Language.PureScript.AST.Traversals

5−-- License : MIT

6−--

7−-- Maintainer : Phil Freeman <paf31@cantab.net>

8−-- Stability : experimental

9−-- Portability :

10−--

11−-- | AST traversal helpers

12−--

13−-----------------------------------------------------------------------------

3+-- |

4+-- AST traversal helpers

5+--

15module Language.PureScript.AST.Traversals where

6module Language.PureScript.AST.Traversals where

17import Prelude ()

8import Prelude ()

@@ -26,15 +17,20 @@ import Control.Monad

26import Control.Arrow ((***), (+++))

17import Control.Arrow ((***), (+++))

28import Language.PureScript.AST.Binders

19import Language.PureScript.AST.Binders

20+import Language.PureScript.AST.Literals

29import Language.PureScript.AST.Declarations

21import Language.PureScript.AST.Declarations

30import Language.PureScript.Types

22import Language.PureScript.Types

31import Language.PureScript.Traversals

23import Language.PureScript.Traversals

32import Language.PureScript.Names

24import Language.PureScript.Names

26+everywhereOnValues

34−everywhereOnValues :: (Declaration -> Declaration) ->

27+ :: (Declaration -> Declaration)

35− (Expr -> Expr) ->

28+ -> (Expr -> Expr)

36− (Binder -> Binder) ->

29+ -> (Binder -> Binder)

37− (Declaration -> Declaration, Expr -> Expr, Binder -> Binder)

30+ -> ( Declaration -> Declaration

31+ , Expr -> Expr

32+ , Binder -> Binder

33+ )

38everywhereOnValues f g h = (f', g', h')

34everywhereOnValues f g h = (f', g', h')

39 where

35 where

40 f' :: Declaration -> Declaration

36 f' :: Declaration -> Declaration

@@ -47,13 +43,12 @@ everywhereOnValues f g h = (f', g', h')

47 f' other = f other

43 f' other = f other

49 g' :: Expr -> Expr

45 g' :: Expr -> Expr

46+ g' (Literal l) = g (Literal (lit g' l))

50 g' (UnaryMinus v) = g (UnaryMinus (g' v))

47 g' (UnaryMinus v) = g (UnaryMinus (g' v))

51 g' (BinaryNoParens op v1 v2) = g (BinaryNoParens (g' op) (g' v1) (g' v2))

48 g' (BinaryNoParens op v1 v2) = g (BinaryNoParens (g' op) (g' v1) (g' v2))

52 g' (Parens v) = g (Parens (g' v))

49 g' (Parens v) = g (Parens (g' v))

53 g' (OperatorSection op (Left v)) = g (OperatorSection (g' op) (Left $ g' v))

50 g' (OperatorSection op (Left v)) = g (OperatorSection (g' op) (Left $ g' v))

54 g' (OperatorSection op (Right v)) = g (OperatorSection (g' op) (Right $ g' v))

51 g' (OperatorSection op (Right v)) = g (OperatorSection (g' op) (Right $ g' v))

55− g' (ArrayLiteral vs) = g (ArrayLiteral (map g' vs))

56− g' (ObjectLiteral vs) = g (ObjectLiteral (map (fmap g') vs))

57 g' (TypeClassDictionaryConstructorApp name v) = g (TypeClassDictionaryConstructorApp name (g' v))

52 g' (TypeClassDictionaryConstructorApp name v) = g (TypeClassDictionaryConstructorApp name (g' v))

58 g' (Accessor prop v) = g (Accessor prop (g' v))

53 g' (Accessor prop v) = g (Accessor prop (g' v))

59 g' (ObjectUpdate obj vs) = g (ObjectUpdate (g' obj) (map (fmap g') vs))

54 g' (ObjectUpdate obj vs) = g (ObjectUpdate (g' obj) (map (fmap g') vs))

@@ -71,13 +66,17 @@ everywhereOnValues f g h = (f', g', h')

71 h' (ConstructorBinder ctor bs) = h (ConstructorBinder ctor (map h' bs))

66 h' (ConstructorBinder ctor bs) = h (ConstructorBinder ctor (map h' bs))

72 h' (BinaryNoParensBinder b1 b2 b3) = h (BinaryNoParensBinder (h' b1) (h' b2) (h' b3))

67 h' (BinaryNoParensBinder b1 b2 b3) = h (BinaryNoParensBinder (h' b1) (h' b2) (h' b3))

73 h' (ParensInBinder b) = h (ParensInBinder (h' b))

68 h' (ParensInBinder b) = h (ParensInBinder (h' b))

74− h' (ObjectBinder bs) = h (ObjectBinder (map (fmap h') bs))

69+ h' (LiteralBinder l) = h (LiteralBinder (lit h' l))

75− h' (ArrayBinder bs) = h (ArrayBinder (map h' bs))

76 h' (NamedBinder name b) = h (NamedBinder name (h' b))

70 h' (NamedBinder name b) = h (NamedBinder name (h' b))

77 h' (PositionedBinder pos com b) = h (PositionedBinder pos com (h' b))

71 h' (PositionedBinder pos com b) = h (PositionedBinder pos com (h' b))

78 h' (TypedBinder t b) = h (TypedBinder t (h' b))

72 h' (TypedBinder t b) = h (TypedBinder t (h' b))

79 h' other = h other

73 h' other = h other

75+ lit :: (a -> a) -> Literal a -> Literal a

76+ lit go (ArrayLiteral as) = ArrayLiteral (map go as)

77+ lit go (ObjectLiteral as) = ObjectLiteral (map (fmap go) as)

78+ lit _ other = other

79+

81 handleCaseAlternative :: CaseAlternative -> CaseAlternative

80 handleCaseAlternative :: CaseAlternative -> CaseAlternative

82 handleCaseAlternative ca =

81 handleCaseAlternative ca =

83 ca { caseAlternativeBinders = map h' (caseAlternativeBinders ca)

82 ca { caseAlternativeBinders = map h' (caseAlternativeBinders ca)

@@ -90,13 +89,20 @@ everywhereOnValues f g h = (f', g', h')

90 handleDoNotationElement (DoNotationLet ds) = DoNotationLet (map f' ds)

89 handleDoNotationElement (DoNotationLet ds) = DoNotationLet (map f' ds)

91 handleDoNotationElement (PositionedDoNotationElement pos com e) = PositionedDoNotationElement pos com (handleDoNotationElement e)

90 handleDoNotationElement (PositionedDoNotationElement pos com e) = PositionedDoNotationElement pos com (handleDoNotationElement e)

93−everywhereOnValuesTopDownM :: (Functor m, Applicative m, Monad m) =>

92+everywhereOnValuesTopDownM

93+ :: forall m

94+ . (Functor m, Applicative m, Monad m)

94− (Declaration -> m Declaration) ->

95+ => (Declaration -> m Declaration)

95− (Expr -> m Expr) ->

96+ -> (Expr -> m Expr)

96− (Binder -> m Binder) ->

97+ -> (Binder -> m Binder)

97− (Declaration -> m Declaration, Expr -> m Expr, Binder -> m Binder)

98+ -> ( Declaration -> m Declaration

99+ , Expr -> m Expr

100+ , Binder -> m Binder

101+ )

98everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)

102everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)

99 where

103 where

104+

105+ f' :: Declaration -> m Declaration

100 f' (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> traverse (f' <=< f) ds

106 f' (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> traverse (f' <=< f) ds

101 f' (ValueDeclaration name nameKind bs val) = ValueDeclaration name nameKind <$> traverse (h' <=< h) bs <*> eitherM (traverse (pairM (g' <=< g) (g' <=< g))) (g' <=< g) val

107 f' (ValueDeclaration name nameKind bs val) = ValueDeclaration name nameKind <$> traverse (h' <=< h) bs <*> eitherM (traverse (pairM (g' <=< g) (g' <=< g))) (g' <=< g) val

102 f' (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> traverse (\(name, nameKind, val) -> (,,) name nameKind <$> (g val >>= g')) ds

108 f' (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> traverse (\(name, nameKind, val) -> (,,) name nameKind <$> (g val >>= g')) ds

@@ -105,13 +111,13 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)

105 f' (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> (f d >>= f')

111 f' (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> (f d >>= f')

106 f' other = f other

112 f' other = f other

107

113

114+ g' :: Expr -> m Expr

115+ g' (Literal l) = Literal <$> lit (g >=> g') l

108 g' (UnaryMinus v) = UnaryMinus <$> (g v >>= g')

116 g' (UnaryMinus v) = UnaryMinus <$> (g v >>= g')

109 g' (BinaryNoParens op v1 v2) = BinaryNoParens <$> (g op >>= g') <*> (g v1 >>= g') <*> (g v2 >>= g')

117 g' (BinaryNoParens op v1 v2) = BinaryNoParens <$> (g op >>= g') <*> (g v1 >>= g') <*> (g v2 >>= g')

110 g' (Parens v) = Parens <$> (g v >>= g')

118 g' (Parens v) = Parens <$> (g v >>= g')

111 g' (OperatorSection op (Left v)) = OperatorSection <$> (g op >>= g') <*> (Left <$> (g v >>= g'))

119 g' (OperatorSection op (Left v)) = OperatorSection <$> (g op >>= g') <*> (Left <$> (g v >>= g'))

112 g' (OperatorSection op (Right v)) = OperatorSection <$> (g op >>= g') <*> (Right <$> (g v >>= g'))

120 g' (OperatorSection op (Right v)) = OperatorSection <$> (g op >>= g') <*> (Right <$> (g v >>= g'))

113− g' (ArrayLiteral vs) = ArrayLiteral <$> traverse (g' <=< g) vs

114− g' (ObjectLiteral vs) = ObjectLiteral <$> traverse (sndM (g' <=< g)) vs

115 g' (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> (g v >>= g')

121 g' (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> (g v >>= g')

116 g' (Accessor prop v) = Accessor prop <$> (g v >>= g')

122 g' (Accessor prop v) = Accessor prop <$> (g v >>= g')

117 g' (ObjectUpdate obj vs) = ObjectUpdate <$> (g obj >>= g') <*> traverse (sndM (g' <=< g)) vs

123 g' (ObjectUpdate obj vs) = ObjectUpdate <$> (g obj >>= g') <*> traverse (sndM (g' <=< g)) vs

@@ -125,31 +131,47 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)

125 g' (PositionedValue pos com v) = PositionedValue pos com <$> (g v >>= g')

131 g' (PositionedValue pos com v) = PositionedValue pos com <$> (g v >>= g')

126 g' other = g other

132 g' other = g other

127

133

134+ h' :: Binder -> m Binder

135+ h' (LiteralBinder l) = LiteralBinder <$> lit (h >=> h') l

128 h' (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> traverse (h' <=< h) bs

136 h' (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> traverse (h' <=< h) bs

129 h' (BinaryNoParensBinder b1 b2 b3) = BinaryNoParensBinder <$> (h b1 >>= h') <*> (h b2 >>= h') <*> (h b3 >>= h')

137 h' (BinaryNoParensBinder b1 b2 b3) = BinaryNoParensBinder <$> (h b1 >>= h') <*> (h b2 >>= h') <*> (h b3 >>= h')

130 h' (ParensInBinder b) = ParensInBinder <$> (h b >>= h')

138 h' (ParensInBinder b) = ParensInBinder <$> (h b >>= h')

131− h' (ObjectBinder bs) = ObjectBinder <$> traverse (sndM (h' <=< h)) bs

132− h' (ArrayBinder bs) = ArrayBinder <$> traverse (h' <=< h) bs

133 h' (NamedBinder name b) = NamedBinder name <$> (h b >>= h')

139 h' (NamedBinder name b) = NamedBinder name <$> (h b >>= h')

134 h' (PositionedBinder pos com b) = PositionedBinder pos com <$> (h b >>= h')

140 h' (PositionedBinder pos com b) = PositionedBinder pos com <$> (h b >>= h')

135 h' (TypedBinder t b) = TypedBinder t <$> (h b >>= h')

141 h' (TypedBinder t b) = TypedBinder t <$> (h b >>= h')

136 h' other = h other

142 h' other = h other

137

143

144+ lit :: (a -> m a) -> Literal a -> m (Literal a)

145+ lit go (ObjectLiteral as) = ObjectLiteral <$> traverse (sndM go) as

146+ lit go (ArrayLiteral as) = ArrayLiteral <$> traverse go as

147+ lit _ other = pure other

148+

149+ handleCaseAlternative :: CaseAlternative -> m CaseAlternative

138− handleCaseAlternative (CaseAlternative bs val) = CaseAlternative <$> traverse (h' <=< h) bs

150+ handleCaseAlternative (CaseAlternative bs val) =

151+ CaseAlternative

152+ <$> traverse (h' <=< h) bs

139− <*> eitherM (traverse (pairM (g' <=< g) (g' <=< g))) (g' <=< g) val

153+ <*> eitherM (traverse (pairM (g' <=< g) (g' <=< g))) (g' <=< g) val

140

154

155+ handleDoNotationElement :: DoNotationElement -> m DoNotationElement

141 handleDoNotationElement (DoNotationValue v) = DoNotationValue <$> (g' <=< g) v

156 handleDoNotationElement (DoNotationValue v) = DoNotationValue <$> (g' <=< g) v

142 handleDoNotationElement (DoNotationBind b v) = DoNotationBind <$> (h' <=< h) b <*> (g' <=< g) v

157 handleDoNotationElement (DoNotationBind b v) = DoNotationBind <$> (h' <=< h) b <*> (g' <=< g) v

143 handleDoNotationElement (DoNotationLet ds) = DoNotationLet <$> traverse (f' <=< f) ds

158 handleDoNotationElement (DoNotationLet ds) = DoNotationLet <$> traverse (f' <=< f) ds

144 handleDoNotationElement (PositionedDoNotationElement pos com e) = PositionedDoNotationElement pos com <$> handleDoNotationElement e

159 handleDoNotationElement (PositionedDoNotationElement pos com e) = PositionedDoNotationElement pos com <$> handleDoNotationElement e

145

160

161+everywhereOnValuesM

162+ :: forall m

146−everywhereOnValuesM :: (Functor m, Applicative m, Monad m) =>

163+ . (Functor m, Applicative m, Monad m)

147− (Declaration -> m Declaration) ->

164+ => (Declaration -> m Declaration)

148− (Expr -> m Expr) ->

165+ -> (Expr -> m Expr)

149− (Binder -> m Binder) ->

166+ -> (Binder -> m Binder)

150− (Declaration -> m Declaration, Expr -> m Expr, Binder -> m Binder)

167+ -> ( Declaration -> m Declaration

168+ , Expr -> m Expr

169+ , Binder -> m Binder

170+ )

151everywhereOnValuesM f g h = (f', g', h')

171everywhereOnValuesM f g h = (f', g', h')

152 where

172 where

173+

174+ f' :: Declaration -> m Declaration

153 f' (DataBindingGroupDeclaration ds) = (DataBindingGroupDeclaration <$> traverse f' ds) >>= f

175 f' (DataBindingGroupDeclaration ds) = (DataBindingGroupDeclaration <$> traverse f' ds) >>= f

154 f' (ValueDeclaration name nameKind bs val) = (ValueDeclaration name nameKind <$> traverse h' bs <*> eitherM (traverse (pairM g' g')) g' val) >>= f

176 f' (ValueDeclaration name nameKind bs val) = (ValueDeclaration name nameKind <$> traverse h' bs <*> eitherM (traverse (pairM g' g')) g' val) >>= f

155 f' (BindingGroupDeclaration ds) = (BindingGroupDeclaration <$> traverse (\(name, nameKind, val) -> (,,) name nameKind <$> g' val) ds) >>= f

177 f' (BindingGroupDeclaration ds) = (BindingGroupDeclaration <$> traverse (\(name, nameKind, val) -> (,,) name nameKind <$> g' val) ds) >>= f

@@ -158,13 +180,13 @@ everywhereOnValuesM f g h = (f', g', h')

158 f' (PositionedDeclaration pos com d) = (PositionedDeclaration pos com <$> f' d) >>= f

180 f' (PositionedDeclaration pos com d) = (PositionedDeclaration pos com <$> f' d) >>= f

159 f' other = f other

181 f' other = f other

160

182

183+ g' :: Expr -> m Expr

184+ g' (Literal l) = (Literal <$> lit g' l) >>= g

161 g' (UnaryMinus v) = (UnaryMinus <$> g' v) >>= g

185 g' (UnaryMinus v) = (UnaryMinus <$> g' v) >>= g

162 g' (BinaryNoParens op v1 v2) = (BinaryNoParens <$> g' op <*> g' v1 <*> g' v2) >>= g

186 g' (BinaryNoParens op v1 v2) = (BinaryNoParens <$> g' op <*> g' v1 <*> g' v2) >>= g

163 g' (Parens v) = (Parens <$> g' v) >>= g

187 g' (Parens v) = (Parens <$> g' v) >>= g

164 g' (OperatorSection op (Left v)) = (OperatorSection <$> g' op <*> (Left <$> g' v)) >>= g

188 g' (OperatorSection op (Left v)) = (OperatorSection <$> g' op <*> (Left <$> g' v)) >>= g

165 g' (OperatorSection op (Right v)) = (OperatorSection <$> g' op <*> (Right <$> g' v)) >>= g

189 g' (OperatorSection op (Right v)) = (OperatorSection <$> g' op <*> (Right <$> g' v)) >>= g

166− g' (ArrayLiteral vs) = (ArrayLiteral <$> traverse g' vs) >>= g

167− g' (ObjectLiteral vs) = (ObjectLiteral <$> traverse (sndM g') vs) >>= g

168 g' (TypeClassDictionaryConstructorApp name v) = (TypeClassDictionaryConstructorApp name <$> g' v) >>= g

190 g' (TypeClassDictionaryConstructorApp name v) = (TypeClassDictionaryConstructorApp name <$> g' v) >>= g

169 g' (Accessor prop v) = (Accessor prop <$> g' v) >>= g

191 g' (Accessor prop v) = (Accessor prop <$> g' v) >>= g

170 g' (ObjectUpdate obj vs) = (ObjectUpdate <$> g' obj <*> traverse (sndM g') vs) >>= g

192 g' (ObjectUpdate obj vs) = (ObjectUpdate <$> g' obj <*> traverse (sndM g') vs) >>= g

@@ -178,33 +200,51 @@ everywhereOnValuesM f g h = (f', g', h')

178 g' (PositionedValue pos com v) = (PositionedValue pos com <$> g' v) >>= g

200 g' (PositionedValue pos com v) = (PositionedValue pos com <$> g' v) >>= g

179 g' other = g other

201 g' other = g other

180

202

203+ h' :: Binder -> m Binder

204+ h' (LiteralBinder l) = (LiteralBinder <$> lit h' l) >>= h

181 h' (ConstructorBinder ctor bs) = (ConstructorBinder ctor <$> traverse h' bs) >>= h

205 h' (ConstructorBinder ctor bs) = (ConstructorBinder ctor <$> traverse h' bs) >>= h

182 h' (BinaryNoParensBinder b1 b2 b3) = (BinaryNoParensBinder <$> h' b1 <*> h' b2 <*> h' b3) >>= h

206 h' (BinaryNoParensBinder b1 b2 b3) = (BinaryNoParensBinder <$> h' b1 <*> h' b2 <*> h' b3) >>= h

183 h' (ParensInBinder b) = (ParensInBinder <$> h' b) >>= h

207 h' (ParensInBinder b) = (ParensInBinder <$> h' b) >>= h

184− h' (ObjectBinder bs) = (ObjectBinder <$> traverse (sndM h') bs) >>= h

185− h' (ArrayBinder bs) = (ArrayBinder <$> traverse h' bs) >>= h

186 h' (NamedBinder name b) = (NamedBinder name <$> h' b) >>= h

208 h' (NamedBinder name b) = (NamedBinder name <$> h' b) >>= h

187 h' (PositionedBinder pos com b) = (PositionedBinder pos com <$> h' b) >>= h

209 h' (PositionedBinder pos com b) = (PositionedBinder pos com <$> h' b) >>= h

188 h' (TypedBinder t b) = (TypedBinder t <$> h' b) >>= h

210 h' (TypedBinder t b) = (TypedBinder t <$> h' b) >>= h

189 h' other = h other

211 h' other = h other

190

212

191− handleCaseAlternative (CaseAlternative bs val) = CaseAlternative <$> traverse h' bs

213+ lit :: (a -> m a) -> Literal a -> m (Literal a)

214+ lit go (ObjectLiteral as) = ObjectLiteral <$> traverse (sndM go) as

215+ lit go (ArrayLiteral as) = ArrayLiteral <$> traverse go as

216+ lit _ other = pure other

217+

218+ handleCaseAlternative :: CaseAlternative -> m CaseAlternative

219+ handleCaseAlternative (CaseAlternative bs val) =

220+ CaseAlternative

221+ <$> traverse h' bs

192− <*> eitherM (traverse (pairM g' g')) g' val

222+ <*> eitherM (traverse (pairM g' g')) g' val

193

223

224+ handleDoNotationElement :: DoNotationElement -> m DoNotationElement

194 handleDoNotationElement (DoNotationValue v) = DoNotationValue <$> g' v

225 handleDoNotationElement (DoNotationValue v) = DoNotationValue <$> g' v

195 handleDoNotationElement (DoNotationBind b v) = DoNotationBind <$> h' b <*> g' v

226 handleDoNotationElement (DoNotationBind b v) = DoNotationBind <$> h' b <*> g' v

196 handleDoNotationElement (DoNotationLet ds) = DoNotationLet <$> traverse f' ds

227 handleDoNotationElement (DoNotationLet ds) = DoNotationLet <$> traverse f' ds

197 handleDoNotationElement (PositionedDoNotationElement pos com e) = PositionedDoNotationElement pos com <$> handleDoNotationElement e

228 handleDoNotationElement (PositionedDoNotationElement pos com e) = PositionedDoNotationElement pos com <$> handleDoNotationElement e

198

229

199−everythingOnValues :: (r -> r -> r) ->

230+everythingOnValues

231+ :: forall r

232+ . (r -> r -> r)

200− (Declaration -> r) ->

233+ -> (Declaration -> r)

201− (Expr -> r) ->

234+ -> (Expr -> r)

202− (Binder -> r) ->

235+ -> (Binder -> r)

203− (CaseAlternative -> r) ->

236+ -> (CaseAlternative -> r)

204− (DoNotationElement -> r) ->

237+ -> (DoNotationElement -> r)

238+ -> ( Declaration -> r

239+ , Expr -> r

240+ , Binder -> r

241+ , CaseAlternative -> r

205− (Declaration -> r, Expr -> r, Binder -> r, CaseAlternative -> r, DoNotationElement -> r)

242+ , DoNotationElement -> r

243+ )

206everythingOnValues (<>) f g h i j = (f', g', h', i', j')

244everythingOnValues (<>) f g h i j = (f', g', h', i', j')

207 where

245 where

246+

247+ f' :: Declaration -> r

208 f' d@(DataBindingGroupDeclaration ds) = foldl (<>) (f d) (map f' ds)

248 f' d@(DataBindingGroupDeclaration ds) = foldl (<>) (f d) (map f' ds)

209 f' d@(ValueDeclaration _ _ bs (Right val)) = foldl (<>) (f d) (map h' bs) <> g' val

249 f' d@(ValueDeclaration _ _ bs (Right val)) = foldl (<>) (f d) (map h' bs) <> g' val

210 f' d@(ValueDeclaration _ _ bs (Left gs)) = foldl (<>) (f d) (map h' bs ++ concatMap (\(grd, val) -> [g' grd, g' val]) gs)

250 f' d@(ValueDeclaration _ _ bs (Left gs)) = foldl (<>) (f d) (map h' bs ++ concatMap (\(grd, val) -> [g' grd, g' val]) gs)

@@ -214,13 +254,13 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j')

214 f' d@(PositionedDeclaration _ _ d1) = f d <> f' d1

254 f' d@(PositionedDeclaration _ _ d1) = f d <> f' d1

215 f' d = f d

255 f' d = f d

216

256

257+ g' :: Expr -> r

258+ g' v@(Literal l) = lit (g v) g' l

217 g' v@(UnaryMinus v1) = g v <> g' v1

259 g' v@(UnaryMinus v1) = g v <> g' v1

218 g' v@(BinaryNoParens op v1 v2) = g v <> g' op <> g' v1 <> g' v2

260 g' v@(BinaryNoParens op v1 v2) = g v <> g' op <> g' v1 <> g' v2

219 g' v@(Parens v1) = g v <> g' v1

261 g' v@(Parens v1) = g v <> g' v1

220 g' v@(OperatorSection op (Left v1)) = g v <> g' op <> g' v1

262 g' v@(OperatorSection op (Left v1)) = g v <> g' op <> g' v1

221 g' v@(OperatorSection op (Right v1)) = g v <> g' op <> g' v1

263 g' v@(OperatorSection op (Right v1)) = g v <> g' op <> g' v1

222− g' v@(ArrayLiteral vs) = foldl (<>) (g v) (map g' vs)

223− g' v@(ObjectLiteral vs) = foldl (<>) (g v) (map (g' . snd) vs)

224 g' v@(TypeClassDictionaryConstructorApp _ v1) = g v <> g' v1

264 g' v@(TypeClassDictionaryConstructorApp _ v1) = g v <> g' v1

225 g' v@(Accessor _ v1) = g v <> g' v1

265 g' v@(Accessor _ v1) = g v <> g' v1

226 g' v@(ObjectUpdate obj vs) = foldl (<>) (g v <> g' obj) (map (g' . snd) vs)

266 g' v@(ObjectUpdate obj vs) = foldl (<>) (g v <> g' obj) (map (g' . snd) vs)

@@ -234,42 +274,53 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j')

234 g' v@(PositionedValue _ _ v1) = g v <> g' v1

274 g' v@(PositionedValue _ _ v1) = g v <> g' v1

235 g' v = g v

275 g' v = g v

236

276

277+ h' :: Binder -> r

278+ h' b@(LiteralBinder l) = lit (h b) h' l

237 h' b@(ConstructorBinder _ bs) = foldl (<>) (h b) (map h' bs)

279 h' b@(ConstructorBinder _ bs) = foldl (<>) (h b) (map h' bs)

238 h' b@(BinaryNoParensBinder b1 b2 b3) = h b <> h' b1 <> h' b2 <> h' b3

280 h' b@(BinaryNoParensBinder b1 b2 b3) = h b <> h' b1 <> h' b2 <> h' b3

239 h' b@(ParensInBinder b1) = h b <> h' b1

281 h' b@(ParensInBinder b1) = h b <> h' b1

240− h' b@(ObjectBinder bs) = foldl (<>) (h b) (map (h' . snd) bs)

241− h' b@(ArrayBinder bs) = foldl (<>) (h b) (map h' bs)

242 h' b@(NamedBinder _ b1) = h b <> h' b1

282 h' b@(NamedBinder _ b1) = h b <> h' b1

243 h' b@(PositionedBinder _ _ b1) = h b <> h' b1

283 h' b@(PositionedBinder _ _ b1) = h b <> h' b1

244 h' b@(TypedBinder _ b1) = h b <> h' b1

284 h' b@(TypedBinder _ b1) = h b <> h' b1

245 h' b = h b

285 h' b = h b

246

286

287+ lit :: r -> (a -> r) -> Literal a -> r

288+ lit r go (ArrayLiteral as) = foldl (<>) r (map go as)

289+ lit r go (ObjectLiteral as) = foldl (<>) r (map (go . snd) as)

290+ lit r _ _ = r

291+

292+ i' :: CaseAlternative -> r

247 i' ca@(CaseAlternative bs (Right val)) = foldl (<>) (i ca) (map h' bs) <> g' val

293 i' ca@(CaseAlternative bs (Right val)) = foldl (<>) (i ca) (map h' bs) <> g' val

248 i' ca@(CaseAlternative bs (Left gs)) = foldl (<>) (i ca) (map h' bs ++ concatMap (\(grd, val) -> [g' grd, g' val]) gs)

294 i' ca@(CaseAlternative bs (Left gs)) = foldl (<>) (i ca) (map h' bs ++ concatMap (\(grd, val) -> [g' grd, g' val]) gs)

249

295

296+ j' :: DoNotationElement -> r

250 j' e@(DoNotationValue v) = j e <> g' v

297 j' e@(DoNotationValue v) = j e <> g' v

251 j' e@(DoNotationBind b v) = j e <> h' b <> g' v

298 j' e@(DoNotationBind b v) = j e <> h' b <> g' v

252 j' e@(DoNotationLet ds) = foldl (<>) (j e) (map f' ds)

299 j' e@(DoNotationLet ds) = foldl (<>) (j e) (map f' ds)

253 j' e@(PositionedDoNotationElement _ _ e1) = j e <> j' e1

300 j' e@(PositionedDoNotationElement _ _ e1) = j e <> j' e1

254

301

255−everythingWithContextOnValues ::

302+everythingWithContextOnValues

256− s ->

303+ :: forall s r

257− r ->

304+ . s

305+ -> r

258− (r -> r -> r) ->

306+ -> (r -> r -> r)

259− (s -> Declaration -> (s, r)) ->

307+ -> (s -> Declaration -> (s, r))

260− (s -> Expr -> (s, r)) ->

308+ -> (s -> Expr -> (s, r))

261− (s -> Binder -> (s, r)) ->

309+ -> (s -> Binder -> (s, r))

262− (s -> CaseAlternative -> (s, r)) ->

310+ -> (s -> CaseAlternative -> (s, r))

263− (s -> DoNotationElement -> (s, r)) ->

311+ -> (s -> DoNotationElement -> (s, r))

264− ( Declaration -> r

312+ -> ( Declaration -> r

265− , Expr -> r

313+ , Expr -> r

266− , Binder -> r

314+ , Binder -> r

267− , CaseAlternative -> r

315+ , CaseAlternative -> r

268− , DoNotationElement -> r)

316+ , DoNotationElement -> r)

269everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j'' s0)

317everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j'' s0)

270 where

318 where

319+

320+ f'' :: s -> Declaration -> r

271 f'' s d = let (s', r) = f s d in r <> f' s' d

321 f'' s d = let (s', r) = f s d in r <> f' s' d

272

322

323+ f' :: s -> Declaration -> r

273 f' s (DataBindingGroupDeclaration ds) = foldl (<>) r0 (map (f'' s) ds)

324 f' s (DataBindingGroupDeclaration ds) = foldl (<>) r0 (map (f'' s) ds)

274 f' s (ValueDeclaration _ _ bs (Right val)) = foldl (<>) r0 (map (h'' s) bs) <> g'' s val

325 f' s (ValueDeclaration _ _ bs (Right val)) = foldl (<>) r0 (map (h'' s) bs) <> g'' s val

275 f' s (ValueDeclaration _ _ bs (Left gs)) = foldl (<>) r0 (map (h'' s) bs ++ concatMap (\(grd, val) -> [g'' s grd, g'' s val]) gs)

326 f' s (ValueDeclaration _ _ bs (Left gs)) = foldl (<>) r0 (map (h'' s) bs ++ concatMap (\(grd, val) -> [g'' s grd, g'' s val]) gs)

@@ -279,15 +330,16 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'

279 f' s (PositionedDeclaration _ _ d1) = f'' s d1

330 f' s (PositionedDeclaration _ _ d1) = f'' s d1

280 f' _ _ = r0

331 f' _ _ = r0

281

332

333+ g'' :: s -> Expr -> r

282 g'' s v = let (s', r) = g s v in r <> g' s' v

334 g'' s v = let (s', r) = g s v in r <> g' s' v

283

335

336+ g' :: s -> Expr -> r

337+ g' s (Literal l) = lit g'' s l

284 g' s (UnaryMinus v1) = g'' s v1

338 g' s (UnaryMinus v1) = g'' s v1

285 g' s (BinaryNoParens op v1 v2) = g'' s op <> g'' s v1 <> g'' s v2

339 g' s (BinaryNoParens op v1 v2) = g'' s op <> g'' s v1 <> g'' s v2

286 g' s (Parens v1) = g'' s v1

340 g' s (Parens v1) = g'' s v1

287 g' s (OperatorSection op (Left v)) = g'' s op <> g'' s v

341 g' s (OperatorSection op (Left v)) = g'' s op <> g'' s v

288 g' s (OperatorSection op (Right v)) = g'' s op <> g'' s v

342 g' s (OperatorSection op (Right v)) = g'' s op <> g'' s v

289− g' s (ArrayLiteral vs) = foldl (<>) r0 (map (g'' s) vs)

290− g' s (ObjectLiteral vs) = foldl (<>) r0 (map (g'' s . snd) vs)

291 g' s (TypeClassDictionaryConstructorApp _ v1) = g'' s v1

343 g' s (TypeClassDictionaryConstructorApp _ v1) = g'' s v1

292 g' s (Accessor _ v1) = g'' s v1

344 g' s (Accessor _ v1) = g'' s v1

293 g' s (ObjectUpdate obj vs) = foldl (<>) (g'' s obj) (map (g'' s . snd) vs)

345 g' s (ObjectUpdate obj vs) = foldl (<>) (g'' s obj) (map (g'' s . snd) vs)

@@ -301,42 +353,54 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'

301 g' s (PositionedValue _ _ v1) = g'' s v1

353 g' s (PositionedValue _ _ v1) = g'' s v1

302 g' _ _ = r0

354 g' _ _ = r0

303

355

356+ h'' :: s -> Binder -> r

304 h'' s b = let (s', r) = h s b in r <> h' s' b

357 h'' s b = let (s', r) = h s b in r <> h' s' b

305

358

359+ h' :: s -> Binder -> r

360+ h' s (LiteralBinder l) = lit h'' s l

306 h' s (ConstructorBinder _ bs) = foldl (<>) r0 (map (h'' s) bs)

361 h' s (ConstructorBinder _ bs) = foldl (<>) r0 (map (h'' s) bs)

307 h' s (BinaryNoParensBinder b1 b2 b3) = h'' s b1 <> h'' s b2 <> h'' s b3

362 h' s (BinaryNoParensBinder b1 b2 b3) = h'' s b1 <> h'' s b2 <> h'' s b3

308 h' s (ParensInBinder b) = h'' s b

363 h' s (ParensInBinder b) = h'' s b

309− h' s (ObjectBinder bs) = foldl (<>) r0 (map (h'' s . snd) bs)

310− h' s (ArrayBinder bs) = foldl (<>) r0 (map (h'' s) bs)

311 h' s (NamedBinder _ b1) = h'' s b1

364 h' s (NamedBinder _ b1) = h'' s b1

312 h' s (PositionedBinder _ _ b1) = h'' s b1

365 h' s (PositionedBinder _ _ b1) = h'' s b1

313 h' s (TypedBinder _ b1) = h'' s b1

366 h' s (TypedBinder _ b1) = h'' s b1

314 h' _ _ = r0

367 h' _ _ = r0

315

368

369+ lit :: (s -> a -> r) -> s -> Literal a -> r

370+ lit go s (ArrayLiteral as) = foldl (<>) r0 (map (go s) as)

371+ lit go s (ObjectLiteral as) = foldl (<>) r0 (map (go s . snd) as)

372+ lit _ _ _ = r0

373+

374+ i'' :: s -> CaseAlternative -> r

316 i'' s ca = let (s', r) = i s ca in r <> i' s' ca

375 i'' s ca = let (s', r) = i s ca in r <> i' s' ca

317

376

377+ i' :: s -> CaseAlternative -> r

318 i' s (CaseAlternative bs (Right val)) = foldl (<>) r0 (map (h'' s) bs) <> g'' s val

378 i' s (CaseAlternative bs (Right val)) = foldl (<>) r0 (map (h'' s) bs) <> g'' s val

319 i' s (CaseAlternative bs (Left gs)) = foldl (<>) r0 (map (h'' s) bs ++ concatMap (\(grd, val) -> [g'' s grd, g'' s val]) gs)

379 i' s (CaseAlternative bs (Left gs)) = foldl (<>) r0 (map (h'' s) bs ++ concatMap (\(grd, val) -> [g'' s grd, g'' s val]) gs)

320

380

381+ j'' :: s -> DoNotationElement -> r

321 j'' s e = let (s', r) = j s e in r <> j' s' e

382 j'' s e = let (s', r) = j s e in r <> j' s' e

322

383

384+ j' :: s -> DoNotationElement -> r

323 j' s (DoNotationValue v) = g'' s v

385 j' s (DoNotationValue v) = g'' s v

324 j' s (DoNotationBind b v) = h'' s b <> g'' s v

386 j' s (DoNotationBind b v) = h'' s b <> g'' s v

325 j' s (DoNotationLet ds) = foldl (<>) r0 (map (f'' s) ds)

387 j' s (DoNotationLet ds) = foldl (<>) r0 (map (f'' s) ds)

326 j' s (PositionedDoNotationElement _ _ e1) = j'' s e1

388 j' s (PositionedDoNotationElement _ _ e1) = j'' s e1

327

389

328−everywhereWithContextOnValuesM :: (Functor m, Applicative m, Monad m) =>

390+everywhereWithContextOnValuesM

329− s ->

391+ :: forall m s

392+ . (Functor m, Applicative m, Monad m)

393+ => s

330− (s -> Declaration -> m (s, Declaration)) ->

394+ -> (s -> Declaration -> m (s, Declaration))

331− (s -> Expr -> m (s, Expr)) ->

395+ -> (s -> Expr -> m (s, Expr))

332− (s -> Binder -> m (s, Binder)) ->

396+ -> (s -> Binder -> m (s, Binder))

333− (s -> CaseAlternative -> m (s, CaseAlternative)) ->

397+ -> (s -> CaseAlternative -> m (s, CaseAlternative))

334− (s -> DoNotationElement -> m (s, DoNotationElement)) ->

398+ -> (s -> DoNotationElement -> m (s, DoNotationElement))

335− ( Declaration -> m Declaration

399+ -> ( Declaration -> m Declaration

336− , Expr -> m Expr

400+ , Expr -> m Expr

337− , Binder -> m Binder

401+ , Binder -> m Binder

338− , CaseAlternative -> m CaseAlternative

402+ , CaseAlternative -> m CaseAlternative

339− , DoNotationElement -> m DoNotationElement)

403+ , DoNotationElement -> m DoNotationElement)

340everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j'' s0)

404everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j'' s0)

341 where

405 where

342 f'' s = uncurry f' <=< f s

406 f'' s = uncurry f' <=< f s

@@ -351,13 +415,12 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j

351

415

352 g'' s = uncurry g' <=< g s

416 g'' s = uncurry g' <=< g s

353

417

418+ g' s (Literal l) = Literal <$> lit g'' s l

354 g' s (UnaryMinus v) = UnaryMinus <$> g'' s v

419 g' s (UnaryMinus v) = UnaryMinus <$> g'' s v

355 g' s (BinaryNoParens op v1 v2) = BinaryNoParens <$> g'' s op <*> g'' s v1 <*> g'' s v2

420 g' s (BinaryNoParens op v1 v2) = BinaryNoParens <$> g'' s op <*> g'' s v1 <*> g'' s v2

356 g' s (Parens v) = Parens <$> g'' s v

421 g' s (Parens v) = Parens <$> g'' s v

357 g' s (OperatorSection op (Left v)) = OperatorSection <$> g'' s op <*> (Left <$> g'' s v)

422 g' s (OperatorSection op (Left v)) = OperatorSection <$> g'' s op <*> (Left <$> g'' s v)

358 g' s (OperatorSection op (Right v)) = OperatorSection <$> g'' s op <*> (Right <$> g'' s v)

423 g' s (OperatorSection op (Right v)) = OperatorSection <$> g'' s op <*> (Right <$> g'' s v)

359− g' s (ArrayLiteral vs) = ArrayLiteral <$> traverse (g'' s) vs

360− g' s (ObjectLiteral vs) = ObjectLiteral <$> traverse (sndM (g'' s)) vs

361 g' s (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> g'' s v

424 g' s (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> g'' s v

362 g' s (Accessor prop v) = Accessor prop <$> g'' s v

425 g' s (Accessor prop v) = Accessor prop <$> g'' s v

363 g' s (ObjectUpdate obj vs) = ObjectUpdate <$> g'' s obj <*> traverse (sndM (g'' s)) vs

426 g' s (ObjectUpdate obj vs) = ObjectUpdate <$> g'' s obj <*> traverse (sndM (g'' s)) vs

@@ -373,16 +436,20 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j

373

436

374 h'' s = uncurry h' <=< h s

437 h'' s = uncurry h' <=< h s

375

438

439+ h' s (LiteralBinder l) = LiteralBinder <$> lit h'' s l

376 h' s (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> traverse (h'' s) bs

440 h' s (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> traverse (h'' s) bs

377 h' s (BinaryNoParensBinder b1 b2 b3) = BinaryNoParensBinder <$> h'' s b1 <*> h'' s b2 <*> h'' s b3

441 h' s (BinaryNoParensBinder b1 b2 b3) = BinaryNoParensBinder <$> h'' s b1 <*> h'' s b2 <*> h'' s b3

378 h' s (ParensInBinder b) = ParensInBinder <$> h'' s b

442 h' s (ParensInBinder b) = ParensInBinder <$> h'' s b

379− h' s (ObjectBinder bs) = ObjectBinder <$> traverse (sndM (h'' s)) bs

380− h' s (ArrayBinder bs) = ArrayBinder <$> traverse (h'' s) bs

381 h' s (NamedBinder name b) = NamedBinder name <$> h'' s b

443 h' s (NamedBinder name b) = NamedBinder name <$> h'' s b

382 h' s (PositionedBinder pos com b) = PositionedBinder pos com <$> h'' s b

444 h' s (PositionedBinder pos com b) = PositionedBinder pos com <$> h'' s b

383 h' s (TypedBinder t b) = TypedBinder t <$> h'' s b

445 h' s (TypedBinder t b) = TypedBinder t <$> h'' s b

384 h' _ other = return other

446 h' _ other = return other

385

447

448+ lit :: (s -> a -> m a) -> s -> Literal a -> m (Literal a)

449+ lit go s (ArrayLiteral as) = ArrayLiteral <$> traverse (go s) as

450+ lit go s (ObjectLiteral as) = ObjectLiteral <$> traverse (sndM (go s)) as

451+ lit _ _ other = return other

452+

386 i'' s = uncurry i' <=< i s

453 i'' s = uncurry i' <=< i s

387

454

388 i' s (CaseAlternative bs val) = CaseAlternative <$> traverse (h'' s) bs <*> eitherM (traverse (pairM (g'' s) (g'' s))) (g'' s) val

455 i' s (CaseAlternative bs val) = CaseAlternative <$> traverse (h'' s) bs <*> eitherM (traverse (pairM (g'' s) (g'' s))) (g'' s) val

@@ -394,25 +461,29 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j

394 j' s (DoNotationLet ds) = DoNotationLet <$> traverse (f'' s) ds

461 j' s (DoNotationLet ds) = DoNotationLet <$> traverse (f'' s) ds

395 j' s (PositionedDoNotationElement pos com e1) = PositionedDoNotationElement pos com <$> j'' s e1

462 j' s (PositionedDoNotationElement pos com e1) = PositionedDoNotationElement pos com <$> j'' s e1

396

463

397−everythingWithScope ::

464+everythingWithScope

465+ :: forall r

398− (Monoid r) =>

466+ . (Monoid r)

399− (S.Set Ident -> Declaration -> r) ->

467+ => (S.Set Ident -> Declaration -> r)

400− (S.Set Ident -> Expr -> r) ->

468+ -> (S.Set Ident -> Expr -> r)

401− (S.Set Ident -> Binder -> r) ->

469+ -> (S.Set Ident -> Binder -> r)

402− (S.Set Ident -> CaseAlternative -> r) ->

470+ -> (S.Set Ident -> CaseAlternative -> r)

403− (S.Set Ident -> DoNotationElement -> r) ->

471+ -> (S.Set Ident -> DoNotationElement -> r)

404− ( S.Set Ident -> Declaration -> r

472+ -> ( S.Set Ident -> Declaration -> r

405− , S.Set Ident -> Expr -> r

473+ , S.Set Ident -> Expr -> r

406− , S.Set Ident -> Binder -> r

474+ , S.Set Ident -> Binder -> r

407− , S.Set Ident -> CaseAlternative -> r

475+ , S.Set Ident -> CaseAlternative -> r

408− , S.Set Ident -> DoNotationElement -> r)

476+ , S.Set Ident -> DoNotationElement -> r

477+ )

409everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)

478everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)

410 where

479 where

411 -- Avoid importing Data.Monoid and getting shadowed names above

480 -- Avoid importing Data.Monoid and getting shadowed names above

412 (<>) = mappend

481 (<>) = mappend

413

482

483+ f'' :: S.Set Ident -> Declaration -> r

414 f'' s a = f s a <> f' s a

484 f'' s a = f s a <> f' s a

415

485

486+ f' :: S.Set Ident -> Declaration -> r

416 f' s (DataBindingGroupDeclaration ds) =

487 f' s (DataBindingGroupDeclaration ds) =

417 let s' = S.union s (S.fromList (mapMaybe getDeclIdent ds))

488 let s' = S.union s (S.fromList (mapMaybe getDeclIdent ds))

418 in foldMap (f'' s') ds

489 in foldMap (f'' s') ds

@@ -431,15 +502,16 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)

431 f' s (PositionedDeclaration _ _ d) = f'' s d

502 f' s (PositionedDeclaration _ _ d) = f'' s d

432 f' _ _ = mempty

503 f' _ _ = mempty

433

504

505+ g'' :: S.Set Ident -> Expr -> r

434 g'' s a = g s a <> g' s a

506 g'' s a = g s a <> g' s a

435

507

508+ g' :: S.Set Ident -> Expr -> r

509+ g' s (Literal l) = lit g'' s l

436 g' s (UnaryMinus v1) = g'' s v1

510 g' s (UnaryMinus v1) = g'' s v1

437 g' s (BinaryNoParens op v1 v2) = g' s op <> g' s v1 <> g' s v2

511 g' s (BinaryNoParens op v1 v2) = g' s op <> g' s v1 <> g' s v2

438 g' s (Parens v1) = g'' s v1

512 g' s (Parens v1) = g'' s v1

439 g' s (OperatorSection op (Left v)) = g'' s op <> g'' s v

513 g' s (OperatorSection op (Left v)) = g'' s op <> g'' s v

440 g' s (OperatorSection op (Right v)) = g'' s op <> g'' s v

514 g' s (OperatorSection op (Right v)) = g'' s op <> g'' s v

441− g' s (ArrayLiteral vs) = foldMap (g'' s) vs

442− g' s (ObjectLiteral vs) = foldMap (g'' s . snd) vs

443 g' s (TypeClassDictionaryConstructorApp _ v1) = g'' s v1

515 g' s (TypeClassDictionaryConstructorApp _ v1) = g'' s v1

444 g' s (Accessor _ v1) = g'' s v1

516 g' s (Accessor _ v1) = g'' s v1

445 g' s (ObjectUpdate obj vs) = g'' s obj <> foldMap (g'' s . snd) vs

517 g' s (ObjectUpdate obj vs) = g'' s obj <> foldMap (g'' s . snd) vs

@@ -460,20 +532,28 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)

460 g' s (PositionedValue _ _ v1) = g'' s v1

532 g' s (PositionedValue _ _ v1) = g'' s v1

461 g' _ _ = mempty

533 g' _ _ = mempty

462

534

535+ h'' :: S.Set Ident -> Binder -> r

463 h'' s a = h s a <> h' s a

536 h'' s a = h s a <> h' s a

464

537

538+ h' :: S.Set Ident -> Binder -> r

539+ h' s (LiteralBinder l) = lit h'' s l

465 h' s (ConstructorBinder _ bs) = foldMap (h'' s) bs

540 h' s (ConstructorBinder _ bs) = foldMap (h'' s) bs

466 h' s (BinaryNoParensBinder b1 b2 b3) = foldMap (h'' s) [b1, b2, b3]

541 h' s (BinaryNoParensBinder b1 b2 b3) = foldMap (h'' s) [b1, b2, b3]

467 h' s (ParensInBinder b) = h'' s b

542 h' s (ParensInBinder b) = h'' s b

468− h' s (ObjectBinder bs) = foldMap (h'' s . snd) bs

469− h' s (ArrayBinder bs) = foldMap (h'' s) bs

470 h' s (NamedBinder name b1) = h'' (S.insert name s) b1

543 h' s (NamedBinder name b1) = h'' (S.insert name s) b1

471 h' s (PositionedBinder _ _ b1) = h'' s b1

544 h' s (PositionedBinder _ _ b1) = h'' s b1

472 h' s (TypedBinder _ b1) = h'' s b1

545 h' s (TypedBinder _ b1) = h'' s b1

473 h' _ _ = mempty

546 h' _ _ = mempty

474

547

548+ lit :: (S.Set Ident -> a -> r) -> S.Set Ident -> Literal a -> r

549+ lit go s (ArrayLiteral as) = foldMap (go s) as

550+ lit go s (ObjectLiteral as) = foldMap (go s . snd) as

551+ lit _ _ _ = mempty

552+

553+ i'' :: S.Set Ident -> CaseAlternative -> r

475 i'' s a = i s a <> i' s a

554 i'' s a = i s a <> i' s a

476

555

556+ i' :: S.Set Ident -> CaseAlternative -> r

477 i' s (CaseAlternative bs (Right val)) =

557 i' s (CaseAlternative bs (Right val)) =

478 let s' = S.union s (S.fromList (concatMap binderNames bs))

558 let s' = S.union s (S.fromList (concatMap binderNames bs))

479 in foldMap (h'' s) bs <> g'' s' val

559 in foldMap (h'' s) bs <> g'' s' val

@@ -481,8 +561,10 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)

481 let s' = S.union s (S.fromList (concatMap binderNames bs))

561 let s' = S.union s (S.fromList (concatMap binderNames bs))

482 in foldMap (h'' s) bs <> foldMap (\(grd, val) -> g'' s' grd <> g'' s' val) gs

562 in foldMap (h'' s) bs <> foldMap (\(grd, val) -> g'' s' grd <> g'' s' val) gs

483

563

564+ j'' :: S.Set Ident -> DoNotationElement -> (S.Set Ident, r)

484 j'' s a = let (s', r) = j' s a in (s', j s a <> r)

565 j'' s a = let (s', r) = j' s a in (s', j s a <> r)

485

566

567+ j' :: S.Set Ident -> DoNotationElement -> (S.Set Ident, r)

486 j' s (DoNotationValue v) = (s, g'' s v)

568 j' s (DoNotationValue v) = (s, g'' s v)

487 j' s (DoNotationBind b v) =

569 j' s (DoNotationBind b v) =

488 let s' = S.union (S.fromList (binderNames b)) s

570 let s' = S.union (S.fromList (binderNames b)) s

@@ -498,7 +580,15 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)

498 getDeclIdent (TypeDeclaration ident _) = Just ident

580 getDeclIdent (TypeDeclaration ident _) = Just ident

499 getDeclIdent _ = Nothing

581 getDeclIdent _ = Nothing

500

582

501−accumTypes :: (Monoid r) => (Type -> r) -> (Declaration -> r, Expr -> r, Binder -> r, CaseAlternative -> r, DoNotationElement -> r)

583+accumTypes

584+ :: (Monoid r)

585+ => (Type -> r)

586+ -> ( Declaration -> r

587+ , Expr -> r

588+ , Binder -> r

589+ , CaseAlternative -> r

590+ , DoNotationElement -> r

591+ )

502accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (const mempty) (const mempty)

592accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (const mempty) (const mempty)

503 where

593 where

504 forDecls (DataDeclaration _ _ _ dctors) = mconcat (concatMap (map f . snd) dctors)

594 forDecls (DataDeclaration _ _ _ dctors) = mconcat (concatMap (map f . snd) dctors)

src/Language/PureScript/CoreFn.hs+3−14

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

1−-----------------------------------------------------------------------------

1+-- |

2+-- The core functional representation

2--

3--

3−-- Module : Language.PureScript.CoreFn

5−-- License : MIT

6−--

7−-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>

8−-- Stability : experimental

9−-- Portability :

10−--

11−-- | The core functional representation

12−--

13−-----------------------------------------------------------------------------

14−

15module Language.PureScript.CoreFn (

4module Language.PureScript.CoreFn (

16 module C

5 module C

17) where

6) where

@@ -20,7 +9,7 @@ import Language.PureScript.CoreFn.Ann as C

20import Language.PureScript.CoreFn.Binders as C

9import Language.PureScript.CoreFn.Binders as C

21import Language.PureScript.CoreFn.Desugar as C

10import Language.PureScript.CoreFn.Desugar as C

22import Language.PureScript.CoreFn.Expr as C

11import Language.PureScript.CoreFn.Expr as C

23−import Language.PureScript.CoreFn.Literals as C

12+import Language.PureScript.AST.Literals as C

24import Language.PureScript.CoreFn.Meta as C

13import Language.PureScript.CoreFn.Meta as C

25import Language.PureScript.CoreFn.Module as C

14import Language.PureScript.CoreFn.Module as C

26import Language.PureScript.CoreFn.Traversals as C

15import Language.PureScript.CoreFn.Traversals as C

src/Language/PureScript/CoreFn/Binders.hs+1−1

@@ -5,7 +5,7 @@

5--

6module Language.PureScript.CoreFn.Binders where

8−import Language.PureScript.CoreFn.Literals

8+import Language.PureScript.AST.Literals

9import Language.PureScript.Names

11-- |

src/Language/PureScript/CoreFn/Desugar.hs+6−26

@@ -17,7 +17,7 @@ import Language.PureScript.AST.Traversals

17import Language.PureScript.CoreFn.Ann

18import Language.PureScript.CoreFn.Binders

19import Language.PureScript.CoreFn.Expr

20−import Language.PureScript.CoreFn.Literals

20+import Language.PureScript.AST.Literals

21import Language.PureScript.CoreFn.Meta

22import Language.PureScript.CoreFn.Module

23import Language.PureScript.Environment

@@ -88,18 +88,8 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =

88 -- Desugars expressions from AST to CoreFn representation.

89 --

90 exprToCoreFn :: Maybe SourceSpan -> [Comment] -> Maybe Type -> A.Expr -> Expr Ann

91− exprToCoreFn ss com ty (A.NumericLiteral v) =

91+ exprToCoreFn ss com ty (A.Literal lit) =

92− Literal (ss, com, ty, Nothing) (NumericLiteral v)

93− exprToCoreFn ss com ty (A.StringLiteral v) =

94− Literal (ss, com, ty, Nothing) (StringLiteral v)

95− exprToCoreFn ss com ty (A.CharLiteral v) =

96− Literal (ss, com, ty, Nothing) (CharLiteral v)

97− exprToCoreFn ss com ty (A.BooleanLiteral v) =

98− Literal (ss, com, ty, Nothing) (BooleanLiteral v)

99− exprToCoreFn ss com ty (A.ArrayLiteral vs) =

100− Literal (ss, com, ty, Nothing) (ArrayLiteral $ map (exprToCoreFn ss [] Nothing) vs)

92+ Literal (ss, com, ty, Nothing) (fmap (exprToCoreFn ss com Nothing) lit)

101− exprToCoreFn ss com ty (A.ObjectLiteral vs) =

102− Literal (ss, com, ty, Nothing) (ObjectLiteral $ map (second (exprToCoreFn ss [] Nothing)) vs)

103 exprToCoreFn ss com ty (A.Accessor name v) =

93 exprToCoreFn ss com ty (A.Accessor name v) =

104 Accessor (ss, com, ty, Nothing) name (exprToCoreFn ss [] Nothing v)

94 Accessor (ss, com, ty, Nothing) name (exprToCoreFn ss [] Nothing v)

105 exprToCoreFn ss com ty (A.ObjectUpdate obj vs) =

95 exprToCoreFn ss com ty (A.ObjectUpdate obj vs) =

@@ -126,7 +116,7 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =

126 exprToCoreFn ss com (Just ty) v

116 exprToCoreFn ss com (Just ty) v

127 exprToCoreFn ss com ty (A.Let ds v) =

117 exprToCoreFn ss com ty (A.Let ds v) =

128 Let (ss, com, ty, Nothing) (concatMap (declToCoreFn ss []) ds) (exprToCoreFn ss [] Nothing v)

118 Let (ss, com, ty, Nothing) (concatMap (declToCoreFn ss []) ds) (exprToCoreFn ss [] Nothing v)

129− exprToCoreFn ss com _ (A.TypeClassDictionaryConstructorApp name (A.TypedValue _ (A.ObjectLiteral vs) _)) =

119+ exprToCoreFn ss com _ (A.TypeClassDictionaryConstructorApp name (A.TypedValue _ (A.Literal (A.ObjectLiteral vs)) _)) =

130 let args = map (exprToCoreFn ss [] Nothing . snd) $ sortBy (compare `on` fst) vs

120 let args = map (exprToCoreFn ss [] Nothing . snd) $ sortBy (compare `on` fst) vs

131 ctor = Var (ss, [], Nothing, Just IsTypeClassConstructor) (fmap properToIdent name)

121 ctor = Var (ss, [], Nothing, Just IsTypeClassConstructor) (fmap properToIdent name)

132 in foldl (App (ss, com, Nothing, Nothing)) ctor args

122 in foldl (App (ss, com, Nothing, Nothing)) ctor args

@@ -152,25 +142,15 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =

152 -- Desugars case binders from AST to CoreFn representation.

142 -- Desugars case binders from AST to CoreFn representation.

153 --

143 --

154 binderToCoreFn :: Maybe SourceSpan -> [Comment] -> A.Binder -> Binder Ann

144 binderToCoreFn :: Maybe SourceSpan -> [Comment] -> A.Binder -> Binder Ann

145+ binderToCoreFn ss com (A.LiteralBinder lit) =

146+ LiteralBinder (ss, com, Nothing, Nothing) (fmap (binderToCoreFn ss com) lit)

155 binderToCoreFn ss com (A.NullBinder) =

147 binderToCoreFn ss com (A.NullBinder) =

156 NullBinder (ss, com, Nothing, Nothing)

148 NullBinder (ss, com, Nothing, Nothing)

157− binderToCoreFn ss com (A.BooleanBinder b) =

158− LiteralBinder (ss, com, Nothing, Nothing) (BooleanLiteral b)

159− binderToCoreFn ss com (A.StringBinder s) =

160− LiteralBinder (ss, com, Nothing, Nothing) (StringLiteral s)

161− binderToCoreFn ss com (A.CharBinder c) =

162− LiteralBinder (ss, com, Nothing, Nothing) (CharLiteral c)

163− binderToCoreFn ss com (A.NumberBinder n) =

164− LiteralBinder (ss, com, Nothing, Nothing) (NumericLiteral n)

165 binderToCoreFn ss com (A.VarBinder name) =

149 binderToCoreFn ss com (A.VarBinder name) =

166 VarBinder (ss, com, Nothing, Nothing) name

150 VarBinder (ss, com, Nothing, Nothing) name

167 binderToCoreFn ss com (A.ConstructorBinder dctor@(Qualified mn' _) bs) =

151 binderToCoreFn ss com (A.ConstructorBinder dctor@(Qualified mn' _) bs) =

168 let (_, tctor, _, _) = lookupConstructor env dctor

152 let (_, tctor, _, _) = lookupConstructor env dctor

169 in ConstructorBinder (ss, com, Nothing, Just $ getConstructorMeta dctor) (Qualified mn' tctor) dctor (map (binderToCoreFn ss []) bs)

153 in ConstructorBinder (ss, com, Nothing, Just $ getConstructorMeta dctor) (Qualified mn' tctor) dctor (map (binderToCoreFn ss []) bs)

170− binderToCoreFn ss com (A.ObjectBinder bs) =

171− LiteralBinder (ss, com, Nothing, Nothing) (ObjectLiteral $ map (second (binderToCoreFn ss [])) bs)

172− binderToCoreFn ss com (A.ArrayBinder bs) =

173− LiteralBinder (ss, com, Nothing, Nothing) (ArrayLiteral $ map (binderToCoreFn ss []) bs)

174 binderToCoreFn ss com (A.NamedBinder name b) =

154 binderToCoreFn ss com (A.NamedBinder name b) =

175 NamedBinder (ss, com, Nothing, Nothing) name (binderToCoreFn ss [] b)

155 NamedBinder (ss, com, Nothing, Nothing) name (binderToCoreFn ss [] b)

176 binderToCoreFn _ com (A.PositionedBinder ss com1 b) =

156 binderToCoreFn _ com (A.PositionedBinder ss com1 b) =

src/Language/PureScript/CoreFn/Expr.hs+1−1

@@ -8,7 +8,7 @@ module Language.PureScript.CoreFn.Expr where

8import Control.Arrow ((***))

10import Language.PureScript.CoreFn.Binders

11−import Language.PureScript.CoreFn.Literals

11+import Language.PureScript.AST.Literals

12import Language.PureScript.Names

14-- |

src/Language/PureScript/CoreFn/Traversals.hs+3−14

@@ -1,24 +1,13 @@

1−-----------------------------------------------------------------------------

1+-- |

2+-- CoreFn traversal helpers

2--

3--

3−-- Module : Language.PureScript.CoreFn.Traversals

5−-- License : MIT

6−--

7−-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>

8−-- Stability : experimental

9−-- Portability :

10−--

11−-- | CoreFn traversal helpers

12−--

13−-----------------------------------------------------------------------------

14−

15module Language.PureScript.CoreFn.Traversals where

4module Language.PureScript.CoreFn.Traversals where

17import Control.Arrow (second, (***), (+++))

6import Control.Arrow (second, (***), (+++))

19import Language.PureScript.CoreFn.Binders

8import Language.PureScript.CoreFn.Binders

20import Language.PureScript.CoreFn.Expr

9import Language.PureScript.CoreFn.Expr

21−import Language.PureScript.CoreFn.Literals

10+import Language.PureScript.AST.Literals

23everywhereOnValues :: (Bind a -> Bind a) ->

12everywhereOnValues :: (Bind a -> Bind a) ->

24 (Expr a -> Expr a) ->

13 (Expr a -> Expr a) ->

src/Language/PureScript/Linter/Exhaustive.hs+11−10

@@ -24,6 +24,7 @@ import Control.Monad.Writer.Class

25import Language.PureScript.Crash

26import Language.PureScript.AST.Binders

27+import Language.PureScript.AST.Literals

27import Language.PureScript.AST.Declarations

28import Language.PureScript.AST.Declarations

28import Language.PureScript.Environment

29import Language.PureScript.Environment

29import Language.PureScript.Names as P

30import Language.PureScript.Names as P

@@ -119,12 +120,12 @@ missingCasesSingle env mn NullBinder cb@(ConstructorBinder con _) =

119missingCasesSingle env mn cb@(ConstructorBinder con bs) (ConstructorBinder con' bs')

120missingCasesSingle env mn cb@(ConstructorBinder con bs) (ConstructorBinder con' bs')

120 | con == con' = let (bs'', pr) = missingCasesMultiple env mn bs bs' in (map (ConstructorBinder con) bs'', pr)

121 | con == con' = let (bs'', pr) = missingCasesMultiple env mn bs bs' in (map (ConstructorBinder con) bs'', pr)

121 | otherwise = ([cb], return False)

122 | otherwise = ([cb], return False)

122−missingCasesSingle env mn NullBinder (ObjectBinder bs) =

123+missingCasesSingle env mn NullBinder (LiteralBinder (ObjectLiteral bs)) =

123− (map (ObjectBinder . zip (map fst bs)) allMisses, pr)

124+ (map (LiteralBinder . ObjectLiteral . zip (map fst bs)) allMisses, pr)

124 where

125 where

125 (allMisses, pr) = missingCasesMultiple env mn (initialize $ length bs) (map snd bs)

126 (allMisses, pr) = missingCasesMultiple env mn (initialize $ length bs) (map snd bs)

126−missingCasesSingle env mn (ObjectBinder bs) (ObjectBinder bs') =

127+missingCasesSingle env mn (LiteralBinder (ObjectLiteral bs)) (LiteralBinder (ObjectLiteral bs')) =

127− (map (ObjectBinder . zip sortedNames) allMisses, pr)

128+ (map (LiteralBinder . ObjectLiteral . zip sortedNames) allMisses, pr)

128 where

129 where

129 (allMisses, pr) = uncurry (missingCasesMultiple env mn) (unzip binders)

130 (allMisses, pr) = uncurry (missingCasesMultiple env mn) (unzip binders)

130

131

@@ -141,10 +142,10 @@ missingCasesSingle env mn (ObjectBinder bs) (ObjectBinder bs') =

141 compBS e s b b' = (s, compB e b b')

142 compBS e s b b' = (s, compB e b b')

142

143

143 (sortedNames, binders) = unzip $ genericMerge (compBS NullBinder) sbs sbs'

144 (sortedNames, binders) = unzip $ genericMerge (compBS NullBinder) sbs sbs'

144−missingCasesSingle _ _ NullBinder (BooleanBinder b) = ([BooleanBinder $ not b], return True)

145+missingCasesSingle _ _ NullBinder (LiteralBinder (BooleanLiteral b)) = ([LiteralBinder . BooleanLiteral $ not b], return True)

145−missingCasesSingle _ _ (BooleanBinder bl) (BooleanBinder br)

146+missingCasesSingle _ _ (LiteralBinder (BooleanLiteral bl)) (LiteralBinder (BooleanLiteral br))

146 | bl == br = ([], return True)

147 | bl == br = ([], return True)

147− | otherwise = ([BooleanBinder bl], return False)

148+ | otherwise = ([LiteralBinder $ BooleanLiteral bl], return False)

148missingCasesSingle env mn b (PositionedBinder _ _ cb) = missingCasesSingle env mn b cb

149missingCasesSingle env mn b (PositionedBinder _ _ cb) = missingCasesSingle env mn b cb

149missingCasesSingle env mn b (TypedBinder _ cb) = missingCasesSingle env mn b cb

150missingCasesSingle env mn b (TypedBinder _ cb) = missingCasesSingle env mn b cb

150missingCasesSingle _ _ b _ = ([b], Left Unknown)

151missingCasesSingle _ _ b _ = ([b], Left Unknown)

@@ -201,7 +202,7 @@ isExhaustiveGuard :: Either [(Guard, Expr)] Expr -> Bool

201isExhaustiveGuard (Left gs) = not . null $ filter (\(g, _) -> isOtherwise g) gs

202isExhaustiveGuard (Left gs) = not . null $ filter (\(g, _) -> isOtherwise g) gs

202 where

203 where

203 isOtherwise :: Expr -> Bool

204 isOtherwise :: Expr -> Bool

204− isOtherwise (BooleanLiteral True) = True

205+ isOtherwise (Literal (BooleanLiteral True)) = True

205 isOtherwise (Var (Qualified (Just (ModuleName [ProperName "Prelude"])) (Ident "otherwise"))) = True

206 isOtherwise (Var (Qualified (Just (ModuleName [ProperName "Prelude"])) (Ident "otherwise"))) = True

206 isOtherwise (Var (Qualified (Just (ModuleName [ProperName "Data", ProperName "Boolean"])) (Ident "otherwise"))) = True

207 isOtherwise (Var (Qualified (Just (ModuleName [ProperName "Data", ProperName "Boolean"])) (Ident "otherwise"))) = True

207 isOtherwise (TypedValue _ e _) = isOtherwise e

208 isOtherwise (TypedValue _ e _) = isOtherwise e

@@ -274,8 +275,8 @@ checkExhaustiveDecls env mn = mapM_ onDecl

274

275

275 onExpr :: Bool -> Expr -> m ()

276 onExpr :: Bool -> Expr -> m ()

276 onExpr isP (UnaryMinus e) = onExpr isP e

277 onExpr isP (UnaryMinus e) = onExpr isP e

277− onExpr isP (ArrayLiteral es) = mapM_ (onExpr isP) es

278+ onExpr isP (Literal (ArrayLiteral es)) = mapM_ (onExpr isP) es

278− onExpr isP (ObjectLiteral es) = mapM_ (onExpr isP . snd) es

279+ onExpr isP (Literal (ObjectLiteral es)) = mapM_ (onExpr isP . snd) es

279 onExpr isP (TypeClassDictionaryConstructorApp _ e) = onExpr isP e

280 onExpr isP (TypeClassDictionaryConstructorApp _ e) = onExpr isP e

280 onExpr isP (Accessor _ e) = onExpr isP e

281 onExpr isP (Accessor _ e) = onExpr isP e

281 onExpr isP (ObjectUpdate o es) = onExpr isP o >> mapM_ (onExpr isP . snd) es

282 onExpr isP (ObjectUpdate o es) = onExpr isP o >> mapM_ (onExpr isP . snd) es

src/Language/PureScript/Parser/Declarations.hs+27−36

@@ -299,23 +299,23 @@ parseModules = mark (P.many (same *> parseModule)) <* P.eof

299booleanLiteral :: TokenParser Bool

300booleanLiteral = (reserved "true" >> return True) P.<|> (reserved "false" >> return False)

301

302−parseNumericLiteral :: TokenParser Expr

302+parseNumericLiteral :: TokenParser (Literal a)

303parseNumericLiteral = NumericLiteral <$> number

304

305−parseCharLiteral :: TokenParser Expr

305+parseCharLiteral :: TokenParser (Literal a)

306parseCharLiteral = CharLiteral <$> charLiteral

307

308−parseStringLiteral :: TokenParser Expr

308+parseStringLiteral :: TokenParser (Literal a)

309parseStringLiteral = StringLiteral <$> stringLiteral

310

311−parseBooleanLiteral :: TokenParser Expr

311+parseBooleanLiteral :: TokenParser (Literal a)

312parseBooleanLiteral = BooleanLiteral <$> booleanLiteral

313

314−parseArrayLiteral :: TokenParser Expr

314+parseArrayLiteral :: TokenParser a -> TokenParser (Literal a)

315−parseArrayLiteral = ArrayLiteral <$> squares (commaSep parseValue)

315+parseArrayLiteral p = ArrayLiteral <$> squares (commaSep p)

316

317−parseObjectLiteral :: TokenParser Expr

317+parseObjectLiteral :: TokenParser (String, a) -> TokenParser (Literal a)

318−parseObjectLiteral = ObjectLiteral <$> braces (commaSep parseIdentifierAndValue)

318+parseObjectLiteral p = ObjectLiteral <$> braces (commaSep p)

319

320parseIdentifierAndValue :: TokenParser (String, Expr)

321parseIdentifierAndValue =

@@ -376,12 +376,12 @@ parseLet = do

376parseValueAtom :: TokenParser Expr

377parseValueAtom = P.choice

378 [ parseAnonymousArgument

379− , parseNumericLiteral

379+ , Literal <$> parseNumericLiteral

380− , parseCharLiteral

380+ , Literal <$> parseCharLiteral

381− , parseStringLiteral

381+ , Literal <$> parseStringLiteral

382− , parseBooleanLiteral

382+ , Literal <$> parseBooleanLiteral

383− , parseArrayLiteral

383+ , Literal <$> parseArrayLiteral parseValue

384− , P.try parseObjectLiteral

384+ , Literal <$> P.try (parseObjectLiteral parseIdentifierAndValue)

385 , parseAbs

386 , P.try parseConstructor

387 , P.try parseVar

@@ -469,17 +469,8 @@ parseUpdaterBody v = ObjectUpdate v <$> (C.indented *> braces (commaSep1 (C.inde

469parseAnonymousArgument :: TokenParser Expr

470parseAnonymousArgument = underscore *> pure AnonymousArgument

471

472−parseStringBinder :: TokenParser Binder

473−parseStringBinder = StringBinder <$> stringLiteral

474−

475−parseCharBinder :: TokenParser Binder

476−parseCharBinder = CharBinder <$> charLiteral

477−

478−parseBooleanBinder :: TokenParser Binder

472+parseNumberLiteral :: TokenParser Binder

479−parseBooleanBinder = BooleanBinder <$> booleanLiteral

473+parseNumberLiteral = LiteralBinder . NumericLiteral <$> (sign <*> number)

480−

481−parseNumberBinder :: TokenParser Binder

482−parseNumberBinder = NumberBinder <$> (sign <*> number)

483 where

474 where

484 sign :: TokenParser (Either Integer Double -> Either Integer Double)

475 sign :: TokenParser (Either Integer Double -> Either Integer Double)

485 sign = (symbol' "-" >> return (negate +++ negate))

476 sign = (symbol' "-" >> return (negate +++ negate))

@@ -492,11 +483,11 @@ parseNullaryConstructorBinder = ConstructorBinder <$> C.parseQualified C.properN

492parseConstructorBinder :: TokenParser Binder

483parseConstructorBinder :: TokenParser Binder

493parseConstructorBinder = ConstructorBinder <$> C.parseQualified C.properName <*> many (C.indented *> parseBinderNoParens)

484parseConstructorBinder = ConstructorBinder <$> C.parseQualified C.properName <*> many (C.indented *> parseBinderNoParens)

494

485

495−parseObjectBinder :: TokenParser Binder

486+parseObjectBinder:: TokenParser Binder

496−parseObjectBinder = ObjectBinder <$> braces (commaSep (C.indented *> parseIdentifierAndBinder))

487+parseObjectBinder= LiteralBinder <$> parseObjectLiteral (C.indented *> parseIdentifierAndBinder)

497

488

498parseArrayBinder :: TokenParser Binder

489parseArrayBinder :: TokenParser Binder

499−parseArrayBinder = squares $ ArrayBinder <$> commaSep (C.indented *> parseBinder)

490+parseArrayBinder = LiteralBinder <$> parseArrayLiteral (C.indented *> parseBinder)

500

491

501parseVarOrNamedBinder :: TokenParser Binder

492parseVarOrNamedBinder :: TokenParser Binder

502parseVarOrNamedBinder = do

493parseVarOrNamedBinder = do

@@ -541,10 +532,10 @@ parseBinder =

541 parseBinderAtom :: TokenParser Binder

532 parseBinderAtom :: TokenParser Binder

542 parseBinderAtom = P.choice

533 parseBinderAtom = P.choice

543 [ parseNullBinder

534 [ parseNullBinder

544− , parseCharBinder

535+ , LiteralBinder <$> parseCharLiteral

545− , parseStringBinder

536+ , LiteralBinder <$> parseStringLiteral

546− , parseBooleanBinder

537+ , LiteralBinder <$> parseBooleanLiteral

547− , parseNumberBinder

538+ , parseNumberLiteral

548 , parseVarOrNamedBinder

539 , parseVarOrNamedBinder

549 , parseConstructorBinder

540 , parseConstructorBinder

550 , parseObjectBinder

541 , parseObjectBinder

@@ -561,10 +552,10 @@ parseBinder =

561parseBinderNoParens :: TokenParser Binder

552parseBinderNoParens :: TokenParser Binder

562parseBinderNoParens = P.choice

553parseBinderNoParens = P.choice

563 [ parseNullBinder

554 [ parseNullBinder

564− , parseCharBinder

555+ , LiteralBinder <$> parseCharLiteral

565− , parseStringBinder

556+ , LiteralBinder <$> parseStringLiteral

566− , parseBooleanBinder

557+ , LiteralBinder <$> parseBooleanLiteral

567− , parseNumberBinder

558+ , parseNumberLiteral

568 , parseVarOrNamedBinder

559 , parseVarOrNamedBinder

569 , parseNullaryConstructorBinder

560 , parseNullaryConstructorBinder

570 , parseObjectBinder

561 , parseObjectBinder

src/Language/PureScript/Pretty/Values.hs+28−39

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

1−-----------------------------------------------------------------------------

2−--

3−-- Module : Language.PureScript.Pretty.Values

4−-- Copyright : (c) Phil Freeman 2013

5−-- License : MIT

6−--

7−-- Maintainer : Phil Freeman <paf31@cantab.net>

8−-- Stability : experimental

9−-- Portability :

10−--

11-- |

1-- |

12-- Pretty printer for values

2-- Pretty printer for values

13--

3--

14−-----------------------------------------------------------------------------

15−

16module Language.PureScript.Pretty.Values (

4module Language.PureScript.Pretty.Values (

17 prettyPrintValue,

5 prettyPrintValue,

18 prettyPrintBinder,

6 prettyPrintBinder,

@@ -75,12 +63,7 @@ prettyPrintValue _ (TypeClassDictionaryAccessor className ident) =

75 text "#dict-accessor " <> text (runProperName (disqualify className)) <> text "." <> text (showIdent ident) <> text ">"

63 text "#dict-accessor " <> text (runProperName (disqualify className)) <> text "." <> text (showIdent ident) <> text ">"

76prettyPrintValue d (TypedValue _ val _) = prettyPrintValue d val

64prettyPrintValue d (TypedValue _ val _) = prettyPrintValue d val

77prettyPrintValue d (PositionedValue _ _ val) = prettyPrintValue d val

65prettyPrintValue d (PositionedValue _ _ val) = prettyPrintValue d val

78−prettyPrintValue d expr@NumericLiteral{} = prettyPrintValueAtom d expr

66+prettyPrintValue d (Literal l) = prettyPrintLiteralValue d l

79−prettyPrintValue d expr@StringLiteral{} = prettyPrintValueAtom d expr

80−prettyPrintValue d expr@CharLiteral{} = prettyPrintValueAtom d expr

81−prettyPrintValue d expr@BooleanLiteral{} = prettyPrintValueAtom d expr

82−prettyPrintValue d expr@ArrayLiteral{} = prettyPrintValueAtom d expr

83−prettyPrintValue d expr@ObjectLiteral{} = prettyPrintValueAtom d expr

84prettyPrintValue d expr@AnonymousArgument{} = prettyPrintValueAtom d expr

67prettyPrintValue d expr@AnonymousArgument{} = prettyPrintValueAtom d expr

85prettyPrintValue d expr@Constructor{} = prettyPrintValueAtom d expr

68prettyPrintValue d expr@Constructor{} = prettyPrintValueAtom d expr

86prettyPrintValue d expr@Var{} = prettyPrintValueAtom d expr

69prettyPrintValue d expr@Var{} = prettyPrintValueAtom d expr

@@ -92,13 +75,7 @@ prettyPrintValue d expr@ObjectGetter{} = prettyPrintValueAtom d expr

93-- | Pretty-print an atomic expression, adding parentheses if necessary.

76-- | Pretty-print an atomic expression, adding parentheses if necessary.

94prettyPrintValueAtom :: Int -> Expr -> Box

77prettyPrintValueAtom :: Int -> Expr -> Box

95−prettyPrintValueAtom _ (NumericLiteral n) = text $ either show show n

78+prettyPrintValueAtom d (Literal l) = prettyPrintLiteralValue d l

96−prettyPrintValueAtom _ (StringLiteral s) = text $ show s

97−prettyPrintValueAtom _ (CharLiteral c) = text $ show c

98−prettyPrintValueAtom _ (BooleanLiteral True) = text "true"

99−prettyPrintValueAtom _ (BooleanLiteral False) = text "false"

100−prettyPrintValueAtom d (ArrayLiteral xs) = list '[' ']' (prettyPrintValue (d - 1)) xs

101−prettyPrintValueAtom d (ObjectLiteral ps) = prettyPrintObject (d - 1) $ second Just `map` ps

102prettyPrintValueAtom _ AnonymousArgument = text "_"

79prettyPrintValueAtom _ AnonymousArgument = text "_"

103prettyPrintValueAtom _ (Constructor name) = text $ runProperName (disqualify name)

80prettyPrintValueAtom _ (Constructor name) = text $ runProperName (disqualify name)

104prettyPrintValueAtom _ (Var ident) = text $ showIdent (disqualify ident)

81prettyPrintValueAtom _ (Var ident) = text $ showIdent (disqualify ident)

@@ -116,6 +93,15 @@ prettyPrintValueAtom d (UnaryMinus expr) = text "(-" <> prettyPrintValue d expr

116prettyPrintValueAtom _ (ObjectGetter field) = text "_." <> text field

93prettyPrintValueAtom _ (ObjectGetter field) = text "_." <> text field

117prettyPrintValueAtom d expr = (text "(" <> prettyPrintValue d expr) `before` text ")"

94prettyPrintValueAtom d expr = (text "(" <> prettyPrintValue d expr) `before` text ")"

118

96+prettyPrintLiteralValue :: Int -> Literal Expr -> Box

97+prettyPrintLiteralValue _ (NumericLiteral n) = text $ either show show n

98+prettyPrintLiteralValue _ (StringLiteral s) = text $ show s

99+prettyPrintLiteralValue _ (CharLiteral c) = text $ show c

100+prettyPrintLiteralValue _ (BooleanLiteral True) = text "true"

101+prettyPrintLiteralValue _ (BooleanLiteral False) = text "false"

102+prettyPrintLiteralValue d (ArrayLiteral xs) = list '[' ']' (prettyPrintValue (d - 1)) xs

103+prettyPrintLiteralValue d (ObjectLiteral ps) = prettyPrintObject (d - 1) $ second Just `map` ps

104+

119prettyPrintDeclaration :: Int -> Declaration -> Box

105prettyPrintDeclaration :: Int -> Declaration -> Box

120prettyPrintDeclaration d _ | d < 0 = ellipsis

106prettyPrintDeclaration d _ | d < 0 = ellipsis

121prettyPrintDeclaration _ (TypeDeclaration ident ty) =

107prettyPrintDeclaration _ (TypeDeclaration ident ty) =

@@ -160,32 +146,35 @@ prettyPrintDoNotationElement d (PositionedDoNotationElement _ _ el) = prettyPrin

160

146

161prettyPrintBinderAtom :: Binder -> String

147prettyPrintBinderAtom :: Binder -> String

162prettyPrintBinderAtom NullBinder = "_"

148prettyPrintBinderAtom NullBinder = "_"

163−prettyPrintBinderAtom (StringBinder str) = show str

149+prettyPrintBinderAtom (LiteralBinder l) = prettyPrintLiteralBinder l

164−prettyPrintBinderAtom (CharBinder c) = show c

165−prettyPrintBinderAtom (NumberBinder num) = either show show num

166−prettyPrintBinderAtom (BooleanBinder True) = "true"

167−prettyPrintBinderAtom (BooleanBinder False) = "false"

168prettyPrintBinderAtom (VarBinder ident) = showIdent ident

150prettyPrintBinderAtom (VarBinder ident) = showIdent ident

169prettyPrintBinderAtom (ConstructorBinder ctor []) = runProperName (disqualify ctor)

151prettyPrintBinderAtom (ConstructorBinder ctor []) = runProperName (disqualify ctor)

170prettyPrintBinderAtom b@ConstructorBinder{} = parens (prettyPrintBinder b)

152prettyPrintBinderAtom b@ConstructorBinder{} = parens (prettyPrintBinder b)

171−prettyPrintBinderAtom (ObjectBinder bs) =

153+prettyPrintBinderAtom (NamedBinder ident binder) = showIdent ident ++ "@" ++ prettyPrintBinder binder

154+prettyPrintBinderAtom (PositionedBinder _ _ binder) = prettyPrintBinderAtom binder

155+prettyPrintBinderAtom (TypedBinder _ binder) = prettyPrintBinderAtom binder

156+prettyPrintBinderAtom (OpBinder op) = showIdent (disqualify op)

157+prettyPrintBinderAtom (BinaryNoParensBinder op b1 b2) =

158+ prettyPrintBinderAtom b1 ++ " " ++ prettyPrintBinderAtom op ++ " " ++ prettyPrintBinderAtom b2

159+prettyPrintBinderAtom (ParensInBinder b) = parens (prettyPrintBinder b)

160+

161+prettyPrintLiteralBinder :: Literal Binder -> String

162+prettyPrintLiteralBinder (StringLiteral str) = show str

163+prettyPrintLiteralBinder (CharLiteral c) = show c

164+prettyPrintLiteralBinder (NumericLiteral num) = either show show num

165+prettyPrintLiteralBinder (BooleanLiteral True) = "true"

166+prettyPrintLiteralBinder (BooleanLiteral False) = "false"

167+prettyPrintLiteralBinder (ObjectLiteral bs) =

172 "{ "

168 "{ "

173 ++ intercalate ", " (map prettyPrintObjectPropertyBinder bs)

169 ++ intercalate ", " (map prettyPrintObjectPropertyBinder bs)

174 ++ " }"

170 ++ " }"

175 where

171 where

176 prettyPrintObjectPropertyBinder :: (String, Binder) -> String

172 prettyPrintObjectPropertyBinder :: (String, Binder) -> String

177 prettyPrintObjectPropertyBinder (key, binder) = prettyPrintObjectKey key ++ ": " ++ prettyPrintBinder binder

173 prettyPrintObjectPropertyBinder (key, binder) = prettyPrintObjectKey key ++ ": " ++ prettyPrintBinder binder

178−prettyPrintBinderAtom (ArrayBinder bs) =

174+prettyPrintLiteralBinder (ArrayLiteral bs) =

179 "[ "

175 "[ "

180 ++ intercalate ", " (map prettyPrintBinder bs)

176 ++ intercalate ", " (map prettyPrintBinder bs)

181 ++ " ]"

177 ++ " ]"

182−prettyPrintBinderAtom (NamedBinder ident binder) = showIdent ident ++ "@" ++ prettyPrintBinder binder

183−prettyPrintBinderAtom (PositionedBinder _ _ binder) = prettyPrintBinderAtom binder

184−prettyPrintBinderAtom (TypedBinder _ binder) = prettyPrintBinderAtom binder

185−prettyPrintBinderAtom (OpBinder op) = showIdent (disqualify op)

186−prettyPrintBinderAtom (BinaryNoParensBinder op b1 b2) =

187− prettyPrintBinderAtom b1 ++ " " ++ prettyPrintBinderAtom op ++ " " ++ prettyPrintBinderAtom b2

188−prettyPrintBinderAtom (ParensInBinder b) = parens (prettyPrintBinder b)

189

178

190-- |

179-- |

191-- Generate a pretty-printed string representing a Binder

180-- Generate a pretty-printed string representing a Binder

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

@@ -19,7 +19,11 @@ import Language.PureScript.AST

19import Language.PureScript.Errors

20import Language.PureScript.Names

22+desugarObjectConstructors

23+ :: forall m

22−desugarObjectConstructors :: forall m. (Applicative m, MonadSupply m, MonadError MultipleErrors m) => Module -> m Module

24+ . (Applicative m, MonadSupply m, MonadError MultipleErrors m)

25+ => Module

26+ -> m Module

23desugarObjectConstructors (Module ss coms mn ds exts) = Module ss coms mn <$> mapM desugarDecl ds <*> pure exts

27desugarObjectConstructors (Module ss coms mn ds exts) = Module ss coms mn <$> mapM desugarDecl ds <*> pure exts

24 where

28 where

@@ -38,7 +42,7 @@ desugarObjectConstructors (Module ss coms mn ds exts) = Module ss coms mn <$> ma

38 | b' <- stripPositionInfo b

42 | b' <- stripPositionInfo b

39 , BinaryNoParens op u val <- b'

43 , BinaryNoParens op u val <- b'

40 , isAnonymousArgument u = return $ OperatorSection op (Right val)

44 , isAnonymousArgument u = return $ OperatorSection op (Right val)

41− desugarExpr (ObjectLiteral ps) = wrapLambda ObjectLiteral ps

45+ desugarExpr (Literal (ObjectLiteral ps)) = wrapLambda (Literal . ObjectLiteral) ps

42 desugarExpr (ObjectUpdate u ps) | isAnonymousArgument u = do

46 desugarExpr (ObjectUpdate u ps) | isAnonymousArgument u = do

43 obj <- freshIdent'

47 obj <- freshIdent'

44 Abs (Left obj) <$> wrapLambda (ObjectUpdate (Var (Qualified Nothing obj))) ps

48 Abs (Left obj) <$> wrapLambda (ObjectUpdate (Var (Qualified Nothing obj))) ps

src/Language/PureScript/Sugar/TypeClasses.hs+1−1

@@ -297,7 +297,7 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =

297 , let tyArgs = map (replaceAllTypeVars (zip (map fst args) tys)) suTyArgs

298 ]

299

300− let props = ObjectLiteral (members ++ superclasses)

300+ let props = Literal $ ObjectLiteral (members ++ superclasses)

301 dictTy = foldl TypeApp (TypeConstructor (fmap coerceProperName className)) tys

302 constrainedTy = quantify (if null deps then dictTy else ConstrainedType deps dictTy)

303 dict = TypeClassDictionaryConstructorApp className props

src/Language/PureScript/Sugar/TypeClasses/Deriving.hs+49−29

@@ -115,15 +115,21 @@ deriveGeneric mn ds tyConNm dargs = do

115 return $ CaseAlternative [ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)] (Right (caseResult idents))

116 where

117 caseResult idents =

118− App (prodConstructor (StringLiteral . showQualified runProperName $ Qualified (Just mn) ctorName))

118+ App (prodConstructor (Literal . StringLiteral . showQualified runProperName $ Qualified (Just mn) ctorName))

119− . ArrayLiteral

119+ . Literal . ArrayLiteral

120 $ zipWith toSpineFun (map (Var . Qualified Nothing) idents) tys

121

122 toSpineFun :: Expr -> Type -> Expr

123 toSpineFun i r | Just rec <- objectType r =

124− lamNull . recordConstructor . ArrayLiteral .

124+ lamNull . recordConstructor . Literal . ArrayLiteral

125+ . map

126+ (\(str,typ) ->

127+ Literal $ ObjectLiteral

128+ [ ("recLabel", Literal (StringLiteral str))

125− map (\(str,typ) -> ObjectLiteral [("recLabel", StringLiteral str), ("recValue", toSpineFun (Accessor str i) typ)])

129+ , ("recValue", toSpineFun (Accessor str i) typ)

130+ ]

131+ )

126− $ decomposeRec rec

132+ $ decomposeRec rec

127 toSpineFun i _ = lamNull $ App (mkGenVar (Ident C.toSpine)) i

133 toSpineFun i _ = lamNull $ App (mkGenVar (Ident C.toSpine)) i

128 mkSpineFunction (PositionedDeclaration _ _ d) = mkSpineFunction d

134 mkSpineFunction (PositionedDeclaration _ _ d) = mkSpineFunction d

129 mkSpineFunction _ = internalError "mkSpineFunction: expected DataDeclaration"

135 mkSpineFunction _ = internalError "mkSpineFunction: expected DataDeclaration"

@@ -132,30 +138,37 @@ deriveGeneric mn ds tyConNm dargs = do

132 mkSignatureFunction (DataDeclaration _ name tyArgs args) classArgs = lamNull . mkSigProd $ map mkProdClause args

138 mkSignatureFunction (DataDeclaration _ name tyArgs args) classArgs = lamNull . mkSigProd $ map mkProdClause args

133 where

139 where

134 mkSigProd :: [Expr] -> Expr

140 mkSigProd :: [Expr] -> Expr

141+ mkSigProd =

142+ App

143+ (App

135− mkSigProd = App (App (Constructor (Qualified (Just dataGeneric) (ProperName "SigProd")))

144+ (Constructor (Qualified (Just dataGeneric) (ProperName "SigProd")))

136− (StringLiteral (showQualified runProperName (Qualified (Just mn) name)))

145+ (Literal (StringLiteral (showQualified runProperName (Qualified (Just mn) name))))

146+ )

147+ . Literal

137− ) . ArrayLiteral

148+ . ArrayLiteral

138

149

139 mkSigRec :: [Expr] -> Expr

150 mkSigRec :: [Expr] -> Expr

140− mkSigRec = App (Constructor (Qualified (Just dataGeneric) (ProperName "SigRecord"))) . ArrayLiteral

151+ mkSigRec = App (Constructor (Qualified (Just dataGeneric) (ProperName "SigRecord"))) . Literal . ArrayLiteral

141

152

142 proxy :: Type -> Type

153 proxy :: Type -> Type

143 proxy = TypeApp (TypeConstructor (Qualified (Just typesProxy) (ProperName "Proxy")))

154 proxy = TypeApp (TypeConstructor (Qualified (Just typesProxy) (ProperName "Proxy")))

144

155

145 mkProdClause :: (ProperName 'ConstructorName, [Type]) -> Expr

156 mkProdClause :: (ProperName 'ConstructorName, [Type]) -> Expr

146 mkProdClause (ctorName, tys) =

157 mkProdClause (ctorName, tys) =

147− ObjectLiteral

158+ Literal $ ObjectLiteral

148− [ ("sigConstructor", StringLiteral (showQualified runProperName (Qualified (Just mn) ctorName)))

159+ [ ("sigConstructor", Literal (StringLiteral (showQualified runProperName (Qualified (Just mn) ctorName))))

149− , ("sigValues", ArrayLiteral . map (mkProductSignature . instantiate) $ tys)

160+ , ("sigValues", Literal . ArrayLiteral . map (mkProductSignature . instantiate) $ tys)

150 ]

161 ]

151

162

152 mkProductSignature :: Type -> Expr

163 mkProductSignature :: Type -> Expr

153 mkProductSignature r | Just rec <- objectType r =

164 mkProductSignature r | Just rec <- objectType r =

165+ lamNull . mkSigRec $

166+ [ Literal $ ObjectLiteral

154− lamNull . mkSigRec $ [ ObjectLiteral [ ("recLabel", StringLiteral str)

167+ [ ("recLabel", Literal (StringLiteral str))

155− , ("recValue", mkProductSignature typ)

168+ , ("recValue", mkProductSignature typ)

156− ]

169+ ]

157− | (str, typ) <- decomposeRec rec

170+ | (str, typ) <- decomposeRec rec

158− ]

171+ ]

159 mkProductSignature typ = lamNull $ App (mkGenVar (Ident C.toSignature))

172 mkProductSignature typ = lamNull $ App (mkGenVar (Ident C.toSignature))

160 (TypedValue False (mkGenVar (Ident "anyProxy")) (proxy typ))

173 (TypedValue False (mkGenVar (Ident "anyProxy")) (proxy typ))

161 instantiate = replaceAllTypeVars (zipWith (\(arg, _) ty -> (arg, ty)) tyArgs classArgs)

174 instantiate = replaceAllTypeVars (zipWith (\(arg, _) ty -> (arg, ty)) tyArgs classArgs)

@@ -182,10 +195,17 @@ deriveGeneric mn ds tyConNm dargs = do

182 mkAlternative :: (ProperName 'ConstructorName, [Type]) -> m CaseAlternative

195 mkAlternative :: (ProperName 'ConstructorName, [Type]) -> m CaseAlternative

183 mkAlternative (ctorName, tys) = do

196 mkAlternative (ctorName, tys) = do

184 idents <- replicateM (length tys) freshIdent'

197 idents <- replicateM (length tys) freshIdent'

198+ return $

199+ CaseAlternative

200+ [ prodBinder

185− return $ CaseAlternative [ prodBinder [ StringBinder (showQualified runProperName (Qualified (Just mn) ctorName)), ArrayBinder (map VarBinder idents)]]

201+ [ LiteralBinder (StringLiteral (showQualified runProperName (Qualified (Just mn) ctorName)))

202+ , LiteralBinder (ArrayLiteral (map VarBinder idents))

203+ ]

204+ ]

186− . Right

205+ . Right

206+ $ liftApplicative

187− $ liftApplicative (mkJust $ Constructor (Qualified (Just mn) ctorName))

207+ (mkJust $ Constructor (Qualified (Just mn) ctorName))

188− (zipWith fromSpineFun (map (Var . Qualified Nothing) idents) tys)

208+ (zipWith fromSpineFun (map (Var . Qualified Nothing) idents) tys)

189

209

190 addCatch :: [CaseAlternative] -> [CaseAlternative]

210 addCatch :: [CaseAlternative] -> [CaseAlternative]

191 addCatch = (++ [catchAll])

211 addCatch = (++ [catchAll])

@@ -202,15 +222,15 @@ deriveGeneric mn ds tyConNm dargs = do

202 fromSpineFun e _ = App (mkGenVar (Ident C.fromSpine)) (App e (mkPrelVar (Ident "unit")))

222 fromSpineFun e _ = App (mkGenVar (Ident C.fromSpine)) (App e (mkPrelVar (Ident "unit")))

203

223

204 mkRecCase :: [(String, Type)] -> CaseAlternative

224 mkRecCase :: [(String, Type)] -> CaseAlternative

225+ mkRecCase rs =

226+ CaseAlternative

205− mkRecCase rs = CaseAlternative [ recordBinder [ ArrayBinder (map (VarBinder . Ident . fst) rs)

227+ [ recordBinder [ LiteralBinder (ArrayLiteral (map (VarBinder . Ident . fst) rs)) ] ]

206− ]

207− ]

208− . Right

228+ . Right

209− $ liftApplicative (mkRecFun rs) (map (\(x, y) -> fromSpineFun (Accessor "recValue" (mkVar (Ident x))) y) rs)

229+ $ liftApplicative (mkRecFun rs) (map (\(x, y) -> fromSpineFun (Accessor "recValue" (mkVar (Ident x))) y) rs)

210

230

211 mkRecFun :: [(String, Type)] -> Expr

231 mkRecFun :: [(String, Type)] -> Expr

212 mkRecFun xs = mkJust $ foldr lam recLiteral (map (Ident . fst) xs)

232 mkRecFun xs = mkJust $ foldr lam recLiteral (map (Ident . fst) xs)

213− where recLiteral = ObjectLiteral $ map (\(s,_) -> (s, mkVar (Ident s))) xs

233+ where recLiteral = Literal . ObjectLiteral $ map (\(s,_) -> (s, mkVar (Ident s))) xs

214 mkFromSpineFunction (PositionedDeclaration _ _ d) = mkFromSpineFunction d

234 mkFromSpineFunction (PositionedDeclaration _ _ d) = mkFromSpineFunction d

215 mkFromSpineFunction _ = internalError "mkFromSpineFunction: expected DataDeclaration"

235 mkFromSpineFunction _ = internalError "mkFromSpineFunction: expected DataDeclaration"

216

236

@@ -255,7 +275,7 @@ deriveEq mn ds tyConNm = do

255 | length xs /= 1 = xs ++ [catchAll]

275 | length xs /= 1 = xs ++ [catchAll]

256 | otherwise = xs -- Avoid redundant case

276 | otherwise = xs -- Avoid redundant case

257 where

277 where

258− catchAll = CaseAlternative [NullBinder, NullBinder] (Right (BooleanLiteral False))

278+ catchAll = CaseAlternative [NullBinder, NullBinder] (Right (Literal (BooleanLiteral False)))

259

279

260 mkCtorClause :: (ProperName 'ConstructorName, [Type]) -> m CaseAlternative

280 mkCtorClause :: (ProperName 'ConstructorName, [Type]) -> m CaseAlternative

261 mkCtorClause (ctorName, tys) = do

281 mkCtorClause (ctorName, tys) = do

@@ -267,7 +287,7 @@ deriveEq mn ds tyConNm = do

267 caseBinder idents = ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)

287 caseBinder idents = ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)

268

288

269 conjAll :: [Expr] -> Expr

289 conjAll :: [Expr] -> Expr

270− conjAll [] = BooleanLiteral True

290+ conjAll [] = Literal (BooleanLiteral True)

271 conjAll xs = foldl1 preludeConj xs

291 conjAll xs = foldl1 preludeConj xs

272

292

273 toEqTest :: Expr -> Expr -> Type -> Expr

293 toEqTest :: Expr -> Expr -> Type -> Expr

src/Language/PureScript/TypeChecker/Types.hs+25−25

@@ -217,22 +217,22 @@ infer' ::

217 (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

218 Expr ->

219 m Expr

220−infer' v@(NumericLiteral (Left _)) = return $ TypedValue True v tyInt

220+infer' v@(Literal (NumericLiteral (Left _))) = return $ TypedValue True v tyInt

221−infer' v@(NumericLiteral (Right _)) = return $ TypedValue True v tyNumber

221+infer' v@(Literal (NumericLiteral (Right _))) = return $ TypedValue True v tyNumber

222−infer' v@(StringLiteral _) = return $ TypedValue True v tyString

222+infer' v@(Literal (StringLiteral _)) = return $ TypedValue True v tyString

223−infer' v@(CharLiteral _) = return $ TypedValue True v tyChar

223+infer' v@(Literal (CharLiteral _)) = return $ TypedValue True v tyChar

224−infer' v@(BooleanLiteral _) = return $ TypedValue True v tyBoolean

224+infer' v@(Literal (BooleanLiteral _)) = return $ TypedValue True v tyBoolean

225−infer' (ArrayLiteral vals) = do

225+infer' (Literal (ArrayLiteral vals)) = do

226 ts <- traverse infer vals

227 els <- freshType

228 forM_ ts $ \(TypedValue _ _ t) -> unifyTypes els t

229− return $ TypedValue True (ArrayLiteral ts) (TypeApp tyArray els)

229+ return $ TypedValue True (Literal (ArrayLiteral ts)) (TypeApp tyArray els)

230−infer' (ObjectLiteral ps) = do

230+infer' (Literal (ObjectLiteral ps)) = do

231 ensureNoDuplicateProperties ps

232 ts <- traverse (infer . snd) ps

233 let fields = zipWith (\name (TypedValue _ _ t) -> (name, t)) (map fst ps) ts

234 ty = TypeApp tyObject $ rowFromList (fields, REmpty)

235− return $ TypedValue True (ObjectLiteral (zip (map fst ps) ts)) ty

235+ return $ TypedValue True (Literal (ObjectLiteral (zip (map fst ps) ts))) ty

236infer' (ObjectUpdate o ps) = do

237 ensureNoDuplicateProperties ps

238 row <- freshType

@@ -346,11 +346,11 @@ inferBinder :: forall m.

346 Binder ->

347 m (M.Map Ident Type)

348inferBinder _ NullBinder = return M.empty

349−inferBinder val (StringBinder _) = unifyTypes val tyString >> return M.empty

349+inferBinder val (LiteralBinder (StringLiteral _)) = unifyTypes val tyString >> return M.empty

350−inferBinder val (CharBinder _) = unifyTypes val tyChar >> return M.empty

350+inferBinder val (LiteralBinder (CharLiteral _)) = unifyTypes val tyChar >> return M.empty

351−inferBinder val (NumberBinder (Left _)) = unifyTypes val tyInt >> return M.empty

351+inferBinder val (LiteralBinder (NumericLiteral (Left _))) = unifyTypes val tyInt >> return M.empty

352−inferBinder val (NumberBinder (Right _)) = unifyTypes val tyNumber >> return M.empty

352+inferBinder val (LiteralBinder (NumericLiteral (Right _))) = unifyTypes val tyNumber >> return M.empty

353−inferBinder val (BooleanBinder _) = unifyTypes val tyBoolean >> return M.empty

353+inferBinder val (LiteralBinder (BooleanLiteral _)) = unifyTypes val tyBoolean >> return M.empty

354inferBinder val (VarBinder name) = return $ M.singleton name val

355inferBinder val (ConstructorBinder ctor binders) = do

356 env <- getEnv

@@ -369,7 +369,7 @@ inferBinder val (ConstructorBinder ctor binders) = do

369 where

370 go args (TypeApp (TypeApp fn arg) ret) | fn == tyFunction = go (arg : args) ret

371 go args ret = (args, ret)

372−inferBinder val (ObjectBinder props) = do

372+inferBinder val (LiteralBinder (ObjectLiteral props)) = do

373 row <- freshType

374 rest <- freshType

375 m1 <- inferRowProperties row rest props

@@ -383,7 +383,7 @@ inferBinder val (ObjectBinder props) = do

383 m1 <- inferBinder propTy binder

384 m2 <- inferRowProperties nrow (RCons name propTy row) binders

385 return $ m1 `M.union` m2

386−inferBinder val (ArrayBinder binders) = do

386+inferBinder val (LiteralBinder (ArrayLiteral binders)) = do

387 el <- freshType

388 m1 <- M.unions <$> traverse (inferBinder el) binders

389 unifyTypes val (TypeApp tyArray el)

@@ -524,19 +524,19 @@ check' val u@(TUnknown _) = do

524 (val'', ty') <- instantiatePolyTypeWithUnknowns val' ty

525 unifyTypes ty' u

526 return $ TypedValue True val'' ty'

527−check' v@(NumericLiteral (Left _)) t | t == tyInt =

527+check' v@(Literal (NumericLiteral (Left _))) t | t == tyInt =

528 return $ TypedValue True v t

529−check' v@(NumericLiteral (Right _)) t | t == tyNumber =

529+check' v@(Literal (NumericLiteral (Right _))) t | t == tyNumber =

530 return $ TypedValue True v t

531−check' v@(StringLiteral _) t | t == tyString =

531+check' v@(Literal (StringLiteral _)) t | t == tyString =

532 return $ TypedValue True v t

533−check' v@(CharLiteral _) t | t == tyChar =

533+check' v@(Literal (CharLiteral _)) t | t == tyChar =

534 return $ TypedValue True v t

535−check' v@(BooleanLiteral _) t | t == tyBoolean =

535+check' v@(Literal (BooleanLiteral _)) t | t == tyBoolean =

536 return $ TypedValue True v t

537−check' (ArrayLiteral vals) t@(TypeApp a ty) = do

537+check' (Literal (ArrayLiteral vals)) t@(TypeApp a ty) = do

538 unifyTypes a tyArray

539− array <- ArrayLiteral <$> forM vals (`check` ty)

539+ array <- Literal . ArrayLiteral <$> forM vals (`check` ty)

540 return $ TypedValue True array t

541check' (Abs (Left arg) ret) ty@(TypeApp (TypeApp t argTy) retTy) = do

542 unifyTypes t tyFunction

@@ -587,10 +587,10 @@ check' (IfThenElse cond th el) ty = do

587 th' <- check th ty

588 el' <- check el ty

589 return $ TypedValue True (IfThenElse cond' th' el') ty

590−check' e@(ObjectLiteral ps) t@(TypeApp obj row) | obj == tyObject = do

590+check' e@(Literal (ObjectLiteral ps)) t@(TypeApp obj row) | obj == tyObject = do

591 ensureNoDuplicateProperties ps

592 ps' <- checkProperties e ps row False

593− return $ TypedValue True (ObjectLiteral ps') t

593+ return $ TypedValue True (Literal (ObjectLiteral ps')) t

594check' (TypeClassDictionaryConstructorApp name ps) t = do

595 ps' <- check' ps t

596 return $ TypedValue True (TypeClassDictionaryConstructorApp name ps') t