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