e5655c8 · rowtype-yoga/purescript-native

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

Use generic Literal in the AST

commite5655c8db56c7119d1e02e0a9392e8cfd57278d2 authorGary Burgess <gary.burgess@gmail.com> dateThu 3 Mar 2016, 02:14 (11 years ago) parentc4ae1cf

19 files changed+374−367

compare with golang

unifiedsplit

psci/PSCi.hs+1−1

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

214214handleDecls ds = do

215215 st <- PSCI $ lift get

216216 let st' = updateLets ds st

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

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

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

219219 case e of

220220 Left err -> PSCI $ printErrors err

purescript.cabal+1−1

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

9696 Language.PureScript.AST.Binders

9797 Language.PureScript.AST.Declarations

9898 Language.PureScript.AST.Operators

99+ Language.PureScript.AST.Literals

99100 Language.PureScript.AST.SourcePos

100101 Language.PureScript.AST.Traversals

101102 Language.PureScript.AST.Exported

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

119120 Language.PureScript.CoreFn.Binders

120121 Language.PureScript.CoreFn.Desugar

121122 Language.PureScript.CoreFn.Expr

122− Language.PureScript.CoreFn.Literals

123123 Language.PureScript.CoreFn.Meta

124124 Language.PureScript.CoreFn.Module

125125 Language.PureScript.CoreFn.Traversals

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

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

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

1+-- |

2+-- The initial PureScript AST

23--

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−

154module Language.PureScript.AST (

165 module AST

176) where

187

198import Language.PureScript.AST.Binders as AST

209import Language.PureScript.AST.Declarations as AST

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

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

2112import Language.PureScript.AST.Operators as AST

2213import Language.PureScript.AST.SourcePos as AST

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

44module Language.PureScript.AST.Binders where

66import Language.PureScript.AST.SourcePos

7+import Language.PureScript.AST.Literals

78import Language.PureScript.Names

89import Language.PureScript.Comments

910import Language.PureScript.Types

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

1718 --

1819 = NullBinder

1920 -- |

20− -- A binder which matches a boolean literal

21+ -- A binder which matches a literal

2122 --

22− | BooleanBinder Bool

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)

23+ | LiteralBinder (Literal Binder)

3524 -- |

3625 -- A binder which binds an identifier

3726 --

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

5948 --

6049 | ParensInBinder Binder

6150 -- |

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

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

7152 --

7253 | NamedBinder Ident Binder

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

8667binderNames :: Binder -> [Ident]

8768binderNames = go []

8869 where

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

8971 go ns (VarBinder name) = name : ns

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

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

9274 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

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

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

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

9878 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

1919import Control.Monad.Identity

2020

2121import Language.PureScript.AST.Binders

22+import Language.PureScript.AST.Literals

2223import Language.PureScript.AST.Operators

2324import Language.PureScript.AST.SourcePos

2425import Language.PureScript.Types

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

309310--

310311data Expr

311312 -- |

312− -- A numeric literal

313+ -- A literal value

313314 --

314− = NumericLiteral (Either Integer Double)

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

315+ = Literal (Literal Expr)

327316 -- |

328317 -- A prefix -, will be desugared

329318 --

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

347336 --

348337 | OperatorSection Expr (Either Expr Expr)

349338 -- |

350− -- An array literal

351− --

352− | ArrayLiteral [Expr]

353− -- |

354− -- An object literal

355− --

356− | ObjectLiteral [(String, Expr)]

357− -- |

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

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

360341 --

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

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

33-- |

44-- The core functional representation for literal values.

55--

6−module Language.PureScript.CoreFn.Literals where

6+module Language.PureScript.AST.Literals where

88-- |

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

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

3434 -- An object literal

3535 --

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

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

1+{-# LANGUAGE ScopedTypeVariables #-}

142

3+-- |

4+-- AST traversal helpers

5+--

156module Language.PureScript.AST.Traversals where

167

178import Prelude ()

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

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

2718

2819import Language.PureScript.AST.Binders

20+import Language.PureScript.AST.Literals

2921import Language.PureScript.AST.Declarations

3022import Language.PureScript.Types

3123import Language.PureScript.Traversals

3224import Language.PureScript.Names

3325

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

35− (Expr -> Expr) ->

36− (Binder -> Binder) ->

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

26+everywhereOnValues

27+ :: (Declaration -> Declaration)

28+ -> (Expr -> Expr)

29+ -> (Binder -> Binder)

30+ -> ( Declaration -> Declaration

31+ , Expr -> Expr

32+ , Binder -> Binder

33+ )

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

3935 where

4036 f' :: Declaration -> Declaration

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

4743 f' other = f other

4844

4945 g' :: Expr -> Expr

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

5047 g' (UnaryMinus v) = g (UnaryMinus (g' v))

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

