{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}
module Data.Time.Zones.Internal.CoerceTH (
getNewTypeCon,
constructNewType,
destructNewType,
) where
import Language.Haskell.TH
getNewTypeCon :: Name -> Q Name
getNewTypeCon :: Name -> Q Name
getNewTypeCon Name
newTy = do
Info
info <- Name -> Q Info
reify Name
newTy
case Info
info of
#if MIN_VERSION_template_haskell(2,11,0)
TyConI (NewtypeD Cxt
_ Name
_ [TyVarBndr]
_ Maybe Kind
_ (NormalC Name
name [BangType]
_) [DerivClause]
_) -> Name -> Q Name
forall (m :: * -> *) a. Monad m => a -> m a
return Name
name
#else
TyConI (NewtypeD _ _ _ (NormalC name _) _) -> return name
#endif
Info
_ -> String -> Q Name
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Not a newtype"
constructNewType :: Name -> Q Exp
constructNewType :: Name -> Q Exp
constructNewType Name
newTy = Name -> Exp
ConE (Name -> Exp) -> Q Name -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Name -> Q Name
getNewTypeCon Name
newTy
mkConP :: Name -> [Pat] -> Pat
mkConP :: Name -> [Pat] -> Pat
mkConP Name
name [Pat]
pats =
#if MIN_VERSION_template_haskell(2,18,0)
ConP name [] pats
#else
Name -> [Pat] -> Pat
ConP Name
name [Pat]
pats
#endif
destructNewType :: Name -> Q Exp
destructNewType :: Name -> Q Exp
destructNewType Name
newTy = do
Name
con <- Name -> Q Name
getNewTypeCon Name
newTy
Name
lamV <- String -> Q Name
newName String
"x"
Name
patV <- String -> Q Name
newName String
"v"
Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$
[Pat] -> Exp -> Exp
LamE [Name -> Pat
VarP Name
lamV]
(Exp -> [Match] -> Exp
CaseE (Name -> Exp
VarE Name
lamV) [
Pat -> Body -> [Dec] -> Match
Match (Name -> [Pat] -> Pat
mkConP Name
con [Name -> Pat
VarP Name
patV]) (Exp -> Body
NormalB (Name -> Exp
VarE Name
patV)) []])