diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3 @@ +# Version history for `constrained-generators` + +## This package is not being released yet. diff --git a/constrained-generators.cabal b/constrained-generators.cabal new file mode 100644 --- /dev/null +++ b/constrained-generators.cabal @@ -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 diff --git a/examples/Constrained/Examples.hs b/examples/Constrained/Examples.hs new file mode 100644 --- /dev/null +++ b/examples/Constrained/Examples.hs @@ -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 diff --git a/examples/Constrained/Examples/Basic.hs b/examples/Constrained/Examples/Basic.hs new file mode 100644 --- /dev/null +++ b/examples/Constrained/Examples/Basic.hs @@ -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) diff --git a/examples/Constrained/Examples/BinTree.hs b/examples/Constrained/Examples/BinTree.hs new file mode 100644 --- /dev/null +++ b/examples/Constrained/Examples/BinTree.hs @@ -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 diff --git a/examples/Constrained/Examples/CheatSheet.hs b/examples/Constrained/Examples/CheatSheet.hs new file mode 100644 --- /dev/null +++ b/examples/Constrained/Examples/CheatSheet.hs @@ -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 diff --git a/examples/Constrained/Examples/Either.hs b/examples/Constrained/Examples/Either.hs new file mode 100644 --- /dev/null +++ b/examples/Constrained/Examples/Either.hs @@ -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) + ] diff --git a/examples/Constrained/Examples/Fold.hs b/examples/Constrained/Examples/Fold.hs new file mode 100644 --- /dev/null +++ b/examples/Constrained/Examples/Fold.hs @@ -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 + ) diff --git a/examples/Constrained/Examples/List.hs b/examples/Constrained/Examples/List.hs new file mode 100644 --- /dev/null +++ b/examples/Constrained/Examples/List.hs @@ -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] + ] diff --git a/examples/Constrained/Examples/ManualExamples.hs b/examples/Constrained/Examples/ManualExamples.hs new file mode 100644 --- /dev/null +++ b/examples/Constrained/Examples/ManualExamples.hs @@ -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] diff --git a/examples/Constrained/Examples/Map.hs b/examples/Constrained/Examples/Map.hs new file mode 100644 --- /dev/null +++ b/examples/Constrained/Examples/Map.hs @@ -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) + ] diff --git a/examples/Constrained/Examples/Set.hs b/examples/Constrained/Examples/Set.hs new file mode 100644 --- /dev/null +++ b/examples/Constrained/Examples/Set.hs @@ -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]] + ] diff --git a/examples/Constrained/Examples/Tree.hs b/examples/Constrained/Examples/Tree.hs new file mode 100644 --- /dev/null +++ b/examples/Constrained/Examples/Tree.hs @@ -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 + ] diff --git a/src/Constrained/API.hs b/src/Constrained/API.hs new file mode 100644 --- /dev/null +++ b/src/Constrained/API.hs @@ -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 diff --git a/src/Constrained/API/Extend.hs b/src/Constrained/API/Extend.hs new file mode 100644 --- /dev/null +++ b/src/Constrained/API/Extend.hs @@ -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 diff --git a/src/Constrained/AbstractSyntax.hs b/src/Constrained/AbstractSyntax.hs new file mode 100644 --- /dev/null +++ b/src/Constrained/AbstractSyntax.hs @@ -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 diff --git a/src/Constrained/Base.hs b/src/Constrained/Base.hs new file mode 100644 --- /dev/null +++ b/src/Constrained/Base.hs @@ -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 diff --git a/src/Constrained/Conformance.hs b/src/Constrained/Conformance.hs new file mode 100644 --- /dev/null +++ b/src/Constrained/Conformance.hs @@ -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 diff --git a/src/Constrained/Core.hs b/src/Constrained/Core.hs new file mode 100644 --- /dev/null +++ b/src/Constrained/Core.hs @@ -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' diff --git a/src/Constrained/DependencyInjection.hs b/src/Constrained/DependencyInjection.hs new file mode 100644 --- /dev/null +++ b/src/Constrained/DependencyInjection.hs @@ -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 diff --git a/src/Constrained/Env.hs b/src/Constrained/Env.hs new file mode 100644 --- /dev/null +++ b/src/Constrained/Env.hs @@ -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] diff --git a/src/Constrained/FunctionSymbol.hs b/src/Constrained/FunctionSymbol.hs new file mode 100644 --- /dev/null +++ b/src/Constrained/FunctionSymbol.hs @@ -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 diff --git a/src/Constrained/GenT.hs b/src/Constrained/GenT.hs new file mode 100644 --- /dev/null +++ b/src/Constrained/GenT.hs @@ -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 diff --git a/src/Constrained/Generation.hs b/src/Constrained/Generation.hs new file mode 100644 --- /dev/null +++ b/src/Constrained/Generation.hs @@ -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 diff --git a/src/Constrained/Generic.hs b/src/Constrained/Generic.hs new file mode 100644 --- /dev/null +++ b/src/Constrained/Generic.hs @@ -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`. +-- ==================================================================== diff --git a/src/Constrained/Graph.hs b/src/Constrained/Graph.hs new file mode 100644 --- /dev/null +++ b/src/Constrained/Graph.hs @@ -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 diff --git a/src/Constrained/List.hs b/src/Constrained/List.hs new file mode 100644 --- /dev/null +++ b/src/Constrained/List.hs @@ -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 diff --git a/src/Constrained/NumOrd.hs b/src/Constrained/NumOrd.hs new file mode 100644 --- /dev/null +++ b/src/Constrained/NumOrd.hs @@ -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 diff --git a/src/Constrained/PrettyUtils.hs b/src/Constrained/PrettyUtils.hs new file mode 100644 --- /dev/null +++ b/src/Constrained/PrettyUtils.hs @@ -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)) diff --git a/src/Constrained/Properties.hs b/src/Constrained/Properties.hs new file mode 100644 --- /dev/null +++ b/src/Constrained/Properties.hs @@ -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 diff --git a/src/Constrained/Spec/List.hs b/src/Constrained/Spec/List.hs new file mode 100644 --- /dev/null +++ b/src/Constrained/Spec/List.hs @@ -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) diff --git a/src/Constrained/Spec/Map.hs b/src/Constrained/Spec/Map.hs new file mode 100644 --- /dev/null +++ b/src/Constrained/Spec/Map.hs @@ -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 diff --git a/src/Constrained/Spec/Set.hs b/src/Constrained/Spec/Set.hs new file mode 100644 --- /dev/null +++ b/src/Constrained/Spec/Set.hs @@ -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 diff --git a/src/Constrained/Spec/SumProd.hs b/src/Constrained/Spec/SumProd.hs new file mode 100644 --- /dev/null +++ b/src/Constrained/Spec/SumProd.hs @@ -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) diff --git a/src/Constrained/Spec/Tree.hs b/src/Constrained/Spec/Tree.hs new file mode 100644 --- /dev/null +++ b/src/Constrained/Spec/Tree.hs @@ -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 diff --git a/src/Constrained/SumList.hs b/src/Constrained/SumList.hs new file mode 100644 --- /dev/null +++ b/src/Constrained/SumList.hs @@ -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)) + +-- ===================================================================== diff --git a/src/Constrained/Syntax.hs b/src/Constrained/Syntax.hs new file mode 100644 --- /dev/null +++ b/src/Constrained/Syntax.hs @@ -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) diff --git a/src/Constrained/Test.hs b/src/Constrained/Test.hs new file mode 100644 --- /dev/null +++ b/src/Constrained/Test.hs @@ -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 diff --git a/src/Constrained/TheKnot.hs b/src/Constrained/TheKnot.hs new file mode 100644 --- /dev/null +++ b/src/Constrained/TheKnot.hs @@ -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 [] diff --git a/src/Constrained/TypeErrors.hs b/src/Constrained/TypeErrors.hs new file mode 100644 --- /dev/null +++ b/src/Constrained/TypeErrors.hs @@ -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 + ) + ) diff --git a/test/Constrained/GraphSpec.hs b/test/Constrained/GraphSpec.hs new file mode 100644 --- /dev/null +++ b/test/Constrained/GraphSpec.hs @@ -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] diff --git a/test/Constrained/Tests.hs b/test/Constrained/Tests.hs new file mode 100644 --- /dev/null +++ b/test/Constrained/Tests.hs @@ -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) diff --git a/test/Tests.hs b/test/Tests.hs new file mode 100644 --- /dev/null +++ b/test/Tests.hs @@ -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