git.iko.soy/elk
on 2d29699 help sign in
elk/src/Reporting/Error/Syntax.hs
231 lines 7.4 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Reporting.Error.Syntax where
4import qualified Data.List as List
5import qualified Data.Set as Set
6import qualified Text.Parsec.Error as Parsec
7import qualified Text.PrettyPrint as P
8import Text.PrettyPrint ((<+>))
10import qualified AST.Helpers as Help
11import qualified AST.Type as Type
12import qualified Reporting.PrettyPrint as P
13import qualified Reporting.Report as Report
16data Error
17 = Parse [Parsec.Message]
18 | InfixDuplicate String
19 | TypeWithoutDefinition String
20 | PortWithoutAnnotation String
21 | UnexpectedPort
22 | DuplicateValueDeclaration String
23 | DuplicateTypeDeclaration String
24 | DuplicateDefinition String
25 | UnboundTypeVarsInAlias String [String] String [String] Type.Raw
26 | UnboundTypeVarsInUnion String [String] String [String] [(String, [Type.Raw])]
29-- TO REPORT
31toReport :: P.Dealiaser -> Error -> Report.Report
32toReport dealiaser err =
33 case err of
34 Parse messages ->
35 parseErrorReport messages
37 InfixDuplicate opName ->
38 Report.simple
39 "INFIX OVERLAP"
40 ("The infix declarations for " ++ operator ++ " must be removed.")
41 ("The precedence and associativity can only be set in one place, and\n"
42 ++ "this information has already been set somewhere else."
43 )
44 where
45 operator =
46 if Help.isOp opName
47 then "(" ++ opName ++ ")"
48 else "`" ++ opName ++ "`"
50 TypeWithoutDefinition valueName ->
51 Report.simple
52 "MISSING DEFINITION"
53 ("There is a type annotation for `" ++ valueName ++ "` but there"
54 ++ " is no corresponding definition!"
55 )
56 ("Directly below the type annotation, put a definition like:\n\n"
57 ++ " " ++ valueName ++ " = 42"
58 )
60 PortWithoutAnnotation portName ->
61 Report.simple
62 "PORT ERROR"
63 ("Port `" ++ portName ++ "` does not have a type annotation!")
64 ("Directly above the port definition, I need something like this:\n\n"
65 ++ " port " ++ portName ++ " : Signal Int"
66 )
69 UnexpectedPort ->
70 Report.simple
71 "PORT ERROR"
72 "This module has ports, but ports can only appear in the main module."
73 ( "Ports in library code would create hidden dependencies where importing a\n"
74 ++ "module could bring in constraints not captured in the public API. Furthermore,\n"
75 ++ "if the module is imported twice, do we send values out the port twice?"
76 )
78 DuplicateValueDeclaration name ->
79 Report.simple
80 "DUPLICATE DEFINITION"
81 ("Naming multiple top-level values `" ++ name ++ "` makes things\n"
82 ++ "ambiguous. When you say `" ++ name ++ "` which one do you want?"
83 )
84 ("Find all the top-level values named `" ++ name ++ "` and\n"
85 ++ "do some renaming. Make sure the names are distinct!"
86 )
88 DuplicateTypeDeclaration name ->
89 Report.simple
90 "DUPLICATE DEFINITION"
91 ("Naming multiple types `" ++ name ++ "` makes things ambiguous\n"
92 ++ "When you say `" ++ name ++ "` which one do you want?"
93 )
94 ("Find all the types named `" ++ name ++ "` and\n"
95 ++ "do some renaming. Make sure the names are distinct!"
96 )
98 DuplicateDefinition name ->
99 Report.simple
100 "DUPLICATE DEFINITION"
101 ("Naming multiple values `" ++ name ++ "` in a single let-expression makes\n"
102 ++ "things ambiguous. When you say `" ++ name ++ "` which one do you want?"
103 )
104 ("Find all the values named `" ++ name ++ "` in this let-expression and\n"
105 ++ "do some renaming. Make sure the names are distinct!"
106 )
108 UnboundTypeVarsInAlias typeName givenVars tvar tvars tipe ->
109 unboundTypeVars typeName tvar tvars $ P.render $
110 P.hang
111 (P.text "type alias" <+> P.text typeName <+> P.hsep vars <+> P.equals)
112 4
113 (P.pretty dealiaser False tipe)
114 where
115 vars = map P.text (givenVars ++ tvar : tvars)
118 UnboundTypeVarsInUnion typeName givenVars tvar tvars ctors ->
119 unboundTypeVars typeName tvar tvars $ P.render $
120 P.vcat
121 [ P.text "type" <+> P.text typeName <+> P.hsep vars
122 , map toDoc ctors
123 |> zipWith (<+>) (P.text "=" : repeat (P.text "|"))
124 |> P.vcat
125 |> P.nest 4
126 ]
127 where
128 (|>) = flip ($)
129 vars = map P.text (givenVars ++ tvar : tvars)
130 toDoc (ctor, args) =
131 P.text ctor <+> P.hsep (map (P.pretty dealiaser True) args)
134unboundTypeVars :: String -> String -> [String] -> String -> Report.Report
135unboundTypeVars typeName tvar tvars revisedDeclaration =
136 Report.simple
137 "UNBOUND TYPE VARS"
138 ( "Not all type variables in `" ++ typeName ++ "` are listed, making sneaky\n"
139 ++ "type errors possible. Unbound type variables include: "
140 ++ List.intercalate ", " (tvar:tvars)
141 )
142 ( "You probably want this definition instead:\n"
143 ++ concatMap ("\n "++) (lines revisedDeclaration) ++ "\n\n"
144 ++ "Here's why. Imagine one `" ++ typeName ++ "` where `" ++ tvar ++ "` is an Int and\n"
145 ++ "another where it is a Bool. When we explicitly list the type variables, type\n"
146 ++ "checker can see that they are actually different types."
147 )
150-- TAGGING PARSE ERRORS
152newline :: String
153newline = "NEWLINE"
155freshLine :: String
156freshLine = "FRESH_LINE"
158whitespace :: String
159whitespace = "WHITESPACE"
161keyword :: String -> String
162keyword kwd =
163 "KEYWORD=" ++ kwd
165unkeyword :: String -> Maybe String
166unkeyword message =
167 if List.isPrefixOf "KEYWORD=" message
168 then Just (drop (length "KEYWORD=") message)
169 else Nothing
172-- REPORTING PARSE ERRORS
174parseErrorReport :: [Parsec.Message] -> Report.Report
175parseErrorReport messages =
176 let
177 addMsg message hint =
178 case message of
179 Parsec.SysUnExpect _msg ->
180 hint
182 Parsec.UnExpect _msg ->
183 hint
185 Parsec.Expect msg ->
186 let
187 msg' =
188 if msg `elem` [whitespace, newline, freshLine]
189 then "whitespace"
190 else msg
191 in
192 hint { _expected = Set.insert msg' (_expected hint) }
194 Parsec.Message msg ->
195 hint { _messages = msg : _messages hint }
197 (ParseHint msgs expects) =
198 foldr addMsg emptyHint messages
200 preHint =
201 case msgs of
202 [msg] ->
203 case unkeyword msg of
204 Just kwd ->
205 "It looks like the keyword `" ++ kwd ++ "` is being used as a variable.\n"
206 ++ "Try renaming it to something else."
207 Nothing ->
208 msg
210 _ -> "I ran into something unexpected when parsing your code!"
212 postHint =
213 if Set.null expects
214 then ""
215 else
216 "I am looking for one of the following things:\n"
217 ++ concatMap ("\n "++) (Set.toList expects)
218 in
219 Report.simple "SYNTAX PROBLEM" preHint postHint
222data ParseHint = ParseHint
223 { _messages :: [String]
224 , _expected :: Set.Set String
225 }
226 deriving (Show)
229emptyHint :: ParseHint
230emptyHint =
231 ParseHint [] Set.empty