git.iko.soy/elk
on 2ec798e help sign in
elk/src/Type/Unify.hs
373 lines 14 kB history raw
1module Type.Unify (unify) where
3import Control.Applicative ((<|>))
4import Control.Monad.Error (ErrorT, throwError, runErrorT)
5import Control.Monad.State as State
6import qualified Data.List as List
7import qualified Data.Map as Map
8import qualified Data.Maybe as Maybe
9import qualified Data.UnionFind.IO as UF
10import Text.PrettyPrint (render)
12import qualified AST.Annotation as A
13import qualified AST.Variable as Var
14import qualified Type.State as TS
15import Type.Type
16import Type.PrettyPrint
17import qualified Type.Hint as Hint
18import Elm.Utils ((|>))
21unify :: A.Region -> Variable -> Variable -> StateT TS.SolverState IO ()
22unify region variable1 variable2 =
23 do result <- runErrorT (unifyHelp region variable1 variable2)
24 either TS.addHint return result
27-- ACTUALLY UNIFY STUFF
29type Unify = ErrorT Hint.Hint (StateT TS.SolverState IO)
32typeError
33 :: A.Region
34 -> Maybe String
35 -> UF.Point Descriptor
36 -> UF.Point Descriptor
37 -> Unify a
38typeError region hint t1 t2 =
39 do msg <- liftIO (Hint.create region hint t1 t2)
40 throwError msg
43unifyHelp :: A.Region -> Variable -> Variable -> Unify ()
44unifyHelp region variable1 variable2 = do
45 equivalent <- liftIO $ UF.equivalent variable1 variable2
46 if equivalent
47 then return ()
48 else actuallyUnify region variable1 variable2
51actuallyUnify :: A.Region -> Variable -> Variable -> Unify ()
52actuallyUnify region variable1 variable2 = do
53 desc1 <- liftIO $ UF.descriptor variable1
54 desc2 <- liftIO $ UF.descriptor variable2
55 let unifyHelp' = unifyHelp region
57 (name', flex', rank', alias') = combinedDescriptors desc1 desc2
59 merge1 :: Unify ()
60 merge1 = liftIO $ do
61 if rank desc1 < rank desc2 then UF.union variable2 variable1
62 else UF.union variable1 variable2
63 UF.modifyDescriptor variable1 $ \desc ->
64 desc { structure = structure desc1
65 , flex = flex'
66 , name = name'
67 , alias = alias'
68 }
70 merge2 :: Unify ()
71 merge2 = liftIO $ do
72 if rank desc1 < rank desc2 then UF.union variable2 variable1
73 else UF.union variable1 variable2
74 UF.modifyDescriptor variable2 $ \desc ->
75 desc { structure = structure desc2
76 , flex = flex'
77 , name = name'
78 , alias = alias'
79 }
81 merge = if rank desc1 < rank desc2 then merge1 else merge2
83 fresh :: Maybe (Term1 Variable) -> Unify Variable
84 fresh structure = do
85 v <- liftIO . UF.fresh $ Descriptor
86 { structure = structure
87 , rank = rank'
88 , flex = flex'
89 , name = name'
90 , copy = Nothing
91 , mark = noMark
92 , alias = alias'
93 }
94 lift (TS.register v)
96 flexAndUnify v = do
97 liftIO $ UF.modifyDescriptor v $ \desc -> desc { flex = Flexible }
98 unifyHelp' variable1 variable2
100 unifyNumber svar (Var.Canonical home name) =
101 case home of
102 Var.BuiltIn | name `elem` ["Int","Float"] -> flexAndUnify svar
103 Var.Local | List.isPrefixOf "number" name -> flexAndUnify svar
104 _ ->
105 let hint = "Looks like something besides an Int or Float is being used as a number."
106 in
107 typeError region (Just hint) variable1 variable2
109 comparableError maybe =
110 typeError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2
111 where
112 msg =
113 "Looks like you want something comparable, but the only valid comparable\n\
114 \types are Int, Float, Char, String, lists, or tuples."
116 appendableError maybe =
117 typeError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2
118 where
119 msg =
120 "Looks like you want something appendable, but the only Strings, Lists,\n\
121 \and Text can be appended with the (++) operator."
123 unifyComparable v (Var.Canonical home name) =
124 case home of
125 Var.BuiltIn | name `elem` ["Int","Float","Char","String"] -> flexAndUnify v
126 Var.Local | List.isPrefixOf "comparable" name -> flexAndUnify v
127 _ -> comparableError Nothing
129 unifyComparableStructure varSuper varFlex =
130 do struct <- liftIO $ collectApps varFlex
131 case struct of
132 Other -> comparableError Nothing
133 List v -> do flexAndUnify varSuper
134 unifyHelp' v =<< liftIO (variable $ Is Comparable)
135 Tuple vs
136 | length vs > 6 ->
137 comparableError $ Just "Cannot compare a tuple with more than 6 elements."
138 | otherwise ->
139 do flexAndUnify varSuper
140 cmpVars <- liftIO $ forM [1..length vs] $ \_ -> variable (Is Comparable)
141 zipWithM_ unifyHelp' vs cmpVars
143 unifyAppendable varSuper varFlex =
144 do struct <- liftIO $ collectApps varFlex
145 case struct of
146 List _ -> flexAndUnify varSuper
147 _ -> appendableError Nothing
149 rigidError var =
150 typeError region (Just hint) variable1 variable2
151 where
152 hint =
153 "Could not unify rigid type variable '" ++ render (pretty Never var) ++ "'.\n" ++
154 "The problem probably relates to the type variable being shared between a\n\
155 \top-level type annotation and a related let-bound type annotation."
157 superUnify =
158 case (flex desc1, flex desc2, name desc1, name desc2) of
159 (Is super1, Is super2, _, _)
160 | super1 == super2 -> merge
161 (Is Number, Is Comparable, _, _) -> merge1
162 (Is Comparable, Is Number, _, _) -> merge2
164 (Is Number, _, _, Just name) -> unifyNumber variable1 name
165 (_, Is Number, Just name, _) -> unifyNumber variable2 name
167 (Is Comparable, _, _, Just name) -> unifyComparable variable1 name
168 (_, Is Comparable, Just name, _) -> unifyComparable variable2 name
169 (Is Comparable, _, _, _) -> unifyComparableStructure variable1 variable2
170 (_, Is Comparable, _, _) -> unifyComparableStructure variable2 variable1
172 (Is Appendable, _, _, Just name)
173 | Var.isText name || Var.isPrim "String" name -> flexAndUnify variable1
174 (_, Is Appendable, Just name, _)
175 | Var.isText name || Var.isPrim "String" name -> flexAndUnify variable2
176 (Is Appendable, _, _, _) -> unifyAppendable variable1 variable2
177 (_, Is Appendable, _, _) -> unifyAppendable variable2 variable1
179 (Rigid, _, _, _) -> rigidError variable1
180 (_, Rigid, _, _) -> rigidError variable2
181 _ -> typeError region Nothing variable1 variable2
183 case (structure desc1, structure desc2) of
184 (Nothing, Nothing) | flex desc1 == Flexible && flex desc1 == Flexible -> merge
185 (Nothing, _) | flex desc1 == Flexible -> merge2
186 (_, Nothing) | flex desc2 == Flexible -> merge1
188 (Just (Var1 v), _) -> unifyHelp' v variable2
189 (_, Just (Var1 v)) -> unifyHelp' v variable1
191 (Nothing, _) -> superUnify
192 (_, Nothing) -> superUnify
194 (Just type1, Just type2) ->
195 case (type1,type2) of
196 (App1 term1 term2, App1 term1' term2') ->
197 do merge
198 unifyHelp' term1 term1'
199 unifyHelp' term2 term2'
200 (Fun1 term1 term2, Fun1 term1' term2') ->
201 do merge
202 unifyHelp' term1 term1'
203 unifyHelp' term2 term2'
205 (EmptyRecord1, EmptyRecord1) ->
206 return ()
208 (Record1 fields ext, EmptyRecord1) | Map.null fields -> unifyHelp' ext variable2
209 (EmptyRecord1, Record1 fields ext) | Map.null fields -> unifyHelp' ext variable1
211 (Record1 _ _, Record1 _ _) ->
212 recordUnify region fresh variable1 variable2
214 _ -> typeError region Nothing variable1 variable2
217-- RECORD UNIFICATION
219recordUnify
220 :: A.Region
221 -> (Maybe (Term1 Variable) -> Unify Variable)
222 -> Variable
223 -> Variable
224 -> Unify ()
225recordUnify region fresh variable1 variable2 =
226 do (ExpandedRecord fields1 ext1) <- liftIO (gatherFields variable1)
227 (ExpandedRecord fields2 ext2) <- liftIO (gatherFields variable2)
229 unifyOverlappingFields region fields1 fields2
231 let freshRecord fields ext =
232 fresh (Just (Record1 fields ext))
234 let uniqueFields1 = diffFields fields1 fields2
235 let uniqueFields2 = diffFields fields2 fields1
237 let addFieldMismatchError missingFields =
238 let msg = fieldMismatchError missingFields
239 in
240 typeError region (Just msg) variable1 variable2
242 case (ext1, ext2) of
243 (Empty _, Empty _) ->
244 case Map.null uniqueFields1 && Map.null uniqueFields2 of
245 True -> return ()
246 False -> typeError region Nothing variable1 variable2
248 (Empty var1, Extension var2) ->
249 case (Map.null uniqueFields1, Map.null uniqueFields2) of
250 (_, False) -> addFieldMismatchError uniqueFields2
251 (True, True) -> unifyHelp region var1 var2
252 (False, True) ->
253 do subRecord <- freshRecord uniqueFields1 var1
254 unifyHelp region subRecord var2
256 (Extension var1, Empty var2) ->
257 case (Map.null uniqueFields1, Map.null uniqueFields2) of
258 (False, _) -> addFieldMismatchError uniqueFields1
259 (True, True) -> unifyHelp region var1 var2
260 (True, False) ->
261 do subRecord <- freshRecord uniqueFields2 var2
262 unifyHelp region var1 subRecord
264 (Extension var1, Extension var2) ->
265 case (Map.null uniqueFields1, Map.null uniqueFields2) of
266 (True, True) ->
267 unifyHelp region var1 var2
269 (True, False) ->
270 do subRecord <- freshRecord uniqueFields2 var2
271 unifyHelp region var1 subRecord
273 (False, True) ->
274 do subRecord <- freshRecord uniqueFields1 var1
275 unifyHelp region subRecord var2
277 (False, False) ->
278 do record1' <- freshRecord uniqueFields1 =<< fresh Nothing
279 record2' <- freshRecord uniqueFields2 =<< fresh Nothing
280 unifyHelp region record1' var2
281 unifyHelp region var1 record2'
284unifyOverlappingFields
285 :: A.Region
286 -> Map.Map String [Variable]
287 -> Map.Map String [Variable]
288 -> Unify ()
289unifyOverlappingFields region fields1 fields2 =
290 Map.intersectionWith (zipWith (unifyHelp region)) fields1 fields2
291 |> Map.elems
292 |> concat
293 |> sequence_
296diffFields :: Map.Map String [a] -> Map.Map String [a] -> Map.Map String [a]
297diffFields fields1 fields2 =
298 let eat (_:xs) (_:ys) = eat xs ys
299 eat xs _ = xs
300 in
301 Map.union (Map.intersectionWith eat fields1 fields2) fields1
302 |> Map.filter (not . null)
305data ExpandedRecord = ExpandedRecord
306 { _fields :: Map.Map String [Variable]
307 , _extension :: Extension
308 }
310data Extension = Empty Variable | Extension Variable
313gatherFields :: Variable -> IO ExpandedRecord
314gatherFields var =
315 do desc <- UF.descriptor var
316 case structure desc of
317 (Just (Record1 fields ext)) ->
318 do (ExpandedRecord deeperFields rootExt) <- gatherFields ext
319 return (ExpandedRecord (Map.unionWith (++) fields deeperFields) rootExt)
321 (Just EmptyRecord1) ->
322 return (ExpandedRecord Map.empty (Empty var))
324 _ ->
325 return (ExpandedRecord Map.empty (Extension var))
328-- assumes that one of the dicts has stuff in it
329fieldMismatchError :: Map.Map String a -> String
330fieldMismatchError missingFields =
331 case Map.keys missingFields of
332 [] -> ""
333 [key] ->
334 "Looks like a record is missing the field '" ++ key ++ "'.\n " ++
335 "Maybe there is a misspelling in a record access or record update?"
336 keys ->
337 "Looks like one record is missing fields "
338 ++ List.intercalate ", " (init keys) ++ ", and " ++ last keys
341combinedDescriptors :: Descriptor -> Descriptor
342 -> (Maybe Var.Canonical, Flex, Int, Maybe Var.Canonical)
343combinedDescriptors desc1 desc2 =
344 (name', flex', rank', alias')
345 where
346 rank' :: Int
347 rank' = min (rank desc1) (rank desc2)
349 alias' :: Maybe Var.Canonical
350 alias' = alias desc1 <|> alias desc2
352 name' :: Maybe Var.Canonical
353 name' = case (name desc1, name desc2) of
354 (Just name1, Just name2) ->
355 case (flex desc1, flex desc2) of
356 (_, Flexible) -> Just name1
357 (Flexible, _) -> Just name2
358 (Is Number, Is _) -> Just name1
359 (Is _, Is Number) -> Just name2
360 (Is _, Is _) -> Just name1
361 (_, _) -> Nothing
362 (Just name1, _) -> Just name1
363 (_, Just name2) -> Just name2
364 _ -> Nothing
366 flex' :: Flex
367 flex' = case (flex desc1, flex desc2) of
368 (f, Flexible) -> f
369 (Flexible, f) -> f
370 (Is Number, Is _) -> Is Number
371 (Is _, Is Number) -> Is Number
372 (Is super, Is _) -> Is super
373 (_, _) -> Flexible