Merge branch 'master' into resurrect-shrinking

Author: MaximilianAlgehed

README.md

@@ -1,2 +1,5 @@
+
 # constrained-generators
+[![Coverage Status](https://coveralls.io/repos/github/input-output-hk/constrained-generators/badge.svg?branch=master)](https://coveralls.io/github/input-output-hk/constrained-generators?branch=master)
+
 Framework for generating constrained random data using a subset of first order logic

constrained-generators.cabal

@@ -79,7 +79,7 @@ library
     -Wunused-packages
 
   build-depends:
-    QuickCheck >=2.14 && <2.18,
+    QuickCheck >=2.15.0.1 && <2.18,
     base >=4.18 && <5,
     base-orphans,
     containers,
@@ -114,7 +114,7 @@ library examples
     -Wunused-packages
 
   build-depends:
-    QuickCheck >=2.14,
+    QuickCheck >=2.15.0.1,
     base >=4.18 && <5,
     constrained-generators,
     containers,
@@ -125,7 +125,9 @@ test-suite constrained-tests
   type: exitcode-stdio-1.0
   main-is: Tests.hs
   hs-source-dirs: test
-  other-modules: Constrained.Tests
+  other-modules:
+    Constrained.Tests
+    Constrained.GraphSpec
   default-language: Haskell2010
   ghc-options:
     -Wall
@@ -138,7 +140,7 @@ test-suite constrained-tests
     -rtsopts
 
   build-depends:
-    QuickCheck,
+    QuickCheck >= 2.15.0.1,
     base,
     constrained-generators,
     containers,

examples/Constrained/Examples/CheatSheet.hs

@@ -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]
 

src/Constrained/Base.hs

@@ -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,
  )
@@ -527,12 +523,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.

src/Constrained/Conformance.hs

@@ -14,7 +14,6 @@ module Constrained.Conformance (
   conformsToSpec,
   conformsToSpecE,
   satisfies,
-  checkPred,
   checkPredsE,
 ) where
 
@@ -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)
@@ -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) ->

src/Constrained/Env.hs

@@ -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)
 

src/Constrained/Graph.hs

