{- Language/Haskell/TH/Desugar/Sweeten.hs

(c) Richard Eisenberg 2013
rae@cs.brynmawr.edu

Converts desugared TH back into real TH.
-}

{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Language.Haskell.TH.Desugar.Sweeten
-- Copyright   :  (C) 2014 Richard Eisenberg
-- License     :  BSD-style (see LICENSE)
-- Maintainer  :  Ryan Scott
-- Stability   :  experimental
-- Portability :  non-portable
--
-- The functions in this module convert desugared Template Haskell back into
-- proper Template Haskell.
--
----------------------------------------------------------------------------

module Language.Haskell.TH.Desugar.Sweeten (
  expToTH, matchToTH, patToTH, decsToTH, decToTH,
  letDecToTH, typeToTH,

  conToTH, foreignToTH, pragmaToTH, ruleBndrToTH,
  clauseToTH, tvbToTH, cxtToTH, predToTH, derivClauseToTH,
#if __GLASGOW_HASKELL__ >= 801
  patSynDirToTH,
#endif

  typeArgToTH
  ) where

import Prelude hiding (exp)
import Control.Arrow

import Language.Haskell.TH hiding (cxt)
import Language.Haskell.TH.Datatype.TyVarBndr

import Language.Haskell.TH.Desugar.AST
import Language.Haskell.TH.Desugar.Core (DTypeArg(..))
import Language.Haskell.TH.Desugar.Util

expToTH :: DExp -> Exp
expToTH :: DExp -> Exp
expToTH (DVarE Name
n)            = Name -> Exp
VarE Name
n
expToTH (DConE Name
n)            = Name -> Exp
ConE Name
n
expToTH (DLitE Lit
l)            = Lit -> Exp
LitE Lit
l
expToTH (DAppE DExp
e1 DExp
e2)        = Exp -> Exp -> Exp
AppE (DExp -> Exp
expToTH DExp
e1) (DExp -> Exp
expToTH DExp
e2)
expToTH (DLamE [Name]
names DExp
exp)    = [Pat] -> Exp -> Exp
LamE ((Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
names) (DExp -> Exp
expToTH DExp
exp)
expToTH (DCaseE DExp
exp [DMatch]
matches) = Exp -> [Match] -> Exp
CaseE (DExp -> Exp
expToTH DExp
exp) ((DMatch -> Match) -> [DMatch] -> [Match]
forall a b. (a -> b) -> [a] -> [b]
map DMatch -> Match
matchToTH [DMatch]
matches)
expToTH (DLetE [DLetDec]
decs DExp
exp)     = [Dec] -> Exp -> Exp
LetE ((DLetDec -> Dec) -> [DLetDec] -> [Dec]
forall a b. (a -> b) -> [a] -> [b]
map DLetDec -> Dec
letDecToTH [DLetDec]
decs) (DExp -> Exp
expToTH DExp
exp)
expToTH (DSigE DExp
exp DType
ty)       = Exp -> Type -> Exp
SigE (DExp -> Exp
expToTH DExp
exp) (DType -> Type
typeToTH DType
ty)
#if __GLASGOW_HASKELL__ < 709
expToTH (DStaticE _)         = error "Static expressions supported only in GHC 7.10+"
#else
expToTH (DStaticE DExp
exp)       = Exp -> Exp
StaticE (DExp -> Exp
expToTH DExp
exp)
#endif
#if __GLASGOW_HASKELL__ >= 801
expToTH (DAppTypeE DExp
exp DType
ty)   = Exp -> Type -> Exp
AppTypeE (DExp -> Exp
expToTH DExp
exp) (DType -> Type
typeToTH DType
ty)
#else
-- In the event that we're on a version of Template Haskell without support for
-- type applications, we will simply drop the applied type.
expToTH (DAppTypeE exp _)    = expToTH exp
#endif

matchToTH :: DMatch -> Match
matchToTH :: DMatch -> Match
matchToTH (DMatch DPat
pat DExp
exp) = Pat -> Body -> [Dec] -> Match
Match (DPat -> Pat
patToTH DPat
pat) (Exp -> Body
NormalB (DExp -> Exp
expToTH DExp
exp)) []

patToTH :: DPat -> Pat
patToTH :: DPat -> Pat
patToTH (DLitP Lit
lit)         = Lit -> Pat
LitP Lit
lit
patToTH (DVarP Name
n)           = Name -> Pat
VarP Name
n
patToTH (DConP Name
n [DType]
_tys [DPat]
pats) = Name -> [Pat] -> Pat
ConP Name
n
#if __GLASGOW_HASKELL__ >= 901
                                   (map typeToTH _tys)
#endif
                                   ((DPat -> Pat) -> [DPat] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map DPat -> Pat
patToTH [DPat]
pats)
patToTH (DTildeP DPat
pat)       = Pat -> Pat
TildeP (DPat -> Pat
patToTH DPat
pat)
patToTH (DBangP DPat
pat)        = Pat -> Pat
BangP (DPat -> Pat
patToTH DPat
pat)
patToTH (DSigP DPat
pat DType
ty)      = Pat -> Type -> Pat
SigP (DPat -> Pat
patToTH DPat
pat) (DType -> Type
typeToTH DType
ty)
patToTH DPat
DWildP              = Pat
WildP

decsToTH :: [DDec] -> [Dec]
decsToTH :: [DDec] -> [Dec]
decsToTH = (DDec -> Dec) -> [DDec] -> [Dec]
forall a b. (a -> b) -> [a] -> [b]
map DDec -> Dec
decToTH

-- | This returns a list of @Dec@s because GHC 7.6.3 does not have
-- a one-to-one mapping between 'DDec' and @Dec@.
decToTH :: DDec -> Dec
decToTH :: DDec -> Dec
decToTH (DLetDec DLetDec
d) = DLetDec -> Dec
letDecToTH DLetDec
d
decToTH (DDataD NewOrData
Data [DType]
cxt Name
n [DTyVarBndrUnit]
tvbs Maybe DType
_mk [DCon]
cons [DDerivClause]
derivings) =
#if __GLASGOW_HASKELL__ > 710
  Cxt
-> Name
-> [TyVarBndr]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataD ([DType] -> Cxt
cxtToTH [DType]
cxt) Name
n ((DTyVarBndrUnit -> TyVarBndr) -> [DTyVarBndrUnit] -> [TyVarBndr]
forall a b. (a -> b) -> [a] -> [b]
map DTyVarBndrUnit -> TyVarBndr
forall flag. DTyVarBndr flag -> TyVarBndr
tvbToTH [DTyVarBndrUnit]
tvbs) ((DType -> Type) -> Maybe DType -> Maybe Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DType -> Type
typeToTH Maybe DType
_mk) ((DCon -> Con) -> [DCon] -> [Con]
forall a b. (a -> b) -> [a] -> [b]
map DCon -> Con
conToTH [DCon]
cons)
        ((DDerivClause -> [DerivClause]) -> [DDerivClause] -> [DerivClause]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap DDerivClause -> [DerivClause]
derivClauseToTH [DDerivClause]
derivings)
#else
  DataD (cxtToTH cxt) n (map tvbToTH tvbs) (map conToTH cons)
        (map derivingToTH derivings)
#endif
decToTH (DDataD NewOrData
Newtype [DType]
cxt Name
n [DTyVarBndrUnit]
tvbs Maybe DType
_mk [DCon
con] [DDerivClause]
derivings) =
#if __GLASGOW_HASKELL__ > 710
  Cxt
-> Name -> [TyVarBndr] -> Maybe Type -> Con -> [DerivClause] -> Dec
NewtypeD ([DType] -> Cxt
cxtToTH [DType]
cxt) Name
n ((DTyVarBndrUnit -> TyVarBndr) -> [DTyVarBndrUnit] -> [TyVarBndr]
forall a b. (a -> b) -> [a] -> [b]
map DTyVarBndrUnit -> TyVarBndr
forall flag. DTyVarBndr flag -> TyVarBndr
tvbToTH [DTyVarBndrUnit]
tvbs) ((DType -> Type) -> Maybe DType -> Maybe Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DType -> Type
typeToTH Maybe DType
_mk) (DCon -> Con
conToTH DCon
con)
           ((DDerivClause -> [DerivClause]) -> [DDerivClause] -> [DerivClause]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap DDerivClause -> [DerivClause]
derivClauseToTH [DDerivClause]
derivings)
#else
  NewtypeD (cxtToTH cxt) n (map tvbToTH tvbs) (conToTH con)
           (map derivingToTH derivings)
#endif
decToTH (DDataD NewOrData
Newtype [DType]
_cxt Name
_n [DTyVarBndrUnit]
_tvbs Maybe DType
_mk [DCon]
_cons [DDerivClause]
_derivings) =
  [Char] -> Dec
forall a. HasCallStack => [Char] -> a
error [Char]
"Newtype declaration without exactly 1 constructor."
decToTH (DTySynD Name
n [DTyVarBndrUnit]
tvbs DType
ty) = Name -> [TyVarBndr] -> Type -> Dec
TySynD Name
n ((DTyVarBndrUnit -> TyVarBndr) -> [DTyVarBndrUnit] -> [TyVarBndr]
forall a b. (a -> b) -> [a] -> [b]
map DTyVarBndrUnit -> TyVarBndr
forall flag. DTyVarBndr flag -> TyVarBndr
tvbToTH [DTyVarBndrUnit]
tvbs) (DType -> Type
typeToTH DType
ty)
decToTH (DClassD [DType]
cxt Name
n [DTyVarBndrUnit]
tvbs [FunDep]
fds [DDec]
decs) =
  Cxt -> Name -> [TyVarBndr] -> [FunDep] -> [Dec] -> Dec
ClassD ([DType] -> Cxt
cxtToTH [DType]
cxt) Name
n ((DTyVarBndrUnit -> TyVarBndr) -> [DTyVarBndrUnit] -> [TyVarBndr]
forall a b. (a -> b) -> [a] -> [b]
map DTyVarBndrUnit -> TyVarBndr
forall flag. DTyVarBndr flag -> TyVarBndr
tvbToTH [DTyVarBndrUnit]
tvbs) [FunDep]
fds ([DDec] -> [Dec]
decsToTH [DDec]
decs)
decToTH (DInstanceD Maybe Overlap
over Maybe [DTyVarBndrUnit]
_mtvbs [DType]
cxt DType
ty [DDec]
decs) =
  -- We deliberately avoid sweetening _mtvbs. See #151.
  Maybe Overlap -> [DType] -> DType -> [DDec] -> Dec
instanceDToTH Maybe Overlap
over [DType]
cxt DType
ty [DDec]
decs
decToTH (DForeignD DForeign
f) = Foreign -> Dec
ForeignD (DForeign -> Foreign
foreignToTH DForeign
f)
#if __GLASGOW_HASKELL__ > 710
decToTH (DOpenTypeFamilyD (DTypeFamilyHead Name
n [DTyVarBndrUnit]
tvbs DFamilyResultSig
frs Maybe InjectivityAnn
ann)) =
  TypeFamilyHead -> Dec
OpenTypeFamilyD (Name
-> [TyVarBndr]
-> FamilyResultSig
-> Maybe InjectivityAnn
-> TypeFamilyHead
TypeFamilyHead Name
n ((DTyVarBndrUnit -> TyVarBndr) -> [DTyVarBndrUnit] -> [TyVarBndr]
forall a b. (a -> b) -> [a] -> [b]
map DTyVarBndrUnit -> TyVarBndr
forall flag. DTyVarBndr flag -> TyVarBndr
tvbToTH [DTyVarBndrUnit]
tvbs) (DFamilyResultSig -> FamilyResultSig
frsToTH DFamilyResultSig
frs) Maybe InjectivityAnn
ann)
#else
decToTH (DOpenTypeFamilyD (DTypeFamilyHead n tvbs frs _ann)) =
  FamilyD TypeFam n (map tvbToTH tvbs) (frsToTH frs)
#endif
decToTH (DDataFamilyD Name
n [DTyVarBndrUnit]
tvbs Maybe DType
mk) =
#if __GLASGOW_HASKELL__ > 710
  Name -> [TyVarBndr] -> Maybe Type -> Dec
DataFamilyD Name
n ((DTyVarBndrUnit -> TyVarBndr) -> [DTyVarBndrUnit] -> [TyVarBndr]
forall a b. (a -> b) -> [a] -> [b]
map DTyVarBndrUnit -> TyVarBndr
forall flag. DTyVarBndr flag -> TyVarBndr
tvbToTH [DTyVarBndrUnit]
tvbs) ((DType -> Type) -> Maybe DType -> Maybe Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DType -> Type
typeToTH Maybe DType
mk)
#else
  FamilyD DataFam n (map tvbToTH tvbs) (fmap typeToTH mk)
#endif
decToTH (DDataInstD NewOrData
nd [DType]
cxt Maybe [DTyVarBndrUnit]
mtvbs DType
lhs Maybe DType
mk [DCon]
cons [DDerivClause]
derivings) =
  let ndc :: DNewOrDataCons
ndc = case (NewOrData
nd, [DCon]
cons) of
              (NewOrData
Newtype, [DCon
con]) -> DCon -> DNewOrDataCons
DNewtypeCon DCon
con
              (NewOrData
Newtype, [DCon]
_)     -> [Char] -> DNewOrDataCons
forall a. HasCallStack => [Char] -> a
error [Char]
"Newtype that doesn't have only one constructor"
              (NewOrData
Data,    [DCon]
_)     -> [DCon] -> DNewOrDataCons
DDataCons [DCon]
cons
  in DNewOrDataCons
-> [DType]
-> Maybe [DTyVarBndrUnit]
-> DType
-> Maybe DType
-> [DDerivClause]
-> Dec
dataInstDecToTH DNewOrDataCons
ndc [DType]
cxt Maybe [DTyVarBndrUnit]
mtvbs DType
lhs Maybe DType
mk [DDerivClause]
derivings
#if __GLASGOW_HASKELL__ >= 807
decToTH (DTySynInstD DTySynEqn
eqn) = TySynEqn -> Dec
TySynInstD ((Name, TySynEqn) -> TySynEqn
forall a b. (a, b) -> b
snd ((Name, TySynEqn) -> TySynEqn) -> (Name, TySynEqn) -> TySynEqn
forall a b. (a -> b) -> a -> b
$ DTySynEqn -> (Name, TySynEqn)
tySynEqnToTH DTySynEqn
eqn)
#else
decToTH (DTySynInstD eqn) =
  let (n, eqn') = tySynEqnToTH eqn in
  TySynInstD n eqn'
#endif
#if __GLASGOW_HASKELL__ > 710
decToTH (DClosedTypeFamilyD (DTypeFamilyHead Name
n [DTyVarBndrUnit]
tvbs DFamilyResultSig
frs Maybe InjectivityAnn
ann) [DTySynEqn]
eqns) =
  TypeFamilyHead -> [TySynEqn] -> Dec
ClosedTypeFamilyD (Name
-> [TyVarBndr]
-> FamilyResultSig
-> Maybe InjectivityAnn
-> TypeFamilyHead
TypeFamilyHead Name
n ((DTyVarBndrUnit -> TyVarBndr) -> [DTyVarBndrUnit] -> [TyVarBndr]
forall a b. (a -> b) -> [a] -> [b]
map DTyVarBndrUnit -> TyVarBndr
forall flag. DTyVarBndr flag -> TyVarBndr
tvbToTH [DTyVarBndrUnit]
tvbs) (DFamilyResultSig -> FamilyResultSig
frsToTH DFamilyResultSig
frs) Maybe InjectivityAnn
ann)
                    ((DTySynEqn -> TySynEqn) -> [DTySynEqn] -> [TySynEqn]
forall a b. (a -> b) -> [a] -> [b]
map ((Name, TySynEqn) -> TySynEqn
forall a b. (a, b) -> b
snd ((Name, TySynEqn) -> TySynEqn)
-> (DTySynEqn -> (Name, TySynEqn)) -> DTySynEqn -> TySynEqn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DTySynEqn -> (Name, TySynEqn)
tySynEqnToTH) [DTySynEqn]
eqns)
#else
decToTH (DClosedTypeFamilyD (DTypeFamilyHead n tvbs frs _ann) eqns) =
  ClosedTypeFamilyD n (map tvbToTH tvbs) (frsToTH frs) (map (snd . tySynEqnToTH) eqns)
#endif
decToTH (DRoleAnnotD Name
n [Role]
roles) = Name -> [Role] -> Dec
RoleAnnotD Name
n [Role]
roles
decToTH (DStandaloneDerivD Maybe DDerivStrategy
mds Maybe [DTyVarBndrUnit]
_mtvbs [DType]
cxt DType
ty) =
  -- We deliberately avoid sweetening _mtvbs. See #151.
  Maybe DDerivStrategy -> [DType] -> DType -> Dec
standaloneDerivDToTH Maybe DDerivStrategy
mds [DType]
cxt DType
ty
#if __GLASGOW_HASKELL__ < 709
decToTH (DDefaultSigD {})      =
  error "Default method signatures supported only in GHC 7.10+"
#else
decToTH (DDefaultSigD Name
n DType
ty)        = Name -> Type -> Dec
DefaultSigD Name
n (DType -> Type
typeToTH DType
ty)
#endif
#if __GLASGOW_HASKELL__ >= 801
decToTH (DPatSynD Name
n PatSynArgs
args DPatSynDir
dir DPat
pat) = Name -> PatSynArgs -> PatSynDir -> Pat -> Dec
PatSynD Name
n PatSynArgs
args (DPatSynDir -> PatSynDir
patSynDirToTH DPatSynDir
dir) (DPat -> Pat
patToTH DPat
pat)
decToTH (DPatSynSigD Name
n DType
ty)        = Name -> Type -> Dec
PatSynSigD Name
n (DType -> Type
typeToTH DType
ty)
#else
decToTH DPatSynD{}    = patSynErr
decToTH DPatSynSigD{} = patSynErr
#endif
#if __GLASGOW_HASKELL__ >= 809
decToTH (DKiSigD Name
n DType
ki) = Name -> Type -> Dec
KiSigD Name
n (DType -> Type
typeToTH DType
ki)
#else
decToTH (DKiSigD {})   =
  error "Standalone kind signatures supported only in GHC 8.10+"
#endif

#if __GLASGOW_HASKELL__ < 801
patSynErr :: a
patSynErr = error "Pattern synonyms supported only in GHC 8.2+"
#endif

-- | Indicates whether something is a newtype or data type, bundling its
-- constructor(s) along with it.
data DNewOrDataCons
  = DNewtypeCon DCon
  | DDataCons   [DCon]

-- | Sweeten a 'DDataInstD'.
dataInstDecToTH :: DNewOrDataCons -> DCxt -> Maybe [DTyVarBndrUnit] -> DType
                -> Maybe DKind -> [DDerivClause] -> Dec
dataInstDecToTH :: DNewOrDataCons
-> [DType]
-> Maybe [DTyVarBndrUnit]
-> DType
-> Maybe DType
-> [DDerivClause]
-> Dec
dataInstDecToTH DNewOrDataCons
ndc [DType]
cxt Maybe [DTyVarBndrUnit]
_mtvbs DType
lhs Maybe DType
_mk [DDerivClause]
derivings =
  case DNewOrDataCons
ndc of
    DNewtypeCon DCon
con ->
#if __GLASGOW_HASKELL__ >= 807
      Cxt
-> Maybe [TyVarBndr]
-> Type
-> Maybe Type
-> Con
-> [DerivClause]
-> Dec
NewtypeInstD ([DType] -> Cxt
cxtToTH [DType]
cxt) (([DTyVarBndrUnit] -> [TyVarBndr])
-> Maybe [DTyVarBndrUnit] -> Maybe [TyVarBndr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((DTyVarBndrUnit -> TyVarBndr) -> [DTyVarBndrUnit] -> [TyVarBndr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DTyVarBndrUnit -> TyVarBndr
forall flag. DTyVarBndr flag -> TyVarBndr
tvbToTH) Maybe [DTyVarBndrUnit]
_mtvbs) (DType -> Type
typeToTH DType
lhs)
                   ((DType -> Type) -> Maybe DType -> Maybe Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DType -> Type
typeToTH Maybe DType
_mk) (DCon -> Con
conToTH DCon
con)
                   ((DDerivClause -> [DerivClause]) -> [DDerivClause] -> [DerivClause]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap DDerivClause -> [DerivClause]
derivClauseToTH [DDerivClause]
derivings)
#elif __GLASGOW_HASKELL__ > 710
      NewtypeInstD (cxtToTH cxt) _n _lhs_args (fmap typeToTH _mk) (conToTH con)
                   (concatMap derivClauseToTH derivings)
#else
      NewtypeInstD (cxtToTH cxt) _n _lhs_args (conToTH con)
                   (map derivingToTH derivings)
#endif

    DDataCons [DCon]
cons ->
#if __GLASGOW_HASKELL__ >= 807
      Cxt
-> Maybe [TyVarBndr]
-> Type
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataInstD ([DType] -> Cxt
cxtToTH [DType]
cxt) (([DTyVarBndrUnit] -> [TyVarBndr])
-> Maybe [DTyVarBndrUnit] -> Maybe [TyVarBndr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((DTyVarBndrUnit -> TyVarBndr) -> [DTyVarBndrUnit] -> [TyVarBndr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DTyVarBndrUnit -> TyVarBndr
forall flag. DTyVarBndr flag -> TyVarBndr
tvbToTH) Maybe [DTyVarBndrUnit]
_mtvbs) (DType -> Type
typeToTH DType
lhs)
                ((DType -> Type) -> Maybe DType -> Maybe Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DType -> Type
typeToTH Maybe DType
_mk) ((DCon -> Con) -> [DCon] -> [Con]
forall a b. (a -> b) -> [a] -> [b]
map DCon -> Con
conToTH [DCon]
cons)
                ((DDerivClause -> [DerivClause]) -> [DDerivClause] -> [DerivClause]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap DDerivClause -> [DerivClause]
derivClauseToTH [DDerivClause]
derivings)
#elif __GLASGOW_HASKELL__ > 710
      DataInstD (cxtToTH cxt) _n _lhs_args (fmap typeToTH _mk) (map conToTH cons)
                (concatMap derivClauseToTH derivings)
#else
      DataInstD (cxtToTH cxt) _n _lhs_args (map conToTH cons)
                (map derivingToTH derivings)
#endif
  where
    _lhs' :: Type
_lhs' = DType -> Type
typeToTH DType
lhs
    (Name
_n, Cxt
_lhs_args) =
      case Type -> (Type, [TypeArg])
unfoldType Type
_lhs' of
        (ConT Name
n, [TypeArg]
lhs_args) -> (Name
n, [TypeArg] -> Cxt
filterTANormals [TypeArg]
lhs_args)
        (Type
_, [TypeArg]
_) -> [Char] -> (Name, Cxt)
forall a. HasCallStack => [Char] -> a
error ([Char] -> (Name, Cxt)) -> [Char] -> (Name, Cxt)
forall a b. (a -> b) -> a -> b
$ [Char]
"Illegal data instance LHS: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Type -> [Char]
forall a. Ppr a => a -> [Char]
pprint Type
_lhs'

#if __GLASGOW_HASKELL__ > 710
frsToTH :: DFamilyResultSig -> FamilyResultSig
frsToTH :: DFamilyResultSig -> FamilyResultSig
frsToTH DFamilyResultSig
DNoSig          = FamilyResultSig
NoSig
frsToTH (DKindSig DType
k)    = Type -> FamilyResultSig
KindSig (DType -> Type
typeToTH DType
k)
frsToTH (DTyVarSig DTyVarBndrUnit
tvb) = TyVarBndr -> FamilyResultSig
TyVarSig (DTyVarBndrUnit -> TyVarBndr
forall flag. DTyVarBndr flag -> TyVarBndr
tvbToTH DTyVarBndrUnit
tvb)
#else
frsToTH :: DFamilyResultSig -> Maybe Kind
frsToTH DNoSig                        = Nothing
frsToTH (DKindSig k)                  = Just (typeToTH k)
frsToTH (DTyVarSig (DPlainTV _ _))    = Nothing
frsToTH (DTyVarSig (DKindedTV _ _ k)) = Just (typeToTH k)
#endif

#if __GLASGOW_HASKELL__ <= 710
derivingToTH :: DDerivClause -> Name
derivingToTH (DDerivClause _ [DConT nm]) = nm
derivingToTH p =
  error ("Template Haskell in GHC < 8.0 only allows simple derivings: " ++ show p)
#endif

-- | Sweeten a 'DLetDec'.
letDecToTH :: DLetDec -> Dec
letDecToTH :: DLetDec -> Dec
letDecToTH (DFunD Name
name [DClause]
clauses) = Name -> [Clause] -> Dec
FunD Name
name ((DClause -> Clause) -> [DClause] -> [Clause]
forall a b. (a -> b) -> [a] -> [b]
map DClause -> Clause
clauseToTH [DClause]
clauses)
letDecToTH (DValD DPat
pat DExp
exp)      = Pat -> Body -> [Dec] -> Dec
ValD (DPat -> Pat
patToTH DPat
pat) (Exp -> Body
NormalB (DExp -> Exp
expToTH DExp
exp)) []
letDecToTH (DSigD Name
name DType
ty)      = Name -> Type -> Dec
SigD Name
name (DType -> Type
typeToTH DType
ty)
letDecToTH (DInfixD Fixity
f Name
name)     = Fixity -> Name -> Dec
InfixD Fixity
f Name
name
letDecToTH (DPragmaD DPragma
prag)      = Pragma -> Dec
PragmaD (DPragma -> Pragma
pragmaToTH DPragma
prag)

conToTH :: DCon -> Con
#if __GLASGOW_HASKELL__ > 710
conToTH :: DCon -> Con
conToTH (DCon [] [] Name
n (DNormalC DDeclaredInfix
_ [DBangType]
stys) DType
rty) =
  [Name] -> [BangType] -> Type -> Con
GadtC [Name
n] ((DBangType -> BangType) -> [DBangType] -> [BangType]
forall a b. (a -> b) -> [a] -> [b]
map ((DType -> Type) -> DBangType -> BangType
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second DType -> Type
typeToTH) [DBangType]
stys) (DType -> Type
typeToTH DType
rty)
conToTH (DCon [] [] Name
n (DRecC [DVarBangType]
vstys) DType
rty) =
  [Name] -> [VarBangType] -> Type -> Con
RecGadtC [Name
n] ((DVarBangType -> VarBangType) -> [DVarBangType] -> [VarBangType]
forall a b. (a -> b) -> [a] -> [b]
map ((DType -> Type) -> DVarBangType -> VarBangType
forall a b c d. (a -> b) -> (c, d, a) -> (c, d, b)
thirdOf3 DType -> Type
typeToTH) [DVarBangType]
vstys) (DType -> Type
typeToTH DType
rty)
#else
conToTH (DCon [] [] n (DNormalC True [sty1, sty2]) _) =
  InfixC ((bangToStrict *** typeToTH) sty1) n ((bangToStrict *** typeToTH) sty2)
-- Note: it's possible that someone could pass in a DNormalC value that
-- erroneously claims that it's declared infix (e.g., if has more than two
-- fields), but we will fall back on NormalC in such a scenario.
conToTH (DCon [] [] n (DNormalC _ stys) _) =
  NormalC n (map (bangToStrict *** typeToTH) stys)
conToTH (DCon [] [] n (DRecC vstys) _) =
  RecC n (map (\(v,b,t) -> (v,bangToStrict b,typeToTH t)) vstys)
#endif
#if __GLASGOW_HASKELL__ > 710
-- On GHC 8.0 or later, we sweeten every constructor to GADT syntax, so it is
-- perfectly OK to put all of the quantified type variables
-- (both universal and existential) in a ForallC.
conToTH (DCon [DTyVarBndrSpec]
tvbs [DType]
cxt Name
n DConFields
fields DType
rty) =
  [TyVarBndr] -> Cxt -> Con -> Con
ForallC ((DTyVarBndrSpec -> TyVarBndr) -> [DTyVarBndrSpec] -> [TyVarBndr]
forall a b. (a -> b) -> [a] -> [b]
map DTyVarBndrSpec -> TyVarBndr
forall flag. DTyVarBndr flag -> TyVarBndr
tvbToTH [DTyVarBndrSpec]
tvbs) ([DType] -> Cxt
cxtToTH [DType]
cxt) (DCon -> Con
conToTH (DCon -> Con) -> DCon -> Con
forall a b. (a -> b) -> a -> b
$ [DTyVarBndrSpec] -> [DType] -> Name -> DConFields -> DType -> DCon
DCon [] [] Name
n DConFields
fields DType
rty)
#else
-- On GHCs earlier than 8.0, we must be careful, since the only time ForallC is
-- used is when there are either:
--
-- 1. Any existentially quantified type variables
-- 2. A constructor context
--
-- If neither of these conditions hold, then we needn't put a ForallC at the
-- front, since it would be completely pointless (you'd end up with things like
-- @data Foo = forall. MkFoo@!).
conToTH (DCon tvbs cxt n fields rty)
  | null ex_tvbs && null cxt
  = con'
  | otherwise
  = ForallC ex_tvbs (cxtToTH cxt) con'
  where
    -- Fortunately, on old GHCs, it's especially easy to distinguish between
    -- universally and existentially quantified type variables. When desugaring
    -- a ForallC, we just stick all of the universals (from the datatype
    -- definition) at the front of the @forall@. Therefore, it suffices to
    -- count the number of type variables in the return type and drop that many
    -- variables from the @forall@ in the ForallC, leaving only the
    -- existentials.
    ex_tvbs :: [TyVarBndr]
    ex_tvbs = map tvbToTH $ drop num_univ_tvs tvbs

    num_univ_tvs :: Int
    num_univ_tvs = go rty
      where
        go :: DType -> Int
        go (DAppT t1 t2) = go t1 + go t2
        go (DSigT t _)   = go t
        go (DVarT {})    = 1
        go (DConT {})    = 0
        go DArrowT       = 0
        go (DLitT {})    = 0
        -- These won't show up on pre-8.0 GHCs
        go (DForallT {})      = error "`forall` type used in GADT return type"
        go (DConstrainedT {}) = error "Constrained type used in GADT return type"
        go DWildCardT         = 0
        go (DAppKindT {})     = 0

    con' :: Con
    con' = conToTH $ DCon [] [] n fields rty
#endif

instanceDToTH :: Maybe Overlap -> DCxt -> DType -> [DDec] -> Dec
instanceDToTH :: Maybe Overlap -> [DType] -> DType -> [DDec] -> Dec
instanceDToTH Maybe Overlap
_over [DType]
cxt DType
ty [DDec]
decs =
  Maybe Overlap -> Cxt -> Type -> [Dec] -> Dec
InstanceD
#if __GLASGOW_HASKELL__ >= 800
            Maybe Overlap
_over
#endif
            ([DType] -> Cxt
cxtToTH [DType]
cxt) (DType -> Type
typeToTH DType
ty) ([DDec] -> [Dec]
decsToTH [DDec]
decs)

standaloneDerivDToTH :: Maybe DDerivStrategy -> DCxt -> DType -> Dec
#if __GLASGOW_HASKELL__ >= 710
standaloneDerivDToTH :: Maybe DDerivStrategy -> [DType] -> DType -> Dec
standaloneDerivDToTH Maybe DDerivStrategy
_mds [DType]
cxt DType
ty =
  Maybe DerivStrategy -> Cxt -> Type -> Dec
StandaloneDerivD
#if __GLASGOW_HASKELL__ >= 802
                   ((DDerivStrategy -> DerivStrategy)
-> Maybe DDerivStrategy -> Maybe DerivStrategy
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DDerivStrategy -> DerivStrategy
derivStrategyToTH Maybe DDerivStrategy
_mds)
#endif
                   ([DType] -> Cxt
cxtToTH [DType]
cxt) (DType -> Type
typeToTH DType
ty)
#else
standaloneDerivDToTH _ _ _ = error "Standalone deriving supported only in GHC 7.10+"
#endif

foreignToTH :: DForeign -> Foreign
foreignToTH :: DForeign -> Foreign
foreignToTH (DImportF Callconv
cc Safety
safety [Char]
str Name
n DType
ty) =
  Callconv -> Safety -> [Char] -> Name -> Type -> Foreign
ImportF Callconv
cc Safety
safety [Char]
str Name
n (DType -> Type
typeToTH DType
ty)
foreignToTH (DExportF Callconv
cc [Char]
str Name
n DType
ty) = Callconv -> [Char] -> Name -> Type -> Foreign
ExportF Callconv
cc [Char]
str Name
n (DType -> Type
typeToTH DType
ty)

pragmaToTH :: DPragma -> Pragma
pragmaToTH :: DPragma -> Pragma
pragmaToTH (DInlineP Name
n Inline
inl RuleMatch
rm Phases
phases) = Name -> Inline -> RuleMatch -> Phases -> Pragma
InlineP Name
n Inline
inl RuleMatch
rm Phases
phases
pragmaToTH (DSpecialiseP Name
n DType
ty Maybe Inline
m_inl Phases
phases) =
  Name -> Type -> Maybe Inline -> Phases -> Pragma
SpecialiseP Name
n (DType -> Type
typeToTH DType
ty) Maybe Inline
m_inl Phases
phases
pragmaToTH (DSpecialiseInstP DType
ty) = Type -> Pragma
SpecialiseInstP (DType -> Type
typeToTH DType
ty)
#if __GLASGOW_HASKELL__ >= 807
pragmaToTH (DRuleP [Char]
str Maybe [DTyVarBndrUnit]
mtvbs [DRuleBndr]
rbs DExp
lhs DExp
rhs Phases
phases) =
  [Char]
-> Maybe [TyVarBndr]
-> [RuleBndr]
-> Exp
-> Exp
-> Phases
-> Pragma
RuleP [Char]
str (([DTyVarBndrUnit] -> [TyVarBndr])
-> Maybe [DTyVarBndrUnit] -> Maybe [TyVarBndr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((DTyVarBndrUnit -> TyVarBndr) -> [DTyVarBndrUnit] -> [TyVarBndr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DTyVarBndrUnit -> TyVarBndr
forall flag. DTyVarBndr flag -> TyVarBndr
tvbToTH) Maybe [DTyVarBndrUnit]
mtvbs) ((DRuleBndr -> RuleBndr) -> [DRuleBndr] -> [RuleBndr]
forall a b. (a -> b) -> [a] -> [b]
map DRuleBndr -> RuleBndr
ruleBndrToTH [DRuleBndr]
rbs)
        (DExp -> Exp
expToTH DExp
lhs) (DExp -> Exp
expToTH DExp
rhs) Phases
phases
#else
pragmaToTH (DRuleP str _ rbs lhs rhs phases) =
  RuleP str (map ruleBndrToTH rbs) (expToTH lhs) (expToTH rhs) phases
#endif
pragmaToTH (DAnnP AnnTarget
target DExp
exp) = AnnTarget -> Exp -> Pragma
AnnP AnnTarget
target (DExp -> Exp
expToTH DExp
exp)
#if __GLASGOW_HASKELL__ < 709
pragmaToTH (DLineP {}) = error "LINE pragmas only supported in GHC 7.10+"
#else
pragmaToTH (DLineP Int
n [Char]
str) = Int -> [Char] -> Pragma
LineP Int
n [Char]
str
#endif
#if __GLASGOW_HASKELL__ < 801
pragmaToTH (DCompleteP {}) = error "COMPLETE pragmas only supported in GHC 8.2+"
#else
pragmaToTH (DCompleteP [Name]
cls Maybe Name
mty) = [Name] -> Maybe Name -> Pragma
CompleteP [Name]
cls Maybe Name
mty
#endif

ruleBndrToTH :: DRuleBndr -> RuleBndr
ruleBndrToTH :: DRuleBndr -> RuleBndr
ruleBndrToTH (DRuleVar Name
n) = Name -> RuleBndr
RuleVar Name
n
ruleBndrToTH (DTypedRuleVar Name
n DType
ty) = Name -> Type -> RuleBndr
TypedRuleVar Name
n (DType -> Type
typeToTH DType
ty)

#if __GLASGOW_HASKELL__ >= 807
-- | It's convenient to also return a 'Name' here, since some call sites make
-- use of it.
tySynEqnToTH :: DTySynEqn -> (Name, TySynEqn)
tySynEqnToTH :: DTySynEqn -> (Name, TySynEqn)
tySynEqnToTH (DTySynEqn Maybe [DTyVarBndrUnit]
tvbs DType
lhs DType
rhs) =
  let lhs' :: Type
lhs' = DType -> Type
typeToTH DType
lhs in
  case Type -> (Type, [TypeArg])
unfoldType Type
lhs' of
    (ConT Name
n, [TypeArg]
_lhs_args) -> (Name
n, Maybe [TyVarBndr] -> Type -> Type -> TySynEqn
TySynEqn (([DTyVarBndrUnit] -> [TyVarBndr])
-> Maybe [DTyVarBndrUnit] -> Maybe [TyVarBndr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((DTyVarBndrUnit -> TyVarBndr) -> [DTyVarBndrUnit] -> [TyVarBndr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DTyVarBndrUnit -> TyVarBndr
forall flag. DTyVarBndr flag -> TyVarBndr
tvbToTH) Maybe [DTyVarBndrUnit]
tvbs) Type
lhs' (DType -> Type
typeToTH DType
rhs))
    (Type
_, [TypeArg]
_) -> [Char] -> (Name, TySynEqn)
forall a. HasCallStack => [Char] -> a
error ([Char] -> (Name, TySynEqn)) -> [Char] -> (Name, TySynEqn)
forall a b. (a -> b) -> a -> b
$ [Char]
"Illegal type instance LHS: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Type -> [Char]
forall a. Ppr a => a -> [Char]
pprint Type
lhs'
#else
tySynEqnToTH :: DTySynEqn -> (Name, TySynEqn)
tySynEqnToTH (DTySynEqn _ lhs rhs) =
  let lhs' = typeToTH lhs in
  case unfoldType lhs' of
    (ConT n, lhs_args) -> (n, TySynEqn (filterTANormals lhs_args) (typeToTH rhs))
    (_, _) -> error $ "Illegal type instance LHS: " ++ pprint lhs'
#endif

clauseToTH :: DClause -> Clause
clauseToTH :: DClause -> Clause
clauseToTH (DClause [DPat]
pats DExp
exp) = [Pat] -> Body -> [Dec] -> Clause
Clause ((DPat -> Pat) -> [DPat] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map DPat -> Pat
patToTH [DPat]
pats) (Exp -> Body
NormalB (DExp -> Exp
expToTH DExp
exp)) []

typeToTH :: DType -> Type
-- We need a special case for DForallT ForallInvis followed by DConstrainedT
-- so that we may collapse them into a single ForallT when sweetening.
-- See Note [Desugaring and sweetening ForallT] in L.H.T.Desugar.Core.
typeToTH :: DType -> Type
typeToTH (DForallT (DForallInvis [DTyVarBndrSpec]
tvbs) (DConstrainedT [DType]
ctxt DType
ty)) =
  [TyVarBndr] -> Cxt -> Type -> Type
ForallT ((DTyVarBndrSpec -> TyVarBndr) -> [DTyVarBndrSpec] -> [TyVarBndr]
forall a b. (a -> b) -> [a] -> [b]
map DTyVarBndrSpec -> TyVarBndr
forall flag. DTyVarBndr flag -> TyVarBndr
tvbToTH [DTyVarBndrSpec]
tvbs) ((DType -> Type) -> [DType] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map DType -> Type
predToTH [DType]
ctxt) (DType -> Type
typeToTH DType
ty)
typeToTH (DForallT DForallTelescope
tele DType
ty) =
  case DForallTelescope
tele of
    DForallInvis  [DTyVarBndrSpec]
tvbs -> [TyVarBndr] -> Cxt -> Type -> Type
ForallT ((DTyVarBndrSpec -> TyVarBndr) -> [DTyVarBndrSpec] -> [TyVarBndr]
forall a b. (a -> b) -> [a] -> [b]
map DTyVarBndrSpec -> TyVarBndr
forall flag. DTyVarBndr flag -> TyVarBndr
tvbToTH [DTyVarBndrSpec]
tvbs) [] Type
ty'
    DForallVis   [DTyVarBndrUnit]
_tvbs ->
#if __GLASGOW_HASKELL__ >= 809
      [TyVarBndr] -> Type -> Type
ForallVisT ((DTyVarBndrUnit -> TyVarBndr) -> [DTyVarBndrUnit] -> [TyVarBndr]
forall a b. (a -> b) -> [a] -> [b]
map DTyVarBndrUnit -> TyVarBndr
forall flag. DTyVarBndr flag -> TyVarBndr
tvbToTH [DTyVarBndrUnit]
_tvbs) Type
ty'
#else
      error "Visible dependent quantification supported only in GHC 8.10+"
#endif
  where
    ty' :: Type
ty'   = DType -> Type
typeToTH DType
ty
typeToTH (DConstrainedT [DType]
cxt DType
ty) = [TyVarBndr] -> Cxt -> Type -> Type
ForallT [] ((DType -> Type) -> [DType] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map DType -> Type
predToTH [DType]
cxt) (DType -> Type
typeToTH DType
ty)
typeToTH (DAppT DType
t1 DType
t2)          = Type -> Type -> Type
AppT (DType -> Type
typeToTH DType
t1) (DType -> Type
typeToTH DType
t2)
typeToTH (DSigT DType
ty DType
ki)          = Type -> Type -> Type
SigT (DType -> Type
typeToTH DType
ty) (DType -> Type
typeToTH DType
ki)
typeToTH (DVarT Name
n)              = Name -> Type
VarT Name
n
typeToTH (DConT Name
n)              = Name -> Type
tyconToTH Name
n
typeToTH DType
DArrowT                = Type
ArrowT
typeToTH (DLitT TyLit
lit)            = TyLit -> Type
LitT TyLit
lit
#if __GLASGOW_HASKELL__ > 710
typeToTH DType
DWildCardT = Type
WildCardT
#else
typeToTH DWildCardT = error "Wildcards supported only in GHC 8.0+"
#endif
#if __GLASGOW_HASKELL__ >= 807
typeToTH (DAppKindT DType
t DType
k)        = Type -> Type -> Type
AppKindT (DType -> Type
typeToTH DType
t) (DType -> Type
typeToTH DType
k)
#else
-- In the event that we're on a version of Template Haskell without support for
-- kind applications, we will simply drop the applied kind.
typeToTH (DAppKindT t _)        = typeToTH t
#endif

tvbToTH :: DTyVarBndr flag -> TyVarBndr_ flag
tvbToTH :: DTyVarBndr flag -> TyVarBndr
tvbToTH (DPlainTV Name
n flag
flag)    = Name -> flag -> TyVarBndr
forall flag. Name -> flag -> TyVarBndr
plainTVFlag Name
n flag
flag
tvbToTH (DKindedTV Name
n flag
flag DType
k) = Name -> flag -> Type -> TyVarBndr
forall flag. Name -> flag -> Type -> TyVarBndr
kindedTVFlag Name
n flag
flag (DType -> Type
typeToTH DType
k)

cxtToTH :: DCxt -> Cxt
cxtToTH :: [DType] -> Cxt
cxtToTH = (DType -> Type) -> [DType] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map DType -> Type
predToTH

#if __GLASGOW_HASKELL__ >= 801
derivClauseToTH :: DDerivClause -> [DerivClause]
derivClauseToTH :: DDerivClause -> [DerivClause]
derivClauseToTH (DDerivClause Maybe DDerivStrategy
mds [DType]
cxt) =
  [Maybe DerivStrategy -> Cxt -> DerivClause
DerivClause ((DDerivStrategy -> DerivStrategy)
-> Maybe DDerivStrategy -> Maybe DerivStrategy
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DDerivStrategy -> DerivStrategy
derivStrategyToTH Maybe DDerivStrategy
mds) ([DType] -> Cxt
cxtToTH [DType]
cxt)]
#else
derivClauseToTH :: DDerivClause -> Cxt
derivClauseToTH (DDerivClause _ cxt) = cxtToTH cxt
#endif

#if __GLASGOW_HASKELL__ >= 801
derivStrategyToTH :: DDerivStrategy -> DerivStrategy
derivStrategyToTH :: DDerivStrategy -> DerivStrategy
derivStrategyToTH DDerivStrategy
DStockStrategy    = DerivStrategy
StockStrategy
derivStrategyToTH DDerivStrategy
DAnyclassStrategy = DerivStrategy
AnyclassStrategy
derivStrategyToTH DDerivStrategy
DNewtypeStrategy  = DerivStrategy
NewtypeStrategy
#if __GLASGOW_HASKELL__ >= 805
derivStrategyToTH (DViaStrategy DType
ty) = Type -> DerivStrategy
ViaStrategy (DType -> Type
typeToTH DType
ty)
#else
derivStrategyToTH (DViaStrategy _)  = error "DerivingVia supported only in GHC 8.6+"
#endif
#endif

#if __GLASGOW_HASKELL__ >= 801
patSynDirToTH :: DPatSynDir -> PatSynDir
patSynDirToTH :: DPatSynDir -> PatSynDir
patSynDirToTH DPatSynDir
DUnidir              = PatSynDir
Unidir
patSynDirToTH DPatSynDir
DImplBidir           = PatSynDir
ImplBidir
patSynDirToTH (DExplBidir [DClause]
clauses) = [Clause] -> PatSynDir
ExplBidir ((DClause -> Clause) -> [DClause] -> [Clause]
forall a b. (a -> b) -> [a] -> [b]
map DClause -> Clause
clauseToTH [DClause]
clauses)
#endif

predToTH :: DPred -> Pred
#if __GLASGOW_HASKELL__ < 709
predToTH = go []
  where
    go acc (DAppT p t) = go (typeToTH t : acc) p
    -- In the event that we're on a version of Template Haskell without support
    -- for kind applications, we will simply drop the applied kind.
    go acc (DAppKindT t _) = go acc t
    go acc (DSigT p _) = go acc                p  -- this shouldn't happen.
    go acc (DConT n)
      | nameBase n == "~"
      , [t1, t2] <- acc
      = EqualP t1 t2
      | otherwise
      = ClassP n acc
    go _   (DVarT _)
      = error "Template Haskell in GHC <= 7.8 does not support variable constraints."
    go _ DWildCardT
      = error "Wildcards supported only in GHC 8.0+"
    go _ (DForallT {})
      = error "Quantified constraints supported only in GHC 8.6+"
    go _ (DConstrainedT {})
      = error "Quantified constraints supported only in GHC 8.6+"
    go _ DArrowT
      = error "(->) spotted at head of a constraint"
    go _ (DLitT {})
      = error "Type-level literal spotted at head of a constraint"
#else
predToTH :: DType -> Type
predToTH (DAppT DType
p DType
t) = Type -> Type -> Type
AppT (DType -> Type
predToTH DType
p) (DType -> Type
typeToTH DType
t)
predToTH (DSigT DType
p DType
k) = Type -> Type -> Type
SigT (DType -> Type
predToTH DType
p) (DType -> Type
typeToTH DType
k)
predToTH (DVarT Name
n)   = Name -> Type
VarT Name
n
predToTH (DConT Name
n)   = DType -> Type
typeToTH (Name -> DType
DConT Name
n)
predToTH DType
DArrowT     = Type
ArrowT
predToTH (DLitT TyLit
lit) = TyLit -> Type
LitT TyLit
lit
#if __GLASGOW_HASKELL__ > 710
predToTH DType
DWildCardT  = Type
WildCardT
#else
predToTH DWildCardT  = error "Wildcards supported only in GHC 8.0+"
#endif
#if __GLASGOW_HASKELL__ >= 805
-- We need a special case for DForallT ForallInvis followed by DConstrainedT
-- so that we may collapse them into a single ForallT when sweetening.
-- See Note [Desugaring and sweetening ForallT] in L.H.T.Desugar.Core.
predToTH (DForallT (DForallInvis [DTyVarBndrSpec]
tvbs) (DConstrainedT [DType]
ctxt DType
p)) =
  [TyVarBndr] -> Cxt -> Type -> Type
ForallT ((DTyVarBndrSpec -> TyVarBndr) -> [DTyVarBndrSpec] -> [TyVarBndr]
forall a b. (a -> b) -> [a] -> [b]
map DTyVarBndrSpec -> TyVarBndr
forall flag. DTyVarBndr flag -> TyVarBndr
tvbToTH [DTyVarBndrSpec]
tvbs) ((DType -> Type) -> [DType] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map DType -> Type
predToTH [DType]
ctxt) (DType -> Type
predToTH DType
p)
predToTH (DForallT DForallTelescope
tele DType
p) =
  case DForallTelescope
tele of
    DForallInvis [DTyVarBndrSpec]
tvbs -> [TyVarBndr] -> Cxt -> Type -> Type
ForallT ((DTyVarBndrSpec -> TyVarBndr) -> [DTyVarBndrSpec] -> [TyVarBndr]
forall a b. (a -> b) -> [a] -> [b]
map DTyVarBndrSpec -> TyVarBndr
forall flag. DTyVarBndr flag -> TyVarBndr
tvbToTH [DTyVarBndrSpec]
tvbs) [] (DType -> Type
predToTH DType
p)
    DForallVis [DTyVarBndrUnit]
_      -> [Char] -> Type
forall a. HasCallStack => [Char] -> a
error [Char]
"Visible dependent quantifier spotted at head of a constraint"
predToTH (DConstrainedT [DType]
cxt DType
p) = [TyVarBndr] -> Cxt -> Type -> Type
ForallT [] ((DType -> Type) -> [DType] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map DType -> Type
predToTH [DType]
cxt) (DType -> Type
predToTH DType
p)
#else
predToTH (DForallT {})      = error "Quantified constraints supported only in GHC 8.6+"
predToTH (DConstrainedT {}) = error "Quantified constraints supported only in GHC 8.6+"
#endif
#if __GLASGOW_HASKELL__ >= 807
predToTH (DAppKindT DType
p DType
k) = Type -> Type -> Type
AppKindT (DType -> Type
predToTH DType
p) (DType -> Type
typeToTH DType
k)
#else
-- In the event that we're on a version of Template Haskell without support for
-- kind applications, we will simply drop the applied kind.
predToTH (DAppKindT p _) = predToTH p
#endif
#endif

tyconToTH :: Name -> Type
tyconToTH :: Name -> Type
tyconToTH Name
n
  | Name
n Name -> Name -> DDeclaredInfix
forall a. Eq a => a -> a -> DDeclaredInfix
== ''(->)                 = Type
ArrowT -- Work around Trac #14888
  | Name
n Name -> Name -> DDeclaredInfix
forall a. Eq a => a -> a -> DDeclaredInfix
== ''[]                   = Type
ListT
#if __GLASGOW_HASKELL__ >= 709
  | Name
n Name -> Name -> DDeclaredInfix
forall a. Eq a => a -> a -> DDeclaredInfix
== ''(~)                  = Type
EqualityT
#endif
  | Name
n Name -> Name -> DDeclaredInfix
forall a. Eq a => a -> a -> DDeclaredInfix
== '[]                    = Type
PromotedNilT
  | Name
n Name -> Name -> DDeclaredInfix
forall a. Eq a => a -> a -> DDeclaredInfix
== '(:)                   = Type
PromotedConsT
  | Just Int
deg <- Name -> Maybe Int
tupleNameDegree_maybe Name
n
                                = if Name -> DDeclaredInfix
isDataName Name
n
#if __GLASGOW_HASKELL__ >= 805
                                  then Int -> Type
PromotedTupleT Int
deg
#else
                                  then PromotedT n -- Work around Trac #14843
#endif
                                  else Int -> Type
TupleT Int
deg
  | Just Int
deg <- Name -> Maybe Int
unboxedTupleNameDegree_maybe Name
n = Int -> Type
UnboxedTupleT Int
deg
#if __GLASGOW_HASKELL__ >= 801
  | Just Int
deg <- Name -> Maybe Int
unboxedSumNameDegree_maybe Name
n   = Int -> Type
UnboxedSumT Int
deg
#endif
  | DDeclaredInfix
otherwise                   = Name -> Type
ConT Name
n

typeArgToTH :: DTypeArg -> TypeArg
typeArgToTH :: DTypeArg -> TypeArg
typeArgToTH (DTANormal DType
t) = Type -> TypeArg
TANormal (DType -> Type
typeToTH DType
t)
typeArgToTH (DTyArg DType
k)    = Type -> TypeArg
TyArg    (DType -> Type
typeToTH DType
k)

#if __GLASGOW_HASKELL__ <= 710
-- | Convert a 'Bang' to a 'Strict'
bangToStrict :: Bang -> Strict
bangToStrict (Bang SourceUnpack _) = Unpacked
bangToStrict (Bang _ SourceStrict) = IsStrict
bangToStrict (Bang _ _)            = NotStrict
#endif