fa89354 · rowtype-yoga/purescript-native

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

on golang help sign in

Initial work on #518

fa89354Phil Freeman12 years ago

hierarchy/Main.hs+1−1

compare with golang

unifiedsplit

@@ -84,7 +84,7 @@ superClasses :: P.Declaration -> [SuperMap]

84superClasses (P.TypeClassDeclaration sub _ supers@(_:_) _) =

85 fmap (\(P.Qualified _ super, _) -> SuperMap (Right (super, sub))) supers

86superClasses (P.TypeClassDeclaration sub _ _ _) = [SuperMap (Left sub)]

87−superClasses (P.PositionedDeclaration _ decl) = superClasses decl

87+superClasses (P.PositionedDeclaration _ _ decl) = superClasses decl

88superClasses _ = []

90inputFile :: Parser FilePath

psc-docs/Main.hs+6−6

@@ -152,7 +152,7 @@ renderDeclaration n _ (P.TypeInstanceDeclaration name constraints className tys

152 [] -> ""

153 cs -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map P.prettyPrintTypeAtom tys')) cs) ++ ") => "

154 atIndent n $ "instance " ++ show name ++ " :: " ++ constraintsText ++ show className ++ " " ++ unwords (map P.prettyPrintTypeAtom tys)

155−renderDeclaration n exps (P.PositionedDeclaration _ d) =

155+renderDeclaration n exps (P.PositionedDeclaration _ _ d) =

156 renderDeclaration n exps d

157renderDeclaration _ _ _ = return ()

158

@@ -176,30 +176,30 @@ getName (P.ExternDataDeclaration name _) = P.runProperName name

176getName (P.TypeSynonymDeclaration name _ _) = P.runProperName name

177getName (P.TypeClassDeclaration name _ _ _) = P.runProperName name

178getName (P.TypeInstanceDeclaration name _ _ _ _) = show name

179−getName (P.PositionedDeclaration _ d) = getName d

179+getName (P.PositionedDeclaration _ _ d) = getName d

180getName _ = error "Invalid argument to getName"

181

182isValueDeclaration :: P.Declaration -> Bool

183isValueDeclaration P.TypeDeclaration{} = True

184isValueDeclaration P.ExternDeclaration{} = True

185−isValueDeclaration (P.PositionedDeclaration _ d) = isValueDeclaration d

185+isValueDeclaration (P.PositionedDeclaration _ _ d) = isValueDeclaration d

186isValueDeclaration _ = False

187

188isTypeDeclaration :: P.Declaration -> Bool

189isTypeDeclaration P.DataDeclaration{} = True

190isTypeDeclaration P.ExternDataDeclaration{} = True

191isTypeDeclaration P.TypeSynonymDeclaration{} = True

192−isTypeDeclaration (P.PositionedDeclaration _ d) = isTypeDeclaration d

192+isTypeDeclaration (P.PositionedDeclaration _ _ d) = isTypeDeclaration d

193isTypeDeclaration _ = False

194

195isTypeClassDeclaration :: P.Declaration -> Bool

196isTypeClassDeclaration P.TypeClassDeclaration{} = True

197−isTypeClassDeclaration (P.PositionedDeclaration _ d) = isTypeClassDeclaration d

197+isTypeClassDeclaration (P.PositionedDeclaration _ _ d) = isTypeClassDeclaration d

198isTypeClassDeclaration _ = False

199

200isTypeInstanceDeclaration :: P.Declaration -> Bool

201isTypeInstanceDeclaration P.TypeInstanceDeclaration{} = True

202−isTypeInstanceDeclaration (P.PositionedDeclaration _ d) = isTypeInstanceDeclaration d

202+isTypeInstanceDeclaration (P.PositionedDeclaration _ _ d) = isTypeInstanceDeclaration d

203isTypeInstanceDeclaration _ = False

204

205inputFile :: Parser FilePath

psci/Main.hs+2−2

@@ -244,7 +244,7 @@ completion = completeWordWithPrev Nothing " \t\n\r" findCompletions

244 getDeclName :: Maybe [P.DeclarationRef] -> P.Declaration -> Maybe P.Ident

245 getDeclName exts (P.ValueDeclaration ident _ _ _) | isExported ident exts = Just ident

246 getDeclName exts (P.ExternDeclaration _ ident _ _) | isExported ident exts = Just ident

247− getDeclName exts (P.PositionedDeclaration _ d) = getDeclName exts d

247+ getDeclName exts (P.PositionedDeclaration _ _ d) = getDeclName exts d

248 getDeclName _ _ = Nothing

249

250 isExported :: N.Ident -> Maybe [P.DeclarationRef] -> Bool

@@ -252,7 +252,7 @@ completion = completeWordWithPrev Nothing " \t\n\r" findCompletions

252 where

253 exports :: P.DeclarationRef -> Bool

254 exports (P.ValueRef ident') = ident == ident'

255− exports (P.PositionedDeclarationRef _ r) = exports r

255+ exports (P.PositionedDeclarationRef _ _ r) = exports r

256 exports _ = False

257

258 identNames :: [P.Module] -> [String]

src/Language/PureScript.hs+1−1

@@ -239,7 +239,7 @@ addDefaultImport toImport m@(Module mn decls exps) =

239 else Module mn (ImportDeclaration toImport Unqualified Nothing : decls) exps

240 where

241 isExistingImport (ImportDeclaration mn' _ _) | mn' == toImport = True

242− isExistingImport (PositionedDeclaration _ d) = isExistingImport d

242+ isExistingImport (PositionedDeclaration _ _ d) = isExistingImport d

243 isExistingImport _ = False

244

245importPrim :: Module -> Module

src/Language/PureScript/AST/Binders.hs+3−2

@@ -20,6 +20,7 @@ import qualified Data.Data as D

21import Language.PureScript.AST.SourcePos

22import Language.PureScript.Names

23+import Language.PureScript.Parser.Lexer

24-- |

25-- |

25-- Data type for binders

26-- Data type for binders

@@ -68,7 +69,7 @@ data Binder

68 -- |

69 -- |

69 -- A binder with source position information

70 -- A binder with source position information

70 --

71 --

71− | PositionedBinder SourceSpan Binder deriving (Show, D.Data, D.Typeable)

72+ | PositionedBinder SourceSpan [Comment] Binder deriving (Show, D.Data, D.Typeable)

73-- |

74-- |

74-- Collect all names introduced in binders in an expression

75-- Collect all names introduced in binders in an expression

@@ -82,5 +83,5 @@ binderNames = go []

82 go ns (ArrayBinder bs) = foldl go ns bs

83 go ns (ArrayBinder bs) = foldl go ns bs

83 go ns (ConsBinder b1 b2) = go (go ns b1) b2

84 go ns (ConsBinder b1 b2) = go (go ns b1) b2

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

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

85− go ns (PositionedBinder _ b) = go ns b

86+ go ns (PositionedBinder _ _ b) = go ns b

86 go ns _ = ns

87 go ns _ = ns

src/Language/PureScript/AST/Declarations.hs+19−18

@@ -25,6 +25,7 @@ import Language.PureScript.Types

25import Language.PureScript.Names

26import Language.PureScript.Kinds

27import Language.PureScript.TypeClassDictionaries

28+import Language.PureScript.Parser.Lexer

28import Language.PureScript.CodeGen.JS.AST

29import Language.PureScript.CodeGen.JS.AST

29import Language.PureScript.Environment

30import Language.PureScript.Environment

@@ -40,7 +41,7 @@ data Module = Module ModuleName [Declaration] (Maybe [DeclarationRef]) deriving

40isExported :: Maybe [DeclarationRef] -> Declaration -> Bool

41isExported :: Maybe [DeclarationRef] -> Declaration -> Bool

41isExported Nothing _ = True

42isExported Nothing _ = True

42isExported _ TypeInstanceDeclaration{} = True

43isExported _ TypeInstanceDeclaration{} = True

43−isExported exps (PositionedDeclaration _ d) = isExported exps d

44+isExported exps (PositionedDeclaration _ _ d) = isExported exps d

44isExported (Just exps) decl = any (matches decl) exps

45isExported (Just exps) decl = any (matches decl) exps

45 where

46 where

46 matches (TypeDeclaration ident _) (ValueRef ident') = ident == ident'

47 matches (TypeDeclaration ident _) (ValueRef ident') = ident == ident'

@@ -49,8 +50,8 @@ isExported (Just exps) decl = any (matches decl) exps

49 matches (ExternDataDeclaration ident _) (TypeRef ident' _) = ident == ident'

50 matches (ExternDataDeclaration ident _) (TypeRef ident' _) = ident == ident'

50 matches (TypeSynonymDeclaration ident _ _) (TypeRef ident' _) = ident == ident'

51 matches (TypeSynonymDeclaration ident _ _) (TypeRef ident' _) = ident == ident'

51 matches (TypeClassDeclaration ident _ _ _) (TypeClassRef ident') = ident == ident'

52 matches (TypeClassDeclaration ident _ _ _) (TypeClassRef ident') = ident == ident'

52− matches (PositionedDeclaration _ d) r = d `matches` r

53+ matches (PositionedDeclaration _ _ d) r = d `matches` r

53− matches d (PositionedDeclarationRef _ r) = d `matches` r

54+ matches d (PositionedDeclarationRef _ _ r) = d `matches` r

54 matches _ _ = False

55 matches _ _ = False

56exportedDeclarations :: Module -> [Declaration]

57exportedDeclarations :: Module -> [Declaration]

@@ -63,7 +64,7 @@ isDctorExported :: ProperName -> Maybe [DeclarationRef] -> ProperName -> Bool

63isDctorExported _ Nothing _ = True

64isDctorExported _ Nothing _ = True

64isDctorExported ident (Just exps) ctor = test `any` exps

65isDctorExported ident (Just exps) ctor = test `any` exps

65 where

66 where

66− test (PositionedDeclarationRef _ d) = test d

67+ test (PositionedDeclarationRef _ _ d) = test d

67 test (TypeRef ident' Nothing) = ident == ident'

68 test (TypeRef ident' Nothing) = ident == ident'

68 test (TypeRef ident' (Just ctors)) = ident == ident' && ctor `elem` ctors

69 test (TypeRef ident' (Just ctors)) = ident == ident' && ctor `elem` ctors

69 test _ = False

70 test _ = False

@@ -102,7 +103,7 @@ data DeclarationRef

102 -- |

103 -- |

103 -- A declaration reference with source position information

104 -- A declaration reference with source position information

104 --

105 --

105− | PositionedDeclarationRef SourceSpan DeclarationRef

106+ | PositionedDeclarationRef SourceSpan [Comment] DeclarationRef

106 deriving (Show, D.Data, D.Typeable)

107 deriving (Show, D.Data, D.Typeable)

107

108

108instance Eq DeclarationRef where

109instance Eq DeclarationRef where

@@ -110,8 +111,8 @@ instance Eq DeclarationRef where

110 (ValueRef name) == (ValueRef name') = name == name'

111 (ValueRef name) == (ValueRef name') = name == name'

111 (TypeClassRef name) == (TypeClassRef name') = name == name'

112 (TypeClassRef name) == (TypeClassRef name') = name == name'

112 (TypeInstanceRef name) == (TypeInstanceRef name') = name == name'

113 (TypeInstanceRef name) == (TypeInstanceRef name') = name == name'

113− (PositionedDeclarationRef _ r) == r' = r == r'

114+ (PositionedDeclarationRef _ _ r) == r' = r == r'

114− r == (PositionedDeclarationRef _ r') = r == r'

115+ r == (PositionedDeclarationRef _ _ r') = r == r'

115 _ == _ = False

116 _ == _ = False

116

117

117-- |

118-- |

@@ -192,7 +193,7 @@ data Declaration

192 -- |

193 -- |

193 -- A declaration with source position information

194 -- A declaration with source position information

194 --

195 --

195− | PositionedDeclaration SourceSpan Declaration

196+ | PositionedDeclaration SourceSpan [Comment] Declaration

196 deriving (Show, D.Data, D.Typeable)

197 deriving (Show, D.Data, D.Typeable)

197

198

198-- |

199-- |

@@ -200,7 +201,7 @@ data Declaration

200--

201--

201isValueDecl :: Declaration -> Bool

202isValueDecl :: Declaration -> Bool

202isValueDecl ValueDeclaration{} = True

203isValueDecl ValueDeclaration{} = True

203−isValueDecl (PositionedDeclaration _ d) = isValueDecl d

204+isValueDecl (PositionedDeclaration _ _ d) = isValueDecl d

204isValueDecl _ = False

205isValueDecl _ = False

205

206

206-- |

207-- |

@@ -209,7 +210,7 @@ isValueDecl _ = False

209isDataDecl :: Declaration -> Bool

210isDataDecl :: Declaration -> Bool

210isDataDecl DataDeclaration{} = True

211isDataDecl DataDeclaration{} = True

211isDataDecl TypeSynonymDeclaration{} = True

212isDataDecl TypeSynonymDeclaration{} = True

212−isDataDecl (PositionedDeclaration _ d) = isDataDecl d

213+isDataDecl (PositionedDeclaration _ _ d) = isDataDecl d

213isDataDecl _ = False

214isDataDecl _ = False

214

215

215-- |

216-- |

@@ -217,7 +218,7 @@ isDataDecl _ = False

217--

218--

218isImportDecl :: Declaration -> Bool

219isImportDecl :: Declaration -> Bool

219isImportDecl ImportDeclaration{} = True

220isImportDecl ImportDeclaration{} = True

220−isImportDecl (PositionedDeclaration _ d) = isImportDecl d

221+isImportDecl (PositionedDeclaration _ _ d) = isImportDecl d

221isImportDecl _ = False

222isImportDecl _ = False

222

223

223-- |

224-- |

@@ -225,7 +226,7 @@ isImportDecl _ = False

225--

226--

226isExternDataDecl :: Declaration -> Bool

227isExternDataDecl :: Declaration -> Bool

227isExternDataDecl ExternDataDeclaration{} = True

228isExternDataDecl ExternDataDeclaration{} = True

228−isExternDataDecl (PositionedDeclaration _ d) = isExternDataDecl d

229+isExternDataDecl (PositionedDeclaration _ _ d) = isExternDataDecl d

229isExternDataDecl _ = False

230isExternDataDecl _ = False

230

231

231-- |

232-- |

@@ -233,7 +234,7 @@ isExternDataDecl _ = False

233--

234--

234isExternInstanceDecl :: Declaration -> Bool

235isExternInstanceDecl :: Declaration -> Bool

235isExternInstanceDecl ExternInstanceDeclaration{} = True

236isExternInstanceDecl ExternInstanceDeclaration{} = True

236−isExternInstanceDecl (PositionedDeclaration _ d) = isExternInstanceDecl d

237+isExternInstanceDecl (PositionedDeclaration _ _ d) = isExternInstanceDecl d

237isExternInstanceDecl _ = False

238isExternInstanceDecl _ = False

238

239

239-- |

240-- |

@@ -241,7 +242,7 @@ isExternInstanceDecl _ = False

241--

242--

242isFixityDecl :: Declaration -> Bool

243isFixityDecl :: Declaration -> Bool

243isFixityDecl FixityDeclaration{} = True

244isFixityDecl FixityDeclaration{} = True

244−isFixityDecl (PositionedDeclaration _ d) = isFixityDecl d

245+isFixityDecl (PositionedDeclaration _ _ d) = isFixityDecl d

245isFixityDecl _ = False

246isFixityDecl _ = False

246

247

247-- |

248-- |

@@ -249,7 +250,7 @@ isFixityDecl _ = False

249--

250--

250isExternDecl :: Declaration -> Bool

251isExternDecl :: Declaration -> Bool

251isExternDecl ExternDeclaration{} = True

252isExternDecl ExternDeclaration{} = True

252−isExternDecl (PositionedDeclaration _ d) = isExternDecl d

253+isExternDecl (PositionedDeclaration _ _ d) = isExternDecl d

253isExternDecl _ = False

254isExternDecl _ = False

254

255

255-- |

256-- |

@@ -258,7 +259,7 @@ isExternDecl _ = False

258isTypeClassDeclaration :: Declaration -> Bool

259isTypeClassDeclaration :: Declaration -> Bool

259isTypeClassDeclaration TypeClassDeclaration{} = True

260isTypeClassDeclaration TypeClassDeclaration{} = True

260isTypeClassDeclaration TypeInstanceDeclaration{} = True

261isTypeClassDeclaration TypeInstanceDeclaration{} = True

261−isTypeClassDeclaration (PositionedDeclaration _ d) = isTypeClassDeclaration d

262+isTypeClassDeclaration (PositionedDeclaration _ _ d) = isTypeClassDeclaration d

262isTypeClassDeclaration _ = False

263isTypeClassDeclaration _ = False

263

264

264-- |

265-- |

@@ -369,7 +370,7 @@ data Expr

369 -- |

370 -- |

370 -- A value with source position information

371 -- A value with source position information

371 --

372 --

372− | PositionedValue SourceSpan Expr deriving (Show, D.Data, D.Typeable)

373+ | PositionedValue SourceSpan [Comment] Expr deriving (Show, D.Data, D.Typeable)

373

374

374-- |

375-- |

375-- An alternative in a case statement

376-- An alternative in a case statement

@@ -404,4 +405,4 @@ data DoNotationElement

404 -- |

405 -- |

405 -- A do notation element with source position information

406 -- A do notation element with source position information

406 --

407 --

407− | PositionedDoNotationElement SourceSpan DoNotationElement deriving (Show, D.Data, D.Typeable)

408+ | PositionedDoNotationElement SourceSpan [Comment] DoNotationElement deriving (Show, D.Data, D.Typeable)

src/Language/PureScript/AST/Traversals.hs+24−24

@@ -37,7 +37,7 @@ everywhereOnValues f g h = (f', g', h')

37 f' (BindingGroupDeclaration ds) = f (BindingGroupDeclaration (map (\(name, nameKind, val) -> (name, nameKind, g' val)) ds))

38 f' (TypeClassDeclaration name args implies ds) = f (TypeClassDeclaration name args implies (map f' ds))

39 f' (TypeInstanceDeclaration name cs className args ds) = f (TypeInstanceDeclaration name cs className args (map f' ds))

40− f' (PositionedDeclaration pos d) = f (PositionedDeclaration pos (f' d))

40+ f' (PositionedDeclaration pos com d) = f (PositionedDeclaration pos com (f' d))

41 f' other = f other

43 g' :: Expr -> Expr

@@ -56,7 +56,7 @@ everywhereOnValues f g h = (f', g', h')

56 g' (TypedValue check v ty) = g (TypedValue check (g' v) ty)

57 g' (Let ds v) = g (Let (map f' ds) (g' v))

58 g' (Do es) = g (Do (map handleDoNotationElement es))

59− g' (PositionedValue pos v) = g (PositionedValue pos (g' v))

59+ g' (PositionedValue pos com v) = g (PositionedValue pos com (g' v))

60 g' other = g other

62 h' :: Binder -> Binder

@@ -65,7 +65,7 @@ everywhereOnValues f g h = (f', g', h')

65 h' (ArrayBinder bs) = h (ArrayBinder (map h' bs))

66 h' (ConsBinder b1 b2) = h (ConsBinder (h' b1) (h' b2))

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

68− h' (PositionedBinder pos b) = h (PositionedBinder pos (h' b))

68+ h' (PositionedBinder pos com b) = h (PositionedBinder pos com (h' b))

69 h' other = h other

71 handleCaseAlternative :: CaseAlternative -> CaseAlternative

@@ -78,7 +78,7 @@ everywhereOnValues f g h = (f', g', h')

78 handleDoNotationElement (DoNotationValue v) = DoNotationValue (g' v)

79 handleDoNotationElement (DoNotationBind b v) = DoNotationBind (h' b) (g' v)

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

81− handleDoNotationElement (PositionedDoNotationElement pos e) = PositionedDoNotationElement pos (handleDoNotationElement e)

81+ handleDoNotationElement (PositionedDoNotationElement pos com e) = PositionedDoNotationElement pos com (handleDoNotationElement e)

84everywhereOnValuesTopDownM :: (Functor m, Applicative m, Monad m) =>

@@ -93,7 +93,7 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)

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

94 f' (TypeClassDeclaration name args implies ds) = TypeClassDeclaration name args implies <$> mapM (f' <=< f) ds

95 f' (TypeInstanceDeclaration name cs className args ds) = TypeInstanceDeclaration name cs className args <$> mapM (f' <=< f) ds

96− f' (PositionedDeclaration pos d) = PositionedDeclaration pos <$> (f d >>= f')

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