5249 g' (Parens v) = g (Parens (g' v))

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

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

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

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

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

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

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

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

7368 h' (ParensInBinder b) = h (ParensInBinder (h' b))

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

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

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

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

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

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

7973 h' other = h other

8074

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+

8180 handleCaseAlternative :: CaseAlternative -> CaseAlternative

8281 handleCaseAlternative ca =

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

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

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

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

9291

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

94− (Declaration -> m Declaration) ->

95− (Expr -> m Expr) ->

96− (Binder -> m Binder) ->

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

92+everywhereOnValuesTopDownM

93+ :: forall m

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

95+ => (Declaration -> m Declaration)

96+ -> (Expr -> m Expr)

97+ -> (Binder -> m Binder)

98+ -> ( Declaration -> m Declaration

99+ , Expr -> m Expr

100+ , Binder -> m Binder

101+ )

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

99103 where

104+

105+ f' :: Declaration -> m Declaration

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

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

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

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

106112 f' other = f other

107113

114+ g' :: Expr -> m Expr

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

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

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

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

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

112120 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

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

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

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

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

126132 g' other = g other

127133

134+ h' :: Binder -> m Binder

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

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

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

130138 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

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

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

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

136142 h' other = h other

137143

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

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

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

150+ handleCaseAlternative (CaseAlternative bs val) =

151+ CaseAlternative

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

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

140154

155+ handleDoNotationElement :: DoNotationElement -> m DoNotationElement

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

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

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

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

145160

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

147− (Declaration -> m Declaration) ->

148− (Expr -> m Expr) ->

149− (Binder -> m Binder) ->

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

161+everywhereOnValuesM

162+ :: forall m

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

164+ => (Declaration -> m Declaration)

165+ -> (Expr -> m Expr)

166+ -> (Binder -> m Binder)

167+ -> ( Declaration -> m Declaration

168+ , Expr -> m Expr

169+ , Binder -> m Binder

170+ )

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

152172 where

173+

174+ f' :: Declaration -> m Declaration

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

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

155177 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')

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

159181 f' other = f other

160182

183+ g' :: Expr -> m Expr

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

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

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

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

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

165189 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

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

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

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

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

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

179201 g' other = g other

180202

203+ h' :: Binder -> m Binder

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

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

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

183207 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

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

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

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

189211 h' other = h other

190212

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

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

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

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

193223

224+ handleDoNotationElement :: DoNotationElement -> m DoNotationElement

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

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

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

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

198229

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

200− (Declaration -> r) ->

201− (Expr -> r) ->

202− (Binder -> r) ->

203− (CaseAlternative -> r) ->

204− (DoNotationElement -> r) ->

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

230+everythingOnValues

231+ :: forall r

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

233+ -> (Declaration -> r)

234+ -> (Expr -> r)

235+ -> (Binder -> r)

236+ -> (CaseAlternative -> r)

237+ -> (DoNotationElement -> r)

238+ -> ( Declaration -> r

239+ , Expr -> r

240+ , Binder -> r

241+ , CaseAlternative -> r

242+ , DoNotationElement -> r

243+ )

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

207245 where

246+

247+ f' :: Declaration -> r

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

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

210250 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')

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

215255 f' d = f d

216256

257+ g' :: Expr -> r

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

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

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

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

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

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

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

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

226266 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')

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

235275 g' v = g v

236276

277+ h' :: Binder -> r

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

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

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

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

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

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

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

245285 h' b = h b

246286

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

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

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

249295

296+ j' :: DoNotationElement -> r

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

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

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

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

254301

255−everythingWithContextOnValues ::

256− s ->

257− r ->

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

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

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

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

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

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

264− ( Declaration -> r

265− , Expr -> r

266− , Binder -> r

267− , CaseAlternative -> r

268− , DoNotationElement -> r)

302+everythingWithContextOnValues

303+ :: forall s r

304+ . s

305+ -> r

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

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

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

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

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

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

312+ -> ( Declaration -> r

313+ , Expr -> r

314+ , Binder -> r

315+ , CaseAlternative -> r

316+ , DoNotationElement -> r)

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

270318 where

319+

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

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

272322

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

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

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

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

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

280331 f' _ _ = r0

281332

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

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

283335

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

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

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

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

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

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

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

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

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

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

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

302354 g' _ _ = r0

303355

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

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

305358

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

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

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

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

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

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

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

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

314367 h' _ _ = r0

315368

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

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

317376

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

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

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

320380

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

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

322383

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

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

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

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

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

327389

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

329− s ->

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

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

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

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

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

335− ( Declaration -> m Declaration

336− , Expr -> m Expr

337− , Binder -> m Binder

338− , CaseAlternative -> m CaseAlternative

339− , DoNotationElement -> m DoNotationElement)

390+everywhereWithContextOnValuesM

391+ :: forall m s

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

