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

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

Converts desugared TH back into real TH.
-}

{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskellQuotes #-}

-----------------------------------------------------------------------------

-- |

-- 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 (Extension(..), 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 (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) (forall a b. (a -> b) -> [a] -> [b]
map DMatch -> Match
matchToTH [DMatch]
matches)
expToTH (DLetE [DLetDec]
decs DExp
exp)     = [Dec] -> Exp -> Exp
LetE (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)
expToTH (DStaticE DExp
exp)       = Exp -> Exp
StaticE (DExp -> Exp
expToTH DExp
exp)
#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 -> [Type] -> [Pat] -> Pat
ConP Name
n
#if __GLASGOW_HASKELL__ >= 901
                                   (forall a b. (a -> b) -> [a] -> [b]
map DType -> Type
typeToTH [DType]
_tys)
#endif
                                   (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 = 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 DataFlavor
Data [DType]
cxt Name
n [DTyVarBndrUnit]
tvbs Maybe DType
_mk [DCon]
cons [DDerivClause]
derivings) =
  [Type]
-> Name
-> [TyVarBndr ()]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataD ([DType] -> [Type]
cxtToTH [DType]
cxt) Name
n (forall a b. (a -> b) -> [a] -> [b]
map forall flag. DTyVarBndr flag -> TyVarBndr_ flag
tvbToTH [DTyVarBndrUnit]
tvbs) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DType -> Type
typeToTH Maybe DType
_mk) (forall a b. (a -> b) -> [a] -> [b]
map DCon -> Con
conToTH [DCon]
cons)
        (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap DDerivClause -> [DerivClause]
derivClauseToTH [DDerivClause]
derivings)
decToTH (DDataD DataFlavor
Newtype [DType]
cxt Name
n [DTyVarBndrUnit]
tvbs Maybe DType
_mk [DCon
con] [DDerivClause]
derivings) =
  [Type]
-> Name
-> [TyVarBndr ()]
-> Maybe Type
-> Con
-> [DerivClause]
-> Dec
NewtypeD ([DType] -> [Type]
cxtToTH [DType]
cxt) Name
n (forall a b. (a -> b) -> [a] -> [b]
map forall flag. DTyVarBndr flag -> TyVarBndr_ flag
tvbToTH [DTyVarBndrUnit]
tvbs) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DType -> Type
typeToTH Maybe DType
_mk) (DCon -> Con
conToTH DCon
con)
           (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap DDerivClause -> [DerivClause]
derivClauseToTH [DDerivClause]
derivings)
decToTH (DDataD DataFlavor
Newtype [DType]
_cxt Name
_n [DTyVarBndrUnit]
_tvbs Maybe DType
_mk [DCon]
_cons [DDerivClause]
_derivings) =
  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 (forall a b. (a -> b) -> [a] -> [b]
map forall flag. DTyVarBndr flag -> TyVarBndr_ flag
tvbToTH [DTyVarBndrUnit]
tvbs) (DType -> Type
typeToTH DType
ty)
decToTH (DClassD [DType]
cxt Name
n [DTyVarBndrUnit]
tvbs [FunDep]
fds [DDec]
decs) =
  [Type] -> Name -> [TyVarBndr ()] -> [FunDep] -> [Dec] -> Dec
ClassD ([DType] -> [Type]
cxtToTH [DType]
cxt) Name
n (forall a b. (a -> b) -> [a] -> [b]
map forall flag. DTyVarBndr flag -> TyVarBndr_ flag
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)
decToTH (DOpenTypeFamilyD (DTypeFamilyHead Name
n [DTyVarBndrUnit]
tvbs DFamilyResultSig
frs Maybe InjectivityAnn
ann)) =
  TypeFamilyHead -> Dec
OpenTypeFamilyD (Name
-> [TyVarBndr ()]
-> FamilyResultSig
-> Maybe InjectivityAnn
-> TypeFamilyHead
TypeFamilyHead Name
n (forall a b. (a -> b) -> [a] -> [b]
map forall flag. DTyVarBndr flag -> TyVarBndr_ flag
tvbToTH [DTyVarBndrUnit]
tvbs) (DFamilyResultSig -> FamilyResultSig
frsToTH DFamilyResultSig
frs) Maybe InjectivityAnn
ann)
decToTH (DDataFamilyD Name
n [DTyVarBndrUnit]
tvbs Maybe DType
mk) =
  Name -> [TyVarBndr ()] -> Maybe Type -> Dec
DataFamilyD Name
n (forall a b. (a -> b) -> [a] -> [b]
map forall flag. DTyVarBndr flag -> TyVarBndr_ flag
tvbToTH [DTyVarBndrUnit]
tvbs) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DType -> Type
typeToTH Maybe DType
mk)
decToTH (DDataInstD DataFlavor
nd [DType]
cxt Maybe [DTyVarBndrUnit]
mtvbs DType
lhs Maybe DType
mk [DCon]
cons [DDerivClause]
derivings) =
  let ndc :: DNewOrDataCons
