git.iko.soy/elk
on c19392f help sign in
elk/src/Reporting/Error/Canonicalize.hs
605 lines 17 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Reporting.Error.Canonicalize
4 ( Error(..)
5 , CtorType(..)
6 , variable
7 , VarKind(..)
8 , VarProblem(..)
9 , argMismatch
10 , port
11 , toReport
12 , extractSuggestions
13 )
14 where
16import Control.Arrow ((***))
17import qualified Data.Char as Char
18import qualified Data.Map as Map
19import qualified Data.Text as Text
20import Data.Text (Text)
22import qualified AST.Binop as Binop
23import qualified AST.Expression.Canonical as Canonical
24import qualified AST.Module.Name as ModuleName
25import qualified AST.Type as Type
26import qualified AST.Variable as Var
27import qualified Elm.Name as N
28import qualified Reporting.Annotation as A
29import qualified Reporting.Region as Region
30import qualified Reporting.Render.Type as RenderType
31import qualified Reporting.Report as Report
32import qualified Reporting.Helpers as Help
33import Reporting.Helpers ( Doc, (<>), dullyellow, fillSep, green, i2t, indent, reflowParagraph, text )
37-- CANONICALIZATION ERRORS
40data Error
41 = Var VarError
42 | AliasArgMismatch Var.Canonical Int Int
43 | AliasRecursion N.Name [N.Name] Type.Raw [N.Name]
44 | BadRecursion Region.Region Canonical.Def [Canonical.Def]
45 | BadInfix Region.Region Int Var.Canonical Binop.Associativity Var.Canonical Binop.Associativity
46 | Pattern PatternError
47 | DuplicateDecl N.Name
48 | DuplicateType N.Name
49 | DuplicateCtor N.Name CtorType CtorType
50 | DuplicateBinop N.Name
51 | DuplicateField N.Name
52 | DuplicateAliasArg N.Name N.Name [N.Name]
53 | DuplicateUnionArg N.Name N.Name [N.Name]
54 | ImportNotFound ModuleName.Raw [ModuleName.Raw]
55 | ImportCtorNotFound N.Name N.Name
56 | ImportOpenAlias N.Name
57 | ImportExposingNotFound ModuleName.Raw N.Name [N.Name]
58 | Export Text [Text]
59 | DuplicateExport Text
60 | Port PortError
61 | BadPort Text Type.Canonical
62 | TypeVarsUnboundInUnion N.Name [N.Name] [A.Located N.Name]
63 | TypeVarsMessedUpInAlias N.Name [N.Name] [A.Located N.Name] [A.Located N.Name]
66data CtorType
67 = UnionCtor N.Name
68 | RecordCtor
72-- VARIABLES
75data VarError =
76 VarError
77 { _kind :: VarKind
78 , _name :: Text
79 , _problem :: VarProblem
80 , _suggestions :: [Text]
81 }
84data VarProblem
85 = Ambiguous
86 | UnknownQualifier Text Text
87 | QualifiedUnknown Text Text
88 | ExposedUnknown
91variable :: VarKind -> Text -> VarProblem -> [Text] -> Error
92variable kind name problem suggestions =
93 Var (VarError kind name problem suggestions)
97-- KIND
100data VarKind
101 = BadOp
102 | BadVar
103 | BadPattern
104 | BadType
107toKindInfo :: VarKind -> Text -> ( Doc, Doc, Doc )
108toKindInfo kind name =
109 case kind of
110 BadOp ->
111 ( "an", "operator", text $ "(" <> name <> ")" )
113 BadVar ->
114 ( "a", "value", text name )
116 BadPattern ->
117 ( "a", "pattern", text name )
119 BadType ->
120 ( "a", "type", text name )
124-- PATTERN
127data PatternError
128 = PatternArgMismatch Var.Canonical Int Int
131argMismatch :: Var.Canonical -> Int -> Int -> Error
132argMismatch name expected actual =
133 Pattern (PatternArgMismatch name expected actual)
137-- PORTS
140data PortError =
141 PortError
142 { _portName :: Text
143 , _portType :: Type.Canonical
144 , _portMessage :: Maybe Text
145 }
148port :: Text -> Type.Canonical -> Maybe Text -> Error
149port name tipe maybeMessage =
150 Port (PortError name tipe maybeMessage)
154-- EXTRACT SUGGESTIONS
157extractSuggestions :: Error -> Maybe [Text]
158extractSuggestions err =
159 case err of
160 Var (VarError _ _ _ suggestions) ->
161 Just suggestions
163 AliasArgMismatch _ _ _ ->
164 Nothing
166 AliasRecursion _ _ _ _ ->
167 Nothing
169 BadRecursion _ _ _ ->
170 Nothing
172 BadInfix _ _ _ _ _ _ ->
173 Nothing
175 DuplicateDecl _ ->
176 Nothing
178 DuplicateType _ ->
179 Nothing
181 DuplicateCtor _ _ _ ->
182 Nothing
184 DuplicateBinop _ ->
185 Nothing
187 DuplicateField _ ->
188 Nothing
190 DuplicateAliasArg _ _ _ ->
191 Nothing
193 DuplicateUnionArg _ _ _ ->
194 Nothing
196 Pattern _ ->
197 Nothing
199 ImportNotFound _ suggestions ->
200 Just (map ModuleName.toText suggestions)
202 ImportExposingNotFound _ _ suggestions ->
203 Just suggestions
205 ImportCtorNotFound _ _ ->
206 Nothing
208 ImportOpenAlias _ ->
209 Nothing
211 Export _ suggestions ->
212 Just suggestions
214 DuplicateExport _ ->
215 Nothing
217 Port _ ->
218 Nothing
220 BadPort _ _ ->
221 Nothing
223 TypeVarsUnboundInUnion _ _ _ ->
224 Nothing
226 TypeVarsMessedUpInAlias _ _ _ _ ->
227 Nothing
231-- TO REPORT
234toReport :: RenderType.Localizer -> Error -> Report.Report
235toReport localizer err =
236 case err of
237 Var varError ->
238 varErrorToReport varError
240 BadRecursion region def defs ->
241 case defs of
242 [] ->
243 badSelfRecursion region (defToText def)
245 _ ->
246 badMutualRecursion region (defToText def) (map (defToText) defs)
248 BadInfix region _prec (Var.Canonical _ name1) _assoc1 (Var.Canonical _ name2) _assoc2 ->
249 Report.report
250 "INFIX PROBLEM"
251 (Just region)
252 ("You cannot mix (" <> name1 <> ") and (" <> name2 <> ") without parentheses." )
253 (
254 Help.stack
255 [ reflowParagraph $
256 "I do not know how to group these expressions. Add parentheses for me!"
257 ]
258 )
260 DuplicateDecl _ ->
261 error "TODO DuplicateDecl"
263 DuplicateType _ ->
264 error "TODO DuplicateType"
266 DuplicateCtor _ _ _ ->
267 error "TODO DuplicateCtor"
269 DuplicateBinop _ ->
270 error "TODO DuplicateBinop"
272 DuplicateField _ ->
273 error "TODO DuplicateField"
275 DuplicateAliasArg _ _ _ ->
276 error "TODO DuplicateAliasArg"
278 DuplicateUnionArg _ _ _ ->
279 error "TODO DuplicateUnionArg"
281 Pattern patternError ->
282 case patternError of
283 PatternArgMismatch var expected actual ->
284 argMismatchReport "Pattern" var expected actual
286 AliasArgMismatch var expected actual ->
287 argMismatchReport "Type" var expected actual
289 AliasRecursion name args tipe others ->
290 aliasRecursionReport localizer name args tipe others
292 ImportNotFound name suggestions ->
293 Report.report "IMPORT ERROR" Nothing
294 ("Could not find a module named `" <> ModuleName.toText name <> "`")
295 (Help.maybeYouWant Nothing suggestions)
297 ImportCtorNotFound ctor tipe ->
298 Report.report "IMPORT ERROR" Nothing
299 ("This is not the syntax for exposing a `" <> tipe <> "` type constructor:")
300 ( Help.stack
301 [ reflowParagraph $
302 "Delete that. You can expose the `" <> ctor
303 <> "` type constructors by saying:"
304 , indent 4 (green (text (tipe <> "(..)")))
305 , reflowParagraph $
306 "This means that every type constructors of `" <> tipe
307 <> "` is exposed. No need to list them separately."
308 ]
309 )
311 ImportOpenAlias name ->
312 Report.report "IMPORT ERROR" Nothing
313 ("Cannot expose `" <> name <> "` like this:")
314 ( reflowParagraph $
315 "The (..) syntax exposes type constructors, but a type alias like `"
316 <> name <> "` has no constructors! It is just an alternate name for\
317 \ an existing type. Remove the (..) part and it should work."
318 )
319 -- TODO add docs about the difference between types and type aliases
321 ImportExposingNotFound name value suggestions ->
322 Report.report "IMPORT ERROR" Nothing
323 ("Module `" <> ModuleName.toText name <> "` does not expose `" <> value <> "`")
324 (Help.maybeYouWant Nothing suggestions)
326 Export name suggestions ->
327 Report.report "EXPOSING ERROR" Nothing
328 ("Could not expose `" <> name <> "` which is not defined in this module.")
329 (Help.maybeYouWant Nothing suggestions)
331 DuplicateExport name ->
332 Report.report "EXPOSING ERROR" Nothing
333 ("You are trying to expose `" <> name <> "` multiple times!")
334 "Remove duplicates until there is only one listed."
336 Port (PortError name tipe maybeMessage) ->
337 let
338 context =
339 maybe "" (" the following " <> ) maybeMessage
340 in
341 Report.report
342 "PORT ERROR"
343 Nothing
344 ("Port `" <> name <> "` is trying to communicate an unsupported type."
345 )
346 ( Help.stack
347 [ text ("The specific unsupported type is" <> context <> ":")
348 , indent 4 (RenderType.toDoc localizer tipe)
349 , text "The types of values that can flow through in and out of Elm include:"
350 , indent 4 $ reflowParagraph $
351 "Ints, Floats, Bools, Strings, Maybes, Lists, Arrays,\
352 \ Tuples, Json.Values, and concrete records."
353 -- TODO add a note about custom decoders and encoders when they exist!
354 ]
355 )
357 BadPort name tipe ->
358 Report.report
359 "PORT ERROR"
360 Nothing
361 ("Port `" <> name <> "` has an invalid type."
362 )
363 ( Help.stack
364 [ text ("You are saying it should be:")
365 , indent 4 (RenderType.toDoc localizer tipe)
366 , reflowParagraph $
367 "But you need to use the particular format described here:\
368 \ <http://guide.elm-lang.org/interop/javascript.html#ports>"
369 ]
370 )
372 TypeVarsUnboundInUnion _ _ _ ->
373 error "TODO TypeVarsUnboundInUnion"
375 TypeVarsMessedUpInAlias _ _ _ _ ->
376 error "TODO TypeVarsMessedUpInAlias"
382-- VAR ERROR
385varErrorToReport :: VarError -> Report.Report
386varErrorToReport (VarError kind name problem suggestions) =
387 let
388 learnMore orMaybe =
389 Help.reflowParagraph $
390 orMaybe <> " `import` works different than you expect? Learn all about it here: "
391 <> Help.hintLink "imports"
393 namingError overview maybeStarter specializedSuggestions =
394 Report.reportDoc "NAMING ERROR" Nothing overview $
395 case Help.maybeYouWant' maybeStarter specializedSuggestions of
396 Nothing ->
397 learnMore "Maybe"
398 Just doc ->
399 Help.stack [ doc, learnMore "Or maybe" ]
401 specialNamingError specialHint =
402 Report.reportDoc "NAMING ERROR" Nothing (cannotFind kind name) (Help.hsep specialHint)
403 in
404 case problem of
405 Ambiguous ->
406 namingError (ambiguous kind name) Nothing suggestions
408 UnknownQualifier qualifier localName ->
409 namingError
410 (cannotFind kind name)
411 (Just $ text $ "No module called `" <> qualifier <> "` has been imported.")
412 (map (\modul -> modul <> "." <> localName) suggestions)
414 QualifiedUnknown qualifier localName ->
415 namingError
416 (cannotFind kind name)
417 (Just $ text $ "`" <> qualifier <> "` does not expose `" <> localName <> "`.")
418 (map (\v -> qualifier <> "." <> v) suggestions)
420 ExposedUnknown ->
421 case name of
422 "!=" -> specialNamingError (notEqualsHint name)
423 "!==" -> specialNamingError (notEqualsHint name)
424 "===" -> specialNamingError equalsHint
425 "%" -> specialNamingError modHint
426 _ -> namingError (cannotFind kind name) Nothing suggestions
429cannotFind :: VarKind -> Text -> [Doc]
430cannotFind kind rawName =
431 let ( a, thing, name ) = toKindInfo kind rawName in
432 [ "Cannot", "find", a, thing, "named", dullyellow name <> ":" ]
435ambiguous :: VarKind -> Text -> [Doc]
436ambiguous kind rawName =
437 let ( _a, thing, name ) = toKindInfo kind rawName in
438 [ "This", "usage", "of", "the", dullyellow name, thing, "is", "ambiguous." ]
441notEqualsHint :: Text -> [Doc]
442notEqualsHint op =
443 [ "Looking", "for", "the", "“not", "equal”", "operator?", "The", "traditional"
444 , dullyellow $ text $ "(" <> op <> ")"
445 , "is", "replaced", "by", green "(/=)", "in", "Elm.", "It", "is", "meant"
446 , "to", "look", "like", "the", "“not", "equal”", "sign", "from", "math!", "(≠)"
447 ]
450equalsHint :: [Doc]
451equalsHint =
452 [ "A", "special", dullyellow "(===)", "operator", "is", "not", "needed"
453 , "in", "Elm.", "We", "use", green "(==)", "for", "everything!"
454 ]
457modHint :: [Doc]
458modHint =
459 [ "Rather", "than", "a", dullyellow "(%)", "operator,"
460 , "Elm", "has", "a", green "modBy", "function."
461 , "Learn", "more", "here:"
462 , "<https://package.elm-lang.org/packages/elm-lang/core/latest/Basics#modBy>"
463 ]
467-- ARG MISMATCH
470argMismatchReport :: Text -> Var.Canonical -> Int -> Int -> Report.Report
471argMismatchReport kind var expected actual =
472 let
473 numArgs =
474 "too "
475 <> (if actual < expected then "few" else "many")
476 <> " arguments"
477 in
478 Report.report
479 (Text.map Char.toUpper numArgs)
480 Nothing
481 ( kind <> " " <> Var.toText var <> " has " <> numArgs <> "."
482 )
483 ( text $
484 "Expecting " <> i2t expected <> ", but got " <> i2t actual <> "."
485 )
489-- BAD RECURSION
492badSelfRecursion :: Region.Region -> Text -> Report.Report
493badSelfRecursion region name =
494 let
495 header =
496 Help.functionName name <> " is defined directly in terms of itself, causing an infinite loop."
497 in
498 Report.report "BAD RECURSION" (Just region) header $
499 Help.stack
500 [ badSelfRecursionHelp "Maybe you are trying to mutate a variable?" $
501 "Elm does not have mutation, so when I see " <> Help.functionName name
502 <> " defined in terms of " <> Help.functionName name
503 <> ", I treat it as a recursive definition. Try giving the new value a new name!"
504 , badSelfRecursionHelp "Maybe you DO want a recursive value?" $
505 "To define " <> Help.functionName name <> " we need to know what " <> Help.functionName name
506 <> " is, so let’s expand it. Wait, but now we need to know what " <> Help.functionName name
507 <> " is, so let’s expand it... This will keep going infinitely!"
508 , badSelfRecursionHelp "To really learn what is going on and how to fix it, check out:" $
509 Help.hintLink "bad-recursion"
510 ]
513badSelfRecursionHelp :: Text -> Text -> Doc
514badSelfRecursionHelp intro body =
515 fillSep $
516 map (dullyellow . text) (Text.words intro)
517 ++ map text (Text.words body)
520badMutualRecursion :: Region.Region -> Text -> [Text] -> Report.Report
521badMutualRecursion region name names =
522 let
523 header =
524 Help.functionName name <> " is defined in terms of itself in a sneaky way, causing an infinite loop."
525 in
526 Report.report "BAD RECURSION" (Just region) header $
527 Help.stack
528 [ reflowParagraph $
529 "The following definitions depend directly on each other:"
530 , indent 4 $ Help.drawCycle (name : names)
531 , reflowParagraph $
532 "You seem to have a fairly tricky case, so I very highly recommend reading this: "
533 <> Help.hintLink "bad-recursion"
534 <> " It will help you really understand the problem and how to fix it. Read it!"
535 ]
538defToText :: Canonical.Def -> Text
539defToText (Canonical.Def _ pattern _ _) =
540 error "TODO P.toText" pattern
544-- BAD ALIAS RECURSION
547aliasRecursionReport :: RenderType.Localizer -> N.Name -> [N.Name] -> Type.Raw -> [N.Name] -> Report.Report
548aliasRecursionReport localizer name args tipe others =
549 case others of
550 [] ->
551 Report.report "ALIAS PROBLEM" Nothing
552 "This type alias is recursive, forming an infinite type!"
553 (
554 Help.stack
555 [ reflowParagraph $
556 "When I expand a recursive type alias, it just keeps getting bigger and bigger.\
557 \ So dealiasing results in an infinitely large type! Try this instead:"
558 , indent 4 $
559 RenderType.decl localizer name args [(name, [unsafePromote tipe])]
560 , text $
561 "This is kind of a subtle distinction. I suggested the naive fix, but you can\n"
562 <> "often do something a bit nicer. So I would recommend reading more at:\n"
563 <> Help.hintLink "recursive-alias"
564 ]
565 )
567 _ ->
568 Report.report "ALIAS PROBLEM" Nothing
569 "This type alias is part of a mutually recursive set of type aliases."
570 ( Help.stack
571 [ text "The following type aliases are mutually recursive:"
572 , indent 4 (Help.drawCycle (name:others))
573 , reflowParagraph $
574 "You need to convert at least one `type alias` into a `type`. This is a kind of\
575 \ subtle distinction, so definitely read up on this before you make a fix: "
576 <> Help.hintLink "recursive-alias"
577 ]
578 )
581unsafePromote :: Type.Raw -> Type.Canonical
582unsafePromote (A.A _ rawType) =
583 case rawType of
584 Type.RLambda arg result ->
585 Type.Lambda (unsafePromote arg) (unsafePromote result)
587 Type.RVar x ->
588 Type.Var x
590 Type.RType _ _ name args ->
591 Type.Type (error "TODO unsafePromote better") name (map unsafePromote args)
593 Type.RRecord fields ext ->
594 Type.Record
595 (Map.fromList (map (A.drop *** unsafePromote) fields))
596 (fmap unsafePromote ext)
598 Type.RUnit ->
599 Type.Unit
601 Type.RTuple a b cs ->
602 Type.Tuple
603 (unsafePromote a)
604 (unsafePromote b)
605 (map unsafePromote cs)