393+ => s

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

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

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

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

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

399+ -> ( Declaration -> m Declaration

400+ , Expr -> m Expr

401+ , Binder -> m Binder

402+ , CaseAlternative -> m CaseAlternative

403+ , DoNotationElement -> m DoNotationElement)

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

341405 where

342406 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

351415

352416 g'' s = uncurry g' <=< g s

353417

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

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

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

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

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

358423 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

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

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

363426 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

373436

374437 h'' s = uncurry h' <=< h s

375438

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

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

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

378442 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

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

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

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

384446 h' _ other = return other

385447

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+

386453 i'' s = uncurry i' <=< i s

387454

388455 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

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

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

396463

397−everythingWithScope ::

398− (Monoid r) =>

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

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

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

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

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

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

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

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

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

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

464+everythingWithScope

465+ :: forall r

466+ . (Monoid r)

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

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

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

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

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

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

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

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

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

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

477+ )

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

410479 where

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

412481 (<>) = mappend

413482

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

414484 f'' s a = f s a <> f' s a

415485

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

416487 f' s (DataBindingGroupDeclaration ds) =

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

418489 in foldMap (f'' s') ds

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

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

432503 f' _ _ = mempty

433504

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

434506 g'' s a = g s a <> g' s a

435507

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

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

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

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

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

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

440514 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

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

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

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

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

461533 g' _ _ = mempty

462534

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

463536 h'' s a = h s a <> h' s a

464537

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

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

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

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

467542 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

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

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

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

473546 h' _ _ = mempty

474547

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

475554 i'' s a = i s a <> i' s a

476555

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

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

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

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

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

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

483563

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

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

485566

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

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

487569 j' s (DoNotationBind b v) =

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

498580 getDeclIdent (TypeDeclaration ident _) = Just ident

499581 getDeclIdent _ = Nothing

500582

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

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

503593 where

504594 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

23--

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−

154module Language.PureScript.CoreFn (

165 module C

176) where

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

209import Language.PureScript.CoreFn.Binders as C

2110import Language.PureScript.CoreFn.Desugar as C

2211import Language.PureScript.CoreFn.Expr as C

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

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

2413import Language.PureScript.CoreFn.Meta as C

2514import Language.PureScript.CoreFn.Module as C

2615import Language.PureScript.CoreFn.Traversals as C

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

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

55--

66module Language.PureScript.CoreFn.Binders where

8−import Language.PureScript.CoreFn.Literals

8+import Language.PureScript.AST.Literals

99import Language.PureScript.Names

1010

1111-- |

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

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

1717import Language.PureScript.CoreFn.Ann

1818import Language.PureScript.CoreFn.Binders

1919import Language.PureScript.CoreFn.Expr

20−import Language.PureScript.CoreFn.Literals

20+import Language.PureScript.AST.Literals

2121import Language.PureScript.CoreFn.Meta

2222import Language.PureScript.CoreFn.Module

2323import Language.PureScript.Environment

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

8888 -- Desugars expressions from AST to CoreFn representation.

8989 --

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

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

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)

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

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

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

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

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

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

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

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

126116 exprToCoreFn ss com (Just ty) v

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

128118 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)) _)) =

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

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

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

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

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

153143 --

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

155147 binderToCoreFn ss com (A.NullBinder) =

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

165149 binderToCoreFn ss com (A.VarBinder name) =

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

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

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

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

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

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

176156 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

88import Control.Arrow ((***))

1010import Language.PureScript.CoreFn.Binders

11−import Language.PureScript.CoreFn.Literals

11+import Language.PureScript.AST.Literals

1212import Language.PureScript.Names

1313

1414-- |

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

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

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

1+-- |

2+-- CoreFn traversal helpers

23--

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−

154module Language.PureScript.CoreFn.Traversals where

165

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

187

198import Language.PureScript.CoreFn.Binders

209import Language.PureScript.CoreFn.Expr

21−import Language.PureScript.CoreFn.Literals

10+import Language.PureScript.AST.Literals

2211

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

2413 (Expr a -> Expr a) ->

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

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

2424

2525import Language.PureScript.Crash

2626import Language.PureScript.AST.Binders

27+import Language.PureScript.AST.Literals

2728import Language.PureScript.AST.Declarations

2829import Language.PureScript.Environment

2930import Language.PureScript.Names as P

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

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

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

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

122−missingCasesSingle env mn NullBinder (ObjectBinder bs) =

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

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

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

124125 where

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

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

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

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

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

128129 where

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

130131

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

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

142143

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

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

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

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

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

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

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

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

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

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

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

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

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

202203 where

203204 isOtherwise :: Expr -> Bool

204− isOtherwise (BooleanLiteral True) = True

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

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

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

207208 isOtherwise (TypedValue _ e _) = isOtherwise e

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

274275

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

