{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE LambdaCase     #-}
{-# LANGUAGE CPP            #-}
{-# OPTIONS_GHC -Wno-unused-imports #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Telegram.Bot.API.Internal.TH (makeDefault) where

import Language.Haskell.TH
import Control.Monad.State
import Data.Maybe (catMaybes)
import Control.Applicative(liftA2)

makeDefault :: Name -> Q [Dec]
makeDefault :: Name -> Q [Dec]
makeDefault Name
typeN = do
  Info
info <- Name -> Q Info
reify Name
typeN
  case Info
info of
    TyConI Dec
dec -> case Dec
dec of
      -- no sence to handle other declarations
      DataD Cxt
_ Name
_ [TyVarBndr]
_ Maybe Kind
_ [Con
con] [DerivClause]
_  | Just (Name, Cxt)
x <- Con -> Maybe (Name, Cxt)
getConInfo Con
con -> (Name, Cxt) -> Q [Dec]
makeDefaultFromCon (Name, Cxt)
x
      NewtypeD Cxt
_ Name
_ [TyVarBndr]
_ Maybe Kind
_ Con
con [DerivClause]
_ | Just (Name, Cxt)
x <- Con -> Maybe (Name, Cxt)
getConInfo Con
con -> (Name, Cxt) -> Q [Dec]
makeDefaultFromCon (Name, Cxt)
x
      Dec
_ -> [Char] -> Q [Dec]
forall a. HasCallStack => [Char] -> a
error [Char]
"declaration not supported"
    Info
_ -> [Char] -> Q [Dec]
forall a. HasCallStack => [Char] -> a
error [Char]
"not a type constructor name"
  where
    defName :: Name
defName = Name -> Name
constructDefName Name
typeN
    defNameP :: PatQ
defNameP = Name -> PatQ
varP Name
defName

    makeDefaultFromCon :: (Name, Cxt) -> Q [Dec]
makeDefaultFromCon (Name
conN, Cxt
tys) = let
      type' :: Q Kind
type' = Name -> Cxt -> Q Kind
constructType Name
typeN Cxt
tys
      expr :: Q Exp
expr = Name -> Cxt -> Q Exp
construcExpr Name
conN Cxt
tys
      -- ghc disallows quote of form [d| $name :: some type |]
      sig :: Q [Dec]
sig = Dec -> [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec -> [Dec]) -> Q Dec -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Q Kind -> Q Dec
sigD Name
defName Q Kind
type'

      in Q [Dec]
sig Q [Dec] -> Q [Dec] -> Q [Dec]
forall a. Semigroup a => a -> a -> a
<> [d|
        $defNameP = $expr
      |]

constructDefName :: Name -> Name
constructDefName :: Name -> Name
constructDefName Name
typeN = [Char] -> Name
mkName ([Char]
"def" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char] -> [Char]
trimReq [Char]
typeStr)
  where
    typeStr :: [Char]
typeStr = Name -> [Char]
nameBase Name
typeN

    trimReq :: [Char] -> [Char]
trimReq [Char]
"Request" = []
    trimReq (Char
x:[Char]
xs) = Char
x Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char] -> [Char]
trimReq [Char]
xs
    trimReq [] = []


construcExpr :: Name -> [Type] -> Q Exp
construcExpr :: Name -> Cxt -> Q Exp
construcExpr Name
conN Cxt
tys = let
  mVars :: [Maybe Name]
mVars = (State Int [Maybe Name] -> Int -> [Maybe Name])
-> Int -> State Int [Maybe Name] -> [Maybe Name]
forall a b c. (a -> b -> c) -> b -> a -> c
flip State Int [Maybe Name] -> Int -> [Maybe Name]
forall s a. State s a -> s -> a
evalState Int
0 (State Int [Maybe Name] -> [Maybe Name])
-> State Int [Maybe Name] -> [Maybe Name]
forall a b. (a -> b) -> a -> b
$ (Kind -> StateT Int Identity (Maybe Name))
-> Cxt -> State Int [Maybe Name]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse
    (\Kind
ty -> if Kind -> Bool
isMaybeTy Kind
ty then Maybe Name -> StateT Int Identity (Maybe Name)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Name
forall a. Maybe a
Nothing else Name -> Maybe Name
forall a. a -> Maybe a
Just (Name -> Maybe Name)
-> StateT Int Identity Name -> StateT Int Identity (Maybe Name)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT Int Identity Name
newNameI)
    Cxt
tys

  vars :: [Name]
vars = [Maybe Name] -> [Name]
forall a. [Maybe a] -> [a]
catMaybes [Maybe Name]
mVars

  argExps :: [Q Exp]
argExps = (Maybe Name -> Q Exp) -> [Maybe Name] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map (\case
    Maybe Name
Nothing -> Name -> Q Exp
conE 'Nothing
    Just Name
na -> Name -> Q Exp
varE Name
na) [Maybe Name]
mVars

  in [PatQ] -> Q Exp -> Q Exp
lamE ((Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
vars) ((Q Exp -> Q Exp -> Q Exp) -> Q Exp -> [Q Exp] -> Q Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Exp -> Q Exp -> Q Exp
appE (Name -> Q Exp
conE Name
conN) [Q Exp]
argExps)

constructType :: Name -> [Type] -> Q Type
constructType :: Name -> Cxt -> Q Kind
constructType Name
typeN Cxt
tys = (Kind -> Q Kind -> Q Kind) -> Q Kind -> Cxt -> Q Kind
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Kind -> Q Kind -> Q Kind
arrAp Q Kind
baseTy ((Kind -> Bool) -> Cxt -> Cxt
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Kind -> Bool) -> Kind -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Kind -> Bool
isMaybeTy) Cxt
tys)
  where
    baseTy :: Q Kind
