{-# LANGUAGE CPP             #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UnicodeSyntax   #-}
{-# LANGUAGE ViewPatterns    #-}

module Data.Class.Closed.TH where

import Data.Class.Closed          (Closed)
import Data.Maybe                 (fromMaybe)
import Data.Proxy                 (Proxy (..))
import Language.Haskell.TH        (Dec (..), Name, Q, TyVarBndr (..), Type (..),
                                   appT, classD, clause, conT, defaultSigD,
                                   funD, instanceWithOverlapD, nameBase,
                                   newName, normalB, sigD, varT)
import Language.Haskell.TH.Syntax (getQ, putQ)

-- | Closes all declared classes. Any instances must be given in the same quote.
close ∷ Q [Dec] -> Q [Dec]
close :: Q [Dec] -> Q [Dec]
close = (Q [Dec] -> ([Dec] -> Q [Dec]) -> Q [Dec]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m 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
modify) where
  modify ∷ Dec → Q Dec
  modify :: Dec -> Q Dec
modify (ClassD Cxt
context Name
name [TyVarBndr]
tvs [FunDep]
deps [Dec]
decs) = do
    let con :: TypeQ
con = Name -> TypeQ
conT Name
name
        ty :: TypeQ
ty  = (TypeQ -> TyVarBndr -> TypeQ) -> TypeQ -> [TyVarBndr] -> TypeQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\TypeQ
t TyVarBndr
b → TypeQ -> TypeQ -> TypeQ
appT TypeQ
t (TyVarBndr -> TypeQ
binderT TyVarBndr
b)) TypeQ
con [TyVarBndr]
tvs
    Name
private ← Name -> Q Name
getPrivateName Name
name
    CxtQ -> Name -> [TyVarBndr] -> [FunDep] -> [Q Dec] -> Q Dec
classD (Cxt -> CxtQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Cxt
context) Name
name [TyVarBndr]
tvs [FunDep]
deps                  -- class ... ⇒ C ... where
      ([Q Dec] -> Q Dec) -> [Q Dec] -> Q Dec
forall a b. (a -> b) -> a -> b
$ Name -> TypeQ -> Q Dec
defaultSigD Name
private [t|Closed $con ⇒ Proxy $ty|] --   default private ∷ Closed C ⇒ Proxy (C ...)
      Q Dec -> [Q Dec] -> [Q Dec]
forall a. a -> [a] -> [a]
: Name -> TypeQ -> Q Dec
sigD Name
private [t|Proxy $ty|]                      --   private ∷ Proxy (C ...)
      Q Dec -> [Q Dec] -> [Q Dec]
forall a. a -> [a] -> [a]
: Name -> [ClauseQ] -> Q Dec
funD Name
private [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] (ExpQ -> BodyQ
normalB [|Proxy|]) []]  --   private = Proxy
      Q Dec -> [Q Dec] -> [Q Dec]
forall a. a -> [a] -> [a]
: (Dec -> Q Dec) -> [Dec] -> [Q Dec]
forall a b. (a -> b) -> [a] -> [b]
map Dec -> Q Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec]
decs                                    --   ...
  modify (InstanceD Maybe Overlap
overlap Cxt
context ty :: Type
ty@(Type -> Maybe Name
conName → Just Name
name) [Dec]
decs) = do
    Name
private ← Name -> Q Name
getPrivateName Name
name
    Maybe Overlap -> CxtQ -> TypeQ -> [Q Dec] -> Q Dec
instanceWithOverlapD Maybe Overlap
overlap (Cxt -> CxtQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Cxt
context) (Type -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
ty) -- instance ... where
      ([Q Dec] -> Q Dec) -> [Q Dec] -> Q Dec
forall a b. (a -> b) -> a -> b
$ Name -> [ClauseQ] -> Q Dec
funD Name
private [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] (ExpQ -> BodyQ
normalB [|Proxy|]) []]   --   private = Proxy
      Q Dec -> [Q Dec] -> [Q Dec]
forall a. a -> [a] -> [a]
: (Dec -> Q Dec) -> [Dec] -> [Q Dec]
forall a b. (a -> b) -> [a] -> [b]
map Dec -> Q Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec]
decs                                     --   ...
  modify Dec
dec = Dec -> Q Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure Dec
dec

#if MIN_VERSION_template_haskell(2, 17, 0)
  binderT ∷ TyVarBndr flag → Q Type
  binderT (PlainTV  name _)   = varT name
  binderT (KindedTV name _ _) = varT name
#else
  binderT ∷ TyVarBndr → Q Type
  binderT :: TyVarBndr -> TypeQ
binderT (PlainTV  Name
name)   = Name -> TypeQ
varT Name
name
  binderT (KindedTV Name
name Type
_) = Name -> TypeQ
varT Name
name
#endif

  getPrivateName ∷ Name → Q Name
  getPrivateName :: Name -> Q Name
getPrivateName Name
name = do
    [(Name, Name)]
cache ← [(Name, Name)] -> Maybe [(Name, Name)] -> [(Name, Name)]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [(Name, Name)] -> [(Name, Name)])
-> Q (Maybe [(Name, Name)]) -> Q [(Name, Name)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q (Maybe [(Name, Name)])
forall a. Typeable a => Q (Maybe a)
getQ
    case Name -> [(Name, Name)] -> Maybe Name
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Name
name [(Name, Name)]
cache of
      Just Name
private → Name -> Q Name
forall (m :: * -> *) a. Monad m => a -> m a
return Name
private
      Maybe Name
Nothing      → do
        Name
temp    ← String -> Q Name
newName (String
"_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
name)
        Name
private ← String -> Q Name
newName (Name -> String
forall a. Show a => a -> String
show Name
temp)
        [(Name, Name)] -> Q ()
forall a. Typeable a => a -> Q ()
putQ ((Name
name, Name
private)(Name, Name) -> [(Name, Name)] -> [(Name, Name)]
forall a. a -> [a] -> [a]
:[(Name, Name)]
cache)
        Name -> Q Name
forall (m :: * -> *) a. Monad m => a -> m a
return Name
private

  conName ∷ Type → Maybe Name
  conName :: Type -> Maybe Name
conName (ConT Name
n)        = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
  conName (AppT Type
x Type
_)      = Type -> Maybe Name
conName Type
x
  conName (AppKindT Type
x Type
_)  = Type -> Maybe Name
conName Type
x
  conName (SigT Type
x Type
_)      = Type -> Maybe Name
conName Type
x
  conName (InfixT Type
_ Name
n Type
_)  = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
  conName (UInfixT Type
_ Name
n Type
_) = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
  conName (ParensT Type
x)     = Type -> Maybe Name
conName Type
x
  conName Type
_               = Maybe Name
forall a. Maybe a
Nothing