@@ -57,45 +57,50 @@ actuallyUnify region variable1 variable2 = do
5757 (name', flex', rank', alias') = combinedDescriptors desc1 desc2
5858
5959 merge1 :: Unify ()
60− merge1 = liftIO $ do
61− if rank desc1 < rank desc2 then UF.union variable2 variable1
62− else UF.union variable1 variable2
63− UF.modifyDescriptor variable1 $ \desc ->
64− desc { structure = structure desc1
65− , flex = flex'
66− , name = name'
67− , alias = alias'
68− }
60+ merge1 =
61+ liftIO $ do
62+ if rank desc1 < rank desc2
63+ then UF.union variable2 variable1
64+ else UF.union variable1 variable2
65+ UF.modifyDescriptor variable1 $ \desc ->
66+ desc { structure = structure desc1
67+ , flex = flex'
68+ , name = name'
69+ , alias = alias'
70+ }
6971
7072 merge2 :: Unify ()
71− merge2 = liftIO $ do
72− if rank desc1 < rank desc2 then UF.union variable2 variable1
73− else UF.union variable1 variable2
74− UF.modifyDescriptor variable2 $ \desc ->
75− desc { structure = structure desc2
73+ merge2 =
74+ liftIO $ do
75+ if rank desc1 < rank desc2
76+ then UF.union variable2 variable1
77+ else UF.union variable1 variable2
78+ UF.modifyDescriptor variable2 $ \desc ->
79+ desc { structure = structure desc2
80+ , flex = flex'
81+ , name = name'
82+ , alias = alias'
83+ }
84+
85+ merge =
86+ if rank desc1 < rank desc2 then merge1 else merge2
87+
88+ fresh :: Maybe (Term1 Variable) -> Unify Variable
89+ fresh structure =
90+ do v <- liftIO . UF.fresh $ Descriptor
91+ { structure = structure
92+ , rank = rank'
7693 , flex = flex'
7794 , name = name'
95+ , copy = Nothing
96+ , mark = noMark
7897 , alias = alias'
7998 }
99+ lift (TS.register v)
80100
81− merge = if rank desc1 < rank desc2 then merge1 else merge2
82−
83− fresh :: Maybe (Term1 Variable) -> Unify Variable
84− fresh structure = do
85− v <- liftIO . UF.fresh $ Descriptor
86− { structure = structure
87− , rank = rank'
88− , flex = flex'
89− , name = name'
90− , copy = Nothing
91− , mark = noMark
92− , alias = alias'
93− }
94− lift (TS.register v)
95−
96− flexAndUnify v = do
97− liftIO $ UF.modifyDescriptor v $ \desc -> desc { flex = Flexible }
98− unifyHelp' variable1 variable2
101+ flexAndUnify v =
102+ do liftIO $ UF.modifyDescriptor v $ \desc -> desc { flex = Flexible }
103+ unifyHelp' variable1 variable2
99104
100105 unifyNumber svar (Var.Canonical home name) =
101106 case home of
@@ -127,24 +132,28 @@ actuallyUnify region variable1 variable2 = do
127132 _ -> comparableError Nothing
128133
129134 unifyComparableStructure varSuper varFlex =
130− do struct <- liftIO $ collectApps varFlex
131− case struct of
132− Other -> comparableError Nothing
133− List v -> do flexAndUnify varSuper
134− unifyHelp' v =<< liftIO (variable $ Is Comparable)
135− Tuple vs
136− | length vs > 6 ->
137− comparableError $ Just "Cannot compare a tuple with more than 6 elements."
138− | otherwise ->
139− do flexAndUnify varSuper
135+ do struct <- liftIO $ collectApps varFlex
136+ case struct of
137+ Other ->
138+ comparableError Nothing
139+
140+ List v ->
141+ do flexAndUnify varSuper
142+ unifyHelp' v =<< liftIO (variable $ Is Comparable)
143+
144+ Tuple vs
145+ | length vs > 6 ->
146+ comparableError $ Just "Cannot compare a tuple with more than 6 elements."
147+ | otherwise ->
148+ do flexAndUnify varSuper
140149 cmpVars <- liftIO $ forM [1..length vs] $ \_ -> variable (Is Comparable)
141150 zipWithM_ unifyHelp' vs cmpVars
142151
143152 unifyAppendable varSuper varFlex =
144− do struct <- liftIO $ collectApps varFlex
145− case struct of
146− List _ -> flexAndUnify varSuper
147− _ -> appendableError Nothing
153+ do struct <- liftIO $ collectApps varFlex
154+ case struct of
155+ List _ -> flexAndUnify varSuper
156+ _ -> appendableError Nothing
148157
149158 rigidError var =
150159 typeError region (Just hint) variable1 variable2
@@ -160,7 +169,7 @@ actuallyUnify region variable1 variable2 = do
160169 | super1 == super2 -> merge
161170 (Is Number, Is Comparable, _, _) -> merge1
162171 (Is Comparable, Is Number, _, _) -> merge2
163−
172+
164173 (Is Number, _, _, Just name) -> unifyNumber variable1 name
165174 (_, Is Number, Just name, _) -> unifyNumber variable2 name
166175
@@ -181,15 +190,26 @@ actuallyUnify region variable1 variable2 = do
181190 _ -> typeError region Nothing variable1 variable2
182191
183192 case (structure desc1, structure desc2) of
184− (Nothing, Nothing) | flex desc1 == Flexible && flex desc1 == Flexible -> merge
185− (Nothing, _) | flex desc1 == Flexible -> merge2
186− (_, Nothing) | flex desc2 == Flexible -> merge1
193+ (Nothing, Nothing) | flex desc1 == Flexible && flex desc1 == Flexible ->
194+ merge
195+
196+ (Nothing, _) | flex desc1 == Flexible ->
197+ merge2
198+
199+ (_, Nothing) | flex desc2 == Flexible ->
200+ merge1
201+
202+ (Just (Var1 v), _) ->
203+ unifyHelp' v variable2
204+
205+ (_, Just (Var1 v)) ->
206+ unifyHelp' v variable1
187207
188− (Just (Var1 v), _) -> unifyHelp' v variable2
189− (_, Just (Var1 v)) -> unifyHelp' v variable1
208+ (Nothing, _) ->
209+ superUnify
190210
191− (Nothing, _) -> superUnify
192− (_, Nothing) -> superUnify
211+ (_, Nothing) ->
212+ superUnify
193213
194214 (Just type1, Just type2) ->
195215 case (type1,type2) of
@@ -288,7 +308,7 @@ unifyOverlappingFields
288308 -> Unify ()
289309unifyOverlappingFields region fields1 fields2 =
290310 Map.intersectionWith (zipWith (unifyHelp region)) fields1 fields2
291− |> Map.elems
311+ |> Map.elems
292312 |> concat
293313 |> sequence_
294314
@@ -338,36 +358,42 @@ fieldMismatchError missingFields =
338358 ++ List.intercalate ", " (init keys) ++ ", and " ++ last keys
339359
340360
341−combinedDescriptors :: Descriptor -> Descriptor
342− -> (Maybe Var.Canonical, Flex, Int, Maybe Var.Canonical)
361+combinedDescriptors
362+ :: Descriptor
363+ -> Descriptor
364+ -> (Maybe Var.Canonical, Flex, Int, Maybe Var.Canonical)
343365combinedDescriptors desc1 desc2 =
344366 (name', flex', rank', alias')
345367 where
346368 rank' :: Int
347− rank' = min (rank desc1) (rank desc2)
369+ rank' =
370+ min (rank desc1) (rank desc2)
348371
349372 alias' :: Maybe Var.Canonical
350− alias' = alias desc1 <|> alias desc2
373+ alias' =
374+ alias desc1 <|> alias desc2
351375
352376 name' :: Maybe Var.Canonical
353− name' = case (name desc1, name desc2) of
354− (Just name1, Just name2) ->
355− case (flex desc1, flex desc2) of
356− (_, Flexible) -> Just name1
357− (Flexible, _) -> Just name2
358− (Is Number, Is _) -> Just name1
359− (Is _, Is Number) -> Just name2
360− (Is _, Is _) -> Just name1
361− (_, _) -> Nothing
362− (Just name1, _) -> Just name1
363− (_, Just name2) -> Just name2
364− _ -> Nothing
377+ name' =
378+ case (name desc1, name desc2) of
379+ (Just name1, Just name2) ->
380+ case (flex desc1, flex desc2) of
381+ (_, Flexible) -> Just name1
382+ (Flexible, _) -> Just name2
383+ (Is Number, Is _) -> Just name1
384+ (Is _, Is Number) -> Just name2
385+ (Is _, Is _) -> Just name1
386+ (_, _) -> Nothing
387+ (Just name1, _) -> Just name1
388+ (_, Just name2) -> Just name2
389+ _ -> Nothing
365390
366391 flex' :: Flex
367− flex' = case (flex desc1, flex desc2) of
368− (f, Flexible) -> f
369− (Flexible, f) -> f
370− (Is Number, Is _) -> Is Number
371− (Is _, Is Number) -> Is Number
372− (Is super, Is _) -> Is super
373− (_, _) -> Flexible
392+ flex' =
393+ case (flex desc1, flex desc2) of
394+ (f, Flexible) -> f
395+ (Flexible, f) -> f
396+ (Is Number, Is _) -> Is Number
397+ (Is _, Is Number) -> Is Number
398+ (Is super, Is _) -> Is super
399+ (_, _) -> Flexible