{-# LANGUAGE TemplateHaskell #-}

module Test.QuickCheck.TH.Generators.Internal (makeArbitrary) where


import           Data.Monoid ((<>))

import           Language.Haskell.TH
import           Language.Haskell.TH.Syntax

import           Test.QuickCheck
import           Test.QuickCheck.TH.Generators.Internal.BuildArbitrary


-- | create buildArb1 through buildArb20 automatically
$(buildArbAny 1)
$(buildArbAny 2)
$(buildArbAny 3)
$(buildArbAny 4)
$(buildArbAny 5)
$(buildArbAny 6)
$(buildArbAny 7)
$(buildArbAny 8)
$(buildArbAny 9)
$(buildArbAny 10)
$(buildArbAny 11)
$(buildArbAny 12)
$(buildArbAny 13)
$(buildArbAny 14)
$(buildArbAny 15)
$(buildArbAny 16)
$(buildArbAny 17)
$(buildArbAny 18)
$(buildArbAny 19)
$(buildArbAny 20)

-- | Boilerplate for top level splices.
--
-- The given 'Name' must be from a type constructor. Furthermore, the
-- type constructor must be either a data type or a newtype. Any other
-- value will result in an exception.
withType :: Name
         -> ([TyVarBndr] -> [Con] -> Q a)
         -- ^ Function that generates the actual code. Will be applied
         -- to the type variable binders and constructors extracted
         -- from the given 'Name'.
         -> Q a
         -- ^ Resulting value in the 'Q'uasi monad.
withType :: Name -> ([TyVarBndr] -> [Con] -> Q a) -> Q a
withType Name
name [TyVarBndr] -> [Con] -> Q a
f = do
    Info
info <- Name -> Q Info
reify Name
name
    case Info
info of
      TyConI Dec
dec ->
        case Dec
dec of
          DataD    Cxt
_ Name
_ [TyVarBndr]
tvbs Maybe Kind
_ [Con]
cons' [DerivClause]
_ -> [TyVarBndr] -> [Con] -> Q a
f [TyVarBndr]
tvbs [Con]
cons'
          NewtypeD Cxt
_ Name
_ [TyVarBndr]
tvbs Maybe Kind
_ Con
con  [DerivClause]
_ -> [TyVarBndr] -> [Con] -> Q a
f [TyVarBndr]
tvbs [Con
con]
          Dec
other -> [Char] -> Q a
forall a. HasCallStack => [Char] -> a
error ([Char] -> Q a) -> [Char] -> Q a
forall a b. (a -> b) -> a -> b
$ [Char]
"Example.TH.withType: Unsupported type: "
                          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Dec -> [Char]
forall a. Show a => a -> [Char]
show Dec
other
      Info
_ -> [Char] -> Q a
forall a. HasCallStack => [Char] -> a
error [Char]
"Example.TH.withType: I need the name of a type."


-- | Extracts the name from a constructor.

-- | Make a ('Gen' a) for type 'a'
-- Currently support arbitrary Sum types up to 7 params
-- per constructor.
--
-- Record Types not currently supported
makeArbitrary :: Name -> Q [Dec]
makeArbitrary :: Name -> Q [Dec]
makeArbitrary Name
n = Name -> ([TyVarBndr] -> [Con] -> Q [Dec]) -> Q [Dec]
forall a. Name -> ([TyVarBndr] -> [Con] -> Q a) -> Q a
withType Name
n [TyVarBndr] -> [Con] -> Q [Dec]
forall p. p -> [Con] -> Q [Dec]
runConstructionApp
  where
    runConstructionApp :: p -> [Con] -> Q [Dec]
runConstructionApp p
_  [Con]
con = do
                         [Dec]
dec <- Name -> [Con] -> Q [Dec]
applyCon Name
n [Con]
con
                         [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return [Dec]
dec

-- | build the function taht applys the type constructor
applyCon :: Name -> [Con] -> DecsQ
applyCon :: Name -> [Con] -> Q [Dec]
applyCon Name
n [Con]
cons' = [Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Q Dec
signature,Q Dec
value]
  where
    signature :: Q Dec
signature = Name -> TypeQ -> Q Dec
sigD Name
finalFunctionName (TypeQ -> TypeQ -> TypeQ
appT (Name -> TypeQ
conT ''Gen) (Name -> TypeQ
conT Name
n))
    value :: Q Dec
value =   PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD (Name -> PatQ
varP Name
finalFunctionName) (ExpQ -> BodyQ
normalB ([Con] -> ExpQ
makeArbList [Con]
cons')) []
    finalFunctionName :: Name
finalFunctionName = [Char] -> Name
mkName ([Char]
"arbitrary" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Name -> [Char]
nameBase Name
n)


-- | select one of the list of generators
-- Q Exp == oneOf [Gen *]
makeArbList :: [Con] -> Q Exp
makeArbList :: [Con] -> ExpQ
makeArbList [Con]
cons' = ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE 'oneof)
                        ([ExpQ] -> ExpQ
listE ([ExpQ] -> ExpQ) -> [ExpQ] -> ExpQ
forall a b. (a -> b) -> a -> b
$ ((Name, [StrictType]) -> ExpQ) -> [Con] -> [ExpQ]
forall a. ((Name, [StrictType]) -> a) -> [Con] -> [a]
asNormalOrRecC (Name, [StrictType]) -> ExpQ
applyConExp [Con]
cons'  )

-- | Normal Constructors are the only ones we are considering
asNormalOrRecC  :: ((Name, [StrictType]) -> a) -> [Con] -> [a]
asNormalOrRecC :: ((Name, [StrictType]) -> a) -> [Con] -> [a]
asNormalOrRecC  (Name, [StrictType]) -> a
f [Con]
cons' = (Con -> [a] -> [a]) -> [a] -> [Con] -> [a]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Con -> [a] -> [a]
decodeC [] [Con]
cons'
  where
   decodeC :: Con -> [a] -> [a]
decodeC (RecC Name
n [VarBangType]
l)   [a]
lst  = ((Name, [StrictType]) -> a
f (Name
n, VarBangType -> StrictType
forall a a b. (a, a, b) -> (a, b)
varStrictToStrict (VarBangType -> StrictType) -> [VarBangType] -> [StrictType]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>  [VarBangType]
l)) a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
lst
   decodeC (NormalC Name
n [StrictType]
l) [a]
lst = ((Name, [StrictType]) -> a
f (Name
n, [StrictType]
l)) a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
lst
   decodeC Con
_ [a]
lst = [a]
lst
   varStrictToStrict :: (a, a, b) -> (a, b)
varStrictToStrict (a
_ , a
s,b
t) = (a
s,b
t)

-- | This is where we run the sum type thing
-- Q Exp
applyConExp :: (Name, [StrictType]) -> ExpQ
applyConExp :: (Name, [StrictType]) -> ExpQ
applyConExp (Name, [StrictType])
deconstructedConstructor = Integer -> ExpQ
runMapAndApp Integer
argCount
  where
    conName :: Name
conName = (Name, [StrictType]) -> Name
forall a b. (a, b) -> a
fst (Name, [StrictType])
deconstructedConstructor
    argCount :: Integer
argCount = Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Integer)
-> ((Name, [StrictType]) -> Int) -> (Name, [StrictType]) -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [StrictType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([StrictType] -> Int)
-> ((Name, [StrictType]) -> [StrictType])
-> (Name, [StrictType])
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, [StrictType]) -> [StrictType]
forall a b. (a, b) -> b
snd ((Name, [StrictType]) -> Integer)
-> (Name, [StrictType]) -> Integer
forall a b. (a -> b) -> a -> b
$ (Name, [StrictType])
deconstructedConstructor :: Integer
    runMapAndApp :: Integer -> ExpQ
    runMapAndApp :: Integer -> ExpQ
runMapAndApp Integer
0 = ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE 'arbReturn ) (Name -> ExpQ
conE Name
conName)
    runMapAndApp Integer
1 = ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE 'buildArb1 ) (Name -> ExpQ
conE Name
conName)
    runMapAndApp Integer
