input-output-hk / constrained-generators / 337

Committed 22 Oct 2025 11:42AM UTC coverage: 76.44% (-0.4%) from 76.798%

Build # 337

Build Type

push

github

Committed by

web-flow

Commit Message

Resurrect shrinking and improve it (#51)

Run Details

41 of 61 new or added lines in 9 files covered. (67.21%)

40 existing lines in 8 files now uncovered.

3861 of 5051 relevant lines covered (76.44%)

1.44 hits per line

Source File
Press 'n' to go to next uncovered line, 'b' for previous

81.4

/examples/Constrained/Examples/BinTree.hs

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

module Constrained.Examples.BinTree where

import Constrained.API
import GHC.Generics

------------------------------------------------------------------------
-- The types
------------------------------------------------------------------------

data BinTree a
  = BinTip
  | BinNode (BinTree a) a (BinTree a)
  deriving (Ord, Eq, Show, Generic)

------------------------------------------------------------------------
-- HasSpec for BinTree
------------------------------------------------------------------------

data BinTreeSpec a = BinTreeSpec (Maybe Integer) (Specification (BinTree a, a, BinTree a))
  deriving (Show)

instance Forallable (BinTree a) (BinTree a, a, BinTree a) where
  fromForAllSpec = typeSpec . BinTreeSpec Nothing
  forAllToList BinTip = []
  forAllToList (BinNode left a right) = (left, a, right) : forAllToList left ++ forAllToList right

instance HasSpec a => HasSpec (BinTree a) where
  type TypeSpec (BinTree a) = BinTreeSpec a

  emptySpec = BinTreeSpec Nothing mempty

  combineSpec (BinTreeSpec sz s) (BinTreeSpec sz' s') =
    typeSpec $ BinTreeSpec (unionWithMaybe min sz sz') (s <> s')

  conformsTo BinTip _ = True
  conformsTo (BinNode left a right) s@(BinTreeSpec _ es) =
    and
      [ (left, a, right) `conformsToSpec` es
      , left `conformsTo` s
      , right `conformsTo` s
      ]

  genFromTypeSpec (BinTreeSpec msz s)
    | Just sz <- msz, sz <= 0 = pure BinTip
    | otherwise = do
        let sz = maybe 20 id msz
            sz' = sz `div` 2
        oneofT
          [ do
              (left, a, right) <- genFromSpecT @(BinTree a, a, BinTree a) $
                constrained $ \ctx ->
                  [ match ctx $ \left _ right ->
                      [ forAll left (`satisfies` s)
                      , genHint sz' left
                      , forAll right (`satisfies` s)
                      , genHint sz' right
                      ]
                  , ctx `satisfies` s
                  ]
              pure $ BinNode left a right
          , pure BinTip
          ]

  shrinkWithTypeSpec _ BinTip = []
  shrinkWithTypeSpec s (BinNode left a right) =
    BinTip
      : left
      : right
      : (BinNode left a <$> shrinkWithTypeSpec s right)
      ++ ((\l -> BinNode l a right) <$> shrinkWithTypeSpec s left)

  fixupWithTypeSpec _ _ = Nothing

  cardinalTypeSpec _ = mempty

  toPreds t (BinTreeSpec msz s) =
    (forAll t $ \n -> n `satisfies` s)
      <> maybe mempty (flip genHint t) msz

instance HasSpec a => HasGenHint (BinTree a) where
  type Hint (BinTree a) = Integer
  giveHint h = typeSpec $ BinTreeSpec (Just h) mempty

1	{-# LANGUAGE DeriveGeneric #-}
2	{-# LANGUAGE FlexibleInstances #-}
3	{-# LANGUAGE FunctionalDependencies #-}
4	{-# LANGUAGE ScopedTypeVariables #-}
5	{-# LANGUAGE TypeApplications #-}
6	{-# LANGUAGE TypeFamilies #-}
7
8	module Constrained.Examples.BinTree where
9
10	import Constrained.API
11	import GHC.Generics
12
13	------------------------------------------------------------------------
14	-- The types
15	------------------------------------------------------------------------
16
17	data BinTree a
18	= BinTip
19	\| BinNode (BinTree a) a (BinTree a)
20	deriving (Ord, Eq, Show, Generic)	×
21
22	------------------------------------------------------------------------
23	-- HasSpec for BinTree
24	------------------------------------------------------------------------
25
26	data BinTreeSpec a = BinTreeSpec (Maybe Integer) (Specification (BinTree a, a, BinTree a))
27	deriving (Show)	×
28
29	instance Forallable (BinTree a) (BinTree a, a, BinTree a) where
30	fromForAllSpec = typeSpec . BinTreeSpec Nothing	2✔
31	forAllToList BinTip = []	2✔
32	forAllToList (BinNode left a right) = (left, a, right) : forAllToList left ++ forAllToList right	2✔
33
34	instance HasSpec a => HasSpec (BinTree a) where	×
35	type TypeSpec (BinTree a) = BinTreeSpec a
36
37	emptySpec = BinTreeSpec Nothing mempty	2✔
38
39	combineSpec (BinTreeSpec sz s) (BinTreeSpec sz' s') =	2✔
40	typeSpec $ BinTreeSpec (unionWithMaybe min sz sz') (s <> s')	1✔
41
42	conformsTo BinTip _ = True	2✔
43	conformsTo (BinNode left a right) s@(BinTreeSpec _ es) =
44	and	2✔
45	[ (left, a, right) `conformsToSpec` es	2✔
46	, left `conformsTo` s	2✔
47	, right `conformsTo` s	2✔
48	]
49
50	genFromTypeSpec (BinTreeSpec msz s)	2✔
51	\| Just sz <- msz, sz <= 0 = pure BinTip	2✔
52	\| otherwise = do	1✔
53	let sz = maybe 20 id msz	1✔
54	sz' = sz `div` 2	2✔
55	oneofT	2✔
56	[ do	2✔
57	(left, a, right) <- genFromSpecT @(BinTree a, a, BinTree a) $	2✔
58	constrained $ \ctx ->	2✔
59	[ match ctx $ \left _ right ->	2✔
60	[ forAll left (`satisfies` s)	2✔
61	, genHint sz' left	2✔
62	, forAll right (`satisfies` s)	2✔
63	, genHint sz' right	2✔
64	]
65	, ctx `satisfies` s	2✔
66	]
67	pure $ BinNode left a right	2✔
68	, pure BinTip	2✔
69	]
70
71	shrinkWithTypeSpec _ BinTip = []	2✔
72	shrinkWithTypeSpec s (BinNode left a right) =
73	BinTip	2✔
74	: left	2✔
75	: right	2✔
76	: (BinNode left a <$> shrinkWithTypeSpec s right)	1✔
77	++ ((\l -> BinNode l a right) <$> shrinkWithTypeSpec s left)	1✔
78
NEW 79	fixupWithTypeSpec _ _ = Nothing	×
80
UNCOV 81	cardinalTypeSpec _ = mempty	×
82
83	toPreds t (BinTreeSpec msz s) =	×
84	(forAll t $ \n -> n `satisfies` s)	×
85	<> maybe mempty (flip genHint t) msz	×
86
87	instance HasSpec a => HasGenHint (BinTree a) where
88	type Hint (BinTree a) = Integer
89	giveHint h = typeSpec $ BinTreeSpec (Just h) mempty	2✔

input-output-hk / constrained-generators / 337

Source File Press 'n' to go to next uncovered line, 'b' for previous

Source File
Press 'n' to go to next uncovered line, 'b' for previous