module Language.Haskell.TH.Instances where
import Language.Haskell.TH
import Data.String
import Test.QuickCheck
import Control.Applicative
import Test.QuickCheck.Instances.Char
instance IsString Name where
fromString x = mkName x
instance Arbitrary Name where
arbitrary = mkName <$> arbitrary
arb_constructor_name = do
x <- upperAlpha
xs <- listOf (oneof [numeric, lowerAlpha, upperAlpha])
return $ mkName $ x:xs
instance Arbitrary Type where
arbitrary = sized type_arb
type_arb :: Int -> Gen Type
type_arb depth = do
let max_option = if depth > 0 then 8 else (5 :: Int)
typ <- choose (0, max_option)
case typ of
0 -> VarT <$> mkName <$> listOf lowerAlpha
1 -> ConT <$> arb_constructor_name
2 -> TupleT <$> arbitrary
3 -> UnboxedTupleT <$> arbitrary
4 -> return ArrowT
5 -> return ListT
6 -> forallt_arb (depth 1)
7 -> SigT <$> type_arb (depth 1) <*> arbitrary
8 -> AppT <$> type_arb (depth 1) <*> type_arb (depth 1)
forallt_arb :: Int -> Gen Type
forallt_arb depth = do
ForallT <$> (return []) <*> (return []) <*> (return $ VarT $ mkName "test")
instance Arbitrary Kind where
arbitrary = sized kind_arb
kind_arb :: Int -> Gen Kind
kind_arb depth = do
let max_option = if depth > 0 then 1 else (2 :: Int)
typ <- choose(0, max_option)
case typ of
0 -> return StarK
1 -> ArrowK <$> kind_arb (depth 1) <*> kind_arb (depth 1)
haskell_98_type_arb depth = do
let max_option = if depth > 0 then 6 else (5 :: Int)
typ <- choose (0, max_option)
case typ of
0 -> VarT <$> mkName <$> listOf lowerAlpha
1 -> ConT <$> arb_constructor_name
2 -> TupleT <$> arbitrary
3 -> UnboxedTupleT <$> arbitrary
4 -> return ArrowT
5 -> return ListT
6 -> AppT <$> haskell_98_type_arb (depth 1) <*> haskell_98_type_arb (depth 1)