@@ -1,12 +1,10 @@
1+{-# OPTIONS_GHC -Wall #-}
12module Type.Unify (unify) where
23
3−import Control.Applicative ((<|>))
4−import Control.Monad.Except (ExceptT, throwError, runExceptT)
5−import Control.Monad.State as State
6−import qualified Data.List as List
4+import Control.Monad (zipWithM_)
5+import Control.Monad.Except (ExceptT, lift, liftIO, throwError, runExceptT)
76import qualified Data.Map as Map
87import qualified Data.UnionFind.IO as UF
9−import Text.PrettyPrint (render)
108
119import qualified AST.Type as AstType
1210import qualified AST.Variable as Var
@@ -14,435 +12,654 @@ import qualified Reporting.Region as R
1412import qualified Reporting.Error.Type as Error
1513import qualified Type.State as TS
1614import Type.Type as Type
17−import Type.PrettyPrint
18−import Elm.Utils ((|>))
19−
20−
21−unify
22− :: Error.Hint
23− -> R.Region
24− -> Variable
25− -> Variable
26− -> StateT TS.SolverState IO ()
27−unify hint region variable1 variable2 =
28− do result <- runExceptT (unifyHelp variable1 variable2)
15+
16+
17+
18+-- KICK OFF UNIFICATION
19+
20+
21+unify :: Error.Hint -> R.Region -> Variable -> Variable -> TS.Solver ()
22+unify hint region expected actual =
23+ do result <- runExceptT (guardedUnify ExpectedActual expected actual)
2924 case result of
3025 Right state ->
3126 return state
3227
33− Left (RawMismatch (leftType, rightType, note)) ->
34− TS.addError region $ Error.Mismatch $
35− Error.MismatchInfo hint leftType rightType note
28+ Left (Mismatch leftType rightType maybeReason) ->
29+ do rootType <- liftIO (Type.toSrcType expected)
30+ TS.addError region $ Error.Mismatch $
31+ Error.MismatchInfo hint rootType leftType rightType maybeReason
32+
3633
3734
38−-- ACTUALLY UNIFY STUFF
35+-- UNIFICATION HELPERS
36+
3937
4038type Unify =
41− ExceptT RawMismatch (StateT TS.SolverState IO)
39+ ExceptT Mismatch TS.Solver
40+
41+
42+data Context = Context
43+ { _orientation :: Orientation
44+ , _first :: Variable
45+ , _firstDesc :: Descriptor
46+ , _second :: Variable
47+ , _secondDesc :: Descriptor
48+ }
49+
50+
51+data Orientation = ExpectedActual | ActualExpected
52+
53+
54+reorient :: Context -> Context
55+reorient (Context orientation var1 desc1 var2 desc2) =
56+ let
57+ otherOrientation =
58+ case orientation of
59+ ExpectedActual -> ActualExpected
60+ ActualExpected -> ExpectedActual
61+ in
62+ Context otherOrientation var2 desc2 var1 desc1
63+
64+
65+
66+-- ERROR MESSAGES
67+
68+
69+data Mismatch
70+ = Mismatch AstType.Canonical AstType.Canonical (Maybe Error.Reason)
71+
4272
73+mismatch :: Context -> Maybe Error.Reason -> Unify a
74+mismatch (Context orientation first _ second _) maybeReason =
75+ let
76+ (expected, actual) =
77+ case orientation of
78+ ExpectedActual ->
79+ (first, second)
80+
81+ ActualExpected ->
82+ (second, first)
83+ in
84+ do errorMsg <- liftIO $
85+ do expectedSrcType <- Type.toSrcType expected
86+ actualSrcType <- Type.toSrcType actual
87+ return (Mismatch expectedSrcType actualSrcType maybeReason)
88+ mergeHelp expected actual Error
89+ throwError errorMsg
90+
91+
92+rigidityError :: Context -> Maybe String -> Unify ()
93+rigidityError context maybeName =
94+ mismatch context (Just (Error.Rigid maybeName))
95+
96+
97+
98+-- MERGE
99+
100+
101+merge :: Context -> Content -> Unify ()
102+merge (Context _ first _ second _) content =
103+ mergeHelp first second content
104+
105+
106+mergeHelp :: Variable -> Variable -> Content -> Unify ()
107+mergeHelp first second content =
108+ liftIO $ UF.union' first second $ \desc1 desc2 ->
109+ return $
110+ Descriptor
111+ { _content = content
112+ , _rank = min (_rank desc1) (_rank desc2)
113+ , _mark = noMark
114+ , _copy = Nothing
115+ }
43116
44−newtype RawMismatch =
45− RawMismatch (AstType.Canonical, AstType.Canonical, Maybe String)
46117
118+fresh :: Context -> Content -> Unify Variable
119+fresh (Context _ _ desc1 _ desc2) content =
120+ do freshVariable <-
121+ liftIO $ UF.fresh $
122+ Descriptor
123+ { _content = content
124+ , _rank = min (_rank desc1) (_rank desc2)
125+ , _mark = noMark
126+ , _copy = Nothing
127+ }
128+ lift (TS.register freshVariable)
47129
48−typeError
49− :: UF.Point Descriptor
50− -> UF.Point Descriptor
51− -> Maybe String
52− -> Unify a
53−typeError leftType rightType note =
54− do leftSrcType <- liftIO (Type.toSrcType leftType)
55− rightSrcType <- liftIO (Type.toSrcType rightType)
56− liftIO $ do
57− UF.setDescriptor leftType (Type.descriptor Error)
58− UF.setDescriptor rightType (Type.descriptor Error)
59− throwError (RawMismatch (leftSrcType, rightSrcType, note))
60130
61131
62−unifyHelp :: Variable -> Variable -> Unify ()
63−unifyHelp variable1 variable2 =
64− do equivalent <- liftIO $ UF.equivalent variable1 variable2
132+-- ACTUALLY UNIFY THINGS
133+
134+
135+guardedUnify :: Orientation -> Variable -> Variable -> Unify ()
136+guardedUnify orientation left right =
137+ do equivalent <- liftIO $ UF.equivalent left right
65138 if equivalent
66− then return ()
67− else actuallyUnify variable1 variable2
68−
69−
70−actuallyUnify :: Variable -> Variable -> Unify ()
71−actuallyUnify variable1 variable2 = do
72− desc1 <- liftIO $ UF.descriptor variable1
73− desc2 <- liftIO $ UF.descriptor variable2
74− let name' = pickName desc1 desc2
75− flex' = pickFlex desc1 desc2
76− rank' = pickRank desc1 desc2
77− alias' = pickAlias desc1 desc2
78−
79− merge1 :: Unify ()
80− merge1 =
81− liftIO $ do
82− if rank desc1 < rank desc2
83− then UF.union variable2 variable1
84− else UF.union variable1 variable2
85− UF.modifyDescriptor variable1 $ \desc ->
86− desc { structure = structure desc1
87− , flex = flex'
88− , name = name'
89− , alias = alias'
90− }
91−
92− merge2 :: Unify ()
93− merge2 =
94− liftIO $ do
95− if rank desc1 < rank desc2
96− then UF.union variable2 variable1
97− else UF.union variable1 variable2
98− UF.modifyDescriptor variable2 $ \desc ->
99− desc { structure = structure desc2
100− , flex = flex'
101− , name = name'
102− , alias = alias'
103− }
104−
105− merge =
106− if rank desc1 < rank desc2 then merge1 else merge2
107−
108− fresh :: Maybe (Term1 Variable) -> Unify Variable
109− fresh structure =
110− do v <- liftIO . UF.fresh $ Descriptor
111− { structure = structure
112− , rank = rank'
113− , flex = flex'
114− , name = name'
115− , copy = Nothing
116− , mark = noMark
117− , alias = alias'
118− }
119− lift (TS.register v)
120−
121− flexAndUnify v =
122− do liftIO $ UF.modifyDescriptor v $ \desc -> desc { flex = Flexible }
123− unifyHelp variable1 variable2
124−
125− unifyNumber svar (Var.Canonical home name) =
126− case home of
127− Var.BuiltIn | name `elem` ["Int","Float"] ->
128− flexAndUnify svar
129−
130− Var.Local | List.isPrefixOf "number" name ->
131− flexAndUnify svar
132−
133− Var.TopLevel _ | List.isPrefixOf "number" name ->
134− flexAndUnify svar
135−
136− _ ->
137− typeError variable1 variable2 Nothing
138−
139− comparableError maybeHint =
140− typeError variable1 variable2 $ Just $
141− "Note: comparable types include Int, Float, Char, String, lists, and tuples."
142− ++ maybe "" ("\n"++) maybeHint
143−
144− appendableError =
145− typeError variable1 variable2 $ Just $
146− "Note: appendable types include only Strings, Lists, and Text."
147−
148− unifyComparable v (Var.Canonical home name) =
149− case home of
150− Var.BuiltIn | name `elem` ["Int","Float","Char","String"] ->
151− flexAndUnify v
152− Var.Local | List.isPrefixOf "comparable" name ->
153− flexAndUnify v
154− _ ->
155− comparableError Nothing
156−
157− unifyComparableStructure varSuper varFlex =
158− do struct <- liftIO $ collectApps varFlex
159− case struct of
160− Other ->
161− comparableError Nothing
162−
163− List v ->
164− do flexAndUnify varSuper
165− unifyHelp v =<< liftIO (variable $ Is Comparable)
166−
167− Tuple vs ->
168− if length vs > 6 then
169− comparableError $ Just $
170− "Furthermore, it cannot be a tuple with more than 6 elements."
171− else
172− do flexAndUnify varSuper
173− cmpVars <- liftIO $ forM [1..length vs] $ \_ -> variable (Is Comparable)
174− zipWithM_ unifyHelp vs cmpVars
175−
176− unifyAppendable v cvar =
177− let
178− canUnify =
179− Var.isPrim "String" cvar
180− || Var.isText cvar
181− || Var.isLocal (List.isPrefixOf "comparable") cvar
182− || Var.isLocal (List.isPrefixOf "appendable") cvar
183− in
184− if canUnify then
185− flexAndUnify v
186− else
187− appendableError
188−
189− unifyAppendableStructure varSuper varFlex =
190− do struct <- liftIO $ collectApps varFlex
191− case struct of
192− List _ -> flexAndUnify varSuper
193− _ -> appendableError
194−
195− rigidError var =
196− typeError variable1 variable2 $ Just $
197− rigidErrorMessage (render (pretty Never var))
198−
199− superUnify =
200− case (flex desc1, flex desc2, name desc1, name desc2) of
201− (Is super1, Is super2, _, _)
202− | super1 == super2 -> merge
203− (Is Number, Is Comparable, _, _) -> merge1
204− (Is Comparable, Is Number, _, _) -> merge2
205−
206− (Is Number, _, _, Just name) -> unifyNumber variable1 name
207− (_, Is Number, Just name, _) -> unifyNumber variable2 name
208−
209− (Is Appendable, _, _, Just name) -> unifyAppendable variable1 name
210− (_, Is Appendable, Just name, _) -> unifyAppendable variable2 name
211− (Is Appendable, _, _, _) -> unifyAppendableStructure variable1 variable2
212− (_, Is Appendable, _, _) -> unifyAppendableStructure variable2 variable1
213−
214− (Is Comparable, _, _, Just name) -> unifyComparable variable1 name
215− (_, Is Comparable, Just name, _) -> unifyComparable variable2 name
216− (Is Comparable, _, _, _) -> unifyComparableStructure variable1 variable2
217− (_, Is Comparable, _, _) -> unifyComparableStructure variable2 variable1
218−
219− (Rigid, _, _, _) -> rigidError variable1
220− (_, Rigid, _, _) -> rigidError variable2
221− _ -> typeError variable1 variable2 Nothing
222−
223− case (structure desc1, structure desc2) of
224− (Nothing, Nothing)
225− | flex desc1 == Flexible && flex desc1 == Flexible ->
226− merge
227−
228− (Nothing, _)
229− | flex desc1 == Flexible -> merge2
230− | flex desc1 == Error -> return ()
231−
232− (_, Nothing)
233− | flex desc2 == Flexible -> merge1
234− | flex desc2 == Error -> return ()
235−
236− (Just (Var1 v), _) ->
237− unifyHelp v variable2
238−
239− (_, Just (Var1 v)) ->
240− unifyHelp variable1 v
241−
242− (Nothing, _) ->
243− superUnify
244−
245− (_, Nothing) ->
246− superUnify
247−
248− (Just type1, Just type2) ->
249− case (type1,type2) of
250− (App1 term1 term2, App1 term1' term2') ->
251− do merge
252− unifyHelp term1 term1'
253− unifyHelp term2 term2'
254− (Fun1 term1 term2, Fun1 term1' term2') ->
255− do merge
256− unifyHelp term1 term1'
257− unifyHelp term2 term2'
139+ then return ()
140+ else
141+ do leftDesc <- liftIO $ UF.descriptor left
142+ rightDesc <- liftIO $ UF.descriptor right
143+ actuallyUnify (Context orientation left leftDesc right rightDesc)
258144
259− (EmptyRecord1, EmptyRecord1) ->
260− return ()
261145
262− (Record1 fields ext, EmptyRecord1) | Map.null fields -> unifyHelp ext variable2
263− (EmptyRecord1, Record1 fields ext) | Map.null fields -> unifyHelp variable1 ext
146+subUnify :: Context -> Variable -> Variable -> Unify ()
147+subUnify context var1 var2 =
148+ guardedUnify (_orientation context) var1 var2
149+
264150
265− (Record1 _ _, Record1 _ _) ->
266− recordUnify fresh variable1 variable2
151+actuallyUnify :: Context -> Unify ()
152+actuallyUnify context@(Context _ _ firstDesc _ secondDesc) =
153+ let
154+ secondContent = _content secondDesc
155+ in
156+ case _content firstDesc of
157+ Error ->
158+ -- If there was an error, just pretend it is okay. This lets us avoid
159+ -- "cascading" errors where one problem manifests as multiple message.
160+ return ()
267161
268− _ -> typeError variable1 variable2 Nothing
162+ Var Flex Nothing _ ->
163+ unifyFlex context secondContent
269164
165+ Var Flex (Just super) _ ->
166+ unifySuper context super secondContent
270167
271−-- RIGID ERROR
168+ Var Rigid maybeSuper maybeName ->
169+ unifyRigid context maybeSuper maybeName secondContent
272170
273−rigidErrorMessage :: String -> String
274−rigidErrorMessage var =
275− "Could not unify user provided type variable `" ++ var ++ "`. The most likely cases are:\n\n"
276− ++ " 1. The type you wrote down is too general. It says any type can go through\n"
277− ++ " but in fact only a certain type can.\n"
278− ++ " 2. A type variable is probably being shared between two type annotations.\n"
279− ++ " They are treated as different things in the current implementation, so\n"
280− ++ " Try commenting out some type annotations and see what happens."
171+ Atom name ->
172+ unifyAtom context name secondContent
281173
174+ Alias name args realVar ->
175+ unifyAlias context name args realVar secondContent
282176
283−-- RECORD UNIFICATION
177+ Structure term ->
178+ unifyStructure context term secondContent
284179
285−recordUnify
286− :: (Maybe (Term1 Variable) -> Unify Variable)
287− -> Variable
288− -> Variable
289− -> Unify ()
290−recordUnify fresh variable1 variable2 =
291− do (ExpandedRecord fields1 ext1) <- liftIO (gatherFields variable1)
292− (ExpandedRecord fields2 ext2) <- liftIO (gatherFields variable2)
293180
294− unifyOverlappingFields fields1 fields2
295181
296− let freshRecord fields ext =
297− fresh (Just (Record1 fields ext))
182+-- UNIFY FLEXIBLE VARIABLES
298183
299− let uniqueFields1 = diffFields fields1 fields2
300− let uniqueFields2 = diffFields fields2 fields1
301184
302− let addFieldMismatchError missingFields =
303− typeError variable1 variable2 $ Just $
304− fieldMismatchError missingFields
185+unifyFlex :: Context -> Content -> Unify ()
186+unifyFlex context otherContent =
187+ case otherContent of
188+ Error ->
189+ return ()
305190
306− case (ext1, ext2) of
307− (Empty _, Empty _) ->
308− case Map.null uniqueFields1 && Map.null uniqueFields2 of
309− True -> return ()
310− False -> typeError variable1 variable2 Nothing
191+ Var Flex _ _ ->
192+ merge context otherContent
311193
312− (Empty var1, Extension var2) ->
313− case (Map.null uniqueFields1, Map.null uniqueFields2) of
314− (_, False) -> addFieldMismatchError uniqueFields2
315− (True, True) -> unifyHelp var1 var2
316− (False, True) ->
317− do subRecord <- freshRecord uniqueFields1 var1
318− unifyHelp subRecord var2
194+ Var Rigid _ _ ->
195+ merge context otherContent
319196
320− (Extension var1, Empty var2) ->
321− case (Map.null uniqueFields1, Map.null uniqueFields2) of
322− (False, _) -> addFieldMismatchError uniqueFields1
323− (True, True) -> unifyHelp var1 var2
324− (True, False) ->
325− do subRecord <- freshRecord uniqueFields2 var2
326− unifyHelp var1 subRecord
197+ Atom _ ->
198+ merge context otherContent
327199
328− (Extension var1, Extension var2) ->
329− case (Map.null uniqueFields1, Map.null uniqueFields2) of
330− (True, True) ->
331− unifyHelp var1 var2
200+ Alias _ _ _ ->
201+ merge context otherContent
332202
333− (True, False) ->
334− do subRecord <- freshRecord uniqueFields2 var2
335− unifyHelp var1 subRecord
203+ Structure _ ->
204+ merge context otherContent
205+
206+
207+
208+-- UNIFY RIGID VARIABLES
209+
210+
211+unifyRigid :: Context -> Maybe Super -> Maybe String -> Content -> Unify ()
212+unifyRigid context maybeSuper maybeName otherContent =
213+ case otherContent of
214+ Error ->
215+ return ()
216+
217+ Var Flex otherMaybeSuper _ ->
218+ if maybeSuper == otherMaybeSuper then
219+ merge context (Var Rigid maybeSuper maybeName)
220+ else
221+ rigidityError context maybeName
222+
223+ Var Rigid _ _ ->
224+ rigidityError context maybeName
225+
226+ Atom _ ->
227+ rigidityError context maybeName
228+
229+ Alias _ _ _ ->
230+ rigidityError context maybeName
231+
232+ Structure _ ->
233+ rigidityError context maybeName
234+
235+
236+-- UNIFY SUPER VARIABLES
237+
238+
239+unifySuper :: Context -> Super -> Content -> Unify ()
240+unifySuper context super otherContent =
241+ case otherContent of
242+ Structure term ->
243+ unifySuperStructure context super term
244+
245+ Atom name ->
246+ if atomMatchesSuper super name then
247+ merge context otherContent
248+ else
249+ mismatch context Nothing
250+
251+ Var Rigid Nothing maybeName ->
252+ rigidityError context maybeName
253+
254+ Var Rigid (Just otherSuper) maybeName ->
255+ if super == otherSuper then
256+ merge context otherContent
257+ else
258+ rigidityError context maybeName
259+
260+ Var Flex Nothing _ ->
261+ merge context (Var Flex (Just super) Nothing)
262+
263+ Var Flex (Just otherSuper) _ ->
264+ case combineSupers super otherSuper of
265+ Nothing ->
266+ mismatch context Nothing
267+
268+ Just newSuper ->
269+ merge context (Var Flex (Just newSuper) Nothing)
270+
271+ Alias _ _ realVar ->
272+ subUnify context (_first context) realVar
273+
274+ Error ->
275+ return ()
276+
277+
278+combineSupers :: Super -> Super -> Maybe Super
279+combineSupers firstSuper secondSuper =
280+ case (firstSuper, secondSuper) of
281+ (Number , Number ) -> Just Number
282+ (Comparable, Number ) -> Just Number
283+ (Number , Comparable) -> Just Number
284+
285+ (Comparable, Comparable) -> Just Comparable
286+ (Appendable, Appendable) -> Just Appendable
287+
288+ (Appendable, Comparable) -> Just CompAppend
289+ (Comparable, Appendable) -> Just CompAppend
290+
291+ (CompAppend, CompAppend) -> Just CompAppend
292+ (CompAppend, Comparable) -> Just CompAppend
293+ (Comparable, CompAppend) -> Just CompAppend
294+ (CompAppend, Appendable) -> Just CompAppend
295+ (Appendable, CompAppend) -> Just CompAppend
296+
297+ (_ , _ ) -> Nothing
298+
299+
300+isPrimitiveFrom :: [String] -> Var.Canonical -> Bool
301+isPrimitiveFrom prims var =
302+ any (\p -> Var.isPrim p var) prims
303+
304+
305+atomMatchesSuper :: Super -> Var.Canonical -> Bool
306+atomMatchesSuper super name =
307+ case super of
308+ Number ->
309+ isPrimitiveFrom ["Int", "Float"] name
310+
311+ Comparable ->
312+ isPrimitiveFrom ["Int", "Float", "Char", "String"] name
313+
314+ Appendable ->
315+ Var.isPrim "String" name || Var.isText name
316+
317+ CompAppend ->
318+ Var.isPrim "String" name
319+
320+
321+unifySuperStructure :: Context -> Super -> Term1 Variable -> Unify ()
322+unifySuperStructure context super term =
323+ do appStructure <- liftIO (collectApps (Structure term))
324+ case appStructure of
325+ Other ->
326+ mismatch context Nothing
327+
328+ List variable ->
329+ case super of
330+ Number ->
331+ mismatch context Nothing
332+
333+ Appendable ->
334+ merge context (Structure term)
335+
336+ Comparable ->
337+ do merge context (Structure term)
338+ unifyComparableRecursive (_orientation context) variable
339+
340+ CompAppend ->
341+ do merge context (Structure term)
342+ unifyComparableRecursive (_orientation context) variable
343+
344+ Tuple entries ->
345+ case super of
346+ Number ->
347+ mismatch context Nothing
348+
349+ Appendable ->
350+ mismatch context Nothing
351+
352+ Comparable ->
353+ if length entries > 6 then
354+ mismatch context (Just (Error.TooLongComparableTuple (length entries)))
355+
356+ else
357+ do merge context (Structure term)
358+ mapM_ (unifyComparableRecursive (_orientation context)) entries
359+
360+ CompAppend ->
361+ mismatch context Nothing
362+
363+
364+unifyComparableRecursive :: Orientation -> Variable -> Unify ()
365+unifyComparableRecursive orientation var =
366+ do compVar <-
367+ liftIO $
368+ do desc <- UF.descriptor var
369+ UF.fresh $
370+ Descriptor
371+ { _content = Var Flex (Just Comparable) Nothing
372+ , _rank = _rank desc
373+ , _mark = noMark
374+ , _copy = Nothing
375+ }
376+
377+ guardedUnify orientation compVar var
378+
379+
380+data AppStructure
381+ = List Variable
382+ | Tuple [Variable]
383+ | Other
384+
385+
386+collectApps :: Content -> IO AppStructure
387+collectApps content =
388+ collectAppsHelp [] content
389+
390+
391+collectAppsHelp :: [Variable] -> Content -> IO AppStructure
392+collectAppsHelp args content =
393+ case (content, args) of
394+ (Structure (App1 func arg), _) ->
395+ collectAppsHelp (args ++ [arg]) =<< getContent func
396+
397+ (Atom name, [arg]) | Var.isList name ->
398+ return (List arg)
399+
400+ (Atom name, _) | Var.isTuple name ->
401+ return (Tuple args)
402+
403+ _ ->
404+ return Other
405+
406+
407+getContent :: Variable -> IO Content
408+getContent variable =
409+ _content <$> UF.descriptor variable
410+
411+
412+
413+-- UNIFY ATOMS
414+
415+
416+unifyAtom :: Context -> Var.Canonical -> Content -> Unify ()
417+unifyAtom context name otherContent =
418+ case otherContent of
419+ Error ->
420+ return ()
421+
422+ Var Flex Nothing _ ->
423+ merge context (Atom name)
424+
425+ Var Flex (Just super) _ ->
426+ if atomMatchesSuper super name then
427+ merge context (Atom name)
428+
429+ else
430+ mismatch context Nothing
431+
432+ Var Rigid _ maybeName ->
433+ rigidityError context maybeName
434+
435+ Atom otherName ->
436+ if name == otherName then
437+ merge context otherContent
438+
439+ else
440+ mismatch context Nothing
441+
442+ Alias _ _ realVar ->
443+ subUnify context (_first context) realVar
444+
445+ Structure _ ->
446+ mismatch context Nothing
447+
448+
449+
450+-- UNIFY ALIASES
451+
452+unifyAlias :: Context -> Var.Canonical -> [(String, Variable)] -> Variable -> Content -> Unify ()
453+unifyAlias context name args realVar otherContent =
454+ case otherContent of
455+ Error ->
456+ return ()
457+
458+ Var Flex Nothing _ ->
459+ merge context (Alias name args realVar)
460+
461+ Var _ _ _ ->
462+ subUnify context realVar (_second context)
463+
464+ Atom _ ->
465+ subUnify context realVar (_second context)
466+
467+
468+ Alias otherName otherArgs otherRealVar ->
469+ if name == otherName then
470+ do merge context otherContent
471+ zipWithM_ (subUnify context) (map snd args) (map snd otherArgs)
472+
473+ else
474+ subUnify context realVar otherRealVar
475+
476+ Structure _ ->
477+ subUnify context realVar (_second context)
478+
479+
480+
481+-- UNIFY STRUCTURES
482+
483+
484+unifyStructure :: Context -> Term1 Variable -> Content -> Unify ()
485+unifyStructure context term otherContent =
486+ case otherContent of
487+ Error ->
488+ return ()
489+
490+ Var Flex Nothing _ ->
491+ merge context (Structure term)
492+
493+ Var Flex (Just super) _ ->
494+ unifySuper (reorient context) super (Structure term)
495+
496+ Var Rigid _ maybeName ->
497+ rigidityError context maybeName
498+
499+ Atom _ ->
500+ mismatch context Nothing
501+
502+ Alias _ _ realVar ->
503+ subUnify context (_first context) realVar
504+
505+ Structure otherTerm ->
506+ case (term, otherTerm) of
507+ (App1 func arg, App1 otherFunc otherArg) ->
508+ do merge context otherContent
509+ subUnify context func otherFunc
510+ subUnify context arg otherArg
511+
512+ (Fun1 arg result, Fun1 otherArg otherResult) ->
513+ do merge context otherContent
514+ subUnify context arg otherArg
515+ subUnify context result otherResult
516+
517+ (EmptyRecord1, EmptyRecord1) ->
518+ merge context otherContent
519+
520+ (Record1 fields ext, EmptyRecord1) | Map.null fields ->
521+ subUnify context ext (_second context)
522+
523+ (EmptyRecord1, Record1 fields ext) | Map.null fields ->
524+ subUnify context (_first context) ext
525+
526+ (Record1 fields extension, Record1 otherFields otherExtension) ->
527+ do firstStructure <- gatherFields context fields extension
528+ secondStructure <- gatherFields context otherFields otherExtension
529+ unifyRecord context firstStructure secondStructure
530+
531+ _ ->
532+ mismatch context Nothing
533+
534+
535+
536+-- UNIFY RECORDS
537+
538+
539+unifyRecord :: Context -> RecordStructure -> RecordStructure -> Unify ()
540+unifyRecord context firstStructure secondStructure =
541+ do let (RecordStructure expFields expVar expStruct) = firstStructure
542+ let (RecordStructure actFields actVar actStruct) = secondStructure
543+
544+ -- call after unifying extension, make sure record shape matches before
545+ -- looking into whether the particular field types match.
546+ let unifySharedFields otherFields ext =
547+ do let sharedFields = Map.intersectionWith (,) expFields actFields
548+ _ <- traverse (uncurry (subUnify context)) sharedFields
549+ let allFields = Map.union (Map.map fst sharedFields) otherFields
550+ merge context (Structure (Record1 allFields ext))
551+
552+ let uniqueExpFields = Map.difference expFields actFields
553+ let uniqueActFields = Map.difference actFields expFields
554+
555+ case (expStruct, actStruct) of
556+ (Empty, Empty) ->
557+ if Map.null uniqueExpFields && Map.null uniqueActFields then
558+ do mergeHelp expVar actVar (Structure EmptyRecord1)
559+ unifySharedFields Map.empty expVar
560+
561+ else
562+ mismatch context (Just (Error.MessyFields (Map.keys uniqueExpFields) (Map.keys uniqueActFields)))
563+
564+ (Empty, Extension) ->
565+ case (Map.null uniqueExpFields, Map.null uniqueActFields) of
566+ (_, False) ->
567+ mismatch context (Just (Error.ActualFields (Map.keys uniqueActFields)))
568+
569+ (True, True) ->
570+ do subUnify context expVar actVar
571+ unifySharedFields Map.empty expVar
336572
337573 (False, True) ->
338− do subRecord <- freshRecord uniqueFields1 var1
339− unifyHelp subRecord var2
574+ do subRecord <- fresh context (Structure (Record1 uniqueExpFields expVar))
575+ subUnify context subRecord actVar
576+ unifySharedFields Map.empty subRecord
340577
341− (False, False) ->
342− do record1' <- freshRecord uniqueFields1 =<< fresh Nothing
343− record2' <- freshRecord uniqueFields2 =<< fresh Nothing
344− unifyHelp record1' var2
345− unifyHelp var1 record2'
346−
347−
348−unifyOverlappingFields
349− :: Map.Map String [Variable]
350− -> Map.Map String [Variable]
351− -> Unify ()
352−unifyOverlappingFields fields1 fields2 =
353− Map.intersectionWith (zipWith unifyHelp) fields1 fields2
354− |> Map.elems
355− |> concat
356− |> sequence_
357−
358−
359−diffFields :: Map.Map String [a] -> Map.Map String [a] -> Map.Map String [a]
360−diffFields fields1 fields2 =
361− let eat (_:xs) (_:ys) = eat xs ys
362− eat xs _ = xs
363− in
364− Map.union (Map.intersectionWith eat fields1 fields2) fields1
365− |> Map.filter (not . null)
578+ (Extension, Empty) ->
579+ case (Map.null uniqueExpFields, Map.null uniqueActFields) of
580+ (False, _) ->
581+ mismatch context (Just (Error.ExpectedFields (Map.keys uniqueExpFields)))
366582
583+ (True, True) ->
584+ do subUnify context expVar actVar
585+ unifySharedFields Map.empty expVar
367586
368−data ExpandedRecord = ExpandedRecord
369− { _fields :: Map.Map String [Variable]
370− , _extension :: Extension
371− }
587+ (True, False) ->
588+ do subRecord <- fresh context (Structure (Record1 uniqueActFields actVar))
589+ subUnify context expVar subRecord
590+ unifySharedFields Map.empty subRecord
372591
373−data Extension = Empty Variable | Extension Variable
592+ (Extension, Extension) ->
593+ case (Map.null uniqueExpFields, Map.null uniqueActFields) of
594+ (True, True) ->
595+ do subUnify context expVar actVar
596+ unifySharedFields Map.empty expVar
374597
598+ (True, False) ->
599+ do subRecord <- fresh context (Structure (Record1 uniqueActFields actVar))
600+ subUnify context expVar subRecord
601+ unifySharedFields Map.empty subRecord
375602
376−gatherFields :: Variable -> IO ExpandedRecord
377−gatherFields var =
378− do desc <- UF.descriptor var
379− case structure desc of
380− (Just (Record1 fields ext)) ->
381− do (ExpandedRecord deeperFields rootExt) <- gatherFields ext
382− return (ExpandedRecord (Map.unionWith (++) fields deeperFields) rootExt)
603+ (False, True) ->
604+ do subRecord <- fresh context (Structure (Record1 uniqueExpFields expVar))
605+ subUnify context subRecord actVar
606+ unifySharedFields Map.empty subRecord
383607
384− (Just EmptyRecord1) ->
385− return (ExpandedRecord Map.empty (Empty var))
608+ (False, False) ->
609+ do let subFields = Map.union uniqueExpFields uniqueActFields
610+ subExt <- fresh context (Var Flex Nothing Nothing)
611+ expRecord <- fresh context (Structure (Record1 uniqueActFields subExt))
612+ actRecord <- fresh context (Structure (Record1 uniqueExpFields subExt))
613+ subUnify context expVar expRecord
614+ subUnify context actRecord actVar
615+ unifySharedFields subFields subExt
386616
387− _ ->
388− return (ExpandedRecord Map.empty (Extension var))
389617
390618
391−-- assumes that one of the dicts has stuff in it
392−fieldMismatchError :: Map.Map String a -> String
393−fieldMismatchError missingFields =
394− case Map.keys missingFields of
395− [] ->
396− ""
619+-- GATHER RECORD STRUCTURE
397620
398− [key] ->
399− "Looks like a record is missing the field `" ++ key ++ "`"
400621
401− keys ->
402− "Looks like a record is missing fields "
403− ++ List.intercalate ", " (init keys) ++ ", and " ++ last keys
622+data RecordStructure = RecordStructure
623+ { _fields :: Map.Map String Variable
624+ , _extVar :: Variable
625+ , _extStruct :: ExtensionStructure
626+ }
404627
405628
629+data ExtensionStructure
630+ = Empty
631+ | Extension
406632
407−pickAlias :: Descriptor -> Descriptor -> Alias Variable
408−pickAlias desc1 desc2 =
409− alias desc1 <|> alias desc2
410633
634+gatherFields :: Context -> Map.Map String Variable -> Variable -> Unify RecordStructure
635+gatherFields context fields variable =
636+ do desc <- liftIO (UF.descriptor variable)
637+ case _content desc of
638+ Structure (Record1 subFields subExt) ->
639+ gatherFields context (Map.union fields subFields) subExt
411640
412−pickRank :: Descriptor -> Descriptor -> Int
413−pickRank desc1 desc2 =
414− min (rank desc1) (rank desc2)
641+ Structure (EmptyRecord1) ->
642+ return (RecordStructure fields variable Empty)
415643
644+ Structure (App1 _ _) ->
645+ mismatch context (Just Error.NotRecord)
416646
417−pickFlex :: Descriptor -> Descriptor -> Flex
418−pickFlex desc1 desc2 =
419− case (flex desc1, flex desc2) of
420− ( f , Flexible ) -> f
421− ( Flexible , f ) -> f
422− ( Is Number , Is _ ) -> Is Number
423− ( Is _ , Is Number ) -> Is Number
424− ( Is super , Is _ ) -> Is super
425− ( _ , _ ) -> Flexible
647+ Structure (Fun1 _ _) ->
648+ mismatch context (Just Error.NotRecord)
426649
650+ Atom _ ->
651+ mismatch context (Just Error.NotRecord)
427652
428−pickName :: Descriptor -> Descriptor -> Maybe Var.Canonical
429−pickName desc1 desc2 =
430− case (name desc1, name desc2) of
431− (Nothing, Nothing) ->
432− Nothing
653+ Var _ Nothing _ ->
654+ return (RecordStructure fields variable Extension)
433655
434− (Just name1, Nothing) ->
435− Just name1
656+ Var _ (Just _) _ ->
657+ mismatch context (Just Error.NotRecord)
436658
437− (Nothing, Just name2) ->
438− Just name2
659+ -- TODO may be dropping useful alias info here
660+ Alias _ _ var ->
661+ gatherFields context fields var
439662
440− (Just name1, Just name2) ->
441− case (flex desc1, flex desc2) of
442− ( _ , Flexible ) -> Just name1
443− ( Flexible , _ ) -> Just name2
444− ( Is Number , Is _ ) -> Just name1
445− ( Is _ , Is Number ) -> Just name2
446− ( Is _ , Is _ ) -> Just name1
447− ( _ , _ ) -> Nothing
663+ Error ->
664+ return (RecordStructure fields variable Extension)
448665