mirror of
https://github.com/GaloisInc/cryptol.git
synced 2025-01-07 08:19:12 +03:00
Do and-goal splitting in more places.
This alleviates some of the problems in #522
This commit is contained in:
parent
1e5209ade5
commit
0739448933
@ -695,7 +695,7 @@ generalize bs0 gs0 =
|
|||||||
do {- First, we apply the accumulating substitution to the goals
|
do {- First, we apply the accumulating substitution to the goals
|
||||||
and the inferred types, to ensure that we have the most up
|
and the inferred types, to ensure that we have the most up
|
||||||
to date information. -}
|
to date information. -}
|
||||||
gs <- forM gs0 $ \g -> applySubst g
|
gs <- applySubstGoals gs0
|
||||||
bs <- forM bs0 $ \b -> do s <- applySubst (dSignature b)
|
bs <- forM bs0 $ \b -> do s <- applySubst (dSignature b)
|
||||||
return b { dSignature = s }
|
return b { dSignature = s }
|
||||||
|
|
||||||
@ -801,7 +801,7 @@ checkSigB b (Forall as asmps0 t0, validSchema) = case thing (P.bDef b) of
|
|||||||
addGoals validSchema
|
addGoals validSchema
|
||||||
() <- simplifyAllConstraints -- XXX: using `asmps` also?
|
() <- simplifyAllConstraints -- XXX: using `asmps` also?
|
||||||
return e1
|
return e1
|
||||||
cs <- applySubst cs0
|
cs <- applySubstGoals cs0
|
||||||
|
|
||||||
let findKeep vs keep todo =
|
let findKeep vs keep todo =
|
||||||
let stays (_,cvs) = not $ Set.null $ Set.intersection vs cvs
|
let stays (_,cvs) = not $ Set.null $ Set.intersection vs cvs
|
||||||
@ -816,12 +816,12 @@ checkSigB b (Forall as asmps0 t0, validSchema) = case thing (P.bDef b) of
|
|||||||
|
|
||||||
addGoals leave
|
addGoals leave
|
||||||
|
|
||||||
asmps1 <- applySubst asmps0
|
asmps1 <- applySubstPreds asmps0
|
||||||
|
|
||||||
su <- proveImplication (Just (thing (P.bName b))) as asmps1 stay
|
su <- proveImplication (Just (thing (P.bName b))) as asmps1 stay
|
||||||
extendSubst su
|
extendSubst su
|
||||||
|
|
||||||
let asmps = apSubst su asmps1
|
let asmps = concatMap pSplitAnd (apSubst su asmps1)
|
||||||
t <- applySubst t0
|
t <- applySubst t0
|
||||||
e2 <- applySubst e1
|
e2 <- applySubst e1
|
||||||
|
|
||||||
|
@ -343,7 +343,8 @@ newGoals src ps = addGoals =<< mapM (newGoal src) ps
|
|||||||
The substitution IS applied to them. -}
|
The substitution IS applied to them. -}
|
||||||
getGoals :: InferM [Goal]
|
getGoals :: InferM [Goal]
|
||||||
getGoals =
|
getGoals =
|
||||||
do goals <- applySubst =<< IM (sets $ \s -> (iCts s, s { iCts = emptyGoals }))
|
do goals <- applySubst =<<
|
||||||
|
IM (sets $ \s -> (iCts s, s { iCts = emptyGoals }))
|
||||||
return (fromGoals goals)
|
return (fromGoals goals)
|
||||||
|
|
||||||
-- | Add a bunch of goals that need solving.
|
-- | Add a bunch of goals that need solving.
|
||||||
@ -504,6 +505,17 @@ applySubst t =
|
|||||||
do su <- getSubst
|
do su <- getSubst
|
||||||
return (apSubst su t)
|
return (apSubst su t)
|
||||||
|
|
||||||
|
applySubstPreds :: [Prop] -> InferM [Prop]
|
||||||
|
applySubstPreds ps =
|
||||||
|
do ps1 <- applySubst ps
|
||||||
|
return (concatMap pSplitAnd ps1)
|
||||||
|
|
||||||
|
|
||||||
|
applySubstGoals :: [Goal] -> InferM [Goal]
|
||||||
|
applySubstGoals gs =
|
||||||
|
do gs1 <- applySubst gs
|
||||||
|
return [ g { goal = p } | g <- gs1, p <- pSplitAnd (goal g) ]
|
||||||
|
|
||||||
-- | Get the substitution that we have accumulated so far.
|
-- | Get the substitution that we have accumulated so far.
|
||||||
getSubst :: InferM Subst
|
getSubst :: InferM Subst
|
||||||
getSubst = IM $ fmap iSubst get
|
getSubst = IM $ fmap iSubst get
|
||||||
|
@ -232,7 +232,8 @@ capture, because we rely on the 'Subst' datatype invariant to ensure
|
|||||||
that variable scopes will be properly preserved. -}
|
that variable scopes will be properly preserved. -}
|
||||||
|
|
||||||
instance TVars Schema where
|
instance TVars Schema where
|
||||||
apSubst su (Forall xs ps t) = Forall xs (apSubst su ps) (apSubst su t)
|
apSubst su (Forall xs ps t) = Forall xs (concatMap pSplitAnd (apSubst su ps))
|
||||||
|
(apSubst su t)
|
||||||
|
|
||||||
instance TVars Expr where
|
instance TVars Expr where
|
||||||
apSubst su = go
|
apSubst su = go
|
||||||
@ -243,7 +244,13 @@ instance TVars Expr where
|
|||||||
EAbs x t e1 -> EAbs x (apSubst su t) (go e1)
|
EAbs x t e1 -> EAbs x (apSubst su t) (go e1)
|
||||||
ETAbs a e -> ETAbs a (go e)
|
ETAbs a e -> ETAbs a (go e)
|
||||||
ETApp e t -> ETApp (go e) (apSubst su t)
|
ETApp e t -> ETApp (go e) (apSubst su t)
|
||||||
EProofAbs p e -> EProofAbs (apSubst su p) (go e)
|
EProofAbs p e -> EProofAbs hmm (go e)
|
||||||
|
where hmm = case pSplitAnd (apSubst su p) of
|
||||||
|
[p1] -> p1
|
||||||
|
_ -> panic "apSubst@EProofAbs"
|
||||||
|
[ "Predicate split or disappeared after"
|
||||||
|
, "we applied a substitution." ]
|
||||||
|
|
||||||
EProofApp e -> EProofApp (go e)
|
EProofApp e -> EProofApp (go e)
|
||||||
|
|
||||||
EVar {} -> expr
|
EVar {} -> expr
|
||||||
|
Loading…
Reference in New Issue
Block a user