diff --git a/src/Cryptol/TypeCheck/Solver/Numeric.hs b/src/Cryptol/TypeCheck/Solver/Numeric.hs index da3f11fc..36c745db 100644 --- a/src/Cryptol/TypeCheck/Solver/Numeric.hs +++ b/src/Cryptol/TypeCheck/Solver/Numeric.hs @@ -14,7 +14,7 @@ import Cryptol.TypeCheck.TypePat import Cryptol.TypeCheck.Solver.Types import Cryptol.TypeCheck.Solver.InfNat import Cryptol.TypeCheck.Solver.Numeric.Interval -import Cryptol.TypeCheck.SimpType +import Cryptol.TypeCheck.SimpType as Simp {- Convention for comments: @@ -40,8 +40,8 @@ cryIsEqual ctxt t1 t2 = <|> tryEqMulConst t1 t2 <|> tryEqAddInf ctxt t1 t2 <|> tryAddConst (=#=) t1 t2 - - + <|> tryLinearSolution t1 t2 + <|> tryLinearSolution t2 t1 -- | Try to solve @t1 /= t2@ cryIsNotEqual :: Ctxt -> Type -> Type -> Solved @@ -331,3 +331,46 @@ tryAddConst rel l r = if k1 > k2 then return (SolvedIf [ tAdd (tNum (k1 - k2)) x2 `rel` y2 ]) else return (SolvedIf [ x2 `rel` tAdd (tNum (k2 - k1)) y2 ]) + + +-- | Check for situations where a unification variable is involved in +-- a sum of terms not containing additional unification variables, +-- and replace it with a solution and an inequality. +-- @s1 = ?a + s2 ~~> (?a = s1 - s2, s1 >= s2)@ +tryLinearSolution :: Type -> Type -> Match Solved +tryLinearSolution s1 t = + do (a,xs) <- matchLinearUnifier t + guard (noFreeVariables s1) + + -- NB: matchLinearUnifier only matches if xs is nonempty + let s2 = foldr1 Simp.tAdd xs + return (SolvedIf [ TVar a =#= (Simp.tSub s1 s2), s1 >== s2 ]) + + +-- | Match a sum of the form @(s1 + ... + ?a + ... sn)@ where +-- @s1@ through @sn@ do not contain any free variables. +-- +-- Note: a successful match should only occur if @s1 ... sn@ is +-- not empty. +matchLinearUnifier :: Pat Type (TVar,[Type]) +matchLinearUnifier = go [] + where + go xs t = + -- Case where a free variable occurs at the end of a sequence of additions. + -- NB: match fails if @xs@ is empty + do v <- aFreeTVar t + guard (not . null $ xs) + return (v, xs) + <|> + -- Next symbol is an addition + do (x, y) <- anAdd t + + -- Case where a free variable occurs in the middle of an expression + (do v <- aFreeTVar x + guard (noFreeVariables y) + return (v, reverse (y:xs)) + + <|> + -- Non-free-variable recursive case + do guard (noFreeVariables x) + go (x:xs) y) diff --git a/src/Cryptol/TypeCheck/Type.hs b/src/Cryptol/TypeCheck/Type.hs index 4836edff..6c2483c0 100644 --- a/src/Cryptol/TypeCheck/Type.hs +++ b/src/Cryptol/TypeCheck/Type.hs @@ -636,6 +636,8 @@ pError msg = TCon (TError KProp msg) [] -------------------------------------------------------------------------------- +noFreeVariables :: FVS t => t -> Bool +noFreeVariables = all (not . isFreeTV) . Set.toList . fvs class FVS t where fvs :: t -> Set TVar diff --git a/src/Cryptol/TypeCheck/TypePat.hs b/src/Cryptol/TypeCheck/TypePat.hs index 54a0c466..6f875c2c 100644 --- a/src/Cryptol/TypeCheck/TypePat.hs +++ b/src/Cryptol/TypeCheck/TypePat.hs @@ -7,6 +7,7 @@ module Cryptol.TypeCheck.TypePat , aLenFromThen, aLenFromThenTo , aTVar + , aFreeTVar , aBit , aSeq , aWord @@ -112,6 +113,12 @@ aTVar = \a -> case tNoUser a of TVar x -> return x _ -> mzero +aFreeTVar :: Pat Type TVar +aFreeTVar t = + do v <- aTVar t + guard (isFreeTV v) + return v + aBit :: Pat Type () aBit = tc TCBit ar0 diff --git a/tests/issues/issue212.icry.fails b/tests/issues/issue212.icry.fails deleted file mode 100644 index 1cfc5f67..00000000 --- a/tests/issues/issue212.icry.fails +++ /dev/null @@ -1 +0,0 @@ -Known tc failure. See issue #212. diff --git a/tests/issues/issue212.icry.stdout b/tests/issues/issue212.icry.stdout index e69de29b..57a1d7a1 100644 --- a/tests/issues/issue212.icry.stdout +++ b/tests/issues/issue212.icry.stdout @@ -0,0 +1,3 @@ +Loading module Cryptol +Loading module Cryptol +Loading module Main