git.iko.soy/elk
on c19ccfe help sign in
elk/compiler/Type/Unify.hs
128 lines 5.2 kB history raw
1module Type.Unify (unify) where
3import Type.Type
4import qualified Data.UnionFind.IO as UF
5import qualified Type.State as TS
6import Control.Arrow (first,second)
7import Control.Monad.State
8import qualified Text.PrettyPrint as P
10unify :: Variable -> Variable -> StateT TS.SolverState IO ()
11unify variable1 variable2 = do
12 equivalent <- liftIO $ UF.equivalent variable1 variable2
13 if equivalent then return ()
14 else actuallyUnify variable1 variable2
16actuallyUnify :: Variable -> Variable -> StateT TS.SolverState IO ()
17actuallyUnify variable1 variable2 = do
18 desc1 <- liftIO $ UF.descriptor variable1
19 desc2 <- liftIO $ UF.descriptor variable2
20 let name' :: Maybe String
21 name' = case (name desc1, name desc2) of
22 (Just name1, Just name2) ->
23 case (flex desc1, flex desc2) of
24 (_, Flexible) -> Just name1
25 (Flexible, _) -> Just name2
26 (Is Number, Is _) -> Just name1
27 (Is _, Is Number) -> Just name2
28 (Is _, Is _) -> Just name1
29 (_, _) -> Nothing
30 (Just name1, _) -> Just name1
31 (_, Just name2) -> Just name2
32 _ -> Nothing
34 flex' :: Flex
35 flex' = case (flex desc1, flex desc2) of
36 (f, Flexible) -> f
37 (Flexible, f) -> f
38 (Is Number, Is _) -> Is Number
39 (Is _, Is Number) -> Is Number
40 (Is super, Is _) -> Is super
41 (_, _) -> Flexible
43 rank' :: Int
44 rank' = min (rank desc1) (rank desc2)
46 merge1 :: StateT TS.SolverState IO ()
47 merge1 = liftIO $ do
48 if rank desc1 < rank desc2 then UF.union variable2 variable1
49 else UF.union variable1 variable2
50 UF.modifyDescriptor variable1 $ \desc ->
51 desc { structure = structure desc1, flex = flex', name = name' }
53 merge2 :: StateT TS.SolverState IO ()
54 merge2 = liftIO $ do
55 if rank desc1 < rank desc2 then UF.union variable2 variable1
56 else UF.union variable1 variable2
57 UF.modifyDescriptor variable2 $ \desc ->
58 desc { structure = structure desc2, flex = flex', name = name' }
60 merge = if rank desc1 < rank desc2 then merge1 else merge2
62 fresh :: Maybe (Term1 Variable) -> StateT TS.SolverState IO Variable
63 fresh structure = do
64 var <- liftIO . UF.fresh $ Descriptor {
65 structure = structure, rank = rank', flex = flex',
66 name = name', copy = Nothing, mark = noMark
67 }
68 TS.register var
70 flexAndUnify var = do
71 liftIO $ UF.modifyDescriptor var $ \desc -> desc { flex = Flexible }
72 unify variable1 variable2
74 superUnify =
75 case (flex desc1, flex desc2, name desc1, name desc2) of
76 (Is super1, Is super2, _, _)
77 | super1 == super2 -> merge
78 (Is Number, Is Comparable, _, _) -> merge1
79 (Is Comparable, Is Number, _, _) -> merge2
81 (Is Number, _, _, Just name)
82 | name `elem` ["Int","Float"] -> flexAndUnify variable1
83 | otherwise -> TS.addError "Expecting a number (Int or Float)" variable1 variable2
85 (_, Is Number, Just name, _)
86 | name `elem` ["Int","Float"] -> flexAndUnify variable2
87 | otherwise -> TS.addError "Expecting a number (Int or Float)" variable1 variable2
89 (Is Comparable, _, _, Just name)
90 | name `elem` ["Int","Float","Char"] -> flexAndUnify variable1
91 | otherwise -> TS.addError "Expecting something comparable (Int, Float, Char, [comparable])." variable1 variable2
93 (_, Is Comparable, Just name, _)
94 | name `elem` ["Int","Float","Char"] -> flexAndUnify variable2
95 | otherwise -> TS.addError "Expecting something comparable (Int, Float, Char, [comparable])." variable1 variable2
97 _ -> TS.addError "The following types are not equal" variable1 variable2
99 case (structure desc1, structure desc2) of
100 (Nothing, Nothing) | flex desc1 == Flexible && flex desc1 == Flexible -> merge
101 (Nothing, _) | flex desc1 == Flexible -> merge2
102 (_, Nothing) | flex desc2 == Flexible -> merge1
104 (Just (Var1 v), _) -> unify v variable2
105 (_, Just (Var1 v)) -> unify v variable1
107 (Nothing, _) -> superUnify
108 (_, Nothing) -> superUnify
110 (Just type1, Just type2) ->
111 case (type1,type2) of
112 (App1 term1 term2, App1 term1' term2') ->
113 do merge
114 unify term1 term1'
115 unify term2 term2'
116 (Fun1 term1 term2, Fun1 term1' term2') ->
117 do merge
118 unify term1 term1'
119 unify term2 term2'
121 (EmptyRecord1, EmptyRecord1) ->
122 return ()
124 (Record1 fields1 ext1, Record1 fields2 ext2) ->
125 TS.addError "did not write record unification yet" variable1 variable2
127 _ -> TS.addError "could not unify types" variable1 variable2