baseTy = Name -> Q Kind
conT Name
typeN
    arrAp :: Kind -> Q Kind -> Q Kind
arrAp Kind
a Q Kind
b = Q Kind -> Q Kind -> Q Kind
appT (Q Kind -> Q Kind -> Q Kind
appT Q Kind
arrowT (Kind -> Q Kind
forall (f :: * -> *) a. Applicative f => a -> f a
pure Kind
a)) Q Kind
b


-- Predicates over TH

getConInfo :: Con -> Maybe (Name, [Type])
getConInfo :: Con -> Maybe (Name, Cxt)
getConInfo (NormalC Name
name [BangType]
tys) = (Name, Cxt) -> Maybe (Name, Cxt)
forall a. a -> Maybe a
Just (Name
name, (BangType -> Kind) -> [BangType] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map BangType -> Kind
forall a b. (a, b) -> b
snd [BangType]
tys)
getConInfo (RecC Name
name [VarBangType]
tys) = (Name, Cxt) -> Maybe (Name, Cxt)
forall a. a -> Maybe a
Just (Name
name, (VarBangType -> Kind) -> [VarBangType] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map (\(Name
_,Bang
_,Kind
x) -> Kind
x) [VarBangType]
tys)
getConInfo Con
_= Maybe (Name, Cxt)
forall a. Maybe a
Nothing

isMaybeTy :: Type -> Bool
isMaybeTy :: Kind -> Bool
isMaybeTy (AppT (ConT Name
m) Kind
_) = Name
m Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Maybe
isMaybeTy Kind
_ = Bool
False

-- State heplers

newInd :: State Int Int
newInd :: State Int Int
newInd = do
  Int
x <- State Int Int
forall s (m :: * -> *). MonadState s m => m s
get
  (Int -> Int) -> StateT Int Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
  Int -> State Int Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
x

newNameI :: State Int Name
newNameI :: StateT Int Identity Name
newNameI = do
  Int
i <- State Int Int
newInd
  Name -> StateT Int Identity Name
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> StateT Int Identity Name)
-> Name -> StateT Int Identity Name
forall a b. (a -> b) -> a -> b
$ [Char] -> Name
mkName ([Char]
"a" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show Int
i)

-- Instance Monoid for TH of ghc < 8.6
#if !MIN_VERSION_template_haskell(2,17,0)

instance Semigroup a => Semigroup (Q a) where
  <> :: Q a -> Q a -> Q a
(<>) = (a -> a -> a) -> Q a -> Q a -> Q a
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> a -> a
forall a. Semigroup a => a -> a -> a
(<>)

instance Monoid a => Monoid (Q a) where
  mempty :: Q a
mempty = a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
forall a. Monoid a => a
mempty

#endif