git.iko.soy/elk
on master help sign in
Show better error messages on infinite comparable types
commit60ca557f13d52148f7d9b606776547bd1717675f authorEvan Czaplicki <evancz@users.noreply.github.com> dateFri 2 Jun 2017, 01:45 (9 years ago) parent1408bc3
4 files changed+188−77
compare with master
unifiedsplit
src/Reporting/Error/Type.hs+112−25 src/Type/Occurs.hs+25−27 src/Type/Solve.hs+6−3 src/Type/Unify.hs+45−22
src/Reporting/Error/Type.hs+112−25
@@ -37,7 +37,7 @@ data Error
3737 = Mismatch Mismatch
3838 | BadMain Type.Canonical
3939 | BadFlags Type.Canonical (Maybe Text)
40− | InfiniteType Text Type.Canonical
40+ | InfiniteType (Either Hint Text) Type.Canonical
4141
4242
4343data Mismatch = MismatchInfo
@@ -111,8 +111,8 @@ toReport localizer err =
111111 Mismatch info ->
112112 mismatchToReport localizer info
113113
114− InfiniteType name overallType ->
115− infiniteTypeToReport localizer name overallType
114+ InfiniteType context overallType ->
115+ infiniteTypeToReport localizer context overallType
116116
117117 BadMain tipe ->
118118 Report.report
@@ -960,25 +960,112 @@ padTypo arrow maxLen (missingField, knownField) =
960960-- INFINITE TYPES
961961
962962
963−infiniteTypeToReport
964− :: RenderType.Localizer
965− -> Text
966− -> Type.Canonical
967− -> Report.Report
968−infiniteTypeToReport localizer name overallType =
969− Report.report
970− "INFINITE TYPE"
971− Nothing
972− ( "I am inferring a weird self-referential type for " <> functionName name
973− )
974− ( stack
975− [ reflowParagraph $
976− "Here is my best effort at writing down the type. You will see ? and ∞ for\
977− \ parts of the type that repeat something already printed out infinitely."
978− , indent 4 (RenderType.toDoc localizer overallType)
979− , reflowParagraph $
980− "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: "
982− <> Help.hintLink "infinite-type"
983− ]
984− )
963+infiniteTypeToReport :: RenderType.Localizer -> Either Hint Text -> Type.Canonical -> Report.Report
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
973+ Report.report
974+ "INFINITE TYPE"
975+ maybeRegion
976+ ( "I am inferring a weird self-referential type for " <> description <> ":"
977+ )
978+ ( stack
979+ [ reflowParagraph $
980+ "Here is my best effort at writing down the type. You will see ∞ for\
981+ \ parts of the type that repeat something already printed out infinitely."
982+ , indent 4 (RenderType.toDoc localizer overallType)
983+ , reflowParagraph $
984+ "Usually staring at the type is not so helpful in these cases, so definitely\
985+ \ read the debugging hints for ideas on how to figure this out: "
986+ <> Help.hintLink "infinite-type"
987+ ]
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 =
2020occursHelp :: [Type.Variable] -> Type.Variable -> IO Bool
2121occursHelp seen var =
2222 if elem var seen then
23− do infiniteDescriptor <- UF.descriptor var
24− UF.setDescriptor var (infiniteDescriptor { _content = Error "∞" })
25− return True
23+ return True
2624
2725 else
28− do desc <- UF.descriptor var
29− case _content desc of
30− Atom _ ->
31− return False
26+ do desc <- UF.descriptor var
27+ case _content desc of
28+ Atom _ ->
29+ return False
3230
33− Var _ _ _ ->
34− return False
31+ Var _ _ _ ->
32+ return False
3533
36− Error ->
37− return False
34+ Error _ ->
35+ return False
3836
39− Alias _ args _ ->
40− -- TODO is it okay to only check args?
41− or <$> traverse (occursHelp (var:seen) . snd) args
37+ Alias _ args _ ->
38+ -- TODO is it okay to only check args?
39+ or <$> traverse (occursHelp (var:seen) . snd) args
4240
43− Structure term ->
44− let
45− go = occursHelp (var:seen)
46− in
47− case term of
48− App1 a b ->
49− (||) <$> go a <*> go b
41+ Structure term ->
42+ let
43+ go = occursHelp (var:seen)
44+ in
45+ case term of
46+ App1 a b ->
47+ (||) <$> go a <*> go b
5048
51− Fun1 a b ->
52− (||) <$> go a <*> go b
49+ Fun1 a b ->
50+ (||) <$> go a <*> go b
5351
54− EmptyRecord1 ->
55− return False
52+ EmptyRecord1 ->
53+ return False
5654
57− Record1 fields ext ->
58− or <$> traverse go (ext : Map.elems fields)
55+ Record1 fields ext ->
56+ or <$> traverse go (ext : Map.elems fields)
src/Type/Solve.hs+6−3
@@ -272,8 +272,11 @@ occurs (name, A.A region variable) =
272272 do hasOccurred <- liftIO $ Occurs.occurs variable
273273 case hasOccurred of
274274 False ->
275− return ()
275+ return ()
276276
277277 True ->
278− do overallType <- liftIO (Type.toSrcType variable)
279− TS.addError region (Error.InfiniteType name overallType)
278+ do overallType <- liftIO $ Type.toSrcType variable
279+ infiniteDescriptor <- liftIO $ UF.descriptor variable
280+ liftIO $ UF.setDescriptor variable (infiniteDescriptor { _content = Error "∞" })
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 =
2929 Right () ->
3030 return ()
3131
32− Left (Mismatch maybeReason) ->
33− let
34− mkError =
35− do expectedSrcType <- Type.toSrcType expected
36− actualSrcType <- Type.toSrcType actual
37− 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
32+ Left problem ->
33+ do expectedSrcType <- liftIO $ Type.toSrcType expected
34+ actualSrcType <- liftIO $ Type.toSrcType actual
35+ liftIO $ mergeHelp expected actual (Error "?") noRank
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
4248
4349
4450
@@ -46,7 +52,7 @@ unify hint region expected actual =
4652
4753
4854type Unify =
49− ExceptT Mismatch TS.Solver
55+ ExceptT Problem TS.Solver
5056
5157
5258data Context =
@@ -77,8 +83,10 @@ reorient (Context orientation var1 desc1 var2 desc2) =
7783-- ERROR MESSAGES
7884
7985
80−newtype Mismatch =
81− Mismatch (Maybe Error.Reason)
86+data Problem
87+ = Typical
88+ | Special Error.Reason
89+ | Infinite
8290
8391
8492mismatch :: Context -> Maybe Error.Reason -> Unify a
@@ -99,13 +107,19 @@ mismatch context@(Context orientation var1 _ var2 _) maybeReason =
99107
100108mismatchHelp :: Orientation -> Maybe Error.Reason -> Unify a
101109mismatchHelp orientation maybeReason =
102− throwError $ Mismatch $
103− case orientation of
104− ExpectedActual ->
105− maybeReason
110+ throwError $
111+ case maybeReason of
112+ Nothing ->
113+ Typical
114+
115+ Just reason ->
116+ Special $
117+ case orientation of
118+ ExpectedActual ->
119+ reason
106120
107− ActualExpected ->
108− Error.flipReason <$> maybeReason
121+ ActualExpected ->
122+ Error.flipReason reason
109123
110124
111125badRigid :: Maybe Text -> Error.Reason
@@ -436,7 +450,7 @@ comparableOccursCheck :: Context -> Unify ()
436450comparableOccursCheck (Context _ _ _ var _) =
437451 do hasOccurred <- liftIO $ Occurs.occurs var
438452 if hasOccurred
439− then throwError (Mismatch Nothing)
453+ then throwError Infinite
440454 else return ()
441455
442456
@@ -714,8 +728,17 @@ unifyField context (field, (expected, actual)) =
714728 Right () ->
715729 return $ Nothing
716730
717− Left (Mismatch maybeReason) ->
718− return $ Just (field, maybeReason)
731+ Left problem ->
732+ return $ Just $ (,) field $
733+ case problem of
734+ Typical ->
735+ Nothing
736+
737+ Special reason ->
738+ Just reason
739+
740+ Infinite ->
741+ Nothing
719742
720743
721744