git.iko.soy/elk
on 501c607 help sign in
elk/src/Type/Unify.hs
399 lines 14 kB history raw
1module Type.Unify (unify) where
3import Control.Applicative ((<|>))
4import Control.Monad.Error (ErrorT, throwError, runErrorT)
5import Control.Monad.State as 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 Text.PrettyPrint (render)
12import qualified AST.Annotation as A
13import qualified AST.Variable as Var
14import qualified Type.State as TS
15import Type.Type
16import Type.PrettyPrint
17import qualified Type.Hint as Hint
18import Elm.Utils ((|>))
21unify :: A.Region -> Variable -> Variable -> StateT TS.SolverState IO ()
22unify region variable1 variable2 =
23 do result <- runErrorT (unifyHelp region variable1 variable2)
24 either TS.addHint return result
27-- ACTUALLY UNIFY STUFF
29type Unify = ErrorT Hint.Hint (StateT TS.SolverState IO)
32typeError
33 :: A.Region
34 -> Maybe String
35 -> UF.Point Descriptor
36 -> UF.Point Descriptor
37 -> Unify a
38typeError region hint t1 t2 =
39 do msg <- liftIO (Hint.create region hint t1 t2)
40 throwError msg
43unifyHelp :: A.Region -> Variable -> Variable -> Unify ()
44unifyHelp region variable1 variable2 = do
45 equivalent <- liftIO $ UF.equivalent variable1 variable2
46 if equivalent
47 then return ()
48 else actuallyUnify region variable1 variable2
51actuallyUnify :: A.Region -> Variable -> Variable -> Unify ()
52actuallyUnify region variable1 variable2 = do
53 desc1 <- liftIO $ UF.descriptor variable1
54 desc2 <- liftIO $ UF.descriptor variable2
55 let unifyHelp' = unifyHelp region
57 (name', flex', rank', alias') = combinedDescriptors desc1 desc2
59 merge1 :: Unify ()
60 merge1 =
61 liftIO $ do
62 if rank desc1 < rank desc2
63 then UF.union variable2 variable1
64 else UF.union variable1 variable2
65 UF.modifyDescriptor variable1 $ \desc ->
66 desc { structure = structure desc1
67 , flex = flex'
68 , name = name'
69 , alias = alias'
70 }
72 merge2 :: Unify ()
73 merge2 =
74 liftIO $ do
75 if rank desc1 < rank desc2
76 then UF.union variable2 variable1
77 else UF.union variable1 variable2
78 UF.modifyDescriptor variable2 $ \desc ->
79 desc { structure = structure desc2
80 , flex = flex'
81 , name = name'
82 , alias = alias'
83 }
85 merge =
86 if rank desc1 < rank desc2 then merge1 else merge2
88 fresh :: Maybe (Term1 Variable) -> Unify Variable
89 fresh structure =
90 do v <- liftIO . UF.fresh $ Descriptor
91 { structure = structure
92 , rank = rank'
93 , flex = flex'
94 , name = name'
95 , copy = Nothing
96 , mark = noMark
97 , alias = alias'
98 }
99 lift (TS.register v)
101 flexAndUnify v =
102 do liftIO $ UF.modifyDescriptor v $ \desc -> desc { flex = Flexible }
103 unifyHelp' variable1 variable2
105 unifyNumber svar (Var.Canonical home name) =
106 case home of
107 Var.BuiltIn | name `elem` ["Int","Float"] -> flexAndUnify svar
108 Var.Local | List.isPrefixOf "number" name -> flexAndUnify svar
109 _ ->
110 let hint = "Looks like something besides an Int or Float is being used as a number."
111 in
112 typeError region (Just hint) variable1 variable2
114 comparableError maybe =
115 typeError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2
116 where
117 msg =
118 "Looks like you want something comparable, but the only valid comparable\n\
119 \types are Int, Float, Char, String, lists, or tuples."
121 appendableError maybe =
122 typeError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2
123 where
124 msg =
125 "Looks like you want something appendable, but the only Strings, Lists,\n\
126 \and Text can be appended with the (++) operator."
128 unifyComparable v (Var.Canonical home name) =
129 case home of
130 Var.BuiltIn | name `elem` ["Int","Float","Char","String"] -> flexAndUnify v
131 Var.Local | List.isPrefixOf "comparable" name -> flexAndUnify v
132 _ -> comparableError Nothing
134 unifyComparableStructure varSuper varFlex =
135 do struct <- liftIO $ collectApps varFlex
136 case struct of
137 Other ->
138 comparableError Nothing
140 List v ->
141 do flexAndUnify varSuper
142 unifyHelp' v =<< liftIO (variable $ Is Comparable)
144 Tuple vs
145 | length vs > 6 ->
146 comparableError $ Just "Cannot compare a tuple with more than 6 elements."
147 | otherwise ->
148 do flexAndUnify varSuper
149 cmpVars <- liftIO $ forM [1..length vs] $ \_ -> variable (Is Comparable)
150 zipWithM_ unifyHelp' vs cmpVars
152 unifyAppendable varSuper varFlex =
153 do struct <- liftIO $ collectApps varFlex
154 case struct of
155 List _ -> flexAndUnify varSuper
156 _ -> appendableError Nothing
158 rigidError var =
159 typeError region (Just hint) variable1 variable2
160 where
161 hint =
162 "Could not unify rigid type variable '" ++ render (pretty Never var) ++ "'.\n" ++
163 "The problem probably relates to the type variable being shared between a\n\
164 \top-level type annotation and a related let-bound type annotation."
166 superUnify =
167 case (flex desc1, flex desc2, name desc1, name desc2) of
168 (Is super1, Is super2, _, _)
169 | super1 == super2 -> merge
170 (Is Number, Is Comparable, _, _) -> merge1
171 (Is Comparable, Is Number, _, _) -> merge2
173 (Is Number, _, _, Just name) -> unifyNumber variable1 name
174 (_, Is Number, Just name, _) -> unifyNumber variable2 name
176 (Is Comparable, _, _, Just name) -> unifyComparable variable1 name
177 (_, Is Comparable, Just name, _) -> unifyComparable variable2 name
178 (Is Comparable, _, _, _) -> unifyComparableStructure variable1 variable2
179 (_, Is Comparable, _, _) -> unifyComparableStructure variable2 variable1
181 (Is Appendable, _, _, Just name)
182 | Var.isText name || Var.isPrim "String" name -> flexAndUnify variable1
183 (_, Is Appendable, Just name, _)
184 | Var.isText name || Var.isPrim "String" name -> flexAndUnify variable2
185 (Is Appendable, _, _, _) -> unifyAppendable variable1 variable2
186 (_, Is Appendable, _, _) -> unifyAppendable variable2 variable1
188 (Rigid, _, _, _) -> rigidError variable1
189 (_, Rigid, _, _) -> rigidError variable2
190 _ -> typeError region Nothing variable1 variable2
192 case (structure desc1, structure desc2) of
193 (Nothing, Nothing) | flex desc1 == Flexible && flex desc1 == Flexible ->
194 merge
196 (Nothing, _) | flex desc1 == Flexible ->
197 merge2
199 (_, Nothing) | flex desc2 == Flexible ->
200 merge1
202 (Just (Var1 v), _) ->
203 unifyHelp' v variable2
205 (_, Just (Var1 v)) ->
206 unifyHelp' variable1 v
208 (Nothing, _) ->
209 superUnify
211 (_, Nothing) ->
212 superUnify
214 (Just type1, Just type2) ->
215 case (type1,type2) of
216 (App1 term1 term2, App1 term1' term2') ->
217 do merge
218 unifyHelp' term1 term1'
219 unifyHelp' term2 term2'
220 (Fun1 term1 term2, Fun1 term1' term2') ->
221 do merge
222 unifyHelp' term1 term1'
223 unifyHelp' term2 term2'
225 (EmptyRecord1, EmptyRecord1) ->
226 return ()
228 (Record1 fields ext, EmptyRecord1) | Map.null fields -> unifyHelp' ext variable2
229 (EmptyRecord1, Record1 fields ext) | Map.null fields -> unifyHelp' variable1 ext
231 (Record1 _ _, Record1 _ _) ->
232 recordUnify region fresh variable1 variable2
234 _ -> typeError region Nothing variable1 variable2
237-- RECORD UNIFICATION
239recordUnify
240 :: A.Region
241 -> (Maybe (Term1 Variable) -> Unify Variable)
242 -> Variable
243 -> Variable
244 -> Unify ()
245recordUnify region fresh variable1 variable2 =
246 do (ExpandedRecord fields1 ext1) <- liftIO (gatherFields variable1)
247 (ExpandedRecord fields2 ext2) <- liftIO (gatherFields variable2)
249 unifyOverlappingFields region fields1 fields2
251 let freshRecord fields ext =
252 fresh (Just (Record1 fields ext))
254 let uniqueFields1 = diffFields fields1 fields2
255 let uniqueFields2 = diffFields fields2 fields1
257 let addFieldMismatchError missingFields =
258 let msg = fieldMismatchError missingFields
259 in
260 typeError region (Just msg) variable1 variable2
262 case (ext1, ext2) of
263 (Empty _, Empty _) ->
264 case Map.null uniqueFields1 && Map.null uniqueFields2 of
265 True -> return ()
266 False -> typeError region Nothing variable1 variable2
268 (Empty var1, Extension var2) ->
269 case (Map.null uniqueFields1, Map.null uniqueFields2) of
270 (_, False) -> addFieldMismatchError uniqueFields2
271 (True, True) -> unifyHelp region var1 var2
272 (False, True) ->
273 do subRecord <- freshRecord uniqueFields1 var1
274 unifyHelp region subRecord var2
276 (Extension var1, Empty var2) ->
277 case (Map.null uniqueFields1, Map.null uniqueFields2) of
278 (False, _) -> addFieldMismatchError uniqueFields1
279 (True, True) -> unifyHelp region var1 var2
280 (True, False) ->
281 do subRecord <- freshRecord uniqueFields2 var2
282 unifyHelp region var1 subRecord
284 (Extension var1, Extension var2) ->
285 case (Map.null uniqueFields1, Map.null uniqueFields2) of
286 (True, True) ->
287 unifyHelp region var1 var2
289 (True, False) ->
290 do subRecord <- freshRecord uniqueFields2 var2
291 unifyHelp region var1 subRecord
293 (False, True) ->
294 do subRecord <- freshRecord uniqueFields1 var1
295 unifyHelp region subRecord var2
297 (False, False) ->
298 do record1' <- freshRecord uniqueFields1 =<< fresh Nothing
299 record2' <- freshRecord uniqueFields2 =<< fresh Nothing
300 unifyHelp region record1' var2
301 unifyHelp region var1 record2'
304unifyOverlappingFields
305 :: A.Region
306 -> Map.Map String [Variable]
307 -> Map.Map String [Variable]
308 -> Unify ()
309unifyOverlappingFields region fields1 fields2 =
310 Map.intersectionWith (zipWith (unifyHelp region)) fields1 fields2
311 |> Map.elems
312 |> concat
313 |> sequence_
316diffFields :: Map.Map String [a] -> Map.Map String [a] -> Map.Map String [a]
317diffFields fields1 fields2 =
318 let eat (_:xs) (_:ys) = eat xs ys
319 eat xs _ = xs
320 in
321 Map.union (Map.intersectionWith eat fields1 fields2) fields1
322 |> Map.filter (not . null)
325data ExpandedRecord = ExpandedRecord
326 { _fields :: Map.Map String [Variable]
327 , _extension :: Extension
328 }
330data Extension = Empty Variable | Extension Variable
333gatherFields :: Variable -> IO ExpandedRecord
334gatherFields var =
335 do desc <- UF.descriptor var
336 case structure desc of
337 (Just (Record1 fields ext)) ->
338 do (ExpandedRecord deeperFields rootExt) <- gatherFields ext
339 return (ExpandedRecord (Map.unionWith (++) fields deeperFields) rootExt)
341 (Just EmptyRecord1) ->
342 return (ExpandedRecord Map.empty (Empty var))
344 _ ->
345 return (ExpandedRecord Map.empty (Extension var))
348-- assumes that one of the dicts has stuff in it
349fieldMismatchError :: Map.Map String a -> String
350fieldMismatchError missingFields =
351 case Map.keys missingFields of
352 [] -> ""
353 [key] ->
354 "Looks like a record is missing the field '" ++ key ++ "'.\n " ++
355 "Maybe there is a misspelling in a record access or record update?"
356 keys ->
357 "Looks like one record is missing fields "
358 ++ List.intercalate ", " (init keys) ++ ", and " ++ last keys
361combinedDescriptors
362 :: Descriptor
363 -> Descriptor
364 -> (Maybe Var.Canonical, Flex, Int, Alias Variable)
365combinedDescriptors desc1 desc2 =
366 (name', flex', rank', alias')
367 where
368 rank' :: Int
369 rank' =
370 min (rank desc1) (rank desc2)
372 alias' :: Alias Variable
373 alias' =
374 alias desc1 <|> alias desc2
376 name' :: Maybe Var.Canonical
377 name' =
378 case (name desc1, name desc2) of
379 (Just name1, Just name2) ->
380 case (flex desc1, flex desc2) of
381 (_, Flexible) -> Just name1
382 (Flexible, _) -> Just name2
383 (Is Number, Is _) -> Just name1
384 (Is _, Is Number) -> Just name2
385 (Is _, Is _) -> Just name1
386 (_, _) -> Nothing
387 (Just name1, _) -> Just name1
388 (_, Just name2) -> Just name2
389 _ -> Nothing
391 flex' :: Flex
392 flex' =
393 case (flex desc1, flex desc2) of
394 (f, Flexible) -> f
395 (Flexible, f) -> f
396 (Is Number, Is _) -> Is Number
397 (Is _, Is Number) -> Is Number
398 (Is super, Is _) -> Is super
399 (_, _) -> Flexible