276277 onExpr isP (UnaryMinus e) = onExpr isP e

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

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

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

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

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

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

281282 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

299299booleanLiteral :: TokenParser Bool

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

301301

302−parseNumericLiteral :: TokenParser Expr

302+parseNumericLiteral :: TokenParser (Literal a)

303303parseNumericLiteral = NumericLiteral <$> number

304304

305−parseCharLiteral :: TokenParser Expr

305+parseCharLiteral :: TokenParser (Literal a)

306306parseCharLiteral = CharLiteral <$> charLiteral

307307

308−parseStringLiteral :: TokenParser Expr

308+parseStringLiteral :: TokenParser (Literal a)

309309parseStringLiteral = StringLiteral <$> stringLiteral

310310

311−parseBooleanLiteral :: TokenParser Expr

311+parseBooleanLiteral :: TokenParser (Literal a)

312312parseBooleanLiteral = BooleanLiteral <$> booleanLiteral

313313

314−parseArrayLiteral :: TokenParser Expr

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

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

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

316316

317−parseObjectLiteral :: TokenParser Expr

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

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

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

319319

320320parseIdentifierAndValue :: TokenParser (String, Expr)

321321parseIdentifierAndValue =

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

376376parseValueAtom :: TokenParser Expr

377377parseValueAtom = P.choice

