git.iko.soy/elk
on master help sign in
Bail out of unification on first failure
0d10d2fEvan Czaplicki
elm-compiler.cabal+1
compare with master
unifiedsplit
@@ -98,6 +98,7 @@ Library
98 Type.Environment,
98 Type.Environment,
99 Type.ExtraChecks,
99 Type.ExtraChecks,
100 Type.Fragment,
100 Type.Fragment,
101+ Type.Hint,
101 Type.Inference,
102 Type.Inference,
102 Type.PrettyPrint,
103 Type.PrettyPrint,
103 Type.Solve,
104 Type.Solve,
src/AST/PrettyPrint.hs+4
@@ -38,5 +38,9 @@ eightyCharLines indent message = answer
38 | slen + wlen > 79 = (sentence ++ "\n" ++ spaces ++ word, indent + wlen, " ")
38 | slen + wlen > 79 = (sentence ++ "\n" ++ spaces ++ word, indent + wlen, " ")
39 | otherwise = (sentence ++ space ++ word, slen + wlen + length space, " ")
39 | otherwise = (sentence ++ space ++ word, slen + wlen + length space, " ")
40
40
41+instance Error Doc where
42+ noMsg = P.empty
43+ strMsg = P.text
44+
41instance ErrorList Doc where
45instance ErrorList Doc where
42 listMsg str = [ P.text str ]
46 listMsg str = [ P.text str ]
src/Type/ExtraChecks.hs+4−2
@@ -20,6 +20,7 @@ import qualified AST.PrettyPrint as PP
20import qualified AST.Type as ST
20import qualified AST.Type as ST
21import qualified AST.Variable as V
21import qualified AST.Variable as V
22import qualified Transform.Expression as Expr
22import qualified Transform.Expression as Expr
23+import qualified Type.Hint as Hint
23import qualified Type.Type as TT
24import qualified Type.Type as TT
24import qualified Type.State as TS
25import qualified Type.State as TS
25
26
@@ -143,12 +144,13 @@ occurs (name, variable) =
143 do desc <- liftIO $ UF.descriptor var
144 do desc <- liftIO $ UF.descriptor var
144 case TT.structure desc of
145 case TT.structure desc of
145 Nothing ->
146 Nothing ->
146− modify $ \s -> s { TS.sErrors = P.text msg : TS.sErrors s }
147+ TS.addHint (P.text msg)
147
148
148 Just _ ->
149 Just _ ->
149 do liftIO $ UF.setDescriptor var (desc { TT.structure = Nothing })
150 do liftIO $ UF.setDescriptor var (desc { TT.structure = Nothing })
150 var' <- liftIO $ UF.fresh desc
151 var' <- liftIO $ UF.fresh desc
151− TS.addError (A.None (P.text name)) (Just msg) var var'
152+ hint <- liftIO $ Hint.create (A.None (P.text name)) (Just msg) var var'
153+ TS.addHint hint
152 where
154 where
153 msg = "Infinite types are not allowed"
155 msg = "Infinite types are not allowed"
154
156
src/Type/Hint.hsnew file+35
@@ -0,0 +1,35 @@
1+module Type.Hint where
2+
3+import Control.Applicative ( (<$>) )
4+import qualified Data.UnionFind.IO as UF
5+import Text.PrettyPrint as P
6+
7+import qualified AST.Annotation as A
8+import AST.PrettyPrint (pretty)
9+import Type.Type (Descriptor, toSrcType)
10+
11+
12+type Hint = Doc
13+
14+
15+create
16+ :: A.Region
17+ -> Maybe String
18+ -> UF.Point Descriptor
19+ -> UF.Point Descriptor
20+ -> IO Hint
21+create region hint t1 t2 =
22+ do t1' <- pretty <$> toSrcType t1
23+ t2' <- pretty <$> toSrcType t2
24+ return . foldr ($+$) P.empty $
25+ [ P.text "Type mismatch between the following types" <+> pretty region <> P.text ":"
26+ , P.text ""
27+ , P.nest 8 t1'
28+ , P.text ""
29+ , P.nest 8 t2'
30+ , P.text ""
31+ , maybe P.empty (P.nest 4 . P.text) hint
32+ , P.text " It is related to the following expression:"
33+ , P.text ""
34+ , P.nest 8 $ A.getRegionDocs region
35+ ]
src/Type/Inference.hs+3−3
@@ -29,9 +29,9 @@ infer interfaces modul =
29
29
30 state <- liftIO $ execStateT (Solve.solve constraint) TS.initialState
30 state <- liftIO $ execStateT (Solve.solve constraint) TS.initialState
31
31
32− () <- case TS.sErrors state of
32+ () <- case TS.sHint state of
33− errors@(_:_) -> throwError errors
33+ hints@(_:_) -> throwError hints
34− [] -> return ()
34+ [] -> return ()
35
35
36 () <- Check.portTypes (program (body modul))
36 () <- Check.portTypes (program (body modul))
37
37
src/Type/Solve.hs+22−9
@@ -9,6 +9,7 @@ import qualified Data.UnionFind.IO as UF
9import Type.Type
9import Type.Type
10import Type.Unify
10import Type.Unify
11import qualified Type.ExtraChecks as Check
11import qualified Type.ExtraChecks as Check
12+import qualified Type.Hint as Hint
12import qualified Type.State as TS
13import qualified Type.State as TS
13import qualified AST.Annotation as A
14import qualified AST.Annotation as A
14
15
@@ -169,6 +170,17 @@ solveScheme region scheme =
169 return header'
170 return header'
170
171
171
172
173+addHint
174+ :: A.Region
175+ -> Maybe String
176+ -> UF.Point Descriptor
177+ -> UF.Point Descriptor
178+ -> StateT TS.SolverState IO ()
179+addHint region hint t1 t2 =
180+ do msg <- liftIO (Hint.create region hint t1 t2)
181+ TS.addHint msg
182+
183+
172-- Checks that all of the given variables belong to distinct equivalence classes.
184-- Checks that all of the given variables belong to distinct equivalence classes.
173-- Also checks that their structure is Nothing, so they represent a variable, not
185-- Also checks that their structure is Nothing, so they represent a variable, not
174-- a more complex term.
186-- a more complex term.
@@ -178,15 +190,16 @@ allDistinct region vars =
178 forM_ vars $ \var ->
190 forM_ vars $ \var ->
179 do desc <- liftIO $ UF.descriptor var
191 do desc <- liftIO $ UF.descriptor var
180 case structure desc of
192 case structure desc of
181− Just _ -> TS.addError region (Just msg) var var
193+ Just _ ->
182− where msg = "Cannot generalize something that is not a type variable."
194+ let msg = "Cannot generalize something that is not a type variable."
195+ in
196+ addHint region (Just msg) var var
183
197
184− Nothing -> do
198+ Nothing ->
185− if mark desc == seen
199+ do when (mark desc == seen) $
186− then let msg = "Duplicate variable during generalization."
200+ do let msg = "Duplicate variable during generalization."
187− in TS.addError region (Just msg) var var
201+ addHint region (Just msg) var var
188− else return ()
189− liftIO $ UF.setDescriptor var (desc { mark = seen })
202+ liftIO $ UF.setDescriptor var (desc { mark = seen })
190
203
191
204
192-- Check that a variable has rank == noRank, meaning that it can be generalized.
205-- Check that a variable has rank == noRank, meaning that it can be generalized.
@@ -197,4 +210,4 @@ isGeneric region var =
197 then return ()
210 then return ()
198 else
211 else
199 let msg = "Unable to generalize a type variable. It is not unranked."
212 let msg = "Unable to generalize a type variable. It is not unranked."
200− in TS.addError region (Just msg) var var
213+ in addHint region (Just msg) var var
src/Type/State.hs+9−32
@@ -7,11 +7,10 @@ import qualified Data.Map as Map
7import qualified Data.Traversable as Traversable
7import qualified Data.Traversable as Traversable
8import qualified Data.UnionFind.IO as UF
8import qualified Data.UnionFind.IO as UF
9
9
10−import qualified AST.Annotation as A
10+import qualified Type.Hint as Hint
11−import AST.PrettyPrint
12−import Text.PrettyPrint as P
13import Type.Type
11import Type.Type
14
12
13+
15-- Pool
14-- Pool
16-- Holds a bunch of variables
15-- Holds a bunch of variables
17-- The rank of each variable is less than or equal to the pool's "maxRank"
16-- The rank of each variable is less than or equal to the pool's "maxRank"
@@ -40,7 +39,7 @@ data SolverState = SS
40 , sSavedEnv :: Env
39 , sSavedEnv :: Env
41 , sPool :: Pool
40 , sPool :: Pool
42 , sMark :: Int
41 , sMark :: Int
43− , sErrors :: [P.Doc]
42+ , sHint :: [Hint.Hint]
44 }
43 }
45
44
46
45
@@ -51,7 +50,7 @@ initialState =
51 , sSavedEnv = Map.empty
50 , sSavedEnv = Map.empty
52 , sPool = emptyPool
51 , sPool = emptyPool
53 , sMark = noMark + 1 -- The mark must never be equal to noMark!
52 , sMark = noMark + 1 -- The mark must never be equal to noMark!
54− , sErrors = []
53+ , sHint = []
55 }
54 }
56
55
57
56
@@ -65,31 +64,9 @@ modifyPool f =
65 modify $ \state -> state { sPool = f (sPool state) }
64 modify $ \state -> state { sPool = f (sPool state) }
66
65
67
66
68−addError
69− :: A.Region
70− -> Maybe String
71− -> UF.Point Descriptor
72− -> UF.Point Descriptor
73− -> StateT SolverState IO ()
67+addHint :: Hint.Hint -> StateT SolverState IO ()
74−addError region hint t1 t2 =
68+addHint hint =
75− do err <- liftIO makeError
76− modify $ \state -> state { sErrors = err : sErrors state }
69+ modify $ \state -> state { sHint = hint : sHint state }
77− where
78− makeError = do
79− t1' <- pretty <$> toSrcType t1
80− t2' <- pretty <$> toSrcType t2
81− return . foldr ($+$) P.empty $
82− [ P.text "Type mismatch between the following types" <+> pretty region <> P.text ":"
83− , P.text ""
84− , P.nest 8 t1'
85− , P.text ""
86− , P.nest 8 t2'
87− , P.text ""
88− , maybe P.empty (P.nest 4 . P.text) hint
89− , P.text " It is related to the following expression:"
90− , P.text ""
91− , P.nest 8 $ A.getRegionDocs region
92− ]
93
70
94
71
95switchToPool :: (MonadState SolverState m) => Pool -> m ()
72switchToPool :: (MonadState SolverState m) => Pool -> m ()
@@ -109,8 +86,8 @@ getEnv =
109
86
110saveLocalEnv :: StateT SolverState IO ()
87saveLocalEnv :: StateT SolverState IO ()
111saveLocalEnv =
88saveLocalEnv =
112− do env <- sEnv <$> get
89+ do currentEnv <- getEnv
113− modify $ \state -> state { sSavedEnv = env }
90+ modify $ \state -> state { sSavedEnv = currentEnv }
114
91
115
92
116uniqueMark :: StateT SolverState IO Int
93uniqueMark :: StateT SolverState IO Int
src/Type/Unify.hs+66−41
@@ -1,37 +1,62 @@
1module Type.Unify (unify) where
1module Type.Unify (unify) where
2
2
3import Control.Applicative ((<|>))
3import Control.Applicative ((<|>))
4−import Control.Monad.State
4+import Control.Monad.Error (ErrorT, throwError, runErrorT)
5+import Control.Monad.State as State
5import qualified Data.List as List
6import qualified Data.List as List
6import qualified Data.Map as Map
7import qualified Data.Map as Map
7import qualified Data.Maybe as Maybe
8import qualified Data.Maybe as Maybe
8import qualified Data.UnionFind.IO as UF
9import qualified Data.UnionFind.IO as UF
10+import Text.PrettyPrint (render)
11+
9import qualified AST.Annotation as A
12import qualified AST.Annotation as A
10import qualified AST.Variable as Var
13import qualified AST.Variable as Var
11import qualified Type.State as TS
14import qualified Type.State as TS
12import Type.Type
15import Type.Type
13import Type.PrettyPrint
16import Type.PrettyPrint
14−import Text.PrettyPrint (render)
17+import qualified Type.Hint as Hint
15import Elm.Utils ((|>))
18import Elm.Utils ((|>))
16
19
17
20
18unify :: A.Region -> Variable -> Variable -> StateT TS.SolverState IO ()
21unify :: A.Region -> Variable -> Variable -> StateT TS.SolverState IO ()
19−unify region variable1 variable2 = do
22+unify region variable1 variable2 =
23+ do result <- runErrorT (unifyHelp region variable1 variable2)
24+ either TS.addHint return result
25+
26+
27+-- ACTUALLY UNIFY STUFF
28+
29+type Unify = ErrorT Hint.Hint (StateT TS.SolverState IO)
30+
31+
32+typeError
33+ :: A.Region
34+ -> Maybe String
35+ -> UF.Point Descriptor
36+ -> UF.Point Descriptor
37+ -> Unify a
38+typeError region hint t1 t2 =
39+ do msg <- liftIO (Hint.create region hint t1 t2)
40+ throwError msg
41+
42+
43+unifyHelp :: A.Region -> Variable -> Variable -> Unify ()
44+unifyHelp region variable1 variable2 = do
20 equivalent <- liftIO $ UF.equivalent variable1 variable2
45 equivalent <- liftIO $ UF.equivalent variable1 variable2
21 if equivalent
46 if equivalent
22 then return ()
47 then return ()
23 else actuallyUnify region variable1 variable2
48 else actuallyUnify region variable1 variable2
24
49
25
50
26−actuallyUnify :: A.Region -> Variable -> Variable -> StateT TS.SolverState IO ()
51+actuallyUnify :: A.Region -> Variable -> Variable -> Unify ()
27actuallyUnify region variable1 variable2 = do
52actuallyUnify region variable1 variable2 = do
28 desc1 <- liftIO $ UF.descriptor variable1
53 desc1 <- liftIO $ UF.descriptor variable1
29 desc2 <- liftIO $ UF.descriptor variable2
54 desc2 <- liftIO $ UF.descriptor variable2
30− let unify' = unify region
55+ let unifyHelp' = unifyHelp region
31
56
32 (name', flex', rank', alias') = combinedDescriptors desc1 desc2
57 (name', flex', rank', alias') = combinedDescriptors desc1 desc2
33
58
34− merge1 :: StateT TS.SolverState IO ()
59+ merge1 :: Unify ()
35 merge1 = liftIO $ do
60 merge1 = liftIO $ do
36 if rank desc1 < rank desc2 then UF.union variable2 variable1
61 if rank desc1 < rank desc2 then UF.union variable2 variable1
37 else UF.union variable1 variable2
62 else UF.union variable1 variable2
@@ -42,7 +67,7 @@ actuallyUnify region variable1 variable2 = do
42 , alias = alias'
67 , alias = alias'
43 }
68 }
44
69
45− merge2 :: StateT TS.SolverState IO ()
70+ merge2 :: Unify ()
46 merge2 = liftIO $ do
71 merge2 = liftIO $ do
47 if rank desc1 < rank desc2 then UF.union variable2 variable1
72 if rank desc1 < rank desc2 then UF.union variable2 variable1
48 else UF.union variable1 variable2
73 else UF.union variable1 variable2
@@ -55,7 +80,7 @@ actuallyUnify region variable1 variable2 = do
55
80
56 merge = if rank desc1 < rank desc2 then merge1 else merge2
81 merge = if rank desc1 < rank desc2 then merge1 else merge2
57
82
58− fresh :: Maybe (Term1 Variable) -> StateT TS.SolverState IO Variable
83+ fresh :: Maybe (Term1 Variable) -> Unify Variable
59 fresh structure = do
84 fresh structure = do
60 v <- liftIO . UF.fresh $ Descriptor
85 v <- liftIO . UF.fresh $ Descriptor
61 { structure = structure
86 { structure = structure
@@ -66,11 +91,11 @@ actuallyUnify region variable1 variable2 = do
66 , mark = noMark
91 , mark = noMark
67 , alias = alias'
92 , alias = alias'
68 }
93 }
69− TS.register v
94+ lift (TS.register v)
70
95
71 flexAndUnify v = do
96 flexAndUnify v = do
72 liftIO $ UF.modifyDescriptor v $ \desc -> desc { flex = Flexible }
97 liftIO $ UF.modifyDescriptor v $ \desc -> desc { flex = Flexible }
73− unify' variable1 variable2
98+ unifyHelp' variable1 variable2
74
99
75 unifyNumber svar (Var.Canonical home name) =
100 unifyNumber svar (Var.Canonical home name) =
76 case home of
101 case home of
@@ -79,17 +104,17 @@ actuallyUnify region variable1 variable2 = do
79 _ ->
104 _ ->
80 let hint = "Looks like something besides an Int or Float is being used as a number."
105 let hint = "Looks like something besides an Int or Float is being used as a number."
81 in
106 in
82− TS.addError region (Just hint) variable1 variable2
107+ typeError region (Just hint) variable1 variable2
83
108
84 comparableError maybe =
109 comparableError maybe =
85− TS.addError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2
110+ typeError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2
86 where
111 where
87 msg =
112 msg =
88 "Looks like you want something comparable, but the only valid comparable\n\
113 "Looks like you want something comparable, but the only valid comparable\n\
89 \types are Int, Float, Char, String, lists, or tuples."
114 \types are Int, Float, Char, String, lists, or tuples."
90
115
91 appendableError maybe =
116 appendableError maybe =
92− TS.addError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2
117+ typeError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2
93 where
118 where
94 msg =
119 msg =
95 "Looks like you want something appendable, but the only Strings, Lists,\n\
120 "Looks like you want something appendable, but the only Strings, Lists,\n\
@@ -106,14 +131,14 @@ actuallyUnify region variable1 variable2 = do
106 case struct of
131 case struct of
107 Other -> comparableError Nothing
132 Other -> comparableError Nothing
108 List v -> do flexAndUnify varSuper
133 List v -> do flexAndUnify varSuper
109− unify' v =<< liftIO (variable $ Is Comparable)
134+ unifyHelp' v =<< liftIO (variable $ Is Comparable)
110 Tuple vs
135 Tuple vs
111 | length vs > 6 ->
136 | length vs > 6 ->
112 comparableError $ Just "Cannot compare a tuple with more than 6 elements."
137 comparableError $ Just "Cannot compare a tuple with more than 6 elements."
113 | otherwise ->
138 | otherwise ->
114 do flexAndUnify varSuper
139 do flexAndUnify varSuper
115 cmpVars <- liftIO $ forM [1..length vs] $ \_ -> variable (Is Comparable)
140 cmpVars <- liftIO $ forM [1..length vs] $ \_ -> variable (Is Comparable)
116− zipWithM_ unify' vs cmpVars
141+ zipWithM_ unifyHelp' vs cmpVars
117
142
118 unifyAppendable varSuper varFlex =
143 unifyAppendable varSuper varFlex =
119 do struct <- liftIO $ collectApps varFlex
144 do struct <- liftIO $ collectApps varFlex
@@ -122,7 +147,7 @@ actuallyUnify region variable1 variable2 = do
122 _ -> appendableError Nothing
147 _ -> appendableError Nothing
123
148
124 rigidError var =
149 rigidError var =
125− TS.addError region (Just hint) variable1 variable2
150+ typeError region (Just hint) variable1 variable2
126 where
151 where
127 hint =
152 hint =
128 "Could not unify rigid type variable '" ++ render (pretty Never var) ++ "'.\n" ++
153 "Could not unify rigid type variable '" ++ render (pretty Never var) ++ "'.\n" ++
@@ -153,15 +178,15 @@ actuallyUnify region variable1 variable2 = do
153
178
154 (Rigid, _, _, _) -> rigidError variable1
179 (Rigid, _, _, _) -> rigidError variable1
155 (_, Rigid, _, _) -> rigidError variable2
180 (_, Rigid, _, _) -> rigidError variable2
156− _ -> TS.addError region Nothing variable1 variable2
181+ _ -> typeError region Nothing variable1 variable2
157
182
158 case (structure desc1, structure desc2) of
183 case (structure desc1, structure desc2) of
159 (Nothing, Nothing) | flex desc1 == Flexible && flex desc1 == Flexible -> merge
184 (Nothing, Nothing) | flex desc1 == Flexible && flex desc1 == Flexible -> merge
160 (Nothing, _) | flex desc1 == Flexible -> merge2
185 (Nothing, _) | flex desc1 == Flexible -> merge2
161 (_, Nothing) | flex desc2 == Flexible -> merge1
186 (_, Nothing) | flex desc2 == Flexible -> merge1
162
187
163− (Just (Var1 v), _) -> unify' v variable2
188+ (Just (Var1 v), _) -> unifyHelp' v variable2
164− (_, Just (Var1 v)) -> unify' v variable1
189+ (_, Just (Var1 v)) -> unifyHelp' v variable1
165
190
166 (Nothing, _) -> superUnify
191 (Nothing, _) -> superUnify
167 (_, Nothing) -> superUnify
192 (_, Nothing) -> superUnify
@@ -170,33 +195,33 @@ actuallyUnify region variable1 variable2 = do
170 case (type1,type2) of
195 case (type1,type2) of
171 (App1 term1 term2, App1 term1' term2') ->
196 (App1 term1 term2, App1 term1' term2') ->
172 do merge
197 do merge
173− unify' term1 term1'
198+ unifyHelp' term1 term1'
174− unify' term2 term2'
199+ unifyHelp' term2 term2'
175 (Fun1 term1 term2, Fun1 term1' term2') ->
200 (Fun1 term1 term2, Fun1 term1' term2') ->
176 do merge
201 do merge
177− unify' term1 term1'
202+ unifyHelp' term1 term1'
178− unify' term2 term2'
203+ unifyHelp' term2 term2'
179
204
180 (EmptyRecord1, EmptyRecord1) ->
205 (EmptyRecord1, EmptyRecord1) ->
181 return ()
206 return ()
182
207
183− (Record1 fields ext, EmptyRecord1) | Map.null fields -> unify' ext variable2
208+ (Record1 fields ext, EmptyRecord1) | Map.null fields -> unifyHelp' ext variable2
184− (EmptyRecord1, Record1 fields ext) | Map.null fields -> unify' ext variable1
209+ (EmptyRecord1, Record1 fields ext) | Map.null fields -> unifyHelp' ext variable1
185
210
186 (Record1 _ _, Record1 _ _) ->
211 (Record1 _ _, Record1 _ _) ->
187 recordUnify region fresh variable1 variable2
212 recordUnify region fresh variable1 variable2
188
213
189− _ -> TS.addError region Nothing variable1 variable2
214+ _ -> typeError region Nothing variable1 variable2
190
215
191
216
192-- RECORD UNIFICATION
217-- RECORD UNIFICATION
193
218
194recordUnify
219recordUnify
195 :: A.Region
220 :: A.Region
196− -> (Maybe (Term1 Variable) -> StateT TS.SolverState IO Variable)
221+ -> (Maybe (Term1 Variable) -> Unify Variable)
197 -> Variable
222 -> Variable
198 -> Variable
223 -> Variable
199− -> StateT TS.SolverState IO ()
224+ -> Unify ()
200recordUnify region fresh variable1 variable2 =
225recordUnify region fresh variable1 variable2 =
201 do (ExpandedRecord fields1 ext1) <- liftIO (gatherFields variable1)
226 do (ExpandedRecord fields1 ext1) <- liftIO (gatherFields variable1)
202 (ExpandedRecord fields2 ext2) <- liftIO (gatherFields variable2)
227 (ExpandedRecord fields2 ext2) <- liftIO (gatherFields variable2)
@@ -212,57 +237,57 @@ recordUnify region fresh variable1 variable2 =
212 let addFieldMismatchError missingFields =
237 let addFieldMismatchError missingFields =
213 let msg = fieldMismatchError missingFields
238 let msg = fieldMismatchError missingFields
214 in
239 in
215− TS.addError region (Just msg) variable1 variable2
240+ typeError region (Just msg) variable1 variable2
216
241
217 case (ext1, ext2) of
242 case (ext1, ext2) of
218 (Empty _, Empty _) ->
243 (Empty _, Empty _) ->
219 case Map.null uniqueFields1 && Map.null uniqueFields2 of
244 case Map.null uniqueFields1 && Map.null uniqueFields2 of
220 True -> return ()
245 True -> return ()
221− False -> TS.addError region Nothing variable1 variable2
246+ False -> typeError region Nothing variable1 variable2
222
247
223 (Empty var1, Extension var2) ->
248 (Empty var1, Extension var2) ->
224 case (Map.null uniqueFields1, Map.null uniqueFields2) of
249 case (Map.null uniqueFields1, Map.null uniqueFields2) of
225 (_, False) -> addFieldMismatchError uniqueFields2
250 (_, False) -> addFieldMismatchError uniqueFields2
226− (True, True) -> unify region var1 var2
251+ (True, True) -> unifyHelp region var1 var2
227 (False, True) ->
252 (False, True) ->
228 do subRecord <- freshRecord uniqueFields1 var1
253 do subRecord <- freshRecord uniqueFields1 var1
229− unify region subRecord var2
254+ unifyHelp region subRecord var2
230
255
231 (Extension var1, Empty var2) ->
256 (Extension var1, Empty var2) ->
232 case (Map.null uniqueFields1, Map.null uniqueFields2) of
257 case (Map.null uniqueFields1, Map.null uniqueFields2) of
233 (False, _) -> addFieldMismatchError uniqueFields1
258 (False, _) -> addFieldMismatchError uniqueFields1
234− (True, True) -> unify region var1 var2
259+ (True, True) -> unifyHelp region var1 var2
235 (True, False) ->
260 (True, False) ->
236 do subRecord <- freshRecord uniqueFields2 var2
261 do subRecord <- freshRecord uniqueFields2 var2
237− unify region var1 subRecord
262+ unifyHelp region var1 subRecord
238
263
239 (Extension var1, Extension var2) ->
264 (Extension var1, Extension var2) ->
240 case (Map.null uniqueFields1, Map.null uniqueFields2) of
265 case (Map.null uniqueFields1, Map.null uniqueFields2) of
241 (True, True) ->
266 (True, True) ->
242− unify region var1 var2
267+ unifyHelp region var1 var2
243
268
244 (True, False) ->
269 (True, False) ->
245 do subRecord <- freshRecord uniqueFields2 var2
270 do subRecord <- freshRecord uniqueFields2 var2
246− unify region var1 subRecord
271+ unifyHelp region var1 subRecord
247
272
248 (False, True) ->
273 (False, True) ->
249 do subRecord <- freshRecord uniqueFields1 var1
274 do subRecord <- freshRecord uniqueFields1 var1
250− unify region subRecord var2
275+ unifyHelp region subRecord var2
251
276
252 (False, False) ->
277 (False, False) ->
253 do record1' <- freshRecord uniqueFields1 =<< fresh Nothing
278 do record1' <- freshRecord uniqueFields1 =<< fresh Nothing
254 record2' <- freshRecord uniqueFields2 =<< fresh Nothing
279 record2' <- freshRecord uniqueFields2 =<< fresh Nothing
255− unify region record1' var2
280+ unifyHelp region record1' var2
256− unify region var1 record2'
281+ unifyHelp region var1 record2'
257
282
258
283
259unifyOverlappingFields
284unifyOverlappingFields
260 :: A.Region
285 :: A.Region
261 -> Map.Map String [Variable]
286 -> Map.Map String [Variable]
262 -> Map.Map String [Variable]
287 -> Map.Map String [Variable]
263− -> StateT TS.SolverState IO ()
288+ -> Unify ()
264unifyOverlappingFields region fields1 fields2 =
289unifyOverlappingFields region fields1 fields2 =
265− Map.intersectionWith (zipWith (unify region)) fields1 fields2
290+ Map.intersectionWith (zipWith (unifyHelp region)) fields1 fields2
266 |> Map.elems
291 |> Map.elems
267 |> concat
292 |> concat
268 |> sequence_
293 |> sequence_