{-# 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
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
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
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
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)
#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