git.iko.soy/elk
on fdcaaed help sign in
elk/src/Type/Unify.hs
232 lines 9.7 kB history raw
1module Type.Unify (unify) where
3import Control.Applicative ((<|>))
4import Control.Monad.State
5import qualified Data.List as List
6import qualified Data.Map as Map
7import qualified Data.Maybe as Maybe
8import qualified Data.UnionFind.IO as UF
9import qualified AST.Annotation as A
10import qualified AST.Variable as Var
11import qualified Type.State as TS
12import Type.Type
13import Type.PrettyPrint
14import Text.PrettyPrint (render)
16unify :: A.Region -> Variable -> Variable -> StateT TS.SolverState IO ()
17unify region variable1 variable2 = do
18 equivalent <- liftIO $ UF.equivalent variable1 variable2
19 if equivalent then return ()
20 else actuallyUnify region variable1 variable2
22actuallyUnify :: A.Region -> Variable -> Variable -> StateT TS.SolverState IO ()
23actuallyUnify region variable1 variable2 = do
24 desc1 <- liftIO $ UF.descriptor variable1
25 desc2 <- liftIO $ UF.descriptor variable2
26 let unify' = unify region
28 (name', flex', rank', alias') = combinedDescriptors desc1 desc2
30 merge1 :: StateT TS.SolverState IO ()
31 merge1 = liftIO $ do
32 if rank desc1 < rank desc2 then UF.union variable2 variable1
33 else UF.union variable1 variable2
34 UF.modifyDescriptor variable1 $ \desc ->
35 desc { structure = structure desc1
36 , flex = flex'
37 , name = name'
38 , alias = alias'
39 }
41 merge2 :: StateT TS.SolverState IO ()
42 merge2 = liftIO $ do
43 if rank desc1 < rank desc2 then UF.union variable2 variable1
44 else UF.union variable1 variable2
45 UF.modifyDescriptor variable2 $ \desc ->
46 desc { structure = structure desc2
47 , flex = flex'
48 , name = name'
49 , alias = alias'
50 }
52 merge = if rank desc1 < rank desc2 then merge1 else merge2
54 fresh :: Maybe (Term1 Variable) -> StateT TS.SolverState IO Variable
55 fresh structure = do
56 v <- liftIO . UF.fresh $ Descriptor
57 { structure = structure
58 , rank = rank'
59 , flex = flex'
60 , name = name'
61 , copy = Nothing
62 , mark = noMark
63 , alias = alias'
64 }
65 TS.register v
67 flexAndUnify v = do
68 liftIO $ UF.modifyDescriptor v $ \desc -> desc { flex = Flexible }
69 unify' variable1 variable2
71 unifyNumber svar (Var.Canonical home name) =
72 case home of
73 Var.BuiltIn | name `elem` ["Int","Float"] -> flexAndUnify svar
74 Var.Local | List.isPrefixOf "number" name -> flexAndUnify svar
75 _ -> let hint = "A number must be an Int or Float."
76 in TS.addError region (Just hint) variable1 variable2
78 comparableError maybe =
79 TS.addError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2
80 where msg = "A comparable must be an Int, Float, Char, String, list, or tuple."
82 appendableError maybe =
83 TS.addError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2
84 where msg = "An appendable must be of type String, List, or Text."
86 unifyComparable v (Var.Canonical home name) =
87 case home of
88 Var.BuiltIn | name `elem` ["Int","Float","Char","String"] -> flexAndUnify v
89 Var.Local | List.isPrefixOf "comparable" name -> flexAndUnify v
90 _ -> comparableError Nothing
92 unifyComparableStructure varSuper varFlex =
93 do struct <- liftIO $ collectApps varFlex
94 case struct of
95 Other -> comparableError Nothing
96 List v -> do flexAndUnify varSuper
97 unify' v =<< liftIO (variable $ Is Comparable)
98 Tuple vs
99 | length vs > 6 ->
100 comparableError $ Just "Cannot compare a tuple with more than 6 elements."
101 | otherwise ->
102 do flexAndUnify varSuper
103 cmpVars <- liftIO $ forM [1..length vs] $ \_ -> variable (Is Comparable)
104 zipWithM_ unify' vs cmpVars
106 unifyAppendable varSuper varFlex =
107 do struct <- liftIO $ collectApps varFlex
108 case struct of
109 List _ -> flexAndUnify varSuper
110 _ -> appendableError Nothing
112 rigidError var = TS.addError region (Just hint) variable1 variable2
113 where
114 var' = "'" ++ render (pretty Never var) ++ "'"
115 hint = "Cannot unify rigid type variable " ++ var' ++
116 ".\nThe problem probably relates to a type annotation. Note that rigid type\n\
117 \variables are not shared between a top-level and let-bound type annotations."
119 superUnify =
120 case (flex desc1, flex desc2, name desc1, name desc2) of
121 (Is super1, Is super2, _, _)
122 | super1 == super2 -> merge
123 (Is Number, Is Comparable, _, _) -> merge1
124 (Is Comparable, Is Number, _, _) -> merge2
126 (Is Number, _, _, Just name) -> unifyNumber variable1 name
127 (_, Is Number, Just name, _) -> unifyNumber variable2 name
129 (Is Comparable, _, _, Just name) -> unifyComparable variable1 name
130 (_, Is Comparable, Just name, _) -> unifyComparable variable2 name
131 (Is Comparable, _, _, _) -> unifyComparableStructure variable1 variable2
132 (_, Is Comparable, _, _) -> unifyComparableStructure variable2 variable1
134 (Is Appendable, _, _, Just name)
135 | Var.isText name || Var.isPrim "String" name -> flexAndUnify variable1
136 (_, Is Appendable, Just name, _)
137 | Var.isText name || Var.isPrim "String" name -> flexAndUnify variable2
138 (Is Appendable, _, _, _) -> unifyAppendable variable1 variable2
139 (_, Is Appendable, _, _) -> unifyAppendable variable2 variable1
141 (Rigid, _, _, _) -> rigidError variable1
142 (_, Rigid, _, _) -> rigidError variable2
143 _ -> TS.addError region Nothing variable1 variable2
145 case (structure desc1, structure desc2) of
146 (Nothing, Nothing) | flex desc1 == Flexible && flex desc1 == Flexible -> merge
147 (Nothing, _) | flex desc1 == Flexible -> merge2
148 (_, Nothing) | flex desc2 == Flexible -> merge1
150 (Just (Var1 v), _) -> unify' v variable2
151 (_, Just (Var1 v)) -> unify' v variable1
153 (Nothing, _) -> superUnify
154 (_, Nothing) -> superUnify
156 (Just type1, Just type2) ->
157 case (type1,type2) of
158 (App1 term1 term2, App1 term1' term2') ->
159 do merge
160 unify' term1 term1'
161 unify' term2 term2'
162 (Fun1 term1 term2, Fun1 term1' term2') ->
163 do merge
164 unify' term1 term1'
165 unify' term2 term2'
167 (EmptyRecord1, EmptyRecord1) ->
168 return ()
170 (Record1 fields ext, EmptyRecord1) | Map.null fields -> unify' ext variable2
171 (EmptyRecord1, Record1 fields ext) | Map.null fields -> unify' ext variable1
173 (Record1 fields1 ext1, Record1 fields2 ext2) ->
174 do sequence . concat . Map.elems $ Map.intersectionWith (zipWith unify') fields1 fields2
175 let mkRecord fs ext = fresh . Just $ Record1 fs ext
176 case (Map.null fields1', Map.null fields2') of
177 (True , True ) -> unify' ext1 ext2
178 (True , False) -> do
179 record2' <- mkRecord fields2' ext2
180 unify' ext1 record2'
181 (False, True ) -> do
182 record1' <- mkRecord fields1' ext1
183 unify' record1' ext2
184 (False, False) -> do
185 record1' <- mkRecord fields1' =<< fresh Nothing
186 record2' <- mkRecord fields2' =<< fresh Nothing
187 unify' record1' ext2
188 unify' ext1 record2'
189 where
190 fields1' = unmerged fields1 fields2
191 fields2' = unmerged fields2 fields1
193 unmerged a b = Map.filter (not . null) $ Map.union (Map.intersectionWith eat a b) a
195 eat (_:xs) (_:ys) = eat xs ys
196 eat xs _ = xs
198 _ -> TS.addError region Nothing variable1 variable2
200combinedDescriptors :: Descriptor -> Descriptor
201 -> (Maybe Var.Canonical, Flex, Int, Maybe Var.Canonical)
202combinedDescriptors desc1 desc2 =
203 (name', flex', rank', alias')
204 where
205 rank' :: Int
206 rank' = min (rank desc1) (rank desc2)
208 alias' :: Maybe Var.Canonical
209 alias' = alias desc1 <|> alias desc2
211 name' :: Maybe Var.Canonical
212 name' = case (name desc1, name desc2) of
213 (Just name1, Just name2) ->
214 case (flex desc1, flex desc2) of
215 (_, Flexible) -> Just name1
216 (Flexible, _) -> Just name2
217 (Is Number, Is _) -> Just name1
218 (Is _, Is Number) -> Just name2
219 (Is _, Is _) -> Just name1
220 (_, _) -> Nothing
221 (Just name1, _) -> Just name1
222 (_, Just name2) -> Just name2
223 _ -> Nothing
225 flex' :: Flex
226 flex' = case (flex desc1, flex desc2) of
227 (f, Flexible) -> f
228 (Flexible, f) -> f
229 (Is Number, Is _) -> Is Number
230 (Is _, Is Number) -> Is Number
231 (Is super, Is _) -> Is super
232 (_, _) -> Flexible