{- |
Module      : Data.Time.Zones.Internal.CoerceTH
Copyright   : (C) 2014 Mihaly Barasz
License     : Apache-2.0, see LICENSE
Maintainer  : Janus Troelsen <ysangkok@gmail.com>
Stability   : experimental
-}

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