ndc = case (DataFlavor
nd, [DCon]
cons) of
              (DataFlavor
Newtype,  [DCon
con]) -> DCon -> DNewOrDataCons
DNewtypeCon DCon
con
              (DataFlavor
Newtype,  [DCon]
_)     -> forall a. HasCallStack => [Char] -> a
error [Char]
"Newtype that doesn't have only one constructor"
              (DataFlavor
Data,     [DCon]
_)     -> [DCon] -> DNewOrDataCons
DDataCons [DCon]
cons
              (DataFlavor
TypeData, [DCon]
_)     -> forall a. HasCallStack => [Char] -> a
error [Char]
"Data family instance that is combined with `type data`"
  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 (forall a b. (a, b) -> b
snd 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
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 (forall a b. (a -> b) -> [a] -> [b]
map forall flag. DTyVarBndr flag -> TyVarBndr_ flag
tvbToTH [DTyVarBndrUnit]
tvbs) (DFamilyResultSig -> FamilyResultSig
frsToTH DFamilyResultSig
frs) Maybe InjectivityAnn
ann)
                    (forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. DTySynEqn -> (Name, TySynEqn)
tySynEqnToTH) [DTySynEqn]
eqns)
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
decToTH (DDefaultSigD Name
n DType
ty)        = Name -> Type -> Dec
DefaultSigD Name
n (DType -> Type
typeToTH DType
ty)
#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__ >= 903
decToTH (DDefaultD tys) = DefaultD (map typeToTH tys)
#else
decToTH (DDefaultD{})   =
  forall a. HasCallStack => [Char] -> a
error [Char]
"Default declarations supported only in GHC 9.4+"
#endif
#if __GLASGOW_HASKELL__ >= 906
decToTH (DDataD TypeData _cxt n tvbs mk cons _derivings) =
  -- NB: Due to the invariants on 'DDataD' and 'TypeData', _cxt and _derivings

  -- will be empty.

  TypeDataD n (map tvbToTH tvbs) (fmap typeToTH mk) (map conToTH cons)
#else
decToTH (DDataD DataFlavor
TypeData [DType]
_cxt Name
_n [DTyVarBndrUnit]
_tvbs Maybe DType
_mk [DCon]
_cons [DDerivClause]
_derivings) =
  forall a. HasCallStack => [Char] -> a
error [Char]
"`type data` declarations supported only in GHC 9.6+"
#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
      [Type]
-> Maybe [TyVarBndr ()]
-> Type
-> Maybe Type
-> Con
-> [DerivClause]
-> Dec
NewtypeInstD ([DType] -> [Type]
cxtToTH [DType]
cxt) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall flag. DTyVarBndr flag -> TyVarBndr_ flag
tvbToTH) Maybe [DTyVarBndrUnit]
_mtvbs) (DType -> Type
typeToTH DType
lhs)
                   (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DType -> Type
typeToTH Maybe DType
_mk) (DCon -> Con
conToTH DCon
con)
                   (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap DDerivClause -> [DerivClause]
derivClauseToTH [DDerivClause]
derivings)
#else
      NewtypeInstD (cxtToTH cxt) _n _lhs_args (fmap typeToTH _mk) (conToTH con)
                   (concatMap derivClauseToTH derivings)
#endif

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

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 (forall flag. DTyVarBndr flag -> TyVarBndr_ flag
tvbToTH DTyVarBndrUnit
tvb)

-- | Sweeten a 'DLetDec'.

