git.iko.soy/elk
on ca5f9da help sign in
elk/src/Type/Unify.hs
409 lines 14 kB history raw
1module Type.Unify (unify) where
3import Control.Applicative ((<|>))
4import Control.Monad.Except (ExceptT, throwError, runExceptT)
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.Variable as Var
13import qualified Reporting.Region as R
14import qualified Reporting.Error.Type as Error
15import qualified Type.State as TS
16import Type.Type as Type
17import Type.PrettyPrint
18import Elm.Utils ((|>))
21unify
22 :: Error.Hint
23 -> R.Region
24 -> Variable
25 -> Variable
26 -> StateT TS.SolverState IO ()
27unify hint region variable1 variable2 =
28 do result <- runExceptT (unifyHelp variable1 variable2)
29 case result of
30 Right state ->
31 return state
33 Left (Error.MismatchInfo maybeMessage leftType rightType) ->
34 let
35 trueHint = Error.mergeHint hint maybeMessage
36 in
37 TS.addError region $ Error.Mismatch $
38 Error.MismatchInfo trueHint leftType rightType
41-- ACTUALLY UNIFY STUFF
43type Unify =
44 ExceptT (Error.Mismatch (Maybe String)) (StateT TS.SolverState IO)
47typeError
48 :: Maybe String
49 -> UF.Point Descriptor
50 -> UF.Point Descriptor
51 -> Unify a
52typeError hint leftType rightType =
53 do leftSrcType <- liftIO (toSrcType leftType)
54 rightSrcType <- liftIO (toSrcType rightType)
55 throwError (Error.MismatchInfo hint leftSrcType rightSrcType)
58unifyHelp :: Variable -> Variable -> Unify ()
59unifyHelp variable1 variable2 =
60 do equivalent <- liftIO $ UF.equivalent variable1 variable2
61 if equivalent
62 then return ()
63 else actuallyUnify variable1 variable2
66actuallyUnify :: Variable -> Variable -> Unify ()
67actuallyUnify variable1 variable2 = do
68 desc1 <- liftIO $ UF.descriptor variable1
69 desc2 <- liftIO $ UF.descriptor variable2
70 let (name', flex', rank', alias') = combinedDescriptors desc1 desc2
72 merge1 :: Unify ()
73 merge1 =
74 liftIO $ do
75 if rank desc1 < rank desc2
76 then UF.union variable2 variable1
77 else UF.union variable1 variable2
78 UF.modifyDescriptor variable1 $ \desc ->
79 desc { structure = structure desc1
80 , flex = flex'
81 , name = name'
82 , alias = alias'
83 }
85 merge2 :: Unify ()
86 merge2 =
87 liftIO $ do
88 if rank desc1 < rank desc2
89 then UF.union variable2 variable1
90 else UF.union variable1 variable2
91 UF.modifyDescriptor variable2 $ \desc ->
92 desc { structure = structure desc2
93 , flex = flex'
94 , name = name'
95 , alias = alias'
96 }
98 merge =
99 if rank desc1 < rank desc2 then merge1 else merge2
101 fresh :: Maybe (Term1 Variable) -> Unify Variable
102 fresh structure =
103 do v <- liftIO . UF.fresh $ Descriptor
104 { structure = structure
105 , rank = rank'
106 , flex = flex'
107 , name = name'
108 , copy = Nothing
109 , mark = noMark
110 , alias = alias'
111 }
112 lift (TS.register v)
114 flexAndUnify v =
115 do liftIO $ UF.modifyDescriptor v $ \desc -> desc { flex = Flexible }
116 unifyHelp variable1 variable2
118 unifyNumber svar (Var.Canonical home name) =
119 case home of
120 Var.BuiltIn | name `elem` ["Int","Float"] -> flexAndUnify svar
121 Var.Local | List.isPrefixOf "number" name -> flexAndUnify svar
122 _ ->
123 let hint = "Looks like something besides an Int or Float is being used as a number."
124 in
125 typeError (Just hint) variable1 variable2
127 comparableError maybe =
128 typeError (Just $ Maybe.fromMaybe msg maybe) variable1 variable2
129 where
130 msg =
131 "Looks like you want something comparable, but the only valid comparable\n\
132 \types are Int, Float, Char, String, lists, and tuples."
134 appendableError maybe =
135 typeError (Just $ Maybe.fromMaybe msg maybe) variable1 variable2
136 where
137 msg =
138 "Looks like you want something appendable, but the only Strings, Lists,\n\
139 \and Text can be appended with the (++) operator."
141 unifyComparable v (Var.Canonical home name) =
142 case home of
143 Var.BuiltIn | name `elem` ["Int","Float","Char","String"] -> flexAndUnify v
144 Var.Local | List.isPrefixOf "comparable" name -> flexAndUnify v
145 _ -> comparableError Nothing
147 unifyComparableStructure varSuper varFlex =
148 do struct <- liftIO $ collectApps varFlex
149 case struct of
150 Other ->
151 comparableError Nothing
153 List v ->
154 do flexAndUnify varSuper
155 unifyHelp v =<< liftIO (variable $ Is Comparable)
157 Tuple vs
158 | length vs > 6 ->
159 comparableError $ Just "Cannot compare a tuple with more than 6 elements."
160 | otherwise ->
161 do flexAndUnify varSuper
162 cmpVars <- liftIO $ forM [1..length vs] $ \_ -> variable (Is Comparable)
163 zipWithM_ unifyHelp vs cmpVars
165 unifyAppendable varSuper varFlex =
166 do struct <- liftIO $ collectApps varFlex
167 case struct of
168 List _ -> flexAndUnify varSuper
169 _ -> appendableError Nothing
171 rigidError var =
172 typeError (Just hint) variable1 variable2
173 where
174 hint =
175 "Could not unify rigid type variable '" ++ render (pretty Never var) ++ "'.\n" ++
176 "The problem probably relates to the type variable being shared between a\n\
177 \top-level type annotation and a related let-bound type annotation."
179 superUnify =
180 case (flex desc1, flex desc2, name desc1, name desc2) of
181 (Is super1, Is super2, _, _)
182 | super1 == super2 -> merge
183 (Is Number, Is Comparable, _, _) -> merge1
184 (Is Comparable, Is Number, _, _) -> merge2
186 (Is Number, _, _, Just name) -> unifyNumber variable1 name
187 (_, Is Number, Just name, _) -> unifyNumber variable2 name
189 (Is Comparable, _, _, Just name) -> unifyComparable variable1 name
190 (_, Is Comparable, Just name, _) -> unifyComparable variable2 name
191 (Is Comparable, _, _, _) -> unifyComparableStructure variable1 variable2
192 (_, Is Comparable, _, _) -> unifyComparableStructure variable2 variable1
194 (Is Appendable, _, _, Just name)
195 | Var.isText name || Var.isPrim "String" name -> flexAndUnify variable1
196 (_, Is Appendable, Just name, _)
197 | Var.isText name || Var.isPrim "String" name -> flexAndUnify variable2
198 (Is Appendable, _, _, _) -> unifyAppendable variable1 variable2
199 (_, Is Appendable, _, _) -> unifyAppendable variable2 variable1
201 (Rigid, _, _, _) -> rigidError variable1
202 (_, Rigid, _, _) -> rigidError variable2
203 _ -> typeError Nothing variable1 variable2
205 case (structure desc1, structure desc2) of
206 (Nothing, Nothing) | flex desc1 == Flexible && flex desc1 == Flexible ->
207 merge
209 (Nothing, _) | flex desc1 == Flexible ->
210 merge2
212 (_, Nothing) | flex desc2 == Flexible ->
213 merge1
215 (Just (Var1 v), _) ->
216 unifyHelp v variable2
218 (_, Just (Var1 v)) ->
219 unifyHelp variable1 v
221 (Nothing, _) ->
222 superUnify
224 (_, Nothing) ->
225 superUnify
227 (Just type1, Just type2) ->
228 case (type1,type2) of
229 (App1 term1 term2, App1 term1' term2') ->
230 do merge
231 unifyHelp term1 term1'
232 unifyHelp term2 term2'
233 (Fun1 term1 term2, Fun1 term1' term2') ->
234 do merge
235 unifyHelp term1 term1'
236 unifyHelp term2 term2'
238 (EmptyRecord1, EmptyRecord1) ->
239 return ()
241 (Record1 fields ext, EmptyRecord1) | Map.null fields -> unifyHelp ext variable2
242 (EmptyRecord1, Record1 fields ext) | Map.null fields -> unifyHelp variable1 ext
244 (Record1 _ _, Record1 _ _) ->
245 recordUnify fresh variable1 variable2
247 _ -> typeError Nothing variable1 variable2
250-- RECORD UNIFICATION
252recordUnify
253 :: (Maybe (Term1 Variable) -> Unify Variable)
254 -> Variable
255 -> Variable
256 -> Unify ()
257recordUnify fresh variable1 variable2 =
258 do (ExpandedRecord fields1 ext1) <- liftIO (gatherFields variable1)
259 (ExpandedRecord fields2 ext2) <- liftIO (gatherFields variable2)
261 unifyOverlappingFields fields1 fields2
263 let freshRecord fields ext =
264 fresh (Just (Record1 fields ext))
266 let uniqueFields1 = diffFields fields1 fields2
267 let uniqueFields2 = diffFields fields2 fields1
269 let addFieldMismatchError missingFields =
270 let msg = fieldMismatchError missingFields
271 in
272 typeError (Just msg) variable1 variable2
274 case (ext1, ext2) of
275 (Empty _, Empty _) ->
276 case Map.null uniqueFields1 && Map.null uniqueFields2 of
277 True -> return ()
278 False -> typeError Nothing variable1 variable2
280 (Empty var1, Extension var2) ->
281 case (Map.null uniqueFields1, Map.null uniqueFields2) of
282 (_, False) -> addFieldMismatchError uniqueFields2
283 (True, True) -> unifyHelp var1 var2
284 (False, True) ->
285 do subRecord <- freshRecord uniqueFields1 var1
286 unifyHelp subRecord var2
288 (Extension var1, Empty var2) ->
289 case (Map.null uniqueFields1, Map.null uniqueFields2) of
290 (False, _) -> addFieldMismatchError uniqueFields1
291 (True, True) -> unifyHelp var1 var2
292 (True, False) ->
293 do subRecord <- freshRecord uniqueFields2 var2
294 unifyHelp var1 subRecord
296 (Extension var1, Extension var2) ->
297 case (Map.null uniqueFields1, Map.null uniqueFields2) of
298 (True, True) ->
299 unifyHelp var1 var2
301 (True, False) ->
302 do subRecord <- freshRecord uniqueFields2 var2
303 unifyHelp var1 subRecord
305 (False, True) ->
306 do subRecord <- freshRecord uniqueFields1 var1
307 unifyHelp subRecord var2
309 (False, False) ->
310 do record1' <- freshRecord uniqueFields1 =<< fresh Nothing
311 record2' <- freshRecord uniqueFields2 =<< fresh Nothing
312 unifyHelp record1' var2
313 unifyHelp var1 record2'
316unifyOverlappingFields
317 :: Map.Map String [Variable]
318 -> Map.Map String [Variable]
319 -> Unify ()
320unifyOverlappingFields fields1 fields2 =
321 Map.intersectionWith (zipWith unifyHelp) fields1 fields2
322 |> Map.elems
323 |> concat
324 |> sequence_
327diffFields :: Map.Map String [a] -> Map.Map String [a] -> Map.Map String [a]
328diffFields fields1 fields2 =
329 let eat (_:xs) (_:ys) = eat xs ys
330 eat xs _ = xs
331 in
332 Map.union (Map.intersectionWith eat fields1 fields2) fields1
333 |> Map.filter (not . null)
336data ExpandedRecord = ExpandedRecord
337 { _fields :: Map.Map String [Variable]
338 , _extension :: Extension
339 }
341data Extension = Empty Variable | Extension Variable
344gatherFields :: Variable -> IO ExpandedRecord
345gatherFields var =
346 do desc <- UF.descriptor var
347 case structure desc of
348 (Just (Record1 fields ext)) ->
349 do (ExpandedRecord deeperFields rootExt) <- gatherFields ext
350 return (ExpandedRecord (Map.unionWith (++) fields deeperFields) rootExt)
352 (Just EmptyRecord1) ->
353 return (ExpandedRecord Map.empty (Empty var))
355 _ ->
356 return (ExpandedRecord Map.empty (Extension var))
359-- assumes that one of the dicts has stuff in it
360fieldMismatchError :: Map.Map String a -> String
361fieldMismatchError missingFields =
362 case Map.keys missingFields of
363 [] -> ""
364 [key] ->
365 "Looks like a record is missing the field '" ++ key ++ "'"
366 keys ->
367 "Looks like a record is missing fields "
368 ++ List.intercalate ", " (init keys) ++ ", and " ++ last keys
371combinedDescriptors
372 :: Descriptor
373 -> Descriptor
374 -> (Maybe Var.Canonical, Flex, Int, Alias Variable)
375combinedDescriptors desc1 desc2 =
376 (name', flex', rank', alias')
377 where
378 rank' :: Int
379 rank' =
380 min (rank desc1) (rank desc2)
382 alias' :: Alias Variable
383 alias' =
384 alias desc1 <|> alias desc2
386 name' :: Maybe Var.Canonical
387 name' =
388 case (name desc1, name desc2) of
389 (Just name1, Just name2) ->
390 case (flex desc1, flex desc2) of
391 (_, Flexible) -> Just name1
392 (Flexible, _) -> Just name2
393 (Is Number, Is _) -> Just name1
394 (Is _, Is Number) -> Just name2
395 (Is _, Is _) -> Just name1
396 (_, _) -> Nothing
397 (Just name1, _) -> Just name1
398 (_, Just name2) -> Just name2
399 _ -> Nothing
401 flex' :: Flex
402 flex' =
403 case (flex desc1, flex desc2) of
404 (f, Flexible) -> f
405 (Flexible, f) -> f
406 (Is Number, Is _) -> Is Number
407 (Is _, Is Number) -> Is Number
408 (Is super, Is _) -> Is super
409 (_, _) -> Flexible