378378 [ parseAnonymousArgument

379− , parseNumericLiteral

380− , parseCharLiteral

381− , parseStringLiteral

382− , parseBooleanLiteral

383− , parseArrayLiteral

384− , P.try parseObjectLiteral

379+ , Literal <$> parseNumericLiteral

380+ , Literal <$> parseCharLiteral

381+ , Literal <$> parseStringLiteral

382+ , Literal <$> parseBooleanLiteral

383+ , Literal <$> parseArrayLiteral parseValue

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

385385 , parseAbs

386386 , P.try parseConstructor

387387 , P.try parseVar

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

469469parseAnonymousArgument :: TokenParser Expr

470470parseAnonymousArgument = underscore *> pure AnonymousArgument

471471

472−parseStringBinder :: TokenParser Binder

473−parseStringBinder = StringBinder <$> stringLiteral

474−

475−parseCharBinder :: TokenParser Binder

476−parseCharBinder = CharBinder <$> charLiteral

477−

478−parseBooleanBinder :: TokenParser Binder

479−parseBooleanBinder = BooleanBinder <$> booleanLiteral

480−

481−parseNumberBinder :: TokenParser Binder

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

472+parseNumberLiteral :: TokenParser Binder

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

483474 where

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

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

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

492483parseConstructorBinder :: TokenParser Binder

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

494485

495−parseObjectBinder :: TokenParser Binder

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

486+parseObjectBinder:: TokenParser Binder

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

497488

498489parseArrayBinder :: TokenParser Binder

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

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

500491

501492parseVarOrNamedBinder :: TokenParser Binder

502493parseVarOrNamedBinder = do

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

541532 parseBinderAtom :: TokenParser Binder

542533 parseBinderAtom = P.choice

543534 [ parseNullBinder

544− , parseCharBinder

545− , parseStringBinder

546− , parseBooleanBinder

547− , parseNumberBinder

535+ , LiteralBinder <$> parseCharLiteral

536+ , LiteralBinder <$> parseStringLiteral

537+ , LiteralBinder <$> parseBooleanLiteral

538+ , parseNumberLiteral

548539 , parseVarOrNamedBinder

549540 , parseConstructorBinder

550541 , parseObjectBinder

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

561552parseBinderNoParens :: TokenParser Binder

562553parseBinderNoParens = P.choice

563554 [ parseNullBinder

564− , parseCharBinder

565− , parseStringBinder

566− , parseBooleanBinder

567− , parseNumberBinder

555+ , LiteralBinder <$> parseCharLiteral

556+ , LiteralBinder <$> parseStringLiteral

557+ , LiteralBinder <$> parseBooleanLiteral

558+ , parseNumberLiteral

568559 , parseVarOrNamedBinder

569560 , parseNullaryConstructorBinder

570561 , 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−--

111-- |

122-- Pretty printer for values

133--

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

15−

164module Language.PureScript.Pretty.Values (

175 prettyPrintValue,

186 prettyPrintBinder,

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

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

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

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

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

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

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

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

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

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

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

9275

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

9477prettyPrintValueAtom :: Int -> Expr -> Box

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

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

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

10279prettyPrintValueAtom _ AnonymousArgument = text "_"

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

10481prettyPrintValueAtom _ (Var ident) = text $ showIdent (disqualify ident)

@@ -116,6 +93,15 @@ prettyPrintValueAtom d (UnaryMinus expr) = text "(-" <> prettyPrintValue d expr

11693prettyPrintValueAtom _ (ObjectGetter field) = text "_." <> text field

11794prettyPrintValueAtom d expr = (text "(" <> prettyPrintValue d expr) `before` text ")"

11895

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+

119105prettyPrintDeclaration :: Int -> Declaration -> Box

120106prettyPrintDeclaration d _ | d < 0 = ellipsis

121107prettyPrintDeclaration _ (TypeDeclaration ident ty) =

@@ -160,32 +146,35 @@ prettyPrintDoNotationElement d (PositionedDoNotationElement _ _ el) = prettyPrin

160146

161147prettyPrintBinderAtom :: Binder -> String

162148prettyPrintBinderAtom NullBinder = "_"

163−prettyPrintBinderAtom (StringBinder str) = show str

164−prettyPrintBinderAtom (CharBinder c) = show c

165−prettyPrintBinderAtom (NumberBinder num) = either show show num

166−prettyPrintBinderAtom (BooleanBinder True) = "true"

167−prettyPrintBinderAtom (BooleanBinder False) = "false"

149+prettyPrintBinderAtom (LiteralBinder l) = prettyPrintLiteralBinder l

168150prettyPrintBinderAtom (VarBinder ident) = showIdent ident

169151prettyPrintBinderAtom (ConstructorBinder ctor []) = runProperName (disqualify ctor)

170152prettyPrintBinderAtom 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) =

172168 "{ "

173169 ++ intercalate ", " (map prettyPrintObjectPropertyBinder bs)

174170 ++ " }"

175171 where

176172 prettyPrintObjectPropertyBinder :: (String, Binder) -> String

177173 prettyPrintObjectPropertyBinder (key, binder) = prettyPrintObjectKey key ++ ": " ++ prettyPrintBinder binder

178−prettyPrintBinderAtom (ArrayBinder bs) =

174+prettyPrintLiteralBinder (ArrayLiteral bs) =

179175 "[ "

180176 ++ intercalate ", " (map prettyPrintBinder bs)

181177 ++ " ]"

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)

189178

190179-- |

191180-- Generate a pretty-printed string representing a Binder

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

@@ -19,7 +19,11 @@ import Language.PureScript.AST

1919import Language.PureScript.Errors

2020import Language.PureScript.Names

2121

22−desugarObjectConstructors :: forall m. (Applicative m, MonadSupply m, MonadError MultipleErrors m) => Module -> m Module

22+desugarObjectConstructors

23+ :: forall m

24+ . (Applicative m, MonadSupply m, MonadError MultipleErrors m)

25+ => Module

26+ -> m Module

2327desugarObjectConstructors (Module ss coms mn ds exts) = Module ss coms mn <$> mapM desugarDecl ds <*> pure exts

2428 where

2529

@@ -38,7 +42,7 @@ desugarObjectConstructors (Module ss coms mn ds exts) = Module ss coms mn <$> ma

3842 | b' <- stripPositionInfo b

3943 , BinaryNoParens op u val <- b'

4044 , isAnonymousArgument u = return $ OperatorSection op (Right val)

41− desugarExpr (ObjectLiteral ps) = wrapLambda ObjectLiteral ps

45+ desugarExpr (Literal (ObjectLiteral ps)) = wrapLambda (Literal . ObjectLiteral) ps

4246 desugarExpr (ObjectUpdate u ps) | isAnonymousArgument u = do

4347 obj <- freshIdent'

4448 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 =

297297 , let tyArgs = map (replaceAllTypeVars (zip (map fst args) tys)) suTyArgs

298298 ]

299299

300− let props = ObjectLiteral (members ++ superclasses)

300+ let props = Literal $ ObjectLiteral (members ++ superclasses)

301301 dictTy = foldl TypeApp (TypeConstructor (fmap coerceProperName className)) tys

302302 constrainedTy = quantify (if null deps then dictTy else ConstrainedType deps dictTy)

303303 dict = TypeClassDictionaryConstructorApp className props

src/Language/PureScript/Sugar/TypeClasses/Deriving.hs+49−29

@@ -115,15 +115,21 @@ deriveGeneric mn ds tyConNm dargs = do

115115 return $ CaseAlternative [ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)] (Right (caseResult idents))

116116 where

117117 caseResult idents =

118− App (prodConstructor (StringLiteral . showQualified runProperName $ Qualified (Just mn) ctorName))

119− . ArrayLiteral

118+ App (prodConstructor (Literal . StringLiteral . showQualified runProperName $ Qualified (Just mn) ctorName))

119+ . Literal . ArrayLiteral

120120 $ zipWith toSpineFun (map (Var . Qualified Nothing) idents) tys

121121

122122 toSpineFun :: Expr -> Type -> Expr

123123 toSpineFun i r | Just rec <- objectType r =

124− lamNull . recordConstructor . ArrayLiteral .

