packages feed

constrained-generators (empty) → 0.2.0.0

raw patch · 43 files changed

+15035/−0 lines, 43 filesdep +QuickCheckdep +basedep +base-orphans

Dependencies added: QuickCheck, base, base-orphans, constrained-generators, containers, hspec, mtl, prettyprinter, random, template-haskell

Files

+ CHANGELOG.md view
@@ -0,0 +1,3 @@+# Version history for `constrained-generators`++## This package is not being released yet.
+ constrained-generators.cabal view
@@ -0,0 +1,153 @@+cabal-version: 3.0+name: constrained-generators+version: 0.2.0.0+license: Apache-2.0+maintainer: operations@iohk.io+author: IOHK+synopsis:+  Framework for generating constrained random data using+  a subset of first order logic++build-type: Simple+extra-source-files: CHANGELOG.md++source-repository head+  type: git+  location: https://github.com/input-output-hk/constrained-generators++flag dev+  description:       Enable development mode+  default:           False+  manual:            True++library+  exposed-modules:+    Constrained.API+    Constrained.API.Extend+    Constrained.AbstractSyntax+    Constrained.Base+    Constrained.Conformance+    Constrained.Core+    Constrained.DependencyInjection+    Constrained.Env+    Constrained.FunctionSymbol+    Constrained.GenT+    Constrained.Generation+    Constrained.Generic+    Constrained.Graph+    Constrained.List+    Constrained.NumOrd+    Constrained.PrettyUtils+    Constrained.Properties+    Constrained.Spec.List+    Constrained.Spec.Map+    Constrained.Spec.Set+    Constrained.Spec.SumProd+    Constrained.Spec.Tree+    Constrained.SumList+    Constrained.Syntax+    Constrained.Test+    Constrained.TheKnot+    Constrained.TypeErrors++  hs-source-dirs: src++  if flag(dev)+    exposed-modules:+      Constrained.Examples+      Constrained.Examples.Basic+      Constrained.Examples.BinTree+      Constrained.Examples.CheatSheet+      Constrained.Examples.Either+      Constrained.Examples.Fold+      Constrained.Examples.List+      Constrained.Examples.ManualExamples+      Constrained.Examples.Map+      Constrained.Examples.Set+      Constrained.Examples.Tree++    hs-source-dirs: examples++  default-language: Haskell2010+  ghc-options:+    -Wall+    -Wcompat+    -Wincomplete-record-updates+    -Wincomplete-uni-patterns+    -Wpartial-fields+    -Wredundant-constraints+    -Wunused-packages++  build-depends:+    QuickCheck >=2.15.0.1 && <2.18,+    base >=4.18 && <5,+    base-orphans,+    containers,+    mtl,+    prettyprinter,+    random,+    template-haskell,++library examples+  exposed-modules:+    Constrained.Examples+    Constrained.Examples.Basic+    Constrained.Examples.BinTree+    Constrained.Examples.CheatSheet+    Constrained.Examples.Either+    Constrained.Examples.Fold+    Constrained.Examples.List+    Constrained.Examples.ManualExamples+    Constrained.Examples.Map+    Constrained.Examples.Set+    Constrained.Examples.Tree++  hs-source-dirs: examples+  default-language: Haskell2010+  ghc-options:+    -Wall+    -Wcompat+    -Wincomplete-record-updates+    -Wincomplete-uni-patterns+    -Wpartial-fields+    -Wredundant-constraints+    -Wunused-packages++  build-depends:+    QuickCheck >=2.15.0.1,+    base >=4.18 && <5,+    constrained-generators,+    containers,+    prettyprinter,+    random,++test-suite constrained-tests+  type: exitcode-stdio-1.0+  main-is: Tests.hs+  hs-source-dirs: test+  other-modules:+    Constrained.Tests+    Constrained.GraphSpec+  default-language: Haskell2010+  ghc-options:+    -Wall+    -Wcompat+    -Wincomplete-record-updates+    -Wincomplete-uni-patterns+    -Wpartial-fields+    -Wredundant-constraints+    -Wunused-packages+    -rtsopts+    -threaded+    -with-rtsopts=-N++  build-depends:+    QuickCheck >= 2.15.0.1,+    base,+    constrained-generators,+    containers,+    hspec++  if !flag(dev)+    build-depends:+      constrained-generators:examples
+ examples/Constrained/Examples.hs view
@@ -0,0 +1,8 @@+module Constrained.Examples (module X) where++import Constrained.Examples.Basic as X+import Constrained.Examples.Either as X+import Constrained.Examples.List as X+import Constrained.Examples.Map as X+import Constrained.Examples.Set as X+import Constrained.Examples.Tree as X
+ examples/Constrained/Examples/Basic.hs view
@@ -0,0 +1,380 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}++module Constrained.Examples.Basic where++import Constrained.API+import GHC.Generics+import Test.QuickCheck qualified as QC++leqPair :: Specification (Int, Int)+leqPair = constrained $ \ [var| p |] ->+  match p $ \ [var| x |] [var| y |] ->+    x <=. y++simplePairSpec :: Specification (Int, Int)+simplePairSpec = constrained $ \(name "p" -> p) ->+  match p $ \(name "x" -> x) y ->+    [ assert $ x /=. 0+    , assert $ name "y" y /=. 0+    , -- You can use `monitor` to add QuickCheck property modifiers for+      -- monitoring distribution, like classify, label, and cover, to your+      -- specification+      monitor $ \eval ->+        QC.classify (eval y > 0) "positive y"+          . QC.classify (eval x > 0) "positive x"+    ]++sizeAddOrSub1 :: Specification Integer+sizeAddOrSub1 = constrained $ \s ->+  4 ==. s + 2++sizeAddOrSub2 :: Specification Integer+sizeAddOrSub2 = constrained $ \s ->+  4 ==. 2 + s++sizeAddOrSub3 :: Specification Integer+sizeAddOrSub3 = constrained $ \s ->+  4 ==. s - 2++-- | We expect a negative Integer, so ltSpec tests for that.+sizeAddOrSub4 :: Specification Integer+sizeAddOrSub4 = ltSpec 0 <> (constrained $ \s -> 4 ==. 2 - s)++sizeAddOrSub5 :: Specification Integer+sizeAddOrSub5 = constrained $ \s ->+  2 ==. 12 - s++listSubSize :: Specification [Int]+listSubSize = constrained $ \s ->+  2 ==. 12 - (sizeOf_ s)++orPair :: Specification (Int, Int)+orPair = constrained' $ \x y ->+  x <=. 5 ||. y <=. 5++trickyCompositional :: Specification (Int, Int)+trickyCompositional = constrained $ \p ->+  satisfies p simplePairSpec <> assert (fst_ p ==. 1000)++data Foo = Foo Int | Bar Int Int+  deriving (Show, Eq, Ord, Generic)++instance HasSimpleRep Foo++instance HasSpec Foo++fooSpec :: Specification Foo+fooSpec = constrained $ \foo ->+  (caseOn foo)+    ( branch $ \i ->+        [ assert $ 0 <=. i+        , monitor $ \_ -> QC.cover 40 True "Foo"+        ]+    )+    ( branch $ \i j ->+        [ assert $ i <=. j+        , monitor $ \_ -> QC.cover 40 True "Bar"+        ]+    )++intSpec :: Specification (Int, Int)+intSpec = constrained' $ \a b ->+  reify a (`mod` 10) $ \a' -> b ==. a'++mapElemKeySpec :: Specification Int+mapElemKeySpec = constrained $ \n ->+  letBind (pair_ n $ lit (False, 4)) $ \(p :: Term (Int, (Bool, Int))) ->+    letBind (snd_ (snd_ p)) $ \x ->+      [x <. 10, 0 <. x, not_ $ elem_ n $ lit []]++intRangeSpec :: Int -> Specification Int+intRangeSpec a = constrained $ \n -> n <. lit a++testRewriteSpec :: Specification ((Int, Int), (Int, Int))+testRewriteSpec = constrained' $ \x y ->+  x ==. fromGeneric_ (toGeneric_ y)++pairSingletonSpec :: Specification (Int, Int)+pairSingletonSpec = constrained $ \q ->+  forAll (singleton_ q) $ \p ->+    letBind (fst_ p) $ \x ->+      letBind (snd_ p) $ \y ->+        x <=. y++parallelLet :: Specification (Int, Int)+parallelLet = constrained $ \p ->+  [ letBind (fst_ p) $ \x -> 0 <. x+  , letBind (snd_ p) $ \x -> x <. 0+  ]++letExists :: Specification (Int, Int)+letExists = constrained $ \p ->+  [ letBind (fst_ p) $ \x -> 0 <. x+  , exists (\eval -> pure $ snd (eval p)) $+      \x ->+        [ x <. 0+        , snd_ p ==. x+        ]+  ]++letExistsLet :: Specification (Int, Int)+letExistsLet = constrained $ \p ->+  [ letBind (fst_ p) $ \x -> 0 <. x+  , exists (\eval -> pure $ snd (eval p)) $+      \x ->+        [ assert $ x <. 0+        , letBind (snd_ p) $ \y ->+            [ x ==. y+            , y <. -1+            ]+        ]+  ]++dependencyWeirdness :: Specification (Int, Int, Int)+dependencyWeirdness = constrained' $ \x y z ->+  reify (x + y) id $ \zv -> z ==. zv++parallelLetPair :: Specification (Int, Int)+parallelLetPair = constrained $ \p ->+  [ match p $ \x y ->+      [ assert $ x <=. y+      , y `dependsOn` x+      ]+  , match p $ \x y -> y <=. x+  ]++existsUnfree :: Specification Int+existsUnfree = constrained $ \_ -> exists (\_ -> pure 1) $ \y -> y `elem_` lit [1, 2 :: Int]++reifyYucky :: Specification (Int, Int, Int)+reifyYucky = constrained' $ \x y z ->+  [ reify x id $ \w ->+      [ y ==. w+      , z ==. w+      ]+  , z `dependsOn` y+  ]++basicSpec :: Specification Int+basicSpec = constrained $ \x ->+  exists (\eval -> pure $ eval x) $ \y ->+    satisfies x $ constrained $ \x' ->+      x' <=. 1 + y++canFollowLike :: Specification ((Int, Int), (Int, Int))+canFollowLike = constrained' $ \p q ->+  match p $ \ma mi ->+    match q $ \ma' mi' ->+      [ ifElse+          (ma' ==. ma)+          (mi' ==. mi + 1)+          (mi' ==. 0)+      , assert $ ma' <=. ma + 1+      , assert $ ma <=. ma'+      , ma' `dependsOn` ma+      ]++ifElseBackwards :: Specification (Int, Int)+ifElseBackwards = constrained' $ \p q ->+  [ ifElse+      (p ==. 1)+      (q <=. 0)+      (0 <. q)+  , p `dependsOn` q+  ]++assertReal :: Specification Int+assertReal = constrained $ \x ->+  [ assert $ x <=. 10+  , assertReified x (<= 10)+  ]++assertRealMultiple :: Specification (Int, Int)+assertRealMultiple = constrained' $ \x y ->+  [ assert $ x <=. 10+  , assert $ 11 <=. y+  , assertReified (pair_ x y) $ uncurry (/=)+  ]++reifiesMultiple :: Specification (Int, Int, Int)+reifiesMultiple = constrained' $ \x y z ->+  [ reifies (x + y) z id+  , x `dependsOn` y+  ]++data Three = One | Two | Three deriving (Ord, Eq, Show, Generic)++instance HasSimpleRep Three++instance HasSpec Three++trueSpecUniform :: Specification Three+trueSpecUniform = constrained $ \o -> monitor $ \eval -> QC.cover 30 True (show $ eval o)++three :: Specification Three+three = constrained $ \o ->+  [ caseOn+      o+      (branchW 1 $ \_ -> True)+      (branchW 1 $ \_ -> True)+      (branchW 1 $ \_ -> True)+  , monitor $ \eval -> QC.cover 30 True (show $ eval o)+  ]++three' :: Specification Three+three' = three <> three++threeSpecific :: Specification Three+threeSpecific = constrained $ \o ->+  [ caseOn+      o+      (branchW 1 $ \_ -> True)+      (branchW 1 $ \_ -> True)+      (branchW 2 $ \_ -> True)+  , monitor $ \eval ->+      QC.coverTable "TheValue" [("One", 22), ("Two", 22), ("Three", 47)]+        . QC.tabulate "TheValue" [show $ eval o]+  ]++threeSpecific' :: Specification Three+threeSpecific' = threeSpecific <> threeSpecific++posNegDistr :: Specification Int+posNegDistr =+  constrained $ \x ->+    [ monitor $ \eval -> QC.cover 60 (0 < eval x) "x positive"+    , x `satisfies` chooseSpec (1, constrained (<. 0)) (2, constrained (0 <.))+    ]++ifElseMany :: Specification (Bool, Int, Int)+ifElseMany = constrained' $ \b x y ->+  ifElse+    b+    [ x <. 0+    , y <. 10+    ]+    [ 0 <. x+    , 10 <. y+    ]++propBack :: Specification (Int, Int)+propBack = constrained' $ \x y ->+  [ x ==. y + 10+  , x <. 20+  , 8 <. y+  ]++propBack' :: Specification (Int, Int)+propBack' = constrained' $ \x y ->+  [ y ==. x - 10+  , 20 >. x+  , 8 >. y+  , y >. x - 20+  ]++propBack'' :: Specification (Int, Int)+propBack'' = constrained' $ \x y ->+  [ assert $ y + 10 ==. x+  , x `dependsOn` y+  , assert $ x <. 20+  , assert $ 8 <. y+  ]++chooseBackwards :: Specification (Int, [Int])+chooseBackwards = constrained $ \xy ->+  [ assert $ xy `elem_` lit [(1, [1001 .. 1005]), (2, [1006 .. 1010])]+  , match xy $ \_ ys ->+      forAll ys $ \y -> 0 <. y+  ]++chooseBackwards' :: Specification ([(Int, [Int])], (Int, [Int]))+chooseBackwards' = constrained' $ \ [var| xys |] [var| xy |] ->+  [ forAll' xys $ \_ [var| ys |] ->+      forAll ys $ \ [var| y |] -> 1000 <. y+  , assert $ 0 <. length_ xys+  , assert $ xy `elem_` xys+  , match xy $ \_ [var| ys |] ->+      forAll ys $ \ [var| y |] -> 0 <. y+  ]++whenTrueExists :: Specification Int+whenTrueExists = constrained $ \x ->+  whenTrue ([var| x |] ==. 0) $+    exists (\_ -> pure False) $ \b ->+      [ not_ [var| b |]+      , not_ (not_ b)+      ]++wtfSpec :: Specification ([Int], Maybe ((), [Int]))+wtfSpec = constrained' $ \ [var| options |] [var| mpair |] ->+  caseOn+    mpair+    (branch $ \_ -> False)+    ( branch $ \pair -> match pair $ \unit ints ->+        [ forAll ints $ \int -> reify options id $ \xs -> int `elem_` xs+        , assert $ unit ==. lit ()+        ]+    )++manyInconsistent :: Specification (Int, Int, Int, Int, Int, Int)+manyInconsistent = constrained' $ \ [var| a |] b c d e [var| f |] ->+  [ assert $ a <. 10+  , assert $ b >. a+  , assert $ c >. b+  , assert $ d >. c+  , assert $ e >. d+  , f `dependsOn` e+  , assert $ f >. 10+  , assert $ f <. a+  ]++manyInconsistentTrans :: Specification (Int, Int, Int, Int, Int, Int)+manyInconsistentTrans = constrained' $ \ [var| a |] [var| b |] c d e [var| f |] ->+  [ assert $ a <. 10+  , assert $ b <. a+  , assert $ c >. b+  , assert $ d >. c+  , assert $ e >. d+  , f `dependsOn` e+  , assert $ f >. 10+  , assert $ f <. b+  ]++complicatedEither :: Specification (Either Int Int, (Either Int Int, Int, Int))+complicatedEither = constrained' $ \ [var| i |] [var| t |] ->+  [ caseOn+      i+      (branch $ \a -> a `elem_` lit [1 .. 10])+      (branch $ \b -> b `elem_` lit [1 .. 10])+  , match t $ \ [var| k |] _ _ ->+      [ k ==. i+      , not_ $ k `elem_` lit [Left j | j <- [1 .. 9]]+      ]+  ]++pairCant :: Specification (Int, (Int, Int))+pairCant = constrained' $ \ [var| i |] [var| p |] ->+  [ assert $ i `elem_` lit [1 .. 10]+  , match p $ \ [var| k |] _ ->+      [ k ==. i+      , not_ $ k `elem_` lit [1 .. 9]+      ]+  ]++signumPositive :: Specification Rational+signumPositive = constrained $ \x -> signum (x * 30) >=. 1++twiceChooseSpec :: Specification Bool+twiceChooseSpec =+  chooseSpec (1, notEqualSpec True) (3, notEqualSpec False)+    <> chooseSpec (1, notEqualSpec True) (3, notEqualSpec False)++twiceChooseSpecInt :: Specification Int+twiceChooseSpecInt =+  chooseSpec (1, leqSpec 1) (3, gtSpec 1)+    <> chooseSpec (1, leqSpec 1) (3, gtSpec 1)
+ examples/Constrained/Examples/BinTree.hs view
@@ -0,0 +1,89 @@+{-# 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
+ examples/Constrained/Examples/CheatSheet.hs view
@@ -0,0 +1,693 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ViewPatterns #-}++module Constrained.Examples.CheatSheet where++import Constrained.API+import Data.Set (Set)+import Data.Set qualified as Set+import GHC.Generics+import Test.QuickCheck (Property, label)++-- The `constrained-generators` library allows us to write+-- constraints that give us random generators, shrinkers, and checkers+-- for data using a small embedded DSL, which defines a limited first order logic.+--+-- Every first order logic has 4 parts, as does our DSL.+-- 1) Terms :  e.g. x, 5, (member_ x set) (x ==. y)+--    Implemented as (Term a). We have variables like 'x', and constants like '5'.+--    'member_' and '==.' are function symbols, and build Terms from other terms.+--    By convention, a name followed by '_' or an infix operator followed by '.' are function symbols.+-- 2) Predicates (over terms). Predicates commonly used are+--        TruePred,+--        FalsePred (pure "explain"),+--        assert $ termWithTypeBool,+--    Some more unusual predicates are described below.+--    Implemented as type (Pred fn)+-- 3) Combinators (combining predicates). In general, And, Or, Not, Implies, True, False+--    But in the DSL, we are limited to+--      'And' using Block :: [Pred] -> Pred+--      'Not' using the function symbol not_ :: Term Bool -> Term Bool+--            for example:  assert $ not_ (x ==. y)+--      limited form of 'Or' using+--         chooseSpec :: (Int, Specification a)- > (Int, Specification a) -> Specification a+-- 4) Quantifiers (applying constraints to many things) :+--    forAll: Term t -> (Term a -> p) -> Pred fn+--    exists: ((forall b. Term b -> b) -> GE a) -> (Term a -> p) -> Pred fn+--    These are explained in detail below++-- In case you are interested, here is a list of supported function symbols (note the use of the '_' and '.' convention)+-- disjoint_,  dom_,  elem_,  length_,  member_,  not_,  rng_,  singleton_,  sizeOf_,  subset_,  sum_,  (/=.),+-- (<.),  (<=.),  (==.),  (>.),  (>=.), fromList_, null_, union_+-- You may also use the methods of Num (+) (-) (*), since there is a (Num (Term fn)) instance.++-- The first order logic DSL is used to build Specifications+-- A specifcation with type (Specification x) has two uses+-- 1) To generate a random values of type 'x', subject to the constraints in the specifications definition.+--    This is implemented by   genFromSpec :: Specification x -> Gen x (Gen is the QuickCheck Gen)+-- 2) To test if a value of type 'x' meets all of the constraints given in the specifications definition.+--     This is implemented by  conformsToSpec :: HasSpec a => a -> Specification a -> Bool++-- Lets get started. We can talk about numbers:++specInt :: Specification Int+specInt = constrained $ \i ->+  [ assert $ i <. 10+  , assert $ 0 <. i+  ]++-- What's going on here? In short:+--    `constrained :: (HasSpec a, IsPred p fn) => (Term a -> p) -> Specification a`+--    Introduces the variable `i` over which we can write constraints of type `p` over something+--    of type `a` to produce a `Specifcation a` using a list of+--    `assert :: Term Bool -> Pred  with `Term -level versions (function symbols) of familiar functions like+--    `(<.) :: OrdLike a => Term a -> Term a -> Term Bool`, `null_ :: Term [a] -> Term Bool`,+--    `rng_ :: (HasSpec k, HasSpec v, Ord k) => Term (Map k v) -> Term (Set k)` etc.+-- We get a generator from `genFromSpec :: Specification BaseFn a -> Gen a`:+-- λ> sample $ genFromSpec specInt+-- 1+-- 5+-- 6+-- 6+-- 8+-- 5+-- 3+-- 1+-- 1+-- 4+-- 8++-- Likewise, `shrinkWithSpec :: Specification BaseFn a -> a -> [a]` gives us+-- a shrinker:+-- λ> shrinkWithSpec specInt 10+-- [5,8,9]+-- λ> shrinkWithSpec specInt 5+-- [3,4]+-- λ> shrinkWithSpec specInt 3+-- [2]+-- λ> shrinkWithSpec specInt 1+-- []++-- And, `conformsToSpec :: a -> Specification BaseFn a -> Bool` gives us a checker:+-- λ> 10 `conformsToSpec` specInt+-- False+-- λ> 5 `conformsToSpec` specInt+-- True++-- Note that the type of `constrained` says the binding function of type `Term a -> p` doesn't+-- have to produce a `Pred  (which is the return type of `assert`), but can produce something of type `p`+-- that satisfies `IsPred p`. This basically just means something that can be readily turned into a+-- `Pred`, like e.g. `Pred`, `Bool`, `Term Bool`, `[p]` for `IsPred p`. Consequently, we could+-- have written `specInt` as:++specInt' :: Specification Int+specInt' = constrained $ \i ->+  [ i <. 10+  , 0 <. i+  ]++-- However, beware that when we start mixing `Term Bool` and `Pred` in these lists we can end+-- up getting some inscrutable error messages. So, if a call to `constrained` or another function that+-- has `IsPred` as a constraint, starts giving you strange error messages, double check that you have+-- used `assert` instead of raw `Term Bool` everywhere relevant.++-- We also have support for product types with functions like `fst_`, `snd_`, and `pair_`:++specProd :: Specification (Int, Int)+specProd = constrained $ \p ->+  [ fst_ p <. 10+  , snd_ p <. 100+  ]++-- However, product types can also be a bit finicky:++specProd0 :: Specification (Int, Int)+specProd0 = constrained $ \p -> assert $ fst_ p <. snd_ p++-- λ> sample $ genFromSpec specProd0++-- *** Exception: Simplifying:++--   constrained $ \ v0 -> assert $ Less (Fst (ToGeneric v0)) (Snd (ToGeneric v0))+-- optimisePred => assert $ Less (Fst (ToGeneric v0)) (Snd (ToGeneric v0))+-- assert $ Less (Fst (ToGeneric v0)) (Snd (ToGeneric v0))+-- Can't build a single-hole context for variable v0 in term Less (Fst (ToGeneric v0)) (Snd (ToGeneric v0))++-- This gives us the _fundamental restriction_:+--   A variable can not appear twice in the same constraint++-- The fundamental restriction is very important to make the system compositional+-- and modular. We will get back to talking about it in detail when we discuss how to+-- extend the system. However, for now suffice to say that it's a lot easier to solve+-- constraints that look like `2 * x <. 10` than it is to solve constraints+-- like `x <. 10 - x` (i.e. ones that mention the same variable more than once).++-- To overcome the fundamental restriction we can use `match`:+-- match ::+--   forall p a.+--   ( HasSpec a+--   , IsProductType a+--   , IsPred p fn+--   ) =>+--   Term a ->+--   FunTy (MapList (Term fn) (ProductAsList a)) p ->+--   Pred fn++specProd1 :: Specification (Int, Int)+specProd1 = constrained $ \p ->+  match p $ \x y ->+    x <. y++-- λ> sample $ genFromSpec specProd1+-- (-1,0)+-- (-4,-2)+-- (1,2)+-- (-2,1)+-- (7,8)+-- (-9,-4)+-- (-3,3)+-- (-1,12)+-- (-7,-6)+-- (-11,17)+-- (-53,-14)++-- Bringing variables into scope.+-- 'constrained' and 'match' are the ways we bring variable into scope, And they are often nested.+-- Consider writing a specification for pair of nested pairs: Specification ((Int,Int),(Int,Int))+-- How do we name the four different Int's ?++nested :: Specification ((Int, Int), (Int, Int))+nested =+  constrained $ \pp ->+    match pp $ \p1 p2 ->+      match p1 $ \x1 y1 ->+        match p2 $ \x2 y2 ->+          [x1 <=. y1, y1 <=. x2, x2 <=. y2]++-- ghci> sample $ genFromSpec nested+-- ((0,0),(0,0))+-- ((-9,-5),(-1,0))+-- ((-12,-10),(-5,-2))+-- ((-8,-4),(-3,-2))+-- ((-33,-18),(-15,-6))+-- ((-21,-12),(-1,3))+-- ((-36,-12),(1,9))+-- ((-64,-37),(-30,-4))+-- ((-53,-37),(-33,-10))+-- ((-49,-15),(-6,8))+-- ((-72,-34),(-26,-19))++-- A good rule of thumb when starting a new specification is to think about how you would+-- use 'constrained' and 'match' to bring variables, naming each of the parts that you want+-- to constrain, into scope.++-- Let's look under the hood of `match`, it introduces two auxilliary variables `v0` and `v1`+-- that circumvents the fundamental restriction by allowing us to generate values for `v1` and+-- `v0` before we generate a value for `v3`.++-- λ> simplifySpec specProd1+-- constrained $ \ v3 ->+--   let v1 = Fst (ToGeneric v3) in+--   let v0 = Snd (ToGeneric v3) in+--   assert $ Less v1 v0++-- This pattern of `constrained $ \ p -> match p $ \ x y -> ...` is very common+-- and has a shorthand in the form of `constrained'`:++specProd2 :: Specification (Int, Int)+specProd2 = constrained' $ \x y -> x <. y++-- How does generation actually work when we have multiple variables? For example,+-- it is not obvious (to the computer) what the best way of generating values satisfying+-- this constraint is:++solverOrder :: Specification (Int, Int)+solverOrder = constrained' $ \x y ->+  [ x <. y+  , y <. 10+  ]++-- For example, if you tried generating a value for `x` first chances are you'd generate+-- something larger than 10, which would make it impossible to generate a valid `y`. However,+-- when we run it we get reasonable values out:++-- sample $ genFromSpec solverOrder+-- (-1,0)+-- (0,2)+-- (-4,4)+-- (-7,-3)+-- (-7,3)+-- (-11,-3)+-- (4,8)+-- (-15,-14)+-- (-25,-10)+-- (-23,-6)+-- (-51,-20)++-- But how does the system know to generate `y` first? Unfortunately, there is nothing smart about+-- it. The system simply solves things "right to left" - variables that appear to the right in assertions+-- are solved before variables to the left. If one wants to understand the consequences of this and how it+-- affects the generator the `printPlan` function comes in handy:++-- λ> printPlan solverOrder+-- Simplified spec:+--   constrained $ \ v_3 ->+--     let v_1 = Fst (ToGeneric v_3) in+--     let v_0 = Snd (ToGeneric v_3) in+--     {assert $ Less v_0 10+--      assert $ Less v_1 v_0}+-- SolverPlan+--   Dependencies:+--     v_0 <- []+--     v_1 <- [v_0]+--     v_3 <- [v_0, v_1]+--   Linearization:+--     v_0 <- TypeSpec [..9] []+--     v_1 <- assert $ Less v_1 v_0+--     v_3 <-+--       assert $ Equal (Fst (ToGeneric v_3)) v_1+--       assert $ Equal (Snd (ToGeneric v_3)) v_0++-- There are three parts to the output:+--  - The "Simplified spec" is the input specification after it has gone through a number of optimization+--    and simplification passes to make it amenable to solving.+--  - The "Dependencies" tells us what variables depend on what other variables to be solved. In this case `v0` (y)+--    has no dependencies, `v1` (x) is solved after `v0` and `v3` (the actual pair we are generating) is solved+--    last.+--  - Finaly, the "Linearization" tells us _what constraints define what varible_. This is an important aspect of the+--    system: variables are only constrained by assertions that talk about the variable itself and variables that+--    are solved before it. In this case `v0` (y) is defined by `y <. 10`, `v1` (x) by `x <. y` and `v3` by the equalities+--    in the `Let` constructs.+--+-- As the generator executes this plan it will pick the variables in the order in which they appear in the linearization+-- and generate the corresponding values. For example, an execution trace could go like the following pseudo-trace (the details of how+-- this works are slightly more involved but the basic order of operations is accurate):+--  v0 <- pick from (-∞, 10)+--  v0 = 4+--  v1 <- pick from [4/v0](-∞, v0)+--        -> pick from (-∞, 4)+--  v1 = 2+--  v3 <- pick from [4/v0, 2/v1]{fst == v1, snd == v0}+--        -> pick from {fst == 2, snd == 4}+--  v3 = (2, 4)++-- As an aside, the frustrating thing about making sense of the output of `printPlan` is the `v0`, `v1`, etc. naming.+-- To introduce proper names we can use the `var` quasi-quoter:++solverOrder' :: Specification (Int, Int)+solverOrder' = constrained' $ \ [var|x|] [var|y|] ->+  [ x <. y+  , y <. 10+  ]++-- Now we get more reasonable looking oputput from `printPlan`:+-- λ> printPlan solverOrder'+-- Simplified spec:+--   constrained $ \ v_3 ->+--     let x_1 = Fst (ToGeneric v_3) in+--     let y_0 = Snd (ToGeneric v_3) in+--     {assert $ Less y_0 10+--      assert $ Less x_1 y_0}+-- SolverPlan+--   Dependencies:+--     y_0 <- []+--     x_1 <- [y_0]+--     v_3 <- [y_0, x_1]+--   Linearization:+--     y_0 <- TypeSpec [..9] []+--     x_1 <- assert $ Less x_1 y_0+--     v_3 <-+--       assert $ Equal (Fst (ToGeneric v_3)) x_1+--       assert $ Equal (Snd (ToGeneric v_3)) y_0++-- A consequence of the default dependency order approach is that it's possible+-- to write constraints that put you in a tricky situation:++tightFit0 :: Specification (Int, Int)+tightFit0 = constrained' $ \x y ->+  [ 0 <. x+  , x <. y+  ]++-- λ> sample $ genFromSpec tightFit0++-- *** Exception: genFromPreds:++--   let v_1 = Fst (ToGeneric v_3) in+--   let v_0 = Snd (ToGeneric v_3) in+--   {assert $ Less v_1 v_0+--    assert $ Less 0 v_1}+-- SolverPlan+--   Dependencies:+--     v_0 <- []+--     v_1 <- [v_0]+--     v_3 <- [v_0, v_1]+--   Linearization:+--     v_0 <-+--     v_1 <-+--       TypeSpec [1..] []+--       ---+--       assert $ Less v_1 v_0+--     v_3 <-+--       assert $ Equal (Fst (ToGeneric v_3)) v_1+--       assert $ Equal (Snd (ToGeneric v_3)) v_0+-- Stepping the plan:+--   SolverPlan+--     Dependencies:+--       v_1 <- []+--       v_3 <- [v_1]+--     Linearization:+--       v_1 <- ErrorSpec [1..-1]+--       v_3 <-+--         TypeSpec (Cartesian TrueSpec (MemberSpec [0])) []+--         ---+--         assert $ Equal (Fst (ToGeneric v_3)) v_1+--   Env (fromList [(v_0,EnvValue 0)])+-- genFromSpecT ErrorSpec{} with explanation:+-- [1..-1]++-- The generator fails with output similar to what we saw above and a message telling us we tried to generate+-- a value from the (empty) interval [1..-1]. Inspecting the output above carefully we see that the graph and the+-- linearization tell us that `v0` (y) is completely unconstrained. The consequence of this is that when we get to the+-- point of trying to generate `v1` (x) we've already picked a value (-1) for `v0` that makes it impossible to satisfy+-- the constraints on `v1` and its constraints have specialized away to an error spec.++-- The solution to this issue is to introduce `dependsOn`, which lets us override the dependency order in constraints:++tightFit1 :: Specification (Int, Int)+tightFit1 = constrained' $ \x y ->+  [ assert $ 0 <. x+  , assert $ x <. y+  , y `dependsOn` x+  ]++-- λ> printPlan tightFit1+-- Simplified spec:+--   constrained $ \ v_3 ->+--     let v_1 = Fst (ToGeneric v_3) in+--     let v_0 = Snd (ToGeneric v_3) in+--     {v_0 <- v_1+--      assert $ Less v_1 v_0+--      assert $ Less 0 v_1}+-- SolverPlan+--   Dependencies:+--     v_0 <- [v_1]+--     v_1 <- []+--     v_3 <- [v_0, v_1]+--   Linearization:+--     v_1 <- TypeSpec [1..] []+--     v_0 <- assert $ Less v_1 v_0+--     v_3 <-+--       assert $ Equal (Fst (ToGeneric v_3)) v_1+--       assert $ Equal (Snd (ToGeneric v_3)) v_0++-- This gives us more balanced constraints that solve `v1` before they solve `v0`!+-- Consequently, this constraint generates reasonable values:++-- λ> sample $ genFromSpec tightFit1+-- (1,2)+-- (2,3)+-- (9,15)+-- (4,10)+-- (12,27)+-- (15,21)+-- (10,30)+-- (23,51)+-- (7,34)+-- (21,46)+-- (28,49)++-- We also support booleans with `ifElse :: Term Bool -> Pred -> Pred -> Pred`+-- where the branches of the `ifElse` depend on the scrutinee.++booleanExample :: Specification (Int, Int)+booleanExample = constrained' $ \x y ->+  ifElse+    (0 <. x)+    (y ==. 10)+    (y ==. 20)++-- sample $ genFromSpec booleanExample+-- (0,20)+-- (2,10)+-- (4,10)+-- (1,10)+-- (-2,20)+-- (3,10)+-- (7,10)+-- (-8,20)+-- (-5,20)+-- (-2,20)+-- (-19,20)++-- We can combine `ifElse` and `dependsOn` to write a nice example saying+-- that a PVP version pair `q` can follow a pair `p`.++-- Because we will need to re-use this multiple times we start by defining a valid+-- PVP constraint as any constraint that has non-negative major and minor version number.+validPVPVersion :: Specification (Int, Int)+validPVPVersion = constrained' $ \ma mi -> [0 <=. ma, 0 <=. mi]++-- Now we are ready to define the constraints for valid PVP succession. Note here that+-- we use the `satisfies :: Term a -> Specification BaseFn a -> Pred` combinator+-- to re-use the `validPVPVersion` constraint.++canFollowExample :: Specification ((Int, Int), (Int, Int))+canFollowExample = constrained' $ \p q ->+  [ match p $ \ma mi ->+      match q $ \ma' mi' ->+        [ ifElse+            (ma' ==. ma)+            (mi' ==. mi + 1)+            (mi' ==. 0)+        , -- Note how these two constraints imply a cycle:+          --  ma' <- ma <- ma'+          assert $ ma' <=. ma + 1+        , assert $ ma <=. ma'+        , -- We break that cycle by specifying a concrete order+          -- Another option would be to define `>=.` but that doesn't+          -- exist right now and we will get to extending the language+          -- later on!+          ma' `dependsOn` ma+        ]+  , p `satisfies` validPVPVersion+  , q `satisfies` validPVPVersion+  ]++-- λ> sample $ genFromSpec canFollowExample+-- ((0,0),(0,1))+-- ((1,0),(1,1))+-- ((4,2),(4,3))+-- ((12,1),(12,2))+-- ((11,16),(11,17))+-- ((20,7),(21,0))+-- ((18,12),(18,13))+-- ((6,18),(7,0))+-- ((29,24),(30,0))+-- ((23,21),(23,22))+-- ((26,14),(26,15))++-- We have native support for sum types using `caseOn` and `branch`:++sumExample :: Specification (Either Int Bool)+sumExample = constrained $ \e ->+  (caseOn e)+    (branch $ \i -> i <. 0)+    (branch $ \b -> not_ b)++-- Furthermore, cases are solved _inside-out_ by default:++sumExampleTwo :: Specification (Int, Either Int Bool)+sumExampleTwo = constrained' $ \i e ->+  [ caseOn+      e+      (branch $ \j -> i <. j)+      (branch $ \b -> not_ b)+  , assert $ 20 <. i+  ]++-- We can work with sets with operations like `subset_`, `union_` (or `<>`), `disjoint_`, and `singleton_`:++setExample :: Specification (Set Int, Set Int, Set Int)+setExample = constrained' $ \xs ys zs ->+  [ xs `subset_` (ys <> zs)+  , sizeOf_ ys <=. 10+  ]++-- We can also quantify over things like sets with `forAll`:++forAllFollow0 :: Specification ((Int, Int), Set (Int, Int))+forAllFollow0 = constrained' $ \p qs ->+  [ forAll qs $ \q -> pair_ p q `satisfies` canFollowExample+  ]++-- λ> sample $ genFromSpec forAllFollow0+-- ((0,0),fromList [])+-- ((1,-1),fromList [])+-- ((2,3),fromList [(2,4),(3,0)])+-- ((4,2),fromList [(4,3),(5,0)])+-- ((-2,6),fromList [])+-- ((10,-9),fromList [])+-- ((-1,-8),fromList [])+-- ((-8,-1),fromList [])+-- ((1,4),fromList [(1,5),(2,0)])+-- ((-17,-5),fromList [])+-- ((-2,12),fromList [])++-- How come the sets are so small? Note that we sometimes still generate+-- negative values for the components of `p`. But we said in the `canFollowExample`+-- that `p` needs to be a valid PVP version. However, the constraints only say that+-- it needs to be a valid PVP version _if `qs` is non-empty!_. This is easily fixed+-- by specifying that `p` is _always_ a valid PVP version!++forAllFollow :: Specification ((Int, Int), Set (Int, Int))+forAllFollow = constrained' $ \p qs ->+  [ forAll qs $ \q -> pair_ p q `satisfies` canFollowExample+  , p `satisfies` validPVPVersion+  ]++-- λ> sample $ genFromSpec forAllFollow+-- ((0,0),fromList [])+-- ((0,1),fromList [])+-- ((1,5),fromList [(1,6),(2,0)])+-- ((8,10),fromList [(8,11)])+-- ((12,15),fromList [(12,16)])+-- ((6,16),fromList [])+-- ((4,11),fromList [(4,12)])+-- ((10,21),fromList [(10,22),(11,0)])+-- ((28,2),fromList [(28,3),(29,0)])+-- ((20,3),fromList [(20,4),(21,0)])+-- ((16,29),fromList [(16,30),(17,0)])++-- We also have existential quantification in the language. The first argument to+-- `exists` tells you how to reconstruct the value from known values.++existentials :: Specification (Set Int, Set Int)+existentials = constrained' $ \xs ys ->+  exists (\eval -> pure $ Set.intersection (eval xs) (eval ys)) $ \zs ->+    [ assert $ not_ $ null_ zs+    , assert $ zs `subset_` xs+    , assert $ zs `subset_` ys+    , xs `dependsOn` zs+    , ys `dependsOn` zs+    ]++-- You can work with your own types relatively easily. If they are `Generic`+-- you even get all the machinery of sum and product types for free!++data FooBarBaz = Foo Int Int | Bar Bool | Baz deriving (Eq, Show, Generic)++-- All you need to do is introduce instances for `HasSimpleRep` and `HasSpec`:++instance HasSimpleRep FooBarBaz++instance HasSpec FooBarBaz++fooBarBaz :: Specification FooBarBaz+fooBarBaz = constrained $ \fbb ->+  caseOn+    fbb+    (branch $ \i j -> i <. j)+    (branch $ \b -> not_ b)+    (branch $ \_ -> False)++-- λ> sample $ genFromSpec fooBarBaz+-- Foo (-1) 0+-- Bar False+-- Foo (-9) (-3)+-- Bar False+-- Foo 1 3+-- Foo (-20) (-8)+-- Foo (-35) (-11)+-- Bar False+-- Foo (-8) 5+-- Bar False+-- Foo (-4) 7++-- Some functions don't exist on the term level. In this case we can use+-- `reifies :: (HasSpec a, HasSpec b) => Term b -> Term a -> (a -> b) -> Pred`+-- to introduce a one-way evaluation of a Haskell function:++reifyExample :: Specification (Int, Int)+reifyExample = constrained' $ \ [var|a|] [var|b|] ->+  reifies b a $ \x -> mod x 10++-- Here we introduce two variables `a` and `b` without any immediate dependency and we say that+-- `b` reifies `a` via the haskell function `\x -> mod x 10`. The best way to understand what this+-- cryptic code means is to imagine there was a `mod_` function, in that case this code would be equivalent+-- to:++reifyExample' :: Specification (Int, Int)+reifyExample' = constrained' $ \a b ->+  [ assert $ b ==. mod_ a 10+  , b `dependsOn` a+  ]+  where+    mod_ :: Term Int -> Term Int -> Term Int+    mod_ = error "This doesn't exist"++-- When we look at the plan we get from `reifyExample` we get what we'd expect:+-- λ> printPlan reifyExample+-- Simplified spec:+--   constrained $ \ v_3 ->+--     let v_1 = Fst (ToGeneric v_3) in+--     let v_0 = Snd (ToGeneric v_3) in reifies v_0 v_1+-- SolverPlan+--   Dependencies:+--     v_0 <- [v_1]+--     v_1 <- []+--     v_3 <- [v_0, v_1]+--   Linearization:+--     v_1 <-+--     v_0 <- reifies v_0 v_1+--     v_3 <-+--       assert $ Equal (Fst (ToGeneric v_3)) v_1+--       assert $ Equal (Snd (ToGeneric v_3)) v_0++-- Sometimes it is convenient to introduce an auxilliary variable to represent the result of applying the+-- haskell-level function to the term, for this purpose we have+-- `reify :: (HasSpec a, HasSpec b, IsPred p fn) => Term a -> (a -> b) -> (Term b -> p) -> Pred`.++-- We have tools to control the distribution of test cases and monitor those distributions. Using `branchW` we can+-- attach weights to branches in a `caseOn` and using `monitor :: ((forall. Term a -> a) -> Property -> Property) -> Pred`+-- we can use the normal QuickCheck functions for monitoring distributions of generators to see the effects of this.++monitorExample :: Specification (Either Int Int)+monitorExample = constrained $ \e ->+  caseOn+    e+    (branchW 1 $ \_ -> monitor $ \_ -> label "Left")+    (branchW 2 $ \_ -> monitor $ \_ -> label "Right")++-- The `forAllSpec :: (Testable p, HasSpec a) => Specification a -> (a -> p) -> Property` we+-- automatically get the monitoring from the spec in our property:++prop_monitoring :: Property+prop_monitoring = forAllSpec monitorExample $ \_ -> True++-- λ> quickCheck $ prop_monitoring+-- +++ OK, passed 100 tests:+-- 64% Right+-- 36% Left++-- Other tools for controlling distributions of specifications are available too, for example+-- `chooseSpec :: HasSpec a => (Int, Specification a) -> (Int, Specification a) -> Specification a`,+-- the definition of which constitutes a useful object of study to better understand how to use the compositional+-- nature of the system to build powerful features.++chooseSpecExample :: Specification Int+chooseSpecExample =+  chooseSpec+    (1, constrained $ \i -> i <. 0)+    (2, constrained $ \i -> 0 <. i)++prop_chooseSpec :: Property+prop_chooseSpec = forAllSpec chooseSpecExample $ \i ->+  label (show $ signum i) True++-- λ> quickCheck prop_chooseSpec+-- +++ OK, passed 100 tests:+-- 67% 1+-- 33% -1
+ examples/Constrained/Examples/Either.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE ImportQualifiedPost #-}++module Constrained.Examples.Either where++import Constrained.API+import Data.Set qualified as Set++eitherSpec :: Specification (Either Int Int)+eitherSpec = constrained $ \e ->+  (caseOn e)+    (branch $ \i -> i <=. 0)+    (branch $ \i -> 0 <=. i)++foldTrueCases :: Specification (Either Int Int)+foldTrueCases = constrained $ \x ->+  [ assert $ not_ $ member_ x (lit (Set.fromList [Left 10]))+  , letBind (pair_ x (lit (0 :: Int))) $ \p ->+      caseOn+        (fst_ p)+        (branch $ \_ -> True)+        (branch $ \_ -> True)+  ]
+ examples/Constrained/Examples/Fold.hs view
@@ -0,0 +1,188 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ViewPatterns #-}++module Constrained.Examples.Fold where++import Constrained.API+import Constrained.Examples.List (Numbery)+import Constrained.GenT (catMessages, genFromGenT, inspect)+import Constrained.SumList+import Data.String (fromString)+import Prettyprinter (fillSep, punctuate, space)+import System.Random (Random)+import Test.QuickCheck hiding (forAll, total)++-- ========================================================+-- Specifications we use in the examples and in the tests++oddSpec :: Specification Int+oddSpec = explainSpec ["odd via (y+y+1)"] $+  constrained $ \ [var|oddx|] ->+    exists+      (\eval -> pure (div (eval oddx - 1) 2))+      (\ [var|y|] -> [assert $ oddx ==. y + y + 1])++evenSpec ::+  forall n.+  (NumLike n, Integral n) =>+  Specification n+evenSpec = explainSpec ["even via (x+x)"] $+  constrained $ \ [var|evenx|] ->+    exists+      (\eval -> pure (div (eval evenx) 2))+      (\ [var|somey|] -> [assert $ evenx ==. somey + somey])++composeEvenSpec :: Specification Int+composeEvenSpec = constrained $ \x -> [satisfies x evenSpec, assert $ x >. 10]++composeOddSpec :: Specification Int+composeOddSpec = constrained $ \x -> [satisfies x oddSpec, assert $ x >. 10]++sum3WithLength :: Integer -> Specification ([Int], Int, Int, Int)+sum3WithLength n =+  constrained $ \ [var|quad|] ->+    match quad $ \ [var|l|] [var|n1|] [var|n2|] [var|n3|] ->+      [ assert $ sizeOf_ l ==. lit n+      , forAll l $ \ [var|item|] -> item >=. lit 0+      , assert $ sum_ l ==. n1 + n2 + n3+      , assert $ n1 + n2 + n3 >=. lit (fromInteger n)+      ]++sum3 :: Specification [Int]+sum3 = constrained $ \ [var|xs|] -> [sum_ xs ==. lit 6 + lit 9 + lit 5, sizeOf_ xs ==. 5]++listSumPair :: Numbery a => Specification [(a, Int)]+listSumPair = constrained $ \xs ->+  [ assert $ foldMap_ fst_ xs ==. 100+  , forAll' xs $ \x y -> [20 <. x, x <. 30, y <. 100]+  ]++listSumForall :: Numbery a => Specification [a]+listSumForall = constrained $ \xs ->+  [ forAll xs $ \x -> 1 <. x+  , assert $ sum_ xs ==. 20+  ]++-- | Complicated, because if 'a' is too large, the spec is unsatisfiable.+listSumComplex :: Numbery a => a -> Specification [a]+listSumComplex a = constrained $ \xs ->+  [ forAll xs $ \x -> 1 <. x+  , assert $ sum_ xs ==. 20+  , assert $ sizeOf_ xs >=. lit 4+  , assert $ sizeOf_ xs <=. lit 6+  , assert $ elem_ (lit a) xs+  ]++-- ==============================================================+-- Tools for building properties that have good counterexamples++data Outcome = Succeed | Fail++propYes :: String -> Solution t -> Property+propYes _ (Yes _) = property True+propYes msg (No xs) = property (counterexample (unlines (msg : xs)) False)++propNo :: Show t => String -> Solution t -> Property+propNo msg (Yes (x :| _)) = property (counterexample (unlines [msg, "Expected to fail, but succeeds with", show x]) False)+propNo _ (No _) = property True++parensList :: [String] -> String+parensList xs = show (fillSep $ punctuate space $ map fromString xs)++-- ===============================================================+-- Functions for building properties about the functions defined+-- in module Constrained.SumList(logish,pickAll)++logishProp :: Gen Property+logishProp = do+  n <- choose (-17, 17 :: Int) -- Any bigger or smaller is out of the range of Int+  i <- choose (logRange n)+  pure (logish i === n)++picktest :: (Ord a, Num a) => a -> a -> (a -> Bool) -> a -> Int -> [a] -> Bool+picktest smallest largest p total count ans =+  smallest <= largest+    && total == sum ans+    && count == length ans+    && all p ans++-- | generate a different category of test, each time.+pickProp :: Gen Property+pickProp = do+  smallest <- elements [-4, 1 :: Int]+  count <- choose (2, 4)+  total <- (+ 20) <$> choose (smallest, 5477)+  let largest = total + 10+  (nam, p) <-+    elements+      ( concat+          [ if even total then [("even", even)] else []+          , if odd total && odd count then [("odd", odd)] else []+          , [("(>0)", (> 0)), ("true", const True)]+          ]+      )+  (_cost, ans) <- pickAll smallest largest (nam, p) total count (Cost 0)+  case ans of+    Yes result -> pure $ property $ all (picktest smallest largest p total count) result+    No msgs -> pure $ counterexample ("predicate " ++ nam ++ "\n" ++ unlines msgs) False++-- | Build properties about calls to 'genListWithSize'+testFoldSpec ::+  forall a.+  Foldy a =>+  Specification Integer ->+  Specification a ->+  Specification a ->+  Outcome ->+  Gen Property+testFoldSpec size elemSpec total outcome = do+  ans <- genFromGenT $ inspect $ genSizedList size elemSpec total+  let callString = parensList ["GenListWithSize", show size, fst (predSpecPair elemSpec), show total]+      fails xs = unlines [callString, "Should fail, but it succeeds with", show xs]+      succeeds xs =+        unlines [callString, "Should succeed, but it fails with", catMessages xs]+  case (ans, outcome) of+    (Result _, Succeed) -> pure $ property True+    (Result xs, Fail) -> pure $ counterexample (fails xs) False+    (FatalError _, Fail) -> pure $ property True+    (FatalError xs, Succeed) -> pure $ counterexample (succeeds xs) False+    (GenError _, Fail) -> pure $ property True+    (GenError xs, Succeed) -> pure $ counterexample (succeeds xs) False++-- | Generate a property from a call to 'pickAll'. We can test for success or failure using 'outcome'+sumProp ::+  (Integral t, Random t, HasSpec t) =>+  t ->+  t ->+  Specification t ->+  t ->+  Int ->+  Outcome ->+  Gen Property+sumProp smallest largest spec total count outcome = sumProp2 smallest largest (predSpecPair spec) total count outcome++-- | Like SumProp, but instead of using a (Specification fn n) for the element predicate+--   It uses an explicit pair of a (String, n -> Bool). This means we can test things+--   using any Haskell function.+sumProp2 ::+  (Show t, Integral t, Random t) =>+  t ->+  t ->+  (String, t -> Bool) ->+  t ->+  Int ->+  Outcome ->+  Gen Property+sumProp2 smallest largest spec total count outcome = do+  (_, ans) <- pickAll smallest largest spec total count (Cost 0)+  let callString = parensList ["pickAll", show smallest, (fst spec), show total, show count]+      message Succeed = "\nShould succeed, but it fails with"+      message Fail = "\nShould fail, but it succeeds with " ++ show ans+  pure+    ( case outcome of+        Succeed -> propYes (callString ++ message outcome) ans+        Fail -> propNo callString ans+    )
+ examples/Constrained/Examples/List.hs view
@@ -0,0 +1,181 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ViewPatterns #-}++module Constrained.Examples.List where++import Constrained.API+import Constrained.Examples.Basic+import Data.Word++type Numbery a =+  ( Foldy a+  , OrdLike a+  , NumLike a+  , Ord a+  , Enum a+  )++listSum :: Numbery a => Specification [a]+listSum = constrained $ \as ->+  10 <=. sum_ as++listSumForall :: Numbery a => Specification [a]+listSumForall = constrained $ \xs ->+  [ forAll xs $ \x -> 1 <. x+  , assert $ sum_ xs ==. 20+  ]++listSumRange :: Numbery a => Specification [a]+listSumRange = constrained $ \xs ->+  let n = sum_ xs+   in [ forAll xs $ \x -> 1 <. x+      , assert $ n <. 20+      , assert $ 10 <. n+      ]++listSumRangeUpper :: Numbery a => Specification [a]+listSumRangeUpper = constrained $ \xs ->+  let n = sum_ xs+   in -- All it takes is one big negative number,+      -- then we can't get enough small ones to exceed 10+      -- in the number of tries allowed.+      -- So we make x relatively large ( <. 12), If its is+      -- relatively small ( <. 5), we can get unlucky.+      [ forAll xs $ \x -> [x <. 12]+      , assert $ n <. 20+      , assert $ 10 <. n+      ]++listSumRangeRange :: Numbery a => Specification [a]+listSumRangeRange = constrained $ \xs ->+  let n = sum_ xs+   in [ forAll xs $ \x -> [1 <. x, x <. 5]+      , assert $ n <. 20+      , assert $ 10 <. n+      ]++listSumElemRange :: Numbery a => Specification [a]+listSumElemRange = constrained $ \xs ->+  let n = sum_ xs+   in [ forAll xs $ \x -> [1 <. x, x <. 5]+      , assert $ n `elem_` lit [10, 12 .. 20]+      ]++listSumPair :: Numbery a => Specification [(a, Int)]+listSumPair = constrained $ \xs ->+  [ assert $ foldMap_ fst_ xs ==. 100+  , forAll' xs $ \x y -> [20 <. x, x <. 30, y <. 100]+  ]++listEmpty :: Specification [Int]+listEmpty = constrained $ \xs ->+  [ forAll xs $ \_ -> False+  , assert $ length_ xs <=. 10+  ]++pairListError :: Specification [(Int, Int)]+pairListError = constrained $ \ps ->+  [ assert $ length_ ps <=. 10+  , forAll' ps $ \a b ->+      [ a `elem_` lit [1 .. 8]+      , a ==. 9+      , b ==. a+      ]+  ]++listMustSizeIssue :: Specification [Int]+listMustSizeIssue = constrained $ \xs ->+  [ 1 `elem_` xs+  , length_ xs ==. 1+  ]++-- FIX ME, generates but the unsafeExists means it is unsound+sumListBad :: Specification [Word64]+sumListBad = constrained $ \xs ->+  [ forAll xs $ \x -> unsafeExists $ \y -> y ==. x+  , assert $ sum_ xs ==. lit 10+  ]++listExistsUnfree :: Specification [Int]+listExistsUnfree = constrained $ \xs ->+  [ forAll xs $ \x -> x `satisfies` existsUnfree+  , assert $ sizeOf_ xs ==. 3+  ]++listSumShort :: Specification [Int]+listSumShort = constrained $ \ [var| xs |] ->+  [ assert $ sizeOf_ xs <=. 4+  , assert $ sum_ xs <=. 100000+  , forAll xs $ \ [var| x |] ->+      [ exists (const $ pure True) $ \b ->+          whenTrue b $ x <=. 10000000+      ]+  ]++appendSize :: Specification ([Int], [Int])+appendSize = constrained' $ \ [var| xs |] [var| ys |] ->+  [ assert $ sizeOf_ xs <=. 10+  , assert $ sizeOf_ (ys ++. xs) <=. 15+  ]++appendSingleton :: Specification Int+appendSingleton = constrained $ \ [var| x |] ->+  10 `elem_` singletonList_ x ++. lit [1, 2, 3]++singletonSubset :: Specification Int+singletonSubset = constrained $ \ [var| x |] ->+  fromList_ (singletonList_ x) `subset_` fromList_ (lit [1, 2, 3])++appendSuffix :: Specification ([Int], [Int])+appendSuffix = constrained' $+  \ [var|x|] [var|y|] -> assert $ x ==. y ++. lit [4, 5, 6]++appendForAll :: Specification ([Int], [Int])+appendForAll = constrained' $ \ [var| xs |] [var| ys |] ->+  [ forAll xs $ \x -> x `elem_` lit [2, 4 .. 10]+  , assert $ xs ==. ys ++. lit [2, 4, 6]+  ]++-- Some notable error cases that shouldn't succeed++singletonErrorTooMany :: Specification Int+singletonErrorTooMany = constrained $ \ [var| x |] ->+  fromList_ (lit [1, 2, 3]) `subset_` fromList_ (singletonList_ x)++singletonErrorTooLong :: Specification Int+singletonErrorTooLong = constrained $ \ [var| x |] ->+  2 <=. length_ (singletonList_ x)++appendTooLong :: Specification [Int]+appendTooLong = constrained $ \ [var| xs |] ->+  sizeOf_ (lit [1, 2, 3, 4] ++. xs) <=. 3++-- | Fails because the cant set is over constrained+overconstrainedAppend :: Specification ([Int], [Int])+overconstrainedAppend = constrained' $+  \ [var|x|] [var|y|] ->+    [ dependsOn y x+    , assert $ x ==. lit [1, 2, 3] ++. y+    , assert $ y ==. lit [4, 5, 6]+    , assert $ x /=. lit [1, 2, 3, 4, 5, 6]+    ]++overconstrainedPrefixes :: Specification ([Int], [Int], [Int])+overconstrainedPrefixes = constrained' $ \ [var| xs |] [var| ys |] [var| zs |] ->+  [ xs ==. lit [1, 2, 3] ++. ys+  , xs ==. lit [3, 4, 5] ++. zs+  ]++overconstrainedSuffixes :: Specification ([Int], [Int], [Int])+overconstrainedSuffixes = constrained' $ \ [var| xs |] [var| ys |] [var| zs |] ->+  [ xs ==. ys ++. lit [1, 2, 3]+  , xs ==. zs ++. lit [3, 4, 5]+  ]++appendForAllBad :: Specification ([Int], [Int])+appendForAllBad = constrained' $ \ [var| xs |] [var| ys |] ->+  [ forAll xs $ \x -> x `elem_` lit [1 .. 10]+  , assert $ xs ==. ys ++. lit [2, 4, 11]+  ]
+ examples/Constrained/Examples/ManualExamples.hs view
@@ -0,0 +1,493 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}++module Constrained.Examples.ManualExamples where++import Constrained.API+import Data.Set (Set)+import GHC.Generics+import GHC.Natural+import Test.QuickCheck hiding (forAll)+import qualified Test.QuickCheck as QuickCheck++{- Generating from Specifications, and checking against Specifications -}++prop1 :: Gen Property+prop1 = do+  (w, x, y, z) <- arbitrary :: Gen (Int, Int, Int, Int)+  pure $ (w < x && x < y && y < z) ==> property (w < z)++spec1 :: Specification (Int, Int, Int, Int)+spec1 = constrained' $ \w x y z -> [w <. x, x <. y, y <. z]++prop2 :: Gen Property+prop2 = do+  (w, x, y, z) <- genFromSpec spec1+  pure $ (w < x && x < y && y < z) ==> property (w < z)++prop3 :: Gen Property+prop3 = do+  (w, x, y, z) <- frequency [(9, genFromSpec spec1), (1, arbitrary)]+  pure $+    if (w < x && x < y && y < z)+      then property (w < z)+      else expectFailure $ property (w < z)++leqPair :: Specification (Int, Int)+leqPair = constrained $ \p ->+  match p $ \x y ->+    assert (x <=. (y +. lit 2))++sumPair :: Specification (Int, Int)+sumPair = constrained $ \p ->+  match p $ \x y ->+    [ assert $ x <=. y+    , assert $ y >=. 20+    , assert $ x + y ==. 25+    ]++ex1 :: Specification Int+ex1 = constrained $ \_x -> True++ex2 :: Specification Int+ex2 = constrained $ \x -> x ==. lit 3++ex3 :: Specification Int+ex3 = constrained $ \x -> [x <=. lit 2, x >=. lit 0]++ex4 :: Specification Int+ex4 = constrained $ \x -> assert $ x ==. lit 9++{- From Term to Pred+1.   `assert`+-}++-- assert :: IsPred p => p -> Pred+ex5 :: Specification [Int]+ex5 = constrained $ \xs -> assert $ elem_ 7 xs++{-  For all elements in a container type (List, Set, Map)+1.  `forAll`+-}++-- forAll :: (Forallable t a, HasSpec t, HasSpec a, IsPred p) =>+--           Term t -> (Term a -> p) -> Pred+-- class Forallable t e | t -> e where+-- instance Ord k => Forallable (Map k v) (k, v)+-- instance Ord a => Forallable (Set a) a+-- instance Forallable [a] a++ex6 :: Specification [Int]+ex6 = constrained $ \xs ->+  forAll xs $ \x -> [x <=. 10, x >. 1]++{-  Reification+1.  `reifies`+2.  `reify`+3.  `assertRefified`+-}++-- reifies :: (HasSpec a, HasSpec b) => Term b -> Term a -> (a -> b) -> Pred+ex7 :: Specification (Int, [Int])+ex7 = constrained $ \pair ->+  match pair $ \n xs ->+    reifies n xs sum++-- reify :: (HasSpec a, HasSpec b, IsPred p) => Term a -> (a -> b) -> (Term b -> p) -> Pred+ex8 :: Specification ([Int], [Int])+ex8 = constrained $ \pair ->+  match pair $ \xs1 xs2 ->+    [ assert $ sizeOf_ xs1 <=. 5+    , forAll xs1 $ \x -> x <=. 10+    , reify xs1 reverse $ \t -> xs2 ==. t+    ]++-- assertReified :: (HasSpec Bool, HasSpec a) => Term a -> (a -> Bool) -> Pred+ex9 :: Specification Int+ex9 = constrained $ \x ->+  [ assert $ x <=. 10+  , assertReified x (<= 10)+  ]++{- Disjunction, choosing between multiple things with the same type+1.  `CaseOn`, `branch`, `branchW`+2.  `chooseSpec`+-}++{-+caseOn+  :: (HasSpec a, HasSpec (SimpleRep a), HasSimpleRep a,+      TypeSpec a ~ TypeSpec (SimpleRep a),+      SimpleRep a+      ~ Constrained.Generic.SumOver+          (Constrained.Spec.SumProd.Cases (SimpleRep a)),+      TypeList (Constrained.Spec.SumProd.Cases (SimpleRep a))) =>+     Term a+     -> FunTy+          (MapList+             (Weighted Binder) (Constrained.Spec.SumProd.Cases (SimpleRep a)))+          Pred+-}++data Three = One Int | Two Bool | Three Int deriving (Ord, Eq, Show, Generic)++instance HasSimpleRep Three++instance HasSpec Three++ex10 :: Specification Three+ex10 = constrained $ \three ->+  caseOn+    three+    (branch $ \i -> i ==. 1) -- One+    (branch $ \b -> assert (not_ b)) -- Two+    (branch $ \j -> j ==. 3) -- Three++ex11 :: Specification Three+ex11 = constrained $ \three ->+  caseOn+    three+    (branchW 1 $ \i -> i <. 0) -- One, weight 1+    (branchW 2 $ \b -> assert b) -- Two, weight 2+    (branchW 3 $ \j -> j >. 0) -- Three, weight 3++-- chooseSpec:: HasSpec a => (Int, Specification a) -> (Int, Specification a) -> Specification a++ex12 :: Specification (Int, [Int])+ex12 =+  chooseSpec+    ( 5+    , constrained $ \pair ->+        match pair $ \tot xs -> [tot >. lit 10, sum_ xs ==. tot, sizeOf_ xs ==. lit 3]+    )+    ( 3+    , constrained $ \pair ->+        match pair $ \tot xs -> [tot <. lit 10, sum_ xs ==. tot, sizeOf_ xs ==. lit 6]+    )++{- Primed library functions which are compositions with match++1.  `forAll'`+2.  `constrained'`+3.  `reify'`+-}++ex13a :: Specification [(Int, Int)]+ex13a = constrained $ \xs ->+  forAll xs $ \x -> match x $ \a b -> a ==. negate b++ex13b :: Specification [(Int, Int)]+ex13b = constrained $ \xs ->+  forAll' xs $ \a b -> a ==. negate b++ex14a :: Specification (Int, Int, Int)+ex14a = constrained $ \triple ->+  match triple $ \a b c -> [b ==. a + lit 1, c ==. b + lit 1]++ex14b :: Specification (Int, Int, Int)+ex14b = constrained' $ \a b c -> [b ==. a + lit 1, c ==. b + lit 1]++ex15a :: Specification (Int, Int, Int)+ex15a = constrained $ \triple ->+  match triple $ \x1 x2 x3 ->+    reify x1 (\a -> (a + 1, a + 2)) $ \t ->+      match t $ \b c -> [x2 ==. b, x3 ==. c]++ex15b :: Specification (Int, Int, Int)+ex15b = constrained $ \triple ->+  match triple $ \x1 x2 x3 ->+    reify' x1 (\a -> (a + 1, a + 2)) $ \b c -> [x2 ==. b, x3 ==. c]++ex15c :: Specification (Int, Int, Int)+ex15c = constrained' $ \x1 x2 x3 ->+  reify' x1 (\a -> (a + 1, a + 2)) $ \b c -> [x2 ==. b, x3 ==. c]++{-  Construtors and Selectors+1.  `onCon`+2.  `sel`+4.  `isJust`+-}++ex16 :: Specification Three+ex16 = constrained $ \three ->+  caseOn+    three+    (branchW 1 $ \i -> i ==. lit 1) -- One, weight 1+    (branchW 2 $ \b -> assert (not_ b)) -- Two, weight 2+    (branchW 3 $ \j -> j ==. 3) -- Three, weight 3++ex17 :: Specification Three+ex17 = constrained $ \three ->+  [ onCon @"One" three (\x -> x ==. lit 1)+  , onCon @"Two" three (\x -> not_ x)+  , onCon @"Three" three (\x -> x ==. lit 3)+  ]++ex18 :: Specification Three+ex18 = constrained $ \three -> onCon @"Three" three (\x -> x ==. lit 3)++ex19 :: Specification (Maybe Bool)+ex19 = constrained $ \mb -> onCon @"Just" mb (\x -> x ==. lit False)++data Dimensions where+  Dimensions ::+    { length :: Int+    , width :: Int+    , depth :: Int+    } ->+    Dimensions+  deriving (Ord, Eq, Show, Generic)++instance HasSimpleRep Dimensions++instance HasSpec Dimensions++ex20a :: Specification Dimensions+ex20a = constrained $ \d ->+  match d $ \l w dp -> [l >. lit 10, w ==. lit 5, dp <. lit 20]++ex20b :: Specification Dimensions+ex20b = constrained $ \d ->+  [ sel @0 d >. lit 10+  , sel @1 d ==. lit 5+  , sel @2 d <. lit 20+  ]++width_ :: Term Dimensions -> Term Int+width_ d = sel @1 d++ex21 :: Specification Dimensions+ex21 = constrained $ \d -> width_ d ==. lit 1++{- Naming introduced lambda bound Term variables+1.  [var|name|]+-}++ex22a :: Specification (Int, Int)+ex22a = constrained $ \pair ->+  match pair $ \left right -> [left ==. right, left ==. right + lit 1]++ex22b :: Specification (Int, Int)+ex22b = constrained $ \ [var|pair|] ->+  match pair $ \ [var|left|] [var|right|] -> [left ==. right, left ==. right + lit 1]++{-  Existential quantifiers+1.  `exists`+2.  `unsafeExists`+-}++ex24 :: Specification Int+ex24 = constrained $ \ [var|oddx|] ->+  unsafeExists+    (\ [var|y|] -> [assert $ oddx ==. y + y + 1])++ex25 :: Specification Int+ex25 = explainSpec ["odd via (y+y+1)"] $+  constrained $ \ [var|oddx|] ->+    exists+      (\eval -> pure (div (eval oddx - 1) 2))+      (\ [var|y|] -> [assert $ oddx ==. y + y + 1])++{-  Conditionals+1.  `whenTrue`+2.  `ifElse`+-}++data Rectangle = Rectangle {wid :: Int, len :: Int, square :: Bool}+  deriving (Show, Eq, Generic)++instance HasSimpleRep Rectangle++instance HasSpec Rectangle++ex26 :: Specification Rectangle+ex26 = constrained' $ \w l sq ->+  [ assert $ w >=. lit 0+  , assert $ l >=. lit 0+  , whenTrue sq (assert $ w ==. l)+  ]++ex27 :: Specification Rectangle+ex27 = constrained' $ \w l sq ->+  ifElse+    sq+    (assert $ w ==. l)+    [ assert $ w >=. lit 0+    , assert $ l >=. lit 0+    ]++{-  `Explanantions`+1.  `assertExplain`+2.  `explanation`+3.  `ExplainSpec`+-}++ex28a :: Specification (Set Int)+ex28a = constrained $ \s ->+  [ assert $ member_ (lit 5) s+  , forAll s $ \x -> [x >. lit 6, x <. lit 20]+  ]++ex28b :: Specification (Set Int)+ex28b = explainSpec ["5 must be in the set"] $+  constrained $ \s ->+    [ assert $ member_ (lit 5) s+    , forAll s $ \x -> [x >. lit 6, x <. lit 20]+    ]++{-  Operations to define and use Specifications+1.  `satisfies`+2.  `equalSpec`+3.  `notEqualSpec`+4.  `notMemberSpec`+5.  `leqSpec`+6.  `ltSpec`+7.  `geqSpec`+8.  `gtSpec`+5.  `cardinality`+-}++ex29 :: Specification Int+ex29 = constrained $ \x ->+  [ assert $ x >=. lit 0+  , assert $ x <=. lit 5+  , satisfies x (notMemberSpec [2, 3])+  ]++{-  Utility functions+1.  `simplifyTerm`+2.  `simplifySpec`+3.  `genFromSpecT`+4.  `genFromSpec`+5.  `genFromSpecWithSeed`+6.  `debugSpec`+-}++{-  Escape Hatch to QuickCheck Gen monad+1.  `monitor`+-}++ex30 :: Specification (Int, Int)+ex30 = constrained $ \ [var|p|] ->+  match p $ \ [var|x|] [var|y|] ->+    [ assert $ x /=. 0+    , -- You can use `monitor` to add QuickCheck property modifiers for+      -- monitoring distribution, like classify, label, and cover, to your+      -- specification+      monitor $ \eval ->+        QuickCheck.classify (eval y > 0) "positive y"+          . QuickCheck.classify (eval x > 0) "positive x"+    ]++prop31 :: QuickCheck.Property+prop31 = forAllSpec ex30 $ \_ -> True++ex32 :: IO ()+ex32 = QuickCheck.quickCheck $ prop31++ex11m :: Specification Three+ex11m = constrained $ \three ->+  [ caseOn+      three+      (branchW 1 $ \i -> i <. 0) -- One, weight 1+      (branchW 2 $ \b -> assert b) -- Two, weight 2+      (branchW 3 $ \j -> j >. 0) -- Three, weight 3+  , monitor $ \eval ->+      case (eval three) of+        One _ -> QuickCheck.classify True "One should be about 1/6"+        Two _ -> QuickCheck.classify True "Two should be about 2/6"+        Three _ -> QuickCheck.classify True "Three should be about 3/6"+  ]++propex11 :: QuickCheck.Property+propex11 = forAllSpec ex11m $ \_ -> True++ex33 :: IO ()+ex33 = QuickCheck.quickCheck $ propex11++{-  Strategy for constraining a large type with many nested sub-components -}++data Nested = Nested Three Rectangle [Int]+  deriving (Show, Eq, Generic)++instance HasSimpleRep Nested++instance HasSpec Nested++{-+Problem using TruePred, not monomorphic enough+skeleton1 :: Specification Nested+skeleton1 = constrained $ \ [var|nest|] ->+  match nest $ \ [var|three|] [var|rect|] [var|line|] ->+    [ (caseOn (three :: Term Three))+        (branch $ \ _i -> TruePred) -- One,+        (branch $ \ _k -> TruePred) -- Two,+        (branch $ \ _j -> TruePred) -- Three,+    , match rect $ \ [var|_wid|] [var|_len|] [var|_square|] -> TruePred+    , forAll line $ \ [var|_point|] -> TruePred+    ]+-}++-- By type applying match, branch, and forAll to @Pred , makes it monomorphic+--  Note    type Pred = PredD Deps , so it fixes the type argument of PredD+skeleton2 :: Specification Nested+skeleton2 = constrained $ \ [var|nest|] ->+  match nest $ \ [var|three|] [var|rect|] [var|line|] ->+    [ (caseOn (three :: Term Three))+        (branch @Pred $ \_i -> truePred) -- One,+        (branch @Pred $ \_k -> truePred) -- Two,+        (branch @Pred $ \_j -> truePred) -- Three,+    , match @Pred rect $ \ [var|_wid|] [var|_len|] [var|_square|] -> truePred+    , forAll @Pred line $ \ [var|_point|] -> truePred+    ]++-- We can do a similar thing by introducing `truePred` with the monomorphic type.+truePred :: Pred+truePred = mempty++skeleton :: Specification Nested+skeleton = constrained $ \ [var|nest|] ->+  match nest $ \ [var|three|] [var|rect|] [var|line|] ->+    [ (caseOn (three :: Term Three))+        (branch $ \_i -> truePred) -- One,+        (branch $ \_k -> truePred) -- Two,+        (branch $ \_j -> truePred) -- Three,+    , match rect $ \ [var|_wid|] [var|_len|] [var|_square|] -> [truePred]+    , forAll line $ \ [var|_point|] -> truePred+    ]++-- ======================================================================++newtype Coin = Coin {unCoin :: Integer} deriving (Eq, Show)++instance HasSimpleRep Coin where+  type SimpleRep Coin = Natural+  toSimpleRep (Coin i) = case integerToNatural i of+    Nothing -> error $ "The impossible happened in toSimpleRep for (Coin " ++ show i ++ ")"+    Just w -> w+  fromSimpleRep = naturalToCoin++instance HasSpec Coin++integerToNatural :: Integer -> Maybe Natural+integerToNatural c+  | c < 0 = Nothing+  | otherwise = Just $ fromIntegral c++naturalToCoin :: Natural -> Coin+naturalToCoin = Coin . fromIntegral++ex34 :: Specification Coin+ex34 = constrained $ \coin ->+  match coin $ \nat -> [nat >=. lit 100, nat <=. lit 200]
+ examples/Constrained/Examples/Map.hs view
@@ -0,0 +1,161 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ViewPatterns #-}++module Constrained.Examples.Map where++import Constrained.API+import Constrained.Examples.Basic+import Data.Map (Map)+import Data.Map qualified as Map+import Data.Set (Set)+import Data.Set qualified as Set+import Data.Word++mapElemSpec :: Specification (Map Int (Bool, Int))+mapElemSpec = constrained $ \m ->+  [ assert $ m /=. lit mempty+  , forAll' (rng_ m) $ \_ b ->+      [0 <. b, b <. 10]+  ]++mapPairSpec :: Specification (Map Int Int, Set Int)+mapPairSpec = constrained' $ \m s ->+  subset_ (dom_ m) s++mapEmptyDomainSpec :: Specification (Map Int Int)+mapEmptyDomainSpec = constrained $ \m ->+  subset_ (dom_ m) mempty -- mempty in the Monoid instance (Term fn (Set a))++mapSubSize :: Specification (Map Int Int)+mapSubSize = constrained $ \s ->+  2 ==. 12 - (sizeOf_ s)++knownDomainMap :: Specification (Map Int Int)+knownDomainMap = constrained $ \m ->+  [ dom_ m ==. lit (Set.fromList [1, 2])+  , not_ $ 0 `elem_` rng_ m+  ]++mapSizeConstrained :: Specification (Map Three Int)+mapSizeConstrained = constrained $ \m -> sizeOf_ m <=. 3++sumRange :: Specification (Map Word64 Word64)+sumRange = constrained $ \m -> sum_ (rng_ m) ==. lit 10++fixedRange :: Specification (Map Int Int)+fixedRange = constrained $ \m ->+  [ forAll (rng_ m) (\x -> x ==. 5)+  , assert $ (sizeOf_ m) ==. 1+  ]++rangeHint :: Specification (Map Int Int)+rangeHint = constrained $ \m ->+  genHint 10 (rng_ m)++rangeSumSize :: Specification (Map Int Int)+rangeSumSize = constrained $ \m ->+  [ assert $ sizeOf_ m <=. 0+  , assert $ sum_ (rng_ m) <=. 0+  , assert $ (-1) <=. sum_ (rng_ m)+  , forAll' m $ \k v ->+      [ k ==. (-1)+      , v ==. 1+      ]+  ]++elemSpec :: Specification (Int, Int, Map Int Int)+elemSpec = constrained' $ \ [var|key|] [var|val|] [var|mapp|] ->+  [ assert $ key `member_` dom_ mapp+  , forAll' mapp $ \ [var|k'|] [var|v'|] ->+      whenTrue (k' ==. key) (v' ==. val)+  , mapp `dependsOn` key+  ]++lookupSpecific :: Specification (Int, Int, Map Int Int)+lookupSpecific = constrained' $ \ [var|k|] [var|v|] [var|m|] ->+  [ m `dependsOn` k+  , assert $ lookup_ k m ==. just_ v+  ]++mapRestrictedValues :: Specification (Map (Either Int ()) Int)+mapRestrictedValues = constrained $ \m ->+  [ assert $ sizeOf_ m ==. 6+  , forAll' m $ \k v ->+      [ caseOn+          k+          (branch $ \_ -> 20 <=. v)+          (branch $ \_ -> True)+      , v `dependsOn` k+      ]+  ]++-- NOTE: this fails if you pick the values of the map first - you're unlikely to generate+-- three values such that two of them are <= -100 and >= 100 respectively even though+-- you take satisfiability of the whole elem constraint into account. This can't be fixed+-- with a `dependsOn v k` because the issue is that we've generated a bunch of values+-- before we ever go to generate the keys.+mapRestrictedValuesThree :: Specification (Map Three Int)+mapRestrictedValuesThree = constrained $ \m ->+  [ assert $ sizeOf_ m ==. 3+  , forAll' m $ \k v ->+      [ caseOn+          k+          (branch $ \_ -> v <=. (-100))+          (branch $ \_ -> 100 <=. v)+          (branch $ \_ -> True)+      , -- This is important to demonstrate the point that keys sometimes need to be solved before+        -- values+        v `dependsOn` k+      ]+  ]++mapRestrictedValuesBool :: Specification (Map Bool Int)+mapRestrictedValuesBool = constrained $ \m ->+  [ assert $ sizeOf_ m ==. 2+  , forAll' m $ \k v -> [v `dependsOn` k, whenTrue k (100 <=. v)]+  ]++mapSetSmall :: Specification (Map (Set Int) Int)+mapSetSmall = constrained $ \x ->+  forAll (dom_ x) $ \d ->+    assert $ subset_ d $ lit (Set.fromList [3 .. 4])++-- | this tests the function saturatePred+mapIsJust :: Specification (Int, Int)+mapIsJust = constrained' $ \ [var| x |] [var| y |] ->+  just_ x ==. lookup_ y (lit $ Map.fromList [(z, z) | z <- [100 .. 102]])++eitherKeys :: Specification ([Int], [Int], Map (Either Int Int) Int)+eitherKeys = constrained' $ \ [var| as |] [var| bs |] [var| m |] ->+  [ forAll' m $ \ [var| k |] _v ->+      [ caseOn+          k+          (branch $ \a -> a `elem_` as)+          (branch $ \b -> b `elem_` bs)+      , reify as (map Left) $ \ls ->+          reify bs (map Right) $ \rs ->+            k `elem_` ls ++. rs+      ]+  ]++keysExample :: Specification (Either Int Int)+keysExample = constrained $ \k ->+  [ caseOn+      k+      (branch $ \a -> a `elem_` as)+      (branch $ \b -> b `elem_` bs)+  , reify as (map Left) $ \ls ->+      reify bs (map Right) $ \rs ->+        k `elem_` ls ++. rs+  ]+  where+    as = lit [1 .. 10]+    bs = lit [11 .. 20]++failingKVSpec :: Specification (Map Int Int)+failingKVSpec = constrained $ \m ->+  [ assert $ 10 <. sizeOf_ m+  , forAll' m $ \k _v ->+      k `satisfies` chooseSpec (1, constrained $ \k' -> 2 * k' ==. 1) (3, mempty)+  ]
+ examples/Constrained/Examples/Set.hs view
@@ -0,0 +1,184 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}++module Constrained.Examples.Set where++import Constrained.API+import Constrained.Examples.Basic+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Typeable+import GHC.Generics++-- =============================================================++setPairSpec :: Specification (Set Int, Set Int)+setPairSpec = constrained' $ \s s' ->+  forAll s $ \x ->+    forAll s' $ \y ->+      x <=. y++fixedSetSpec :: Specification (Set Int)+fixedSetSpec = constrained $ \s ->+  forAll s $ \x ->+    [x <=. lit (i :: Int) | i <- [1 .. 3]]++setOfPairLetSpec :: Specification (Set (Int, Int))+setOfPairLetSpec = constrained $ \ps ->+  forAll' ps $ \x y ->+    x <=. y++setSingletonSpec :: Specification (Set (Int, Int))+setSingletonSpec = constrained $ \ps ->+  forAll ps $ \p ->+    forAll (singleton_ (fst_ p)) $ \x ->+      x <=. 10++eitherSimpleSetSpec :: Specification (Set (Either Int Int))+eitherSimpleSetSpec = constrained $ \ss ->+  forAll ss $ \s ->+    (caseOn s)+      (branch $ \a -> a <=. 0)+      (branch $ \b -> 0 <=. b)++forAllAnySpec :: Specification (Set Int)+forAllAnySpec = constrained $ \as ->+  forAll as $ \_ -> True++maybeJustSetSpec :: Specification (Set (Maybe Int))+maybeJustSetSpec = constrained $ \ms ->+  forAll ms $ \m ->+    (caseOn m)+      (branch $ \_ -> False)+      (branch $ \y -> 0 <=. y)++notSubsetSpec :: Specification (Set Int, Set Int)+notSubsetSpec = constrained' $ \s s' -> not_ $ subset_ s s'++emptyEitherMemberSpec :: Specification (Set (Either Int Int))+emptyEitherMemberSpec = constrained $ \s ->+  forAll s $ \x ->+    (caseOn x)+      (branch $ \l -> member_ l mempty)+      (branch $ \r -> member_ r mempty)++emptyEitherSpec :: Specification (Set (Either Int Int))+emptyEitherSpec = constrained $ \s ->+  forAll s $ \x ->+    (caseOn x)+      (branch $ \_ -> False)+      (branch $ \_ -> False)++notSubset :: Specification (Set Int)+notSubset = constrained $ \s ->+  not_ $ s `subset_` lit (Set.fromList [1, 2, 3])++unionSized :: Specification (Set Int)+unionSized = constrained $ \s ->+  10 ==. sizeOf_ (s <> lit (Set.fromList [1 .. 8]))++maybeSpec :: Specification (Set (Maybe Int))+maybeSpec = constrained $ \ms ->+  forAll ms $ \m ->+    (caseOn m)+      (branch $ \_ -> False)+      (branch $ \y -> 0 <=. y)++eitherSetSpec ::+  Specification (Set (Either Int Int), Set (Either Int Int), Set (Either Int Int))+eitherSetSpec = constrained' $ \es as bs ->+  [ assert $ es ==. (as <> bs)+  , forAll as $ \a ->+      (caseOn a)+        (branch $ \a' -> a' <=. 0)+        (branch $ \b' -> 1 <=. b')+  , forAll bs $ \b ->+      (caseOn b)+        (branch $ \_ -> False)+        (branch $ \b' -> 1 <=. b')+  ]++weirdSetPairSpec :: Specification ([Int], Set (Either Int Int))+weirdSetPairSpec = constrained' $ \as as' ->+  [ as' `dependsOn` as+  , forAll as $ \a ->+      member_ (left_ a) as'+  , forAll as' $ \a' ->+      (caseOn a')+        (branch $ \x -> elem_ x as)+        (branch $ \_ -> False)+  ]++setPair :: Specification (Set (Int, Int))+setPair = constrained $ \s ->+  [ forAll s $ \p ->+      p `satisfies` leqPair+  , assert $ lit (0, 1) `member_` s+  ]++setSpec :: Specification (Set Int)+setSpec = constrained $ \ss ->+  forAll ss $ \s ->+    s <=. 10++compositionalSpec :: Specification (Set Int)+compositionalSpec = constrained $ \x ->+  [ satisfies x setSpec+  , assert $ 0 `member_` x+  ]++emptySetSpec :: Specification (Set Int)+emptySetSpec = constrained $ \s ->+  forAll s $ \x -> member_ x mempty++setSubSize :: Specification (Set Int)+setSubSize = constrained $ \s ->+  2 ==. 12 - (sizeOf_ s)++newtype NotASet a = NotASet (Set a)+  deriving (Generic, Show, Eq)++instance (Typeable a, Ord a) => HasSimpleRep (NotASet a) where+  type SimpleRep (NotASet a) = [a]+  fromSimpleRep = NotASet . Set.fromList+  toSimpleRep (NotASet s) = Set.toList s++instance (Ord a, HasSpec a) => HasSpec (NotASet a)++instance (Typeable a, Ord a) => Forallable (NotASet a) a++emptyListSpec :: Specification ([Int], NotASet (Either Int Int, Int))+emptyListSpec = constrained' $ \is ls ->+  [ forAll is $ \i -> i <=. 0+  , forAll' ls $ \l _ ->+      caseOn l (branch $ \_ -> False) (branch $ \_ -> False)+  ]++foldSingleCase :: Specification Int+foldSingleCase = constrained $ \x ->+  [ assert $ not_ $ member_ x (lit (Set.fromList [10]))+  , letBind (pair_ x $ lit [(10, 20) :: (Int, Int)]) $ \p ->+      match p $ \_ p1 -> forAll p1 $ \p2 ->+        assert (0 <=. snd_ p2)+  ]++complexUnion :: Specification (Set Int, Set Int)+complexUnion = constrained' $ \ys zs ->+  [ sizeOf_ ys <=. 10+  , 0 <. sizeOf_ (ys <> zs)+  ]++unionBounded :: Specification (Set Int)+unionBounded = constrained $ \xs ->+  [ sizeOf_ (xs <> lit (Set.fromList [1, 2, 3])) <=. 3+  ]++-- Only possible value is {4}+powersetPickOne :: Specification (Set Int)+powersetPickOne =+  constrained $ \xs ->+    [ xs `subset_` lit (Set.fromList [3, 4])+    , not_ $ xs `elem_` lit [mempty, Set.fromList [3], Set.fromList [3, 4]]+    ]
+ examples/Constrained/Examples/Tree.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeApplications #-}++module Constrained.Examples.Tree where++import Constrained.API+import Constrained.Examples.BinTree+import Data.Tree++allZeroTree :: Specification (BinTree Int)+allZeroTree = constrained $ \t ->+  [ forAll' t $ \_ a _ -> a ==. 0+  , genHint 10 t+  ]++isBST :: Specification (BinTree Int)+isBST = constrained $ \t ->+  [ forAll' t $ \left a right ->+      -- TODO: if there was a `binTreeRoot` function on trees+      -- this wouldn't need to be quadratic as we would+      -- only check agains the head of the left and right+      -- subtrees, not _every element_+      [ forAll' left $ \_ l _ -> l <. a+      , forAll' right $ \_ h _ -> a <. h+      ]+  , genHint 10 t+  ]++noChildrenSameTree :: Specification (BinTree Int)+noChildrenSameTree = constrained $ \t ->+  [ forAll' t $ \left a right ->+      [ forAll' left $ \_ l _ -> l /=. a+      , forAll' right $ \_ r _ -> r /=. a+      ]+  , genHint 8 t+  ]++isAllZeroTree :: Specification (Tree Int)+isAllZeroTree = constrained $ \t ->+  [ forAll' t $ \a cs ->+      [ a ==. 0+      , length_ cs <=. 4+      ]+  , genHint (Just 2, 30) t+  ]++noSameChildrenTree :: Specification (Tree Int)+noSameChildrenTree = constrained $ \t ->+  [ forAll' t $ \a cs ->+      [ assert $ a `elem_` lit [1 .. 8]+      , forAll cs $ \t' ->+          forAll' t' $ \b _ ->+            b /=. a+      ]+  , genHint (Just 2, 30) t+  ]++successiveChildren :: Specification (Tree Int)+successiveChildren = constrained $ \t ->+  [ forAll' t $ \a cs ->+      [ forAll cs $ \t' ->+          rootLabel_ t' ==. a + 1+      ]+  , genHint (Just 2, 10) t+  ]++successiveChildren8 :: Specification (Tree Int)+successiveChildren8 = constrained $ \t ->+  [ t `satisfies` successiveChildren+  , forAll' t $ \a _ -> a `elem_` lit [1 .. 5]+  ]++roseTreeList :: Specification [Tree Int]+roseTreeList = constrained $ \ts ->+  [ assert $ length_ ts <=. 10+  , forAll ts $ \t ->+      [ forAll t $ \_ -> False+      ]+  ]++roseTreePairs :: Specification (Tree ([Int], [Int]))+roseTreePairs = constrained $ \t ->+  [ assert $ rootLabel_ t ==. lit ([1 .. 10], [1 .. 10])+  , forAll' t $ \p ts ->+      forAll ts $ \t' ->+        fst_ (rootLabel_ t') ==. snd_ p+  , genHint (Nothing, 10) t+  ]++roseTreeMaybe :: Specification (Tree (Maybe (Int, Int)))+roseTreeMaybe = constrained $ \t ->+  [ forAll' t $ \mp ts ->+      forAll ts $ \t' ->+        onJust mp $ \p ->+          onJust (rootLabel_ t') $ \p' ->+            fst_ p' ==. snd_ p+  , forAll' t $ \mp _ -> isJust mp+  , genHint (Nothing, 10) t+  ]++badTreeInteraction :: Specification (Tree (Either Int Int))+badTreeInteraction = constrained $ \t ->+  [ forAll' t $ \n ts' ->+      [ isCon @"Right" n+      , forAll ts' $ \_ -> True+      ]+  , forAll' t $ \n ts' ->+      forAll ts' $ \t' ->+        [ genHint (Just 4, 10) t'+        , assert $ rootLabel_ t' ==. n+        ]+  , genHint (Just 4, 10) t+  ]
+ src/Constrained/API.hs view
@@ -0,0 +1,232 @@+{-# LANGUAGE PatternSynonyms #-}++-- | This is the main user-facing API of the library for when you just want to+-- write constraints and simple `HasSpec` instances.+module Constrained.API (+  -- * Types+  Specification,+  Pred,+  Term,++  -- * Type classes and constraints+  HasSpec (..),+  HasSimpleRep (..),+  Foldy (..),+  OrdLike (..),+  Forallable (..),+  HasGenHint (..),+  Sized (..),+  NumLike (..),+  HasDivision (..),+  GenericallyInstantiated,+  IsPred,+  Logic,+  Semantics,+  Syntax,+  Numeric,+  IsNormalType,++  -- * Core syntax+  constrained,+  constrained',+  match,+  letBind,+  assert,+  assertExplain,+  assertReified,+  forAll,+  forAll',+  exists,+  unsafeExists,+  whenTrue,+  ifElse,+  dependsOn,+  reify,+  reify',+  reifies,+  explanation,+  monitor,+  genHint,+  caseOn,+  branch,+  branchW,+  onCon,+  isCon,+  onJust,+  isJust,+  lit,+  con,+  sel,+  var,+  name,++  -- * Function symbols++  -- ** Numbers+  (<.),+  (<=.),+  (>=.),+  (>.),+  (==.),+  (/=.),+  (+.),+  (-.),+  negate_,++  -- ** Booleans+  not_,+  (||.),++  -- ** Pairs+  pair_,+  fst_,+  snd_,++  -- ** Either+  left_,+  right_,++  -- ** Maybe+  just_,+  nothing_,++  -- ** List+  foldMap_,+  sum_,+  elem_,+  singletonList_,+  append_,+  (++.),+  sizeOf_,+  null_,+  length_,++  -- ** Set+  singleton_,+  member_,+  union_,+  subset_,+  disjoint_,+  fromList_,++  -- ** Map+  dom_,+  rng_,+  lookup_,+  mapMember_,+  rootLabel_,++  -- ** Generics+  fromGeneric_,+  toGeneric_,++  -- * Composing specifications+  satisfies,+  chooseSpec,+  trueSpec,+  equalSpec,+  notEqualSpec,+  notMemberSpec,+  hasSize,+  explainSpec,+  rangeSize,+  between,+  typeSpec,+  defaultMapSpec,++  -- * Generation, Shrinking, and Testing++  -- ** Types+  GE (..),+  GenT,++  -- ** Generating+  genFromSpec,+  genFromSpecT,+  genFromSpecWithSeed,+  genFromSizeSpec,+  looseGen,+  strictGen,++  -- ** Shrinking+  shrinkWithSpec,++  -- ** Debugging+  debugSpec,+  printPlan,++  -- ** Testing+  conformsToSpec,+  conformsToSpecE,+  conformsToSpecProp,++  -- ** Building properties+  monitorSpec,+  forAllSpec,+  forAllSpecShow,+  forAllSpecDiscard,++  -- ** Building generators+  pureGen,+  listOfT,+  oneofT,+  frequencyT,+  vectorOfT,++  -- * Utilities+  unionWithMaybe,++  -- * Re-exports+  NonEmpty ((:|)),+) where++import Constrained.AbstractSyntax+import Constrained.Base+import Constrained.Conformance+import Constrained.Core+import Constrained.FunctionSymbol+import Constrained.GenT+import Constrained.Generation+import Constrained.Generic+import Constrained.NumOrd+import Constrained.Properties+import Constrained.Spec.List+import Constrained.Spec.Map+import Constrained.Spec.Set+import Constrained.Spec.SumProd+import Constrained.Spec.Tree+import Constrained.Syntax+import Constrained.TheKnot++infix 4 /=.++-- | Inequality as a constraint+(/=.) :: HasSpec a => Term a -> Term a -> Term Bool+a /=. b = not_ (a ==. b)++-- | Specialized `sizeOf_`+length_ :: HasSpec a => Term [a] -> Term Integer+length_ = sizeOf_++infixr 2 ||.++-- | Another name for `or_`+(||.) ::+  Term Bool ->+  Term Bool ->+  Term Bool+(||.) = or_++infixr 5 ++.++-- | Another name for `append_`+(++.) :: HasSpec a => Term [a] -> Term [a] -> Term [a]+(++.) = append_++-- | Like `null` on `Term`+null_ :: (HasSpec a, Sized a) => Term a -> Term Bool+null_ xs = sizeOf_ xs ==. 0++-- | `mempty` for `Specification` without the extra constraints+trueSpec :: Specification a+trueSpec = TrueSpec
+ src/Constrained/API/Extend.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE PatternSynonyms #-}++-- | This module provides an API for extending the library with new function+-- symbols.+module Constrained.API.Extend (+  -- * Abstract syntax+  SpecificationD (..),+  pattern TypeSpec,+  PredD (..),+  TermD (..),+  BinderD (..),++  -- * Implementing new functions+  appTerm,+  Semantics (..),+  Syntax (..),++  -- ** The `Logic` instance+  Logic (..),+  HOLE (..),+  pattern Unary,+  pattern (:<:),+  pattern (:>:),++  -- ** Built-in 'TypeSpec's+  PairSpec (..),+  MapSpec (..),+  SetSpec (..),+  NumSpec (..),+  TreeSpec (..),++  -- * Generics+  (:::),+  SOP,+  algebra,+  inject,++  -- * Building new `NumSpec`-based instances+  emptyNumSpec,+  cardinalNumSpec,+  combineNumSpec,+  genFromNumSpec,+  shrinkWithNumSpec,+  fixupWithNumSpec,+  conformsToNumSpec,+  toPredsNumSpec,+  MaybeBounded (..),++  -- * Re-export of `Constrained.API`+  module Constrained.API,+) where++import Constrained.API+import Constrained.AbstractSyntax+import Constrained.Base+import Constrained.FunctionSymbol+import Constrained.Generic+import Constrained.NumOrd+import Constrained.Spec.Map+import Constrained.Spec.Set+import Constrained.Spec.Tree+import Constrained.TheKnot
+ src/Constrained/AbstractSyntax.hs view
@@ -0,0 +1,399 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++-- | This module contains the abstract syntax of terms, predicates, and specifications+module Constrained.AbstractSyntax (+  TermD (..),+  runTermE,+  runTerm,+  fastInequality,+  PredD (..),+  SpecificationD (..),+  BinderD (..),+  Weighted (..),+  mapWeighted,+  traverseWeighted,+  AppRequiresD,+  Syntax (..),+) where++import Constrained.Core+import Constrained.DependencyInjection+import Constrained.Env (Env)+import Constrained.Env qualified as Env+import Constrained.FunctionSymbol+import Constrained.GenT+import Constrained.Generic+import Constrained.List+import Constrained.PrettyUtils+import Control.Monad.Identity+import Data.Kind+import Data.List.NonEmpty qualified as NE+import Data.String+import Data.Typeable+import Prettyprinter hiding (cat)+import Test.QuickCheck++------------------------------------------------------------------------+-- The first-order term language+------------------------------------------------------------------------++-- $depsExplanation+-- See `Constrained.DependencyInjection` to better understand @deps@ - it's a+-- pointer to postpone having to define `Constrained.Base.HasSpec` and friends here.++-- | First-order terms, application, literals, variables. $depsExplanation+data TermD deps a where+  App ::+    AppRequiresD deps t dom rng =>+    t dom rng ->+    List (TermD deps) dom ->+    TermD deps rng+  Lit :: (Typeable a, Eq a, Show a) => a -> TermD deps a+  V :: (HasSpecD deps a, Typeable a) => Var a -> TermD deps a++-- | Everything required to deal with applications of a function to arguments+-- of type @dom@+type AppRequiresD deps (t :: [Type] -> Type -> Type) dom rng =+  ( LogicD deps t+  , Syntax t+  , Semantics t+  , TypeList dom+  , Eq (t dom rng)+  , Show (t dom rng)+  , Typeable t+  , All Typeable dom+  , Typeable dom+  , Typeable rng+  , All (HasSpecD deps) dom+  , All Show dom+  , HasSpecD deps rng+  , Show rng+  )++instance Eq (TermD deps a) where+  V x == V x' = x == x'+  Lit a == Lit b = a == b+  App (w1 :: x1) (ts :: List (TermD deps) dom1) == App (w2 :: x2) (ts' :: List (TermD deps) dom2) =+    case (eqT @dom1 @dom2, eqT @x1 @x2) of+      (Just Refl, Just Refl) ->+        w1 == w2+          && ts == ts'+      _ -> False+  _ == _ = False++-- Semantics --------------------------------------------------------------++-- | Run a term in an environment, with an error if it fails+runTermE :: forall a deps. Env -> TermD deps a -> Either (NE.NonEmpty String) a+runTermE env = \case+  Lit a -> Right a+  V v -> case Env.lookup env v of+    Just a -> Right a+    Nothing -> Left (pure ("Couldn't find " ++ show v ++ " in " ++ show env))+  -- The first two cases here are an optimization to avoid dispatching to `mapMList` (which does all sorts of+  -- unpacking and packing and doesn't fuse nicely with `uncurryList_`)+  App f (ta :> Nil) -> semantics f <$> runTermE env ta+  App f (ta :> tb :> Nil) -> semantics f <$> runTermE env ta <*> runTermE env tb+  App f ts -> do+    vs <- mapMList (fmap Identity . runTermE env) ts+    pure $ uncurryList_ runIdentity (semantics f) vs++-- | Generalized `runTermE` to `MonadGenError`+runTerm :: MonadGenError m => Env -> TermD deps a -> m a+runTerm env x = case runTermE env x of+  Left msgs -> fatalErrorNE msgs+  Right val -> pure val++-- Utilities --------------------------------------------------------------++-- | Sound but not complete inequality on terms+fastInequality :: TermD deps a -> TermD deps b -> Bool+fastInequality (V (Var i _)) (V (Var j _)) = i /= j+fastInequality Lit {} Lit {} = False+fastInequality (App _ as) (App _ bs) = go as bs+  where+    go :: List (TermD deps) as -> List (TermD deps) bs -> Bool+    go Nil Nil = False+    go (a :> as') (b :> bs') = fastInequality a b || go as' bs'+    go _ _ = True+fastInequality _ _ = True++-- Pretty-printing --------------------------------------------------------++-- | Syntactic operations are ones that have to do with the structure and appearence of the type. $depsExplanation+class Syntax (t :: [Type] -> Type -> Type) where+  isInfix :: t dom rng -> Bool+  isInfix _ = False++  prettySymbol ::+    forall deps dom rng ann.+    t dom rng ->+    List (TermD deps) dom ->+    Int ->+    Maybe (Doc ann)+  prettySymbol _ _ _ = Nothing++instance Show a => Pretty (WithPrec (TermD deps a)) where+  pretty (WithPrec p t) = case t of+    Lit n -> fromString $ showsPrec p n ""+    V x -> viaShow x+    App x Nil -> viaShow x+    App f as+      | Just doc <- prettySymbol f as p -> doc -- Use Function Symbol specific pretty printers+    App f as+      | isInfix f+      , a :> b :> Nil <- as ->+          parensIf (p > 9) $ prettyPrec 10 a <+> viaShow f <+> prettyPrec 10 b+      | otherwise -> parensIf (p > 10) $ viaShow f <+> align (fillSep (ppListC @Show (prettyPrec 11) as))++instance Show a => Pretty (TermD deps a) where+  pretty = prettyPrec 0++instance Show a => Show (TermD deps a) where+  showsPrec p t = shows $ pretty (WithPrec p t)++------------------------------------------------------------------------+-- The language for predicates+------------------------------------------------------------------------++-- | This is _essentially_ a first-order logic with some extra spicyness thrown+-- in to handle things like sum types and the specific problems you get into+-- when generating from constraints (mostly to do with choosing the order in+-- which to generate things). $depsExplanation+data PredD deps where+  ElemPred ::+    (HasSpecD deps a, Show a) =>+    Bool ->+    TermD deps a ->+    NonEmpty a ->+    PredD deps+  Monitor :: ((forall a. TermD deps a -> a) -> Property -> Property) -> PredD deps+  And :: [PredD deps] -> PredD deps+  Exists ::+    -- | Constructive recovery function for checking+    -- existential quantification+    ((forall b. TermD deps b -> b) -> GE a) ->+    BinderD deps a ->+    PredD deps+  -- This is here because we sometimes need to delay substitution until we're done building+  -- terms and predicates. This is because our surface syntax relies on names being "a bit"+  -- lazily bound to avoid infinite loops when trying to create new names.+  Subst ::+    ( HasSpecD deps a+    , Show a+    ) =>+    Var a ->+    TermD deps a ->+    PredD deps ->+    PredD deps+  Let ::+    TermD deps a ->+    BinderD deps a ->+    PredD deps+  Assert :: TermD deps Bool -> PredD deps+  Reifies ::+    ( HasSpecD deps a+    , HasSpecD deps b+    , Show a+    , Show b+    ) =>+    -- | This depends on the @a@ term+    TermD deps b ->+    TermD deps a ->+    -- | Recover a useable @b@ value from the @a@ term in normal Haskell land+    (a -> b) ->+    PredD deps+  DependsOn ::+    ( HasSpecD deps a+    , HasSpecD deps b+    , Show a+    , Show b+    ) =>+    TermD deps a ->+    TermD deps b ->+    PredD deps+  ForAll ::+    ( ForallableD deps t e+    , HasSpecD deps t+    , HasSpecD deps e+    , Show t+    , Show e+    ) =>+    TermD deps t ->+    BinderD deps e ->+    PredD deps+  Case ::+    ( HasSpecD deps (SumOver as)+    , Show (SumOver as)+    ) =>+    TermD deps (SumOver as) ->+    -- | Each branch of the type is bound with+    -- only one variable because `as` are types.+    -- Constructors with multiple arguments are+    -- encoded with `ProdOver` (c.f. `Constrained.Univ`).+    List (Weighted (BinderD deps)) as ->+    PredD deps+  -- monadic-style `when` - if the first argument is False the second+  -- doesn't apply.+  When ::+    TermD deps Bool ->+    PredD deps ->+    PredD deps+  GenHintD ::+    ( HasGenHintD deps a+    , Show a+    , Show (HintD deps a)+    ) =>+    HintD deps a ->+    TermD deps a ->+    PredD deps+  TruePred :: PredD deps+  FalsePred :: NE.NonEmpty String -> PredD deps+  Explain :: NE.NonEmpty String -> PredD deps -> PredD deps++-- | Binders, a t`Var` is bound in a `PredD`, never anywhere else+data BinderD deps a where+  (:->) ::+    (HasSpecD deps a, Show a) =>+    Var a ->+    PredD deps ->+    BinderD deps a++deriving instance Show (BinderD deps a)++-- | A thing, wrapped in a functor, with a weight+data Weighted f a = Weighted {weight :: Maybe Int, thing :: f a}+  deriving (Functor, Traversable, Foldable)++-- | Apply a natural transformation to the weighted value+mapWeighted :: (f a -> g b) -> Weighted f a -> Weighted g b+mapWeighted f (Weighted w t) = Weighted w (f t)++-- | Like `mapWeighted` but `Applicative`+traverseWeighted :: Applicative m => (f a -> m (g a)) -> Weighted f a -> m (Weighted g a)+traverseWeighted f (Weighted w t) = Weighted w <$> f t++instance Semigroup (PredD deps) where+  FalsePred xs <> FalsePred ys = FalsePred (xs <> ys)+  FalsePred es <> _ = FalsePred es+  _ <> FalsePred es = FalsePred es+  TruePred <> p = p+  p <> TruePred = p+  p <> p' = And (unpackPred p ++ unpackPred p')+    where+      unpackPred (And ps) = ps+      unpackPred x = [x]++instance Monoid (PredD deps) where+  mempty = TruePred++-- Pretty-printing --------------------------------------------------------++instance Pretty (PredD deps) where+  pretty = \case+    ElemPred True term vs ->+      align $+        sep+          [ "memberPred"+          , pretty term+          , prettyShowList (NE.toList vs)+          ]+    ElemPred False term vs -> align $ sep ["notMemberPred", pretty term, prettyShowList (NE.toList vs)]+    Exists _ (x :-> p) -> align $ sep ["exists" <+> viaShow x <+> "in", pretty p]+    Let t (x :-> p) -> align $ sep ["let" <+> viaShow x <+> "=" /> pretty t <+> "in", pretty p]+    And ps -> braces $ vsep' $ map pretty ps+    Assert t -> "assert $" <+> pretty t+    Reifies t' t _ -> "reifies" <+> pretty (WithPrec 11 t') <+> pretty (WithPrec 11 t)+    DependsOn a b -> pretty a <+> "<-" /> pretty b+    ForAll t (x :-> p) -> "forall" <+> viaShow x <+> "in" <+> pretty t <+> "$" /> pretty p+    Case t bs -> "case" <+> pretty t <+> "of" /> vsep' (ppList pretty bs)+    When b p -> "whenTrue" <+> pretty (WithPrec 11 b) <+> "$" /> pretty p+    Subst x t p -> "[" <> pretty t <> "/" <> viaShow x <> "]" <> pretty p+    GenHintD h t -> "genHint" <+> fromString (showsPrec 11 h "") <+> "$" <+> pretty t+    TruePred -> "True"+    FalsePred {} -> "False"+    Monitor {} -> "monitor"+    Explain es p -> "Explain" <+> viaShow (NE.toList es) <+> "$" /> pretty p++instance Show (PredD deps) where+  show = show . pretty++instance Pretty (f a) => Pretty (Weighted f a) where+  pretty (Weighted Nothing t) = pretty t+  pretty (Weighted (Just w) t) = viaShow w <> "~" <> pretty t++instance Pretty (BinderD deps a) where+  pretty (x :-> p) = viaShow x <+> "->" <+> pretty p++------------------------------------------------------------------------+-- The language of specifications+------------------------------------------------------------------------++-- | A @`SpecificationD` deps a@ denotes a set of @a@s. $depsExplanation+data SpecificationD deps a where+  -- | Explain a Specification+  ExplainSpec :: [String] -> SpecificationD deps a -> SpecificationD deps a+  -- | Elements of a known set+  MemberSpec ::+    -- | It must be an element of this list. Try hard not to put duplicates in the List.+    NE.NonEmpty a ->+    SpecificationD deps a+  -- | The empty set+  ErrorSpec ::+    NE.NonEmpty String ->+    SpecificationD deps a+  -- | The set described by some predicates+  -- over the bound variable.+  SuspendedSpec ::+    HasSpecD deps a =>+    -- | This variable ranges over values denoted by+    -- the spec+    Var a ->+    -- | And the variable is subject to these constraints+    PredD deps ->+    SpecificationD deps a+  -- | A type-specific spec+  TypeSpecD ::+    HasSpecD deps a =>+    TypeSpecD deps a ->+    -- | It can't be any of the elements of this set+    [a] ->+    SpecificationD deps a+  -- | Anything+  TrueSpec :: SpecificationD deps a++instance (Show a, Typeable a, Show (TypeSpecD deps a)) => Pretty (WithPrec (SpecificationD deps a)) where+  pretty (WithPrec d s) = case s of+    ExplainSpec es z -> "ExplainSpec" <+> viaShow es <+> "$" /> pretty z+    ErrorSpec es -> "ErrorSpec" /> vsep' (map fromString (NE.toList es))+    TrueSpec -> fromString $ "TrueSpec @(" ++ showType @a ++ ")"+    MemberSpec xs -> "MemberSpec" <+> prettyShowList (NE.toList xs)+    SuspendedSpec x p -> parensIf (d > 10) $ "constrained $ \\" <+> viaShow x <+> "->" /> pretty p+    -- TODO: require pretty for `TypeSpec` to make this much nicer+    TypeSpecD ts cant ->+      parensIf (d > 10) $+        "TypeSpec"+          /> vsep+            [ fromString (showsPrec 11 ts "")+            , prettyShowList cant+            ]++instance (Show a, Typeable a, Show (TypeSpecD deps a)) => Pretty (SpecificationD deps a) where+  pretty = pretty . WithPrec 0++instance (Show a, Typeable a, Show (TypeSpecD deps a)) => Show (SpecificationD deps a) where+  showsPrec d = shows . pretty . WithPrec d
+ src/Constrained/Base.hs view
@@ -0,0 +1,990 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE UndecidableSuperClasses #-}+{-# LANGUAGE ViewPatterns #-}++-- | This module contains the most basic parts the implementation. Essentially+--   everything to define Specification, HasSpec, HasSimpleRep, Term, Pred, and the Syntax,+--   Semantics, and Logic class. It also has a few HasSpec, HasSimpleRep, and Logic+--   instances for basic types needed to define the default types and methods of HasSpec.+--   It also supplies Eq, Pretty, and Show instances on the syntax (Term, Pred, Binder etc.)+--   because many functions require these instances. It exports functions that define the+--   user interface to the domain embedded language (constrained, forall, exists etc.).+--   And, by design, nothing more.+module Constrained.Base (+  -- * Implementing logic propagation+  Logic (..),+  pattern (:<:),+  pattern (:>:),+  pattern Unary,+  Ctx (..),+  toCtx,+  flipCtx,+  fromListCtx,+  ctxHasSpec,++  -- * Useful function symbols and patterns for building custom rewrite rules+  fromGeneric_,+  toGeneric_,+  pattern ToGeneric,+  pattern FromGeneric,++  -- * Syntax for building specifications+  constrained,+  notMemberSpec,+  notEqualSpec,+  typeSpec,+  addToErrorSpec,+  memberSpec,+  fromSimpleRepSpec,+  toSimpleRepSpec,+  explainSpec,++  -- * Instantiated types and helper patterns+  Term,+  Specification,+  Pred,+  Binder,+  pattern TypeSpec,+  pattern GenHint,++  -- * Constraints and classes+  HasSpec (..),+  HasGenHint (..),+  Forallable,+  AppRequires,+  GenericallyInstantiated,+  GenericRequires,++  -- * Building `Pred`, `Specification`, `Term` etc.+  bind,+  name,++  -- * TODO: documentme+  propagateSpec,+  appFun,+  errorLikeMessage,+  isErrorLike,+  BinaryShow (..),+  toPred,+  forAllToList,+  IsPred,+  equalSpec,+  appTerm,+  HOLE (..),+  fromForAllSpec,+  Fun (..),+  BaseW (..),+  Deps,+) where++import Constrained.AbstractSyntax+import Constrained.Core+import Constrained.DependencyInjection+import Constrained.FunctionSymbol+import Constrained.GenT+import Constrained.Generic+import Constrained.List hiding (toList)+import Constrained.TypeErrors+import Data.Foldable (+  toList,+ )+import Data.Kind (Constraint, Type)+import Data.List (nub)+import qualified Data.List.NonEmpty as NE+import Data.Orphans ()+import Data.Semigroup (Max (..), getMax)+import Data.Typeable+import GHC.Stack+import Prettyprinter hiding (cat)+import Test.QuickCheck (arbitrary, shrink)++newtype TypeSpecF a = TypeSpecF (TypeSpec a)++instance Show (TypeSpec a) => Show (TypeSpecF a) where+  show (TypeSpecF ts) = show ts++newtype HintF a = HintF (Hint a)++instance Show (Hint a) => Show (HintF a) where+  show (HintF h) = show h++data Deps++instance Dependencies Deps where+  type HasSpecD Deps = HasSpec+  type TypeSpecD Deps = TypeSpecF+  type LogicD Deps = Logic+  type ForallableD Deps = Forallable+  type HasGenHintD Deps = HasGenHint+  type HintD Deps = HintF++-- | Binders instantiated with the correct `HasSpec` etc. classes+type Binder = BinderD Deps++-- | All the constraints needed for application in the first order term languge+type AppRequires t as b = AppRequiresD Deps t as b++-- | Predicates over `Term`s+type Pred = PredD Deps++-- | First-order language of variables, literals, and application+type Term = TermD Deps++-- | Specifications for generators instantiated with the `HasSpec` et al actual+-- classes+type Specification = SpecificationD Deps++-- | Pattern match out a `TypeSpec` and the can't-"set" - avoids some tedious+-- pitfalls related to the `Deps` and `Dependencies` trick+pattern TypeSpec :: () => HasSpec a => TypeSpec a -> [a] -> Specification a+pattern TypeSpec ts cant = TypeSpecD (TypeSpecF ts) cant++{-# COMPLETE ExplainSpec, MemberSpec, ErrorSpec, SuspendedSpec, TypeSpec, TrueSpec #-}++-- | Build a specifiation from just a `TypeSpec`, useful internal function when+-- writing `Logic` instances+typeSpec :: HasSpec a => TypeSpec a -> Specification a+typeSpec ts = TypeSpec ts mempty++-- | Pattern match out a `Hint` and the `Term` it applies to - avoids some+-- tedious pitfalls related to the `Deps` and `Dependencies` trick+pattern GenHint :: () => HasGenHint a => Hint a -> Term a -> Pred+pattern GenHint h t = GenHintD (HintF h) t++{-# COMPLETE+  ElemPred+  , Monitor+  , And+  , Exists+  , Subst+  , Let+  , Assert+  , Reifies+  , DependsOn+  , ForAll+  , Case+  , When+  , GenHint+  , TruePred+  , FalsePred+  , Explain+  #-}++-- ====================================================================++-- A First-order typed logic has 4 components+--     1. Terms        (Variables (x), Constants (5), and Applications (F x 5)+--        Applications, apply a function symbol to a list of arguments: (FunctionSymbol term1 .. termN)+--     2. Predicates   (Ordered, Odd, ...)+--     3. Connectives  (And, Or, Not, =>, ...)+--     4. Quantifiers  (Forall, Exists)+--+-- The Syntax, Semantics, and Logic classes implement new function symbols in+-- the first order logic. Note that a function symbol is first order+-- data, that uniquely identifies a higher order function. The three classes+-- supply varying levels of functionality, relating to the Syntax, Semantics, and+-- Logical operations of the function symbol.++-- | Logical operations are one that support reasoning about how a function symbol+--   relates to logical properties, that we call Specification's+class (Typeable t, Semantics t, Syntax t) => Logic t where+  {-# MINIMAL propagate | (propagateTypeSpec, propagateMemberSpec) #-}++  propagateTypeSpec ::+    (AppRequires t as b, HasSpec a) =>+    t as b ->+    ListCtx Value as (HOLE a) ->+    TypeSpec b ->+    [b] ->+    Specification a+  propagateTypeSpec f ctx ts cant = propagate f ctx (TypeSpec ts cant)++  propagateMemberSpec ::+    (AppRequires t as b, HasSpec a) =>+    t as b ->+    ListCtx Value as (HOLE a) ->+    NonEmpty b ->+    Specification a+  propagateMemberSpec f ctx xs = propagate f ctx (MemberSpec xs)++  propagate ::+    (AppRequires t as b, HasSpec a) =>+    t as b ->+    ListCtx Value as (HOLE a) ->+    Specification b ->+    Specification a+  propagate f ctx (ExplainSpec es s) = explainSpec es (propagate f ctx s)+  propagate _ _ TrueSpec = TrueSpec+  propagate _ _ (ErrorSpec es) = ErrorSpec es+  propagate f ctx (SuspendedSpec v ps) = constrained $ \v' -> Let (App f (fromListCtx ctx v')) (v :-> ps) :: Pred+  propagate f ctx (TypeSpec ts cant) = propagateTypeSpec f ctx ts cant+  propagate f ctx (MemberSpec xs) = propagateMemberSpec f ctx xs++  rewriteRules ::+    (TypeList dom, Typeable dom, HasSpec rng, All HasSpec dom) =>+    t dom rng ->+    List Term dom ->+    Evidence (AppRequires t dom rng) ->+    Maybe (Term rng)+  rewriteRules _ _ _ = Nothing++  mapTypeSpec ::+    forall a b.+    (HasSpec a, HasSpec b) =>+    t '[a] b ->+    TypeSpec a ->+    Specification b+  mapTypeSpec _ts _spec = TrueSpec++  saturate :: t dom Bool -> List Term dom -> [Pred]+  saturate _symbol _ = []++-- | This is where the logical properties of a function symbol are applied to transform one spec into another+-- Note if there is a bunch of functions nested together, like (sizeOf_ (elems_ (snd_ x)))+-- we propagate each of those nested function symbols over the current spec, one at a time.+-- The result of this propagation is then made the current spec in the recusive calls to 'propagateSpec'+propagateSpec ::+  forall v a.+  HasSpec v =>+  Specification a ->+  Ctx v a ->+  Specification v+propagateSpec spec = \case+  CtxHOLE -> spec+  CtxApp f (ListCtx pre c suf)+    | Evidence <- ctxHasSpec c -> propagateSpec (propagate f (ListCtx pre HOLE suf) spec) c++ctxHasSpec :: Ctx v a -> Evidence (HasSpec a)+ctxHasSpec CtxHOLE = Evidence+ctxHasSpec CtxApp {} = Evidence++-- | Contexts for Terms, basically a term with a _single_ HOLE+-- instead of a variable. This is used to traverse the defining+-- constraints for a variable and turn them into a spec. Each+-- subterm `f vs Ctx vs'` for lists of values `vs` and `vs'`+-- gets given to the `propagateSpecFun` for `f` as  `(f vs HOLE vs')`.+data Ctx v a where+  -- | A single hole of type `v`. Note ctxHOLE is a nullary constructor, where the `a` type index is the same as the `v` type index.+  CtxHOLE ::+    HasSpec v =>+    Ctx v v+  -- | The application `f vs Ctx vs'`+  CtxApp ::+    ( AppRequires fn as b+    , HasSpec b+    , TypeList as+    , Typeable as+    , All HasSpec as+    , Logic fn+    ) =>+    fn as b ->+    -- This is basically a `List` where+    -- everything is `Value` except for+    -- one entry which is `Ctx fn v`.+    ListCtx Value as (Ctx v) ->+    Ctx v b++-- | This is used together with `ListCtx` to form+-- just the arguments to `f vs Ctx vs'` - replacing+-- `Ctx` with `HOLE`, to get a `ListCtx Value as (HOLE a)` which then can be used as an input to `propagate`.+data HOLE a b where+  HOLE :: HOLE a a++-- | Try to convert a `Term` to a single-hole context - works only if the `Var`+-- is the _only_ variable in the term _and_ it appears only once in the `Term`.+toCtx ::+  forall m v a.+  ( Typeable v+  , Show v+  , MonadGenError m+  , HasCallStack+  ) =>+  Var v ->+  Term a ->+  m (Ctx v a)+toCtx v = go+  where+    go :: forall b. Term b -> m (Ctx v b)+    go (Lit i) =+      fatalErrorNE $+        NE.fromList+          [ "toCtx applied to literal: (Lit " ++ show i ++ ")"+          , "A context is always constructed from an (App f xs) term."+          ]+    go (App f as) = CtxApp f <$> toCtxList v as+    go (V v')+      | Just Refl <- eqVar v v' = pure $ CtxHOLE+      | otherwise =+          fatalErrorNE $+            NE.fromList+              [ "A context is always constructed from an (App f xs) term,"+              , "with a single occurence of the variable " ++ show v ++ "@(" ++ show (typeOf v) ++ ")"+              , "Instead we found an unknown variable " ++ show v' ++ "@(" ++ show (typeOf v') ++ ")"+              ]++-- | `toCtx` lifted to a `List` of `Term`s+toCtxList ::+  forall m v as.+  (Show v, Typeable v, MonadGenError m, HasCallStack) =>+  Var v ->+  List Term as ->+  m (ListCtx Value as (Ctx v))+toCtxList v xs = prefix xs+  where+    prefix :: forall as'. HasCallStack => List Term as' -> m (ListCtx Value as' (Ctx v))+    prefix Nil = fatalError ("toCtxList without hole, for variable " ++ show v)+    prefix (Lit l :> ts) = do+      ctx <- prefix ts+      pure $ Value l :! ctx+    prefix (t :> ts) = do+      hole <- toCtx v t+      suf <- suffix ts+      pure $ hole :? suf++    suffix :: forall as'. List Term as' -> m (List Value as')+    suffix Nil = pure Nil+    suffix (Lit l :> ts) = (Value l :>) <$> suffix ts+    suffix (_ :> _) = fatalErrorNE $ NE.fromList ["toCtxList with too many holes, for variable " ++ show v]++-- | A Convenient pattern for singleton contexts+pattern Unary :: HOLE a' a -> ListCtx f '[a] (HOLE a')+pattern Unary h = NilCtx h++{-# COMPLETE Unary #-}++-- | Convenient patterns for binary contexts (the arrow :<: points towards the hole)+pattern (:<:) :: (Typeable b, Show b) => HOLE c a -> b -> ListCtx Value '[a, b] (HOLE c)+pattern h :<: a = h :? Value a :> Nil++-- | Convenient patterns for binary contexts (the arrow :>: points towards the hole)+pattern (:>:) :: (Typeable a, Show a) => a -> HOLE c b -> ListCtx Value '[a, b] (HOLE c)+pattern a :>: h = Value a :! NilCtx h++{-# COMPLETE (:<:), (:>:) #-}++-- | Flip a binary context around+flipCtx ::+  (Typeable a, Show a, Typeable b, Show b) =>+  ListCtx Value '[a, b] (HOLE c) -> ListCtx Value '[b, a] (HOLE c)+flipCtx (HOLE :<: x) = x :>: HOLE+flipCtx (x :>: HOLE) = HOLE :<: x++-- | From a ListCtx, build a (List Term as), to which the function symbol can be applied.+fromListCtx :: All HasSpec as => ListCtx Value as (HOLE a) -> Term a -> List Term as+fromListCtx ctx t = fillListCtx (mapListCtxC @HasSpec (\(Value a) -> Lit a) ctx) (\HOLE -> t)++-- =================================================================+-- The class (HasSpec a) tells us what operations type 'a' must+-- support to add it to the constraint solver and generator+-- Writing HasSpec instances gives the system the power to grow+-- Don't be afraid of all the methods. Most have default implementations.+-- =================================================================++-- | A type where the `HasSpec` instance has been instantiated via the `SimpleRep` with+-- constraints that give good type errors+type GenericallyInstantiated a =+  ( AssertComputes+      (SimpleRep a)+      ( Text "Trying to use a generic instantiation of "+          :<>: ShowType a+          :<>: Text ", likely in a HasSpec instance."+          :$$: Text+                 "However, the type has no definition of SimpleRep, likely because of a missing instance of HasSimpleRep."+      )+  , HasSimpleRep a+  , HasSpec (SimpleRep a)+  , TypeSpec a ~ TypeSpec (SimpleRep a)+  )++-- | `Eq` and `Show` for `TypeSpec` with additional constraints to ensure good type errors+type TypeSpecEqShow a =+  ( AssertComputes+      (TypeSpec a)+      ( Text "Can't compute "+          :<>: ShowType (TypeSpec a)+          :$$: Text "Either because of a missing definition of TypeSpec or a missing instance of HasSimpleRep."+      )+  , Show (TypeSpec a)+  , Typeable (TypeSpec a)+  )++{- NOTE: type errors in constrained-generators+    It's easy to make a mistake like this:+      data Bad = Bad | Worse deriving (Eq, Show)+      instance HasSpec Bad+    Missing that this requires an instance of HasSimpleRep for Bad to work.+    The two `AssertComputes` uses above are here to give you better error messages when you make this mistake,+    e.g. giving you something like this:+      src/Constrained/Examples/Basic.hs:327:10: error: [GHC-64725]+          • Can't compute TypeSpec (SimpleRep Bad)+            Either because of a missing definition of TypeSpec or a missing instance of HasSimpleRep.+          • In the instance declaration for ‘HasSpec Bad’+          |+      327 | instance HasSpec Bad+          |          ^^^^^^^^^^^++      src/Constrained/Examples/Basic.hs:327:10: error: [GHC-64725]+          • Trying to use a generic instantiation of Bad, likely in a HasSpec instance.+            However, the type has no definition of SimpleRep, likely because of a missing instance of HasSimpleRep.+          • In the expression: Constrained.Base.$dmemptySpec @(Bad)+            In an equation for ‘emptySpec’:+                emptySpec = Constrained.Base.$dmemptySpec @(Bad)+            In the instance declaration for ‘HasSpec Bad’+          |+      327 | instance HasSpec Bad+          |          ^^^^^^^^^^^+-}++-- | Class for talking about types that we can write `Specification`s about+class+  ( Typeable a+  , Eq a+  , Show a+  , TypeSpecEqShow a+  ) =>+  HasSpec a+  where+  -- | The `TypeSpec a` is the type-specific `Specification a`.+  type TypeSpec a++  type TypeSpec a = TypeSpec (SimpleRep a)++  -- `TypeSpec` behaves sort-of like a monoid with a neutral+  -- element `emptySpec` and a `combineSpec` for combining+  -- two `TypeSpec a`. However, in order to provide flexibilty+  -- `combineSpec` takes two `TypeSpec` and constucts a `Specification`. This+  -- avoids e.g. having to have a separate implementation of `ErrorSpec`+  -- and `MemberSpec` in `TypeSpec`.++  -- | Trivial `TypeSpec` that admits anything+  emptySpec :: TypeSpec a++  -- | Conjunction of two `TypeSpec`s+  combineSpec :: TypeSpec a -> TypeSpec a -> Specification a++  -- | Generate a value that satisfies the `TypeSpec`.+  -- The key property for this generator is soundness:+  --  ∀ a ∈ genFromTypeSpec spec. a `conformsTo` spec+  genFromTypeSpec :: (HasCallStack, MonadGenError m) => TypeSpec a -> GenT m a++  -- | Check conformance to the spec.+  conformsTo :: HasCallStack => a -> TypeSpec a -> Bool++  -- | Shrink an `a` with the aide of a `TypeSpec`+  shrinkWithTypeSpec :: TypeSpec a -> a -> [a]++  -- | Try to make an `a` conform to `TypeSpec` with minimal changes. When+  -- `fixupWithSpec ts a` returns `Just a'`, it should be the case that+  -- `conformsTo a' ts`. There are no constraints in the `Nothing` case. A+  -- non-trivial implementation of this function is important for shrinking.+  fixupWithTypeSpec :: TypeSpec a -> a -> Maybe a++  -- | Convert a spec to predicates:+  -- The key property here is:+  --   ∀ a. a `conformsTo` spec == a `conformsTo` constrained (\t -> toPreds t spec)+  toPreds :: Term a -> TypeSpec a -> Pred++  -- | Compute an upper and lower bound on the number of solutions genFromTypeSpec might return+  cardinalTypeSpec :: TypeSpec a -> Specification Integer++  -- | A bound on the number of solutions `genFromTypeSpec TrueSpec` can produce.+  --   For a type with finite elements, we can get a much more accurate+  --   answer than TrueSpec+  cardinalTrueSpec :: Specification Integer+  cardinalTrueSpec = TrueSpec++  -- Each instance can decide if a TypeSpec has an Error, and what String+  -- to pass to ErrorSpec to create an ErrorSpec value. Particulary+  -- useful for type Sum and Prod. The default instance uses guardTypeSpec,+  -- which also has a default value, and if that defualt value is used, typeSpecHasError will+  -- return Nothing. Both 'typeSpecHasError' and 'guardTypeSpec' can be set individually.+  -- If you're only writing one of these non default values, give it to 'guardTypeSpec'+  typeSpecHasError :: TypeSpec a -> Maybe (NE.NonEmpty String)+  typeSpecHasError tspec = case guardTypeSpec @a [] tspec of+    ErrorSpec msgs -> Just msgs+    _ -> Nothing++  -- Some binary TypeSpecs, which nest to the right+  -- e.g. something like this (X a (TypeSpec (X b (TypeSpec (X c w))))))+  -- An would look better in Vertical mode as (X [a,b,c] m).+  -- This lets each HasSpec instance decide. Particulary useful for type Sum and Prod+  alternateShow :: TypeSpec a -> BinaryShow+  alternateShow _ = NonBinary++  -- | 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.+  typeSpecOpt :: TypeSpec a -> [a] -> Specification a+  typeSpecOpt tySpec bad = TypeSpec tySpec bad++  -- | This can be used to detect self inconsistencies in a (TypeSpec t)+  --   Note this is similar to 'typeSpecHasError', and the default+  --   value for 'typeSpecHasError' is written in terms of 'guardTypeSpec'+  --   Both 'typeSpecHasError' and 'guardTypeSpec' can be set individually.+  guardTypeSpec :: [String] -> TypeSpec a -> Specification a+  guardTypeSpec _ ty = typeSpec ty++  -- | Prerequisites for the instance that are sometimes necessary+  -- when working with e.g. `Specification`s or functions in the universe.+  type Prerequisites a :: Constraint++  type Prerequisites a = ()++  -- | Materialize the `Prerequisites` dictionary. It should not be necessary to+  -- implement this function manually.+  prerequisites :: Evidence (Prerequisites a)+  default prerequisites :: Prerequisites a => Evidence (Prerequisites a)+  prerequisites = Evidence++  {- NOTE: Below follows default implementations for the functions in this+     class based on Generics.  They are meant to provide an implementation of+     `HasSpec a` when `HasSimpleRep a` and `HasSpec (SimpleRep a)`. For example,+     for a newtype wrapper like `newtype Foo = Foo Word64` we can define `SimpleRep+     Foo = Word64` with the requisite instance for `HasSimpleRep` (all of which+     is derived from `Generic Foo`) and the instance for `HasSpec Foo` is+     essentially the same as the instance for `Word64`. This is achieved by+     ensuring that `TypeSpec Foo = TypeSpec Word64` (c.f. the default+     implementation of `TypeSpec` above). To this end, the implementations+     below simply convert the relevant things between `SimpleRep a` and `a`.+     For example, in the implementation of `combineSpec s s'` we treat `s` and+     `s'` (which have type `TypeSpec a`) as `TypeSpec (SimpleRep a)`,+     combine them, and go from the resulting `Specification (SimpleRep a)` to `Specification+     a` using `fromSimpleRepSpec`.+   -}++  default emptySpec :: GenericallyInstantiated a => TypeSpec a+  emptySpec = emptySpec @(SimpleRep a)++  default combineSpec ::+    GenericallyInstantiated a =>+    TypeSpec a ->+    TypeSpec a ->+    Specification a+  combineSpec s s' = fromSimpleRepSpec $ combineSpec @(SimpleRep a) s s'++  default genFromTypeSpec ::+    (GenericallyInstantiated a, HasCallStack, MonadGenError m) =>+    TypeSpec a ->+    GenT m a+  genFromTypeSpec s = fromSimpleRep <$> genFromTypeSpec s++  default conformsTo ::+    (GenericallyInstantiated a, HasCallStack) =>+    a ->+    TypeSpec a ->+    Bool+  a `conformsTo` s = conformsTo (toSimpleRep a) s++  default toPreds ::+    GenericallyInstantiated a =>+    Term a ->+    TypeSpec a ->+    Pred+  toPreds v s = toPreds (toGeneric_ v) s++  default shrinkWithTypeSpec ::+    GenericallyInstantiated a =>+    TypeSpec a ->+    a ->+    [a]+  shrinkWithTypeSpec spec a = map fromSimpleRep $ shrinkWithTypeSpec spec (toSimpleRep a)++  default fixupWithTypeSpec ::+    GenericallyInstantiated a =>+    TypeSpec a ->+    a ->+    Maybe a+  fixupWithTypeSpec spec a = fromSimpleRep <$> fixupWithTypeSpec spec (toSimpleRep a)++  default cardinalTypeSpec ::+    GenericallyInstantiated a =>+    TypeSpec a ->+    Specification Integer+  cardinalTypeSpec = cardinalTypeSpec @(SimpleRep a)++------------------------------------------------------------------------+-- Some instances of HasSpec+------------------------------------------------------------------------++-- | NOTE: this instance means we have to use `ifElse`, `whenTrue`, and `whenFalse` instead+-- of `caseOn` for `Bool`+instance HasSpec Bool where+  type TypeSpec Bool = ()+  emptySpec = ()+  combineSpec _ _ = typeSpec ()+  genFromTypeSpec _ = pureGen arbitrary+  cardinalTypeSpec _ = equalSpec 2+  cardinalTrueSpec = equalSpec 2+  shrinkWithTypeSpec _ = shrink+  fixupWithTypeSpec _ = Just+  conformsTo _ _ = True+  toPreds _ _ = TruePred+  typeSpecOpt _ [] = TrueSpec+  typeSpecOpt _ (nub -> [b]) = equalSpec (not b)+  typeSpecOpt _ _ = ErrorSpec $ pure "inconsistent bool spec"++instance HasSpec () where+  type TypeSpec () = ()+  emptySpec = ()+  combineSpec _ _ = typeSpec ()+  _ `conformsTo` _ = True+  shrinkWithTypeSpec _ _ = []+  fixupWithTypeSpec _ _ = pure ()+  genFromTypeSpec _ = pure ()+  toPreds _ _ = TruePred+  cardinalTypeSpec _ = MemberSpec (pure 1)+  cardinalTrueSpec = equalSpec 1+  typeSpecOpt _ [] = TrueSpec+  typeSpecOpt _ (_ : _) = ErrorSpec (pure "Non null 'cant' set in typeSpecOpt @()")++-- ===================================================================+-- toGeneric and fromGeneric as Function Symbols+-- That means they can be used inside (Term a)+-- ===================================================================++-- | The things you need to know to work with the generics which translates things+-- into their SimpleRep, made of Sum and Prod+type GenericRequires a =+  ( HasSpec a -- This gives Show, Eq, and Typeable instances+  , GenericallyInstantiated a+  )++-- | The constructors of BaseW, are first order data (i.e Function Symbols) that describe functions.+-- The Base functions are just the functions neccessary to define Specification, and the classes+-- HasSimpleRep, HasSpec, Syntax, Semantics, and Logic. We call BaseW a 'witness type', and use+-- the convention that all witness types (and their constructors) have "W" as thrit last character.+data BaseW (dom :: [Type]) (rng :: Type) where+  ToGenericW :: GenericRequires a => BaseW '[a] (SimpleRep a)+  FromGenericW :: GenericRequires a => BaseW '[SimpleRep a] a++deriving instance Eq (BaseW dom rng)++instance Show (BaseW d r) where+  show ToGenericW = "toSimpleRep"+  show FromGenericW = "fromSimpleRep"++instance Syntax BaseW++instance Semantics BaseW where+  semantics FromGenericW = fromSimpleRep+  semantics ToGenericW = toSimpleRep++-- -- ============== ToGenericW Logic instance++instance Logic BaseW where+  propagateTypeSpec ToGenericW (Unary HOLE) s cant = TypeSpec s (fromSimpleRep <$> cant)+  propagateTypeSpec FromGenericW (Unary HOLE) s cant = TypeSpec s (toSimpleRep <$> cant)++  propagateMemberSpec ToGenericW (Unary HOLE) es = MemberSpec (fmap fromSimpleRep es)+  propagateMemberSpec FromGenericW (Unary HOLE) es = MemberSpec (fmap toSimpleRep es)++  mapTypeSpec ToGenericW ts = typeSpec ts+  mapTypeSpec FromGenericW ts = typeSpec ts++  rewriteRules ToGenericW (FromGeneric x :> Nil) Evidence = Just x+  rewriteRules (FromGenericW :: BaseW dom rng) (ToGeneric (x :: Term a) :> Nil) Evidence+    | Just Refl <- eqT @rng @a = Just x+  rewriteRules _ _ _ = Nothing++-- | Convert an @a@ to a @`SimpleRep` a@+toGeneric_ ::+  forall a.+  GenericRequires a =>+  Term a ->+  Term (SimpleRep a)+toGeneric_ = appTerm ToGenericW++-- | Convert an @`SimpleRep` a@ to an @a@+fromGeneric_ ::+  forall a.+  (GenericRequires a, AppRequires BaseW '[SimpleRep a] a) =>+  Term (SimpleRep a) ->+  Term a+fromGeneric_ = appTerm FromGenericW++-- ====================================================================+-- Generic Transformers+-- Using Generics to transform from ordinary (Specifications a) to+-- Specifications over 'a's SimpleRep (Specification (SimpleRep a))+-- ====================================================================++-- | Convert a `Specification` for a @`SimpleRep` a@ to one for @a@+fromSimpleRepSpec ::+  GenericRequires a =>+  Specification (SimpleRep a) ->+  Specification a+fromSimpleRepSpec = \case+  ExplainSpec es s -> explainSpec es (fromSimpleRepSpec s)+  TrueSpec -> TrueSpec+  ErrorSpec e -> ErrorSpec e+  TypeSpec s'' cant -> TypeSpec s'' $ map fromSimpleRep cant+  MemberSpec elems -> MemberSpec $ NE.nub (fmap fromSimpleRep elems)+  SuspendedSpec x p ->+    constrained $ \x' ->+      Let (toGeneric_ x') (x :-> p) :: Pred++-- | Convert a @`Specification` a@ to one for @`SimpleRep` a@+toSimpleRepSpec ::+  forall a.+  GenericRequires a =>+  Specification a ->+  Specification (SimpleRep a)+toSimpleRepSpec = \case+  ExplainSpec es s -> explainSpec es (toSimpleRepSpec s)+  TrueSpec -> TrueSpec+  ErrorSpec e -> ErrorSpec e+  TypeSpec s'' cant -> TypeSpec s'' $ map toSimpleRep cant+  MemberSpec elems -> MemberSpec $ NE.nub $ fmap toSimpleRep elems+  SuspendedSpec x p ->+    constrained $ \x' ->+      Let (fromGeneric_ x') (x :-> p) :: Pred++-- =====================================================================+-- Now the supporting operations and types.+-- =====================================================================++-- | Used to show binary operators like SumSpec and PairSpec+data BinaryShow where+  BinaryShow :: forall a. String -> [Doc a] -> BinaryShow+  NonBinary :: BinaryShow++-- =================================================+-- Term++-- | Like 'appSym' but builds functions over terms, rather that just one App term.+appTerm ::+  forall t ds r.+  AppRequires t ds r =>+  t ds r ->+  FunTy (MapList Term ds) (Term r)+appTerm sym = curryList @ds (App @Deps @t @ds @r sym)++-- | Give a `Term` a `String` name-hint _if_ the `Term` is a variable+name :: String -> Term a -> Term a+name nh (V (Var i _)) = V (Var i nh)+name _ _ = error "applying name to non-var thing! Shame on you!"++-- | Create a `Binder` with a fresh variable, used in e.g. `constrained`+bind :: (HasSpec a, IsPred p) => (Term a -> p) -> Binder a+bind bodyf = newv :-> bodyPred+  where+    bodyPred = toPred body+    newv = Var (nextVar bodyPred) "v"+    body = bodyf (V newv)++    nextVar q = 1 + bound q++    boundBinder :: Binder a -> Int+    boundBinder (x :-> p) = max (nameOf x) (bound p)++    bound (Explain _ p) = bound p+    bound (Subst x _ p) = max (nameOf x) (bound p)+    bound (And ps) = maximum $ (-1) : map bound ps -- (-1) as the default to get 0 as `nextVar p`+    bound (Exists _ b) = boundBinder b+    bound (Let _ b) = boundBinder b+    bound (ForAll _ b) = boundBinder b+    bound (Case _ cs) = getMax $ foldMapList (Max . boundBinder . thing) cs+    bound (When _ p) = bound p+    bound Reifies {} = -1+    bound GenHintD {} = -1+    bound Assert {} = -1+    bound DependsOn {} = -1+    bound TruePred = -1+    bound FalsePred {} = -1+    bound Monitor {} = -1+    bound ElemPred {} = -1++-- ==================================================+-- Pred++-- | A collection @t@ with elements of type @e@ where the `forAll` syntax will+-- work+class Forallable t e | t -> e where+  -- | Lift the `Specification` for the elements to the collection+  fromForAllSpec ::+    (HasSpec t, HasSpec e) => Specification e -> Specification t+  default fromForAllSpec ::+    ( HasSpec e+    , Forallable (SimpleRep t) e+    , GenericRequires t+    ) =>+    Specification e ->+    Specification t+  fromForAllSpec es = fromSimpleRepSpec $ fromForAllSpec @(SimpleRep t) @e es++  -- | Get the underlying items in the collection+  forAllToList :: t -> [e]+  default forAllToList ::+    ( HasSimpleRep t+    , Forallable (SimpleRep t) e+    ) =>+    t ->+    [e]+  forAllToList t = forAllToList (toSimpleRep t)++-- ===========================================+-- IsPred++-- | Something from which we can construct a `Pred`, useful for providing+-- flexible syntax for `constrained` and friends.+class Show p => IsPred p where+  -- | Convert to a `Pred`+  toPred :: p -> Pred++instance IsPred Pred where+  toPred (Assert (Lit False)) = FalsePred (pure "toPred(Lit False)")+  toPred (Assert (Lit True)) = TruePred+  toPred (Explain xs p) = Explain xs (toPred p)+  toPred (And ps) = And (map toPred ps)+  toPred x = x++instance IsPred p => IsPred [p] where+  toPred xs = And (map toPred xs)++instance IsPred Bool where+  toPred True = TruePred+  toPred False = FalsePred (pure "toPred False")++instance IsPred (Term Bool) where+  toPred (Lit b) = toPred b+  toPred term = Assert term++-- ============================================================+-- Simple Widely used operations on Specification++-- | return a MemberSpec or ans ErrorSpec depending on if 'xs' is null or not+memberSpec :: Foldable f => f a -> NE.NonEmpty String -> Specification a+memberSpec (toList -> xs) messages =+  case NE.nonEmpty xs of+    Nothing -> ErrorSpec messages+    Just ys -> MemberSpec ys++-- | Attach an explanation to a specification in order to track issues with satisfiability+explainSpec :: [String] -> Specification a -> Specification a+explainSpec [] x = x+explainSpec es (ExplainSpec es' spec) = ExplainSpec (es ++ es') spec+explainSpec es spec = ExplainSpec es spec++-- | A "discrete" specification satisfied by exactly one element+equalSpec :: a -> Specification a+equalSpec = MemberSpec . pure++-- | Anything but this+notEqualSpec :: forall a. HasSpec a => a -> Specification a+notEqualSpec = typeSpecOpt (emptySpec @a) . pure++-- | Anything but these+notMemberSpec :: forall a f. (HasSpec a, Foldable f) => f a -> Specification a+notMemberSpec = typeSpecOpt (emptySpec @a) . toList++-- | Build a `Specification` using predicates, e.g.+-- > constrained $ \ x -> assert $ x `elem_` lit [1..10 :: Int]+constrained ::+  forall a p.+  (IsPred p, HasSpec a) =>+  (Term a -> p) ->+  Specification a+constrained body =+  let x :-> p = bind body+   in SuspendedSpec x p++-- | Sound but not complete check for empty `Specification`s+isErrorLike :: forall a. Specification a -> Bool+isErrorLike (ExplainSpec _ s) = isErrorLike s+isErrorLike ErrorSpec {} = True+isErrorLike (TypeSpec x _) =+  case typeSpecHasError @a x of+    Nothing -> False+    Just _ -> True+isErrorLike _ = False++-- | Get the error message of an `isErrorLike` `Specification`+errorLikeMessage :: forall a. Specification a -> NE.NonEmpty String+errorLikeMessage (ErrorSpec es) = es+errorLikeMessage (TypeSpec x _) =+  case typeSpecHasError @a x of+    Nothing -> pure ("Bad call to errorLikeMessage case 1, not guarded by isErrorLike")+    Just xs -> xs+errorLikeMessage _ = pure ("Bad call to errorLikeMessage, case 2, not guarded by isErrorLike")++-- | Add the explanations, if it's an ErrorSpec, else drop them+addToErrorSpec :: NE.NonEmpty String -> Specification a -> Specification a+addToErrorSpec es (ExplainSpec [] x) = addToErrorSpec es x+addToErrorSpec es (ExplainSpec es2 x) = ExplainSpec es2 (addToErrorSpec es x)+addToErrorSpec es (ErrorSpec es') = ErrorSpec (es <> es')+addToErrorSpec _ s = s++------------------------------------------------------------------------+-- Pretty and Show instances+------------------------------------------------------------------------++-- | The Fun type encapuslates a Logic instance and symbol universe type to+-- hide everything but the domain and range. This is a way to pass around+-- functions without pain. Usefull in the ListFoldy implementaion that deals+-- with higher order functions.+data Fun dom rng where+  Fun ::+    forall t dom rng.+    AppRequires t dom rng =>+    t dom rng ->+    Fun dom rng++instance Show (Fun dom r) where+  show (Fun (f :: t dom rng)) = "(Fun " ++ show f ++ ")"++-- | Apply a single-argument `Fun` to a `Term`+appFun :: Fun '[x] b -> Term x -> Term b+appFun (Fun f) x = App f (x :> Nil)++sameFun :: Fun d1 r1 -> Fun d2 r2 -> Bool+sameFun (Fun f) (Fun g) = case cast f of+  Just f' -> f' == g+  Nothing -> False++instance Eq (Fun d r) where+  (==) = sameFun++-- | Pattern-match on an application of `fromGeneric_`, useful for writing+-- custom rewrite rules to help the solver+pattern FromGeneric ::+  forall rng.+  () =>+  forall a.+  (rng ~ a, GenericRequires a, HasSpec a, AppRequires BaseW '[SimpleRep a] rng) =>+  Term (SimpleRep a) ->+  Term rng+pattern FromGeneric x <-+  (App (getWitness -> Just FromGenericW) (x :> Nil))++-- | Pattern-match on an application of `toGeneric_`, useful for writing custom+-- rewrite rules to help the solver+pattern ToGeneric ::+  forall rng.+  () =>+  forall a.+  (rng ~ SimpleRep a, GenericRequires a, HasSpec a, AppRequires BaseW '[a] rng) =>+  Term a ->+  Term rng+pattern ToGeneric x <- (App (getWitness -> Just ToGenericW) (x :> Nil))++-- | Hints are things that only affect generation, and not validation. For instance, parameters to+--   control distribution of generated values.+class (HasSpec a, Show (Hint a)) => HasGenHint a where+  type Hint a+  giveHint :: Hint a -> Specification a
+ src/Constrained/Conformance.hs view
@@ -0,0 +1,284 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+-- Semigroup (Specification a), Monoid (Specification a)+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Functions primarily for checking that a value conforms to a+-- `Specification`+module Constrained.Conformance (+  monitorSpec,+  conformsToSpec,+  conformsToSpecE,+  allConformToSpec,+  satisfies,+  checkPredE,+  checkPredsE,+) where++import Constrained.AbstractSyntax+import Constrained.Base+import Constrained.Core+import Constrained.Env+import Constrained.Env qualified as Env+import Constrained.GenT+import Constrained.List+import Constrained.PrettyUtils+import Constrained.Syntax+import Data.List (intersect, nub)+import Data.List.NonEmpty qualified as NE+import Data.Maybe+import Data.Semigroup (sconcat)+import Data.Set (Set)+import Data.Set qualified as Set+import Prettyprinter hiding (cat)+import Test.QuickCheck (Property, Testable, property)++-- ==========================================================++-- | 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)+--   If it does, then it returns Nothing+checkPredsE ::+  NE.NonEmpty String ->+  Env ->+  [Pred] ->+  Maybe (NE.NonEmpty String)+checkPredsE msgs env ps =+  case catMaybes (fmap (checkPredE env msgs) ps) of+    [] -> Nothing+    (x : xs) -> Just (NE.nub (sconcat (x NE.:| xs)))++-- | 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) ->+    case runTermE env t of+      Left message -> Just (msgs <> message)+      Right v -> case (elem v xs, bool) of+        (True, True) -> Nothing+        (True, False) -> Just ("notElemPred reduces to True" :| [show p])+        (False, True) -> Just ("elemPred reduces to False" :| [show p])+        (False, False) -> Nothing+  Monitor {} -> Nothing+  Subst x t p -> checkPredE env msgs $ substitutePred x t p+  Assert t -> case runTermE env t of+    Right True -> Nothing+    Right False ->+      Just+        (msgs <> pure ("Assert " ++ show t ++ " returns False") <> pure ("\nenv=\n" ++ show (pretty env)))+    Left es -> Just (msgs <> es)+  GenHint {} -> Nothing+  p@(Reifies t' t f) ->+    case runTermE env t of+      Left es -> Just (msgs <> NE.fromList ["checkPredE: Reification fails", "  " ++ show p] <> es)+      Right val -> case runTermE env t' of+        Left es -> Just (msgs <> NE.fromList ["checkPredE: Reification fails", "  " ++ show p] <> es)+        Right val' ->+          if f val == val'+            then Nothing+            else+              Just+                ( msgs+                    <> NE.fromList+                      [ "checkPredE: Reification doesn't match up"+                      , "  " ++ show p+                      , show (f val) ++ " /= " ++ show val'+                      ]+                )+  ForAll t (x :-> p) -> case runTermE env t of+    Left es -> Just $ (msgs <> NE.fromList ["checkPredE: ForAll fails to run."] <> es)+    Right set ->+      let answers =+            catMaybes+              [ checkPredE env' (pure "Some items in ForAll fail") p+              | v <- forAllToList set+              , let env' = Env.extend x v env+              ]+       in case answers of+            [] -> Nothing+            (y : ys) -> Just (NE.nub (sconcat (y NE.:| ys)))+  Case t bs -> case runTermE env t of+    Right v -> runCaseOn v (mapList thing bs) (\x val ps -> checkPredE (Env.extend x val env) msgs ps)+    Left es -> Just (msgs <> pure "checkPredE: Case fails" <> es)+  When bt p -> case runTermE env bt of+    Right b -> if b then checkPredE env msgs p else Nothing+    Left es -> Just (msgs <> pure "checkPredE: When fails" <> es)+  TruePred -> Nothing+  FalsePred es -> Just (msgs <> pure "checkPredE: FalsePred" <> es)+  DependsOn {} -> Nothing+  And ps ->+    case catMaybes (fmap (checkPredE env (pure "Some items in And  fail")) ps) of+      [] -> Nothing+      (x : xs) -> Just (msgs <> NE.nub (sconcat (x NE.:| xs)))+  Let t (x :-> p) -> case runTermE env t of+    Right val -> checkPredE (Env.extend x val env) msgs p+    Left es -> Just (msgs <> pure "checkPredE: Let fails" <> es)+  Exists k (x :-> p) ->+    let eval :: forall b. Term b -> b+        eval term = case runTermE env term of+          Right v -> v+          Left es -> error $ unlines $ NE.toList (msgs <> es)+     in case k eval of+          Result a -> checkPredE (Env.extend x a env) msgs p+          FatalError es -> Just (msgs <> catMessageList es)+          GenError es -> Just (msgs <> catMessageList es)+  Explain es p -> checkPredE env (msgs <> es) p++-- | @conformsToSpec@ with explanation. Nothing if (conformsToSpec a spec),+--   but (Just explanations) if not(conformsToSpec a spec).+conformsToSpecE ::+  forall a.+  HasSpec a =>+  a ->+  Specification a ->+  NE.NonEmpty String ->+  Maybe (NE.NonEmpty String)+conformsToSpecE a (ExplainSpec [] s) msgs = conformsToSpecE a s msgs+conformsToSpecE a (ExplainSpec (x : xs) s) msgs = conformsToSpecE a s ((x :| xs) <> msgs)+conformsToSpecE _ TrueSpec _ = Nothing+conformsToSpecE a (MemberSpec as) msgs =+  if elem a as+    then Nothing+    else+      Just+        ( msgs+            <> NE.fromList+              ["conformsToSpecE MemberSpec case", "  " ++ show a, "  not an element of", "  " ++ show as, ""]+        )+conformsToSpecE a spec@(TypeSpec s cant) msgs =+  if notElem a cant && conformsTo a s+    then Nothing+    else+      Just+        ( msgs+            <> NE.fromList+              ["conformsToSpecE TypeSpec case", "  " ++ show a, "  (" ++ show spec ++ ")", "fails", ""]+        )+conformsToSpecE a (SuspendedSpec v ps) msgs =+  case checkPredE (Env.singleton v a) msgs ps of+    Nothing -> Nothing+    Just es -> Just (pure ("conformsToSpecE SuspendedSpec case on var " ++ show v ++ " fails") <> es)+conformsToSpecE _ (ErrorSpec es) msgs = Just (msgs <> pure "conformsToSpecE ErrorSpec case" <> es)++-- | Check if an @a@ conforms to a @`Specification` a@+conformsToSpec :: HasSpec a => a -> Specification a -> Bool+conformsToSpec a x = case conformsToSpecE a x (pure "call to conformsToSpecE") of+  Nothing -> True+  Just _ -> False++allConformToSpec :: (HasSpec a, Ord a) => Set a -> Specification a -> Bool+allConformToSpec xs (MemberSpec ys) = null $ xs Set.\\ Set.fromList (NE.toList ys)+allConformToSpec _ TrueSpec = True+allConformToSpec xs spec = all (`conformsToSpec` spec) xs++-- | Embed a `Specification` in a `Pred`. Useful for re-using `Specification`s+satisfies :: forall a. HasSpec a => Term a -> Specification a -> Pred+satisfies e (ExplainSpec [] s) = satisfies e s+satisfies e (ExplainSpec (x : xs) s) = Explain (x :| xs) $ satisfies e s+satisfies _ TrueSpec = TruePred+satisfies e (MemberSpec nonempty) = ElemPred True e nonempty+satisfies t (SuspendedSpec x p) = Subst x t p+satisfies e (TypeSpec s cant) = case cant of+  [] -> toPreds e s+  (c : cs) -> ElemPred False e (c :| cs) <> toPreds e s+satisfies _ (ErrorSpec e) = FalsePred e++-- ==================================================================++instance HasSpec a => Semigroup (Specification a) where+  ExplainSpec es x <> y = explainSpec es (x <> y)+  x <> ExplainSpec es y = explainSpec es (x <> y)+  TrueSpec <> s = s+  s <> TrueSpec = s+  ErrorSpec e <> ErrorSpec e' =+    ErrorSpec+      ( e+          <> pure ("------ spec <> spec ------ @" ++ showType @a)+          <> e'+      )+  ErrorSpec e <> _ = ErrorSpec e+  _ <> ErrorSpec e = ErrorSpec e+  MemberSpec as <> MemberSpec as' =+    addToErrorSpec+      ( NE.fromList+          ["Intersecting: ", "  MemberSpec " ++ show (NE.toList as), "  MemberSpec " ++ show (NE.toList as')]+      )+      ( memberSpec+          (nub $ intersect (NE.toList as) (NE.toList as'))+          (pure "Empty intersection")+      )+  ms@(MemberSpec as) <> ts@TypeSpec {} =+    memberSpec+      (nub $ NE.filter (`conformsToSpec` ts) as)+      ( NE.fromList+          [ "The two " ++ showType @a ++ " Specifications are inconsistent."+          , "  " ++ show ms+          , "  " ++ show ts+          ]+      )+  TypeSpec s cant <> MemberSpec as = MemberSpec as <> TypeSpec s cant+  SuspendedSpec v p <> SuspendedSpec v' p' = SuspendedSpec v (p <> rename v' v p')+  SuspendedSpec v ps <> s = SuspendedSpec v (ps <> satisfies (V v) s)+  s <> SuspendedSpec v ps = SuspendedSpec v (ps <> satisfies (V v) s)+  TypeSpec s cant <> TypeSpec s' cant' = case combineSpec s s' of+    -- NOTE: This might look like an unnecessary case, but doing+    -- it like this avoids looping.+    TypeSpec s'' cant'' -> TypeSpec s'' (cant <> cant' <> cant'')+    s'' -> s'' <> notMemberSpec (cant <> cant')++instance HasSpec a => Monoid (Specification a) where+  mempty = TrueSpec++-- =========================================================================++-- | Collect the 'monitor' calls from a specification instantiated to the given value. Typically,+--+--   > quickCheck $ forAll (genFromSpec spec) $ \ x -> monitorSpec spec x $ ...+monitorSpec :: Testable p => Specification a -> a -> p -> Property+monitorSpec (SuspendedSpec x p) a =+  errorGE (monitorPred (Env.singleton x a) p) . property+monitorSpec _ _ = property++monitorPred ::+  forall m. MonadGenError m => Env -> Pred -> m (Property -> Property)+monitorPred env = \case+  ElemPred {} -> pure id -- Not sure about this, but ElemPred is a lot like Assert, so ...+  Monitor m -> pure (m $ errorGE . explain "monitorPred: Monitor" . runTerm env)+  Subst x t p -> monitorPred env $ substitutePred x t p+  Assert {} -> pure id+  GenHint {} -> pure id+  Reifies {} -> pure id+  ForAll t (x :-> p) -> do+    set <- runTerm env t+    foldr (.) id+      <$> sequence+        [ monitorPred 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 -> monitorPred (Env.extend x val env) ps)+  When b p -> do+    v <- runTerm env b+    if v then monitorPred env p else pure id+  TruePred -> pure id+  FalsePred {} -> pure id+  DependsOn {} -> pure id+  And ps -> foldr (.) id <$> mapM (monitorPred env) ps+  Let t (x :-> p) -> do+    val <- runTerm env t+    monitorPred (Env.extend x val env) p+  Exists k (x :-> p) -> do+    case k (errorGE . explain "monitorPred: Exists" . runTerm env) of+      Result a -> monitorPred (Env.extend x a env) p+      _ -> pure id+  Explain es p -> explainNE es $ monitorPred env p
+ src/Constrained/Core.hs view
@@ -0,0 +1,131 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}++-- | This is a collection of relatively core concepts that are re-used+-- throughout the codebase.+module Constrained.Core (+  -- * Variables and renaming+  Var (..),+  eqVar,+  Rename (..),+  freshen,++  -- * Random cruft+  Value (..),+  unValue,+  NonEmpty ((:|)),+  Evidence (..),+  unionWithMaybe,+) where++import Constrained.List (+  List (..),+  mapList,+ )+import Constrained.PrettyUtils+import Control.Applicative+import Data.Function+import Data.List.NonEmpty (NonEmpty ((:|)))+import Data.Set (Set)+import Data.Set qualified as Set+import Data.Typeable++-- Variables --------------------------------------------------------------++-- | Typed, optionally named, variables+data Var a = Var {nameOf :: Int, nameHint :: String}++instance Ord (Var a) where+  compare = compare `on` nameOf++instance Eq (Var a) where+  (==) = (==) `on` nameOf++instance Show (Var a) where+  show v = nameHint v ++ "_" ++ show (nameOf v)++-- | Check if two variables of different type are equal+eqVar :: forall a a'. (Typeable a, Typeable a') => Var a -> Var a' -> Maybe (a :~: a')+eqVar v v' | nameOf v == nameOf v' = eqT @a @a'+eqVar _ _ = Nothing++-- Variable renaming ------------------------------------------------------++-- | Things where variables can be renamed+class Rename a where+  rename :: Typeable x => Var x -> Var x -> a -> a++instance Typeable a => Rename (Var a) where+  rename v v' vOld+    | Just Refl <- eqVar v vOld = v'+    | otherwise = vOld++instance Rename () where+  rename _ _ _ = ()++instance (Rename a, Rename b) => Rename (a, b) where+  rename x x' (a, b) = (rename x x' a, rename x x' b)++instance {-# OVERLAPPABLE #-} (Functor t, Rename a) => Rename (t a) where+  rename v v'+    | v == v' = id+    | otherwise = fmap (rename v v')++instance (Ord a, Rename a) => Rename (Set a) where+  rename v v'+    | v == v' = id+    | otherwise = Set.map (rename v v')++instance (forall a. Rename (f a)) => Rename (List f as) where+  rename v v' = mapList (rename v v')++instance Rename a => Rename [a] where+  rename v v' = map (rename v v')++freshVar :: Var a -> Set Int -> Var a+freshVar (Var n nh) ns+  | Set.member n ns = Var (1 + Set.findMax ns) nh+  | otherwise = Var n nh++-- | Freshen a variable and rename it in a term where it is used given a set of+-- used names that we can't overlap with+freshen :: (Typeable a, Rename t) => Var a -> t -> Set Int -> (Var a, t)+freshen v t nms+  | nameOf v `Set.member` nms = let v' = freshVar v nms in (v', rename v v' t)+  | otherwise = (v, t)++-- Values -----------------------------------------------------------------++-- | Simple values that we can show+data Value a where+  Value :: Show a => !a -> Value a++deriving instance Eq a => Eq (Value a)++deriving instance Ord a => Ord (Value a)++instance Show (Value a) where+  showsPrec p (Value a) = showsPrec p a++-- | Extract an underlying value from a t`Value`+unValue :: Value a -> a+unValue (Value v) = v++-- Cruft ------------------------------------------------------------------++-- | Evidence that a constraint it satisfied, a runtime dict+data Evidence c where+  Evidence :: c => Evidence c++instance Typeable c => Show (Evidence c) where+  show _ = "Evidence@(" ++ showType @c ++ ")"++-- | Take the union of two `Maybe` values with a given union operator+unionWithMaybe :: (a -> a -> a) -> Maybe a -> Maybe a -> Maybe a+unionWithMaybe f ma ma' = (f <$> ma <*> ma') <|> ma <|> ma'
+ src/Constrained/DependencyInjection.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilies #-}++-- | In this module we introduce the `Dependencies` class which is intended to+--    collect type classes and type families that are necessary in the abstract+--    syntax of terms, predicates, and specifications but which we don't want to+--    define in the same place as we define the abstract syntax. C.f.+--    `Constrained.AbstractSyntax` for an example of how we use this module.+--+--    This is typically because the type classes have large default instances that+--    mean the type classes themselves need a lot of code before we can define+--    them. By making these classes abstract in the GADTs we avoid the code-base+--    blowing up with a lot of interdependencies.+--+--    The `Dependencies` class will eventually only be instantiated once by an+--    uninhabited type @data Deps@.+module Constrained.DependencyInjection where++import Data.Kind++-- | A collection of names of type families and type classes to be instantiated+-- later.+class Dependencies d where+  type HasSpecD d :: Type -> Constraint+  type TypeSpecD d :: Type -> Type+  type LogicD d :: ([Type] -> Type -> Type) -> Constraint+  type ForallableD d :: Type -> Type -> Constraint+  type HasGenHintD d :: Type -> Constraint+  type HintD d :: Type -> Type
+ src/Constrained/Env.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE ImpredicativeTypes #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-}++-- | Environments that map types variables to values+module Constrained.Env (+  Env,+  singleton,+  extend,+  lookup,+  find,+  remove,+  filterKeys,+) where++import Constrained.Core+import Constrained.GenT+import Data.Map (Map)+import Data.Map qualified as Map+import Data.Typeable+import Prettyprinter+import Prelude hiding (lookup)++-- | Typed environments for mapping @t`Var` a@ to @a@+newtype Env = Env (Map EnvKey EnvValue)+  deriving newtype (Semigroup, Monoid)+  deriving stock (Show)++data EnvValue where+  EnvValue :: (Typeable a, Show a) => !a -> EnvValue++deriving instance Show EnvValue++data EnvKey where+  EnvKey :: Typeable a => !(Var a) -> EnvKey++instance Eq EnvKey where+  EnvKey v == EnvKey v' = nameOf v == nameOf v'++instance Ord EnvKey where+  compare (EnvKey v) (EnvKey v') = compare (nameOf v) (nameOf v')++instance Show EnvKey where+  show (EnvKey var) = show var++-- | Extend an environment with a new variable value pair+extend :: (Typeable a, Show a) => Var a -> a -> Env -> Env+extend v a (Env m) = Env $ Map.insert (EnvKey v) (EnvValue a) m++-- | Remove a variable from an environment if it exists+remove :: Typeable a => Var a -> Env -> Env+remove v (Env m) = Env $ Map.delete (EnvKey v) m++-- | Create a singleton environment+singleton :: (Typeable a, Show a) => Var a -> a -> Env+singleton v a = Env $ Map.singleton (EnvKey v) (EnvValue a)++-- | Lookup a avariable in the environment+lookup :: Typeable a => Env -> Var a -> Maybe a+lookup (Env m) v = do+  EnvValue val <- Map.lookup (EnvKey v) m+  cast val++-- | `lookup` generalized to any `MonadGenError` monad @m@+find :: (Typeable a, MonadGenError m) => Env -> Var a -> m a+find env var = do+  case lookup env var of+    Just a -> pure a+    Nothing -> genError ("Couldn't find " ++ show var ++ " in " ++ show env)++-- | Filter the keys in an env, useful for removing irrelevant variables in+-- error messages+filterKeys :: Env -> (forall a. Typeable a => Var a -> Bool) -> Env+filterKeys (Env m) f = Env $ Map.filterWithKey (\(EnvKey k) _ -> f k) m++instance Pretty EnvValue where+  pretty (EnvValue x) = viaShow x++instance Pretty EnvKey where+  pretty (EnvKey x) = viaShow x++instance Pretty Env where+  pretty (Env m) = vsep (map f (Map.toList m))+    where+      f (k, v) = hsep [pretty k, "->", pretty v]
+ src/Constrained/FunctionSymbol.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}++-- | Utility functions and key concepts for talking about typed function+-- symbols, i.e. witness type formers @W :: (as :: [Type]) -> (r :: Type) ->+-- Type@ whose constructors stand in for functions of type @`FunTy` as r@.+module Constrained.FunctionSymbol (sameFunSym, getWitness, Semantics (..)) where++import Constrained.List+import Data.Kind+import Data.Typeable++-- | Check if two function symbols of different type are the same+sameFunSym ::+  forall (t1 :: [Type] -> Type -> Type) d1 r1 (t2 :: [Type] -> Type -> Type) d2 r2.+  ( Typeable t1+  , Typeable d1+  , Typeable r1+  , Typeable t2+  , Typeable d2+  , Typeable r2+  , Eq (t1 d1 r1)+  ) =>+  t1 d1 r1 ->+  t2 d2 r2 ->+  Maybe (t1 :~: t2, d1 :~: d2, r1 :~: r2)+sameFunSym x y = do+  Refl <- eqT @t1 @t2+  Refl <- eqT @d1 @d2+  Refl <- eqT @r1 @r2+  if x == y+    then Just (Refl, Refl, Refl)+    else Nothing++-- | Try to cast from an unknown function symbol universe @t@ to a known+-- universe @t'@+getWitness ::+  forall t t' d r.+  ( Typeable t+  , Typeable d+  , Typeable r+  , Typeable t'+  ) =>+  t d r -> Maybe (t' d r)+getWitness = cast++-- | Semantic operations are ones that give the function symbol, meaning as a+-- function. I.e. how to apply the function to a list of arguments and return+-- a value.+class Semantics (t :: [Type] -> Type -> Type) where+  semantics :: t d r -> FunTy d r -- e.g. FunTy '[a, Int] Bool ~ a -> Int -> Bool
+ src/Constrained/GenT.hs view
@@ -0,0 +1,518 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}+-- NOTE: this is for `split` vs. `splitGen` that we haven't had+-- time to fix in `QuickCheck`.+{-# OPTIONS_GHC -Wno-deprecations #-}++-- | This module provides an interface for writing and working with generators+--     that may fail in both recoverable and unrecoverable ways.+module Constrained.GenT (+  -- * Types+  GE (..),+  GenT,+  GenMode (..),++  -- * Writing t`GenT` generators+  MonadGenError (..),+  pureGen,+  genFromGenT,+  suchThatT,+  suchThatWithTryT,+  scaleT,+  resizeT,+  firstGenT,+  tryGenT,+  chooseT,+  sizeT,+  withMode,+  frequencyT,+  oneofT,+  vectorOfT,+  listOfUntilLenT,+  listOfT,+  strictGen,+  looseGen,++  -- * So far undocumented+  fatalError,+  getMessages,+  catMessages,+  catMessageList,+  explain,+  errorGE,+  fromGE,+  runGE,+  inspect,+  genError,+  pushGE,+  push,+  dropGen,+  catchGen,+  getMode,+  headGE,+  fromGEProp,+  fromGEDiscard,+  listFromGE,+) where++import Control.Arrow (second)+import Control.Monad+import Control.Monad.Trans+import Data.Foldable+import Data.List.NonEmpty (NonEmpty ((:|)), (<|))+import Data.List.NonEmpty qualified as NE+import Data.Typeable+import GHC.Stack+import System.Random+import Test.QuickCheck hiding (Args, Fun)+import Test.QuickCheck.Gen+import Test.QuickCheck.Random++-- ==============================================================+-- The GE Monad++-- | This is like an @Error@ monad that distinguishes between two kinds of+-- errors: @FatalError@s and non-fatal @GenError@s.+data GE a+  = FatalError (NonEmpty (NonEmpty String))+  | GenError (NonEmpty (NonEmpty String))+  | Result a+  deriving (Ord, Eq, Show, Functor)++instance Applicative GE where+  pure = Result+  (<*>) = ap++instance Monad GE where+  FatalError es >>= _ = FatalError es+  GenError es >>= _ = GenError es+  Result a >>= k = k a++------------------------------------------------------------------------+-- Threading gen monad+------------------------------------------------------------------------++-- The normal Gen monad always splits the seed when doing >>=. This is for very+-- good reasons - it lets you write generators that generate infinite data to+-- the left of a >>= and let's your generators be very lazy!++-- A traditional GenT m a implementation would inherit this splitting behaviour+-- in order to let you keep writing infinite and lazy things to the left of >>=+-- on the GenT m level. Now, the thing to realize about this is that unless+-- your code is very carefully written to avoid it this means you're going to+-- end up with unnecessary >>=s and thus unnecessary splits.++-- To get around this issue of unnecessary splits we introduce a threading GenT+-- implementation here that sacrifices letting you do infinite (and to some+-- extent lazy) structures to the left of >>= on the GenT m level, but doesn't+-- prohibit you from doing so on the Gen level.++-- This drastically reduces the number of seed splits while still letting you+-- write lazy and infinite generators in Gen land by being a little bit more+-- careful. It works great for constrained-generators in particular, which has+-- a tendency to be strict and by design avoids inifinte values.++liftGenToThreading :: Monad m => Gen a -> ThreadingGenT m a+liftGenToThreading g = ThreadingGen $ \seed size -> do+  let (seed', seed'') = split seed+  pure (seed'', unGen g seed' size)++runThreadingGen :: Functor m => ThreadingGenT m a -> Gen (m a)+runThreadingGen g = MkGen $ \seed size -> do+  snd <$> unThreadingGen g seed size++strictGetSize :: Applicative m => ThreadingGenT m Int+strictGetSize = ThreadingGen $ \seed size -> pure (seed, size)++scaleThreading :: (Int -> Int) -> ThreadingGenT m a -> ThreadingGenT m a+scaleThreading f sg = ThreadingGen $ \seed size -> unThreadingGen sg seed (f size)++newtype ThreadingGenT m a = ThreadingGen {unThreadingGen :: QCGen -> Int -> m (QCGen, a)}++instance Functor m => Functor (ThreadingGenT m) where+  fmap f (ThreadingGen g) = ThreadingGen $ \seed size -> second f <$> g seed size++instance Monad m => Applicative (ThreadingGenT m) where+  pure a = ThreadingGen $ \seed _ -> pure (seed, a)+  (<*>) = ap++instance Monad m => Monad (ThreadingGenT m) where+  ThreadingGen g >>= k = ThreadingGen $ \seed size -> do+    (seed', a) <- g seed size+    unThreadingGen (k a) seed' size++instance MonadTrans ThreadingGenT where+  lift m = ThreadingGen $ \seed _ -> (seed,) <$> m++------------------------------------------------------------------------+-- The GenT monad+-- An environment monad on top of GE+------------------------------------------------------------------------++-- | Generation mode - how strict are we about requiring the generator to+-- succeed. This is necessary because sometimes failing to find a value means+-- there is an actual problem (a generator _should_ be satisfiable but for+-- whatever buggy reason it isn't) and sometimes failing to find a value just+-- means there are no values. The latter case is very relevant when you're+-- generating e.g. lists or sets of values that can be empty.+data GenMode+  = Loose+  | Strict+  deriving (Ord, Eq, Show)++-- | A `Gen` monad wrapper that allows different generation modes and different+-- failure types.+newtype GenT m a = GenT {runGenT :: GenMode -> [NonEmpty String] -> ThreadingGenT m a}+  deriving (Functor)++instance Monad m => Applicative (GenT m) where+  pure a = GenT (\_ _ -> pure a)+  (<*>) = ap++instance Monad m => Monad (GenT m) where+  GenT m >>= k = GenT $ \mode msgs -> do+    a <- m mode msgs+    runGenT (k a) mode msgs++instance MonadGenError m => MonadFail (GenT m) where+  fail s = genError s++------------------------------------------------------------------------+-- The MonadGenError transformer+----------------------------------------------------------------------++-- | A class for different types of errors with a stack of `explain` calls to+-- narrow down problems. The @NonEmpty String@ means one cannot cause an error+-- without at least one string to explain it.+class Monad m => MonadGenError m where+  genErrors :: HasCallStack => NonEmpty (NonEmpty String) -> m a+  fatalErrors :: HasCallStack => NonEmpty (NonEmpty String) -> m a+  genErrorNE :: HasCallStack => NonEmpty String -> m a+  fatalErrorNE :: HasCallStack => NonEmpty String -> m a+  explainNE :: HasCallStack => NonEmpty String -> m a -> m a++-- | A potentially recoverable generation error+genError :: MonadGenError m => String -> m a+genError = genErrorNE . pure++-- | A non-recoverable fatal error+fatalError :: MonadGenError m => String -> m a+fatalError = fatalErrorNE . pure++-- | Attach an explanation to a computation in case of error+explain :: MonadGenError m => String -> m a -> m a+explain = explainNE . pure++-- GE instance++instance MonadGenError GE where+  genErrorNE msg = GenError (pure msg)+  genErrors msgs = GenError msgs+  fatalErrorNE msg = FatalError (pure msg)+  fatalErrors msgs = FatalError msgs+  explainNE m (GenError ms) = GenError (m <| ms)+  explainNE m (FatalError ms) = FatalError (m <| ms)+  explainNE _ (Result x) = Result x++-- GenT instance++-- | calls to genError and fatalError, add the stacked messages in the monad.+instance MonadGenError m => MonadGenError (GenT m) where+  genErrorNE e = GenT $ \_ xs -> lift $ genErrors (add e xs)+  genErrors es = GenT $ \_ xs -> lift $ genErrors (cat es xs)++  -- Perhaps we want to turn genError into fatalError, if mode_ is Strict?+  fatalErrorNE e = GenT $ \_ xs -> lift $ fatalErrors (add e xs)+  fatalErrors es = GenT $ \_ xs -> lift $ fatalErrors (cat es xs)++  -- Perhaps we want to turn fatalError into genError, if mode_ is Loose?+  explainNE e (GenT f) = GenT $ \mode es -> ThreadingGen $ \seed size -> explainNE e $ unThreadingGen (f mode es) seed size++-- ====================================================+-- useful operations on NonEmpty++add :: NonEmpty a -> [NonEmpty a] -> NonEmpty (NonEmpty a)+add a [] = pure a+add a (x : xs) = a <| (x :| xs)++cat :: NonEmpty (NonEmpty a) -> [NonEmpty a] -> NonEmpty (NonEmpty a)+cat a [] = a+cat a (x : xs) = a <> (x :| xs)++-- | Sometimes we have a bunch of `genError` or `fatalError` messages we want+-- to combine into one big message. This happens when we want to lift one of+-- these into an input for 'error'+catMessages :: NonEmpty (NonEmpty String) -> String+catMessages xs = unlines (NE.toList (catMessageList xs))++-- | Turn each inner @NonEmpty String@ into a String+catMessageList :: NonEmpty (NonEmpty String) -> NonEmpty String+catMessageList = fmap (unlines . NE.toList)++-- ========================================================+-- Useful operations on GE++-- If none of the GE's are FatalError, then concat together all the+-- Results (skipping over GenError). If there is at least one+-- @FatalError xs@ abort, and lift all those @xs@ as errors in the monad @m@.+catGEs :: forall m a. MonadGenError m => [GE a] -> m [a]+catGEs ges0 = go [] ges0+  where+    go acc [] = pure $ reverse acc+    go !acc (g : ges) =+      case g of+        Result a -> go (a : acc) ges+        GenError _ -> go acc ges+        FatalError xs -> fatalErrors xs++-- | Turn @'GE' a@ into @a@ given a function for handling @GenError@, and handle+-- @FatalError@ with 'error'+fromGE :: HasCallStack => (NonEmpty (NonEmpty String) -> a) -> GE a -> a+fromGE f ge = case ge of+  Result a -> a+  GenError xs -> f xs+  FatalError es -> error $ catMessages es++-- | Turn @'GE' a@ into where both @GenError@ and @FatalError@ are handled by+-- using 'error'+errorGE :: GE a -> a+errorGE = fromGE (error . catMessages)++isOk :: GE a -> Bool+isOk ge = case ge of+  GenError {} -> False+  FatalError {} -> False+  Result {} -> True++-- | Convert a `GE` into an arbitrary monad that has an instance of+-- `MonadGenError`+runGE :: forall m r. MonadGenError m => GE r -> m r+runGE ge = case ge of+  GenError es -> genErrors es+  FatalError es -> fatalErrors es+  Result a -> pure a++-- | Turn a `GE` for something testable into a `Property`, failing on any+-- kind of error.+fromGEProp :: Testable p => GE p -> Property+fromGEProp ge = case ge of+  GenError es -> counterexample (catMessages es) False+  FatalError es -> counterexample (catMessages es) False+  Result p -> property p++-- | Turn a `GE` into a property, `discard`ing any failure.+fromGEDiscard :: Testable p => GE p -> Property+fromGEDiscard ge = case ge of+  Result p -> property p+  _ -> discard++-- | Like `Prelude.head` in the `GE` monad+headGE :: Foldable t => t a -> GE a+headGE t+  | x : _ <- toList t = pure x+  | otherwise = fatalError "head of empty structure"++-- | Turn a `GE [a]` to `[a]`, `genError` goes to `[]` and `fatalError` to `error`.+listFromGE :: GE [a] -> [a]+listFromGE = fromGE (const []) . explain "listFromGE"++-- ========================================================+-- Useful operations on GenT++-- | Run a t`GenT` generator in `Strict` mode+strictGen :: Functor m => GenT m a -> Gen (m a)+strictGen genT = runThreadingGen $ runGenT genT Strict []++-- | Run a t`GenT` generator in `Loose` mode+looseGen :: Functor m => GenT m a -> Gen (m a)+looseGen genT = runThreadingGen $ runGenT genT Loose []++-- | Turn a t`GenT` generator into a `Gen` generator in `Strict` mode+genFromGenT :: GenT GE a -> Gen a+genFromGenT genT = errorGE <$> strictGen genT++-- | Turn a `Gen` generator into a t`GenT` generator that never fails.+pureGen :: Monad m => Gen a -> GenT m a+pureGen gen = GenT $ \_ _ -> liftGenToThreading gen++-- | Lift `listOf` to t`GenT`+listOfT :: MonadGenError m => GenT GE a -> GenT m [a]+listOfT gen = do+  lst <- pureGen . listOf $ runThreadingGen $ runGenT gen Loose []+  catGEs lst++-- | Generate a list of elements of length at most @goalLen@, but accepting+-- failure to get that many elements so long as @validLen@ is true.+listOfUntilLenT ::+  (Typeable a, MonadGenError m) =>+  -- | Element generator+  GenT GE a ->+  -- | @goalLen@ goal length+  Int ->+  -- | @validLen@ filter+  (Int -> Bool) ->+  GenT m [a]+listOfUntilLenT gen goalLen validLen =+  genList `suchThatT` validLen . length+  where+    genList = do+      res <- pureGen . vectorOf goalLen $ runThreadingGen $ runGenT gen Loose []+      catGEs res++-- | Lift `vectorOf` to t`GenT`+vectorOfT :: MonadGenError m => Int -> GenT GE a -> GenT m [a]+vectorOfT i gen = GenT $ \mode _ -> do+  res <- liftGenToThreading $ fmap sequence . vectorOf i $ runThreadingGen $ runGenT gen Strict []+  case mode of+    Strict -> lift $ runGE res+    Loose -> case res of+      FatalError es -> lift $ genErrors es+      _ -> lift $ runGE res++infixl 2 `suchThatT`++-- | Lift `suchThat` to t`GenT`, equivalent to @`suchThatT` 100@+suchThatT :: (Typeable a, MonadGenError m) => GenT m a -> (a -> Bool) -> GenT m a+suchThatT g p = suchThatWithTryT 100 g p++-- | Lift `suchThat` to t`GenT` with special handling of generation mode. In+-- `Strict` mode @suchThatWithTry tries@ will try @tries@ times and fail with a+-- `fatalError` if unsuccessful.  In `Loose` mode however, we will try only+-- once and generate a `genError`.+suchThatWithTryT ::+  forall a m. (Typeable a, MonadGenError m) => Int -> GenT m a -> (a -> Bool) -> GenT m a+suchThatWithTryT tries g p = do+  mode <- getMode+  let (n, cont) = case mode of+        Strict -> (tries, fatalError)+        Loose -> (1 :: Int, genError) -- TODO: Maybe 1 is not the right number here!+  go n cont+  where+    go 0 cont =+      cont+        ("Ran out of tries (" ++ show tries ++ ") on suchThatWithTryT at type " ++ show (typeRep (Proxy @a)))+    go n cont = do+      a <- g+      if p a then pure a else scaleT (+ 1) $ go (n - 1) cont++-- | Lift `scale` to t`GenT`+scaleT :: (Int -> Int) -> GenT m a -> GenT m a+scaleT sc (GenT gen) = GenT $ \mode msgs -> scaleThreading sc $ gen mode msgs++-- | Lift `resize` to t`GenT`+resizeT :: Int -> GenT m a -> GenT m a+resizeT = scaleT . const++-- | Access the `GenMode` we are running in, useful to decide e.g.  if we want+-- to re-try in case of a `GenError` or give up+getMode :: Monad m => GenT m GenMode+getMode = GenT $ \mode _ -> pure mode++-- | Get the current stack of `explain` above you+getMessages :: Monad m => GenT m [NonEmpty String]+getMessages = GenT $ \_ msgs -> pure msgs++-- | Locally change the generation mode+withMode :: GenMode -> GenT m a -> GenT m a+withMode mode gen = GenT $ \_ msgs -> runGenT gen mode msgs++-- | Lift `oneof` to t`GenT`+oneofT :: (Typeable a, MonadGenError m) => [GenT GE a] -> GenT m a+oneofT gs = frequencyT $ map (1,) gs++-- | Lift `frequency` to t`GenT`+frequencyT :: (Typeable a, MonadGenError m) => [(Int, GenT GE a)] -> GenT m a+frequencyT gs = do+  mode <- getMode+  msgs <- getMessages+  r <-+    explain "suchThatT in oneofT" $+      pureGen (frequency [(f, runThreadingGen $ runGenT g mode msgs) | (f, g) <- gs]) `suchThatT` isOk+  runGE r++-- | Lift `choose` to t`GenT`, failing with a `genError` in case of an empty interval+chooseT :: (Random a, Ord a, Show a, MonadGenError m) => (a, a) -> GenT m a+chooseT (a, b)+  | b < a = genError ("chooseT (" ++ show a ++ ", " ++ show b ++ ")")+  | otherwise = pureGen $ choose (a, b)++-- | Get the size provided to the generator+sizeT :: Monad m => GenT m Int+sizeT = GenT $ \_ _ -> strictGetSize++-- ==================================================================+-- Reflective analysis of the internal GE structure of (GenT GE x)+-- This allows "catching" internal FatalError and GenError, and allowing+-- the program to control what happens in those cases.++-- | Always succeeds, but returns the internal GE structure for analysis+inspect :: forall m a. MonadGenError m => GenT GE a -> GenT m (GE a)+inspect (GenT f) = GenT $ \mode msgs -> liftGenToThreading $ runThreadingGen $ f mode msgs++-- | Ignore all kinds of Errors, by squashing them into Nothing+tryGenT :: MonadGenError m => GenT GE a -> GenT m (Maybe a)+tryGenT g = do+  r <- inspect g+  case r of+    FatalError _ -> pure Nothing+    GenError _ -> pure Nothing+    Result a -> pure $ Just a++-- Pass on the error messages of both kinds of Errors, by squashing and combining both of them into Left constructor+catchGenT :: MonadGenError m => GenT GE a -> GenT m (Either (NonEmpty (NonEmpty String)) a)+catchGenT g = do+  r <- inspect g+  case r of+    FatalError es -> pure $ Left es+    GenError es -> pure $ Left es+    Result a -> pure $ Right a++-- | Pass on the error messages of both kinds of Errors in the Gen (not the GenT) monad+catchGen :: GenT GE a -> Gen (Either (NonEmpty (NonEmpty String)) a)+catchGen g = genFromGenT (catchGenT g)++-- | Return the first successfull result from a list of computations, if they all fail+--   return a list of the error messages from each one.+firstGenT ::+  forall m a. MonadGenError m => [GenT GE a] -> GenT m (Either [(NonEmpty (NonEmpty String))] a)+firstGenT gs = loop gs []+  where+    loop ::+      [GenT GE a] -> [NonEmpty (NonEmpty String)] -> GenT m (Either [NonEmpty (NonEmpty String)] a)+    loop [] ys = pure (Left (reverse ys))+    loop (x : xs) ys = do+      this <- catchGenT x+      case this of+        Left zs -> loop xs (zs : ys)+        Right a -> pure (Right a)++-- | Drop a @t`GenT` `GE`@ computation into a @t`GenT` m@ computation.+--+-- Depending on the monad @m@ Some error information might be lost as+-- the monad might fold `FatalError`'s and `GenError`'s together.+dropGen :: MonadGenError m => GenT GE a -> GenT m a+dropGen y = do+  r <- inspect y+  case r of+    FatalError es -> fatalErrors es+    GenError es -> genErrors es+    Result a -> pure a++-- ======================================++-- | like explain for GenT, but uses [String] rather than (NonEmpty String)+--   if the list is null, it becomes the identity+push :: forall m a. MonadGenError m => [String] -> m a -> m a+push [] m = m+push (x : xs) m = explainNE (x :| xs) m++-- | like explain for GE, but uses [String] rather than (NonEmpty String)+--   if the list is null, it becomes the identity+pushGE :: forall a. [String] -> GE a -> GE a+pushGE [] x = x+pushGE (x : xs) m = explainNE (x :| xs) m
+ src/Constrained/Generation.hs view
@@ -0,0 +1,1467 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | All the things that are necessary for generation and shrinking.+module Constrained.Generation (+  -- * Generation and shrinking+  genFromSpec,+  genFromSpecT,+  genFromSpecWithSeed,+  shrinkWithSpec,+  fixupWithSpec,+  simplifySpec,++  -- ** Debugging+  printPlan,+  debugSpec,+  prettyPlan,++  -- * Function Symbols+  or_,+  not_,+  injRight_,+  injLeft_,+  (==.),++  -- * Other syntax+  whenTrue,++  -- * Internals+  CountCases,+  SumW (..),+  BoolW (..),+  EqW (..),+  SumSpec (..),+  pattern SumSpec,+  mapSpec,+  forwardPropagateSpec,+) where++import Constrained.AbstractSyntax+import Constrained.Base+import Constrained.Conformance+import Constrained.Core+import Constrained.Env (Env)+import Constrained.Env qualified as Env+import Constrained.FunctionSymbol+import Constrained.GenT+import Constrained.Generic+import Constrained.Graph hiding (irreflexiveDependencyOn)+import Constrained.List+import Constrained.NumOrd+import Constrained.PrettyUtils+import Constrained.Syntax+import Control.Applicative+import Control.Monad+import Control.Monad.Writer (Writer, runWriter, tell)+import Data.Foldable+import Data.Int+import Data.Kind+import Data.List (partition)+import Data.List.NonEmpty qualified as NE+import Data.Maybe+import Data.Semigroup (Any (..), getSum)+import Data.Semigroup qualified as Semigroup+import Data.Set (Set)+import Data.Set qualified as Set+import Data.String+import Data.Typeable+import GHC.Stack+import GHC.TypeLits+import Prettyprinter hiding (cat)+import Test.QuickCheck hiding (Args, Fun, Witness, forAll, witness)+import Test.QuickCheck.Gen+import Test.QuickCheck.Random hiding (left, right)+import Prelude hiding (cycle, pred)++------------------------------------------------------------------------+-- Generation, shrinking, and debugging+------------------------------------------------------------------------++-- | Generate a value that satisfies the spec. This function can fail if the+-- spec is inconsistent, there is a dependency error, or if the underlying+-- generators are not flexible enough.+genFromSpecT ::+  forall a m. (HasCallStack, HasSpec a, MonadGenError m) => Specification a -> GenT m a+genFromSpecT (ExplainSpec [] s) = genFromSpecT s+genFromSpecT (ExplainSpec es s) = push es (genFromSpecT s)+genFromSpecT (simplifySpec -> spec) = case spec of+  ExplainSpec [] s -> genFromSpecT s+  ExplainSpec es s -> push es (genFromSpecT s)+  MemberSpec as -> explain ("genFromSpecT on spec" ++ show spec) $ pureGen (elements (NE.toList as))+  TrueSpec -> genFromSpecT (typeSpec $ emptySpec @a)+  SuspendedSpec x p+    -- NOTE: If `x` isn't free in `p` we still have to try to generate things+    -- from `p` to make sure `p` is sat and then we can throw it away. A better+    -- approach would be to only do this in the case where we don't know if `p`+    -- is sat. The proper way to implement such a sat check is to remove+    -- sat-but-unnecessary variables in the optimiser.+    | not $ Name x `appearsIn` p -> do+        !_ <- genFromPreds mempty p+        genFromSpecT TrueSpec+    | otherwise -> do+        env <- genFromPreds mempty p+        Env.find env x+  TypeSpec s cant -> do+    mode <- getMode+    explainNE+      ( NE.fromList+          [ "genFromSpecT on (TypeSpec tspec cant) at type " ++ showType @a+          , "tspec = "+          , show s+          , "cant = " ++ show cant+          , "with mode " ++ show mode+          ]+      )+      $+      -- TODO: we could consider giving `cant` as an argument to `genFromTypeSpec` if this+      -- starts giving us trouble.+      genFromTypeSpec s `suchThatT` (`notElem` cant)+  ErrorSpec e -> genErrorNE e++-- | A version of `genFromSpecT` that simply errors if the generator fails+genFromSpec :: forall a. (HasCallStack, HasSpec a) => Specification a -> Gen a+genFromSpec spec = do+  res <- catchGen $ genFromSpecT @a @GE spec+  either (error . ('\n' :) . catMessages) pure res++-- | A version of `genFromSpecT` that takes a seed and a size and gives you a result+genFromSpecWithSeed ::+  forall a. (HasCallStack, HasSpec a) => Int -> Int -> Specification a -> a+genFromSpecWithSeed seed size spec = unGen (genFromSpec spec) (mkQCGen seed) size++-- ----------------------- Shrinking -------------------------------++unconstrainedShrink :: forall a. HasSpec a => a -> [a]+unconstrainedShrink = shrinkWithTypeSpec (emptySpec @a)++-- | Shrink a value while preserving adherence to a `Specification`+shrinkWithSpec :: forall a. HasSpec a => Specification a -> a -> [a]+shrinkWithSpec (ExplainSpec _ s) a = shrinkWithSpec s a+shrinkWithSpec (simplifySpec -> spec) a = case spec of+  -- TODO: It would be nice to avoid the extra `conformsToSpec` check here and only look+  -- at the cant set instead+  TypeSpec s _ -> [a' | a' <- shrinkWithTypeSpec s a, a' `conformsToSpec` spec]+  SuspendedSpec x p -> shrinkFromPreds p x a+  -- TODO: it would be nice if there was some better way of doing this+  MemberSpec as -> [a' | a' <- unconstrainedShrink a, a' `elem` as]+  TrueSpec -> unconstrainedShrink a+  ErrorSpec {} -> []+  -- Should be impossible?+  ExplainSpec _ s -> shrinkWithSpec s a++shrinkFromPreds :: forall a. HasSpec a => Pred -> Var a -> a -> [a]+shrinkFromPreds p+  | Result plan <- prepareLinearization p = \x a -> listFromGE $ do+      -- NOTE: we do this to e.g. guard against bad construction functions in Exists+      case checkPredE (Env.singleton x a) (NE.fromList []) p of+        Nothing -> pure ()+        Just err -> explainNE err $ fatalError "Trying to shrink a bad value, don't do that!"+      if not $ Name x `appearsIn` p -- NOTE: this is safe because we just checked that p is SAT above+        then return $ unconstrainedShrink a+        else do+          -- Get an `env` for the original value+          initialEnv <- envFromPred (Env.singleton x a) p+          return+            [ a'+            | -- Shrink the initialEnv+            env' <- shrinkEnvFromPlan initialEnv plan+            , -- Get the value of the constrained variable `x` in the shrunk env+            Just a' <- [Env.lookup env' x]+            , -- NOTE: this is necessary because it's possible that changing+            -- a particular value in the env during shrinking might not result+            -- in the value of `x` changing and there is no better way to know than+            -- to do this.+            a' /= a+            ]+  | otherwise = error "Bad pred"++-- Start with a valid Env for the plan and try to shrink it+shrinkEnvFromPlan :: Env -> SolverPlan -> [Env]+shrinkEnvFromPlan initialEnv SolverPlan {..} = go mempty solverPlan+  where+    go :: Env -> [SolverStage] -> [Env]+    go _ [] = [] -- In this case we decided to keep every variable the same so nothing to return+    go env ((unsafeSubstStage env -> SolverStage {..}) : plan) = do+      Just a <- [Env.lookup initialEnv stageVar]+      -- Two cases:+      --  - either we shrink this value and try to fixup every value later on in the plan or+      [ fixedEnv+        | a' <- shrinkWithSpec stageSpec a+        , let env' = Env.extend stageVar a' env+        , Just fixedEnv <- [fixupPlan env' plan]+        ]+        --  - we keep this value the way it is and try to shrink some later value+        ++ go (Env.extend stageVar a env) plan++    -- Fix the rest of the plan given an environment `env` for the plan so far+    fixupPlan :: Env -> [SolverStage] -> Maybe Env+    fixupPlan env [] = pure env+    fixupPlan env ((unsafeSubstStage env -> SolverStage {..}) : plan) =+      case Env.lookup (env <> initialEnv) stageVar >>= fixupWithSpec stageSpec of+        Nothing -> Nothing+        Just a -> fixupPlan (Env.extend stageVar a env) plan++-- Try to fix a value w.r.t a specification+fixupWithSpec :: forall a. HasSpec a => Specification a -> a -> Maybe a+fixupWithSpec spec a+  | a `conformsToSpec` spec = Just a+  | otherwise = case spec of+      MemberSpec (a' :| _) -> Just a'+      TypeSpec ts _ -> fixupWithTypeSpec ts a >>= \a' -> a' <$ guard (conformsToSpec a' spec)+      _ -> listToMaybe $ filter (`conformsToSpec` spec) (shrinkWithSpec TrueSpec a)++-- Debugging --------------------------------------------------------------++-- | A version of `genFromSpecT` that runs in the IO monad. Good for debugging.+debugSpec :: forall a. HasSpec a => Specification a -> IO ()+debugSpec spec = do+  ans <- generate $ genFromGenT $ inspect (genFromSpecT spec)+  let f x = putStrLn (unlines (NE.toList x))+      ok x =+        if conformsToSpec x spec+          then putStrLn "True"+          else putStrLn "False, perhaps there is an unsafeExists in the spec?"+  case ans of+    FatalError xs -> mapM_ f xs+    GenError xs -> mapM_ f xs+    Result x -> print spec >> print x >> ok x++-- | Pretty-print the plan for a `Specifcation` in the terminal for debugging+printPlan :: HasSpec a => Specification a -> IO ()+printPlan = print . prettyPlan++-- | Plan pretty-printer for debugging+prettyPlan :: HasSpec a => Specification a -> Doc ann+prettyPlan (simplifySpec -> spec)+  | SuspendedSpec _ p <- spec+  , Result plan <- prepareLinearization p =+      vsep'+        [ "Simplified spec:" /> pretty spec+        , pretty plan+        ]+  | otherwise = "Simplfied spec:" /> pretty spec++-- ---------------------- Building a plan -----------------------------------++unsafeSubstStage :: Env -> SolverStage -> SolverStage+unsafeSubstStage env (SolverStage y ps spec relevant) =+  normalizeSolverStage $ SolverStage y (substPred env <$> ps) spec relevant++substStage :: HasSpec a => Set Name -> Var a -> a -> SolverStage -> SolverStage+substStage rel' x val (SolverStage y ps spec relevant) =+  normalizeSolverStage $ SolverStage y (substPred env <$> ps) spec relevant'+  where+    env = Env.singleton x val+    relevant'+      | Name x `appearsIn` ps = rel' <> relevant+      | otherwise = relevant++normalizeSolverStage :: SolverStage -> SolverStage+normalizeSolverStage (SolverStage x ps spec relevant) = SolverStage x ps'' (spec <> spec') relevant+  where+    (ps', ps'') = partition ((1 ==) . Set.size . freeVarSet) ps+    spec' = fromGESpec $ computeSpec x (And ps')++-- TODO: here we can compute both the explicit hints (i.e. constraints that+-- define the order of two variables) and any whole-program smarts.+computeHints :: [Pred] -> Hints+computeHints ps =+  transitiveClosure $ fold [x `irreflexiveDependencyOn` y | DependsOn x y <- ps]++-- | Linearize a predicate, turning it into a list of variables to solve and+-- their defining constraints such that each variable can be solved independently.+prepareLinearization :: Pred -> GE SolverPlan+prepareLinearization p = do+  let preds = concatMap saturatePred $ flattenPred p+      hints = computeHints preds+      graph = transitiveClosure $ hints <> respecting hints (foldMap computeDependencies preds)+  plan <-+    explainNE+      ( NE.fromList+          [ "Linearizing"+          , show $+              "  preds: "+                <> pretty (take 3 preds)+                <> (if length preds > 3 then fromString (" ... " ++ show (length preds - 3) ++ " more.") else "")+          , show $ "  graph: " <> pretty graph+          ]+      )+      $ linearize preds graph+  pure $ backPropagation mempty $ SolverPlan plan++-- | Flatten nested `Let`, `Exists`, and `And` in a `Pred fn`. `Let` and+-- `Exists` bound variables become free in the result.+flattenPred :: Pred -> [Pred]+flattenPred pIn = go (freeVarNames pIn) [pIn]+  where+    go _ [] = []+    go fvs (p : ps) = case p of+      And ps' -> go fvs (ps' ++ ps)+      -- NOTE: the order of the arguments to `==.` here are important.+      -- The whole point of `Let` is that it allows us to solve all of `t`+      -- before we solve the variables in `t`.+      Let t b -> goBinder fvs b ps (\x -> (assert (t ==. (V x)) :))+      Exists _ b -> goBinder fvs b ps (const id)+      When b pp -> map (When b) (go fvs [pp]) ++ go fvs ps+      Explain es pp -> map (explanation es) (go fvs [pp]) ++ go fvs ps+      _ -> p : go fvs ps++    goBinder ::+      Set Int ->+      Binder a ->+      [Pred] ->+      (HasSpec a => Var a -> [Pred] -> [Pred]) ->+      [Pred]+    goBinder fvs (x :-> p) ps k = k x' $ go (Set.insert (nameOf x') fvs) (p' : ps)+      where+        (x', p') = freshen x p fvs++-- Consider: A + B = C + D+-- We want to fail if A and B are independent.+-- Consider: A + B = A + C, A <- B+-- Here we want to consider this constraint defining for A+linearize ::+  MonadGenError m => [Pred] -> DependGraph -> m [SolverStage]+linearize preds graph = do+  sorted <- case topsort graph of+    Left cycle ->+      fatalError+        ( show $+            "linearize: Dependency cycle in graph:"+              /> vsep'+                [ "cycle:" /> pretty cycle+                , "graph:" /> pretty graph+                ]+        )+    Right sorted -> pure sorted+  go sorted [(freeVarSet ps, ps) | ps <- filter isRelevantPred preds]+  where+    isRelevantPred TruePred = False+    isRelevantPred DependsOn {} = False+    isRelevantPred (Assert (Lit True)) = False+    isRelevantPred _ = True++    go [] [] = pure []+    go [] ps+      | null $ foldMap fst ps =+          case checkPredsE (pure "Linearizing fails") mempty (map snd ps) of+            Nothing -> pure []+            Just msgs -> genErrorNE msgs+      | otherwise =+          fatalErrorNE $+            NE.fromList+              [ "Dependency error in `linearize`: "+              , show $ indent 2 $ "graph: " /> pretty graph+              , show $+                  indent 2 $+                    "the following left-over constraints are not defining constraints for a unique variable:"+                      /> vsep' (map (pretty . snd) ps)+              ]+    go (n@(Name x) : ns) ps = do+      let (nps, ops) = partition (isLastVariable n . fst) ps+      (normalizeSolverStage (SolverStage x (map snd nps) mempty mempty) :) <$> go ns ops++    isLastVariable n set = n `Set.member` set && solvableFrom n (Set.delete n set) graph++------------------------------------------------------------------------+-- Simplification of Specifications+------------------------------------------------------------------------++-- | Spec simplification, use with care and don't modify the spec after using this!+simplifySpec :: HasSpec a => Specification a -> Specification a+simplifySpec spec = case applyNameHints spec of+  SuspendedSpec x p ->+    let optP = optimisePred p+     in fromGESpec $+          explain+            ("\nWhile calling simplifySpec on var " ++ show x ++ "\noptP=\n" ++ show optP ++ "\n")+            (computeSpecSimplified x optP)+  MemberSpec xs -> MemberSpec xs+  ErrorSpec es -> ErrorSpec es+  TypeSpec ts cant -> TypeSpec ts cant+  TrueSpec -> TrueSpec+  ExplainSpec es s -> explainSpec es (simplifySpec s)++-- ------- Stages of simplifying -------------------------------++-- TODO: it might be necessary to run aggressiveInlining again after the let floating etc.+optimisePred :: Pred -> Pred+optimisePred p =+  simplifyPred+    . letSubexpressionElimination+    . letFloating+    . aggressiveInlining+    . simplifyPred+    $ p++aggressiveInlining :: Pred -> Pred+aggressiveInlining pred+  | inlined = aggressiveInlining pInlined+  | otherwise = pred+  where+    (pInlined, Any inlined) = runWriter $ go (freeVars pred) [] pred++    underBinder fvs x p = fvs `without` [Name x] <> singleton (Name x) (countOf (Name x) p)++    underBinderSub :: HasSpec a => Subst -> Var a -> Subst+    underBinderSub sub x =+      [ x' := t+      | x' := t <- sub+      , isNothing $ eqVar x x'+      ]++    -- NOTE: this is safe because we only use the `Subst` when it results in a literal so there+    -- is no risk of variable capture.+    goBinder :: FreeVars -> Subst -> Binder a -> Writer Any (Binder a)+    goBinder fvs sub (x :-> p) = (x :->) <$> go (underBinder fvs x p) (underBinderSub sub x) p++    -- Check that the name `n` is only ever used as the only variable+    -- in the expressions where it appears. This ensures that it doesn't+    -- interact with anything.+    onlyUsedUniquely n p = case p of+      Assert t+        | n `appearsIn` t -> Set.size (freeVarSet t) == 1+        | otherwise -> True+      And ps -> all (onlyUsedUniquely n) ps+      -- TODO: we can (and should) probably add a bunch of cases to this.+      _ -> False++    go fvs sub pred2 = case pred2 of+      ElemPred bool t xs+        | not (isLit t)+        , Lit a <- substituteAndSimplifyTerm sub t -> do+            tell $ Any True+            pure $ ElemPred bool (Lit a) xs+        | otherwise -> pure $ ElemPred bool t xs+      Subst x t p -> go fvs sub (substitutePred x t p)+      Reifies t' t f+        | not (isLit t)+        , Lit a <- substituteAndSimplifyTerm sub t -> do+            tell $ Any True+            pure $ Reifies t' (Lit a) f+        | otherwise -> pure $ Reifies t' t f+      ForAll set b+        | not (isLit set)+        , Lit a <- substituteAndSimplifyTerm sub set -> do+            tell $ Any True+            pure $ foldMap (`unBind` b) (forAllToList a)+        | otherwise -> ForAll set <$> goBinder fvs sub b+      Case t bs+        | not (isLit t)+        , Lit a <- substituteAndSimplifyTerm sub t -> do+            tell $ Any True+            pure $ runCaseOn a (mapList thing bs) $ \x v p -> substPred (Env.singleton x v) p+        | (Weighted w (x :-> p) :> Nil) <- bs -> do+            let t' = substituteAndSimplifyTerm sub t+            p' <- go (underBinder fvs x p) (x := t' : sub) p+            pure $ Case t (Weighted w (x :-> p') :> Nil)+        | otherwise -> Case t <$> mapMList (traverseWeighted $ goBinder fvs sub) bs+      When b tp+        | not (isLit b)+        , Lit a <- substituteAndSimplifyTerm sub b -> do+            tell $ Any True+            pure $ if a then tp else TruePred+        | otherwise -> whenTrue b <$> go fvs sub tp+      Let t (x :-> p)+        | all (\n -> count n fvs <= 1) (freeVarSet t) -> do+            tell $ Any True+            pure $ substitutePred x t p+        | onlyUsedUniquely (Name x) p -> do+            tell $ Any True+            pure $ substitutePred x t p+        | not $ Name x `appearsIn` p -> do+            tell $ Any True+            pure p+        | not (isLit t)+        , Lit a <- substituteAndSimplifyTerm sub t -> do+            tell $ Any True+            pure $ unBind a (x :-> p)+        | otherwise -> Let t . (x :->) <$> go (underBinder fvs x p) (x := t : sub) p+      Exists k b -> Exists k <$> goBinder fvs sub b+      And ps -> fold <$> mapM (go fvs sub) ps+      Assert t+        | not (isLit t)+        , Lit b <- substituteAndSimplifyTerm sub t -> do+            tell $ Any True+            pure $ toPred b+        | otherwise -> pure pred2+      -- If the term turns into a literal, there is no more generation to do here+      -- so we can ignore the `GenHint`+      GenHint _ t+        | not (isLit t)+        , Lit {} <- substituteAndSimplifyTerm sub t -> do+            tell $ Any True+            pure TruePred+        | otherwise -> pure pred2+      DependsOn t t'+        | not (isLit t)+        , Lit {} <- substituteAndSimplifyTerm sub t -> do+            tell $ Any True+            pure $ TruePred+        | not (isLit t')+        , Lit {} <- substituteAndSimplifyTerm sub t' -> do+            tell $ Any True+            pure $ TruePred+        | otherwise -> pure pred2+      TruePred -> pure pred2+      FalsePred {} -> pure pred2+      Monitor {} -> pure pred2+      Explain es p -> Explain es <$> go fvs sub p++-- | Apply a substitution and simplify the resulting term if the+-- substitution changed the term.+substituteAndSimplifyTerm :: Subst -> Term a -> Term a+substituteAndSimplifyTerm sub t =+  case runWriter $ substituteTerm' sub t of+    (t', Any b)+      | b -> simplifyTerm t'+      | otherwise -> t'++-- | Simplify a Term, if the Term is an 'App', apply the rewrite rules+--   chosen by the (Logic sym t bs a) instance attached+--   to the function witness 'f'+simplifyTerm :: forall a. Term a -> Term a+simplifyTerm = \case+  V v -> V v+  Lit l -> Lit l+  App (f :: t bs a) (mapList simplifyTerm -> ts)+    | Just vs <- fromLits ts -> Lit $ uncurryList_ unValue (semantics f) vs+    | Just t <- rewriteRules f ts (Evidence @(AppRequires t bs a)) -> simplifyTerm t+    | otherwise -> App f ts++simplifyPred :: Pred -> Pred+simplifyPred = \case+  -- If the term simplifies away to a literal, that means there is no+  -- more generation to do so we can get rid of `GenHint`+  GenHint h t -> case simplifyTerm t of+    Lit {} -> TruePred+    t' -> GenHint h t'+  p@(ElemPred bool t xs) -> case simplifyTerm t of+    Lit x -> case (elem x xs, bool) of+      (True, True) -> TruePred+      (True, False) -> FalsePred ("notElemPred reduces to True" :| [show p])+      (False, True) -> FalsePred ("elemPred reduces to False" :| [show p])+      (False, False) -> TruePred+    t' -> ElemPred bool t' xs+  Subst x t p -> simplifyPred $ substitutePred x t p+  Assert t -> Assert $ simplifyTerm t+  Reifies t' t f -> case simplifyTerm t of+    Lit a ->+      -- Assert $ simplifyTerm t' ==. Lit (f a)+      ElemPred True (simplifyTerm t') (pure (f a))+    t'' -> Reifies (simplifyTerm t') t'' f+  ForAll (ts :: Term t) (b :: Binder a) -> case simplifyTerm ts of+    Lit as -> foldMap (`unBind` b) (forAllToList as)+    -- (App (extractW (UnionW @t) -> Just Refl) xs) -> error "MADE IT"+    {- Has to wait until we have HasSpec(Set a) instance+    UnionPat (xs :: Term (Set a)) ys ->+       let b' = simplifyBinder b+       in mkForAll xs b' <> mkForAll ys b' -}+    set' -> case simplifyBinder b of+      _ :-> TruePred -> TruePred+      b' -> ForAll set' b'+  DependsOn _ Lit {} -> TruePred+  DependsOn Lit {} _ -> TruePred+  DependsOn x y -> DependsOn x y+  -- Here is where we need the SumSpec instance+  Case t bs+    | Just es <- buildElemList bs -> ElemPred True (simplifyTerm t) es+    | otherwise -> mkCase (simplifyTerm t) (mapList (mapWeighted simplifyBinder) bs)+    where+      buildElemList :: List (Weighted Binder) as -> Maybe (NE.NonEmpty (SumOver as))+      buildElemList Nil = Nothing+      buildElemList (Weighted Nothing (x :-> ElemPred True (V x') as) :> xs)+        | Just Refl <- eqVar x x' =+            case xs of+              Nil -> Just as+              _ :> _ -> do+                rest <- buildElemList xs+                return $ fmap SumLeft as <> fmap SumRight rest+      buildElemList _ = Nothing+  When b p -> whenTrue (simplifyTerm b) (simplifyPred p)+  TruePred -> TruePred+  FalsePred es -> FalsePred es+  And ps -> fold (simplifyPreds ps)+  Let t b -> case simplifyTerm t of+    t'@App {} -> Let t' (simplifyBinder b)+    -- Variable or literal+    t' | x :-> p <- b -> simplifyPred $ substitutePred x t' p+  Exists k b -> case simplifyBinder b of+    _ :-> TruePred -> TruePred+    -- This is to get rid of exisentials like:+    -- `constrained $ \ x -> exists $ \ y -> [x ==. y, y + 2 <. 10]`+    x :-> p | Just t <- pinnedBy x p -> simplifyPred $ substitutePred x t p+    b' -> Exists k b'+  Monitor {} -> TruePred+  -- TODO: This is a bit questionable. On the one hand we could get rid of `Explain` here+  -- and just return `simplifyPred p` but doing so risks missing explanations when things+  -- do go wrong.+  Explain es p -> explanation es $ simplifyPred p++simplifyPreds :: [Pred] -> [Pred]+simplifyPreds = go [] . map simplifyPred+  where+    go acc [] = reverse acc+    go _ (FalsePred err : _) = [FalsePred err]+    go acc (TruePred : ps) = go acc ps+    go acc (p : ps) = go (p : acc) ps++simplifyBinder :: Binder a -> Binder a+simplifyBinder (x :-> p) = x :-> simplifyPred p++-- TODO: this can probably be cleaned up and generalized along with generalizing+-- to make sure we float lets in some missing cases.+letFloating :: Pred -> Pred+letFloating = fold . go []+  where+    goBlock ctx ps = goBlock' (freeVarNames ctx <> freeVarNames ps) ctx ps++    goBlock' :: Set Int -> [Pred] -> [Pred] -> [Pred]+    goBlock' _ ctx [] = ctx+    goBlock' fvs ctx (Let t (x :-> p) : ps) =+      -- We can do `goBlock'` here because we've already done let floating+      -- on the inner `p`+      [Let t (x' :-> fold (goBlock' (Set.insert (nameOf x') fvs) ctx (p' : ps)))]+      where+        (x', p') = freshen x p fvs+    goBlock' fvs ctx (And ps : ps') = goBlock' fvs ctx (ps ++ ps')+    goBlock' fvs ctx (p : ps) = goBlock' fvs (p : ctx) ps++    goExists ::+      HasSpec a =>+      [Pred] ->+      (Binder a -> Pred) ->+      Var a ->+      Pred ->+      [Pred]+    goExists ctx ex x (Let t (y :-> p))+      | not $ Name x `appearsIn` t =+          let (y', p') = freshen y p (Set.insert (nameOf x) $ freeVarNames p <> freeVarNames t)+           in go ctx (Let t (y' :-> ex (x :-> p')))+    goExists ctx ex x p = ex (x :-> p) : ctx++    pushExplain es (Let t (x :-> p)) = Let t (x :-> pushExplain es p)+    pushExplain es (And ps) = And (pushExplain es <$> ps)+    pushExplain es (Exists k (x :-> p)) =+      Exists (explainSemantics k) (x :-> pushExplain es p)+      where+        -- TODO: Unfortunately this is necessary on ghc 8.10.7+        explainSemantics ::+          forall a.+          ((forall b. Term b -> b) -> GE a) ->+          (forall b. Term b -> b) ->+          GE a+        explainSemantics k2 env = explainNE es $ k2 env+    -- TODO: possibly one wants to have a `Term` level explanation in case+    -- the `b` propagates to ErrorSpec for some reason?+    pushExplain es (When b p) = When b (pushExplain es p)+    pushExplain es p = explanation es p++    go ctx = \case+      ElemPred bool t xs -> ElemPred bool t xs : ctx+      And ps0 -> goBlock ctx (map letFloating ps0)+      Let t (x :-> p) -> goBlock ctx [Let t (x :-> letFloating p)]+      Exists k (x :-> p) -> goExists ctx (Exists k) x (letFloating p)+      Subst x t p -> go ctx (substitutePred x t p)+      Reifies t' t f -> Reifies t' t f : ctx+      Explain es p -> pushExplain es p : ctx+      -- TODO: float let through forall if possible+      ForAll t (x :-> p) -> ForAll t (x :-> letFloating p) : ctx+      -- TODO: float let through the cases if possible+      Case t bs -> Case t (mapList (mapWeighted (\(x :-> p) -> x :-> letFloating p)) bs) : ctx+      -- TODO: float let through if possible+      When b p -> When b (letFloating p) : ctx+      -- Boring cases+      Assert t -> Assert t : ctx+      GenHint h t -> GenHint h t : ctx+      DependsOn t t' -> DependsOn t t' : ctx+      TruePred -> TruePred : ctx+      FalsePred es -> FalsePred es : ctx+      Monitor m -> Monitor m : ctx++-- Common subexpression elimination but only on terms that are already let-bound.+letSubexpressionElimination :: Pred -> Pred+letSubexpressionElimination = go []+  where+    adjustSub :: HasSpec a => Var a -> Subst -> Subst+    adjustSub x sub =+      [ x' := t+      | x' := t <- sub+      , isNothing $ eqVar x x'+      , -- TODO: possibly freshen the binder where+      -- `x` appears instead?+      not $ Name x `appearsIn` t+      ]++    goBinder :: Subst -> Binder a -> Binder a+    goBinder sub (x :-> p) = x :-> go (adjustSub x sub) p++    go sub = \case+      ElemPred bool t xs -> ElemPred bool (backwardsSubstitution sub t) xs+      GenHint h t -> GenHint h (backwardsSubstitution sub t)+      And ps -> And (go sub <$> ps)+      Let t (x :-> p) -> Let t' (x :-> go (x := t' : sub') p)+        where+          t' = backwardsSubstitution sub t+          sub' = adjustSub x sub+      Exists k b -> Exists k (goBinder sub b)+      Subst x t p -> go sub (substitutePred x t p)+      Assert t -> Assert (backwardsSubstitution sub t)+      Reifies t' t f -> Reifies (backwardsSubstitution sub t') (backwardsSubstitution sub t) f+      -- NOTE: this is a tricky case. One possible thing to do here is to keep the old `DependsOn t t'`+      -- and have the new DependsOn if `backwardsSubstitution` changed something. With this semantics you+      -- risk running into unintuitive behaviour if you have something like:+      -- ```+      -- let x = y + z in+      --  {y + z `dependsOn` w+      --   assert $ w <. y + 2+      --   ...}+      -- ```+      -- This will be rewritten as:+      -- ```+      -- let x = y + z in+      --  {z `dependsOn` w+      --   assert $ w <. y + 2+      --   ...}+      -- ```+      -- which changes the dependency order of `w` and `y`. However, fixing+      -- this behaviour in turn makes it more difficult to detect when+      -- variables are no longer used after being substituted away - which+      -- blocks some other optimizations. As we strongly encourage users not to+      -- use `letBind` in their own code most users will never encounter this issue+      -- so the tradeoff is probably worth it.+      DependsOn t t' -> DependsOn (backwardsSubstitution sub t) (backwardsSubstitution sub t')+      ForAll t b -> ForAll (backwardsSubstitution sub t) (goBinder sub b)+      Case t bs -> Case (backwardsSubstitution sub t) (mapList (mapWeighted $ goBinder sub) bs)+      When b p -> When (backwardsSubstitution sub b) (go sub p)+      TruePred -> TruePred+      FalsePred es -> FalsePred es+      Monitor m -> Monitor m+      Explain es p -> Explain es $ go sub p++-- Turning Preds into Specifications. Here is where Propagation occurs ----++-- | Precondition: the `Pred` defines the `Var a`+-- Runs in `GE` in order for us to have detailed context on failure.+computeSpecSimplified ::+  forall a. (HasSpec a, HasCallStack) => Var a -> Pred -> GE (Specification a)+computeSpecSimplified x pred3 = localGESpec $ case simplifyPred pred3 of+  ElemPred True t xs -> propagateSpec (MemberSpec xs) <$> toCtx x t+  ElemPred False (t :: Term b) xs -> propagateSpec (TypeSpec @b (emptySpec @b) (NE.toList xs)) <$> toCtx x t+  Monitor {} -> pure mempty+  GenHint h t -> propagateSpec (giveHint h) <$> toCtx x t+  Subst x' t p' -> computeSpec x (substitutePred x' t p') -- NOTE: this is impossible as it should have gone away already+  TruePred -> pure mempty+  FalsePred es -> genErrorNE es+  And ps -> do+    spec <- fold <$> mapM (computeSpecSimplified x) ps+    case spec of+      ExplainSpec es (SuspendedSpec y ps') -> pure $ explainSpec es (SuspendedSpec y $ simplifyPred ps')+      SuspendedSpec y ps' -> pure $ SuspendedSpec y $ simplifyPred ps'+      s -> pure s+  Let t b -> pure $ SuspendedSpec x (Let t b)+  Exists k b -> pure $ SuspendedSpec x (Exists k b)+  Assert (Lit True) -> pure mempty+  Assert (Lit False) -> genError (show pred3)+  Assert t -> propagateSpec (equalSpec True) <$> toCtx x t+  ForAll (Lit s) b -> fold <$> mapM (\val -> computeSpec x $ unBind val b) (forAllToList s)+  ForAll t b -> do+    bSpec <- computeSpecBinderSimplified b+    propagateSpec (fromForAllSpec bSpec) <$> toCtx x t+  Case (Lit val) bs -> runCaseOn val (mapList thing bs) $ \va vaVal psa -> computeSpec x (substPred (Env.singleton va vaVal) psa)+  Case t branches -> do+    branchSpecs <- mapMList (traverseWeighted computeSpecBinderSimplified) branches+    propagateSpec (caseSpec (Just (showType @a)) branchSpecs) <$> toCtx x t+  When (Lit b) tp -> if b then computeSpecSimplified x tp else pure TrueSpec+  -- This shouldn't happen a lot of the time because when the body is trivial we mostly get rid of the `When` entirely+  When {} -> pure $ SuspendedSpec x pred3+  Reifies (Lit a) (Lit val) f+    | f val == a -> pure TrueSpec+    | otherwise ->+        pure $+          ErrorSpec (NE.fromList ["Value does not reify to literal: " ++ show val ++ " -/> " ++ show a])+  Reifies t' (Lit val) f ->+    propagateSpec (equalSpec (f val)) <$> toCtx x t'+  Reifies Lit {} _ _ ->+    fatalErrorNE $ NE.fromList ["Dependency error in computeSpec: Reifies", "  " ++ show pred3]+  Explain es p -> do+    -- In case things crash in here we want the explanation+    s <- pushGE (NE.toList es) (computeSpecSimplified x p)+    -- This is because while we do want to propagate `explanation`s into `SuspendedSpec`+    -- we probably don't want to propagate the full "currently simplifying xyz" explanation.+    case s of+      SuspendedSpec x2 p2 -> pure $ SuspendedSpec x2 (explanation es p2)+      _ -> pure $ addToErrorSpec es s+  -- Impossible cases that should be ruled out by the dependency analysis and linearizer+  DependsOn {} ->+    fatalErrorNE $+      NE.fromList+        [ "The impossible happened in computeSpec: DependsOn"+        , "  " ++ show x+        , show $ indent 2 (pretty pred3)+        ]+  Reifies {} ->+    fatalErrorNE $+      NE.fromList+        ["The impossible happened in computeSpec: Reifies", "  " ++ show x, show $ indent 2 (pretty pred3)]+  where+    -- We want `genError` to turn into `ErrorSpec` and we want `FatalError` to turn into `FatalError`+    localGESpec ge = case ge of+      (GenError xs) -> Result $ ErrorSpec (catMessageList xs)+      (FatalError es) -> FatalError es+      (Result v) -> Result v++-- | Precondition: the `Pred fn` defines the `Var a`.+--   Runs in `GE` in order for us to have detailed context on failure.+computeSpec ::+  forall a. (HasSpec a, HasCallStack) => Var a -> Pred -> GE (Specification a)+computeSpec x p = computeSpecSimplified x (simplifyPred p)++computeSpecBinderSimplified :: Binder a -> GE (Specification a)+computeSpecBinderSimplified (x :-> p) = computeSpecSimplified x p++-- | Turn a list of branches into a SumSpec. If all the branches fail return an ErrorSpec.+--   Note the requirement of HasSpec(SumOver).+caseSpec ::+  forall as.+  HasSpec (SumOver as) =>+  Maybe String ->+  List (Weighted (Specification)) as ->+  Specification (SumOver as)+caseSpec tString ss+  | allBranchesFail ss =+      ErrorSpec+        ( NE.fromList+            [ "When simplifying SumSpec, all branches in a caseOn" ++ sumType tString ++ " simplify to False."+            , show spec+            ]+        )+  | True = spec+  where+    spec = loop tString ss++    allBranchesFail :: forall as2. List (Weighted Specification) as2 -> Bool+    allBranchesFail Nil = error "The impossible happened in allBranchesFail"+    allBranchesFail (Weighted _ s :> Nil) = isErrorLike s+    allBranchesFail (Weighted _ s :> ss2@(_ :> _)) = isErrorLike s && allBranchesFail ss2++    loop ::+      forall as3.+      HasSpec (SumOver as3) =>+      Maybe String ->+      List (Weighted Specification) as3 ->+      Specification (SumOver as3)+    loop _ Nil = error "The impossible happened in caseSpec"+    loop _ (s :> Nil) = thing s+    loop mTypeString (s :> ss1@(_ :> _))+      | Evidence <- prerequisites @(SumOver as3) =+          (typeSpec $ SumSpecRaw mTypeString theWeights (thing s) (loop Nothing ss1))+      where+        theWeights =+          case (weight s, totalWeight ss1) of+            (Nothing, Nothing) -> Nothing+            (a, b) -> Just (fromMaybe 1 a, fromMaybe (lengthList ss1) b)++------------------------------------------------------------------------+-- SumSpec et al+------------------------------------------------------------------------++-- | The Specification for Sums.+data SumSpec a b+  = SumSpecRaw+      (Maybe String) -- A String which is the type of arg in (caseOn arg branch1 .. branchN)+      (Maybe (Int, Int))+      (Specification a)+      (Specification b)++-- | The "normal" view of t`SumSpec` that doesn't take weights into account+pattern SumSpec ::+  (Maybe (Int, Int)) -> (Specification a) -> (Specification b) -> SumSpec a b+pattern SumSpec a b c <- SumSpecRaw _ a b c+  where+    SumSpec a b c = SumSpecRaw Nothing a b c++{-# COMPLETE SumSpec #-}++sumType :: Maybe String -> String+sumType Nothing = ""+sumType (Just x) = " type=" ++ x++totalWeight :: List (Weighted f) as -> Maybe Int+totalWeight = fmap getSum . foldMapList (fmap Semigroup.Sum . weight)++-- =================================+-- Operations on Stages and Plans++-- | Does nothing if the variable is not in the plan already.+mergeSolverStage :: SolverStage -> [SolverStage] -> [SolverStage]+mergeSolverStage (SolverStage x ps spec relevant) plan =+  [ case eqVar x y of+      Just Refl ->+        normalizeSolverStage $+          SolverStage+            y+            (ps ++ ps')+            (spec <> spec')+            (relevant <> relevant')+      Nothing -> stage+  | stage@(SolverStage y ps' spec' relevant') <- plan+  ]++isEmptyPlan :: SolverPlan -> Bool+isEmptyPlan (SolverPlan plan) = null plan++stepPlan :: MonadGenError m => SolverPlan -> Env -> SolverPlan -> GenT m (Env, SolverPlan)+stepPlan _ env plan@(SolverPlan []) = pure (env, plan)+stepPlan (SolverPlan origStages) env (SolverPlan (stage@(SolverStage (x :: Var a) ps spec relevant) : pl)) = do+  let errorMessage =+        "Failed to step the plan"+          /> vsep+            [ "Relevant parts of the original plan:" //> pretty narrowedOrigPlan+            , "Already generated variables:" //> pretty narrowedEnv+            , "Current stage:" //> pretty stage+            ]+      relevant' = Set.insert (Name x) relevant+      narrowedOrigPlan = SolverPlan $ [st | st@(SolverStage v _ _ _) <- origStages, Name v `Set.member` relevant']+      narrowedEnv = Env.filterKeys env (\v -> nameOf v `Set.member` (Set.map (\(Name n) -> nameOf n) relevant'))+  explain (show errorMessage) $ do+    when (isErrorLike spec) $+      genError "The specification in the current stage is unsatisfiable, giving up."+    when (not $ null ps) $+      fatalError+        "Something went wrong and not all predicates have been discharged. Report this as a bug in Constrained.Generation"+    val <- genFromSpecT spec+    let env1 = Env.extend x val env+    pure (env1, backPropagation relevant' $ SolverPlan (substStage relevant' x val <$> pl))++-- | Generate a satisfying `Env` for a `p : Pred fn`. The `Env` contains values for+-- all the free variables in `flattenPred p`.+genFromPreds :: forall m. MonadGenError m => Env -> Pred -> GenT m Env+-- TODO: remove this once optimisePred does a proper fixpoint computation+genFromPreds env0 (optimisePred . optimisePred -> preds) = do+  -- NOTE: this is just lazy enough that the work of flattening,+  -- computing dependencies, and linearizing is memoized in+  -- properties that use `genFromPreds`.+  origPlan <- runGE $ prepareLinearization preds+  let go :: Env -> SolverPlan -> GenT m Env+      go env plan | isEmptyPlan plan = pure env+      go env plan = do+        (env', plan') <- stepPlan origPlan env plan+        go env' plan'+  go env0 origPlan++-- | Push as much information we can backwards through the plan.+backPropagation :: Set Name -> SolverPlan -> SolverPlan+backPropagation relevant (SolverPlan initplan) = SolverPlan (go [] (reverse initplan))+  where+    go :: [SolverStage] -> [SolverStage] -> [SolverStage]+    go acc [] = acc+    go acc (s@(SolverStage (x :: Var a) ps spec _) : plan) = go (s : acc) plan'+      where+        newStages = concatMap newStage ps+        plan' = foldr mergeSolverStage plan newStages++        -- Note use of the Term Pattern Equal+        newStage (Assert (Equal tl tr))+          | [Name xl] <- Set.toList $ freeVarSet tl+          , [Name xr] <- Set.toList $ freeVarSet tr+          , Result ctxL <- toCtx xl tl+          , Result ctxR <- toCtx xr tr =+              case (eqVar x xl, eqVar x xr) of+                (Just Refl, _) ->+                  [ SolverStage+                      xr+                      []+                      (propagateSpec (forwardPropagateSpec spec ctxL) ctxR)+                      (Set.insert (Name x) relevant)+                  ]+                (_, Just Refl) ->+                  [ SolverStage+                      xl+                      []+                      (propagateSpec (forwardPropagateSpec spec ctxR) ctxL)+                      (Set.insert (Name x) relevant)+                  ]+                _ -> []+        newStage (Case e bs)+          | [Name xe] <- Set.toList $ freeVarSet e+          , Nothing <- eqVar x xe =+              [ SolverStage+                  xe+                  [Case e $ mapList mkBranch bs]+                  TrueSpec+                  (Set.insert (Name x) relevant) -- TODO: this is only true in the+                  -- case where we actually rule some+                  -- stuff out+              ]+          where+            mkBranch :: Weighted Binder x -> Weighted Binder x+            mkBranch (Weighted _ (xb :-> p))+              | Result spec' <- computeSpec x p+              , isErrorLike (spec <> spec') =+                  Weighted Nothing $ xb :-> toPred False+              | otherwise = Weighted Nothing (xb :-> TruePred)+        newStage _ = []++-- | Function symbols for `(==.)`+data EqW :: [Type] -> Type -> Type where+  EqualW :: (Eq a, HasSpec a) => EqW '[a, a] Bool++deriving instance Eq (EqW dom rng)++instance Show (EqW d r) where+  show EqualW = "==."++instance Syntax EqW where+  isInfix EqualW = True++instance Semantics EqW where+  semantics EqualW = (==)++instance Logic EqW where+  propagate f ctxt (ExplainSpec es s) = explainSpec es $ propagate f ctxt s+  propagate _ _ TrueSpec = TrueSpec+  propagate _ _ (ErrorSpec msgs) = ErrorSpec msgs+  propagate EqualW (HOLE :? Value x :> Nil) (SuspendedSpec v ps) =+    constrained $ \v' -> Let (App EqualW (v' :> Lit x :> Nil)) (v :-> ps)+  propagate EqualW (Value x :! Unary HOLE) (SuspendedSpec v ps) =+    constrained $ \v' -> Let (App EqualW (Lit x :> v' :> Nil)) (v :-> ps)+  propagate EqualW (HOLE :? Value s :> Nil) spec =+    caseBoolSpec spec $ \case+      True -> equalSpec s+      False -> notEqualSpec s+  propagate EqualW (Value s :! Unary HOLE) spec =+    caseBoolSpec spec $ \case+      True -> equalSpec s+      False -> notEqualSpec s++  rewriteRules EqualW (t :> t' :> Nil) Evidence+    | t == t' = Just $ lit True+    | otherwise = Nothing++  saturate EqualW (FromGeneric (InjLeft _) :> t :> Nil) = [toPreds t (SumSpec Nothing TrueSpec (ErrorSpec (pure "saturatePred")))]+  saturate EqualW (FromGeneric (InjRight _) :> t :> Nil) = [toPreds t (SumSpec Nothing (ErrorSpec (pure "saturatePred")) TrueSpec)]+  saturate _ _ = []++infix 4 ==.++-- | Equality on the constraint-level+(==.) :: HasSpec a => Term a -> Term a -> Term Bool+(==.) = appTerm EqualW++-- | Pattern version of `(==.)` for rewrite rules+pattern Equal ::+  forall b.+  () =>+  forall a.+  (b ~ Bool, Eq a, HasSpec a) =>+  Term a ->+  Term a ->+  Term b+pattern Equal x y <-+  ( App+      (getWitness -> Just EqualW)+      (x :> y :> Nil)+    )++-- | Like @if b then p else assert True@ in constraint-land+whenTrue :: forall p. IsPred p => Term Bool -> p -> Pred+whenTrue (Lit True) (toPred -> p) = p+whenTrue (Lit False) _ = TruePred+whenTrue b (toPred -> FalsePred {}) = assert (not_ b)+whenTrue _ (toPred -> TruePred) = TruePred+whenTrue b (toPred -> p) = When b p++-- | Is the variable x pinned to some free term in p? (free term+-- meaning that all the variables in the term are free in p).+--+-- TODO: complete this with more cases!+pinnedBy :: forall a. HasSpec a => Var a -> Pred -> Maybe (Term a)+pinnedBy x (Assert (Equal t t'))+  | V x' <- t, Just Refl <- eqVar x x' = Just t'+  | V x' <- t', Just Refl <- eqVar x x' = Just t+pinnedBy x (ElemPred True (V x') (xs NE.:| []))+  | Just Refl <- eqVar x x' = Just (lit xs)+pinnedBy x (And ps) = listToMaybe $ catMaybes $ map (pinnedBy x) ps+pinnedBy x (Explain _ p) = pinnedBy x p+pinnedBy _ _ = Nothing++-- ==================================================================================================+-- TODO: generalize this to make it more flexible and extensible+--+-- The idea here is that we turn constraints into _extra_ constraints. C.f. the+-- `mapIsJust` example in `Constrained.Examples.Map`:++--    mapIsJust :: Specification BaseFn (Int, Int)+--    mapIsJust = constrained' $ \ [var| x |] [var| y |] ->+--      assert $ just_ x ==. lookup_ y (lit $ Map.fromList [(z, z) | z <- [100 .. 102]])++-- Without this code the example wouldn't work because `y` is completely unconstrained during+-- generation. With this code we _essentially_ rewrite occurences of `just_ A == B` to+-- `[just_ A == B, case B of Nothing -> False; Just _ -> True]` to add extra information+-- about the variables in `B`. Consequently, `y` in the example above is+-- constrained to `MemberSpec [100 .. 102]` in the plan. This is implemented using the `saturate`+-- function in the logic type class - in the example above for `==`.+saturatePred :: Pred -> [Pred]+saturatePred p =+  -- [p]+  --  + ---- if there is an Explain, it is still on 'p' here+  --  |+  --  v+  p : case p of+    Explain _es x -> saturatePred x -- Note that the Explain is still on the original 'p', so it is not lost+    -- Note how the saturation is done by the 'saturate' method of the Logic class+    Assert (App sym xs) -> saturate sym xs+    _ -> []++-- ==================================================================+-- HasSpec for Sums+-- ==================================================================++guardSumSpec ::+  forall a b.+  (HasSpec a, HasSpec b, KnownNat (CountCases b)) =>+  [String] ->+  SumSpec a b ->+  Specification (Sum a b)+guardSumSpec msgs s@(SumSpecRaw tString _ sa sb)+  | isErrorLike sa+  , isErrorLike sb =+      ErrorSpec $+        NE.fromList $+          msgs ++ ["All branches in a caseOn" ++ sumType tString ++ " simplify to False.", show s]+  | otherwise = typeSpec s++instance (KnownNat (CountCases b), HasSpec a, HasSpec b) => Show (SumSpec a b) where+  show sumspec@(SumSpecRaw tstring hint l r) = case alternateShow @(Sum a b) sumspec of+    (BinaryShow _ ps) -> show $ parens (fromString ("SumSpec" ++ sumType tstring) /> vsep ps)+    NonBinary ->+      "(SumSpec"+        ++ sumType tstring+        ++ show (sumWeightL hint)+        ++ " ("+        ++ show l+        ++ ") "+        ++ show (sumWeightR hint)+        ++ " ("+        ++ show r+        ++ "))"++combTypeName :: Maybe String -> Maybe String -> Maybe String+combTypeName (Just x) (Just y) =+  if x == y then Just x else Just ("(" ++ x ++ " | " ++ y ++ ")")+combTypeName (Just x) Nothing = Just x+combTypeName Nothing (Just x) = Just x+combTypeName Nothing Nothing = Nothing++instance (HasSpec a, HasSpec b) => Semigroup (SumSpec a b) where+  SumSpecRaw t h sa sb <> SumSpecRaw t' h' sa' sb' =+    SumSpecRaw (combTypeName t t') (unionWithMaybe mergeH h h') (sa <> sa') (sb <> sb')+    where+      -- TODO: think more carefully about this, now weights like 2 2 and 10 15 give more weight to 10 15+      -- than would be the case if you had 2 2 and 2 3. But on the other hand this approach is associative+      -- whereas actually averaging the ratios is not. One could keep a list. Future work.+      mergeH (fA, fB) (fA', fB') = (fA + fA', fB + fB')++instance forall a b. (HasSpec a, HasSpec b, KnownNat (CountCases b)) => Monoid (SumSpec a b) where+  mempty = SumSpec Nothing mempty mempty++-- | How many constructors are there in this type?+type family CountCases a where+  CountCases (Sum a b) = 1 + CountCases b+  CountCases _ = 1++countCases :: forall a. KnownNat (CountCases a) => Int+countCases = fromIntegral (natVal @(CountCases a) Proxy)++-- | The HasSpec Sum instance+instance (HasSpec a, HasSpec b, KnownNat (CountCases b)) => HasSpec (Sum a b) where+  type TypeSpec (Sum a b) = SumSpec a b++  type Prerequisites (Sum a b) = (HasSpec a, HasSpec b)++  emptySpec = mempty++  combineSpec s s' = guardSumSpec ["When combining SumSpecs", "  " ++ show s, "  " ++ show s'] (s <> s')++  conformsTo (SumLeft a) (SumSpec _ sa _) = conformsToSpec a sa+  conformsTo (SumRight b) (SumSpec _ _ sb) = conformsToSpec b sb++  genFromTypeSpec (SumSpec h sa sb)+    | emptyA, emptyB = genError "genFromTypeSpec @SumSpec: empty"+    | emptyA = SumRight <$> genFromSpecT sb+    | emptyB = SumLeft <$> genFromSpecT sa+    | fA == 0, fB == 0 = genError "All frequencies 0"+    | otherwise =+        frequencyT+          [ (fA, SumLeft <$> genFromSpecT sa)+          , (fB, SumRight <$> genFromSpecT sb)+          ]+    where+      (max 0 -> fA, max 0 -> fB) = fromMaybe (1, countCases @b) h+      emptyA = isErrorLike sa+      emptyB = isErrorLike sb++  shrinkWithTypeSpec (SumSpec _ sa _) (SumLeft a) = SumLeft <$> shrinkWithSpec sa a+  shrinkWithTypeSpec (SumSpec _ _ sb) (SumRight b) = SumRight <$> shrinkWithSpec sb b++  fixupWithTypeSpec (SumSpec _ sa _) (SumLeft a) = SumLeft <$> fixupWithSpec sa a+  fixupWithTypeSpec (SumSpec _ _ sb) (SumRight b) = SumRight <$> fixupWithSpec sb b++  toPreds ct (SumSpec h sa sb) =+    Case+      ct+      ( (Weighted (fst <$> h) $ bind $ \a -> satisfies a sa)+          :> (Weighted (snd <$> h) $ bind $ \b -> satisfies b sb)+          :> Nil+      )++  cardinalTypeSpec (SumSpec _ leftspec rightspec) = addSpecInt (cardinality leftspec) (cardinality rightspec)++  typeSpecHasError (SumSpec _ x y) =+    case (isErrorLike x, isErrorLike y) of+      (True, True) -> Just $ (errorLikeMessage x <> errorLikeMessage y)+      _ -> Nothing++  alternateShow (SumSpec h left right@(TypeSpec r [])) =+    case alternateShow @b r of+      (BinaryShow "SumSpec" ps) -> BinaryShow "SumSpec" ("|" <+> sumWeightL h <+> viaShow left : ps)+      (BinaryShow "Cartesian" ps) ->+        BinaryShow "SumSpec" ("|" <+> sumWeightL h <+> viaShow left : [parens ("Cartesian" /> vsep ps)])+      _ ->+        BinaryShow "SumSpec" ["|" <+> sumWeightL h <+> viaShow left, "|" <+> sumWeightR h <+> viaShow right]+  alternateShow (SumSpec h left right) =+    BinaryShow "SumSpec" ["|" <+> sumWeightL h <+> viaShow left, "|" <+> sumWeightR h <+> viaShow right]++-- ======================================+-- Here are the Logic Instances for Sum++-- | Function symbols for `injLeft_` and `injRight_`+data SumW dom rng where+  InjLeftW :: SumW '[a] (Sum a b)+  InjRightW :: SumW '[b] (Sum a b)++instance Show (SumW dom rng) where+  show InjLeftW = "injLeft_"+  show InjRightW = "injRight_"++deriving instance (Eq (SumW dom rng))++instance Syntax SumW++instance Semantics SumW where+  semantics InjLeftW = SumLeft+  semantics InjRightW = SumRight++instance Logic SumW where+  propagateTypeSpec InjLeftW (Unary HOLE) (SumSpec _ sl _) cant = sl <> foldMap notEqualSpec [a | SumLeft a <- cant]+  propagateTypeSpec InjRightW (Unary HOLE) (SumSpec _ _ sr) cant = sr <> foldMap notEqualSpec [a | SumRight a <- cant]++  propagateMemberSpec InjLeftW (Unary HOLE) es =+    case [a | SumLeft a <- NE.toList es] of+      (x : xs) -> MemberSpec (x :| xs)+      [] ->+        ErrorSpec $+          pure $+            "propMemberSpec (sumleft_ HOLE) on (MemberSpec es) with no SumLeft in es: " ++ show (NE.toList es)+  propagateMemberSpec InjRightW (Unary HOLE) es =+    case [a | SumRight a <- NE.toList es] of+      (x : xs) -> MemberSpec (x :| xs)+      [] ->+        ErrorSpec $+          pure $+            "propagate(InjRight HOLE) on (MemberSpec es) with no SumLeft in es: " ++ show (NE.toList es)++  mapTypeSpec InjLeftW ts = typeSpec $ SumSpec Nothing (typeSpec ts) (ErrorSpec (pure "mapTypeSpec InjLeftW"))+  mapTypeSpec InjRightW ts = typeSpec $ SumSpec Nothing (ErrorSpec (pure "mapTypeSpec InjRightW")) (typeSpec ts)++-- | Constructor for `Sum`+injLeft_ :: (HasSpec a, HasSpec b, KnownNat (CountCases b)) => Term a -> Term (Sum a b)+injLeft_ = appTerm InjLeftW++-- | Constructor for `Sum`+injRight_ :: (HasSpec a, HasSpec b, KnownNat (CountCases b)) => Term b -> Term (Sum a b)+injRight_ = appTerm InjRightW++-- | Pattern for building custom rewrite rules+pattern InjRight ::+  forall c.+  () =>+  forall a b.+  ( c ~ Sum a b+  , AppRequires SumW '[b] c+  ) =>+  Term b ->+  Term c+pattern InjRight x <- (App (getWitness -> Just InjRightW) (x :> Nil))++-- | Pattern for building custom rewrite rules+pattern InjLeft ::+  forall c.+  () =>+  forall a b.+  ( c ~ Sum a b+  , AppRequires SumW '[a] c+  ) =>+  Term a ->+  Term c+pattern InjLeft x <- App (getWitness -> Just InjLeftW) (x :> Nil)++sumWeightL, sumWeightR :: Maybe (Int, Int) -> Doc a+sumWeightL Nothing = "1"+sumWeightL (Just (x, _)) = fromString (show x)+sumWeightR Nothing = "1"+sumWeightR (Just (_, x)) = fromString (show x)++-- | Operations on Bool+data BoolW (dom :: [Type]) (rng :: Type) where+  NotW :: BoolW '[Bool] Bool+  OrW :: BoolW '[Bool, Bool] Bool++deriving instance Eq (BoolW dom rng)++instance Show (BoolW dom rng) where+  show NotW = "not_"+  show OrW = "or_"++boolSem :: BoolW dom rng -> FunTy dom rng+boolSem NotW = not+boolSem OrW = (||)++instance Semantics BoolW where+  semantics = boolSem++instance Syntax BoolW++-- ======= Logic instance BoolW++instance Logic BoolW where+  propagate f ctxt (ExplainSpec [] s) = propagate f ctxt s+  propagate f ctxt (ExplainSpec es s) = ExplainSpec es $ propagate f ctxt s+  propagate _ _ TrueSpec = TrueSpec+  propagate _ _ (ErrorSpec msgs) = ErrorSpec msgs+  propagate NotW (Unary HOLE) (SuspendedSpec v ps) =+    constrained $ \v' -> Let (App NotW (v' :> Nil)) (v :-> ps)+  propagate NotW (Unary HOLE) spec =+    caseBoolSpec spec (equalSpec . not)+  propagate OrW (HOLE :<: x) (SuspendedSpec v ps) =+    constrained $ \v' -> Let (App OrW (v' :> Lit x :> Nil)) (v :-> ps)+  propagate OrW (x :>: HOLE) (SuspendedSpec v ps) =+    constrained $ \v' -> Let (App OrW (Lit x :> v' :> Nil)) (v :-> ps)+  propagate OrW (HOLE :<: s) spec =+    caseBoolSpec spec (okOr s)+  propagate OrW (s :>: HOLE) spec =+    caseBoolSpec spec (okOr s)++  mapTypeSpec NotW () = typeSpec ()++-- | We have something like ('constant' ||. HOLE) must evaluate to 'need'.+--   Return a (Specification Bool) for HOLE, that makes that True.+okOr :: Bool -> Bool -> Specification Bool+okOr constant need = case (constant, need) of+  (True, True) -> TrueSpec+  (True, False) ->+    ErrorSpec+      (pure ("(" ++ show constant ++ "||. HOLE) must equal False. That cannot be the case."))+  (False, False) -> MemberSpec (pure False)+  (False, True) -> MemberSpec (pure True)++-- | Disjunction on @`Term` `Bool`@, note that this will not cause backtracking during generation+or_ :: Term Bool -> Term Bool -> Term Bool+or_ = appTerm OrW++-- | Negation of booleans+not_ :: Term Bool -> Term Bool+not_ = appTerm NotW++-- ===============================================================================+-- Syntax for Solving : stages and plans++data SolverStage where+  SolverStage ::+    HasSpec a =>+    { stageVar :: Var a+    , stagePreds :: [Pred]+    , stageSpec :: Specification a+    , relevantVariables :: Set Name+    } ->+    SolverStage++docVar :: Typeable a => Var a -> Doc h+docVar (v :: Var a) = fromString (show v ++ " :: " ++ showType @a)++instance Pretty SolverStage where+  pretty SolverStage {..} =+    docVar stageVar+      <+> "<-"+        /> vsep'+          ( [pretty stageSpec | not $ isTrueSpec stageSpec]+              ++ ["---" | not $ null stagePreds, not $ isTrueSpec stageSpec]+              ++ map pretty stagePreds+              ++ ["_" | null stagePreds && isTrueSpec stageSpec]+          )++newtype SolverPlan = SolverPlan {solverPlan :: [SolverStage]}++instance Pretty SolverPlan where+  pretty SolverPlan {..} =+    "SolverPlan" /> prettyLinear solverPlan++isTrueSpec :: Specification a -> Bool+isTrueSpec TrueSpec = True+isTrueSpec _ = False++prettyLinear :: [SolverStage] -> Doc ann+prettyLinear = vsep' . map pretty++fromGESpec :: HasCallStack => GE (Specification a) -> Specification a+fromGESpec ge = case ge of+  Result s -> s+  GenError xs -> ErrorSpec (catMessageList xs)+  FatalError es -> error $ catMessages es++-- | Functor like property for Specification, but instead of a Haskell function (a -> b),+--   it takes a function symbol (t '[a] b) from a to b.+--   Note, in this context, a function symbol is some constructor of a witnesstype.+--   Eg. ProdFstW, InjRightW, SingletonW, etc. NOT the lifted versions like fst_ singleton_,+--   which construct Terms. We had to wait until here to define this because it+--   depends on Semigroup property of Specification, and Asserting equality+mapSpec ::+  forall t a b.+  AppRequires t '[a] b =>+  t '[a] b ->+  Specification a ->+  Specification b+mapSpec f (ExplainSpec es s) = explainSpec es (mapSpec f s)+mapSpec f TrueSpec = mapTypeSpec f (emptySpec @a)+mapSpec _ (ErrorSpec err) = ErrorSpec err+mapSpec f (MemberSpec as) = MemberSpec $ NE.nub $ fmap (semantics f) as+mapSpec f (SuspendedSpec x p) =+  constrained $ \x' ->+    Exists (\_ -> fatalError "mapSpec") (x :-> fold [Assert $ (x' ==. appTerm f (V x)), p])+mapSpec f (TypeSpec ts cant) = mapTypeSpec f ts <> notMemberSpec (map (semantics f) cant)++-- TODO generalizeme!+forwardPropagateSpec :: HasSpec a => Specification a -> Ctx a b -> Specification b+forwardPropagateSpec s CtxHOLE = s+forwardPropagateSpec s (CtxApp f (c :? Nil))+  | Evidence <- ctxHasSpec c = mapSpec f (forwardPropagateSpec s c)+forwardPropagateSpec _ _ = TrueSpec
+ src/Constrained/Generic.hs view
@@ -0,0 +1,395 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- | How we automatically inject normal Haskell types into the logic, using+-- `GHC.Generics`+module Constrained.Generic (+  -- * Generic representation++  -- `HasSimpleRep` is the reason we have this module. It's going to allow us+  -- to define `Constrained.Base.HasSpec` instances generically via instances+  -- for the underlying `Sum` and t`Prod` types.+  HasSimpleRep (..),++  -- * Underlying representation+  Prod (..),+  Sum (..),+  (:::),+  SOP,+  SOPLike (..),+  SOPOf,+  ALG,+  Inject (..),+  ProdOver,+  ConstrOf,+  inject,+  SumOver,+) where++import Constrained.List+import Data.Functor.Const+import Data.Functor.Identity+import Data.Kind+import Data.Typeable+import GHC.Generics+import GHC.TypeLits++------------------------------------------------------------------------+-- Pairs+------------------------------------------------------------------------++-- | Pairs; this is a separate type from `(,)` to avoid confusion between internal+-- representation of generic types and user-facing use of `(,)`+data Prod a b = Prod {prodFst :: a, prodSnd :: b}+  deriving (Eq, Ord)++instance (Show a, Show b) => Show (Prod a b) where+  show (Prod x y) = "(Prod " ++ show x ++ " " ++ show y ++ ")"++-- | Turn a type-level list into either, t`()`, a singleton type, or+-- nested uses of t`Prod`+type family ProdOver (as :: [Type]) where+  ProdOver '[] = ()+  ProdOver '[a] = a+  ProdOver (a : as) = Prod a (ProdOver as)++listToProd :: (ProdOver as -> r) -> List Identity as -> r+listToProd k Nil = k ()+listToProd k (Identity a :> Nil) = k a+listToProd k (Identity a :> b :> as) = k (Prod a (listToProd id (b :> as)))++prodToList :: forall as. TypeList as => ProdOver as -> List Identity as+prodToList = go (listShape @as)+  where+    go ::+      forall ts.+      List (Const ()) ts ->+      ProdOver ts ->+      List Identity ts+    go Nil _ = Nil+    go (_ :> Nil) a = Identity a :> Nil+    go (_ :> ix :> ixs) (Prod a as) = Identity a :> go (ix :> ixs) as++appendProd ::+  forall xs ys.+  (TypeList xs, TypeList ys) =>+  ProdOver xs ->+  ProdOver ys ->+  ProdOver (Append xs ys)+appendProd xs ys = listToProd id (appendList @Identity @xs @ys (prodToList xs) (prodToList ys))++splitProd ::+  forall xs ys.+  (TypeList xs, TypeList ys) =>+  ProdOver (Append xs ys) ->+  Prod (ProdOver xs) (ProdOver ys)+splitProd = go (listShape @xs) (listShape @ys)+  where+    go ::+      List (Const ()) as ->+      List (Const ()) bs ->+      ProdOver (Append as bs) ->+      Prod (ProdOver as) (ProdOver bs)+    go Nil _ p = Prod () p+    go (_ :> Nil) Nil p = Prod p ()+    go (_ :> Nil) (_ :> _) p = p+    go (_ :> a :> as) bs (Prod x xs) = Prod (Prod x p0) p1+      where+        Prod p0 p1 = go (a :> as) bs xs++------------------------------------------------------------------------+-- Sums+------------------------------------------------------------------------++-- | Sum types; different from `Either` for the same reason t`Prod` is different+-- from `(,)`+data Sum a b+  = SumLeft a+  | SumRight b+  deriving (Ord, Eq, Show)++-- | Convert a list of types to a nested `Sum`+type family SumOver as where+  SumOver '[a] = a+  SumOver (a : as) = Sum a (SumOver as)++-- | The idea is for each type, we define a type family `HasSimpleRep` the maps+-- that type to another type we already know how to deal with. The methods+-- `toSimpleRep` and `fromSimpleRep` cature that knowledge. The strategy we+-- want to use most of the time, is to use `GHC.Generics`, to construct the+-- `SimpleRep` out of `Sum` and t`Prod`, and to write the `toSimpleRep` and+-- `fromSimpleRep` methods automatically. If we can do that, then every thing+-- else will come for free. Note that it is not REQUIRED to make the+-- @`SimpleRep` t@ out of `Sum` and t`Prod`, but it helps and it is the default.+class Typeable (SimpleRep a) => HasSimpleRep a where+  type SimpleRep a+  type TheSop a :: [Type]+  toSimpleRep :: a -> SimpleRep a+  fromSimpleRep :: SimpleRep a -> a++  type TheSop a = SOPOf (Rep a)+  type SimpleRep a = SOP (TheSop a)++  default toSimpleRep ::+    ( Generic a+    , SimpleGeneric (Rep a)+    , SimpleRep a ~ SimplifyRep (Rep a)+    ) =>+    a ->+    SimpleRep a+  toSimpleRep = toSimpleRep' . from++  default fromSimpleRep ::+    ( Generic a+    , SimpleGeneric (Rep a)+    , SimpleRep a ~ SimplifyRep (Rep a)+    ) =>+    SimpleRep a ->+    a+  fromSimpleRep = to . fromSimpleRep'++type family SimplifyRep f where+  SimplifyRep f = SOP (SOPOf f)++instance HasSimpleRep () where+  type SimpleRep () = ()+  toSimpleRep x = x+  fromSimpleRep x = x++-- ===============================================================+-- How to move back and forth from (SimpleRep a) to 'a' in a+-- generic way, derived by the Generics machinery is captured+-- by the SimpleGeneric class+-- ===============================================================++class SimpleGeneric rep where+  toSimpleRep' :: rep p -> SimplifyRep rep+  fromSimpleRep' :: SimplifyRep rep -> rep p++instance SimpleGeneric f => SimpleGeneric (D1 d f) where+  toSimpleRep' (M1 f) = toSimpleRep' f+  fromSimpleRep' a = M1 (fromSimpleRep' a)++instance+  ( SimpleGeneric f+  , SimpleGeneric g+  , SopList (SOPOf f) (SOPOf g)+  ) =>+  SimpleGeneric (f :+: g)+  where+  toSimpleRep' (L1 f) = injectSOPLeft @(SOPOf f) @(SOPOf g) $ toSimpleRep' f+  toSimpleRep' (R1 g) = injectSOPRight @(SOPOf f) @(SOPOf g) $ toSimpleRep' g+  fromSimpleRep' sop =+    case caseSOP @(SOPOf f) @(SOPOf g) sop of+      SumLeft l -> L1 (fromSimpleRep' l)+      SumRight r -> R1 (fromSimpleRep' r)++instance SimpleConstructor f => SimpleGeneric (C1 ('MetaCons c a b) f) where+  toSimpleRep' (M1 f) = toSimpleCon' f+  fromSimpleRep' a = M1 (fromSimpleCon' a)++-- ================================================================================+--    This part of the code base is responsible for implementing the conversion+--    from a `Generic` type to a `Sum` over `Prod` representation that automatically+--    gives you an instance of `HasSpec`. The user has three options for building their+--    own instances of `HasSpec`, either they hand-roll an instance, they go with the+--    entirely `Generic` instance, or they provide their own `SimpleRep` for their type.+--+--    The latter may be appropriate when the type is an optimized representation:+--+--    ```+--    newtype Foo = Foo { unFoo :: MemoBytes ActualFoo }+--+--    instance HasSimpleRep Foo where+--      type SimpleRep Foo = ActualFoo+--      toSimpleRep = unMemoBytes . unFoo+--      fromSimpleRep = Foo . memoBytes+--    ```+--+--    This would then allow for `Foo` to be treated as a simple `newtype` over `ActualFoo`+--    in constraints:+--+--    ```+--    fooSpec :: Specification Foo+--    fooSpec = constrained $ \ foo ->+--      match foo $ \ actualFoo -> ...+--    ```+-- =========================================================================================++-- Building a SOP type (Sum Of Prod) --------------------------------------++-- | A constructor name with the types of its arguments+data (c :: Symbol) ::: (ts :: [Type])++-- | Turn a `Rep` into a list that flattens the sum+-- structre and gives the constructors names:+-- > Maybe Int -> '["Nothing" ::: '[()], "Just" ::: '[Int]]+-- > Either Int Bool -> '["Left" ::: '[Int], "Right" ::: '[Bool]]+-- > data Foo = Foo Int Bool | Bar Double -> '["Foo" ::: '[Int, Bool], "Bar" ::: '[Double]]+type family SOPOf f where+  SOPOf (D1 _ f) = SOPOf f+  SOPOf (f :+: g) = Append (SOPOf f) (SOPOf g)+  SOPOf (C1 ('MetaCons constr _ _) f) = '[constr ::: Constr f]++-- | Flatten a single constructor+type family Constr f where+  -- TODO: Here we should put in the selector names+  -- so that they can be re-used to create selectors more+  -- easily than the current disgusting `Fst . Snd . Snd . Snd ...`+  -- method.+  Constr (S1 _ f) = Constr f+  Constr (K1 _ k) = '[k]+  Constr U1 = '[()]+  Constr (f :*: g) = Append (Constr f) (Constr g)++-- | Turn a list from `SOPOf` into a `Sum` over+-- t`Prod` representation.+type family SOP constrs where+  SOP '[c ::: prod] = ProdOver prod+  SOP ((c ::: prod) : constrs) = Sum (ProdOver prod) (SOP constrs)++-- Constructing an SOP ----------------------------------------------------++-- | Get the type of a specific constructor in an `SOP`+type family ConstrOf c sop where+  ConstrOf c (c ::: constr : sop) = constr+  ConstrOf c (_ : sop) = ConstrOf c sop++class Inject c constrs r where+  inject' :: (SOP constrs -> r) -> FunTy (ConstrOf c constrs) r++instance TypeList prod => Inject c '[c ::: prod] r where+  inject' k = curryList_ @prod Identity (listToProd k)++instance TypeList prod => Inject c ((c ::: prod) : prod' : constrs) r where+  inject' k = curryList_ @prod Identity (listToProd (k . SumLeft @_ @(SOP (prod' : constrs))))++instance+  {-# OVERLAPPABLE #-}+  ( FunTy (ConstrOf c ((c' ::: prod) : con : constrs)) r ~ FunTy (ConstrOf c (con : constrs)) r+  , -- \^ An unfortunately roundabout way of saying `c !~ c'`+    Inject c (con : constrs) r+  ) =>+  Inject c ((c' ::: prod) : con : constrs) r+  where+  inject' k = inject' @c @(con : constrs) (k . SumRight)++-- | Inject a single constructor into an SOP+inject ::+  forall c constrs. Inject c constrs (SOP constrs) => FunTy (ConstrOf c constrs) (SOP constrs)+inject = inject' @c @constrs id++-- Deconstructing an SOP --------------------------------------------------++-- | An `ALG constrs r` is a function that takes a way to turn every+-- constructor into an @r@:+-- ```+-- ALG (SOPOf (Rep (Either Int Bool))) r = (Int -> r) -> (Bool -> r) -> r+-- ```+type family ALG constrs r where+  ALG '[c ::: prod] r = FunTy prod r -> r+  ALG ((c ::: prod) : constrs) r = FunTy prod r -> ALG constrs r++class SOPLike constrs r where+  -- | Run a `SOP`+  algebra :: SOP constrs -> ALG constrs r++  -- | Ignore everything in the `SOP`+  consts :: r -> ALG constrs r++instance TypeList prod => SOPLike '[c ::: prod] r where+  algebra prod f = uncurryList_ @_ @prod runIdentity f $ prodToList prod+  consts r _ = r++instance (TypeList prod, SOPLike (con : cases) r) => SOPLike ((c ::: prod) : con : cases) r where+  algebra (SumLeft prod) f = consts @(con : cases) @r (algebra @'[c ::: prod] prod f)+  algebra (SumRight rest) _ = algebra @(con : cases) @r rest++  consts r _ = consts @(con : cases) r++-- ========================================================+-- The individual constructor level -----------------------++class SimpleConstructor rep where+  toSimpleCon' :: rep p -> ProdOver (Constr rep)+  fromSimpleCon' :: ProdOver (Constr rep) -> rep p++instance+  ( SimpleConstructor f+  , SimpleConstructor g+  , TypeList (Constr f)+  , TypeList (Constr g)+  ) =>+  SimpleConstructor (f :*: g)+  where+  toSimpleCon' (a :*: b) = appendProd @(Constr f) @(Constr g) (toSimpleCon' a) (toSimpleCon' b)+  fromSimpleCon' constr =+    let Prod a b = splitProd @(Constr f) @(Constr g) constr+     in (fromSimpleCon' a :*: fromSimpleCon' b)++instance SimpleConstructor f => SimpleConstructor (S1 s f) where+  toSimpleCon' (M1 f) = toSimpleCon' f+  fromSimpleCon' a = M1 (fromSimpleCon' a)++instance SimpleConstructor (K1 i k) where+  toSimpleCon' (K1 k) = k+  fromSimpleCon' k = K1 k++instance SimpleConstructor U1 where+  toSimpleCon' U1 = ()+  fromSimpleCon' _ = U1++-- ===================================================+-- The sum type level --------------------------------++-- | Construct and deconstruct cases in a `SOP`+class SopList xs ys where+  injectSOPLeft :: SOP xs -> SOP (Append xs ys)+  injectSOPRight :: SOP ys -> SOP (Append xs ys)+  caseSOP :: SOP (Append xs ys) -> Sum (SOP xs) (SOP ys)++instance SopList '[c ::: x] (y : ys) where+  injectSOPLeft = SumLeft+  injectSOPRight = SumRight+  caseSOP = id++instance SopList (x' : xs) (y : ys) => SopList (c ::: x : x' : xs) (y : ys) where+  injectSOPLeft (SumLeft a) = SumLeft a+  injectSOPLeft (SumRight b) = SumRight (injectSOPLeft @(x' : xs) @(y : ys) b)++  injectSOPRight a = SumRight (injectSOPRight @(x' : xs) @(y : ys) a)++  caseSOP (SumLeft a) = SumLeft (SumLeft a)+  caseSOP (SumRight b) = case caseSOP @(x' : xs) @(y : ys) b of+    SumLeft b' -> SumLeft (SumRight b')+    SumRight b' -> SumRight b'++-- ===========================================================+-- How it works+-- If the TypeSpec method of the HasSpec class has a SimpleRep instance, Like this+-- type TypeSpec = a+-- where 'a' has a Sum Product representation then all of the other methods+-- can use the default implementation. This saves lots of trouble for mundane types.+--+-- `HasSimpleRep` and `GenericsFn` are meant to allow you to express that a+-- type is isomorphic to some other type 't' that has a (HasSpec t) instance.+--+-- The trick is that the default instance of `HasSpec a` assumes+-- `HasSimpleRep a` and defines `TypeSpec a = TypeSpec (SimpleRep a)`.+--+-- From this it's possible to work with things of type `a` in constraints by+-- treating them like things of type `SimpleRep a`. This allows us to do case+-- matching etc. on `a` when `SimpleRep a` is a `Sum` type, for example.+--+-- Or alternatively it allows us to treat `a` as a newtype over `SimpleRep a`+-- when using `match`.+-- ====================================================================
+ src/Constrained/Graph.hs view
@@ -0,0 +1,213 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}++-- | This module provides a dependency graph implementation.+module Constrained.Graph (+  Graph,+  edges,+  opEdges,+  opGraph,+  mkGraph,+  nodes,+  deleteNode,+  subtractGraph,+  dependency,+  findCycle,+  dependsOn,+  dependencies,+  noDependencies,+  topsort,+  transitiveClosure,+  transitiveDependencies,+  irreflexiveDependencyOn,+) where++import Control.Monad+import Data.Foldable+-- TODO: consider using more of this+import Data.Graph qualified as G+import Data.List (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, Eq)++instance Ord node => Semigroup (Graph node) where+  Graph e o <> Graph e' o' =+    Graph+      (Map.unionWith (<>) e e')+      (Map.unionWith (<>) o o')++instance Ord node => Monoid (Graph node) where+  mempty = Graph mempty mempty++instance Pretty n => Pretty (Graph n) where+  pretty gr =+    fold $+      punctuate+        hardline+        [ nest 4 $ pretty n <> " <- " <> brackets (fillSep (map pretty (Set.toList ns)))+        | (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++-- | Delete a node from a graph+deleteNode :: Ord node => node -> Graph node -> Graph node+deleteNode x (Graph e o) = Graph (clean e) (clean o)+  where+    clean = Map.delete x . fmap (Set.delete x)++-- | Invert the graph+opGraph :: Graph node -> Graph node+opGraph (Graph e o) = Graph o e++-- | @subtractGraph g g'@ is the graph @g@ without the dependencies in @g'@+subtractGraph :: Ord node => Graph node -> Graph node -> Graph node+subtractGraph (Graph e o) (Graph e' o') =+  Graph+    (Map.differenceWith del e e')+    (Map.differenceWith del o o')+  where+    del x y = Just $ Set.difference x y++-- | @dependency x xs@ is the graph where @x@ depends on every node in @xs@+-- and there are no other dependencies.+dependency :: Ord node => node -> Set node -> Graph node+dependency x xs =+  Graph+    (Map.singleton x xs)+    ( Map.unionWith+        (<>)+        (Map.singleton x mempty)+        (Map.fromList [(y, Set.singleton x) | y <- Set.toList xs])+    )++-- | Every node in the first set depends on every node in the second set except themselves+irreflexiveDependencyOn :: Ord node => Set node -> Set node -> Graph node+irreflexiveDependencyOn xs ys =+  deps <> noDependencies ys+  where+    deps =+      Graph+        (Map.fromDistinctAscList [(x, Set.delete x ys) | x <- Set.toList xs])+        (Map.fromDistinctAscList [(a, Set.delete a xs) | a <- Set.toList ys])++-- | Get all down-stream dependencies of a node+transitiveDependencies :: Ord node => node -> Graph node -> Set node+transitiveDependencies x (Graph e _) = go mempty (Set.toList $ fromMaybe mempty $ Map.lookup x e)+  where+    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+transitiveClosure g = foldMap (\x -> dependency x (transitiveDependencies x g)) (nodes g)++-- | The discrete graph containing all the input nodes without any dependencies+noDependencies :: Ord node => Set node -> Graph node+noDependencies ns = Graph nodeMap nodeMap+  where+    nodeMap = Map.fromList ((,mempty) <$> Set.toList ns)++-- | Topsort the graph, returning either @Right order@ if the graph is a DAG or+-- @Left cycle@  if it is not+topsort :: Ord node => Graph node -> Either [node] [node]+topsort gr@(Graph e _) = go [] e+  where+    go order g+      | null g = pure $ reverse order+      | otherwise = do+          let noDeps = Map.keysSet . Map.filter null $ g+              removeNode n ds = Set.difference ds noDeps <$ guard (not $ n `Set.member` noDeps)+          if not $ null noDeps+            then go (Set.toList noDeps ++ order) (Map.mapMaybeWithKey removeNode g)+            else Left $ findCycle gr++-- | Simple DFS cycle finding+findCycle :: Ord node => Graph node -> [node]+findCycle g@(Graph e _) = mkCycle . concat . take 1 . filter isCyclic . map (map tr) . concatMap cycles . G.scc $ gr+  where+    edgeList = [(n, n, Set.toList es) | (n, es) <- Map.toList e]+    (gr, tr0, _) = G.graphFromEdges edgeList+    tr x = let (n, _, _) = tr0 x in n+    cycles (G.Node a []) = [[a]]+    cycles (G.Node a as) = (a :) <$> concatMap cycles as+    isCyclic [] = False+    isCyclic [a] = dependsOn a a g+    isCyclic _ = True+    -- Removes a non-dependent stem from the start of the dependencies+    mkCycle ns = let l = last ns in dropWhile (\n -> not $ dependsOn l n g) ns++-- | Get the dependencies of a node in the graph, `mempty` if the node is not+-- in the graph+dependencies :: Ord node => node -> Graph node -> Set node+dependencies x (Graph e _) = fromMaybe mempty (Map.lookup x e)++-- | Check if a node depends on another in the graph+dependsOn :: Ord node => node -> node -> Graph node -> Bool+dependsOn x y g = y `Set.member` dependencies x g
+ src/Constrained/List.hs view
@@ -0,0 +1,250 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}++-- | A module for working with type-indexed heterogenous lists, sometimes+-- called inductive tuples.+module Constrained.List (+  -- * Lists+  List (..),++  -- ** Type families+  Length,+  (:!),+  All,+  MapList,+  Append,+  FunTy,++  -- ** Common functions for working with `List`+  TypeList (..),+  toList,+  toListC,+  mapList,+  mapListC,+  mapMList,+  mapMListC,+  foldMapList,+  foldMapListC,+  appendList,+  lengthList,+  uncurryList,+  uncurryList_,++  -- * List contexts+  ListCtx (..),+  pattern NilCtx,+  pattern ListCtx,+  fillListCtx,+  mapListCtx,+  mapListCtxC,+) where++import Data.Foldable (fold)+import Data.Functor.Const+import Data.Kind+import Data.Semigroup (Sum (..))+import GHC.TypeLits++-- | A heterogeneous list / an inductive tuple. We use this heavily to+-- represent arguments to functions in terms+data List (f :: k -> Type) (as :: [k]) where+  Nil :: List f '[]+  (:>) :: f a -> List f as -> List f (a : as)++infixr 5 :>++deriving instance (forall a. Show (f a)) => Show (List f as)++deriving instance (forall a. Eq (f a)) => Eq (List f as)++-- | Type level `length`+type family Length (as :: [k]) :: Nat where+  Length '[] = 0+  Length (_ : as) = 1 + Length as++-- | Get the @n@:th element of the type-level list @as@+type family (as :: [k]) :! n :: k where+  '[] :! n = TypeError ('Text "Indexing into empty type-level list")+  (a : as) :! 0 = a+  (a : as) :! n = as :! (n - 1)++-- | Convert a @`List` f@ to a normal list with an algebra for @f@+toList :: (forall a. f a -> b) -> List f as -> [b]+toList _ Nil = []+toList f (x :> xs) = f x : toList f xs++-- | Like `toList` when you need a constraint on the elements of the index of the `List`+toListC :: forall c f as b. All c as => (forall a. c a => f a -> b) -> List f as -> [b]+toListC _ Nil = []+toListC f (x :> xs) = f x : toListC @c f xs++-- | Map a natural transformation from @f@ to @g@ over a `List`+mapList :: (forall a. f a -> g a) -> List f as -> List g as+mapList _ Nil = Nil+mapList f (x :> xs) = f x :> mapList f xs++-- | Like `mapList` where the natural transformation is constrained+mapListC :: forall c as f g. All c as => (forall a. c a => f a -> g a) -> List f as -> List g as+mapListC _ Nil = Nil+mapListC f (x :> xs) = f x :> mapListC @c f xs++-- | Monadic (actually applicative) `mapList`+mapMList :: Applicative m => (forall a. f a -> m (g a)) -> List f as -> m (List g as)+mapMList _ Nil = pure Nil+mapMList f (x :> xs) = (:>) <$> f x <*> mapMList f xs++-- | Monadic (actually applicative) `mapListC`+mapMListC ::+  forall c as f g m.+  (Applicative m, All c as) =>+  (forall a. c a => f a -> m (g a)) ->+  List f as ->+  m (List g as)+mapMListC _ Nil = pure Nil+mapMListC f (x :> xs) = (:>) <$> f x <*> mapMListC @c f xs++-- | Like `foldMap` for t`List`+foldMapList :: Monoid b => (forall a. f a -> b) -> List f as -> b+foldMapList f = fold . toList f++-- | Like `foldMapList` where the mapped function has a constraint+foldMapListC ::+  forall c as b f. (All c as, Monoid b) => (forall a. c a => f a -> b) -> List f as -> b+foldMapListC f = fold . toListC @c f++-- | Append two t`List`s+appendList :: List f as -> List f bs -> List f (Append as bs)+appendList Nil bs = bs+appendList (a :> as) bs = a :> appendList as bs++-- | Like `length` for `List`+lengthList :: List f as -> Int+lengthList = getSum . foldMapList (const $ Sum 1)++-- | Append two type-level lists+type family Append as as' where+  Append '[] as' = as'+  Append (a : as) as' = a : Append as as'++-- | Map a type functor over a list+type family MapList (f :: k -> j) as where+  MapList f '[] = '[]+  MapList f (a : as) = f a : MapList f as++-- | A function type from @ts@ to @res@:+--  @FunTy '[Int, Bool] Double = Int -> Bool -> Double@+type family FunTy ts res where+  FunTy '[] a = a+  FunTy (a : as) r = a -> FunTy as r++-- | Apply a function that takes @`MapList` f ts@ to a @`List` f ts@+uncurryList :: FunTy (MapList f ts) r -> List f ts -> r+uncurryList r Nil = r+uncurryList f (a :> as) = uncurryList (f a) as++-- | Like `uncurryList` but first apply an algebra to get rid of the @f@ type+-- wrapper+uncurryList_ :: (forall a. f a -> a) -> FunTy ts r -> List f ts -> r+uncurryList_ _ a Nil = a+uncurryList_ k f (a :> as) = uncurryList_ k (f $ k a) as++-- | Higher-order functions for working on `List`s+class TypeList ts where+  curryList :: (List f ts -> r) -> FunTy (MapList f ts) r+  curryList_ :: (forall a. a -> f a) -> (List f ts -> r) -> FunTy ts r++  -- | Materialize the shape of the type list @as@, this is very useful+  -- for avoiding having to write type classes that recurse over @as@.+  listShape :: List (Const ()) ts++-- | NOTE: the two instances for `TypeList` are @`TypeList` []@ and+-- @`TypeList` (a : as)@. That way its basically just a structurally+-- recursive function on type-level lists that computes the `TypeList`+-- dictionary (mostly) statically.+instance TypeList '[] where+  curryList f = f Nil+  curryList_ _ f = f Nil+  listShape = Nil++instance TypeList as => TypeList (a : as) where+  curryList f a = curryList (\xs -> f (a :> xs))+  curryList_ p f a = curryList_ p (\xs -> f (p a :> xs))+  listShape = Const () :> listShape++-- | Every element @a@ of @as@ obeys constraint @c a@+type family All (c :: k -> Constraint) (as :: [k]) :: Constraint where+  All c '[] = ()+  All c (a : as) = (c a, All c as)++-- | A List with a hole in it, can be seen as a zipper+-- over type-level lists.+--+-- We use this to represent arguments to functions in+-- evaluation contexts (terms with a single hole).+data ListCtx f (as :: [Type]) c where+  (:?) :: c a -> List f as -> ListCtx f (a : as) c+  (:!) :: f a -> ListCtx f as c -> ListCtx f (a : as) c++infixr 5 :?, :!++-- | A Convenient pattern for singleton contexts+pattern NilCtx :: c a -> ListCtx f '[a] c+pattern NilCtx c = ListCtx Nil c Nil++{-# COMPLETE NilCtx #-}++-- | A view of a t`ListCtx` where you see the whole context at the same time.+pattern ListCtx ::+  () => as'' ~ Append as (a : as') => List f as -> c a -> List f as' -> ListCtx f as'' c+pattern ListCtx as c as' <- (toWholeCtx -> ListCtxWhole as c as')+  where+    ListCtx as c as' = fromWholeCtx $ ListCtxWhole as c as'++{-# COMPLETE ListCtx #-}++-- | Internals for the t`ListCtx` pattern+data ListCtxWhole f as c where+  ListCtxWhole ::+    List f as ->+    c a ->+    List f as' ->+    ListCtxWhole f (Append as (a : as')) c++toWholeCtx :: ListCtx f as c -> ListCtxWhole f as c+toWholeCtx (hole :? suf) = ListCtxWhole Nil hole suf+toWholeCtx (x :! xs)+  | ListCtxWhole pre hole suf <- toWholeCtx xs =+      ListCtxWhole (x :> pre) hole suf++fromWholeCtx :: ListCtxWhole f as c -> ListCtx f as c+fromWholeCtx (ListCtxWhole Nil hole suf) = hole :? suf+fromWholeCtx (ListCtxWhole (x :> pre) hole suf) = x :! fromWholeCtx (ListCtxWhole pre hole suf)++-- | Instantiate the hole in a t`ListCtx` to obtain a t`List`+fillListCtx :: ListCtx f as c -> (forall a. c a -> f a) -> List f as+fillListCtx (ListCtx pre c post) f = appendList pre (f c :> post)++-- | Transform a @t`ListCtx` f c@ to a @t`ListCtx` g` c@ via a natural transformation+mapListCtx :: (forall a. f a -> g a) -> ListCtx f as c -> ListCtx g as c+mapListCtx nt (ListCtx pre c post) = ListCtx (mapList nt pre) c (mapList nt post)++-- | Like `mapListCtx` but the natural transformation may have a constraint+mapListCtxC ::+  forall c as f g h. All c as => (forall a. c a => f a -> g a) -> ListCtx f as h -> ListCtx g as h+mapListCtxC nt (h :? as) = h :? mapListC @c nt as+mapListCtxC nt (a :! ctx) = nt a :! mapListCtxC @c nt ctx
+ src/Constrained/NumOrd.hs view
@@ -0,0 +1,1283 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE UndecidableSuperClasses #-}+{-# LANGUAGE ViewPatterns #-}+-- Random Natural, Arbitrary Natural, Uniform Natural+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Everything we need to deal with numbers and comparisons between them+module Constrained.NumOrd (+  NumSpec (..),+  (>.),+  (<.),+  (-.),+  (>=.),+  (<=.),+  (+.),+  (*.),+  negate_,+  cardinality,+  caseBoolSpec,+  addSpecInt,+  emptyNumSpec,+  cardinalNumSpec,+  combineNumSpec,+  genFromNumSpec,+  shrinkWithNumSpec,+  fixupWithNumSpec,+  fixupWithTypeSpec,+  conformsToNumSpec,+  toPredsNumSpec,+  OrdLike (..),+  MaybeBounded (..),+  NumLike (..),+  HasDivision (..),+  Numeric,+  Number,+  nubOrd,+  IntW (..),+  OrdW (..),+) where++import Constrained.AbstractSyntax+import Constrained.Base+import Constrained.Conformance+import Constrained.Core (Value (..), unionWithMaybe)+import Constrained.FunctionSymbol+import Constrained.GenT+import Constrained.Generic+import Constrained.List+import Constrained.PrettyUtils+import Control.Applicative ((<|>))+import Control.Arrow (first)+import Data.Containers.ListUtils+import Data.Foldable+import Data.Kind+import Data.List (nub)+import Data.List.NonEmpty (NonEmpty ((:|)))+import qualified Data.List.NonEmpty as NE+import Data.Maybe+import Data.Typeable (typeOf)+import Data.Word+import GHC.Int+import GHC.Natural+import GHC.Real+import System.Random.Stateful (Random (..), Uniform (..))+import Test.QuickCheck (Arbitrary (arbitrary, shrink), choose, frequency)++-- | Witnesses for comparison operations (<=. and <. and <=. and >=.) on numbers+-- The other operations are defined in terms of these.+data OrdW (dom :: [Type]) (rng :: Type) where+  LessOrEqualW :: OrdLike a => OrdW '[a, a] Bool+  LessW :: OrdLike a => OrdW '[a, a] Bool+  GreaterOrEqualW :: OrdLike a => OrdW '[a, a] Bool+  GreaterW :: OrdLike a => OrdW '[a, a] Bool++deriving instance Eq (OrdW ds r)++instance Show (OrdW ds r) where+  show LessOrEqualW = "<=."+  show LessW = "<."+  show GreaterOrEqualW = ">=."+  show GreaterW = ">."++instance Semantics OrdW where+  semantics LessOrEqualW = (<=)+  semantics LessW = (<)+  semantics GreaterW = (>)+  semantics GreaterOrEqualW = (>=)++instance Syntax OrdW where+  isInfix _ = True++-- =============================================+-- OrdLike. Ord for Numbers in the Logic+-- =============================================++-- | Ancillary things we need to be able to implement `Logic` instances for+-- `OrdW` that make sense for a given type we are comparing things on.+class (Ord a, HasSpec a) => OrdLike a where+  leqSpec :: a -> Specification a+  default leqSpec ::+    ( GenericRequires a+    , OrdLike (SimpleRep a)+    ) =>+    a ->+    Specification a+  leqSpec = fromSimpleRepSpec . leqSpec . toSimpleRep++  ltSpec :: a -> Specification a+  default ltSpec ::+    ( OrdLike (SimpleRep a)+    , GenericRequires a+    ) =>+    a ->+    Specification a+  ltSpec = fromSimpleRepSpec . ltSpec . toSimpleRep++  geqSpec :: a -> Specification a+  default geqSpec ::+    ( OrdLike (SimpleRep a)+    , GenericRequires a+    ) =>+    a ->+    Specification a+  geqSpec = fromSimpleRepSpec . geqSpec . toSimpleRep++  gtSpec :: a -> Specification a+  default gtSpec ::+    ( OrdLike (SimpleRep a)+    , GenericRequires a+    ) =>+    a ->+    Specification a+  gtSpec = fromSimpleRepSpec . gtSpec . toSimpleRep++-- | This instance should be general enough for every type of Number that has a NumSpec as its TypeSpec+instance {-# OVERLAPPABLE #-} (Ord a, HasSpec a, MaybeBounded a, Num a, TypeSpec a ~ NumSpec a) => OrdLike a where+  leqSpec l = typeSpec $ NumSpecInterval Nothing (Just l)+  ltSpec l+    | Just b <- lowerBound+    , l == b =+        ErrorSpec (pure ("ltSpec @" ++ show (typeOf l) ++ " " ++ show l))+    | otherwise = typeSpec $ NumSpecInterval Nothing (Just (l - 1))+  geqSpec l = typeSpec $ NumSpecInterval (Just l) Nothing+  gtSpec l+    | Just b <- upperBound+    , l == b =+        ErrorSpec (pure ("gtSpec @" ++ show (typeOf l) ++ " " ++ show l))+    | otherwise = typeSpec $ NumSpecInterval (Just (l + 1)) Nothing++-- ========================================================================+-- helper functions for the TypeSpec for Numbers+-- ========================================================================++-- | Helper class for talking about things that _might_ be `Bounded`+class MaybeBounded a where+  lowerBound :: Maybe a+  upperBound :: Maybe a++  default lowerBound :: Bounded a => Maybe a+  lowerBound = Just minBound++  default upperBound :: Bounded a => Maybe a+  upperBound = Just maxBound++newtype Unbounded a = Unbounded a++instance MaybeBounded (Unbounded a) where+  lowerBound = Nothing+  upperBound = Nothing++instance MaybeBounded Int++instance MaybeBounded Int64++instance MaybeBounded Int32++instance MaybeBounded Int16++instance MaybeBounded Int8++instance MaybeBounded Word64++instance MaybeBounded Word32++instance MaybeBounded Word16++instance MaybeBounded Word8++deriving via Unbounded Integer instance MaybeBounded Integer++deriving via Unbounded (Ratio Integer) instance MaybeBounded (Ratio Integer)++deriving via Unbounded Float instance MaybeBounded Float++deriving via Unbounded Double instance MaybeBounded Double++instance MaybeBounded Natural where+  lowerBound = Just 0+  upperBound = Nothing++-- ===================================================================+-- The TypeSpec for numbers+-- ===================================================================++-- | t`TypeSpec` for numbers - represented as a single interval+data NumSpec n = NumSpecInterval (Maybe n) (Maybe n)++instance Ord n => Eq (NumSpec n) where+  NumSpecInterval ml mh == NumSpecInterval ml' mh'+    | isEmpty ml mh = isEmpty ml' mh'+    | isEmpty ml' mh' = isEmpty ml mh+    | otherwise = ml == ml' && mh == mh'+    where+      isEmpty (Just a) (Just b) = a > b+      isEmpty _ _ = False++instance Show n => Show (NumSpec n) where+  show (NumSpecInterval ml mu) = lb ++ ".." ++ ub+    where+      lb = "[" ++ maybe "" show ml+      ub = maybe "" show mu ++ "]"++instance Ord n => Semigroup (NumSpec n) where+  NumSpecInterval ml mu <> NumSpecInterval ml' mu' =+    NumSpecInterval+      (unionWithMaybe max ml ml')+      (unionWithMaybe min mu mu')++instance Ord n => Monoid (NumSpec n) where+  mempty = NumSpecInterval Nothing Nothing++-- ===========================================+-- Arbitrary for Num like things+-- ===========================================++instance (Arbitrary a, Ord a) => Arbitrary (NumSpec a) where+  arbitrary = do+    m <- arbitrary+    m' <- arbitrary+    frequency [(10, pure $ mkLoHiInterval m m'), (1, pure $ NumSpecInterval m m')]+    where+      mkLoHiInterval (Just a) (Just b) = NumSpecInterval (Just $ min a b) (Just $ max a b)+      mkLoHiInterval m m' = NumSpecInterval m m'+  shrink (NumSpecInterval m m') =+    uncurry NumSpecInterval <$> shrink (m, m')++#if !MIN_VERSION_QuickCheck(2, 17, 0)+instance Arbitrary Natural where+  arbitrary = wordToNatural . abs <$> arbitrary+  shrink n = [wordToNatural w | w <- shrink (naturalToWord n)]+#endif++instance Uniform Natural where+  uniformM g = wordToNatural . abs <$> uniformM g++instance Random Natural where+  randomR (lo, hi) g = first fromIntegral $ randomR (toInteger lo, toInteger hi) g++instance Random (Ratio Integer) where+  randomR (lo, hi) g =+    let (r, g') = random g+     in (lo + (hi - lo) * r, g')+  random g =+    let (d, g') = first ((+ 1) . abs) $ random g+        (n, g'') = randomR (0, d) g'+     in (n % d, g'')++-- ==============================================================================+-- Operations on NumSpec, that give it the required properties of a TypeSpec+-- ==============================================================================++-- | Admits anything+emptyNumSpec :: Ord a => NumSpec a+emptyNumSpec = mempty++guardNumSpec ::+  (Ord n, HasSpec n, TypeSpec n ~ NumSpec n) =>+  [String] ->+  NumSpec n ->+  Specification n+guardNumSpec msg s@(NumSpecInterval (Just a) (Just b))+  | a > b = ErrorSpec ("NumSpec has low bound greater than hi bound" :| (("   " ++ show s) : msg))+  | a == b = equalSpec a+guardNumSpec _ s = typeSpec s++-- | Conjunction+combineNumSpec ::+  (HasSpec n, Ord n, TypeSpec n ~ NumSpec n) =>+  NumSpec n ->+  NumSpec n ->+  Specification n+combineNumSpec s s' = guardNumSpec ["when combining two NumSpecs", "   " ++ show s, "   " ++ show s'] (s <> s')++-- | Generate a value that satisfies the spec+genFromNumSpec ::+  (MonadGenError m, Show n, Random n, Ord n, Num n, MaybeBounded n) =>+  NumSpec n ->+  GenT m n+genFromNumSpec (NumSpecInterval ml mu) = do+  n <- sizeT+  pureGen . choose =<< constrainInterval (ml <|> lowerBound) (mu <|> upperBound) (fromIntegral n)++-- TODO: fixme++-- | Try to shrink using a `NumSpec`+shrinkWithNumSpec :: Arbitrary n => NumSpec n -> n -> [n]+shrinkWithNumSpec _ = shrink++-- TODO: fixme++fixupWithNumSpec :: Arbitrary n => NumSpec n -> n -> Maybe n+fixupWithNumSpec _ = listToMaybe . shrink++constrainInterval ::+  (MonadGenError m, Ord a, Num a, Show a) => Maybe a -> Maybe a -> Integer -> m (a, a)+constrainInterval ml mu r =+  case (ml, mu) of+    (Nothing, Nothing) -> pure (-r', r')+    (Just l, Nothing)+      | l < 0 -> pure (max l (negate r'), r')+      | otherwise -> pure (l, l + 2 * r')+    (Nothing, Just u)+      | u > 0 -> pure (negate r', min u r')+      | otherwise -> pure (u - r' - r', u)+    (Just l, Just u)+      | l > u -> genError ("bad interval: " ++ show l ++ " " ++ show u)+      | u < 0 -> pure (safeSub l (safeSub l u r') r', u)+      | l >= 0 -> pure (l, safeAdd u (safeAdd u l r') r')+      -- TODO: this is a bit suspect if the bounds are lopsided+      | otherwise -> pure (max l (-r'), min u r')+  where+    r' = abs $ fromInteger r+    safeSub l a b+      | a - b > a = l+      | otherwise = max l (a - b)+    safeAdd u a b+      | a + b < a = u+      | otherwise = min u (a + b)++-- | Check that a value is in the spec+conformsToNumSpec :: Ord n => n -> NumSpec n -> Bool+conformsToNumSpec i (NumSpecInterval ml mu) = maybe True (<= i) ml && maybe True (i <=) mu++-- =======================================================================+-- Several of the methods of HasSpec that have default implementations+-- could benefit from type specific implementations for numbers. Those+-- implementations are found here+-- =====================================================================++-- | Builds a MemberSpec, but returns an Error spec if the list is empty+nubOrdMemberSpec :: Ord a => String -> [a] -> Specification a+nubOrdMemberSpec message xs =+  memberSpec+    (nubOrd xs)+    ( NE.fromList+        [ "In call to nubOrdMemberSpec"+        , "Called from context"+        , message+        , "The input is the empty list."+        ]+    )++lowBound :: Bounded n => Maybe n -> n+lowBound Nothing = minBound+lowBound (Just n) = n++highBound :: Bounded n => Maybe n -> n+highBound Nothing = maxBound+highBound (Just n) = n++-- | The exact count of the number elements in a Bounded NumSpec+countSpec :: forall n. (Bounded n, Integral n) => NumSpec n -> Integer+countSpec (NumSpecInterval lo hi) = if lo > hi then 0 else toInteger high - toInteger low + 1+  where+    high = highBound hi+    low = lowBound lo++-- | The exact number of elements in a Bounded Integral type.+finiteSize :: forall n. (Integral n, Bounded n) => Integer+finiteSize = toInteger (maxBound @n) - toInteger (minBound @n) + 1++-- | This is an optimizing version of  TypeSpec :: TypeSpec n -> [n] -> Specification n+--   for Bounded NumSpecs.+--                    notInNumSpec :: Bounded n => TypeSpec n -> [n] -> Specification n+--   We use this function to specialize the (HasSpec t) method 'typeSpecOpt' for Bounded n.+--   So given (TypeSpec interval badlist) we might want to transform it to (MemberSpec goodlist)+--   There are 2 opportunities where this can payoff big time.+--   1) Suppose the total count of the elements in the interval is < length badlist+--      we can then return (MemberSpec (filter elements (`notElem` badlist)))+--      this must be smaller than (TypeSpec interval badlist) because the filtered list must be smaller than badlist+--   2) Suppose the type 't' is finite with size N. If the length of the badlist > (N/2), then the number of possible+--      good things must be smaller than (length badlist), because (possible good + bad == N), so regardless of the+--      count of the interval (MemberSpec (filter elements (`notElem` badlist))) is better. Sometimes much better.+--      Example, let 'n' be the finite set {0,1,2,3,4,5,6,7,8,9} and the bad list be [0,1,3,4,5,6,8,9]+--      (TypeSpec [0..9]  [0,1,3,4,5,6,8,9]) = filter  {0,1,2,3,4,5,6,7,8,9} (`notElem` [0,1,3,4,5,6,8,9]) = [2,7]+--      So (MemberSpec [2,7]) is better than  (TypeSpec [0..9]  [0,1,3,4,5,6,8,9]). This works no matter what+--      the count of interval is. We only need the (length badlist > (N/2)).+notInNumSpec ::+  forall n.+  ( HasSpec n+  , TypeSpec n ~ NumSpec n+  , Bounded n+  , Integral n+  ) =>+  NumSpec n ->+  [n] ->+  Specification n+notInNumSpec ns@(NumSpecInterval a b) bad+  | toInteger (length bad) > (finiteSize @n `div` 2) || countSpec ns < toInteger (length bad) =+      nubOrdMemberSpec+        ("call to: (notInNumSpec " ++ show ns ++ " " ++ show bad ++ ")")+        [x | x <- [lowBound a .. highBound b], notElem x bad]+  | otherwise = TypeSpec @n ns bad++-- ==========================================================================+-- Num n => (NumSpec n) can support operation of Num as interval arithmetic.+-- So we will make a (Num (NumSpec Integer)) instance. We won't make other+-- instances, because  they would be subject to overflow.+-- Given operator ☉, then (a,b) ☉ (c,d) = (minimum s, maximum s) where s = [a ☉ c, a ☉ d, b ☉ c, b ☉ d]+-- There are simpler rules for (+) and (-), but for (*) we need to use the general rule.+-- ==========================================================================++guardEmpty :: (Ord n, Num n) => Maybe n -> Maybe n -> NumSpec n -> NumSpec n+guardEmpty (Just a) (Just b) s+  | a <= b = s+  | otherwise = NumSpecInterval (Just 1) (Just 0)+guardEmpty _ _ s = s++addNumSpec :: (Ord n, Num n) => NumSpec n -> NumSpec n -> NumSpec n+addNumSpec (NumSpecInterval x y) (NumSpecInterval a b) =+  guardEmpty x y $+    guardEmpty a b $+      NumSpecInterval ((+) <$> x <*> a) ((+) <$> y <*> b)++subNumSpec :: (Ord n, Num n) => NumSpec n -> NumSpec n -> NumSpec n+subNumSpec (NumSpecInterval x y) (NumSpecInterval a b) =+  guardEmpty x y $+    guardEmpty a b $+      NumSpecInterval ((-) <$> x <*> b) ((-) <$> y <*> a)++multNumSpec :: (Ord n, Num n) => NumSpec n -> NumSpec n -> NumSpec n+multNumSpec (NumSpecInterval a b) (NumSpecInterval c d) =+  guardEmpty a b $+    guardEmpty c d $+      NumSpecInterval (unT (minimum s)) (unT (maximum s))+  where+    s = [multT (neg a) (neg c), multT (neg a) (pos d), multT (pos b) (neg c), multT (pos b) (pos d)]++negNumSpec :: Num n => NumSpec n -> NumSpec n+negNumSpec (NumSpecInterval lo hi) = NumSpecInterval (negate <$> hi) (negate <$> lo)++instance Num (NumSpec Integer) where+  (+) = addNumSpec+  (-) = subNumSpec+  (*) = multNumSpec+  negate = negNumSpec+  fromInteger n = NumSpecInterval (Just (fromInteger n)) (Just (fromInteger n))+  abs = error "No abs in the Num (NumSpec  Integer) instance"+  signum = error "No signum in the Num (NumSpec  Integer) instance"++-- ========================================================================+-- Helper functions for interval multiplication+--  (a,b) * (c,d) = (minimum s, maximum s) where s = [a * c, a * d, b * c, b * d]++-- | T is a sort of special version of Maybe, with two Nothings.+--   Given:: NumSpecInterval (Maybe n) (Maybe n) -> Numspec+--   We can't distinguish between the two Nothings in (NumSpecInterval Nothing Nothing)+--   But using (NumSpecInterval NegInf PosInf) we can, In fact we can make a total ordering on 'T'+--   So an ascending Sorted [T x] would all the NegInf on the left and all the PosInf on the right, with+--   the Ok's sorted in between. I.e. [NegInf, NegInf, Ok 3, Ok 6, Ok 12, Pos Inf]+data T x = NegInf | Ok x | PosInf+  deriving (Show, Eq, Ord)++-- \| Conversion between (T x) and (Maybe x)+unT :: T x -> Maybe x+unT (Ok x) = Just x+unT _ = Nothing++-- | Use this on the lower bound. I.e. lo from pair (lo,hi)+neg :: Maybe x -> T x+neg Nothing = NegInf+neg (Just x) = Ok x++-- | Use this on the upper bound. I.e. hi from pair (lo,hi)+pos :: Maybe x -> T x+pos Nothing = PosInf+pos (Just x) = Ok x++-- | multiply two (T x), correctly handling the infinities NegInf and PosInf+multT :: Num x => T x -> T x -> T x+multT NegInf NegInf = PosInf+multT NegInf PosInf = NegInf+multT NegInf (Ok _) = NegInf+multT (Ok _) NegInf = NegInf+multT (Ok x) (Ok y) = Ok (x * y)+multT (Ok _) PosInf = PosInf+multT PosInf PosInf = PosInf+multT PosInf NegInf = NegInf+multT PosInf (Ok _) = PosInf++-- ========================================================================+-- We have+-- (1) Num Integer+-- (2) Num (NumSpec Integer)   And we need+-- (3) Num (Specification Integer)+-- We need this to implement the method cardinalTypeSpec of (HasSpec t).+-- cardinalTypeSpec :: HasSpec a => TypeSpec a -> Specification Integer+-- Basically for defining these two cases+-- cardinalTypeSpec (Cartesian x y) = (cardinality x) * (cardinality y)+-- cardinalTypeSpec (SumSpec leftspec rightspec) = (cardinality leftspec) + (cardinality rightspec)+-- So we define addSpecInt for (+)   and  multSpecInt for (*)++-- | What constraints we need to make HasSpec instance for a Haskell numeric type.+--   By abstracting over this, we can avoid making actual HasSpec instances until+--   all the requirements (HasSpec Bool, HasSpec(Sum a b)) have been met in+--   Constrained.TheKnot.+type Number n = (Num n, Enum n, TypeSpec n ~ NumSpec n, Num (NumSpec n), HasSpec n, Ord n)++-- | Addition on `Specification` for `Number`+addSpecInt ::+  Number n =>+  Specification n ->+  Specification n ->+  Specification n+addSpecInt x y = operateSpec " + " (+) (+) x y++subSpecInt ::+  Number n =>+  Specification n ->+  Specification n ->+  Specification n+subSpecInt x y = operateSpec " - " (-) (-) x y++multSpecInt ::+  Number n =>+  Specification n ->+  Specification n ->+  Specification n+multSpecInt x y = operateSpec " * " (*) (*) x y++-- | let 'n' be some numeric type, and 'f' and 'ft' be operations on 'n' and (TypeSpec n)+--   Then lift these operations from (TypeSpec n) to (Specification n)+--   Normally 'f' will be a (Num n) instance method (+,-,*) on n,+--   and 'ft' will be a a (Num (TypeSpec n)) instance method (+,-,*) on (TypeSpec n)+--   But this will work for any operations 'f' and 'ft' with the right types+operateSpec ::+  Number n =>+  String ->+  (n -> n -> n) ->+  (TypeSpec n -> TypeSpec n -> TypeSpec n) ->+  Specification n ->+  Specification n ->+  Specification n+operateSpec operator f ft (ExplainSpec es x) y = explainSpec es $ operateSpec operator f ft x y+operateSpec operator f ft x (ExplainSpec es y) = explainSpec es $ operateSpec operator f ft x y+operateSpec operator f ft x y = case (x, y) of+  (ErrorSpec xs, ErrorSpec ys) -> ErrorSpec (xs <> ys)+  (ErrorSpec xs, _) -> ErrorSpec xs+  (_, ErrorSpec ys) -> ErrorSpec ys+  (TrueSpec, _) -> TrueSpec+  (_, TrueSpec) -> TrueSpec+  (_, SuspendedSpec _ _) -> TrueSpec+  (SuspendedSpec _ _, _) -> TrueSpec+  (TypeSpec a bad1, TypeSpec b bad2) -> TypeSpec (ft a b) [f b1 b2 | b1 <- bad1, b2 <- bad2]+  (MemberSpec xs, MemberSpec ys) ->+    nubOrdMemberSpec+      (show x ++ operator ++ show y)+      [f x1 y1 | x1 <- NE.toList xs, y1 <- NE.toList ys]+  -- This block is all (MemberSpec{}, TypeSpec{}) with MemberSpec on the left+  (MemberSpec ys, TypeSpec (NumSpecInterval (Just i) (Just j)) bad) ->+    let xs = NE.toList ys+     in nubOrdMemberSpec+          (show x ++ operator ++ show y)+          [f x1 y1 | x1 <- xs, y1 <- [i .. j], not (elem y1 bad)]+  -- Somewhat loose spec here, but more accurate then TrueSpec, it is exact if 'xs' has one element (i.e. 'xs' = [i])+  (MemberSpec ys, TypeSpec (NumSpecInterval lo hi) bads) ->+    -- We use the specialized version of 'TypeSpec' 'typeSpecOpt'+    let xs = NE.toList ys+     in typeSpecOpt+          (NumSpecInterval (f (minimum xs) <$> lo) (f (maximum xs) <$> hi))+          [f x1 b | x1 <- xs, b <- bads]+  -- we flip the arguments, so we need to flip the functions as well+  (sleft, sright) -> operateSpec operator (\a b -> f b a) (\u v -> ft v u) sright sleft++-- | This is very liberal, since in lots of cases it returns TrueSpec.+--  for example all operations on SuspendedSpec, and certain+--  operations between TypeSpec and MemberSpec. Perhaps we should+--  remove it. Only the addSpec (+) and multSpec (*) methods are used.+--  But, it is kind of cool ...+--  In Fact we can use this to make Num(Specification n) instance for any 'n'.+--  But, only Integer is safe, because in all other types (+) and especially+--  (-) can lead to overflow or underflow failures.+instance Number Integer => Num (Specification Integer) where+  (+) = addSpecInt+  (-) = subSpecInt+  (*) = multSpecInt+  fromInteger n = TypeSpec (NumSpecInterval (Just n) (Just n)) []+  abs _ = TrueSpec+  signum _ = TrueSpec++-- ===========================================================================++-- | Put some (admittedly loose bounds) on the number of solutions that+--   'genFromTypeSpec' might return. For lots of types, there is no way to be very accurate.+--   Here we lift the HasSpec methods 'cardinalTrueSpec' and 'cardinalTypeSpec'+--   from (TypeSpec Integer) to (Specification Integer)+cardinality ::+  forall a. (Number Integer, HasSpec a) => Specification a -> Specification Integer+cardinality (ExplainSpec es s) = explainSpec es (cardinality s)+cardinality TrueSpec = cardinalTrueSpec @a+cardinality (MemberSpec es) = equalSpec (toInteger $ length (nub (NE.toList es)))+cardinality ErrorSpec {} = equalSpec 0+cardinality (TypeSpec s cant) =+  subSpecInt+    (cardinalTypeSpec @a s)+    (equalSpec (toInteger $ length (nub $ filter (\c -> conformsTo @a c s) cant)))+cardinality SuspendedSpec {} = cardinalTrueSpec @a++-- | A generic function to use as an instance for the HasSpec method+--   cardinalTypeSpec :: HasSpec a => TypeSpec a -> Specification Integer+--   for types 'n' such that (TypeSpec n ~ NumSpec n)+cardinalNumSpec ::+  forall n. (Integral n, MaybeBounded n, HasSpec n) => NumSpec n -> Specification Integer+cardinalNumSpec (NumSpecInterval (Just lo) (Just hi)) =+  if hi >= lo+    then equalSpec (toInteger hi - toInteger lo + 1)+    else equalSpec 0+cardinalNumSpec (NumSpecInterval Nothing (Just hi)) =+  case lowerBound @n of+    Just lo -> equalSpec (toInteger hi - toInteger lo)+    Nothing -> TrueSpec+cardinalNumSpec (NumSpecInterval (Just lo) Nothing) =+  case upperBound @n of+    Just hi -> equalSpec (toInteger hi - toInteger lo)+    Nothing -> TrueSpec+cardinalNumSpec (NumSpecInterval Nothing Nothing) = cardinalTrueSpec @n++-- ====================================================================+-- Now the operations on Numbers++-- | Everything we need to make the number operations make sense on a given type+class (Num a, HasSpec a, HasDivision a, OrdLike a) => NumLike a where+  subtractSpec :: a -> TypeSpec a -> Specification a+  default subtractSpec ::+    ( NumLike (SimpleRep a)+    , GenericRequires a+    ) =>+    a ->+    TypeSpec a ->+    Specification a+  subtractSpec a ts = fromSimpleRepSpec $ subtractSpec (toSimpleRep a) ts++  negateSpec :: TypeSpec a -> Specification a+  default negateSpec ::+    ( NumLike (SimpleRep a)+    , GenericRequires a+    ) =>+    TypeSpec a ->+    Specification a+  negateSpec = fromSimpleRepSpec . negateSpec @(SimpleRep a)++  safeSubtract :: a -> a -> Maybe a+  default safeSubtract ::+    ( NumLike (SimpleRep a)+    , GenericRequires a+    ) =>+    a ->+    a ->+    Maybe a+  safeSubtract a b = fromSimpleRep <$> safeSubtract @(SimpleRep a) (toSimpleRep a) (toSimpleRep b)++-- | Operations on numbers.+-- The reason there is no implementation of abs here is that you can't easily deal with abs+-- without specifications becoming very large. Consider the following example:+-- > constrained $ \ x -> [1000 <. abs_ x, abs_ x <. 1050]+-- The natural `Specification` here would be something like `(-1050, -1000) || (1000, 1050)`+-- - the disjoint union of two open, non-overlapping, intervals. However, this doesn't work+-- because number type-specs only support a single interval. You could fudge it in all sorts of ways+-- by using `chooseSpec` or by using the can't set (which would blow up to be 2000 elements large in this+-- case). In short, there is no _satisfactory_ solution here.+data IntW (as :: [Type]) b where+  AddW :: NumLike a => IntW '[a, a] a+  MultW :: NumLike a => IntW '[a, a] a+  NegateW :: NumLike a => IntW '[a] a+  SignumW :: NumLike a => IntW '[a] a++deriving instance Eq (IntW dom rng)++instance Show (IntW d r) where+  show AddW = "+"+  show NegateW = "negate_"+  show MultW = "*"+  show SignumW = "signum_"++instance Semantics IntW where+  semantics AddW = (+)+  semantics NegateW = negate+  semantics MultW = (*)+  semantics SignumW = signum++instance Syntax IntW where+  isInfix AddW = True+  isInfix NegateW = False+  isInfix MultW = True+  isInfix SignumW = False++class HasDivision a where+  doDivide :: a -> a -> a+  default doDivide ::+    ( HasDivision (SimpleRep a)+    , GenericRequires a+    ) =>+    a ->+    a ->+    a+  doDivide a b = fromSimpleRep $ doDivide (toSimpleRep a) (toSimpleRep b)++  divideSpec :: a -> TypeSpec a -> Specification a+  default divideSpec ::+    ( HasDivision (SimpleRep a)+    , GenericRequires a+    ) =>+    a ->+    TypeSpec a ->+    Specification a+  divideSpec a ts = fromSimpleRepSpec $ divideSpec (toSimpleRep a) ts++divideSpecIntegral :: (HasSpec a, MaybeBounded a, Integral a, TypeSpec a ~ NumSpec a) => a -> TypeSpec a -> Specification a+divideSpecIntegral 0 _ = TrueSpec+divideSpecIntegral a (NumSpecInterval (unionWithMaybe max lowerBound -> ml) (unionWithMaybe min upperBound -> mu)) = typeSpec ts+    where+      ts+        | a > 0 = NumSpecInterval ml' mu'+        | otherwise = NumSpecInterval mu' ml'+      ml' = adjustLowerBound <$> ml+      mu' = adjustUpperBound <$> mu++      -- NOTE: negate has different overflow semantics than div, so that's why we use negate below...++      adjustLowerBound l+        | a == 1 = l+        | a == -1 = negate l+        | otherwise =+            let r = l `div` a+             in if toInteger r * toInteger a < toInteger l+                  then r + signum a+                  else r++      adjustUpperBound u+        | a == 1 = u+        | a == -1 = negate u+        | otherwise =+            let r = u `div` a+             in if toInteger r * toInteger a > toInteger u+                  then r - signum a+                  else r++instance HasDivision Integer where+  doDivide = div+  divideSpec = divideSpecIntegral++instance HasDivision Natural where+  doDivide = div+  divideSpec = divideSpecIntegral++instance HasDivision Int where+  doDivide = div+  divideSpec = divideSpecIntegral++instance HasDivision Int8 where+  doDivide = div+  divideSpec = divideSpecIntegral++instance HasDivision Int16 where+  doDivide = div+  divideSpec = divideSpecIntegral++instance HasDivision Int32 where+  doDivide = div+  divideSpec = divideSpecIntegral++instance HasDivision Int64 where+  doDivide = div+  divideSpec = divideSpecIntegral++instance HasDivision Word8 where+  doDivide = div+  divideSpec = divideSpecIntegral++instance HasDivision Word16 where+  doDivide = div+  divideSpec = divideSpecIntegral++instance HasDivision Word32 where+  doDivide = div+  divideSpec = divideSpecIntegral++instance HasDivision Word64 where+  doDivide = div+  divideSpec = divideSpecIntegral++instance HasDivision (Ratio Integer) where+  doDivide = (/)++  divideSpec 0 _ = TrueSpec+  divideSpec a (NumSpecInterval ml mu) = typeSpec ts+    where+      ts+        | a > 0 = NumSpecInterval ml' mu'+        | otherwise = NumSpecInterval mu' ml'+      ml' = adjustLowerBound <$> ml+      mu' = adjustUpperBound <$> mu+      adjustLowerBound l =+        let r = l / a+            l' = r * a+         in if l' < l+              then r + (l - l') * 2 / a+              else r++      adjustUpperBound u =+        let r = u / a+            u' = r * a+         in if u < u'+              then r - (u' - u) * 2 / a+              else r++instance HasDivision Float where+  doDivide = (/)++  divideSpec 0 _ = TrueSpec+  divideSpec a (NumSpecInterval ml mu) = typeSpec ts+    where+      ts+        | a > 0 = NumSpecInterval ml' mu'+        | otherwise = NumSpecInterval mu' ml'+      ml' = adjustLowerBound <$> ml+      mu' = adjustUpperBound <$> mu+      adjustLowerBound l =+        let r = l / a+            l' = r * a+         in if l' < l+              then r + (l - l') * 2 / a+              else r++      adjustUpperBound u =+        let r = u / a+            u' = r * a+         in if u < u'+              then r - (u' - u) * 2 / a+              else r++instance HasDivision Double where+  doDivide = (/)++  divideSpec 0 _ = TrueSpec+  divideSpec a (NumSpecInterval ml mu) = typeSpec ts+    where+      ts+        | a > 0 = NumSpecInterval ml' mu'+        | otherwise = NumSpecInterval mu' ml'+      ml' = adjustLowerBound <$> ml+      mu' = adjustUpperBound <$> mu+      adjustLowerBound l =+        let r = l / a+            l' = r * a+         in if l' < l+              then r + (l - l') * 2 / a+              else r++      adjustUpperBound u =+        let r = u / a+            u' = r * a+         in if u < u'+              then r - (u' - u) * 2 / a+              else r++-- | A type that we can reason numerically about in constraints+type Numeric a = (HasSpec a, Ord a, Num a, TypeSpec a ~ NumSpec a, MaybeBounded a, HasDivision a)++instance {-# OVERLAPPABLE #-} Numeric a => NumLike a where+  subtractSpec a ts@(NumSpecInterval ml mu)+    | Just u <- mu+    , a > 0+    , Nothing <- safeSubtract a u =+        ErrorSpec $+          NE.fromList+            [ "Underflow in subtractSpec (" ++ showType @a ++ "):"+            , "  a = " ++ show a+            , "  ts = " ++ show ts+            ]+    | Just l <- ml+    , a < 0+    , Nothing <- safeSubtract a l =+        ErrorSpec $+          NE.fromList+            [ "Overflow in subtractSpec (" ++ showType @a ++ "):"+            , "  a = " ++ show a+            , "  ts = " ++ show ts+            ]+    | otherwise = typeSpec $ NumSpecInterval (safeSub a <$> ml) (safeSub a <$> mu)+    where+      safeSub :: a -> a -> a+      safeSub a1 x+        | Just r <- safeSubtract a1 x = r+        | a1 < 0 = fromJust upperBound+        | otherwise = fromJust lowerBound++  negateSpec (NumSpecInterval ml mu) = typeSpec $ NumSpecInterval (negate <$> mu) (negate <$> ml)++  safeSubtract a x+    | a > 0+    , Just lb <- lowerBound+    , lb + a > x =+        Nothing+    | a < 0+    , Just ub <- upperBound+    , ub + a < x =+        Nothing+    | otherwise = Just $ x - a++instance NumLike a => Num (Term a) where+  (+) = (+.)+  negate = negate_+  fromInteger = Lit . fromInteger+  (*) = (*.)+  signum = signum_+  abs = error "No implementation for abs @(Term a)"++invertMult :: (HasSpec a, Num a, HasDivision a) => a -> a -> Maybe a+invertMult a b =+  let r = a `doDivide` b in if r * b == a then Just r else Nothing++-- | Just a note that these instances won't work until we are in a context where+--   there is a HasSpec instance of 'a', which (NumLike a) demands.+--   This happens in Constrained.Experiment.TheKnot+instance Logic IntW where+  propagateTypeSpec AddW (HOLE :<: i) ts cant = subtractSpec i ts <> notMemberSpec (mapMaybe (safeSubtract i) cant)+  propagateTypeSpec AddW ctx ts cant = propagateTypeSpec AddW (flipCtx ctx) ts cant+  propagateTypeSpec NegateW (Unary HOLE) ts cant = negateSpec ts <> notMemberSpec (map negate cant)+  propagateTypeSpec MultW (HOLE :<: 0) ts cant+    | 0 `conformsToSpec` TypeSpec ts cant = TrueSpec+    | otherwise = ErrorSpec $ NE.fromList ["zero"]+  propagateTypeSpec MultW (HOLE :<: i) ts cant = divideSpec i ts <> notMemberSpec (mapMaybe (flip invertMult i) cant)+  propagateTypeSpec MultW ctx ts cant = propagateTypeSpec MultW (flipCtx ctx) ts cant+  propagateTypeSpec SignumW (Unary HOLE) ts cant =+    constrained $ \x ->+      [x `satisfies` notMemberSpec [0] | not $ ok 0]+        ++ [Assert $ 0 <=. x | not $ ok (-1)]+        ++ [Assert $ x <=. 0 | not $ ok 1]+    where+      ok = flip conformsToSpec (TypeSpec ts cant)++  propagateMemberSpec AddW (HOLE :<: i) es =+    memberSpec+      (nubOrd $ mapMaybe (safeSubtract i) (NE.toList es))+      ( NE.fromList+          [ "propagateSpecFn on (" ++ show i ++ " +. HOLE)"+          , "The Spec is a MemberSpec = " ++ show es -- show (MemberSpec @HasSpec @TS es)+          , "We can't safely subtract " ++ show i ++ " from any choice in the MemberSpec."+          ]+      )+  propagateMemberSpec AddW ctx es = propagateMemberSpec AddW (flipCtx ctx) es+  propagateMemberSpec NegateW (Unary HOLE) es = MemberSpec $ NE.nub $ fmap negate es+  propagateMemberSpec MultW (HOLE :<: 0) es+    | 0 `elem` es = TrueSpec+    | otherwise = ErrorSpec $ NE.fromList ["zero"]+  propagateMemberSpec MultW (HOLE :<: i) es = memberSpec (mapMaybe (flip invertMult i) (NE.toList es)) (NE.fromList ["propagateSpec"])+  propagateMemberSpec MultW ctx es = propagateMemberSpec MultW (flipCtx ctx) es+  propagateMemberSpec SignumW (Unary HOLE) es+    | all ((`notElem` [-1, 0, 1]) . signum) es =+        ErrorSpec $ NE.fromList ["signum for invalid member spec", show es]+    | otherwise = constrained $ \x ->+        [x `satisfies` notMemberSpec [0] | 0 `notElem` es]+          ++ [Assert $ 0 <=. x | -1 `notElem` es]+          ++ [Assert $ x <=. 0 | 1 `notElem` es]++  rewriteRules AddW (x :> y :> Nil) _ | x == y = Just $ 2 * x+  rewriteRules _ _ _ = Nothing++infix 4 +.++-- | `Term`-level `(+)`+(+.) :: NumLike a => Term a -> Term a -> Term a+(+.) = appTerm AddW++infixl 7 *.++-- | `Term`-level `(+)`+(*.) :: NumLike a => Term a -> Term a -> Term a+(*.) = appTerm MultW++-- | `Term`-level `negate`+negate_ :: NumLike a => Term a -> Term a+negate_ = appTerm NegateW++-- | `Term`-level `signum`+signum_ :: NumLike a => Term a -> Term a+signum_ = appTerm SignumW++infix 4 -.++-- | `Term`-level `(-)`+(-.) :: Numeric n => Term n -> Term n -> Term n+(-.) x y = x +. negate_ y++infixr 4 <=.++-- | `Term`-level `(<=)`+(<=.) :: forall a. OrdLike a => Term a -> Term a -> Term Bool+(<=.) = appTerm LessOrEqualW++infixr 4 <.++-- | `Term`-level `(<)`+(<.) :: forall a. OrdLike a => Term a -> Term a -> Term Bool+(<.) = appTerm LessW++infixr 4 >=.++-- | `Term`-level `(>=)`+(>=.) :: forall a. OrdLike a => Term a -> Term a -> Term Bool+(>=.) = appTerm GreaterOrEqualW++infixr 4 >.++-- | `Term`-level `(>)`+(>.) :: forall a. OrdLike a => Term a -> Term a -> Term Bool+(>.) = appTerm GreaterW++-- | t`TypeSpec`-level `satisfies` to implement `toPreds` in+-- `HasSpec` instance+toPredsNumSpec ::+  OrdLike n =>+  Term n ->+  NumSpec n ->+  Pred+toPredsNumSpec v (NumSpecInterval ml mu) =+  fold $+    [Assert $ Lit l <=. v | l <- maybeToList ml]+      ++ [Assert $ v <=. Lit u | u <- maybeToList mu]++instance Logic OrdW where+  propagate f ctxt (ExplainSpec [] s) = propagate f ctxt s+  propagate f ctxt (ExplainSpec es s) = ExplainSpec es $ propagate f ctxt s+  propagate _ _ TrueSpec = TrueSpec+  propagate _ _ (ErrorSpec msgs) = ErrorSpec msgs+  propagate GreaterW (HOLE :? x :> Nil) spec =+    propagate LessW (x :! Unary HOLE) spec+  propagate GreaterW (x :! Unary HOLE) spec =+    propagate LessW (HOLE :? x :> Nil) spec+  propagate LessOrEqualW (HOLE :? Value x :> Nil) (SuspendedSpec v ps) =+    constrained $ \v' -> Let (App LessOrEqualW (v' :> Lit x :> Nil)) (v :-> ps)+  propagate LessOrEqualW (Value x :! Unary HOLE) (SuspendedSpec v ps) =+    constrained $ \v' -> Let (App LessOrEqualW (Lit x :> v' :> Nil)) (v :-> ps)+  propagate LessOrEqualW (HOLE :? Value l :> Nil) spec =+    caseBoolSpec spec $ \case True -> leqSpec l; False -> gtSpec l+  propagate LessOrEqualW (Value l :! Unary HOLE) spec =+    caseBoolSpec spec $ \case True -> geqSpec l; False -> ltSpec l+  propagate GreaterOrEqualW (HOLE :? Value x :> Nil) spec =+    propagate LessOrEqualW (Value x :! Unary HOLE) spec+  propagate GreaterOrEqualW (x :! Unary HOLE) spec =+    propagate LessOrEqualW (HOLE :? x :> Nil) spec+  propagate LessW (HOLE :? Value x :> Nil) (SuspendedSpec v ps) =+    constrained $ \v' -> Let (App LessW (v' :> Lit x :> Nil)) (v :-> ps)+  propagate LessW (Value x :! Unary HOLE) (SuspendedSpec v ps) =+    constrained $ \v' -> Let (App LessW (Lit x :> v' :> Nil)) (v :-> ps)+  propagate LessW (HOLE :? Value l :> Nil) spec =+    caseBoolSpec spec $ \case True -> ltSpec l; False -> geqSpec l+  propagate LessW (Value l :! Unary HOLE) spec =+    caseBoolSpec spec $ \case True -> gtSpec l; False -> leqSpec l++-- | @if-then-else@ on a specification, useful for writing `propagate` implementations+-- of predicates, e.g.:+-- > propagate LessW (Value l :! Unary HOLE) spec =+-- >   caseBoolSpec spec $ \case True -> gtSpec l; False -> leqSpec l+caseBoolSpec ::+  HasSpec a => Specification Bool -> (Bool -> Specification a) -> Specification a+caseBoolSpec spec cont = case possibleValues spec of+  [] -> ErrorSpec (NE.fromList ["No possible values in caseBoolSpec"])+  [b] -> cont b+  _ -> mempty+  where+    -- This will always get the same result, and probably faster since running 2+    -- conformsToSpec on True and False takes less time than simplifying the spec.+    -- Since we are in TheKnot, we could keep the simplifySpec. Is there a good reason to?+    possibleValues s = filter (flip conformsToSpec s) [True, False]++------------------------------------------------------------------------+-- Instances of HasSpec for numeric types+------------------------------------------------------------------------++instance HasSpec Integer where+  type TypeSpec Integer = NumSpec Integer+  emptySpec = emptyNumSpec+  combineSpec = combineNumSpec+  genFromTypeSpec = genFromNumSpec+  shrinkWithTypeSpec = shrinkWithNumSpec+  fixupWithTypeSpec = fixupWithNumSpec+  conformsTo = conformsToNumSpec+  toPreds = toPredsNumSpec+  cardinalTypeSpec = cardinalNumSpec+  guardTypeSpec = guardNumSpec++instance HasSpec Int where+  type TypeSpec Int = NumSpec Int+  emptySpec = emptyNumSpec+  combineSpec = combineNumSpec+  genFromTypeSpec = genFromNumSpec+  shrinkWithTypeSpec = shrinkWithNumSpec+  fixupWithTypeSpec = fixupWithNumSpec+  conformsTo = conformsToNumSpec+  toPreds = toPredsNumSpec+  cardinalTypeSpec = cardinalNumSpec+  guardTypeSpec = guardNumSpec++instance HasSpec (Ratio Integer) where+  type TypeSpec (Ratio Integer) = NumSpec (Ratio Integer)+  emptySpec = emptyNumSpec+  combineSpec = combineNumSpec+  genFromTypeSpec = genFromNumSpec+  shrinkWithTypeSpec = shrinkWithNumSpec+  fixupWithTypeSpec = fixupWithNumSpec+  conformsTo = conformsToNumSpec+  toPreds = toPredsNumSpec+  cardinalTypeSpec _ = TrueSpec+  guardTypeSpec = guardNumSpec++instance HasSpec Natural where+  type TypeSpec Natural = NumSpec Natural+  emptySpec = emptyNumSpec+  combineSpec = combineNumSpec+  genFromTypeSpec = genFromNumSpec+  shrinkWithTypeSpec = shrinkWithNumSpec+  fixupWithTypeSpec = fixupWithNumSpec+  conformsTo = conformsToNumSpec+  toPreds = toPredsNumSpec+  cardinalTypeSpec (NumSpecInterval (fromMaybe 0 -> lo) (Just hi)) =+    if lo < hi+      then equalSpec (fromIntegral $ hi - lo + 1)+      else equalSpec 0+  cardinalTypeSpec _ = TrueSpec+  guardTypeSpec = guardNumSpec++instance HasSpec Word8 where+  type TypeSpec Word8 = NumSpec Word8+  emptySpec = emptyNumSpec+  combineSpec = combineNumSpec+  genFromTypeSpec = genFromNumSpec+  shrinkWithTypeSpec = shrinkWithNumSpec+  fixupWithTypeSpec = fixupWithNumSpec+  conformsTo = conformsToNumSpec+  toPreds = toPredsNumSpec+  cardinalTypeSpec = cardinalNumSpec+  cardinalTrueSpec = equalSpec 256+  typeSpecOpt = notInNumSpec+  guardTypeSpec = guardNumSpec++instance HasSpec Word16 where+  type TypeSpec Word16 = NumSpec Word16+  emptySpec = emptyNumSpec+  combineSpec = combineNumSpec+  genFromTypeSpec = genFromNumSpec+  shrinkWithTypeSpec = shrinkWithNumSpec+  fixupWithTypeSpec = fixupWithNumSpec+  conformsTo = conformsToNumSpec+  toPreds = toPredsNumSpec+  cardinalTypeSpec = cardinalNumSpec+  cardinalTrueSpec = equalSpec 65536+  guardTypeSpec = guardNumSpec++instance HasSpec Word32 where+  type TypeSpec Word32 = NumSpec Word32+  emptySpec = emptyNumSpec+  combineSpec = combineNumSpec+  genFromTypeSpec = genFromNumSpec+  shrinkWithTypeSpec = shrinkWithNumSpec+  fixupWithTypeSpec = fixupWithNumSpec+  conformsTo = conformsToNumSpec+  toPreds = toPredsNumSpec+  cardinalTypeSpec = cardinalNumSpec+  guardTypeSpec = guardNumSpec++instance HasSpec Word64 where+  type TypeSpec Word64 = NumSpec Word64+  emptySpec = emptyNumSpec+  combineSpec = combineNumSpec+  genFromTypeSpec = genFromNumSpec+  shrinkWithTypeSpec = shrinkWithNumSpec+  fixupWithTypeSpec = fixupWithNumSpec+  conformsTo = conformsToNumSpec+  toPreds = toPredsNumSpec+  cardinalTypeSpec = cardinalNumSpec+  guardTypeSpec = guardNumSpec++instance HasSpec Int8 where+  type TypeSpec Int8 = NumSpec Int8+  emptySpec = emptyNumSpec+  combineSpec = combineNumSpec+  genFromTypeSpec = genFromNumSpec+  shrinkWithTypeSpec = shrinkWithNumSpec+  fixupWithTypeSpec = fixupWithNumSpec+  conformsTo = conformsToNumSpec+  toPreds = toPredsNumSpec+  cardinalTrueSpec = equalSpec 256+  cardinalTypeSpec = cardinalNumSpec+  guardTypeSpec = guardNumSpec++instance HasSpec Int16 where+  type TypeSpec Int16 = NumSpec Int16+  emptySpec = emptyNumSpec+  combineSpec = combineNumSpec+  genFromTypeSpec = genFromNumSpec+  shrinkWithTypeSpec = shrinkWithNumSpec+  fixupWithTypeSpec = fixupWithNumSpec+  conformsTo = conformsToNumSpec+  toPreds = toPredsNumSpec+  cardinalTypeSpec = cardinalNumSpec+  cardinalTrueSpec = equalSpec 65536+  guardTypeSpec = guardNumSpec++instance HasSpec Int32 where+  type TypeSpec Int32 = NumSpec Int32+  emptySpec = emptyNumSpec+  combineSpec = combineNumSpec+  genFromTypeSpec = genFromNumSpec+  shrinkWithTypeSpec = shrinkWithNumSpec+  fixupWithTypeSpec = fixupWithNumSpec+  conformsTo = conformsToNumSpec+  toPreds = toPredsNumSpec+  cardinalTypeSpec = cardinalNumSpec+  guardTypeSpec = guardNumSpec++instance HasSpec Int64 where+  type TypeSpec Int64 = NumSpec Int64+  emptySpec = emptyNumSpec+  combineSpec = combineNumSpec+  genFromTypeSpec = genFromNumSpec+  shrinkWithTypeSpec = shrinkWithNumSpec+  fixupWithTypeSpec = fixupWithNumSpec+  conformsTo = conformsToNumSpec+  toPreds = toPredsNumSpec+  cardinalTypeSpec = cardinalNumSpec+  guardTypeSpec = guardNumSpec++instance HasSpec Float where+  type TypeSpec Float = NumSpec Float+  emptySpec = emptyNumSpec+  combineSpec = combineNumSpec+  genFromTypeSpec = genFromNumSpec+  shrinkWithTypeSpec = shrinkWithNumSpec+  fixupWithTypeSpec = fixupWithNumSpec+  conformsTo = conformsToNumSpec+  toPreds = toPredsNumSpec+  cardinalTypeSpec _ = TrueSpec+  guardTypeSpec = guardNumSpec++instance HasSpec Double where+  type TypeSpec Double = NumSpec Double+  emptySpec = emptyNumSpec+  combineSpec = combineNumSpec+  genFromTypeSpec = genFromNumSpec+  shrinkWithTypeSpec = shrinkWithNumSpec+  fixupWithTypeSpec = fixupWithNumSpec+  conformsTo = conformsToNumSpec+  toPreds = toPredsNumSpec+  cardinalTypeSpec _ = TrueSpec+  guardTypeSpec = guardNumSpec
+ src/Constrained/PrettyUtils.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- | Utility functions for writing pretty-printers+module Constrained.PrettyUtils (+  -- * Precedence+  WithPrec (..),+  parensIf,+  prettyPrec,++  -- * Lists and sets+  ppList,+  ppListC,+  prettyShowSet,+  prettyShowList,++  -- * General helpers+  prettyType,+  vsep',+  (/>),+  (//>),+  showType,+) where++import Constrained.List+import Data.Set (Set)+import Data.Set qualified as Set+import Data.String (fromString)+import Data.Typeable+import Prettyprinter++-- | Wrapper for pretty-printing with precendence. To get precedence+-- pretty-printing implement an instance of @`Pretty` (t`WithPrec` YourType)@ so+-- that you can use `prettyPrec`.+data WithPrec a = WithPrec Int a++-- | Pretty-print with precedence+prettyPrec :: Pretty (WithPrec a) => Int -> a -> Doc ann+prettyPrec p = pretty . WithPrec p++-- | Wrap a term in @( .. )@ if the first argument is `True`. Useful+-- in combination with t`WithPrec`+parensIf :: Bool -> Doc ann -> Doc ann+parensIf True = parens+parensIf False = id++-- | Map a pretty-printer for elements over a `List`+ppList :: forall f as ann. (forall a. f a -> Doc ann) -> List f as -> [Doc ann]+ppList _ Nil = []+ppList pp (a :> as) = pp a : ppList pp as++-- | Like `ppList` for a constrained pretty-printer+ppListC ::+  forall c f as ann. All c as => (forall a. c a => f a -> Doc ann) -> List f as -> [Doc ann]+ppListC _ Nil = []+ppListC pp (a :> as) = pp a : ppListC @c pp as++prettyShowSet :: Show a => Set a -> Doc ann+prettyShowSet xs = fillSep $ "{" : punctuate "," (map viaShow (Set.toList xs)) ++ ["}"]++prettyShowList :: Show a => [a] -> Doc ann+prettyShowList xs = fillSep $ "[" : punctuate "," (map viaShow xs) ++ ["]"]++-- | Pretty-print a type+prettyType :: forall t x. Typeable t => Doc x+prettyType = fromString $ show (typeRep (Proxy @t))++-- | Separate documents by a hardline and align them+vsep' :: [Doc ann] -> Doc ann+vsep' = align . mconcat . punctuate hardline++-- | Lay the header (first argument) out before the body+-- and if it overflows the line indent the body by 2+(/>) :: Doc ann -> Doc ann -> Doc ann+h /> cont = hang 2 $ sep [h, align cont]++infixl 5 />++-- | Lay the header (first argument) out above the body+-- and and indent the body by 2+(//>) :: Doc ann -> Doc ann -> Doc ann+h //> cont = hang 2 $ vsep [h, align cont]++infixl 5 //>++-- | Show a `Typeable` thing's type+showType :: forall t. Typeable t => String+showType = show (typeRep (Proxy @t))
+ src/Constrained/Properties.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE TypeApplications #-}++-- | Useful of helpers for writing properties with constrained generators+module Constrained.Properties (+  conformsToSpecProp,+  forAllSpec,+  forAllSpecShow,+  forAllSpecDiscard,+) where++import Constrained.Base+import Constrained.Conformance+import Constrained.GenT+import Constrained.Generation+import qualified Data.List.NonEmpty as NE+import qualified Test.QuickCheck as QC++-- | Like @Constrained.Conformance.conformsToSpec@ but in @Test.QuickCheck.Property@ form.+conformsToSpecProp :: forall a. HasSpec a => a -> Specification a -> QC.Property+conformsToSpecProp a s = case conformsToSpecE a (simplifySpec s) (pure "call to conformsToSpecProp") of+  Nothing -> QC.property True+  Just msgs -> QC.counterexample (unlines (NE.toList msgs)) False++-- | Quanitfy over a @Constrained.Base.Specification@.+forAllSpec :: (HasSpec a, QC.Testable p) => Specification a -> (a -> p) -> QC.Property+forAllSpec spec prop = forAllSpecShow spec show prop++-- | Like `forAllSpec` with a custom way of printing values+forAllSpecShow ::+  (HasSpec a, QC.Testable p) => Specification a -> (a -> String) -> (a -> p) -> QC.Property+forAllSpecShow spec pp prop =+  let sspec = simplifySpec spec+   in QC.forAllShrinkShow (genFromSpec sspec) (shrinkWithSpec sspec) pp $ \a ->+        monitorSpec spec a $ prop a++-- | Quanitfy over a @Constrained.Base.Specification@ and discard any test where generation fails.+forAllSpecDiscard :: (HasSpec a, QC.Testable p) => Specification a -> (a -> p) -> QC.Property+forAllSpecDiscard spec prop =+  let sspec = simplifySpec spec+   in QC.forAllShrinkBlind+        (strictGen $ genFromSpecT @_ @GE sspec)+        (map pure . shrinkWithSpec sspec . errorGE)+        $ \ge ->+          fromGEDiscard $ do+            a <- ge+            pure $ QC.counterexample (show a) $ prop a
+ src/Constrained/Spec/List.hs view
@@ -0,0 +1,663 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableSuperClasses #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wno-orphans -Wno-name-shadowing #-}++-- | `TypeSpec` definition for `[]` and functions for writing constraints over+-- lists+module Constrained.Spec.List (+  ListSpec (..),+  ListW (..),+  ElemW (..),+  pattern Elem,++  -- * Functions for writing constraints on lists+  append_,+  singletonList_,+  elem_,+  sum_,+  foldMap_,++  -- * FoldSpec and Foldy definitions and helper functions+  Foldy (..),+  FoldSpec (..),+  preMapFoldSpec,+  toPredsFoldSpec,+  adds,+  conformsToFoldSpec,+  combineFoldSpec,+) where++import Constrained.AbstractSyntax+import Constrained.Base+import Constrained.Conformance+import Constrained.Core+import Constrained.FunctionSymbol+import Constrained.GenT+import Constrained.Generation+import Constrained.Generic+import Constrained.List+import Constrained.NumOrd+import Constrained.PrettyUtils+import Constrained.SumList+import Constrained.Syntax+import Constrained.TheKnot+import Control.Applicative+import Control.Monad+import Data.Foldable+import Data.Int+import Data.Kind+import Data.List (isPrefixOf, isSuffixOf, nub, (\\))+import qualified Data.List.NonEmpty as NE+import Data.Maybe+import Data.String+import Data.Typeable+import Data.Word+import GHC.Natural+import GHC.Stack+import Prettyprinter hiding (cat)+import Test.QuickCheck hiding (Args, Fun, Witness, forAll, witness)+import Prelude hiding (cycle, pred)++-- | `TypeSpec` for `[]`+data ListSpec a = ListSpec+  { listSpecHint :: Maybe Integer+  -- ^ Hint for the length of the list+  , listSpecMust :: [a]+  -- ^ Things that must be in the list+  , listSpecSize :: Specification Integer+  -- ^ Spec for the size of the list+  , listSpecElem :: Specification a+  -- ^ Spec for every element+  , listSpecFold :: FoldSpec a+  -- ^ Spec for the sum (or fold) of the list+  }++instance HasSpec a => Show (FoldSpec a) where+  showsPrec d = shows . prettyPrec d++instance HasSpec a => Pretty (WithPrec (FoldSpec a)) where+  pretty (WithPrec _ NoFold) = "NoFold"+  pretty (WithPrec d (FoldSpec fun s)) =+    parensIf (d > 10) $+      "FoldSpec"+        /> vsep'+          [ "fn   =" <+> viaShow fun+          , "spec =" <+> pretty s+          ]++instance HasSpec a => Pretty (FoldSpec a) where+  pretty = prettyPrec 0++instance HasSpec a => Show (ListSpec a) where+  showsPrec d = shows . prettyPrec d++instance+  HasSpec a =>+  Pretty (WithPrec (ListSpec a))+  where+  pretty (WithPrec d s) =+    parensIf (d > 10) $+      "ListSpec"+        /> vsep'+          [ "hint =" <+> viaShow (listSpecHint s)+          , "must =" <+> viaShow (listSpecMust s)+          , "size =" <+> pretty (listSpecSize s)+          , "elem =" <+> pretty (listSpecElem s)+          , "fold =" <+> pretty (listSpecFold s)+          ]++instance HasSpec a => Pretty (ListSpec a) where+  pretty = prettyPrec 0++guardListSpec :: HasSpec a => [String] -> ListSpec a -> Specification [a]+guardListSpec msg l@(ListSpec _hint must size elemS _fold)+  | ErrorSpec es <- size = ErrorSpec $ (NE.fromList ("Error in size of ListSpec" : msg)) <> es+  | Just u <- knownUpperBound size+  , u < 0 =+      ErrorSpec $ NE.fromList (["Negative size in guardListSpec", show size] ++ msg)+  | not (all (`conformsToSpec` elemS) must) =+      ErrorSpec $+        ( NE.fromList+            (["Some items in the must list do not conform to 'element' spec.", "   " ++ show elemS] ++ msg)+        )+  | otherwise = (typeSpec l)++-- | Witness type for `elem_`+data ElemW :: [Type] -> Type -> Type where+  ElemW :: HasSpec a => ElemW '[a, [a]] Bool++deriving instance Eq (ElemW dom rng)++instance Show (ElemW dom rng) where+  show ElemW = "elem_"++instance Syntax ElemW++instance Semantics ElemW where+  semantics ElemW = elem++instance Logic ElemW where+  propagate f ctxt (ExplainSpec es s) = explainSpec es $ propagate f ctxt s+  propagate _ _ TrueSpec = TrueSpec+  propagate _ _ (ErrorSpec msgs) = ErrorSpec msgs+  propagate ElemW (HOLE :<: (x :: [w])) (SuspendedSpec v ps) =+    constrained $ \v' -> Let (App ElemW ((v' :: Term w) :> Lit x :> Nil)) (v :-> ps)+  propagate ElemW (x :>: HOLE) (SuspendedSpec v ps) =+    constrained $ \v' -> Let (App ElemW (Lit x :> v' :> Nil)) (v :-> ps)+  propagate ElemW (HOLE :<: es) spec =+    caseBoolSpec spec $ \case+      True -> memberSpec (nub es) (pure "propagate on (elem_ x []), The empty list, [], has no solution")+      False -> notMemberSpec es+  propagate ElemW (e :>: HOLE) spec =+    caseBoolSpec spec $ \case+      True -> typeSpec (ListSpec Nothing [e] mempty mempty NoFold)+      False -> typeSpec (ListSpec Nothing mempty mempty (notEqualSpec e) NoFold)++  rewriteRules ElemW (_ :> Lit [] :> Nil) Evidence = Just $ Lit False+  rewriteRules ElemW (t :> Lit [a] :> Nil) Evidence = Just $ t ==. (Lit a)+  rewriteRules _ _ _ = Nothing++  saturate ElemW ((FromGeneric (Product (x :: Term a) (y :: Term b)) :: Term c) :> Lit zs :> Nil)+    | Just Refl <- eqT @c @(a, b) = case zs of+        (w : ws) -> [ElemPred True x (fmap fst (w :| ws))]+        [] -> [FalsePred (pure $ "empty list, zs , in elem_ " ++ show (x, y) ++ " zs")]+    | otherwise = []+  saturate ElemW (x :> Lit (y : ys) :> Nil) = [satisfies x (MemberSpec (y :| ys))]+  saturate _ _ = []++infix 4 `elem_`++-- | Check if a term is an element of the list+elem_ :: HasSpec a => Term a -> Term [a] -> Term Bool+elem_ = appTerm ElemW++-- | Pattern for extracting the v`ElemW` symbol, useful for writing custom+-- rewrite rules for functions that deal with lists+pattern Elem ::+  forall b.+  () =>+  forall a.+  (b ~ Bool, Eq a, HasSpec a) =>+  Term a ->+  Term [a] ->+  Term b+pattern Elem x y <-+  ( App+      (getWitness -> Just ElemW)+      (x :> y :> Nil)+    )++instance HasSpec a => HasSpec [a] where+  type TypeSpec [a] = ListSpec a+  type Prerequisites [a] = HasSpec a+  emptySpec = ListSpec Nothing [] mempty mempty NoFold+  combineSpec l1@(ListSpec msz must size elemS foldS) l2@(ListSpec msz' must' size' elemS' foldS') =+    let must'' = nub $ must <> must'+        elemS'' = elemS <> elemS'+        size'' = size <> size'+        foldeither = combineFoldSpec foldS foldS'+        msg = ["Error in combineSpec for ListSpec", "1) " ++ show l1, "2) " ++ show l2]+     in case foldeither of+          Left foldmsg -> ErrorSpec (NE.fromList (msg ++ foldmsg))+          Right fold'' -> guardListSpec msg $ ListSpec (unionWithMaybe min msz msz') must'' size'' elemS'' fold''++  genFromTypeSpec (ListSpec _ must _ elemS _)+    | any (not . (`conformsToSpec` elemS)) must =+        genError "genTypeSpecSpec @ListSpec: some elements of mustSet do not conform to elemS"+  genFromTypeSpec (ListSpec msz must TrueSpec elemS NoFold) = do+    lst <- case msz of+      Nothing -> listOfT $ genFromSpecT elemS+      Just szHint -> do+        sz <- genFromSizeSpec (leqSpec szHint)+        listOfUntilLenT (genFromSpecT elemS) (fromIntegral sz) (const True)+    must' <- pureGen $ shuffle must+    pureGen $ randomInterleaving must' lst+  genFromTypeSpec (ListSpec msz must szSpec elemS NoFold) = do+    sz0 <- genFromSizeSpec (szSpec <> geqSpec (sizeOf must) <> maybe TrueSpec (leqSpec . max 0) msz)+    let sz = fromIntegral (sz0 - sizeOf must)+    lst <-+      listOfUntilLenT+        (genFromSpecT elemS)+        sz+        ((`conformsToSpec` szSpec) . (+ sizeOf must) . fromIntegral)+    must' <- pureGen $ shuffle must+    pureGen $ randomInterleaving must' lst+  genFromTypeSpec (ListSpec msz must szSpec elemS (FoldSpec f foldS)) = do+    let szSpec' = szSpec <> maybe TrueSpec (leqSpec . max 0) msz+    genFromFold must szSpec' elemS f foldS++  shrinkWithTypeSpec (ListSpec _ _ _ es _) as =+    shrinkList (shrinkWithSpec es) as++  -- TODO: fixme+  fixupWithTypeSpec _ _ = Nothing++  cardinalTypeSpec _ = TrueSpec++  guardTypeSpec = guardListSpec++  conformsTo xs (ListSpec _ must size elemS foldS) =+    sizeOf xs+      `conformsToSpec` size+      && all (`elem` xs) must+      && all (`conformsToSpec` elemS) xs+      && xs+        `conformsToFoldSpec` foldS++  toPreds x (ListSpec msz must size elemS foldS) =+    (forAll x $ \x' -> satisfies x' elemS)+      <> (forAll (Lit must) $ \x' -> Assert (elem_ x' x))+      <> toPredsFoldSpec x foldS+      <> satisfies (sizeOf_ x) size+      <> maybe TruePred (flip genHint x) msz++randomInterleaving :: [a] -> [a] -> Gen [a]+randomInterleaving xs ys = go xs ys (length ys)+  where+    go [] ys _ = pure ys+    go xs [] _ = pure xs+    go xs ys l = do+      -- TODO: think about distribution here+      i <- choose (0, l)+      go' i xs ys (l - i)++    go' _ xs [] _ = pure xs+    go' _ [] ys _ = pure ys+    go' 0 (x : xs) ys l = (x :) <$> go xs ys l+    go' i xs (y : ys) l = (y :) <$> go' (i - 1) xs ys l++instance HasSpec a => HasGenHint [a] where+  type Hint [a] = Integer+  giveHint szHint = typeSpec $ ListSpec (Just szHint) [] mempty mempty NoFold++instance Forallable [a] a where+  fromForAllSpec es = typeSpec (ListSpec Nothing [] mempty es NoFold)+  forAllToList = id++instance Logic ListW where+  propagateTypeSpec (FoldMapW f) (Unary HOLE) ts cant =+    typeSpec (ListSpec Nothing [] TrueSpec TrueSpec $ FoldSpec f (TypeSpec ts cant))+  propagateTypeSpec SingletonListW (Unary HOLE) (ListSpec _ m sz e f) cant+    | length m > 1 =+        ErrorSpec $+          NE.fromList+            [ "Too many required elements for SingletonListW : "+            , "  " ++ show m+            ]+    | not $ 1 `conformsToSpec` sz =+        ErrorSpec $ pure $ "Size spec requires too many elements for SingletonListW : " ++ show sz+    | bad@(_ : _) <- filter (not . (`conformsToSpec` e)) m =+        ErrorSpec $+          NE.fromList+            [ "The following elements of the must spec do not conforms to the elem spec:"+            , show bad+            ]+    -- There is precisely one required element in the final list, so the argument to singletonList_ has to+    -- be that element and we have to respect the cant and fold specs+    | [a] <- m = equalSpec a <> notMemberSpec [z | [z] <- cant] <> reverseFoldSpec f+    -- We have to respect the elem-spec, the can't spec, and the fold spec.+    | otherwise = e <> notMemberSpec [a | [a] <- cant] <> reverseFoldSpec f+  propagateTypeSpec AppendW ctx (ts@ListSpec {listSpecElem = e}) cant+    | (HOLE :? Value (ys :: [a]) :> Nil) <- ctx+    , Evidence <- prerequisites @[a]+    , all (`conformsToSpec` e) ys =+        TypeSpec (alreadyHave ys ts) (suffixedBy ys cant)+    | (Value (ys :: [a]) :! Unary HOLE) <- ctx+    , Evidence <- prerequisites @[a]+    , all (`conformsToSpec` e) ys =+        TypeSpec (alreadyHave ys ts) (prefixedBy ys cant)+    | otherwise = ErrorSpec $ pure "The spec given to propagate for AppendW is inconsistent!"++  propagateMemberSpec (FoldMapW f) (Unary HOLE) es =+    typeSpec (ListSpec Nothing [] TrueSpec TrueSpec $ FoldSpec f (MemberSpec es))+  propagateMemberSpec SingletonListW (Unary HOLE) xss =+    case [a | [a] <- NE.toList xss] of+      [] ->+        ErrorSpec $ (pure "PropagateSpec SingletonListW  with MemberSpec which has no lists of length 1")+      (x : xs) -> MemberSpec (x :| xs)+  propagateMemberSpec AppendW ctx xss+    | (HOLE :<: (ys :: [a])) <- ctx+    , Evidence <- prerequisites @[a] =+        -- Only keep the prefixes of the elements of xss that can+        -- give you the correct resulting list+        case suffixedBy ys (NE.toList xss) of+          [] ->+            ErrorSpec+              ( NE.fromList+                  [ "propagateSpecFun (append HOLE ys) with (MemberSpec xss)"+                  , "there are no elements in xss with suffix ys"+                  ]+              )+          (x : xs) -> MemberSpec (x :| xs)+    | ((ys :: [a]) :>: HOLE) <- ctx+    , Evidence <- prerequisites @[a] =+        -- Only keep the suffixes of the elements of xss that can+        -- give you the correct resulting list+        case prefixedBy ys (NE.toList xss) of+          [] ->+            ErrorSpec+              ( NE.fromList+                  [ "propagateSpecFun (append ys HOLE) with (MemberSpec xss)"+                  , "there are no elements in xss with prefix ys"+                  ]+              )+          (x : xs) -> MemberSpec (x :| xs)++  mapTypeSpec SingletonListW ts = typeSpec (ListSpec Nothing [] (equalSpec 1) (typeSpec ts) NoFold)+  mapTypeSpec (FoldMapW g) ts =+    constrained $ \x ->+      unsafeExists $ \x' ->+        Assert (x ==. appFun (foldMapFn g) x') <> toPreds x' ts++-- | Function symbols for talking about lists+data ListW (args :: [Type]) (res :: Type) where+  FoldMapW :: forall a b. (Foldy b, HasSpec a) => Fun '[a] b -> ListW '[[a]] b+  SingletonListW :: HasSpec a => ListW '[a] [a]+  AppendW :: (HasSpec a, Typeable a, Show a) => ListW '[[a], [a]] [a]++instance Semantics ListW where+  semantics (FoldMapW (Fun f)) = adds . map (semantics f)+  semantics SingletonListW = (: [])+  semantics AppendW = (++)++instance Syntax ListW where+  prettySymbol AppendW (Lit n :> y :> Nil) p = Just $ parensIf (p > 10) $ "append_" <+> prettyShowList n <+> prettyPrec 10 y+  prettySymbol AppendW (y :> Lit n :> Nil) p = Just $ parensIf (p > 10) $ "append_" <+> prettyPrec 10 y <+> prettyShowList n+  prettySymbol _ _ _ = Nothing++instance Show (ListW d r) where+  show AppendW = "append_"+  show SingletonListW = "singletonList_"+  show (FoldMapW n) = "(FoldMapW  " ++ show n ++ ")"++deriving instance (Eq (ListW d r))++------------------------------------------------------------------------+-- Functions for writing constraints on lists+------------------------------------------------------------------------++-- | Sum over a `Foldy` list+sum_ ::+  Foldy a =>+  Term [a] ->+  Term a+sum_ = foldMap_ id++-- | Like @[a]@+singletonList_ :: HasSpec a => Term a -> Term [a]+singletonList_ = appTerm SingletonListW++-- | Append two lists, like `(++)`+append_ :: HasSpec a => Term [a] -> Term [a] -> Term [a]+append_ = appTerm AppendW++-- | Map a function over a list and fold the results via the `Foldy` instance+foldMap_ :: forall a b. (Foldy b, HasSpec a) => (Term a -> Term b) -> Term [a] -> Term b+foldMap_ f = appFun $ foldMapFn $ toFn $ f (V v)+  where+    v = Var (-1) "v" :: Var a+    -- Turn `f (V v) = fn (gn (hn v))` into `composeFn fn (composeFn gn hn)`+    -- Note: composeFn :: HasSpec b => Fun '[b] c -> Fun '[a] b -> Fun '[a] c+    toFn :: forall x. HasCallStack => Term x -> Fun '[a] x+    toFn (App fn (V v' :> Nil)) | Just Refl <- eqVar v v' = Fun fn+    toFn (App fn (t :> Nil)) = composeFn (Fun fn) (toFn t)+    toFn (V v') | Just Refl <- eqVar v v' = idFn+    toFn _ = error "foldMap_ has not been given a function of the form \\ x -> f (g ... (h x))"++-- Fun types for lists and their helper functions++foldMapFn :: forall a b. (HasSpec a, Foldy b) => Fun '[a] b -> Fun '[[a]] b+foldMapFn f = Fun (FoldMapW f)++reverseFoldSpec :: FoldSpec a -> Specification a+reverseFoldSpec NoFold = TrueSpec+-- The single element list has to sum to something that obeys spec, i.e. `conformsToSpec (f a) spec`+reverseFoldSpec (FoldSpec (Fun fn) spec) = propagate fn (HOLE :? Nil) spec++prefixedBy :: Eq a => [a] -> [[a]] -> [[a]]+prefixedBy ys xss = [drop (length ys) xs | xs <- xss, ys `isPrefixOf` xs]++suffixedBy :: Eq a => [a] -> [[a]] -> [[a]]+suffixedBy ys xss = [take (length xs - length ys) xs | xs <- xss, ys `isSuffixOf` xs]++alreadyHave :: Eq a => [a] -> ListSpec a -> ListSpec a+alreadyHave ys (ListSpec h m sz e f) =+  ListSpec+    -- Reduce the hint+    (fmap (subtract (sizeOf ys)) h)+    -- The things in `ys` have already been added to the list, no need to+    -- require them too+    (m \\ ys)+    -- Reduce the required size+    (constrained $ \x -> (x + Lit (sizeOf ys)) `satisfies` sz)+    -- Nothing changes about what's a correct element+    e+    -- we have fewer things to sum now+    (alreadyHaveFold ys f)++alreadyHaveFold :: [a] -> FoldSpec a -> FoldSpec a+alreadyHaveFold _ NoFold = NoFold+alreadyHaveFold ys (FoldSpec fn spec) =+  FoldSpec+    fn+    (constrained $ \s -> appTerm theAddFn s (foldMap_ (appFun fn) (Lit ys)) `satisfies` spec)++-- | Used in the HasSpec [a] instance+toPredsFoldSpec :: HasSpec a => Term [a] -> FoldSpec a -> Pred+toPredsFoldSpec _ NoFold = TruePred+toPredsFoldSpec x (FoldSpec funAB sspec) =+  satisfies (appFun (foldMapFn funAB) x) sspec++-- =======================================================+-- FoldSpec is a Spec that appears inside of ListSpec++-- | Specification for how a thing sums together, used to represent `foldMap_`-related constraints+data FoldSpec a where+  NoFold :: FoldSpec a+  FoldSpec ::+    forall b a.+    ( HasSpec a+    , HasSpec b+    , Foldy b+    ) =>+    Fun '[a] b ->+    Specification b ->+    FoldSpec a++-- | Take a `FoldSpec` and turn it into a `FoldSpec` for a function applied+-- before the original spec+preMapFoldSpec :: HasSpec a => Fun '[a] b -> FoldSpec b -> FoldSpec a+preMapFoldSpec _ NoFold = NoFold+preMapFoldSpec f (FoldSpec g s) = FoldSpec (composeFn g f) s++composeFn :: (HasSpec b, HasSpec c) => Fun '[b] c -> Fun '[a] b -> Fun '[a] c+composeFn (Fun f) (Fun g) = (Fun (ComposeW f g))++idFn :: HasSpec a => Fun '[a] a+idFn = Fun IdW++-- | Possibly failing conjuction of `FoldSpec`s+combineFoldSpec :: FoldSpec a -> FoldSpec a -> Either [String] (FoldSpec a)+combineFoldSpec NoFold s = pure s+combineFoldSpec s NoFold = pure s+combineFoldSpec (FoldSpec (Fun f) s) (FoldSpec (Fun g) s') =+  case sameFunSym f g of+    Just (_, _, Refl) -> pure $ FoldSpec (Fun f) (s <> s')+    Nothing -> Left ["Can't combine fold specs on different functions", "  " ++ show f, "  " ++ show g]++-- | Check if a list sums like what's required by a `FoldSpec`+conformsToFoldSpec :: forall a. [a] -> FoldSpec a -> Bool+conformsToFoldSpec _ NoFold = True+conformsToFoldSpec xs (FoldSpec (Fun f) s) = adds (map (semantics f) xs) `conformsToSpec` s++-- | Talk about how to add together values and generate lists of values that+-- conform to `FoldSpec`s+class (HasSpec a, NumLike a) => Foldy a where+  genList ::+    MonadGenError m => Specification a -> Specification a -> GenT m [a]+  default genList ::+    (MonadGenError m, GenericallyInstantiated a, Foldy (SimpleRep a)) =>+    Specification a -> Specification a -> GenT m [a]+  genList s s' = map fromSimpleRep <$> genList (toSimpleRepSpec s) (toSimpleRepSpec s')++  theAddFn :: IntW '[a, a] a+  theAddFn = AddW++  theZero :: a+  theZero = 0++  genSizedList ::+    MonadGenError m =>+    Specification Integer ->+    Specification a ->+    Specification a ->+    GenT m [a]+  default genSizedList ::+    (MonadGenError m, GenericallyInstantiated a, Foldy (SimpleRep a)) =>+    Specification Integer ->+    Specification a ->+    Specification a ->+    GenT m [a]+  genSizedList sz elemSpec foldSpec =+    map fromSimpleRep+      <$> genSizedList sz (toSimpleRepSpec elemSpec) (toSimpleRepSpec foldSpec)++  noNegativeValues :: Bool+  noNegativeValues = False++-- | Semantics of `foldMap_`+adds :: Foldy a => [a] -> a+adds = foldr (semantics theAddFn) theZero++------------------------------------------------------------------------+-- Foldy instances+------------------------------------------------------------------------++instance Foldy Integer where+  genList = genNumList+  genSizedList = genListWithSize++instance Foldy Int where+  genList = genNumList+  genSizedList = genListWithSize++instance Foldy Int8 where+  genList = genNumList+  genSizedList = genListWithSize++instance Foldy Int16 where+  genList = genNumList+  genSizedList = genListWithSize++instance Foldy Int32 where+  genList = genNumList+  genSizedList = genListWithSize++instance Foldy Int64 where+  genList = genNumList+  genSizedList = genListWithSize++instance Foldy Natural where+  noNegativeValues = True+  genList = genNumList+  genSizedList = genListWithSize++instance Foldy Word8 where+  noNegativeValues = True+  genList = genNumList+  genSizedList = genListWithSize++instance Foldy Word16 where+  noNegativeValues = True+  genList = genNumList+  genSizedList = genListWithSize++instance Foldy Word32 where+  noNegativeValues = True+  genList = genNumList+  genSizedList = genListWithSize++instance Foldy Word64 where+  noNegativeValues = True+  genList = genNumList+  genSizedList = genListWithSize++genFromFold ::+  forall m a b.+  ( MonadGenError m+  , Foldy b+  , HasSpec a+  ) =>+  [a] ->+  Specification Integer ->+  Specification a ->+  Fun '[a] b ->+  Specification b ->+  GenT m [a]+genFromFold must (simplifySpec -> size) elemS fun@(Fun fn) foldS+  | isErrorLike size =+      fatalErrorNE (NE.cons "genFromFold has ErrorLike sizeSpec" (errorLikeMessage size))+  | isErrorLike elemS =+      fatalErrorNE (NE.cons "genFromFold has ErrorLike elemSpec" (errorLikeMessage elemS))+  | isErrorLike foldS =+      fatalErrorNE (NE.cons "genFromFold has ErrorLike totalSpec" (errorLikeMessage foldS))+  | otherwise = ( explainNE+                    ( NE.fromList+                        [ "while calling genFromFold"+                        , "  must  = " ++ show must+                        , "  size  = " ++ show size+                        , "  elemS = " ++ show elemS+                        , "  fun   = " ++ show fun+                        , "  foldS = " ++ show foldS+                        ]+                    )+                )+      $ do+        let elemS' :: Specification b+            elemS' = mapSpec fn elemS+            mustVal = adds (map (semantics fn) must)+            foldS' :: Specification b+            foldS' = propagate theAddFn (HOLE :? Value mustVal :> Nil) foldS+            sizeSpec' :: Specification Integer+            sizeSpec' = propagate AddW (HOLE :? Value (sizeOf must) :> Nil) size+        when (isErrorLike sizeSpec') $ genError "Inconsistent size spec"+        results0 <- case sizeSpec' of+          TrueSpec -> genList (simplifySpec elemS') (simplifySpec foldS')+          _ -> genSizedList sizeSpec' (simplifySpec elemS') (simplifySpec foldS')+        results <-+          explainNE+            ( NE.fromList+                [ "genInverse"+                , "  fun = " ++ show fun+                , "  results0 = " ++ show results0+                , show $ "  elemS' =" <+> pretty elemS'+                ]+            )+            $ mapM (genInverse fun elemS) results0+        pureGen $ shuffle $ must ++ results++instance Sized [a] where+  sizeOf = toInteger . length+  liftSizeSpec spec cant = typeSpec (ListSpec Nothing mempty (TypeSpec spec cant) TrueSpec NoFold)+  liftMemberSpec xs = case NE.nonEmpty xs of+    Nothing -> ErrorSpec (pure ("In liftMemberSpec for (Sized List) instance, xs is the empty list"))+    Just zs -> typeSpec (ListSpec Nothing mempty (MemberSpec zs) TrueSpec NoFold)+  sizeOfTypeSpec (ListSpec _ _ _ ErrorSpec {} _) = equalSpec 0+  sizeOfTypeSpec (ListSpec _ must sizespec _ _) = sizespec <> geqSpec (sizeOf must)
+ src/Constrained/Spec/Map.hs view
@@ -0,0 +1,436 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | `HasSpec` instance for `Map` and functions for working with `Map`s+module Constrained.Spec.Map (+  MapSpec (..),+  defaultMapSpec,+  MapW (..),+  lookup_,+  mapMember_,+  dom_,+  rng_,+) where++import Constrained.AbstractSyntax+import Constrained.Base+import Constrained.Conformance+import Constrained.Core+import Constrained.FunctionSymbol+import Constrained.GenT+import Constrained.Generation+import Constrained.Generic (Prod (..))+import Constrained.List+import Constrained.NumOrd (cardinality, geqSpec, leqSpec, nubOrd)+import Constrained.PrettyUtils+import Constrained.Spec.List+import Constrained.Spec.Set+import Constrained.Spec.SumProd+import Constrained.Syntax+import Constrained.TheKnot+import Control.Monad+import Data.Foldable+import Data.Kind+import Data.List (nub)+import qualified Data.List.NonEmpty as NE+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Set (Set)+import qualified Data.Set as Set+import GHC.Generics+import Prettyprinter+import Test.QuickCheck hiding (Fun, Witness, forAll)++------------------------------------------------------------------------+-- HasSpec+------------------------------------------------------------------------++instance Ord a => Sized (Map.Map a b) where+  sizeOf = toInteger . Map.size+  liftSizeSpec sz cant = typeSpec $ defaultMapSpec {mapSpecSize = TypeSpec sz cant}+  liftMemberSpec xs = case NE.nonEmpty (nubOrd xs) of+    Nothing -> ErrorSpec (pure "In liftMemberSpec for the (Sized Map) instance, xs is the empty list")+    Just ys -> typeSpec $ defaultMapSpec {mapSpecSize = MemberSpec ys}+  sizeOfTypeSpec (MapSpec _ mustk mustv size _ _) =+    geqSpec (sizeOf mustk)+      <> geqSpec (sizeOf mustv)+      <> size++-- | Custom `TypeSpec` for `Map`+data MapSpec k v = MapSpec+  { mapSpecHint :: Maybe Integer+  , mapSpecMustKeys :: Set k+  , mapSpecMustValues :: [v]+  , mapSpecSize :: Specification Integer+  , mapSpecElem :: Specification (k, v)+  , mapSpecFold :: FoldSpec v+  }+  deriving (Generic)++-- | emptySpec without all the constraints+defaultMapSpec :: Ord k => MapSpec k v+defaultMapSpec = MapSpec Nothing mempty mempty TrueSpec TrueSpec NoFold++instance+  ( HasSpec (k, v)+  , HasSpec k+  , HasSpec v+  , HasSpec [v]+  ) =>+  Pretty (WithPrec (MapSpec k v))+  where+  pretty (WithPrec d s) =+    parensIf (d > 10) $+      "MapSpec"+        /> vsep+          [ "hint       =" <+> viaShow (mapSpecHint s)+          , "mustKeys   =" <+> viaShow (mapSpecMustKeys s)+          , "mustValues =" <+> viaShow (mapSpecMustValues s)+          , "size       =" <+> pretty (mapSpecSize s)+          , "elem       =" <+> pretty (mapSpecElem s)+          , "fold       =" <+> pretty (mapSpecFold s)+          ]++instance+  ( HasSpec (k, v)+  , HasSpec k+  , HasSpec v+  , HasSpec [v]+  ) =>+  Show (MapSpec k v)+  where+  showsPrec d = shows . prettyPrec d++instance Ord k => Forallable (Map k v) (k, v) where+  fromForAllSpec kvs = typeSpec $ defaultMapSpec {mapSpecElem = kvs}+  forAllToList = Map.toList++-- ============================================================+-- We will need to take projections on (Specification (a,b))++fstSpec :: forall k v. (HasSpec k, HasSpec v) => Specification (k, v) -> Specification k+fstSpec s = mapSpec ProdFstW (mapSpec ToGenericW s)++sndSpec :: forall k v. (HasSpec k, HasSpec v) => Specification (k, v) -> Specification v+sndSpec s = mapSpec ProdSndW (mapSpec ToGenericW s)++-- ======================================================================+-- The HasSpec instance for Maps++instance+  (Ord k, HasSpec (Prod k v), HasSpec k, HasSpec v, HasSpec [v], IsNormalType k, IsNormalType v) =>+  HasSpec (Map k v)+  where+  type TypeSpec (Map k v) = MapSpec k v+  type Prerequisites (Map k v) = (HasSpec k, HasSpec v)++  emptySpec = defaultMapSpec++  combineSpec+    (MapSpec mHint mustKeys mustVals size kvs foldSpec)+    (MapSpec mHint' mustKeys' mustVals' size' kvs' foldSpec') = case combineFoldSpec foldSpec foldSpec' of+      Left msgs ->+        ErrorSpec $+          NE.fromList $+            [ "Error in combining FoldSpec in combineSpec for Map"+            , "  " ++ show foldSpec+            , "  " ++ show foldSpec'+            ]+              ++ msgs+      Right foldSpec'' ->+        typeSpec $+          MapSpec+            -- This is min because that allows more compositionality - if a spec specifies a+            -- low upper bound because some part of the spec will be slow it doesn't make sense+            -- to increase it somewhere else because that part isn't slow.+            (unionWithMaybe min mHint mHint')+            (mustKeys <> mustKeys')+            (nub $ mustVals <> mustVals')+            (size <> size')+            (kvs <> kvs')+            foldSpec''++  conformsTo m (MapSpec _ mustKeys mustVals size kvs foldSpec) =+    and+      [ mustKeys `Set.isSubsetOf` Map.keysSet m+      , all (`elem` Map.elems m) mustVals+      , sizeOf m `conformsToSpec` size+      , all (`conformsToSpec` kvs) (Map.toList m)+      , Map.elems m `conformsToFoldSpec` foldSpec+      ]++  genFromTypeSpec (MapSpec mHint mustKeys mustVals size (simplifySpec -> kvs) NoFold)+    | null mustKeys+    , null mustVals = do+        let size' =+              fold+                [ maybe TrueSpec (leqSpec . max 0) mHint+                , size+                , maxSpec (cardinality (fstSpec kvs))+                , maxSpec (cardinalTrueSpec @k)+                , geqSpec 0+                ]+        n <- genFromSpecT size'+        let go fc sz 0 slow kvs' m+              | fromInteger sz == Map.size m = pure m+              | not slow =+                  go+                    fc+                    sz+                    (sz - fromIntegral (Map.size m))+                    True+                    (kvs' <> typeSpec (Cartesian (notMemberSpec (Map.keys m)) mempty))+                    m+              | otherwise = fatalError "The impossible happened"+            go fc sz n' slow kvs' m = do+              mkv <- inspect $ genFromSpecT kvs'+              case mkv of+                Result (k, v) ->+                  go+                    fc+                    sz+                    (n' - 1)+                    slow+                    (kvs' <> if slow then typeSpec (Cartesian (notEqualSpec k) mempty) else mempty)+                    (Map.insert k v m)+                GenError {} | fc > 0 -> go (fc - 1) sz n' slow kvs' m+                GenError msgs ->+                  if sizeOf m `conformsToSpec` size+                    then pure m+                    else+                      genErrorNE+                        (pure "Gen error while trying to generate enough elements for a Map." <> catMessageList msgs)+                FatalError msgs ->+                  genErrorNE+                    ( NE.fromList+                        [ "Fatal error while trying to generate enough elements for a map:"+                        , "  The ones we have generated so far = " ++ show m+                        , "  The number we need to still generate: n' = " ++ show n'+                        , "The original size spec " ++ show size+                        , "The refined  size spec " ++ show size'+                        , "The computed target size " ++ show n+                        , "Fatal error messages"+                        , "<<<---"+                        ]+                        <> catMessageList msgs+                        <> (pure "--->>>")+                    )+        explain ("  The number we are trying for: n = " ++ show n) $ go (10 * n) n n False kvs mempty+  genFromTypeSpec (MapSpec mHint mustKeys mustVals size (simplifySpec -> kvs) foldSpec) = do+    !mustMap <- explain "Make the mustMap" $ forM (Set.toList mustKeys) $ \k -> do+      let vSpec = constrained $ \v -> satisfies (pair_ (Lit k) v) kvs+      v <- explain (show $ "vSpec =" <+> pretty vSpec) $ genFromSpecT vSpec+      pure (k, v)+    let haveVals = map snd mustMap+        mustVals' = filter (`notElem` haveVals) mustVals+        size' = simplifySpec $ constrained $ \sz ->+          -- TODO, we should make sure size' is greater than or equal to 0+          satisfies+            (sz + Lit (sizeOf mustMap))+            ( maybe TrueSpec (leqSpec . max 0) mHint+                <> size+                <> maxSpec (cardinality (fstSpec kvs)) -- (mapSpec FstW $ mapSpec ToGenericW kvs))+                <> maxSpec (cardinalTrueSpec @k)+            )+        !foldSpec' = case foldSpec of+          NoFold -> NoFold+          FoldSpec fn@(Fun symbol) sumSpec -> FoldSpec fn $ propagate theAddFn (HOLE :? Value mustSum :> Nil) sumSpec+            where+              mustSum = adds (map (semantics symbol) haveVals)+    let !valsSpec =+          ListSpec+            Nothing+            mustVals'+            size'+            (simplifySpec $ constrained $ \v -> unsafeExists $ \k -> pair_ k v `satisfies` kvs)+            foldSpec'++    !restVals <-+      explainNE+        ( NE.fromList+            [ "Make the restVals"+            , show $ "  valsSpec =" <+> pretty valsSpec+            , show $ "  mustMap =" <+> viaShow mustMap+            , show $ "  size' =" <+> pretty size'+            ]+        )+        $ genFromTypeSpec+        $ valsSpec+    let go m [] = pure m+        go m (v : restVals') = do+          let keySpec = notMemberSpec (Map.keysSet m) <> constrained (\k -> pair_ k (Lit v) `satisfies` kvs)+          k <-+            explainNE+              ( NE.fromList+                  [ "Make a key"+                  , show $ indent 4 $ "keySpec =" <+> pretty keySpec+                  ]+              )+              $ genFromSpecT keySpec+          go (Map.insert k v m) restVals'++    go (Map.fromList mustMap) restVals++  cardinalTypeSpec _ = TrueSpec++  shrinkWithTypeSpec (MapSpec _ _ _ _ kvs _) m = map Map.fromList $ shrinkList (shrinkWithSpec kvs) (Map.toList m)++  fixupWithTypeSpec _ _ = Nothing++  toPreds m (MapSpec mHint mustKeys mustVals size kvs foldSpec) =+    toPred+      [ Assert $ Lit mustKeys `subset_` dom_ m+      , forAll (Lit mustVals) $ \val ->+          val `elem_` rng_ m+      , sizeOf_ (rng_ m) `satisfies` size+      , forAll m $ \kv -> satisfies kv kvs+      , toPredsFoldSpec (rng_ m) foldSpec+      , maybe TruePred (`genHint` m) mHint+      ]++instance+  (Ord k, HasSpec k, HasSpec v, HasSpec [v], IsNormalType k, IsNormalType v) =>+  HasGenHint (Map k v)+  where+  type Hint (Map k v) = Integer+  giveHint h = typeSpec $ defaultMapSpec {mapSpecHint = Just h}++------------------------------------------------------------------------+-- Logic instances for+------------------------------------------------------------------------++-- | Function symbols for talking about maps+data MapW (dom :: [Type]) (rng :: Type) where+  DomW :: (HasSpec k, HasSpec v, IsNormalType k, IsNormalType v, Ord k) => MapW '[Map k v] (Set k)+  RngW :: (HasSpec k, HasSpec v, IsNormalType k, IsNormalType v, Ord k) => MapW '[Map k v] [v]+  LookupW ::+    (HasSpec k, HasSpec v, IsNormalType k, IsNormalType v, Ord k) => MapW '[k, Map k v] (Maybe v)++deriving instance Eq (MapW dom rng)++instance Semantics MapW where+  semantics DomW = Map.keysSet+  semantics RngW = Map.elems+  semantics LookupW = Map.lookup++instance Syntax MapW++instance Show (MapW d r) where+  show DomW = "dom_"+  show RngW = "rng_"+  show LookupW = "lookup_"++instance Logic MapW where+  propagate f ctxt (ExplainSpec es s) = explainSpec es $ propagate f ctxt s+  propagate _ _ TrueSpec = TrueSpec+  propagate _ _ (ErrorSpec msgs) = ErrorSpec msgs+  propagate f ctx (SuspendedSpec v ps) = constrained $ \v' -> Let (App f (fromListCtx ctx v')) (v :-> ps)+  propagate DomW (Unary HOLE) spec =+    case spec of+      MemberSpec (s :| []) ->+        typeSpec $+          MapSpec Nothing s [] (equalSpec $ sizeOf s) TrueSpec NoFold+      TypeSpec (SetSpec must elemspec size) [] ->+        typeSpec $+          MapSpec+            Nothing+            must+            []+            size+            (constrained $ \kv -> satisfies (fst_ kv) elemspec)+            NoFold+      _ -> ErrorSpec (NE.fromList ["Dom on bad map spec", show spec])+  propagate RngW (Unary HOLE) spec =+    case spec of+      TypeSpec (ListSpec listHint must size elemspec foldspec) [] ->+        typeSpec $+          MapSpec+            listHint+            Set.empty+            must+            size+            (constrained $ \kv -> satisfies (snd_ kv) elemspec)+            foldspec+      -- NOTE: you'd think `MemberSpec [r]` was a safe and easy case. However, that+      -- requires not only that the elements of the map are fixed to what is in `r`,+      -- but they appear in the order that they are in `r`. That's+      -- very difficult to achieve!+      _ -> ErrorSpec (NE.fromList ["Rng on bad map spec", show spec])+  propagate LookupW (Value k :! Unary HOLE) spec =+    constrained $ \m ->+      [Assert $ Lit k `member_` dom_ m | not $ Nothing `conformsToSpec` spec]+        ++ [ forAll m $ \kv ->+               letBind (fst_ kv) $ \k' ->+                 letBind (snd_ kv) $ \v ->+                   whenTrue (Lit k ==. k') $+                     -- TODO: What you want to write is `just_ v `satisfies` spec` but we can't+                     -- do that because we don't have access to `IsNormalType v` here. When+                     -- we refactor the `IsNormalType` machinery we will be able to make+                     -- this nicer.+                     case spec of+                       MemberSpec as -> Assert $ v `elem_` Lit [a | Just a <- NE.toList as]+                       TypeSpec (SumSpec _ _ vspec) cant ->+                         v `satisfies` (vspec <> notMemberSpec [a | Just a <- cant])+           ]+  propagate LookupW (HOLE :? Value m :> Nil) spec =+    if Nothing `conformsToSpec` spec+      then notMemberSpec [k | (k, v) <- Map.toList m, not $ Just v `conformsToSpec` spec]+      else+        memberSpec+          (Map.keys $ Map.filter ((`conformsToSpec` spec) . Just) m)+          ( NE.fromList+              [ "propagate (lookup HOLE ms) on (MemberSpec ms)"+              , "forall pairs (d,r) in ms, no 'd' conforms to spec"+              , "  " ++ show spec+              ]+          )++  mapTypeSpec DomW (MapSpec _ mustSet _ sz kvSpec _) = typeSpec $ SetSpec mustSet (fstSpec kvSpec) sz+  mapTypeSpec RngW (MapSpec _ _ mustList sz kvSpec foldSpec) = typeSpec $ ListSpec Nothing mustList sz (sndSpec kvSpec) foldSpec++------------------------------------------------------------------------+-- Syntax+------------------------------------------------------------------------++-- | Take the domain of a `Map` as a `Set`+dom_ ::+  (HasSpec (Map k v), HasSpec v, HasSpec k, Ord k, IsNormalType k, IsNormalType v) =>+  Term (Map k v) ->+  Term (Set k)+dom_ = appTerm DomW++-- | Take the range of a `Map` as a list+rng_ ::+  (HasSpec k, HasSpec v, Ord k, IsNormalType k, IsNormalType v) =>+  Term (Map k v) ->+  Term [v]+rng_ = appTerm RngW++-- | Lookup a key in the `Map`+lookup_ ::+  (HasSpec k, HasSpec v, Ord k, IsNormalType k, IsNormalType v) =>+  Term k ->+  Term (Map k v) ->+  Term (Maybe v)+lookup_ = appTerm LookupW++-- | Check if a key is a member of the map+mapMember_ ::+  (HasSpec k, HasSpec v, Ord k, IsNormalType k, IsNormalType v) =>+  Term k ->+  Term (Map k v) ->+  Term Bool+mapMember_ k m = not_ $ lookup_ k m ==. lit Nothing
+ src/Constrained/Spec/Set.hs view
@@ -0,0 +1,465 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | `HasSpec` instance for `Set`s and functions for writing+-- constraints about sets+module Constrained.Spec.Set (+  SetSpec (..),+  SetW (..),+  singleton_,+  subset_,+  member_,+  union_,+  disjoint_,+  fromList_,+) where++import Constrained.AbstractSyntax+import Constrained.Base+import Constrained.Conformance+import Constrained.Core+import Constrained.FunctionSymbol+import Constrained.GenT+import Constrained.Generation+import Constrained.List+import Constrained.NumOrd+import Constrained.PrettyUtils+import Constrained.Spec.List+import Constrained.SumList+import Constrained.Syntax+import Constrained.TheKnot+import Data.Foldable+import Data.Kind+import Data.List ((\\))+import qualified Data.List.NonEmpty as NE+import Data.Set (Set)+import qualified Data.Set as Set+import Prettyprinter hiding (cat)+import Test.QuickCheck (shrinkList, shuffle)++------------------------------------------------------------------------+-- HasSpec instance for Set+------------------------------------------------------------------------++-- | `TypeSpec` for `Set`+data SetSpec a+  = SetSpec+      -- | Required elements+      (Set a)+      -- | Specification for elements+      (Specification a)+      -- | Specification for size+      (Specification Integer)++instance Ord a => Sized (Set.Set a) where+  sizeOf = toInteger . Set.size+  liftSizeSpec spec cant = typeSpec (SetSpec mempty TrueSpec (TypeSpec spec cant))+  liftMemberSpec xs = case NE.nonEmpty xs of+    Nothing -> ErrorSpec (pure "In liftMemberSpec for the (Sized Set) instance, xs is the empty list")+    Just zs -> typeSpec (SetSpec mempty TrueSpec (MemberSpec zs))+  sizeOfTypeSpec (SetSpec must _ sz) = sz <> geqSpec (sizeOf must)++instance (Ord a, HasSpec a) => Semigroup (SetSpec a) where+  SetSpec must es size <> SetSpec must' es' size' =+    SetSpec (must <> must') (es <> es') (size <> size')++instance (Ord a, HasSpec a) => Monoid (SetSpec a) where+  mempty = SetSpec mempty mempty TrueSpec++instance Ord a => Forallable (Set a) a where+  fromForAllSpec (e :: Specification a)+    | Evidence <- prerequisites @(Set a) = typeSpec $ SetSpec mempty e TrueSpec+  forAllToList = Set.toList++prettySetSpec :: HasSpec a => SetSpec a -> Doc ann+prettySetSpec (SetSpec must elemS size) =+  parens+    ( "SetSpec"+        /> sep ["must=" <> viaShow (Set.toList must), "elem=" <> pretty elemS, "size=" <> pretty size]+    )++instance HasSpec a => Show (SetSpec a) where+  show x = show (prettySetSpec x)++guardSetSpec :: (HasSpec a, Ord a) => [String] -> SetSpec a -> Specification (Set a)+guardSetSpec es (SetSpec must elemS ((<> geqSpec 0) -> size))+  | Just u <- knownUpperBound size+  , u < 0 =+      ErrorSpec (("guardSetSpec: negative size " ++ show u) :| es)+  | not (all (`conformsToSpec` elemS) must) =+      ErrorSpec (("Some 'must' items do not conform to 'element' spec: " ++ show elemS) :| es)+  | isErrorLike size = ErrorSpec ("guardSetSpec: error in size" :| es)+  | isErrorLike (geqSpec (sizeOf must) <> size) =+      ErrorSpec $+        ("Must set size " ++ show (sizeOf must) ++ ", is inconsistent with SetSpec size" ++ show size) :| es+  | isErrorLike (maxSpec (cardinality elemS) <> size) =+      ErrorSpec $+        NE.fromList $+          [ "Cardinality of SetSpec elemSpec (" ++ show elemS ++ ") = " ++ show (maxSpec (cardinality elemS))+          , "   This is inconsistent with SetSpec size (" ++ show size ++ ")"+          ]+            ++ es+  | otherwise = typeSpec (SetSpec must elemS size)++instance (Ord a, HasSpec a) => HasSpec (Set a) where+  type TypeSpec (Set a) = SetSpec a++  type Prerequisites (Set a) = HasSpec a++  emptySpec = mempty++  combineSpec s s' = guardSetSpec ["While combining 2 SetSpecs", "  " ++ show s, "  " ++ show s'] (s <> s')++  conformsTo s (SetSpec must es size) =+    and+      [ sizeOf s `conformsToSpec` size+      , must `Set.isSubsetOf` s+      , all (`conformsToSpec` es) s+      ]++  genFromTypeSpec (SetSpec must e _)+    | not $ allConformToSpec must e =+        genErrorNE+          ( NE.fromList+              [ "Failed to generate set"+              , "Some element in the must set does not conform to the elem specification"+              , "Unconforming elements from the must set:"+              , unlines (map (\x -> "  " ++ show x) (filter (not . (`conformsToSpec` e)) (Set.toList must)))+              , "Element Specifcation"+              , "  " ++ show e+              ]+          )+  -- Special case when elemS is a MemberSpec.+  -- Just union 'must' with enough elements of 'xs' to meet  'szSpec'+  genFromTypeSpec (SetSpec must (ExplainSpec [] elemspec) szSpec) =+    genFromTypeSpec (SetSpec must elemspec szSpec)+  genFromTypeSpec (SetSpec must (ExplainSpec (e : es) elemspec) szSpec) =+    explainNE (e :| es) $ genFromTypeSpec (SetSpec must elemspec szSpec)+  genFromTypeSpec (SetSpec must elemS@(MemberSpec xs) szSpec) = do+    let szSpec' = szSpec <> geqSpec (sizeOf must) <> maxSpec (cardinality elemS)+    choices <- pureGen $ shuffle (NE.toList xs \\ Set.toList must)+    size <- fromInteger <$> genFromSpecT szSpec'+    let additions = Set.fromList $ take (size - Set.size must) choices+    pure (Set.union must additions)+  genFromTypeSpec (SetSpec must (simplifySpec -> elemS) szSpec) = do+    let szSpec' = szSpec <> geqSpec (sizeOf must) <> maxSpec cardinalityElem+    chosenSize <-+      explain "Choose a size for the Set to be generated" $+        genFromSpecT szSpec'+    let targetSize = chosenSize - sizeOf must+    explainNE+      ( NE.fromList+          [ "Choose size = " ++ show chosenSize+          , "szSpec' = " ++ show szSpec'+          , "Picking items not in must = " ++ show (Set.toList must)+          , "that also meet the element test: "+          , "  " ++ show elemS+          ]+      )+      $ case theMostWeCanExpect of+        -- 0 means TrueSpec or SuspendedSpec so we can't rule anything out+        0 -> go 100 targetSize must+        n -> case compare n targetSize of+          LT -> fatalError "The number of things that meet the element test is too small."+          GT -> go 100 targetSize must+          EQ -> go 100 targetSize must+    where+      cardinalityElem = cardinality elemS+      theMostWeCanExpect = maxFromSpec 0 cardinalityElem+      genElem = genFromSpecT elemS+      go _ n s | n <= 0 = pure s+      go tries n s = do+        e <-+          explainNE+            ( NE.fromList+                [ "Generate set member at type " ++ showType @a+                , "  number of items starting with  = " ++ show (Set.size must)+                , "  number of items left to pick   = " ++ show n+                , "  number of items already picked = " ++ show (Set.size s)+                , "  the most items we can expect is " ++ show theMostWeCanExpect ++ " (a SuspendedSpec)"+                ]+            )+            $ withMode Strict+            $ suchThatWithTryT tries genElem (`Set.notMember` s)++        go tries (n - 1) (Set.insert e s)++  cardinalTypeSpec (SetSpec _ es _)+    | Just ub <- knownUpperBound (cardinality es) = leqSpec (2 ^ ub)+  cardinalTypeSpec _ = TrueSpec++  cardinalTrueSpec+    | Just ub <- knownUpperBound $ cardinalTrueSpec @a = leqSpec (2 ^ ub)+    | otherwise = TrueSpec++  shrinkWithTypeSpec (SetSpec _ es _) as = map Set.fromList $ shrinkList (shrinkWithSpec es) (Set.toList as)++  -- TODO: fixme+  fixupWithTypeSpec _ _ = Nothing++  toPreds s (SetSpec m es size) =+    fold $+      -- Don't include this if the must set is empty+      [ Explain (pure (show m ++ " is a subset of the set.")) $ Assert $ subset_ (Lit m) s+      | not $ Set.null m+      ]+        ++ [ forAll s (\e -> satisfies e es)+           , satisfies (sizeOf_ s) size+           ]++  guardTypeSpec = guardSetSpec++------------------------------------------------------------------------+-- Functions that deal with sets+------------------------------------------------------------------------++-- | Symbols for working on sets+data SetW (d :: [Type]) (r :: Type) where+  SingletonW :: (HasSpec a, Ord a) => SetW '[a] (Set a)+  UnionW :: (HasSpec a, Ord a) => SetW '[Set a, Set a] (Set a)+  SubsetW :: (HasSpec a, Ord a, HasSpec a) => SetW '[Set a, Set a] Bool+  MemberW :: (HasSpec a, Ord a) => SetW '[a, Set a] Bool+  DisjointW :: (HasSpec a, Ord a) => SetW '[Set a, Set a] Bool+  FromListW :: (HasSpec a, Ord a) => SetW '[[a]] (Set a)++deriving instance Eq (SetW dom rng)++instance Show (SetW ds r) where+  show SingletonW = "singleton_"+  show UnionW = "union_"+  show SubsetW = "subset_"+  show MemberW = "member_"+  show DisjointW = "disjoint_"+  show FromListW = "fromList_"++setSem :: SetW ds r -> FunTy ds r+setSem SingletonW = Set.singleton+setSem UnionW = Set.union+setSem SubsetW = Set.isSubsetOf+setSem MemberW = Set.member+setSem DisjointW = Set.disjoint+setSem FromListW = Set.fromList++instance Semantics SetW where+  semantics = setSem++instance Syntax SetW where+  prettySymbol SubsetW (Lit n :> y :> Nil) p = Just $ parensIf (p > 10) $ "subset_" <+> prettyShowSet n <+> prettyPrec 11 y+  prettySymbol SubsetW (y :> Lit n :> Nil) p = Just $ parensIf (p > 10) $ "subset_" <+> prettyPrec 11 y <+> prettyShowSet n+  prettySymbol DisjointW (Lit n :> y :> Nil) p = Just $ parensIf (p > 10) $ "disjoint_" <+> prettyShowSet n <+> prettyPrec 11 y+  prettySymbol DisjointW (y :> Lit n :> Nil) p = Just $ parensIf (p > 10) $ "disjoint_" <+> prettyPrec 11 y <+> prettyShowSet n+  prettySymbol UnionW (Lit n :> y :> Nil) p = Just $ parensIf (p > 10) $ "union_" <+> prettyShowSet n <+> prettyPrec 11 y+  prettySymbol UnionW (y :> Lit n :> Nil) p = Just $ parensIf (p > 10) $ "union_" <+> prettyPrec 11 y <+> prettyShowSet n+  prettySymbol MemberW (y :> Lit n :> Nil) p = Just $ parensIf (p > 10) $ "member_" <+> prettyPrec 11 y <+> prettyShowSet n+  prettySymbol _ _ _ = Nothing++instance (Ord a, HasSpec a, HasSpec (Set a)) => Semigroup (Term (Set a)) where+  (<>) = union_++instance (Ord a, HasSpec a, HasSpec (Set a)) => Monoid (Term (Set a)) where+  mempty = Lit mempty++-- Logic instance for SetW ------------------------------------------------++singletons :: [Set a] -> [Set a] -- Every Set in the filterd output has size 1 (if there are any)+singletons = filter ((1 ==) . Set.size)++instance Logic SetW where+  propagate f ctxt (ExplainSpec es s) = explainSpec es $ propagate f ctxt s+  propagate _ _ TrueSpec = TrueSpec+  propagate _ _ (ErrorSpec msgs) = ErrorSpec msgs+  propagate f ctx (SuspendedSpec v ps) = constrained $ \v' -> Let (App f (fromListCtx ctx v')) (v :-> ps)+  propagate SingletonW (Unary HOLE) (TypeSpec (SetSpec must es size) cant)+    | not $ 1 `conformsToSpec` size =+        ErrorSpec (pure "propagateSpecFun Singleton with spec that doesn't accept 1 size set")+    | [a] <- Set.toList must+    , a `conformsToSpec` es+    , Set.singleton a `notElem` cant =+        equalSpec a+    | null must = es <> notMemberSpec (Set.toList $ fold $ singletons cant)+    | otherwise = ErrorSpec (pure "propagateSpecFun Singleton with `must` of size > 1")+  propagate SingletonW (Unary HOLE) (MemberSpec es) =+    case Set.toList $ fold $ singletons (NE.toList es) of+      [] -> ErrorSpec $ pure "In propagateSpecFun Singleton, the sets of size 1, in MemberSpec is empty"+      (x : xs) -> MemberSpec (x :| xs)+  propagate UnionW ctx spec+    | (Value s :! Unary HOLE) <- ctx =+        propagate UnionW (HOLE :? Value s :> Nil) spec+    | (HOLE :? Value (s :: Set a) :> Nil) <- ctx+    , Evidence <- prerequisites @(Set a) =+        case spec of+          _ | null s -> spec+          TypeSpec (SetSpec must es size) cant+            | not $ all (`conformsToSpec` es) s ->+                ErrorSpec $+                  NE.fromList+                    [ "Elements in union argument does not conform to elem spec"+                    , "  spec: " ++ show es+                    , "  elems: " ++ show (filter (not . (`conformsToSpec` es)) (Set.toList s))+                    ]+            | not $ null cant -> ErrorSpec (pure "propagateSpecFun Union TypeSpec, not (null cant)")+            | TrueSpec <- size -> typeSpec $ SetSpec (Set.difference must s) es TrueSpec+            | TypeSpec (NumSpecInterval mlb Nothing) [] <- size+            , maybe True (<= sizeOf s) mlb ->+                typeSpec $ SetSpec (Set.difference must s) es TrueSpec+            | otherwise -> constrained $ \x ->+                exists (\eval -> pure $ Set.intersection (eval x) s) $ \overlap ->+                  exists (\eval -> pure $ Set.difference (eval x) s) $ \disjoint ->+                    [ Assert $ overlap `subset_` Lit s+                    , Assert $ disjoint `disjoint_` Lit s+                    , satisfies (sizeOf_ disjoint + Lit (sizeOf s)) size+                    , Assert $ x ==. (overlap <> disjoint) -- depends on Semigroup (Term (Set a))+                    , forAll disjoint $ \e -> e `satisfies` es+                    , Assert $ Lit (must Set.\\ s) `subset_` disjoint+                    ]+          -- We only do singleton MemberSpec to avoid really bad blowup+          MemberSpec (e :| [])+            | s `Set.isSubsetOf` e ->+                typeSpec+                  ( SetSpec+                      (Set.difference e s)+                      ( memberSpec+                          (Set.toList e)+                          (pure "propagateSpec (union_ s HOLE) on (MemberSpec [e]) where e is the empty set")+                      )+                      mempty+                  )+          -- TODO: improve this error message+          _ ->+            ErrorSpec+              ( NE.fromList+                  [ "propagateSpecFun (union_ s HOLE) with spec"+                  , "s = " ++ show s+                  , "spec = " ++ show spec+                  ]+              )+  propagate SubsetW ctx spec+    | (HOLE :? Value (s :: Set a) :> Nil) <- ctx+    , Evidence <- prerequisites @(Set a) = caseBoolSpec spec $ \case+        True ->+          case NE.nonEmpty (Set.toList s) of+            Nothing -> MemberSpec (pure Set.empty)+            Just slist -> typeSpec $ SetSpec mempty (MemberSpec slist) mempty+        False -> constrained $ \set ->+          exists (\eval -> headGE $ Set.difference (eval set) s) $ \e ->+            [ set `DependsOn` e+            , Assert $ not_ $ member_ e (Lit s)+            , Assert $ member_ e set+            ]+    | (Value (s :: Set a) :! Unary HOLE) <- ctx+    , Evidence <- prerequisites @(Set a) = caseBoolSpec spec $ \case+        True -> typeSpec $ SetSpec s TrueSpec mempty+        False -> constrained $ \set ->+          exists (\eval -> headGE $ Set.difference (eval set) s) $ \e ->+            [ set `DependsOn` e+            , Assert $ member_ e (Lit s)+            , Assert $ not_ $ member_ e set+            ]+  propagate MemberW ctx spec+    | (HOLE :? Value s :> Nil) <- ctx = caseBoolSpec spec $ \case+        True -> memberSpec (Set.toList s) (pure "propagateSpecFun on (Member x s) where s is Set.empty")+        False -> notMemberSpec s+    | (Value e :! Unary HOLE) <- ctx = caseBoolSpec spec $ \case+        True -> typeSpec $ SetSpec (Set.singleton e) mempty mempty+        False -> typeSpec $ SetSpec mempty (notEqualSpec e) mempty+  propagate DisjointW ctx spec+    | (HOLE :? Value (s :: Set a) :> Nil) <- ctx =+        propagate DisjointW (Value s :! Unary HOLE) spec+    | (Value (s :: Set a) :! Unary HOLE) <- ctx+    , Evidence <- prerequisites @(Set a) = caseBoolSpec spec $ \case+        True -> typeSpec $ SetSpec mempty (notMemberSpec s) mempty+        False -> constrained $ \set ->+          exists (\eval -> headGE (Set.intersection (eval set) s)) $ \e ->+            [ set `DependsOn` e+            , Assert $ member_ e (Lit s)+            , Assert $ member_ e set+            ]+  propagate FromListW (Unary HOLE) spec =+    case spec of+      MemberSpec (xs :| []) ->+        typeSpec $+          ListSpec+            Nothing+            (Set.toList xs)+            TrueSpec+            ( memberSpec+                (Set.toList xs)+                (pure "propagateSpec (fromList_ HOLE) on (MemberSpec xs) where the set 'xs' is empty")+            )+            NoFold+      TypeSpec (SetSpec must elemSpec sizeSpec) []+        | TrueSpec <- sizeSpec -> typeSpec $ ListSpec Nothing (Set.toList must) TrueSpec elemSpec NoFold+        | TypeSpec (NumSpecInterval (Just l) Nothing) cantSize <- sizeSpec+        , l <= sizeOf must+        , all (< sizeOf must) cantSize ->+            typeSpec $ ListSpec Nothing (Set.toList must) TrueSpec elemSpec NoFold+      _ ->+        -- Here we simply defer to basically generating the universe that we can+        -- draw from according to `spec` first and then fold that into the spec for the list.+        -- The tricky thing about this is that it may not play super nicely with other constraints+        -- on the list. For this reason it's important to try to find as many possible work-arounds+        -- in the above cases as possible.+        constrained $ \xs ->+          exists (\eval -> pure $ Set.fromList (eval xs)) $ \s ->+            [ s `satisfies` spec+            , xs `DependsOn` s+            , forAll xs $ \e -> e `member_` s+            , forAll s $ \e -> e `elem_` xs+            ]++  mapTypeSpec FromListW ts =+    constrained $ \x ->+      unsafeExists $ \x' -> Assert (x ==. fromList_ x') <> toPreds x' ts+  mapTypeSpec SingletonW ts =+    constrained $ \x ->+      unsafeExists $ \x' ->+        Assert (x ==. singleton_ x') <> toPreds x' ts++  rewriteRules SubsetW (Lit s :> _ :> Nil) Evidence | null s = Just $ Lit True+  rewriteRules SubsetW (x :> Lit s :> Nil) Evidence | null s = Just $ x ==. Lit Set.empty+  rewriteRules UnionW (x :> Lit s :> Nil) Evidence | null s = Just x+  rewriteRules UnionW (Lit s :> x :> Nil) Evidence | null s = Just x+  rewriteRules MemberW (t :> Lit s :> Nil) Evidence+    | null s = Just $ Lit False+    | [a] <- Set.toList s = Just $ t ==. Lit a+  rewriteRules DisjointW (Lit s :> _ :> Nil) Evidence | null s = Just $ Lit True+  rewriteRules DisjointW (_ :> Lit s :> Nil) Evidence | null s = Just $ Lit True+  rewriteRules _ _ _ = Nothing++-- Functions for writing constraints on sets ------------------------------++-- | Create a set with a single element+singleton_ :: (Ord a, HasSpec a) => Term a -> Term (Set a)+singleton_ = appTerm SingletonW++-- | Check if the first argument is a subset of the second+subset_ :: (Ord a, HasSpec a) => Term (Set a) -> Term (Set a) -> Term Bool+subset_ = appTerm SubsetW++-- | Check if an element is a member of the set+member_ :: (Ord a, HasSpec a) => Term a -> Term (Set a) -> Term Bool+member_ = appTerm MemberW++-- | Take the union of two sets+union_ :: (Ord a, HasSpec a) => Term (Set a) -> Term (Set a) -> Term (Set a)+union_ = appTerm UnionW++-- | Check if two sets have no elements in common+disjoint_ :: (Ord a, HasSpec a) => Term (Set a) -> Term (Set a) -> Term Bool+disjoint_ = appTerm DisjointW++-- | Convert a list to a set+fromList_ :: forall a. (Ord a, HasSpec a) => Term [a] -> Term (Set a)+fromList_ = appTerm FromListW
+ src/Constrained/Spec/SumProd.hs view
@@ -0,0 +1,696 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE UndecidableSuperClasses #-}+{-# OPTIONS_GHC -Wno-orphans #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++-- | A lot of the surface-syntax related to generics+module Constrained.Spec.SumProd (+  IsNormalType,+  ProdAsListComputes,+  IsProductType,+  caseOn,+  branch,+  branchW,+  forAll',+  constrained',+  reify',+  con,+  onCon,+  isCon,+  sel,+  match,+  onJust,+  isJust,+  chooseSpec,+  left_,+  right_,+  just_,+  nothing_,+  fst_,+  snd_,+  pair_,+  prodFst_,+  prodSnd_,+  prod_,+) where++import Constrained.AbstractSyntax+import Constrained.Base+import Constrained.Conformance+import Constrained.Core+import Constrained.Generation+import Constrained.Generic+import Constrained.List+import Constrained.Spec.List+import Constrained.Syntax+import Constrained.TheKnot+import Constrained.TypeErrors+import Data.Typeable (Typeable)+import GHC.Generics+import GHC.TypeLits (Symbol)+import GHC.TypeNats+import Test.QuickCheck (Arbitrary (..), oneof)++------------------------------------------------------------------------+-- Syntax for `(,)` and `Either`+------------------------------------------------------------------------++-- | `fst` in `Term` form+fst_ :: (HasSpec x, HasSpec y) => Term (x, y) -> Term x+fst_ = prodFst_ . toGeneric_++-- | `snd` in `Term` form+snd_ :: (HasSpec x, HasSpec y) => Term (x, y) -> Term y+snd_ = prodSnd_ . toGeneric_++-- | `(,)` in `Term` form+pair_ ::+  ( HasSpec a+  , HasSpec b+  , IsNormalType a+  , IsNormalType b+  ) =>+  Term a ->+  Term b ->+  Term (a, b)+pair_ x y = fromGeneric_ $ prod_ x y++-- | `Left` in `Term` form+left_ ::+  ( HasSpec a+  , HasSpec b+  , IsNormalType a+  , IsNormalType b+  ) =>+  Term a ->+  Term (Either a b)+left_ = fromGeneric_ . injLeft_++-- | `Right` in `Term` form+right_ ::+  ( HasSpec a+  , HasSpec b+  , IsNormalType a+  , IsNormalType b+  ) =>+  Term b ->+  Term (Either a b)+right_ = fromGeneric_ . injRight_++-- | @case .. of@ for `Term` and `Pred`. Note that the arguments+-- here are @`Weighted` `Binder`@ over all the `Cases` of the+-- `SimpleRep` of the scrutinee. The `Binder`s can be constructed with+-- `branch` and `branchW`.+caseOn ::+  forall a.+  ( GenericRequires a+  , SimpleRep a ~ SumOver (Cases (SimpleRep a))+  , TypeList (Cases (SimpleRep a))+  ) =>+  Term a ->+  FunTy (MapList (Weighted Binder) (Cases (SimpleRep a))) Pred+caseOn tm = curryList @(Cases (SimpleRep a)) (mkCase (toGeneric_ tm))++-- | Build a branch in a `caseOn`+branch ::+  forall p a.+  ( HasSpec a+  , All HasSpec (Args a)+  , IsPred p+  , IsProd a+  ) =>+  FunTy (MapList Term (Args a)) p ->+  Weighted Binder a+branch body =+  -- NOTE: It's not sufficient to simply apply `body` to all the arguments+  -- with `uncurryList` because that will mean that `var` is repeated in the+  -- body. For example, consider `branch $ \ i j -> i <=. j`. If we don't+  -- build the lets this will boil down to `p :-> fst p <=. snd p` which+  -- will blow up at generation time. If we instead do: `p :-> Let x (fst p) (Let y (snd p) (x <=. y))`+  -- the solver will solve `x` and `y` separately (`y` before `x` in this case) and things+  -- will work just fine.+  Weighted Nothing (bind (buildBranch @p body . toArgs @a))++-- | Build a branch in a `caseOn` with a weight attached.+branchW ::+  forall p a.+  ( HasSpec a+  , All HasSpec (Args a)+  , IsPred p+  , IsProd a+  ) =>+  Int ->+  FunTy (MapList Term (Args a)) p ->+  Weighted Binder a+branchW w body =+  Weighted (Just w) (bind (buildBranch @p body . toArgs @a))++-- ====================================================+-- All the magic for things like 'caseOn', 'match', forAll' etc. lives here.+-- Classes and type families about Sum, Prod, construtors, selectors+-- These let us express the types of things like 'match' and 'caseOn'++class IsProd p where+  toArgs ::+    HasSpec p => Term p -> List Term (Args p)++instance {-# OVERLAPPABLE #-} Args a ~ '[a] => IsProd a where+  toArgs = (:> Nil)++instance IsProd b => IsProd (Prod a b) where+  toArgs (p :: Term (Prod a b))+    | Evidence <- prerequisites @(Prod a b) = prodFst_ p :> toArgs (prodSnd_ p)++type family Args t where+  Args (Prod a b) = a : Args b+  Args a = '[a]++type family ResultType t where+  ResultType (a -> b) = ResultType b+  ResultType a = a++-- | A normal type, not an underlying generic representation using `Sum` and t`Prod`+type IsNormalType a =+  ( AssertComputes+      (Cases a)+      ( Text "Failed to compute Cases in a use of IsNormalType for "+          :$$: ShowType a+          :<>: Text ", are you missing an IsNormalType constraint?"+      )+  , Cases a ~ '[a]+  , AssertComputes+      (Args a)+      ( Text "Failed to compute Args in a use of IsNormalType for "+          :<>: ShowType a+          :<>: Text ", are you missing an IsNormalType constraint?"+      )+  , Args a ~ '[a]+  , IsProd a+  , CountCases a ~ 1+  )++type family Cases t where+  Cases (Sum a b) = a : Cases b+  Cases a = '[a]++-- | A single-constructor type like t`(,)`+type IsProductType a =+  ( HasSimpleRep a+  , AssertComputes+      (Cases (SimpleRep a))+      ( Text "Failed to compute Cases in a use of IsProductType for "+          :$$: ShowType a+          :<>: Text ", are you missing an IsProductType constraint?"+      )+  , Cases (SimpleRep a) ~ '[SimpleRep a]+  , SimpleRep a ~ SumOver (Cases (SimpleRep a))+  , IsProd (SimpleRep a)+  , HasSpec (SimpleRep a)+  , TypeSpec a ~ TypeSpec (SimpleRep a)+  , All HasSpec (Args (SimpleRep a))+  )++type ProductAsList a = Args (SimpleRep a)++class HasSpec (SOP sop) => SOPTerm c sop where+  inj_ :: Term (ProdOver (ConstrOf c sop)) -> Term (SOP sop)++instance HasSpec (ProdOver constr) => SOPTerm c (c ::: constr : '[]) where+  inj_ = id++instance+  ( HasSpec (SOP (con : sop))+  , HasSpec (ProdOver constr)+  , KnownNat (CountCases (SOP (con : sop)))+  ) =>+  SOPTerm c (c ::: constr : con : sop)+  where+  inj_ = injLeft_++instance+  {-# OVERLAPPABLE #-}+  ( HasSpec (ProdOver con)+  , SOPTerm c (con' : sop)+  , ConstrOf c (con' : sop) ~ ConstrOf c ((c' ::: con) : con' : sop)+  , KnownNat (CountCases (SOP (con' : sop)))+  ) =>+  SOPTerm c ((c' ::: con) : con' : sop)+  where+  inj_ = injRight_ . inj_ @c @(con' : sop)++class HasSpec (ProdOver constr) => ConstrTerm constr where+  prodOver_ :: List Term constr -> Term (ProdOver constr)++instance HasSpec a => ConstrTerm '[a] where+  prodOver_ (a :> Nil) = a++type family At n as where+  At 0 (a : as) = a+  At n (a : as) = At (n - 1) as++class Select n as where+  select_ :: Term (ProdOver as) -> Term (At n as)++instance Select 0 (a : '[]) where+  select_ = id++instance (HasSpec a, HasSpec (ProdOver (a' : as))) => Select 0 (a : a' : as) where+  select_ = prodFst_++instance+  {-# OVERLAPPABLE #-}+  ( HasSpec a+  , HasSpec (ProdOver (a' : as))+  , At (n - 1) (a' : as) ~ At n (a : a' : as)+  , Select (n - 1) (a' : as)+  ) =>+  Select n (a : a' : as)+  where+  select_ = select_ @(n - 1) @(a' : as) . prodSnd_++class IsConstrOf (c :: Symbol) b sop where+  mkCases ::+    (HasSpec b, All HasSpec (Cases (SOP sop))) =>+    (forall a. Term a -> Pred) ->+    (Term b -> Pred) ->+    List (Weighted Binder) (Cases (SOP sop))++instance+  ( b ~ ProdOver as+  , TypeList (Cases (SOP (con : sop)))+  ) =>+  IsConstrOf c b ((c ::: as) : con : sop)+  where+  mkCases r (k :: Term b -> Pred) =+    Weighted Nothing (bind k)+      :> mapListC @HasSpec (\_ -> Weighted Nothing (bind r)) (listShape @(Cases (SOP (con : sop))))++instance+  ( b ~ ProdOver as+  , IsNormalType b+  ) =>+  IsConstrOf c b '[c ::: as]+  where+  mkCases _ (k :: Term b -> Pred) = Weighted Nothing (bind k) :> Nil++instance+  {-# OVERLAPPABLE #-}+  ( Cases (SOP ((c' ::: as) : cs)) ~ (ProdOver as : Cases (SOP cs))+  , IsConstrOf c b cs+  ) =>+  IsConstrOf c b ((c' ::: as) : cs)+  where+  mkCases r k = Weighted Nothing (bind (r @(ProdOver as))) :> mkCases @c @_ @cs r k++-- Instances --------------------------------------------------------------++fstW :: (HasSpec a, HasSpec b) => FunW '[(a, b)] a+fstW = ComposeW ProdFstW ToGenericW++sndW :: (HasSpec a, HasSpec b) => FunW '[(a, b)] b+sndW = ComposeW ProdSndW ToGenericW++instance+  (HasSpec a, HasSpec b, Arbitrary (FoldSpec a), Arbitrary (FoldSpec b)) =>+  Arbitrary (FoldSpec (a, b))+  where+  arbitrary =+    oneof+      [ preMapFoldSpec (Fun fstW) <$> arbitrary+      , preMapFoldSpec (Fun sndW) <$> arbitrary+      , pure NoFold+      ]+  shrink NoFold = []+  shrink FoldSpec {} = [NoFold]++buildBranch ::+  forall p as.+  ( All HasSpec as+  , IsPred p+  ) =>+  FunTy (MapList Term as) p ->+  List Term as ->+  Pred+buildBranch bd Nil = toPred bd+buildBranch bd (t :> args) =+  letBind t $ \x -> buildBranch @p (bd x) args++-- | ProdAsListComputes is here to make sure that in situations like this:+--+-- > type family Foobar k+-- >+-- > ex :: HasSpec (Foobar k) => Specification (Int, Foobar k)+-- > ex = constrained $ \ p -> match p $ \ i _ -> (i ==. 10)+--+-- Where you're trying to work with an unevaluated type family in constraints.+-- You get reasonable type errors prompting you to add the @IsNormalType (Foobar k)@ constraint+-- like this:+--+-- >     • Type list computation is stuck on+-- >         Args (Foobar k)+-- >       Have you considered adding an IsNormalType or ProdAsListComputes constraint?+-- >     • In the first argument of ‘($)’, namely ‘match p’+-- >       In the expression: match p $ \ i _ -> (i ==. 10)+-- >       In the second argument of ‘($)’, namely+-- >         ‘\ p -> match p $ \ i _ -> (i ==. 10)’+-- >     |+-- > 503 | ex = constrained $ \ p -> match p $ \ i _ -> (i ==. 10)+-- >     |                           ^^^^^+--+-- Which should help you come to the conclusion that you need to do something+-- like this for everything to compile:+--+-- > ex :: (HasSpec (Foobar k), IsNormalType (Foobar k)) => Specification (Int, Foobar k)+type ProdAsListComputes a =+  AssertSpineComputes+    (Text "Have you considered adding an IsNormalType or ProdAsListComputes constraint?")+    (ProductAsList a)++-- | Pattern-match on a product type and build constraints with the constituents:+match ::+  forall p a.+  ( IsProductType a+  , IsPred p+  , GenericRequires a+  , ProdAsListComputes a+  ) =>+  Term a -> FunTy (MapList Term (ProductAsList a)) p -> Pred+match p m = caseOn p (branch @p m)++-- NOTE: `ResultType r ~ Term a` is NOT a redundant constraint,+-- removing it causes type inference to break elsewhere++-- | Create a constructor @c@:+-- > just_ :: (HasSpec a, IsNormalType a) => Term a -> Term (Maybe a)+-- > just_ = con @"Just"+con ::+  forall c a r.+  ( SimpleRep a ~ SOP (TheSop a)+  , TypeSpec a ~ TypeSpec (SOP (TheSop a))+  , TypeList (ConstrOf c (TheSop a))+  , r ~ FunTy (MapList Term (ConstrOf c (TheSop a))) (Term a)+  , ResultType r ~ Term a+  , SOPTerm c (TheSop a)+  , ConstrTerm (ConstrOf c (TheSop a))+  , GenericRequires a+  ) =>+  r+con =+  curryList @(ConstrOf c (TheSop a)) @Term+    (fromGeneric_ @a . inj_ @c @(TheSop a) . prodOver_)++-- | `Term`-level `Just`+just_ :: (HasSpec a, IsNormalType a) => Term a -> Term (Maybe a)+just_ = con @"Just"++-- | `Term`-level `Nothing`+nothing_ :: (HasSpec a, IsNormalType a) => Term (Maybe a)+nothing_ = con @"Nothing" (Lit ())++-- | Select a specific field from a single-constructor type:+-- > data Record = Record { foo :: Int, bar :: Bool }+-- > foo_ :: Term Record -> Term Int+-- > foo_ = sel @0+-- > bar_ :: Term Record -> Term Bool+-- > bar_ = sel @1+sel ::+  forall n a c as.+  ( SimpleRep a ~ ProdOver as+  , -- TODO: possibly investigate deriving this from the actual SOP of SimpleRep, as currently it's buggy if you define+    -- your own custom SOP-like SimpleRep by defining SimpleRep rather than TheSop (it's stupid I know)+    TheSop a ~ '[c ::: as]+  , TypeSpec a ~ TypeSpec (ProdOver as)+  , Select n as+  , HasSpec a+  , HasSpec (ProdOver as)+  , HasSimpleRep a+  , GenericRequires a+  ) =>+  Term a ->+  Term (At n as)+sel = select_ @n @as . toGeneric_++-- | Like `forAll` but pattern matches on the `Term a`+forAll' ::+  forall t a p.+  ( Forallable t a+  , Cases (SimpleRep a) ~ '[SimpleRep a]+  , TypeSpec a ~ TypeSpec (SimpleRep a)+  , HasSpec t+  , HasSpec (SimpleRep a)+  , HasSimpleRep a+  , All HasSpec (Args (SimpleRep a))+  , IsPred p+  , IsProd (SimpleRep a)+  , IsProductType a+  , HasSpec a+  , GenericRequires a+  , ProdAsListComputes a+  ) =>+  Term t ->+  FunTy (MapList Term (ProductAsList a)) p ->+  Pred+forAll' xs f = forAll xs $ \x -> match @p x f++-- | Like `constrained` but pattern matches on the bound `Term a`+constrained' ::+  forall a p.+  ( Cases (SimpleRep a) ~ '[SimpleRep a]+  , TypeSpec a ~ TypeSpec (SimpleRep a)+  , HasSpec (SimpleRep a)+  , HasSimpleRep a+  , All HasSpec (Args (SimpleRep a))+  , IsProd (SimpleRep a)+  , HasSpec a+  , IsProductType a+  , IsPred p+  , GenericRequires a+  , ProdAsListComputes a+  ) =>+  FunTy (MapList Term (ProductAsList a)) p ->+  Specification a+constrained' f = constrained $ \x -> match @p x f++-- | Like `reify` but pattern matches on the bound `Term b`+reify' ::+  forall a b p.+  ( Cases (SimpleRep b) ~ '[SimpleRep b]+  , TypeSpec b ~ TypeSpec (SimpleRep b)+  , HasSpec (SimpleRep b)+  , HasSimpleRep b+  , All HasSpec (Args (SimpleRep b))+  , IsProd (SimpleRep b)+  , HasSpec a+  , HasSpec b+  , IsProductType b+  , IsProd a+  , IsPred p+  , GenericRequires b+  , ProdAsListComputes b+  ) =>+  Term a ->+  (a -> b) ->+  FunTy (MapList Term (ProductAsList b)) p ->+  Pred+reify' a r f = reify a r $ \x -> match @p x f++instance+  ( HasSpec a+  , HasSpec (ProdOver (a : b : as))+  , ConstrTerm (b : as)+  ) =>+  ConstrTerm (a : b : as)+  where+  prodOver_ (a :> as) = prod_ a (prodOver_ as)++-- TODO: the constraints around this are horrible!! We should figure out a way to make these things nicer.++-- | `caseOn` a _single_ constructor only+onCon ::+  forall c a p.+  ( IsConstrOf c (ProdOver (ConstrOf c (TheSop a))) (TheSop a)+  , GenericRequires a+  , SumOver (Cases (SOP (TheSop a))) ~ SimpleRep a+  , All HasSpec (Cases (SOP (TheSop a)))+  , HasSpec (ProdOver (ConstrOf c (TheSop a)))+  , IsPred p+  , Args (ProdOver (ConstrOf c (TheSop a))) ~ ConstrOf c (TheSop a)+  , All HasSpec (ConstrOf c (TheSop a))+  , IsProd (ProdOver (ConstrOf c (TheSop a)))+  ) =>+  Term a ->+  FunTy (MapList Term (ConstrOf c (TheSop a))) p ->+  Pred+onCon tm p =+  Case+    (toGeneric_ tm)+    ( mkCases @c @(ProdOver (ConstrOf c (TheSop a))) @(TheSop a)+        (const $ Assert (Lit True))+        (buildBranch @p p . toArgs)+    )++-- | Check if a value is an instance of a specific constructor:+-- > isJustConstraint :: HasSpec a => Term (Maybe a) -> Pred+-- > isJustConstraint t = isCon @"Just" t+isCon ::+  forall c a.+  ( IsConstrOf c (ProdOver (ConstrOf c (TheSop a))) (TheSop a)+  , SumOver (Cases (SOP (TheSop a))) ~ SimpleRep a+  , All HasSpec (Cases (SOP (TheSop a)))+  , HasSpec (ProdOver (ConstrOf c (TheSop a)))+  , GenericRequires a+  ) =>+  Term a ->+  Pred+isCon tm =+  Case+    (toGeneric_ tm)+    ( mkCases @c @(ProdOver (ConstrOf c (TheSop a))) @(TheSop a)+        (const $ Assert (Lit False))+        (const $ Assert (Lit True))+    )++-- | `onCon` specialized to `Just`+onJust ::+  forall a p.+  (HasSpec a, IsNormalType a, IsPred p) =>+  Term (Maybe a) ->+  (Term a -> p) ->+  Pred+onJust = onCon @"Just"++-- | `isCon` specialized to `Just`+isJust ::+  forall a.+  (HasSpec a, IsNormalType a) =>+  Term (Maybe a) ->+  Pred+isJust = isCon @"Just"++-- |  ChooseSpec is one of the ways we can 'Or' two Specs together+--    This works for any kind of type that has a HasSpec instance.+--    If your type is a Sum type. One can use CaseOn which is much easier.+chooseSpec ::+  HasSpec a =>+  (Int, Specification a) ->+  (Int, Specification a) ->+  Specification a+chooseSpec (w, s) (w', s') =+  constrained $ \x ->+    exists (\eval -> pure $ if eval x `conformsToSpec` s then PickFirst else PickSecond) $ \p ->+      [ caseOn+          p+          (branch $ \_ -> (x `satisfies` s))+          (branch $ \_ -> (x `satisfies` s'))+      , -- This is a bit ugly :(+        caseOn+          p+          (branchW w $ \_ -> True)+          (branchW w' $ \_ -> True)+      , x `dependsOn` p+      ]++data Picky = PickFirst | PickSecond deriving (Ord, Eq, Show, Generic)++instance HasSimpleRep Picky++instance HasSpec Picky++------------------------------------------------------------------------+-- Some generic instances of HasSpec and HasSimpleRep+------------------------------------------------------------------------++instance (Typeable a, Typeable b) => HasSimpleRep (a, b)++instance (Typeable a, Typeable b, Typeable c) => HasSimpleRep (a, b, c)++instance (Typeable a, Typeable b, Typeable c, Typeable d) => HasSimpleRep (a, b, c, d)++instance (Typeable a, Typeable b, Typeable c, Typeable d, Typeable e) => HasSimpleRep (a, b, c, d, e)++instance+  (Typeable a, Typeable b, Typeable c, Typeable d, Typeable e, Typeable g) =>+  HasSimpleRep (a, b, c, d, e, g)++instance+  (Typeable a, Typeable b, Typeable c, Typeable d, Typeable e, Typeable g, Typeable h) =>+  HasSimpleRep (a, b, c, d, e, g, h)++instance Typeable a => HasSimpleRep (Maybe a)++instance (Typeable a, Typeable b) => HasSimpleRep (Either a b)++instance+  ( HasSpec a+  , HasSpec b+  ) =>+  HasSpec (a, b)++instance+  ( HasSpec a+  , HasSpec b+  , HasSpec c+  ) =>+  HasSpec (a, b, c)++instance+  ( HasSpec a+  , HasSpec b+  , HasSpec c+  , HasSpec d+  ) =>+  HasSpec (a, b, c, d)++instance+  ( HasSpec a+  , HasSpec b+  , HasSpec c+  , HasSpec d+  , HasSpec e+  ) =>+  HasSpec (a, b, c, d, e)++instance+  ( HasSpec a+  , HasSpec b+  , HasSpec c+  , HasSpec d+  , HasSpec e+  , HasSpec g+  ) =>+  HasSpec (a, b, c, d, e, g)++instance+  ( HasSpec a+  , HasSpec b+  , HasSpec c+  , HasSpec d+  , HasSpec e+  , HasSpec g+  , HasSpec h+  ) =>+  HasSpec (a, b, c, d, e, g, h)++instance+  (IsNormalType a, HasSpec a) =>+  HasSpec (Maybe a)++instance+  ( HasSpec a+  , IsNormalType a+  , HasSpec b+  , IsNormalType b+  ) =>+  HasSpec (Either a b)
+ src/Constrained/Spec/Tree.hs view
@@ -0,0 +1,156 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- | `HasSpec` instance for `Tree`+module Constrained.Spec.Tree (+  TreeSpec (..),+  rootLabel_,+  TreeW (..),+) where++import Constrained.AbstractSyntax+import Constrained.Base+import Constrained.Conformance+import Constrained.Core+import Constrained.FunctionSymbol+import Constrained.Generation+import Constrained.List+import Constrained.Spec.List+import Constrained.Spec.SumProd ()+import Constrained.Syntax+import Constrained.TheKnot+import Data.Kind+import Data.Tree+import Test.QuickCheck (shrinkList)++------------------------------------------------------------------------+-- HasSpec for Tree+------------------------------------------------------------------------++-- | t`TypeSpec` for `Tree`+data TreeSpec a = TreeSpec+  { roseTreeAvgLength :: Maybe Integer+  , roseTreeMaxSize :: Maybe Integer+  , roseTreeRootSpec :: Specification a+  , roseTreeCtxSpec :: Specification (a, [Tree a])+  }++deriving instance HasSpec a => Show (TreeSpec a)++instance Forallable (Tree a) (a, [Tree a]) where+  fromForAllSpec = guardRoseSpec . TreeSpec Nothing Nothing TrueSpec+  forAllToList (Node a children) = (a, children) : concatMap forAllToList children++-- TODO: get rid of this when we implement `cardinality`+-- in `HasSpec`+guardRoseSpec :: HasSpec (Tree a) => TreeSpec a -> Specification (Tree a)+guardRoseSpec spec@(TreeSpec _ _ rs s)+  | isErrorLike rs = ErrorSpec (pure "guardRoseSpec: rootSpec is error")+  | isErrorLike s = ErrorSpec (pure "guardRoseSpec: ctxSpec is error")+  | otherwise = TypeSpec spec []++instance HasSpec a => HasSpec (Tree a) where+  type TypeSpec (Tree a) = TreeSpec a++  emptySpec = TreeSpec Nothing Nothing TrueSpec TrueSpec++  combineSpec (TreeSpec mal sz rs s) (TreeSpec mal' sz' rs' s')+    | isErrorLike alteredspec = ErrorSpec (errorLikeMessage alteredspec)+    | otherwise =+        guardRoseSpec $+          TreeSpec+            (unionWithMaybe max mal mal')+            (unionWithMaybe min sz sz')+            rs''+            s''+    where+      alteredspec = (typeSpec (Cartesian rs'' TrueSpec) <> s'')+      rs'' = rs <> rs'+      s'' = s <> s'++  conformsTo (Node a children) (TreeSpec _ _ rs s) =+    and+      [ (a, children) `conformsToSpec` s+      , all (\(Node a' children') -> (a', children') `conformsToSpec` s) children+      , a `conformsToSpec` rs+      ]++  genFromTypeSpec (TreeSpec mal msz rs s) = do+    let sz = maybe 20 id msz+        sz' = maybe (sz `div` 4) (sz `div`) mal+        childrenSpec =+          typeSpec $+            ListSpec+              (Just sz')+              []+              TrueSpec+              (typeSpec $ TreeSpec mal (Just sz') TrueSpec s)+              NoFold+        innerSpec = s <> typeSpec (Cartesian rs childrenSpec)+    fmap (uncurry Node) $+      genFromSpecT @(a, [Tree a]) innerSpec++  shrinkWithTypeSpec (TreeSpec _ _ rs ctxSpec) (Node a ts) =+    [Node a [] | not $ null ts]+      ++ ts+      ++ [Node a' ts | a' <- shrinkWithSpec rs a]+      ++ [Node a [t] | t <- ts]+      ++ [ Node a ts'+         | ts' <- shrinkList (shrinkWithTypeSpec (TreeSpec Nothing Nothing TrueSpec ctxSpec)) ts+         ]++  -- TODO: fixme+  fixupWithTypeSpec _ _ = Nothing++  cardinalTypeSpec _ = mempty++  toPreds t (TreeSpec mal msz rs s) =+    (forAll t $ \n -> n `satisfies` s)+      <> rootLabel_ t+        `satisfies` rs+      <> maybe TruePred (\sz -> genHint (mal, sz) t) msz++instance HasSpec a => HasGenHint (Tree a) where+  type Hint (Tree a) = (Maybe Integer, Integer)+  giveHint (avgLen, sz) = typeSpec $ TreeSpec avgLen (Just sz) TrueSpec TrueSpec++-- | Function symbols for talking about trees+data TreeW (dom :: [Type]) (rng :: Type) where+  RootLabelW :: HasSpec a => TreeW '[Tree a] a++deriving instance Eq (TreeW d r)++deriving instance Show (TreeW d r)++instance Semantics TreeW where+  semantics RootLabelW = \(Node a _) -> a++instance Syntax TreeW++instance Logic TreeW where+  propagate f ctxt (ExplainSpec es s) = explainSpec es $ propagate f ctxt s+  propagate _ _ TrueSpec = TrueSpec+  propagate _ _ (ErrorSpec msgs) = ErrorSpec msgs+  propagate RootLabelW (Unary HOLE) (SuspendedSpec v ps) = constrained $ \v' -> Let (App RootLabelW (v' :> Nil)) (v :-> ps)+  propagate RootLabelW (Unary HOLE) spec = typeSpec $ TreeSpec Nothing Nothing spec TrueSpec++  -- NOTE: this function over-approximates and returns a liberal spec.+  mapTypeSpec RootLabelW (TreeSpec _ _ rs _) = rs++-- | Get the label of the root of the `Tree`+rootLabel_ ::+  forall a.+  HasSpec a =>+  Term (Tree a) ->+  Term a+rootLabel_ = appTerm RootLabelW
+ src/Constrained/SumList.hs view
@@ -0,0 +1,912 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstrainedClassMethods #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableSuperClasses #-}+{-# LANGUAGE ViewPatterns #-}++-- | Operations for generating random elements of Num like types, that sum to a particular total.+--   The class `Foldy` (defined in the TheKnot.hs) gives the operations necessary to do this.+--   In this module we define the helper functions necessary to define the methods of the Foldy class.+--   The helper functions do not need to know about the Foldy class, and are not dependent upon any of+--   the mutually recursive operations defined in TheKnot, except the operations defined in the Complete class.+--   That class is defined in this module, but the instance for that class is made in TheKnot.+module Constrained.SumList (+  genNumList,+  pickAll,+  knownUpperBound,+  knownLowerBound,+  genListWithSize,+  Complete (..),+  maxFromSpec,+  Solution (..),+  logRange,+  logish,+  Cost (..),+  predSpecPair,+  narrowByFuelAndSize,+) where++import Constrained.AbstractSyntax+import Constrained.Base+import Constrained.Conformance (conformsToSpec)+import Constrained.Core (Value (..))+import Constrained.GenT (+  GE (..),+  GenT,+  MonadGenError (..),+  oneofT,+  pureGen,+  push,+  scaleT,+  sizeT,+  suchThatT,+  tryGenT,+ )+import Constrained.List (List (..), ListCtx (..))+import Constrained.NumOrd (+  IntW (..),+  MaybeBounded (..),+  NumSpec (..),+  Numeric,+  geqSpec,+  gtSpec,+  leqSpec,+  ltSpec,+  nubOrd,+ )+import Constrained.PrettyUtils+import Control.Applicative ((<|>))+import Control.Monad (guard)+import Data.List ((\\))+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE+import Data.Maybe (fromMaybe, isNothing, listToMaybe)+import qualified Data.Set as Set+import GHC.Stack+import Prettyprinter hiding (cat)+import System.Random (Random (..))+import Test.QuickCheck (Arbitrary, Gen, choose, shuffle, vectorOf)++-- ====================================================================+-- What we need to know, that can only be defined in TheKnot module, is+-- abstracted into this class, which will be a precondition on the `Foldy` class++-- | Dependency-trick+class HasSpec a => Complete a where+  -- method standing for `simplifySpec`+  simplifyA :: Specification a -> Specification a++  -- method standing for `genFromSpecT`+  genFromSpecA :: forall m. (HasCallStack, HasSpec a, MonadGenError m) => Specification a -> GenT m a++  -- method standing for method `theAddFn` from the `Foldy` class+  theAddA :: Numeric a => IntW '[a, a] a+  theAddA = AddW++-- ==========================================================+-- helpers++-- ===================================================================++-- | Try to find an upper-bound for the values admitted by a `Specification`+knownUpperBound ::+  (TypeSpec a ~ NumSpec a, Ord a, Enum a, Num a, MaybeBounded a) =>+  Specification a ->+  Maybe a+knownUpperBound (ExplainSpec _ s) = knownUpperBound s+knownUpperBound TrueSpec = upperBound+knownUpperBound (MemberSpec as) = Just $ maximum as+knownUpperBound ErrorSpec {} = Nothing+knownUpperBound SuspendedSpec {} = upperBound+knownUpperBound (TypeSpec (NumSpecInterval lo hi) cant) = upper (lo <|> lowerBound) (hi <|> upperBound)+  where+    upper _ Nothing = Nothing+    upper Nothing (Just b) = listToMaybe $ [b, b - 1 ..] \\ cant+    upper (Just a) (Just b)+      | a == b = a <$ guard (a `notElem` cant)+      | otherwise = listToMaybe $ [b, b - 1 .. a] \\ cant++-- | Try to find a lower-bound for the values admitted by a `Specification`+knownLowerBound ::+  (TypeSpec a ~ NumSpec a, Ord a, Enum a, Num a, MaybeBounded a) =>+  Specification a ->+  Maybe a+knownLowerBound (ExplainSpec _ s) = knownLowerBound s+knownLowerBound TrueSpec = lowerBound+knownLowerBound (MemberSpec as) = Just $ minimum as+knownLowerBound ErrorSpec {} = Nothing+knownLowerBound SuspendedSpec {} = lowerBound+knownLowerBound (TypeSpec (NumSpecInterval lo hi) cant) =+  lower (lo <|> lowerBound) (hi <|> upperBound)+  where+    lower Nothing _ = Nothing+    lower (Just a) Nothing = listToMaybe $ [a, a + 1 ..] \\ cant+    lower (Just a) (Just b)+      | a == b = a <$ guard (a `notElem` cant)+      | otherwise = listToMaybe $ [a, a + 1 .. b] \\ cant++isEmptyNumSpec ::+  (TypeSpec a ~ NumSpec a, Ord a, Enum a, Num a, MaybeBounded a) => Specification a -> Bool+isEmptyNumSpec = \case+  ExplainSpec _ s -> isEmptyNumSpec s+  ErrorSpec {} -> True+  TrueSpec -> False+  MemberSpec _ -> False -- MemberSpec always has at least one element (NE.NonEmpty)+  SuspendedSpec {} -> False+  TypeSpec i cant -> null $ enumerateInterval i \\ cant++-- | Note: potentially infinite list+enumerateInterval :: (Enum a, Num a, MaybeBounded a) => NumSpec a -> [a]+enumerateInterval (NumSpecInterval lo hi) =+  case (lo <|> lowerBound, hi <|> upperBound) of+    (Nothing, Nothing) -> interleave [0 ..] [-1, -2 ..]+    (Nothing, Just b) -> [b, b - 1 ..]+    (Just a, Nothing) -> [a ..]+    (Just a, Just b) -> [a .. b]+  where+    interleave [] ys = ys+    interleave (x : xs) ys = x : interleave ys xs++-- ========================================================================+-- Operations to complete the Foldy instances genNumList, genListWithSize++-- | Generate a list of values subject to a constraint on both the elements and+-- the result+genNumList ::+  forall a m.+  ( MonadGenError m+  , Arbitrary a+  , Integral a+  , Numeric a+  , Random a+  , Complete a+  ) =>+  Specification a ->+  Specification a ->+  GenT m [a]+genNumList elemSIn foldSIn = do+  let extraElemConstraints+        | Just l <- knownLowerBound elemSIn+        , 0 <= l+        , Just u <- knownUpperBound foldSIn =+            leqSpec u+        | otherwise = TrueSpec+      elemSIn' = elemSIn <> extraElemConstraints+  normElemS <- normalize elemSIn'+  normFoldS <- normalize foldSIn+  let narrowedSpecs = narrowFoldSpecs (normElemS, normFoldS)+  explainNE+    ( NE.fromList+        [ "Can't generate list of ints with fold constraint"+        , "  elemSpec = " ++ show elemSIn+        , "  normElemSpec = " ++ show normElemS+        , "  foldSpec = " ++ show foldSIn+        ]+    )+    $ gen narrowedSpecs 50 [] >>= pureGen . shuffle+  where+    normalize (ExplainSpec es x) = explainSpec es <$> normalize x+    normalize spec@SuspendedSpec {} = do+      sz <- sizeT+      spec' <- buildMemberSpec sz (100 :: Int) mempty spec+      normalize $ spec'+    normalize spec =+      pure $+        maybe mempty geqSpec lowerBound+          <> maybe mempty leqSpec upperBound+          <> spec++    buildMemberSpec _ 0 es _ =+      pure+        ( memberSpec+            (Set.toList es)+            (pure "In genNumList, in buildMemberSpec 'es' is the empty list, can't make a MemberSpec from that")+        )+    buildMemberSpec sz fuel es spec = do+      me <- scaleT (const sz) $ tryGenT (genFromSpecA @a spec)+      let sz'+            | sz > 100 = sz+            | isNothing me = 2 * sz + 1+            | Just e <- me, Set.member e es = 2 * sz + 1+            | otherwise = sz+      buildMemberSpec+        sz'+        (fuel - 1)+        (maybe es (flip Set.insert es) me)+        spec++    gen ::+      forall m'. MonadGenError m' => (Specification a, Specification a) -> Int -> [a] -> GenT m' [a]+    gen (elemS, foldS) fuel lst+      | fuel <= 0+      , not $ 0 `conformsToSpec` foldS =+          genErrorNE $+            NE.fromList+              [ "Ran out of fuel in genNumList"+              , "  elemSpec =" ++ show elemSIn+              , "  foldSpec = " ++ show foldSIn+              , "  lst = " ++ show (reverse lst)+              ]+      | ErrorSpec err <- foldS = genErrorNE err+      | ErrorSpec {} <- elemS = pure lst -- At this point we know that foldS admits 0 (also this should be redundant)+      | 0 `conformsToSpec` foldS = oneofT [pure lst, nonemptyList @GE] -- TODO: distribution+      | otherwise = nonemptyList+      where+        isUnsat (elemSpec, foldSpec) = isEmptyNumSpec foldSpec || not (0 `conformsToSpec` foldSpec) && isEmptyNumSpec elemSpec+        nonemptyList :: forall m''. MonadGenError m'' => GenT m'' [a]+        nonemptyList = do+          (x, specs') <-+            explainNE+              ( NE.fromList+                  [ "Generating an element:"+                  , "  elemS = " ++ show elemS+                  , "  foldS = " ++ show foldS+                  , "  fuel  = " ++ show fuel+                  , "  lst   = " ++ show (reverse lst)+                  ]+              )+              $ do+                sz <- sizeT+                x <- genFromSpecA @a elemS+                let foldS' = propagate theAddA (HOLE :? Value x :> Nil) foldS+                    specs' = narrowByFuelAndSize (fromIntegral $ fuel - 1) sz (elemS, foldS')+                pure (x, specs')+                `suchThatT` not+                . isUnsat+                . snd+          gen specs' (fuel - 1) (x : lst)++narrowFoldSpecs ::+  forall a.+  ( TypeSpec a ~ NumSpec a+  , Arbitrary a+  , Integral a+  , Random a+  , MaybeBounded a+  , Complete a+  ) =>+  (Specification a, Specification a) ->+  (Specification a, Specification a)+narrowFoldSpecs specs = maybe specs narrowFoldSpecs (go specs)+  where+    -- Note: make sure there is some progress when returning Just or this will loop forever+    go :: (Specification a, Specification a) -> Maybe (Specification a, Specification a)+    go (simplifyA -> elemS, simplifyA -> foldS) = case (elemS, foldS) of+      -- Empty foldSpec+      (_, ErrorSpec {}) -> Nothing+      _ | isEmptyNumSpec foldS -> Just (elemS, ErrorSpec (NE.fromList ["Empty foldSpec:", show foldS]))+      -- Empty elemSpec+      (ErrorSpec {}, MemberSpec ys) | NE.toList ys == [0] -> Nothing+      (ErrorSpec {}, _)+        | 0 `conformsToSpec` foldS -> Just (elemS, MemberSpec (pure 0))+        | otherwise ->+            Just+              ( elemS+              , ErrorSpec $+                  NE.fromList+                    [ "Empty elemSpec and non-zero foldSpec"+                    , show $ indent 2 $ "elemSpec =" /> pretty elemS+                    , show $ indent 2 $ "foldSpec =" /> pretty foldS+                    ]+              )+      -- We can reduce the size of the `elemS` interval when it is+      -- `[l, u]` or `[l, ∞)` given that `0 <= l` and we have+      -- an upper bound on the sum - we can't pick things bigger than the+      -- upper bound.+      _+        | Just lo <- knownLowerBound elemS+        , 0 <= lo+        , Just hi <- knownUpperBound foldS+        , -- Check that we will actually be making the set smaller+          fromMaybe True ((hi <) <$> knownUpperBound elemS) ->+            Just (elemS <> typeSpec (NumSpecInterval (Just lo) (Just hi)), foldS)+      -- We can reduce the size of the foldS set by bumping the lower bound when+      -- there is a positive lower bound on the elemS, we can't generate things smaller+      -- than the lower bound on `elemS`.+      _+        | Just lo <- knownLowerBound elemS+        , 0 <= lo+        , not $ 0 `conformsToSpec` foldS+        , -- Check that we will actually be making the set smaller+          fromMaybe True ((lo >) <$> knownLowerBound foldS) ->+            Just (elemS, foldS <> typeSpec (NumSpecInterval (Just lo) Nothing))+      -- NOTE: this is far from sufficient, but it's good enough of an approximation+      -- to avoid the worst failures.+      _+        | Just lo <- knownLowerBound elemS+        , Just loS <- knownLowerBound foldS+        , Just hi <- knownUpperBound elemS+        , Just hiS <- knownUpperBound foldS+        , hi < loS+        , lo > hiS - lo ->+            Just+              ( ErrorSpec $ NE.fromList ["Can't solve diophantine equation"]+              , ErrorSpec $ NE.fromList ["Can't solve diophantine equation"]+              )+      _ -> Nothing++-- | Try to narrow down a specification for the elems and fold of a list+narrowByFuelAndSize ::+  forall a.+  ( TypeSpec a ~ NumSpec a+  , Arbitrary a+  , Integral a+  , Random a+  , MaybeBounded a+  , Complete a+  ) =>+  -- | Fuel+  a ->+  -- | Integer+  Int ->+  (Specification a, Specification a) ->+  (Specification a, Specification a)+narrowByFuelAndSize fuel size specpair =+  loop (100 :: Int) (onlyOnceTransformations $ (narrowFoldSpecs specpair))+  where+    loop 0 specs =+      error $+        unlines+          [ "narrowByFuelAndSize loops:"+          , "  fuel = " ++ show fuel+          , "  size = " ++ show size+          , "  specs = " ++ show specs+          , "  narrowFoldSpecs spec = " ++ show (narrowFoldSpecs specs)+          , "  go (narrowFoldSpecs specs) = " ++ show (go (narrowFoldSpecs specs))+          ]+    loop n specs = case go specs of+      Nothing -> specs+      Just specs' -> loop (n - 1) (narrowFoldSpecs specs')++    -- Transformations only applied once. It's annoying to check if you're+    -- going to change the spec with these so easier to just make sure you only apply+    -- these once+    onlyOnceTransformations (elemS, foldS)+      | fuel == 1 = (elemS <> foldS, foldS)+      | otherwise = (elemS, foldS)++    canReach _ 0 s = s == 0+    canReach e currentfuel s+      -- You can reach it in one step+      | s <= e = 0 < currentfuel+      | otherwise = canReach e (currentfuel - 1) (s - e)++    -- Precondition:+    --   a is negative+    --   the type has more negative numbers than positive ones+    safeNegate a+      | Just u <- upperBound+      , a < negate u =+          u+      | otherwise = negate a++    divCeil a b+      | b * d < a = d + 1+      | otherwise = d+      where+        d = a `div` b++    go :: (Specification a, Specification a) -> Maybe (Specification a, Specification a)+    go (simplifyA -> elemS, simplifyA -> foldS)+      -- There is nothing we can do+      | fuel == 0 = Nothing+      | ErrorSpec {} <- elemS = Nothing+      | ErrorSpec {} <- foldS = Nothing+      -- Give up as early as possible+      | Just 0 <- knownUpperBound elemS+      , Just 0 <- knownLowerBound elemS+      , not $ 0 `conformsToSpec` foldS =+          Just (ErrorSpec (NE.fromList ["only 0 left"]), foldS)+      -- Make sure we try to generate the smallest possible list+      -- that gives you the right result - don't put a bunch of zeroes in+      -- a _small_ (size 0) list.+      | size == 0+      , 0 `conformsToSpec` elemS =+          Just (elemS <> notEqualSpec 0, foldS)+      -- Member specs with non-zero elements, TODO: explain+      | MemberSpec ys <- elemS+      , let xs = NE.toList ys+      , Just u <- knownUpperBound foldS+      , all (0 <=) xs+      , any (0 <) xs+      , let xMinP = minimum $ filter (0 <) xs+            possible x = x == u || xMinP <= u - x+            xs' = filter possible xs+      , xs' /= xs =+          Just (memberSpec (nubOrd xs') (pure ("None of " ++ show xs ++ " are possible")), foldS)+      -- The lower bound on the number of elements is too low+      | Just e <- knownLowerBound elemS+      , e > 0+      , Just s <- knownLowerBound foldS+      , s > 0+      , let c = divCeil s fuel+      , e < c =+          Just (elemS <> geqSpec c, foldS)+      -- The upper bound on the number of elements is too high+      | Just e <- knownUpperBound elemS+      , e < 0+      , Just s <- knownUpperBound foldS+      , s < 0+      , let c = divCeil (safeNegate s) fuel+      , negate c < e+      , maybe True (c <) (knownUpperBound elemS) =+          Just (elemS <> leqSpec c, foldS)+      -- It's time to stop generating negative numbers+      | Just s <- knownLowerBound foldS+      , s > 0+      , Just e <- knownUpperBound elemS+      , e > 0+      , not $ canReach e (fuel `div` 2 + 1) s+      , maybe True (<= 0) (knownLowerBound elemS) =+          Just (elemS <> gtSpec 0, foldS)+      -- It's time to stop generating positive numbers+      | Just s <- knownUpperBound foldS+      , s < 0+      , Just e <- knownLowerBound elemS+      , e < 0+      , not $ canReach (safeNegate e) (fuel `div` 2 + 1) (safeNegate s)+      , maybe True (0 <=) (knownUpperBound elemS) =+          Just (elemS <> ltSpec 0, foldS)+      -- There is nothing we need to do+      | otherwise = Nothing++-- =====================================================================================+-- Like genList, but generate a list whose size conforms to s SizeSpec+-- =====================================================================================++-- | Generate a list with 'sizeSpec' elements, that add up to a total that conforms+--   to 'foldSpec'. Every element in the list should conform to 'elemSpec'+genListWithSize ::+  forall a m.+  ( Complete a+  , MonadGenError m+  , Random a+  , Integral a+  , Arbitrary a+  , Numeric a+  , Complete Integer+  ) =>+  Specification Integer ->+  Specification a ->+  Specification a ->+  GenT m [a]+genListWithSize sizeSpec elemSpec foldSpec+  | TrueSpec <- sizeSpec = genNumList elemSpec foldSpec+  | ErrorSpec _ <- sizeSpec <> geqSpec 0 =+      fatalErrorNE+        ( NE.fromList+            [ "genListWithSize called with possible negative size"+            , "  sizeSpec = " ++ specName sizeSpec+            , "  elemSpec = " ++ specName elemSpec+            , "  foldSpec = " ++ specName foldSpec+            ]+        )+  | otherwise = do+      total <- genFromSpecA @a foldSpec+      -- The compatible sizes for the list, for a given choice of total+      let sizeAdjusted =+            if total /= 0+              then sizeSpec <> gtSpec 0 -- if total is not zero, we better not pick a 0 size+              else+                if lowerBound @a == Just 0 -- Type `a` has no negative numbers (Natural, Word8, Word16, Word 32, Word64)+                  then sizeSpec <> equalSpec 0 -- if it is zero, and negative numbers not allowed, then only possible size is 0+                  else sizeSpec <> gtSpec 0+          message =+            [ "\nGenSizedList fails"+            , "sizespec = " ++ specName sizeSpec+            , "elemSpec = " ++ specName elemSpec+            , "foldSpec = " ++ specName foldSpec+            , "total choosen from foldSpec = " ++ show total+            , "size adjusted for total = " ++ show sizeAdjusted+            ]+      push message $ do+        count <- genFromSpecA @Integer sizeAdjusted+        case compare total 0 of+          EQ ->+            if count == 0+              then pure []+              else pickPositive elemSpec total count+          GT -> pickPositive elemSpec total count+          LT -> pickNegative elemSpec total count++pickPositive ::+  forall t m.+  (Integral t, Random t, MonadGenError m, TypeSpec t ~ NumSpec t, Complete t) =>+  Specification t ->+  t ->+  Integer ->+  GenT m [t]+pickPositive elemspec total count = do+  sol <-+    pureGen $+      pickAll+        (minFromSpec 0 elemspec) -- Search from [0..total] unless elemspec says otherwise+        (maxFromSpec total elemspec)+        (predSpecPair elemspec)+        total+        (fromInteger count)+        (Cost 0)+  case snd sol of+    No msgs -> fatalErrorNE (NE.fromList msgs)+    Yes (x :| _) -> pure x++pickNegative ::+  forall t m.+  (Integral t, Complete t, Random t, MonadGenError m, TypeSpec t ~ NumSpec t) =>+  Specification t ->+  t ->+  Integer ->+  GenT m [t]++-- | total can be either negative, or 0. If it is 0, we want `count` numbers that add to `zero`+pickNegative elemspec total count = do+  sol <-+    pureGen $+      pickAll+        -- Recall 'total' is negative here.+        -- Here is a graphic of the range we search in (smallest .. largest)+        -- [(total+n) .. total .. 0 .. (0-n)],  where n = (total `div` 4) which is negative.+        (minFromSpec (total + (total `div` 4)) elemspec)+        (maxFromSpec (0 - (total `div` 4)) elemspec)+        (predSpecPair elemspec)+        total+        (fromInteger count)+        (Cost 0)+  case snd sol of+    No msgs -> fatalErrorNE (NE.fromList msgs)+    Yes (x :| _) -> pure x++specName :: forall a. HasSpec a => Specification a -> String+specName (ExplainSpec [x] _) = x+specName x = show x++-- | Name (?!) and semantics of a spec+predSpecPair :: forall a. HasSpec a => Specification a -> (String, a -> Bool)+predSpecPair spec = (specName spec, (`conformsToSpec` spec))++-- | The smallest number admitted by the spec, if we can find one.+--   if not return the defaultValue 'dv'+minFromSpec ::+  forall n.+  (Ord n, Complete n, TypeSpec n ~ NumSpec n) =>+  n ->+  Specification n ->+  n+minFromSpec dv (ExplainSpec _ spec) = minFromSpec @n dv spec+minFromSpec dv TrueSpec = dv+minFromSpec dv s@(SuspendedSpec _ _) =+  case simplifyA s of+    SuspendedSpec {} -> dv+    x -> minFromSpec @n dv x+minFromSpec dv (ErrorSpec _) = dv+minFromSpec _ (MemberSpec xs) = minimum xs+minFromSpec dv (TypeSpec (NumSpecInterval lo _) _) = maybe dv id lo++-- | The largest number admitted by the spec, if we can find one.+--   if not return the defaultValue 'dv'+maxFromSpec ::+  forall n.+  (Ord n, Complete n, TypeSpec n ~ NumSpec n) =>+  n ->+  Specification n ->+  n+maxFromSpec dv (ExplainSpec _ spec) = maxFromSpec @n dv spec+maxFromSpec dv TrueSpec = dv+maxFromSpec dv s@(SuspendedSpec _ _) =+  case simplifyA s of+    SuspendedSpec {} -> dv+    x -> maxFromSpec @n dv x+maxFromSpec dv (ErrorSpec _) = dv+maxFromSpec _ (MemberSpec xs) = maximum xs+maxFromSpec dv (TypeSpec (NumSpecInterval _ hi) _) = maybe dv id hi++-- =======================================================+-- Helper functions for genSizedList++-- | Either a list of possible answers of an explanation of why there is no+-- solution+data Solution t = Yes (NonEmpty [t]) | No [String]+  deriving (Eq)++instance Show t => Show (Solution t) where+  show (No xs) = "No" ++ "\n" ++ unlines xs+  show (Yes xs) = "Yes " ++ show xs++-- | Special case Int for keeping track of "fuel" to find solutions+newtype Cost = Cost Int deriving (Eq, Show, Num, Ord)++firstYesG ::+  Monad m => Solution t -> (x -> Cost -> m (Cost, Solution t)) -> [x] -> Cost -> m (Cost, Solution t)+firstYesG nullSolution f xs c = go xs c+  where+    go [] cost = pure (cost, nullSolution)+    go [x] cost = f x (cost + 1)+    go (x : more) cost = do+      ans <- f x (cost + 1)+      case ans of+        (cost1, No _) -> go more cost1+        (_, Yes _) -> pure ans++noChoices :: Show t => Cost -> String -> t -> t -> t -> Int -> [(t, t)] -> Solution t+noChoices cost p smallest largest total count samp =+  No+    [ "\nNo legal choice can be found, where for each sample (x,y)"+    , "x+y = total && predicate x && predicate y"+    , "  predicate = " ++ p+    , "  smallest = " ++ show smallest+    , "  largest = " ++ show largest+    , "  total = " ++ show total+    , "  count = " ++ show count+    , "  cost = " ++ show cost+    , "Small sample of what was explored"+    , show samp+    ]++-- =====================================================++-- | Given 'count', return a list of pairs, that add to 'count'+--   splitsOf 6 --> [(1,5),(2,4),(3,3)].+--   Note we don't return reflections like (5,1) and (4,2),+--   as they have the same information as (1,5) and (2,4).+splitsOf :: Integral b => b -> [(b, b)]+splitsOf count = [(i, j) | i <- [1 .. div count 2], let j = count - i]+{-# SPECIALIZE splitsOf :: Int -> [(Int, Int)] #-}++-- | Given a Path, find a representative solution, 'ans', for that path, such that+--   1) (length ans) == 'count',+--   2) (sum ans) == 'total'+--   3) (all p ans) is True+--   What is a path?+--   Suppose i==5, then we recursively explore every way to split 5 into+--   split pairs that add to 5. I.e. (1,4) (2,3), then we split each of those.+--   Here is a picture of the graph of all paths for i==5. A path goes from the root '5'+--   to one of the leaves. Note all leaves are count == '1 (where the solution is '[total]').+--   To solve for 5, we could solve either of the sub problems rooted at 5: [1,4] or [2,3].+--   5+--   |+--   [1,4]+--   |  |+--   |  [1,3]+--   |  |  |+--   |  |  [1,2]+--   |  |     |+--   |  |     [1,1]+--   |  |+--   |  [2,2]+--   |   | |+--   |   | [1,1]+--   |   |+--   |   [1,1]+--   |+--   [2,3]+--    | |+--    | [1,2]+--    |    |+--    |    [1,1]+--    [1,1]+--  In 'pickAll' will explore a path for every split of 'count'+--  so if it returns (No _), we can be somewhat confidant that no solution exists.+--  Note that count of 1 and 2, are base cases.+--  When 'count' is greater than 1, we need to sample from [smallest..total],+--  so 'smallest' better be less that or equal to 'total'+pickAll ::+  forall t.+  (Show t, Integral t, Random t) =>+  t ->+  t ->+  (String, t -> Bool) ->+  t ->+  Int ->+  Cost ->+  Gen (Cost, Solution t)+pickAll smallest largest (pName, _) total count cost+  | cost > 1000 =+      pure $+        ( cost+        , No+            [ "\nPickAll exceeds cost limit " ++ show cost+            , "  predicate = " ++ pName+            , "  smallest = " ++ show smallest+            , "  largest = " ++ show largest+            , "  total = " ++ show total+            , "  count = " ++ show count+            ]+        )+pickAll smallest largest (pName, p) total 0 cost =+  if total == 0 && p total+    then pure (cost, Yes $ pure [])+    else+      pure+        ( cost+        , No+            [ "We are trying to find list of length 0."+            , "  Whose sum is " ++ show total ++ "."+            , "  That is only possible if the sum == 0."+            , "  All elements have to satisfy " ++ pName+            , "  smallest = " ++ show smallest+            , "  largest = " ++ show largest+            ]+        )+pickAll smallest largest (pName, p) total 1 cost =+  if p total+    then pure (cost, Yes $ pure [total])+    else pure (cost, noChoices cost pName smallest largest total 1 [(total, 0)])+pickAll smallest largest (pName, _) total count cost+  | smallest > largest =+      pure $+        ( cost+        , No+            [ "\nThe feasible range to pickAll ["+                ++ show smallest+                ++ " .. "+                ++ show (div total 2)+                ++ "] was empty"+            , "  predicate = " ++ pName+            , "  smallest = " ++ show smallest+            , "  largest = " ++ show largest+            , "  total = " ++ show total+            , "  count = " ++ show count+            , "  cost = " ++ show cost+            ]+        )+pickAll smallest largest (pName, p) total 2 cost = do+  -- for large things, use a fair sample.+  choices <- smallSample smallest largest total 1000 100+  case filter (\(x, y) -> p x && p y) choices of+    [] -> pure $ (cost + 1, noChoices cost pName smallest largest total 2 (take 10 choices))+    zs -> pure $ (cost + 1, Yes $ NE.fromList (fmap (\(x, y) -> [x, y]) zs))+pickAll smallest largest (pName, p) total count cost = do+  -- Compute a representative sample of the choices between smallest and total.+  -- E.g. when smallest = -2, and total = 5, the complete set of values is:+  -- [(-2,7),(-1,6),(0,5),(1,4),(2,3),(3,2),(4,1),(5,0)]  Note they all add to 5+  -- We could explore the whole set of values, but that can be millions of choices.+  -- so we choose to explore a representative subset. See the function 'fairSample', for details.+  -- Remember this is just 1 step on one path. So if this step fails, there are many more+  -- paths to explore. In fact there are usually many many solutions. We need to find just 1.+  choices <- smallSample smallest largest total 1000 20+  -- The choice of splits is crucial. If total >> count, we want the larger splits first+  -- if count >> total , we want smaller splits first+  splits <-+    if count >= 20+      then shuffle $ take 10 (splitsOf count)+      else+        if total > fromIntegral count+          then pure (reverse (splitsOf count))+          else pure (splitsOf count)++  firstYesG+    (No ["\nNo split has a solution", "cost = " ++ show cost])+    (doSplit smallest largest (pName, p) total choices)+    splits+    cost++-- TODO run some tests to see if this is a better solution than firstYesG+-- concatSolution smallest pName total count+--  <$> mapM  (doSplit smallest largest total (pName, p) choices (pickAll (depth +1) smallest)) splits++-- {-# SPECIALIZE pickAll::Int -> (String, Int -> Bool) -> Int -> Int -> Cost -> Gen (Cost, Solution Int) #-}++doSplit ::+  (Random t, Show t, Integral t) =>+  t ->+  t ->+  (String, t -> Bool) ->+  t ->+  [(t, t)] ->+  -- (t -> (String, t -> Bool) -> t -> Int -> Cost -> Gen (Cost, Solution t)) ->+  (Int, Int) ->+  Cost ->+  Gen (Cost, Solution t)+doSplit smallest largest (pName, p) total sample (i, j) c = go sample c+  where+    -- The 'sample' is a list of pairs (x,y), where we know (x+y) == total.+    -- We will search for the first good solution in the given sample+    -- to build a representative value for this path, with split (i,j).+    go ((x, y) : more) cost0 = do+      -- Note (i+j) = current length of the ans we are looking for+      --      (x+y) = total+      -- pick 'ans1' such that (sum ans1 == x) and (length ans1 == i)+      (cost1, ans1) <- pickAll smallest largest (pName, p) x i cost0+      -- pick 'ans2' such that (sum ans2 == y) and (length ans2 == j)+      (cost2, ans2) <- pickAll smallest largest (pName, p) y j cost1+      case (ans1, ans2) of+        (Yes ys, Yes zs) -> pure $ (cost2, Yes (NE.fromList [a <> b | a <- NE.toList ys, b <- NE.toList zs]))+        _ -> go more cost2+    go [] cost =+      case sample of+        [] ->+          pure $+            ( cost+            , No+                [ "\nThe sample passed to doSplit [" ++ show smallest ++ " .. " ++ show (div total 2) ++ "] was empty"+                , "  predicate = " ++ pName+                , "  smallest = " ++ show smallest+                , "  largest = " ++ show largest+                , "  total " ++ show total+                , "  count = " ++ show (i + j)+                , "  split of count = " ++ show (i, j)+                ]+            )+        ((left, right) : _) ->+          pure $+            ( cost+            , No+                [ "\nAll choices in (genSizedList " ++ show (i + j) ++ " 'p' " ++ show total ++ ") have failed."+                , "Here is 1 example failure."+                , "  smallest = " ++ show smallest+                , "  largest = " ++ show largest+                , "  total " ++ show total ++ " = " ++ show left ++ " + " ++ show right+                , "  count = " ++ show (i + j) ++ ", split of count = " ++ show (i, j)+                , "We are trying to solve sub-problems like:"+                , "  split " ++ show left ++ " into " ++ show i ++ " parts, where all parts meet 'p'"+                , "  split " ++ show right ++ " into " ++ show j ++ " parts, where all parts meet 'p'"+                , "Predicate 'p' = " ++ pName+                , "A small prefix of the sample, elements (x,y) where x+y = " ++ show total+                , unlines (map (("  " ++) . show) (take 10 sample))+                ]+            )+{-# INLINE doSplit #-}++-- | If the sample is small enough, then enumerate all of it, otherwise take a fair sample.+smallSample :: (Random t, Integral t) => t -> t -> t -> t -> Int -> Gen [(t, t)]+smallSample smallest largest total bound size+  | largest - smallest <= bound = do+      shuffle $ takeWhile (uncurry (<=)) [(x, total - x) | x <- [smallest .. total]]+  | otherwise = do+      choices <- fair smallest largest size 5 True+      shuffle [(x, total - x) | x <- choices]+{-# INLINE smallSample #-}++-- | Generates a fair sample of numbers between 'smallest' and 'largest'.+--   makes sure there are numbers of all sizes. Controls both the size of the sample+--   and the precision (how many powers of 10 are covered)+--   Here is how we generate one sample when we call (fair (-3455) (10234) 12 3 True)+--   raw = [(-9999,-1000),(-999,-100),(-99,-10),(-9,-1),(0,9),(10,99),(100,999),(1000,9999),(10000,99999)]+--   ranges = [(-3455,-1000),(-999,-100),(-99,-10),(-9,-1),(0,9),(10,99),(100,999),(1000,9999),(10000,10234)]+--   count = 4+--   largePrecision = [(10000,10234),(1000,9999),(100,999)]+--   smallPrecision = [(-3455,-1000),(-999,-100),(-99,-10)]+--   answer generated = [10128,10104,10027,10048,4911,7821,5585,2157,448,630,802,889]+--   isLarge==True   means be biased towards the large end of the range,+--   isLArge==False  means be biased towards the small end of the range,+fair :: (Random a, Integral a) => a -> a -> Int -> Int -> Bool -> Gen [a]+fair smallest largest size precision isLarge =+  concat <$> mapM oneRange (if isLarge then largePrecision else smallPrecision)+  where+    raw = map logRange [logish smallest .. logish largest]+    fixEnds (x, y) = (max smallest x, min largest y)+    ranges = map fixEnds raw+    count = div size precision+    largePrecision = take precision (reverse ranges)+    smallPrecision = take precision ranges+    oneRange (x, y) = vectorOf count (choose (x, y))++-- | Get the bucket a number is in, i.e. @0-9, 10-99@, etc.+logRange :: Integral a => a -> (a, a)+logRange 1 = (10, 99)+logRange (-1) = (-9, -1)+logRange n = case compare n 0 of+  EQ -> (0, 9)+  LT -> (negate (div b 10), negate (div a 10))+  GT -> (10 ^ n, 10 ^ (n + 1) - 1)+  where+    (a, b) = logRange (negate n)++-- | like (logBase10 n), except negative answers mean negative numbers, rather than fractions less than 1.+logish :: Integral t => t -> t+logish n+  | 0 <= n && n <= 9 = 0+  | n > 9 = 1 + logish (n `div` 10)+  | (-9) <= n && n <= (-1) = -1+  | True = negate (1 + logish (negate n))++-- =====================================================================
+ src/Constrained/Syntax.hs view
@@ -0,0 +1,904 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE ImpredicativeTypes #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ViewPatterns #-}+-- Rename instances+{-# OPTIONS_GHC -Wno-orphans #-}++-- | This module contains operations and tranformations on Syntax, Term, Pred, etc.+--    1) Computing Free Variables+--    2) Substitution+--    3) Renaming+--    4) internal helper functions+--    5) Syntacic only transformations+module Constrained.Syntax (+  -- * Surface syntax+  lit,+  genHint,+  dependsOn,+  reifies,+  monitor,+  explanation,+  assertReified,+  reify,+  reifyWithName,+  letBind,+  unsafeExists,+  forAll,+  assertExplain,+  exists,+  assert,++  -- * Free variable computations+  FreeVars,+  HasVariables (..),+  freeVarNames,+  count,+  singleton,+  without,++  -- * TODO: documentme+  computeDependencies,+  solvableFrom,+  respecting,+  applyNameHints,+  envFromPred,+  isLit,+  mkCase,+  unBind,+  substituteTerm',+  var,+  runCaseOn,+  substitutePred,+  Name (..),+  DependGraph,+  Hints,+  Subst,+  SubstEntry (..),+  irreflexiveDependencyOn,+  substPred,+  fromLits,+  backwardsSubstitution,+) where++import Constrained.AbstractSyntax+import Constrained.Base+import Constrained.Core+import Constrained.Env (Env)+import Constrained.Env qualified as Env+import Constrained.FunctionSymbol+import Constrained.GenT+import Constrained.Generic+import Constrained.Graph (+  deleteNode,+  dependencies,+  nodes,+  opGraph,+  subtractGraph,+ )+import Constrained.Graph qualified as Graph+import Constrained.List hiding (toList)+import Control.Monad.Writer (Writer, tell)+import Data.Foldable (fold, toList)+import Data.List.NonEmpty qualified as NE+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Maybe (fromMaybe, isJust)+import Data.Monoid qualified as Monoid+import Data.Orphans ()+import Data.Semigroup (Any (..))+import Data.Semigroup qualified as Semigroup+import Data.Set (Set)+import Data.Set qualified as Set+import Data.String (fromString)+import Data.Typeable+import Language.Haskell.TH qualified as TH+import Language.Haskell.TH.Quote qualified as TH+import Prettyprinter hiding (cat)+import Test.QuickCheck hiding (Args, Fun, Witness, forAll, witness)+import Prelude hiding (pred)++------------------------------------------------------------------------+-- Surface Syntax+------------------------------------------------------------------------++-- | Attach an explanation (a list of lines) to a `Pred` to get a better+-- error-message when things go wrong+assertExplain ::+  IsPred p =>+  [String] ->+  p ->+  Pred+assertExplain [] p = toPred p+assertExplain (s : es) p = Explain (s :| es) (toPred p)++-- | Assert something, most commonly a @`Term` `Bool`@+assert ::+  IsPred p =>+  p ->+  Pred+assert p = toPred p++-- | Quantify over all the elements of a collection+forAll ::+  forall p t a.+  ( Forallable t a+  , HasSpec t+  , HasSpec a+  , IsPred p+  ) =>+  Term t ->+  (Term a -> p) ->+  Pred+forAll tm = mkForAll tm . bind++mkForAll ::+  ( Forallable t a+  , HasSpec t+  , HasSpec a+  ) =>+  Term t ->+  Binder a ->+  Pred+mkForAll (Lit (forAllToList -> [])) _ = TruePred+mkForAll _ (_ :-> TruePred) = TruePred+mkForAll tm binder = ForAll tm binder++-- | Existentially quanitfy a value, the first argument is a recovery-function+-- to recover the value from a semantics for all the outer-bound variables during+-- constraint-checking+exists ::+  forall a p.+  (HasSpec a, IsPred p) =>+  ((forall b. Term b -> b) -> GE a) ->+  (Term a -> p) ->+  Pred+exists sem k =+  Exists sem $ bind k++-- | Existentially quantify a variable without the ability to check the constraint+unsafeExists ::+  forall a p.+  (HasSpec a, IsPred p) =>+  (Term a -> p) ->+  Pred+unsafeExists = exists (\_ -> fatalError "unsafeExists")++-- | Create a fresh variable to be able to talk about the same `Term` mutliple times+-- without introducing circular dependencies. The following would work:+-- > letBind (fst_ p) $ \ x ->+-- > letBind (snd_ p) $ \ y ->+-- >   assert $ x <=. y+-- While this does not:+-- > assert $ fst_ p <=. snd_ p+-- Although you'd most likely prefer to use `match` in practise:+-- > match p $ \ x y -> assert $ x <=. y+letBind ::+  ( HasSpec a+  , IsPred p+  ) =>+  Term a ->+  (Term a -> p) ->+  Pred+letBind tm@V {} body = toPred (body tm)+letBind tm body = Let tm (bind body)++-- | Bind a @`Term` b@ obtained via a haskell-level function @reification :: a -> b@+-- from a @`Term` a@, the inner `Term` depends strictly on the outer one+reify ::+  ( HasSpec a+  , HasSpec b+  , IsPred p+  ) =>+  Term a ->+  (a -> b) ->+  (Term b -> p) ->+  Pred+reify t f body =+  exists (\eval -> pure $ f (eval t)) $ \(name "reify_variable" -> x) ->+    [ reifies x t f+    , Explain (pure ("reify " ++ show t ++ " somef $")) $ toPred (body x)+    ]++-- | Like `reify` but provide a @[`var`| ... |]@-style name explicitly+reifyWithName ::+  ( HasSpec a+  , HasSpec b+  , IsPred p+  ) =>+  String ->+  Term a ->+  (a -> b) ->+  (Term b -> p) ->+  Pred+reifyWithName nam t f body =+  exists (\eval -> pure $ f (eval t)) $ \(name nam -> x) ->+    [ reifies x t f+    , Explain (pure ("reify " ++ show t ++ " somef $")) $ toPred (body x)+    ]++-- | Like `suchThat` for constraints+assertReified :: HasSpec a => Term a -> (a -> Bool) -> Pred+-- Note, it is necessary to introduce the extra variable from the `exists` here+-- to make things like `assertRealMultiple` work, if you don't have it then the+-- `reifies` isn't a defining constraint for anything any more.+assertReified t f =+  reify t f assert++-- | Wrap an 'Explain' around a Pred, unless there is a simpler form.+explanation :: NE.NonEmpty String -> Pred -> Pred+explanation _ p@DependsOn {} = p+explanation _ TruePred = TruePred+explanation es (FalsePred es') = FalsePred (es <> es')+explanation es (Assert t) = Explain es $ Assert t+explanation es p = Explain es p++-- | Add QuickCheck monitoring (e.g. 'Test.QuickCheck.collect' or 'Test.QuickCheck.counterexample')+--   to a predicate. To use the monitoring in a property call 'monitorSpec' on the 'Specification'+--   containing the monitoring and a value generated from the specification.+monitor :: ((forall a. Term a -> a) -> Property -> Property) -> Pred+monitor = Monitor++-- | Fix the first argument to be the haskell-"reification" of the second via+-- the third, "reification-function", argument+reifies :: (HasSpec a, HasSpec b) => Term b -> Term a -> (a -> b) -> Pred+reifies = Reifies++-- | Fix the solver order of the variables in two terms+dependsOn :: (HasSpec a, HasSpec b) => Term a -> Term b -> Pred+dependsOn = DependsOn++-- | Embed a literal as a `Term`+lit :: HasSpec a => a -> Term a+lit = Lit++-- | Add a generation-hint (e.g. a soft size constraint) to a `Term`+genHint :: forall t. HasGenHint t => Hint t -> Term t -> Pred+genHint = GenHint++-- ==========================================================+-- Variables+-- ==========================================================++mkNamed :: String -> TH.Q TH.Pat+mkNamed x =+  pure $+    TH.ViewP (TH.AppE (TH.VarE $ TH.mkName "name") (TH.LitE $ TH.StringL x)) (TH.VarP $ TH.mkName x)++mkNamedExpr :: String -> TH.Q TH.Exp+mkNamedExpr x =+  pure $+    TH.AppE (TH.AppE (TH.VarE $ TH.mkName "name") (TH.LitE $ TH.StringL x)) (TH.VarE $ TH.mkName x)++-- | A quasi-quoter for giving variables readable names:+-- > match p $ \ [var| x |] [var| y |] -> ...+-- will give you better error messages than:+-- > match p $ \ x y -> ...+var :: TH.QuasiQuoter+var =+  TH.QuasiQuoter+    { -- Parses variables e.g. `constrained $ \ [var| x |] [var| y |] -> ...` from the strings " x " and " y "+      -- and replaces them with `name "x" -> x` and `name "y" -> y`+      TH.quotePat = mkNamed . varName+    , -- Parses variables in expressions like `assert $ [var| x |] + 3 <. 10` and replaces them with `name "x" x`+      TH.quoteExp = mkNamedExpr . varName+    , TH.quoteDec = const $ fail "var should only be used at binding sites and in expressions"+    , TH.quoteType = const $ fail "var should only be used at binding sites and in expressions"+    }+  where+    varName s = case words s of+      [w] -> w+      _ -> fail "expected a single var name"++-- ============================================================+-- 1) Free variables and variable names+-- ============================================================++-- | Get all the free variable names of a thing+freeVarNames :: forall t. HasVariables t => t -> Set Int+freeVarNames = Set.mapMonotonic (\(Name v) -> nameOf v) . freeVarSet++-- | A multi-set of free variables+newtype FreeVars = FreeVars {unFreeVars :: Map Name Int}+  deriving (Show)++-- | How many times does a name appear in a t`FreeVars` set?+count :: Name -> FreeVars -> Int+count n (FreeVars m) = fromMaybe 0 $ Map.lookup n m++instance Semigroup FreeVars where+  FreeVars fv <> FreeVars fv' = FreeVars $ Map.unionWith (+) fv fv'++instance Monoid FreeVars where+  mempty = FreeVars mempty++-- | A name appears once+freeVar :: Name -> FreeVars+freeVar n = singleton n 1++-- | A name appears this many times, no more information than that+singleton :: Name -> Int -> FreeVars+singleton n k = FreeVars $ Map.singleton n k++-- | Remove some names+without :: Foldable t => FreeVars -> t Name -> FreeVars+without (FreeVars m) remove = FreeVars $ foldr Map.delete m (toList remove)++-- | Something for which we can do free-variable-check operations+class HasVariables a where+  freeVars :: a -> FreeVars+  freeVarSet :: a -> Set Name+  freeVarSet = Map.keysSet . unFreeVars . freeVars+  countOf :: Name -> a -> Int+  countOf n = count n . freeVars+  appearsIn :: Name -> a -> Bool+  appearsIn n = (> 0) . count n . freeVars++instance (HasVariables a, HasVariables b) => HasVariables (a, b) where+  freeVars (a, b) = freeVars a <> freeVars b+  freeVarSet (a, b) = freeVarSet a <> freeVarSet b+  countOf n (a, b) = countOf n a + countOf n b+  appearsIn n (a, b) = appearsIn n a || appearsIn n b++instance HasVariables (List Term as) where+  freeVars Nil = mempty+  freeVars (x :> xs) = freeVars x <> freeVars xs+  freeVarSet Nil = mempty+  freeVarSet (x :> xs) = freeVarSet x <> freeVarSet xs+  countOf _ Nil = 0+  countOf n (x :> xs) = countOf n x + countOf n xs+  appearsIn _ Nil = False+  appearsIn n (x :> xs) = appearsIn n x || appearsIn n xs++instance HasVariables Name where+  freeVars = freeVar+  freeVarSet = Set.singleton+  countOf n n'+    | n == n' = 1+    | otherwise = 0+  appearsIn n n' = n == n'++instance HasVariables (Term a) where+  freeVars = \case+    Lit {} -> mempty+    V x -> freeVar (Name x)+    App _ ts -> freeVars ts+  freeVarSet = \case+    Lit {} -> mempty+    V x -> freeVarSet (Name x)+    App _ ts -> freeVarSet ts+  countOf n = \case+    Lit {} -> 0+    V x -> countOf n (Name x)+    App _ ts -> countOf n ts+  appearsIn n = \case+    Lit {} -> False+    V x -> appearsIn n (Name x)+    App _ ts -> appearsIn n ts++instance HasVariables Pred where+  freeVars = \case+    ElemPred _ t _ -> freeVars t+    GenHint _ t -> freeVars t+    Subst x t p -> freeVars t <> freeVars p `without` [Name x]+    And ps -> foldMap freeVars ps+    Let t b -> freeVars t <> freeVars b+    Exists _ b -> freeVars b+    Assert t -> freeVars t+    Reifies t' t _ -> freeVars t' <> freeVars t+    DependsOn x y -> freeVars x <> freeVars y+    ForAll set b -> freeVars set <> freeVars b+    Case t bs -> freeVars t <> freeVars bs+    When b p -> freeVars b <> freeVars p+    TruePred -> mempty+    FalsePred _ -> mempty+    Monitor {} -> mempty+    Explain _ p -> freeVars p+  freeVarSet = \case+    ElemPred _ t _ -> freeVarSet t+    GenHint _ t -> freeVarSet t+    Subst x t p -> freeVarSet t <> Set.delete (Name x) (freeVarSet p)+    And ps -> foldMap freeVarSet ps+    Let t b -> freeVarSet t <> freeVarSet b+    Exists _ b -> freeVarSet b+    Assert t -> freeVarSet t+    Reifies t' t _ -> freeVarSet t' <> freeVarSet t+    DependsOn x y -> freeVarSet x <> freeVarSet y+    ForAll set b -> freeVarSet set <> freeVarSet b+    Case t bs -> freeVarSet t <> freeVarSet bs+    When b p -> freeVarSet b <> freeVarSet p+    Explain _ p -> freeVarSet p+    TruePred -> mempty+    FalsePred _ -> mempty+    Monitor {} -> mempty+  countOf n = \case+    ElemPred _ t _ -> countOf n t+    GenHint _ t -> countOf n t+    Subst x t p+      | n == Name x -> countOf n t+      | otherwise -> countOf n t + countOf n p+    And ps -> sum $ map (countOf n) ps+    Let t b -> countOf n t + countOf n b+    Exists _ b -> countOf n b+    Assert t -> countOf n t+    Reifies t' t _ -> countOf n t' + countOf n t+    DependsOn x y -> countOf n x + countOf n y+    ForAll set b -> countOf n set + countOf n b+    Case t bs -> countOf n t + countOf n bs+    When b p -> countOf n b + countOf n p+    Explain _ p -> countOf n p+    TruePred -> 0+    FalsePred _ -> 0+    Monitor {} -> 0+  appearsIn n = \case+    ElemPred _ t _ -> appearsIn n t+    GenHint _ t -> appearsIn n t+    Subst x t p+      | n == Name x -> appearsIn n t+      | otherwise -> appearsIn n t || appearsIn n p+    And ps -> any (appearsIn n) ps+    Let t b -> appearsIn n t || appearsIn n b+    Exists _ b -> appearsIn n b+    Assert t -> appearsIn n t+    Reifies t' t _ -> appearsIn n t' || appearsIn n t+    DependsOn x y -> appearsIn n x || appearsIn n y+    ForAll set b -> appearsIn n set || appearsIn n b+    Case t bs -> appearsIn n t || appearsIn n bs+    When b p -> appearsIn n b || appearsIn n p+    Explain _ p -> appearsIn n p+    TruePred -> False+    FalsePred _ -> False+    Monitor {} -> False++instance HasVariables (Binder a) where+  freeVars (x :-> p) = freeVars p `without` [Name x]+  freeVarSet (x :-> p) = Set.delete (Name x) (freeVarSet p)+  countOf n (x :-> p)+    | Name x == n = 0+    | otherwise = countOf n p+  appearsIn n (x :-> p)+    | Name x == n = False+    | otherwise = appearsIn n p++instance HasVariables (f a) => HasVariables (Weighted f a) where+  freeVars = freeVars . thing+  freeVarSet = freeVarSet . thing+  countOf n = countOf n . thing+  appearsIn n = appearsIn n . thing++instance HasVariables (List (Weighted Binder) as) where+  freeVars Nil = mempty+  freeVars (a :> as) = freeVars a <> freeVars as+  freeVarSet Nil = mempty+  freeVarSet (a :> as) = freeVarSet a <> freeVarSet as+  countOf _ Nil = 0+  countOf n (x :> xs) = countOf n x + countOf n xs+  appearsIn _ Nil = False+  appearsIn n (x :> xs) = appearsIn n x || appearsIn n xs++instance {-# OVERLAPPABLE #-} (Foldable t, HasVariables a) => HasVariables (t a) where+  freeVars = foldMap freeVars+  freeVarSet = foldMap freeVarSet+  countOf n = Monoid.getSum . foldMap (Monoid.Sum . countOf n)+  appearsIn n = any (appearsIn n)++instance HasVariables a => HasVariables (Set a) where+  freeVars = foldMap freeVars+  freeVarSet = foldMap freeVarSet+  countOf n = sum . Set.map (countOf n)+  appearsIn n = any (appearsIn n)++-- =================================================================+-- 2) Substitutions+-- ============================================================++-- | A substitution+type Subst = [SubstEntry]++-- | Individual substitution entry+data SubstEntry where+  (:=) :: HasSpec a => Var a -> Term a -> SubstEntry++-- | Try to run a substitution backwards to abstract+backwardsSubstitution :: forall a. HasSpec a => Subst -> Term a -> Term a+backwardsSubstitution sub0 t =+  case findMatch sub0 t of+    -- TODO: what about multiple matches??+    Just x -> V x+    Nothing -> case t of+      Lit a -> Lit a+      V x -> V x+      App f ts -> App f (mapListC @HasSpec (backwardsSubstitution sub0) ts)+  where+    findMatch :: Subst -> Term a -> Maybe (Var a)+    findMatch [] _ = Nothing+    findMatch (x := t' : sub1) t1+      | fastInequality t1 t' = findMatch sub1 t1+      | Just (x', t'') <- cast (x, t')+      , t == t'' =+          Just x'+      | otherwise = findMatch sub1 t1++-- ===================================================================++substituteTerm :: forall a. Subst -> Term a -> Term a+substituteTerm sub = \case+  Lit a -> Lit a+  V x -> substVar sub x+  App f (mapList (substituteTerm sub) -> (ts :: List Term dom)) ->+    case fromLits ts of+      Just vs -> Lit (uncurryList_ unValue (semantics f) vs)+      _ -> App f ts+  where+    substVar :: HasSpec a => Subst -> Var a -> Term a+    substVar [] x = V x+    substVar (y := t : sub1) x+      | Just Refl <- eqVar x y = t+      | otherwise = substVar sub1 x++-- | Apply substitution and check if we did anything+substituteTerm' :: forall a. Subst -> Term a -> Writer Any (Term a)+substituteTerm' sub = \case+  Lit a -> pure $ Lit a+  V x -> substVar sub x+  App f ts ->+    App f <$> mapMList (substituteTerm' sub) ts+  where+    substVar :: HasSpec a => Subst -> Var a -> Writer Any (Term a)+    substVar [] x = pure $ V x+    substVar (y := t : sub1) x+      | Just Refl <- eqVar x y = t <$ tell (Any True)+      | otherwise = substVar sub1 x++substituteBinder :: HasSpec a => Var a -> Term a -> Binder b -> Binder b+substituteBinder x tm (y :-> p) = y' :-> substitutePred x tm p'+  where+    (y', p') =+      freshen y p (Set.singleton (nameOf x) <> freeVarNames tm <> Set.delete (nameOf y) (freeVarNames p))++-- | Apply a single-variable substitution+substitutePred :: HasSpec a => Var a -> Term a -> Pred -> Pred+substitutePred x tm = \case+  ElemPred bool t xs -> ElemPred bool (substituteTerm [x := tm] t) xs+  GenHint h t -> GenHint h (substituteTerm [x := tm] t)+  Subst x' t p -> substitutePred x tm $ substitutePred x' t p+  Assert t -> Assert (substituteTerm [x := tm] t)+  And ps -> fold (substitutePred x tm <$> ps)+  Exists k b -> Exists (\eval -> k (eval . substituteTerm [x := tm])) (substituteBinder x tm b)+  Let t b -> Let (substituteTerm [x := tm] t) (substituteBinder x tm b)+  ForAll t b -> ForAll (substituteTerm [x := tm] t) (substituteBinder x tm b)+  Case t bs -> Case (substituteTerm [x := tm] t) (mapList (mapWeighted $ substituteBinder x tm) bs)+  When b p -> When (substituteTerm [x := tm] b) (substitutePred x tm p)+  Reifies t' t f -> Reifies (substituteTerm [x := tm] t') (substituteTerm [x := tm] t) f+  DependsOn t t' -> DependsOn (substituteTerm [x := tm] t) (substituteTerm [x := tm] t')+  TruePred -> TruePred+  FalsePred es -> FalsePred es+  Monitor m -> Monitor (\eval -> m (eval . substituteTerm [x := tm]))+  Explain es p -> Explain es $ substitutePred x tm p++-- =====================================================+-- Substituion under an Env, rather than a single Var+-- It takes Values in the Env, and makes them Literals in the Term.++substTerm :: Env -> Term a -> Term a+substTerm env = \case+  Lit a -> Lit a+  V v+    | Just a <- Env.lookup env v -> Lit a+    | otherwise -> V v+  App f (mapList (substTerm env) -> ts) ->+    case fromLits ts of+      Just vs -> Lit (uncurryList_ unValue (semantics f) vs)+      _ -> App f ts++substBinder :: Env -> Binder a -> Binder a+substBinder env (x :-> p) = x :-> substPred (Env.remove x env) p++-- | Apply a variable-to-value substitution to a `Pred`+substPred :: Env -> Pred -> Pred+substPred env = \case+  ElemPred bool t xs -> ElemPred bool (substTerm env t) xs+  GenHint h t -> GenHint h (substTerm env t)+  Subst x t p -> substPred env $ substitutePred x t p+  Assert t -> Assert (substTerm env t)+  Reifies t' t f -> Reifies (substTerm env t') (substTerm env t) f+  ForAll set b -> ForAll (substTerm env set) (substBinder env b)+  Case t bs -> Case (substTerm env t) (mapList (mapWeighted $ substBinder env) bs)+  When b p -> When (substTerm env b) (substPred env p)+  DependsOn x y -> DependsOn (substTerm env x) (substTerm env y)+  TruePred -> TruePred+  FalsePred es -> FalsePred es+  And ps -> fold (substPred env <$> ps)+  Exists k b -> Exists (\eval -> k $ eval . substTerm env) (substBinder env b)+  Let t b -> Let (substTerm env t) (substBinder env b)+  Monitor m -> Monitor m+  Explain es p -> Explain es $ substPred env p++-- | Substitute a value for a `Binder`+unBind :: a -> Binder a -> Pred+unBind a (x :-> p) = substPred (Env.singleton x a) p++-- ==========================================================+-- Renaming+-- ============================================================++-- Name++-- | Wrap a `Var` and hide the type+data Name where+  Name :: HasSpec a => Var a -> Name++deriving instance Show Name++instance Eq Name where+  Name v == Name v' = isJust $ eqVar v v'++-- Instances++instance Pretty (Var a) where+  pretty = fromString . show++instance Pretty Name where+  pretty (Name v) = pretty v++instance Ord Name where+  compare (Name v) (Name v') = compare (nameOf v, typeOf v) (nameOf v', typeOf v')++instance Rename Name where+  rename v v' (Name v'') = Name $ rename v v' v''++instance Rename (Term a) where+  rename v v'+    | v == v' = id+    | otherwise = \case+        Lit l -> Lit l+        V v'' -> V (rename v v' v'')+        App f a -> App f (rename v v' a)++instance Rename Pred where+  rename v v'+    | v == v' = id+    | otherwise = \case+        ElemPred bool t xs -> ElemPred bool (rename v v' t) xs+        GenHint h t -> GenHint h (rename v v' t)+        Subst x t p -> rename v v' $ substitutePred x t p+        And ps -> And (rename v v' ps)+        Exists k b -> Exists (\eval -> k $ eval . rename v v') (rename v v' b)+        Let t b -> Let (rename v v' t) (rename v v' b)+        Reifies t' t f -> Reifies (rename v v' t') (rename v v' t) f+        Assert t -> Assert (rename v v' t)+        DependsOn x y -> DependsOn (rename v v' x) (rename v v' y)+        ForAll set b -> ForAll (rename v v' set) (rename v v' b)+        Case t bs -> Case (rename v v' t) (rename v v' bs)+        When b p -> When (rename v v' b) (rename v v' p)+        TruePred -> TruePred+        FalsePred es -> FalsePred es+        Monitor m -> Monitor m+        Explain es p -> Explain es (rename v v' p)++instance Rename (Binder a) where+  rename v v' (va :-> psa) = va' :-> rename v v' psa'+    where+      (va', psa') = freshen va psa (Set.fromList [nameOf v, nameOf v'] <> Set.delete (nameOf va) (freeVarNames psa))++instance Rename (f a) => Rename (Weighted f a) where+  rename v v' (Weighted w t) = Weighted w (rename v v' t)++-- ============================================================================+-- 4) Internals+-- ============================================================================++-- | Try to extract literals from a list of Term, if anything isn't a literal, give up+fromLits :: List Term as -> Maybe (List Value as)+fromLits = mapMList fromLit++fromLit :: Term a -> Maybe (Value a)+fromLit (Lit l) = pure $ Value l+-- fromLit (To x) = (Value . toSimpleRep . unValue) <$> fromLit x -- MAYBE we don't want to do this?+-- fromLit (From x) = (Value . fromSimpleRep . unValue) <$> fromLit x -- Why not apply unary functions to Lit ?+fromLit _ = Nothing++-- | Is a term a literl?+isLit :: Term a -> Bool+isLit = isJust . fromLit++-- | Build a `caseOn`+mkCase ::+  HasSpec (SumOver as) => Term (SumOver as) -> List (Weighted Binder) as -> Pred+mkCase tm cs+  | Weighted _ (x :-> p) :> Nil <- cs = Subst x tm p+  -- TODO: all equal maybe?+  | Semigroup.getAll $ foldMapList isTrueBinder cs = TruePred+  | Semigroup.getAll $ foldMapList (isFalseBinder . thing) cs = FalsePred (pure "mkCase on all False")+  | Lit a <- tm = runCaseOn a (mapList thing cs) (\x val p -> substPred (Env.singleton x val) p)+  | otherwise = Case tm cs+  where+    isTrueBinder (Weighted Nothing (_ :-> TruePred)) = Semigroup.All True+    isTrueBinder _ = Semigroup.All False++    isFalseBinder (_ :-> FalsePred {}) = Semigroup.All True+    isFalseBinder _ = Semigroup.All False++-- | Run a `caseOn`+runCaseOn ::+  SumOver as ->+  List Binder as ->+  (forall a. (Typeable a, Show a) => Var a -> a -> Pred -> r) ->+  r+runCaseOn _ Nil _ = error "The impossible happened in runCaseOn"+runCaseOn a ((x :-> ps) :> Nil) f = f x a ps+runCaseOn s ((x :-> ps) :> bs@(_ :> _)) f = case s of+  SumLeft a -> f x a ps+  SumRight a -> runCaseOn a bs f++-- | Construct an environment for all variables that show up on the top level+-- (i.e. ones bound in `let` and `exists`) from an environment for all the free+-- variables in the pred. The environment you get out of this function is+-- _bigger_ than the environment you put in. From+-- ```+-- let y = x + 1 in let z = y + 1 in foo x y z+-- ```+-- and an environment with `{x -> 1}` you would get `{x -> 1, y -> 2, z -> 3}`+-- out.+envFromPred :: Env -> Pred -> GE Env+envFromPred env p = case p of+  ElemPred _bool _term _xs -> pure env+  -- NOTE: these don't bind anything+  Assert {} -> pure env+  DependsOn {} -> pure env+  Monitor {} -> pure env+  TruePred {} -> pure env+  FalsePred {} -> pure env+  GenHint {} -> pure env+  -- NOTE: this is ok because the variables either come from an `Exists`, a `Let`, or from+  -- the top level+  Reifies {} -> pure env+  -- NOTE: variables in here shouldn't escape to the top level+  ForAll {} -> pure env+  Case {} -> pure env+  -- These can introduce binders that show up in the plan+  When _ pp -> envFromPred env pp+  Subst x a pp -> envFromPred env (substitutePred x a pp)+  Let t (x :-> pp) -> do+    v <- runTerm env t+    envFromPred (Env.extend x v env) pp+  Explain _ pp -> envFromPred env pp+  Exists c (x :-> pp) -> do+    v <- c (errorGE . explain "envFromPred: Exists" . runTerm env)+    envFromPred (Env.extend x v env) pp+  And [] -> pure env+  And (pp : ps) -> do+    env' <- envFromPred env pp+    envFromPred env' (And ps)++------------------------------------------------------------------------+-- Lifting name hints to binders+------------------------------------------------------------------------++findNameHint :: HasVariables t => Var a -> t -> Var a+findNameHint v t =+  case [nameHint v' | Name v' <- Set.toList $ freeVarSet t, nameOf v' == nameOf v, nameHint v' /= "v"] of+    [] -> v+    nh : _ -> v {nameHint = nh}++liftNameHintToBinder :: Binder a -> Binder a+liftNameHintToBinder (x :-> p) = x' :-> substitutePred x (V x') (applyNameHintsPred p)+  where+    x' = findNameHint x p++applyNameHintsPred :: Pred -> Pred+applyNameHintsPred pred = case pred of+  ElemPred {} -> pred+  Monitor {} -> pred+  And ps -> And $ map applyNameHintsPred ps+  Exists k b -> Exists k (liftNameHintToBinder b)+  Subst v t p -> applyNameHintsPred (substitutePred v t p)+  Let t b -> Let t (liftNameHintToBinder b)+  Assert {} -> pred+  Reifies {} -> pred+  DependsOn {} -> pred+  ForAll t b -> ForAll t (liftNameHintToBinder b)+  Case t bs -> Case t (mapList (mapWeighted liftNameHintToBinder) bs)+  When b p' -> When b (applyNameHintsPred p')+  GenHint {} -> pred+  TruePred {} -> pred+  FalsePred {} -> pred+  Explain es p' -> Explain es (applyNameHintsPred p')++-- | Makes sure that uses of the @[var| |]@ quasi-quoter are correctly+-- propagated to the binding site of the variable. This is done as a separate+-- pass to make sure we don't traverse the `Specification` too many times+applyNameHints :: Specification a -> Specification a+applyNameHints (ExplainSpec es x) = explainSpec es (applyNameHints x)+applyNameHints (SuspendedSpec x p) =+  SuspendedSpec x' p'+  where+    x' :-> p' = liftNameHintToBinder (x :-> p)+applyNameHints spec = spec++------------------------------------------------------------------------+-- Dependency Graphs+------------------------------------------------------------------------++-- | `Graph` specialized to dependencies for variables+type DependGraph = Graph.Graph Name++-- | Everything to the left depends on everything from the right, except themselves+irreflexiveDependencyOn ::+  forall t t'. (HasVariables t, HasVariables t') => t -> t' -> DependGraph+irreflexiveDependencyOn (freeVarSet -> xs) (freeVarSet -> ys) = Graph.irreflexiveDependencyOn xs ys++-- | These variables are free+noDependencies :: HasVariables t => t -> DependGraph+noDependencies (freeVarSet -> xs) = Graph.noDependencies xs++-- | Hints from `dependsOn`+type Hints = DependGraph++-- | Adjust a `DependGraph` to some `Hints`+respecting :: Hints -> DependGraph -> DependGraph+respecting hints g = g `subtractGraph` opGraph hints++-- | Given a dependency graph, are all the presrequisites of a variable covered by the set?+solvableFrom :: Name -> Set Name -> DependGraph -> Bool+solvableFrom x s g =+  let less = dependencies x g+   in s `Set.isSubsetOf` less && not (x `Set.member` less)++-- | Get the dependencies that appear in a `Pred`+computeDependencies :: Pred -> DependGraph+computeDependencies = \case+  ElemPred _bool term _xs -> computeTermDependencies term+  Monitor {} -> mempty+  Subst x t p -> computeDependencies (substitutePred x t p)+  Assert t -> computeTermDependencies t+  Reifies t' t _ -> t' `irreflexiveDependencyOn` t+  ForAll set b ->+    let innerG = computeBinderDependencies b+     in innerG <> set `irreflexiveDependencyOn` nodes innerG+  x `DependsOn` y -> x `irreflexiveDependencyOn` y+  Case t bs ->+    let innerG = foldMapList (computeBinderDependencies . thing) bs+     in innerG <> t `irreflexiveDependencyOn` nodes innerG+  When b p ->+    let pG = computeDependencies p+        oG = nodes pG `irreflexiveDependencyOn` b+     in oG <> pG+  TruePred -> mempty+  FalsePred {} -> mempty+  And ps -> foldMap computeDependencies ps+  Exists _ b -> computeBinderDependencies b+  Let t b -> noDependencies t <> computeBinderDependencies b+  GenHint _ t -> noDependencies t+  Explain _ p -> computeDependencies p++computeBinderDependencies :: Binder a -> DependGraph+computeBinderDependencies (x :-> p) =+  deleteNode (Name x) $ computeDependencies p++computeTermDependencies :: Term a -> DependGraph+computeTermDependencies = fst . computeTermDependencies'++computeTermDependencies' :: Term a -> (DependGraph, Set Name)+computeTermDependencies' = \case+  (App _ args) -> go args+  Lit {} -> (mempty, mempty)+  (V x) -> (noDependencies (Name x), Set.singleton (Name x))+  where+    go :: List Term as -> (DependGraph, Set Name)+    go Nil = (mempty, mempty)+    go (t :> ts) =+      let (gr, ngr) = go ts+          (tgr, ntgr) = computeTermDependencies' t+       in (ntgr `irreflexiveDependencyOn` ngr <> tgr <> gr, ngr <> ntgr)
+ src/Constrained/Test.hs view
@@ -0,0 +1,453 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Useful properties for debugging HasSpec instances and this library itself+module Constrained.Test (+  prop_sound,+  prop_constrained_satisfies_sound,+  prop_constrained_explained,+  prop_complete,+  prop_constrained_satisfies_complete,+  prop_shrink_sound,+  prop_conformEmpty,+  prop_univSound,+  prop_mapSpec,+  prop_propagateSpecSound,+  prop_gen_sound,+  specType,+  TestableFn (..),+) where++import Constrained.API.Extend+import Constrained.Base+import Constrained.Core+import Constrained.FunctionSymbol+import Constrained.GenT+import Constrained.Generation+import Constrained.List+import Constrained.NumOrd+import Constrained.PrettyUtils+import Constrained.Spec.List+import Constrained.Spec.Map+import Constrained.Spec.Set+import Constrained.TheKnot+import Data.Int+import Data.List (nub)+import qualified Data.List.NonEmpty as NE+import Data.Map (Map)+import Data.Set (Set)+import Data.Typeable (Typeable, typeOf)+import Data.Word+import Prettyprinter+import Test.QuickCheck hiding (Fun)+import qualified Test.QuickCheck as QC++-- | Check that a generator from a given `Specification` is sound, it never+-- generates a bad value that doesn't satisfy the constraint+prop_sound ::+  HasSpec a =>+  Specification a ->+  QC.Property+prop_sound spec =+  QC.forAllBlind (strictGen $ genFromSpecT spec) $ \ma ->+    case ma of+      Result a ->+        QC.cover 80 True "successful" $+          QC.counterexample (show a) $+            monitorSpec spec a $+              conformsToSpecProp a spec+      _ -> QC.cover 80 False "successful" True++-- | Modify the `Specification` in `prop_sound` to test re-use+prop_constrained_satisfies_sound :: HasSpec a => Specification a -> QC.Property+prop_constrained_satisfies_sound spec = prop_sound (constrained $ \a -> satisfies a spec)++-- | Check that explanations don't immediately ruin soundness+prop_constrained_explained :: HasSpec a => Specification a -> QC.Property+prop_constrained_explained spec =+  let es = NE.singleton "Dummy explanation"+   in prop_sound $ constrained $ \x -> Explain es $ x `satisfies` spec++-- | `prop_complete ps` assumes that `ps` is satisfiable and checks that it doesn't crash+prop_complete :: HasSpec a => Specification a -> QC.Property+prop_complete s =+  QC.forAllBlind (strictGen $ genFromSpecT s) $ \ma -> fromGEProp $ do+    a <- ma+    -- Force the value to make sure we don't crash with `error` somewhere+    -- or fall into an inifinite loop+    pure $ length (show a) > 0++-- | Like `prop_constrained_satisfies_sound` for completeness+prop_constrained_satisfies_complete :: HasSpec a => Specification a -> QC.Property+prop_constrained_satisfies_complete spec = prop_complete (constrained $ \a -> satisfies a spec)++-- | Check that shrinking preserves constraint adherence+prop_shrink_sound :: HasSpec a => Specification a -> QC.Property+prop_shrink_sound s =+  QC.forAll (strictGen $ genFromSpecT s) $ \ma -> fromGEDiscard $ do+    a <- ma+    let shrinks = shrinkWithSpec s a+    pure $+      QC.cover 40 (not $ null shrinks) "non-null shrinks" $+        if null shrinks+          then QC.property True+          else QC.forAll (QC.elements shrinks) $ \a' ->+            conformsToSpecProp a' s++-- | Check that anything conforms to the trivial specification+prop_conformEmpty ::+  forall a.+  HasSpec a =>+  a ->+  QC.Property+prop_conformEmpty a = QC.property $ conformsTo a (emptySpec @a)++-- | Check that propagation works properly+prop_univSound :: TestableFn -> QC.Property+prop_univSound (TestableFn (fn :: t as b)) =+  QC.label (show fn) $+    QC.forAllShrinkBlind @QC.Property (QC.arbitrary @(TestableCtx as)) QC.shrink $ \tc@(TestableCtx ctx) ->+      QC.forAllShrinkBlind QC.arbitrary QC.shrink $ \spec ->+        QC.counterexample ("\nfn ctx = " ++ showCtxWith fn tc) $+          QC.counterexample (show $ "\nspec =" <+> pretty spec) $+            let sspec = simplifySpec (propagate fn ctx spec)+             in QC.counterexample ("\n" ++ show ("propagate ctx spec =" /> pretty sspec)) $+                  QC.counterexample ("\n" ++ show (prettyPlan sspec)) $+                    QC.within 20_000_000 $+                      QC.forAllBlind (strictGen $ genFromSpecT sspec) $ \ge ->+                        fromGEDiscard $ do+                          a <- ge+                          let res = uncurryList_ unValue (semantics fn) $ fillListCtx ctx $ \HOLE -> Value a+                          pure $+                            QC.counterexample ("\ngenerated value: a = " ++ show a) $+                              QC.counterexample ("\nfn ctx[a] = " ++ show res) $+                                conformsToSpecProp res spec++-- | Similar to `prop_sound`+prop_gen_sound :: forall a. HasSpec a => Specification a -> QC.Property+prop_gen_sound spec =+  let sspec = simplifySpec spec+   in QC.tabulate "specType spec" [specType spec] $+        QC.tabulate "specType (simplifySpec spec)" [specType sspec] $+          QC.counterexample ("\n" ++ show (prettyPlan sspec)) $+            QC.forAllBlind (strictGen $ genFromSpecT @a @GE sspec) $ \ge ->+              fromGEDiscard $ do+                a <- ge+                pure $+                  QC.counterexample ("\ngenerated value: a = " ++ show a) $+                    conformsToSpecProp a spec++-- | Pretty-print the type of a spec for test statistics, @"SuspendedSpec"@, @"MemberSpec"@, etc.+specType :: Specification a -> String+specType (ExplainSpec [] s) = specType s+specType (ExplainSpec _ s) = "(ExplainSpec " ++ specType s ++ ")"+specType SuspendedSpec {} = "SuspendedSpec"+specType ErrorSpec {} = "ErrorSpec"+specType MemberSpec {} = "MemberSpec"+specType TypeSpec {} = "TypeSpec"+specType TrueSpec {} = "TrueSpec"++-- ============================================================+-- An abstraction that hides everything about a function symbol+-- But includes inside in the constraints, everything needed to+-- use the function symbol++showCtxWith ::+  forall fn as b.+  AppRequires fn as b =>+  fn as b ->+  TestableCtx as ->+  String+showCtxWith fn (TestableCtx ctx) = show tm+  where+    tm :: Term b+    tm =+      uncurryList (appTerm fn) $+        fillListCtx (mapListCtxC @HasSpec @_ @Value @Term (lit @_ . unValue) ctx) (\HOLE -> V $ Var 0 "v")++data TestableFn where+  TestableFn ::+    ( QC.Arbitrary (Specification b)+    , Typeable (FunTy as b)+    , AppRequires t as b+    ) =>+    t as b ->+    TestableFn++instance Show TestableFn where+  show (TestableFn (fn :: t as b)) =+    show fn ++ " :: " ++ show (typeOf (undefined :: FunTy as b))++-- | Check that `mapSpec` is correct+prop_mapSpec ::+  ( HasSpec a+  , AppRequires t '[a] b+  ) =>+  t '[a] b ->+  Specification a ->+  QC.Property+prop_mapSpec funsym spec =+  QC.forAll (strictGen $ genFromSpecT spec) $ \ma -> fromGEDiscard $ do+    a <- ma+    pure $ conformsToSpec (semantics funsym a) (mapSpec funsym spec)++-- | Check that propagation is correct via `genInverse`+prop_propagateSpecSound ::+  ( HasSpec a+  , AppRequires t '[a] b+  ) =>+  t '[a] b ->+  b ->+  QC.Property+prop_propagateSpecSound funsym b =+  QC.forAll (strictGen $ genInverse (Fun funsym) TrueSpec b) $ \ma -> fromGEDiscard $ do+    a <- ma+    pure $ semantics funsym a == b++------------------------------------------------------------------------+-- Arbitrary instances for Specifications+------------------------------------------------------------------------++instance (Arbitrary (Specification a), Arbitrary (Specification b)) => Arbitrary (SumSpec a b) where+  arbitrary =+    SumSpec+      <$> frequency+        [ (3, pure Nothing)+        , (10, Just <$> ((,) <$> choose (0, 100) <*> choose (0, 100)))+        , (1, arbitrary)+        ]+      <*> arbitrary+      <*> arbitrary+  shrink (SumSpec h a b) = [SumSpec h' a' b' | (h', a', b') <- shrink (h, a, b)]++instance (Arbitrary (Specification a), Arbitrary (Specification b)) => Arbitrary (PairSpec a b) where+  arbitrary = Cartesian <$> arbitrary <*> arbitrary+  shrink (Cartesian a b) = uncurry Cartesian <$> shrink (a, b)++-- TODO: consider making this more interesting to get fewer discarded tests+-- in `prop_gen_sound`+instance+  ( Arbitrary k+  , Arbitrary v+  , Arbitrary (TypeSpec k)+  , Arbitrary (TypeSpec v)+  , Ord k+  , HasSpec k+  , Foldy v+  ) =>+  Arbitrary (MapSpec k v)+  where+  arbitrary =+    MapSpec+      <$> arbitrary+      <*> arbitrary+      <*> arbitrary+      <*> arbitrary+      <*> arbitrary+      <*> frequency [(1, pure NoFold), (1, arbitrary)]+  shrink = genericShrink++instance Arbitrary (FoldSpec (Map k v)) where+  arbitrary = pure NoFold++instance (HasSpec a, Arbitrary (TypeSpec a)) => Arbitrary (Specification a) where+  arbitrary = do+    baseSpec <-+      frequency+        [ (1, pure TrueSpec)+        ,+          ( 7+          , do+              zs <- nub <$> listOf1 (genFromSpec TrueSpec)+              pure+                ( memberSpec+                    zs+                    ( NE.fromList+                        [ "In (Arbitrary Specification) this should never happen"+                        , "listOf1 generates empty list."+                        ]+                    )+                )+          )+        , (10, typeSpec <$> arbitrary)+        ,+          ( 1+          , do+              len <- choose (1, 5)+              TypeSpec <$> arbitrary <*> vectorOf len (genFromSpec TrueSpec)+          )+        , (1, ErrorSpec <$> arbitrary)+        , -- Recurse to make sure we apply the tricks for generating suspended specs multiple times+          (1, arbitrary)+        ]+    -- TODO: we probably want smarter ways of generating constraints+    frequency+      [ (1, pure $ constrained $ \x -> x `satisfies` baseSpec)+      , (1, ExplainSpec ["Arbitrary"] <$> arbitrary)+      ,+        ( 1+        , pure $ constrained $ \x -> exists (\eval -> pure $ eval x) $ \y ->+            [ assert $ x ==. y+            , y `satisfies` baseSpec+            ]+        )+      , (1, pure $ constrained $ \x -> letBind x $ \y -> y `satisfies` baseSpec)+      ,+        ( 1+        , pure $ constrained $ \x -> exists (\_ -> pure True) $ \b ->+            ifElse b (x `satisfies` baseSpec) (x `satisfies` baseSpec)+        )+      ,+        ( 1+        , pure $ constrained $ \x -> exists (\_ -> pure True) $ \b ->+            [ ifElse b True (x `satisfies` baseSpec)+            , x `satisfies` baseSpec+            ]+        )+      ,+        ( 1+        , pure $ constrained $ \x -> exists (\_ -> pure False) $ \b ->+            [ ifElse b (x `satisfies` baseSpec) True+            , x `satisfies` baseSpec+            ]+        )+      ,+        ( 1+        , pure $ constrained $ \x -> explanation (pure "its very subtle, you won't get it.") $ x `satisfies` baseSpec+        )+      , (10, pure baseSpec)+      ]++  shrink (TypeSpec ts cant) = flip TypeSpec cant <$> shrink ts+  shrink (ExplainSpec _ s) = [s]+  shrink _ = []++instance+  ( Arbitrary a+  , Arbitrary (FoldSpec a)+  , Arbitrary (TypeSpec a)+  , HasSpec a+  ) =>+  Arbitrary (ListSpec a)+  where+  arbitrary = ListSpec <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary+  shrink (ListSpec a b c d e) = [ListSpec a' b' c' d' e' | (a', b', c', d', e') <- shrink (a, b, c, d, e)]++instance {-# OVERLAPPABLE #-} (Arbitrary (Specification a), Foldy a) => Arbitrary (FoldSpec a) where+  arbitrary = oneof [FoldSpec (Fun IdW) <$> arbitrary, pure NoFold]+  shrink NoFold = []+  shrink (FoldSpec (Fun (getWitness -> Just IdW)) spec) = FoldSpec (Fun IdW) <$> shrink spec+  shrink FoldSpec {} = [NoFold]++instance (Ord a, Arbitrary (Specification a), Arbitrary a) => Arbitrary (SetSpec a) where+  arbitrary = SetSpec <$> arbitrary <*> arbitrary <*> arbitrary+  shrink (SetSpec a b c) = [SetSpec a' b' c' | (a', b', c') <- shrink (a, b, c)]++-- TODO: consider improving this+instance Arbitrary (FoldSpec (Set a)) where+  arbitrary = pure NoFold++------------------------------------------------------------------------+-- Random contexts+------------------------------------------------------------------------++data TestableCtx as where+  TestableCtx ::+    HasSpec a =>+    ListCtx Value as (HOLE a) ->+    TestableCtx as++instance forall as. (All HasSpec as, TypeList as) => QC.Arbitrary (TestableCtx as) where+  arbitrary = do+    let shape = listShape @as+    idx <- QC.choose (0, lengthList shape - 1)+    go idx shape+    where+      go :: forall f as'. All HasSpec as' => Int -> List f as' -> QC.Gen (TestableCtx as')+      go 0 (_ :> as) =+        TestableCtx . (HOLE :?) <$> mapMListC @HasSpec (\_ -> Value <$> genFromSpec TrueSpec) as+      go n (_ :> as) = do+        TestableCtx ctx <- go (n - 1) as+        TestableCtx . (:! ctx) . Value <$> genFromSpec TrueSpec+      go _ _ = error "The impossible happened in Arbitrary for TestableCtx"++  shrink (TestableCtx ctx) = TestableCtx <$> shrinkCtx ctx+    where+      shrinkCtx :: forall c as'. All HasSpec as' => ListCtx Value as' c -> [ListCtx Value as' c]+      shrinkCtx (c :? as) = (c :?) <$> go as+      shrinkCtx (Value a :! ctx') = map ((:! ctx') . Value) (shrinkWithSpec TrueSpec a) ++ map (Value a :!) (shrinkCtx ctx')++      go :: forall as'. All HasSpec as' => List Value as' -> [List Value as']+      go Nil = []+      go (Value a :> as) = map ((:> as) . Value) (shrinkWithSpec TrueSpec a) ++ map (Value a :>) (go as)++instance QC.Arbitrary TestableFn where+  arbitrary =+    QC.elements+      [ -- data IntW+        TestableFn $ AddW @Int+      , TestableFn $ NegateW @Int+      , TestableFn $ MultW @Int+      , TestableFn $ MultW @Integer+      , TestableFn $ SignumW @Integer+      , -- These are representative of the bounded types+        TestableFn $ MultW @Word8+      , TestableFn $ SignumW @Word8+      , TestableFn $ MultW @Int8+      , TestableFn $ MultW @Float+      , TestableFn $ SignumW @Float+      , TestableFn $ MultW @Double+      , TestableFn $ SignumW @Double+      , TestableFn $ SizeOfW @(Map Int Int)+      , -- data BaseW+        TestableFn $ EqualW @Int+      , TestableFn $ ProdFstW @Int @Int+      , TestableFn $ ProdSndW @Int @Int+      , TestableFn $ ProdW @Int @Int+      , TestableFn $ InjRightW @Int @Int+      , TestableFn $ InjLeftW @Int @Int+      , TestableFn $ ElemW @Int+      , TestableFn $ FromGenericW @(Either Int Bool)+      , TestableFn $ ToGenericW @(Either Int Bool)+      , -- data SetW+        TestableFn $ SingletonW @Int+      , TestableFn $ UnionW @Int+      , TestableFn $ SubsetW @Int+      , TestableFn $ MemberW @Int+      , TestableFn $ DisjointW @Int+      , TestableFn $ FromListW @Int+      , -- data BoolW+        TestableFn $ NotW+      , TestableFn $ OrW+      , -- data OrdW+        TestableFn $ LessW @Int+      , TestableFn $ LessOrEqualW @Int+      , -- data MapW+        TestableFn $ RngW @Int @Int+      , TestableFn $ DomW @Int @Int+      , TestableFn $ LookupW @Int @Int+      , -- data ListW+        TestableFn $ FoldMapW @Int (Fun IdW)+      , TestableFn $ SingletonListW @Int+      , TestableFn $ AppendW @Int+      ]+  shrink _ = []++-- Cruft ------------------------------------------------------------------++#if !MIN_VERSION_QuickCheck(2, 17, 0)+instance Arbitrary a => Arbitrary (NonEmpty a) where+  arbitrary = do+    NonEmpty xs <- arbitrary+    pure (NE.fromList xs)+#endif
+ src/Constrained/TheKnot.hs view
@@ -0,0 +1,469 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ImpredicativeTypes #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE UndecidableSuperClasses #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wno-orphans -Wno-name-shadowing #-}++-- | All the things that are mutually recursive.+module Constrained.TheKnot (+  FunW (..),+  ProdW (..),+  SizeW (..),+  PairSpec (..),+  ifElse,+  sizeOf_,++  -- * Useful internal function symbols+  prodFst_,+  prodSnd_,+  prod_,++  -- * Misc+  genFromSizeSpec,+  maxSpec,+  rangeSize,+  hasSize,+  genInverse,+  between,++  -- * Patterns+  pattern Product,++  -- * Classes+  Sized (..),+) where++import Constrained.AbstractSyntax+import Constrained.Base+import Constrained.Conformance+import Constrained.Core+import Constrained.FunctionSymbol+import Constrained.GenT+import Constrained.Generation+import Constrained.Generic+import Constrained.List+import Constrained.NumOrd+import Constrained.PrettyUtils+import Constrained.SumList+-- TODO: some strange things here, why is SolverStage in here?!+-- Because it is mutually recursive with something else in here.+import Constrained.Syntax+import Control.Applicative+import Data.Foldable+import Data.Kind+import Data.List (nub)+import qualified Data.List.NonEmpty as NE+import Data.Maybe+import Data.Typeable+import Prettyprinter hiding (cat)+import Prelude hiding (cycle, pred)++instance Numeric a => Complete a where+  simplifyA = simplifySpec+  genFromSpecA = genFromSpecT++-- | If the `Specification Bool` doesn't constrain the boolean you will get a `TrueSpec` out.+ifElse :: (IsPred p, IsPred q) => Term Bool -> p -> q -> Pred+ifElse b p q = whenTrue b p <> whenTrue (not_ b) q++-- --------------- Simplification of Sum types --------------------++-- =======================================================================================++-- ================================================================+-- HasSpec for Products+-- ================================================================++pairView :: Term (Prod a b) -> Maybe (Term a, Term b)+pairView (App (getWitness -> Just ProdW) (x :> y :> Nil)) = Just (x, y)+pairView _ = Nothing++cartesian ::+  forall a b.+  (HasSpec a, HasSpec b) =>+  Specification a ->+  Specification b ->+  Specification (Prod a b)+cartesian (ErrorSpec es) (ErrorSpec fs) = ErrorSpec (es <> fs)+cartesian (ErrorSpec es) _ = ErrorSpec (NE.cons "cartesian left" es)+cartesian _ (ErrorSpec es) = ErrorSpec (NE.cons "cartesian right" es)+cartesian s s' = typeSpec $ Cartesian s s'++-- | t`TypeSpec` for @`Prod` a b@+data PairSpec a b = Cartesian (Specification a) (Specification b)++instance (HasSpec a, HasSpec b) => HasSpec (Prod a b) where+  type TypeSpec (Prod a b) = PairSpec a b++  type Prerequisites (Prod a b) = (HasSpec a, HasSpec b)++  emptySpec = Cartesian mempty mempty++  combineSpec (Cartesian a b) (Cartesian a' b') = cartesian (a <> a') (b <> b')++  conformsTo (Prod a b) (Cartesian sa sb) = conformsToSpec a sa && conformsToSpec b sb++  genFromTypeSpec (Cartesian sa sb) = Prod <$> genFromSpecT sa <*> genFromSpecT sb++  shrinkWithTypeSpec (Cartesian sa sb) (Prod a b) =+    [Prod a' b | a' <- shrinkWithSpec sa a]+      ++ [Prod a b' | b' <- shrinkWithSpec sb b]++  fixupWithTypeSpec (Cartesian sa sb) (Prod a b) =+    Prod <$> fixupWithSpec sa a <*> fixupWithSpec sb b++  toPreds x (Cartesian sf ss) =+    satisfies (prodFst_ x) sf+      <> satisfies (prodSnd_ x) ss++  cardinalTypeSpec (Cartesian x y) = (cardinality x) + (cardinality y)++  typeSpecHasError (Cartesian x y) =+    case (isErrorLike x, isErrorLike y) of+      (False, False) -> Nothing+      (True, False) -> Just $ errorLikeMessage x+      (False, True) -> Just $ errorLikeMessage y+      (True, True) -> Just $ (errorLikeMessage x <> errorLikeMessage y)++  alternateShow (Cartesian left right@(TypeSpec r [])) =+    case alternateShow @b r of+      (BinaryShow "Cartesian" ps) -> BinaryShow "Cartesian" ("," <+> viaShow left : ps)+      (BinaryShow "SumSpec" ps) -> BinaryShow "Cartesian" ("," <+> viaShow left : ["SumSpec" /> vsep ps])+      _ -> BinaryShow "Cartesian" ["," <+> viaShow left, "," <+> viaShow right]+  alternateShow (Cartesian left right) = BinaryShow "Cartesian" ["," <+> viaShow left, "," <+> viaShow right]++instance (HasSpec a, HasSpec b) => Show (PairSpec a b) where+  show pair@(Cartesian l r) = case alternateShow @(Prod a b) pair of+    (BinaryShow "Cartesian" ps) -> show $ parens ("Cartesian" /> vsep ps)+    _ -> "(Cartesian " ++ "(" ++ show l ++ ") (" ++ show r ++ "))"++-- ==================================================+-- Logic instances for Prod+-- ==================================================++-- | Function symbols for talking about `Prod`+data ProdW :: [Type] -> Type -> Type where+  ProdW :: (HasSpec a, HasSpec b) => ProdW '[a, b] (Prod a b)+  ProdFstW :: (HasSpec a, HasSpec b) => ProdW '[Prod a b] a+  ProdSndW :: (HasSpec a, HasSpec b) => ProdW '[Prod a b] b++deriving instance Eq (ProdW as b)++deriving instance Show (ProdW as b)++instance Syntax ProdW where+  prettySymbol ProdW _ _ = Nothing+  prettySymbol ProdFstW (t :> Nil) p = parensIf (p > 10) <$> prettySelect 0 t+  prettySymbol ProdSndW (t :> Nil) p = parensIf (p > 10) <$> prettySelect 1 t++prettySelect :: Int -> TermD deps t -> Maybe (Doc ann)+prettySelect i (App f (t :> Nil))+  | Just ProdSndW <- getWitness f = prettySelect (i + 1) t+  | Just ToGenericW <- getWitness f = Just $ "sel @" <> pretty i <+> prettyPrec 11 t+prettySelect _ _ = Nothing++instance Semantics ProdW where+  semantics ProdW = Prod+  semantics ProdFstW = prodFst+  semantics ProdSndW = prodSnd++instance Logic ProdW where+  propagateTypeSpec ProdFstW (Unary HOLE) ts cant = cartesian (TypeSpec ts cant) TrueSpec+  propagateTypeSpec ProdSndW (Unary HOLE) ts cant =+    cartesian TrueSpec (TypeSpec ts cant)+  propagateTypeSpec ProdW (a :>: HOLE) sc@(Cartesian sa sb) cant+    | a `conformsToSpec` sa = sb <> foldMap notEqualSpec (sameFst a cant)+    | otherwise =+        ErrorSpec+          ( NE.fromList+              ["propagate (pair_ " ++ show a ++ " HOLE) has conformance failure on a", show (TypeSpec sc cant)]+          )+  propagateTypeSpec ProdW (HOLE :<: b) sc@(Cartesian sa sb) cant+    | b `conformsToSpec` sb = sa <> foldMap notEqualSpec (sameSnd b cant)+    | otherwise =+        ErrorSpec+          ( NE.fromList+              ["propagate (pair_ HOLE " ++ show b ++ ") has conformance failure on b", show (TypeSpec sc cant)]+          )++  propagateMemberSpec ProdFstW (Unary HOLE) es = cartesian (MemberSpec es) TrueSpec+  propagateMemberSpec ProdSndW (Unary HOLE) es = cartesian TrueSpec (MemberSpec es)+  propagateMemberSpec ProdW (a :>: HOLE) es =+    case (nub (sameFst a (NE.toList es))) of+      (w : ws) -> MemberSpec (w :| ws)+      [] ->+        ErrorSpec $+          NE.fromList+            [ "propagate (pair_ HOLE " ++ show a ++ ") on (MemberSpec " ++ show (NE.toList es)+            , "Where " ++ show a ++ " does not appear as the fst component of anything in the MemberSpec."+            ]+  propagateMemberSpec ProdW (HOLE :<: b) es =+    case (nub (sameSnd b (NE.toList es))) of+      (w : ws) -> MemberSpec (w :| ws)+      [] ->+        ErrorSpec $+          NE.fromList+            [ "propagate (pair_ HOLE " ++ show b ++ ") on (MemberSpec " ++ show (NE.toList es)+            , "Where " ++ show b ++ " does not appear as the snd component of anything in the MemberSpec."+            ]++  rewriteRules ProdFstW ((pairView -> Just (x, _)) :> Nil) Evidence = Just x+  rewriteRules ProdSndW ((pairView -> Just (_, y)) :> Nil) Evidence = Just y+  rewriteRules _ _ _ = Nothing++  mapTypeSpec ProdFstW (Cartesian s _) = s+  mapTypeSpec ProdSndW (Cartesian _ s) = s++-- | `fst` on `Prod`+prodFst_ :: (HasSpec a, HasSpec b) => Term (Prod a b) -> Term a+prodFst_ = appTerm ProdFstW++-- | `snd` on `Prod`+prodSnd_ :: (HasSpec a, HasSpec b) => Term (Prod a b) -> Term b+prodSnd_ = appTerm ProdSndW++-- | `(,)` on `Prod`+prod_ :: (HasSpec a, HasSpec b) => Term a -> Term b -> Term (Prod a b)+prod_ = appTerm ProdW++sameFst :: Eq a1 => a1 -> [Prod a1 a2] -> [a2]+sameFst a ps = [b | Prod a' b <- ps, a == a']++sameSnd :: Eq a1 => a1 -> [Prod a2 a1] -> [a2]+sameSnd b ps = [a | Prod a b' <- ps, b == b']++-- | Pattern for `prod_`+pattern Product ::+  forall c.+  () =>+  forall a b.+  ( c ~ Prod a b+  , AppRequires ProdW '[a, b] (Prod a b)+  ) =>+  Term a ->+  Term b ->+  Term c+pattern Product x y <- (App (getWitness -> Just ProdW) (x :> y :> Nil))++-- ================================================================+-- The TypeSpec for List. Used in the HasSpec instance for Lists+-- ================================================================++-- | Generalized `length` function+sizeOf_ :: (HasSpec a, Sized a) => Term a -> Term Integer+sizeOf_ = curryList (App SizeOfW)++-- | Because Sizes should always be >= 0, We provide this alternate generator+--   that can be used to replace (genFromSpecT @Integer), to ensure this important property+genFromSizeSpec :: MonadGenError m => Specification Integer -> GenT m Integer+genFromSizeSpec integerSpec = genFromSpecT (integerSpec <> geqSpec 0)++-- =====================================================================+-- Syntax, Semantics and Logic instances for function symbols on List++-- ==============  Helper functions++-- ================+-- Sized+-- ================++type SizeSpec = NumSpec Integer++-- | The things we need to talk about the `sizeOf_` a thing+class Sized t where+  sizeOf :: t -> Integer+  default sizeOf :: (HasSimpleRep t, Sized (SimpleRep t)) => t -> Integer+  sizeOf = sizeOf . toSimpleRep++  liftSizeSpec :: HasSpec t => SizeSpec -> [Integer] -> Specification t+  default liftSizeSpec ::+    ( Sized (SimpleRep t)+    , GenericRequires t+    ) =>+    SizeSpec ->+    [Integer] ->+    Specification t+  liftSizeSpec sz cant = fromSimpleRepSpec $ liftSizeSpec sz cant++  liftMemberSpec :: HasSpec t => [Integer] -> Specification t+  default liftMemberSpec ::+    ( Sized (SimpleRep t)+    , GenericRequires t+    ) =>+    [Integer] ->+    Specification t+  liftMemberSpec = fromSimpleRepSpec . liftMemberSpec++  sizeOfTypeSpec :: HasSpec t => TypeSpec t -> Specification Integer+  default sizeOfTypeSpec ::+    ( HasSpec (SimpleRep t)+    , Sized (SimpleRep t)+    , TypeSpec t ~ TypeSpec (SimpleRep t)+    ) =>+    TypeSpec t ->+    Specification Integer+  sizeOfTypeSpec = sizeOfTypeSpec @(SimpleRep t)++-- =============================================================+-- All Foldy class instances are over Numbers (so far).+-- Foldy class requires higher order functions, so here they are.+-- Note this is a new witness type, different from BaseW+-- but serving the same purpose. Note it can take Witnesses from+-- other classes as inputs. See ComposeW+-- ==============================================================++-- | Function symbols for basic higher-order functions+data FunW (dom :: [Type]) (rng :: Type) where+  IdW :: forall a. FunW '[a] a+  ComposeW ::+    forall b t1 t2 a r.+    ( AppRequires t1 '[b] r+    , AppRequires t2 '[a] b+    , HasSpec b+    ) =>+    t1 '[b] r ->+    t2 '[a] b ->+    FunW '[a] r++instance Semantics FunW where+  semantics IdW = id+  semantics (ComposeW f g) = semantics f . semantics g++instance Syntax FunW++instance Show (FunW dom rng) where+  show IdW = "id_"+  show (ComposeW x y) = "(compose_ " ++ show x ++ " " ++ show y ++ ")"++instance Eq (FunW dom rng) where+  IdW == IdW = True+  ComposeW f f' == ComposeW g g' = compareWit f g && compareWit f' g'+  _ == _ = False++compareWit ::+  forall t1 bs1 r1 t2 bs2 r2.+  (AppRequires t1 bs1 r1, AppRequires t2 bs2 r2) =>+  t1 bs1 r1 ->+  t2 bs2 r2 ->+  Bool+compareWit x y = case (eqT @t1 @t2, eqT @bs1 @bs2, eqT @r1 @r2) of+  (Just Refl, Just Refl, Just Refl) -> x == y+  _ -> False++-- ===================================+-- Logic instances for IdW and ComposeW++instance Logic FunW where+  propagate IdW (Unary HOLE) = id+  propagate (ComposeW f g) (Unary HOLE) = propagate g (Unary HOLE) . propagate f (Unary HOLE)++  mapTypeSpec IdW ts = typeSpec ts+  mapTypeSpec (ComposeW g h) ts = mapSpec g . mapSpec h $ typeSpec ts++  -- Note we need the Evidence to apply App to f, and to apply App to g+  rewriteRules (ComposeW f g) (x :> Nil) Evidence = Just $ App f (App g (x :> Nil) :> Nil)+  rewriteRules IdW (x :> Nil) Evidence = Just x++-- =======================================================+-- The Foldy class instances for Numbers+-- =======================================================++-- | Invert a `Fun` and combine it with a `Specification` for the input to+-- generate a value+genInverse ::+  ( MonadGenError m+  , HasSpec a+  , HasSpec b+  ) =>+  Fun '[a] b ->+  Specification a ->+  b ->+  GenT m a+genInverse (Fun f) argS x =+  let argSpec' = argS <> propagate f (HOLE :? Nil) (equalSpec x)+   in explainNE+        ( NE.fromList+            [ "genInverse"+            , "  f = " ++ show f+            , show $ "  argS =" <+> pretty argS+            , "  x = " ++ show x+            , show $ "  argSpec' =" <+> pretty argSpec'+            ]+        )+        $ genFromSpecT argSpec'++-- | Function symbols for generalized `length` and `Data.Set.size` functions.+-- Used to implement `sizeOf_`.+data SizeW (dom :: [Type]) rng :: Type where+  SizeOfW :: (Sized n, HasSpec n) => SizeW '[n] Integer++deriving instance Eq (SizeW ds r)++instance Show (SizeW d r) where+  show SizeOfW = "sizeOf_"++instance Semantics SizeW where+  semantics SizeOfW = sizeOf -- From the Sized class.++instance Syntax SizeW++instance Logic SizeW where+  propagateTypeSpec SizeOfW (Unary HOLE) ts cant = liftSizeSpec ts cant++  propagateMemberSpec SizeOfW (Unary HOLE) es = liftMemberSpec (NE.toList es)++  mapTypeSpec (SizeOfW :: SizeW '[a] b) ts =+    constrained $ \x ->+      unsafeExists $ \x' -> Assert (x ==. sizeOf_ x') <> toPreds @a x' ts++-- ======================================++-- | A spec for a positive non-empty range+rangeSize :: Integer -> Integer -> SizeSpec+rangeSize a b | a < 0 || b < 0 = error ("Negative Int in call to rangeSize: " ++ show a ++ " " ++ show b)+rangeSize a b = NumSpecInterval (Just a) (Just b)++-- | Constrain a number to be between two points+between :: (HasSpec a, TypeSpec a ~ NumSpec a) => a -> a -> Specification a+between lo hi = TypeSpec (NumSpecInterval (Just lo) (Just hi)) []++-- | The widest interval whose largest element is admitted by the original spec+maxSpec :: Specification Integer -> Specification Integer+maxSpec (ExplainSpec es s) = explainSpec es (maxSpec s)+maxSpec TrueSpec = TrueSpec+maxSpec s@(SuspendedSpec _ _) =+  constrained $ \x -> unsafeExists $ \y -> [y `satisfies` s, Explain (pure "maxSpec on SuspendedSpec") $ Assert (x <=. y)]+maxSpec (ErrorSpec xs) = ErrorSpec xs+maxSpec (MemberSpec xs) = leqSpec (maximum xs)+maxSpec (TypeSpec (NumSpecInterval _ hi) bad) = TypeSpec (NumSpecInterval Nothing hi) bad++-- | How to constrain the size of any type, with a Sized instance+hasSize :: (HasSpec t, Sized t) => SizeSpec -> Specification t+hasSize sz = liftSizeSpec sz []
+ src/Constrained/TypeErrors.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++-- | This module implementes this very neat little trick for observing when+-- type families are stuck https://blog.csongor.co.uk/report-stuck-families/+-- which allows us to report much better type errors when our generics tricks+-- fail.+module Constrained.TypeErrors (+  Computes,+  AssertComputes,+  AssertSpineComputes,+  module X,+) where++import Data.Kind+import GHC.TypeError as X++-- | The idea of this type family is that if `ty` evaluates to a type (other than Dummy which+-- we haven't exported) then `Computes ty (TE err)` will evaluate to `()` without+-- getting stuck and without expanding `TE` to `TypeError err`.+--+-- If, on the other hand, GHC gets stuck evaluating `ty` it will (hopefully) try to normalize+-- everything and (hopefully) end up with `Computes (TypeError err) ty` which in turn will cause+-- it to throw `err` as a type error.+--+-- Now, the important thing here is that you can't do `Computes _ _ = ()` because that doesn't+-- force the evaluation of `ty` and consequently doesn't end up with GHC wanting to report+-- that `Computes tyThatDoesntCompute (TE err)` fails and consequently normalizing `TE err`+-- and finally arriving at `TypeError err`.+type family Computes (ty :: k0) (err :: Constraint) (a :: k) :: k where+  Computes Dummy _ _ =+    TypeError+      (Text "This shouldn't be reachable because " :<>: ShowType Dummy :<>: Text " shouldn't be exported!")+  Computes (Dummy : as) _ _ =+    TypeError+      (Text "This shouldn't be reachable because " :<>: ShowType Dummy :<>: Text " shouldn't be exported!")+  Computes _ _ a = a++-- This is intentionally hidden in here to avoid any funny business+data Dummy++-- | Assert that type @ty` computes+type AssertComputes ty em = Computes ty (TypeError em) (() :: Constraint)++type family AssertSpineComputesF (help :: ErrorMessage) (xs :: [k]) (err :: ()) :: Constraint where+  AssertSpineComputesF _ '[] _ = ()+  AssertSpineComputesF help (_ : xs) err = AssertSpineComputes help xs++-- | Assert that the entire spine of a type-level list computes+type AssertSpineComputes help (xs :: [k]) =+  AssertSpineComputesF+    help+    xs+    ( TypeError+        ( Text "Type list computation is stuck on "+            :$$: Text "  "+              :<>: ShowType xs+            :$$: help+        )+    )
+ test/Constrained/GraphSpec.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}++module Constrained.GraphSpec where++import Constrained.Graph+import Data.Either+import Data.Set (Set)+import Data.Set qualified as Set+import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck++newtype Node = Node Int+  deriving (Ord, Eq)+  deriving (Show) via Int++instance Arbitrary Node where+  arbitrary = Node <$> choose (0, 20)+  shrink (Node n) = Node <$> shrink n++prop_arbitrary_reasonable_distribution :: Graph Node -> Property+prop_arbitrary_reasonable_distribution g =+  cover 60 (isRight $ topsort g) "has topsort" True++prop_no_dependencies_topsort :: Set Node -> Property+prop_no_dependencies_topsort = property . isRight . topsort . noDependencies++prop_subtract_topsort :: Graph Node -> Graph Node -> Property+prop_subtract_topsort g g' =+  isRight (topsort g) ==>+    isRight (topsort $ subtractGraph g g')++prop_subtract_union :: Graph Node -> Graph Node -> Property+prop_subtract_union g g0' =+  let g' = subtractGraph g g0'+   in subtractGraph g g' <> g' === g++prop_subtract_keeps_nodes :: Graph Node -> Graph Node -> Property+prop_subtract_keeps_nodes g g' = nodes (subtractGraph g g') === nodes g++prop_subtract_removes_edges :: Graph Node -> Graph Node -> Node -> Node -> Property+prop_subtract_removes_edges g g' x y =+  property $+    not+      ( dependsOn+          x+          y+          (subtractGraph (dependency x (Set.singleton y) <> g) $ dependency x (Set.singleton y) <> g')+      )++prop_union_commutes :: Graph Node -> Graph Node -> Property+prop_union_commutes g g' = g <> g' === g' <> g++prop_delete_topsort :: Graph Node -> Node -> Property+prop_delete_topsort g n =+  isRight (topsort g) ==>+    isRight (topsort $ deleteNode n g)++prop_op_topsort :: Graph Node -> Property+prop_op_topsort g =+  isRight (topsort g) === isRight (topsort $ opGraph g)++prop_trC_topsort :: Graph Node -> Property+prop_trC_topsort g =+  isRight (topsort g) === isRight (topsort $ transitiveClosure g)++prop_trC_opgraph_commute :: Graph Node -> Property+prop_trC_opgraph_commute g =+  transitiveClosure (opGraph g) === opGraph (transitiveClosure g)++prop_depends_grows :: Graph Node -> Graph Node -> Node -> Property+prop_depends_grows g g' n = property $ dependencies n g `Set.isSubsetOf` dependencies n (g <> g')++prop_transitive_dependencies :: Graph Node -> Node -> Property+prop_transitive_dependencies g n =+  transitiveDependencies n g === dependencies n (transitiveClosure g)++prop_topsort_all_nodes :: Graph Node -> Property+prop_topsort_all_nodes g =+  case topsort g of+    Left {} -> discard+    Right o -> Set.fromList o === nodes g++prop_topsort_sound :: Graph Node -> Property+prop_topsort_sound g =+  case topsort g of+    Left {} -> discard+    Right o -> property $ go o+  where+    go [] = True+    go (n : ns) = all (\n' -> not $ dependsOn n n' g) ns && go ns++prop_topsort_complete :: Graph Node -> Property+prop_topsort_complete g =+  isLeft (topsort g) === not (null $ findCycle g)++prop_find_cycle_sound :: Property+prop_find_cycle_sound =+  forAllShrink (mkGraph @Node <$> arbitrary) shrink $ \g ->+    let c = findCycle g+     in counterexample (show c) $ all (\(x, y) -> dependsOn x y g) (zip c (drop 1 $ cycle c))++prop_find_cycle_loops :: Property+prop_find_cycle_loops =+  forAllShrink (mkGraph @Node <$> arbitrary) shrink $ \g ->+    case findCycle g of+      [] -> property True+      c@(x : _) -> cover 40 True "found cycle" $ counterexample (show c) $ dependsOn (last c) x g++return []++tests :: Bool -> Spec+tests _nightly =+  describe "Graph tests" $+    sequence_ [prop n (checkCoverage $ withMaxSuccess 1000 p) | (n, p) <- $allProperties]
+ test/Constrained/Tests.hs view
@@ -0,0 +1,473 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module Constrained.Tests where++import Constrained.API.Extend+import Constrained.Examples.Basic+import Constrained.Examples.Either+import Constrained.Examples.Fold (+  Outcome (..),+  composeEvenSpec,+  composeOddSpec,+  evenSpec,+  listSumComplex,+  logishProp,+  oddSpec,+  pickProp,+  sum3,+  sum3WithLength,+  sumProp,+  sumProp2,+  testFoldSpec,+ )+import Constrained.Examples.List+import Constrained.Examples.Map+import Constrained.Examples.Set+import Constrained.Examples.Tree+import Constrained.SumList (narrowByFuelAndSize)+import Constrained.Test+import Control.Monad+import Data.Int+import qualified Data.List.NonEmpty as NE+import Data.Map (Map)+import Data.Set (Set)+import Data.Word+import GHC.Natural+import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck hiding (Args, Fun, forAll)++------------------------------------------------------------------------+-- Test suite+------------------------------------------------------------------------++testAll :: IO ()+testAll = hspec $ tests False++tests :: Bool -> Spec+tests nightly =+  describe "constrained" . modifyMaxSuccess (\ms -> if nightly then ms * 10 else ms) $ do+    testSpecNoShrink "twiceChooseSpec" twiceChooseSpec+    testSpecNoShrink "twiceChooseSpec" twiceChooseSpecInt+    testSpec "signumPositive" signumPositive+    testSpec "setOfPairLetSpec" setOfPairLetSpec+    testSpec "setPair" setPair+    testSpec "mapElemSpec" mapElemSpec+    testSpec "complicatedEither" complicatedEither+    testSpec "pairCant" pairCant+    testSpec "reifiesMultiple" reifiesMultiple+    testSpec "assertReal" assertReal+    testSpecNoShrink "chooseBackwards" chooseBackwards+    testSpecNoShrink "chooseBackwards'" chooseBackwards'+    testSpec "whenTrueExists" whenTrueExists+    testSpec "assertRealMultiple" assertRealMultiple+    testSpec "setSpec" setSpec+    testSpec "leqPair" leqPair+    testSpecNoShrink "listEmpty" listEmpty+    testSpec "compositionalSpec" compositionalSpec+    testSpec "simplePairSpec" simplePairSpec+    testSpec "trickyCompositional" trickyCompositional+    testSpec "emptyListSpec" emptyListSpec+    testSpec "eitherSpec" eitherSpec+    testSpec "maybeSpec" maybeSpec+    testSpecNoShrink "eitherSetSpec" eitherSetSpec+    testSpec "fooSpec" fooSpec+    testSpec "mapElemKeySpec" mapElemKeySpec+    testSpec "mapIsJust" mapIsJust+    -- NOTE: very slow to check in shrinking+    testSpecNoShrink "eitherKeys" eitherKeys+    testSpec "intSpec" intSpec+    testSpec "mapPairSpec" mapPairSpec+    testSpecNoShrink "mapEmptyDomainSpec" mapEmptyDomainSpec+    -- NOTE: this _can_ be shrunk, but it's incredibly expensive to do+    -- so and it's not obvious if there is a faster way without implementing+    -- more detailed shrinking of `SuspendedSpec`s+    testSpecNoShrink "setPairSpec" setPairSpec+    testSpec "fixedSetSpec" fixedSetSpec+    testSpecNoShrink "emptyEitherSpec" emptyEitherSpec+    testSpecNoShrink "emptyEitherMemberSpec" emptyEitherMemberSpec+    testSpec "setSingletonSpec" setSingletonSpec+    testSpec "pairSingletonSpec" pairSingletonSpec+    testSpec "eitherSimpleSetSpec" eitherSimpleSetSpec+    testSpecNoShrink "emptySetSpec" emptySetSpec+    testSpec "forAllAnySpec" forAllAnySpec+    testSpec "notSubsetSpec" notSubsetSpec+    testSpec "maybeJustSetSpec" maybeJustSetSpec+    testSpec "weirdSetPairSpec" weirdSetPairSpec+    testSpec "knownDomainMap" knownDomainMap+    testSpec "testRewriteSpec" testRewriteSpec+    testSpec "parallelLet" parallelLet+    testSpec "letExists" letExists+    testSpec "letExistsLet" letExistsLet+    testSpec "notSubset" notSubset+    testSpec "unionSized" unionSized+    testSpec "dependencyWeirdness" dependencyWeirdness+    testSpec "foldTrueCases" foldTrueCases+    testSpec "foldSingleCase" foldSingleCase+    testSpec "listSumPair" (listSumPair @Int)+    testSpec "parallelLetPair" parallelLetPair+    testSpec "mapSizeConstrained" mapSizeConstrained+    testSpec "isAllZeroTree" isAllZeroTree+    testSpec "noChildrenSameTree" noChildrenSameTree+    testSpec "isBST" isBST+    testSpecNoShrink "pairListError" pairListError+    testSpecNoShrink "listMustSizeIssue" listMustSizeIssue+    testSpec "successiveChildren" successiveChildren+    testSpec "successiveChildren8" successiveChildren8+    testSpecNoShrink "roseTreeList" roseTreeList+    testSpec "orPair" orPair+    testSpec "roseTreePairs" roseTreePairs+    testSpec "roseTreeMaybe" roseTreeMaybe+    testSpec "badTreeInteraction" badTreeInteraction+    testSpec "sumRange" sumRange+    testSpec "sumListBad" sumListBad+    testSpec "listExistsUnfree" listExistsUnfree+    testSpec "listSumShort" listSumShort+    testSpec "existsUnfree" existsUnfree+    testSpec "appendSize" appendSize+    testSpecNoShrink "appendSingleton" appendSingleton+    testSpec "singletonSubset" singletonSubset+    testSpec "reifyYucky" reifyYucky+    testSpec "fixedRange" fixedRange+    testSpec "rangeHint" rangeHint+    testSpec "basicSpec" basicSpec+    testSpec "canFollowLike" canFollowLike+    testSpec "ifElseBackwards" ifElseBackwards+    testSpecNoShrink "three" three+    testSpecNoShrink "three'" three'+    testSpecNoShrink "threeSpecific" threeSpecific+    testSpecNoShrink "threeSpecific'" threeSpecific'+    testSpecNoShrink "trueSpecUniform" trueSpecUniform+    testSpec "posNegDistr" posNegDistr+    testSpec "ifElseMany" ifElseMany+    testSpecNoShrink "propBack" propBack+    testSpecNoShrink "propBack'" propBack'+    testSpecNoShrink "propBack''" propBack''+    testSpec "complexUnion" complexUnion+    testSpec "unionBounded" unionBounded+    testSpec "elemSpec" elemSpec+    testSpec "lookupSpecific" lookupSpecific+    testSpec "mapRestrictedValues" mapRestrictedValues+    testSpec "mapRestrictedValuesThree" mapRestrictedValuesThree+    testSpec "mapRestrictedValuesBool" mapRestrictedValuesBool+    testSpec "mapSetSmall" mapSetSmall+    testSpecNoShrink "powersetPickOne" powersetPickOne+    testSpecNoShrink "appendSuffix" appendSuffix+    testSpecNoShrink "appendForAll" appendForAll+    testSpec "wtfSpec" wtfSpec+    numberyTests+    sizeTests+    numNumSpecTree+    sequence_+      [ testSpec ("intRangeSpec " ++ show i) (intRangeSpec i)+      | i <- [-1000, -100, -10, 0, 10, 100, 1000]+      ]+    describe "prop_conformEmpty" $ do+      prop "Int" $ prop_conformEmpty @Int+      prop "Set Int" $ prop_conformEmpty @(Set Int)+      prop "Map Int Int" $ prop_conformEmpty @(Map Int Int)+      prop "[Int]" $ prop_conformEmpty @[Int]+      prop "[(Int, Int)]" $ prop_conformEmpty @[(Int, Int)]+    prop "prop_univSound @BaseFn" $+      withMaxSuccess (if nightly then 100_000 else 10_000) $+        prop_univSound+    describe "prop_gen_sound" $ do+      modifyMaxSuccess (const $ if nightly then 10_000 else 1000) $ do+        prop "Int" $ prop_gen_sound @Int+        prop "Bool" $ prop_gen_sound @Bool+        prop "(Int, Int)" $ prop_gen_sound @(Int, Int)+        prop "Map Int Int" $ prop_gen_sound @(Map Int Int)+        prop "Set Int" $ prop_gen_sound @(Set Int)+        prop "Set Bool" $ prop_gen_sound @(Set Bool)+        prop "[Int]" $ prop_gen_sound @[Int]+        prop "[(Int, Int)]" $ prop_gen_sound @[(Int, Int)]+        prop "Map Bool Int" $ prop_gen_sound @(Map Bool Int)+      -- Slow tests that shouldn't run 1000 times+      xprop "Map (Set Int) Int" $ prop_gen_sound @(Map (Set Int) Int)+      prop "[(Set Int, Set Bool)]" $ prop_gen_sound @[(Set Int, Set Bool)]+      prop "Set (Set Bool)" $ prop_gen_sound @(Set (Set Bool))+    negativeTests+    prop "prop_noNarrowLoop" $ withMaxSuccess 1000 prop_noNarrowLoop+    conformsToSpecESpec+    foldWithSizeTests+    testSpec "evenSpec" (evenSpec @Int)+    testSpec "composeEvenSpec" composeEvenSpec+    testSpec "oddSpec" oddSpec+    testSpec "composeOddSpec" composeOddSpec+    testSpec "keysExample" keysExample+    testSpec "failingKVSpec" failingKVSpec++negativeTests :: Spec+negativeTests =+  describe "negative tests" $ do+    prop "reifies 10 x id" $+      expectFailure $+        prop_complete @Int $+          constrained $+            \x ->+              explanation (pure "The value is decided before reifies happens") $+                reifies 10 x id+    prop "reify overconstrained" $+      expectFailure $+        prop_complete @Int $+          constrained $ \x ->+            explanation+              (pure "You can't constrain the variable introduced by reify as its already decided")+              $ reify x id+              $ \y -> y ==. 10+    testSpecFail "singletonErrorTooMany" singletonErrorTooMany+    testSpecFail "singletonErrorTooLong" singletonErrorTooLong+    testSpecFail "appendTooLong" appendTooLong+    testSpecFail "overconstrainedAppend" overconstrainedAppend+    testSpecFail "overconstrainedPrefixes" overconstrainedPrefixes+    testSpecFail "overconstrainedSuffixes" overconstrainedSuffixes+    testSpecFail "appendForAllBad" appendForAllBad+    testSpecFail "manyInconsistent" manyInconsistent+    testSpecFail "manyInconsistentTrans" manyInconsistentTrans++testSpecFail :: HasSpec a => String -> Specification a -> Spec+testSpecFail s spec =+  prop (s ++ " fails") $+    expectFailure $+      withMaxSuccess 1 $+        prop_complete spec++numberyTests :: Spec+numberyTests =+  describe "numbery tests" $ do+    testNumberyListSpec "listSum" listSum+    testNumberyListSpecNoShrink "listSumForall" listSumForall+    testNumberyListSpec "listSumRange" listSumRange+    testNumberyListSpec "listSumRangeUpper" listSumRangeUpper+    testNumberyListSpec "listSumRangeRange" listSumRangeRange+    testNumberyListSpec "listSumElemRange" listSumElemRange++sizeTests :: Spec+sizeTests =+  describe "SizeTests" $ do+    testSpecNoShrink "sizeAddOrSub1" sizeAddOrSub1+    testSpecNoShrink "sizeAddOrSub2" sizeAddOrSub2+    testSpecNoShrink "sizeAddOrSub3" sizeAddOrSub3+    testSpecNoShrink "sizeAddOrSub4 returns Negative Size" sizeAddOrSub4+    testSpecNoShrink "sizeAddOrSub5" sizeAddOrSub5+    testSpecNoShrink "sizeAddOrSub5" sizeAddOrSub5+    testSpec "listSubSize" listSubSize+    testSpec "listSubSize" setSubSize+    testSpec "listSubSize" mapSubSize+    testSpec "hasSizeList" hasSizeList+    testSpec "hasSizeSet" hasSizeSet+    testSpec "hasSizeMap" hasSizeMap++testNumberyListSpec :: String -> (forall a. Numbery a => Specification [a]) -> Spec+testNumberyListSpec = testNumberyListSpec' True++testNumberyListSpecNoShrink :: String -> (forall a. Numbery a => Specification [a]) -> Spec+testNumberyListSpecNoShrink = testNumberyListSpec' False++testNumberyListSpec' :: Bool -> String -> (forall a. Numbery a => Specification [a]) -> Spec+testNumberyListSpec' withShrink n p =+  describe n $ do+    testSpec' withShrink "Integer" (p @Integer)+    testSpec' withShrink "Natural" (p @Natural)+    testSpec' withShrink "Word64" (p @Word64)+    testSpec' withShrink "Word32" (p @Word32)+    testSpec' withShrink "Word16" (p @Word16)+    testSpec' withShrink "Word8" (p @Word8)+    testSpec' withShrink "Int64" (p @Int64)+    testSpec' withShrink "Int32" (p @Int32)+    testSpec' withShrink "Int16" (p @Int16)+    testSpec' withShrink "Int8" (p @Int8)++testSpec :: HasSpec a => String -> Specification a -> Spec+testSpec = testSpec' True++testSpecNoShrink :: HasSpec a => String -> Specification a -> Spec+testSpecNoShrink = testSpec' False++testSpec' :: HasSpec a => Bool -> String -> Specification a -> Spec+testSpec' withShrink n s = do+  let checkCoverage' = checkCoverageWith stdConfidence {certainty = 1_000_000}+  describe n $ do+    prop "prop_sound" $+      within 10_000_000 $+        checkCoverage' $+          prop_sound s+    prop "prop_constrained_satisfies_sound" $+      within 10_000_000 $+        checkCoverage' $+          prop_constrained_satisfies_sound s++    prop "prop_constrained_explained" $+      within 10_000_0000 $+        checkCoverage' $+          prop_constrained_explained s++#if MIN_VERSION_QuickCheck(2, 15, 0)+    when withShrink $+      prop "prop_shrink_sound" $+        discardAfter 100_000 $+          checkCoverage' $+            prop_shrink_sound s+#endif++------------------------------------------------------------------------+-- Test properties of the instance Num (NumSpec Integer)+------------------------------------------------------------------------++-- | When we multiply intervals, we get a bounding box, around the possible values.+--   When the intervals have infinities, the bounding box can be very loose. In fact the+--   order in which we multiply intervals with infinities can affect how loose the bounding box is.+--   So ((NegInf, n) * (a, b)) * (c,d)  AND  (NegInf, n) * ((a, b) * (c,d)) may have different bounding boxes+--   To test the associative laws we must have no infinities, and then the associative law will hold.+noInfinity :: Gen (NumSpec Integer)+noInfinity = do+  lo <- arbitrary+  hi <- suchThat arbitrary (> lo)+  pure $ NumSpecInterval (Just lo) (Just hi)++plusNegate :: NumSpec Integer -> NumSpec Integer -> Property+plusNegate x y = x - y === x + negate y++commutesNumSpec :: NumSpec Integer -> NumSpec Integer -> Property+commutesNumSpec x y = x + y === y + x++assocNumSpec :: NumSpec Integer -> NumSpec Integer -> NumSpec Integer -> Property+assocNumSpec x y z = x + (y + z) === (x + y) + z++commuteTimes :: NumSpec Integer -> NumSpec Integer -> Property+commuteTimes x y = x * y === y * x++assocNumSpecTimes :: Gen Property+assocNumSpecTimes = do+  x <- noInfinity+  y <- noInfinity+  z <- noInfinity+  pure (x * (y * z) === (x * y) * z)++negNegate :: NumSpec Integer -> Property+negNegate x = x === negate (negate x)++scaleNumSpec :: NumSpec Integer -> Property+scaleNumSpec y = y + y === 2 * y++scaleOne :: NumSpec Integer -> Property+scaleOne y = y === 1 * y++numNumSpecTree :: Spec+numNumSpecTree =+  describe "Num (NumSpec Integer) properties" $+    modifyMaxSuccess (const 10000) $ do+      prop "plusNegate(x - y == x + negate y)" plusNegate+      prop "scaleNumSpec(y + y = 2 * y)" scaleNumSpec+      prop "scaleOne(y = 1 * y)" scaleOne+      prop "negNagate(x = x == negate (negate x))" negNegate+      prop "commutesNumSpec(x+y = y+x)" commutesNumSpec+      prop "assocNumSpec(x+(y+z) == (x+y)+z)" assocNumSpec+      prop "assocNumSpecTimes(x*(y*z) == (x*y)*z)" assocNumSpecTimes+      prop "commuteTimes" commuteTimes++------------------------------------------------------------------------+-- Tests for `hasSize`+------------------------------------------------------------------------++hasSizeList :: Specification [Int]+hasSizeList = hasSize (rangeSize 0 4)++hasSizeSet :: Specification (Set Int)+hasSizeSet = hasSize (rangeSize 1 3)++hasSizeMap :: Specification (Map Int Int)+hasSizeMap = hasSize (rangeSize 1 3)++------------------------------------------------------------------------+-- Tests for narrowing+------------------------------------------------------------------------++prop_noNarrowLoop :: Int -> Int -> Specification Int -> Specification Int -> Property+prop_noNarrowLoop f s eSpec fSpec =+  -- Make sure the fuel is non-negative+  f >= 0 ==>+    discardAfter 100_000 $+      narrowByFuelAndSize f s (eSpec, fSpec) `seq`+        property True++-- | The test succeeds if conformsToSpec and conformsToSpecE both conform, or both fail to conform.+--   We collect answers by specType (ErrorSpec, MemberSpec, SuspendedSpec, ...) and whether+--   they both conform, or they both fail to conform.+conformsToSpecETest :: forall a. HasSpec a => a -> Specification a -> Property+conformsToSpecETest a speca =+  let resultE = conformsToSpecE a speca (pure ("ConformsToSpecETest " ++ show a ++ " " ++ show speca))+   in if conformsToSpec a speca+        then case resultE of+          Nothing -> property (collect (specType speca ++ " both conform") True)+          Just xs -> counterexample (unlines (NE.toList xs)) False+        else case resultE of+          Nothing ->+            counterexample ("conformstoSpec returns False, but conformsToSpecE returns no explanations") False+          Just _ -> property (collect (specType speca ++ " both fail to conform") True)++conformsToSpecESpec :: Spec+conformsToSpecESpec =+  describe "Testing alignment of conformsToSpec and conformsToSpecE" $+    modifyMaxSuccess (const 1000) $ do+      prop "Int" (conformsToSpecETest @Int)+      prop "Word64" (conformsToSpecETest @Word64)+      prop "Bool" (conformsToSpecETest @Bool)+      prop "[Int]" (conformsToSpecETest @[Int])+      prop "(Int,Bool)" (conformsToSpecETest @(Int, Bool))+      prop "Set Integer" (conformsToSpecETest @(Set Integer))+      prop "Set[Int]" (conformsToSpecETest @(Set [Int]))+      prop "Map Int Int" (conformsToSpecETest @(Map Int Int))++-- ======================================================================+-- Test for use of Fold with size annotations++foldWithSizeTests :: Spec+foldWithSizeTests = do+  describe "Summation tests with size. " $ do+    prop "logish is sound" logishProp+    prop "small odd/even tests" pickProp+    prop "negative small" $ sumProp (-1000) 100 TrueSpec (-400 :: Int) 4 Succeed+    prop "negative sum too small" $ sumProp (-1000) 0 TrueSpec (-8002 :: Int) 4 Fail+    prop "negative large" $ sumProp (-60000 :: Int) 0 TrueSpec (-1000) 4 Succeed+    prop "(between 50 60) small enough" $ sumProp 1 10 (between 50 60) (200 :: Int) 4 Succeed+    prop "(between 50 60) too large" $ sumProp 1 10 (between 50 60) (400 :: Int) 4 Fail+    prop "(count 2) large is fast" $ sumProp 1 5000000 TrueSpec (5000000 :: Int) 2 Succeed+    prop "(count 5) large is fast" $ sumProp 1 5000000 TrueSpec (5000000 :: Int) 5 Succeed+    prop "even succeeds on even" $ sumProp2 1 50000 ("even", even) (45876 :: Int) 5 Succeed+    prop "even succeeds on even spec" $ sumProp 1 50000 evenSpec (45876 :: Int) 5 Succeed+    prop "even fails on odd total, odd count" $ sumProp 1 50000 evenSpec (45875 :: Int) 3 Fail+    prop "odd fails on odd total, even count" $ sumProp 1 50000 oddSpec (45878 :: Int) 3 Fail+    prop "odd succeeds on odd total, odd count" $ sumProp 1 50000 oddSpec (45871 :: Int) 3 Succeed+    xprop "succeeds with large count" $+      withMaxSuccess 100 (sumProp 1 1500567 TrueSpec (1500567 :: Int) 20 Succeed)+    prop "sum3 is sound" $ prop_constrained_satisfies_sound sum3+    prop "(sum3WithLength 3) is sound" $ prop_constrained_satisfies_sound (sum3WithLength 3)+    prop "(sum3WithLength 4) is sound" $ prop_constrained_satisfies_sound (sum3WithLength 4)+    prop "(sum3WithLength 7) is sound" $ prop_constrained_satisfies_sound (sum3WithLength 7)+    prop "listSum is sound" $ prop_constrained_satisfies_sound (listSum @Int)+    prop "listSumPair is sound" $ prop_constrained_satisfies_sound (listSumPair @Word64)+    -- This, by design, will fail for inputs greater than 7+    prop "listSumComplex is sound" $ prop_constrained_satisfies_sound (listSumComplex @Integer 7)+    prop "All sizes are negative" $+      testFoldSpec @Int (between (-5) (-2)) evenSpec (MemberSpec (pure 100)) Fail+    prop "Only some sizes are negative" $+      testFoldSpec @Int (between (-5) 0) evenSpec (MemberSpec (pure 100)) Fail+    prop "total and count can only be 0 in Word type" $+      testFoldSpec @Word64 (between 0 0) evenSpec (MemberSpec (pure 0)) Succeed+    prop "something of size 2, can add to 0 in type with negative values." $+      testFoldSpec @Int (between 2 2) (between (-10) 10) (MemberSpec (pure 0)) Succeed+    prop "TEST listSum" $ prop_constrained_satisfies_sound (listSum @Int)
+ test/Tests.hs view
@@ -0,0 +1,14 @@+module Main where++import Constrained.GraphSpec as Graph+import Constrained.Tests as Tests+import Data.Maybe+import System.Environment+import Test.Hspec++main :: IO ()+main = do+  nightly <- isJust <$> lookupEnv "NIGHTLY"+  hspec $ parallel $ do+    Tests.tests nightly+    Graph.tests nightly