dea47d7 · rowtype-yoga/purescript-native

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

First version of source position information in error messages

commitdea47d72d37795dc9eddf6175e0a832fe5ede312 authorPhil Freeman <paf31@cantab.net> dateThu 27 Mar 2014, 22:04 (13 years ago) parent1a087e7

20 files changed+195−49

compare with golang

unifiedsplit

docgen/Main.hs+3

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

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

8585isExported Nothing _ = True

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

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

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

8889 where

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

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

130131 [] -> ""

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

132133 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

133136renderDeclaration _ _ _ = return ()

134137

135138getName :: P.Declaration -> String

src/Language/PureScript.hs+1

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

248248 where

249249 prelude = ModuleName [ProperName C.prelude]

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

251+ isPreludeImport (PositionedDeclaration _ d) = isPreludeImport d

251252 isPreludeImport _ = False

252253 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

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

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

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

48+ fixityToPs (PositionedDeclaration _ d) = fixityToPs d

4849 fixityToPs _ = return ()

4950

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

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

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

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

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

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

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

8586declToJs _ _ _ _ = Nothing

8687

8788-- |

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

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

308309 js <- binderToJs m e varName done binder

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

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

312+ binderToJs m e varName done binder

310313

311314-- |

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

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

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

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

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

5354 valueExists _ _ = False

5455

5556 typeExists :: ProperName -> Declaration -> Bool

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

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

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

5860 typeExists _ _ = False

5961

6062type Key = (ModuleName, Either Ident ProperName)

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

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

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

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

73+ go (PositionedDeclaration _ d) = go d

7174 go _ = []

7275

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

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

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

9598isUsed moduleName graph vertexFor entryPointVertices (DataBindingGroupDeclaration ds) =

9699 any (isUsed moduleName graph vertexFor entryPointVertices) ds

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

101+ isUsed moduleName graph vertexFor entryPointVertices d

97102isUsed _ _ _ _ _ = True

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

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

4141 show Infixr = "infixr"

4242 show Infix = "infix"

4343

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+

4462-- |

4563-- Fixity data for infix operators

4664--

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

132150 -- declarations)

133151 --

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

153+ -- |

154+ -- A declaration with source position information

155+ --

156+ | PositionedDeclaration SourcePos Declaration

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

136158

137159-- |

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

139161--

140162isValueDecl :: Declaration -> Bool

141163isValueDecl ValueDeclaration{} = True

164+isValueDecl (PositionedDeclaration _ d) = isValueDecl d

142165isValueDecl _ = False

143166

144167-- |

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

147170isDataDecl :: Declaration -> Bool

148171isDataDecl DataDeclaration{} = True

149172isDataDecl TypeSynonymDeclaration{} = True

173+isDataDecl (PositionedDeclaration _ d) = isDataDecl d

150174isDataDecl _ = False

151175

152176-- |

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

154178--

155179isImportDecl :: Declaration -> Bool

156180isImportDecl ImportDeclaration{} = True

181+isImportDecl (PositionedDeclaration _ d) = isImportDecl d

157182isImportDecl _ = False

158183

159184-- |

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

161186--

162187isExternDataDecl :: Declaration -> Bool

163188isExternDataDecl ExternDataDeclaration{} = True

189+isExternDataDecl (PositionedDeclaration _ d) = isExternDataDecl d

164190isExternDataDecl _ = False

165191

166192-- |

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

168194--

169195isExternInstanceDecl :: Declaration -> Bool

170196isExternInstanceDecl ExternInstanceDeclaration{} = True

197+isExternInstanceDecl (PositionedDeclaration _ d) = isExternInstanceDecl d

171198isExternInstanceDecl _ = False

172199

173200-- |

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

175202--

176203isFixityDecl :: Declaration -> Bool

177204isFixityDecl FixityDeclaration{} = True

205+isFixityDecl (PositionedDeclaration _ d) = isFixityDecl d

178206isFixityDecl _ = False

179207

180208-- |

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

182210--

183211isExternDecl :: Declaration -> Bool

184212isExternDecl ExternDeclaration{} = True

213+isExternDecl (PositionedDeclaration _ d) = isExternDecl d

185214isExternDecl _ = False

186215

187216-- |

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

190219isTypeClassDeclaration :: Declaration -> Bool

191220isTypeClassDeclaration TypeClassDeclaration{} = True

192221isTypeClassDeclaration TypeInstanceDeclaration{} = True

222+isTypeClassDeclaration (PositionedDeclaration _ d) = isTypeClassDeclaration d

193223isTypeClassDeclaration _ = False

194224

195225-- |

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

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

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

288318 --

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)

290324

291325-- |

292326-- An alternative in a case statement

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

328362 -- |

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

330364 --

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)

332370

333371-- |

334372-- Data type for binders

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

