git.iko.soy/elk
on ea343fc help sign in
elk/src/Type/Unify.hs
403 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, Error.Note)
48typeError
49 :: UF.Point Descriptor
50 -> UF.Point Descriptor
51 -> Error.Note
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 Error.NoNote
126 comparableError maybeHint =
127 typeError variable1 variable2 $ Error.PostNote $
128 "Note: comparable types include Int, Float, Char, String, lists, and tuples."
129 ++ maybe "" ("\n"++) maybeHint
131 appendableError =
132 typeError variable1 variable2 $ Error.PostNote $
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 let v = render (pretty Never var)
168 in
169 typeError variable1 variable2 $ Error.PreNote $
170 "Could not unify rigid type variable '" ++ v ++ "'. The problem probably\n"
171 ++ "relates to the type variable being shared between two type annotations.\n"
172 ++ "Try commenting out some type annotations and see what happens."
174 superUnify =
175 case (flex desc1, flex desc2, name desc1, name desc2) of
176 (Is super1, Is super2, _, _)
177 | super1 == super2 -> merge
178 (Is Number, Is Comparable, _, _) -> merge1
179 (Is Comparable, Is Number, _, _) -> merge2
181 (Is Number, _, _, Just name) -> unifyNumber variable1 name
182 (_, Is Number, Just name, _) -> unifyNumber variable2 name
184 (Is Comparable, _, _, Just name) -> unifyComparable variable1 name
185 (_, Is Comparable, Just name, _) -> unifyComparable variable2 name
186 (Is Comparable, _, _, _) -> unifyComparableStructure variable1 variable2
187 (_, Is Comparable, _, _) -> unifyComparableStructure variable2 variable1
189 (Is Appendable, _, _, Just name)
190 | Var.isText name || Var.isPrim "String" name -> flexAndUnify variable1
191 (_, Is Appendable, Just name, _)
192 | Var.isText name || Var.isPrim "String" name -> flexAndUnify variable2
193 (Is Appendable, _, _, _) -> unifyAppendable variable1 variable2
194 (_, Is Appendable, _, _) -> unifyAppendable variable2 variable1
196 (Rigid, _, _, _) -> rigidError variable1
197 (_, Rigid, _, _) -> rigidError variable2
198 _ -> typeError variable1 variable2 Error.NoNote
200 case (structure desc1, structure desc2) of
201 (Nothing, Nothing) | flex desc1 == Flexible && flex desc1 == Flexible ->
202 merge
204 (Nothing, _) | flex desc1 == Flexible ->
205 merge2
207 (_, Nothing) | flex desc2 == Flexible ->
208 merge1
210 (Just (Var1 v), _) ->
211 unifyHelp v variable2
213 (_, Just (Var1 v)) ->
214 unifyHelp variable1 v
216 (Nothing, _) ->
217 superUnify
219 (_, Nothing) ->
220 superUnify
222 (Just type1, Just type2) ->
223 case (type1,type2) of
224 (App1 term1 term2, App1 term1' term2') ->
225 do merge
226 unifyHelp term1 term1'
227 unifyHelp term2 term2'
228 (Fun1 term1 term2, Fun1 term1' term2') ->
229 do merge
230 unifyHelp term1 term1'
231 unifyHelp term2 term2'
233 (EmptyRecord1, EmptyRecord1) ->
234 return ()
236 (Record1 fields ext, EmptyRecord1) | Map.null fields -> unifyHelp ext variable2
237 (EmptyRecord1, Record1 fields ext) | Map.null fields -> unifyHelp variable1 ext
239 (Record1 _ _, Record1 _ _) ->
240 recordUnify fresh variable1 variable2
242 _ -> typeError variable1 variable2 Error.NoNote
245-- RECORD UNIFICATION
247recordUnify
248 :: (Maybe (Term1 Variable) -> Unify Variable)
249 -> Variable
250 -> Variable
251 -> Unify ()
252recordUnify fresh variable1 variable2 =
253 do (ExpandedRecord fields1 ext1) <- liftIO (gatherFields variable1)
254 (ExpandedRecord fields2 ext2) <- liftIO (gatherFields variable2)
256 unifyOverlappingFields fields1 fields2
258 let freshRecord fields ext =
259 fresh (Just (Record1 fields ext))
261 let uniqueFields1 = diffFields fields1 fields2
262 let uniqueFields2 = diffFields fields2 fields1
264 let addFieldMismatchError missingFields =
265 typeError variable1 variable2 $ Error.PreNote $
266 fieldMismatchError missingFields
268 case (ext1, ext2) of
269 (Empty _, Empty _) ->
270 case Map.null uniqueFields1 && Map.null uniqueFields2 of
271 True -> return ()
272 False -> typeError variable1 variable2 Error.NoNote
274 (Empty var1, Extension var2) ->
275 case (Map.null uniqueFields1, Map.null uniqueFields2) of
276 (_, False) -> addFieldMismatchError uniqueFields2
277 (True, True) -> unifyHelp var1 var2
278 (False, True) ->
279 do subRecord <- freshRecord uniqueFields1 var1
280 unifyHelp subRecord var2
282 (Extension var1, Empty var2) ->
283 case (Map.null uniqueFields1, Map.null uniqueFields2) of
284 (False, _) -> addFieldMismatchError uniqueFields1
285 (True, True) -> unifyHelp var1 var2
286 (True, False) ->
287 do subRecord <- freshRecord uniqueFields2 var2
288 unifyHelp var1 subRecord
290 (Extension var1, Extension var2) ->
291 case (Map.null uniqueFields1, Map.null uniqueFields2) of
292 (True, True) ->
293 unifyHelp var1 var2
295 (True, False) ->
296 do subRecord <- freshRecord uniqueFields2 var2
297 unifyHelp var1 subRecord
299 (False, True) ->
300 do subRecord <- freshRecord uniqueFields1 var1
301 unifyHelp subRecord var2
303 (False, False) ->
304 do record1' <- freshRecord uniqueFields1 =<< fresh Nothing
305 record2' <- freshRecord uniqueFields2 =<< fresh Nothing
306 unifyHelp record1' var2
307 unifyHelp var1 record2'
310unifyOverlappingFields
311 :: Map.Map String [Variable]
312 -> Map.Map String [Variable]
313 -> Unify ()
314unifyOverlappingFields fields1 fields2 =
315 Map.intersectionWith (zipWith unifyHelp) fields1 fields2
316 |> Map.elems
317 |> concat
318 |> sequence_
321diffFields :: Map.Map String [a] -> Map.Map String [a] -> Map.Map String [a]
322diffFields fields1 fields2 =
323 let eat (_:xs) (_:ys) = eat xs ys
324 eat xs _ = xs
325 in
326 Map.union (Map.intersectionWith eat fields1 fields2) fields1
327 |> Map.filter (not . null)
330data ExpandedRecord = ExpandedRecord
331 { _fields :: Map.Map String [Variable]
332 , _extension :: Extension
333 }
335data Extension = Empty Variable | Extension Variable
338gatherFields :: Variable -> IO ExpandedRecord
339gatherFields var =
340 do desc <- UF.descriptor var
341 case structure desc of
342 (Just (Record1 fields ext)) ->
343 do (ExpandedRecord deeperFields rootExt) <- gatherFields ext
344 return (ExpandedRecord (Map.unionWith (++) fields deeperFields) rootExt)
346 (Just EmptyRecord1) ->
347 return (ExpandedRecord Map.empty (Empty var))
349 _ ->
350 return (ExpandedRecord Map.empty (Extension var))
353-- assumes that one of the dicts has stuff in it
354fieldMismatchError :: Map.Map String a -> String
355fieldMismatchError missingFields =
356 case Map.keys missingFields of
357 [] -> ""
358 [key] ->
359 "Looks like a record is missing the field '" ++ key ++ "'"
360 keys ->
361 "Looks like a record is missing fields "
362 ++ List.intercalate ", " (init keys) ++ ", and " ++ last keys
365combinedDescriptors
366 :: Descriptor
367 -> Descriptor
368 -> (Maybe Var.Canonical, Flex, Int, Alias Variable)
369combinedDescriptors desc1 desc2 =
370 (name', flex', rank', alias')
371 where
372 rank' :: Int
373 rank' =
374 min (rank desc1) (rank desc2)
376 alias' :: Alias Variable
377 alias' =
378 alias desc1 <|> alias desc2
380 name' :: Maybe Var.Canonical
381 name' =
382 case (name desc1, name desc2) of
383 (Just name1, Just name2) ->
384 case (flex desc1, flex desc2) of
385 (_, Flexible) -> Just name1
386 (Flexible, _) -> Just name2
387 (Is Number, Is _) -> Just name1
388 (Is _, Is Number) -> Just name2
389 (Is _, Is _) -> Just name1
390 (_, _) -> Nothing
391 (Just name1, _) -> Just name1
392 (_, Just name2) -> Just name2
393 _ -> Nothing
395 flex' :: Flex
396 flex' =
397 case (flex desc1, flex desc2) of
398 (f, Flexible) -> f
399 (Flexible, f) -> f
400 (Is Number, Is _) -> Is Number
401 (Is _, Is Number) -> Is Number
402 (Is super, Is _) -> Is super
403 (_, _) -> Flexible