fa89354 · rowtype-yoga/purescript-native

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

Initial work on #518

commitfa893548743d099ec8a96c3b14f8c21083945883 authorPhil Freeman <paf31@cantab.net> dateTue 6 Jan 2015, 18:22 (12 years ago) parent2881a5b

25 files changed+247−226

compare with golang

unifiedsplit

hierarchy/Main.hs+1−1

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

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

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

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

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

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

8888superClasses _ = []

8989

9090inputFile :: Parser FilePath

psc-docs/Main.hs+6−6

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

152152 [] -> ""

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

154154 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) =

156156 renderDeclaration n exps d

157157renderDeclaration _ _ _ = return ()

158158

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

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

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

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

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

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

180180getName _ = error "Invalid argument to getName"

181181

182182isValueDeclaration :: P.Declaration -> Bool

183183isValueDeclaration P.TypeDeclaration{} = True

184184isValueDeclaration P.ExternDeclaration{} = True

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

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

186186isValueDeclaration _ = False

187187

188188isTypeDeclaration :: P.Declaration -> Bool

189189isTypeDeclaration P.DataDeclaration{} = True

190190isTypeDeclaration P.ExternDataDeclaration{} = True

191191isTypeDeclaration P.TypeSynonymDeclaration{} = True

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

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

193193isTypeDeclaration _ = False

194194

195195isTypeClassDeclaration :: P.Declaration -> Bool

196196isTypeClassDeclaration P.TypeClassDeclaration{} = True

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

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

198198isTypeClassDeclaration _ = False

199199

200200isTypeInstanceDeclaration :: P.Declaration -> Bool

201201isTypeInstanceDeclaration P.TypeInstanceDeclaration{} = True

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

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

203203isTypeInstanceDeclaration _ = False

204204

205205inputFile :: Parser FilePath

psci/Main.hs+2−2

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

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

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

246246 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

248248 getDeclName _ _ = Nothing

249249

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

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

252252 where

253253 exports :: P.DeclarationRef -> Bool

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

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

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

256256 exports _ = False

257257

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

src/Language/PureScript.hs+1−1

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

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

240240 where

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

242− isExistingImport (PositionedDeclaration _ d) = isExistingImport d

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

243243 isExistingImport _ = False

244244

245245importPrim :: Module -> Module

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

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

2020

2121import Language.PureScript.AST.SourcePos

2222import Language.PureScript.Names

23+import Language.PureScript.Parser.Lexer

2324

2425-- |

2526-- Data type for binders

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

6869 -- |

6970 -- A binder with source position information

7071 --

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

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

7273

7374-- |

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

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

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

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

8485 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

8687 go ns _ = ns

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

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

2525import Language.PureScript.Names

2626import Language.PureScript.Kinds

2727import Language.PureScript.TypeClassDictionaries

28+import Language.PureScript.Parser.Lexer

2829import Language.PureScript.CodeGen.JS.AST

2930import Language.PureScript.Environment

3031

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

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

4142isExported Nothing _ = True

4243isExported _ TypeInstanceDeclaration{} = True

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

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

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

4546 where

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

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

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

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

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

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

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

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

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

5455 matches _ _ = False

5556

5657exportedDeclarations :: Module -> [Declaration]

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

6364isDctorExported _ Nothing _ = True

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

6566 where

66− test (PositionedDeclarationRef _ d) = test d

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

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

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

6970 test _ = False

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

102103 -- |

103104 -- A declaration reference with source position information

104105 --

105− | PositionedDeclarationRef SourceSpan DeclarationRef

106+ | PositionedDeclarationRef SourceSpan [Comment] DeclarationRef

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

107108

108109instance Eq DeclarationRef where

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