97 f' other = f other

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

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

111 g' (TypedValue check v ty) = TypedValue check <$> (g v >>= g') <*> pure ty

112 g' (Let ds v) = Let <$> mapM (f' <=< f) ds <*> (g v >>= g')

113 g' (Do es) = Do <$> mapM handleDoNotationElement es

114− g' (PositionedValue pos v) = PositionedValue pos <$> (g v >>= g')

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

115 g' other = g other

116

117 h' (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> mapM (h' <=< h) bs

@@ -119,7 +119,7 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)

119 h' (ArrayBinder bs) = ArrayBinder <$> mapM (h' <=< h) bs

120 h' (ConsBinder b1 b2) = ConsBinder <$> (h b1 >>= h') <*> (h b2 >>= h')

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

122− h' (PositionedBinder pos b) = PositionedBinder pos <$> (h b >>= h')

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

123 h' other = h other

124

125 handleCaseAlternative (CaseAlternative bs val) = CaseAlternative <$> mapM (h' <=< h) bs

@@ -128,7 +128,7 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)

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

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

130 handleDoNotationElement (DoNotationLet ds) = DoNotationLet <$> mapM (f' <=< f) ds

131− handleDoNotationElement (PositionedDoNotationElement pos e) = PositionedDoNotationElement pos <$> handleDoNotationElement e

131+ handleDoNotationElement (PositionedDoNotationElement pos com e) = PositionedDoNotationElement pos com <$> handleDoNotationElement e

132

133everywhereOnValuesM :: (Functor m, Applicative m, Monad m) =>

134 (Declaration -> m Declaration) ->

@@ -142,7 +142,7 @@ everywhereOnValuesM f g h = (f', g', h')

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

143 f' (TypeClassDeclaration name args implies ds) = (TypeClassDeclaration name args implies <$> mapM f' ds) >>= f

144 f' (TypeInstanceDeclaration name cs className args ds) = (TypeInstanceDeclaration name cs className args <$> mapM f' ds) >>= f

