git.iko.soy/elk
on ce01547 help sign in
elk/src/Type/Unify.hs
423 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
129 _ ->
130 typeError variable1 variable2 Nothing
132 comparableError maybeHint =
133 typeError variable1 variable2 $ Just $
134 "Note: comparable types include Int, Float, Char, String, lists, and tuples."
135 ++ maybe "" ("\n"++) maybeHint
137 appendableError =
138 typeError variable1 variable2 $ Just $
139 "Note: appendable types include only Strings, Lists, and Text."
141 unifyComparable v (Var.Canonical home name) =
142 case home of
143 Var.BuiltIn | name `elem` ["Int","Float","Char","String"] ->
144 flexAndUnify v
145 Var.Local | List.isPrefixOf "comparable" name ->
146 flexAndUnify v
147 _ ->
148 comparableError Nothing
150 unifyComparableStructure varSuper varFlex =
151 do struct <- liftIO $ collectApps varFlex
152 case struct of
153 Other ->
154 comparableError Nothing
156 List v ->
157 do flexAndUnify varSuper
158 unifyHelp v =<< liftIO (variable $ Is Comparable)
160 Tuple vs ->
161 if length vs > 6 then
162 comparableError $ Just $
163 "Furthermore, it cannot be a tuple with more than 6 elements."
164 else
165 do flexAndUnify varSuper
166 cmpVars <- liftIO $ forM [1..length vs] $ \_ -> variable (Is Comparable)
167 zipWithM_ unifyHelp vs cmpVars
169 unifyAppendable varSuper varFlex =
170 do struct <- liftIO $ collectApps varFlex
171 case struct of
172 List _ -> flexAndUnify varSuper
173 _ -> appendableError
175 rigidError var =
176 typeError variable1 variable2 $ Just $
177 rigidErrorMessage (render (pretty Never var))
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 variable1 variable2 Nothing
205 case (structure desc1, structure desc2) of
206 (Nothing, Nothing)
207 | flex desc1 == Flexible && flex desc1 == Flexible ->
208 merge
210 (Nothing, _)
211 | flex desc1 == Flexible -> merge2
212 | flex desc1 == Error -> return ()
214 (_, Nothing)
215 | flex desc2 == Flexible -> merge1
216 | flex desc2 == Error -> return ()
218 (Just (Var1 v), _) ->
219 unifyHelp v variable2
221 (_, Just (Var1 v)) ->
222 unifyHelp variable1 v
224 (Nothing, _) ->
225 superUnify
227 (_, Nothing) ->
228 superUnify
230 (Just type1, Just type2) ->
231 case (type1,type2) of
232 (App1 term1 term2, App1 term1' term2') ->
233 do merge
234 unifyHelp term1 term1'
235 unifyHelp term2 term2'
236 (Fun1 term1 term2, Fun1 term1' term2') ->
237 do merge
238 unifyHelp term1 term1'
239 unifyHelp term2 term2'
241 (EmptyRecord1, EmptyRecord1) ->
242 return ()
244 (Record1 fields ext, EmptyRecord1) | Map.null fields -> unifyHelp ext variable2
245 (EmptyRecord1, Record1 fields ext) | Map.null fields -> unifyHelp variable1 ext
247 (Record1 _ _, Record1 _ _) ->
248 recordUnify fresh variable1 variable2
250 _ -> typeError variable1 variable2 Nothing
253-- RIGID ERROR
255rigidErrorMessage :: String -> String
256rigidErrorMessage var =
257 "Could not unify user provided type variable `" ++ var ++ "`. The most likely cases are:\n\n"
258 ++ " 1. The type you wrote down is too general. It says any type can go through\n"
259 ++ " but in fact only a certain type can.\n"
260 ++ " 2. A type variable is probably being shared between two type annotations.\n"
261 ++ " They are treated as different things in the current implementation, so\n"
262 ++ " Try commenting out some type annotations and see what happens."
265-- RECORD UNIFICATION
267recordUnify
268 :: (Maybe (Term1 Variable) -> Unify Variable)
269 -> Variable
270 -> Variable
271 -> Unify ()
272recordUnify fresh variable1 variable2 =
273 do (ExpandedRecord fields1 ext1) <- liftIO (gatherFields variable1)
274 (ExpandedRecord fields2 ext2) <- liftIO (gatherFields variable2)
276 unifyOverlappingFields fields1 fields2
278 let freshRecord fields ext =
279 fresh (Just (Record1 fields ext))
281 let uniqueFields1 = diffFields fields1 fields2
282 let uniqueFields2 = diffFields fields2 fields1
284 let addFieldMismatchError missingFields =
285 typeError variable1 variable2 $ Just $
286 fieldMismatchError missingFields
288 case (ext1, ext2) of
289 (Empty _, Empty _) ->
290 case Map.null uniqueFields1 && Map.null uniqueFields2 of
291 True -> return ()
292 False -> typeError variable1 variable2 Nothing
294 (Empty var1, Extension var2) ->
295 case (Map.null uniqueFields1, Map.null uniqueFields2) of
296 (_, False) -> addFieldMismatchError uniqueFields2
297 (True, True) -> unifyHelp var1 var2
298 (False, True) ->
299 do subRecord <- freshRecord uniqueFields1 var1
300 unifyHelp subRecord var2
302 (Extension var1, Empty var2) ->
303 case (Map.null uniqueFields1, Map.null uniqueFields2) of
304 (False, _) -> addFieldMismatchError uniqueFields1
305 (True, True) -> unifyHelp var1 var2
306 (True, False) ->
307 do subRecord <- freshRecord uniqueFields2 var2
308 unifyHelp var1 subRecord
310 (Extension var1, Extension var2) ->
311 case (Map.null uniqueFields1, Map.null uniqueFields2) of
312 (True, True) ->
313 unifyHelp var1 var2
315 (True, False) ->
316 do subRecord <- freshRecord uniqueFields2 var2
317 unifyHelp var1 subRecord
319 (False, True) ->
320 do subRecord <- freshRecord uniqueFields1 var1
321 unifyHelp subRecord var2
323 (False, False) ->
324 do record1' <- freshRecord uniqueFields1 =<< fresh Nothing
325 record2' <- freshRecord uniqueFields2 =<< fresh Nothing
326 unifyHelp record1' var2
327 unifyHelp var1 record2'
330unifyOverlappingFields
331 :: Map.Map String [Variable]
332 -> Map.Map String [Variable]
333 -> Unify ()
334unifyOverlappingFields fields1 fields2 =
335 Map.intersectionWith (zipWith unifyHelp) fields1 fields2
336 |> Map.elems
337 |> concat
338 |> sequence_
341diffFields :: Map.Map String [a] -> Map.Map String [a] -> Map.Map String [a]
342diffFields fields1 fields2 =
343 let eat (_:xs) (_:ys) = eat xs ys
344 eat xs _ = xs
345 in
346 Map.union (Map.intersectionWith eat fields1 fields2) fields1
347 |> Map.filter (not . null)
350data ExpandedRecord = ExpandedRecord
351 { _fields :: Map.Map String [Variable]
352 , _extension :: Extension
353 }
355data Extension = Empty Variable | Extension Variable
358gatherFields :: Variable -> IO ExpandedRecord
359gatherFields var =
360 do desc <- UF.descriptor var
361 case structure desc of
362 (Just (Record1 fields ext)) ->
363 do (ExpandedRecord deeperFields rootExt) <- gatherFields ext
364 return (ExpandedRecord (Map.unionWith (++) fields deeperFields) rootExt)
366 (Just EmptyRecord1) ->
367 return (ExpandedRecord Map.empty (Empty var))
369 _ ->
370 return (ExpandedRecord Map.empty (Extension var))
373-- assumes that one of the dicts has stuff in it
374fieldMismatchError :: Map.Map String a -> String
375fieldMismatchError missingFields =
376 case Map.keys missingFields of
377 [] -> ""
378 [key] ->
379 "Looks like a record is missing the field `" ++ key ++ "`"
380 keys ->
381 "Looks like a record is missing fields "
382 ++ List.intercalate ", " (init keys) ++ ", and " ++ last keys
385combinedDescriptors
386 :: Descriptor
387 -> Descriptor
388 -> (Maybe Var.Canonical, Flex, Int, Alias Variable)
389combinedDescriptors desc1 desc2 =
390 (name', flex', rank', alias')
391 where
392 rank' :: Int
393 rank' =
394 min (rank desc1) (rank desc2)
396 alias' :: Alias Variable
397 alias' =
398 alias desc1 <|> alias desc2
400 name' :: Maybe Var.Canonical
401 name' =
402 case (name desc1, name desc2) of
403 (Just name1, Just name2) ->
404 case (flex desc1, flex desc2) of
405 (_, Flexible) -> Just name1
406 (Flexible, _) -> Just name2
407 (Is Number, Is _) -> Just name1
408 (Is _, Is Number) -> Just name2
409 (Is _, Is _) -> Just name1
410 (_, _) -> Nothing
411 (Just name1, _) -> Just name1
412 (_, Just name2) -> Just name2
413 _ -> Nothing
415 flex' :: Flex
416 flex' =
417 case (flex desc1, flex desc2) of
418 (f, Flexible) -> f
419 (Flexible, f) -> f
420 (Is Number, Is _) -> Is Number
421 (Is _, Is Number) -> Is Number
422 (Is super, Is _) -> Is super
423 (_, _) -> Flexible