373411 -- |

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

375413 --

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

377−

414+ | NamedBinder Ident Binder

415+ -- |

416+ -- A binder with source position information

417+ --

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

378419

379420-- |

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

5656 qualifiedProperNames _ = []

5757 imports :: Declaration -> [ModuleName]

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

59+ imports (PositionedDeclaration _ d) = imports d

5960 imports _ = []

6061

6162getModuleName :: Module -> ModuleName

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

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

369369--

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

371371runIndentParser 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

3838import qualified Text.Parsec as P

3939import qualified Text.Parsec.Expr as P

4040

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+

4149parseDataDeclaration :: P.Parsec String ParseState Declaration

4250parseDataDeclaration = do

4351 reserved "data"

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

162170-- Parse a single declaration

163171--

164172parseDeclaration :: P.Parsec String ParseState Declaration

165−parseDeclaration = P.choice

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

166174 [ parseDataDeclaration

167175 , parseTypeDeclaration

168176 , parseTypeSynonymDeclaration

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

175183 ] P.<?> "declaration"

176184

177185parseLocalDeclaration :: P.Parsec String ParseState Declaration

178−parseLocalDeclaration = P.choice

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

179187 [ parseTypeDeclaration

180188 , parseValueDeclaration

181189 ] P.<?> "local declaration"

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

313321-- Parse a value

314322--

315323parseValue :: P.Parsec String ParseState Value

316−parseValue =

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

