{-# LANGUAGE TemplateHaskell #-}

{- | 
  Module:        Control.Bidirectional.TH
  Description:   Template haskell for generating bidirectional instances
  Copyright:     Lev Dvorkin (c) 2022
  License:       MIT
  Maintainer:    lev_135@mail.ru
  Stability:     experimental
-}
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)

{-| 
  Declare instance and make it bidirectional at the same time.
  Provides instances for 'Bidirectional' and 'BidirectionalRec'.

  It's suitable for declaring your own instances. To make existing instances
  (for example, from libs) bidirectional, use 'makeBidirectionalInstances'.

  You can use it for declaring multiple instances:

  > data A a = A a
  > data B a b = B a b
  > data C a b = CA a | CB b
  > 
  > decBidirectionalInstances [d| 
  >     instance Show a => Show (A a) where
  >       show (A a) = "A " ++ show a
  >     instance (Show a, Show b) => Show (B a b) where
  >       show (B a b) = "B " ++ show a ++ " " show b
  >     instance (Show a, Show b) => Show (C a b) where
  >       show (CA a) = "CA " ++ show a
  >       show (CB b) = "CB " ++ show b
  >   |] 
-} 
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

{- |
  Make existing instance bidirectional.
  Provides instances for 'Bidirectional' and 'BidirectionalRec'.

  It's suitable for making bidirectional existing instances, that you can't 
  change (for example, from libs). If you want to declare your one instance
  and make it bidirectional, use 'decBidirectionalInstances'.

  You can use it for declaring multiple instances:

  > makeBidirectionalInstances [d| 
  >     instance Show a => Show [a]
  >     instance (Show a, Show b) => Show (a, b)
  >     instance (Show a, Show b) => Show (Either a b)
  >   |] 
  
  Note that you need not provide the body of instance, only its head. 
-}
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