git.iko.soy/elk
on master help sign in
Improve canonicalization hints and add JSON decoder hint
commit70865f593b2556a5695e746249117407cb71ed55 authorEvan Czaplicki <evancz@users.noreply.github.com> dateSat 9 Sep 2017, 09:29 (9 years ago) parent5fb0d04
8 files changed+441−326
compare with master
unifiedsplit
src/AST/Variable.hs+6−1 src/Canonicalize/Variable.hs+9−9 src/Reporting/Error/Canonicalize.hs+206−110 src/Reporting/Error/Syntax.hs+1−1 src/Reporting/Error/Type.hs+153−142 src/Reporting/Helpers.hs+10−8 src/Reporting/Report.hs+8−1 src/Type/Unify.hs+48−54
src/AST/Variable.hs+6−1
@@ -9,7 +9,7 @@ module AST.Variable
99 , int, float, char, string, tuple
1010 , list, cons, nil
1111 , bool, true, false
12− , never, task, cmd, sub, router, shader
12+ , never, task, cmd, sub, router, shader, decoder
1313 , isLocalHome, isCons
1414 , is, isJson, isMaybe, isArray, isTask, isList
1515 , isKernel, isTuple, isPrim, isLocal
@@ -192,6 +192,11 @@ shader =
192192 fromModule (ModuleName.Canonical Pkg.webgl "WebGL") "Shader"
193193
194194
195+decoder :: Canonical
196+decoder =
197+ inCore "Json.Decode" "Decoder"
198+
199+
195200
196201-- VARIABLE RECOGNIZERS
197202
src/Canonicalize/Variable.hs+9−9
@@ -68,18 +68,18 @@ variable region env var =
6868 logVar v
6969
7070 Just vs ->
71− preferLocals region env "variable" vs var
71+ preferLocals region env Error.BadValue vs var
7272
7373 Nothing ->
74− notFound region "variable" (Map.keys (Env._values env)) var
74+ notFound region Error.BadValue (Map.keys (Env._values env)) var
7575
7676
7777tvar :: R.Region -> Env.Env -> Text -> Result (Either Var.Canonical (Var.Canonical, [Text], Type.Canonical))
7878tvar region env var =
7979 case unions ++ aliases of
80− [] -> notFound region "type" (Map.keys (Env._unions env) ++ Map.keys (Env._aliases env)) var
80+ [] -> notFound region Error.BadType (Map.keys (Env._unions env) ++ Map.keys (Env._aliases env)) var
8181 [v] -> logVarWith extract v
82− vs -> preferLocals' region env extract "type" vs var
82+ vs -> preferLocals' region env extract Error.BadType vs var
8383 where
8484 unions =
8585 map Left (maybe [] Set.toList (Map.lookup var (Env._unions env)))
@@ -100,10 +100,10 @@ pvar region env var actualArgs =
100100 foundArgCheck value
101101
102102 Just values ->
103− foundArgCheck =<< preferLocals' region env fst "pattern" values var
103+ foundArgCheck =<< preferLocals' region env fst Error.BadPattern values var
104104
105105 Nothing ->
106− notFound region "pattern" (Map.keys (Env._patterns env)) var
106+ notFound region Error.BadPattern (Map.keys (Env._patterns env)) var
107107 where
108108 foundArgCheck (name, expectedArgs) =
109109 if actualArgs == expectedArgs then
@@ -117,7 +117,7 @@ pvar region env var actualArgs =
117117-- FOUND
118118
119119
120−preferLocals :: R.Region -> Env.Env -> Text -> [Var.Canonical] -> Text -> Result Var.Canonical
120+preferLocals :: R.Region -> Env.Env -> Error.VarKind -> [Var.Canonical] -> Text -> Result Var.Canonical
121121preferLocals region env =
122122 preferLocals' region env id
123123
@@ -126,7 +126,7 @@ preferLocals'
126126 :: R.Region
127127 -> Env.Env
128128 -> (a -> Var.Canonical)
129− -> Text
129+ -> Error.VarKind
130130 -> [a]
131131 -> Text
132132 -> Result a
@@ -217,7 +217,7 @@ isOp name =
217217-- NOT FOUND
218218
219219
220−notFound :: R.Region -> Text -> [Text] -> Text -> Result a
220+notFound :: R.Region -> Error.VarKind -> [Text] -> Text -> Result a
221221notFound region kind possibilities var =
222222 let name =
223223 toVarName var
src/Reporting/Error/Canonicalize.hs+206−110
@@ -1,6 +1,20 @@
11{-# OPTIONS_GHC -Wall #-}
22{-# LANGUAGE OverloadedStrings #-}
3−module Reporting.Error.Canonicalize where
3+module Reporting.Error.Canonicalize
4+ ( Error(..)
5+ , variable
6+ , VarKind(..)
7+ , VarProblem(..)
8+ , argMismatch
9+ , moduleNotFound
10+ , valueNotFound
11+ , AliasError(..)
12+ , alias
13+ , port
14+ , toReport
15+ , extractSuggestions
16+ )
17+ where
418
519import Control.Arrow ((***))
620import qualified Data.Char as Char
@@ -9,6 +23,7 @@ import Data.Text (Text)
923
1024import qualified AST.Declaration as Decl
1125import qualified AST.Expression.Canonical as Canonical
26+import qualified AST.Helpers as Help (isOp)
1227import qualified AST.Module.Name as ModuleName
1328import qualified AST.Pattern as P
1429import qualified AST.Type as Type
@@ -18,9 +33,7 @@ import qualified Reporting.Region as Region
1833import qualified Reporting.Render.Type as RenderType
1934import qualified Reporting.Report as Report
2035import qualified Reporting.Helpers as Help
21−import Reporting.Helpers
22− ( Doc, (<>), dullyellow, fillSep, i2t, indent, reflowParagraph, text
23− )
36+import Reporting.Helpers ( Doc, (<>), dullyellow, fillSep, green, i2t, indent, reflowParagraph, text )
2437
2538
2639
@@ -46,26 +59,52 @@ data Error
4659
4760data VarError =
4861 VarError
49− { varKind :: Text
50− , varName :: Text
51− , varProblem :: VarProblem
52− , varSuggestions :: [Text]
62+ { _kind :: VarKind
63+ , _name :: Text
64+ , _problem :: VarProblem
65+ , _suggestions :: [Text]
5366 }
5467
5568
5669data VarProblem
57− = Ambiguous
58− | UnknownQualifier Text Text
59− | QualifiedUnknown Text Text
60− | ExposedUnknown
70+ = Ambiguous
71+ | UnknownQualifier Text Text
72+ | QualifiedUnknown Text Text
73+ | ExposedUnknown
6174
6275
63−variable :: Text -> Text -> VarProblem -> [Text] -> Error
76+variable :: VarKind -> Text -> VarProblem -> [Text] -> Error
6477variable kind name problem suggestions =
6578 Var (VarError kind name problem suggestions)
6679
6780
6881
82+-- KIND
83+
84+
85+data VarKind
86+ = BadValue
87+ | BadPattern
88+ | BadType
89+
90+
91+toKindInfo :: VarKind -> Text -> ( Doc, Doc, Doc )
92+toKindInfo kind name =
93+ case kind of
94+ BadValue ->
95+ if Help.isOp name then
96+ ( "an", "operator", text $ "(" <> name <> ")" )
97+ else
98+ ( "a", "value", text name )
99+
100+ BadPattern ->
101+ ( "a", "pattern", text name )
102+
103+ BadType ->
104+ ( "a", "type", text name )
105+
106+
107+
69108-- PATTERN
70109
71110
@@ -118,9 +157,9 @@ alias name expected actual =
118157
119158data PortError =
120159 PortError
121− { portName :: Text
122− , portType :: Type.Canonical
123− , portMessage :: Maybe Text
160+ { _portName :: Text
161+ , _portType :: Type.Canonical
162+ , _portMessage :: Maybe Text
124163 }
125164
126165
@@ -130,54 +169,57 @@ port name tipe maybeMessage =
130169
131170
132171
172+-- EXTRACT SUGGESTIONS
173+
174+
175+extractSuggestions :: Error -> Maybe [Text]
176+extractSuggestions err =
177+ case err of
178+ Var (VarError _ _ _ suggestions) ->
179+ Just suggestions
180+
181+ BadRecursion _ _ _ ->
182+ Nothing
183+
184+ BadInfix _ _ _ _ _ _ ->
185+ Nothing
186+
187+ Pattern _ ->
188+ Nothing
189+
190+ Alias _ ->
191+ Nothing
192+
193+ Import _ importError ->
194+ case importError of
195+ ModuleNotFound suggestions ->
196+ Just (map ModuleName.toText suggestions)
197+
198+ ValueNotFound _ suggestions ->
199+ Just suggestions
200+
201+ Export _ suggestions ->
202+ Just suggestions
203+
204+ DuplicateExport _ ->
205+ Nothing
206+
207+ Port _ ->
208+ Nothing
209+
210+ BadPort _ _ ->
211+ Nothing
212+
213+
214+
133215-- TO REPORT
134216
135217
136218toReport :: RenderType.Localizer -> Error -> Report.Report
137219toReport localizer err =
138220 case err of
139− Var (VarError kind name problem suggestions) ->
140− let
141− variableName =
142− kind <> " `" <> name <> "`"
143−
144− learnMore orMaybe =
145− Help.reflowParagraph $
146− orMaybe <> " `import` works different than you expect? Learn all about it here: "
147− <> Help.hintLink "imports"
148−
149− namingError overview maybeStarter specializedSuggestions =
150− Report.report "NAMING ERROR" Nothing overview $
151− case Help.maybeYouWant' maybeStarter specializedSuggestions of
152− Nothing ->
153− learnMore "Maybe"
154− Just doc ->
155− Help.stack [ doc, learnMore "Or maybe" ]
156− in
157− case problem of
158− Ambiguous ->
159− namingError
160− ("This usage of " <> variableName <> " is ambiguous.")
161− Nothing
162− suggestions
163−
164− UnknownQualifier qualifier localName ->
165− namingError
166− ("Cannot find " <> variableName)
167− (Just $ text $ "No module called `" <> qualifier <> "` has been imported.")
168− (map (\modul -> modul <> "." <> localName) suggestions)
169−
170− QualifiedUnknown qualifier localName ->
171− namingError
172− ("Cannot find " <> variableName)
173− (Just $ text $ "`" <> qualifier <> "` does not expose `" <> localName <> "`.")
174− (map (\v -> qualifier <> "." <> v) suggestions)
175−
176− ExposedUnknown ->
177− namingError
178− ("Cannot find " <> variableName)
179− Nothing
180− suggestions
221+ Var varError ->
222+ varErrorToReport varError
181223
182224 BadRecursion region def defs ->
183225 case defs of
@@ -302,78 +344,111 @@ toReport localizer err =
302344 )
303345
304346
305−argMismatchReport :: Text -> Var.Canonical -> Int -> Int -> Report.Report
306−argMismatchReport kind var expected actual =
347+
348+-- VAR ERROR
349+
350+
351+varErrorToReport :: VarError -> Report.Report
352+varErrorToReport (VarError kind name problem suggestions) =
307353 let
308− numArgs =
309− "too "
310− <> (if actual < expected then "few" else "many")
311− <> " arguments"
354+ learnMore orMaybe =
355+ Help.reflowParagraph $
356+ orMaybe <> " `import` works different than you expect? Learn all about it here: "
357+ <> Help.hintLink "imports"
358+
359+ namingError overview maybeStarter specializedSuggestions =
360+ Report.reportDoc "NAMING ERROR" Nothing overview $
361+ case Help.maybeYouWant' maybeStarter specializedSuggestions of
362+ Nothing ->
363+ learnMore "Maybe"
364+ Just doc ->
365+ Help.stack [ doc, learnMore "Or maybe" ]
366+
367+ specialNamingError specialHint =
368+ Report.reportDoc "NAMING ERROR" Nothing (cannotFind kind name) (Help.hsep specialHint)
312369 in
313− Report.report
314− (Text.map Char.toUpper numArgs)
315− Nothing
316− ( kind <> " " <> Var.toText var <> " has " <> numArgs <> "."
317− )
318− ( text $
319− "Expecting " <> i2t expected <> ", but got " <> i2t actual <> "."
320− )
370+ case problem of
371+ Ambiguous ->
372+ namingError (ambiguous kind name) Nothing suggestions
321373
374+ UnknownQualifier qualifier localName ->
375+ namingError
376+ (cannotFind kind name)
377+ (Just $ text $ "No module called `" <> qualifier <> "` has been imported.")
378+ (map (\modul -> modul <> "." <> localName) suggestions)
322379
380+ QualifiedUnknown qualifier localName ->
381+ namingError
382+ (cannotFind kind name)
383+ (Just $ text $ "`" <> qualifier <> "` does not expose `" <> localName <> "`.")
384+ (map (\v -> qualifier <> "." <> v) suggestions)
323385
324−extractSuggestions :: Error -> Maybe [Text]
325−extractSuggestions err =
326− case err of
327− Var (VarError _ _ _ suggestions) ->
328− Just suggestions
386+ ExposedUnknown ->
387+ case name of
388+ "!=" -> specialNamingError (notEqualsHint name)
389+ "!==" -> specialNamingError (notEqualsHint name)
390+ "===" -> specialNamingError equalsHint
391+ "%" -> specialNamingError modHint
392+ _ -> namingError (cannotFind kind name) Nothing suggestions
329393
330− BadRecursion _ _ _ ->
331− Nothing
332394
333− BadInfix _ _ _ _ _ _ ->
334− Nothing
395+cannotFind :: VarKind -> Text -> [Doc]
396+cannotFind kind rawName =
397+ let ( a, thing, name ) = toKindInfo kind rawName in
398+ [ "Cannot", "find", a, thing, "named", dullyellow name <> ":" ]
335399
336− Pattern _ ->
337− Nothing
338400
339− Alias _ ->
340− Nothing
401+ambiguous :: VarKind -> Text -> [Doc]
402+ambiguous kind rawName =
403+ let ( _a, thing, name ) = toKindInfo kind rawName in
404+ [ "This", "usage", "of", "the", dullyellow name, thing, "is", "ambiguous." ]
341405
342− Import _ importError ->
343− case importError of
344− ModuleNotFound suggestions ->
345− Just (map ModuleName.toText suggestions)
346406
347− ValueNotFound _ suggestions ->
348− Just suggestions
407+notEqualsHint :: Text -> [Doc]
408+notEqualsHint op =
409+ [ "Looking", "for", "the", "“not", "equal”", "operator?", "The", "traditional"
410+ , dullyellow $ text $ "(" <> op <> ")"
411+ , "is", "replaced", "by", green "(/=)", "in", "Elm.", "It", "is", "meant"
412+ , "to", "look", "like", "the", "“not", "equal”", "sign", "from", "math!", "(≠)"
413+ ]
349414
350− Export _ suggestions ->
351− Just suggestions
352415
353− DuplicateExport _ ->
354− Nothing
416+equalsHint :: [Doc]
417+equalsHint =
418+ [ "A", "special", dullyellow "(===)", "operator", "is", "not", "needed"
419+ , "in", "Elm.", "We", "use", green "(==)", "for", "everything!"
420+ ]
355421
356− Port _ ->
357− Nothing
358422
359− BadPort _ _ ->
360− Nothing
423+modHint :: [Doc]
424+modHint =
425+ [ "Rather", "than", "a", dullyellow "(%)", "operator,"
426+ , "Elm", "has", "a", green "modBy", "function."
427+ , "Learn", "more", "here:"
428+ , "<https://package.elm-lang.org/packages/elm-lang/core/latest/Basics#modBy>"
429+ ]
361430
362431
363−unsafePromote :: Type.Raw -> Type.Canonical
364−unsafePromote (A.A _ rawType) =
365− case rawType of
366− Type.RLambda arg result ->
367− Type.Lambda (unsafePromote arg) (unsafePromote result)
368432
369− Type.RVar x ->
370− Type.Var x
433+-- ARG MISMATCH
371434
372− Type.RType (A.A _ (Var.Raw name)) args ->
373− Type.Type (Var.local name) (map unsafePromote args)
374435
375− Type.RRecord fields ext ->
376− Type.Record (map (A.drop *** unsafePromote) fields) (fmap unsafePromote ext)
436+argMismatchReport :: Text -> Var.Canonical -> Int -> Int -> Report.Report
437+argMismatchReport kind var expected actual =
438+ let
439+ numArgs =
440+ "too "
441+ <> (if actual < expected then "few" else "many")
442+ <> " arguments"
443+ in
444+ Report.report
445+ (Text.map Char.toUpper numArgs)
446+ Nothing
447+ ( kind <> " " <> Var.toText var <> " has " <> numArgs <> "."
448+ )
449+ ( text $
450+ "Expecting " <> i2t expected <> ", but got " <> i2t actual <> "."
451+ )
377452
378453
379454
@@ -429,3 +504,24 @@ badMutualRecursion region name names =
429504defToText :: Canonical.Def -> Text
430505defToText (Canonical.Def _ pattern _ _) =
431506 P.toText pattern
507+
508+
509+
510+-- TYPE COERCION
511+
512+
513+unsafePromote :: Type.Raw -> Type.Canonical
514+unsafePromote (A.A _ rawType) =
515+ case rawType of
516+ Type.RLambda arg result ->
517+ Type.Lambda (unsafePromote arg) (unsafePromote result)
518+
519+ Type.RVar x ->
520+ Type.Var x
521+
522+ Type.RType (A.A _ (Var.Raw name)) args ->
523+ Type.Type (Var.local name) (map unsafePromote args)
524+
525+ Type.RRecord fields ext ->
526+ Type.Record (map (A.drop *** unsafePromote) fields) (fmap unsafePromote ext)
527+
src/Reporting/Error/Syntax.hs+1−1
@@ -635,7 +635,7 @@ escapeProblemToReport escapeProblem =
635635 ( "A backslash starts an escaped character, but I do not recognize this one:"
636636 , Help.stack
637637 [ "Maybe there is some typo?"
638− , Help.toHint $ "Valid escape characters include:"
638+ , Help.toSimpleHint "Valid escape characters include:"
639639 , Help.indent 4 $ Help.vcat $
640640 [ "\\n"
641641 , "\\t"
src/Reporting/Error/Type.hs+153−142
@@ -10,11 +10,11 @@ module Reporting.Error.Type
1010 )
1111 where
1212
13−import Control.Arrow (first, second)
13+import Control.Arrow (second)
1414import qualified Data.Map as Map
15−import qualified Data.Maybe as Maybe
1615import qualified Data.Text as Text
1716import Data.Text (Text)
17+import Data.Monoid ((<>))
1818
1919import qualified AST.Helpers as Help
2020import qualified AST.Type as Type
@@ -24,8 +24,8 @@ import qualified Reporting.Render.Type as RenderType
2424import qualified Reporting.Report as Report
2525import qualified Reporting.Helpers as Help
2626import Reporting.Helpers
27− ( Doc, (<>), (<+>), capitalize, dullyellow, functionName
28− , i2t, indent, ordinalize, reflowParagraph, stack, text, toHint, vcat
27+ ( Doc, (<+>), capitalize, dullyellow, functionName, i2t
28+ , indent, ordinalize, reflowParagraph, stack, text
2929 )
3030
3131
@@ -34,30 +34,32 @@ import Reporting.Helpers
3434
3535
3636data Error
37− = Mismatch Mismatch
38− | BadMain Type.Canonical
39− | BadFlags Type.Canonical (Maybe Text)
40− | InfiniteType (Either Hint Text) Type.Canonical
37+ = Mismatch Mismatch
38+ | BadMain Type.Canonical
39+ | BadFlags Type.Canonical (Maybe Text)
40+ | InfiniteType (Either Hint Text) Type.Canonical
4141
4242
43−data Mismatch = MismatchInfo
43+data Mismatch =
44+ MismatchInfo
4445 { _hint :: Hint
4546 , _leftType :: Type.Canonical
4647 , _rightType :: Type.Canonical
48+ , _decoders :: Bool
4749 , _reason :: Maybe Reason
4850 }
4951
5052
5153data Reason
52− = BadFields [(Text, Maybe Reason)]
53− | MessyFields [Text] [Text] [Text]
54− | IntFloat
55− | TooLongComparableTuple Int
56− | MissingArgs Int
57− | RigidClash Text Text
58− | NotPartOfSuper Type.Super
59− | RigidVarTooGeneric Text SpecificThing
60− | RigidSuperTooGeneric Type.Super Text SpecificThing
54+ = BadFields [(Text, Maybe Reason)]
55+ | MessyFields [Text] [Text] [Text]
56+ | IntFloat
57+ | TooLongComparableTuple Int
58+ | MissingArgs Int
59+ | RigidClash Text Text
60+ | NotPartOfSuper Type.Super
61+ | RigidVarTooGeneric Text SpecificThing
62+ | RigidSuperTooGeneric Type.Super Text SpecificThing
6163
6264
6365data SpecificThing
@@ -68,39 +70,39 @@ data SpecificThing
6870
6971
7072data Hint
71− = CaseBranch Int Region.Region
72− | Case
73− | IfCondition
74− | IfBranches
75− | MultiIfBranch Int Region.Region
76− | If
77− | List
78− | ListElement Int Region.Region
79− | BinopLeft Var.Canonical Region.Region
80− | BinopRight Var.Canonical Region.Region
81− | Binop Var.Canonical
82− | Function (Maybe Var.Canonical)
83− | UnexpectedArg (Maybe Var.Canonical) Int Int Region.Region
84− | FunctionArity (Maybe Var.Canonical) Int Int Region.Region
85− | ReturnType Text Int Int Region.Region
86− | Instance Text
87− | Literal Text
88− | Pattern Pattern
89− | Shader
90− | Lambda
91− | Access (Maybe Text) Text
92− | Record
93− -- effect manager problems
94− | Manager Text
95− | State Text
96− | SelfMsg
73+ = CaseBranch Int Region.Region
74+ | Case
75+ | IfCondition
76+ | IfBranches
77+ | MultiIfBranch Int Region.Region
78+ | If
79+ | List
80+ | ListElement Int Region.Region
81+ | BinopLeft Var.Canonical Region.Region
82+ | BinopRight Var.Canonical Region.Region
83+ | Binop Var.Canonical
84+ | Function (Maybe Var.Canonical)
85+ | UnexpectedArg (Maybe Var.Canonical) Int Int Region.Region
86+ | FunctionArity (Maybe Var.Canonical) Int Int Region.Region
87+ | ReturnType Text Int Int Region.Region
88+ | Instance Text
89+ | Literal Text
90+ | Pattern Pattern
91+ | Shader
92+ | Lambda
93+ | Access (Maybe Text) Text
94+ | Record
95+ -- effect manager problems
96+ | Manager Text
97+ | State Text
98+ | SelfMsg
9799
98100
99101data Pattern
100− = PVar Text
101− | PAlias Text
102− | PCtor Var.Canonical
103− | PRecord
102+ = PVar Text
103+ | PAlias Text
104+ | PCtor Var.Canonical
105+ | PRecord
104106
105107
106108
@@ -155,17 +157,18 @@ toReport localizer err =
155157
156158
157159mismatchToReport :: RenderType.Localizer -> Mismatch -> Report.Report
158−mismatchToReport localizer (MismatchInfo hint leftType rightType maybeReason) =
160+mismatchToReport localizer (MismatchInfo hint leftType rightType decoders maybeReason) =
159161 let
160162 report =
161163 Report.report "TYPE MISMATCH"
162164
163165 typicalHints =
164− Maybe.maybeToList (reasonToString =<< maybeReason)
166+ maybe id (:) (reasonToDoc <$> maybeReason) $
167+ if decoders then [ jsonDecoderHint ] else []
165168
166169 cmpHint leftWords rightWords extraHints =
167170 comparisonHint localizer leftType rightType leftWords rightWords
168− (typicalHints <> map toHint extraHints)
171+ (typicalHints <> map Help.toSimpleHint extraHints)
169172 in
170173 case hint of
171174 CaseBranch branchNumber region ->
@@ -548,6 +551,8 @@ mismatchToReport localizer (MismatchInfo hint leftType rightType maybeReason) =
548551
549552
550553
554+-- COMPARISON HINT
555+
551556
552557comparisonHint
553558 :: RenderType.Localizer
@@ -573,6 +578,17 @@ comparisonHint localizer leftType rightType leftWords rightWords finalHints =
573578
574579
575580
581+-- JSON DECODER HINT
582+
583+
584+jsonDecoderHint :: Doc
585+jsonDecoderHint =
586+ Help.toSimpleHint $
587+ "New to JSON decoders? They are tough at first, so DEFINITELY learn more here: "
588+ <> Help.hintLink "json-decoders"
589+
590+
591+
576592-- BINOP HINTS
577593
578594
@@ -709,62 +725,64 @@ flipReason reason =
709725 RigidSuperTooGeneric super name specific
710726
711727
712−reasonToString :: Reason -> Maybe Doc
713−reasonToString reason =
714− let
715− (fields, maybeDeepReason) =
716− collectFields reason
717−
718− maybeDocs =
719− reasonToStringHelp =<< maybeDeepReason
720−
721− starter =
722− case fields of
723− [] ->
724− Nothing
728+reasonToDoc :: Reason -> Doc
729+reasonToDoc reason =
730+ case collectFields reason of
731+ Nothing ->
732+ let
733+ (firstLine, details) =
734+ reasonToDocHelp reason
735+ in
736+ Help.vcat $ Help.toSimpleHint firstLine : map (indent 4) details
725737
726− [field] ->
727− Just $ "Problem in the `" <> field <> "` field. "
738+ Just (fields, maybeDeepReason) ->
739+ let
740+ recordHint elaboration =
741+ [ "Problem", "in", "the", dullyellow (text (Text.intercalate "." fields)) <> "field." ]
742+ ++
743+ map text (Text.words elaboration)
744+ in
745+ case reasonToDocHelp <$> maybeDeepReason of
746+ Nothing ->
747+ Help.toFancyHint (recordHint badFieldElaboration)
728748
729− _ ->
730− Just $ "Problem at `" <> Text.intercalate "." fields <> "`. "
731− in
732− case (starter, maybeDocs) of
733− (Nothing, Nothing) ->
734− Nothing
749+ Just (firstLine, details) ->
750+ Help.vcat $ Help.toFancyHint (recordHint firstLine) : map (indent 4) details
735751
736− (Just msg, Nothing) ->
737− Just $ toHint (msg <> badFieldElaboration)
738752
739− (_, Just (firstLine, docs)) ->
740− Just $ vcat $
741− toHint (maybe firstLine (<> firstLine) starter)
742− : map (indent 4) docs
743753
754+-- COLLECT FIELDS
744755
745756
746−collectFields :: Reason -> ([Text], Maybe Reason)
757+collectFields :: Reason -> Maybe ([Text], Maybe Reason)
747758collectFields reason =
748759 case reason of
749− BadFields [(field, Nothing)] ->
750− ([field], Nothing)
760+ BadFields [(field, maybeReason)] ->
761+ Just (collectFieldsHelp [field] maybeReason)
762+
763+ _ ->
764+ Nothing
751765
752− BadFields [(field, Just subReason)] ->
753− first (field:) (collectFields subReason)
766+
767+collectFieldsHelp :: [Text] -> Maybe Reason -> ([Text], Maybe Reason)
768+collectFieldsHelp revFields maybeReason =
769+ case maybeReason of
770+ Just (BadFields [(field, deeperReason)]) ->
771+ collectFieldsHelp (field : revFields) deeperReason
754772
755773 _ ->
756− ([], Just reason)
774+ ( reverse revFields, maybeReason )
757775
758776
759−reasonToStringHelp :: Reason -> Maybe (Text, [Doc])
760−reasonToStringHelp reason =
777+reasonToDocHelp :: Reason -> (Text, [Doc])
778+reasonToDocHelp reason =
761779 let
762− go msg =
763− Just (msg, [])
780+ simpleDoc msg =
781+ ( msg, [] )
764782 in
765783 case reason of
766784 BadFields fields ->
767− go $
785+ simpleDoc $
768786 "I am seeing issues with the "
769787 <> Help.commaSep (map fst fields) <> " fields. "
770788 <> badFieldElaboration
@@ -773,22 +791,22 @@ reasonToStringHelp reason =
773791 messyFieldsHelp both leftOnly rightOnly
774792
775793 IntFloat ->
776− go $
794+ simpleDoc $
777795 "Elm does not automatically convert between Ints and Floats. Use\
778796 \ `toFloat` and `round` to do specific conversions.\
779797 \ <http://package.elm-lang.org/packages/elm-lang/core/latest/Basics#toFloat>"
780798
781799 TooLongComparableTuple len ->
782− go $
800+ simpleDoc $
783801 "Although tuples are comparable, this is currently only supported\
784802 \ for tuples with 6 or fewer entries, not " <> i2t len <> "."
785803
786804 MissingArgs num ->
787− go $
805+ simpleDoc $
788806 "It looks like a function needs " <> Help.moreArgs num <> "."
789807
790808 RigidClash name1 name2 ->
791− go $
809+ simpleDoc $
792810 "Your type annotation uses `" <> name1 <> "` and `" <> name2 <>
793811 "` as DIFFERENT type variables. By using separate names, you are\
794812 \ claiming the values can be different, but the code suggests that\
@@ -798,31 +816,31 @@ reasonToStringHelp reason =
798816 <> Help.hintLink "type-annotations"
799817
800818 NotPartOfSuper Type.Number ->
801− go "Only ints and floats are numbers."
819+ simpleDoc "Only ints and floats are numbers."
802820
803821 NotPartOfSuper Type.Comparable ->
804− go "Only ints, floats, chars, strings, lists, and tuples are comparable."
822+ simpleDoc "Only ints, floats, chars, strings, lists, and tuples are comparable."
805823
806824 NotPartOfSuper Type.Appendable ->
807− go "Only strings and lists are appendable."
825+ simpleDoc "Only strings and lists are appendable."
808826
809827 NotPartOfSuper Type.CompAppend ->
810− go "Only strings and lists are both comparable and appendable."
828+ simpleDoc "Only strings and lists are both comparable and appendable."
811829
812830 RigidVarTooGeneric name specific ->
813− go $ rigidTooGenericHelp "ANY type of value" name specific
831+ simpleDoc $ rigidTooGenericHelp "ANY type of value" name specific
814832
815833 RigidSuperTooGeneric Type.Number name specific ->
816− go $ rigidTooGenericHelp "BOTH Ints and Floats" name specific
834+ simpleDoc $ rigidTooGenericHelp "BOTH Ints and Floats" name specific
817835
818836 RigidSuperTooGeneric Type.Comparable name specific ->
819− go $ rigidTooGenericHelp "ANY comparable value" name specific
837+ simpleDoc $ rigidTooGenericHelp "ANY comparable value" name specific
820838
821839 RigidSuperTooGeneric Type.Appendable name specific ->
822− go $ rigidTooGenericHelp "BOTH Strings and Lists" name specific
840+ simpleDoc $ rigidTooGenericHelp "BOTH Strings and Lists" name specific
823841
824842 RigidSuperTooGeneric Type.CompAppend name specific ->
825− go $ rigidTooGenericHelp "Strings and ANY comparable List" name specific
843+ simpleDoc $ rigidTooGenericHelp "Strings and ANY comparable List" name specific
826844
827845
828846rigidTooGenericHelp :: Text -> Text -> SpecificThing -> Text
@@ -869,11 +887,11 @@ specificThingToText specific =
869887badFieldElaboration :: Text
870888badFieldElaboration =
871889 "I always figure out field types in alphabetical order. If a field\
872− \ seems fine, I assume it is \"correct\" in subsequent checks.\
890+ \ seems fine, I assume it is “correct” in subsequent checks.\
873891 \ So the problem may actually be a weird interaction with previous fields."
874892
875893
876−messyFieldsHelp :: [Text] -> [Text] -> [Text] -> Maybe (Text, [Doc])
894+messyFieldsHelp :: [Text] -> [Text] -> [Text] -> (Text, [Doc])
877895messyFieldsHelp both leftOnly rightOnly =
878896 case (leftOnly, rightOnly) of
879897 ([], [missingField]) ->
@@ -899,62 +917,55 @@ messyFieldsHelp both leftOnly rightOnly =
899917 pairs
900918 in
901919 if null typoPairs then
902− Just
903− ( "The record fields do not match up. One has "
904− <> Help.commaSep leftOnly <> ". The other has "
905− <> Help.commaSep rightOnly <> "."
906− , []
907− )
920+ ( "The record fields do not match up. One has "
921+ <> Help.commaSep leftOnly <> ". The other has "
922+ <> Help.commaSep rightOnly <> "."
923+ , []
924+ )
908925
909926 else
910− Just
911− ( "The record fields do not match up. Maybe you made one of these typos?"
912− , typoDocs "<->" typoPairs
913− )
927+ ( "The record fields do not match up. Maybe you made one of these typos?"
928+ , typoDocs "<->" typoPairs
929+ )
914930
915931
916−oneMissingField :: [Text] -> Text -> Maybe (Text, [Doc])
932+oneMissingField :: [Text] -> Text -> ( Text, [Doc] )
917933oneMissingField knownFields missingField =
918934 case Help.findPotentialTypos knownFields missingField of
919935 [] ->
920− Just
921− ( "Looks like a record is missing the `" <> missingField <> "` field."
922− , []
923− )
936+ ( "Looks like a record is missing the `" <> missingField <> "` field."
937+ , []
938+ )
924939
925940 [typo] ->
926− Just
927− ( "Looks like a record is missing the `" <> missingField
928− <> "` field. Maybe it is a typo?"
929− , typoDocs "->" [(missingField, typo)]
930− )
941+ ( "Looks like a record is missing the `" <> missingField
942+ <> "` field. Maybe it is a typo?"
943+ , typoDocs "->" [(missingField, typo)]
944+ )
931945
932946 typos ->
933− Just
934− ( "Looks like a record is missing the `" <> missingField
935− <> "` field. It is close to names like "
936− <> Help.commaSep typos <> " so maybe it is a typo?"
937− , []
938− )
947+ ( "Looks like a record is missing the `" <> missingField
948+ <> "` field. It is close to names like "
949+ <> Help.commaSep typos <> " so maybe it is a typo?"
950+ , []
951+ )
939952
940953
941−manyMissingFields :: [Text] -> [Text] -> Maybe (Text, [Doc])
954+manyMissingFields :: [Text] -> [Text] -> (Text, [Doc])
942955manyMissingFields knownFields missingFields =
943956 case Help.findTypoPairs missingFields knownFields of
944957 [] ->
945− Just
946− ( "Looks like a record is missing these fields: "
947− <> Help.commaSep missingFields
948− , []
949− )
958+ ( "Looks like a record is missing these fields: "
959+ <> Help.commaSep missingFields
960+ , []
961+ )
950962
951963 typoPairs ->
952− Just
953− ( "Looks like a record is missing these fields: "
954− <> Help.commaSep missingFields
955− <> ". Potential typos include:"
956− , typoDocs "->" typoPairs
957− )
964+ ( "Looks like a record is missing these fields: "
965+ <> Help.commaSep missingFields
966+ <> ". Potential typos include:"
967+ , typoDocs "->" typoPairs
968+ )
958969
959970
960971typoDocs :: Text -> [(Text, Text)] -> [Doc]
src/Reporting/Helpers.hs+10−8
@@ -8,7 +8,8 @@ module Reporting.Helpers
88 -- custom helpers
99 , i2t
1010 , functionName, args, moreArgs
11− , toHint, hintLink, stack, reflowParagraph
11+ , toSimpleHint, toFancyHint, hintLink
12+ , stack, reflowParagraph
1213 , commaSep, capitalize, ordinalize, drawCycle
1314 , findPotentialTypos, findTypoPairs, vetTypos
1415 , nearbyNames, distance, maybeYouWant, maybeYouWant'
@@ -81,13 +82,14 @@ moreArgs n =
8182-- HINTS
8283
8384
84−toHint :: Text -> Doc
85−toHint txt =
86− let
87− hint =
88− underline (text "Hint") <> ":"
89− in
90− fillSep (hint : map text (Text.words txt))
85+toSimpleHint :: Text -> Doc
86+toSimpleHint txt =
87+ toFancyHint (map text (Text.words txt))
88+
89+
90+toFancyHint :: [Doc] -> Doc
91+toFancyHint chunks =
92+ fillSep (underline (text "Hint") <> ":" : chunks)
9193
9294
9395hintLink :: Text -> Text
src/Reporting/Report.hs+8−1
@@ -3,6 +3,7 @@
33module Reporting.Report
44 ( Report
55 , report
6+ , reportDoc
67 , toDoc
78 , toJson
89 )
@@ -23,7 +24,8 @@ import qualified Reporting.Render.Code as Code
2324-- BUILD REPORTS
2425
2526
26−data Report = Report
27+data Report =
28+ Report
2729 { _title :: Text
2830 , _highlight :: Maybe R.Region
2931 , _preHint :: Doc
@@ -36,6 +38,11 @@ report title highlight pre post =
3638 Report title highlight (Help.reflowParagraph pre) post
3739
3840
41+reportDoc :: Text -> Maybe R.Region -> [Doc] -> Doc -> Report
42+reportDoc title highlight pre post =
43+ Report title highlight (Help.hsep pre) post
44+
45+
3946
4047-- REPORT TO JSON
4148
src/Type/Unify.hs+48−54
@@ -19,7 +19,7 @@ import qualified Type.UnionFind as UF
1919
2020
2121
22−-- KICK OFF UNIFICATION
22+-- UNIFY
2323
2424
2525unify :: Error.Hint -> R.Region -> Variable -> Variable -> TS.Solver ()
@@ -36,13 +36,9 @@ unify hint region expected actual =
3636 liftIO $ mergeHelp expected actual (Error "?") noRank
3737 TS.addError region $
3838 case problem of
39− Typical ->
39+ Reason hasDecoder maybeReason ->
4040 Error.Mismatch $
41− Error.MismatchInfo hint expectedSrcType actualSrcType Nothing
42−
43− Special reason ->
44− Error.Mismatch $
45− Error.MismatchInfo hint expectedSrcType actualSrcType (Just reason)
41+ Error.MismatchInfo hint expectedSrcType actualSrcType hasDecoder maybeReason
4642
4743 Infinite ->
4844 Error.InfiniteType (Left hint) expectedSrcType
@@ -66,7 +62,9 @@ data Context =
6662 }
6763
6864
69−data Orientation = ExpectedActual | ActualExpected
65+data Orientation
66+ = ExpectedActual
67+ | ActualExpected
7068
7169
7270reorient :: Context -> Context
@@ -85,8 +83,7 @@ reorient (Context orientation var1 desc1 var2 desc2) =
8583
8684
8785data Problem
88− = Typical
89− | Special Error.Reason
86+ = Reason Bool (Maybe Error.Reason)
9087 | Infinite
9188
9289
@@ -95,34 +92,49 @@ mismatch context@(Context orientation var1 _ var2 _) maybeReason =
9592 do anyInfinite <- liftIO $ liftM2 (||) (Occurs.occurs var1) (Occurs.occurs var2)
9693 when anyInfinite $ throwError Infinite
9794
98− args1 <- liftIO $ collectArgs var1
99− args2 <- liftIO $ collectArgs var2
95+ args1 <- liftIO $ collectArgs [] var1
96+ args2 <- liftIO $ collectArgs [] var2
10097
101− let numArgs1 = length args1
102− let numArgs2 = length args2
98+ hasDecoder <- liftIO $ or <$> traverse detectDecoder (args1 ++ args2)
10399
104− if numArgs1 == numArgs2
100+ if length args1 /= length args2
105101 then
106− throwError $ reasonToProblem orientation maybeReason
107− else
108102 do lift $ zipWithM_ (\a1 a2 -> runExceptT $ subUnify context a1 a2) args1 args2
109− throwError $ reasonToProblem orientation $ Just $
110− Error.MissingArgs $ abs (numArgs2 - numArgs1)
103+ throwError $ Reason hasDecoder $ Just $
104+ Error.MissingArgs (abs (length args2 - length args1))
105+ else
106+ throwError $ Reason hasDecoder $
107+ case orientation of
108+ ExpectedActual ->
109+ maybeReason
111110
111+ ActualExpected ->
112+ fmap Error.flipReason maybeReason
112113
113−reasonToProblem :: Orientation -> Maybe Error.Reason -> Problem
114−reasonToProblem orientation maybeReason =
115− case maybeReason of
116− Nothing ->
117− Typical
118114
119− Just reason ->
120− case orientation of
121− ExpectedActual ->
122− Special reason
123115
124− ActualExpected ->
125− Special (Error.flipReason reason)
116+
117+
118+collectArgs :: [Variable] -> Variable -> IO [Variable]
119+collectArgs revArgs variable =
120+ do (Descriptor content _ _ _) <- UF.descriptor variable
121+ case content of
122+ Structure (Fun1 arg returnType) ->
123+ collectArgs (arg : revArgs) returnType
124+
125+ _ ->
126+ return $ variable : revArgs
127+
128+
129+detectDecoder :: Variable -> IO Bool
130+detectDecoder variable =
131+ do (Descriptor content _ _ _) <- UF.descriptor variable
132+ case content of
133+ Structure (App1 name [_]) | Var.decoder == name ->
134+ return True
135+
136+ _ ->
137+ return False
126138
127139
128140
@@ -445,22 +457,6 @@ unifyComparableRecursive orientation var =
445457 guardedUnify orientation compVar var
446458
447459
448−collectArgs :: Variable -> IO [Variable]
449−collectArgs variable =
450− collectArgsHelp [] variable
451−
452−
453−collectArgsHelp :: [Variable] -> Variable -> IO [Variable]
454−collectArgsHelp revArgs variable =
455− do (Descriptor content _ _ _) <- UF.descriptor variable
456− case content of
457− Structure (Fun1 arg returnType) ->
458− collectArgsHelp (arg : revArgs) returnType
459−
460− _ ->
461− return $ variable : revArgs
462−
463−
464460
465461-- UNIFY ALIASES
466462
@@ -638,11 +634,8 @@ unifyField context (field, (expected, actual)) =
638634 Left problem ->
639635 return $ Just $ (,) field $
640636 case problem of
641− Typical ->
642− Nothing
643−
644− Special reason ->
645− Just reason
637+ Reason _ reason ->
638+ reason
646639
647640 Infinite ->
648641 Nothing
@@ -652,7 +645,8 @@ unifyField context (field, (expected, actual)) =
652645-- GATHER RECORD STRUCTURE
653646
654647
655−data RecordStructure = RecordStructure
648+data RecordStructure =
649+ RecordStructure
656650 { _fields :: Map.Map Text Variable
657651 , _extVar :: Variable
658652 , _extStruct :: ExtensionStructure
@@ -660,8 +654,8 @@ data RecordStructure = RecordStructure
660654
661655
662656data ExtensionStructure
663− = Empty
664− | Extension
657+ = Empty
658+ | Extension
665659
666660
667661gatherFields :: Context -> Map.Map Text Variable -> Variable -> IO RecordStructure