git.iko.soy/elk
on 8aec074 help sign in
elk/src/Type/Unify.hs
438 lines 15 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.UnionFind.IO as UF
9import Text.PrettyPrint (render)
11import qualified AST.Type as AstType
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 (RawMismatch (leftType, rightType, note)) ->
34 TS.addError region $ Error.Mismatch $
35 Error.MismatchInfo hint leftType rightType note
38-- ACTUALLY UNIFY STUFF
40type Unify =
41 ExceptT RawMismatch (StateT TS.SolverState IO)
44newtype RawMismatch =
45 RawMismatch (AstType.Canonical, AstType.Canonical, Maybe String)
48typeError
49 :: UF.Point Descriptor
50 -> UF.Point Descriptor
51 -> Maybe String
52 -> Unify a
53typeError leftType rightType note =
54 do leftSrcType <- liftIO (Type.toSrcType leftType)
55 rightSrcType <- liftIO (Type.toSrcType rightType)
56 liftIO $ do
57 UF.setDescriptor leftType (Type.descriptor Error)
58 UF.setDescriptor rightType (Type.descriptor Error)
59 throwError (RawMismatch (leftSrcType, rightSrcType, note))
62unifyHelp :: Variable -> Variable -> Unify ()
63unifyHelp variable1 variable2 =
64 do equivalent <- liftIO $ UF.equivalent variable1 variable2
65 if equivalent
66 then return ()
67 else actuallyUnify variable1 variable2
70actuallyUnify :: Variable -> Variable -> Unify ()
71actuallyUnify variable1 variable2 = do
72 desc1 <- liftIO $ UF.descriptor variable1
73 desc2 <- liftIO $ UF.descriptor variable2
74 let (name', flex', rank', alias') = combinedDescriptors desc1 desc2
76 merge1 :: Unify ()
77 merge1 =
78 liftIO $ do
79 if rank desc1 < rank desc2
80 then UF.union variable2 variable1
81 else UF.union variable1 variable2
82 UF.modifyDescriptor variable1 $ \desc ->
83 desc { structure = structure desc1
84 , flex = flex'
85 , name = name'
86 , alias = alias'
87 }
89 merge2 :: Unify ()
90 merge2 =
91 liftIO $ do
92 if rank desc1 < rank desc2
93 then UF.union variable2 variable1
94 else UF.union variable1 variable2
95 UF.modifyDescriptor variable2 $ \desc ->
96 desc { structure = structure desc2
97 , flex = flex'
98 , name = name'
99 , alias = alias'
100 }
102 merge =
103 if rank desc1 < rank desc2 then merge1 else merge2
105 fresh :: Maybe (Term1 Variable) -> Unify Variable
106 fresh structure =
107 do v <- liftIO . UF.fresh $ Descriptor
108 { structure = structure
109 , rank = rank'
110 , flex = flex'
111 , name = name'
112 , copy = Nothing
113 , mark = noMark
114 , alias = alias'
115 }
116 lift (TS.register v)
118 flexAndUnify v =
119 do liftIO $ UF.modifyDescriptor v $ \desc -> desc { flex = Flexible }
120 unifyHelp variable1 variable2
122 unifyNumber svar (Var.Canonical home name) =
123 case home of
124 Var.BuiltIn | name `elem` ["Int","Float"] ->
125 flexAndUnify svar
127 Var.Local | List.isPrefixOf "number" name ->
128 flexAndUnify svar
130 Var.TopLevel _ | List.isPrefixOf "number" name ->
131 flexAndUnify svar
133 _ ->
134 typeError variable1 variable2 Nothing
136 comparableError maybeHint =
137 typeError variable1 variable2 $ Just $
138 "Note: comparable types include Int, Float, Char, String, lists, and tuples."
139 ++ maybe "" ("\n"++) maybeHint
141 appendableError =
142 typeError variable1 variable2 $ Just $
143 "Note: appendable types include only Strings, Lists, and Text."
145 unifyComparable v (Var.Canonical home name) =
146 case home of
147 Var.BuiltIn | name `elem` ["Int","Float","Char","String"] ->
148 flexAndUnify v
149 Var.Local | List.isPrefixOf "comparable" name ->
150 flexAndUnify v
151 _ ->
152 comparableError Nothing
154 unifyComparableStructure varSuper varFlex =
155 do struct <- liftIO $ collectApps varFlex
156 case struct of
157 Other ->
158 comparableError Nothing
160 List v ->
161 do flexAndUnify varSuper
162 unifyHelp v =<< liftIO (variable $ Is Comparable)
164 Tuple vs ->
165 if length vs > 6 then
166 comparableError $ Just $
167 "Furthermore, it cannot be a tuple with more than 6 elements."
168 else
169 do flexAndUnify varSuper
170 cmpVars <- liftIO $ forM [1..length vs] $ \_ -> variable (Is Comparable)
171 zipWithM_ unifyHelp vs cmpVars
173 unifyAppendable v cvar@(Var.Canonical home name) =
174 let
175 canUnify =
176 Var.isPrim "String" cvar
177 || Var.isText cvar
178 || Var.isLocal (List.isPrefixOf "comparable") cvar
179 || Var.isLocal (List.isPrefixOf "appendable") cvar
180 in
181 if canUnify then
182 flexAndUnify v
183 else
184 appendableError
186 unifyAppendableStructure varSuper varFlex =
187 do struct <- liftIO $ collectApps varFlex
188 case struct of
189 List _ -> flexAndUnify varSuper
190 _ -> appendableError
192 rigidError var =
193 typeError variable1 variable2 $ Just $
194 rigidErrorMessage (render (pretty Never var))
196 superUnify =
197 case (flex desc1, flex desc2, name desc1, name desc2) of
198 (Is super1, Is super2, _, _)
199 | super1 == super2 -> merge
200 (Is Number, Is Comparable, _, _) -> merge1
201 (Is Comparable, Is Number, _, _) -> merge2
203 (Is Number, _, _, Just name) -> unifyNumber variable1 name
204 (_, Is Number, Just name, _) -> unifyNumber variable2 name
206 (Is Appendable, _, _, Just name) -> unifyAppendable variable1 name
207 (_, Is Appendable, Just name, _) -> unifyAppendable variable2 name
208 (Is Appendable, _, _, _) -> unifyAppendableStructure variable1 variable2
209 (_, Is Appendable, _, _) -> unifyAppendableStructure variable2 variable1
211 (Is Comparable, _, _, Just name) -> unifyComparable variable1 name
212 (_, Is Comparable, Just name, _) -> unifyComparable variable2 name
213 (Is Comparable, _, _, _) -> unifyComparableStructure variable1 variable2
214 (_, Is Comparable, _, _) -> unifyComparableStructure variable2 variable1
216 (Rigid, _, _, _) -> rigidError variable1
217 (_, Rigid, _, _) -> rigidError variable2
218 _ -> typeError variable1 variable2 Nothing
220 case (structure desc1, structure desc2) of
221 (Nothing, Nothing)
222 | flex desc1 == Flexible && flex desc1 == Flexible ->
223 merge
225 (Nothing, _)
226 | flex desc1 == Flexible -> merge2
227 | flex desc1 == Error -> return ()
229 (_, Nothing)
230 | flex desc2 == Flexible -> merge1
231 | flex desc2 == Error -> return ()
233 (Just (Var1 v), _) ->
234 unifyHelp v variable2
236 (_, Just (Var1 v)) ->
237 unifyHelp variable1 v
239 (Nothing, _) ->
240 superUnify
242 (_, Nothing) ->
243 superUnify
245 (Just type1, Just type2) ->
246 case (type1,type2) of
247 (App1 term1 term2, App1 term1' term2') ->
248 do merge
249 unifyHelp term1 term1'
250 unifyHelp term2 term2'
251 (Fun1 term1 term2, Fun1 term1' term2') ->
252 do merge
253 unifyHelp term1 term1'
254 unifyHelp term2 term2'
256 (EmptyRecord1, EmptyRecord1) ->
257 return ()
259 (Record1 fields ext, EmptyRecord1) | Map.null fields -> unifyHelp ext variable2
260 (EmptyRecord1, Record1 fields ext) | Map.null fields -> unifyHelp variable1 ext
262 (Record1 _ _, Record1 _ _) ->
263 recordUnify fresh variable1 variable2
265 _ -> typeError variable1 variable2 Nothing
268-- RIGID ERROR
270rigidErrorMessage :: String -> String
271rigidErrorMessage var =
272 "Could not unify user provided type variable `" ++ var ++ "`. The most likely cases are:\n\n"
273 ++ " 1. The type you wrote down is too general. It says any type can go through\n"
274 ++ " but in fact only a certain type can.\n"
275 ++ " 2. A type variable is probably being shared between two type annotations.\n"
276 ++ " They are treated as different things in the current implementation, so\n"
277 ++ " Try commenting out some type annotations and see what happens."
280-- RECORD UNIFICATION
282recordUnify
283 :: (Maybe (Term1 Variable) -> Unify Variable)
284 -> Variable
285 -> Variable
286 -> Unify ()
287recordUnify fresh variable1 variable2 =
288 do (ExpandedRecord fields1 ext1) <- liftIO (gatherFields variable1)
289 (ExpandedRecord fields2 ext2) <- liftIO (gatherFields variable2)
291 unifyOverlappingFields fields1 fields2
293 let freshRecord fields ext =
294 fresh (Just (Record1 fields ext))
296 let uniqueFields1 = diffFields fields1 fields2
297 let uniqueFields2 = diffFields fields2 fields1
299 let addFieldMismatchError missingFields =
300 typeError variable1 variable2 $ Just $
301 fieldMismatchError missingFields
303 case (ext1, ext2) of
304 (Empty _, Empty _) ->
305 case Map.null uniqueFields1 && Map.null uniqueFields2 of
306 True -> return ()
307 False -> typeError variable1 variable2 Nothing
309 (Empty var1, Extension var2) ->
310 case (Map.null uniqueFields1, Map.null uniqueFields2) of
311 (_, False) -> addFieldMismatchError uniqueFields2
312 (True, True) -> unifyHelp var1 var2
313 (False, True) ->
314 do subRecord <- freshRecord uniqueFields1 var1
315 unifyHelp subRecord var2
317 (Extension var1, Empty var2) ->
318 case (Map.null uniqueFields1, Map.null uniqueFields2) of
319 (False, _) -> addFieldMismatchError uniqueFields1
320 (True, True) -> unifyHelp var1 var2
321 (True, False) ->
322 do subRecord <- freshRecord uniqueFields2 var2
323 unifyHelp var1 subRecord
325 (Extension var1, Extension var2) ->
326 case (Map.null uniqueFields1, Map.null uniqueFields2) of
327 (True, True) ->
328 unifyHelp var1 var2
330 (True, False) ->
331 do subRecord <- freshRecord uniqueFields2 var2
332 unifyHelp var1 subRecord
334 (False, True) ->
335 do subRecord <- freshRecord uniqueFields1 var1
336 unifyHelp subRecord var2
338 (False, False) ->
339 do record1' <- freshRecord uniqueFields1 =<< fresh Nothing
340 record2' <- freshRecord uniqueFields2 =<< fresh Nothing
341 unifyHelp record1' var2
342 unifyHelp var1 record2'
345unifyOverlappingFields
346 :: Map.Map String [Variable]
347 -> Map.Map String [Variable]
348 -> Unify ()
349unifyOverlappingFields fields1 fields2 =
350 Map.intersectionWith (zipWith unifyHelp) fields1 fields2
351 |> Map.elems
352 |> concat
353 |> sequence_
356diffFields :: Map.Map String [a] -> Map.Map String [a] -> Map.Map String [a]
357diffFields fields1 fields2 =
358 let eat (_:xs) (_:ys) = eat xs ys
359 eat xs _ = xs
360 in
361 Map.union (Map.intersectionWith eat fields1 fields2) fields1
362 |> Map.filter (not . null)
365data ExpandedRecord = ExpandedRecord
366 { _fields :: Map.Map String [Variable]
367 , _extension :: Extension
368 }
370data Extension = Empty Variable | Extension Variable
373gatherFields :: Variable -> IO ExpandedRecord
374gatherFields var =
375 do desc <- UF.descriptor var
376 case structure desc of
377 (Just (Record1 fields ext)) ->
378 do (ExpandedRecord deeperFields rootExt) <- gatherFields ext
379 return (ExpandedRecord (Map.unionWith (++) fields deeperFields) rootExt)
381 (Just EmptyRecord1) ->
382 return (ExpandedRecord Map.empty (Empty var))
384 _ ->
385 return (ExpandedRecord Map.empty (Extension var))
388-- assumes that one of the dicts has stuff in it
389fieldMismatchError :: Map.Map String a -> String
390fieldMismatchError missingFields =
391 case Map.keys missingFields of
392 [] -> ""
393 [key] ->
394 "Looks like a record is missing the field `" ++ key ++ "`"
395 keys ->
396 "Looks like a record is missing fields "
397 ++ List.intercalate ", " (init keys) ++ ", and " ++ last keys
400combinedDescriptors
401 :: Descriptor
402 -> Descriptor
403 -> (Maybe Var.Canonical, Flex, Int, Alias Variable)
404combinedDescriptors desc1 desc2 =
405 (name', flex', rank', alias')
406 where
407 rank' :: Int
408 rank' =
409 min (rank desc1) (rank desc2)
411 alias' :: Alias Variable
412 alias' =
413 alias desc1 <|> alias desc2
415 name' :: Maybe Var.Canonical
416 name' =
417 case (name desc1, name desc2) of
418 (Just name1, Just name2) ->
419 case (flex desc1, flex desc2) of
420 (_, Flexible) -> Just name1
421 (Flexible, _) -> Just name2
422 (Is Number, Is _) -> Just name1
423 (Is _, Is Number) -> Just name2
424 (Is _, Is _) -> Just name1
425 (_, _) -> Nothing
426 (Just name1, _) -> Just name1
427 (_, Just name2) -> Just name2
428 _ -> Nothing
430 flex' :: Flex
431 flex' =
432 case (flex desc1, flex desc2) of
433 (f, Flexible) -> f
434 (Flexible, f) -> f
435 (Is Number, Is _) -> Is Number
436 (Is _, Is Number) -> Is Number
437 (Is super, Is _) -> Is super
438 (_, _) -> Flexible