Skip to content
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
2 changes: 1 addition & 1 deletion examples/Constrained/Examples/CheatSheet.hs
Original file line number Diff line number Diff line change
Expand Up @@ -364,7 +364,7 @@ tightFit0 = constrained' $ \x y ->
-- TypeSpec (Cartesian TrueSpec (MemberSpec [0])) []
-- ---
-- assert $ Equal (Fst (ToGeneric v_3)) v_1
-- Env {unEnv = fromList [(v_0,EnvValue 0)]}
-- Env (fromList [(v_0,EnvValue 0)])
-- genFromSpecT ErrorSpec{} with explanation:
-- [1..-1]

Expand Down
10 changes: 0 additions & 10 deletions src/Constrained/Base.hs
Original file line number Diff line number Diff line change
Expand Up @@ -101,10 +101,6 @@ import Constrained.GenT
import Constrained.Generic
import Constrained.List hiding (toList)
import Constrained.TypeErrors
import Control.Monad.Writer (
Writer,
tell,
)
import Data.Foldable (
toList,
)
Expand Down Expand Up @@ -524,12 +520,6 @@ class
alternateShow :: TypeSpec a -> BinaryShow
alternateShow _ = NonBinary

monadConformsTo :: a -> TypeSpec a -> Writer [String] Bool
monadConformsTo x spec =
if conformsTo @a x spec
then pure True
else tell ["Fails by " ++ show spec] >> pure False

-- | For some types (especially finite ones) there may be much better ways to construct
-- a Specification than the default method of just adding a large 'bad' list to TypSpec. This
-- function allows each HasSpec instance to decide.
Expand Down
58 changes: 4 additions & 54 deletions src/Constrained/Conformance.hs
Original file line number Diff line number Diff line change
Expand Up @@ -14,7 +14,6 @@ module Constrained.Conformance (
conformsToSpec,
conformsToSpecE,
satisfies,
checkPred,
checkPredsE,
) where

Expand All @@ -34,59 +33,9 @@ import Data.Semigroup (sconcat)
import Prettyprinter hiding (cat)
import Test.QuickCheck (Property, Testable, property)

-- =========================================================================

-- | Does the Pred evaluate to true under the given Env.
-- If it doesn't, some explanation appears in the failure of the monad 'm'
checkPred :: forall m. MonadGenError m => Env -> Pred -> m Bool
checkPred env = \case
p@(ElemPred bool term xs) -> do
v <- runTerm env term
case (elem v xs, bool) of
(True, True) -> pure True
(True, False) -> fatalErrorNE ("notElemPred reduces to True" :| [show p])
(False, True) -> fatalErrorNE ("elemPred reduces to False" :| [show p])
(False, False) -> pure True
Monitor {} -> pure True
Subst x t p -> checkPred env $ substitutePred x t p
Assert t -> runTerm env t
GenHint {} -> pure True
p@(Reifies t' t f) -> do
val <- runTerm env t
val' <- runTerm env t'
explainNE (NE.fromList ["Reification:", " " ++ show p]) $ pure (f val == val')
ForAll t (x :-> p) -> do
set <- runTerm env t
and
<$> sequence
[ checkPred env' p
| v <- forAllToList set
, let env' = Env.extend x v env
]
Case t bs -> do
v <- runTerm env t
runCaseOn v (mapList thing bs) (\x val ps -> checkPred (Env.extend x val env) ps)
When bt p -> do
b <- runTerm env bt
if b then checkPred env p else pure True
TruePred -> pure True
FalsePred es -> explainNE es $ pure False
DependsOn {} -> pure True
And ps -> checkPreds env ps
Let t (x :-> p) -> do
val <- runTerm env t
checkPred (Env.extend x val env) p
Exists k (x :-> p) -> do
a <- runGE $ k (errorGE . explain "checkPred: Exists" . runTerm env)
checkPred (Env.extend x a env) p
Explain es p -> explainNE es $ checkPred env p

checkPreds :: (MonadGenError m, Traversable t) => Env -> t Pred -> m Bool
checkPreds env ps = and <$> mapM (checkPred env) ps

-- ==========================================================

-- | Like checkPred, But it takes [Pred] rather than a single Pred,
-- | Like checkPredE, But it takes [Pred] rather than a single Pred,
-- and it builds a much more involved explanation if it fails.
-- Does the Pred evaluate to True under the given Env?
-- If it doesn't, an involved explanation appears in the (Just message)
Expand All @@ -101,8 +50,9 @@ checkPredsE msgs env ps =
[] -> Nothing
(x : xs) -> Just (NE.nub (sconcat (x NE.:| xs)))

-- | An involved explanation for a single Pred
-- The most important explanations come when an assertion fails.
-- | Does the Pred evaluate to true under the given Env. An involved
-- explanation for a single Pred in case of failure and `Nothing` otherwise.
-- The most important explanations come when an assertion fails.
checkPredE :: Env -> NE.NonEmpty String -> Pred -> Maybe (NE.NonEmpty String)
checkPredE env msgs = \case
p@(ElemPred bool t xs) ->
Expand Down
2 changes: 1 addition & 1 deletion src/Constrained/Env.hs
Original file line number Diff line number Diff line change
Expand Up @@ -27,7 +27,7 @@ import Prettyprinter
import Prelude hiding (lookup)

-- | Typed environments for mapping @t`Var` a@ to @a@
newtype Env = Env {unEnv :: Map EnvKey EnvValue}
newtype Env = Env (Map EnvKey EnvValue)
deriving newtype (Semigroup, Monoid)
deriving stock (Show)

Expand Down
5 changes: 0 additions & 5 deletions src/Constrained/Syntax.hs
Original file line number Diff line number Diff line change
Expand Up @@ -51,7 +51,6 @@ module Constrained.Syntax (
computeDependencies,
solvableFrom,
respecting,
dependency,
applyNameHints,
envFromPred,
isLit,
Expand Down Expand Up @@ -834,10 +833,6 @@ applyNameHints spec = spec
-- | `Graph` specialized to dependencies for variables
type DependGraph = Graph.Graph Name

-- | A variable depends on a thing witha buch of other variables
dependency :: HasVariables t => Name -> t -> DependGraph
dependency x (freeVarSet -> xs) = Graph.dependency x xs

-- | Everything to the left depends on everything from the right, except themselves
irreflexiveDependencyOn ::
forall t t'. (HasVariables t, HasVariables t') => t -> t' -> DependGraph
Expand Down