git.iko.soy/elk
on a67b4dc help sign in
elk/src/Type/Unify.hs
411 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 throwError (RawMismatch (leftSrcType, rightSrcType, note))
59unifyHelp :: Variable -> Variable -> Unify ()
60unifyHelp variable1 variable2 =
61 do equivalent <- liftIO $ UF.equivalent variable1 variable2
62 if equivalent
63 then return ()
64 else actuallyUnify variable1 variable2
67actuallyUnify :: Variable -> Variable -> Unify ()
68actuallyUnify variable1 variable2 = do
69 desc1 <- liftIO $ UF.descriptor variable1
70 desc2 <- liftIO $ UF.descriptor variable2
71 let (name', flex', rank', alias') = combinedDescriptors desc1 desc2
73 merge1 :: Unify ()
74 merge1 =
75 liftIO $ do
76 if rank desc1 < rank desc2
77 then UF.union variable2 variable1
78 else UF.union variable1 variable2
79 UF.modifyDescriptor variable1 $ \desc ->
80 desc { structure = structure desc1
81 , flex = flex'
82 , name = name'
83 , alias = alias'
84 }
86 merge2 :: Unify ()
87 merge2 =
88 liftIO $ do
89 if rank desc1 < rank desc2
90 then UF.union variable2 variable1
91 else UF.union variable1 variable2
92 UF.modifyDescriptor variable2 $ \desc ->
93 desc { structure = structure desc2
94 , flex = flex'
95 , name = name'
96 , alias = alias'
97 }
99 merge =
100 if rank desc1 < rank desc2 then merge1 else merge2
102 fresh :: Maybe (Term1 Variable) -> Unify Variable
103 fresh structure =
104 do v <- liftIO . UF.fresh $ Descriptor
105 { structure = structure
106 , rank = rank'
107 , flex = flex'
108 , name = name'
109 , copy = Nothing
110 , mark = noMark
111 , alias = alias'
112 }
113 lift (TS.register v)
115 flexAndUnify v =
116 do liftIO $ UF.modifyDescriptor v $ \desc -> desc { flex = Flexible }
117 unifyHelp variable1 variable2
119 unifyNumber svar (Var.Canonical home name) =
120 case home of
121 Var.BuiltIn | name `elem` ["Int","Float"] -> flexAndUnify svar
122 Var.Local | List.isPrefixOf "number" name -> flexAndUnify svar
123 _ ->
124 typeError variable1 variable2 Nothing
126 comparableError maybeHint =
127 typeError variable1 variable2 $ Just $
128 "Note: comparable types include Int, Float, Char, String, lists, and tuples."
129 ++ maybe "" ("\n"++) maybeHint
131 appendableError =
132 typeError variable1 variable2 $ Just $
133 "Note: appendable types include only Strings, Lists, and Text."
135 unifyComparable v (Var.Canonical home name) =
136 case home of
137 Var.BuiltIn | name `elem` ["Int","Float","Char","String"] -> flexAndUnify v
138 Var.Local | List.isPrefixOf "comparable" name -> flexAndUnify v
139 _ -> comparableError Nothing
141 unifyComparableStructure varSuper varFlex =
142 do struct <- liftIO $ collectApps varFlex
143 case struct of
144 Other ->
145 comparableError Nothing
147 List v ->
148 do flexAndUnify varSuper
149 unifyHelp v =<< liftIO (variable $ Is Comparable)
151 Tuple vs
152 | length vs > 6 ->
153 comparableError $ Just $
154 "Furthermore, it cannot be a tuple with more than 6 elements."
155 | otherwise ->
156 do flexAndUnify varSuper
157 cmpVars <- liftIO $ forM [1..length vs] $ \_ -> variable (Is Comparable)
158 zipWithM_ unifyHelp vs cmpVars
160 unifyAppendable varSuper varFlex =
161 do struct <- liftIO $ collectApps varFlex
162 case struct of
163 List _ -> flexAndUnify varSuper
164 _ -> appendableError
166 rigidError var =
167 typeError variable1 variable2 $ Just $
168 rigidErrorMessage (render (pretty Never var))
170 superUnify =
171 case (flex desc1, flex desc2, name desc1, name desc2) of
172 (Is super1, Is super2, _, _)
173 | super1 == super2 -> merge
174 (Is Number, Is Comparable, _, _) -> merge1
175 (Is Comparable, Is Number, _, _) -> merge2
177 (Is Number, _, _, Just name) -> unifyNumber variable1 name
178 (_, Is Number, Just name, _) -> unifyNumber variable2 name
180 (Is Comparable, _, _, Just name) -> unifyComparable variable1 name
181 (_, Is Comparable, Just name, _) -> unifyComparable variable2 name
182 (Is Comparable, _, _, _) -> unifyComparableStructure variable1 variable2
183 (_, Is Comparable, _, _) -> unifyComparableStructure variable2 variable1
185 (Is Appendable, _, _, Just name)
186 | Var.isText name || Var.isPrim "String" name -> flexAndUnify variable1
187 (_, Is Appendable, Just name, _)
188 | Var.isText name || Var.isPrim "String" name -> flexAndUnify variable2
189 (Is Appendable, _, _, _) -> unifyAppendable variable1 variable2
190 (_, Is Appendable, _, _) -> unifyAppendable variable2 variable1
192 (Rigid, _, _, _) -> rigidError variable1
193 (_, Rigid, _, _) -> rigidError variable2
194 _ -> typeError variable1 variable2 Nothing
196 case (structure desc1, structure desc2) of
197 (Nothing, Nothing) | flex desc1 == Flexible && flex desc1 == Flexible ->
198 merge
200 (Nothing, _) | flex desc1 == Flexible ->
201 merge2
203 (_, Nothing) | flex desc2 == Flexible ->
204 merge1
206 (Just (Var1 v), _) ->
207 unifyHelp v variable2
209 (_, Just (Var1 v)) ->
210 unifyHelp variable1 v
212 (Nothing, _) ->
213 superUnify
215 (_, Nothing) ->
216 superUnify
218 (Just type1, Just type2) ->
219 case (type1,type2) of
220 (App1 term1 term2, App1 term1' term2') ->
221 do merge
222 unifyHelp term1 term1'
223 unifyHelp term2 term2'
224 (Fun1 term1 term2, Fun1 term1' term2') ->
225 do merge
226 unifyHelp term1 term1'
227 unifyHelp term2 term2'
229 (EmptyRecord1, EmptyRecord1) ->
230 return ()
232 (Record1 fields ext, EmptyRecord1) | Map.null fields -> unifyHelp ext variable2
233 (EmptyRecord1, Record1 fields ext) | Map.null fields -> unifyHelp variable1 ext
235 (Record1 _ _, Record1 _ _) ->
236 recordUnify fresh variable1 variable2
238 _ -> typeError variable1 variable2 Nothing
241-- RIGID ERROR
243rigidErrorMessage :: String -> String
244rigidErrorMessage var =
245 "Could not unify user provided type variable `" ++ var ++ "`. The most likely cases are:\n\n"
246 ++ " 1. The type you wrote down is too general. It says any type can go through\n"
247 ++ " but in fact only a certain type can.\n"
248 ++ " 2. A type variable is probably being shared between two type annotations.\n"
249 ++ " They are treated as different things in the current implementation, so\n"
250 ++ " Try commenting out some type annotations and see what happens."
253-- RECORD UNIFICATION
255recordUnify
256 :: (Maybe (Term1 Variable) -> Unify Variable)
257 -> Variable
258 -> Variable
259 -> Unify ()
260recordUnify fresh variable1 variable2 =
261 do (ExpandedRecord fields1 ext1) <- liftIO (gatherFields variable1)
262 (ExpandedRecord fields2 ext2) <- liftIO (gatherFields variable2)
264 unifyOverlappingFields fields1 fields2
266 let freshRecord fields ext =
267 fresh (Just (Record1 fields ext))
269 let uniqueFields1 = diffFields fields1 fields2
270 let uniqueFields2 = diffFields fields2 fields1
272 let addFieldMismatchError missingFields =
273 typeError variable1 variable2 $ Just $
274 fieldMismatchError missingFields
276 case (ext1, ext2) of
277 (Empty _, Empty _) ->
278 case Map.null uniqueFields1 && Map.null uniqueFields2 of
279 True -> return ()
280 False -> typeError variable1 variable2 Nothing
282 (Empty var1, Extension var2) ->
283 case (Map.null uniqueFields1, Map.null uniqueFields2) of
284 (_, False) -> addFieldMismatchError uniqueFields2
285 (True, True) -> unifyHelp var1 var2
286 (False, True) ->
287 do subRecord <- freshRecord uniqueFields1 var1
288 unifyHelp subRecord var2
290 (Extension var1, Empty var2) ->
291 case (Map.null uniqueFields1, Map.null uniqueFields2) of
292 (False, _) -> addFieldMismatchError uniqueFields1
293 (True, True) -> unifyHelp var1 var2
294 (True, False) ->
295 do subRecord <- freshRecord uniqueFields2 var2
296 unifyHelp var1 subRecord
298 (Extension var1, Extension var2) ->
299 case (Map.null uniqueFields1, Map.null uniqueFields2) of
300 (True, True) ->
301 unifyHelp var1 var2
303 (True, False) ->
304 do subRecord <- freshRecord uniqueFields2 var2
305 unifyHelp var1 subRecord
307 (False, True) ->
308 do subRecord <- freshRecord uniqueFields1 var1
309 unifyHelp subRecord var2
311 (False, False) ->
312 do record1' <- freshRecord uniqueFields1 =<< fresh Nothing
313 record2' <- freshRecord uniqueFields2 =<< fresh Nothing
314 unifyHelp record1' var2
315 unifyHelp var1 record2'
318unifyOverlappingFields
319 :: Map.Map String [Variable]
320 -> Map.Map String [Variable]
321 -> Unify ()
322unifyOverlappingFields fields1 fields2 =
323 Map.intersectionWith (zipWith unifyHelp) fields1 fields2
324 |> Map.elems
325 |> concat
326 |> sequence_
329diffFields :: Map.Map String [a] -> Map.Map String [a] -> Map.Map String [a]
330diffFields fields1 fields2 =
331 let eat (_:xs) (_:ys) = eat xs ys
332 eat xs _ = xs
333 in
334 Map.union (Map.intersectionWith eat fields1 fields2) fields1
335 |> Map.filter (not . null)
338data ExpandedRecord = ExpandedRecord
339 { _fields :: Map.Map String [Variable]
340 , _extension :: Extension
341 }
343data Extension = Empty Variable | Extension Variable
346gatherFields :: Variable -> IO ExpandedRecord
347gatherFields var =
348 do desc <- UF.descriptor var
349 case structure desc of
350 (Just (Record1 fields ext)) ->
351 do (ExpandedRecord deeperFields rootExt) <- gatherFields ext
352 return (ExpandedRecord (Map.unionWith (++) fields deeperFields) rootExt)
354 (Just EmptyRecord1) ->
355 return (ExpandedRecord Map.empty (Empty var))
357 _ ->
358 return (ExpandedRecord Map.empty (Extension var))
361-- assumes that one of the dicts has stuff in it
362fieldMismatchError :: Map.Map String a -> String
363fieldMismatchError missingFields =
364 case Map.keys missingFields of
365 [] -> ""
366 [key] ->
367 "Looks like a record is missing the field `" ++ key ++ "`"
368 keys ->
369 "Looks like a record is missing fields "
370 ++ List.intercalate ", " (init keys) ++ ", and " ++ last keys
373combinedDescriptors
374 :: Descriptor
375 -> Descriptor
376 -> (Maybe Var.Canonical, Flex, Int, Alias Variable)
377combinedDescriptors desc1 desc2 =
378 (name', flex', rank', alias')
379 where
380 rank' :: Int
381 rank' =
382 min (rank desc1) (rank desc2)
384 alias' :: Alias Variable
385 alias' =
386 alias desc1 <|> alias desc2
388 name' :: Maybe Var.Canonical
389 name' =
390 case (name desc1, name desc2) of
391 (Just name1, Just name2) ->
392 case (flex desc1, flex desc2) of
393 (_, Flexible) -> Just name1
394 (Flexible, _) -> Just name2
395 (Is Number, Is _) -> Just name1
396 (Is _, Is Number) -> Just name2
397 (Is _, Is _) -> Just name1
398 (_, _) -> Nothing
399 (Just name1, _) -> Just name1
400 (_, Just name2) -> Just name2
401 _ -> Nothing
403 flex' :: Flex
404 flex' =
405 case (flex desc1, flex desc2) of
406 (f, Flexible) -> f
407 (Flexible, f) -> f
408 (Is Number, Is _) -> Is Number
409 (Is _, Is Number) -> Is Number
410 (Is super, Is _) -> Is super
411 (_, _) -> Flexible