git.iko.soy/elk
on d87affe help sign in
elk/src/Type/Unify.hs
348 lines 13 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 _ ->
80 let hint = "Looks like something besides an Int or Float is being used as a number."
81 in
82 TS.addError region (Just hint) variable1 variable2
84 comparableError maybe =
85 TS.addError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2
86 where
87 msg =
88 "Looks like you want something comparable, but the only valid comparable\n\
89 \types are Int, Float, Char, String, lists, or tuples."
91 appendableError maybe =
92 TS.addError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2
93 where
94 msg =
95 "Looks like you want something appendable, but the only Strings, Lists,\n\
96 \and Text can be appended with the (++) operator."
98 unifyComparable v (Var.Canonical home name) =
99 case home of
100 Var.BuiltIn | name `elem` ["Int","Float","Char","String"] -> flexAndUnify v
101 Var.Local | List.isPrefixOf "comparable" name -> flexAndUnify v
102 _ -> comparableError Nothing
104 unifyComparableStructure varSuper varFlex =
105 do struct <- liftIO $ collectApps varFlex
106 case struct of
107 Other -> comparableError Nothing
108 List v -> do flexAndUnify varSuper
109 unify' v =<< liftIO (variable $ Is Comparable)
110 Tuple vs
111 | length vs > 6 ->
112 comparableError $ Just "Cannot compare a tuple with more than 6 elements."
113 | otherwise ->
114 do flexAndUnify varSuper
115 cmpVars <- liftIO $ forM [1..length vs] $ \_ -> variable (Is Comparable)
116 zipWithM_ unify' vs cmpVars
118 unifyAppendable varSuper varFlex =
119 do struct <- liftIO $ collectApps varFlex
120 case struct of
121 List _ -> flexAndUnify varSuper
122 _ -> appendableError Nothing
124 rigidError var =
125 TS.addError region (Just hint) variable1 variable2
126 where
127 hint =
128 "Could not unify rigid type variable '" ++ render (pretty Never var) ++ "'.\n" ++
129 "The problem probably relates to the type variable being shared between a\n\
130 \top-level type annotation and a related let-bound type annotation."
132 superUnify =
133 case (flex desc1, flex desc2, name desc1, name desc2) of
134 (Is super1, Is super2, _, _)
135 | super1 == super2 -> merge
136 (Is Number, Is Comparable, _, _) -> merge1
137 (Is Comparable, Is Number, _, _) -> merge2
139 (Is Number, _, _, Just name) -> unifyNumber variable1 name
140 (_, Is Number, Just name, _) -> unifyNumber variable2 name
142 (Is Comparable, _, _, Just name) -> unifyComparable variable1 name
143 (_, Is Comparable, Just name, _) -> unifyComparable variable2 name
144 (Is Comparable, _, _, _) -> unifyComparableStructure variable1 variable2
145 (_, Is Comparable, _, _) -> unifyComparableStructure variable2 variable1
147 (Is Appendable, _, _, Just name)
148 | Var.isText name || Var.isPrim "String" name -> flexAndUnify variable1
149 (_, Is Appendable, Just name, _)
150 | Var.isText name || Var.isPrim "String" name -> flexAndUnify variable2
151 (Is Appendable, _, _, _) -> unifyAppendable variable1 variable2
152 (_, Is Appendable, _, _) -> unifyAppendable variable2 variable1
154 (Rigid, _, _, _) -> rigidError variable1
155 (_, Rigid, _, _) -> rigidError variable2
156 _ -> TS.addError region Nothing variable1 variable2
158 case (structure desc1, structure desc2) of
159 (Nothing, Nothing) | flex desc1 == Flexible && flex desc1 == Flexible -> merge
160 (Nothing, _) | flex desc1 == Flexible -> merge2
161 (_, Nothing) | flex desc2 == Flexible -> merge1
163 (Just (Var1 v), _) -> unify' v variable2
164 (_, Just (Var1 v)) -> unify' v variable1
166 (Nothing, _) -> superUnify
167 (_, Nothing) -> superUnify
169 (Just type1, Just type2) ->
170 case (type1,type2) of
171 (App1 term1 term2, App1 term1' term2') ->
172 do merge
173 unify' term1 term1'
174 unify' term2 term2'
175 (Fun1 term1 term2, Fun1 term1' term2') ->
176 do merge
177 unify' term1 term1'
178 unify' term2 term2'
180 (EmptyRecord1, EmptyRecord1) ->
181 return ()
183 (Record1 fields ext, EmptyRecord1) | Map.null fields -> unify' ext variable2
184 (EmptyRecord1, Record1 fields ext) | Map.null fields -> unify' ext variable1
186 (Record1 _ _, Record1 _ _) ->
187 recordUnify region fresh variable1 variable2
189 _ -> TS.addError region Nothing variable1 variable2
192-- RECORD UNIFICATION
194recordUnify
195 :: A.Region
196 -> (Maybe (Term1 Variable) -> StateT TS.SolverState IO Variable)
197 -> Variable
198 -> Variable
199 -> StateT TS.SolverState IO ()
200recordUnify region fresh variable1 variable2 =
201 do (ExpandedRecord fields1 ext1) <- liftIO (gatherFields variable1)
202 (ExpandedRecord fields2 ext2) <- liftIO (gatherFields variable2)
204 unifyOverlappingFields region fields1 fields2
206 let freshRecord fields ext =
207 fresh (Just (Record1 fields ext))
209 let uniqueFields1 = diffFields fields1 fields2
210 let uniqueFields2 = diffFields fields2 fields1
212 let addFieldMismatchError missingFields =
213 let msg = fieldMismatchError missingFields
214 in
215 TS.addError region (Just msg) variable1 variable2
217 case (ext1, ext2) of
218 (Empty _, Empty _) ->
219 case Map.null uniqueFields1 && Map.null uniqueFields2 of
220 True -> return ()
221 False -> TS.addError region Nothing variable1 variable2
223 (Empty var1, Extension var2) ->
224 case (Map.null uniqueFields1, Map.null uniqueFields2) of
225 (_, False) -> addFieldMismatchError uniqueFields2
226 (True, True) -> unify region var1 var2
227 (False, True) ->
228 do subRecord <- freshRecord uniqueFields1 var1
229 unify region subRecord var2
231 (Extension var1, Empty var2) ->
232 case (Map.null uniqueFields1, Map.null uniqueFields2) of
233 (False, _) -> addFieldMismatchError uniqueFields1
234 (True, True) -> unify region var1 var2
235 (True, False) ->
236 do subRecord <- freshRecord uniqueFields2 var2
237 unify region var1 subRecord
239 (Extension var1, Extension var2) ->
240 case (Map.null uniqueFields1, Map.null uniqueFields2) of
241 (True, True) ->
242 unify region var1 var2
244 (True, False) ->
245 do subRecord <- freshRecord uniqueFields2 var2
246 unify region var1 subRecord
248 (False, True) ->
249 do subRecord <- freshRecord uniqueFields1 var1
250 unify region subRecord var2
252 (False, False) ->
253 do record1' <- freshRecord uniqueFields1 =<< fresh Nothing
254 record2' <- freshRecord uniqueFields2 =<< fresh Nothing
255 unify region record1' var2
256 unify region var1 record2'
259unifyOverlappingFields
260 :: A.Region
261 -> Map.Map String [Variable]
262 -> Map.Map String [Variable]
263 -> StateT TS.SolverState IO ()
264unifyOverlappingFields region fields1 fields2 =
265 Map.intersectionWith (zipWith (unify region)) fields1 fields2
266 |> Map.elems
267 |> concat
268 |> sequence_
271diffFields :: Map.Map String [a] -> Map.Map String [a] -> Map.Map String [a]
272diffFields fields1 fields2 =
273 let eat (_:xs) (_:ys) = eat xs ys
274 eat xs _ = xs
275 in
276 Map.union (Map.intersectionWith eat fields1 fields2) fields1
277 |> Map.filter (not . null)
280data ExpandedRecord = ExpandedRecord
281 { fields :: Map.Map String [Variable]
282 , extension :: Extension
283 }
285data Extension = Empty Variable | Extension Variable
288gatherFields :: Variable -> IO ExpandedRecord
289gatherFields var =
290 do desc <- UF.descriptor var
291 case structure desc of
292 (Just (Record1 fields ext)) ->
293 do (ExpandedRecord deeperFields rootExt) <- gatherFields ext
294 return (ExpandedRecord (Map.unionWith (++) fields deeperFields) rootExt)
296 (Just EmptyRecord1) ->
297 return (ExpandedRecord Map.empty (Empty var))
299 _ ->
300 return (ExpandedRecord Map.empty (Extension var))
303-- assumes that one of the dicts has stuff in it
304fieldMismatchError :: Map.Map String a -> String
305fieldMismatchError missingFields =
306 case Map.keys missingFields of
307 [] -> ""
308 [key] ->
309 "Looks like a record is missing the field '" ++ key ++ "'.\n" ++
310 "Maybe there is a misspelling in a record access or record update?"
311 keys ->
312 "Looks like one record is missing fields "
313 ++ List.intercalate ", " (init keys) ++ ", and " ++ last keys
316combinedDescriptors :: Descriptor -> Descriptor
317 -> (Maybe Var.Canonical, Flex, Int, Maybe Var.Canonical)
318combinedDescriptors desc1 desc2 =
319 (name', flex', rank', alias')
320 where
321 rank' :: Int
322 rank' = min (rank desc1) (rank desc2)
324 alias' :: Maybe Var.Canonical
325 alias' = alias desc1 <|> alias desc2
327 name' :: Maybe Var.Canonical
328 name' = case (name desc1, name desc2) of
329 (Just name1, Just name2) ->
330 case (flex desc1, flex desc2) of
331 (_, Flexible) -> Just name1
332 (Flexible, _) -> Just name2
333 (Is Number, Is _) -> Just name1
334 (Is _, Is Number) -> Just name2
335 (Is _, Is _) -> Just name1
336 (_, _) -> Nothing
337 (Just name1, _) -> Just name1
338 (_, Just name2) -> Just name2
339 _ -> Nothing
341 flex' :: Flex
342 flex' = case (flex desc1, flex desc2) of
343 (f, Flexible) -> f
344 (Flexible, f) -> f
345 (Is Number, Is _) -> Is Number
346 (Is _, Is Number) -> Is Number
347 (Is super, Is _) -> Is super
348 (_, _) -> Flexible