123f867 · elk · git.iko.soy

git.iko.soy/elk

on master help sign in

Create Reporting.Report and move towards nicer messages

123f867Evan Czaplicki11 years ago

src/Elm/Compiler.hs+2−19

compare with master

unifiedsplit

@@ -3,8 +3,8 @@

3module Elm.Compiler

4 ( version, rawVersion

5 , parseDependencies, compile

6− , Error, errorToString, errorToJson

6+ , Error, errorToString

7− , Warning, warningToString, warningToJson

7+ , Warning

8 ) where

10import Control.Monad.Error.Class (MonadError, throwError)

@@ -88,23 +88,6 @@ errorToString location source (Error err) =

88 Error.toString location source err

91−errorToJson :: Error -> String

92−errorToJson (Error err) =

93− Error.toJson err

94−

95−

96-- WARNINGS

91-- WARNINGS

98newtype Warning = Warning (A.Located Warning.Warning)

93newtype Warning = Warning (A.Located Warning.Warning)

99−

100−

101−warningToString :: Warning -> String

102−warningToString (Warning warning) =

103− Warning.toString warning

104−

105−

106−warningToJson :: Warning -> String

107−warningToJson (Warning warning) =

108− Warning.toJson warning

109−

110−

src/Reporting/Error.hs+6−43

@@ -1,15 +1,11 @@

