git.iko.soy/elk
on 54dfb21 help sign in
elk/src/Type/Unify.hs
448 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' = pickName desc1 desc2
75 flex' = pickFlex desc1 desc2
76 rank' = pickRank desc1 desc2
77 alias' = pickAlias desc1 desc2
79 merge1 :: Unify ()
80 merge1 =
81 liftIO $ do
82 if rank desc1 < rank desc2
83 then UF.union variable2 variable1
84 else UF.union variable1 variable2
85 UF.modifyDescriptor variable1 $ \desc ->
86 desc { structure = structure desc1
87 , flex = flex'
88 , name = name'
89 , alias = alias'
90 }
92 merge2 :: Unify ()
93 merge2 =
94 liftIO $ do
95 if rank desc1 < rank desc2
96 then UF.union variable2 variable1
97 else UF.union variable1 variable2
98 UF.modifyDescriptor variable2 $ \desc ->
99 desc { structure = structure desc2
100 , flex = flex'
101 , name = name'
102 , alias = alias'
103 }
105 merge =
106 if rank desc1 < rank desc2 then merge1 else merge2
108 fresh :: Maybe (Term1 Variable) -> Unify Variable
109 fresh structure =
110 do v <- liftIO . UF.fresh $ Descriptor
111 { structure = structure
112 , rank = rank'
113 , flex = flex'
114 , name = name'
115 , copy = Nothing
116 , mark = noMark
117 , alias = alias'
118 }
119 lift (TS.register v)
121 flexAndUnify v =
122 do liftIO $ UF.modifyDescriptor v $ \desc -> desc { flex = Flexible }
123 unifyHelp variable1 variable2
125 unifyNumber svar (Var.Canonical home name) =
126 case home of
127 Var.BuiltIn | name `elem` ["Int","Float"] ->
128 flexAndUnify svar
130 Var.Local | List.isPrefixOf "number" name ->
131 flexAndUnify svar
133 Var.TopLevel _ | List.isPrefixOf "number" name ->
134 flexAndUnify svar
136 _ ->
137 typeError variable1 variable2 Nothing
139 comparableError maybeHint =
140 typeError variable1 variable2 $ Just $
141 "Note: comparable types include Int, Float, Char, String, lists, and tuples."
142 ++ maybe "" ("\n"++) maybeHint
144 appendableError =
145 typeError variable1 variable2 $ Just $
146 "Note: appendable types include only Strings, Lists, and Text."
148 unifyComparable v (Var.Canonical home name) =
149 case home of
150 Var.BuiltIn | name `elem` ["Int","Float","Char","String"] ->
151 flexAndUnify v
152 Var.Local | List.isPrefixOf "comparable" name ->
153 flexAndUnify v
154 _ ->
155 comparableError Nothing
157 unifyComparableStructure varSuper varFlex =
158 do struct <- liftIO $ collectApps varFlex
159 case struct of
160 Other ->
161 comparableError Nothing
163 List v ->
164 do flexAndUnify varSuper
165 unifyHelp v =<< liftIO (variable $ Is Comparable)
167 Tuple vs ->
168 if length vs > 6 then
169 comparableError $ Just $
170 "Furthermore, it cannot be a tuple with more than 6 elements."
171 else
172 do flexAndUnify varSuper
173 cmpVars <- liftIO $ forM [1..length vs] $ \_ -> variable (Is Comparable)
174 zipWithM_ unifyHelp vs cmpVars
176 unifyAppendable v cvar =
177 let
178 canUnify =
179 Var.isPrim "String" cvar
180 || Var.isText cvar
181 || Var.isLocal (List.isPrefixOf "comparable") cvar
182 || Var.isLocal (List.isPrefixOf "appendable") cvar
183 in
184 if canUnify then
185 flexAndUnify v
186 else
187 appendableError
189 unifyAppendableStructure varSuper varFlex =
190 do struct <- liftIO $ collectApps varFlex
191 case struct of
192 List _ -> flexAndUnify varSuper
193 _ -> appendableError
195 rigidError var =
196 typeError variable1 variable2 $ Just $
197 rigidErrorMessage (render (pretty Never var))
199 superUnify =
200 case (flex desc1, flex desc2, name desc1, name desc2) of
201 (Is super1, Is super2, _, _)
202 | super1 == super2 -> merge
203 (Is Number, Is Comparable, _, _) -> merge1
204 (Is Comparable, Is Number, _, _) -> merge2
206 (Is Number, _, _, Just name) -> unifyNumber variable1 name
207 (_, Is Number, Just name, _) -> unifyNumber variable2 name
209 (Is Appendable, _, _, Just name) -> unifyAppendable variable1 name
210 (_, Is Appendable, Just name, _) -> unifyAppendable variable2 name
211 (Is Appendable, _, _, _) -> unifyAppendableStructure variable1 variable2
212 (_, Is Appendable, _, _) -> unifyAppendableStructure variable2 variable1
214 (Is Comparable, _, _, Just name) -> unifyComparable variable1 name
215 (_, Is Comparable, Just name, _) -> unifyComparable variable2 name
216 (Is Comparable, _, _, _) -> unifyComparableStructure variable1 variable2
217 (_, Is Comparable, _, _) -> unifyComparableStructure variable2 variable1
219 (Rigid, _, _, _) -> rigidError variable1
220 (_, Rigid, _, _) -> rigidError variable2
221 _ -> typeError variable1 variable2 Nothing
223 case (structure desc1, structure desc2) of
224 (Nothing, Nothing)
225 | flex desc1 == Flexible && flex desc1 == Flexible ->
226 merge
228 (Nothing, _)
229 | flex desc1 == Flexible -> merge2
230 | flex desc1 == Error -> return ()
232 (_, Nothing)
233 | flex desc2 == Flexible -> merge1
234 | flex desc2 == Error -> return ()
236 (Just (Var1 v), _) ->
237 unifyHelp v variable2
239 (_, Just (Var1 v)) ->
240 unifyHelp variable1 v
242 (Nothing, _) ->
243 superUnify
245 (_, Nothing) ->
246 superUnify
248 (Just type1, Just type2) ->
249 case (type1,type2) of
250 (App1 term1 term2, App1 term1' term2') ->
251 do merge
252 unifyHelp term1 term1'
253 unifyHelp term2 term2'
254 (Fun1 term1 term2, Fun1 term1' term2') ->
255 do merge
256 unifyHelp term1 term1'
257 unifyHelp term2 term2'
259 (EmptyRecord1, EmptyRecord1) ->
260 return ()
262 (Record1 fields ext, EmptyRecord1) | Map.null fields -> unifyHelp ext variable2
263 (EmptyRecord1, Record1 fields ext) | Map.null fields -> unifyHelp variable1 ext
265 (Record1 _ _, Record1 _ _) ->
266 recordUnify fresh variable1 variable2
268 _ -> typeError variable1 variable2 Nothing
271-- RIGID ERROR
273rigidErrorMessage :: String -> String
274rigidErrorMessage var =
275 "Could not unify user provided type variable `" ++ var ++ "`. The most likely cases are:\n\n"
276 ++ " 1. The type you wrote down is too general. It says any type can go through\n"
277 ++ " but in fact only a certain type can.\n"
278 ++ " 2. A type variable is probably being shared between two type annotations.\n"
279 ++ " They are treated as different things in the current implementation, so\n"
280 ++ " Try commenting out some type annotations and see what happens."
283-- RECORD UNIFICATION
285recordUnify
286 :: (Maybe (Term1 Variable) -> Unify Variable)
287 -> Variable
288 -> Variable
289 -> Unify ()
290recordUnify fresh variable1 variable2 =
291 do (ExpandedRecord fields1 ext1) <- liftIO (gatherFields variable1)
292 (ExpandedRecord fields2 ext2) <- liftIO (gatherFields variable2)
294 unifyOverlappingFields fields1 fields2
296 let freshRecord fields ext =
297 fresh (Just (Record1 fields ext))
299 let uniqueFields1 = diffFields fields1 fields2
300 let uniqueFields2 = diffFields fields2 fields1
302 let addFieldMismatchError missingFields =
303 typeError variable1 variable2 $ Just $
304 fieldMismatchError missingFields
306 case (ext1, ext2) of
307 (Empty _, Empty _) ->
308 case Map.null uniqueFields1 && Map.null uniqueFields2 of
309 True -> return ()
310 False -> typeError variable1 variable2 Nothing
312 (Empty var1, Extension var2) ->
313 case (Map.null uniqueFields1, Map.null uniqueFields2) of
314 (_, False) -> addFieldMismatchError uniqueFields2
315 (True, True) -> unifyHelp var1 var2
316 (False, True) ->
317 do subRecord <- freshRecord uniqueFields1 var1
318 unifyHelp subRecord var2
320 (Extension var1, Empty var2) ->
321 case (Map.null uniqueFields1, Map.null uniqueFields2) of
322 (False, _) -> addFieldMismatchError uniqueFields1
323 (True, True) -> unifyHelp var1 var2
324 (True, False) ->
325 do subRecord <- freshRecord uniqueFields2 var2
326 unifyHelp var1 subRecord
328 (Extension var1, Extension var2) ->
329 case (Map.null uniqueFields1, Map.null uniqueFields2) of
330 (True, True) ->
331 unifyHelp var1 var2
333 (True, False) ->
334 do subRecord <- freshRecord uniqueFields2 var2
335 unifyHelp var1 subRecord
337 (False, True) ->
338 do subRecord <- freshRecord uniqueFields1 var1
339 unifyHelp subRecord var2
341 (False, False) ->
342 do record1' <- freshRecord uniqueFields1 =<< fresh Nothing
343 record2' <- freshRecord uniqueFields2 =<< fresh Nothing
344 unifyHelp record1' var2
345 unifyHelp var1 record2'
348unifyOverlappingFields
349 :: Map.Map String [Variable]
350 -> Map.Map String [Variable]
351 -> Unify ()
352unifyOverlappingFields fields1 fields2 =
353 Map.intersectionWith (zipWith unifyHelp) fields1 fields2
354 |> Map.elems
355 |> concat
356 |> sequence_
359diffFields :: Map.Map String [a] -> Map.Map String [a] -> Map.Map String [a]
360diffFields fields1 fields2 =
361 let eat (_:xs) (_:ys) = eat xs ys
362 eat xs _ = xs
363 in
364 Map.union (Map.intersectionWith eat fields1 fields2) fields1
365 |> Map.filter (not . null)
368data ExpandedRecord = ExpandedRecord
369 { _fields :: Map.Map String [Variable]
370 , _extension :: Extension
371 }
373data Extension = Empty Variable | Extension Variable
376gatherFields :: Variable -> IO ExpandedRecord
377gatherFields var =
378 do desc <- UF.descriptor var
379 case structure desc of
380 (Just (Record1 fields ext)) ->
381 do (ExpandedRecord deeperFields rootExt) <- gatherFields ext
382 return (ExpandedRecord (Map.unionWith (++) fields deeperFields) rootExt)
384 (Just EmptyRecord1) ->
385 return (ExpandedRecord Map.empty (Empty var))
387 _ ->
388 return (ExpandedRecord Map.empty (Extension var))
391-- assumes that one of the dicts has stuff in it
392fieldMismatchError :: Map.Map String a -> String
393fieldMismatchError missingFields =
394 case Map.keys missingFields of
395 [] ->
396 ""
398 [key] ->
399 "Looks like a record is missing the field `" ++ key ++ "`"
401 keys ->
402 "Looks like a record is missing fields "
403 ++ List.intercalate ", " (init keys) ++ ", and " ++ last keys
407pickAlias :: Descriptor -> Descriptor -> Alias Variable
408pickAlias desc1 desc2 =
409 alias desc1 <|> alias desc2
412pickRank :: Descriptor -> Descriptor -> Int
413pickRank desc1 desc2 =
414 min (rank desc1) (rank desc2)
417pickFlex :: Descriptor -> Descriptor -> Flex
418pickFlex desc1 desc2 =
419 case (flex desc1, flex desc2) of
420 ( f , Flexible ) -> f
421 ( Flexible , f ) -> f
422 ( Is Number , Is _ ) -> Is Number
423 ( Is _ , Is Number ) -> Is Number
424 ( Is super , Is _ ) -> Is super
425 ( _ , _ ) -> Flexible
428pickName :: Descriptor -> Descriptor -> Maybe Var.Canonical
429pickName desc1 desc2 =
430 case (name desc1, name desc2) of
431 (Nothing, Nothing) ->
432 Nothing
434 (Just name1, Nothing) ->
435 Just name1
437 (Nothing, Just name2) ->
438 Just name2
440 (Just name1, Just name2) ->
441 case (flex desc1, flex desc2) of
442 ( _ , Flexible ) -> Just name1
443 ( Flexible , _ ) -> Just name2
444 ( Is Number , Is _ ) -> Just name1
445 ( Is _ , Is Number ) -> Just name2
446 ( Is _ , Is _ ) -> Just name1
447 ( _ , _ ) -> Nothing