145− f' (PositionedDeclaration pos d) = (PositionedDeclaration pos <$> f' d) >>= f

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

146 f' other = f other

147

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

@@ -160,7 +160,7 @@ everywhereOnValuesM f g h = (f', g', h')

160 g' (TypedValue check v ty) = (TypedValue check <$> g' v <*> pure ty) >>= g

161 g' (Let ds v) = (Let <$> mapM f' ds <*> g' v) >>= g

162 g' (Do es) = (Do <$> mapM handleDoNotationElement es) >>= g

163− g' (PositionedValue pos v) = (PositionedValue pos <$> g' v) >>= g

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

164 g' other = g other

165

166 h' (ConstructorBinder ctor bs) = (ConstructorBinder ctor <$> mapM h' bs) >>= h

@@ -168,7 +168,7 @@ everywhereOnValuesM f g h = (f', g', h')

168 h' (ArrayBinder bs) = (ArrayBinder <$> mapM h' bs) >>= h

169 h' (ConsBinder b1 b2) = (ConsBinder <$> h' b1 <*> h' b2) >>= h

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

171− h' (PositionedBinder pos b) = (PositionedBinder pos <$> h' b) >>= h

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

172 h' other = h other

173

174 handleCaseAlternative (CaseAlternative bs val) = CaseAlternative <$> mapM h' bs

@@ -177,7 +177,7 @@ everywhereOnValuesM f g h = (f', g', h')

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

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

179 handleDoNotationElement (DoNotationLet ds) = DoNotationLet <$> mapM f' ds

180− handleDoNotationElement (PositionedDoNotationElement pos e) = PositionedDoNotationElement pos <$> handleDoNotationElement e

180+ handleDoNotationElement (PositionedDoNotationElement pos com e) = PositionedDoNotationElement pos com <$> handleDoNotationElement e

181

182everythingOnValues :: (r -> r -> r) ->

183 (Declaration -> r) ->

@@ -194,7 +194,7 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j')

194 f' d@(BindingGroupDeclaration ds) = foldl (<>) (f d) (map (\(_, _, val) -> g' val) ds)

195 f' d@(TypeClassDeclaration _ _ _ ds) = foldl (<>) (f d) (map f' ds)

196 f' d@(TypeInstanceDeclaration _ _ _ _ ds) = foldl (<>) (f d) (map f' ds)

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

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

198 f' d = f d

199

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

@@ -212,7 +212,7 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j')

212 g' v@(TypedValue _ v1 _) = g v <> g' v1

213 g' v@(Let ds v1) = foldl (<>) (g v) (map f' ds) <> g' v1

214 g' v@(Do es) = foldl (<>) (g v) (map j' es)

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

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

216 g' v = g v

217

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

@@ -220,7 +220,7 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j')

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

221 h' b@(ConsBinder b1 b2) = h b <> h' b1 <> h' b2

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

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

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

224 h' b = h b

225

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

@@ -229,7 +229,7 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j')

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

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

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

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

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

233

234everythingWithContextOnValues ::

235 s ->

@@ -255,7 +255,7 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'

255 f' s (BindingGroupDeclaration ds) = foldl (<>) r0 (map (\(_, _, val) -> g'' s val) ds)

256 f' s (TypeClassDeclaration _ _ _ ds) = foldl (<>) r0 (map (f'' s) ds)

257 f' s (TypeInstanceDeclaration _ _ _ _ ds) = foldl (<>) r0 (map (f'' s) ds)

258− f' s (PositionedDeclaration _ d1) = f'' s d1

258+ f' s (PositionedDeclaration _ _ d1) = f'' s d1

259 f' _ _ = r0

260

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

@@ -275,7 +275,7 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'

275 g' s (TypedValue _ v1 _) = g'' s v1

276 g' s (Let ds v1) = foldl (<>) r0 (map (f'' s) ds) <> g'' s v1

277 g' s (Do es) = foldl (<>) r0 (map (j'' s) es)

278− g' s (PositionedValue _ v1) = g'' s v1

278+ g' s (PositionedValue _ _ v1) = g'' s v1

279 g' _ _ = r0

280

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

@@ -285,7 +285,7 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'

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

286 h' s (ConsBinder b1 b2) = h'' s b1 <> h'' s b2

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

288− h' s (PositionedBinder _ b1) = h'' s b1

288+ h' s (PositionedBinder _ _ b1) = h'' s b1

289 h' _ _ = r0

290

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

@@ -298,7 +298,7 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'

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

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

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

301− j' s (PositionedDoNotationElement _ e1) = j'' s e1

301+ j' s (PositionedDoNotationElement _ _ e1) = j'' s e1

302

303everywhereWithContextOnValuesM :: (Functor m, Applicative m, Monad m) =>

304 s ->

@@ -321,7 +321,7 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j

321 f' s (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> mapM (thirdM (g'' s)) ds

322 f' s (TypeClassDeclaration name args implies ds) = TypeClassDeclaration name args implies <$> mapM (f'' s) ds

323 f' s (TypeInstanceDeclaration name cs className args ds) = TypeInstanceDeclaration name cs className args <$> mapM (f'' s) ds

324− f' s (PositionedDeclaration pos d1) = PositionedDeclaration pos <$> f'' s d1

324+ f' s (PositionedDeclaration pos com d1) = PositionedDeclaration pos com <$> f'' s d1

325 f' _ other = return other

326

327 g'' s = uncurry g' <=< g s

@@ -341,7 +341,7 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j

341 g' s (TypedValue check v ty) = TypedValue check <$> g'' s v <*> pure ty

342 g' s (Let ds v) = Let <$> mapM (f'' s) ds <*> g'' s v

343 g' s (Do es) = Do <$> mapM (j'' s) es

344− g' s (PositionedValue pos v) = PositionedValue pos <$> g'' s v

344+ g' s (PositionedValue pos com v) = PositionedValue pos com <$> g'' s v

345 g' _ other = return other

346

347 h'' s = uncurry h' <=< h s

@@ -351,7 +351,7 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j

351 h' s (ArrayBinder bs) = ArrayBinder <$> mapM (h'' s) bs

352 h' s (ConsBinder b1 b2) = ConsBinder <$> h'' s b1 <*> h'' s b2

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

354− h' s (PositionedBinder pos b) = PositionedBinder pos <$> h'' s b

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

355 h' _ other = return other

356

357 i'' s = uncurry i' <=< i s

@@ -363,7 +363,7 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j

363 j' s (DoNotationValue v) = DoNotationValue <$> g'' s v

364 j' s (DoNotationBind b v) = DoNotationBind <$> h'' s b <*> g'' s v

365 j' s (DoNotationLet ds) = DoNotationLet <$> mapM (f'' s) ds

366− j' s (PositionedDoNotationElement pos e1) = PositionedDoNotationElement pos <$> j'' s e1

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

367

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

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

src/Language/PureScript/CodeGen/Externs.hs+7−2

@@ -30,6 +30,7 @@ import Language.PureScript.Names

30import Language.PureScript.Pretty

31import Language.PureScript.TypeClassDictionaries

32import Language.PureScript.Types

33+import Language.PureScript.Parser.Lexer

34-- |

35-- |

35-- Generate foreign imports for all declarations in a module

36-- Generate foreign imports for all declarations in a module

@@ -46,11 +47,15 @@ moduleToPs (Module moduleName ds (Just exts)) env = intercalate "\n" . execWrite

46 declToPs (ImportDeclaration mn _ _) = tell ["import " ++ show mn ++ " ()"]

47 declToPs (ImportDeclaration mn _ _) = tell ["import " ++ show mn ++ " ()"]

47 declToPs (FixityDeclaration (Fixity assoc prec) ident) =

48 declToPs (FixityDeclaration (Fixity assoc prec) ident) =

48 tell [ unwords [ show assoc, show prec, ident ] ]

49 tell [ unwords [ show assoc, show prec, ident ] ]

49− declToPs (PositionedDeclaration _ d) = declToPs d

50+ declToPs (PositionedDeclaration _ com d) = mapM commentToPs com >> declToPs d

50 declToPs _ = return ()

51 declToPs _ = return ()

52+

53+ commentToPs :: Comment -> Writer [String] ()

54+ commentToPs (LineComment s) = tell ["-- " ++ s]

55+ commentToPs (BlockComment s) = tell ["{- " ++ s ++ " -}"]

52 exportToPs :: DeclarationRef -> Writer [String] ()

57 exportToPs :: DeclarationRef -> Writer [String] ()

53− exportToPs (PositionedDeclarationRef _ r) = exportToPs r

58+ exportToPs (PositionedDeclarationRef _ _ r) = exportToPs r

54 exportToPs (TypeRef pn dctors) = do

59 exportToPs (TypeRef pn dctors) = do

55 case Qualified (Just moduleName) pn `M.lookup` types env of

60 case Qualified (Just moduleName) pn `M.lookup` types env of

56 Nothing -> error $ show pn ++ " has no kind in exportToPs"

61 Nothing -> error $ show pn ++ " has no kind in exportToPs"

src/Language/PureScript/CodeGen/JS.hs+10−11

@@ -22,8 +22,7 @@ module Language.PureScript.CodeGen.JS (

22 moduleToJs

23) where

25−import Data.Function (on)

25+import Data.List ((\\), delete)

26−import Data.List ((\\), delete, sortBy)

27import Data.Maybe (catMaybes, mapMaybe)

26import Data.Maybe (catMaybes, mapMaybe)

29import Control.Applicative

28import Control.Applicative

@@ -113,9 +112,9 @@ accessorString prop | identNeedsEscaping prop = JSIndexer (JSStringLiteral prop)

113valueToJs :: (Functor m, Applicative m, Monad m) => ModuleName -> Expr Ann -> SupplyT m JS

112valueToJs :: (Functor m, Applicative m, Monad m) => ModuleName -> Expr Ann -> SupplyT m JS

114valueToJs m (Literal _ l) =

113valueToJs m (Literal _ l) =

115 literalToValueJS m l

114 literalToValueJS m l

116−valueToJs m (Var (_, _, Just (IsConstructor _ 0)) name) =

115+valueToJs m (Var (_, _, _, Just (IsConstructor _ 0)) name) =

117 return $ JSAccessor "value" $ qualifiedToJS m id name

116 return $ JSAccessor "value" $ qualifiedToJS m id name

118−valueToJs m (Var (_, _, Just (IsConstructor _ _)) name) =

117+valueToJs m (Var (_, _, _, Just (IsConstructor _ _)) name) =

119 return $ JSAccessor "create" $ qualifiedToJS m id name

118 return $ JSAccessor "create" $ qualifiedToJS m id name

120valueToJs m (Accessor _ prop val) =

119valueToJs m (Accessor _ prop val) =