1{-# LANGUAGE OverloadedStrings #-}

2module Reporting.Error where

4−import Data.Aeson ((.=))

5−import qualified Data.Aeson as Json

6−import qualified Data.ByteString.Lazy.Char8 as BS

7−

8import qualified Reporting.Annotation as A

4import qualified Reporting.Annotation as A

9import qualified Reporting.Error.Canonicalize as Canonicalize

5import qualified Reporting.Error.Canonicalize as Canonicalize

10import qualified Reporting.Error.Syntax as Syntax

6import qualified Reporting.Error.Syntax as Syntax

11import qualified Reporting.Error.Type as Type

7import qualified Reporting.Error.Type as Type

12−import qualified Reporting.Region as R

8+import qualified Reporting.Report as Report

15-- ALL POSSIBLE ERRORS

11-- ALL POSSIBLE ERRORS

@@ -25,54 +21,21 @@ data Error

25toString :: String -> String -> A.Located Error -> String

21toString :: String -> String -> A.Located Error -> String

26toString location source (A.A region err) =

22toString location source (A.A region err) =

27 let

23 let

28− (tag, hint) =

24+ (tag, report) =

29 case err of

25 case err of

30 Syntax syntaxError ->

26 Syntax syntaxError ->

31 ( "SYNTAX ERROR"

27 ( "SYNTAX ERROR"

32− , Syntax.toHint syntaxError

28+ , Syntax.toReport syntaxError

33 )

29 )

35 Canonicalize canonicalizeError ->

31 Canonicalize canonicalizeError ->

36 ( "NAMING ERROR"

32 ( "NAMING ERROR"

37− , Canonicalize.toHint canonicalizeError

33+ , Canonicalize.toReport canonicalizeError

38 )

34 )

40 Type typeError ->

36 Type typeError ->

41 ( "TYPE ERROR"

37 ( "TYPE ERROR"

42− , Type.toHint typeError

38+ , Type.toReport typeError

43 )

39 )

44−

45− usedSpace =

46− 4 + length tag + 1 + length location

47−

48− messageBar =

49− "-- " ++ tag ++ " "

50− ++ replicate (max 1 (80 - usedSpace)) '-'

51− ++ " " ++ location

52− in

53− messageBar ++ "\n\n"

54− ++ R.select region source ++ "\n"

55− ++ hint ++ "\n\n\n"

56−

57−

58−-- JSON

59−

60−toJson :: A.Located Error -> String

61−toJson (A.A region err) =

62− let json =

63− case err of

64− Syntax syntaxError ->

65− Syntax.toJson syntaxError

66−

67− Canonicalize canonicalizeError ->

68− Canonicalize.toJson canonicalizeError

69−

70− Type typeError ->

71− Type.toJson typeError

72 in

40 in

73− BS.unpack $ Json.encode $

41+ Report.toString tag location region report source

74− Json.object

75− [ "tag" .= ("error" :: String)

76− , "region" .= region

77− , "error" .= json

78− ]

src/Reporting/Error/Canonicalize.hs+78−80

@@ -2,9 +2,6 @@

2{-# LANGUAGE OverloadedStrings #-}

3module Reporting.Error.Canonicalize where

5−--import Data.Aeson ((.=))

6−import qualified Data.Aeson as Json

7−--import qualified Data.Aeson.Types as Json

8import Data.Function (on)

5import Data.Function (on)

9import qualified Data.List as List

6import qualified Data.List as List

10import qualified Text.EditDistance as Dist

7import qualified Text.EditDistance as Dist

@@ -15,7 +12,8 @@ import qualified AST.Type as Type

15import qualified AST.Variable as Var

12import qualified AST.Variable as Var

16import Elm.Utils ((|>))

13import Elm.Utils ((|>))

17import qualified Reporting.PrettyPrint as P

14import qualified Reporting.PrettyPrint as P

18−import qualified Reporting.Region as R

15+import qualified Reporting.Region as Region

16+import qualified Reporting.Report as Report

21data Error

19data Error

@@ -82,7 +80,7 @@ valueNotFound name value possibilities =

82data AliasError

80data AliasError

83 = ArgMismatch Var.Canonical Int Int

81 = ArgMismatch Var.Canonical Int Int

84 | SelfRecursive String [String] Type.Raw

82 | SelfRecursive String [String] Type.Raw

85− | MutuallyRecursive [(R.Region, String, [String], Type.Raw)]

83+ | MutuallyRecursive [(Region.Region, String, [String], Type.Raw)]

88alias :: Var.Canonical -> Int -> Int -> Error

86alias :: Var.Canonical -> Int -> Int -> Error

@@ -131,126 +129,126 @@ distance x y =

131 Dist.restrictedDamerauLevenshteinDistance Dist.defaultEditCosts x y

129 Dist.restrictedDamerauLevenshteinDistance Dist.defaultEditCosts x y

132

130

133

131

134−-- TO STRING

132+-- TO REPORT

135

133

136−toString :: R.Region -> Error -> String

134+toReport :: Error -> Report.Report

137−toString region err =

135+toReport err =

138− case err of

139− _ -> error "Canonicalize.toString" region

140−

141−

142−-- TO JSON

143−

144−toJson :: Error -> Json.Value

145−toJson err =

146− case err of

147− _ -> error "Canonicalize.toJson"

148−

149−

150−-- HINTS

151−

152−toHint :: Error -> String

153−toHint err =

154 case err of

136 case err of

155 Var (VarError kind name problem suggestions) ->

137 Var (VarError kind name problem suggestions) ->

156− let var = kind ++ "'" ++ name ++ "'"

138+ let var = kind ++ " '" ++ name ++ "'"

157 in

139 in

158 case problem of

140 case problem of

159 Ambiguous ->

141 Ambiguous ->

142+ Report.simple

160− "This usage of " ++ var ++ " is ambiguous"

143+ ("This usage of " ++ var ++ " is ambiguous.")

161− ++ maybeYouWant "\n\n" suggestions

144+ (maybeYouWant suggestions)

162

145

163 UnknownQualifier qualifier ->

146 UnknownQualifier qualifier ->

164− "Cannot find " ++ var ++ "\n\n"

147+ Report.simple

165− ++ "The qualifier " ++ qualifier ++ " is not in scope."

148+ ("Cannot find " ++ var ++ ", qualifier '" ++ qualifier ++ "' is not in scope.")

166− ++ maybeYouWant "\n" suggestions

149+ (maybeYouWant suggestions)

167

150

168 QualifiedUnknown qualifier ->

151 QualifiedUnknown qualifier ->

169− "Cannot find " ++ var ++ "\n\n"

152+ Report.simple

170− ++ "The module called " ++ qualifier ++ " does not expose that value."

153+ ("Cannot find " ++ var ++ ", module '" ++ qualifier ++ "'' does not expose that value.")

171− ++ maybeYouWant "\n" suggestions

154+ (maybeYouWant suggestions)

172

155

173 ExposedUnknown ->

156 ExposedUnknown ->

157+ Report.simple

174− "Cannot find " ++ var

158+ ("Cannot find " ++ var)

175− ++ maybeYouWant "\n\n" suggestions

159+ (maybeYouWant suggestions)

176

160

177 Pattern patternError ->

161 Pattern patternError ->

178 case patternError of

162 case patternError of

179 PatternArgMismatch var expected actual ->

163 PatternArgMismatch var expected actual ->

180− argMismatchHint "pattern" var expected actual

164+ argMismatchReport "Pattern" var expected actual

181

165

182 Alias aliasError ->

166 Alias aliasError ->

183 case aliasError of

167 case aliasError of

184 ArgMismatch var expected actual ->

168 ArgMismatch var expected actual ->

185− argMismatchHint "type" var expected actual

169+ argMismatchReport "Type" var expected actual

186

170

187 SelfRecursive name tvars tipe ->

171 SelfRecursive name tvars tipe ->

188− "This type alias is recursive, forming an infinite type!\n\n"

172+ Report.simple "This type alias is recursive, forming an infinite type!" $

189− ++ "Type aliases are just names for more fundamental types, so I go through\n"

173+ "Type aliases are just names for more fundamental types, so I go through\n"

190− ++ "and expand them all to know the real underlying type. The problem is that\n"

174+ ++ "and expand them all to know the real underlying type. The problem is that\n"

191− ++ "when I expand a recursive type alias, it keeps getting bigger and bigger.\n"

175+ ++ "when I expand a recursive type alias, it keeps getting bigger and bigger.\n"

192− ++ "Dealiasing results in an infinitely large type! Try this instead:\n\n"

176+ ++ "Dealiasing results in an infinitely large type! Try this instead:\n\n"

193− ++ " type " ++ name ++ concatMap (' ':) tvars ++ " ="

177+ ++ " type " ++ name ++ concatMap (' ':) tvars ++ " ="

194− ++ P.render (P.nest 8 (P.hang (P.text name) 2 (P.pretty True tipe)))

178+ ++ P.render (P.nest 8 (P.hang (P.text name) 2 (P.pretty True tipe)))

195− ++ "\n\nThis creates a brand new type that cannot be expanded. It is similar types\n"

179+ ++ "\n\nThis creates a brand new type that cannot be expanded. It is similar types\n"

196− ++ "like List which are recursive, but do not get expanded into infinite types."

180+ ++ "like List which are recursive, but do not get expanded into infinite types."

197

181

198 MutuallyRecursive aliases ->

182 MutuallyRecursive aliases ->

199− "This type alias is part of a mutually recursive set of type aliases.\n"

183+ Report.simple "This type alias is part of a mutually recursive set of type aliases." $

200− ++ "The following type aliases all depend on each other in some way:\n"

184+ "The following type aliases all depend on each other in some way:\n"

201− ++ concatMap showName aliases ++ "\n\n"

185+ ++ concatMap showName aliases ++ "\n\n"

202− ++ "The problem is that when you try to expand any of these type aliases, they\n"

186+ ++ "The problem is that when you try to expand any of these type aliases, they\n"

203− ++ "expand infinitely! To fix, first try to centralize them into one alias."

187+ ++ "expand infinitely! To fix, first try to centralize them into one alias."

204 where

188 where

205− showName (R.Region start _, name, _, _) =

189+ showName (Region.Region start _, name, _, _) =

206 "\n " ++ name ++ replicate (65 - length name) ' '

190 "\n " ++ name ++ replicate (65 - length name) ' '

207− ++ "line " ++ show (R.line start)

191+ ++ "line " ++ show (Region.line start)

208

192

209 Import name importError ->

193 Import name importError ->

194+ let moduleName = Module.nameToString name

195+ in

210 case importError of

196 case importError of

211 ModuleNotFound suggestions ->

197 ModuleNotFound suggestions ->

198+ Report.simple

212− "Could not find a module named '" ++ Module.nameToString name ++ "'"

199+ ("Could not find a module named '" ++ moduleName ++ "'")

213− ++ maybeYouWant "\n\n" (map Module.nameToString suggestions)

200+ (maybeYouWant (map Module.nameToString suggestions))

214

201

215 ValueNotFound value suggestions ->

202 ValueNotFound value suggestions ->

203+ Report.simple

216− "Module '" ++ Module.nameToString name ++ "' does not expose '" ++ value ++ "'"

204+ ("Module '" ++ moduleName ++ "' does not expose '" ++ value ++ "'")

217− ++ maybeYouWant "\n\n" suggestions

205+ (maybeYouWant suggestions)

218

206

219 Export name suggestions ->

207 Export name suggestions ->

220− "Could not export '" ++ name ++ "'\n\n"

208+ Report.simple

221− ++ "It is not defined in this module."

209+ ("Could not export '" ++ name ++ "' which is not defined in this module.")

222− ++ maybeYouWant " " suggestions

210+ (maybeYouWant suggestions)

223

211

224 Port (PortError name isInbound _rootType localType maybeMessage) ->

212 Port (PortError name isInbound _rootType localType maybeMessage) ->

213+ let

214+ boundPort =

215+ if isInbound then "inbound port" else "outbound port"

216+

217+ preHint =

218+ "Trying to send " ++ maybe "an unsupported type" id maybeMessage

225− "Cannot pass " ++ message ++ " through " ++ boundPort ++ " '" ++ name ++ "':\n\n"

219+ ++ " through " ++ boundPort ++ " '" ++ name ++ "'"

220+

221+ postHint =

222+ "The specific unsupported type is:\n\n"

226− ++ P.render (P.nest 4 (P.pretty False localType)) ++ "\n\n"

223+ ++ P.render (P.nest 4 (P.pretty False localType)) ++ "\n\n"

227− ++ "The kinds of values that can flow through " ++ boundPort ++ "s include:\n"

224+ ++ "The types of values that can flow through " ++ boundPort ++ "s include:\n"

228− ++ "Ints, Floats, Bools, Strings, Maybes, Lists, Arrays, Tuples,\n"

225+ ++ "Ints, Floats, Bools, Strings, Maybes, Lists, Arrays, Tuples,\n"

229− ++ "Json.Values, and concrete records."

226+ ++ "Json.Values, and concrete records."

230− where

227+ in

231− boundPort =

228+ Report.simple preHint postHint

232− if isInbound then "inbound port" else "outbound port"

233

229

234− message =

235− maybe "the following type" id maybeMessage

236

230

231+argMismatchReport :: String -> Var.Canonical -> Int -> Int -> Report.Report

232+argMismatchReport kind var expected actual =

233+ let

234+ preHint =

235+ kind ++ " " ++ Var.toString var ++ " has too "

236+ ++ (if actual < expected then "few" else "many")

237+ ++ "arguments."

237

238

238−argMismatchHint :: String -> Var.Canonical -> Int -> Int -> String

239+ postHint =

239−argMismatchHint kind var expected actual =

240− "The " ++ kind ++ " " ++ Var.toString var ++ " has too "

241− ++ (if actual < expected then "few" else "many")

242− ++ "arguments.\n\n"

243− ++ "Expecting " ++ show expected ++ ", but got " ++ show actual

240+ "Expecting " ++ show expected ++ ", but got " ++ show actual ++ "."

241+ in

242+ Report.Report Nothing preHint postHint

244

243

245

244

246−maybeYouWant :: String -> [String] -> String

245+maybeYouWant :: [String] -> String

247−maybeYouWant prefix suggestions =

246+maybeYouWant suggestions =

248 case suggestions of

247 case suggestions of

249 [] ->

248 [] ->

250 ""

249 ""

251

250

252 _:_ ->

251 _:_ ->

253− prefix

254− ++ "Maybe you want one of the following?\n"

252+ "Maybe you want one of the following?\n"

255 ++ concatMap ("\n "++) suggestions

253 ++ concatMap ("\n "++) suggestions

256

254

src/Reporting/Error/Syntax.hs+61−56

@@ -1,7 +1,6 @@

1{-# OPTIONS_GHC -Wall #-}

2module Reporting.Error.Syntax where

4−import qualified Data.Aeson as Json

5import qualified Data.List as List

4import qualified Data.List as List

6import qualified Text.Parsec.Error as Parsec

5import qualified Text.Parsec.Error as Parsec

7import qualified Text.PrettyPrint as P

6import qualified Text.PrettyPrint as P

@@ -11,6 +10,7 @@ import qualified AST.Helpers as Help

11import qualified AST.Type as Type

10import qualified AST.Type as Type

12import Elm.Utils ((|>))

11import Elm.Utils ((|>))

13import qualified Reporting.PrettyPrint as P

12import qualified Reporting.PrettyPrint as P

13+import qualified Reporting.Report as Report

16data Error

@@ -25,26 +25,22 @@ data Error

25 | UnboundTypeVarsInUnion String [String] String [String] [(String, [Type.Raw])]

28−-- TO JSON

28+-- TO REPORT

30−toJson :: Error -> Json.Value

30+toReport :: Error -> Report.Report

31−toJson err =

31+toReport err =

32− case err of

33− _ -> error "Syntax.toJson"

34−

35−

36−-- HINTS

37−

38−toHint :: Error -> String

39−toHint err =

40 case err of

32 case err of

41 Parse messages ->

33 Parse messages ->

34+ Report.simple

35+ "Problem when parsing your code!"

42− unlines (map parseErrorHint messages)

36+ (unlines (map parseErrorHint messages))

44 InfixDuplicate opName ->

38 InfixDuplicate opName ->

39+ Report.simple

45− "The infix declarations for " ++ operator ++ " must be removed.\n\n"

40+ ("The infix declarations for " ++ operator ++ " must be removed.")

46− ++ "The precedence and associativity can only be set in one place, and\n"

41+ ("The precedence and associativity can only be set in one place, and\n"

47− ++ "this information has already been set somewhere else."

42+ ++ "this information has already been set somewhere else."

43+ )

48 where

44 where

49 operator =

45 operator =

50 if Help.isOp opName

46 if Help.isOp opName

@@ -52,37 +48,47 @@ toHint err =

52 else "`" ++ opName ++ "`"

48 else "`" ++ opName ++ "`"

54 TypeWithoutDefinition valueName ->

50 TypeWithoutDefinition valueName ->

51+ Report.simple

55− "There is a type annotation for '" ++ valueName ++ "' but there"

52+ ("There is a type annotation for '" ++ valueName ++ "' but there"

56− ++ "is no corresponding definition! I need something like this:\n\n"

53+ ++ "is no corresponding definition!"

54+ )

55+ ("Directly below the type annotation, put a definition like:\n\n"

57− ++ " " ++ valueName ++ " = 42\n\n"

56+ ++ " " ++ valueName ++ " = 42"

58− ++ "And be sure to put the definition directly below the type annotation."

57+ )

60 PortWithoutAnnotation portName ->

59 PortWithoutAnnotation portName ->

60+ Report.simple

61− "There is a port named '" ++ portName ++ "' but it does not have"

61+ ("Port '" ++ portName ++ "' does not have a type annotation!")

62− ++ "a type annotation! I need something like this:\n\n"

62+ ("Directly above the port definition, I need something like this:\n\n"

63− ++ indent ("port " ++ portName ++ " : Signal Int") ++ "\n\n"

63+ ++ " port " ++ portName ++ " : Signal Int"

64− ++ "And be sure to put this annotation directly above the port definition."

64+ )

66 DuplicateValueDeclaration name ->

67− "Multiple top-level declarations define '" ++ name ++ "',\n"

67+ Report.simple

68− ++ "but the name overlap makes all uses of '" ++ name ++ "' ambiguous.\n"

68+ ("Naming multiple top-level values '" ++ name ++ "' makes things\n"

69− ++ "How can we know which you want?!\n\n"

69+ ++ "ambiguous. When you say '" ++ name ++ "' which one do you want?!"

70+ )

70− ++ "Find all the top-level variables named '" ++ name ++ "' and\n"

71+ ("Find all the top-level values named '" ++ name ++ "' and\n"

71− ++ "do some renaming. Make sure the names are distinct!"

72+ ++ "do some renaming. Make sure the names are distinct!"

72−

73+ )

74+

73− DuplicateTypeDeclaration tipeName ->

75+ DuplicateTypeDeclaration name ->

74− "Multiple declarations define a type '" ++ tipeName ++ "',\n"

76+ Report.simple

75− ++ "but the name overlap makes all uses of '" ++ tipeName ++ "' ambiguous.\n"

77+ ("Naming multiple types '" ++ name ++ "' makes things ambiguous\n"

76− ++ "How can we know which you want?!\n\n"

78+ ++ "When you say '" ++ name ++ "' which one do you want?!"

79+ )

77− ++ "Find all the types named '" ++ tipeName ++ "' and\n"

80+ ("Find all the types named '" ++ name ++ "' and\n"

78− ++ "do some renaming. Make sure the names are distinct!"

81+ ++ "do some renaming. Make sure the names are distinct!"

82+ )

80 DuplicateDefinition name ->

84 DuplicateDefinition name ->

81− "This let-expression defines multiple variables named '" ++ name ++ "',\n"

85+ Report.simple

82− ++ "but the name overlap makes all uses of '" ++ name ++ "' ambiguous.\n"

86+ ("Naming multiple values '" ++ name ++ "' in a single let-expression makes\n"

83− ++ "How can we know which you want?!\n\n"

87+ ++ "things ambiguous. When you say '" ++ name ++ "' which one do you want?!"

88+ )

84− ++ "Find the variables named '" ++ name ++ "' in this let-expression and\n"

89+ ("Find all the values named '" ++ name ++ "' in this let-expression and\n"

85− ++ "do some renaming. Make sure the names are distinct!"

90+ ++ "do some renaming. Make sure the names are distinct!"

91+ )

87 UnboundTypeVarsInAlias typeName givenVars tvar tvars tipe ->

93 UnboundTypeVarsInAlias typeName givenVars tvar tvars tipe ->

88 unboundTypeVars typeName tvar tvars $ P.render $

94 unboundTypeVars typeName tvar tvars $ P.render $

@@ -109,23 +115,22 @@ toHint err =

109 P.text ctor <+> P.hsep (map (P.pretty True) args)

115 P.text ctor <+> P.hsep (map (P.pretty True) args)

110

116

111

117

112−unboundTypeVars :: String -> String -> [String] -> String -> String

118+unboundTypeVars :: String -> String -> [String] -> String -> Report.Report

113unboundTypeVars typeName tvar tvars revisedDeclaration =

119unboundTypeVars typeName tvar tvars revisedDeclaration =

114− "In the definition of type '" ++ typeName ++ "' you use the following\n"

120+ let

115− ++ "unbound type variable" ++ s ++ ": " ++ List.intercalate ", " (tvar:tvars) ++ "\n\n"

116− ++ "All type variables must be listed to avoid sneaky type errors.\n"

117− ++ "Imagine one '" ++ typeName ++ "' where '" ++ tvar ++ "' is an Int and\n"

118− ++ "another where it is a Bool. They both look like a '" ++ typeName ++ "'\n"

119− ++ "to the type checker, but they are actually different types!\n\n"

120− ++ "Maybe you want a definition like this?\n\n"

121− ++ indent revisedDeclaration ++ "\n\n"

122− where

123 s = if null tvars then "" else "s"

121 s = if null tvars then "" else "s"

124−

122+ in

125−

123+ Report.simple

126−indent :: String -> String

124+ ("Type '" ++ typeName ++ "' uses unbound type variable" ++ s ++ ": "

127−indent string =

128− List.intercalate "\n" (map (" " ++ ) (lines string))

125+ ++ List.intercalate ", " (tvar:tvars)

126+ )

127+ ("All type variables must be listed to avoid sneaky type errors.\n"

128+ ++ "Imagine one '" ++ typeName ++ "' where '" ++ tvar ++ "' is an Int and\n"

129+ ++ "another where it is a Bool. They both look like a '" ++ typeName ++ "'\n"

130+ ++ "to the type checker, but they are actually different types!\n\n"

131+ ++ "Maybe you want a definition like this?\n"

132+ ++ concatMap ("\n "++) (lines revisedDeclaration)

133+ )

129

134

130

135

131parseErrorHint :: Parsec.Message -> String

136parseErrorHint :: Parsec.Message -> String

src/Reporting/Error/Type.hs+26−41

@@ -1,13 +1,11 @@

1{-# OPTIONS_GHC -Wall #-}

2module Reporting.Error.Type where

4−--import Data.Aeson ((.=))

5−import qualified Data.Aeson as Json

6import qualified Text.PrettyPrint as P

4import qualified Text.PrettyPrint as P

8import qualified AST.Type as T

6import qualified AST.Type as T

9import qualified Reporting.PrettyPrint as P

7import qualified Reporting.PrettyPrint as P

10−import qualified Reporting.Region as R

8+import qualified Reporting.Report as Report

13data Error

11data Error

@@ -23,48 +21,35 @@ data Mismatch = MismatchInfo

23 }

21 }

26−-- TO STRING

24+-- TO REPORT

28−toString :: R.Region -> Error -> String

26+toReport :: Error -> Report.Report

29−toString region err =

27+toReport err =

30− case err of

31− _ -> error "Type.toString" region

32−

33−

34−-- TO JSON

35−

36−toJson :: Error -> Json.Value

37−toJson err =

38− case err of

39− _ -> error "Type.toJson"

40−

41−

42−-- HINTS

43−

44−toHint :: Error -> String

45−toHint err =

46 case err of

28 case err of

47 Mismatch (MismatchInfo maybeHint leftType rightType) ->

29 Mismatch (MismatchInfo maybeHint leftType rightType) ->

30+ let

31+ preHint =

48− maybe "This expression is triggering a type mismatch." id maybeHint

32+ maybe "This expression is triggering a type mismatch." id maybeHint

49− ++ "\n\n"

33+

50− ++ "I am trying to infer the type, but I am getting conflicting information.\n"

34+ postHint =

51− ++ "Some evidence suggests it has the type:\n\n"

35+ "During type inference, I am seeing a conflict between this type:\n\n"

52− ++ P.render (P.nest 4 (P.pretty False leftType))

36+ ++ P.render (P.nest 4 (P.pretty False leftType))

53− ++ "\n\nBut other evidence suggests:\n\n"

37+ ++ "\n\nand this type:\n\n"

54− ++ P.render (P.nest 4 (P.pretty False rightType))

38+ ++ P.render (P.nest 4 (P.pretty False rightType))

39+ in

40+ Report.simple preHint postHint

56 InfiniteType var tipe ->

42 InfiniteType var tipe ->

57− "This expression is leading me to infer an infinite type. Maybe you are trying\n"

43+ Report.simple "This expression is leading me to infer an infinite type." $

58− ++ "to do some tricky recursion? Try breaking the expression into smaller pieces.\n"

44+ "Maybe you are trying to do some tricky recursion? Try breaking the expression\n"

59− ++ "Give each piece a name and try to write down its type.\n\n"

45+ ++ "into smaller pieces. Give each piece a name and try to write down its type.\n\n"

60− ++ "The evidence is suggesting that type '" ++ var ++ "' is equal to:\n\n"

46+ ++ "Type inference got stuck when type '" ++ var ++ "' needed equal to:\n\n"

61− ++ P.render (P.nest 4 (P.pretty False tipe))

47+ ++ P.render (P.nest 4 (P.pretty False tipe))

62− ++ "\n\nNotice that type variable '" ++ var ++ "' appears there too, so if we\n"

48+ ++ "\n\nNotice that type variable '" ++ var ++ "' appears there too, so if we\n"

63− ++ "expanded this type, it would just keep getting bigger and bigger."

49+ ++ "expanded this type, it would just keep getting bigger and bigger."

65 BadMain tipe ->

51 BadMain tipe ->

66− "The 'main' value has an unsupported type:\n\n"

52+ Report.simple "The 'main' value has an unsupported type." $

67− ++ P.render (P.nest 4 (P.pretty False tipe))

68− ++ "\n\n"

69− ++ "Please give me an Element, Html, (Signal Element), or (Signal Html) so\n"

53+ "I need an Element, Html, (Signal Element), or (Signal Html) so I can render it\n"

70− ++ "that I can render it on screen!"

54+ ++ "on screen, but you gave me:\n\n"

55+ ++ P.render (P.nest 4 (P.pretty False tipe))

src/Reporting/Region.hs−62

@@ -5,8 +5,6 @@ import Data.Aeson ((.=))

5import qualified Data.Aeson as Json

6import qualified Text.Parsec.Pos as Parsec

8−import Elm.Utils ((|>))

9−

11data Region = Region

9data Region = Region

12 { start :: Position

10 { start :: Position

@@ -48,66 +46,6 @@ toString (Region start end) =

48 ++ show (column start) ++ " to " ++ show (column end)

46 ++ show (column start) ++ " to " ++ show (column end)

51−-- EXTRACT REGION from SOURCE with LINE NUMBERS

52−

53−select :: Region -> String -> String

54−select (Region start end) source =

55− let

56− relevantLines =

57− lines source

58− |> drop (line start - 1)

59− |> take (line end - line start + 1)

60− in

61− case relevantLines of

62− [] ->

63− error "something has gone badly wrong with reporting source locations"

64−

65− [theLine] ->

66− let

67− n = line start

68− w = length (show (n + 1))

69− underline =

70− replicate (column start - 1) ' '

71− ++ replicate (max 1 (column end - column start)) '^'

72− in

73− unlines

74− [ addLineNumber w (n-1) ""

75− , addLineNumber w n theLine

76− , addLineNumber w (n+1) underline

77− ]

78−

79− firstLine : rest ->

80− let

81− filteredFirstLine =

82− replicate (column start - 1) ' '

83− ++ drop (column start - 1) firstLine

84−

85− filteredLastLine =

86− take (column end) (last rest)

87−

88− focusedRelevantLines =

89− filteredFirstLine : init rest ++ [filteredLastLine]

90−

91− lineNumbersWidth =

92− length (show (line end + 1))

93−

94− numberedLines =

95− zipWith

96− (addLineNumber lineNumbersWidth)

97− [line start - 1 .. line end + 1]

98− ("" : focusedRelevantLines ++ [""])

99− in

100− unlines numberedLines ++ "\n"

101−

102−

103−addLineNumber :: Int -> Int -> String -> String

104−addLineNumber width n line =

105− let

106− number = if n < 0 then " " else show n

107− in

108− replicate (width - length number) ' ' ++ number ++ "| " ++ line

109−

110−

111-- JSON

49-- JSON

112

113instance Json.ToJSON Region where

51instance Json.ToJSON Region where

src/Reporting/Report.hsnew file+110

@@ -0,0 +1,110 @@

1+module Reporting.Report

2+ ( Report(Report)

3+ , simple

4+ , toString

5+ ) where

7+import Elm.Utils ((|>))

8+import qualified Reporting.Region as R

10+

11+data Report = Report

12+ { highlight :: Maybe (Int,Int)

13+ , preHint :: String

14+ , postHint :: String

15+ }

16+

17+

18+simple :: String -> String -> Report

19+simple pre post =

20+ Report Nothing pre post

21+

22+

23+toString :: String -> String -> R.Region -> Report -> String -> String

24+toString tag location region report source =

25+ concat

26+ [ messageBar tag location

27+ , preHint report ++ "\n\n"

28+ , grabRegion (highlight report) region source ++ "\n"

29+ , postHint report ++ "\n\n\n"

30+ ]

31+

32+

33+-- REPORT HEADER

34+

35+messageBar :: String -> String -> String

36+messageBar tag location =

37+ let usedSpace = 4 + length tag + 1 + length location

38+ in

39+ "-- " ++ tag ++ " "

40+ ++ replicate (max 1 (80 - usedSpace)) '-'

41+ ++ " " ++ location ++ "\n\n"

42+

43+

44+-- REGIONS

45+

46+grabRegion :: Maybe (Int,Int) -> R.Region -> String -> String

47+grabRegion maybeSubRegion (R.Region start end) source =

48+ let

49+ (R.Position startLine startColumn) = start

50+ (R.Position endLine endColumn) = end

51+

52+ relevantLines =

53+ lines source

54+ |> drop (startLine - 1)

55+ |> take (endLine - startLine + 1)

56+ in

57+ case relevantLines of

58+ [] ->

59+ error "something has gone badly wrong with reporting source locations"

60+

61+ [theLine] ->

62+ let

63+ n = startLine

64+ w = length (show (n + 1))

65+ underline =

66+ replicate (startColumn - 1) ' '

67+ ++ replicate (max 1 (endColumn - startColumn)) '^'

68+ number =

69+ addLineNumber Nothing w

70+ in

71+ unlines

72+ [ number (n-1) ""

73+ , number n theLine

74+ , number (n+1) underline

75+ ]

76+

77+ firstLine : rest ->

78+ let

79+ filteredFirstLine =

80+ replicate (startColumn - 1) ' '

81+ ++ drop (startColumn - 1) firstLine

82+

83+ filteredLastLine =

84+ take (endColumn) (last rest)

85+

86+ focusedRelevantLines =

87+ filteredFirstLine : init rest ++ [filteredLastLine]

88+

89+ lineNumbersWidth =

90+ length (show (endLine + 1))

91+

92+ numberedLines =

93+ zipWith

94+ (addLineNumber maybeSubRegion lineNumbersWidth)

95+ [startLine - 1 .. endLine + 1]

96+ ("" : focusedRelevantLines ++ [""])

97+ in

98+ unlines numberedLines ++ "\n"

99+

100+

101+addLineNumber :: Maybe (Int,Int) -> Int -> Int -> String -> String

102+addLineNumber maybeSubRegion width n line =

103+ let

104+ number = if n <= 0 then " " else show n

105+ spacer =

106+ case maybeSubRegion of

107+ Just (lo,hi) | lo <= n && n <= hi -> ">"

108+ _ -> " "

109+ in

110+ replicate (width - length number) ' ' ++ number ++ "|" ++ spacer ++ line