@@ -116,8 +116,8 @@ implies (Group group) candidate = any (`subsumes` candidate) group
116
116
-- __subset__ of the switches in @y@. In other words, the @x@ 'Rule' will match
117
117
-- /everything/ that @y@ will.
118
118
subsumes :: Rule -> Rule -> Bool
119
- subsumes (Rule these ) (Rule those ) = HashMap. foldrWithKey check True these
120
- where check key value acc = HashMap. lookup key those == Just value && acc
119
+ subsumes (Rule x ) (Rule y ) = HashMap. foldrWithKey check True x
120
+ where check key v acc = HashMap. lookup key y == Just v && acc
121
121
122
122
-- | Add a new 'Rule' to a 'Group'. Attempt to calculate any 'refinements' of
123
123
-- the rule, and generalise the 'Group' as far as possible.
@@ -126,11 +126,17 @@ resolve rule group | group `implies` rule = group
126
126
resolve rule@ (Rule config) group@ (Group rules)
127
127
= case refinements rule group of
128
128
[] -> Group case HashMap. toList config of
129
- [ (key, value ) ] -> do -- Unit propagation
129
+ [ (key, x ) ] -> do -- Unit propagation
130
130
HashSet. insert rule $ rules & HashSet. map \ (Rule current) -> do
131
- if HashMap. lookup key current /= Just value
132
- then Rule (HashMap. delete key current)
133
- else rule
131
+ Rule $ case HashMap. lookup key current of
132
+ -- The unit does not appear in the current rule : keep the current rule.
133
+ Nothing -> current
134
+ -- The unit subsumes the current rule : delete the current rule.
135
+ Just y | y == x -> config
136
+ -- If the unit matches, the current rule is useless for that group to match.
137
+ -- Otherwise the unit does not match, but then the current rule
138
+ -- does not need to recheck that : delete the unit from the current rule.
139
+ | otherwise {- y == not x -} -> HashMap. delete key current
134
140
135
141
_ -> rules & HashSet. filter (not . (rule `subsumes` ))
136
142
& HashSet. insert rule
0 commit comments