git.iko.soy/elk
on 87ba2bc help sign in
elk/src/Type/Unify.hs
248 lines 9.9 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)
15import Elm.Utils ((|>))
18unify :: A.Region -> Variable -> Variable -> StateT TS.SolverState IO ()
19unify region variable1 variable2 = do
20 equivalent <- liftIO $ UF.equivalent variable1 variable2
21 if equivalent
22 then return ()
23 else actuallyUnify region variable1 variable2
26actuallyUnify :: A.Region -> Variable -> Variable -> StateT TS.SolverState IO ()
27actuallyUnify region variable1 variable2 = do
28 desc1 <- liftIO $ UF.descriptor variable1
29 desc2 <- liftIO $ UF.descriptor variable2
30 let unify' = unify region
32 (name', flex', rank', alias') = combinedDescriptors desc1 desc2
34 merge1 :: StateT TS.SolverState IO ()
35 merge1 = liftIO $ do
36 if rank desc1 < rank desc2 then UF.union variable2 variable1
37 else UF.union variable1 variable2
38 UF.modifyDescriptor variable1 $ \desc ->
39 desc { structure = structure desc1
40 , flex = flex'
41 , name = name'
42 , alias = alias'
43 }
45 merge2 :: StateT TS.SolverState IO ()
46 merge2 = liftIO $ do
47 if rank desc1 < rank desc2 then UF.union variable2 variable1
48 else UF.union variable1 variable2
49 UF.modifyDescriptor variable2 $ \desc ->
50 desc { structure = structure desc2
51 , flex = flex'
52 , name = name'
53 , alias = alias'
54 }
56 merge = if rank desc1 < rank desc2 then merge1 else merge2
58 fresh :: Maybe (Term1 Variable) -> StateT TS.SolverState IO Variable
59 fresh structure = do
60 v <- liftIO . UF.fresh $ Descriptor
61 { structure = structure
62 , rank = rank'
63 , flex = flex'
64 , name = name'
65 , copy = Nothing
66 , mark = noMark
67 , alias = alias'
68 }
69 TS.register v
71 flexAndUnify v = do
72 liftIO $ UF.modifyDescriptor v $ \desc -> desc { flex = Flexible }
73 unify' variable1 variable2
75 unifyNumber svar (Var.Canonical home name) =
76 case home of
77 Var.BuiltIn | name `elem` ["Int","Float"] -> flexAndUnify svar
78 Var.Local | List.isPrefixOf "number" name -> flexAndUnify svar
79 _ -> let hint = "A number must be an Int or Float."
80 in TS.addError region (Just hint) variable1 variable2
82 comparableError maybe =
83 TS.addError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2
84 where msg = "A comparable must be an Int, Float, Char, String, list, or tuple."
86 appendableError maybe =
87 TS.addError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2
88 where msg = "An appendable must be of type String, List, or Text."
90 unifyComparable v (Var.Canonical home name) =
91 case home of
92 Var.BuiltIn | name `elem` ["Int","Float","Char","String"] -> flexAndUnify v
93 Var.Local | List.isPrefixOf "comparable" name -> flexAndUnify v
94 _ -> comparableError Nothing
96 unifyComparableStructure varSuper varFlex =
97 do struct <- liftIO $ collectApps varFlex
98 case struct of
99 Other -> comparableError Nothing
100 List v -> do flexAndUnify varSuper
101 unify' v =<< liftIO (variable $ Is Comparable)
102 Tuple vs
103 | length vs > 6 ->
104 comparableError $ Just "Cannot compare a tuple with more than 6 elements."
105 | otherwise ->
106 do flexAndUnify varSuper
107 cmpVars <- liftIO $ forM [1..length vs] $ \_ -> variable (Is Comparable)
108 zipWithM_ unify' vs cmpVars
110 unifyAppendable varSuper varFlex =
111 do struct <- liftIO $ collectApps varFlex
112 case struct of
113 List _ -> flexAndUnify varSuper
114 _ -> appendableError Nothing
116 rigidError var = TS.addError region (Just hint) variable1 variable2
117 where
118 var' = "'" ++ render (pretty Never var) ++ "'"
119 hint = "Cannot unify rigid type variable " ++ var' ++
120 ".\nThe problem probably relates to a type annotation. Note that rigid type\n\
121 \variables are not shared between a top-level and let-bound type annotations."
123 superUnify =
124 case (flex desc1, flex desc2, name desc1, name desc2) of
125 (Is super1, Is super2, _, _)
126 | super1 == super2 -> merge
127 (Is Number, Is Comparable, _, _) -> merge1
128 (Is Comparable, Is Number, _, _) -> merge2
130 (Is Number, _, _, Just name) -> unifyNumber variable1 name
131 (_, Is Number, Just name, _) -> unifyNumber variable2 name
133 (Is Comparable, _, _, Just name) -> unifyComparable variable1 name
134 (_, Is Comparable, Just name, _) -> unifyComparable variable2 name
135 (Is Comparable, _, _, _) -> unifyComparableStructure variable1 variable2
136 (_, Is Comparable, _, _) -> unifyComparableStructure variable2 variable1
138 (Is Appendable, _, _, Just name)
139 | Var.isText name || Var.isPrim "String" name -> flexAndUnify variable1
140 (_, Is Appendable, Just name, _)
141 | Var.isText name || Var.isPrim "String" name -> flexAndUnify variable2
142 (Is Appendable, _, _, _) -> unifyAppendable variable1 variable2
143 (_, Is Appendable, _, _) -> unifyAppendable variable2 variable1
145 (Rigid, _, _, _) -> rigidError variable1
146 (_, Rigid, _, _) -> rigidError variable2
147 _ -> TS.addError region Nothing variable1 variable2
149 case (structure desc1, structure desc2) of
150 (Nothing, Nothing) | flex desc1 == Flexible && flex desc1 == Flexible -> merge
151 (Nothing, _) | flex desc1 == Flexible -> merge2
152 (_, Nothing) | flex desc2 == Flexible -> merge1
154 (Just (Var1 v), _) -> unify' v variable2
155 (_, Just (Var1 v)) -> unify' v variable1
157 (Nothing, _) -> superUnify
158 (_, Nothing) -> superUnify
160 (Just type1, Just type2) ->
161 case (type1,type2) of
162 (App1 term1 term2, App1 term1' term2') ->
163 do merge
164 unify' term1 term1'
165 unify' term2 term2'
166 (Fun1 term1 term2, Fun1 term1' term2') ->
167 do merge
168 unify' term1 term1'
169 unify' term2 term2'
171 (EmptyRecord1, EmptyRecord1) ->
172 return ()
174 (Record1 fields ext, EmptyRecord1) | Map.null fields -> unify' ext variable2
175 (EmptyRecord1, Record1 fields ext) | Map.null fields -> unify' ext variable1
177 (Record1 fields1 ext1, Record1 fields2 ext2) ->
178 do Map.intersectionWith (zipWith unify') fields1 fields2
179 |> Map.elems
180 |> concat
181 |> sequence
183 let mkRecord fs ext =
184 fresh (Just (Record1 fs ext))
186 case (Map.null fields1', Map.null fields2') of
187 (True, True) ->
188 unify' ext1 ext2
190 (True, False) ->
191 do record2' <- mkRecord fields2' ext2
192 unify' ext1 record2'
194 (False, True) ->
195 do record1' <- mkRecord fields1' ext1
196 unify' record1' ext2
198 (False, False) ->
199 do record1' <- mkRecord fields1' =<< fresh Nothing
200 record2' <- mkRecord fields2' =<< fresh Nothing
201 unify' record1' ext2
202 unify' ext1 record2'
203 where
204 fields1' = unmerged fields1 fields2
205 fields2' = unmerged fields2 fields1
207 unmerged a b =
208 Map.union (Map.intersectionWith eat a b) a
209 |> Map.filter (not . null)
211 eat (_:xs) (_:ys) = eat xs ys
212 eat xs _ = xs
214 _ -> TS.addError region Nothing variable1 variable2
216combinedDescriptors :: Descriptor -> Descriptor
217 -> (Maybe Var.Canonical, Flex, Int, Maybe Var.Canonical)
218combinedDescriptors desc1 desc2 =
219 (name', flex', rank', alias')
220 where
221 rank' :: Int
222 rank' = min (rank desc1) (rank desc2)
224 alias' :: Maybe Var.Canonical
225 alias' = alias desc1 <|> alias desc2
227 name' :: Maybe Var.Canonical
228 name' = case (name desc1, name desc2) of
229 (Just name1, Just name2) ->
230 case (flex desc1, flex desc2) of
231 (_, Flexible) -> Just name1
232 (Flexible, _) -> Just name2
233 (Is Number, Is _) -> Just name1
234 (Is _, Is Number) -> Just name2
235 (Is _, Is _) -> Just name1
236 (_, _) -> Nothing
237 (Just name1, _) -> Just name1
238 (_, Just name2) -> Just name2
239 _ -> Nothing
241 flex' :: Flex
242 flex' = case (flex desc1, flex desc2) of
243 (f, Flexible) -> f
244 (Flexible, f) -> f
245 (Is Number, Is _) -> Is Number
246 (Is _, Is Number) -> Is Number
247 (Is super, Is _) -> Is super
248 (_, _) -> Flexible