@@ -76,16 +76,24 @@ actuallyUnify region variable1 variable2 = do
7676 case home of
7777 Var.BuiltIn | name `elem` ["Int","Float"] -> flexAndUnify svar
7878 Var.Local | List.isPrefixOf "number" name -> flexAndUnify svar
79− _ -> let hint = "A number must be an Int or Float."
80− in TS.addError region (Just hint) variable1 variable2
79+ _ ->
80+ let hint = "Looks like something besides an Int or Float is being used as a number."
81+ in
82+ TS.addError region (Just hint) variable1 variable2
8183
8284 comparableError maybe =
8385 TS.addError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2
84− where msg = "A comparable must be an Int, Float, Char, String, list, or tuple."
86+ where
87+ msg =
88+ "Looks like you want something comparable, but the only valid comparable\n\
89+ \types are Int, Float, Char, String, lists, or tuples."
8590
8691 appendableError maybe =
8792 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."
8997
9098 unifyComparable v (Var.Canonical home name) =
9199 case home of
@@ -113,12 +121,13 @@ actuallyUnify region variable1 variable2 = do
113121 List _ -> flexAndUnify varSuper
114122 _ -> appendableError Nothing
115123
116− rigidError var = TS.addError region (Just hint) variable1 variable2
117− where
118− var' = "'" ++ render (pretty Never var) ++ "'"
119− hint = "Cannot unify rigid type variable " ++ var' ++
120− ".\nThe problem probably relates to a type annotation. Note that rigid type\n\
121− \variables are not shared between a top-level and let-bound type annotations."
124+ rigidError var =
125+ TS.addError region (Just hint) variable1 variable2
126+ where
127+ hint =
128+ "Could not unify rigid type variable '" ++ render (pretty Never var) ++ "'.\n" ++
129+ "The problem probably relates to the type variable being shared between a\n\
130+ \top-level type annotation and a related let-bound type annotation."
122131
123132 superUnify =
124133 case (flex desc1, flex desc2, name desc1, name desc2) of
@@ -174,37 +183,89 @@ actuallyUnify region variable1 variable2 = do
174183 (Record1 fields ext, EmptyRecord1) | Map.null fields -> unify' ext variable2
175184 (EmptyRecord1, Record1 fields ext) | Map.null fields -> unify' ext variable1
176185
177− (Record1 fields1 ext1, Record1 fields2 ext2) ->
178− do Map.intersectionWith (zipWith unify') fields1 fields2
179− |> Map.elems
180− |> concat
181− |> sequence
186+ (Record1 _ _, Record1 _ _) ->
187+ recordUnify region fresh variable1 variable2
182188
183− let mkRecord fs ext =
184− fresh (Just (Record1 fs ext))
185−
186− let uniqueFields1 = diffFields fields1 fields2
187− let uniqueFields2 = diffFields fields2 fields1
188−
189− case (Map.null uniqueFields1, Map.null uniqueFields2) of
190− (True, True) ->
191− unify' ext1 ext2
192−
193− (True, False) ->
194− do record2' <- mkRecord uniqueFields2 ext2
195− unify' ext1 record2'
196−
197− (False, True) ->
198− do record1' <- mkRecord uniqueFields1 ext1
199− unify' record1' ext2
189+ _ -> TS.addError region Nothing variable1 variable2
200190
201− (False, False) ->
202− do record1' <- mkRecord uniqueFields1 =<< fresh Nothing
203− record2' <- mkRecord uniqueFields2 =<< fresh Nothing
204− unify' record1' ext2
205− unify' ext1 record2'
206191
207− _ -> TS.addError region Nothing variable1 variable2
192+-- RECORD UNIFICATION
193+
194+recordUnify
195+ :: A.Region
196+ -> (Maybe (Term1 Variable) -> StateT TS.SolverState IO Variable)
197+ -> Variable
198+ -> Variable
199+ -> StateT TS.SolverState IO ()
200+recordUnify region fresh variable1 variable2 =
201+ do (ExpandedRecord fields1 ext1) <- liftIO (gatherFields variable1)
202+ (ExpandedRecord fields2 ext2) <- liftIO (gatherFields variable2)
203+
204+ unifyOverlappingFields region fields1 fields2
205+
206+ let freshRecord fields ext =
207+ fresh (Just (Record1 fields ext))
208+
209+ let uniqueFields1 = diffFields fields1 fields2
210+ let uniqueFields2 = diffFields fields2 fields1
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) ->
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
234+ (True, True) -> unify region var1 var2
235+ (True, False) ->
236+ do subRecord <- freshRecord uniqueFields2 var2
237+ unify region var1 subRecord
238+
239+ (Extension var1, Extension var2) ->
240+ case (Map.null uniqueFields1, Map.null uniqueFields2) of
241+ (True, True) ->
242+ unify region var1 var2
243+
244+ (True, False) ->
245+ do subRecord <- freshRecord uniqueFields2 var2
246+ unify region var1 subRecord
247+
248+ (False, True) ->
249+ do subRecord <- freshRecord uniqueFields1 var1
250+ unify region subRecord var2
251+
252+ (False, False) ->
253+ do record1' <- freshRecord uniqueFields1 =<< fresh Nothing
254+ record2' <- freshRecord uniqueFields2 =<< fresh Nothing
255+ unify region record1' var2
256+ unify region var1 record2'
257+
258+
259+unifyOverlappingFields
260+ :: A.Region
261+ -> Map.Map String [Variable]
262+ -> Map.Map String [Variable]
263+ -> StateT TS.SolverState IO ()
264+unifyOverlappingFields region fields1 fields2 =
265+ Map.intersectionWith (zipWith (unify region)) fields1 fields2
266+ |> Map.elems
267+ |> concat
268+ |> sequence_
208269
209270
210271diffFields :: Map.Map String [a] -> Map.Map String [a] -> Map.Map String [a]
@@ -216,6 +277,40 @@ diffFields fields1 fields2 =
216277 |> Map.filter (not . null)
217278
218279
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+
219314combinedDescriptors :: Descriptor -> Descriptor
220315 -> (Maybe Var.Canonical, Flex, Int, Maybe Var.Canonical)
221316combinedDescriptors desc1 desc2 =