110111 (ValueRef name) == (ValueRef name') = name == name'

111112 (TypeClassRef name) == (TypeClassRef name') = name == name'

112113 (TypeInstanceRef name) == (TypeInstanceRef name') = name == name'

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

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

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

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

115116 _ == _ = False

116117

117118-- |

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

192193 -- |

193194 -- A declaration with source position information

194195 --

195− | PositionedDeclaration SourceSpan Declaration

196+ | PositionedDeclaration SourceSpan [Comment] Declaration

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

197198

198199-- |

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

200201--

201202isValueDecl :: Declaration -> Bool

202203isValueDecl ValueDeclaration{} = True

203−isValueDecl (PositionedDeclaration _ d) = isValueDecl d

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

204205isValueDecl _ = False

205206

206207-- |

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

209210isDataDecl :: Declaration -> Bool

210211isDataDecl DataDeclaration{} = True

211212isDataDecl TypeSynonymDeclaration{} = True

212−isDataDecl (PositionedDeclaration _ d) = isDataDecl d

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

213214isDataDecl _ = False

214215

215216-- |

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

217218--

218219isImportDecl :: Declaration -> Bool

219220isImportDecl ImportDeclaration{} = True

220−isImportDecl (PositionedDeclaration _ d) = isImportDecl d

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

221222isImportDecl _ = False

222223

223224-- |

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

225226--

226227isExternDataDecl :: Declaration -> Bool

227228isExternDataDecl ExternDataDeclaration{} = True

228−isExternDataDecl (PositionedDeclaration _ d) = isExternDataDecl d

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

229230isExternDataDecl _ = False

230231

231232-- |

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

233234--

234235isExternInstanceDecl :: Declaration -> Bool

235236isExternInstanceDecl ExternInstanceDeclaration{} = True

236−isExternInstanceDecl (PositionedDeclaration _ d) = isExternInstanceDecl d

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

237238isExternInstanceDecl _ = False

238239

239240-- |

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

241242--

242243isFixityDecl :: Declaration -> Bool

243244isFixityDecl FixityDeclaration{} = True

244−isFixityDecl (PositionedDeclaration _ d) = isFixityDecl d

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

245246isFixityDecl _ = False

246247

247248-- |

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

249250--

250251isExternDecl :: Declaration -> Bool

251252isExternDecl ExternDeclaration{} = True

252−isExternDecl (PositionedDeclaration _ d) = isExternDecl d

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

253254isExternDecl _ = False

254255

255256-- |

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

258259isTypeClassDeclaration :: Declaration -> Bool

259260isTypeClassDeclaration TypeClassDeclaration{} = True

260261isTypeClassDeclaration TypeInstanceDeclaration{} = True

261−isTypeClassDeclaration (PositionedDeclaration _ d) = isTypeClassDeclaration d

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

262263isTypeClassDeclaration _ = False

263264

264265-- |

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

369370 -- |

370371 -- A value with source position information

371372 --

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

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

373374

374375-- |

375376-- An alternative in a case statement

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

404405 -- |

405406 -- A do notation element with source position information

406407 --

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

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

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

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

4141 f' other = f other

4242

4343 g' :: Expr -> Expr

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

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

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

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

6060 g' other = g other

6161

6262 h' :: Binder -> Binder

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

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

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

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

6969 h' other = h other

7070

7171 handleCaseAlternative :: CaseAlternative -> CaseAlternative

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

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

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

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

8282

8383

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

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

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

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

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

9797 f' other = f other

9898

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

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

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

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

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

115115 g' other = g other

116116

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

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

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

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

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

123123 h' other = h other

124124

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

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

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

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

130130 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

132132

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

134134 (Declaration -> m Declaration) ->

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

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

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

144144 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

146146 f' other = f other

147147

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

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

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

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

162162 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

164164 g' other = g other

165165

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

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

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

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

170170 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

172172 h' other = h other

173173

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

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

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

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

179179 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

181181

182182everythingOnValues :: (r -> r -> r) ->

183183 (Declaration -> r) ->

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

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

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

196196 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

198198 f' d = f d

199199

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

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

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

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

214214 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

216216 g' v = g v

217217

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

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

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

222222 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

224224 h' b = h b

225225

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

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

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

231231 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

233233

234234everythingWithContextOnValues ::

235235 s ->

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

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

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

257257 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

259259 f' _ _ = r0

260260

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

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

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

277277 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

279279 g' _ _ = r0

280280

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

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

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

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

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

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

289289 h' _ _ = r0

290290

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

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

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

300300 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

302302

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

304304 s ->

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

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

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

323323 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

325325 f' _ other = return other

326326

327327 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

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

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

343343 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

345345 g' _ other = return other

346346

347347 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

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

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

353353 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

355355 h' _ other = return other

356356

357357 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

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

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

365365 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

367367

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

369369accumTypes 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

3030import Language.PureScript.Pretty

3131import Language.PureScript.TypeClassDictionaries

3232import Language.PureScript.Types

33+import Language.PureScript.Parser.Lexer

3334

3435-- |

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

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

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

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

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

49− declToPs (PositionedDeclaration _ d) = declToPs d

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

5051 declToPs _ = return ()

52+

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

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

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

5156

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

53− exportToPs (PositionedDeclarationRef _ r) = exportToPs r

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

5459 exportToPs (TypeRef pn dctors) = do

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

5661 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 (

2222 moduleToJs

2323) where

2424

25−import Data.Function (on)

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

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

2726import Data.Maybe (catMaybes, mapMaybe)

2827

2928import Control.Applicative

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

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

114113valueToJs m (Literal _ l) =

115114 literalToValueJS m l

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

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

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

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

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

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

120119valueToJs m (Accessor _ prop val) =

121120 accessorString prop <$> valueToJs m val

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

123122 obj <- valueToJs m o

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

125124 extendObj obj sts

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

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

127126 let args = unAbs e

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

129128 where

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

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

141140 args' <- mapM (valueToJs m) args

142141 case f of

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

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

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

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

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

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

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

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

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

149148 where

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

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

160159 ret <- valueToJs m val

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

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

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

163162 return $ JSVariableIntroduction ctor (Just $

164163 JSObjectLiteral [("create",

165164 JSFunction Nothing ["value"]

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

268267 literalToBinderJS m varName done l

269268binderToJs _ varName done (VarBinder _ ident) =

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

272271 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

274273 js <- go 0 done bs

275274 return $ case ctorType of

276275 ProductType -> js

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

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

1717import Language.PureScript.AST.SourcePos

1818import Language.PureScript.CoreFn.Meta

1919import Language.PureScript.Types

20+import Language.PureScript.Parser.Lexer

2021

2122-- |

2223-- Type alias for basic annotations

2324--

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

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

2526

2627-- |

2728-- Initial annotation with no metadata

2829--

2930nullAnn :: 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

3333import Language.PureScript.Names

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

3535import Language.PureScript.Types

36+import Language.PureScript.Parser.Lexer

3637import qualified Language.PureScript.AST as A

37−import qualified Language.PureScript.Constants as C

3838

3939-- |

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

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

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

4545 exps' = nub $ concatMap exportToCoreFn exps

4646 externs = nub $ mapMaybe externToCoreFn decls

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

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

4848 in Module mn imports exps' externs decls'

4949moduleToCoreFn _ (A.Module{}) =

5050 error "Module exports were not elaborated before moduleToCoreFn"

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

6363--

6464importToCoreFn :: A.Declaration -> Maybe ModuleName

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

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

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

6767importToCoreFn _ = Nothing

6868

6969-- |

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

7272externToCoreFn :: A.Declaration -> Maybe ForeignDecl

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

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

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

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

7676externToCoreFn _ = Nothing

7777

7878-- |

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

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

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

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

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

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

8989exportToCoreFn _ = []

9090

9191-- |

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

9393--

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

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

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

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

9696 [NonRec (properToIdent ctor) $

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

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

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

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

9999 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) =

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

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

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

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

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

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

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

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

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

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

111− declToCoreFn env (Just ss) d

112−declToCoreFn _ _ _ = []

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

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

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

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

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

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

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

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

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

112+declToCoreFn _ _ _ _ = []

113113

114114-- |

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

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

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

118118--

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

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

121−mkTypeClassConstructor ss supers members =

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

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

121+mkTypeClassConstructor ss com supers members =

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

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

124124 dict = Literal nullAnn (ObjectLiteral props)

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

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

126126 (Ident a)

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

128128

129129-- |

130130-- Desugars expressions from AST to CoreFn representation.

131131--

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

154− Var (ss, ty, Nothing) ident

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

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

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

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

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

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

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

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

157157 [ CaseAlternative [LiteralBinder nullAnn $ BooleanLiteral True]

158− (Right $ exprToCoreFn env Nothing Nothing v2)

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

159159 , CaseAlternative [LiteralBinder nullAnn $ BooleanLiteral False]

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

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

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

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

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

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

166− exprToCoreFn env ss (Just ty) v

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

168− Let (ss, 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) _)) =

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

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

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

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

174− exprToCoreFn env (Just ss) ty v

175−exprToCoreFn _ _ _ e =

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

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

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

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

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

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

166+ exprToCoreFn env ss com (Just ty) v

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

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

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

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

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

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

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

175+exprToCoreFn _ _ _ _ e =

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

177177

178178-- |

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

180180--

181181altToCoreFn :: 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)

183183 where

184184 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

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

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)

187187

188188-- |

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

190190--

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

192−binderToCoreFn _ ss (A.NullBinder) =

193− NullBinder (ss, Nothing, Nothing)

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

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

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

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

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

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

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

201− VarBinder (ss, Nothing, Nothing) name

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

215− binderToCoreFn env (Just ss) b

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

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

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

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

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

216216

217217-- |

218218-- Converts a ProperName to an Ident.

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

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

126126same :: P.Parsec s ParseState ()

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

128128

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+

129135-- |

130136-- Run a parser

131137--

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

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

5050-- |

5151-- Read source position information

5252--

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

5454withSourceSpan f p = do

5555 start <- P.getPosition

56+ comments <- C.readComments

5657 x <- p

5758 end <- P.getPosition

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

59− return $ f sp x

60+ return $ f sp comments x

6061 where

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

6263

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

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

1313--

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

1515

16−{-# LANGUAGE TupleSections #-}

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

1717

1818module Language.PureScript.Parser.Lexer

1919 ( PositionedToken(..)

20+ , Comment(..)

2021 , Token()

2122 , TokenParser()

2223 , lex

24+ , anyToken

2325 , token

2426 , match

2527 , lparen

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

7375import Control.Monad (void, guard)

7476import Data.Functor.Identity

7577

78+import qualified Data.Data as D

79+

7680import Control.Applicative

7781

7882import Language.PureScript.Parser.State

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

8387data Comment

8488 = LineComment String

8589 | BlockComment String

86− deriving (Show, Eq, Ord)

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

8791

8892data Token

8993 = LParen

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

263267

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

265269

270+anyToken :: TokenParser PositionedToken

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

272+

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

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

268275

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

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

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

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

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

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

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

8585 match _ = mzero

8686

8787prettyPrintDeclaration :: Declaration -> StateT PrinterState Maybe String

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

9090 [ return $ show ident ++ " = "

9191 , prettyPrintValue' val

9292 ]

93−prettyPrintDeclaration (PositionedDeclaration _ d) = prettyPrintDeclaration d

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

9494prettyPrintDeclaration _ = error "Invalid argument to prettyPrintDeclaration"

9595

9696prettyPrintCaseAlternative :: CaseAlternative -> StateT PrinterState Maybe String

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

126126 [ return "let "

127127 , withIndent $ prettyPrintMany prettyPrintDeclaration ds

128128 ]

129−prettyPrintDoNotationElement (PositionedDoNotationElement _ el) = prettyPrintDoNotationElement el

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

130130

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

132132ifThenElse = mkPattern match

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

204204 , return "]"

205205 ]

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

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

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

208208 match _ = mzero

209209

210210-- |

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

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

150150 Accessor ann prop <$> renameInValue v

151151renameInValue (ObjectUpdate ann obj vs) =

152152 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

154154renameInValue (Abs ann name v) =

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

156156renameInValue (App ann v1 v2) =

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

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

8888 where

8989 go (DataBindingGroupDeclaration ds) = ds

9090 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

9292 go other = [other]

9393

9494collapseBindingGroupsForValue :: Expr -> Expr

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

139139

140140getIdent :: Declaration -> Ident

141141getIdent (ValueDeclaration ident _ _ _) = ident

142−getIdent (PositionedDeclaration _ d) = getIdent d

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

143143getIdent _ = error "Expected ValueDeclaration"

144144

145145getProperName :: Declaration -> ProperName

146146getProperName (DataDeclaration _ pn _ _) = pn

147147getProperName (TypeSynonymDeclaration pn _ _) = pn

148−getProperName (PositionedDeclaration _ d) = getProperName d

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

149149getProperName _ = error "Expected DataDeclaration"

150150

151151-- |

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

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

179179

180180 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

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

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

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

195195

196196isTypeSynonym :: Declaration -> Maybe ProperName

197197isTypeSynonym (TypeSynonymDeclaration pn _ _) = Just pn

198−isTypeSynonym (PositionedDeclaration _ d) = isTypeSynonym d

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

199199isTypeSynonym _ = Nothing

200200

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

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

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

204−fromValueDecl (PositionedDeclaration _ d) = fromValueDecl d

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

205205fromValueDecl _ = error "Expected ValueDeclaration"

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

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

7575 where

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

7777 go other = return other

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

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

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

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

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

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

8282 desugarRest [] = pure []

8383

8484inSameGroup :: Declaration -> Declaration -> Bool

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

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

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

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

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

8888inSameGroup _ _ = False

8989

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

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

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

102102 caseDecl <- makeCaseDeclaration ident tuples

103103 return [caseDecl]

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

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

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

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

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

107107toDecls ds = return ds

108108

109109isVarBinder :: Binder -> Bool

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

112112

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

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

115−toTuple (PositionedDeclaration _ d) = toTuple d

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

116116toTuple _ = error "Not a value declaration"

117117

118118makeCaseDeclaration :: 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

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

3737

3838desugarDo :: 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)

4040desugarDo d =

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

4242 in f d

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

4949

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

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

5353 replace other = return other

5454

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

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

7171 go (DoNotationLet ds : rest) = do

7272 rest' <- go rest

7373 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) =

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

200200

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

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

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

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

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

217217 updateDecl s d = return (s, d)

218218

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

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

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

223223 let args = mapMaybe letBoundVariable ds

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

235235 updateValue s v = return (s, v)

236236

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

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

240240 updateBinder s v = return (s, v)

241241

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

244244

245245 letBoundVariable :: Declaration -> Maybe Ident

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

247− letBoundVariable (PositionedDeclaration _ d) = letBoundVariable d

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

248248 letBoundVariable _ = Nothing

249249

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

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

317317 foldM go env' ds

318318 where

319319 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

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

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

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

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

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

326326 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

328328 addDecl _ env _ = return env

329329

330330-- |

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

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

350350 -- exports

351351 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

353353 filterTypes expTys result (TypeRef name expDcons) = do

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

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

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

365365

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

367367 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

369369 filterClasses exps' result (TypeClassRef name) =

370370 if name `elem` exps'

371371 then return $ name : result

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

374374

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

376376 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

378378 filterValues exps' result (ValueRef name) =

379379 if name `elem` exps'

380380 then return $ name : result

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

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

390390 where

391391 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

393393 findImports' _ result _ = result

394394

395395-- |

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

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

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

445445 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

447447 checkTypeRef _ acc _ = acc

448448 in foldl (checkTypeRef ref) False hidden

449449 isHidden hidden ref = ref `elem` hidden

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

457457

458458 -- Import something explicitly

459459 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

461461 importExplicit imp (ValueRef name) = do

462462 values' <- updateImports (importedValues imp) name

463463 return $ imp { importedValues = values' }

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

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

477477 checkedRefs = mapM check

478478 where

479− check (PositionedDeclarationRef pos r) =

479+ check (PositionedDeclarationRef pos _ r) =

480480 rethrowWithPosition pos $ check r

481481 check ref@(ValueRef name) =

482482 checkImportExists "value" values name >> return ref

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

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

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

8181 where

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

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

8585 collect _ = []

8686

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

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

164164 desugared <- lift $ desugarCases members

165165 dictDecl <- typeInstanceDictionaryDeclaration name mn deps className tys desugared

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

167− go (PositionedDeclaration pos d) = do

167+ go (PositionedDeclaration pos com d) = do

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

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

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

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

171171

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

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

197197

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

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

200−memberToNameAndType (PositionedDeclaration _ d) = memberToNameAndType d

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

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

202202

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

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

215215 ValueDeclaration ident TypeClassAccessorImport [] $ Right $

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

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

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

219− PositionedDeclaration pos $ typeClassMemberToDictionaryAccessor mn name args d

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

219+ PositionedDeclaration pos com $ typeClassMemberToDictionaryAccessor mn name args d

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

221221

222222unit :: Type

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

263263 where

264264

265265 declName :: Declaration -> Maybe Ident

266− declName (PositionedDeclaration _ d) = declName d

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

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

268268 declName (TypeDeclaration ident _) = Just ident

269269 declName _ = Nothing

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

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

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

274274 return val

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

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

276276 val <- memberToValue tys' d

277− return (PositionedValue pos val)

277+ return (PositionedValue pos com val)

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

279279

280280typeClassMemberName :: Declaration -> String

281281typeClassMemberName (TypeDeclaration ident _) = runIdent ident

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

283−typeClassMemberName (PositionedDeclaration _ d) = typeClassMemberName d

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

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

285285

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

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

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

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

4444--

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

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

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

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

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

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

4949desugarTypeDeclarations (TypeDeclaration name ty : d : rest) = do

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

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

5252 where

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

5454 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

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

57− return (ident, nameKind, PositionedValue pos val)

57+ return (ident, nameKind, PositionedValue pos com val)

5858 fromValueDeclaration _ = throwError $ mkErrorStack ("Orphan type declaration for " ++ show name) Nothing

5959desugarTypeDeclarations (TypeDeclaration name _ : []) = throwError $ mkErrorStack ("Orphan type declaration for " ++ show name) Nothing

6060desugarTypeDeclarations (ValueDeclaration name nameKind bs val : rest) = do

src/Language/PureScript/TypeChecker.hs+8−8

@@ -84,7 +84,7 @@ addTypeClass moduleName pn args implies ds =

8484 modify $ \st -> st { checkEnv = (checkEnv st) { typeClasses = M.insert (Qualified (Just moduleName) pn) (args, members, implies) (typeClasses . checkEnv $ st) } }

8585 where

8686 toPair (TypeDeclaration ident ty) = (ident, ty)

87− toPair (PositionedDeclaration _ d) = toPair d

87+ toPair (PositionedDeclaration _ _ d) = toPair d

8888 toPair _ = error "Invalid declaration in TypeClassDeclaration"

8989

9090addTypeClassDictionaries :: [TypeClassDictionaryInScope] -> Check ()

@@ -163,10 +163,10 @@ typeCheckAll mainModuleName moduleName exps = go

163163 return $ d : ds

164164 where

165165 toTypeSynonym (TypeSynonymDeclaration nm args ty) = Just (nm, args, ty)

166− toTypeSynonym (PositionedDeclaration _ d') = toTypeSynonym d'

166+ toTypeSynonym (PositionedDeclaration _ _ d') = toTypeSynonym d'

167167 toTypeSynonym _ = Nothing

168168 toDataDecl (DataDeclaration dtype nm args dctors) = Just (dtype, nm, args, dctors)

169− toDataDecl (PositionedDeclaration _ d') = toDataDecl d'

169+ toDataDecl (PositionedDeclaration _ _ d') = toDataDecl d'

170170 toDataDecl _ = Nothing

171171 go (TypeSynonymDeclaration name args ty : rest) = do

172172 rethrow (strMsg ("Error in type synonym " ++ show name) <>) $ do

@@ -239,10 +239,10 @@ typeCheckAll mainModuleName moduleName exps = go

239239 goInstance d dictName deps className tys rest

240240 go (d@(ExternInstanceDeclaration dictName deps className tys) : rest) = do

241241 goInstance d dictName deps className tys rest

242− go (PositionedDeclaration pos d : rest) =

242+ go (PositionedDeclaration pos com d : rest) =

243243 rethrowWithPosition pos $ do

244244 (d' : rest') <- go (d : rest)

245− return (PositionedDeclaration pos d' : rest')

245+ return (PositionedDeclaration pos com d' : rest')

246246 goInstance :: Declaration -> Ident -> [Constraint] -> Qualified ProperName -> [Type] -> [Declaration] -> Check [Declaration]

247247 goInstance d dictName deps className tys rest = do

248248 mapM_ (checkTypeClassInstance moduleName) tys

@@ -258,7 +258,7 @@ typeCheckAll mainModuleName moduleName exps = go

258258

259259 exportsInstance :: DeclarationRef -> Bool

260260 exportsInstance (TypeInstanceRef name) | name == dictName = True

261− exportsInstance (PositionedDeclarationRef _ r) = exportsInstance r

261+ exportsInstance (PositionedDeclarationRef _ _ r) = exportsInstance r

262262 exportsInstance _ = False

263263

264264 -- |

@@ -346,10 +346,10 @@ typeCheckModule mainModuleName (Module mn decls (Just exps)) = do

346346 runValueRef _ = error "non-ValueRef passed to runValueRef"

347347 findClassMembers :: Declaration -> Maybe [Ident]

348348 findClassMembers (TypeClassDeclaration name' _ _ ds) | name == name' = Just $ map extractMemberName ds

349− findClassMembers (PositionedDeclaration _ d) = findClassMembers d

349+ findClassMembers (PositionedDeclaration _ _ d) = findClassMembers d

350350 findClassMembers _ = Nothing

351351 extractMemberName :: Declaration -> Ident

352− extractMemberName (PositionedDeclaration _ d) = extractMemberName d

352+ extractMemberName (PositionedDeclaration _ _ d) = extractMemberName d

353353 extractMemberName (TypeDeclaration memberName _) = memberName

354354 extractMemberName _ = error "Unexpected declaration in typeclass member list"

355355 checkClassMembersAreExported _ = return ()

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

@@ -296,7 +296,7 @@ infer' (TypedValue checkType val ty) = do

296296 ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty

297297 val' <- if checkType then check val ty' else return val

298298 return $ TypedValue True val' ty'

299−infer' (PositionedValue pos val) = rethrowWithPosition pos $ infer' val

299+infer' (PositionedValue pos _ val) = rethrowWithPosition pos $ infer' val

300300infer' _ = error "Invalid argument to infer"

301301

302302inferLetBinding :: [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

322322 ds2' <- forM untyped $ \e -> typeForBindingGroupElement e dict untypedDict

323323 let ds' = [(ident, LocalVariable, val') | (ident, (val', _)) <- ds1' ++ ds2']

324324 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

326326 (d' : ds', val') <- inferLetBinding seen (d : ds) ret j

327− return (PositionedDeclaration pos d' : ds', val')

327+ return (PositionedDeclaration pos com d' : ds', val')

328328inferLetBinding _ _ _ _ = error "Invalid argument to inferLetBinding"

329329

330330-- |

@@ -394,7 +394,7 @@ inferBinder val (ConsBinder headBinder tailBinder) = do

394394inferBinder val (NamedBinder name binder) = do

395395 m <- inferBinder val binder

396396 return $ M.insert name val m

397−inferBinder val (PositionedBinder pos binder) =

397+inferBinder val (PositionedBinder pos _ binder) =

398398 rethrowWithPosition pos $ inferBinder val binder

399399

400400-- |

@@ -563,7 +563,7 @@ check' val kt@(KindedType ty kind) = do

563563 guardWith (strMsg $ "Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star

564564 val' <- check' val ty

565565 return $ TypedValue True val' kt

566−check' (PositionedValue pos val) ty =

566+check' (PositionedValue pos _ val) ty =

567567 rethrowWithPosition pos $ check val ty

568568check' val ty = throwError $ mkErrorStack ("Expr does not have type " ++ prettyPrintType ty) (Just (ExprError val))

569569