letDecToTH :: DLetDec -> Dec
letDecToTH :: DLetDec -> Dec
letDecToTH (DFunD Name
name [DClause]
clauses) = Name -> [Clause] -> Dec
FunD Name
name (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
conToTH :: DCon -> Con
conToTH (DCon [] [] Name
n (DNormalC DDeclaredInfix
_ [DBangType]
stys) DType
rty) =
  [Name] -> [BangType] -> Type -> Con
GadtC [Name
n] (forall a b. (a -> b) -> [a] -> [b]
map (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] (forall a b. (a -> b) -> [a] -> [b]
map (forall a b c d. (a -> b) -> (c, d, a) -> (c, d, b)
thirdOf3 DType -> Type
typeToTH) [DVarBangType]
vstys) (DType -> Type
typeToTH DType
rty)
-- 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 Specificity] -> [Type] -> Con -> Con
ForallC (forall a b. (a -> b) -> [a] -> [b]
map forall flag. DTyVarBndr flag -> TyVarBndr_ flag
tvbToTH [DTyVarBndrSpec]
tvbs) ([DType] -> [Type]
cxtToTH [DType]
cxt) (DCon -> Con
conToTH forall a b. (a -> b) -> a -> b
$ [DTyVarBndrSpec] -> [DType] -> Name -> DConFields -> DType -> DCon
DCon [] [] Name
n DConFields
fields DType
rty)

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 -> [Type] -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
over ([DType] -> [Type]
cxtToTH [DType]
cxt) (DType -> Type
typeToTH DType
ty) ([DDec] -> [Dec]
decsToTH [DDec]
decs)

standaloneDerivDToTH :: Maybe DDerivStrategy -> DCxt -> DType -> Dec
standaloneDerivDToTH :: Maybe DDerivStrategy -> [DType] -> DType -> Dec
standaloneDerivDToTH Maybe DDerivStrategy
_mds [DType]
cxt DType
ty =
  Maybe DerivStrategy -> [Type] -> Type -> Dec
StandaloneDerivD
#if __GLASGOW_HASKELL__ >= 802
                   (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DDerivStrategy -> DerivStrategy
derivStrategyToTH Maybe DDerivStrategy
_mds)
#endif
                   ([DType] -> [Type]
cxtToTH [DType]
cxt) (DType -> Type
typeToTH DType
ty)

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 (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall flag. DTyVarBndr flag -> TyVarBndr_ flag
tvbToTH) Maybe [DTyVarBndrUnit]
mtvbs) (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)
pragmaToTH (DLineP Int
n [Char]
str) = Int -> [Char] -> Pragma
LineP Int
n [Char]
str
#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
#if __GLASGOW_HASKELL__ >= 903
pragmaToTH (DOpaqueP n) = OpaqueP n
#else
pragmaToTH (DOpaqueP {}) = forall a. HasCallStack => [Char] -> a
error [Char]
"OPAQUE pragmas only supported in GHC 9.4+"
#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 (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall flag. DTyVarBndr flag -> TyVarBndr_ flag
tvbToTH) Maybe [DTyVarBndrUnit]
tvbs) Type
lhs' (DType -> Type
typeToTH DType
rhs))
    (Type
_, [TypeArg]
_) -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Illegal type instance LHS: " forall a. [a] -> [a] -> [a]
++ 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 (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 Specificity] -> [Type] -> Type -> Type
ForallT (forall a b. (a -> b) -> [a] -> [b]
map forall flag. DTyVarBndr flag -> TyVarBndr_ flag
tvbToTH [DTyVarBndrSpec]
tvbs) (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 Specificity] -> [Type] -> Type -> Type
ForallT (forall a b. (a -> b) -> [a] -> [b]
map forall flag. DTyVarBndr flag -> TyVarBndr_ flag
tvbToTH [DTyVarBndrSpec]
tvbs) [] Type
ty'
    DForallVis   [DTyVarBndrUnit]
_tvbs ->
#if __GLASGOW_HASKELL__ >= 809
      [TyVarBndr ()] -> Type -> Type
ForallVisT (forall a b. (a -> b) -> [a] -> [b]
map forall flag. DTyVarBndr flag -> TyVarBndr_ flag
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 Specificity] -> [Type] -> Type -> Type
ForallT [] (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
typeToTH DType
DWildCardT = Type
WildCardT
#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 :: forall flag. DTyVarBndr flag -> TyVarBndr_ flag
tvbToTH (DPlainTV Name
n flag
flag)    = forall flag. Name -> flag -> TyVarBndr_ flag
plainTVFlag Name
n flag
flag
tvbToTH (DKindedTV Name
n flag
flag DType
k) = forall flag. Name -> flag -> Type -> TyVarBndr_ flag
kindedTVFlag Name
n flag
flag (DType -> Type
typeToTH DType
k)

cxtToTH :: DCxt -> Cxt
cxtToTH :: [DType] -> [Type]
cxtToTH = 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 -> [Type] -> DerivClause
DerivClause (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DDerivStrategy -> DerivStrategy
derivStrategyToTH Maybe DDerivStrategy
mds) ([DType] -> [Type]
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 (forall a b. (a -> b) -> [a] -> [b]
map DClause -> Clause
clauseToTH [DClause]
clauses)
#endif

predToTH :: DPred -> Pred
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
predToTH DType
DWildCardT  = Type
WildCardT
#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 Specificity] -> [Type] -> Type -> Type
ForallT (forall a b. (a -> b) -> [a] -> [b]
map forall flag. DTyVarBndr flag -> TyVarBndr_ flag
tvbToTH [DTyVarBndrSpec]
tvbs) (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 Specificity] -> [Type] -> Type -> Type
ForallT (forall a b. (a -> b) -> [a] -> [b]
map forall flag. DTyVarBndr flag -> TyVarBndr_ flag
tvbToTH [DTyVarBndrSpec]
tvbs) [] (DType -> Type
predToTH DType
p)
    DForallVis [DTyVarBndrUnit]
_      -> forall a. HasCallStack => [Char] -> a
error [Char]
"Visible dependent quantifier spotted at head of a constraint"
predToTH (DConstrainedT [DType]
cxt DType
p) = [TyVarBndr Specificity] -> [Type] -> Type -> Type
ForallT [] (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

tyconToTH :: Name -> Type
tyconToTH :: Name -> Type
tyconToTH Name
n
  | Name
n forall a. Eq a => a -> a -> DDeclaredInfix
== ''(->)                 = Type
ArrowT -- Work around Trac #14888

  | Name
n forall a. Eq a => a -> a -> DDeclaredInfix
== ''[]                   = Type
ListT
  | Name
n forall a. Eq a => a -> a -> DDeclaredInfix
== ''(~)                  = Type
EqualityT
  | Name
n forall a. Eq a => a -> a -> DDeclaredInfix
== '[]                    = Type
PromotedNilT
  | Name
n 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)