125− map (\(str,typ) -> ObjectLiteral [("recLabel", StringLiteral str), ("recValue", toSpineFun (Accessor str i) typ)])

126− $ decomposeRec rec

124+ lamNull . recordConstructor . Literal . ArrayLiteral

125+ . map

126+ (\(str,typ) ->

127+ Literal $ ObjectLiteral

128+ [ ("recLabel", Literal (StringLiteral str))

129+ , ("recValue", toSpineFun (Accessor str i) typ)

130+ ]

131+ )

132+ $ decomposeRec rec

127133 toSpineFun i _ = lamNull $ App (mkGenVar (Ident C.toSpine)) i

128134 mkSpineFunction (PositionedDeclaration _ _ d) = mkSpineFunction d

129135 mkSpineFunction _ = internalError "mkSpineFunction: expected DataDeclaration"

@@ -132,30 +138,37 @@ deriveGeneric mn ds tyConNm dargs = do

132138 mkSignatureFunction (DataDeclaration _ name tyArgs args) classArgs = lamNull . mkSigProd $ map mkProdClause args

133139 where

134140 mkSigProd :: [Expr] -> Expr

135− mkSigProd = App (App (Constructor (Qualified (Just dataGeneric) (ProperName "SigProd")))

136− (StringLiteral (showQualified runProperName (Qualified (Just mn) name)))

137− ) . ArrayLiteral

141+ mkSigProd =

142+ App

143+ (App

144+ (Constructor (Qualified (Just dataGeneric) (ProperName "SigProd")))

145+ (Literal (StringLiteral (showQualified runProperName (Qualified (Just mn) name))))

146+ )

147+ . Literal

148+ . ArrayLiteral

138149

139150 mkSigRec :: [Expr] -> Expr

140− mkSigRec = App (Constructor (Qualified (Just dataGeneric) (ProperName "SigRecord"))) . ArrayLiteral

151+ mkSigRec = App (Constructor (Qualified (Just dataGeneric) (ProperName "SigRecord"))) . Literal . ArrayLiteral

141152

142153 proxy :: Type -> Type

143154 proxy = TypeApp (TypeConstructor (Qualified (Just typesProxy) (ProperName "Proxy")))

144155