317325 (P.buildExpressionParser operators

318326 . C.buildPostfixParser postfixTable2

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

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

373381-- Parse a binder

374382--

375383parseBinder :: P.Parsec String ParseState Binder

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

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

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

377386 where

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

379388 parseBinderAtom :: P.Parsec String ParseState Binder

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

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

4444 match (Var ident) = Just $ show ident

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

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

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

4748 match _ = Nothing

4849

4950prettyPrintCaseAlternative :: CaseAlternative -> String

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

9192prettyPrintDoNotationElement (DoNotationValue val) = prettyPrintValue val

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

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

95+prettyPrintDoNotationElement (PositionedDoNotationElement _ el) = prettyPrintDoNotationElement el

9496

9597-- |

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

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

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

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

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

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

127130 match _ = Nothing

128131

129132-- |

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

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

2626import Data.Generics

2727import Data.Generics.Extras

2828import Data.List (nub, intersect)

29−import Data.Maybe (mapMaybe)

29+import Data.Maybe (isJust, mapMaybe)

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

3131

3232import Language.PureScript.Declarations

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

8282 where

8383 go (DataBindingGroupDeclaration ds) = ds

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

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

8586 go other = [other]

8687

8788collapseBindingGroupsForValue :: Value -> Value

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

109110

110111getIdent :: Declaration -> Ident

111112getIdent (ValueDeclaration ident _ _ _ _) = ident

113+getIdent (PositionedDeclaration _ d) = getIdent d

112114getIdent _ = error "Expected ValueDeclaration"

113115

114116getProperName :: Declaration -> ProperName

115117getProperName (DataDeclaration pn _ _) = pn

116118getProperName (TypeSynonymDeclaration pn _ _) = pn

119+getProperName (PositionedDeclaration _ d) = getProperName d

117120getProperName _ = error "Expected DataDeclaration"

118121

119122toBindingGroup :: SCC Declaration -> Declaration

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

123126

124127toDataBindingGroup :: SCC Declaration -> Either String Declaration

125128toDataBindingGroup (AcyclicSCC d) = return d

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

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

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

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

131+ _ -> return d

128132toDataBindingGroup (CyclicSCC ds')

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

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

130134 | otherwise = return $ DataBindingGroupDeclaration ds'

131− where

132− isTypeSynonym TypeSynonymDeclaration{} = True

133− isTypeSynonym _ = False

135+

136+isTypeSynonym :: Declaration -> Maybe ProperName

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

138+isTypeSynonym (PositionedDeclaration _ d) = isTypeSynonym d

139+isTypeSynonym _ = Nothing

134140

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

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

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

144+fromValueDecl (PositionedDeclaration _ d) = fromValueDecl d

138145fromValueDecl _ = error "Expected ValueDeclaration"

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

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

6262 where

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

6464 go other = return other

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

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

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

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

6669 desugarRest [] = pure []

6770

6871inSameGroup :: Declaration -> Declaration -> Bool

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

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

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

7075inSameGroup _ _ = False

7176

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

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

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

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

8186 return [makeCaseDeclaration ident tuples]

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

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

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

8290toDecls ds = return ds

8391

8492isVarBinder :: Binder -> Bool

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

8795

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

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

98+toTuple (PositionedDeclaration _ d) = toTuple d

9099toTuple _ = error "Not a value declaration"

91100

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

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

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

2727

2828import qualified Language.PureScript.Constants as C

2929

30+import Control.Applicative

31+

3032-- |

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

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

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

6062 go (DoNotationLet binder val : rest) = do

6163 rest' <- go rest

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

223223 go (BindingGroupDeclaration decls') = do

224224 BindingGroupDeclaration <$> mapM go' decls'

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

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

226227 go d = updateAll d

227228

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

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

230231

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

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

233−

234+

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

235236 updateValue v = return v

236−

237+

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

238239 updateBinder v = return v

239−

240+

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

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

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

243244 updateType t = return t

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

245246 updateType' = everywhereM (mkM updateType)

246−

247+

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

248249

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

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

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

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

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

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

302304 addDecl _ env _ = return env

303305

304306-- |

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

365367findImports = foldl findImports' M.empty

366368 where

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

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

368371 findImports' result _ = result

369372

370373-- |

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

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

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

7777 where

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

79+ collect (PositionedDeclaration _ d) = collect d

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

8081 collect _ = []

8182

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

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

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

100100 dictDecl <- typeInstanceDictionaryDeclaration name mn deps className ty desugared

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

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

103106

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

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

109+memberToNameAndType (PositionedDeclaration _ d) = memberToNameAndType d

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

107111

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

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

114118 ExternDeclaration TypeClassAccessorImport ident

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

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

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

118124

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

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

143149 return (identToJs ident, TypedValue False

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

145151 (quantify memberType))

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

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

154+ return (ident, PositionedValue pos val)

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

147156

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

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

157166 where

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

159168 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

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

161172

162173-- |

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

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

2727import Control.Monad (forM)

2828

2929import Language.PureScript.Declarations

30+import Language.PureScript.Names

31+import Language.PureScript.Environment

3032

3133-- |

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

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

3941--

4042desugarTypeDeclarations :: [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

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

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

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)

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

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

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

4658 where

src/Language/PureScript/TypeChecker.hs+2

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

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

195195 ds <- typeCheckAll mainModuleName moduleName rest

196196 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 {

6363 -- The value where the error occurred

6464 --

6565 , unifyErrorValue :: Maybe UnifyErrorSource

66+ -- |

67+ -- Optional source position information

68+ --

69+ , unifyErrorPosition :: Maybe SourcePos

6670 } deriving (Show)

6771

6872-- |

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

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

7276

7377instance Error UnifyErrorStack where

74− strMsg s = UnifyErrorStack [UnifyError s Nothing]

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

7579 noMsg = UnifyErrorStack []

7680

7781prettyPrintUnifyErrorStack :: Options -> UnifyErrorStack -> String

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

79−prettyPrintUnifyErrorStack _ (UnifyErrorStack es) =

80− let

81− errorsWithValues = filter (isJust . unifyErrorValue) es

82− mostSpecificError = last es

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

84− (0, _) -> showError mostSpecificError

85− (1, True) -> showError mostSpecificError

86− (1, False) ->

87− let errorWithValue = head errorsWithValues

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

82+prettyPrintUnifyErrorStack opts (UnifyErrorStack es) =

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

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

85+ _ -> prettyPrintUnifyErrorStack'

86+ where

87+ prettyPrintUnifyErrorStack' :: String

88+ prettyPrintUnifyErrorStack'

89+ | optionsVerboseErrors opts =

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

91+ | otherwise =

9592 let

96− leastSpecificErrorWithValue = head errorsWithValues

97− mostSpecificErrorWithValue = last errorsWithValues

98− in

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

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

101− showError mostSpecificError

93+ es' = filter isErrorNonEmpty es

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

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

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

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

114+ showError mostSpecificError

115+

116+isErrorNonEmpty :: UnifyError -> Bool

117+isErrorNonEmpty = not . null . unifyErrorMessage

102118

103119showError :: UnifyError -> String

104−showError (UnifyError msg Nothing) = msg

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

120+showError (UnifyError msg Nothing _) = msg

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

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

107123

108124mkUnifyErrorStack :: 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)]

110129

111130-- |

112131-- Temporarily bind a collection of names to values

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

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

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

256275

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+

257282-- |

258283-- Generate new type class dictionary name

259284--

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

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

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

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

578578 return $ TypedValue True val' ty'

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

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

580581

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

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

662663inferBinder val (NamedBinder name binder) = do

663664 m <- inferBinder val binder

664665 return $ M.insert name val m

666+inferBinder val (PositionedBinder pos binder) =

667+ rethrowWithPosition pos $ inferBinder val binder

665668

666669-- |

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

826829check' val ty | containsTypeSynonyms ty = do

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

828831 check val ty'

832+check' (PositionedValue pos val) ty =

833+ rethrowWithPosition pos $ check val ty

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

830835

831836containsTypeSynonyms :: Type -> Bool