@@ -5,7 +5,10 @@
 -- | This module provides a dependency graph implementation.
 module Constrained.Graph (
   Graph,
+  edges,
+  opEdges,
   opGraph,
+  mkGraph,
   nodes,
   deleteNode,
   subtractGraph,
@@ -22,20 +25,21 @@ module Constrained.Graph (
 
 import Control.Monad
 import Data.Foldable
-import Data.List (sortOn)
+import Data.List (sortOn, nub)
 import Data.Map (Map)
 import Data.Map qualified as Map
 import Data.Maybe
 import Data.Set (Set)
 import Data.Set qualified as Set
 import Prettyprinter
+import Test.QuickCheck
 
 -- | A graph with unlabeled edges for keeping track of dependencies
 data Graph node = Graph
   { edges :: !(Map node (Set node))
   , opEdges :: !(Map node (Set node))
   }
-  deriving (Show)
+  deriving (Show, Eq)
 
 instance Ord node => Semigroup (Graph node) where
   Graph e o <> Graph e' o' =
@@ -55,6 +59,37 @@ instance Pretty n => Pretty (Graph n) where
         | (n, ns) <- Map.toList (edges gr)
         ]
 
+-- | Construct a graph
+mkGraph :: Ord node => Map node (Set node) -> Graph node
+mkGraph e0 = Graph e $ Map.unionsWith (<>)
+                          [ Map.fromList $ (p, mempty) : [ (c, Set.singleton p)
+                                                         | c <- Set.toList cs
+                                                         ]
+                          | (p, cs) <- Map.toList e
+                          ]
+  where e = Map.unionWith (<>) e0 (Map.fromList [ (c, mempty) | (_, cs) <- Map.toList e0
+                                                              , c <- Set.toList cs
+                                                ])
+
+instance (Arbitrary node, Ord node) => Arbitrary (Graph node) where
+  arbitrary =
+    frequency [ (1, mkGraph <$> arbitrary)
+              , (3, do order <- nub <$> arbitrary
+                       mkGraph <$> buildGraph order
+                )
+              ]
+    where buildGraph [] = return mempty
+          buildGraph [n] = return (Map.singleton n mempty)
+          buildGraph (n:ns) = do
+            deps <- listOf (elements ns)
+            Map.insert n (Set.fromList deps) <$> buildGraph ns
+  shrink g =
+    [ mkGraph e'
+    | e <- shrink (edges g)
+    -- If we don't do this it's very easy to introduce a shrink-loop
+    , let e' = fmap (\ xs -> Set.filter (`Map.member` e) xs) e
+    ]
+
 -- | Get all the nodes of a graph
 nodes :: Graph node -> Set node
 nodes (Graph e _) = Map.keysSet e
@@ -102,11 +137,12 @@ irreflexiveDependencyOn xs ys =
 
 -- | Get all down-stream dependencies of a node
 transitiveDependencies :: Ord node => node -> Graph node -> Set node
-transitiveDependencies x (Graph e _) = go (Set.singleton x) x
+transitiveDependencies x (Graph e _) = go mempty (Set.toList $ fromMaybe mempty $ Map.lookup x e)
   where
-    go seen y = ys <> foldMap (go $ Set.insert y seen) (Set.difference ys seen)
-      where
-        ys = fromMaybe mempty (Map.lookup y e)
+    go deps [] = deps
+    go deps (y:ys)
+      | y `Set.member` deps = go deps ys
+      | otherwise = go (Set.insert y deps) (ys ++ Set.toList (fromMaybe mempty $ Map.lookup y e))
 
 -- | Take the transitive closure of the graph
 transitiveClosure :: Ord node => Graph node -> Graph node
@@ -133,10 +169,11 @@ topsort gr@(Graph e _) = go [] e
             else Left . concat . take 1 . sortOn length . filter (not . null) . map (findCycle gr) $ Map.keys e
 
 -- | Simple DFS cycle finding
--- TODO: tests for this, currently it can produce a stem with a cycle after it
 findCycle :: Ord node => Graph node -> node -> [node]
-findCycle (Graph e _) node = concat . take 1 $ go mempty node
+findCycle g@(Graph e _) node = concat . take 1 $ filter loopy $ go mempty node
   where
+    loopy [] = False
+    loopy c@(x:_) = dependsOn (last c) x g
     go seen n
       | n `Set.member` seen = [[]]
       | otherwise = do

src/Constrained/Syntax.hs

@@ -51,7 +51,6 @@ module Constrained.Syntax (
   computeDependencies,
   solvableFrom,
   respecting,
-  dependency,
   applyNameHints,
   envFromPred,
   isLit,
@@ -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

stack.yaml

@@ -2,3 +2,5 @@ snapshot: lts-22.44
 packages:
 - .
 system-ghc: true
+extra-deps:
+- QuickCheck-2.15.0.1

stack.yaml.lock

@@ -3,7 +3,14 @@
 # For more information, please see the documentation at:
 #   https://docs.haskellstack.org/en/stable/topics/lock_files
 
-packages: []
+packages:
+- completed:
+    hackage: QuickCheck-2.15.0.1@sha256:0cfd337bb9e6fbf09255bd24bb498a156f1d9bcd465396ac8657b25034b9ee31,9046
+    pantry-tree:
+      sha256: 27dddf0b64cc7d7e154326059c89b70da61530c25623af7ef576dd9db0c53821
+      size: 2437
+  original:
+    hackage: QuickCheck-2.15.0.1
 snapshots:
 - completed:
     sha256: 238fa745b64f91184f9aa518fe04bdde6552533d169b0da5256670df83a0f1a9