module Test.Feat.Class (
Enumerable(..),
Constructor,
nullary,
unary,
funcurry,
consts,
optimised,
FreePair(..),
deriveEnumerable,
) where
import Test.Feat.Enumerate
import Test.Feat.Internals.Tag(Tag(Class))
import Test.Feat.Internals.Derive
import Data.Typeable
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Data.Word
import Data.Int
import Data.Bits
class Typeable a => Enumerable a where
enumerate :: Enumerate a
shared :: Enumerate a
shared = tagShare Class enumerate
optimised :: Enumerable a => Enumerate a
optimised = optimise shared
newtype FreePair a b = Free {free :: (a,b)}
deriving (Show, Typeable)
funcurry :: (a -> b -> c) -> FreePair a b -> c
funcurry f = uncurry f . free
instance (Enumerable a, Enumerable b) =>
Enumerable (FreePair a b) where
enumerate = mem $ curry Free <$> shared <*> shared
type Constructor = Enumerate
nullary :: a -> Constructor a
nullary = pure
unary :: Enumerable a => (a -> b) -> Constructor b
unary f = f <$> shared
consts :: [Constructor a] -> Enumerate a
consts xs = mempay $ mconcat xs
deriveEnumerable :: Name -> Q [Dec]
deriveEnumerable = fmap return . instanceFor ''Enumerable [enumDef]
enumDef :: [(Name,[Type])] -> [Q Dec]
enumDef cons = [fmap mk_freqs_binding [|consts $ex |]] where
ex = listE $ map cone cons
cone (n,[]) = [|pure $(conE n)|]
cone (n,_:vs) =
[|unary $(foldr appE (conE n) (map (const [|funcurry|] ) vs) )|]
mk_freqs_binding :: Exp -> Dec
mk_freqs_binding e = ValD (VarP 'enumerate) (NormalB e) []
(let
it = mapM (instanceFor ''Enumerable [enumDef])
[ ''[]
, ''Bool
, ''()
, ''(,)
, ''(,,)
, ''(,,,)
, ''(,,,,)
, ''(,,,,,)
, ''(,,,,,,)
, ''Either
, ''Maybe
, ''Ordering
]
enumDef :: [(Name,[Type])] -> [Q Dec]
enumDef cons = [fmap mk_freqs_binding [|consts $ex |]] where
ex = listE $ map cone cons
cone (n,[]) = [|pure $(conE n)|]
cone (n,_:vs) =
[|unary $(foldr appE (conE n) (map (const [|funcurry|] ) vs) )|]
mk_freqs_binding :: Exp -> Dec
mk_freqs_binding e = ValD (VarP 'enumerate) (NormalB e) []
in it)
newtype Natural = Natural {natural :: Integer} deriving (Typeable, Show)
instance Enumerable Natural where
enumerate = let e = Enumerate{
card = crd,
select = sel,
optimal = return e} in e where
crd p
| p <= 0 = 0
| p == 1 = 1
| otherwise = 2^(p2)
sel 1 0 = Natural 0
sel p i = Natural $ 2^(p2) + i
instance Enumerable Integer where
enumerate = unary f where
f (Free (b,Natural i)) = if b then i1 else i
word :: (Bits a, Integral a) => Enumerate a
word = e where
e = cutOff (bitSize' e+1) $ unary (fromInteger . natural)
int :: (Bits a, Integral a) => Enumerate a
int = e where
e = cutOff (bitSize' e+1) $ unary fromInteger
cutOff :: Int -> Enumerate a -> Enumerate a
cutOff n e = e{
card = \p -> if p > n then 0 else card e p,
optimal = fmap (cutOff n) $ optimal e
}
bitSize' :: Bits a => f a -> Int
bitSize' f = hlp undefined f where
hlp :: Bits a => a -> f a -> Int
hlp a _ = bitSize a
instance Enumerable Word where
enumerate = word
instance Enumerable Word8 where
enumerate = word
instance Enumerable Word16 where
enumerate = word
instance Enumerable Word32 where
enumerate = word
instance Enumerable Word64 where
enumerate = word
instance Enumerable Int where
enumerate = int
instance Enumerable Int8 where
enumerate = int
instance Enumerable Int16 where
enumerate = int
instance Enumerable Int32 where
enumerate = int
instance Enumerable Int64 where
enumerate = int
instance Enumerable Double where
enumerate = unary (funcurry encodeFloat)
instance Enumerable Float where
enumerate = unary (funcurry encodeFloat)
instance Enumerable Char where
enumerate = cutOff 8 $ unary (toEnum . fromIntegral :: Word -> Char)