Quote.hs

{-# LANGUAGE AllowAmbiguousTypes    #-}

{-# LANGUAGE DataKinds              #-}
{-# LANGUAGE FlexibleContexts       #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE PatternSynonyms        #-}
{-# LANGUAGE RankNTypes             #-}
{-# LANGUAGE ScopedTypeVariables    #-}
{-# LANGUAGE TypeApplications       #-}
{-# LANGUAGE TypeFamilies           #-}
{-# LANGUAGE UndecidableInstances   #-}

{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

-----------------------------------------------------------------------------
--
-- (c) The University of Glasgow 2006
--
-- The purpose of this module is to transform an HsExpr into a CoreExpr which
-- when evaluated, returns a (Meta.Q Meta.Exp) computation analogous to the
-- input HsExpr. We do this in the DsM monad, which supplies access to
-- CoreExpr's of the "smart constructors" of the Meta.Exp datatype.
--
-- It also defines a bunch of knownKeyNames, in the same way as is done
-- in prelude/GHC.Builtin.Names.  It's much more convenient to do it here, because
-- otherwise we have to recompile GHC.Builtin.Names whenever we add a Name, which is
-- a Royal Pain (triggers other recompilation).
-----------------------------------------------------------------------------

module GHC.HsToCore.Quote( dsBracket ) where

import GHC.Prelude
import GHC.Platform

import GHC.Driver.Session

import GHC.HsToCore.Errors.Types
import {-# SOURCE #-} GHC.HsToCore.Expr ( dsExpr )
import GHC.HsToCore.Match.Literal
import GHC.HsToCore.Monad
import GHC.HsToCore.Binds

import qualified Language.Haskell.TH as TH
import qualified Language.Haskell.TH.Syntax as TH

import GHC.Hs

import GHC.Tc.Utils.TcType
import GHC.Tc.Types.Evidence

import GHC.Core.Class
import GHC.Core.DataCon
import GHC.Core.TyCon
import GHC.Core.Multiplicity ( pattern Many )
import GHC.Core
import GHC.Core.Make
import GHC.Core.Utils

import GHC.Builtin.Names
import GHC.Builtin.Names.TH
import GHC.Builtin.Types

import GHC.Unit.Module

import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Utils.Misc
import GHC.Utils.Monad

import GHC.Data.Bag
import GHC.Data.FastString
import GHC.Data.Maybe

import GHC.Types.SrcLoc as SrcLoc
import GHC.Types.Unique
import GHC.Types.Basic
import GHC.Types.ForeignCall
import GHC.Types.Var
import GHC.Types.Id
import GHC.Types.SourceText
import GHC.Types.Fixity
import GHC.Types.TyThing
import GHC.Types.Name hiding( varName, tcName )
import GHC.Types.Name.Env

import GHC.TypeLits
import Data.Kind (Constraint)

import qualified GHC.LanguageExtensions as LangExt

import Data.ByteString ( unpack )
import Control.Monad
import Data.List (sort, sortBy)
import Data.List.NonEmpty ( NonEmpty(..) )
import Data.Function
import Control.Monad.Trans.Reader
import Control.Monad.Trans.Class

data MetaWrappers = MetaWrappers {
      -- Applies its argument to a type argument `m` and dictionary `Quote m`
      quoteWrapper :: CoreExpr -> CoreExpr
      -- Apply its argument to a type argument `m` and a dictionary `Monad m`
    , monadWrapper :: CoreExpr -> CoreExpr
      -- Apply the container typed variable `m` to the argument type `T` to get `m T`.
    , metaTy :: Type -> Type
      -- Information about the wrappers which be printed to be inspected
    , _debugWrappers :: (HsWrapper, HsWrapper, Type)
    }

-- | Construct the functions which will apply the relevant part of the
-- QuoteWrapper to identifiers during desugaring.
mkMetaWrappers :: QuoteWrapper -> DsM MetaWrappers
mkMetaWrappers q@(QuoteWrapper quote_var_raw m_var) = do
      let quote_var = Var quote_var_raw
      -- Get the superclass selector to select the Monad dictionary, going
      -- to be used to construct the monadWrapper.
      quote_tc <- dsLookupTyCon quoteClassName
      monad_tc <- dsLookupTyCon monadClassName
      let Just cls = tyConClass_maybe quote_tc
          Just monad_cls = tyConClass_maybe monad_tc
          -- Quote m -> Monad m
          monad_sel = classSCSelId cls 0

          -- Only used for the defensive assertion that the selector has
          -- the expected type
          tyvars = dataConUserTyVarBinders (classDataCon cls)
          expected_ty = mkInvisForAllTys tyvars $
                          mkInvisFunTyMany (mkClassPred cls (mkTyVarTys (binderVars tyvars)))
                                           (mkClassPred monad_cls (mkTyVarTys (binderVars tyvars)))

      massertPpr (idType monad_sel `eqType` expected_ty) (ppr monad_sel $$ ppr expected_ty)

      let m_ty = Type m_var
          -- Construct the contents of MetaWrappers
          quoteWrapper = applyQuoteWrapper q
          monadWrapper = mkWpEvApps [EvExpr $ mkCoreApps (Var monad_sel) [m_ty, quote_var]] <.>
                            mkWpTyApps [m_var]
          tyWrapper t = mkAppTy m_var t
          debug = (quoteWrapper, monadWrapper, m_var)
      q_f <- dsHsWrapper quoteWrapper
      m_f <- dsHsWrapper monadWrapper
      return (MetaWrappers q_f m_f tyWrapper debug)

-- Turn A into m A
wrapName :: Name -> MetaM Type
wrapName n = do
  t <- lookupType n
  wrap_fn <- asks metaTy
  return (wrap_fn t)

-- The local state is always the same, calculated from the passed in
-- wrapper
type MetaM a = ReaderT MetaWrappers DsM a

getPlatform :: MetaM Platform
getPlatform = targetPlatform <$> getDynFlags

-----------------------------------------------------------------------------
dsBracket :: Maybe QuoteWrapper -- ^ This is Nothing only when we are dealing with a VarBr
          -> HsQuote GhcRn      -- See Note [The life cycle of a TH quotation]
          -> [PendingTcSplice]
          -> DsM CoreExpr
-- See Note [Desugaring Brackets]
-- Returns a CoreExpr of type (M TH.Exp)
-- The quoted thing is parameterised over Name, even though it has
-- been type checked.  We don't want all those type decorations!

dsBracket wrap brack splices
  = do_brack brack
  where
    runOverloaded act = do
      -- In the overloaded case we have to get given a wrapper, it is just
      -- for variable quotations that there is no wrapper, because they
      -- have a simple type.
      mw <- mkMetaWrappers (expectJust "runOverloaded" wrap)
      runReaderT (mapReaderT (dsExtendMetaEnv new_bit) act) mw

    new_bit = mkNameEnv [(n, DsSplice (unLoc e))
                        | PendingTcSplice n e <- splices]

    do_brack (VarBr _ _ n) = do { MkC e1  <- lookupOccDsM (unLoc n) ; return e1 }
    do_brack (ExpBr _ e)   = runOverloaded $ do { MkC e1  <- repLE e     ; return e1 }
    do_brack (PatBr _ p)   = runOverloaded $ do { MkC p1  <- repTopP p   ; return p1 }
    do_brack (TypBr _ t)   = runOverloaded $ do { MkC t1  <- repLTy t    ; return t1 }
    do_brack (DecBrG _ gp) = runOverloaded $ do { MkC ds1 <- repTopDs gp ; return ds1 }
    do_brack (DecBrL {})   = panic "dsUntypedBracket: unexpected DecBrL"


{-
Note [Desugaring Brackets]
~~~~~~~~~~~~~~~~~~~~~~~~~~

In the old days (pre Dec 2019) quotation brackets used to be monomorphic, ie
an expression bracket was of type Q Exp. This made the desugaring process simple
as there were no complicated type variables to keep consistent throughout the
whole AST. Due to the overloaded quotations proposal a quotation bracket is now
of type `Quote m => m Exp` and all the combinators defined in TH.Lib have been
generalised to work with any monad implementing a minimal interface.

https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0246-overloaded-bracket.rst

Users can rejoice at the flexibility but now there is some additional complexity in
how brackets are desugared as all these polymorphic combinators need their arguments
instantiated.

> IF YOU ARE MODIFYING THIS MODULE DO NOT USE ANYTHING SPECIFIC TO Q. INSTEAD
> USE THE `wrapName` FUNCTION TO APPLY THE `m` TYPE VARIABLE TO A TYPE CONSTRUCTOR.

What the arguments should be instantiated to is supplied by the `QuoteWrapper`
datatype which is produced by `GHC.Tc.Gen.Splice`. It is a pair of an evidence variable
for `Quote m` and a type variable `m`. All the polymorphic combinators in desugaring
need to be applied to these two type variables.

There are three important functions which do the application.

1. The default is `rep2` which takes a function name of type `Quote m => T` as an argument.
2. `rep2M` takes a function name of type `Monad m => T` as an argument
3. `rep2_nw` takes a function name without any constraints as an argument.

These functions then use the information in QuoteWrapper to apply the correct
arguments to the functions as the representation is constructed.

The `MetaM` monad carries around an environment of three functions which are
used in order to wrap the polymorphic combinators and instantiate the arguments
to the correct things.

1. quoteWrapper wraps functions of type `forall m . Quote m => T`
2. monadWrapper wraps functions of type `forall m . Monad m => T`
3. metaTy wraps a type in the polymorphic `m` variable of the whole representation.

Historical note about the implementation: At the first attempt, I attempted to
lie that the type of any quotation was `Quote m => m Exp` and then specialise it
by applying a wrapper to pass the `m` and `Quote m` arguments. This approach was
simpler to implement but didn't work because of nested splices. For example,
you might have a nested splice of a more specific type which fixes the type of
the overall quote and so all the combinators used must also be instantiated to
that specific type. Therefore you really have to use the contents of the quote
wrapper to directly apply the right type to the combinators rather than
first generate a polymorphic definition and then just apply the wrapper at the end.

-}

{- -------------- Examples --------------------

  [| \x -> x |]
====>
  gensym (unpackString "x"#) `bindQ` \ x1::String ->
  lam (pvar x1) (var x1)


  [| \x -> $(f [| x |]) |]
====>
  gensym (unpackString "x"#) `bindQ` \ x1::String ->
  lam (pvar x1) (f (var x1))
-}


-------------------------------------------------------
--                      Declarations
-------------------------------------------------------

-- Proxy for the phantom type of `Core`. All the generated fragments have
-- type something like `Quote m => m Exp` so to keep things simple we represent fragments
-- of that type as `M Exp`.
data M a

repTopP :: LPat GhcRn -> MetaM (Core (M TH.Pat))
repTopP pat = do { ss <- mkGenSyms (collectPatBinders CollNoDictBinders pat)
                 ; pat' <- addBinds ss (repLP pat)
                 ; wrapGenSyms ss pat' }

repTopDs :: HsGroup GhcRn -> MetaM (Core (M [TH.Dec]))
repTopDs group@(HsGroup { hs_valds   = valds
                        , hs_splcds  = splcds
                        , hs_tyclds  = tyclds
                        , hs_derivds = derivds
                        , hs_fixds   = fixds
                        , hs_defds   = defds
                        , hs_fords   = fords
                        , hs_warnds  = warnds
                        , hs_annds   = annds
                        , hs_ruleds  = ruleds
                        , hs_docs    = docs })
 = do { let { bndrs  = hsScopedTvBinders valds
                       ++ hsGroupBinders group
                       ++ map foExt (hsPatSynSelectors valds)
            ; instds = tyclds >>= group_instds } ;
        ss <- mkGenSyms bndrs ;

        -- Bind all the names mainly to avoid repeated use of explicit strings.
        -- Thus we get
        --      do { t :: String <- genSym "T" ;
        --           return (Data t [] ...more t's... }
        -- The other important reason is that the output must mention
        -- only "T", not "Foo:T" where Foo is the current module

        decls <- addBinds ss (
                  do { val_ds   <- rep_val_binds valds
                     ; _        <- mapM no_splice splcds
                     ; tycl_ds  <- mapM repTyClD (tyClGroupTyClDecls tyclds)
                     ; role_ds  <- mapM repRoleD (concatMap group_roles tyclds)
                     ; kisig_ds <- mapM repKiSigD (concatMap group_kisigs tyclds)
                     ; inst_ds  <- mapM repInstD instds
                     ; deriv_ds <- mapM repStandaloneDerivD derivds
                     ; fix_ds   <- mapM repLFixD fixds
                     ; def_ds   <- mapM repDefD defds
                     ; for_ds   <- mapM repForD fords
                     ; _        <- mapM no_warn (concatMap (wd_warnings . unLoc)
                                                           warnds)
                     ; ann_ds   <- mapM repAnnD annds
                     ; rule_ds  <- mapM repRuleD (concatMap (rds_rules . unLoc)
                                                            ruleds)
                     ; _        <- mapM no_doc docs

                        -- more needed
                     ;  return (de_loc $ sort_by_loc $
                                val_ds ++ catMaybes tycl_ds ++ role_ds
                                       ++ kisig_ds
                                       ++ (concat fix_ds)
                                       ++ def_ds
                                       ++ inst_ds ++ rule_ds ++ for_ds
                                       ++ ann_ds ++ deriv_ds) }) ;

        core_list <- repListM decTyConName return decls ;

        dec_ty <- lookupType decTyConName ;
        q_decs  <- repSequenceM dec_ty core_list ;

        wrapGenSyms ss q_decs
      }
  where
    no_splice (L loc _)
      = notHandledL (locA loc) ThSplicesWithinDeclBrackets
    no_warn :: LWarnDecl GhcRn -> MetaM a
    no_warn (L loc (Warning _ thing _))
      = notHandledL (locA loc) (ThWarningAndDeprecationPragmas thing)
    no_doc (L loc _)
      = notHandledL (locA loc) ThHaddockDocumentation

hsScopedTvBinders :: HsValBinds GhcRn -> [Name]
-- See Note [Scoped type variables in quotes]
hsScopedTvBinders binds
  = concatMap get_scoped_tvs sigs
  where
    sigs = case binds of
             ValBinds           _ _ sigs  -> sigs
             XValBindsLR (NValBinds _ sigs) -> sigs

get_scoped_tvs :: LSig GhcRn -> [Name]
get_scoped_tvs (L _ signature)
  | TypeSig _ _ sig <- signature
  = get_scoped_tvs_from_sig (hswc_body sig)
  | ClassOpSig _ _ _ sig <- signature
  = get_scoped_tvs_from_sig sig
  | PatSynSig _ _ sig <- signature
  = get_scoped_tvs_from_sig sig
  | otherwise
  = []

get_scoped_tvs_from_sig :: LHsSigType GhcRn -> [Name]
  -- Collect both implicit and explicit quantified variables, since
  -- the types in instance heads, as well as `via` types in DerivingVia, can
  -- bring implicitly quantified type variables into scope, e.g.,
  --
  --   instance Foo [a] where
  --     m = n @a
  --
  -- See also Note [Scoped type variables in quotes]
get_scoped_tvs_from_sig (L _ (HsSig{sig_bndrs = outer_bndrs})) =
  hsOuterTyVarNames outer_bndrs

{- Notes

Note [Scoped type variables in quotes]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Quoting declarations with scoped type variables requires some care. Consider:

  $([d| f :: forall a. a -> a
        f x = x::a
      |])

Here, the `forall a` brings `a` into scope over the binding group. This has
ramifications when desugaring the quote, as we must ensure that that the
desugared code binds `a` with `Language.Haskell.TH.newName` and refers to the
bound `a` type variable in the type signature and in the body of `f`. As a
result, the call to `newName` must occur before any part of the declaration for
`f` is processed. To achieve this, we:

 (a) Gensym a binding for `a` at the same time as we do one for `f`,
     collecting the relevant binders with the hsScopedTvBinders family of
     functions.

 (b) Use `addBinds` to bring these gensymmed bindings into scope over any
     part of the code where the type variables scope. In the `f` example,
     above, that means the type signature and the body of `f`.

 (c) When processing the `forall`, /don't/ gensym the type variables. We have
     already brought the type variables into scope in part (b), after all, so
     gensymming them again would lead to shadowing. We use the rep_ty_sig
     family of functions for processing types without gensymming the type
     variables again.

 (d) Finally, we use wrapGenSyms to generate the Core for these scoped type
     variables:

       newName "a" >>= \a ->
         ... -- process the type signature and body of `f`

The relevant places are signposted with references to this Note.

Note [Binders and occurrences]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When we desugar [d| data T = MkT |]
we want to get
        Data "T" [] [Con "MkT" []] []
and *not*
        Data "Foo:T" [] [Con "Foo:MkT" []] []
That is, the new data decl should fit into whatever new module it is
asked to fit in.   We do *not* clone, though; no need for this:
        Data "T79" ....

But if we see this:
        data T = MkT
        foo = reifyDecl T

then we must desugar to
        foo = Data "Foo:T" [] [Con "Foo:MkT" []] []

So in repTopDs we bring the binders into scope with mkGenSyms and addBinds.
And we use lookupOcc, rather than lookupBinder
in repTyClD and repC.

Note [Don't quantify implicit type variables in quotes]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If you're not careful, it's surprisingly easy to take this quoted declaration:

  [d| id :: a -> a
      id x = x
    |]

and have Template Haskell turn it into this:

  id :: forall a. a -> a
  id x = x

Notice that we explicitly quantified the variable `a`! The latter declaration
isn't what the user wrote in the first place.

Usually, the culprit behind these bugs is taking implicitly quantified type
variables (often from the hsib_vars field of HsImplicitBinders) and putting
them into a `ForallT` or `ForallC`. Doing so caused #13018 and #13123.
-}

-- represent associated family instances
--
repTyClD :: LTyClDecl GhcRn -> MetaM (Maybe (SrcSpan, Core (M TH.Dec)))

repTyClD (L loc (FamDecl { tcdFam = fam })) = liftM Just $
                                              repFamilyDecl (L loc fam)

repTyClD (L loc (SynDecl { tcdLName = tc, tcdTyVars = tvs, tcdRhs = rhs }))
  = do { tc1 <- lookupLOcc tc           -- See Note [Binders and occurrences]
       ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
                repSynDecl tc1 bndrs rhs
       ; return (Just (locA loc, dec)) }

repTyClD (L loc (DataDecl { tcdLName = tc
                          , tcdTyVars = tvs
                          , tcdDataDefn = defn }))
  = do { tc1 <- lookupLOcc tc           -- See Note [Binders and occurrences]
       ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
                repDataDefn tc1 (Left bndrs) defn
       ; return (Just (locA loc, dec)) }

repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,
                             tcdTyVars = tvs, tcdFDs = fds,
                             tcdSigs = sigs, tcdMeths = meth_binds,
                             tcdATs = ats, tcdATDefs = atds }))
  = do { cls1 <- lookupLOcc cls         -- See Note [Binders and occurrences]
       ; dec  <- addQTyVarBinds tvs $ \bndrs ->
           do { cxt1   <- repLContext cxt
          -- See Note [Scoped type variables in quotes]
              ; (ss, sigs_binds) <- rep_meth_sigs_binds sigs meth_binds
              ; fds1   <- repLFunDeps fds
              ; ats1   <- repFamilyDecls ats
              ; atds1  <- mapM (repAssocTyFamDefaultD . unLoc) atds
              ; decls1 <- repListM decTyConName return (ats1 ++ atds1 ++ sigs_binds)
              ; decls2 <- repClass cxt1 cls1 bndrs fds1 decls1
              ; wrapGenSyms ss decls2 }
       ; return $ Just (locA loc, dec)
       }

-------------------------
repRoleD :: LRoleAnnotDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
repRoleD (L loc (RoleAnnotDecl _ tycon roles))
  = do { tycon1 <- lookupLOcc tycon
       ; roles1 <- mapM repRole roles
       ; roles2 <- coreList roleTyConName roles1
       ; dec <- repRoleAnnotD tycon1 roles2
       ; return (locA loc, dec) }

-------------------------
repKiSigD :: LStandaloneKindSig GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
repKiSigD (L loc kisig) =
  case kisig of
    StandaloneKindSig _ v ki -> do
      MkC th_v  <- lookupLOcc v
      MkC th_ki <- repHsSigType ki
      dec       <- rep2 kiSigDName [th_v, th_ki]
      pure (locA loc, dec)

-------------------------
repDataDefn :: Core TH.Name
            -> Either (Core [(M (TH.TyVarBndr ()))])
                        -- the repTyClD case
                      (Core (Maybe [(M (TH.TyVarBndr ()))]), Core (M TH.Type))
                        -- the repDataFamInstD case
            -> HsDataDefn GhcRn
            -> MetaM (Core (M TH.Dec))
repDataDefn tc opts
          (HsDataDefn { dd_ND = new_or_data, dd_ctxt = cxt, dd_kindSig = ksig
                      , dd_cons = cons, dd_derivs = mb_derivs })
  = do { cxt1     <- repLContext cxt
       ; derivs1  <- repDerivs mb_derivs
       ; case (new_or_data, cons) of
           (NewType, [con])  -> do { con'  <- repC con
                                   ; ksig' <- repMaybeLTy ksig
                                   ; repNewtype cxt1 tc opts ksig' con'
                                                derivs1 }
           (NewType, _) -> lift $ failWithDs (DsMultipleConForNewtype (getConNames $ unLoc $ head cons))
           (DataType, _) -> do { ksig' <- repMaybeLTy ksig
                               ; consL <- mapM repC cons
                               ; cons1 <- coreListM conTyConName consL
                               ; repData cxt1 tc opts ksig' cons1
                                         derivs1 }
       }

repSynDecl :: Core TH.Name -> Core [(M (TH.TyVarBndr ()))]
           -> LHsType GhcRn
           -> MetaM (Core (M TH.Dec))
repSynDecl tc bndrs ty
  = do { ty1 <- repLTy ty
       ; repTySyn tc bndrs ty1 }

repFamilyDecl :: LFamilyDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
repFamilyDecl decl@(L loc (FamilyDecl { fdInfo      = info
                                      , fdLName     = tc
                                      , fdTyVars    = tvs
                                      , fdResultSig = L _ resultSig
                                      , fdInjectivityAnn = injectivity }))
  = do { tc1 <- lookupLOcc tc           -- See Note [Binders and occurrences]
       ; let mkHsQTvs :: [LHsTyVarBndr () GhcRn] -> LHsQTyVars GhcRn
             mkHsQTvs tvs = HsQTvs { hsq_ext = []
                                   , hsq_explicit = tvs }
             resTyVar = case resultSig of
                     TyVarSig _ bndr -> mkHsQTvs [bndr]
                     _               -> mkHsQTvs []
       ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
                addTyClTyVarBinds resTyVar $ \_ ->
           case info of
             ClosedTypeFamily Nothing ->
                 notHandled (ThAbstractClosedTypeFamily decl)
             ClosedTypeFamily (Just eqns) ->
               do { eqns1  <- mapM (repTyFamEqn . unLoc) eqns
                  ; eqns2  <- coreListM tySynEqnTyConName eqns1
                  ; result <- repFamilyResultSig resultSig
                  ; inj    <- repInjectivityAnn injectivity
                  ; repClosedFamilyD tc1 bndrs result inj eqns2 }
             OpenTypeFamily ->
               do { result <- repFamilyResultSig resultSig
                  ; inj    <- repInjectivityAnn injectivity
                  ; repOpenFamilyD tc1 bndrs result inj }
             DataFamily ->
               do { kind <- repFamilyResultSigToMaybeKind resultSig
                  ; repDataFamilyD tc1 bndrs kind }
       ; return (locA loc, dec)
       }

-- | Represent result signature of a type family
repFamilyResultSig :: FamilyResultSig GhcRn -> MetaM (Core (M TH.FamilyResultSig))
repFamilyResultSig (NoSig _)         = repNoSig
repFamilyResultSig (KindSig _ ki)    = do { ki' <- repLTy ki
                                          ; repKindSig ki' }
repFamilyResultSig (TyVarSig _ bndr) = do { bndr' <- repTyVarBndr bndr
                                          ; repTyVarSig bndr' }

-- | Represent result signature using a Maybe Kind. Used with data families,
-- where the result signature can be either missing or a kind but never a named
-- result variable.
repFamilyResultSigToMaybeKind :: FamilyResultSig GhcRn
                              -> MetaM (Core (Maybe (M TH.Kind)))
repFamilyResultSigToMaybeKind (NoSig _) =
    coreNothingM kindTyConName
repFamilyResultSigToMaybeKind (KindSig _ ki) =
    coreJustM kindTyConName =<< repLTy ki
repFamilyResultSigToMaybeKind TyVarSig{} =
    panic "repFamilyResultSigToMaybeKind: unexpected TyVarSig"

-- | Represent injectivity annotation of a type family
repInjectivityAnn :: Maybe (LInjectivityAnn GhcRn)
                  -> MetaM (Core (Maybe TH.InjectivityAnn))
repInjectivityAnn Nothing =
    coreNothing injAnnTyConName
repInjectivityAnn (Just (L _ (InjectivityAnn _ lhs rhs))) =
    do { lhs'   <- lookupBinder (unLoc lhs)
       ; rhs1   <- mapM (lookupBinder . unLoc) rhs
       ; rhs2   <- coreList nameTyConName rhs1
       ; injAnn <- rep2_nw injectivityAnnName [unC lhs', unC rhs2]
       ; coreJust injAnnTyConName injAnn }

repFamilyDecls :: [LFamilyDecl GhcRn] -> MetaM [Core (M TH.Dec)]
repFamilyDecls fds = liftM de_loc (mapM repFamilyDecl fds)

repAssocTyFamDefaultD :: TyFamDefltDecl GhcRn -> MetaM (Core (M TH.Dec))
repAssocTyFamDefaultD = repTyFamInstD

-------------------------
-- represent fundeps
--
repLFunDeps :: [LHsFunDep GhcRn] -> MetaM (Core [TH.FunDep])
repLFunDeps fds = repList funDepTyConName repLFunDep fds

repLFunDep :: LHsFunDep GhcRn -> MetaM (Core TH.FunDep)
repLFunDep (L _ (FunDep _ xs ys))
   = do xs' <- repList nameTyConName (lookupBinder . unLoc) xs
        ys' <- repList nameTyConName (lookupBinder . unLoc) ys
        repFunDep xs' ys'

-- Represent instance declarations
--
repInstD :: LInstDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
repInstD (L loc (TyFamInstD { tfid_inst = fi_decl }))
  = do { dec <- repTyFamInstD fi_decl
       ; return (locA loc, dec) }
repInstD (L loc (DataFamInstD { dfid_inst = fi_decl }))
  = do { dec <- repDataFamInstD fi_decl
       ; return (locA loc, dec) }
repInstD (L loc (ClsInstD { cid_inst = cls_decl }))
  = do { dec <- repClsInstD cls_decl
       ; return (locA loc, dec) }

repClsInstD :: ClsInstDecl GhcRn -> MetaM (Core (M TH.Dec))
repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
                         , cid_sigs = sigs, cid_tyfam_insts = ats
                         , cid_datafam_insts = adts
                         , cid_overlap_mode = overlap
                         })
  = addSimpleTyVarBinds tvs $
            -- We must bring the type variables into scope, so their
            -- occurrences don't fail, even though the binders don't
            -- appear in the resulting data structure
            --
            -- But we do NOT bring the binders of 'binds' into scope
            -- because they are properly regarded as occurrences
            -- For example, the method names should be bound to
            -- the selector Ids, not to fresh names (#5410)
            --
            do { cxt1     <- repLContext cxt
               ; inst_ty1 <- repLTy inst_ty
          -- See Note [Scoped type variables in quotes]
               ; (ss, sigs_binds) <- rep_meth_sigs_binds sigs binds
               ; ats1   <- mapM (repTyFamInstD . unLoc) ats
               ; adts1  <- mapM (repDataFamInstD . unLoc) adts
               ; decls1 <- coreListM decTyConName (ats1 ++ adts1 ++ sigs_binds)
               ; rOver  <- repOverlap (fmap unLoc overlap)
               ; decls2 <- repInst rOver cxt1 inst_ty1 decls1
               ; wrapGenSyms ss decls2 }
 where
   (tvs, cxt, inst_ty) = splitLHsInstDeclTy ty

repStandaloneDerivD :: LDerivDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
repStandaloneDerivD (L loc (DerivDecl { deriv_strategy = strat
                                       , deriv_type     = ty }))
  = do { dec <- repDerivStrategy strat  $ \strat' ->
                addSimpleTyVarBinds tvs $
                do { cxt'     <- repLContext cxt
                   ; inst_ty' <- repLTy inst_ty
                   ; repDeriv strat' cxt' inst_ty' }
       ; return (locA loc, dec) }
  where
    (tvs, cxt, inst_ty) = splitLHsInstDeclTy (dropWildCards ty)

repTyFamInstD :: TyFamInstDecl GhcRn -> MetaM (Core (M TH.Dec))
repTyFamInstD (TyFamInstDecl { tfid_eqn = eqn })
  = do { eqn1 <- repTyFamEqn eqn
       ; repTySynInst eqn1 }

repTyFamEqn :: TyFamInstEqn GhcRn -> MetaM (Core (M TH.TySynEqn))
repTyFamEqn (FamEqn { feqn_tycon = tc_name
                    , feqn_bndrs = outer_bndrs
                    , feqn_pats = tys
                    , feqn_fixity = fixity
                    , feqn_rhs  = rhs })
  = do { tc <- lookupLOcc tc_name     -- See Note [Binders and occurrences]
       ; addHsOuterFamEqnTyVarBinds outer_bndrs $ \mb_exp_bndrs ->
         do { tys1 <- case fixity of
                        Prefix -> repTyArgs (repNamedTyCon tc) tys
                        Infix  -> do { (HsValArg t1: HsValArg t2: args) <- checkTys tys
                                     ; t1' <- repLTy t1
                                     ; t2'  <- repLTy t2
                                     ; repTyArgs (repTInfix t1' tc t2') args }
            ; rhs1 <- repLTy rhs
            ; repTySynEqn mb_exp_bndrs tys1 rhs1 } }
     where checkTys :: [LHsTypeArg GhcRn] -> MetaM [LHsTypeArg GhcRn]
           checkTys tys@(HsValArg _:HsValArg _:_) = return tys
           checkTys _ = panic "repTyFamEqn:checkTys"

repTyArgs :: MetaM (Core (M TH.Type)) -> [LHsTypeArg GhcRn] -> MetaM (Core (M TH.Type))
repTyArgs f [] = f
repTyArgs f (HsValArg ty : as) = do { f' <- f
                                    ; ty' <- repLTy ty
                                    ; repTyArgs (repTapp f' ty') as }
repTyArgs f (HsTypeArg _ ki : as) = do { f' <- f
                                       ; ki' <- repLTy ki
                                       ; repTyArgs (repTappKind f' ki') as }
repTyArgs f (HsArgPar _ : as) = repTyArgs f as

repDataFamInstD :: DataFamInstDecl GhcRn -> MetaM (Core (M TH.Dec))
repDataFamInstD (DataFamInstDecl { dfid_eqn =
                                      FamEqn { feqn_tycon = tc_name
                                             , feqn_bndrs = outer_bndrs
                                             , feqn_pats  = tys
                                             , feqn_fixity = fixity
                                             , feqn_rhs   = defn }})
  = do { tc <- lookupLOcc tc_name         -- See Note [Binders and occurrences]
       ; addHsOuterFamEqnTyVarBinds outer_bndrs $ \mb_exp_bndrs ->
         do { tys1 <- case fixity of
                        Prefix -> repTyArgs (repNamedTyCon tc) tys
                        Infix  -> do { (HsValArg t1: HsValArg t2: args) <- checkTys tys
                                     ; t1' <- repLTy t1
                                     ; t2'  <- repLTy t2
                                     ; repTyArgs (repTInfix t1' tc t2') args }
            ; repDataDefn tc (Right (mb_exp_bndrs, tys1)) defn } }

      where checkTys :: [LHsTypeArg GhcRn] -> MetaM [LHsTypeArg GhcRn]
            checkTys tys@(HsValArg _: HsValArg _: _) = return tys
            checkTys _ = panic "repDataFamInstD:checkTys"

repForD :: LForeignDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
repForD (L loc (ForeignImport { fd_name = name, fd_sig_ty = typ
                                  , fd_fi = CImport (L _ cc)
                                                    (L _ s) mch cis _ }))
 = do MkC name' <- lookupLOcc name
      MkC typ' <- repHsSigType typ
      MkC cc' <- repCCallConv cc
      MkC s' <- repSafety s
      cis' <- conv_cimportspec cis
      MkC str <- coreStringLit (static ++ chStr ++ cis')
      dec <- rep2 forImpDName [cc', s', str, name', typ']
      return (locA loc, dec)
 where
    conv_cimportspec (CLabel cls)
      = notHandled (ThForeignLabel cls)
    conv_cimportspec (CFunction DynamicTarget) = return "dynamic"
    conv_cimportspec (CFunction (StaticTarget _ fs _ True))
                            = return (unpackFS fs)
    conv_cimportspec (CFunction (StaticTarget _ _  _ False))
                            = panic "conv_cimportspec: values not supported yet"
    conv_cimportspec CWrapper = return "wrapper"
    -- these calling conventions do not support headers and the static keyword
    raw_cconv = cc == PrimCallConv || cc == JavaScriptCallConv
    static = case cis of
                 CFunction (StaticTarget _ _ _ _) | not raw_cconv -> "static "
                 _ -> ""
    chStr = case mch of
            Just (Header _ h) | not raw_cconv -> unpackFS h ++ " "
            _ -> ""
repForD decl@(L _ ForeignExport{}) = notHandled (ThForeignExport decl)

repCCallConv :: CCallConv -> MetaM (Core TH.Callconv)
repCCallConv CCallConv          = rep2_nw cCallName []
repCCallConv StdCallConv        = rep2_nw stdCallName []
repCCallConv CApiConv           = rep2_nw cApiCallName []
repCCallConv PrimCallConv       = rep2_nw primCallName []
repCCallConv JavaScriptCallConv = rep2_nw javaScriptCallName []

repSafety :: Safety -> MetaM (Core TH.Safety)
repSafety PlayRisky = rep2_nw unsafeName []
repSafety PlayInterruptible = rep2_nw interruptibleName []
repSafety PlaySafe = rep2_nw safeName []

repLFixD :: LFixitySig GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))]
repLFixD (L loc fix_sig) = rep_fix_d (locA loc) fix_sig

rep_fix_d :: SrcSpan -> FixitySig GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))]
rep_fix_d loc (FixitySig _ names (Fixity _ prec dir))
  = do { MkC prec' <- coreIntLit prec
       ; let rep_fn = case dir of
                        InfixL -> infixLDName
                        InfixR -> infixRDName
                        InfixN -> infixNDName
       ; let do_one name
              = do { MkC name' <- lookupLOcc name
                   ; dec <- rep2 rep_fn [prec', name']
                   ; return (loc,dec) }
       ; mapM do_one names }

repDefD :: LDefaultDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
repDefD (L loc (DefaultDecl _ tys)) = do { tys1 <- repLTys tys
                                         ; MkC tys2 <- coreListM typeTyConName tys1
                                         ; dec <- rep2 defaultDName [tys2]
                                         ; return (locA loc, dec)}

repRuleD :: LRuleDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
repRuleD (L loc (HsRule { rd_name = n
                        , rd_act = act
                        , rd_tyvs = ty_bndrs
                        , rd_tmvs = tm_bndrs
                        , rd_lhs = lhs
                        , rd_rhs = rhs }))
  = do { rule <- addHsTyVarBinds (fromMaybe [] ty_bndrs) $ \ ex_bndrs ->
         do { let tm_bndr_names = concatMap ruleBndrNames tm_bndrs
            ; ss <- mkGenSyms tm_bndr_names
            ; rule <- addBinds ss $
                      do { elt_ty <- wrapName tyVarBndrUnitTyConName
                         ; ty_bndrs' <- return $ case ty_bndrs of
                             Nothing -> coreNothing' (mkListTy elt_ty)
                             Just _  -> coreJust' (mkListTy elt_ty) ex_bndrs
                         ; tm_bndrs' <- repListM ruleBndrTyConName
                                                repRuleBndr
                                                tm_bndrs
                         ; n'   <- coreStringLit $ unpackFS $ snd $ unLoc n
                         ; act' <- repPhases act
                         ; lhs' <- repLE lhs
                         ; rhs' <- repLE rhs
                         ; repPragRule n' ty_bndrs' tm_bndrs' lhs' rhs' act' }
           ; wrapGenSyms ss rule  }
       ; return (locA loc, rule) }

ruleBndrNames :: LRuleBndr GhcRn -> [Name]
ruleBndrNames (L _ (RuleBndr _ n))      = [unLoc n]
ruleBndrNames (L _ (RuleBndrSig _ n sig))
  | HsPS { hsps_ext = HsPSRn { hsps_imp_tvs = vars }} <- sig
  = unLoc n : vars

repRuleBndr :: LRuleBndr GhcRn -> MetaM (Core (M TH.RuleBndr))
repRuleBndr (L _ (RuleBndr _ n))
  = do { MkC n' <- lookupNBinder n
       ; rep2 ruleVarName [n'] }
repRuleBndr (L _ (RuleBndrSig _ n sig))
  = do { MkC n'  <- lookupNBinder n
       ; MkC ty' <- repLTy (hsPatSigType sig)
       ; rep2 typedRuleVarName [n', ty'] }

repAnnD :: LAnnDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
repAnnD (L loc (HsAnnotation _ _ ann_prov (L _ exp)))
  = do { target <- repAnnProv ann_prov
       ; exp'   <- repE exp
       ; dec    <- repPragAnn target exp'
       ; return (locA loc, dec) }

repAnnProv :: AnnProvenance GhcRn -> MetaM (Core TH.AnnTarget)
repAnnProv (ValueAnnProvenance n)
  = do { -- An ANN references an identifier bound elsewhere in the module, so
         -- we must look it up using lookupLOcc (#19377).
         -- Similarly for TypeAnnProvenance (`ANN type`) below.
         MkC n' <- lookupLOcc n
       ; rep2_nw valueAnnotationName [ n' ] }
repAnnProv (TypeAnnProvenance n)
  = do { MkC n' <- lookupLOcc n
       ; rep2_nw typeAnnotationName [ n' ] }
repAnnProv ModuleAnnProvenance
  = rep2_nw moduleAnnotationName []

-------------------------------------------------------
--                      Constructors
-------------------------------------------------------

repC :: LConDecl GhcRn -> MetaM (Core (M TH.Con))
repC (L _ (ConDeclH98 { con_name   = con
                      , con_forall = False
                      , con_mb_cxt = Nothing
                      , con_args   = args }))
  = repH98DataCon con args