dea47d7 · rowtype-yoga/purescript-native

docgen/Main.hs+3

compare with golang

unifiedsplit

@@ -84,6 +84,7 @@ renderModule (P.Module moduleName ds exps) =

84isExported :: Maybe [P.DeclarationRef] -> P.Declaration -> Bool

85isExported Nothing _ = True

86isExported _ (P.TypeInstanceDeclaration _ _ _ _ _) = True

87+isExported exps (P.PositionedDeclaration _ d) = isExported exps d

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

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

88 where

89 where

89 matches (P.TypeDeclaration ident _) (P.ValueRef ident') = ident == ident'

90 matches (P.TypeDeclaration ident _) (P.ValueRef ident') = ident == ident'

@@ -130,6 +131,8 @@ renderDeclaration n _ (P.TypeInstanceDeclaration name constraints className tys

130 [] -> ""

131 [] -> ""

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

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

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

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

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

135+ renderDeclaration n exps d

133renderDeclaration _ _ _ = return ()

136renderDeclaration _ _ _ = return ()

134

137

135getName :: P.Declaration -> String

138getName :: P.Declaration -> String

src/Language/PureScript.hs+1

@@ -248,5 +248,6 @@ importPrelude m@(Module mn decls exps) =

248 where

249 prelude = ModuleName [ProperName C.prelude]

250 isPreludeImport (ImportDeclaration (ModuleName [ProperName mn']) _ _) | mn' == C.prelude = True

251+ isPreludeImport (PositionedDeclaration _ d) = isPreludeImport d

251 isPreludeImport _ = False

252 isPreludeImport _ = False

252 preludeImport = ImportDeclaration prelude Nothing Nothing

253 preludeImport = ImportDeclaration prelude Nothing Nothing

src/Language/PureScript/CodeGen/Externs.hs+1

@@ -45,6 +45,7 @@ moduleToPs (Module moduleName ds (Just exts)) env = intercalate "\n" . execWrite

45 fixityToPs :: Declaration -> Writer [String] ()

46 fixityToPs (FixityDeclaration (Fixity assoc prec) ident) =

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

48+ fixityToPs (PositionedDeclaration _ d) = fixityToPs d

48 fixityToPs _ = return ()

49 fixityToPs _ = return ()

49

50

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

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

src/Language/PureScript/CodeGen/JS.hs+3

@@ -82,6 +82,7 @@ declToJs _ mp (DataDeclaration _ _ ctors) _ =

82 (JSBlock [JSReturn (go pn (index + 1) tys' (JSVar ("value" ++ show index) : values))])

83declToJs opts mp (DataBindingGroupDeclaration ds) e = Just $ concat $ mapMaybe (flip (declToJs opts mp) e) ds

84declToJs _ _ (ExternDeclaration _ _ (Just js) _) _ = Just [js]

85+declToJs opts mp (PositionedDeclaration _ d) e = declToJs opts mp d e

85declToJs _ _ _ _ = Nothing

86declToJs _ _ _ _ = Nothing

86

87

87-- |

88-- |

@@ -307,6 +308,8 @@ binderToJs m e varName done (ConsBinder headBinder tailBinder) = do

307binderToJs m e varName done (NamedBinder ident binder) = do

308binderToJs m e varName done (NamedBinder ident binder) = do

308 js <- binderToJs m e varName done binder

309 js <- binderToJs m e varName done binder

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

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

311+binderToJs m e varName done (PositionedBinder _ binder) =

312+ binderToJs m e varName done binder

310

313

311-- |

314-- |

312-- Checks whether a data constructor is the only constructor for that type, used to simplify the

315-- Checks whether a data constructor is the only constructor for that type, used to simplify the

src/Language/PureScript/DeadCodeElimination.hs+5

@@ -50,11 +50,13 @@ eliminateDeadCode entryPoints ms = map go ms

50 valueExists name (ValueDeclaration name' _ _ _ _) = name == name'

51 valueExists name (ExternDeclaration _ name' _ _) = name == name'

52 valueExists name (BindingGroupDeclaration decls) = any (\(name', _, _) -> name == name') decls

53+ valueExists name (PositionedDeclaration _ d) = valueExists name d

53 valueExists _ _ = False

54 valueExists _ _ = False

54

55

55 typeExists :: ProperName -> Declaration -> Bool

56 typeExists :: ProperName -> Declaration -> Bool

56 typeExists name (DataDeclaration name' _ _) = name == name'

57 typeExists name (DataDeclaration name' _ _) = name == name'

57 typeExists name (DataBindingGroupDeclaration decls) = any (typeExists name) decls

58 typeExists name (DataBindingGroupDeclaration decls) = any (typeExists name) decls

59+ typeExists name (PositionedDeclaration _ d) = typeExists name d

58 typeExists _ _ = False

60 typeExists _ _ = False

59

61

60type Key = (ModuleName, Either Ident ProperName)

62type Key = (ModuleName, Either Ident ProperName)

@@ -68,6 +70,7 @@ declarationsByModule (Module moduleName ds _) = concatMap go ds

68 go (ExternDeclaration _ name _ _) = [((moduleName, Left name), [])]

70 go (ExternDeclaration _ name _ _) = [((moduleName, Left name), [])]

69 go d@(BindingGroupDeclaration names') = map (\(name, _, _) -> ((moduleName, Left name), dependencies moduleName d)) names'

71 go d@(BindingGroupDeclaration names') = map (\(name, _, _) -> ((moduleName, Left name), dependencies moduleName d)) names'

70 go (DataBindingGroupDeclaration ds') = concatMap go ds'

72 go (DataBindingGroupDeclaration ds') = concatMap go ds'

73+ go (PositionedDeclaration _ d) = go d

71 go _ = []

74 go _ = []

72

75

73dependencies :: (Data d) => ModuleName -> d -> [Key]

76dependencies :: (Data d) => ModuleName -> d -> [Key]

@@ -94,4 +97,6 @@ isUsed moduleName graph vertexFor entryPointVertices (BindingGroupDeclaration ds

94 in any (\v -> path graph v v') entryPointVertices) ds

97 in any (\v -> path graph v v') entryPointVertices) ds

95isUsed moduleName graph vertexFor entryPointVertices (DataBindingGroupDeclaration ds) =

98isUsed moduleName graph vertexFor entryPointVertices (DataBindingGroupDeclaration ds) =

96 any (isUsed moduleName graph vertexFor entryPointVertices) ds

99 any (isUsed moduleName graph vertexFor entryPointVertices) ds

100+isUsed moduleName graph vertexFor entryPointVertices (PositionedDeclaration _ d) =

101+ isUsed moduleName graph vertexFor entryPointVertices d

97isUsed _ _ _ _ _ = True

102isUsed _ _ _ _ _ = True

src/Language/PureScript/Declarations.hs+45−4

@@ -41,6 +41,24 @@ instance Show Associativity where

41 show Infixr = "infixr"

42 show Infix = "infix"

43

44+-- |

45+-- Source position information

46+--

47+data SourcePos = SourcePos

48+ {

49+ -- |

50+ -- Line number

51+ --

52+ sourcePosLine :: Int

53+ -- |

54+ -- Column number

55+ --

56+ , sourcePosColumn :: Int

57+ } deriving (D.Data, D.Typeable)

58+

59+instance Show SourcePos where

60+ show sp = "line " ++ show (sourcePosLine sp) ++ ", column " ++ show (sourcePosColumn sp)

61+

44-- |

62-- |

45-- Fixity data for infix operators

63-- Fixity data for infix operators

46--

64--

@@ -132,6 +150,10 @@ data Declaration

132 -- declarations)

150 -- declarations)

133 --

151 --

134 | TypeInstanceDeclaration Ident [(Qualified ProperName, [Type])] (Qualified ProperName) [Type] [Declaration]

152 | TypeInstanceDeclaration Ident [(Qualified ProperName, [Type])] (Qualified ProperName) [Type] [Declaration]

153+ -- |

154+ -- A declaration with source position information

155+ --

156+ | PositionedDeclaration SourcePos Declaration

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

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

136

158

137-- |

159-- |

@@ -139,6 +161,7 @@ data Declaration

139--

161--

140isValueDecl :: Declaration -> Bool

162isValueDecl :: Declaration -> Bool

141isValueDecl ValueDeclaration{} = True

163isValueDecl ValueDeclaration{} = True

164+isValueDecl (PositionedDeclaration _ d) = isValueDecl d

142isValueDecl _ = False

165isValueDecl _ = False

143

166

144-- |

167-- |

@@ -147,6 +170,7 @@ isValueDecl _ = False

147isDataDecl :: Declaration -> Bool

170isDataDecl :: Declaration -> Bool

148isDataDecl DataDeclaration{} = True

171isDataDecl DataDeclaration{} = True

149isDataDecl TypeSynonymDeclaration{} = True

172isDataDecl TypeSynonymDeclaration{} = True

173+isDataDecl (PositionedDeclaration _ d) = isDataDecl d

150isDataDecl _ = False

174isDataDecl _ = False

151

175

152-- |

176-- |

@@ -154,6 +178,7 @@ isDataDecl _ = False

154--

178--

155isImportDecl :: Declaration -> Bool

179isImportDecl :: Declaration -> Bool

156isImportDecl ImportDeclaration{} = True

180isImportDecl ImportDeclaration{} = True

181+isImportDecl (PositionedDeclaration _ d) = isImportDecl d

157isImportDecl _ = False

182isImportDecl _ = False

158

183

159-- |

184-- |

@@ -161,6 +186,7 @@ isImportDecl _ = False

161--

186--

162isExternDataDecl :: Declaration -> Bool

187isExternDataDecl :: Declaration -> Bool

163isExternDataDecl ExternDataDeclaration{} = True

188isExternDataDecl ExternDataDeclaration{} = True

189+isExternDataDecl (PositionedDeclaration _ d) = isExternDataDecl d

164isExternDataDecl _ = False

190isExternDataDecl _ = False

165

191

166-- |

192-- |

@@ -168,6 +194,7 @@ isExternDataDecl _ = False

168--

194--

169isExternInstanceDecl :: Declaration -> Bool

195isExternInstanceDecl :: Declaration -> Bool

170isExternInstanceDecl ExternInstanceDeclaration{} = True

196isExternInstanceDecl ExternInstanceDeclaration{} = True

197+isExternInstanceDecl (PositionedDeclaration _ d) = isExternInstanceDecl d

171isExternInstanceDecl _ = False

198isExternInstanceDecl _ = False

172

199

173-- |

200-- |

@@ -175,6 +202,7 @@ isExternInstanceDecl _ = False

175--

202--

176isFixityDecl :: Declaration -> Bool

203isFixityDecl :: Declaration -> Bool

177isFixityDecl FixityDeclaration{} = True

204isFixityDecl FixityDeclaration{} = True

205+isFixityDecl (PositionedDeclaration _ d) = isFixityDecl d

178isFixityDecl _ = False

206isFixityDecl _ = False

179

207

180-- |

208-- |

@@ -182,6 +210,7 @@ isFixityDecl _ = False

182--

210--

183isExternDecl :: Declaration -> Bool

211isExternDecl :: Declaration -> Bool

184isExternDecl ExternDeclaration{} = True

212isExternDecl ExternDeclaration{} = True

213+isExternDecl (PositionedDeclaration _ d) = isExternDecl d

185isExternDecl _ = False

214isExternDecl _ = False

186

215

187-- |

216-- |

@@ -190,6 +219,7 @@ isExternDecl _ = False

190isTypeClassDeclaration :: Declaration -> Bool

219isTypeClassDeclaration :: Declaration -> Bool

191isTypeClassDeclaration TypeClassDeclaration{} = True

220isTypeClassDeclaration TypeClassDeclaration{} = True

192isTypeClassDeclaration TypeInstanceDeclaration{} = True

221isTypeClassDeclaration TypeInstanceDeclaration{} = True

222+isTypeClassDeclaration (PositionedDeclaration _ d) = isTypeClassDeclaration d

193isTypeClassDeclaration _ = False

223isTypeClassDeclaration _ = False

194

224

195-- |

225-- |

@@ -286,7 +316,11 @@ data Value

286 -- can be evaluated at runtime. The constructor arguments represent (in order): the type class name and

316 -- can be evaluated at runtime. The constructor arguments represent (in order): the type class name and

287 -- instance type, and the type class dictionaries in scope.

317 -- instance type, and the type class dictionaries in scope.

288 --

318 --

289− | TypeClassDictionary (Qualified ProperName, [Type]) [TypeClassDictionaryInScope] deriving (Show, D.Data, D.Typeable)

319+ | TypeClassDictionary (Qualified ProperName, [Type]) [TypeClassDictionaryInScope]

320+ -- |

321+ -- A value with source position information

322+ --

323+ | PositionedValue SourcePos Value deriving (Show, D.Data, D.Typeable)

290

324

291-- |

325-- |

292-- An alternative in a case statement

326-- An alternative in a case statement

@@ -328,7 +362,11 @@ data DoNotationElement

328 -- |

362 -- |

329 -- A let statement, i.e. a pure value with a binder

363 -- A let statement, i.e. a pure value with a binder

330 --

364 --

331− | DoNotationLet Binder Value deriving (Show, D.Data, D.Typeable)

365+ | DoNotationLet Binder Value

366+ -- |

367+ -- A do notation element with source position information

368+ --

369+ | PositionedDoNotationElement SourcePos DoNotationElement deriving (Show, D.Data, D.Typeable)

332

370

333-- |

371-- |

334-- Data type for binders

372-- Data type for binders

@@ -373,8 +411,11 @@ data Binder

373 -- |

411 -- |

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

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

375 --

413 --

376− | NamedBinder Ident Binder deriving (Show, D.Data, D.Typeable)

414+ | NamedBinder Ident Binder

377−

415+ -- |

416+ -- A binder with source position information

417+ --

418+ | PositionedBinder SourcePos Binder deriving (Show, D.Data, D.Typeable)

378

419

379-- |

420-- |

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

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

src/Language/PureScript/ModuleDependencies.hs+1

@@ -56,6 +56,7 @@ usedModules = nub . everything (++) (mkQ [] qualifiedIdents `extQ` qualifiedProp

56 qualifiedProperNames _ = []

57 imports :: Declaration -> [ModuleName]

58 imports (ImportDeclaration mn _ _) = [mn]

59+ imports (PositionedDeclaration _ d) = imports d

59 imports _ = []

60 imports _ = []

60

61

61getModuleName :: Module -> ModuleName

62getModuleName :: Module -> ModuleName

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

@@ -369,3 +369,4 @@ same = checkIndentation (==) P.<?> "no indentation"

369--

370runIndentParser :: FilePath -> P.Parsec String ParseState a -> String -> Either P.ParseError a

371runIndentParser filePath p = P.runParser p (ParseState 0) filePath

372+

src/Language/PureScript/Parser/Declarations.hs+13−4

@@ -38,6 +38,14 @@ import qualified Language.PureScript.Parser.Common as C

38import qualified Text.Parsec as P

39import qualified Text.Parsec.Expr as P

40

41+-- |

42+-- Read source position information

43+--

44+sourcePos :: P.Parsec s u SourcePos

45+sourcePos = toSourcePos <$> P.getPosition

46+ where

47+ toSourcePos p = SourcePos (P.sourceLine p) (P.sourceColumn p)

48+

41parseDataDeclaration :: P.Parsec String ParseState Declaration

49parseDataDeclaration :: P.Parsec String ParseState Declaration

42parseDataDeclaration = do

50parseDataDeclaration = do

43 reserved "data"

51 reserved "data"

@@ -162,7 +170,7 @@ parseTypeInstanceDeclaration = do

162-- Parse a single declaration

170-- Parse a single declaration

163--

171--

164parseDeclaration :: P.Parsec String ParseState Declaration

172parseDeclaration :: P.Parsec String ParseState Declaration

165−parseDeclaration = P.choice

173+parseDeclaration = PositionedDeclaration <$> sourcePos <*> P.choice

166 [ parseDataDeclaration

174 [ parseDataDeclaration

167 , parseTypeDeclaration

175 , parseTypeDeclaration

168 , parseTypeSynonymDeclaration

176 , parseTypeSynonymDeclaration

@@ -175,7 +183,7 @@ parseDeclaration = P.choice

175 ] P.<?> "declaration"

183 ] P.<?> "declaration"

176

184

177parseLocalDeclaration :: P.Parsec String ParseState Declaration

185parseLocalDeclaration :: P.Parsec String ParseState Declaration

178−parseLocalDeclaration = P.choice

186+parseLocalDeclaration = PositionedDeclaration <$> sourcePos <*> P.choice

179 [ parseTypeDeclaration

187 [ parseTypeDeclaration

180 , parseValueDeclaration

188 , parseValueDeclaration

181 ] P.<?> "local declaration"

189 ] P.<?> "local declaration"

@@ -313,7 +321,7 @@ parseDoNotationElement = P.choice

313-- Parse a value

321-- Parse a value

314--

322--

315parseValue :: P.Parsec String ParseState Value

323parseValue :: P.Parsec String ParseState Value

316−parseValue =

324+parseValue = PositionedValue <$> sourcePos <*>

317 (P.buildExpressionParser operators

325 (P.buildExpressionParser operators

318 . C.buildPostfixParser postfixTable2

326 . C.buildPostfixParser postfixTable2

319 $ indexersAndAccessors) P.<?> "expression"

327 $ indexersAndAccessors) P.<?> "expression"

@@ -373,7 +381,8 @@ parseIdentifierAndBinder = do

373-- Parse a binder

381-- Parse a binder

374--

382--

375parseBinder :: P.Parsec String ParseState Binder

383parseBinder :: P.Parsec String ParseState Binder

384+parseBinder = PositionedBinder <$> sourcePos <*>

376−parseBinder = P.buildExpressionParser operators parseBinderAtom P.<?> "expression"

385+ P.buildExpressionParser operators parseBinderAtom P.<?> "expression"

377 where

386 where

378 operators = [ [ P.Infix ( C.lexeme (P.try $ C.indented *> C.reservedOp ":") >> return ConsBinder) P.AssocRight ] ]

387 operators = [ [ P.Infix ( C.lexeme (P.try $ C.indented *> C.reservedOp ":") >> return ConsBinder) P.AssocRight ] ]

379 parseBinderAtom :: P.Parsec String ParseState Binder

388 parseBinderAtom :: P.Parsec String ParseState Binder

src/Language/PureScript/Pretty/Values.hs+3

@@ -44,6 +44,7 @@ literals = mkPattern match

44 match (Var ident) = Just $ show ident

45 match (Do els) = Just $ " do { " ++ intercalate "; " (map prettyPrintDoNotationElement els) ++ " }"

46 match (TypeClassDictionary _ _) = error "Type class dictionary was not replaced"

47+ match (PositionedValue _ val) = Just $ prettyPrintValue val

47 match _ = Nothing

48 match _ = Nothing

48

49

49prettyPrintCaseAlternative :: CaseAlternative -> String

50prettyPrintCaseAlternative :: CaseAlternative -> String

@@ -91,6 +92,7 @@ prettyPrintDoNotationElement :: DoNotationElement -> String

91prettyPrintDoNotationElement (DoNotationValue val) = prettyPrintValue val

92prettyPrintDoNotationElement (DoNotationValue val) = prettyPrintValue val

92prettyPrintDoNotationElement (DoNotationBind binder val) = prettyPrintBinder binder ++ " <- " ++ prettyPrintValue val

93prettyPrintDoNotationElement (DoNotationBind binder val) = prettyPrintBinder binder ++ " <- " ++ prettyPrintValue val

93prettyPrintDoNotationElement (DoNotationLet binder val) = "let " ++ prettyPrintBinder binder ++ " = " ++ prettyPrintValue val

94prettyPrintDoNotationElement (DoNotationLet binder val) = "let " ++ prettyPrintBinder binder ++ " = " ++ prettyPrintValue val

95+prettyPrintDoNotationElement (PositionedDoNotationElement _ el) = prettyPrintDoNotationElement el

94

96

95-- |

97-- |

96-- Generate a pretty-printed string representing a Value

98-- Generate a pretty-printed string representing a Value

@@ -124,6 +126,7 @@ prettyPrintBinderAtom = mkPattern match

124 match (ObjectBinder bs) = Just $ "{ " ++ intercalate ", " (map (uncurry prettyPrintObjectPropertyBinder) bs) ++ " }"

126 match (ObjectBinder bs) = Just $ "{ " ++ intercalate ", " (map (uncurry prettyPrintObjectPropertyBinder) bs) ++ " }"

125 match (ArrayBinder bs) = Just $ "[ " ++ intercalate ", " (map prettyPrintBinder bs) ++ " ]"

127 match (ArrayBinder bs) = Just $ "[ " ++ intercalate ", " (map prettyPrintBinder bs) ++ " ]"

126 match (NamedBinder ident binder) = Just $ show ident ++ "@" ++ prettyPrintBinder binder

128 match (NamedBinder ident binder) = Just $ show ident ++ "@" ++ prettyPrintBinder binder

129+ match (PositionedBinder _ binder) = Just $ prettyPrintBinder binder

127 match _ = Nothing

130 match _ = Nothing

128

131

129-- |

132-- |

src/Language/PureScript/Sugar/BindingGroups.hs+14−7

@@ -26,7 +26,7 @@ import Data.Graph

26import Data.Generics

27import Data.Generics.Extras

28import Data.List (nub, intersect)

29−import Data.Maybe (mapMaybe)

29+import Data.Maybe (isJust, mapMaybe)

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

31

32import Language.PureScript.Declarations

@@ -82,6 +82,7 @@ collapseBindingGroups = everywhere (mkT collapseBindingGroupsForValue) . concatM

82 where

83 go (DataBindingGroupDeclaration ds) = ds

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

85+ go (PositionedDeclaration pos d) = map (PositionedDeclaration pos) $ go d

85 go other = [other]

86 go other = [other]

86

87

87collapseBindingGroupsForValue :: Value -> Value

88collapseBindingGroupsForValue :: Value -> Value

@@ -109,11 +110,13 @@ usedProperNames moduleName = nub . everything (++) (mkQ [] usedNames)

109

110

110getIdent :: Declaration -> Ident

111getIdent :: Declaration -> Ident

111getIdent (ValueDeclaration ident _ _ _ _) = ident

112getIdent (ValueDeclaration ident _ _ _ _) = ident

113+getIdent (PositionedDeclaration _ d) = getIdent d

112getIdent _ = error "Expected ValueDeclaration"

114getIdent _ = error "Expected ValueDeclaration"

113

115

114getProperName :: Declaration -> ProperName

116getProperName :: Declaration -> ProperName

115getProperName (DataDeclaration pn _ _) = pn

117getProperName (DataDeclaration pn _ _) = pn

116getProperName (TypeSynonymDeclaration pn _ _) = pn

118getProperName (TypeSynonymDeclaration pn _ _) = pn

119+getProperName (PositionedDeclaration _ d) = getProperName d

117getProperName _ = error "Expected DataDeclaration"

120getProperName _ = error "Expected DataDeclaration"

118

121

119toBindingGroup :: SCC Declaration -> Declaration

122toBindingGroup :: SCC Declaration -> Declaration

@@ -123,16 +126,20 @@ toBindingGroup (CyclicSCC ds') = BindingGroupDeclaration $ map fromValueDecl ds'

123

126

124toDataBindingGroup :: SCC Declaration -> Either String Declaration

127toDataBindingGroup :: SCC Declaration -> Either String Declaration

125toDataBindingGroup (AcyclicSCC d) = return d

128toDataBindingGroup (AcyclicSCC d) = return d

129+toDataBindingGroup (CyclicSCC [d]) = case isTypeSynonym d of

126−toDataBindingGroup (CyclicSCC [TypeSynonymDeclaration pn _ _]) = Left $ "Cycle in type synonym " ++ show pn

130+ Just pn -> Left $ "Cycle in type synonym " ++ show pn

127−toDataBindingGroup (CyclicSCC [d]) = return d

131+ _ -> return d

128toDataBindingGroup (CyclicSCC ds')

132toDataBindingGroup (CyclicSCC ds')

129− | all isTypeSynonym ds' = Left "Cycle in type synonyms"

133+ | all (isJust . isTypeSynonym) ds' = Left "Cycle in type synonyms"

130 | otherwise = return $ DataBindingGroupDeclaration ds'

134 | otherwise = return $ DataBindingGroupDeclaration ds'

131− where

135+

136+isTypeSynonym :: Declaration -> Maybe ProperName

132− isTypeSynonym TypeSynonymDeclaration{} = True

137+isTypeSynonym (TypeSynonymDeclaration pn _ _) = Just pn

138+isTypeSynonym (PositionedDeclaration _ d) = isTypeSynonym d

133− isTypeSynonym _ = False

139+isTypeSynonym _ = Nothing

134

140

135fromValueDecl :: Declaration -> (Ident, NameKind, Value)

141fromValueDecl :: Declaration -> (Ident, NameKind, Value)

136fromValueDecl (ValueDeclaration ident nameKind [] Nothing val) = (ident, nameKind, val)

142fromValueDecl (ValueDeclaration ident nameKind [] Nothing val) = (ident, nameKind, val)

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

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

144+fromValueDecl (PositionedDeclaration _ d) = fromValueDecl d

138fromValueDecl _ = error "Expected ValueDeclaration"

145fromValueDecl _ = error "Expected ValueDeclaration"

src/Language/PureScript/Sugar/CaseDeclarations.hs+9

@@ -62,11 +62,16 @@ desugarCases = desugarRest <=< fmap join . mapM toDecls . groupBy inSameGroup

62 where

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

64 go other = return other

65+ desugarRest (PositionedDeclaration pos d : ds) = do

66+ (d' : ds') <- desugarRest (d : ds)

67+ return (PositionedDeclaration pos d' : ds')

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

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

66 desugarRest [] = pure []

69 desugarRest [] = pure []

67

70

68inSameGroup :: Declaration -> Declaration -> Bool

71inSameGroup :: Declaration -> Declaration -> Bool

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

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

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

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

70inSameGroup _ _ = False

75inSameGroup _ _ = False

71

76

72toDecls :: [Declaration] -> Either String [Declaration]

77toDecls :: [Declaration] -> Either String [Declaration]

@@ -79,6 +84,9 @@ toDecls ds@(ValueDeclaration ident _ bs _ _ : _) = do

79 unless (all ((== length bs) . length . fst) tuples) $

84 unless (all ((== length bs) . length . fst) tuples) $

80 throwError $ "Argument list lengths differ in declaration " ++ show ident

85 throwError $ "Argument list lengths differ in declaration " ++ show ident

81 return [makeCaseDeclaration ident tuples]

86 return [makeCaseDeclaration ident tuples]

87+toDecls (PositionedDeclaration pos d : ds) = do

88+ (d' : ds') <- toDecls (d : ds)

89+ return (PositionedDeclaration pos d' : ds')

82toDecls ds = return ds

90toDecls ds = return ds

83

91

84isVarBinder :: Binder -> Bool

92isVarBinder :: Binder -> Bool

@@ -87,6 +95,7 @@ isVarBinder _ = False

87

95

88toTuple :: Declaration -> ([Binder], (Maybe Guard, Value))

96toTuple :: Declaration -> ([Binder], (Maybe Guard, Value))

89toTuple (ValueDeclaration _ _ bs g val) = (bs, (g, val))

97toTuple (ValueDeclaration _ _ bs g val) = (bs, (g, val))

98+toTuple (PositionedDeclaration _ d) = toTuple d

90toTuple _ = error "Not a value declaration"

99toTuple _ = error "Not a value declaration"

91

100

92makeCaseDeclaration :: Ident -> [([Binder], (Maybe Guard, Value))] -> Declaration

101makeCaseDeclaration :: Ident -> [([Binder], (Maybe Guard, Value))] -> Declaration

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

@@ -27,6 +27,8 @@ import Language.PureScript.Declarations

27

28import qualified Language.PureScript.Constants as C

29

30+import Control.Applicative

31+

30-- |

32-- |

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

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

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

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

@@ -60,3 +62,4 @@ desugarDo = everywhereM (mkM replace)

60 go (DoNotationLet binder val : rest) = do

62 go (DoNotationLet binder val : rest) = do

61 rest' <- go rest

63 rest' <- go rest

62 return $ Case [val] [CaseAlternative [binder] Nothing rest']

64 return $ Case [val] [CaseAlternative [binder] Nothing rest']

65+ go (PositionedDoNotationElement pos el : rest) = PositionedValue pos <$> go (el : rest)

src/Language/PureScript/Sugar/Names.hs+7−4

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

223 go (BindingGroupDeclaration decls') = do

224 BindingGroupDeclaration <$> mapM go' decls'

225 where go' = \(name, nk, value) -> rethrowFor "declaration" name $ (,,) <$> pure name <*> pure nk <*> updateAll value

226+ go (PositionedDeclaration pos d) = PositionedDeclaration pos <$> go d

226 go d = updateAll d

227 go d = updateAll d

227

228

228 rethrowFor :: (Show a) => String -> a -> Either String b -> Either String b

229 rethrowFor :: (Show a) => String -> a -> Either String b -> Either String b

@@ -230,20 +231,20 @@ renameInModule imports exports (Module mn decls exps) =

230

231

231 updateAll :: Data d => d -> Either String d

232 updateAll :: Data d => d -> Either String d

232 updateAll = everywhereM (mkM updateType `extM` updateValue `extM` updateBinder)

233 updateAll = everywhereM (mkM updateType `extM` updateValue `extM` updateBinder)

233−

234+

234 updateValue (Constructor name) = Constructor <$> updateDataConstructorName name

235 updateValue (Constructor name) = Constructor <$> updateDataConstructorName name

235 updateValue v = return v

236 updateValue v = return v

236−

237+

237 updateBinder (ConstructorBinder name b) = ConstructorBinder <$> updateDataConstructorName name <*> pure b

238 updateBinder (ConstructorBinder name b) = ConstructorBinder <$> updateDataConstructorName name <*> pure b

238 updateBinder v = return v

239 updateBinder v = return v

239−

240+

240 updateType (TypeConstructor name) = TypeConstructor <$> updateTypeName name

241 updateType (TypeConstructor name) = TypeConstructor <$> updateTypeName name

241 updateType (SaturatedTypeSynonym name tys) = SaturatedTypeSynonym <$> updateTypeName name <*> mapM updateType tys

242 updateType (SaturatedTypeSynonym name tys) = SaturatedTypeSynonym <$> updateTypeName name <*> mapM updateType tys

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

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

243 updateType t = return t

244 updateType t = return t

244 updateType' :: Data d => d -> Either String d

245 updateType' :: Data d => d -> Either String d

245 updateType' = everywhereM (mkM updateType)

246 updateType' = everywhereM (mkM updateType)

246−

247+

247 updateConstraints = mapM (\(name, ts) -> (,) <$> updateClassName name <*> pure ts)

248 updateConstraints = mapM (\(name, ts) -> (,) <$> updateClassName name <*> pure ts)

248

249

249 updateTypeName = update "type" importedTypes (\mes -> isJust . (`lookup` (exportedTypes mes)))

250 updateTypeName = update "type" importedTypes (\mes -> isJust . (`lookup` (exportedTypes mes)))

@@ -299,6 +300,7 @@ findExports = foldM addModule $ M.singleton (ModuleName [ProperName "Prim"]) pri

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

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

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

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

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

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

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

302 addDecl _ env _ = return env

304 addDecl _ env _ = return env

303

305

304-- |

306-- |

@@ -365,6 +367,7 @@ findImports :: [Declaration] -> M.Map ModuleName (Maybe ExplicitImports, Maybe M

365findImports = foldl findImports' M.empty

367findImports = foldl findImports' M.empty

366 where

368 where

367 findImports' result (ImportDeclaration mn expl qual) = M.insert mn (expl, qual) result

369 findImports' result (ImportDeclaration mn expl qual) = M.insert mn (expl, qual) result

370+ findImports' result (PositionedDeclaration _ d) = findImports' result d

368 findImports' result _ = result

371 findImports' result _ = result

369

372

370-- |

373-- |

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

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

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

77 where

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

79+ collect (PositionedDeclaration _ d) = collect d

79 collect (FixityDeclaration fixity name) = [(Qualified (Just moduleName) (Op name), fixity)]

80 collect (FixityDeclaration fixity name) = [(Qualified (Just moduleName) (Op name), fixity)]

80 collect _ = []

81 collect _ = []

81

82

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

@@ -99,10 +99,14 @@ desugarDecl mn d@(TypeInstanceDeclaration name deps className ty members) = do

99 entries <- mapM (typeInstanceDictionaryEntryDeclaration name mn deps className ty) desugared

100 dictDecl <- typeInstanceDictionaryDeclaration name mn deps className ty desugared

101 return $ (Just $ TypeInstanceRef name, d : entries ++ [dictDecl])

102+desugarDecl mn (PositionedDeclaration pos d) = do

103+ (dr, ds) <- desugarDecl mn d

104+ return (dr, map (PositionedDeclaration pos) ds)

102desugarDecl _ other = return (Nothing, [other])

105desugarDecl _ other = return (Nothing, [other])

103

106

104memberToNameAndType :: Declaration -> (String, Type)

107memberToNameAndType :: Declaration -> (String, Type)

105memberToNameAndType (TypeDeclaration ident ty) = (identToJs ident, ty)

108memberToNameAndType (TypeDeclaration ident ty) = (identToJs ident, ty)

109+memberToNameAndType (PositionedDeclaration _ d) = memberToNameAndType d

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

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

107

111

108typeClassDictionaryDeclaration :: ProperName -> [String] -> [Declaration] -> Declaration

112typeClassDictionaryDeclaration :: ProperName -> [String] -> [Declaration] -> Declaration

@@ -114,6 +118,8 @@ typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) =

114 ExternDeclaration TypeClassAccessorImport ident

118 ExternDeclaration TypeClassAccessorImport ident

115 (Just (JSFunction (Just $ identToJs ident) ["dict"] (JSBlock [JSReturn (JSAccessor (identToJs ident) (JSVar "dict"))])))

119 (Just (JSFunction (Just $ identToJs ident) ["dict"] (JSBlock [JSReturn (JSAccessor (identToJs ident) (JSVar "dict"))])))

116 (quantify (ConstrainedType [(Qualified (Just mn) name, map TypeVar args)] ty))

120 (quantify (ConstrainedType [(Qualified (Just mn) name, map TypeVar args)] ty))

121+typeClassMemberToDictionaryAccessor mn name args (PositionedDeclaration pos d) =

122+ PositionedDeclaration pos $ typeClassMemberToDictionaryAccessor mn name args d

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

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

118

124

119typeInstanceDictionaryDeclaration :: Ident -> ModuleName -> [(Qualified ProperName, [Type])] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar Declaration

125typeInstanceDictionaryDeclaration :: Ident -> ModuleName -> [(Qualified ProperName, [Type])] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar Declaration

@@ -143,6 +149,9 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls = do

143 return (identToJs ident, TypedValue False

149 return (identToJs ident, TypedValue False

144 (foldl App (Var (Qualified Nothing memberName)) (map (\n -> Var (Qualified Nothing (Ident ('_' : show n)))) [1..length deps]))

150 (foldl App (Var (Qualified Nothing memberName)) (map (\n -> Var (Qualified Nothing (Ident ('_' : show n)))) [1..length deps]))

145 (quantify memberType))

151 (quantify memberType))

152+ memberToNameAndValue tys' (PositionedDeclaration pos d) = do

153+ (ident, val) <- memberToNameAndValue tys' d

154+ return (ident, PositionedValue pos val)

146 memberToNameAndValue _ _ = error "Invalid declaration in type instance definition"

155 memberToNameAndValue _ _ = error "Invalid declaration in type instance definition"

147

156

148typeInstanceDictionaryEntryDeclaration :: Ident -> ModuleName -> [(Qualified ProperName, [Type])] -> Qualified ProperName -> [Type] -> Declaration -> Desugar Declaration

157typeInstanceDictionaryEntryDeclaration :: Ident -> ModuleName -> [(Qualified ProperName, [Type])] -> Qualified ProperName -> [Type] -> Declaration -> Desugar Declaration

@@ -157,6 +166,8 @@ typeInstanceDictionaryEntryDeclaration name mn deps className tys (ValueDeclarat

157 where

166 where

158 lookupTypeClass m = maybe (Left $ "Type class " ++ show className ++ " is undefined. Type class names must be qualified.") Right $ M.lookup (qualify mn className) m

167 lookupTypeClass m = maybe (Left $ "Type class " ++ show className ++ " is undefined. Type class names must be qualified.") Right $ M.lookup (qualify mn className) m

159 lookupIdent members = maybe (Left $ "Type class " ++ show className ++ " does not have method " ++ show ident) Right $ lookup (identToJs ident) members

168 lookupIdent members = maybe (Left $ "Type class " ++ show className ++ " does not have method " ++ show ident) Right $ lookup (identToJs ident) members

169+typeInstanceDictionaryEntryDeclaration name mn deps className tys (PositionedDeclaration pos d) =

170+ PositionedDeclaration pos <$> typeInstanceDictionaryEntryDeclaration name mn deps className tys d

160typeInstanceDictionaryEntryDeclaration _ _ _ _ _ _ = error "Invalid declaration in type instance definition"

171typeInstanceDictionaryEntryDeclaration _ _ _ _ _ _ = error "Invalid declaration in type instance definition"

161

172

162-- |

173-- |

src/Language/PureScript/Sugar/TypeDeclarations.hs+14−2

@@ -27,6 +27,8 @@ import Control.Monad.Error.Class

27import Control.Monad (forM)

28

29import Language.PureScript.Declarations

30+import Language.PureScript.Names

31+import Language.PureScript.Environment

30

32

31-- |

33-- |

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

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

@@ -38,9 +40,19 @@ desugarTypeDeclarationsModule ms = forM ms $ \(Module name ds exps) -> Module na

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

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

39--

41--

40desugarTypeDeclarations :: [Declaration] -> Either String [Declaration]

42desugarTypeDeclarations :: [Declaration] -> Either String [Declaration]

41−desugarTypeDeclarations (TypeDeclaration name ty : ValueDeclaration name' nameKind [] Nothing val : rest) | name == name' =

43+desugarTypeDeclarations (PositionedDeclaration pos d : ds) = do

44+ (d' : ds') <- desugarTypeDeclarations (d : ds)

45+ return (PositionedDeclaration pos d' : ds')

46+desugarTypeDeclarations (TypeDeclaration name ty : d : rest) = do

47+ (_, nameKind, val) <- fromValueDeclaration d

42 desugarTypeDeclarations (ValueDeclaration name nameKind [] Nothing (TypedValue True val ty) : rest)

48 desugarTypeDeclarations (ValueDeclaration name nameKind [] Nothing (TypedValue True val ty) : rest)

49+ where

50+ fromValueDeclaration :: Declaration -> Either String (Ident, NameKind, Value)

51+ fromValueDeclaration (ValueDeclaration name' nameKind [] Nothing val) | name == name' = return (name', nameKind, val)

52+ fromValueDeclaration (PositionedDeclaration pos d') = do

53+ (ident, nameKind, val) <- fromValueDeclaration d'

54+ return (ident, nameKind, PositionedValue pos val)

43−desugarTypeDeclarations (TypeDeclaration name _ : _) = throwError $ "Orphan type declaration for " ++ show name

55+ fromValueDeclaration _ = throwError $ "Orphan type declaration for " ++ show name

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

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

45 (:) <$> (ValueDeclaration name nameKind bs g <$> everywhereM' (mkM go) val) <*> desugarTypeDeclarations rest

57 (:) <$> (ValueDeclaration name nameKind bs g <$> everywhereM' (mkM go) val) <*> desugarTypeDeclarations rest

46 where

58 where

src/Language/PureScript/TypeChecker.hs+2

@@ -194,3 +194,5 @@ typeCheckAll mainModuleName moduleName (d@(ExternInstanceDeclaration dictName de

194 addTypeClassDictionaries [TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) className tys (Just deps) TCDRegular]

195 ds <- typeCheckAll mainModuleName moduleName rest

196 return $ d : ds

197+typeCheckAll mainModuleName moduleName (PositionedDeclaration pos d : rest) =

198+ rethrowWithPosition pos $ typeCheckAll mainModuleName moduleName (d : rest)

src/Language/PureScript/TypeChecker/Monad.hs+53−28

@@ -63,6 +63,10 @@ data UnifyError = UnifyError {

63 -- The value where the error occurred

64 --

65 , unifyErrorValue :: Maybe UnifyErrorSource

66+ -- |

67+ -- Optional source position information

68+ --

69+ , unifyErrorPosition :: Maybe SourcePos

66 } deriving (Show)

70 } deriving (Show)

67

71

68-- |

72-- |

@@ -71,42 +75,57 @@ data UnifyError = UnifyError {

71newtype UnifyErrorStack = UnifyErrorStack { runUnifyErrorStack :: [UnifyError] } deriving (Show, Monoid)

75newtype UnifyErrorStack = UnifyErrorStack { runUnifyErrorStack :: [UnifyError] } deriving (Show, Monoid)

72

76

73instance Error UnifyErrorStack where

77instance Error UnifyErrorStack where

74− strMsg s = UnifyErrorStack [UnifyError s Nothing]

78+ strMsg s = UnifyErrorStack [UnifyError s Nothing Nothing]

75 noMsg = UnifyErrorStack []

79 noMsg = UnifyErrorStack []

76

80

77prettyPrintUnifyErrorStack :: Options -> UnifyErrorStack -> String

81prettyPrintUnifyErrorStack :: Options -> UnifyErrorStack -> String

78−prettyPrintUnifyErrorStack opts (UnifyErrorStack es) | optionsVerboseErrors opts = intercalate "\n" (map showError es)

82+prettyPrintUnifyErrorStack opts (UnifyErrorStack es) =

79−prettyPrintUnifyErrorStack _ (UnifyErrorStack es) =

83+ case mconcat $ map (Last . unifyErrorPosition) es of

80− let

84+ Last (Just sourcePos) -> "Error at " ++ show sourcePos ++ ": \n" ++ prettyPrintUnifyErrorStack'

81− errorsWithValues = filter (isJust . unifyErrorValue) es

85+ _ -> prettyPrintUnifyErrorStack'

82− mostSpecificError = last es

86+ where

83− in case (length errorsWithValues, isJust (unifyErrorValue mostSpecificError)) of

87+ prettyPrintUnifyErrorStack' :: String

84− (0, _) -> showError mostSpecificError

88+ prettyPrintUnifyErrorStack'

85− (1, True) -> showError mostSpecificError

89+ | optionsVerboseErrors opts =

86− (1, False) ->

90+ intercalate "\n" (map showError (filter isErrorNonEmpty es))

87− let errorWithValue = head errorsWithValues

91+ | otherwise =

88− in showError errorWithValue ++ "\n" ++

89− showError mostSpecificError

90− (_, True) ->

91− let errorWithValue = head errorsWithValues

92− in showError errorWithValue ++ "\n" ++

93− showError mostSpecificError

94− (_, False) ->

95 let

92 let

96− leastSpecificErrorWithValue = head errorsWithValues

93+ es' = filter isErrorNonEmpty es

97− mostSpecificErrorWithValue = last errorsWithValues

94+ errorsWithValues = filter (isJust . unifyErrorValue) es'

98− in

95+ mostSpecificError = last es'

96+ in case (length errorsWithValues, isJust (unifyErrorValue mostSpecificError)) of

97+ (0, _) -> showError mostSpecificError

98+ (1, True) -> showError mostSpecificError

99+ (1, False) ->

100+ let errorWithValue = head errorsWithValues

101+ in showError errorWithValue ++ "\n" ++

102+ showError mostSpecificError

103+ (_, True) ->

104+ let errorWithValue = head errorsWithValues

105+ in showError errorWithValue ++ "\n" ++

106+ showError mostSpecificError

107+ (_, False) ->

108+ let

109+ leastSpecificErrorWithValue = head errorsWithValues

110+ mostSpecificErrorWithValue = last errorsWithValues

111+ in

99− showError leastSpecificErrorWithValue ++ "\n" ++

112+ showError leastSpecificErrorWithValue ++ "\n" ++

100− showError mostSpecificErrorWithValue ++ "\n" ++

113+ showError mostSpecificErrorWithValue ++ "\n" ++

101− showError mostSpecificError

114+ showError mostSpecificError

115+

116+isErrorNonEmpty :: UnifyError -> Bool

117+isErrorNonEmpty = not . null . unifyErrorMessage

102

118

103showError :: UnifyError -> String

119showError :: UnifyError -> String

104−showError (UnifyError msg Nothing) = msg

120+showError (UnifyError msg Nothing _) = msg

105−showError (UnifyError msg (Just (ValueError val))) = "Error in value " ++ prettyPrintValue val ++ ": \n" ++ msg

121+showError (UnifyError msg (Just (ValueError val)) _) = "Error in value " ++ prettyPrintValue val ++ ": \n" ++ msg

106−showError (UnifyError msg (Just (TypeError ty))) = "Error in type " ++ prettyPrintType ty ++ ": \n" ++ msg

122+showError (UnifyError msg (Just (TypeError ty)) _) = "Error in type " ++ prettyPrintType ty ++ ": \n" ++ msg

107

123

108mkUnifyErrorStack :: String -> Maybe UnifyErrorSource -> UnifyErrorStack

124mkUnifyErrorStack :: String -> Maybe UnifyErrorSource -> UnifyErrorStack

109−mkUnifyErrorStack msg t = UnifyErrorStack [UnifyError msg t]

125+mkUnifyErrorStack msg t = UnifyErrorStack [UnifyError msg t Nothing]

126+

127+positionError :: SourcePos -> UnifyErrorStack

128+positionError pos = UnifyErrorStack [UnifyError "" Nothing (Just pos)]

110

129

111-- |

130-- |

112-- Temporarily bind a collection of names to values

131-- Temporarily bind a collection of names to values

@@ -254,6 +273,12 @@ guardWith e False = throwError e

254rethrow :: (MonadError e m) => (e -> e) -> m a -> m a

273rethrow :: (MonadError e m) => (e -> e) -> m a -> m a

255rethrow f = flip catchError $ \e -> throwError (f e)

274rethrow f = flip catchError $ \e -> throwError (f e)

256

275

276+-- |

277+-- Rethrow an error with source position information

278+--

279+rethrowWithPosition :: (MonadError UnifyErrorStack m) => SourcePos -> m a -> m a

280+rethrowWithPosition pos = rethrow (positionError pos <>)

281+

257-- |

282-- |

258-- Generate new type class dictionary name

283-- Generate new type class dictionary name

259--

284--

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

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

576 ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty

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

578 return $ TypedValue True val' ty'

579+infer' (PositionedValue pos val) = rethrowWithPosition pos $ infer' val

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

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

580

581

581inferLetBinding :: [Declaration] -> [Declaration] -> Value -> (Value -> UnifyT Type Check Value) -> UnifyT Type Check ([Declaration], Value)

582inferLetBinding :: [Declaration] -> [Declaration] -> Value -> (Value -> UnifyT Type Check Value) -> UnifyT Type Check ([Declaration], Value)

@@ -662,6 +663,8 @@ inferBinder val (ConsBinder headBinder tailBinder) = do

662inferBinder val (NamedBinder name binder) = do

663inferBinder val (NamedBinder name binder) = do

663 m <- inferBinder val binder

664 m <- inferBinder val binder

664 return $ M.insert name val m

665 return $ M.insert name val m

666+inferBinder val (PositionedBinder pos binder) =

667+ rethrowWithPosition pos $ inferBinder val binder

665

668

666-- |

669-- |

667-- Check the types of the return values in a set of binders in a case statement

670-- Check the types of the return values in a set of binders in a case statement

@@ -826,6 +829,8 @@ check' (Let ds val) ty = do

826check' val ty | containsTypeSynonyms ty = do

829check' val ty | containsTypeSynonyms ty = do

827 ty' <- introduceSkolemScope <=< expandAllTypeSynonyms $ ty

830 ty' <- introduceSkolemScope <=< expandAllTypeSynonyms $ ty

828 check val ty'

831 check val ty'

832+check' (PositionedValue pos val) ty =

833+ rethrowWithPosition pos $ check val ty

829check' val ty = throwError $ mkUnifyErrorStack ("Value does not have type " ++ prettyPrintType ty) (Just (ValueError val))

834check' val ty = throwError $ mkUnifyErrorStack ("Value does not have type " ++ prettyPrintType ty) (Just (ValueError val))

830

835

831containsTypeSynonyms :: Type -> Bool

836containsTypeSynonyms :: Type -> Bool