git.iko.soy/elk
on master help sign in
Merge branch 'record-unification'
0fe796bEvan Czaplicki
src/Type/State.hs+13−8
compare with master
unifiedsplit
@@ -45,8 +45,13 @@ initialState = SS {
45modifyEnv f = modify $ \state -> state { sEnv = f (sEnv state) }
45modifyEnv f = modify $ \state -> state { sEnv = f (sEnv state) }
46modifyPool f = modify $ \state -> state { sPool = f (sPool state) }
46modifyPool f = modify $ \state -> state { sPool = f (sPool state) }
47
47
48+
49+addError
50+ :: A.Region
51+ -> Maybe String
48−addError :: A.Region -> Maybe String -> UF.Point Descriptor -> UF.Point Descriptor
52+ -> UF.Point Descriptor
53+ -> UF.Point Descriptor
49− -> StateT SolverState IO ()
54+ -> StateT SolverState IO ()
50addError region hint t1 t2 =
55addError region hint t1 t2 =
51 do err <- liftIO makeError
56 do err <- liftIO makeError
52 modify $ \state -> state { sErrors = err : sErrors state }
57 modify $ \state -> state { sErrors = err : sErrors state }
@@ -55,16 +60,16 @@ addError region hint t1 t2 =
55 t1' <- pretty <$> toSrcType t1
60 t1' <- pretty <$> toSrcType t1
56 t2' <- pretty <$> toSrcType t2
61 t2' <- pretty <$> toSrcType t2
57 return . foldr ($+$) P.empty $
62 return . foldr ($+$) P.empty $
58− [ P.text "Type mismatch" <+> pretty region <> P.text "."
59− , maybe P.empty P.text hint
60− , P.text ""
61− , P.nest 8 $ A.getRegionDocs region
62− , P.text ""
63− , P.text " Something is causing a mismatch between the following types:"
63+ [ P.text "Type mismatch between the following types:"
64 , P.text ""
64 , P.text ""
65 , P.nest 8 t1'
65 , P.nest 8 t1'
66 , P.text ""
66 , P.text ""
67 , P.nest 8 t2'
67 , P.nest 8 t2'
68+ , P.text ""
69+ , maybe P.empty (P.nest 4 . P.text) hint
70+ , P.text " It is related to the expression" <+> pretty region
71+ , P.text ""
72+ , P.nest 8 $ A.getRegionDocs region
68 ]
73 ]
69
74
70switchToPool pool = modifyPool (\_ -> pool)
75switchToPool pool = modifyPool (\_ -> pool)
src/Type/Unify.hs+133−38
@@ -76,16 +76,24 @@ actuallyUnify region variable1 variable2 = do
76 case home of
76 case home of
77 Var.BuiltIn | name `elem` ["Int","Float"] -> flexAndUnify svar
77 Var.BuiltIn | name `elem` ["Int","Float"] -> flexAndUnify svar
78 Var.Local | List.isPrefixOf "number" name -> flexAndUnify svar
78 Var.Local | List.isPrefixOf "number" name -> flexAndUnify svar
79− _ -> let hint = "A number must be an Int or Float."
79+ _ ->
80+ let hint = "Looks like something besides an Int or Float is being used as a number."
81+ in
80− in TS.addError region (Just hint) variable1 variable2
82+ TS.addError region (Just hint) variable1 variable2
81
83
82 comparableError maybe =
84 comparableError maybe =
83 TS.addError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2
85 TS.addError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2
86+ where
87+ msg =
88+ "Looks like you want something comparable, but the only valid comparable\n\
84− where msg = "A comparable must be an Int, Float, Char, String, list, or tuple."
89+ \types are Int, Float, Char, String, lists, or tuples."
85
90
86 appendableError maybe =
91 appendableError maybe =
87 TS.addError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2
92 TS.addError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2
88− where msg = "An appendable must be of type String, List, or Text."
93+ where
94+ msg =
95+ "Looks like you want something appendable, but the only Strings, Lists,\n\
96+ \and Text can be appended with the (++) operator."
89
97
90 unifyComparable v (Var.Canonical home name) =
98 unifyComparable v (Var.Canonical home name) =
91 case home of
99 case home of
@@ -113,12 +121,13 @@ actuallyUnify region variable1 variable2 = do
113 List _ -> flexAndUnify varSuper
121 List _ -> flexAndUnify varSuper
114 _ -> appendableError Nothing
122 _ -> appendableError Nothing
115
123
124+ rigidError var =
116− rigidError var = TS.addError region (Just hint) variable1 variable2
125+ TS.addError region (Just hint) variable1 variable2
117− where
126+ where
127+ hint =
118− var' = "'" ++ render (pretty Never var) ++ "'"
128+ "Could not unify rigid type variable '" ++ render (pretty Never var) ++ "'.\n" ++
119− hint = "Cannot unify rigid type variable " ++ var' ++
120− ".\nThe problem probably relates to a type annotation. Note that rigid type\n\
129+ "The problem probably relates to the type variable being shared between a\n\
121− \variables are not shared between a top-level and let-bound type annotations."
130+ \top-level type annotation and a related let-bound type annotation."
122
131
123 superUnify =
132 superUnify =
124 case (flex desc1, flex desc2, name desc1, name desc2) of
133 case (flex desc1, flex desc2, name desc1, name desc2) of
@@ -174,37 +183,89 @@ actuallyUnify region variable1 variable2 = do
174 (Record1 fields ext, EmptyRecord1) | Map.null fields -> unify' ext variable2
183 (Record1 fields ext, EmptyRecord1) | Map.null fields -> unify' ext variable2
175 (EmptyRecord1, Record1 fields ext) | Map.null fields -> unify' ext variable1
184 (EmptyRecord1, Record1 fields ext) | Map.null fields -> unify' ext variable1
176
185
177− (Record1 fields1 ext1, Record1 fields2 ext2) ->
186+ (Record1 _ _, Record1 _ _) ->
178− do Map.intersectionWith (zipWith unify') fields1 fields2
187+ recordUnify region fresh variable1 variable2
179− |> Map.elems
180− |> concat
181− |> sequence
182
188
183− let mkRecord fs ext =
189+ _ -> TS.addError region Nothing variable1 variable2
184− fresh (Just (Record1 fs ext))
185−
186− let uniqueFields1 = diffFields fields1 fields2
187− let uniqueFields2 = diffFields fields2 fields1
188−
189− case (Map.null uniqueFields1, Map.null uniqueFields2) of
190− (True, True) ->
191− unify' ext1 ext2
192−
193− (True, False) ->
194− do record2' <- mkRecord uniqueFields2 ext2
195− unify' ext1 record2'
196−
197− (False, True) ->
198− do record1' <- mkRecord uniqueFields1 ext1
199− unify' record1' ext2
200
190
201− (False, False) ->
202− do record1' <- mkRecord uniqueFields1 =<< fresh Nothing
203− record2' <- mkRecord uniqueFields2 =<< fresh Nothing
204− unify' record1' ext2
205− unify' ext1 record2'
206
191
192+-- RECORD UNIFICATION
193+
194+recordUnify
195+ :: A.Region
196+ -> (Maybe (Term1 Variable) -> StateT TS.SolverState IO Variable)
197+ -> Variable
198+ -> Variable
199+ -> StateT TS.SolverState IO ()
200+recordUnify region fresh variable1 variable2 =
201+ do (ExpandedRecord fields1 ext1) <- liftIO (gatherFields variable1)
202+ (ExpandedRecord fields2 ext2) <- liftIO (gatherFields variable2)
203+
204+ unifyOverlappingFields region fields1 fields2
205+
206+ let freshRecord fields ext =
207+ fresh (Just (Record1 fields ext))
208+
209+ let uniqueFields1 = diffFields fields1 fields2
210+ let uniqueFields2 = diffFields fields2 fields1
211+
212+ let addFieldMismatchError missingFields =
213+ let msg = fieldMismatchError missingFields
214+ in
215+ TS.addError region (Just msg) variable1 variable2
216+
217+ case (ext1, ext2) of
218+ (Empty _, Empty _) ->
219+ case Map.null uniqueFields1 && Map.null uniqueFields2 of
220+ True -> return ()
207− _ -> TS.addError region Nothing variable1 variable2
221+ False -> TS.addError region Nothing variable1 variable2
222+
223+ (Empty var1, Extension var2) ->
224+ case (Map.null uniqueFields1, Map.null uniqueFields2) of
225+ (_, False) -> addFieldMismatchError uniqueFields2
226+ (True, True) -> unify region var1 var2
227+ (False, True) ->
228+ do subRecord <- freshRecord uniqueFields1 var1
229+ unify region subRecord var2
230+
231+ (Extension var1, Empty var2) ->
232+ case (Map.null uniqueFields1, Map.null uniqueFields2) of
233+ (False, _) -> addFieldMismatchError uniqueFields1
234+ (True, True) -> unify region var1 var2
235+ (True, False) ->
236+ do subRecord <- freshRecord uniqueFields2 var2
237+ unify region var1 subRecord
238+
239+ (Extension var1, Extension var2) ->
240+ case (Map.null uniqueFields1, Map.null uniqueFields2) of
241+ (True, True) ->
242+ unify region var1 var2
243+
244+ (True, False) ->
245+ do subRecord <- freshRecord uniqueFields2 var2
246+ unify region var1 subRecord
247+
248+ (False, True) ->
249+ do subRecord <- freshRecord uniqueFields1 var1
250+ unify region subRecord var2
251+
252+ (False, False) ->
253+ do record1' <- freshRecord uniqueFields1 =<< fresh Nothing
254+ record2' <- freshRecord uniqueFields2 =<< fresh Nothing
255+ unify region record1' var2
256+ unify region var1 record2'
257+
258+
259+unifyOverlappingFields
260+ :: A.Region
261+ -> Map.Map String [Variable]
262+ -> Map.Map String [Variable]
263+ -> StateT TS.SolverState IO ()
264+unifyOverlappingFields region fields1 fields2 =
265+ Map.intersectionWith (zipWith (unify region)) fields1 fields2
266+ |> Map.elems
267+ |> concat
268+ |> sequence_
208
269
209
270
210diffFields :: Map.Map String [a] -> Map.Map String [a] -> Map.Map String [a]
271diffFields :: Map.Map String [a] -> Map.Map String [a] -> Map.Map String [a]
@@ -216,6 +277,40 @@ diffFields fields1 fields2 =
216 |> Map.filter (not . null)
277 |> Map.filter (not . null)
217
278
218
279
280+data ExpandedRecord = ExpandedRecord
281+ { fields :: Map.Map String [Variable]
282+ , extension :: Extension
283+ }
284+
285+data Extension = Empty Variable | Extension Variable
286+
287+
288+gatherFields :: Variable -> IO ExpandedRecord
289+gatherFields var =
290+ do desc <- UF.descriptor var
291+ case structure desc of
292+ (Just (Record1 fields ext)) ->
293+ do (ExpandedRecord deeperFields rootExt) <- gatherFields ext
294+ return (ExpandedRecord (Map.unionWith (++) fields deeperFields) rootExt)
295+
296+ (Just EmptyRecord1) ->
297+ return (ExpandedRecord Map.empty (Empty var))
298+
299+ _ ->
300+ return (ExpandedRecord Map.empty (Extension var))
301+
302+
303+-- assumes that one of the dicts has stuff in it
304+fieldMismatchError :: Map.Map String a -> String
305+fieldMismatchError missingFields =
306+ case Map.keys missingFields of
307+ [] -> ""
308+ [key] -> "Looks like one record is missing field " ++ key
309+ keys ->
310+ "Looks like one record is missing fields "
311+ ++ List.intercalate ", " (init keys) ++ ", and " ++ last keys
312+
313+
219combinedDescriptors :: Descriptor -> Descriptor
314combinedDescriptors :: Descriptor -> Descriptor
220 -> (Maybe Var.Canonical, Flex, Int, Maybe Var.Canonical)
315 -> (Maybe Var.Canonical, Flex, Int, Maybe Var.Canonical)
221combinedDescriptors desc1 desc2 =
316combinedDescriptors desc1 desc2 =