{-#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              <- (Con -> Q (Name, [Type])) -> [Con] -> Q [(Name, [Type])]
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 = ([Type] -> [Type]) -> Q [Type] -> Q [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Type]
cxt[Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++) (Q [Type] -> Q [Type]) -> Q [Type] -> Q [Type]
forall a b. (a -> b) -> a -> b
$ (Name -> Q Type) -> [Name] -> Q [Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Q Type -> Q Type -> Q Type
appT (Name -> Q Type
conT Name
clname) (Q Type -> Q Type) -> (Name -> Q Type) -> Name -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Q 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

  Q [Type] -> Q Type -> [Q Dec] -> Q Dec
instanceD Q [Type]
mkCxt Q Type
mkTyp ((([(Name, [Type])] -> Q Dec) -> Q Dec)
-> [[(Name, [Type])] -> Q Dec] -> [Q Dec]
forall a b. (a -> b) -> [a] -> [b]
map ([(Name, [Type])] -> Q Dec) -> Q Dec
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 = Q Type -> Q Type -> Q Type
appT (Name -> Q Type
conT Name
cn) ((Q Type -> Q Type -> Q Type) -> Q Type -> [Q Type] -> Q Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (Q Type -> Q Type -> Q Type
appT) (Name -> Q Type
conT Name
dn) ((Name -> Q Type) -> [Name] -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q 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 Q Info
-> (Info -> Q ([Type], [Name], [Con])) -> Q ([Type], [Name], [Con])
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Info
i -> ([Type], [Name], [Con]) -> Q ([Type], [Name], [Con])
forall (m :: * -> *) a. Monad m => a -> m a
return (([Type], [Name], [Con]) -> Q ([Type], [Name], [Con]))
-> ([Type], [Name], [Con]) -> Q ([Type], [Name], [Con])
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, (TyVarBndr -> Name) -> [TyVarBndr] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Name
tvbName [TyVarBndr]
tvbs, [Con]
cons)
  TyConI (NewtypeD [Type]
cxt Name
_ [TyVarBndr]
tvbs Maybe Type
_ Con
con [DerivClause]
_) -> ([Type]
cxt, (TyVarBndr -> Name) -> [TyVarBndr] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> 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 (PlainTV n _)    = n
tvbName (KindedTV n _ _) = n
#else
tvbName :: TyVarBndr -> Name
tvbName :: TyVarBndr -> Name
tvbName (PlainTV Name
n)  = Name
n
tvbName (KindedTV Name
n Type
_) = Name
n
#endif


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


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


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

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