leancheck 1.0.2 → 1.0.4
raw patch · 10 files changed
+485/−211 lines, 10 files
Files
- .github/workflows/build.yml +89/−51
- Makefile +1/−0
- changelog.md +7/−0
- leancheck.cabal +5/−3
- mk/haskell.mk +6/−1
- src/Test/LeanCheck/Basic.hs +3/−3
- src/Test/LeanCheck/Derive.hs +69/−21
- stack.yaml +1/−1
- test/derive.hs +164/−80
- test/generic.hs +140/−51
.github/workflows/build.yml view
@@ -11,58 +11,66 @@ build-and-test: runs-on: ubuntu-latest steps:+ - run: git --version+ - run: make --version+ - run: ghc --version+ - run: cabal --version - - name: Cache ~/.cabal/packages+ - name: Check out repository+ uses: actions/checkout@v3++ # check out needs to happen before cache so that hashing works+ - name: Cache hash+ run: echo Cache hash = ${{ hashFiles('*.cabal') }}++ - name: Cache cabal (source) packages uses: actions/cache@v3 with:- path: ~/.cabal/packages+ path: |+ ~/.cabal/packages+ ~/.cache/cabal key: v1-${{ runner.os }}-cabal-packages-${{ hashFiles('*.cabal') }} restore-keys: v1-${{ runner.os }}-cabal-packages- - - name: Cache ~/.cabal and ~/.ghc+ - name: Cache installed cabal packages uses: actions/cache@v3 with: path: | ~/.cabal !~/.cabal/packages+ ~/.config/cabal+ ~/.local/state/cabal ~/.ghc key: v1-${{ runner.os }}-cabal-ghc-latest-${{ hashFiles('*.cabal') }}- restore-keys: v1-${{ runner.os }}-cabal-ghc-latest--- - run: du -hd3 ~/.cabal ~/.ghc || true-- - run: make --version+ restore-keys: v1-${{ runner.os }}-cabal-ghc-latest-${{ hashFiles('*.cabal') }}+ # restore with exact match has some versions of cabal have trouble updating - run: haddock --version || sudo apt-get install ghc-haddock- - run: ghc --version- - run: cabal --version- - run: haddock --version- - run: ghc-pkg list-- - name: Check out repository- uses: actions/checkout@v3+ # blank line+ # blank line for alignment with matrix scripts - - run: git --version+ - run: du -hd3 ~/.ghc ~/.cabal ~/.config/cabal ~/.cache/cabal ~/.local/state/cabal || true + - run: ghc-pkg list - run: make install-dependencies+ - run: ghc-pkg list - # 2023-07: some projects were failing with missing base for GHC 9.6.- # Here we compile through cabal only provisionally.- # - run: make- # - run: make test- # - run: make haddock+ - run: du -hd3 ~/.ghc ~/.cabal ~/.config/cabal ~/.cache/cabal ~/.local/state/cabal || true++ - run: make+ - run: make test+ - run: make haddock - run: make test-sdist- #- run: make test-via-cabal- - run: cabal configure --enable-tests --enable-benchmarks --ghc-options="-O0"- - run: cabal build- - run: cabal test- - run: cabal haddock+ - run: make test-via-cabal test-with-ghc: strategy:+ max-parallel: 6 matrix:+ # starting with 9.10, docker/_/haskell requires -bullseye as suffix ghc:+ - '9.10-bullseye' - '9.8' - '9.6' - '9.4'@@ -70,47 +78,56 @@ - '9.0' - '8.10' - '8.8'- - '8.6'- - '8.4'- - '8.2'- - '7.10' runs-on: ubuntu-latest needs: build-and-test container: haskell:${{ matrix.ghc }} steps:- - name: Cache ~/.cabal/packages+ - run: git --version || true # git is missing in some images+ - run: make --version || true # make is missing in some images+ - run: ghc --version+ - run: cabal --version++ - name: Check out repository+ uses: actions/checkout@v3++ # check out needs to happen before cache so that hashing works+ - name: Cache hash+ run: echo Cache hash = ${{ hashFiles('*.cabal') }}++ - name: Cache cabal (source) packages uses: actions/cache@v3 with:- path: ~/.cabal/packages+ path: |+ ~/.cabal/packages+ ~/.cache/cabal key: v1-${{ runner.os }}-cabal-packages-${{ hashFiles('*.cabal') }} restore-keys: v1-${{ runner.os }}-cabal-packages- - - name: Cache ~/.cabal and ~/.ghc+ - name: Cache installed cabal packages uses: actions/cache@v3 with: path: | ~/.cabal !~/.cabal/packages+ ~/.config/cabal+ ~/.local/state/cabal ~/.ghc key: v1-${{ runner.os }}-cabal-ghc-${{ matrix.ghc }}-${{ hashFiles('*.cabal') }}- restore-keys: v1-${{ runner.os }}-cabal-ghc-${{ matrix.ghc }}--- - run: du -hd3 ~/.cabal ~/.ghc || true+ restore-keys: v1-${{ runner.os }}-cabal-ghc-${{ matrix.ghc }}-${{ hashFiles('*.cabal') }}+ # restore with exact match has some versions of cabal have trouble updating - run: make --version || rm /etc/apt/sources.list.d/*.list # faster update - run: make --version || apt-get update - run: make --version || apt-get install make - - run: ghc --version- - run: cabal --version- - run: haddock --version- - run: ghc-pkg list-- - name: Check out repository- uses: actions/checkout@v3+ - run: du -hd3 ~/.ghc ~/.cabal ~/.config/cabal ~/.cache/cabal ~/.local/state/cabal || true + - run: ghc-pkg list - run: make install-dependencies+ - run: ghc-pkg list + - run: du -hd3 ~/.ghc ~/.cabal ~/.config/cabal ~/.cache/cabal ~/.local/state/cabal || true+ - run: make - run: make test - run: make haddock@@ -121,23 +138,44 @@ runs-on: ubuntu-latest needs: build-and-test steps:- - name: Setup Haskell's GHC and Cabal as required by current Stackage LTS- uses: haskell-actions/setup@v2- with: # lts-19.19- ghc-version: '9.0.2'- cabal-version: '3.4'+ - name: Check out repository+ uses: actions/checkout@v3 - - uses: actions/cache@v3+ # check out needs to happen before cache so that hashing works+ - name: Cache hash+ run: echo Cache hash = ${{ hashFiles('stack.yaml') }}++ - name: Cache stack folder+ uses: actions/cache@v3 with: path: ~/.stack key: v1-${{ runner.os }}-stack-${{ hashFiles('stack.yaml') }} restore-keys: v1-${{ runner.os }}-stack- + - name: Cache ghcup folder+ uses: actions/cache@v3+ with:+ path: |+ ~/.ghcup+ /usr/local/.ghcup/bin+ /usr/local/.ghcup/db+ /usr/local/.ghcup/ghc/9.4.8+ key: v1-${{ runner.os }}-ghcup-${{ hashFiles('stack.yaml') }}+ restore-keys: v1-${{ runner.os }}-ghcup-++ - name: Setup Haskell's GHC and Cabal as required by current Stackage LTS+ uses: haskell-actions/setup@v2+ with: # lts-21.25+ ghc-version: '9.4.8'+ cabal-version: '3.8'++ - run: du -hd2 ~/.stack ~/.ghcup /usr/local/.ghcup || true+ - run: stack --version - - name: Check out repository- uses: actions/checkout@v3 - run: make test-via-stack++ - run: du -hd2 ~/.stack ~/.ghcup /usr/local/.ghcup || true test-with-hugs: runs-on: ubuntu-latest
Makefile view
@@ -101,6 +101,7 @@ ./test/sdist test-via-cabal:+ cabal update # recent (2024) cabal refuses to build without a package list cabal configure --enable-tests --enable-benchmarks --ghc-options="$(GHCFLAGS) -O0" cabal build cabal test main
changelog.md view
@@ -2,6 +2,13 @@ ======================= +v1.0.4 (August 2025)+--------------------++* `Test.LeanCheck.Derive.deriveListable`: avoid empty tiers when possible+* minor Haddock documentation improvements++ v1.0.2 (January 2024) ---------------------
leancheck.cabal view
@@ -11,7 +11,7 @@ -- this cabal file too complicated. -- Rudy name: leancheck-version: 1.0.2+version: 1.0.4 synopsis: Enumerative property-based testing description: LeanCheck is a simple enumerative property-based testing library.@@ -70,7 +70,8 @@ , mk/install-on , stack.yaml , test/sdist-tested-with: GHC==9.8+tested-with: GHC==9.10+ , GHC==9.8 , GHC==9.6 , GHC==9.4 , GHC==9.2@@ -81,6 +82,7 @@ , GHC==8.4 , GHC==8.2 , GHC==7.10+ , GHC==7.8 , Hugs==2006.9 source-repository head@@ -90,7 +92,7 @@ source-repository this type: git location: https://github.com/rudymatela/leancheck- tag: v1.0.2+ tag: v1.0.4 library exposed-modules: Test.LeanCheck
mk/haskell.mk view
@@ -91,9 +91,14 @@ install-dependencies: if [ -n "$(INSTALL_DEPS)" ]; then \+ cd ~ && \ cabal update && \- $(CABAL_INSTALL) $(INSTALL_DEPS); \+ $(CABAL_INSTALL) $(INSTALL_DEPS) || true; \ fi+ # above, "|| true" is needed for cabal >= 3.10.2+ # Before, cabal would successfully skip installation+ # of already existing packages+ # cd ~ is needed so cabal installs only dependencies # haddock rules haddock: doc/index.html
src/Test/LeanCheck/Basic.hs view
@@ -15,12 +15,12 @@ -- * a 'Listable' 'Word' instance; -- * a 'Listable' 'Ratio' instance (consequently 'Listable' 'Rational'); -- * a 'Listable' 'Complex' instance;--- * 'Listable' 'Int8/16/32/64' instances;--- * 'Listable' 'Word8/16/32/64' instances;+-- * 'Listable' 'Int8', 'Int16', 'Int32' and 'Int64' instances;+-- * 'Listable' 'Word8', 'Word16', 'Word32' and 'Word64' instances; -- * 'Listable' instances for "Foreign.C" types; -- * a 'Listable' 'ExitCode' instance; -- * a 'Listable' 'GeneralCategory' instance;--- * 'Listable' 'Buffer/IO/SeekMode' instances;+-- * 'Listable' 'Buffer', 'IO' and 'SeekMode' instances; -- * the operators 'addWeight' and 'ofWeight'. -- -- The above includes all types defined in the Haskell 2010 Report
src/Test/LeanCheck/Derive.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE TemplateHaskell, CPP #-} -- | -- Module : Test.LeanCheck.Derive--- Copyright : (c) 2015-2024 Rudy Matela+-- Copyright : (c) 2015-2025 Rudy Matela -- License : 3-Clause BSD (see the file LICENSE) -- Maintainer : Rudy Matela <rudy@matela.com.br> --@@ -144,12 +144,25 @@ -- > instance Listable MyType where -- > tiers = $(deriveTiers) deriveTiers :: Name -> ExpQ-deriveTiers t = conse =<< typeConstructors t+deriveTiers t = conse =<< typeConstructorsWithArityAndRecursiveness t where- cone n as = do- (Just consN) <- lookupValueName $ "cons" ++ show (length as)- [| $(varE consN) $(conE n) |]- conse = foldr1 (\e1 e2 -> [| $e1 \/ $e2 |]) . map (uncurry cone)+ cone (n,arity,shouldReset) = do+ (Just consN) <- lookupValueName $ "cons" ++ show arity+ -- the shouldReset switch is necessary to avoid derivations+ -- where we end with an empty tier at the head of the tiers list+ -- such as a type homomorphic to Either+ -- on earlier LeanCheck versions, we never reset+ if shouldReset+ then [| reset ($(varE consN) $(conE n)) |]+ else [| $(varE consN) $(conE n) |]+ conse = foldr1 (\e1 e2 -> [| $e1 \/ $e2 |]) . map cone . arityReset+ -- computes whether we should reset some constructors and which+ arityReset nars+ -- if there's a constructor with 0 arguments, we don't need to reset+ | or [arity == 0 | (_,arity,_) <- nars] = [(name,arity,False) | (name,arity,_) <- nars]+ -- otherwise we reset constructors that are not recursive to avoid infinite loops+ | otherwise = [(name, arity, arity > 0 && not isRecursive) | (name,arity,isRecursive) <- nars]+ -- by reset here of course we mean removing the preceding empty tiers -- | Given a type 'Name', derives an expression to be placed as the result of -- 'list':@@ -174,22 +187,29 @@ typeConArgs t = do is <- isTypeSynonym t if is- then typeConTs `fmap` typeSynonymType t- else (nubMerges . map typeConTs . concatMap snd) `fmap` typeConstructors t- where- typeConTs :: Type -> [Name]- typeConTs (AppT t1 t2) = typeConTs t1 `nubMerge` typeConTs t2- typeConTs (SigT t _) = typeConTs t- typeConTs (VarT _) = []- typeConTs (ConT n) = [n]+ then subtypeNames `fmap` typeSynonymType t+ else (nubMerges . map subtypeNames . concatMap snd) `fmap` typeConstructors t++subtypeNames :: Type -> [Name]+subtypeNames (AppT t1 t2) = subtypeNames t1 `nubMerge` subtypeNames t2+subtypeNames (SigT t _) = subtypeNames t+subtypeNames (VarT _) = []+subtypeNames (ConT n) = [n] #if __GLASGOW_HASKELL__ >= 800- -- typeConTs (PromotedT n) = [n] ?- typeConTs (InfixT t1 n t2) = typeConTs t1 `nubMerge` typeConTs t2- typeConTs (UInfixT t1 n t2) = typeConTs t1 `nubMerge` typeConTs t2- typeConTs (ParensT t) = typeConTs t+-- subtypeNames (PromotedT n) = [n] ?+subtypeNames (InfixT t1 n t2) = subtypeNames t1 `nubMerge` subtypeNames t2+subtypeNames (UInfixT t1 n t2) = subtypeNames t1 `nubMerge` subtypeNames t2+subtypeNames (ParensT t) = subtypeNames t #endif- typeConTs _ = []+subtypeNames _ = [] +cascadingSubtypeNames :: [Type] -> Q [Name]+cascadingSubtypeNames t = do+ nss <- mapM (`typeConCascadingArgsThat` (\t -> return $ t `notElem` ns)) ns+ return $ nubMerges (ns:nss)+ where+ ns = nubMerges $ map subtypeNames t+ typeConArgsThat :: Name -> (Name -> Q Bool) -> Q [Name] t `typeConArgsThat` p = filterM p =<< typeConArgs t @@ -308,6 +328,7 @@ -- paired with the type arguments they take. -- the type arguments they take. --+-- > > :set -XTemplateHaskell -- > > putStrLn $(stringE . show =<< typeConstructors ''Bool) -- > [ ('False, []) -- > , ('True, [])@@ -334,14 +355,41 @@ cons (TyConI (DataD _ _ _ _ cs _)) = cs cons (TyConI (NewtypeD _ _ _ _ c _)) = [c] #endif- cons _ = errorOn "typeConstructors"- $ "neither newtype nor data: " ++ show t+ cons _ = [] normalize (NormalC n ts) = (n,map snd ts) normalize (RecC n ts) = (n,map trd ts) normalize (InfixC t1 n t2) = (n,[snd t1,snd t2]) normalize _ = errorOn "typeConstructors" $ "unexpected unhandled case when called with " ++ show t trd (x,y,z) = z++-- |+-- Given a type 'Name',+-- returns a list of its type constructors 'Name's+-- tupled with its arity and whether the constructor is recursive.+--+-- > > :set -XTemplateHaskell+-- > > data Lst a = a :- Lst a | Nil deriving Show+-- > > putStrLn $(stringE . show =<< typeConstructorsWithArityAndRecursiveness ''Lst)+-- > [ ('(:-),2,True)+-- > , ('Nil,0,False)+-- > ]+--+-- The recursive item does not work properly for some built-in types such as list+-- as they have special representations within TH.+--+-- > > putStrLn $(stringE . show =<< typeConstructorsWithArityAndRecursiveness ''[])+-- > [ ('[],0,False)+-- > , ('(:),2,False)+-- > ]+typeConstructorsWithArityAndRecursiveness :: Name -> Q [(Name,Int,Bool)]+typeConstructorsWithArityAndRecursiveness t = do+ cs <- typeConstructors t+ mapM ar cs+ where+ ar (n,ts) = do+ ns <- cascadingSubtypeNames ts+ return (n, length ts, t `elem` ns) -- | -- Is the given 'Name' a type synonym?
stack.yaml view
@@ -1,4 +1,4 @@-resolver: lts-19.19 # or ghc-9.0.2+resolver: lts-21.25 # or ghc-9.4.8 packages: - .
test/derive.hs view
@@ -1,66 +1,73 @@--- Copyright (c) 2015-2024 Rudy Matela.+-- Copyright (c) 2015-2025 Rudy Matela. -- Distributed under the 3-Clause BSD licence (see the file LICENSE). {-# LANGUAGE TemplateHaskell, CPP #-} import Test -- import Test.LeanCheck -- already exported by Test import Test.LeanCheck.Derive import Test.LeanCheck.Utils-import Data.List (sort)--data D0 = D0 deriving Show-newtype D1 a = D1 a deriving Show-data D2 a b = D2 a b deriving Show-data D3 a b c = D3 a b c deriving Show-data C1 a = C11 a | C10 deriving Show-data C2 a b = C22 a b | C21 a | C20 deriving Show-data I a b = a :+ b deriving Show+import Data.List (sort, isPrefixOf) -deriveListable ''D0-deriveListable ''D1-deriveListable ''D2-deriveListable ''D3-deriveListable ''C1-deriveListable ''C2-deriveListable ''I+-- replication of Haskell's built-in data types+-- in the order of the Haskell98 standard+-- https://www.haskell.org/onlinereport/basic.html+-- with Peanos as a numeric type.+data Peano = Zero | Succ Peano deriving (Eq, Ord, Show)+data Choice = Yes | No deriving (Eq, Ord, Show)+data Lst a = a :- Lst a | Nil deriving (Eq, Ord, Show)+data Duo a b = a :+ b deriving (Eq, Ord, Show)+data Unit = Unit deriving (Eq, Ord, Show)+data Perhaps a = Naught | Precisely a deriving (Eq, Ord, Show)+data Alternatively a b = Sinister a | Dexter b deriving (Eq, Ord, Show)+data Relation = Smaller | Same | Bigger deriving (Eq, Ord, Show)+data Trio a b c = Trio a b c deriving (Eq, Ord, Show) --- recursive datatypes-data Peano = Zero | Succ Peano deriving Show-data List a = a :- List a | Nil deriving Show-data Bush a = Bush a :-: Bush a | Leaf a deriving (Show, Eq)-data Tree a = Node (Tree a) a (Tree a) | Null deriving (Show, Eq)+infixr 5 :- deriveListable ''Peano-deriveListable ''List-deriveListable ''Bush+deriveListable ''Choice+deriveListable ''Lst+deriveListable ''Duo+deriveListable ''Unit+deriveListable ''Perhaps+deriveListable ''Alternatively+deriveListable ''Relation+deriveListable ''Trio++-- tree types+data Tree a = Node (Tree a) a (Tree a) | Null deriving (Eq, Ord, Show)+data Bush a = Bush a :-: Bush a | Leaf a deriving (Eq, Ord, Show)+ deriveListable ''Tree+deriveListable ''Bush --- Nested datatype cascade+-- mutually recursive types+data Mutual = Munil | Mutual CoMutual deriving (Eq, Ord, Show)+data CoMutual = CoMunil | CoMutual Mutual deriving (Eq, Ord, Show)++deriveListableCascading ''Mutual++-- newtypes, type synonyms, inner/outer+newtype Novel a = Novel a deriving (Eq, Ord, Show)+data Inner = I deriving (Eq, Ord, Show)+data Outer = O Inner deriving (Eq, Ord, Show)+type Nouter = Novel Outer+deriveListableCascading ''Nouter+++-- Complex nested datatype cascade data Nested = Nested N0 (N1 Int) (N2 Int Int) newtype N0 = R0 Int newtype N1 a = R1 a data N2 a b = R2 a b deriveListableCascading ''Nested --- Recursive nested datatype cascade+-- Complex recursive nested datatype cascade data RN = RN RN0 (RN1 Int) (RN2 Int RN) data RN0 = Nest0 Int | Recurse0 RN data RN1 a = Nest1 a | Recurse1 RN data RN2 a b = Nest2 a b | Recurse2 RN deriveListableCascading ''RN --- Type synonyms-data Pair a = Pair a a-type Alias a = Pair a--- deriveListable ''Alias -- this will fail-deriveListableCascading ''Alias-deriveListableIfNeeded ''Alias -- only works because instance already exists---- Nested type synonyms-data Triple a = Triple a a a-type Tralias a = Triple a-data Pairiple a = Pairriple (Tralias a) (Tralias a)-deriveListableCascading ''Pairiple- -- Those should have no effect (instance already exists): {- uncommenting those should generate warnings deriveListable ''Bool@@ -80,51 +87,113 @@ tests n = [ True - , map unD0 list =| n |= list- , map unD1 list =| n |= (list :: [Int])- , map unD2 list =| n |= (list :: [(Int,Int)])- , map unD3 list =| n |= (list :: [(Int,Int,Int)])+ , [ Zero+ , Succ Zero+ , Succ (Succ Zero)+ , Succ (Succ (Succ Zero))+ ] `isPrefixOf` list - , map unD1 list == (list :: [()])- , map unD2 list == (list :: [((),())])- , map unD3 list == (list :: [((),(),())])+ , [Yes, No] == list - , map unD1 list == (list :: [Bool])- , map unD2 list == (list :: [(Bool,Bool)])- , map unD3 list == (list :: [(Bool,Bool,Bool)])+ , [ Nil+ , Unit :- Nil+ , Unit :- Unit :- Nil+ , Unit :- Unit :- Unit :- Nil+ ] `isPrefixOf` list - , map peanoToNat list =| n |= list- , map listToList list =| n |= (list :: [[Bool]])- , map listToList list =| n |= (list :: [[Int]])+ , [ Nil+ , Zero :- Nil+ , Zero :- (Zero :- Nil)+ , Succ Zero :- Nil+ , Zero :- (Zero :- (Zero :- Nil))+ , Zero :- (Succ Zero :- Nil)+ ] `isPrefixOf` list - , mapT peanoToNat tiers =| 6 |= tiers- , mapT listToList tiers =| 6 |= (tiers :: [[ [Bool] ]])- , mapT listToList tiers =| 6 |= (tiers :: [[ [Int] ]])+ , list == [Yes :+ Yes, Yes :+ No, No :+ Yes, No :+ No] - , take 6 (list :: [Bush Bool])- == [ Leaf False- , Leaf True- , Leaf False :-: Leaf False- , Leaf False :-: Leaf True- , Leaf True :-: Leaf False- , Leaf True :-: Leaf True- ]+ , [ Zero :+ Zero+ , Zero :+ Succ Zero+ , Succ Zero :+ Zero+ , Zero :+ Succ (Succ Zero)+ , Succ Zero :+ Succ Zero+ ] `isPrefixOf` list - , take 6 (list :: [Tree Bool])- == [ Null- , Node Null False Null- , Node Null True Null- , Node Null False (Node Null False Null)- , Node Null False (Node Null True Null)- , Node Null True (Node Null False Null)- ]+ , list == [Unit] + , list == [Naught, Precisely Unit]++ , list == [Naught, Precisely Yes, Precisely No]++ , list == [Sinister Yes, Sinister No, Dexter Yes, Dexter No]++ , [ Sinister Zero+ , Dexter Zero+ , Sinister (Succ Zero)+ , Dexter (Succ Zero)+ , Sinister (Succ (Succ Zero))+ , Dexter (Succ (Succ Zero))+ ] `isPrefixOf` list++ , list == [Smaller, Same, Bigger]++ , list == [Trio Unit Unit Unit]++ , [ Null+ , Node Null False Null+ , Node Null True Null+ , Node Null False (Node Null False Null)+ , Node Null False (Node Null True Null)+ , Node Null True (Node Null False Null)+ ] `isPrefixOf` list++ , [ Leaf False+ , Leaf True+ , Leaf False :-: Leaf False+ , Leaf False :-: Leaf True+ , Leaf True :-: Leaf False+ , Leaf True :-: Leaf True+ ] `isPrefixOf` list++ , [ Munil+ , Mutual CoMunil+ , Mutual (CoMutual Munil)+ , Mutual (CoMutual (Mutual CoMunil))+ , Mutual (CoMutual (Mutual (CoMutual Munil)))+ , Mutual (CoMutual (Mutual (CoMutual (Mutual CoMunil))))+ ] `isPrefixOf` list++ , list == [I]+ , list == [O I]+ , list == [Novel (O I) :: Nouter]++ , map (\Unit -> ()) list =| n |= list++ , map (\(Novel x) -> x) list == (list :: [()])+ , map (\(Novel x) -> x) list == (list :: [Bool])+ , map (\(Novel x) -> x) list =| n |= (list :: [Int])++ , map (\(x :+ y) -> (x,y)) list == (list :: [((),())])+ , map (\(x :+ y) -> (x,y)) list == (list :: [(Bool,Bool)])+ , map (\(x :+ y) -> (x,y)) list =| n |= (list :: [(Int,Int)])++ , map (\(Trio x y z) -> (x,y,z)) list == (list :: [((),(),())])+ , map (\(Trio x y z) -> (x,y,z)) list == (list :: [(Bool,Bool,Bool)])+ , map (\(Trio x y z) -> (x,y,z)) list =| n |= (list :: [(Int,Int,Int)])++ , map peanoToNat list =| n |= list+ , map listLst list =| n |= (list :: [[Bool]])+ , map listLst list =| n |= (list :: [[Int]])++ , mapT peanoToNat tiers =| 6 |= tiers+ , mapT listLst tiers =| 6 |= (tiers :: [[ [Bool] ]])+ , mapT listLst tiers =| 6 |= (tiers :: [[ [Int] ]])+ , (tiers :: [[ Bool ]]) =| 6 |= $(deriveTiers ''Bool) , (tiers :: [[ [Int] ]]) =| 6 |= $(deriveTiers ''[]) , (tiers :: [[ [Bool] ]]) =| 6 |= $(deriveTiers ''[]) , (tiers :: [[ Maybe Int ]]) =| 6 |= $(deriveTiers ''Maybe) , (tiers :: [[ Maybe Bool ]]) =| 6 |= $(deriveTiers ''Maybe)- , ([]:tiers :: [[Either Bool Int]])+ , (tiers :: [[Either Bool Int]]) =$ map sort . take 6 $= $(deriveTiers ''Either) , (list :: [ Bool ]) =| n |= $(deriveList ''Bool)@@ -132,17 +201,32 @@ , (list :: [ [Bool] ]) =| n |= $(deriveList ''[]) , (list :: [ Maybe Int ]) =| n |= $(deriveList ''Maybe) , (list :: [ Maybe Bool ]) =| n |= $(deriveList ''Maybe)++ , map length (take 6 $ tiers :: [[Unit]]) == [1]+ , map length (take 6 $ tiers :: [[Novel Peano]]) == [1,1,1,1,1,1]+ , map length (take 6 $ tiers :: [[Duo Peano Peano]]) == [1,2,3,4,5,6]+ , map length (take 6 $ tiers :: [[Trio Int Int Int]]) == [1,3,6,10,15,21]+ , map length (take 6 $ tiers :: [[Novel Choice]]) == [2]+ , map length (take 6 $ tiers :: [[Duo Choice Choice]]) == [4]+ , map length (take 6 $ tiers :: [[Trio Choice Choice Choice]]) == [8]++ , map length (take 6 $ tiers :: [[ [Novel Int] ]]) == [1,1,2,4,8,16]+ , map length (take 6 $ tiers :: [[ [Novel Bool] ]]) == [1,2,4,8,16,32]+ , map length (take 6 $ tiers :: [[ [Duo Int Int] ]]) == [1,1,3,8,21,55]++ , map length (take 6 $ tiers :: [[ Lst Int ]]) == [1,1,2,4,8,16]+ , map length (take 6 $ tiers :: [[ Lst Bool ]]) == [1,2,4,8,16,32]++ , map length (take 6 $ tiers :: [[ Mutual ]]) == [1,1,1,1,1,1]+ , map length (take 6 $ tiers :: [[ Nouter ]]) == [1]+ , map length (take 6 $ tiers :: [[ Outer ]]) == [1]+ , map length (take 6 $ tiers :: [[ Inner ]]) == [1] ]- where- unD0 (D0) = ()- unD1 (D1 x) = (x)- unD2 (D2 x y) = (x,y)- unD3 (D3 x y z) = (x,y,z) peanoToNat :: Peano -> Nat peanoToNat Zero = 0 peanoToNat (Succ n) = 1 + peanoToNat n -listToList :: List a -> [a]-listToList Nil = []-listToList (x :- xs) = x : listToList xs+listLst :: Lst a -> [a]+listLst Nil = []+listLst (x :- xs) = x : listLst xs
test/generic.hs view
@@ -6,45 +6,59 @@ import Test.LeanCheck.Generic import Test.LeanCheck.Derive (deriveTiers) import Test.LeanCheck.Utils-import Data.List (sort)+import Data.List (sort, isPrefixOf) import GHC.Generics (Generic) -data D0 = D0 deriving (Eq, Show, Generic)-newtype D1 a = D1 a deriving (Eq, Show, Generic)-data D2 a b = D2 a b deriving (Eq, Show, Generic)-data D3 a b c = D3 a b c deriving (Eq, Show, Generic)-data C1 a = C11 a | C10 deriving (Eq, Show, Generic)-data C2 a b = C22 a b | C21 a | C20 deriving (Eq, Show, Generic)-data I a b = a :+ b deriving (Eq, Show, Generic)+-- replication of Haskell's built-in data types+-- in the order of the Haskell98 standard+-- https://www.haskell.org/onlinereport/basic.html+-- with Peanos as a numeric type.+data Peano = Zero | Succ Peano deriving (Eq, Ord, Show, Generic)+data Choice = Yes | No deriving (Eq, Ord, Show, Generic)+data Lst a = a :- Lst a | Nil deriving (Eq, Ord, Show, Generic)+data Duo a b = a :+ b deriving (Eq, Ord, Show, Generic)+data Unit = Unit deriving (Eq, Ord, Show, Generic)+data Perhaps a = Naught | Precisely a deriving (Eq, Ord, Show, Generic)+data Alternatively a b = Sinister a | Dexter b deriving (Eq, Ord, Show, Generic)+data Relation = Smaller | Same | Bigger deriving (Eq, Ord, Show, Generic)+data Trio a b c = Trio a b c deriving (Eq, Ord, Show, Generic) -instance Listable D0 where tiers = genericTiers+infixr 5 :- -instance Listable a => Listable (D1 a) where tiers = genericTiers+instance Listable Peano where tiers = genericTiers+instance Listable Choice where tiers = genericTiers+instance Listable a => Listable (Lst a) where tiers = genericTiers+instance (Listable a, Listable b) => Listable (Duo a b) where tiers = genericTiers+instance Listable Unit where tiers = genericTiers+instance Listable a => Listable (Perhaps a) where tiers = genericTiers+instance (Listable a, Listable b) => Listable (Alternatively a b) where tiers = genericTiers+instance Listable Relation where tiers = genericTiers+instance (Listable a, Listable b, Listable c) => Listable (Trio a b c) where tiers = genericTiers -instance (Listable a, Listable b)- => Listable (D2 a b) where tiers = genericTiers -instance (Listable a, Listable b, Listable c)- => Listable (D3 a b c) where tiers = genericTiers+-- recursive datatypes+data Tree a = Node (Tree a) a (Tree a) | Null deriving (Show, Eq, Generic)+data Bush a = Bush a :-: Bush a | Leaf a deriving (Show, Eq, Generic) -instance Listable a => Listable (C1 a) where tiers = genericTiers+instance Listable a => Listable (Tree a) where tiers = genericTiers+instance Listable a => Listable (Bush a) where tiers = genericTiers -instance (Listable a, Listable b)- => Listable (C2 a b) where tiers = genericTiers+-- mutually recursive types+data Mutual = Munil | Mutual CoMutual deriving (Eq, Ord, Show, Generic)+data CoMutual = CoMunil | CoMutual Mutual deriving (Eq, Ord, Show, Generic) -instance (Listable a, Listable b)- => Listable (I a b) where tiers = genericTiers+instance Listable Mutual where tiers = genericTiers+instance Listable CoMutual where tiers = genericTiers --- recursive datatypes-data Peano = Zero | Succ Peano deriving (Show, Generic)-data List a = a :- List a | Nil deriving (Show, Generic)-data Bush a = Bush a :-: Bush a | Leaf a deriving (Show, Eq, Generic)-data Tree a = Node (Tree a) a (Tree a) | Null deriving (Show, Eq, Generic)+-- newtypes, type synonyms, inner/outer+newtype Novel a = Novel a deriving (Eq, Ord, Show, Generic)+data Inner = I deriving (Eq, Ord, Show, Generic)+data Outer = O Inner deriving (Eq, Ord, Show, Generic)+type Nouter = Novel Outer -instance Listable Peano where tiers = genericTiers-instance Listable a => Listable (List a) where tiers = genericTiers-instance Listable a => Listable (Bush a) where tiers = genericTiers-instance Listable a => Listable (Tree a) where tiers = genericTiers+instance Listable a => Listable (Novel a) where tiers = genericTiers+instance Listable Inner where tiers = genericTiers+instance Listable Outer where tiers = genericTiers main :: IO ()@@ -54,26 +68,106 @@ tests n = [ True - , map unD0 list =| n |= list- , map unD1 list =| n |= (list :: [Int])- , map unD2 list =| n |= (list :: [(Int,Int)])- , map unD3 list =| n |= (list :: [(Int,Int,Int)])+ , [ Zero+ , Succ Zero+ , Succ (Succ Zero)+ , Succ (Succ (Succ Zero))+ ] `isPrefixOf` list - , map unD1 list == (list :: [()])- , map unD2 list == (list :: [((),())])- , map unD3 list == (list :: [((),(),())])+ , [Yes, No] == list - , map unD1 list == (list :: [Bool])- , map unD2 list == (list :: [(Bool,Bool)])- , map unD3 list == (list :: [(Bool,Bool,Bool)])+ , [ Nil+ , Unit :- Nil+ , Unit :- Unit :- Nil+ , Unit :- Unit :- Unit :- Nil+ ] `isPrefixOf` list + , [ Nil+ , Zero :- Nil+ , Zero :- (Zero :- Nil)+ , Succ Zero :- Nil+ , Zero :- (Zero :- (Zero :- Nil))+ , Zero :- (Succ Zero :- Nil)+ ] `isPrefixOf` list++ , list == [Yes :+ Yes, Yes :+ No, No :+ Yes, No :+ No]++ , [ Zero :+ Zero+ , Zero :+ Succ Zero+ , Succ Zero :+ Zero+ , Zero :+ Succ (Succ Zero)+ , Succ Zero :+ Succ Zero+ ] `isPrefixOf` list++ , list == [Unit]++ , list == [Naught, Precisely Unit]++ , list == [Naught, Precisely Yes, Precisely No]++ , list == [Sinister Yes, Sinister No, Dexter Yes, Dexter No]++ , [ Sinister Zero+ , Dexter Zero+ , Sinister (Succ Zero)+ , Dexter (Succ Zero)+ , Sinister (Succ (Succ Zero))+ , Dexter (Succ (Succ Zero))+ ] `isPrefixOf` list++ , list == [Smaller, Same, Bigger]++ , list == [Trio Unit Unit Unit]++ , [ Null+ , Node Null False Null+ , Node Null True Null+ , Node Null False (Node Null False Null)+ , Node Null False (Node Null True Null)+ , Node Null True (Node Null False Null)+ ] `isPrefixOf` list++ , [ Leaf False+ , Leaf True+ , Leaf False :-: Leaf False+ , Leaf False :-: Leaf True+ , Leaf True :-: Leaf False+ , Leaf True :-: Leaf True+ ] `isPrefixOf` list++ , [ Munil+ , Mutual CoMunil+ , Mutual (CoMutual Munil)+ , Mutual (CoMutual (Mutual CoMunil))+ , Mutual (CoMutual (Mutual (CoMutual Munil)))+ , Mutual (CoMutual (Mutual (CoMutual (Mutual CoMunil))))+ ] `isPrefixOf` list++ , list == [I]+ , list == [O I]+ , list == [Novel (O I) :: Nouter]++ , map (\Unit -> ()) list =| n |= list++ , map (\(Novel x) -> x) list == (list :: [()])+ , map (\(Novel x) -> x) list == (list :: [Bool])+ , map (\(Novel x) -> x) list =| n |= (list :: [Int])++ , map (\(x :+ y) -> (x,y)) list == (list :: [((),())])+ , map (\(x :+ y) -> (x,y)) list == (list :: [(Bool,Bool)])+ , map (\(x :+ y) -> (x,y)) list =| n |= (list :: [(Int,Int)])++ , map (\(Trio x y z) -> (x,y,z)) list == (list :: [((),(),())])+ , map (\(Trio x y z) -> (x,y,z)) list == (list :: [(Bool,Bool,Bool)])+ , map (\(Trio x y z) -> (x,y,z)) list =| n |= (list :: [(Int,Int,Int)])+ , map peanoToNat list =| n |= list- , map listToList list =| n |= (list :: [[Bool]])- , map listToList list =| n |= (list :: [[Int]])+ , map listLst list =| n |= (list :: [[Bool]])+ , map listLst list =| n |= (list :: [[Int]]) , mapT peanoToNat tiers =| 6 |= tiers- , mapT listToList tiers =| 6 |= (tiers :: [[ [Bool] ]])- , mapT listToList tiers =| 6 |= (tiers :: [[ [Int] ]])+ , mapT listLst tiers =| 6 |= (tiers :: [[ [Bool] ]])+ , mapT listLst tiers =| 6 |= (tiers :: [[ [Int] ]]) , take 6 (list :: [Bush Bool]) == [ Leaf False@@ -112,18 +206,13 @@ , (genericTiers :: [[ [Bool] ]]) =| 6 |= $(deriveTiers ''[]) , (genericTiers :: [[ Maybe Int ]]) =| 6 |= $(deriveTiers ''Maybe) , (genericTiers :: [[ Maybe Bool ]]) =| 6 |= $(deriveTiers ''Maybe)- , (genericTiers :: [[ Either Bool Int ]]) =| 6 |= $(deriveTiers ''Either)+ , (genericTiers :: [[ Either Bool Int ]]) =| 6 |= ([] : $(deriveTiers ''Either)) ]- where- unD0 (D0) = ()- unD1 (D1 x) = (x)- unD2 (D2 x y) = (x,y)- unD3 (D3 x y z) = (x,y,z) peanoToNat :: Peano -> Nat peanoToNat Zero = 0 peanoToNat (Succ n) = 1 + peanoToNat n -listToList :: List a -> [a]-listToList Nil = []-listToList (x :- xs) = x : listToList xs+listLst :: Lst a -> [a]+listLst Nil = []+listLst (x :- xs) = x : listLst xs