git.iko.soy/elk
on master help sign in
Show better error messages on infinite comparable types
60ca557Evan Czaplicki
src/Reporting/Error/Type.hs+112−25
compare with master
unifiedsplit
@@ -37,7 +37,7 @@ data Error
37 = Mismatch Mismatch
37 = Mismatch Mismatch
38 | BadMain Type.Canonical
38 | BadMain Type.Canonical
39 | BadFlags Type.Canonical (Maybe Text)
39 | BadFlags Type.Canonical (Maybe Text)
40− | InfiniteType Text Type.Canonical
40+ | InfiniteType (Either Hint Text) Type.Canonical
41
41
42
42
43data Mismatch = MismatchInfo
43data Mismatch = MismatchInfo
@@ -111,8 +111,8 @@ toReport localizer err =
111 Mismatch info ->
111 Mismatch info ->
112 mismatchToReport localizer info
112 mismatchToReport localizer info
113
113
114− InfiniteType name overallType ->
114+ InfiniteType context overallType ->
115− infiniteTypeToReport localizer name overallType
115+ infiniteTypeToReport localizer context overallType
116
116
117 BadMain tipe ->
117 BadMain tipe ->
118 Report.report
118 Report.report
@@ -960,25 +960,112 @@ padTypo arrow maxLen (missingField, knownField) =
960-- INFINITE TYPES
960-- INFINITE TYPES
961
961
962
962
963−infiniteTypeToReport
963+infiniteTypeToReport :: RenderType.Localizer -> Either Hint Text -> Type.Canonical -> Report.Report
964− :: RenderType.Localizer
965− -> Text
966− -> Type.Canonical
967− -> Report.Report
968−infiniteTypeToReport localizer name overallType =
964+infiniteTypeToReport localizer context overallType =
965+ let
966+ (maybeRegion, description) =
967+ case context of
968+ Right name ->
969+ ( Nothing, functionName name )
970+ Left hint ->
971+ infiniteHint hint
972+ in
969− Report.report
973+ Report.report
970− "INFINITE TYPE"
974+ "INFINITE TYPE"
971− Nothing
975+ maybeRegion
972− ( "I am inferring a weird self-referential type for " <> functionName name
976+ ( "I am inferring a weird self-referential type for " <> description <> ":"
973− )
977+ )
974− ( stack
978+ ( stack
975− [ reflowParagraph $
979+ [ reflowParagraph $
976− "Here is my best effort at writing down the type. You will see ? and ∞ for\
980+ "Here is my best effort at writing down the type. You will see ∞ for\
977− \ parts of the type that repeat something already printed out infinitely."
981+ \ parts of the type that repeat something already printed out infinitely."
978− , indent 4 (RenderType.toDoc localizer overallType)
982+ , indent 4 (RenderType.toDoc localizer overallType)
979− , reflowParagraph $
983+ , reflowParagraph $
980− "Usually staring at the type is not so helpful in these cases, so definitely\
984+ "Usually staring at the type is not so helpful in these cases, so definitely\
981− \ read the debugging hints for ideas on how to figure this out: "
985+ \ read the debugging hints for ideas on how to figure this out: "
982− <> Help.hintLink "infinite-type"
986+ <> Help.hintLink "infinite-type"
983− ]
987+ ]
984− )
988+ )
989+
990+
991+infiniteHint :: Hint -> (Maybe Region.Region, Text)
992+infiniteHint hint =
993+ case hint of
994+ CaseBranch n region ->
995+ ( Just region, "the " <> ordinalize n <> " `case` branch" )
996+
997+ Case ->
998+ ( Nothing, "this `case` expression" )
999+
1000+ IfCondition ->
1001+ ( Nothing, "the `if` condition" )
1002+
1003+ IfBranches ->
1004+ ( Nothing, "the `if` branches" )
1005+
1006+ MultiIfBranch n region ->
1007+ ( Just region, "the " <> ordinalize n <> " `if` branch" )
1008+
1009+ If ->
1010+ ( Nothing, "this `if` expression" )
1011+
1012+ List ->
1013+ ( Nothing, "this list" )
1014+
1015+ ListElement n region ->
1016+ ( Just region, "the " <> ordinalize n <> " list entry" )
1017+
1018+ BinopLeft _ region ->
1019+ ( Just region, "the left argument" )
1020+
1021+ BinopRight _ region ->
1022+ ( Just region, "the right argument" )
1023+
1024+ Binop _ ->
1025+ ( Nothing, "this expression" )
1026+
1027+ Function maybeName ->
1028+ ( Nothing, maybeFuncName maybeName )
1029+
1030+ UnexpectedArg maybeName 1 1 region ->
1031+ ( Just region, "the argument to " <> maybeFuncName maybeName )
1032+
1033+ UnexpectedArg maybeName index _total region ->
1034+ ( Just region, "the " <> ordinalize index <> " argument to " <> maybeFuncName maybeName )
1035+
1036+ FunctionArity maybeName _ _ region ->
1037+ ( Just region, maybeFuncName maybeName )
1038+
1039+ ReturnType name _ _ region ->
1040+ ( Just region, functionName name )
1041+
1042+ Instance name ->
1043+ ( Nothing, functionName name )
1044+
1045+ Literal name ->
1046+ ( Nothing, name )
1047+
1048+ Pattern _ ->
1049+ ( Nothing, "this pattern" )
1050+
1051+ Shader ->
1052+ ( Nothing, "this shader" )
1053+
1054+ Lambda ->
1055+ ( Nothing, "this anonymous function" )
1056+
1057+ Access _ _ ->
1058+ ( Nothing, "this field access" )
1059+
1060+ Record ->
1061+ ( Nothing, "this record" )
1062+
1063+ -- effect manager problems
1064+ Manager name ->
1065+ ( Nothing, functionName name )
1066+
1067+ State name ->
1068+ ( Nothing, functionName name )
1069+
1070+ SelfMsg ->
1071+ ( Nothing, "this code" )
src/Type/Occurs.hs+25−27
@@ -20,39 +20,37 @@ occurs var =
20occursHelp :: [Type.Variable] -> Type.Variable -> IO Bool
20occursHelp :: [Type.Variable] -> Type.Variable -> IO Bool
21occursHelp seen var =
21occursHelp seen var =
22 if elem var seen then
22 if elem var seen then
23− do infiniteDescriptor <- UF.descriptor var
24− UF.setDescriptor var (infiniteDescriptor { _content = Error "∞" })
25− return True
23+ return True
26
24
27 else
25 else
28− do desc <- UF.descriptor var
26+ do desc <- UF.descriptor var
29− case _content desc of
27+ case _content desc of
30− Atom _ ->
28+ Atom _ ->
31− return False
29+ return False
32
30
33− Var _ _ _ ->
31+ Var _ _ _ ->
34− return False
32+ return False
35
33
36− Error ->
34+ Error _ ->
37− return False
35+ return False
38
36
39− Alias _ args _ ->
37+ Alias _ args _ ->
40− -- TODO is it okay to only check args?
38+ -- TODO is it okay to only check args?
41− or <$> traverse (occursHelp (var:seen) . snd) args
39+ or <$> traverse (occursHelp (var:seen) . snd) args
42
40
43− Structure term ->
41+ Structure term ->
44− let
42+ let
45− go = occursHelp (var:seen)
43+ go = occursHelp (var:seen)
46− in
44+ in
47− case term of
45+ case term of
48− App1 a b ->
46+ App1 a b ->
49− (||) <$> go a <*> go b
47+ (||) <$> go a <*> go b
50
48
51− Fun1 a b ->
49+ Fun1 a b ->
52− (||) <$> go a <*> go b
50+ (||) <$> go a <*> go b
53
51
54− EmptyRecord1 ->
52+ EmptyRecord1 ->
55− return False
53+ return False
56
54
57− Record1 fields ext ->
55+ Record1 fields ext ->
58− or <$> traverse go (ext : Map.elems fields)
56+ or <$> traverse go (ext : Map.elems fields)
src/Type/Solve.hs+6−3
@@ -272,8 +272,11 @@ occurs (name, A.A region variable) =
272 do hasOccurred <- liftIO $ Occurs.occurs variable
272 do hasOccurred <- liftIO $ Occurs.occurs variable
273 case hasOccurred of
273 case hasOccurred of
274 False ->
274 False ->
275− return ()
275+ return ()
276
276
277 True ->
277 True ->
278− do overallType <- liftIO (Type.toSrcType variable)
278+ do overallType <- liftIO $ Type.toSrcType variable
279+ infiniteDescriptor <- liftIO $ UF.descriptor variable
280+ liftIO $ UF.setDescriptor variable (infiniteDescriptor { _content = Error "∞" })
279− TS.addError region (Error.InfiniteType name overallType)
281+ TS.addError region (Error.InfiniteType (Right name) overallType)
282+
src/Type/Unify.hs+45−22
@@ -29,16 +29,22 @@ unify hint region expected actual =
29 Right () ->
29 Right () ->
30 return ()
30 return ()
31
31
32− Left (Mismatch maybeReason) ->
32+ Left problem ->
33− let
34− mkError =
35− do expectedSrcType <- Type.toSrcType expected
33+ do expectedSrcType <- liftIO $ Type.toSrcType expected
36− actualSrcType <- Type.toSrcType actual
34+ actualSrcType <- liftIO $ Type.toSrcType actual
37− mergeHelp expected actual (Error "?") noRank
35+ liftIO $ mergeHelp expected actual (Error "?") noRank
38− let info = Error.MismatchInfo hint expectedSrcType actualSrcType maybeReason
39− return (Error.Mismatch info)
40− in
41− TS.addError region =<< liftIO mkError
36+ TS.addError region $
37+ case problem of
38+ Typical ->
39+ Error.Mismatch $
40+ Error.MismatchInfo hint expectedSrcType actualSrcType Nothing
41+
42+ Special reason ->
43+ Error.Mismatch $
44+ Error.MismatchInfo hint expectedSrcType actualSrcType (Just reason)
45+
46+ Infinite ->
47+ Error.InfiniteType (Left hint) expectedSrcType
42
48
43
49
44
50
@@ -46,7 +52,7 @@ unify hint region expected actual =
46
52
47
53
48type Unify =
54type Unify =
49− ExceptT Mismatch TS.Solver
55+ ExceptT Problem TS.Solver
50
56
51
57
52data Context =
58data Context =
@@ -77,8 +83,10 @@ reorient (Context orientation var1 desc1 var2 desc2) =
77-- ERROR MESSAGES
83-- ERROR MESSAGES
78
84
79
85
80−newtype Mismatch =
86+data Problem
87+ = Typical
81− Mismatch (Maybe Error.Reason)
88+ | Special Error.Reason
89+ | Infinite
82
90
83
91
84mismatch :: Context -> Maybe Error.Reason -> Unify a
92mismatch :: Context -> Maybe Error.Reason -> Unify a
@@ -99,13 +107,19 @@ mismatch context@(Context orientation var1 _ var2 _) maybeReason =
99
107
100mismatchHelp :: Orientation -> Maybe Error.Reason -> Unify a
108mismatchHelp :: Orientation -> Maybe Error.Reason -> Unify a
101mismatchHelp orientation maybeReason =
109mismatchHelp orientation maybeReason =
102− throwError $ Mismatch $
110+ throwError $
111+ case maybeReason of
112+ Nothing ->
113+ Typical
114+
115+ Just reason ->
116+ Special $
103− case orientation of
117+ case orientation of
104− ExpectedActual ->
118+ ExpectedActual ->
105− maybeReason
119+ reason
106
120
107− ActualExpected ->
121+ ActualExpected ->
108− Error.flipReason <$> maybeReason
122+ Error.flipReason reason
109
123
110
124
111badRigid :: Maybe Text -> Error.Reason
125badRigid :: Maybe Text -> Error.Reason
@@ -436,7 +450,7 @@ comparableOccursCheck :: Context -> Unify ()
436comparableOccursCheck (Context _ _ _ var _) =
450comparableOccursCheck (Context _ _ _ var _) =
437 do hasOccurred <- liftIO $ Occurs.occurs var
451 do hasOccurred <- liftIO $ Occurs.occurs var
438 if hasOccurred
452 if hasOccurred
439− then throwError (Mismatch Nothing)
453+ then throwError Infinite
440 else return ()
454 else return ()
441
455
442
456
@@ -714,8 +728,17 @@ unifyField context (field, (expected, actual)) =
714 Right () ->
728 Right () ->
715 return $ Nothing
729 return $ Nothing
716
730
717− Left (Mismatch maybeReason) ->
731+ Left problem ->
718− return $ Just (field, maybeReason)
732+ return $ Just $ (,) field $
733+ case problem of
734+ Typical ->
735+ Nothing
736+
737+ Special reason ->
738+ Just reason
739+
740+ Infinite ->
741+ Nothing
719
742
720
743
721
744