git.iko.soy/elk
on fc4d628 help sign in
elk/src/Type/Unify.hs
427 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.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 (toSrcType leftType)
55 rightSrcType <- liftIO (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 varSuper varFlex =
174 do struct <- liftIO $ collectApps varFlex
175 case struct of
176 List _ -> flexAndUnify varSuper
177 _ -> appendableError
179 rigidError var =
180 typeError variable1 variable2 $ Just $
181 rigidErrorMessage (render (pretty Never var))
183 superUnify =
184 case (flex desc1, flex desc2, name desc1, name desc2) of
185 (Is super1, Is super2, _, _)
186 | super1 == super2 -> merge
187 (Is Number, Is Comparable, _, _) -> merge1
188 (Is Comparable, Is Number, _, _) -> merge2
190 (Is Number, _, _, Just name) -> unifyNumber variable1 name
191 (_, Is Number, Just name, _) -> unifyNumber variable2 name
193 (Is Comparable, _, _, Just name) -> unifyComparable variable1 name
194 (_, Is Comparable, Just name, _) -> unifyComparable variable2 name
195 (Is Comparable, _, _, _) -> unifyComparableStructure variable1 variable2
196 (_, Is Comparable, _, _) -> unifyComparableStructure variable2 variable1
198 (Is Appendable, _, _, Just name)
199 | Var.isText name || Var.isPrim "String" name -> flexAndUnify variable1
200 (_, Is Appendable, Just name, _)
201 | Var.isText name || Var.isPrim "String" name -> flexAndUnify variable2
202 (Is Appendable, _, _, _) -> unifyAppendable variable1 variable2
203 (_, Is Appendable, _, _) -> unifyAppendable variable2 variable1
205 (Rigid, _, _, _) -> rigidError variable1
206 (_, Rigid, _, _) -> rigidError variable2
207 _ -> typeError variable1 variable2 Nothing
209 case (structure desc1, structure desc2) of
210 (Nothing, Nothing)
211 | flex desc1 == Flexible && flex desc1 == Flexible ->
212 merge
214 (Nothing, _)
215 | flex desc1 == Flexible -> merge2
216 | flex desc1 == Error -> return ()
218 (_, Nothing)
219 | flex desc2 == Flexible -> merge1
220 | flex desc2 == Error -> return ()
222 (Just (Var1 v), _) ->
223 unifyHelp v variable2
225 (_, Just (Var1 v)) ->
226 unifyHelp variable1 v
228 (Nothing, _) ->
229 superUnify
231 (_, Nothing) ->
232 superUnify
234 (Just type1, Just type2) ->
235 case (type1,type2) of
236 (App1 term1 term2, App1 term1' term2') ->
237 do merge
238 unifyHelp term1 term1'
239 unifyHelp term2 term2'
240 (Fun1 term1 term2, Fun1 term1' term2') ->
241 do merge
242 unifyHelp term1 term1'
243 unifyHelp term2 term2'
245 (EmptyRecord1, EmptyRecord1) ->
246 return ()
248 (Record1 fields ext, EmptyRecord1) | Map.null fields -> unifyHelp ext variable2
249 (EmptyRecord1, Record1 fields ext) | Map.null fields -> unifyHelp variable1 ext
251 (Record1 _ _, Record1 _ _) ->
252 recordUnify fresh variable1 variable2
254 _ -> typeError variable1 variable2 Nothing
257-- RIGID ERROR
259rigidErrorMessage :: String -> String
260rigidErrorMessage var =
261 "Could not unify user provided type variable `" ++ var ++ "`. The most likely cases are:\n\n"
262 ++ " 1. The type you wrote down is too general. It says any type can go through\n"
263 ++ " but in fact only a certain type can.\n"
264 ++ " 2. A type variable is probably being shared between two type annotations.\n"
265 ++ " They are treated as different things in the current implementation, so\n"
266 ++ " Try commenting out some type annotations and see what happens."
269-- RECORD UNIFICATION
271recordUnify
272 :: (Maybe (Term1 Variable) -> Unify Variable)
273 -> Variable
274 -> Variable
275 -> Unify ()
276recordUnify fresh variable1 variable2 =
277 do (ExpandedRecord fields1 ext1) <- liftIO (gatherFields variable1)
278 (ExpandedRecord fields2 ext2) <- liftIO (gatherFields variable2)
280 unifyOverlappingFields fields1 fields2
282 let freshRecord fields ext =
283 fresh (Just (Record1 fields ext))
285 let uniqueFields1 = diffFields fields1 fields2
286 let uniqueFields2 = diffFields fields2 fields1
288 let addFieldMismatchError missingFields =
289 typeError variable1 variable2 $ Just $
290 fieldMismatchError missingFields
292 case (ext1, ext2) of
293 (Empty _, Empty _) ->
294 case Map.null uniqueFields1 && Map.null uniqueFields2 of
295 True -> return ()
296 False -> typeError variable1 variable2 Nothing
298 (Empty var1, Extension var2) ->
299 case (Map.null uniqueFields1, Map.null uniqueFields2) of
300 (_, False) -> addFieldMismatchError uniqueFields2
301 (True, True) -> unifyHelp var1 var2
302 (False, True) ->
303 do subRecord <- freshRecord uniqueFields1 var1
304 unifyHelp subRecord var2
306 (Extension var1, Empty var2) ->
307 case (Map.null uniqueFields1, Map.null uniqueFields2) of
308 (False, _) -> addFieldMismatchError uniqueFields1
309 (True, True) -> unifyHelp var1 var2
310 (True, False) ->
311 do subRecord <- freshRecord uniqueFields2 var2
312 unifyHelp var1 subRecord
314 (Extension var1, Extension var2) ->
315 case (Map.null uniqueFields1, Map.null uniqueFields2) of
316 (True, True) ->
317 unifyHelp var1 var2
319 (True, False) ->
320 do subRecord <- freshRecord uniqueFields2 var2
321 unifyHelp var1 subRecord
323 (False, True) ->
324 do subRecord <- freshRecord uniqueFields1 var1
325 unifyHelp subRecord var2
327 (False, False) ->
328 do record1' <- freshRecord uniqueFields1 =<< fresh Nothing
329 record2' <- freshRecord uniqueFields2 =<< fresh Nothing
330 unifyHelp record1' var2
331 unifyHelp var1 record2'
334unifyOverlappingFields
335 :: Map.Map String [Variable]
336 -> Map.Map String [Variable]
337 -> Unify ()
338unifyOverlappingFields fields1 fields2 =
339 Map.intersectionWith (zipWith unifyHelp) fields1 fields2
340 |> Map.elems
341 |> concat
342 |> sequence_
345diffFields :: Map.Map String [a] -> Map.Map String [a] -> Map.Map String [a]
346diffFields fields1 fields2 =
347 let eat (_:xs) (_:ys) = eat xs ys
348 eat xs _ = xs
349 in
350 Map.union (Map.intersectionWith eat fields1 fields2) fields1
351 |> Map.filter (not . null)
354data ExpandedRecord = ExpandedRecord
355 { _fields :: Map.Map String [Variable]
356 , _extension :: Extension
357 }
359data Extension = Empty Variable | Extension Variable
362gatherFields :: Variable -> IO ExpandedRecord
363gatherFields var =
364 do desc <- UF.descriptor var
365 case structure desc of
366 (Just (Record1 fields ext)) ->
367 do (ExpandedRecord deeperFields rootExt) <- gatherFields ext
368 return (ExpandedRecord (Map.unionWith (++) fields deeperFields) rootExt)
370 (Just EmptyRecord1) ->
371 return (ExpandedRecord Map.empty (Empty var))
373 _ ->
374 return (ExpandedRecord Map.empty (Extension var))
377-- assumes that one of the dicts has stuff in it
378fieldMismatchError :: Map.Map String a -> String
379fieldMismatchError missingFields =
380 case Map.keys missingFields of
381 [] -> ""
382 [key] ->
383 "Looks like a record is missing the field `" ++ key ++ "`"
384 keys ->
385 "Looks like a record is missing fields "
386 ++ List.intercalate ", " (init keys) ++ ", and " ++ last keys
389combinedDescriptors
390 :: Descriptor
391 -> Descriptor
392 -> (Maybe Var.Canonical, Flex, Int, Alias Variable)
393combinedDescriptors desc1 desc2 =
394 (name', flex', rank', alias')
395 where
396 rank' :: Int
397 rank' =
398 min (rank desc1) (rank desc2)
400 alias' :: Alias Variable
401 alias' =
402 alias desc1 <|> alias desc2
404 name' :: Maybe Var.Canonical
405 name' =
406 case (name desc1, name desc2) of
407 (Just name1, Just name2) ->
408 case (flex desc1, flex desc2) of
409 (_, Flexible) -> Just name1
410 (Flexible, _) -> Just name2
411 (Is Number, Is _) -> Just name1
412 (Is _, Is Number) -> Just name2
413 (Is _, Is _) -> Just name1
414 (_, _) -> Nothing
415 (Just name1, _) -> Just name1
416 (_, Just name2) -> Just name2
417 _ -> Nothing
419 flex' :: Flex
420 flex' =
421 case (flex desc1, flex desc2) of
422 (f, Flexible) -> f
423 (Flexible, f) -> f
424 (Is Number, Is _) -> Is Number
425 (Is _, Is Number) -> Is Number
426 (Is super, Is _) -> Is super
427 (_, _) -> Flexible