git.iko.soy/elk
on 9b0c310 help sign in
elk/src/Type/Unify.hs
400 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
17import Type.PrettyPrint
18import Elm.Utils ((|>))
21unify :: R.Region -> Variable -> Variable -> StateT TS.SolverState IO ()
22unify region variable1 variable2 =
23 do result <- runExceptT (unifyHelp variable1 variable2)
24 case result of
25 Right state ->
26 return state
28 Left mismatch ->
29 TS.addError region (Error.Mismatch mismatch)
32-- ACTUALLY UNIFY STUFF
34type Unify = ExceptT Error.Mismatch (StateT TS.SolverState IO)
37typeError
38 :: Maybe String
39 -> UF.Point Descriptor
40 -> UF.Point Descriptor
41 -> Unify a
42typeError hint leftType rightType =
43 do leftSrcType <- liftIO (toSrcType leftType)
44 rightSrcType <- liftIO (toSrcType rightType)
45 throwError (Error.MismatchInfo hint leftSrcType rightSrcType)
48unifyHelp :: Variable -> Variable -> Unify ()
49unifyHelp variable1 variable2 =
50 do equivalent <- liftIO $ UF.equivalent variable1 variable2
51 if equivalent
52 then return ()
53 else actuallyUnify variable1 variable2
56actuallyUnify :: Variable -> Variable -> Unify ()
57actuallyUnify variable1 variable2 = do
58 desc1 <- liftIO $ UF.descriptor variable1
59 desc2 <- liftIO $ UF.descriptor variable2
60 let (name', flex', rank', alias') = combinedDescriptors desc1 desc2
62 merge1 :: Unify ()
63 merge1 =
64 liftIO $ do
65 if rank desc1 < rank desc2
66 then UF.union variable2 variable1
67 else UF.union variable1 variable2
68 UF.modifyDescriptor variable1 $ \desc ->
69 desc { structure = structure desc1
70 , flex = flex'
71 , name = name'
72 , alias = alias'
73 }
75 merge2 :: Unify ()
76 merge2 =
77 liftIO $ do
78 if rank desc1 < rank desc2
79 then UF.union variable2 variable1
80 else UF.union variable1 variable2
81 UF.modifyDescriptor variable2 $ \desc ->
82 desc { structure = structure desc2
83 , flex = flex'
84 , name = name'
85 , alias = alias'
86 }
88 merge =
89 if rank desc1 < rank desc2 then merge1 else merge2
91 fresh :: Maybe (Term1 Variable) -> Unify Variable
92 fresh structure =
93 do v <- liftIO . UF.fresh $ Descriptor
94 { structure = structure
95 , rank = rank'
96 , flex = flex'
97 , name = name'
98 , copy = Nothing
99 , mark = noMark
100 , alias = alias'
101 }
102 lift (TS.register v)
104 flexAndUnify v =
105 do liftIO $ UF.modifyDescriptor v $ \desc -> desc { flex = Flexible }
106 unifyHelp variable1 variable2
108 unifyNumber svar (Var.Canonical home name) =
109 case home of
110 Var.BuiltIn | name `elem` ["Int","Float"] -> flexAndUnify svar
111 Var.Local | List.isPrefixOf "number" name -> flexAndUnify svar
112 _ ->
113 let hint = "Looks like something besides an Int or Float is being used as a number."
114 in
115 typeError (Just hint) variable1 variable2
117 comparableError maybe =
118 typeError (Just $ Maybe.fromMaybe msg maybe) variable1 variable2
119 where
120 msg =
121 "Looks like you want something comparable, but the only valid comparable\n\
122 \types are Int, Float, Char, String, lists, and tuples."
124 appendableError maybe =
125 typeError (Just $ Maybe.fromMaybe msg maybe) variable1 variable2
126 where
127 msg =
128 "Looks like you want something appendable, but the only Strings, Lists,\n\
129 \and Text can be appended with the (++) operator."
131 unifyComparable v (Var.Canonical home name) =
132 case home of
133 Var.BuiltIn | name `elem` ["Int","Float","Char","String"] -> flexAndUnify v
134 Var.Local | List.isPrefixOf "comparable" name -> flexAndUnify v
135 _ -> comparableError Nothing
137 unifyComparableStructure varSuper varFlex =
138 do struct <- liftIO $ collectApps varFlex
139 case struct of
140 Other ->
141 comparableError Nothing
143 List v ->
144 do flexAndUnify varSuper
145 unifyHelp v =<< liftIO (variable $ Is Comparable)
147 Tuple vs
148 | length vs > 6 ->
149 comparableError $ Just "Cannot compare a tuple with more than 6 elements."
150 | otherwise ->
151 do flexAndUnify varSuper
152 cmpVars <- liftIO $ forM [1..length vs] $ \_ -> variable (Is Comparable)
153 zipWithM_ unifyHelp vs cmpVars
155 unifyAppendable varSuper varFlex =
156 do struct <- liftIO $ collectApps varFlex
157 case struct of
158 List _ -> flexAndUnify varSuper
159 _ -> appendableError Nothing
161 rigidError var =
162 typeError (Just hint) variable1 variable2
163 where
164 hint =
165 "Could not unify rigid type variable '" ++ render (pretty Never var) ++ "'.\n" ++
166 "The problem probably relates to the type variable being shared between a\n\
167 \top-level type annotation and a related let-bound type annotation."
169 superUnify =
170 case (flex desc1, flex desc2, name desc1, name desc2) of
171 (Is super1, Is super2, _, _)
172 | super1 == super2 -> merge
173 (Is Number, Is Comparable, _, _) -> merge1
174 (Is Comparable, Is Number, _, _) -> merge2
176 (Is Number, _, _, Just name) -> unifyNumber variable1 name
177 (_, Is Number, Just name, _) -> unifyNumber variable2 name
179 (Is Comparable, _, _, Just name) -> unifyComparable variable1 name
180 (_, Is Comparable, Just name, _) -> unifyComparable variable2 name
181 (Is Comparable, _, _, _) -> unifyComparableStructure variable1 variable2
182 (_, Is Comparable, _, _) -> unifyComparableStructure variable2 variable1
184 (Is Appendable, _, _, Just name)
185 | Var.isText name || Var.isPrim "String" name -> flexAndUnify variable1
186 (_, Is Appendable, Just name, _)
187 | Var.isText name || Var.isPrim "String" name -> flexAndUnify variable2
188 (Is Appendable, _, _, _) -> unifyAppendable variable1 variable2
189 (_, Is Appendable, _, _) -> unifyAppendable variable2 variable1
191 (Rigid, _, _, _) -> rigidError variable1
192 (_, Rigid, _, _) -> rigidError variable2
193 _ -> typeError Nothing variable1 variable2
195 case (structure desc1, structure desc2) of
196 (Nothing, Nothing) | flex desc1 == Flexible && flex desc1 == Flexible ->
197 merge
199 (Nothing, _) | flex desc1 == Flexible ->
200 merge2
202 (_, Nothing) | flex desc2 == Flexible ->
203 merge1
205 (Just (Var1 v), _) ->
206 unifyHelp v variable2
208 (_, Just (Var1 v)) ->
209 unifyHelp variable1 v
211 (Nothing, _) ->
212 superUnify
214 (_, Nothing) ->
215 superUnify
217 (Just type1, Just type2) ->
218 case (type1,type2) of
219 (App1 term1 term2, App1 term1' term2') ->
220 do merge
221 unifyHelp term1 term1'
222 unifyHelp term2 term2'
223 (Fun1 term1 term2, Fun1 term1' term2') ->
224 do merge
225 unifyHelp term1 term1'
226 unifyHelp term2 term2'
228 (EmptyRecord1, EmptyRecord1) ->
229 return ()
231 (Record1 fields ext, EmptyRecord1) | Map.null fields -> unifyHelp ext variable2
232 (EmptyRecord1, Record1 fields ext) | Map.null fields -> unifyHelp variable1 ext
234 (Record1 _ _, Record1 _ _) ->
235 recordUnify fresh variable1 variable2
237 _ -> typeError Nothing variable1 variable2
240-- RECORD UNIFICATION
242recordUnify
243 :: (Maybe (Term1 Variable) -> Unify Variable)
244 -> Variable
245 -> Variable
246 -> Unify ()
247recordUnify fresh variable1 variable2 =
248 do (ExpandedRecord fields1 ext1) <- liftIO (gatherFields variable1)
249 (ExpandedRecord fields2 ext2) <- liftIO (gatherFields variable2)
251 unifyOverlappingFields fields1 fields2
253 let freshRecord fields ext =
254 fresh (Just (Record1 fields ext))
256 let uniqueFields1 = diffFields fields1 fields2
257 let uniqueFields2 = diffFields fields2 fields1
259 let addFieldMismatchError missingFields =
260 let msg = fieldMismatchError missingFields
261 in
262 typeError (Just msg) variable1 variable2
264 case (ext1, ext2) of
265 (Empty _, Empty _) ->
266 case Map.null uniqueFields1 && Map.null uniqueFields2 of
267 True -> return ()
268 False -> typeError Nothing variable1 variable2
270 (Empty var1, Extension var2) ->
271 case (Map.null uniqueFields1, Map.null uniqueFields2) of
272 (_, False) -> addFieldMismatchError uniqueFields2
273 (True, True) -> unifyHelp var1 var2
274 (False, True) ->
275 do subRecord <- freshRecord uniqueFields1 var1
276 unifyHelp subRecord var2
278 (Extension var1, Empty var2) ->
279 case (Map.null uniqueFields1, Map.null uniqueFields2) of
280 (False, _) -> addFieldMismatchError uniqueFields1
281 (True, True) -> unifyHelp var1 var2
282 (True, False) ->
283 do subRecord <- freshRecord uniqueFields2 var2
284 unifyHelp var1 subRecord
286 (Extension var1, Extension var2) ->
287 case (Map.null uniqueFields1, Map.null uniqueFields2) of
288 (True, True) ->
289 unifyHelp var1 var2
291 (True, False) ->
292 do subRecord <- freshRecord uniqueFields2 var2
293 unifyHelp var1 subRecord
295 (False, True) ->
296 do subRecord <- freshRecord uniqueFields1 var1
297 unifyHelp subRecord var2
299 (False, False) ->
300 do record1' <- freshRecord uniqueFields1 =<< fresh Nothing
301 record2' <- freshRecord uniqueFields2 =<< fresh Nothing
302 unifyHelp record1' var2
303 unifyHelp var1 record2'
306unifyOverlappingFields
307 :: Map.Map String [Variable]
308 -> Map.Map String [Variable]
309 -> Unify ()
310unifyOverlappingFields fields1 fields2 =
311 Map.intersectionWith (zipWith unifyHelp) fields1 fields2
312 |> Map.elems
313 |> concat
314 |> sequence_
317diffFields :: Map.Map String [a] -> Map.Map String [a] -> Map.Map String [a]
318diffFields fields1 fields2 =
319 let eat (_:xs) (_:ys) = eat xs ys
320 eat xs _ = xs
321 in
322 Map.union (Map.intersectionWith eat fields1 fields2) fields1
323 |> Map.filter (not . null)
326data ExpandedRecord = ExpandedRecord
327 { _fields :: Map.Map String [Variable]
328 , _extension :: Extension
329 }
331data Extension = Empty Variable | Extension Variable
334gatherFields :: Variable -> IO ExpandedRecord
335gatherFields var =
336 do desc <- UF.descriptor var
337 case structure desc of
338 (Just (Record1 fields ext)) ->
339 do (ExpandedRecord deeperFields rootExt) <- gatherFields ext
340 return (ExpandedRecord (Map.unionWith (++) fields deeperFields) rootExt)
342 (Just EmptyRecord1) ->
343 return (ExpandedRecord Map.empty (Empty var))
345 _ ->
346 return (ExpandedRecord Map.empty (Extension var))
349-- assumes that one of the dicts has stuff in it
350fieldMismatchError :: Map.Map String a -> String
351fieldMismatchError missingFields =
352 case Map.keys missingFields of
353 [] -> ""
354 [key] ->
355 "Looks like a record is missing the field '" ++ key ++ "'.\n"
356 ++ "Maybe there is a misspelling?"
357 keys ->
358 "Looks like a record is missing fields "
359 ++ List.intercalate ", " (init keys) ++ ", and " ++ last keys
362combinedDescriptors
363 :: Descriptor
364 -> Descriptor
365 -> (Maybe Var.Canonical, Flex, Int, Alias Variable)
366combinedDescriptors desc1 desc2 =
367 (name', flex', rank', alias')
368 where
369 rank' :: Int
370 rank' =
371 min (rank desc1) (rank desc2)
373 alias' :: Alias Variable
374 alias' =
375 alias desc1 <|> alias desc2
377 name' :: Maybe Var.Canonical
378 name' =
379 case (name desc1, name desc2) of
380 (Just name1, Just name2) ->
381 case (flex desc1, flex desc2) of
382 (_, Flexible) -> Just name1
383 (Flexible, _) -> Just name2
384 (Is Number, Is _) -> Just name1
385 (Is _, Is Number) -> Just name2
386 (Is _, Is _) -> Just name1
387 (_, _) -> Nothing
388 (Just name1, _) -> Just name1
389 (_, Just name2) -> Just name2
390 _ -> Nothing
392 flex' :: Flex
393 flex' =
394 case (flex desc1, flex desc2) of
395 (f, Flexible) -> f
396 (Flexible, f) -> f
397 (Is Number, Is _) -> Is Number
398 (Is _, Is Number) -> Is Number
399 (Is super, Is _) -> Is super
400 (_, _) -> Flexible