{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -ddump-splices #-} {-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} {-# OPTIONS_GHC -fconstraint-solver-iterations=26 #-} module Main where import GHC.Generics as GHC (Generic) import Generics.POSable.Instances () import Generics.POSable.POSable as POSable import Generics.POSable.Representation import Generics.POSable.TH import Language.Haskell.TH import Language.Haskell.TH.Lib import Test.Tasty (TestTree, defaultMain, testGroup) import Test.Tasty.HUnit (testCase, (@?=)) import Test.Tasty.QuickCheck propInjectivity :: (POSable a, Arbitrary a, Eq a) => a -> Bool propInjectivity x = fromPOSable (choices x) (fields x) == x instance Ground Float where mkGround = 0 instance Ground Double where mkGround = 0 instance Ground Char where mkGround = '0' instance Ground Int where mkGround = 0 instance Ground Word where mkGround = 0 mkPOSableGround ''Float mkPOSableGround ''Double mkPOSableGround ''Char mkPOSableGround ''Int mkPOSableGround ''Word $(runQ $ do -- generate :: Int -> (Int -> a) -> [a] let generate n f = case n of 0 -> [] _ -> f n : generate (n - 1) f let baseTypes = [''Int, ''Float, ''Char, ''Bool] let buildValue n = ( Bang NoSourceUnpackedness NoSourceStrictness , ConT (baseTypes !! (n-1))) let buildCons name n = NormalC (mkName name) (generate n buildValue) let arbitraryCon name n = case n of 0 -> AppE (VarE 'pure) (ConE name) 1 -> AppE (AppE (VarE '(<$>)) (ConE name)) (VarE 'arbitrary) _ -> AppE (AppE (VarE '(<*>)) (arbitraryCon name (n-1))) (VarE 'arbitrary) let buildData name ncons nvals = DataD [] (mkName name) [] Nothing (generate ncons (\x -> buildCons (name ++ show x) nvals)) [ DerivClause Nothing [ ConT ''Show, ConT ''Eq, ConT ''GHC.Generic , ConT ''POSable.Generic, ConT ''POSable ] ] let buildInstance name ncons nvals = InstanceD Nothing [] (AppT (ConT ''Arbitrary) (ConT (mkName name))) [ FunD 'arbitrary [ Clause [] (NormalB ( AppE (VarE 'oneof) (ListE (generate ncons (\x -> arbitraryCon (mkName (name ++ show x)) nvals ))))) [] ] ] let buildDataAndInstance ncons m | nvals <- m-1, name <- "TEST" ++ show ncons ++ show nvals = [ buildData name ncons nvals, buildInstance name ncons nvals ] let buildTest ncons m | nvals <- m-1, name <- "TEST" ++ show ncons ++ show nvals = AppE (AppE (VarE 'testProperty) (LitE (StringL name))) (AppTypeE (VarE 'propInjectivity) (ConT (mkName name))) let tests ncons nvals = FunD (mkName "thtests") [Clause [] (NormalB ( AppE (AppE (VarE 'testGroup) (LitE (StringL "QuickCheck Template Haskell"))) (ListE (concat (generate 4 (generate 5 . buildTest))) ) )) []] return (tests 4 5 : concat (concat (generate 4 (generate 5 . buildDataAndInstance)))) ) main :: IO () main = defaultMain tests tests :: TestTree tests = testGroup "Test Choices and Fields of basic data types" [ testGroup "Maybe" [ testCase "Nothing" $ choices (Nothing :: Maybe Int) @?= 0 , testCase "Just" $ choices (Just 14 :: Maybe Int) @?= 1 , testCase "Nested" $ choices nestedMaybe @?= 2 , testCase "Fields" $ fields nestedMaybe @?= Cons (Skip (Skip (Pick 1.4))) Nil ] , testGroup "Either" [ testCase "Left" $ choices (Left 1 :: Either Int Float) @?= 0 , testCase "Right" $ choices (Right 14 :: Either Float Int) @?= 1 , testCase "Nested" $ choices nestedEither @?= 2 , testCase "Fields" $ fields nestedEither @?= Cons (Skip $ Skip $ Pick 1.4) Nil ] , testGroup "Tuple" [ testCase "choices" $ choices (1 :: Int, 2.3 :: Float) @?= 0 , testCase "fields" $ fields (1 :: Int, 2.3 :: Float) @?= Cons (Pick 1) (Cons (Pick 2.3) Nil) ] , testGroup "Mixed" [ testCase "fields (Either, Either)" $ choices tupleOfEithers @?= 2 , testCase "choices (Either, Either)" $ fields tupleOfEithers @?= Cons (Pick 1) (Cons (Skip $ Pick 2.3) Nil) , testCase "fields Either (,) (,)" $ choices eitherOfTuples @?= 0 , testCase "choices Either (,) (,)" $ fields eitherOfTuples @?= Cons (Pick 1) (Cons (Pick 3.4) Nil) ] , testGroup "QuickCheck" [ testProperty "Either Int Float" $ propInjectivity @(Either Int Float) , testProperty "Either Either Tuple" $ propInjectivity @(Either (Either Int Float) (Float, Int)) , testProperty "Long tuple" $ propInjectivity @(Int, Float, Word, Float, Char) , testProperty "Unit" $ propInjectivity @() , testProperty "Ordering" $ propInjectivity @Ordering , testProperty "Large sum" $ propInjectivity @LONGSUM , testProperty "Large product" $ propInjectivity @LONGPRODUCT ] , testGroup "tags" [ testCase "Bool" $ tags @Bool @?= [1,1] , testCase "Either Int Float" $ tags @(Either Int Float) @?= [1,1] , testCase "Either Bool Bool" $ tags @(Either Bool Bool) @?= [2,2] , testCase "Either (Maybe Int) Float" $ tags @(Either (Maybe Int) Float) @?= [2,1] , testCase "Unit" $ tags @() @?= [1] , testCase "Float" $ tags @() @?= [1] , testCase "(Float, Bool, Bool)" $ tags @(Float, Bool, Bool) @?= [4] ] , thtests ] data LONGSUM = A | B | C | D | E | F | G | H | I | J | K | L | M | N | O | P | Q | R | S | T | U | V | W | X | Y | Z deriving (Show, Eq, GHC.Generic, POSable.Generic, POSable) instance Arbitrary LONGSUM where arbitrary = elements [A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X,Y,Z] data LONGPRODUCT = LONGPRODUCT Int Float Double Char Word Int Float Double Char Word Int Float Double Char Word Int Float Double Char Word deriving (Show, Eq, GHC.Generic, POSable.Generic, POSable) instance Arbitrary LONGPRODUCT where arbitrary = LONGPRODUCT <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary nestedMaybe :: Maybe (Maybe Float) nestedMaybe = Just (Just 1.4) nestedEither :: Either (Either Int Float) (Either Float Int) nestedEither = Right (Left 1.4) tupleOfEithers :: (Either Int Float, Either Int Float) tupleOfEithers = (Left 1, Right 2.3) eitherOfTuples :: Either (Int, Float) (Float, Int) eitherOfTuples = Left (1,3.4)