{-# LANGUAGE TemplateHaskell #-}
module Control.Bidirectional.TH (
decBidirectionalInstances,
makeBidirectionalInstances
) where
import Language.Haskell.TH (Exp, Q, Dec (InstanceD, ClassD), TypeQ, DecsQ, reify, Info (ClassI), Type (ConT, AppT, TupleT), conT)
import Control.Bidirectional.Class (Bidirectional, BidirectionalRec, Constr, ConstrRec)
import Control.Monad (join)
decBidirectionalInstances :: Q [Dec] -> Q [Dec]
decBidirectionalInstances :: Q [Dec] -> Q [Dec]
decBidirectionalInstances Q [Dec]
instances = do
[Dec]
inst <- Q [Dec]
instances
([Dec]
inst [Dec] -> [Dec] -> [Dec]
forall a. Semigroup a => a -> a -> a
<>) ([Dec] -> [Dec]) -> Q [Dec] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q [Dec] -> Q [Dec]
makeBidirectionalInstances Q [Dec]
instances
makeBidirectionalInstances :: Q [Dec] -> Q [Dec]
makeBidirectionalInstances :: Q [Dec] -> Q [Dec]
makeBidirectionalInstances Q [Dec]
instances = do
[Dec]
insts <- Q [Dec]
instances
[[Dec]] -> [Dec]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Dec -> Q [Dec]) -> [Dec] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Dec -> Q [Dec]
makeBidirectionalInstance [Dec]
insts
makeBidirectionalInstance :: Dec -> Q [Dec]
makeBidirectionalInstance :: Dec -> Q [Dec]
makeBidirectionalInstance Dec
inst = do
let InstanceD Maybe Overlap
Nothing Cxt
constr (AppT Type
c Type
a) [Dec]
_ = Dec
inst
c' :: Q Type
c' = Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
c
a' :: Q Type
a' = Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
a
constr' :: Q Type
constr' = Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ Cxt -> Type
mkTup Cxt
constr
constrRec' :: Q Type
constrRec' = Cxt -> Type
mkTup (Cxt -> Type) -> Q Cxt -> Q Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Type -> Q Type) -> Cxt -> Q Cxt
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> Q Type
mkRec Cxt
constr
[d|
instance (Constr $c' $a') => Bidirectional $c' $a' where
type Constr $c' $a' = $constr'
instance (ConstrRec $c' $a') => BidirectionalRec $c' $a' where
type ConstrRec $c' $a' = $constrRec'
|]
where
mkTup :: [Type] -> Type
mkTup :: Cxt -> Type
mkTup [] = Int -> Type
TupleT Int
0
mkTup [Type
t] = Type -> Type -> Type
AppT (Int -> Type
TupleT Int
1) Type
t
mkTup (Type
t : Cxt
ts) = case Cxt -> Type
mkTup Cxt
ts of
AppT (TupleT Int
n) Type
u -> Type -> Type -> Type
AppT (Type -> Type -> Type
AppT (Int -> Type
TupleT (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)) Type
t) Type
u
Type
_ -> [Char] -> Type
forall a. HasCallStack => [Char] -> a
error [Char]
"tmp"
mkRec :: Type -> Q Type
mkRec :: Type -> Q Type
mkRec (AppT Type
a Type
b) = [t| BidirectionalRec $(pure a) $(pure b) |]
mkRec Type
t = Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
t