2 = ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE 'buildArb2 ) (Name -> ExpQ
conE Name
conName)
    runMapAndApp Integer
3 = ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE 'buildArb3 ) (Name -> ExpQ
conE Name
conName)
    runMapAndApp Integer
4 = ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE 'buildArb4 ) (Name -> ExpQ
conE Name
conName)
    runMapAndApp Integer
5 = ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE 'buildArb5 ) (Name -> ExpQ
conE Name
conName)
    runMapAndApp Integer
6 = ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE 'buildArb6 ) (Name -> ExpQ
conE Name
conName)
    runMapAndApp Integer
7 = ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE 'buildArb7 ) (Name -> ExpQ
conE Name
conName)
    runMapAndApp Integer
8 = ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE 'buildArb8 ) (Name -> ExpQ
conE Name
conName)
    runMapAndApp Integer
9 = ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE 'buildArb9 ) (Name -> ExpQ
conE Name
conName)
    runMapAndApp Integer
10 = ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE 'buildArb10 ) (Name -> ExpQ
conE Name
conName)
    runMapAndApp Integer
11 = ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE 'buildArb11 ) (Name -> ExpQ
conE Name
conName)
    runMapAndApp Integer
12 = ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE 'buildArb12 ) (Name -> ExpQ
conE Name
conName)
    runMapAndApp Integer
13 = ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE 'buildArb13 ) (Name -> ExpQ
conE Name
conName)
    runMapAndApp Integer
14 = ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE 'buildArb14 ) (Name -> ExpQ
conE Name
conName)
    runMapAndApp Integer
15 = ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE 'buildArb15 ) (Name -> ExpQ
conE Name
conName)
    runMapAndApp Integer
16 = ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE 'buildArb16 ) (Name -> ExpQ
conE Name
conName)
    runMapAndApp Integer
17 = ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE 'buildArb17 ) (Name -> ExpQ
conE Name
conName)
    runMapAndApp Integer
18 = ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE 'buildArb18 ) (Name -> ExpQ
conE Name
conName)
    runMapAndApp Integer
19 = ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE 'buildArb19 ) (Name -> ExpQ
conE Name
conName)
    runMapAndApp Integer
20 = ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE 'buildArb20 ) (Name -> ExpQ
conE Name
conName)

    runMapAndApp Integer
_ = [Char] -> ExpQ
forall a. HasCallStack => [Char] -> a
error [Char]
"Arbitrary TypeConstructors only defined for 0 to 20 parameters"

{- attempting to automate it further
applyConExp :: (Name, [StrictType]) -> ExpQ
applyConExp deconstructedConstructor = -- runMapAndApp argCount
  case (argCount >= 0) && (argCount <= 20) of
    True -> do
      mBuildArbn <- lookupValueName buildArb
      case mBuildArbn of
        Nothing -> error "Could not find buildArbn function, TH error"
        Just buildArbn -> appE (varE buildArbn) (conE conName)

    False -> error "Arbitrary TypeConstructors only defined for 0 to 20 parameters"
  where
    conName = fst deconstructedConstructor
    argCount = fromIntegral . length . snd $ deconstructedConstructor :: Int
    buildArb = "buildArb" ++ show argCount
-}

arbReturn :: a -> Gen a
arbReturn :: a -> Gen a
arbReturn = a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return