145156 mkProdClause :: (ProperName 'ConstructorName, [Type]) -> Expr

146157 mkProdClause (ctorName, tys) =

147− ObjectLiteral

148− [ ("sigConstructor", StringLiteral (showQualified runProperName (Qualified (Just mn) ctorName)))

149− , ("sigValues", ArrayLiteral . map (mkProductSignature . instantiate) $ tys)

158+ Literal $ ObjectLiteral

159+ [ ("sigConstructor", Literal (StringLiteral (showQualified runProperName (Qualified (Just mn) ctorName))))

160+ , ("sigValues", Literal . ArrayLiteral . map (mkProductSignature . instantiate) $ tys)

150161 ]

151162

152163 mkProductSignature :: Type -> Expr

153164 mkProductSignature r | Just rec <- objectType r =

154− lamNull . mkSigRec $ [ ObjectLiteral [ ("recLabel", StringLiteral str)

155− , ("recValue", mkProductSignature typ)

156− ]

157− | (str, typ) <- decomposeRec rec

158− ]

165+ lamNull . mkSigRec $

166+ [ Literal $ ObjectLiteral

167+ [ ("recLabel", Literal (StringLiteral str))

168+ , ("recValue", mkProductSignature typ)

169+ ]

170+ | (str, typ) <- decomposeRec rec

171+ ]

159172 mkProductSignature typ = lamNull $ App (mkGenVar (Ident C.toSignature))

160173 (TypedValue False (mkGenVar (Ident "anyProxy")) (proxy typ))

161174 instantiate = replaceAllTypeVars (zipWith (\(arg, _) ty -> (arg, ty)) tyArgs classArgs)

@@ -182,10 +195,17 @@ deriveGeneric mn ds tyConNm dargs = do

182195 mkAlternative :: (ProperName 'ConstructorName, [Type]) -> m CaseAlternative

183196 mkAlternative (ctorName, tys) = do

184197 idents <- replicateM (length tys) freshIdent'

185− return $ CaseAlternative [ prodBinder [ StringBinder (showQualified runProperName (Qualified (Just mn) ctorName)), ArrayBinder (map VarBinder idents)]]

186− . Right

187− $ liftApplicative (mkJust $ Constructor (Qualified (Just mn) ctorName))

188− (zipWith fromSpineFun (map (Var . Qualified Nothing) idents) tys)

198+ return $

199+ CaseAlternative

200+ [ prodBinder

201+ [ LiteralBinder (StringLiteral (showQualified runProperName (Qualified (Just mn) ctorName)))

202+ , LiteralBinder (ArrayLiteral (map VarBinder idents))

203+ ]

204+ ]

205+ . Right

206+ $ liftApplicative

207+ (mkJust $ Constructor (Qualified (Just mn) ctorName))

208+ (zipWith fromSpineFun (map (Var . Qualified Nothing) idents) tys)

189209

190210 addCatch :: [CaseAlternative] -> [CaseAlternative]

191211 addCatch = (++ [catchAll])

@@ -202,15 +222,15 @@ deriveGeneric mn ds tyConNm dargs = do

202222 fromSpineFun e _ = App (mkGenVar (Ident C.fromSpine)) (App e (mkPrelVar (Ident "unit")))

203223

204224 mkRecCase :: [(String, Type)] -> CaseAlternative

205− mkRecCase rs = CaseAlternative [ recordBinder [ ArrayBinder (map (VarBinder . Ident . fst) rs)

206− ]

207− ]

208− . Right

209− $ liftApplicative (mkRecFun rs) (map (\(x, y) -> fromSpineFun (Accessor "recValue" (mkVar (Ident x))) y) rs)

225+ mkRecCase rs =

226+ CaseAlternative

227+ [ recordBinder [ LiteralBinder (ArrayLiteral (map (VarBinder . Ident . fst) rs)) ] ]

228+ . Right

229+ $ liftApplicative (mkRecFun rs) (map (\(x, y) -> fromSpineFun (Accessor "recValue" (mkVar (Ident x))) y) rs)

210230

211231 mkRecFun :: [(String, Type)] -> Expr

212232 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

214234 mkFromSpineFunction (PositionedDeclaration _ _ d) = mkFromSpineFunction d

215235 mkFromSpineFunction _ = internalError "mkFromSpineFunction: expected DataDeclaration"

216236

@@ -255,7 +275,7 @@ deriveEq mn ds tyConNm = do

255275 | length xs /= 1 = xs ++ [catchAll]

256276 | otherwise = xs -- Avoid redundant case

257277 where

258− catchAll = CaseAlternative [NullBinder, NullBinder] (Right (BooleanLiteral False))

278+ catchAll = CaseAlternative [NullBinder, NullBinder] (Right (Literal (BooleanLiteral False)))

259279

260280 mkCtorClause :: (ProperName 'ConstructorName, [Type]) -> m CaseAlternative

261281 mkCtorClause (ctorName, tys) = do

@@ -267,7 +287,7 @@ deriveEq mn ds tyConNm = do

267287 caseBinder idents = ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)

268288

269289 conjAll :: [Expr] -> Expr

270− conjAll [] = BooleanLiteral True

290+ conjAll [] = Literal (BooleanLiteral True)

271291 conjAll xs = foldl1 preludeConj xs

272292

273293 toEqTest :: Expr -> Expr -> Type -> Expr

src/Language/PureScript/TypeChecker/Types.hs+25−25

@@ -217,22 +217,22 @@ infer' ::

217217 (Functor m, Applicative m, MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>

218218 Expr ->

219219 m Expr

220−infer' v@(NumericLiteral (Left _)) = return $ TypedValue True v tyInt

221−infer' v@(NumericLiteral (Right _)) = return $ TypedValue True v tyNumber

222−infer' v@(StringLiteral _) = return $ TypedValue True v tyString

223−infer' v@(CharLiteral _) = return $ TypedValue True v tyChar

224−infer' v@(BooleanLiteral _) = return $ TypedValue True v tyBoolean

225−infer' (ArrayLiteral vals) = do

220+infer' v@(Literal (NumericLiteral (Left _))) = return $ TypedValue True v tyInt

221+infer' v@(Literal (NumericLiteral (Right _))) = return $ TypedValue True v tyNumber

222+infer' v@(Literal (StringLiteral _)) = return $ TypedValue True v tyString

223+infer' v@(Literal (CharLiteral _)) = return $ TypedValue True v tyChar

224+infer' v@(Literal (BooleanLiteral _)) = return $ TypedValue True v tyBoolean

225+infer' (Literal (ArrayLiteral vals)) = do

226226 ts <- traverse infer vals

227227 els <- freshType

228228 forM_ ts $ \(TypedValue _ _ t) -> unifyTypes els t

229− return $ TypedValue True (ArrayLiteral ts) (TypeApp tyArray els)

230−infer' (ObjectLiteral ps) = do

229+ return $ TypedValue True (Literal (ArrayLiteral ts)) (TypeApp tyArray els)

230+infer' (Literal (ObjectLiteral ps)) = do

231231 ensureNoDuplicateProperties ps

232232 ts <- traverse (infer . snd) ps

233233 let fields = zipWith (\name (TypedValue _ _ t) -> (name, t)) (map fst ps) ts

234234 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

236236infer' (ObjectUpdate o ps) = do

237237 ensureNoDuplicateProperties ps

238238 row <- freshType

@@ -346,11 +346,11 @@ inferBinder :: forall m.

346346 Binder ->

347347 m (M.Map Ident Type)

348348inferBinder _ NullBinder = return M.empty

349−inferBinder val (StringBinder _) = unifyTypes val tyString >> return M.empty

350−inferBinder val (CharBinder _) = unifyTypes val tyChar >> return M.empty

351−inferBinder val (NumberBinder (Left _)) = unifyTypes val tyInt >> return M.empty

352−inferBinder val (NumberBinder (Right _)) = unifyTypes val tyNumber >> return M.empty

353−inferBinder val (BooleanBinder _) = unifyTypes val tyBoolean >> return M.empty

349+inferBinder val (LiteralBinder (StringLiteral _)) = unifyTypes val tyString >> return M.empty

350+inferBinder val (LiteralBinder (CharLiteral _)) = unifyTypes val tyChar >> return M.empty

351+inferBinder val (LiteralBinder (NumericLiteral (Left _))) = unifyTypes val tyInt >> return M.empty

352+inferBinder val (LiteralBinder (NumericLiteral (Right _))) = unifyTypes val tyNumber >> return M.empty

353+inferBinder val (LiteralBinder (BooleanLiteral _)) = unifyTypes val tyBoolean >> return M.empty

354354inferBinder val (VarBinder name) = return $ M.singleton name val

355355inferBinder val (ConstructorBinder ctor binders) = do

356356 env <- getEnv

@@ -369,7 +369,7 @@ inferBinder val (ConstructorBinder ctor binders) = do

369369 where

370370 go args (TypeApp (TypeApp fn arg) ret) | fn == tyFunction = go (arg : args) ret

371371 go args ret = (args, ret)

372−inferBinder val (ObjectBinder props) = do

372+inferBinder val (LiteralBinder (ObjectLiteral props)) = do

373373 row <- freshType

374374 rest <- freshType

375375 m1 <- inferRowProperties row rest props

@@ -383,7 +383,7 @@ inferBinder val (ObjectBinder props) = do

383383 m1 <- inferBinder propTy binder

384384 m2 <- inferRowProperties nrow (RCons name propTy row) binders

385385 return $ m1 `M.union` m2

386−inferBinder val (ArrayBinder binders) = do

386+inferBinder val (LiteralBinder (ArrayLiteral binders)) = do

387387 el <- freshType

388388 m1 <- M.unions <$> traverse (inferBinder el) binders

389389 unifyTypes val (TypeApp tyArray el)

@@ -524,19 +524,19 @@ check' val u@(TUnknown _) = do

524524 (val'', ty') <- instantiatePolyTypeWithUnknowns val' ty

525525 unifyTypes ty' u

526526 return $ TypedValue True val'' ty'

527−check' v@(NumericLiteral (Left _)) t | t == tyInt =

527+check' v@(Literal (NumericLiteral (Left _))) t | t == tyInt =

528528 return $ TypedValue True v t

529−check' v@(NumericLiteral (Right _)) t | t == tyNumber =

529+check' v@(Literal (NumericLiteral (Right _))) t | t == tyNumber =

530530 return $ TypedValue True v t

531−check' v@(StringLiteral _) t | t == tyString =

531+check' v@(Literal (StringLiteral _)) t | t == tyString =

532532 return $ TypedValue True v t

533−check' v@(CharLiteral _) t | t == tyChar =

533+check' v@(Literal (CharLiteral _)) t | t == tyChar =

534534 return $ TypedValue True v t

535−check' v@(BooleanLiteral _) t | t == tyBoolean =

535+check' v@(Literal (BooleanLiteral _)) t | t == tyBoolean =

536536 return $ TypedValue True v t

537−check' (ArrayLiteral vals) t@(TypeApp a ty) = do

537+check' (Literal (ArrayLiteral vals)) t@(TypeApp a ty) = do

538538 unifyTypes a tyArray

539− array <- ArrayLiteral <$> forM vals (`check` ty)

539+ array <- Literal . ArrayLiteral <$> forM vals (`check` ty)

540540 return $ TypedValue True array t

541541check' (Abs (Left arg) ret) ty@(TypeApp (TypeApp t argTy) retTy) = do

542542 unifyTypes t tyFunction

@@ -587,10 +587,10 @@ check' (IfThenElse cond th el) ty = do

587587 th' <- check th ty

588588 el' <- check el ty

589589 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

591591 ensureNoDuplicateProperties ps

592592 ps' <- checkProperties e ps row False

593− return $ TypedValue True (ObjectLiteral ps') t

593+ return $ TypedValue True (Literal (ObjectLiteral ps')) t

594594check' (TypeClassDictionaryConstructorApp name ps) t = do

595595 ps' <- check' ps t

596596 return $ TypedValue True (TypeClassDictionaryConstructorApp name ps') t