{-# 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
_ -> forall a. HasCallStack => String -> a
error String
"declaration not supported"
    Info
_ -> forall a. HasCallStack => String -> a
error String
"not a type constructor name"
  where
    defName :: Name
defName = Name -> Name
constructDefName Name
typeN
    defNameP :: Q Pat
defNameP = forall (m :: * -> *). Quote m => Name -> m Pat
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 = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). Quote m => Name -> m Kind -> m Dec
sigD Name
defName Q Kind
type'

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

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

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


construcExpr :: Name -> [Type] -> Q Exp
construcExpr :: Name -> Cxt -> Q Exp
construcExpr Name
conN Cxt
tys = let
  mVars :: [Maybe Name]
mVars = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s a. State s a -> s -> a
evalState Int
0 forall a b. (a -> b) -> a -> b
$ 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 forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> State Int Name
newNameI)
    Cxt
tys

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

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

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

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


-- Predicates over TH

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

isMaybeTy :: Type -> Bool
isMaybeTy :: Kind -> Bool
isMaybeTy (AppT (ConT Name
m) Kind
_) = Name
m 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 <- forall s (m :: * -> *). MonadState s m => m s
get
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (forall a. Num a => a -> a -> a
+Int
1)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
x

newNameI :: State Int Name
newNameI :: State Int Name
newNameI = do
  Int
i <- State Int Int
newInd
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ String -> Name
mkName (String
"a" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
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
  (<>) = liftA2 (<>)

instance Monoid a => Monoid (Q a) where
  mempty = pure mempty

#endif