121 accessorString prop <$> valueToJs m val

120 accessorString prop <$> valueToJs m val

@@ -123,7 +122,7 @@ valueToJs m (ObjectUpdate _ o ps) = do

123 obj <- valueToJs m o

122 obj <- valueToJs m o

124 sts <- mapM (sndM (valueToJs m)) ps

123 sts <- mapM (sndM (valueToJs m)) ps

125 extendObj obj sts

124 extendObj obj sts

126−valueToJs _ e@(Abs (_, _, Just IsTypeClassConstructor) _ val) =

125+valueToJs _ e@(Abs (_, _, _, Just IsTypeClassConstructor) _ _) =

127 let args = unAbs e

126 let args = unAbs e

128 in return $ JSFunction Nothing (map identToJs args) (JSBlock $ map assign args)

127 in return $ JSFunction Nothing (map identToJs args) (JSBlock $ map assign args)

129 where

128 where

@@ -140,10 +139,10 @@ valueToJs m e@App{} = do

140 let (f, args) = unApp e []

139 let (f, args) = unApp e []

141 args' <- mapM (valueToJs m) args

140 args' <- mapM (valueToJs m) args

142 case f of

141 case f of

143− Var (_, _, Just IsNewtype) _ -> return (head args')

142+ Var (_, _, _, Just IsNewtype) _ -> return (head args')

144− Var (_, _, Just (IsConstructor _ arity)) name | arity == length args ->

143+ Var (_, _, _, Just (IsConstructor _ arity)) name | arity == length args ->

145 return $ JSUnary JSNew $ JSApp (qualifiedToJS m id name) args'

144 return $ JSUnary JSNew $ JSApp (qualifiedToJS m id name) args'

146− Var (_, _, Just IsTypeClassConstructor) name ->

145+ Var (_, _, _, Just IsTypeClassConstructor) name ->

147 return $ JSUnary JSNew $ JSApp (qualifiedToJS m id name) args'

146 return $ JSUnary JSNew $ JSApp (qualifiedToJS m id name) args'

148 _ -> flip (foldl (\fn a -> JSApp fn [a])) args' <$> valueToJs m f

147 _ -> flip (foldl (\fn a -> JSApp fn [a])) args' <$> valueToJs m f

149 where

148 where

@@ -159,7 +158,7 @@ valueToJs m (Let _ ds val) = do

159 decls <- concat . catMaybes <$> mapM (bindToJs m) ds

158 decls <- concat . catMaybes <$> mapM (bindToJs m) ds

160 ret <- valueToJs m val

159 ret <- valueToJs m val

161 return $ JSApp (JSFunction Nothing [] (JSBlock (decls ++ [JSReturn ret]))) []

160 return $ JSApp (JSFunction Nothing [] (JSBlock (decls ++ [JSReturn ret]))) []

162−valueToJs _ (Constructor (_, _, Just IsNewtype) _ (ProperName ctor) _) =

161+valueToJs _ (Constructor (_, _, _, Just IsNewtype) _ (ProperName ctor) _) =

163 return $ JSVariableIntroduction ctor (Just $

162 return $ JSVariableIntroduction ctor (Just $

164 JSObjectLiteral [("create",

163 JSObjectLiteral [("create",

165 JSFunction Nothing ["value"]

164 JSFunction Nothing ["value"]

@@ -268,9 +267,9 @@ binderToJs m varName done (LiteralBinder _ l) =

268 literalToBinderJS m varName done l

267 literalToBinderJS m varName done l

269binderToJs _ varName done (VarBinder _ ident) =

268binderToJs _ varName done (VarBinder _ ident) =

270 return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : done)

269 return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : done)

271−binderToJs m varName done (ConstructorBinder (_, _, Just IsNewtype) _ _ [b]) =

270+binderToJs m varName done (ConstructorBinder (_, _, _, Just IsNewtype) _ _ [b]) =

272 binderToJs m varName done b

271 binderToJs m varName done b

273−binderToJs m varName done (ConstructorBinder (_, _, Just (IsConstructor ctorType _)) _ ctor bs) = do

272+binderToJs m varName done (ConstructorBinder (_, _, _, Just (IsConstructor ctorType _)) _ ctor bs) = do

274 js <- go 0 done bs

273 js <- go 0 done bs

275 return $ case ctorType of

274 return $ case ctorType of

276 ProductType -> js

275 ProductType -> js

src/Language/PureScript/CoreFn/Ann.hs+3−2

@@ -17,14 +17,15 @@ module Language.PureScript.CoreFn.Ann where

17import Language.PureScript.AST.SourcePos

18import Language.PureScript.CoreFn.Meta

19import Language.PureScript.Types

20+import Language.PureScript.Parser.Lexer

21-- |

22-- |

22-- Type alias for basic annotations

23-- Type alias for basic annotations

23--

24--

24−type Ann = (Maybe SourceSpan, Maybe Type, Maybe Meta)

25+type Ann = (Maybe SourceSpan, [Comment], Maybe Type, Maybe Meta)

26-- |

27-- |

27-- Initial annotation with no metadata

28-- Initial annotation with no metadata

28--

29--

29nullAnn :: Ann

30nullAnn :: Ann

30−nullAnn = (Nothing, Nothing, Nothing)

31+nullAnn = (Nothing, [], Nothing, Nothing)

src/Language/PureScript/CoreFn/Desugar.hs+92−92

@@ -33,8 +33,8 @@ import Language.PureScript.Environment

33import Language.PureScript.Names

34import Language.PureScript.Sugar.TypeClasses (typeClassMemberName, superClassDictionaryNames)

35import Language.PureScript.Types

36+import Language.PureScript.Parser.Lexer

36import qualified Language.PureScript.AST as A

37import qualified Language.PureScript.AST as A

37−import qualified Language.PureScript.Constants as C

39-- |

40-- Desugars a module from AST to CoreFn representation.

@@ -44,7 +44,7 @@ moduleToCoreFn env (A.Module mn decls (Just exps)) =

44 let imports = nub $ mapMaybe importToCoreFn decls ++ findQualModules decls

45 exps' = nub $ concatMap exportToCoreFn exps

46 externs = nub $ mapMaybe externToCoreFn decls

47− decls' = concatMap (declToCoreFn env Nothing) decls

47+ decls' = concatMap (declToCoreFn env Nothing []) decls

48 in Module mn imports exps' externs decls'

49moduleToCoreFn _ (A.Module{}) =

50 error "Module exports were not elaborated before moduleToCoreFn"

@@ -63,7 +63,7 @@ findQualModules decls =

63--

64importToCoreFn :: A.Declaration -> Maybe ModuleName

65importToCoreFn (A.ImportDeclaration name _ _) = Just name

66−importToCoreFn (A.PositionedDeclaration _ d) = importToCoreFn d

66+importToCoreFn (A.PositionedDeclaration _ _ d) = importToCoreFn d

67importToCoreFn _ = Nothing

69-- |

@@ -72,7 +72,7 @@ importToCoreFn _ = Nothing

72externToCoreFn :: A.Declaration -> Maybe ForeignDecl

73externToCoreFn (A.ExternDeclaration _ name js ty) = Just (name, js, ty)

74externToCoreFn (A.ExternInstanceDeclaration name _ _ _) = Just (name, Nothing, tyObject)

75−externToCoreFn (A.PositionedDeclaration _ d) = externToCoreFn d

75+externToCoreFn (A.PositionedDeclaration _ _ d) = externToCoreFn d

76externToCoreFn _ = Nothing

78-- |

@@ -85,134 +85,134 @@ exportToCoreFn (A.TypeRef _ (Just dctors)) = map properToIdent dctors

85exportToCoreFn (A.ValueRef name) = [name]

86exportToCoreFn (A.TypeClassRef name) = [properToIdent name]

87exportToCoreFn (A.TypeInstanceRef name) = [name]

88−exportToCoreFn (A.PositionedDeclarationRef _ d) = exportToCoreFn d

88+exportToCoreFn (A.PositionedDeclarationRef _ _ d) = exportToCoreFn d

89exportToCoreFn _ = []

91-- |

92-- Desugars member declarations from AST to CoreFn representation.

93--

94−declToCoreFn :: Environment -> Maybe SourceSpan -> A.Declaration -> [Bind Ann]

94+declToCoreFn :: Environment -> Maybe SourceSpan -> [Comment] -> A.Declaration -> [Bind Ann]

95−declToCoreFn _ ss (A.DataDeclaration Newtype _ _ [(ctor, _)]) =

95+declToCoreFn _ ss com (A.DataDeclaration Newtype _ _ [(ctor, _)]) =

96 [NonRec (properToIdent ctor) $

97− Abs (ss, Nothing, Just IsNewtype) (Ident "x") (Var nullAnn $ Qualified Nothing (Ident "x"))]

97+ Abs (ss, com, Nothing, Just IsNewtype) (Ident "x") (Var nullAnn $ Qualified Nothing (Ident "x"))]

98−declToCoreFn _ _ d@(A.DataDeclaration Newtype _ _ _) =

98+declToCoreFn _ _ _ d@(A.DataDeclaration Newtype _ _ _) =

99 error $ "Found newtype with multiple constructors: " ++ show d

100−declToCoreFn _ ss (A.DataDeclaration Data tyName _ ctors) =

100+declToCoreFn _ ss com (A.DataDeclaration Data tyName _ ctors) =

101 flip map ctors $ \(ctor, tys) ->

102− NonRec (properToIdent ctor) $ Constructor (ss, Nothing, Nothing) tyName ctor (length tys)

102+ NonRec (properToIdent ctor) $ Constructor (ss, com, Nothing, Nothing) tyName ctor (length tys)

103−declToCoreFn env ss (A.DataBindingGroupDeclaration ds) = concatMap (declToCoreFn env ss) ds

103+declToCoreFn env ss _ (A.DataBindingGroupDeclaration ds) = concatMap (declToCoreFn env ss []) ds

104−declToCoreFn env ss (A.ValueDeclaration name _ _ (Right e)) =

104+declToCoreFn env ss com (A.ValueDeclaration name _ _ (Right e)) =

105− [NonRec name (exprToCoreFn env ss Nothing e)]

105+ [NonRec name (exprToCoreFn env ss com Nothing e)]

106−declToCoreFn env ss (A.BindingGroupDeclaration ds) =

106+declToCoreFn env ss _ (A.BindingGroupDeclaration ds) =

107− [Rec $ map (\(name, _, e) -> (name, exprToCoreFn env ss Nothing e)) ds]

107+ [Rec $ map (\(name, _, e) -> (name, exprToCoreFn env ss [] Nothing e)) ds]

108−declToCoreFn _ ss (A.TypeClassDeclaration name _ supers members) =

108+declToCoreFn _ ss com (A.TypeClassDeclaration name _ supers members) =

109− [NonRec (properToIdent name) $ mkTypeClassConstructor ss supers members]

109+ [NonRec (properToIdent name) $ mkTypeClassConstructor ss com supers members]

110−declToCoreFn env _ (A.PositionedDeclaration ss d) =

110+declToCoreFn env _ com (A.PositionedDeclaration ss com1 d) =

111− declToCoreFn env (Just ss) d

111+ declToCoreFn env (Just ss) (com ++ com1) d

112−declToCoreFn _ _ _ = []

112+declToCoreFn _ _ _ _ = []

113

114-- |

115-- Makes a typeclass dictionary constructor function. The returned expression

116-- is a function that accepts the superclass instances and member

117-- implementations and returns a record for the instance dictionary.

118--

119−mkTypeClassConstructor :: Maybe SourceSpan -> [Constraint] -> [A.Declaration] -> Expr Ann

119+mkTypeClassConstructor :: Maybe SourceSpan -> [Comment] -> [Constraint] -> [A.Declaration] -> Expr Ann

120−mkTypeClassConstructor ss [] [] = Literal (ss, Nothing, Just IsTypeClassConstructor) (ObjectLiteral [])

120+mkTypeClassConstructor ss com [] [] = Literal (ss, com, Nothing, Just IsTypeClassConstructor) (ObjectLiteral [])

121−mkTypeClassConstructor ss supers members =

121+mkTypeClassConstructor ss com supers members =

122 let args@(a:as) = sort $ map typeClassMemberName members ++ superClassDictionaryNames supers

123 props = [ (arg, Var nullAnn $ Qualified Nothing (Ident arg)) | arg <- args ]

124 dict = Literal nullAnn (ObjectLiteral props)

125− in Abs (ss, Nothing, Just IsTypeClassConstructor)

125+ in Abs (ss, com, Nothing, Just IsTypeClassConstructor)

126 (Ident a)

127 (foldr (Abs nullAnn . Ident) dict as)

128

129-- |

130-- Desugars expressions from AST to CoreFn representation.

131--

132−exprToCoreFn :: Environment -> Maybe SourceSpan -> Maybe Type -> A.Expr -> Expr Ann

132+exprToCoreFn :: Environment -> Maybe SourceSpan -> [Comment] -> Maybe Type -> A.Expr -> Expr Ann

133−exprToCoreFn _ ss ty (A.NumericLiteral v) =

133+exprToCoreFn _ ss com ty (A.NumericLiteral v) =

134− Literal (ss, ty, Nothing) (NumericLiteral v)

134+ Literal (ss, com, ty, Nothing) (NumericLiteral v)

135−exprToCoreFn _ ss ty (A.StringLiteral v) =

135+exprToCoreFn _ ss com ty (A.StringLiteral v) =

136− Literal (ss, ty, Nothing) (StringLiteral v)

136+ Literal (ss, com, ty, Nothing) (StringLiteral v)

137−exprToCoreFn _ ss ty (A.BooleanLiteral v) =

137+exprToCoreFn _ ss com ty (A.BooleanLiteral v) =

138− Literal (ss, ty, Nothing) (BooleanLiteral v)

138+ Literal (ss, com, ty, Nothing) (BooleanLiteral v)

139−exprToCoreFn env ss ty (A.ArrayLiteral vs) =

139+exprToCoreFn env ss com ty (A.ArrayLiteral vs) =

140− Literal (ss, ty, Nothing) (ArrayLiteral $ map (exprToCoreFn env ss Nothing) vs)

140+ Literal (ss, com, ty, Nothing) (ArrayLiteral $ map (exprToCoreFn env ss [] Nothing) vs)

141−exprToCoreFn env ss ty (A.ObjectLiteral vs) =

141+exprToCoreFn env ss com ty (A.ObjectLiteral vs) =

142− Literal (ss, ty, Nothing) (ObjectLiteral $ map (second (exprToCoreFn env ss Nothing)) vs)

142+ Literal (ss, com, ty, Nothing) (ObjectLiteral $ map (second (exprToCoreFn env ss [] Nothing)) vs)

143−exprToCoreFn env ss ty (A.Accessor name v) =

143+exprToCoreFn env ss com ty (A.Accessor name v) =

144− Accessor (ss, ty, Nothing) name (exprToCoreFn env ss Nothing v)

144+ Accessor (ss, com, ty, Nothing) name (exprToCoreFn env ss [] Nothing v)

145−exprToCoreFn env ss ty (A.ObjectUpdate obj vs) =

145+exprToCoreFn env ss com ty (A.ObjectUpdate obj vs) =

146− ObjectUpdate (ss, ty, Nothing) (exprToCoreFn env ss Nothing obj) $ map (second (exprToCoreFn env ss Nothing)) vs

146+ ObjectUpdate (ss, com, ty, Nothing) (exprToCoreFn env ss [] Nothing obj) $ map (second (exprToCoreFn env ss [] Nothing)) vs

147−exprToCoreFn env ss ty (A.Abs (Left name) v) =

147+exprToCoreFn env ss com ty (A.Abs (Left name) v) =

148− Abs (ss, ty, Nothing) name (exprToCoreFn env ss Nothing v)

148+ Abs (ss, com, ty, Nothing) name (exprToCoreFn env ss [] Nothing v)

149−exprToCoreFn _ _ _ (A.Abs _ _) =

149+exprToCoreFn _ _ _ _ (A.Abs _ _) =

150 error "Abs with Binder argument was not desugared before exprToCoreFn"

151−exprToCoreFn env ss ty (A.App v1 v2) =

151+exprToCoreFn env ss com ty (A.App v1 v2) =

152− App (ss, ty, Nothing) (exprToCoreFn env ss Nothing v1) (exprToCoreFn env ss Nothing v2)

152+ App (ss, com, ty, Nothing) (exprToCoreFn env ss [] Nothing v1) (exprToCoreFn env ss [] Nothing v2)

153−exprToCoreFn _ ss ty (A.Var ident) =

153+exprToCoreFn _ ss com ty (A.Var ident) =

154− Var (ss, ty, Nothing) ident

154+ Var (ss, com, ty, Nothing) ident

155−exprToCoreFn env ss ty (A.IfThenElse v1 v2 v3) =

155+exprToCoreFn env ss com ty (A.IfThenElse v1 v2 v3) =

156− Case (ss, ty, Nothing) [exprToCoreFn env ss Nothing v1]

156+ Case (ss, com, ty, Nothing) [exprToCoreFn env ss [] Nothing v1]

157 [ CaseAlternative [LiteralBinder nullAnn $ BooleanLiteral True]

158− (Right $ exprToCoreFn env Nothing Nothing v2)

158+ (Right $ exprToCoreFn env Nothing [] Nothing v2)

159 , CaseAlternative [LiteralBinder nullAnn $ BooleanLiteral False]

160− (Right $ exprToCoreFn env Nothing Nothing v3) ]

160+ (Right $ exprToCoreFn env Nothing [] Nothing v3) ]

161−exprToCoreFn env ss ty (A.Constructor name) =

161+exprToCoreFn env ss com ty (A.Constructor name) =

162− Var (ss, ty, Just $ getConstructorMeta env name) $ fmap properToIdent name

162+ Var (ss, com, ty, Just $ getConstructorMeta env name) $ fmap properToIdent name

163−exprToCoreFn env ss ty (A.Case vs alts) =

163+exprToCoreFn env ss com ty (A.Case vs alts) =

164− Case (ss, ty, Nothing) (map (exprToCoreFn env ss Nothing) vs) (map (altToCoreFn env ss) alts)

164+ Case (ss, com, ty, Nothing) (map (exprToCoreFn env ss [] Nothing) vs) (map (altToCoreFn env ss) alts)

165−exprToCoreFn env ss _ (A.TypedValue _ v ty) =

165+exprToCoreFn env ss com _ (A.TypedValue _ v ty) =

166− exprToCoreFn env ss (Just ty) v

166+ exprToCoreFn env ss com (Just ty) v

167−exprToCoreFn env ss ty (A.Let ds v) =

167+exprToCoreFn env ss com ty (A.Let ds v) =

168− Let (ss, ty, Nothing) (concatMap (declToCoreFn env ss) ds) (exprToCoreFn env ss Nothing v)

168+ Let (ss, com, ty, Nothing) (concatMap (declToCoreFn env ss []) ds) (exprToCoreFn env ss [] Nothing v)

169−exprToCoreFn env ss ty (A.TypeClassDictionaryConstructorApp name (A.TypedValue _ (A.ObjectLiteral vs) _)) =

169+exprToCoreFn env ss com _ (A.TypeClassDictionaryConstructorApp name (A.TypedValue _ (A.ObjectLiteral vs) _)) =

170− let args = map (exprToCoreFn env ss Nothing . snd) $ sortBy (compare `on` fst) vs

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

171− ctor = Var (ss, Nothing, Just IsTypeClassConstructor) (fmap properToIdent name)

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

172− in foldl (App (ss, Nothing, Nothing)) ctor args

172+ in foldl (App (ss, com, Nothing, Nothing)) ctor args

173−exprToCoreFn env _ ty (A.PositionedValue ss v) =

173+exprToCoreFn env _ com ty (A.PositionedValue ss com1 v) =

174− exprToCoreFn env (Just ss) ty v

174+ exprToCoreFn env (Just ss) (com ++ com1) ty v

175−exprToCoreFn _ _ _ e =

175+exprToCoreFn _ _ _ _ e =

176 error $ "Unexpected value in exprToCoreFn: " ++ show e

177

178-- |

179-- Desugars case alternatives from AST to CoreFn representation.

180--

181altToCoreFn :: Environment -> Maybe SourceSpan -> A.CaseAlternative -> CaseAlternative Ann

182−altToCoreFn env ss (A.CaseAlternative bs vs) = CaseAlternative (map (binderToCoreFn env ss) bs) (go vs)

182+altToCoreFn env ss (A.CaseAlternative bs vs) = CaseAlternative (map (binderToCoreFn env ss []) bs) (go vs)

183 where

184 go :: Either [(A.Guard, A.Expr)] A.Expr -> Either [(Guard Ann, Expr Ann)] (Expr Ann)

185− go (Left ges) = Left $ map (exprToCoreFn env ss Nothing *** exprToCoreFn env ss Nothing) ges

185+ go (Left ges) = Left $ map (exprToCoreFn env ss [] Nothing *** exprToCoreFn env ss [] Nothing) ges

186− go (Right e) = Right (exprToCoreFn env ss Nothing e)

186+ go (Right e) = Right (exprToCoreFn env ss [] Nothing e)

187

188-- |

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

190--

191−binderToCoreFn :: Environment -> Maybe SourceSpan -> A.Binder -> Binder Ann

191+binderToCoreFn :: Environment -> Maybe SourceSpan -> [Comment] -> A.Binder -> Binder Ann

192−binderToCoreFn _ ss (A.NullBinder) =

192+binderToCoreFn _ ss com (A.NullBinder) =

193− NullBinder (ss, Nothing, Nothing)

193+ NullBinder (ss, com, Nothing, Nothing)

194−binderToCoreFn _ ss (A.BooleanBinder b) =

194+binderToCoreFn _ ss com (A.BooleanBinder b) =

195− LiteralBinder (ss, Nothing, Nothing) (BooleanLiteral b)

195+ LiteralBinder (ss, com, Nothing, Nothing) (BooleanLiteral b)

196−binderToCoreFn _ ss (A.StringBinder s) =

196+binderToCoreFn _ ss com (A.StringBinder s) =

197− LiteralBinder (ss, Nothing, Nothing) (StringLiteral s)

197+ LiteralBinder (ss, com, Nothing, Nothing) (StringLiteral s)

198−binderToCoreFn _ ss (A.NumberBinder n) =

198+binderToCoreFn _ ss com (A.NumberBinder n) =

199− LiteralBinder (ss, Nothing, Nothing) (NumericLiteral n)

199+ LiteralBinder (ss, com, Nothing, Nothing) (NumericLiteral n)

200−binderToCoreFn _ ss (A.VarBinder name) =

200+binderToCoreFn _ ss com (A.VarBinder name) =

201− VarBinder (ss, Nothing, Nothing) name

201+ VarBinder (ss, com, Nothing, Nothing) name

202−binderToCoreFn env ss (A.ConstructorBinder dctor@(Qualified mn _) bs) =

202+binderToCoreFn env ss com (A.ConstructorBinder dctor@(Qualified mn _) bs) =

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

204− in ConstructorBinder (ss, Nothing, Just $ getConstructorMeta env dctor) (Qualified mn tctor) dctor (map (binderToCoreFn env ss) bs)

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

205−binderToCoreFn env ss (A.ObjectBinder bs) =

205+binderToCoreFn env ss com (A.ObjectBinder bs) =

206− LiteralBinder (ss, Nothing, Nothing) (ObjectLiteral $ map (second (binderToCoreFn env ss)) bs)

206+ LiteralBinder (ss, com, Nothing, Nothing) (ObjectLiteral $ map (second (binderToCoreFn env ss [])) bs)

207−binderToCoreFn env ss (A.ArrayBinder bs) =

207+binderToCoreFn env ss com (A.ArrayBinder bs) =

208− LiteralBinder (ss, Nothing, Nothing) (ArrayLiteral $ map (binderToCoreFn env ss) bs)

208+ LiteralBinder (ss, com, Nothing, Nothing) (ArrayLiteral $ map (binderToCoreFn env ss []) bs)

209−binderToCoreFn env ss (A.ConsBinder b1 b2) =

209+binderToCoreFn env ss com (A.ConsBinder b1 b2) =

210 let arrCtor = Qualified (Just $ ModuleName [ProperName "Prim"]) (ProperName "Array")

211− in ConstructorBinder (ss, Nothing, Nothing) arrCtor arrCtor $ map (binderToCoreFn env ss) [b1, b2]

211+ in ConstructorBinder (ss, com, Nothing, Nothing) arrCtor arrCtor $ map (binderToCoreFn env ss []) [b1, b2]

212−binderToCoreFn env ss (A.NamedBinder name b) =

212+binderToCoreFn env ss com (A.NamedBinder name b) =

213− NamedBinder (ss, Nothing, Nothing) name (binderToCoreFn env ss b)

213+ NamedBinder (ss, com, Nothing, Nothing) name (binderToCoreFn env ss [] b)

214−binderToCoreFn env _ (A.PositionedBinder ss b) =

214+binderToCoreFn env _ com (A.PositionedBinder ss com1 b) =

215− binderToCoreFn env (Just ss) b

215+ binderToCoreFn env (Just ss) (com ++ com1) b

216

217-- |

218-- Converts a ProperName to an Ident.

src/Language/PureScript/Parser/Common.hs+6

@@ -126,6 +126,12 @@ indented = checkIndentation (>) P.<?> "indentation"

126same :: P.Parsec s ParseState ()

127same = checkIndentation (==) P.<?> "no indentation"

128

129+-- |

130+-- Read the comments from the the next token, without consuming it

131+--

132+readComments :: P.Parsec [PositionedToken] u [Comment]

133+readComments = P.lookAhead $ ptComments <$> P.anyToken

134+

129-- |

135-- |

130-- Run a parser

136-- Run a parser

131--

137--

src/Language/PureScript/Parser/Declarations.hs+3−2

@@ -50,13 +50,14 @@ import qualified Text.Parsec.Expr as P

50-- |

51-- Read source position information

52--

53−withSourceSpan :: (SourceSpan -> a -> a) -> P.Parsec s u a -> P.Parsec s u a

53+withSourceSpan :: (SourceSpan -> [Comment] -> a -> a) -> P.Parsec [PositionedToken] u a -> P.Parsec [PositionedToken] u a

54withSourceSpan f p = do

55 start <- P.getPosition

56+ comments <- C.readComments

56 x <- p

57 x <- p

57 end <- P.getPosition

58 end <- P.getPosition

58 let sp = SourceSpan (P.sourceName start) (toSourcePos start) (toSourcePos end)

59 let sp = SourceSpan (P.sourceName start) (toSourcePos start) (toSourcePos end)

59− return $ f sp x

60+ return $ f sp comments x

60 where

61 where

61 toSourcePos pos = SourcePos (P.sourceLine pos) (P.sourceColumn pos)

62 toSourcePos pos = SourcePos (P.sourceLine pos) (P.sourceColumn pos)

src/Language/PureScript/Parser/Lexer.hs+9−2

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

13--

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

16−{-# LANGUAGE TupleSections #-}

16+{-# LANGUAGE TupleSections, DeriveDataTypeable #-}

18module Language.PureScript.Parser.Lexer

19 ( PositionedToken(..)

20+ , Comment(..)

20 , Token()

21 , Token()

21 , TokenParser()

22 , TokenParser()

22 , lex

23 , lex

24+ , anyToken

23 , token

25 , token

24 , match

26 , match

25 , lparen

27 , lparen

@@ -73,6 +75,8 @@ import Prelude hiding (lex)

73import Control.Monad (void, guard)

75import Control.Monad (void, guard)

74import Data.Functor.Identity

76import Data.Functor.Identity

78+import qualified Data.Data as D

79+

76import Control.Applicative

80import Control.Applicative

78import Language.PureScript.Parser.State

82import Language.PureScript.Parser.State

@@ -83,7 +87,7 @@ import qualified Text.Parsec.Token as PT

83data Comment

87data Comment

84 = LineComment String

88 = LineComment String

85 | BlockComment String

89 | BlockComment String

86− deriving (Show, Eq, Ord)

90+ deriving (Show, Eq, Ord, D.Data, D.Typeable)

88data Token

92data Token

89 = LParen

93 = LParen

@@ -263,6 +267,9 @@ tokenParser = PT.makeTokenParser langDef

263

267

264type TokenParser a = P.Parsec [PositionedToken] ParseState a

268type TokenParser a = P.Parsec [PositionedToken] ParseState a

265

269

270+anyToken :: TokenParser PositionedToken

271+anyToken = P.token (prettyPrintToken . ptToken) ptSourcePos Just

272+

266token :: (Token -> Maybe a) -> TokenParser a

273token :: (Token -> Maybe a) -> TokenParser a

267token f = P.token (prettyPrintToken . ptToken) ptSourcePos (f . ptToken)

274token f = P.token (prettyPrintToken . ptToken) ptSourcePos (f . ptToken)

268

275

src/Language/PureScript/Pretty/Values.hs+4−4

@@ -81,7 +81,7 @@ literals = mkPattern' match

81 match (TypeClassDictionary name _ _) = return $ "<<dict " ++ show name ++ ">>"

82 match (SuperClassDictionary name _) = return $ "<<superclass dict " ++ show name ++ ">>"

83 match (TypedValue _ val _) = prettyPrintValue' val

84− match (PositionedValue _ val) = prettyPrintValue' val

84+ match (PositionedValue _ _ val) = prettyPrintValue' val

85 match _ = mzero

87prettyPrintDeclaration :: Declaration -> StateT PrinterState Maybe String

@@ -90,7 +90,7 @@ prettyPrintDeclaration (ValueDeclaration ident _ [] (Right val)) = fmap concat $

90 [ return $ show ident ++ " = "

91 , prettyPrintValue' val

92 ]

93−prettyPrintDeclaration (PositionedDeclaration _ d) = prettyPrintDeclaration d

93+prettyPrintDeclaration (PositionedDeclaration _ _ d) = prettyPrintDeclaration d

94prettyPrintDeclaration _ = error "Invalid argument to prettyPrintDeclaration"

96prettyPrintCaseAlternative :: CaseAlternative -> StateT PrinterState Maybe String

@@ -126,7 +126,7 @@ prettyPrintDoNotationElement (DoNotationLet ds) =

126 [ return "let "

127 , withIndent $ prettyPrintMany prettyPrintDeclaration ds

128 ]

129−prettyPrintDoNotationElement (PositionedDoNotationElement _ el) = prettyPrintDoNotationElement el

129+prettyPrintDoNotationElement (PositionedDoNotationElement _ _ el) = prettyPrintDoNotationElement el

130

131ifThenElse :: Pattern PrinterState Expr ((Expr, Expr), Expr)

132ifThenElse = mkPattern match

@@ -204,7 +204,7 @@ prettyPrintBinderAtom = mkPattern' match

204 , return "]"

205 ]

206 match (NamedBinder ident binder) = ((show ident ++ "@") ++) <$> prettyPrintBinder' binder

207− match (PositionedBinder _ binder) = prettyPrintBinder' binder

207+ match (PositionedBinder _ _ binder) = prettyPrintBinder' binder

208 match _ = mzero

209

210-- |

src/Language/PureScript/Renamer.hs+1−1

@@ -150,7 +150,7 @@ renameInValue (Accessor ann prop v) =

150 Accessor ann prop <$> renameInValue v

151renameInValue (ObjectUpdate ann obj vs) =

152 ObjectUpdate ann <$> renameInValue obj <*> mapM (\(name, v) -> (,) name <$> renameInValue v) vs

153−renameInValue e@(Abs (_, _, Just IsTypeClassConstructor) _ _) = return e

153+renameInValue e@(Abs (_, _, _, Just IsTypeClassConstructor) _ _) = return e

154renameInValue (Abs ann name v) =

155 newScope $ Abs ann <$> updateScope name <*> renameInValue v

156renameInValue (App ann v1 v2) =

src/Language/PureScript/Sugar/BindingGroups.hs+6−6

@@ -88,7 +88,7 @@ collapseBindingGroups = let (f, _, _) = everywhereOnValues id collapseBindingGro

88 where

89 go (DataBindingGroupDeclaration ds) = ds

90 go (BindingGroupDeclaration ds) = map (\(ident, nameKind, val) -> ValueDeclaration ident nameKind [] (Right val)) ds

91− go (PositionedDeclaration pos d) = map (PositionedDeclaration pos) $ go d

91+ go (PositionedDeclaration pos com d) = map (PositionedDeclaration pos com) $ go d

92 go other = [other]

94collapseBindingGroupsForValue :: Expr -> Expr

@@ -139,13 +139,13 @@ usedProperNames moduleName =

139

140getIdent :: Declaration -> Ident

141getIdent (ValueDeclaration ident _ _ _) = ident

142−getIdent (PositionedDeclaration _ d) = getIdent d

142+getIdent (PositionedDeclaration _ _ d) = getIdent d

143getIdent _ = error "Expected ValueDeclaration"

144

145getProperName :: Declaration -> ProperName

146getProperName (DataDeclaration _ pn _ _) = pn

147getProperName (TypeSynonymDeclaration pn _ _) = pn

148−getProperName (PositionedDeclaration _ d) = getProperName d

148+getProperName (PositionedDeclaration _ _ d) = getProperName d

149getProperName _ = error "Expected DataDeclaration"

150

151-- |

@@ -178,7 +178,7 @@ toBindingGroup moduleName (CyclicSCC ds') =

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

179

180 cycleError :: Declaration -> [Declaration] -> Either ErrorStack a

181− cycleError (PositionedDeclaration p d) ds = rethrowWithPosition p $ cycleError d ds

181+ cycleError (PositionedDeclaration p _ d) ds = rethrowWithPosition p $ cycleError d ds

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

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

184 cycleError d ds@(_:_) = rethrow (<> mkErrorStack ("The following are not yet defined here: " ++ unwords (map (show . getIdent) ds)) Nothing) $ cycleError d []

@@ -195,11 +195,11 @@ toDataBindingGroup (CyclicSCC ds')

195

196isTypeSynonym :: Declaration -> Maybe ProperName

197isTypeSynonym (TypeSynonymDeclaration pn _ _) = Just pn

198−isTypeSynonym (PositionedDeclaration _ d) = isTypeSynonym d

198+isTypeSynonym (PositionedDeclaration _ _ d) = isTypeSynonym d

199isTypeSynonym _ = Nothing

200

201fromValueDecl :: Declaration -> (Ident, NameKind, Expr)

202fromValueDecl (ValueDeclaration ident nameKind [] (Right val)) = (ident, nameKind, val)

203fromValueDecl ValueDeclaration{} = error "Binders should have been desugared"

204−fromValueDecl (PositionedDeclaration _ d) = fromValueDecl d

204+fromValueDecl (PositionedDeclaration _ _ d) = fromValueDecl d

205fromValueDecl _ = error "Expected ValueDeclaration"

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

@@ -75,16 +75,16 @@ desugarCases = desugarRest <=< fmap join . flip parU toDecls . groupBy inSameGro

75 where

76 go (Let ds val') = Let <$> desugarCases ds <*> pure val'

77 go other = return other

78− desugarRest (PositionedDeclaration pos d : ds) = do

78+ desugarRest (PositionedDeclaration pos com d : ds) = do

79 (d' : ds') <- desugarRest (d : ds)

80− return (PositionedDeclaration pos d' : ds')

80+ return (PositionedDeclaration pos com d' : ds')

81 desugarRest (d : ds) = (:) d <$> desugarRest ds

82 desugarRest [] = pure []

84inSameGroup :: Declaration -> Declaration -> Bool

85inSameGroup (ValueDeclaration ident1 _ _ _) (ValueDeclaration ident2 _ _ _) = ident1 == ident2

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

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

87−inSameGroup d1 (PositionedDeclaration _ d2) = inSameGroup d1 d2

87+inSameGroup d1 (PositionedDeclaration _ _ d2) = inSameGroup d1 d2

88inSameGroup _ _ = False

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

@@ -101,9 +101,9 @@ toDecls ds@(ValueDeclaration ident _ bs result : _) = do

101 throwError $ mkErrorStack ("Duplicate value declaration '" ++ show ident ++ "'") Nothing

102 caseDecl <- makeCaseDeclaration ident tuples

103 return [caseDecl]

104−toDecls (PositionedDeclaration pos d : ds) = do

104+toDecls (PositionedDeclaration pos com d : ds) = do

105 (d' : ds') <- rethrowWithPosition pos $ toDecls (d : ds)

106− return (PositionedDeclaration pos d' : ds')

106+ return (PositionedDeclaration pos com d' : ds')

107toDecls ds = return ds

108

109isVarBinder :: Binder -> Bool

@@ -112,7 +112,7 @@ isVarBinder _ = False

112

113toTuple :: Declaration -> ([Binder], Either [(Guard, Expr)] Expr)

114toTuple (ValueDeclaration _ _ bs result) = (bs, result)

115−toTuple (PositionedDeclaration _ d) = toTuple d

115+toTuple (PositionedDeclaration _ _ d) = toTuple d

116toTuple _ = error "Not a value declaration"

117

118makeCaseDeclaration :: Ident -> [([Binder], Either [(Guard, Expr)] Expr)] -> SupplyT (Either ErrorStack) Declaration

src/Language/PureScript/Sugar/DoNotation.hs+3−3

@@ -36,7 +36,7 @@ desugarDoModule :: Module -> SupplyT (Either ErrorStack) Module

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

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

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

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

40desugarDo d =

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

42 in f d

@@ -49,7 +49,7 @@ desugarDo d =

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

51 replace (Do els) = go els

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

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

53 replace other = return other

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

@@ -71,4 +71,4 @@ desugarDo d =

71 go (DoNotationLet ds : rest) = do

72 rest' <- go rest

73 return $ Let ds rest'

74− go (PositionedDoNotationElement pos el : rest) = rethrowWithPosition pos $ PositionedValue pos <$> go (el : rest)

74+ go (PositionedDoNotationElement pos com el : rest) = rethrowWithPosition pos $ PositionedValue pos com <$> go (el : rest)

src/Language/PureScript/Sugar/Names.hs+13−13

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

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

200

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

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

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

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

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

205 updateDecl (pos, bound) (TypeSynonymDeclaration name ps ty) =

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

217 updateDecl s d = return (s, d)

218

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

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

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

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

222 updateValue (pos, bound) (Let ds val') =

223 let args = mapMaybe letBoundVariable ds

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

235 updateValue s v = return (s, v)

236

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

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

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

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

240 updateBinder s v = return (s, v)

241

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

244

245 letBoundVariable :: Declaration -> Maybe Ident

246 letBoundVariable (ValueDeclaration ident _ _ _) = Just ident

247− letBoundVariable (PositionedDeclaration _ d) = letBoundVariable d

247+ letBoundVariable (PositionedDeclaration _ _ d) = letBoundVariable d

248 letBoundVariable _ = Nothing

249

250 updateTypesEverywhere :: Maybe SourceSpan -> Type -> Either ErrorStack Type

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

317 foldM go env' ds

318 where

319 go env'' (TypeDeclaration name _) = addValue env'' mn name

320− go env'' (PositionedDeclaration pos d) = rethrowWithPosition pos $ go env'' d

320+ go env'' (PositionedDeclaration pos _ d) = rethrowWithPosition pos $ go env'' d

321 go _ _ = error "Invalid declaration in TypeClassDeclaration"

322 addDecl mn env (DataDeclaration _ tn _ dcs) = addType env mn tn (map fst dcs)

323 addDecl mn env (TypeSynonymDeclaration tn _ _) = addType env mn tn []

324 addDecl mn env (ExternDataDeclaration tn _) = addType env mn tn []

325 addDecl mn env (ValueDeclaration name _ _ _) = addValue env mn name

326 addDecl mn env (ExternDeclaration _ name _ _) = addValue env mn name

327− addDecl mn env (PositionedDeclaration _ d) = addDecl mn env d

327+ addDecl mn env (PositionedDeclaration _ _ d) = addDecl mn env d

328 addDecl _ env _ = return env

329

330-- |

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

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

350 -- exports

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

352− filterTypes expTys result (PositionedDeclarationRef pos r) = rethrowWithPosition pos $ filterTypes expTys result r

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

353 filterTypes expTys result (TypeRef name expDcons) = do

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

355 dcons' <- maybe (return dcons) (foldM (filterDcons name dcons) []) expDcons

@@ -365,7 +365,7 @@ filterExports mn exps env = do

365

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

367 filterClasses :: [ProperName] -> [ProperName] -> DeclarationRef -> Either ErrorStack [ProperName]

368− filterClasses exps' result (PositionedDeclarationRef pos r) = rethrowWithPosition pos $ filterClasses exps' result r

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

369 filterClasses exps' result (TypeClassRef name) =

370 if name `elem` exps'

371 then return $ name : result

@@ -374,7 +374,7 @@ filterExports mn exps env = do

374

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

376 filterValues :: [Ident] -> [Ident] -> DeclarationRef -> Either ErrorStack [Ident]

377− filterValues exps' result (PositionedDeclarationRef pos r) = rethrowWithPosition pos $ filterValues exps' result r

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

378 filterValues exps' result (ValueRef name) =

379 if name `elem` exps'

380 then return $ name : result

@@ -389,7 +389,7 @@ findImports :: [Declaration] -> M.Map ModuleName (Maybe SourceSpan, ImportDeclar

389findImports = foldl (findImports' Nothing) M.empty

390 where

391 findImports' pos result (ImportDeclaration mn typ qual) = M.insert mn (pos, typ, qual) result

392− findImports' _ result (PositionedDeclaration pos d) = findImports' (Just pos) result d

392+ findImports' _ result (PositionedDeclaration pos _ d) = findImports' (Just pos) result d

393 findImports' _ result _ = result

394

395-- |

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

443 checkTypeRef (TypeRef _ Nothing) acc (TypeRef _ (Just _)) = acc

444 checkTypeRef (TypeRef name (Just dctor)) _ (TypeRef name' (Just dctor')) = name == name' && dctor == dctor'

445 checkTypeRef (TypeRef name _) _ (TypeRef name' Nothing) = name == name'

446− checkTypeRef (PositionedDeclarationRef _ r) acc hiddenRef = checkTypeRef r acc hiddenRef

446+ checkTypeRef (PositionedDeclarationRef _ _ r) acc hiddenRef = checkTypeRef r acc hiddenRef

447 checkTypeRef _ acc _ = acc

448 in foldl (checkTypeRef ref) False hidden

449 isHidden hidden ref = ref `elem` hidden

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

457

458 -- Import something explicitly

459 importExplicit :: ImportEnvironment -> DeclarationRef -> Either ErrorStack ImportEnvironment

460− importExplicit imp (PositionedDeclarationRef pos r) = rethrowWithPosition pos $ importExplicit imp r

460+ importExplicit imp (PositionedDeclarationRef pos _ r) = rethrowWithPosition pos $ importExplicit imp r

461 importExplicit imp (ValueRef name) = do

462 values' <- updateImports (importedValues imp) name

463 return $ imp { importedValues = values' }

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

476 checkedRefs :: [DeclarationRef] -> Either ErrorStack [DeclarationRef]

477 checkedRefs = mapM check

478 where

479− check (PositionedDeclarationRef pos r) =

479+ check (PositionedDeclarationRef pos _ r) =

480 rethrowWithPosition pos $ check r

481 check ref@(ValueRef name) =

482 checkImportExists "value" values name >> return ref

src/Language/PureScript/Sugar/Operators.hs+1−1

@@ -80,7 +80,7 @@ collectFixities :: Module -> [(Qualified Ident, SourceSpan, Fixity)]

80collectFixities (Module moduleName ds _) = concatMap collect ds

81 where

82 collect :: Declaration -> [(Qualified Ident, SourceSpan, Fixity)]

83− collect (PositionedDeclaration pos (FixityDeclaration fixity name)) = [(Qualified (Just moduleName) (Op name), pos, fixity)]

83+ collect (PositionedDeclaration pos _ (FixityDeclaration fixity name)) = [(Qualified (Just moduleName) (Op name), pos, fixity)]

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

85 collect _ = []

src/Language/PureScript/Sugar/TypeClasses.hs+9−9

@@ -164,9 +164,9 @@ desugarDecl mn exps = go

164 desugared <- lift $ desugarCases members

165 dictDecl <- typeInstanceDictionaryDeclaration name mn deps className tys desugared

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

167− go (PositionedDeclaration pos d) = do

167+ go (PositionedDeclaration pos com d) = do

168 (dr, ds) <- rethrowWithPosition pos $ desugarDecl mn exps d

169− return (dr, map (PositionedDeclaration pos) ds)

169+ return (dr, map (PositionedDeclaration pos com) ds)

170 go other = return (Nothing, [other])

171

172 expRef :: Ident -> Qualified ProperName -> [Type] -> Maybe DeclarationRef

@@ -197,7 +197,7 @@ desugarDecl mn exps = go

197

198memberToNameAndType :: Declaration -> (Ident, Type)

199memberToNameAndType (TypeDeclaration ident ty) = (ident, ty)

200−memberToNameAndType (PositionedDeclaration _ d) = memberToNameAndType d

200+memberToNameAndType (PositionedDeclaration _ _ d) = memberToNameAndType d

201memberToNameAndType _ = error "Invalid declaration in type class definition"

202

203typeClassDictionaryDeclaration :: ProperName -> [(String, Maybe Kind)] -> [Constraint] -> [Declaration] -> Declaration

@@ -215,8 +215,8 @@ typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) =

215 ValueDeclaration ident TypeClassAccessorImport [] $ Right $

216 TypedValue False (Abs (Left $ Ident "dict") (Accessor (runIdent ident) (Var $ Qualified Nothing (Ident "dict")))) $

217 moveQuantifiersToFront (quantify (ConstrainedType [(Qualified (Just mn) name, map (TypeVar . fst) args)] ty))

218−typeClassMemberToDictionaryAccessor mn name args (PositionedDeclaration pos d) =

218+typeClassMemberToDictionaryAccessor mn name args (PositionedDeclaration pos com d) =

219− PositionedDeclaration pos $ typeClassMemberToDictionaryAccessor mn name args d

219+ PositionedDeclaration pos com $ typeClassMemberToDictionaryAccessor mn name args d

220typeClassMemberToDictionaryAccessor _ _ _ _ = error "Invalid declaration in type class definition"

221

222unit :: Type

@@ -263,7 +263,7 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =

263 where

264

265 declName :: Declaration -> Maybe Ident

266− declName (PositionedDeclaration _ d) = declName d

266+ declName (PositionedDeclaration _ _ d) = declName d

267 declName (ValueDeclaration ident _ _ _) = Just ident

268 declName (TypeDeclaration ident _) = Just ident

269 declName _ = Nothing

@@ -272,15 +272,15 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =

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

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

274 return val

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

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

276 val <- memberToValue tys' d

277− return (PositionedValue pos val)

277+ return (PositionedValue pos com val)

278 memberToValue _ _ = error "Invalid declaration in type instance definition"

279

280typeClassMemberName :: Declaration -> String

281typeClassMemberName (TypeDeclaration ident _) = runIdent ident

282typeClassMemberName (ValueDeclaration ident _ _ _) = runIdent ident

283−typeClassMemberName (PositionedDeclaration _ d) = typeClassMemberName d

283+typeClassMemberName (PositionedDeclaration _ _ d) = typeClassMemberName d

284typeClassMemberName d = error $ "Invalid declaration in type class definition: " ++ show d

285

286superClassDictionaryNames :: [Constraint] -> [String]

src/Language/PureScript/Sugar/TypeDeclarations.hs+4−4

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

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

44--

45desugarTypeDeclarations :: [Declaration] -> Either ErrorStack [Declaration]

46−desugarTypeDeclarations (PositionedDeclaration pos d : ds) = do

46+desugarTypeDeclarations (PositionedDeclaration pos com d : ds) = do

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

48− return (PositionedDeclaration pos d' : ds')

48+ return (PositionedDeclaration pos com d' : ds')

49desugarTypeDeclarations (TypeDeclaration name ty : d : rest) = do

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

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

52 where

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

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

55− fromValueDeclaration (PositionedDeclaration pos d') = do

55+ fromValueDeclaration (PositionedDeclaration pos com d') = do

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

57− return (ident, nameKind, PositionedValue pos val)

57+ return (ident, nameKind, PositionedValue pos com val)

58 fromValueDeclaration _ = throwError $ mkErrorStack ("Orphan type declaration for " ++ show name) Nothing

59desugarTypeDeclarations (TypeDeclaration name _ : []) = throwError $ mkErrorStack ("Orphan type declaration for " ++ show name) Nothing

60desugarTypeDeclarations (ValueDeclaration name nameKind bs val : rest) = do

src/Language/PureScript/TypeChecker.hs+8−8

@@ -84,7 +84,7 @@ addTypeClass moduleName pn args implies ds =

84 modify $ \st -> st { checkEnv = (checkEnv st) { typeClasses = M.insert (Qualified (Just moduleName) pn) (args, members, implies) (typeClasses . checkEnv $ st) } }

85 where

86 toPair (TypeDeclaration ident ty) = (ident, ty)

87− toPair (PositionedDeclaration _ d) = toPair d

87+ toPair (PositionedDeclaration _ _ d) = toPair d

88 toPair _ = error "Invalid declaration in TypeClassDeclaration"

90addTypeClassDictionaries :: [TypeClassDictionaryInScope] -> Check ()

@@ -163,10 +163,10 @@ typeCheckAll mainModuleName moduleName exps = go

163 return $ d : ds

164 where

165 toTypeSynonym (TypeSynonymDeclaration nm args ty) = Just (nm, args, ty)

166− toTypeSynonym (PositionedDeclaration _ d') = toTypeSynonym d'

166+ toTypeSynonym (PositionedDeclaration _ _ d') = toTypeSynonym d'

167 toTypeSynonym _ = Nothing

168 toDataDecl (DataDeclaration dtype nm args dctors) = Just (dtype, nm, args, dctors)

169− toDataDecl (PositionedDeclaration _ d') = toDataDecl d'

169+ toDataDecl (PositionedDeclaration _ _ d') = toDataDecl d'

170 toDataDecl _ = Nothing

171 go (TypeSynonymDeclaration name args ty : rest) = do

172 rethrow (strMsg ("Error in type synonym " ++ show name) <>) $ do

@@ -239,10 +239,10 @@ typeCheckAll mainModuleName moduleName exps = go

239 goInstance d dictName deps className tys rest

240 go (d@(ExternInstanceDeclaration dictName deps className tys) : rest) = do

241 goInstance d dictName deps className tys rest

242− go (PositionedDeclaration pos d : rest) =

242+ go (PositionedDeclaration pos com d : rest) =

243 rethrowWithPosition pos $ do

244 (d' : rest') <- go (d : rest)

245− return (PositionedDeclaration pos d' : rest')

245+ return (PositionedDeclaration pos com d' : rest')

246 goInstance :: Declaration -> Ident -> [Constraint] -> Qualified ProperName -> [Type] -> [Declaration] -> Check [Declaration]

247 goInstance d dictName deps className tys rest = do

248 mapM_ (checkTypeClassInstance moduleName) tys

@@ -258,7 +258,7 @@ typeCheckAll mainModuleName moduleName exps = go

258

259 exportsInstance :: DeclarationRef -> Bool

260 exportsInstance (TypeInstanceRef name) | name == dictName = True

261− exportsInstance (PositionedDeclarationRef _ r) = exportsInstance r

261+ exportsInstance (PositionedDeclarationRef _ _ r) = exportsInstance r

262 exportsInstance _ = False

263

264 -- |

@@ -346,10 +346,10 @@ typeCheckModule mainModuleName (Module mn decls (Just exps)) = do

346 runValueRef _ = error "non-ValueRef passed to runValueRef"

347 findClassMembers :: Declaration -> Maybe [Ident]

348 findClassMembers (TypeClassDeclaration name' _ _ ds) | name == name' = Just $ map extractMemberName ds

349− findClassMembers (PositionedDeclaration _ d) = findClassMembers d

349+ findClassMembers (PositionedDeclaration _ _ d) = findClassMembers d

350 findClassMembers _ = Nothing

351 extractMemberName :: Declaration -> Ident

352− extractMemberName (PositionedDeclaration _ d) = extractMemberName d

352+ extractMemberName (PositionedDeclaration _ _ d) = extractMemberName d

353 extractMemberName (TypeDeclaration memberName _) = memberName

354 extractMemberName _ = error "Unexpected declaration in typeclass member list"

355 checkClassMembersAreExported _ = return ()

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

@@ -296,7 +296,7 @@ infer' (TypedValue checkType val ty) = do

296 ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty

297 val' <- if checkType then check val ty' else return val

298 return $ TypedValue True val' ty'

299−infer' (PositionedValue pos val) = rethrowWithPosition pos $ infer' val

299+infer' (PositionedValue pos _ val) = rethrowWithPosition pos $ infer' val

300infer' _ = error "Invalid argument to infer"

301

302inferLetBinding :: [Declaration] -> [Declaration] -> Expr -> (Expr -> UnifyT Type Check Expr) -> UnifyT Type Check ([Declaration], Expr)

@@ -322,9 +322,9 @@ inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do

322 ds2' <- forM untyped $ \e -> typeForBindingGroupElement e dict untypedDict

323 let ds' = [(ident, LocalVariable, val') | (ident, (val', _)) <- ds1' ++ ds2']

324 makeBindingGroupVisible $ bindNames dict $ inferLetBinding (seen ++ [BindingGroupDeclaration ds']) rest ret j

325−inferLetBinding seen (PositionedDeclaration pos d : ds) ret j = rethrowWithPosition pos $ do

325+inferLetBinding seen (PositionedDeclaration pos com d : ds) ret j = rethrowWithPosition pos $ do

326 (d' : ds', val') <- inferLetBinding seen (d : ds) ret j

327− return (PositionedDeclaration pos d' : ds', val')

327+ return (PositionedDeclaration pos com d' : ds', val')

328inferLetBinding _ _ _ _ = error "Invalid argument to inferLetBinding"

329

330-- |

@@ -394,7 +394,7 @@ inferBinder val (ConsBinder headBinder tailBinder) = do

394inferBinder val (NamedBinder name binder) = do

395 m <- inferBinder val binder

396 return $ M.insert name val m

397−inferBinder val (PositionedBinder pos binder) =

397+inferBinder val (PositionedBinder pos _ binder) =

398 rethrowWithPosition pos $ inferBinder val binder

399

400-- |

@@ -563,7 +563,7 @@ check' val kt@(KindedType ty kind) = do

563 guardWith (strMsg $ "Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star

564 val' <- check' val ty

565 return $ TypedValue True val' kt

566−check' (PositionedValue pos val) ty =

566+check' (PositionedValue pos _ val) ty =

567 rethrowWithPosition pos $ check val ty

568check' val ty = throwError $ mkErrorStack ("Expr does not have type " ++ prettyPrintType ty) (Just (ExprError val))

569