git.iko.soy/elk
on master help sign in
Fix #825, nicer error messages when accessing missing fields
9aa9418Evan Czaplicki
src/Type/State.hs+13−8
compare with master
unifiedsplit
@@ -45,8 +45,13 @@ initialState = SS {
45modifyEnv f = modify $ \state -> state { sEnv = f (sEnv state) }
45modifyEnv f = modify $ \state -> state { sEnv = f (sEnv state) }
46modifyPool f = modify $ \state -> state { sPool = f (sPool state) }
46modifyPool f = modify $ \state -> state { sPool = f (sPool state) }
47
47
48+
49+addError
50+ :: A.Region
51+ -> Maybe String
48−addError :: A.Region -> Maybe String -> UF.Point Descriptor -> UF.Point Descriptor
52+ -> UF.Point Descriptor
53+ -> UF.Point Descriptor
49− -> StateT SolverState IO ()
54+ -> StateT SolverState IO ()
50addError region hint t1 t2 =
55addError region hint t1 t2 =
51 do err <- liftIO makeError
56 do err <- liftIO makeError
52 modify $ \state -> state { sErrors = err : sErrors state }
57 modify $ \state -> state { sErrors = err : sErrors state }
@@ -55,16 +60,16 @@ addError region hint t1 t2 =
55 t1' <- pretty <$> toSrcType t1
60 t1' <- pretty <$> toSrcType t1
56 t2' <- pretty <$> toSrcType t2
61 t2' <- pretty <$> toSrcType t2
57 return . foldr ($+$) P.empty $
62 return . foldr ($+$) P.empty $
58− [ P.text "Type mismatch" <+> pretty region <> P.text "."
59− , maybe P.empty P.text hint
60− , P.text ""
61− , P.nest 8 $ A.getRegionDocs region
62− , P.text ""
63− , P.text " Something is causing a mismatch between the following types:"
63+ [ P.text "Type mismatch between the following types:"
64 , P.text ""
64 , P.text ""
65 , P.nest 8 t1'
65 , P.nest 8 t1'
66 , P.text ""
66 , P.text ""
67 , P.nest 8 t2'
67 , P.nest 8 t2'
68+ , P.text ""
69+ , maybe P.empty (P.nest 4 . P.text) hint
70+ , P.text " It is related to the expression" <+> pretty region
71+ , P.text ""
72+ , P.nest 8 $ A.getRegionDocs region
68 ]
73 ]
69
74
70switchToPool pool = modifyPool (\_ -> pool)
75switchToPool pool = modifyPool (\_ -> pool)
src/Type/Unify.hs+107−35
@@ -76,16 +76,24 @@ actuallyUnify region variable1 variable2 = do
76 case home of
76 case home of
77 Var.BuiltIn | name `elem` ["Int","Float"] -> flexAndUnify svar
77 Var.BuiltIn | name `elem` ["Int","Float"] -> flexAndUnify svar
78 Var.Local | List.isPrefixOf "number" name -> flexAndUnify svar
78 Var.Local | List.isPrefixOf "number" name -> flexAndUnify svar
79− _ -> let hint = "A number must be an Int or Float."
79+ _ ->
80+ let hint = "Looks like something besides an Int or Float is being used as a number."
81+ in
80− in TS.addError region (Just hint) variable1 variable2
82+ TS.addError region (Just hint) variable1 variable2
81
83
82 comparableError maybe =
84 comparableError maybe =
83 TS.addError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2
85 TS.addError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2
86+ where
87+ msg =
88+ "Looks like you want something comparable, but the only valid comparable\n\
84− where msg = "A comparable must be an Int, Float, Char, String, list, or tuple."
89+ \types are Int, Float, Char, String, lists, or tuples."
85
90
86 appendableError maybe =
91 appendableError maybe =
87 TS.addError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2
92 TS.addError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2
88− where msg = "An appendable must be of type String, List, or Text."
93+ where
94+ msg =
95+ "Looks like you want something appendable, but the only Strings, Lists,\n\
96+ \and Text can be appended with the (++) operator."
89
97
90 unifyComparable v (Var.Canonical home name) =
98 unifyComparable v (Var.Canonical home name) =
91 case home of
99 case home of
@@ -113,12 +121,13 @@ actuallyUnify region variable1 variable2 = do
113 List _ -> flexAndUnify varSuper
121 List _ -> flexAndUnify varSuper
114 _ -> appendableError Nothing
122 _ -> appendableError Nothing
115
123
124+ rigidError var =
116− rigidError var = TS.addError region (Just hint) variable1 variable2
125+ TS.addError region (Just hint) variable1 variable2
117− where
126+ where
127+ hint =
118− var' = "'" ++ render (pretty Never var) ++ "'"
128+ "Could not unify rigid type variable '" ++ render (pretty Never var) ++ "'.\n" ++
119− hint = "Cannot unify rigid type variable " ++ var' ++
120− ".\nThe problem probably relates to a type annotation. Note that rigid type\n\
129+ "The problem probably relates to the type variable being shared between a\n\
121− \variables are not shared between a top-level and let-bound type annotations."
130+ \top-level type annotation and a related let-bound type annotation."
122
131
123 superUnify =
132 superUnify =
124 case (flex desc1, flex desc2, name desc1, name desc2) of
133 case (flex desc1, flex desc2, name desc1, name desc2) of
@@ -174,8 +183,8 @@ actuallyUnify region variable1 variable2 = do
174 (Record1 fields ext, EmptyRecord1) | Map.null fields -> unify' ext variable2
183 (Record1 fields ext, EmptyRecord1) | Map.null fields -> unify' ext variable2
175 (EmptyRecord1, Record1 fields ext) | Map.null fields -> unify' ext variable1
184 (EmptyRecord1, Record1 fields ext) | Map.null fields -> unify' ext variable1
176
185
177− (Record1 fields1 ext1, Record1 fields2 ext2) ->
186+ (Record1 _ _, Record1 _ _) ->
178− recordUnify region fresh fields1 ext1 fields2 ext2
187+ recordUnify region fresh variable1 variable2
179
188
180 _ -> TS.addError region Nothing variable1 variable2
189 _ -> TS.addError region Nothing variable1 variable2
181
190
@@ -185,37 +194,66 @@ actuallyUnify region variable1 variable2 = do
185recordUnify
194recordUnify
186 :: A.Region
195 :: A.Region
187 -> (Maybe (Term1 Variable) -> StateT TS.SolverState IO Variable)
196 -> (Maybe (Term1 Variable) -> StateT TS.SolverState IO Variable)
188− -> Map.Map String [Variable]
189 -> Variable
197 -> Variable
190− -> Map.Map String [Variable]
191 -> Variable
198 -> Variable
192 -> StateT TS.SolverState IO ()
199 -> StateT TS.SolverState IO ()
193−recordUnify region fresh fields1 ext1 fields2 ext2 =
200+recordUnify region fresh variable1 variable2 =
194− do unifyOverlappingFields region fields1 fields2
201+ do (ExpandedRecord fields1 ext1) <- liftIO (gatherFields variable1)
202+ (ExpandedRecord fields2 ext2) <- liftIO (gatherFields variable2)
195
203
196− let mkRecord fs ext =
204+ unifyOverlappingFields region fields1 fields2
205+
206+ let freshRecord fields ext =
197− fresh (Just (Record1 fs ext))
207+ fresh (Just (Record1 fields ext))
198
208
199 let uniqueFields1 = diffFields fields1 fields2
209 let uniqueFields1 = diffFields fields1 fields2
200 let uniqueFields2 = diffFields fields2 fields1
210 let uniqueFields2 = diffFields fields2 fields1
201
211
212+ let addFieldMismatchError missingFields =
213+ let msg = fieldMismatchError missingFields
214+ in
215+ TS.addError region (Just msg) variable1 variable2
216+
217+ case (ext1, ext2) of
218+ (Empty _, Empty _) ->
219+ case Map.null uniqueFields1 && Map.null uniqueFields2 of
220+ True -> return ()
221+ False -> TS.addError region Nothing variable1 variable2
222+
223+ (Empty var1, Extension var2) ->
202− case (Map.null uniqueFields1, Map.null uniqueFields2) of
224+ case (Map.null uniqueFields1, Map.null uniqueFields2) of
225+ (_, False) -> addFieldMismatchError uniqueFields2
226+ (True, True) -> unify region var1 var2
227+ (False, True) ->
228+ do subRecord <- freshRecord uniqueFields1 var1
229+ unify region subRecord var2
230+
231+ (Extension var1, Empty var2) ->
232+ case (Map.null uniqueFields1, Map.null uniqueFields2) of
233+ (False, _) -> addFieldMismatchError uniqueFields1
203− (True, True) ->
234+ (True, True) -> unify region var1 var2
235+ (True, False) ->
236+ do subRecord <- freshRecord uniqueFields2 var2
204− unify region ext1 ext2
237+ unify region var1 subRecord
205−
238+
239+ (Extension var1, Extension var2) ->
240+ case (Map.null uniqueFields1, Map.null uniqueFields2) of
241+ (True, True) ->
242+ unify region var1 var2
243+
206− (True, False) ->
244+ (True, False) ->
207− do record2' <- mkRecord uniqueFields2 ext2
245+ do subRecord <- freshRecord uniqueFields2 var2
208− unify region ext1 record2'
246+ unify region var1 subRecord
209−
247+
210− (False, True) ->
248+ (False, True) ->
211− do record1' <- mkRecord uniqueFields1 ext1
249+ do subRecord <- freshRecord uniqueFields1 var1
212− unify region record1' ext2
250+ unify region subRecord var2
213−
251+
214− (False, False) ->
252+ (False, False) ->
215− do record1' <- mkRecord uniqueFields1 =<< fresh Nothing
253+ do record1' <- freshRecord uniqueFields1 =<< fresh Nothing
216− record2' <- mkRecord uniqueFields2 =<< fresh Nothing
254+ record2' <- freshRecord uniqueFields2 =<< fresh Nothing
217− unify region record1' ext2
255+ unify region record1' var2
218− unify region ext1 record2'
256+ unify region var1 record2'
219
257
220
258
221unifyOverlappingFields
259unifyOverlappingFields
@@ -239,6 +277,40 @@ diffFields fields1 fields2 =
239 |> Map.filter (not . null)
277 |> Map.filter (not . null)
240
278
241
279
280+data ExpandedRecord = ExpandedRecord
281+ { fields :: Map.Map String [Variable]
282+ , extension :: Extension
283+ }
284+
285+data Extension = Empty Variable | Extension Variable
286+
287+
288+gatherFields :: Variable -> IO ExpandedRecord
289+gatherFields var =
290+ do desc <- UF.descriptor var
291+ case structure desc of
292+ (Just (Record1 fields ext)) ->
293+ do (ExpandedRecord deeperFields rootExt) <- gatherFields ext
294+ return (ExpandedRecord (Map.unionWith (++) fields deeperFields) rootExt)
295+
296+ (Just EmptyRecord1) ->
297+ return (ExpandedRecord Map.empty (Empty var))
298+
299+ _ ->
300+ return (ExpandedRecord Map.empty (Extension var))
301+
302+
303+-- assumes that one of the dicts has stuff in it
304+fieldMismatchError :: Map.Map String a -> String
305+fieldMismatchError missingFields =
306+ case Map.keys missingFields of
307+ [] -> ""
308+ [key] -> "Looks like one record is missing field " ++ key
309+ keys ->
310+ "Looks like one record is missing fields "
311+ ++ List.intercalate ", " (init keys) ++ ", and " ++ last keys
312+
313+
242combinedDescriptors :: Descriptor -> Descriptor
314combinedDescriptors :: Descriptor -> Descriptor
243 -> (Maybe Var.Canonical, Flex, Int, Maybe Var.Canonical)
315 -> (Maybe Var.Canonical, Flex, Int, Maybe Var.Canonical)
244combinedDescriptors desc1 desc2 =
316combinedDescriptors desc1 desc2 =