{-#Language CPP#-}
{-#Language TemplateHaskell#-}
module Control.Enumerable.Derive (instanceFor, module Language.Haskell.TH) where
import Language.Haskell.TH

-- General combinator for class derivation
instanceFor :: Name -> [[(Name,[Type])] -> Q Dec] -> Name -> Q Dec
instanceFor :: Name -> [[(Name, [Type])] -> Q Dec] -> Name -> Q Dec
instanceFor Name
clname [[(Name, [Type])] -> Q Dec]
confs Name
dtname = do
  ([Type]
cxt,[Name]
dtvs,[Con]
cons) <- Name -> Q ([Type], [Name], [Con])
extractData Name
dtname
  [(Name, [Type])]
cd              <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Con -> Q (Name, [Type])
conData [Con]
cons
  let
#if MIN_VERSION_template_haskell(2,10,0)
    mkCxt :: Q [Type]
mkCxt = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Type]
cxtforall a. [a] -> [a] -> [a]
++) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (forall (m :: * -> *). Quote m => Name -> m Type
conT Name
clname) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Quote m => Name -> m Type
varT) [Name]
dtvs
#else
    mkCxt = fmap (cxt++) $ mapM (classP clname . return . varT) dtvs
#endif
    mkTyp :: Q Type
mkTyp = Name -> Name -> [Name] -> Q Type
mkInstanceType Name
clname Name
dtname [Name]
dtvs
    mkDecs :: ([(Name, [Type])] -> t) -> t
mkDecs [(Name, [Type])] -> t
conf = [(Name, [Type])] -> t
conf [(Name, [Type])]
cd

  forall (m :: * -> *).
Quote m =>
m [Type] -> m Type -> [m Dec] -> m Dec
instanceD Q [Type]
mkCxt Q Type
mkTyp (forall a b. (a -> b) -> [a] -> [b]
map forall {t}. ([(Name, [Type])] -> t) -> t
mkDecs [[(Name, [Type])] -> Q Dec]
confs)


mkInstanceType :: Name -> Name -> [Name] -> Q Type
mkInstanceType :: Name -> Name -> [Name] -> Q Type
mkInstanceType Name
cn Name
dn [Name]
vns = forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (forall (m :: * -> *). Quote m => Name -> m Type
conT Name
cn) (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT) (forall (m :: * -> *). Quote m => Name -> m Type
conT Name
dn) (forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Type
varT [Name]
vns))

extractData :: Name -> Q (Cxt, [Name], [Con])
extractData :: Name -> Q ([Type], [Name], [Con])
extractData Name
n = Name -> Q Info
reify Name
n forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Info
i -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Info
i of
#if MIN_VERSION_template_haskell(2,11,0)
  TyConI (DataD [Type]
cxt Name
_ [TyVarBndr ()]
tvbs Maybe Type
_ [Con]
cons [DerivClause]
_)   -> ([Type]
cxt, forall a b. (a -> b) -> [a] -> [b]
map forall flag. TyVarBndr flag -> Name
tvbName [TyVarBndr ()]
tvbs, [Con]
cons)
  TyConI (NewtypeD [Type]
cxt Name
_ [TyVarBndr ()]
tvbs Maybe Type
_ Con
con [DerivClause]
_) -> ([Type]
cxt, forall a b. (a -> b) -> [a] -> [b]
map forall flag. TyVarBndr flag -> Name
tvbName [TyVarBndr ()]
tvbs, [Con
con])
#else
  TyConI (DataD cxt _ tvbs cons _)   -> (cxt, map tvbName tvbs, cons)
  TyConI (NewtypeD cxt _ tvbs con _) -> (cxt, map tvbName tvbs, [con])
#endif

#if MIN_VERSION_template_haskell(2,17,0)
tvbName :: TyVarBndr flag -> Name
tvbName :: forall flag. TyVarBndr flag -> Name
tvbName (PlainTV Name
n flag
_)    = Name
n
tvbName (KindedTV Name
n flag
_ Type
_) = Name
n
#else
tvbName :: TyVarBndr -> Name
tvbName (PlainTV n)  = n
tvbName (KindedTV n _) = n
#endif


conData :: Con -> Q (Name,[Type])
conData :: Con -> Q (Name, [Type])
conData Con
c = case Con
c of
  NormalC Name
n [BangType]
sts    -> forall (m :: * -> *) a. Monad m => a -> m a
return (Name
n,forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [BangType]
sts)
  RecC Name
n [VarBangType]
vsts      -> forall (m :: * -> *) a. Monad m => a -> m a
return (Name
n,forall a b. (a -> b) -> [a] -> [b]
map (\(Name
_,Bang
s,Type
t) -> Type
t) [VarBangType]
vsts)
  InfixC BangType
st1 Name
n BangType
st2 -> forall (m :: * -> *) a. Monad m => a -> m a
return (Name
n,[forall a b. (a, b) -> b
snd BangType
st1,forall a b. (a, b) -> b
snd BangType
st2])
  ForallC [TyVarBndr Specificity]
_ [Type]
_ Con
c'   -> Con -> Q (Name, [Type])
conData Con
c'


x :: IO Type
x :: IO Type
x = forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ forall a b. (a -> b) -> a -> b
$ (Name -> Q Type
toType ''(,))


toType :: Name -> Q Type
toType Name
n = case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Name
n [(Name, Q Type)]
tups of
  Maybe (Q Type)
Nothing -> forall (m :: * -> *). Quote m => Name -> m Type
conT Name
n
  Just Q Type
q  -> Q Type
q

tups :: [(Name, Q Type)]
tups = (''(), [t|()|])forall a. a -> [a] -> [a]
:forall a b. (a -> b) -> [a] -> [b]
map (\(Name
n,Int
i) -> (Name
n, forall (m :: * -> *). Quote m => Int -> m Type
tupleT Int
i)) (forall a b. [a] -> [b] -> [(a, b)]
zip [''(,), ''(,,)] [Int
2..])