{-
(c) The University of Glasgow, 1992-2006

Here we collect a variety of helper functions that construct or
analyse HsSyn.  All these functions deal with generic HsSyn; functions
which deal with the instantiated versions are located elsewhere:

   Parameterised by          Module
   ----------------          -------------
   GhcPs/RdrName             parser/RdrHsSyn
   GhcRn/Name                rename/RnHsSyn
   GhcTc/Id                  typecheck/TcHsSyn
-}

{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}

module HsUtils(
  -- Terms
  mkHsPar, mkHsApp, mkHsAppType, mkHsAppTypes, mkHsCaseAlt,
  mkSimpleMatch, unguardedGRHSs, unguardedRHS,
  mkMatchGroup, mkMatch, mkPrefixFunRhs, mkHsLam, mkHsIf,
  mkHsWrap, mkLHsWrap, mkHsWrapCo, mkHsWrapCoR, mkLHsWrapCo,
  mkHsDictLet, mkHsLams,
  mkHsOpApp, mkHsDo, mkHsComp, mkHsWrapPat, mkHsWrapPatCo,
  mkLHsPar, mkHsCmdWrap, mkLHsCmdWrap,
  mkHsCmdIf,

  nlHsTyApp, nlHsTyApps, nlHsVar, nlHsDataCon,
  nlHsLit, nlHsApp, nlHsApps, nlHsSyntaxApps,
  nlHsIntLit, nlHsVarApps,
  nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList,
  mkLHsTupleExpr, mkLHsVarTuple, missingTupArg,
  typeToLHsType,

  -- * Constructing general big tuples
  -- $big_tuples
  mkChunkified, chunkify,

  -- Bindings
  mkFunBind, mkVarBind, mkHsVarBind, mk_easy_FunBind, mkTopFunBind,
  mkPatSynBind,
  isInfixFunBind,

  -- Literals
  mkHsIntegral, mkHsFractional, mkHsIsString, mkHsString, mkHsStringPrimLit,

  -- Patterns
  mkNPat, mkNPlusKPat, nlVarPat, nlLitPat, nlConVarPat, nlConVarPatName, nlConPat,
  nlConPatName, nlInfixConPat, nlNullaryConPat, nlWildConPat, nlWildPat,
  nlWildPatName, nlTuplePat, mkParPat, nlParPat,
  mkBigLHsVarTup, mkBigLHsTup, mkBigLHsVarPatTup, mkBigLHsPatTup,

  -- Types
  mkHsAppTy, mkHsAppKindTy, userHsTyVarBndrs, userHsLTyVarBndrs,
  mkLHsSigType, mkLHsSigWcType, mkClassOpSigs, mkHsSigEnv,
  nlHsAppTy, nlHsAppKindTy, nlHsTyVar, nlHsFunTy, nlHsParTy, nlHsTyConApp,

  -- Stmts
  mkTransformStmt, mkTransformByStmt, mkBodyStmt, mkBindStmt, mkTcBindStmt,
  mkLastStmt,
  emptyTransStmt, mkGroupUsingStmt, mkGroupByUsingStmt,
  emptyRecStmt, emptyRecStmtName, emptyRecStmtId, mkRecStmt,
  unitRecStmtTc,

  -- Template Haskell
  mkUntypedSplice, mkTypedSplice,
  mkHsQuasiQuote, unqualQuasiQuote,

  -- Collecting binders
  isUnliftedHsBind, isBangedHsBind,

  collectLocalBinders, collectHsValBinders, collectHsBindListBinders,
  collectHsIdBinders,
  collectHsBindsBinders, collectHsBindBinders, collectMethodBinders,
  collectPatBinders, collectPatsBinders,
  collectLStmtsBinders, collectStmtsBinders,
  collectLStmtBinders, collectStmtBinders,

  hsLTyClDeclBinders, hsTyClForeignBinders,
  hsPatSynSelectors, getPatSynBinds,
  hsForeignDeclsBinders, hsGroupBinders, hsDataFamInstBinders,

  -- Collecting implicit binders
  lStmtsImplicits, hsValBindsImplicits, lPatImplicits
  ) where

#include "HsVersions.h"

import GhcPrelude

import HsDecls
import HsBinds
import HsExpr
import HsPat
import HsTypes
import HsLit
import PlaceHolder
import HsExtension

import TcEvidence
import RdrName
import Var
import TyCoRep
import Type   ( tyConArgFlags )
import TysWiredIn ( unitTy )
import TcType
import DataCon
import ConLike
import Id
import Name
import NameSet hiding ( unitFV )
import NameEnv
import BasicTypes
import SrcLoc
import FastString
import Util
import Bag
import Outputable
import Constants

import Data.Either
import Data.Function
import Data.List

{-
************************************************************************
*                                                                      *
        Some useful helpers for constructing syntax
*                                                                      *
************************************************************************

These functions attempt to construct a not-completely-useless SrcSpan
from their components, compared with the nl* functions below which
just attach noSrcSpan to everything.
-}

mkHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkHsPar e = cL (getLoc e) (HsPar noExt e)

mkSimpleMatch :: HsMatchContext (NameOrRdrName (IdP (GhcPass p)))
              -> [LPat (GhcPass p)] -> Located (body (GhcPass p))
              -> LMatch (GhcPass p) (Located (body (GhcPass p)))
mkSimpleMatch ctxt pats rhs
  = cL loc $
    Match { m_ext = noExt, m_ctxt = ctxt, m_pats = pats
          , m_grhss = unguardedGRHSs rhs }
  where
    loc = case pats of
                []      -> getLoc rhs
                (pat:_) -> combineSrcSpans (getLoc pat) (getLoc rhs)

unguardedGRHSs :: Located (body (GhcPass p))
               -> GRHSs (GhcPass p) (Located (body (GhcPass p)))
unguardedGRHSs rhs@(dL->L loc _)
  = GRHSs noExt (unguardedRHS loc rhs) (noLoc emptyLocalBinds)

unguardedRHS :: SrcSpan -> Located (body (GhcPass p))
             -> [LGRHS (GhcPass p) (Located (body (GhcPass p)))]
unguardedRHS loc rhs = [cL loc (GRHS noExt [] rhs)]

mkMatchGroup :: (XMG name (Located (body name)) ~ NoExt)
             => Origin -> [LMatch name (Located (body name))]
             -> MatchGroup name (Located (body name))
mkMatchGroup origin matches = MG { mg_ext = noExt
                                 , mg_alts = mkLocatedList matches
                                 , mg_origin = origin }

mkLocatedList ::  [Located a] -> Located [Located a]
mkLocatedList [] = noLoc []
mkLocatedList ms = cL (combineLocs (head ms) (last ms)) ms

mkHsApp :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkHsApp e1 e2 = addCLoc e1 e2 (HsApp noExt e1 e2)

mkHsAppType :: (NoGhcTc (GhcPass id) ~ GhcRn)
            => LHsExpr (GhcPass id) -> LHsWcType GhcRn -> LHsExpr (GhcPass id)
mkHsAppType e t = addCLoc e t_body (HsAppType noExt e paren_wct)
  where
    t_body    = hswc_body t
    paren_wct = t { hswc_body = parenthesizeHsType appPrec t_body }

mkHsAppTypes :: LHsExpr GhcRn -> [LHsWcType GhcRn] -> LHsExpr GhcRn
mkHsAppTypes = foldl' mkHsAppType

mkHsLam :: (XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ NoExt) =>
  [LPat (GhcPass p)] -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
mkHsLam pats body = mkHsPar (cL (getLoc body) (HsLam noExt matches))
  where
    matches = mkMatchGroup Generated
                           [mkSimpleMatch LambdaExpr pats' body]
    pats' = map (parenthesizePat appPrec) pats

mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr GhcTc -> LHsExpr GhcTc
mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars
                                       <.> mkWpLams dicts) expr

-- |A simple case alternative with a single pattern, no binds, no guards;
-- pre-typechecking
mkHsCaseAlt :: LPat (GhcPass p) -> (Located (body (GhcPass p)))
            -> LMatch (GhcPass p) (Located (body (GhcPass p)))
mkHsCaseAlt pat expr
  = mkSimpleMatch CaseAlt [pat] expr

nlHsTyApp :: IdP (GhcPass id) -> [Type] -> LHsExpr (GhcPass id)
nlHsTyApp fun_id tys
  = noLoc (mkHsWrap (mkWpTyApps tys) (HsVar noExt (noLoc fun_id)))

nlHsTyApps :: IdP (GhcPass id) -> [Type] -> [LHsExpr (GhcPass id)]
           -> LHsExpr (GhcPass id)
nlHsTyApps fun_id tys xs = foldl' nlHsApp (nlHsTyApp fun_id tys) xs

--------- Adding parens ---------
mkLHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
-- Wrap in parens if (hsExprNeedsParens appPrec) says it needs them
-- So   'f x'  becomes '(f x)', but '3' stays as '3'
mkLHsPar le@(dL->L loc e)
  | hsExprNeedsParens appPrec e = cL loc (HsPar noExt le)
  | otherwise                   = le

mkParPat :: LPat (GhcPass name) -> LPat (GhcPass name)
mkParPat lp@(dL->L loc p)
  | patNeedsParens appPrec p = cL loc (ParPat noExt lp)
  | otherwise                = lp

nlParPat :: LPat (GhcPass name) -> LPat (GhcPass name)
nlParPat p = noLoc (ParPat noExt p)

-------------------------------
-- These are the bits of syntax that contain rebindable names
-- See RnEnv.lookupSyntaxName

mkHsIntegral   :: IntegralLit -> HsOverLit GhcPs
mkHsFractional :: FractionalLit -> HsOverLit GhcPs
mkHsIsString   :: SourceText -> FastString -> HsOverLit GhcPs
mkHsDo         :: HsStmtContext Name -> [ExprLStmt GhcPs] -> HsExpr GhcPs
mkHsComp       :: HsStmtContext Name -> [ExprLStmt GhcPs] -> LHsExpr GhcPs
               -> HsExpr GhcPs

mkNPat      :: Located (HsOverLit GhcPs) -> Maybe (SyntaxExpr GhcPs)
            -> Pat GhcPs
mkNPlusKPat :: Located RdrName -> Located (HsOverLit GhcPs) -> Pat GhcPs

mkLastStmt :: Located (bodyR (GhcPass idR))
           -> StmtLR (GhcPass idL) (GhcPass idR) (Located (bodyR (GhcPass idR)))
mkBodyStmt :: Located (bodyR GhcPs)
           -> StmtLR (GhcPass idL) GhcPs (Located (bodyR GhcPs))
mkBindStmt :: (XBindStmt (GhcPass idL) (GhcPass idR)
                         (Located (bodyR (GhcPass idR))) ~ NoExt)
           => LPat (GhcPass idL) -> Located (bodyR (GhcPass idR))
           -> StmtLR (GhcPass idL) (GhcPass idR) (Located (bodyR (GhcPass idR)))
mkTcBindStmt :: LPat GhcTc -> Located (bodyR GhcTc)
             -> StmtLR GhcTc GhcTc (Located (bodyR GhcTc))

emptyRecStmt     :: StmtLR (GhcPass idL) GhcPs bodyR
emptyRecStmtName :: StmtLR GhcRn GhcRn bodyR
emptyRecStmtId   :: StmtLR GhcTc GhcTc bodyR
mkRecStmt        :: [LStmtLR (GhcPass idL) GhcPs bodyR]
                 -> StmtLR (GhcPass idL) GhcPs bodyR

mkHsIntegral     i  = OverLit noExt (HsIntegral       i) noExpr
mkHsFractional   f  = OverLit noExt (HsFractional     f) noExpr
mkHsIsString src s  = OverLit noExt (HsIsString   src s) noExpr

mkHsDo ctxt stmts = HsDo noExt ctxt (mkLocatedList stmts)
mkHsComp ctxt stmts expr = mkHsDo ctxt (stmts ++ [last_stmt])
  where
    last_stmt = cL (getLoc expr) $ mkLastStmt expr

mkHsIf :: LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
       -> HsExpr (GhcPass p)
mkHsIf c a b = HsIf noExt (Just noSyntaxExpr) c a b

mkHsCmdIf :: LHsExpr (GhcPass p) -> LHsCmd (GhcPass p) -> LHsCmd (GhcPass p)
       -> HsCmd (GhcPass p)
mkHsCmdIf c a b = HsCmdIf noExt (Just noSyntaxExpr) c a b

mkNPat lit neg     = NPat noExt lit neg noSyntaxExpr
mkNPlusKPat id lit
  = NPlusKPat noExt id lit (unLoc lit) noSyntaxExpr noSyntaxExpr

mkTransformStmt    :: [ExprLStmt GhcPs] -> LHsExpr GhcPs
                   -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)
mkTransformByStmt  :: [ExprLStmt GhcPs] -> LHsExpr GhcPs
                   -> LHsExpr GhcPs -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)
mkGroupUsingStmt   :: [ExprLStmt GhcPs] -> LHsExpr GhcPs
                   -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)
mkGroupByUsingStmt :: [ExprLStmt GhcPs] -> LHsExpr GhcPs
                   -> LHsExpr GhcPs
                   -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)

emptyTransStmt :: StmtLR GhcPs GhcPs (LHsExpr GhcPs)
emptyTransStmt = TransStmt { trS_ext = noExt
                           , trS_form = panic "emptyTransStmt: form"
                           , trS_stmts = [], trS_bndrs = []
                           , trS_by = Nothing, trS_using = noLoc noExpr
                           , trS_ret = noSyntaxExpr, trS_bind = noSyntaxExpr
                           , trS_fmap = noExpr }
mkTransformStmt    ss u   = emptyTransStmt { trS_form = ThenForm,  trS_stmts = ss, trS_using = u }
mkTransformByStmt  ss u b = emptyTransStmt { trS_form = ThenForm,  trS_stmts = ss, trS_using = u, trS_by = Just b }
mkGroupUsingStmt   ss u   = emptyTransStmt { trS_form = GroupForm, trS_stmts = ss, trS_using = u }
mkGroupByUsingStmt ss b u = emptyTransStmt { trS_form = GroupForm, trS_stmts = ss, trS_using = u, trS_by = Just b }

mkLastStmt body = LastStmt noExt body False noSyntaxExpr
mkBodyStmt body
  = BodyStmt noExt body noSyntaxExpr noSyntaxExpr
mkBindStmt pat body
  = BindStmt noExt pat body noSyntaxExpr noSyntaxExpr
mkTcBindStmt pat body = BindStmt unitTy pat body noSyntaxExpr noSyntaxExpr
  -- don't use placeHolderTypeTc above, because that panics during zonking

emptyRecStmt' :: forall idL idR body.
                 XRecStmt (GhcPass idL) (GhcPass idR) body
              -> StmtLR (GhcPass idL) (GhcPass idR) body
emptyRecStmt' tyVal =
   RecStmt
     { recS_stmts = [], recS_later_ids = []
     , recS_rec_ids = []
     , recS_ret_fn = noSyntaxExpr
     , recS_mfix_fn = noSyntaxExpr
     , recS_bind_fn = noSyntaxExpr
     , recS_ext = tyVal }

unitRecStmtTc :: RecStmtTc
unitRecStmtTc = RecStmtTc { recS_bind_ty = unitTy
                          , recS_later_rets = []
                          , recS_rec_rets = []
                          , recS_ret_ty = unitTy }

emptyRecStmt     = emptyRecStmt' noExt
emptyRecStmtName = emptyRecStmt' noExt
emptyRecStmtId   = emptyRecStmt' unitRecStmtTc
                                        -- a panic might trigger during zonking
mkRecStmt stmts  = emptyRecStmt { recS_stmts = stmts }

-------------------------------
--- A useful function for building @OpApps@.  The operator is always a
-- variable, and we don't know the fixity yet.
mkHsOpApp :: LHsExpr GhcPs -> IdP GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
mkHsOpApp e1 op e2 = OpApp noExt e1 (noLoc (HsVar noExt (noLoc op))) e2

unqualSplice :: RdrName
unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice"))

mkUntypedSplice :: SpliceDecoration -> LHsExpr GhcPs -> HsSplice GhcPs
mkUntypedSplice hasParen e = HsUntypedSplice noExt hasParen unqualSplice e

mkTypedSplice :: SpliceDecoration -> LHsExpr GhcPs -> HsSplice GhcPs
mkTypedSplice hasParen e = HsTypedSplice noExt hasParen unqualSplice e

mkHsQuasiQuote :: RdrName -> SrcSpan -> FastString -> HsSplice GhcPs
mkHsQuasiQuote quoter span quote
  = HsQuasiQuote noExt unqualSplice quoter span quote

unqualQuasiQuote :: RdrName
unqualQuasiQuote = mkRdrUnqual (mkVarOccFS (fsLit "quasiquote"))
                -- A name (uniquified later) to
                -- identify the quasi-quote

mkHsString :: String -> HsLit (GhcPass p)
mkHsString s = HsString NoSourceText (mkFastString s)

mkHsStringPrimLit :: FastString -> HsLit (GhcPass p)
mkHsStringPrimLit fs = HsStringPrim NoSourceText (bytesFS fs)

-------------
userHsLTyVarBndrs :: SrcSpan -> [Located (IdP (GhcPass p))]
                  -> [LHsTyVarBndr (GhcPass p)]
-- Caller sets location
userHsLTyVarBndrs loc bndrs = [ cL loc (UserTyVar noExt v) | v <- bndrs ]

userHsTyVarBndrs :: SrcSpan -> [IdP (GhcPass p)] -> [LHsTyVarBndr (GhcPass p)]
-- Caller sets location
userHsTyVarBndrs loc bndrs = [ cL loc (UserTyVar noExt (cL loc v))
                             | v <- bndrs ]

{-
************************************************************************
*                                                                      *
        Constructing syntax with no location info
*                                                                      *
************************************************************************
-}

nlHsVar :: IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar n = noLoc (HsVar noExt (noLoc n))

-- NB: Only for LHsExpr **Id**
nlHsDataCon :: DataCon -> LHsExpr GhcTc
nlHsDataCon con = noLoc (HsConLikeOut noExt (RealDataCon con))

nlHsLit :: HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit n = noLoc (HsLit noExt n)

nlHsIntLit :: Integer -> LHsExpr (GhcPass p)
nlHsIntLit n = noLoc (HsLit noExt (HsInt noExt (mkIntegralLit n)))

nlVarPat :: IdP (GhcPass id) -> LPat (GhcPass id)
nlVarPat n = noLoc (VarPat noExt (noLoc n))

nlLitPat :: HsLit GhcPs -> LPat GhcPs
nlLitPat l = noLoc (LitPat noExt l)

nlHsApp :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp f x = noLoc (HsApp noExt f (mkLHsPar x))

nlHsSyntaxApps :: SyntaxExpr (GhcPass id) -> [LHsExpr (GhcPass id)]
               -> LHsExpr (GhcPass id)
nlHsSyntaxApps (SyntaxExpr { syn_expr      = fun
                           , syn_arg_wraps = arg_wraps
                           , syn_res_wrap  = res_wrap }) args
  | [] <- arg_wraps   -- in the noSyntaxExpr case
  = ASSERT( isIdHsWrapper res_wrap )
    foldl' nlHsApp (noLoc fun) args

  | otherwise
  = mkLHsWrap res_wrap (foldl' nlHsApp (noLoc fun) (zipWithEqual "nlHsSyntaxApps"
                                                     mkLHsWrap arg_wraps args))

nlHsApps :: IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsApps f xs = foldl' nlHsApp (nlHsVar f) xs

nlHsVarApps :: IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsVarApps f xs = noLoc (foldl' mk (HsVar noExt (noLoc f))
                                               (map ((HsVar noExt) . noLoc) xs))
                 where
                   mk f a = HsApp noExt (noLoc f) (noLoc a)

nlConVarPat :: RdrName -> [RdrName] -> LPat GhcPs
nlConVarPat con vars = nlConPat con (map nlVarPat vars)

nlConVarPatName :: Name -> [Name] -> LPat GhcRn
nlConVarPatName con vars = nlConPatName con (map nlVarPat vars)

nlInfixConPat :: RdrName -> LPat GhcPs -> LPat GhcPs -> LPat GhcPs
nlInfixConPat con l r = noLoc (ConPatIn (noLoc con)
                              (InfixCon (parenthesizePat opPrec l)
                                        (parenthesizePat opPrec r)))

nlConPat :: RdrName -> [LPat GhcPs] -> LPat GhcPs
nlConPat con pats =
  noLoc (ConPatIn (noLoc con) (PrefixCon (map (parenthesizePat appPrec) pats)))

nlConPatName :: Name -> [LPat GhcRn] -> LPat GhcRn
nlConPatName con pats =
  noLoc (ConPatIn (noLoc con) (PrefixCon (map (parenthesizePat appPrec) pats)))

nlNullaryConPat :: IdP (GhcPass p) -> LPat (GhcPass p)
nlNullaryConPat con = noLoc (ConPatIn (noLoc con) (PrefixCon []))

nlWildConPat :: DataCon -> LPat GhcPs
nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con))
                         (PrefixCon (nOfThem (dataConSourceArity con)
                                             nlWildPat)))

nlWildPat :: LPat GhcPs
nlWildPat  = noLoc (WildPat noExt )  -- Pre-typechecking

nlWildPatName :: LPat GhcRn
nlWildPatName  = noLoc (WildPat noExt )  -- Pre-typechecking

nlHsDo :: HsStmtContext Name -> [LStmt GhcPs (LHsExpr GhcPs)]
       -> LHsExpr GhcPs
nlHsDo ctxt stmts = noLoc (mkHsDo ctxt stmts)

nlHsOpApp :: LHsExpr GhcPs -> IdP GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2)

nlHsLam  :: LMatch GhcPs (LHsExpr GhcPs) -> LHsExpr GhcPs
nlHsPar  :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsIf   :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
         -> LHsExpr (GhcPass id)
nlHsCase :: LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)]
         -> LHsExpr GhcPs
nlList   :: [LHsExpr GhcPs] -> LHsExpr GhcPs

nlHsLam match          = noLoc (HsLam noExt (mkMatchGroup Generated [match]))
nlHsPar e              = noLoc (HsPar noExt e)

-- Note [Rebindable nlHsIf]
-- nlHsIf should generate if-expressions which are NOT subject to
-- RebindableSyntax, so the first field of HsIf is Nothing. (#12080)
nlHsIf cond true false = noLoc (HsIf noExt Nothing cond true false)

nlHsCase expr matches
  = noLoc (HsCase noExt expr (mkMatchGroup Generated matches))
nlList exprs          = noLoc (ExplicitList noExt Nothing exprs)

nlHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
nlHsTyVar :: IdP (GhcPass p)                            -> LHsType (GhcPass p)
nlHsFunTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
nlHsParTy :: LHsType (GhcPass p)                        -> LHsType (GhcPass p)

nlHsAppTy f t = noLoc (HsAppTy noExt f (parenthesizeHsType appPrec t))
nlHsTyVar x   = noLoc (HsTyVar noExt NotPromoted (noLoc x))
nlHsFunTy a b = noLoc (HsFunTy noExt (parenthesizeHsType funPrec a) b)
nlHsParTy t   = noLoc (HsParTy noExt t)

nlHsTyConApp :: IdP (GhcPass p) -> [LHsType (GhcPass p)] -> LHsType (GhcPass p)
nlHsTyConApp tycon tys  = foldl' nlHsAppTy (nlHsTyVar tycon) tys

nlHsAppKindTy ::
  LHsType (GhcPass p) -> LHsKind (GhcPass p) -> LHsType (GhcPass p)
nlHsAppKindTy f k
  = noLoc (HsAppKindTy noSrcSpan f (parenthesizeHsType appPrec k))

{-
Tuples.  All these functions are *pre-typechecker* because they lack
types on the tuple.
-}

mkLHsTupleExpr :: [LHsExpr (GhcPass a)] -> LHsExpr (GhcPass a)
-- Makes a pre-typechecker boxed tuple, deals with 1 case
mkLHsTupleExpr [e] = e
mkLHsTupleExpr es
  = noLoc $ ExplicitTuple noExt (map (noLoc . (Present noExt)) es) Boxed

mkLHsVarTuple :: [IdP (GhcPass a)] -> LHsExpr (GhcPass a)
mkLHsVarTuple ids  = mkLHsTupleExpr (map nlHsVar ids)

nlTuplePat :: [LPat GhcPs] -> Boxity -> LPat GhcPs
nlTuplePat pats box = noLoc (TuplePat noExt pats box)

missingTupArg :: HsTupArg GhcPs
missingTupArg = Missing noExt

mkLHsPatTup :: [LPat GhcRn] -> LPat GhcRn
mkLHsPatTup []     = noLoc $ TuplePat noExt [] Boxed
mkLHsPatTup [lpat] = lpat
mkLHsPatTup lpats  = cL (getLoc (head lpats)) $ TuplePat noExt lpats Boxed

-- The Big equivalents for the source tuple expressions
mkBigLHsVarTup :: [IdP (GhcPass id)] -> LHsExpr (GhcPass id)
mkBigLHsVarTup ids = mkBigLHsTup (map nlHsVar ids)

mkBigLHsTup :: [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
mkBigLHsTup = mkChunkified mkLHsTupleExpr

-- The Big equivalents for the source tuple patterns
mkBigLHsVarPatTup :: [IdP GhcRn] -> LPat GhcRn
mkBigLHsVarPatTup bs = mkBigLHsPatTup (map nlVarPat bs)

mkBigLHsPatTup :: [LPat GhcRn] -> LPat GhcRn
mkBigLHsPatTup = mkChunkified mkLHsPatTup

-- $big_tuples
-- #big_tuples#
--
-- GHCs built in tuples can only go up to 'mAX_TUPLE_SIZE' in arity, but
-- we might concievably want to build such a massive tuple as part of the
-- output of a desugaring stage (notably that for list comprehensions).
--
-- We call tuples above this size \"big tuples\", and emulate them by
-- creating and pattern matching on >nested< tuples that are expressible
-- by GHC.
--
-- Nesting policy: it's better to have a 2-tuple of 10-tuples (3 objects)
-- than a 10-tuple of 2-tuples (11 objects), so we want the leaves of any
-- construction to be big.
--
-- If you just use the 'mkBigCoreTup', 'mkBigCoreVarTupTy', 'mkTupleSelector'
-- and 'mkTupleCase' functions to do all your work with tuples you should be
-- fine, and not have to worry about the arity limitation at all.

-- | Lifts a \"small\" constructor into a \"big\" constructor by recursive decompositon
mkChunkified :: ([a] -> a)      -- ^ \"Small\" constructor function, of maximum input arity 'mAX_TUPLE_SIZE'
             -> [a]             -- ^ Possible \"big\" list of things to construct from
             -> a               -- ^ Constructed thing made possible by recursive decomposition
mkChunkified small_tuple as = mk_big_tuple (chunkify as)
  where
        -- Each sub-list is short enough to fit in a tuple
    mk_big_tuple [as] = small_tuple as
    mk_big_tuple as_s = mk_big_tuple (chunkify (map small_tuple as_s))

chunkify :: [a] -> [[a]]
-- ^ Split a list into lists that are small enough to have a corresponding
-- tuple arity. The sub-lists of the result all have length <= 'mAX_TUPLE_SIZE'
-- But there may be more than 'mAX_TUPLE_SIZE' sub-lists
chunkify xs
  | n_xs <= mAX_TUPLE_SIZE = [xs]
  | otherwise              = split xs
  where
    n_xs     = length xs
    split [] = []
    split xs = take mAX_TUPLE_SIZE xs : split (drop mAX_TUPLE_SIZE xs)

{-
************************************************************************
*                                                                      *
        LHsSigType and LHsSigWcType
*                                                                      *
********************************************************************* -}

mkLHsSigType :: LHsType GhcPs -> LHsSigType GhcPs
mkLHsSigType ty = mkHsImplicitBndrs ty

mkLHsSigWcType :: LHsType GhcPs -> LHsSigWcType GhcPs
mkLHsSigWcType ty = mkHsWildCardBndrs (mkHsImplicitBndrs ty)

mkHsSigEnv :: forall a. (LSig GhcRn -> Maybe ([Located Name], a))
                     -> [LSig GhcRn]
                     -> NameEnv a
mkHsSigEnv get_info sigs
  = mkNameEnv          (mk_pairs ordinary_sigs)
   `extendNameEnvList` (mk_pairs gen_dm_sigs)
   -- The subtlety is this: in a class decl with a
   -- default-method signature as well as a method signature
   -- we want the latter to win (Trac #12533)
   --    class C x where
   --       op :: forall a . x a -> x a
   --       default op :: forall b . x b -> x b
   --       op x = ...(e :: b -> b)...
   -- The scoped type variables of the 'default op', namely 'b',
   -- scope over the code for op.   The 'forall a' does not!
   -- This applies both in the renamer and typechecker, both
   -- of which use this function
  where
    (gen_dm_sigs, ordinary_sigs) = partition is_gen_dm_sig sigs
    is_gen_dm_sig (dL->L _ (ClassOpSig _ True _ _)) = True
    is_gen_dm_sig _                                 = False

    mk_pairs :: [LSig GhcRn] -> [(Name, a)]
    mk_pairs sigs = [ (n,a) | Just (ns,a) <- map get_info sigs
                            , (dL->L _ n) <- ns ]

mkClassOpSigs :: [LSig GhcPs] -> [LSig GhcPs]
-- Convert TypeSig to ClassOpSig
-- The former is what is parsed, but the latter is
-- what we need in class/instance declarations
mkClassOpSigs sigs
  = map fiddle sigs
  where
    fiddle (dL->L loc (TypeSig _ nms ty))
      = cL loc (ClassOpSig noExt False nms (dropWildCards ty))
    fiddle sig = sig

typeToLHsType :: Type -> LHsType GhcPs
-- ^ Converting a Type to an HsType RdrName
-- This is needed to implement GeneralizedNewtypeDeriving.
--
-- Note that we use 'getRdrName' extensively, which
-- generates Exact RdrNames rather than strings.
typeToLHsType ty
  = go ty
  where
    go :: Type -> LHsType GhcPs
    go ty@(FunTy { ft_af = af, ft_arg = arg, ft_res = res })
      = case af of
          VisArg   -> nlHsFunTy (go arg) (go res)
          InvisArg | (theta, tau) <- tcSplitPhiTy ty
                   -> noLoc (HsQualTy { hst_ctxt = noLoc (map go theta)
                                      , hst_xqual = noExt
                                      , hst_body = go tau })

    go ty@(ForAllTy (Bndr _ argf) _)
      | (tvs, tau) <- tcSplitForAllTysSameVis argf ty
      = noLoc (HsForAllTy { hst_fvf = argToForallVisFlag argf
                          , hst_bndrs = map go_tv tvs
                          , hst_xforall = noExt
                          , hst_body = go tau })
    go (TyVarTy tv)         = nlHsTyVar (getRdrName tv)
    go (AppTy t1 t2)        = nlHsAppTy (go t1) (go t2)
    go (LitTy (NumTyLit n))
      = noLoc $ HsTyLit NoExt (HsNumTy NoSourceText n)
    go (LitTy (StrTyLit s))
      = noLoc $ HsTyLit NoExt (HsStrTy NoSourceText s)
    go ty@(TyConApp tc args)
      | tyConAppNeedsKindSig True tc (length args)
        -- We must produce an explicit kind signature here to make certain
        -- programs kind-check. See Note [Kind signatures in typeToLHsType].
      = nlHsParTy $ noLoc $ HsKindSig NoExt lhs_ty (go (tcTypeKind ty))
      | otherwise = lhs_ty
       where
        arg_flags :: [ArgFlag]
        arg_flags = tyConArgFlags tc args

        lhs_ty :: LHsType GhcPs
        lhs_ty = foldl' (\f (arg, flag) ->
                          let arg' = go arg in
                          case flag of
                            Inferred  -> f
                            Specified -> f `nlHsAppKindTy` arg'
                            Required  -> f `nlHsAppTy`     arg')
                        (nlHsTyVar (getRdrName tc))
                        (zip args arg_flags)
    go (CastTy ty _)        = go ty
    go (CoercionTy co)      = pprPanic "toLHsSigWcType" (ppr co)

         -- Source-language types have _invisible_ kind arguments,
         -- so we must remove them here (Trac #8563)

    go_tv :: TyVar -> LHsTyVarBndr GhcPs
    go_tv tv = noLoc $ KindedTyVar noExt (noLoc (getRdrName tv))
                                   (go (tyVarKind tv))

{-
Note [Kind signatures in typeToLHsType]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
There are types that typeToLHsType can produce which require explicit kind
signatures in order to kind-check. Here is an example from Trac #14579:

  -- type P :: forall {k} {t :: k}. Proxy t
  type P = 'Proxy

  -- type Wat :: forall a. Proxy a -> *
  newtype Wat (x :: Proxy (a :: Type)) = MkWat (Maybe a)
    deriving Eq

  -- type Wat2 :: forall {a}. Proxy a -> *
  type Wat2 = Wat

  -- type Glurp :: * -> *
  newtype Glurp a = MkGlurp (Wat2 (P :: Proxy a))
    deriving Eq

The derived Eq instance for Glurp (without any kind signatures) would be:

  instance Eq a => Eq (Glurp a) where
    (==) = coerce @(Wat2 P  -> Wat2 P  -> Bool)
                  @(Glurp a -> Glurp a -> Bool)
                  (==) :: Glurp a -> Glurp a -> Bool

(Where the visible type applications use types produced by typeToLHsType.)

The type P (in Wat2 P) has an underspecified kind, so we must ensure that
typeToLHsType ascribes it with its kind: Wat2 (P :: Proxy a). To accomplish
this, whenever we see an application of a tycon to some arguments, we use
the tyConAppNeedsKindSig function to determine if it requires an explicit kind
signature to resolve some ambiguity. (See Note
Note [When does a tycon application need an explicit kind signature?] for a
more detailed explanation of how this works.)

Note that we pass True to tyConAppNeedsKindSig since we are generated code with
visible kind applications, so even specified arguments count towards injective
positions in the kind of the tycon.
-}

{- *********************************************************************
*                                                                      *
    --------- HsWrappers: type args, dict args, casts ---------
*                                                                      *
********************************************************************* -}

mkLHsWrap :: HsWrapper -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkLHsWrap co_fn (dL->L loc e) = cL loc (mkHsWrap co_fn e)

-- Avoid (HsWrap co (HsWrap co' _)).
-- See Note [Detecting forced eta expansion] in DsExpr
mkHsWrap :: HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
mkHsWrap co_fn e | isIdHsWrapper co_fn = e
mkHsWrap co_fn (HsWrap _ co_fn' e)     = mkHsWrap (co_fn <.> co_fn') e
mkHsWrap co_fn e                       = HsWrap noExt co_fn e

mkHsWrapCo :: TcCoercionN   -- A Nominal coercion  a ~N b
           -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
mkHsWrapCo co e = mkHsWrap (mkWpCastN co) e

mkHsWrapCoR :: TcCoercionR   -- A Representational coercion  a ~R b
            -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
mkHsWrapCoR co e = mkHsWrap (mkWpCastR co) e

mkLHsWrapCo :: TcCoercionN -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkLHsWrapCo co (dL->L loc e) = cL loc (mkHsWrapCo co e)

mkHsCmdWrap :: HsWrapper -> HsCmd (GhcPass p) -> HsCmd (GhcPass p)
mkHsCmdWrap w cmd | isIdHsWrapper w = cmd
                  | otherwise       = HsCmdWrap noExt w cmd

mkLHsCmdWrap :: HsWrapper -> LHsCmd (GhcPass p) -> LHsCmd (GhcPass p)
mkLHsCmdWrap w (dL->L loc c) = cL loc (mkHsCmdWrap w c)

mkHsWrapPat :: HsWrapper -> Pat (GhcPass id) -> Type -> Pat (GhcPass id)
mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p
                       | otherwise           = CoPat noExt co_fn p ty

mkHsWrapPatCo :: TcCoercionN -> Pat (GhcPass id) -> Type -> Pat (GhcPass id)
mkHsWrapPatCo co pat ty | isTcReflCo co = pat
                        | otherwise    = CoPat noExt (mkWpCastN co) pat ty

mkHsDictLet :: TcEvBinds -> LHsExpr GhcTc -> LHsExpr GhcTc
mkHsDictLet ev_binds expr = mkLHsWrap (mkWpLet ev_binds) expr

{-
l
************************************************************************
*                                                                      *
                Bindings; with a location at the top
*                                                                      *
************************************************************************
-}

mkFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]
          -> HsBind GhcPs
-- Not infix, with place holders for coercion and free vars
mkFunBind fn ms = FunBind { fun_id = fn
                          , fun_matches = mkMatchGroup Generated ms
                          , fun_co_fn = idHsWrapper
                          , fun_ext = noExt
                          , fun_tick = [] }

mkTopFunBind :: Origin -> Located Name -> [LMatch GhcRn (LHsExpr GhcRn)]
             -> HsBind GhcRn
-- In Name-land, with empty bind_fvs
mkTopFunBind origin fn ms = FunBind { fun_id = fn
                                    , fun_matches = mkMatchGroup origin ms
                                    , fun_co_fn = idHsWrapper
                                    , fun_ext  = emptyNameSet -- NB: closed
                                                              --     binding
                                    , fun_tick = [] }

mkHsVarBind :: SrcSpan -> RdrName -> LHsExpr GhcPs -> LHsBind GhcPs
mkHsVarBind loc var rhs = mk_easy_FunBind loc var [] rhs

mkVarBind :: IdP (GhcPass p) -> LHsExpr (GhcPass p) -> LHsBind (GhcPass p)
mkVarBind var rhs = cL (getLoc rhs) $
                    VarBind { var_ext = noExt,
                              var_id = var, var_rhs = rhs, var_inline = False }

mkPatSynBind :: Located RdrName -> HsPatSynDetails (Located RdrName)
             -> LPat GhcPs -> HsPatSynDir GhcPs -> HsBind GhcPs
mkPatSynBind name details lpat dir = PatSynBind noExt psb
  where
    psb = PSB{ psb_ext = noExt
             , psb_id = name
             , psb_args = details
             , psb_def = lpat
             , psb_dir = dir }

-- |If any of the matches in the 'FunBind' are infix, the 'FunBind' is
-- considered infix.
isInfixFunBind :: HsBindLR id1 id2 -> Bool
isInfixFunBind (FunBind _ _ (MG _ matches _) _ _)
  = any (isInfixMatch . unLoc) (unLoc matches)
isInfixFunBind _ = False

------------
mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat GhcPs]
                -> LHsExpr GhcPs -> LHsBind GhcPs
mk_easy_FunBind loc fun pats expr
  = cL loc $ mkFunBind (cL loc fun)
              [mkMatch (mkPrefixFunRhs (cL loc fun)) pats expr
                       (noLoc emptyLocalBinds)]

-- | Make a prefix, non-strict function 'HsMatchContext'
mkPrefixFunRhs :: Located id -> HsMatchContext id
mkPrefixFunRhs n = FunRhs { mc_fun = n
                          , mc_fixity = Prefix
                          , mc_strictness = NoSrcStrict }

------------
mkMatch :: HsMatchContext (NameOrRdrName (IdP (GhcPass p)))
        -> [LPat (GhcPass p)] -> LHsExpr (GhcPass p)
        -> Located (HsLocalBinds (GhcPass p))
        -> LMatch (GhcPass p) (LHsExpr (GhcPass p))
mkMatch ctxt pats expr lbinds
  = noLoc (Match { m_ext   = noExt
                 , m_ctxt  = ctxt
                 , m_pats  = map paren pats
                 , m_grhss = GRHSs noExt (unguardedRHS noSrcSpan expr) lbinds })
  where
    paren lp@(dL->L l p)
      | patNeedsParens appPrec p = cL l (ParPat noExt lp)
      | otherwise                = lp

{-
************************************************************************
*                                                                      *
        Collecting binders
*                                                                      *
************************************************************************

Get all the binders in some HsBindGroups, IN THE ORDER OF APPEARANCE. eg.

...
where
  (x, y) = ...
  f i j  = ...
  [a, b] = ...

it should return [x, y, f, a, b] (remember, order important).

Note [Collect binders only after renaming]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
These functions should only be used on HsSyn *after* the renamer,
to return a [Name] or [Id].  Before renaming the record punning
and wild-card mechanism makes it hard to know what is bound.
So these functions should not be applied to (HsSyn RdrName)

Note [Unlifted id check in isUnliftedHsBind]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The function isUnliftedHsBind is used to complain if we make a top-level
binding for a variable of unlifted type.

Such a binding is illegal if the top-level binding would be unlifted;
but also if the local letrec generated by desugaring AbsBinds would be.
E.g.
      f :: Num a => (# a, a #)
      g :: Num a => a -> a
      f = ...g...
      g = ...g...

The top-level bindings for f,g are not unlifted (because of the Num a =>),
but the local, recursive, monomorphic bindings are:

      t = /\a \(d:Num a).
         letrec fm :: (# a, a #) = ...g...
                gm :: a -> a = ...f...
         in (fm, gm)

Here the binding for 'fm' is illegal.  So generally we check the abe_mono types.

BUT we have a special case when abs_sig is true;
  see HsBinds Note [The abs_sig field of AbsBinds]
-}

----------------- Bindings --------------------------

-- | Should we treat this as an unlifted bind? This will be true for any
-- bind that binds an unlifted variable, but we must be careful around
-- AbsBinds. See Note [Unlifted id check in isUnliftedHsBind]. For usage
-- information, see Note [Strict binds check] is DsBinds.
isUnliftedHsBind :: HsBind GhcTc -> Bool  -- works only over typechecked binds
isUnliftedHsBind bind
  | AbsBinds { abs_exports = exports, abs_sig = has_sig } <- bind
  = if has_sig
    then any (is_unlifted_id . abe_poly) exports
    else any (is_unlifted_id . abe_mono) exports
    -- If has_sig is True we wil never generate a binding for abe_mono,
    -- so we don't need to worry about it being unlifted. The abe_poly
    -- binding might not be: e.g. forall a. Num a => (# a, a #)

  | otherwise
  = any is_unlifted_id (collectHsBindBinders bind)
  where
    is_unlifted_id id = isUnliftedType (idType id)

-- | Is a binding a strict variable or pattern bind (e.g. @!x = ...@)?
isBangedHsBind :: HsBind GhcTc -> Bool
isBangedHsBind (AbsBinds { abs_binds = binds })
  = anyBag (isBangedHsBind . unLoc) binds
isBangedHsBind (FunBind {fun_matches = matches})
  | [dL->L _ match] <- unLoc $ mg_alts matches
  , FunRhs{mc_strictness = SrcStrict} <- m_ctxt match
  = True
isBangedHsBind (PatBind {pat_lhs = pat})
  = isBangedLPat pat
isBangedHsBind _
  = False

collectLocalBinders :: HsLocalBindsLR (GhcPass idL) (GhcPass idR)
                    -> [IdP (GhcPass idL)]
collectLocalBinders (HsValBinds _ binds) = collectHsIdBinders binds
                                         -- No pattern synonyms here
collectLocalBinders (HsIPBinds {})      = []
collectLocalBinders (EmptyLocalBinds _) = []
collectLocalBinders (XHsLocalBindsLR _) = []

collectHsIdBinders, collectHsValBinders
  :: HsValBindsLR (GhcPass idL) (GhcPass idR) -> [IdP (GhcPass idL)]
-- Collect Id binders only, or Ids + pattern synonyms, respectively
collectHsIdBinders  = collect_hs_val_binders True
collectHsValBinders = collect_hs_val_binders False

collectHsBindBinders :: (SrcSpanLess (LPat p) ~ Pat p, HasSrcSpan (LPat p))=>
                        HsBindLR p idR -> [IdP p]
-- Collect both Ids and pattern-synonym binders
collectHsBindBinders b = collect_bind False b []

collectHsBindsBinders :: LHsBindsLR (GhcPass p) idR -> [IdP (GhcPass p)]
collectHsBindsBinders binds = collect_binds False binds []

collectHsBindListBinders :: [LHsBindLR (GhcPass p) idR] -> [IdP (GhcPass p)]
-- Same as collectHsBindsBinders, but works over a list of bindings
collectHsBindListBinders = foldr (collect_bind False . unLoc) []

collect_hs_val_binders :: Bool -> HsValBindsLR (GhcPass idL) (GhcPass idR)
                       -> [IdP (GhcPass idL)]
collect_hs_val_binders ps (ValBinds _ binds _) = collect_binds ps binds []
collect_hs_val_binders ps (XValBindsLR (NValBinds binds _))
  = collect_out_binds ps binds

collect_out_binds :: Bool -> [(RecFlag, LHsBinds (GhcPass p))] ->
                     [IdP (GhcPass p)]
collect_out_binds ps = foldr (collect_binds ps . snd) []

collect_binds :: Bool -> LHsBindsLR (GhcPass p) idR ->
                 [IdP (GhcPass p)] -> [IdP (GhcPass p)]
-- Collect Ids, or Ids + pattern synonyms, depending on boolean flag
collect_binds ps binds acc = foldrBag (collect_bind ps . unLoc) acc binds

collect_bind :: (SrcSpanLess (LPat p) ~ Pat p , HasSrcSpan (LPat p)) =>
                Bool -> HsBindLR p idR -> [IdP p] -> [IdP p]
collect_bind _ (PatBind { pat_lhs = p })           acc = collect_lpat p acc
collect_bind _ (FunBind { fun_id = (dL->L _ f) })  acc = f : acc
collect_bind _ (VarBind { var_id = f })            acc = f : acc
collect_bind _ (AbsBinds { abs_exports = dbinds }) acc = map abe_poly dbinds ++ acc
        -- I don't think we want the binders from the abe_binds

        -- binding (hence see AbsBinds) is in zonking in TcHsSyn
collect_bind omitPatSyn (PatSynBind _ (PSB { psb_id = (dL->L _ ps) })) acc
  | omitPatSyn                  = acc
  | otherwise                   = ps : acc
collect_bind _ (PatSynBind _ (XPatSynBind _)) acc = acc
collect_bind _ (XHsBindsLR _) acc = acc

collectMethodBinders :: LHsBindsLR idL idR -> [Located (IdP idL)]
-- Used exclusively for the bindings of an instance decl which are all FunBinds
collectMethodBinders binds = foldrBag (get . unLoc) [] binds
  where
    get (FunBind { fun_id = f }) fs = f : fs
    get _                        fs = fs
       -- Someone else complains about non-FunBinds

----------------- Statements --------------------------
collectLStmtsBinders :: [LStmtLR (GhcPass idL) (GhcPass idR) body]
                     -> [IdP (GhcPass idL)]
collectLStmtsBinders = concatMap collectLStmtBinders

collectStmtsBinders :: [StmtLR (GhcPass idL) (GhcPass idR) body]
                    -> [IdP (GhcPass idL)]
collectStmtsBinders = concatMap collectStmtBinders

collectLStmtBinders :: LStmtLR (GhcPass idL) (GhcPass idR) body
                    -> [IdP (GhcPass idL)]
collectLStmtBinders = collectStmtBinders . unLoc

collectStmtBinders :: StmtLR (GhcPass idL) (GhcPass idR) body
                   -> [IdP (GhcPass idL)]
  -- Id Binders for a Stmt... [but what about pattern-sig type vars]?
collectStmtBinders (BindStmt _ pat _ _ _)  = collectPatBinders pat
collectStmtBinders (LetStmt _  binds)      = collectLocalBinders (unLoc binds)
collectStmtBinders (BodyStmt {})           = []
collectStmtBinders (LastStmt {})           = []
collectStmtBinders (ParStmt _ xs _ _)      = collectLStmtsBinders
                                    $ [s | ParStmtBlock _ ss _ _ <- xs, s <- ss]
collectStmtBinders (TransStmt { trS_stmts = stmts }) = collectLStmtsBinders stmts
collectStmtBinders (RecStmt { recS_stmts = ss })     = collectLStmtsBinders ss
collectStmtBinders (ApplicativeStmt _ args _) = concatMap collectArgBinders args
 where
  collectArgBinders (_, ApplicativeArgOne _ pat _ _) = collectPatBinders pat
  collectArgBinders (_, ApplicativeArgMany _ _ _ pat) = collectPatBinders pat
  collectArgBinders _ = []
collectStmtBinders XStmtLR{} = panic "collectStmtBinders"

----------------- Patterns --------------------------
collectPatBinders :: LPat (GhcPass p) -> [IdP (GhcPass p)]
collectPatBinders pat = collect_lpat pat []

collectPatsBinders :: [LPat (GhcPass p)] -> [IdP (GhcPass p)]
collectPatsBinders pats = foldr collect_lpat [] pats

-------------
collect_lpat :: (SrcSpanLess (LPat p) ~ Pat p , HasSrcSpan (LPat p)) =>
                 LPat p -> [IdP p] -> [IdP p]
collect_lpat p bndrs
  = go (unLoc p)
  where
    go (VarPat _ var)             = unLoc var : bndrs
    go (WildPat _)                = bndrs
    go (LazyPat _ pat)            = collect_lpat pat bndrs
    go (BangPat _ pat)            = collect_lpat pat bndrs
    go (AsPat _ a pat)            = unLoc a : collect_lpat pat bndrs
    go (ViewPat _ _ pat)          = collect_lpat pat bndrs
    go (ParPat _ pat)             = collect_lpat pat bndrs

    go (ListPat _ pats)           = foldr collect_lpat bndrs pats
    go (TuplePat _ pats _)        = foldr collect_lpat bndrs pats
    go (SumPat _ pat _ _)         = collect_lpat pat bndrs

    go (ConPatIn _ ps)            = foldr collect_lpat bndrs (hsConPatArgs ps)
    go (ConPatOut {pat_args=ps})  = foldr collect_lpat bndrs (hsConPatArgs ps)
        -- See Note [Dictionary binders in ConPatOut]
    go (LitPat _ _)               = bndrs
    go (NPat {})                  = bndrs
    go (NPlusKPat _ n _ _ _ _)    = unLoc n : bndrs

    go (SigPat _ pat _)           = collect_lpat pat bndrs

    go (SplicePat _ (HsSpliced _ _ (HsSplicedPat pat)))
                                  = go pat
    go (SplicePat _ _)            = bndrs
    go (CoPat _ _ pat _)          = go pat
    go (XPat {})                  = bndrs

{-
Note [Dictionary binders in ConPatOut] See also same Note in DsArrows
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Do *not* gather (a) dictionary and (b) dictionary bindings as binders
of a ConPatOut pattern.  For most calls it doesn't matter, because
it's pre-typechecker and there are no ConPatOuts.  But it does matter
more in the desugarer; for example, DsUtils.mkSelectorBinds uses
collectPatBinders.  In a lazy pattern, for example f ~(C x y) = ...,
we want to generate bindings for x,y but not for dictionaries bound by
C.  (The type checker ensures they would not be used.)

Desugaring of arrow case expressions needs these bindings (see DsArrows
and arrowcase1), but SPJ (Jan 2007) says it's safer for it to use its
own pat-binder-collector:

Here's the problem.  Consider

data T a where
   C :: Num a => a -> Int -> T a

f ~(C (n+1) m) = (n,m)

Here, the pattern (C (n+1)) binds a hidden dictionary (d::Num a),
and *also* uses that dictionary to match the (n+1) pattern.  Yet, the
variables bound by the lazy pattern are n,m, *not* the dictionary d.
So in mkSelectorBinds in DsUtils, we want just m,n as the variables bound.
-}

hsGroupBinders :: HsGroup GhcRn -> [Name]
hsGroupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls,
                          hs_fords = foreign_decls })
  =  collectHsValBinders val_decls
  ++ hsTyClForeignBinders tycl_decls foreign_decls
hsGroupBinders (XHsGroup {}) = panic "hsGroupBinders"

hsTyClForeignBinders :: [TyClGroup GhcRn]
                     -> [LForeignDecl GhcRn]
                     -> [Name]
-- We need to look at instance declarations too,
-- because their associated types may bind data constructors
hsTyClForeignBinders tycl_decls foreign_decls
  =    map unLoc (hsForeignDeclsBinders foreign_decls)
    ++ getSelectorNames
         (foldMap (foldMap hsLTyClDeclBinders . group_tyclds) tycl_decls
         `mappend`
         foldMap (foldMap hsLInstDeclBinders . group_instds) tycl_decls)
  where
    getSelectorNames :: ([Located Name], [LFieldOcc GhcRn]) -> [Name]
    getSelectorNames (ns, fs) = map unLoc ns ++ map (extFieldOcc . unLoc) fs

-------------------
hsLTyClDeclBinders :: Located (TyClDecl pass)
                   -> ([Located (IdP pass)], [LFieldOcc pass])
-- ^ Returns all the /binding/ names of the decl.  The first one is
-- guaranteed to be the name of the decl. The first component
-- represents all binding names except record fields; the second
-- represents field occurrences. For record fields mentioned in
-- multiple constructors, the SrcLoc will be from the first occurrence.
--
-- Each returned (Located name) has a SrcSpan for the /whole/ declaration.
-- See Note [SrcSpan for binders]

hsLTyClDeclBinders (dL->L loc (FamDecl { tcdFam = FamilyDecl
                                            { fdLName = (dL->L _ name) } }))
  = ([cL loc name], [])
hsLTyClDeclBinders (dL->L _ (FamDecl { tcdFam = XFamilyDecl _ }))
  = panic "hsLTyClDeclBinders"
hsLTyClDeclBinders (dL->L loc (SynDecl
                               { tcdLName = (dL->L _ name) }))
  = ([cL loc name], [])
hsLTyClDeclBinders (dL->L loc (ClassDecl
                               { tcdLName = (dL->L _ cls_name)
                               , tcdSigs  = sigs
                               , tcdATs   = ats }))
  = (cL loc cls_name :
     [ cL fam_loc fam_name | (dL->L fam_loc (FamilyDecl
                                        { fdLName = L _ fam_name })) <- ats ]
     ++
     [ cL mem_loc mem_name | (dL->L mem_loc (ClassOpSig _ False ns _)) <- sigs
                           , (dL->L _ mem_name) <- ns ]
    , [])
hsLTyClDeclBinders (dL->L loc (DataDecl    { tcdLName = (dL->L _ name)
                                           , tcdDataDefn = defn }))
  = (\ (xs, ys) -> (cL loc name : xs, ys)) $ hsDataDefnBinders defn
hsLTyClDeclBinders (dL->L _ (XTyClDecl _)) = panic "hsLTyClDeclBinders"
hsLTyClDeclBinders _ = panic "hsLTyClDeclBinders: Impossible Match"
                             -- due to #15884

-------------------
hsForeignDeclsBinders :: [LForeignDecl pass] -> [Located (IdP pass)]
-- See Note [SrcSpan for binders]
hsForeignDeclsBinders foreign_decls
  = [ cL decl_loc n
    | (dL->L decl_loc (ForeignImport { fd_name = (dL->L _ n) }))
        <- foreign_decls]

-------------------
hsPatSynSelectors :: HsValBinds (GhcPass p) -> [IdP (GhcPass p)]
-- Collects record pattern-synonym selectors only; the pattern synonym
-- names are collected by collectHsValBinders.
hsPatSynSelectors (ValBinds _ _ _) = panic "hsPatSynSelectors"
hsPatSynSelectors (XValBindsLR (NValBinds binds _))
  = foldrBag addPatSynSelector [] . unionManyBags $ map snd binds

addPatSynSelector:: LHsBind p -> [IdP p] -> [IdP p]
addPatSynSelector bind sels
  | PatSynBind _ (PSB { psb_args = RecCon as }) <- unLoc bind
  = map (unLoc . recordPatSynSelectorId) as ++ sels
  | otherwise = sels

getPatSynBinds :: [(RecFlag, LHsBinds id)] -> [PatSynBind id id]
getPatSynBinds binds
  = [ psb | (_, lbinds) <- binds
          , (dL->L _ (PatSynBind _ psb)) <- bagToList lbinds ]

-------------------
hsLInstDeclBinders :: LInstDecl (GhcPass p)
                   -> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)])
hsLInstDeclBinders (dL->L _ (ClsInstD
                             { cid_inst = ClsInstDecl
                                          { cid_datafam_insts = dfis }}))
  = foldMap (hsDataFamInstBinders . unLoc) dfis
hsLInstDeclBinders (dL->L _ (DataFamInstD { dfid_inst = fi }))
  = hsDataFamInstBinders fi
hsLInstDeclBinders (dL->L _ (TyFamInstD {})) = mempty
hsLInstDeclBinders (dL->L _ (ClsInstD _ (XClsInstDecl {})))
  = panic "hsLInstDeclBinders"
hsLInstDeclBinders (dL->L _ (XInstDecl _))
  = panic "hsLInstDeclBinders"
hsLInstDeclBinders _ = panic "hsLInstDeclBinders: Impossible Match"
                             -- due to #15884

-------------------
-- the SrcLoc returned are for the whole declarations, not just the names
hsDataFamInstBinders :: DataFamInstDecl pass
                     -> ([Located (IdP pass)], [LFieldOcc pass])
hsDataFamInstBinders (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
                       FamEqn { feqn_rhs = defn }}})
  = hsDataDefnBinders defn
  -- There can't be repeated symbols because only data instances have binders
hsDataFamInstBinders (DataFamInstDecl
                                    { dfid_eqn = HsIB { hsib_body = XFamEqn _}})
  = panic "hsDataFamInstBinders"
hsDataFamInstBinders (DataFamInstDecl (XHsImplicitBndrs _))
  = panic "hsDataFamInstBinders"

-------------------
-- the SrcLoc returned are for the whole declarations, not just the names
hsDataDefnBinders :: HsDataDefn pass -> ([Located (IdP pass)], [LFieldOcc pass])
hsDataDefnBinders (HsDataDefn { dd_cons = cons })
  = hsConDeclsBinders cons
  -- See Note [Binders in family instances]
hsDataDefnBinders (XHsDataDefn _) = panic "hsDataDefnBinders"

-------------------
type Seen pass = [LFieldOcc pass] -> [LFieldOcc pass]
                 -- Filters out ones that have already been seen

hsConDeclsBinders :: [LConDecl pass] -> ([Located (IdP pass)], [LFieldOcc pass])
   -- See hsLTyClDeclBinders for what this does
   -- The function is boringly complicated because of the records
   -- And since we only have equality, we have to be a little careful
hsConDeclsBinders cons
  = go id cons
  where
    go :: Seen pass -> [LConDecl pass]
       -> ([Located (IdP pass)], [LFieldOcc pass])
    go _ [] = ([], [])
    go remSeen (r:rs)
      -- Don't re-mangle the location of field names, because we don't
      -- have a record of the full location of the field declaration anyway
      = let loc = getLoc r
        in case unLoc r of
           -- remove only the first occurrence of any seen field in order to
           -- avoid circumventing detection of duplicate fields (#9156)
           ConDeclGADT { con_names = names, con_args = args }
             -> (map (cL loc . unLoc) names ++ ns, flds ++ fs)
             where
                (remSeen', flds) = get_flds remSeen args
                (ns, fs) = go remSeen' rs

           ConDeclH98 { con_name = name, con_args = args }
             -> ([cL loc (unLoc name)] ++ ns, flds ++ fs)
             where
                (remSeen', flds) = get_flds remSeen args
                (ns, fs) = go remSeen' rs

           XConDecl _ -> panic "hsConDeclsBinders"

    get_flds :: Seen pass -> HsConDeclDetails pass
             -> (Seen pass, [LFieldOcc pass])
    get_flds remSeen (RecCon flds)
       = (remSeen', fld_names)
       where
          fld_names = remSeen (concatMap (cd_fld_names . unLoc) (unLoc flds))
          remSeen' = foldr (.) remSeen
                               [deleteBy ((==) `on` unLoc . rdrNameFieldOcc . unLoc) v
                               | v <- fld_names]
    get_flds remSeen _
       = (remSeen, [])

{-

Note [SrcSpan for binders]
~~~~~~~~~~~~~~~~~~~~~~~~~~
When extracting the (Located RdrNme) for a binder, at least for the
main name (the TyCon of a type declaration etc), we want to give it
the @SrcSpan@ of the whole /declaration/, not just the name itself
(which is how it appears in the syntax tree).  This SrcSpan (for the
entire declaration) is used as the SrcSpan for the Name that is
finally produced, and hence for error messages.  (See Trac #8607.)

Note [Binders in family instances]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In a type or data family instance declaration, the type
constructor is an *occurrence* not a binding site
    type instance T Int = Int -> Int   -- No binders
    data instance S Bool = S1 | S2     -- Binders are S1,S2

************************************************************************
*                                                                      *
        Collecting binders the user did not write
*                                                                      *
************************************************************************

The job of this family of functions is to run through binding sites and find the set of all Names
that were defined "implicitly", without being explicitly written by the user.

The main purpose is to find names introduced by record wildcards so that we can avoid
warning the user when they don't use those names (#4404)

Since the addition of -Wunused-record-wildcards, this function returns a pair
of [(SrcSpan, [Name])]. Each element of the list is one set of implicit
binders, the first component of the tuple is the document describes the possible
fix to the problem (by removing the ..).

This means there is some unfortunate coupling between this function and where it
is used but it's only used for one specific purpose in one place so it seemed
easier.
-}

lStmtsImplicits :: [LStmtLR GhcRn (GhcPass idR) (Located (body (GhcPass idR)))]
                -> [(SrcSpan, [Name])]
lStmtsImplicits = hs_lstmts
  where
    hs_lstmts :: [LStmtLR GhcRn (GhcPass idR) (Located (body (GhcPass idR)))]
              -> [(SrcSpan, [Name])]
    hs_lstmts = concatMap (hs_stmt . unLoc)

    hs_stmt :: StmtLR GhcRn (GhcPass idR) (Located (body (GhcPass idR)))
            -> [(SrcSpan, [Name])]
    hs_stmt (BindStmt _ pat _ _ _) = lPatImplicits pat
    hs_stmt (ApplicativeStmt _ args _) = concatMap do_arg args
      where do_arg (_, ApplicativeArgOne _ pat _ _) = lPatImplicits pat
            do_arg (_, ApplicativeArgMany _ stmts _ _) = hs_lstmts stmts
            do_arg (_, XApplicativeArg _) = panic "lStmtsImplicits"
    hs_stmt (LetStmt _ binds)     = hs_local_binds (unLoc binds)
    hs_stmt (BodyStmt {})         = []
    hs_stmt (LastStmt {})         = []
    hs_stmt (ParStmt _ xs _ _)    = hs_lstmts [s | ParStmtBlock _ ss _ _ <- xs
                                                , s <- ss]
    hs_stmt (TransStmt { trS_stmts = stmts }) = hs_lstmts stmts
    hs_stmt (RecStmt { recS_stmts = ss })     = hs_lstmts ss
    hs_stmt (XStmtLR {})          = panic "lStmtsImplicits"

    hs_local_binds (HsValBinds _ val_binds) = hsValBindsImplicits val_binds
    hs_local_binds (HsIPBinds {})           = []
    hs_local_binds (EmptyLocalBinds _)      = []
    hs_local_binds (XHsLocalBindsLR _)      = []

hsValBindsImplicits :: HsValBindsLR GhcRn (GhcPass idR) -> [(SrcSpan, [Name])]
hsValBindsImplicits (XValBindsLR (NValBinds binds _))
  = concatMap (lhsBindsImplicits . snd) binds
hsValBindsImplicits (ValBinds _ binds _)
  = lhsBindsImplicits binds

lhsBindsImplicits :: LHsBindsLR GhcRn idR -> [(SrcSpan, [Name])]
lhsBindsImplicits = foldBag (++) (lhs_bind . unLoc) []
  where
    lhs_bind (PatBind { pat_lhs = lpat }) = lPatImplicits lpat
    lhs_bind _ = []

lPatImplicits :: LPat GhcRn -> [(SrcSpan, [Name])]
lPatImplicits = hs_lpat
  where
    hs_lpat lpat = hs_pat (unLoc lpat)

    hs_lpats = foldr (\pat rest -> hs_lpat pat ++ rest) []

    hs_pat (LazyPat _ pat)      = hs_lpat pat
    hs_pat (BangPat _ pat)      = hs_lpat pat
    hs_pat (AsPat _ _ pat)      = hs_lpat pat
    hs_pat (ViewPat _ _ pat)    = hs_lpat pat
    hs_pat (ParPat _ pat)       = hs_lpat pat
    hs_pat (ListPat _ pats)     = hs_lpats pats
    hs_pat (TuplePat _ pats _)  = hs_lpats pats

    hs_pat (SigPat _ pat _)     = hs_lpat pat
    hs_pat (CoPat _ _ pat _)    = hs_pat pat

    hs_pat (ConPatIn n ps)           = details n ps
    hs_pat (ConPatOut {pat_con=con, pat_args=ps}) = details (fmap conLikeName con) ps

    hs_pat _ = []

    details :: Located Name -> HsConPatDetails GhcRn -> [(SrcSpan, [Name])]
    details _ (PrefixCon ps)   = hs_lpats ps
    details n (RecCon fs)      =
      [(err_loc, collectPatsBinders implicit_pats) | Just{} <- [rec_dotdot fs] ]
        ++ hs_lpats explicit_pats

      where implicit_pats = map (hsRecFieldArg . unLoc) implicit
            explicit_pats = map (hsRecFieldArg . unLoc) explicit

            (explicit, implicit) = partitionEithers [if pat_explicit then Left fld else Right fld
                                                    | (i, fld) <- [0..] `zip` rec_flds fs
                                                    ,  let  pat_explicit =
                                                              maybe True ((i<) . unLoc)
                                                                         (rec_dotdot fs)]
            err_loc = maybe (getLoc n) getLoc (rec_dotdot fs)

    details _ (InfixCon p1 p2) = hs_lpat p1 ++ hs_lpat p2


{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE StandaloneDeriving #-}

module PlaceHolder where

import Name
import NameSet
import RdrName
import Var

{-
%************************************************************************
%*                                                                      *
\subsection{Annotating the syntax}
%*                                                                      *
%************************************************************************
-}

-- NB: These are intentionally open, allowing API consumers (like Haddock)
-- to declare new instances

placeHolderNamesTc :: NameSet
placeHolderNamesTc = emptyNameSet

{-
TODO:AZ: remove this, and check if we still need all the UndecidableInstances

Note [Pass sensitive types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Since the same AST types are re-used through parsing,renaming and type
checking there are naturally some places in the AST that do not have
any meaningful value prior to the pass they are assigned a value.

Historically these have been filled in with place holder values of the form

  panic "error message"

This has meant the AST is difficult to traverse using standard generic
programming techniques. The problem is addressed by introducing
pass-specific data types, implemented as a pair of open type families,
one for PostTc and one for PostRn. These are then explicitly populated
with a PlaceHolder value when they do not yet have meaning.

In terms of actual usage, we have the following

  PostTc id Kind
  PostTc id Type

  PostRn id Fixity
  PostRn id NameSet

TcId and Var are synonyms for Id

Unfortunately the type checker termination checking conditions fail for the
DataId constraint type based on this, so even though it is safe the
UndecidableInstances pragma is required where this is used.
-}

-- |Follow the @id@, but never beyond Name. This is used in a 'HsMatchContext',
-- for printing messages related to a 'Match'
type family NameOrRdrName id where
  NameOrRdrName Id      = Name
  NameOrRdrName Name    = Name
  NameOrRdrName RdrName = RdrName


{-# LANGUAGE CPP #-}

-- | Computing fingerprints of values serializeable with GHC's "Binary" module.
module BinFingerprint
  ( -- * Computing fingerprints
    fingerprintBinMem
  , computeFingerprint
  , putNameLiterally
  ) where

#include "HsVersions.h"

import GhcPrelude

import Fingerprint
import Binary
import Name
import Panic
import Util

fingerprintBinMem :: BinHandle -> IO Fingerprint
fingerprintBinMem bh = withBinBuffer bh f
  where
    f bs =
        -- we need to take care that we force the result here
        -- lest a reference to the ByteString may leak out of
        -- withBinBuffer.
        let fp = fingerprintByteString bs
        in fp `seq` return fp

computeFingerprint :: (Binary a)
                   => (BinHandle -> Name -> IO ())
                   -> a
                   -> IO Fingerprint
computeFingerprint put_nonbinding_name a = do
    bh <- fmap set_user_data $ openBinMem (3*1024) -- just less than a block
    put_ bh a
    fp <- fingerprintBinMem bh
    return fp
  where
    set_user_data bh =
      setUserData bh $ newWriteState put_nonbinding_name putNameLiterally putFS

-- | Used when we want to fingerprint a structure without depending on the
-- fingerprints of external Names that it refers to.
putNameLiterally :: BinHandle -> Name -> IO ()
putNameLiterally bh name = ASSERT( isExternalName name ) do
    put_ bh $! nameModule name
    put_ bh $! nameOccName name


{-# LANGUAGE BinaryLiterals, CPP, ScopedTypeVariables, BangPatterns #-}

--
--  (c) The University of Glasgow 2002-2006
--

{-# OPTIONS_GHC -O2 #-}
-- We always optimise this, otherwise performance of a non-optimised
-- compiler is severely affected

-- | Binary interface file support.
module BinIface (
        writeBinIface,
        readBinIface,
        getSymtabName,
        getDictFastString,
        CheckHiWay(..),
        TraceBinIFaceReading(..),
        getWithUserData,
        putWithUserData

    ) where

#include "HsVersions.h"

import GhcPrelude

import TcRnMonad
import PrelInfo   ( isKnownKeyName, lookupKnownKeyName )
import IfaceEnv
import HscTypes
import Module
import Name
import DynFlags
import UniqFM
import UniqSupply
import Panic
import Binary
import SrcLoc
import ErrUtils
import FastMutInt
import Unique
import Outputable
import NameCache
import Platform
import FastString
import Constants
import Util

import Data.Array
import Data.Array.ST
import Data.Array.Unsafe
import Data.Bits
import Data.Char
import Data.Word
import Data.IORef
import Data.Foldable
import Control.Monad
import Control.Monad.ST
import Control.Monad.Trans.Class
import qualified Control.Monad.Trans.State.Strict as State

-- ---------------------------------------------------------------------------
-- Reading and writing binary interface files
--

data CheckHiWay = CheckHiWay | IgnoreHiWay
    deriving Eq

data TraceBinIFaceReading = TraceBinIFaceReading | QuietBinIFaceReading
    deriving Eq

-- | Read an interface file
readBinIface :: CheckHiWay -> TraceBinIFaceReading -> FilePath
             -> TcRnIf a b ModIface
readBinIface checkHiWay traceBinIFaceReading hi_path = do
    ncu <- mkNameCacheUpdater
    dflags <- getDynFlags
    liftIO $ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu

readBinIface_ :: DynFlags -> CheckHiWay -> TraceBinIFaceReading -> FilePath
              -> NameCacheUpdater
              -> IO ModIface
readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu = do
    let printer :: SDoc -> IO ()
        printer = case traceBinIFaceReading of
                      TraceBinIFaceReading -> \sd ->
                          putLogMsg dflags
                                    NoReason
                                    SevOutput
                                    noSrcSpan
                                    (defaultDumpStyle dflags)
                                    sd
                      QuietBinIFaceReading -> \_ -> return ()
        wantedGot :: Outputable a => String -> a -> a -> IO ()
        wantedGot what wanted got =
            printer (text what <> text ": " <>
                     vcat [text "Wanted " <> ppr wanted <> text ",",
                           text "got    " <> ppr got])

        errorOnMismatch :: (Eq a, Show a) => String -> a -> a -> IO ()
        errorOnMismatch what wanted got =
            -- This will be caught by readIface which will emit an error
            -- msg containing the iface module name.
            when (wanted /= got) $ throwGhcExceptionIO $ ProgramError
                         (what ++ " (wanted " ++ show wanted
                               ++ ", got "    ++ show got ++ ")")
    bh <- Binary.readBinMem hi_path

    -- Read the magic number to check that this really is a GHC .hi file
    -- (This magic number does not change when we change
    --  GHC interface file format)
    magic <- get bh
    wantedGot "Magic" (binaryInterfaceMagic dflags) magic
    errorOnMismatch "magic number mismatch: old/corrupt interface file?"
        (binaryInterfaceMagic dflags) magic

    -- Note [dummy iface field]
    -- read a dummy 32/64 bit value.  This field used to hold the
    -- dictionary pointer in old interface file formats, but now
    -- the dictionary pointer is after the version (where it
    -- should be).  Also, the serialisation of value of type "Bin
    -- a" used to depend on the word size of the machine, now they
    -- are always 32 bits.
    if wORD_SIZE dflags == 4
        then do _ <- Binary.get bh :: IO Word32; return ()
        else do _ <- Binary.get bh :: IO Word64; return ()

    -- Check the interface file version and ways.
    check_ver  <- get bh
    let our_ver = show hiVersion
    wantedGot "Version" our_ver check_ver
    errorOnMismatch "mismatched interface file versions" our_ver check_ver

    check_way <- get bh
    let way_descr = getWayDescr dflags
    wantedGot "Way" way_descr check_way
    when (checkHiWay == CheckHiWay) $
        errorOnMismatch "mismatched interface file ways" way_descr check_way
    getWithUserData ncu bh

-- | This performs a get action after reading the dictionary and symbol
-- table. It is necessary to run this before trying to deserialise any
-- Names or FastStrings.
getWithUserData :: Binary a => NameCacheUpdater -> BinHandle -> IO a
getWithUserData ncu bh = do
    -- Read the dictionary
    -- The next word in the file is a pointer to where the dictionary is
    -- (probably at the end of the file)
    dict_p <- Binary.get bh
    data_p <- tellBin bh          -- Remember where we are now
    seekBin bh dict_p
    dict   <- getDictionary bh
    seekBin bh data_p             -- Back to where we were before

    -- Initialise the user-data field of bh
    bh <- do
        bh <- return $ setUserData bh $ newReadState (error "getSymtabName")
                                                     (getDictFastString dict)
        symtab_p <- Binary.get bh     -- Get the symtab ptr
        data_p <- tellBin bh          -- Remember where we are now
        seekBin bh symtab_p
        symtab <- getSymbolTable bh ncu
        seekBin bh data_p             -- Back to where we were before

        -- It is only now that we know how to get a Name
        return $ setUserData bh $ newReadState (getSymtabName ncu dict symtab)
                                               (getDictFastString dict)

    -- Read the interface file
    get bh

-- | Write an interface file
writeBinIface :: DynFlags -> FilePath -> ModIface -> IO ()
writeBinIface dflags hi_path mod_iface = do
    bh <- openBinMem initBinMemSize
    put_ bh (binaryInterfaceMagic dflags)

   -- dummy 32/64-bit field before the version/way for
   -- compatibility with older interface file formats.
   -- See Note [dummy iface field] above.
    if wORD_SIZE dflags == 4
        then Binary.put_ bh (0 :: Word32)
        else Binary.put_ bh (0 :: Word64)

    -- The version and way descriptor go next
    put_ bh (show hiVersion)
    let way_descr = getWayDescr dflags
    put_  bh way_descr

    putWithUserData (debugTraceMsg dflags 3) bh mod_iface
    -- And send the result to the file
    writeBinMem bh hi_path

-- | Put a piece of data with an initialised `UserData` field. This
-- is necessary if you want to serialise Names or FastStrings.
-- It also writes a symbol table and the dictionary.
-- This segment should be read using `getWithUserData`.
putWithUserData :: Binary a => (SDoc -> IO ()) -> BinHandle -> a -> IO ()
putWithUserData log_action bh payload = do
    -- Remember where the dictionary pointer will go
    dict_p_p <- tellBin bh
    -- Placeholder for ptr to dictionary
    put_ bh dict_p_p

    -- Remember where the symbol table pointer will go
    symtab_p_p <- tellBin bh
    put_ bh symtab_p_p
    -- Make some initial state
    symtab_next <- newFastMutInt
    writeFastMutInt symtab_next 0
    symtab_map <- newIORef emptyUFM
    let bin_symtab = BinSymbolTable {
                         bin_symtab_next = symtab_next,
                         bin_symtab_map  = symtab_map }
    dict_next_ref <- newFastMutInt
    writeFastMutInt dict_next_ref 0
    dict_map_ref <- newIORef emptyUFM
    let bin_dict = BinDictionary {
                       bin_dict_next = dict_next_ref,
                       bin_dict_map  = dict_map_ref }

    -- Put the main thing,
    bh <- return $ setUserData bh $ newWriteState (putName bin_dict bin_symtab)
                                                  (putName bin_dict bin_symtab)
                                                  (putFastString bin_dict)
    put_ bh payload

    -- Write the symtab pointer at the front of the file
    symtab_p <- tellBin bh        -- This is where the symtab will start
    putAt bh symtab_p_p symtab_p  -- Fill in the placeholder
    seekBin bh symtab_p           -- Seek back to the end of the file

    -- Write the symbol table itself
    symtab_next <- readFastMutInt symtab_next
    symtab_map  <- readIORef symtab_map
    putSymbolTable bh symtab_next symtab_map
    log_action (text "writeBinIface:" <+> int symtab_next
                                <+> text "Names")

    -- NB. write the dictionary after the symbol table, because
    -- writing the symbol table may create more dictionary entries.

    -- Write the dictionary pointer at the front of the file
    dict_p <- tellBin bh          -- This is where the dictionary will start
    putAt bh dict_p_p dict_p      -- Fill in the placeholder
    seekBin bh dict_p             -- Seek back to the end of the file

    -- Write the dictionary itself
    dict_next <- readFastMutInt dict_next_ref
    dict_map  <- readIORef dict_map_ref
    putDictionary bh dict_next dict_map
    log_action (text "writeBinIface:" <+> int dict_next
                                <+> text "dict entries")

-- | Initial ram buffer to allocate for writing interface files
initBinMemSize :: Int
initBinMemSize = 1024 * 1024

binaryInterfaceMagic :: DynFlags -> Word32
binaryInterfaceMagic dflags
 | target32Bit (targetPlatform dflags) = 0x1face
 | otherwise                           = 0x1face64

-- -----------------------------------------------------------------------------
-- The symbol table
--

putSymbolTable :: BinHandle -> Int -> UniqFM (Int,Name) -> IO ()
putSymbolTable bh next_off symtab = do
    put_ bh next_off
    let names = elems (array (0,next_off-1) (nonDetEltsUFM symtab))
      -- It's OK to use nonDetEltsUFM here because the elements have
      -- indices that array uses to create order
    mapM_ (\n -> serialiseName bh n symtab) names

getSymbolTable :: BinHandle -> NameCacheUpdater -> IO SymbolTable
getSymbolTable bh ncu = do
    sz <- get bh
    od_names <- sequence (replicate sz (get bh))
    updateNameCache ncu $ \namecache ->
        runST $ flip State.evalStateT namecache $ do
            mut_arr <- lift $ newSTArray_ (0, sz-1)
            for_ (zip [0..] od_names) $ \(i, odn) -> do
                (nc, !n) <- State.gets $ \nc -> fromOnDiskName nc odn
                lift $ writeArray mut_arr i n
                State.put nc
            arr <- lift $ unsafeFreeze mut_arr
            namecache' <- State.get
            return (namecache', arr)
  where
    -- This binding is required because the type of newArray_ cannot be inferred
    newSTArray_ :: forall s. (Int, Int) -> ST s (STArray s Int Name)
    newSTArray_ = newArray_

type OnDiskName = (UnitId, ModuleName, OccName)

fromOnDiskName :: NameCache -> OnDiskName -> (NameCache, Name)
fromOnDiskName nc (pid, mod_name, occ) =
    let mod   = mkModule pid mod_name
        cache = nsNames nc
    in case lookupOrigNameCache cache  mod occ of
           Just name -> (nc, name)
           Nothing   ->
               let (uniq, us) = takeUniqFromSupply (nsUniqs nc)
                   name       = mkExternalName uniq mod occ noSrcSpan
                   new_cache  = extendNameCache cache mod occ name
               in ( nc{ nsUniqs = us, nsNames = new_cache }, name )

serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO ()
serialiseName bh name _ = do
    let mod = ASSERT2( isExternalName name, ppr name ) nameModule name
    put_ bh (moduleUnitId mod, moduleName mod, nameOccName name)

-- Note [Symbol table representation of names]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--
-- An occurrence of a name in an interface file is serialized as a single 32-bit
-- word. The format of this word is:
--  00xxxxxx xxxxxxxx xxxxxxxx xxxxxxxx
--   A normal name. x is an index into the symbol table
--  10xxxxxx xxyyyyyy yyyyyyyy yyyyyyyy
--   A known-key name. x is the Unique's Char, y is the int part. We assume that
--   all known-key uniques fit in this space. This is asserted by
--   PrelInfo.knownKeyNamesOkay.
--
-- During serialization we check for known-key things using isKnownKeyName.
-- During deserialization we use lookupKnownKeyName to get from the unique back
-- to its corresponding Name.

-- See Note [Symbol table representation of names]
putName :: BinDictionary -> BinSymbolTable -> BinHandle -> Name -> IO ()
putName _dict BinSymbolTable{
               bin_symtab_map = symtab_map_ref,
               bin_symtab_next = symtab_next }
        bh name
  | isKnownKeyName name
  , let (c, u) = unpkUnique (nameUnique name) -- INVARIANT: (ord c) fits in 8 bits
  = -- ASSERT(u < 2^(22 :: Int))
    put_ bh (0x80000000
             .|. (fromIntegral (ord c) `shiftL` 22)
             .|. (fromIntegral u :: Word32))

  | otherwise
  = do symtab_map <- readIORef symtab_map_ref
       case lookupUFM symtab_map name of
         Just (off,_) -> put_ bh (fromIntegral off :: Word32)
         Nothing -> do
            off <- readFastMutInt symtab_next
            -- MASSERT(off < 2^(30 :: Int))
            writeFastMutInt symtab_next (off+1)
            writeIORef symtab_map_ref
                $! addToUFM symtab_map name (off,name)
            put_ bh (fromIntegral off :: Word32)

-- See Note [Symbol table representation of names]
getSymtabName :: NameCacheUpdater
              -> Dictionary -> SymbolTable
              -> BinHandle -> IO Name
getSymtabName _ncu _dict symtab bh = do
    i :: Word32 <- get bh
    case i .&. 0xC0000000 of
      0x00000000 -> return $! symtab ! fromIntegral i

      0x80000000 ->
        let
          tag = chr (fromIntegral ((i .&. 0x3FC00000) `shiftR` 22))
          ix  = fromIntegral i .&. 0x003FFFFF
          u   = mkUnique tag ix
        in
          return $! case lookupKnownKeyName u of
                      Nothing -> pprPanic "getSymtabName:unknown known-key unique"
                                          (ppr i $$ ppr (unpkUnique u))
                      Just n  -> n

      _ -> pprPanic "getSymtabName:unknown name tag" (ppr i)

data BinSymbolTable = BinSymbolTable {
        bin_symtab_next :: !FastMutInt, -- The next index to use
        bin_symtab_map  :: !(IORef (UniqFM (Int,Name)))
                                -- indexed by Name
  }

putFastString :: BinDictionary -> BinHandle -> FastString -> IO ()
putFastString dict bh fs = allocateFastString dict fs >>= put_ bh

allocateFastString :: BinDictionary -> FastString -> IO Word32
allocateFastString BinDictionary { bin_dict_next = j_r,
                                   bin_dict_map  = out_r} f = do
    out <- readIORef out_r
    let uniq = getUnique f
    case lookupUFM out uniq of
        Just (j, _)  -> return (fromIntegral j :: Word32)
        Nothing -> do
           j <- readFastMutInt j_r
           writeFastMutInt j_r (j + 1)
           writeIORef out_r $! addToUFM out uniq (j, f)
           return (fromIntegral j :: Word32)

getDictFastString :: Dictionary -> BinHandle -> IO FastString
getDictFastString dict bh = do
    j <- get bh
    return $! (dict ! fromIntegral (j :: Word32))

data BinDictionary = BinDictionary {
        bin_dict_next :: !FastMutInt, -- The next index to use
        bin_dict_map  :: !(IORef (UniqFM (Int,FastString)))
                                -- indexed by FastString
  }

getWayDescr :: DynFlags -> String
getWayDescr dflags
  | platformUnregisterised (targetPlatform dflags) = 'u':tag
  | otherwise                                      =     tag
  where tag = buildTag dflags
        -- if this is an unregisterised build, make sure our interfaces
        -- can't be used by a registerised build.


{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-}

{-# LANGUAGE CPP #-}

module BuildTyCl (
        buildDataCon,
        buildPatSyn,
        TcMethInfo, MethInfo, buildClass,
        mkNewTyConRhs,
        newImplicitBinder, newTyConRepName
    ) where

#include "HsVersions.h"

import GhcPrelude

import IfaceEnv
import FamInstEnv( FamInstEnvs, mkNewTypeCoAxiom )
import TysWiredIn( isCTupleTyConName )
import TysPrim ( voidPrimTy )
import DataCon
import PatSyn
import Var
import VarSet
import BasicTypes
import Name
import NameEnv
import MkId
import Class
import TyCon
import Type
import Id
import TcType

import SrcLoc( SrcSpan, noSrcSpan )
import DynFlags
import TcRnMonad
import UniqSupply
import Util
import Outputable

mkNewTyConRhs :: Name -> TyCon -> DataCon -> TcRnIf m n AlgTyConRhs
-- ^ Monadic because it makes a Name for the coercion TyCon
--   We pass the Name of the parent TyCon, as well as the TyCon itself,
--   because the latter is part of a knot, whereas the former is not.
mkNewTyConRhs tycon_name tycon con
  = do  { co_tycon_name <- newImplicitBinder tycon_name mkNewTyCoOcc
        ; let nt_ax = mkNewTypeCoAxiom co_tycon_name tycon etad_tvs etad_roles etad_rhs
        ; traceIf (text "mkNewTyConRhs" <+> ppr nt_ax)
        ; return (NewTyCon { data_con    = con,
                             nt_rhs      = rhs_ty,
                             nt_etad_rhs = (etad_tvs, etad_rhs),
                             nt_co       = nt_ax } ) }
                             -- Coreview looks through newtypes with a Nothing
                             -- for nt_co, or uses explicit coercions otherwise
  where
    tvs    = tyConTyVars tycon
    roles  = tyConRoles tycon
    con_arg_ty = case dataConRepArgTys con of
                   [arg_ty] -> arg_ty
                   tys -> pprPanic "mkNewTyConRhs" (ppr con <+> ppr tys)
    rhs_ty = substTyWith (dataConUnivTyVars con)
                         (mkTyVarTys tvs) con_arg_ty
        -- Instantiate the newtype's RHS with the
        -- type variables from the tycon
        -- NB: a newtype DataCon has a type that must look like
        --        forall tvs.  <arg-ty> -> T tvs
        -- Note that we *can't* use dataConInstOrigArgTys here because
        -- the newtype arising from   class Foo a => Bar a where {}
        -- has a single argument (Foo a) that is a *type class*, so
        -- dataConInstOrigArgTys returns [].

    etad_tvs   :: [TyVar]  -- Matched lazily, so that mkNewTypeCo can
    etad_roles :: [Role]   -- return a TyCon without pulling on rhs_ty
    etad_rhs   :: Type     -- See Note [Tricky iface loop] in LoadIface
    (etad_tvs, etad_roles, etad_rhs) = eta_reduce (reverse tvs) (reverse roles) rhs_ty

    eta_reduce :: [TyVar]       -- Reversed
               -> [Role]        -- also reversed
               -> Type          -- Rhs type
               -> ([TyVar], [Role], Type)  -- Eta-reduced version
                                           -- (tyvars in normal order)
    eta_reduce (a:as) (_:rs) ty | Just (fun, arg) <- splitAppTy_maybe ty,
                                  Just tv <- getTyVar_maybe arg,
                                  tv == a,
                                  not (a `elemVarSet` tyCoVarsOfType fun)
                                = eta_reduce as rs fun
    eta_reduce tvs rs ty = (reverse tvs, reverse rs, ty)

------------------------------------------------------
buildDataCon :: FamInstEnvs
            -> Name
            -> Bool                     -- Declared infix
            -> TyConRepName
            -> [HsSrcBang]
            -> Maybe [HsImplBang]
                -- See Note [Bangs on imported data constructors] in MkId
           -> [FieldLabel]             -- Field labels
           -> [TyVar]                  -- Universals
           -> [TyCoVar]                -- Existentials
           -> [TyVarBinder]            -- User-written 'TyVarBinder's
           -> [EqSpec]                 -- Equality spec
           -> KnotTied ThetaType       -- Does not include the "stupid theta"
                                       -- or the GADT equalities
           -> [KnotTied Type]          -- Arguments
           -> KnotTied Type            -- Result types
           -> KnotTied TyCon           -- Rep tycon
           -> NameEnv ConTag           -- Maps the Name of each DataCon to its
                                       -- ConTag
           -> TcRnIf m n DataCon
-- A wrapper for DataCon.mkDataCon that
--   a) makes the worker Id
--   b) makes the wrapper Id if necessary, including
--      allocating its unique (hence monadic)
buildDataCon fam_envs src_name declared_infix prom_info src_bangs impl_bangs
             field_lbls univ_tvs ex_tvs user_tvbs eq_spec ctxt arg_tys res_ty
             rep_tycon tag_map
  = do  { wrap_name <- newImplicitBinder src_name mkDataConWrapperOcc
        ; work_name <- newImplicitBinder src_name mkDataConWorkerOcc
        -- This last one takes the name of the data constructor in the source
        -- code, which (for Haskell source anyway) will be in the DataName name
        -- space, and puts it into the VarName name space

        ; traceIf (text "buildDataCon 1" <+> ppr src_name)
        ; us <- newUniqueSupply
        ; dflags <- getDynFlags
        ; let stupid_ctxt = mkDataConStupidTheta rep_tycon arg_tys univ_tvs
              tag = lookupNameEnv_NF tag_map src_name
              -- See Note [Constructor tag allocation], fixes #14657
              data_con = mkDataCon src_name declared_infix prom_info
                                   src_bangs field_lbls
                                   univ_tvs ex_tvs user_tvbs eq_spec ctxt
                                   arg_tys res_ty NoRRI rep_tycon tag
                                   stupid_ctxt dc_wrk dc_rep
              dc_wrk = mkDataConWorkId work_name data_con
              dc_rep = initUs_ us (mkDataConRep dflags fam_envs wrap_name
                                                impl_bangs data_con)

        ; traceIf (text "buildDataCon 2" <+> ppr src_name)
        ; return data_con }

-- The stupid context for a data constructor should be limited to
-- the type variables mentioned in the arg_tys
-- ToDo: Or functionally dependent on?
--       This whole stupid theta thing is, well, stupid.
mkDataConStupidTheta :: TyCon -> [Type] -> [TyVar] -> [PredType]
mkDataConStupidTheta tycon arg_tys univ_tvs
  | null stupid_theta = []      -- The common case
  | otherwise         = filter in_arg_tys stupid_theta
  where
    tc_subst     = zipTvSubst (tyConTyVars tycon)
                              (mkTyVarTys univ_tvs)
    stupid_theta = substTheta tc_subst (tyConStupidTheta tycon)
        -- Start by instantiating the master copy of the
        -- stupid theta, taken from the TyCon

    arg_tyvars      = tyCoVarsOfTypes arg_tys
    in_arg_tys pred = not $ isEmptyVarSet $
                      tyCoVarsOfType pred `intersectVarSet` arg_tyvars

------------------------------------------------------
buildPatSyn :: Name -> Bool
            -> (Id,Bool) -> Maybe (Id, Bool)
            -> ([TyVarBinder], ThetaType) -- ^ Univ and req
            -> ([TyVarBinder], ThetaType) -- ^ Ex and prov
            -> [Type]               -- ^ Argument types
            -> Type                 -- ^ Result type
            -> [FieldLabel]         -- ^ Field labels for
                                    --   a record pattern synonym
            -> PatSyn
buildPatSyn src_name declared_infix matcher@(matcher_id,_) builder
            (univ_tvs, req_theta) (ex_tvs, prov_theta) arg_tys
            pat_ty field_labels
  = -- The assertion checks that the matcher is
    -- compatible with the pattern synonym
    ASSERT2((and [ univ_tvs `equalLength` univ_tvs1
                 , ex_tvs `equalLength` ex_tvs1
                 , pat_ty `eqType` substTy subst pat_ty1
                 , prov_theta `eqTypes` substTys subst prov_theta1
                 , req_theta `eqTypes` substTys subst req_theta1
                 , compareArgTys arg_tys (substTys subst arg_tys1)
                 ])
            , (vcat [ ppr univ_tvs <+> twiddle <+> ppr univ_tvs1
                    , ppr ex_tvs <+> twiddle <+> ppr ex_tvs1
                    , ppr pat_ty <+> twiddle <+> ppr pat_ty1
                    , ppr prov_theta <+> twiddle <+> ppr prov_theta1
                    , ppr req_theta <+> twiddle <+> ppr req_theta1
                    , ppr arg_tys <+> twiddle <+> ppr arg_tys1]))
    mkPatSyn src_name declared_infix
             (univ_tvs, req_theta) (ex_tvs, prov_theta)
             arg_tys pat_ty
             matcher builder field_labels
  where
    ((_:_:univ_tvs1), req_theta1, tau) = tcSplitSigmaTy $ idType matcher_id
    ([pat_ty1, cont_sigma, _], _)      = tcSplitFunTys tau
    (ex_tvs1, prov_theta1, cont_tau)   = tcSplitSigmaTy cont_sigma
    (arg_tys1, _) = (tcSplitFunTys cont_tau)
    twiddle = char '~'
    subst = zipTvSubst (univ_tvs1 ++ ex_tvs1)
                       (mkTyVarTys (binderVars (univ_tvs ++ ex_tvs)))

    -- For a nullary pattern synonym we add a single void argument to the
    -- matcher to preserve laziness in the case of unlifted types.
    -- See #12746
    compareArgTys :: [Type] -> [Type] -> Bool
    compareArgTys [] [x] = x `eqType` voidPrimTy
    compareArgTys arg_tys matcher_arg_tys = arg_tys `eqTypes` matcher_arg_tys

------------------------------------------------------
type TcMethInfo = MethInfo  -- this variant needs zonking
type MethInfo       -- A temporary intermediate, to communicate
                    -- between tcClassSigs and buildClass.
  = ( Name   -- Name of the class op
    , Type   -- Type of the class op
    , Maybe (DefMethSpec (SrcSpan, Type)))
         -- Nothing                    => no default method
         --
         -- Just VanillaDM             => There is an ordinary
         --                               polymorphic default method
         --
         -- Just (GenericDM (loc, ty)) => There is a generic default metho
         --                               Here is its type, and the location
         --                               of the type signature
         --    We need that location /only/ to attach it to the
         --    generic default method's Name; and we need /that/
         --    only to give the right location of an ambiguity error
         --    for the generic default method, spat out by checkValidClass

buildClass :: Name  -- Name of the class/tycon (they have the same Name)
           -> [TyConBinder]                -- Of the tycon
           -> [Role]
           -> [FunDep TyVar]               -- Functional dependencies
           -- Super classes, associated types, method info, minimal complete def.
           -- This is Nothing if the class is abstract.
           -> Maybe (KnotTied ThetaType, [ClassATItem], [KnotTied MethInfo], ClassMinimalDef)
           -> TcRnIf m n Class

buildClass tycon_name binders roles fds Nothing
  = fixM  $ \ rec_clas ->       -- Only name generation inside loop
    do  { traceIf (text "buildClass")

        ; tc_rep_name  <- newTyConRepName tycon_name
        ; let univ_tvs = binderVars binders
              tycon = mkClassTyCon tycon_name binders roles
                                   AbstractTyCon rec_clas tc_rep_name
              result = mkAbstractClass tycon_name univ_tvs fds tycon
        ; traceIf (text "buildClass" <+> ppr tycon)
        ; return result }

buildClass tycon_name binders roles fds
           (Just (sc_theta, at_items, sig_stuff, mindef))
  = fixM  $ \ rec_clas ->       -- Only name generation inside loop
    do  { traceIf (text "buildClass")

        ; datacon_name <- newImplicitBinder tycon_name mkClassDataConOcc
        ; tc_rep_name  <- newTyConRepName tycon_name

        ; op_items <- mapM (mk_op_item rec_clas) sig_stuff
                        -- Build the selector id and default method id

              -- Make selectors for the superclasses
        ; sc_sel_names <- mapM  (newImplicitBinder tycon_name . mkSuperDictSelOcc)
                                (takeList sc_theta [fIRST_TAG..])
        ; let sc_sel_ids = [ mkDictSelId sc_name rec_clas
                           | sc_name <- sc_sel_names]
              -- We number off the Dict superclass selectors, 1, 2, 3 etc so that we
              -- can construct names for the selectors. Thus
              --      class (C a, C b) => D a b where ...
              -- gives superclass selectors
              --      D_sc1, D_sc2
              -- (We used to call them D_C, but now we can have two different
              --  superclasses both called C!)

        ; let use_newtype = isSingleton arg_tys
                -- Use a newtype if the data constructor
                --   (a) has exactly one value field
                --       i.e. exactly one operation or superclass taken together
                --   (b) that value is of lifted type (which they always are, because
                --       we box equality superclasses)
                -- See note [Class newtypes and equality predicates]

                -- We treat the dictionary superclasses as ordinary arguments.
                -- That means that in the case of
                --     class C a => D a
                -- we don't get a newtype with no arguments!
              args       = sc_sel_names ++ op_names
              op_tys     = [ty | (_,ty,_) <- sig_stuff]
              op_names   = [op | (op,_,_) <- sig_stuff]
              arg_tys    = sc_theta ++ op_tys
              rec_tycon  = classTyCon rec_clas
              univ_bndrs = tyConTyVarBinders binders
              univ_tvs   = binderVars univ_bndrs

        ; rep_nm   <- newTyConRepName datacon_name
        ; dict_con <- buildDataCon (panic "buildClass: FamInstEnvs")
                                   datacon_name
                                   False        -- Not declared infix
                                   rep_nm
                                   (map (const no_bang) args)
                                   (Just (map (const HsLazy) args))
                                   [{- No fields -}]
                                   univ_tvs
                                   [{- no existentials -}]
                                   univ_bndrs
                                   [{- No GADT equalities -}]
                                   [{- No theta -}]
                                   arg_tys
                                   (mkTyConApp rec_tycon (mkTyVarTys univ_tvs))
                                   rec_tycon
                                   (mkTyConTagMap rec_tycon)

        ; rhs <- case () of
                  _ | use_newtype
                    -> mkNewTyConRhs tycon_name rec_tycon dict_con
                    | isCTupleTyConName tycon_name
                    -> return (TupleTyCon { data_con = dict_con
                                          , tup_sort = ConstraintTuple })
                    | otherwise
                    -> return (mkDataTyConRhs [dict_con])

        ; let { tycon = mkClassTyCon tycon_name binders roles
                                     rhs rec_clas tc_rep_name
                -- A class can be recursive, and in the case of newtypes
                -- this matters.  For example
                --      class C a where { op :: C b => a -> b -> Int }
                -- Because C has only one operation, it is represented by
                -- a newtype, and it should be a *recursive* newtype.
                -- [If we don't make it a recursive newtype, we'll expand the
                -- newtype like a synonym, but that will lead to an infinite
                -- type]

              ; result = mkClass tycon_name univ_tvs fds
                                 sc_theta sc_sel_ids at_items
                                 op_items mindef tycon
              }
        ; traceIf (text "buildClass" <+> ppr tycon)
        ; return result }
  where
    no_bang = HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict

    mk_op_item :: Class -> TcMethInfo -> TcRnIf n m ClassOpItem
    mk_op_item rec_clas (op_name, _, dm_spec)
      = do { dm_info <- mk_dm_info op_name dm_spec
           ; return (mkDictSelId op_name rec_clas, dm_info) }

    mk_dm_info :: Name -> Maybe (DefMethSpec (SrcSpan, Type))
               -> TcRnIf n m (Maybe (Name, DefMethSpec Type))
    mk_dm_info _ Nothing
      = return Nothing
    mk_dm_info op_name (Just VanillaDM)
      = do { dm_name <- newImplicitBinder op_name mkDefaultMethodOcc
           ; return (Just (dm_name, VanillaDM)) }
    mk_dm_info op_name (Just (GenericDM (loc, dm_ty)))
      = do { dm_name <- newImplicitBinderLoc op_name mkDefaultMethodOcc loc
           ; return (Just (dm_name, GenericDM dm_ty)) }

{-
Note [Class newtypes and equality predicates]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
        class (a ~ F b) => C a b where
          op :: a -> b

We cannot represent this by a newtype, even though it's not
existential, because there are two value fields (the equality
predicate and op. See Trac #2238

Moreover,
          class (a ~ F b) => C a b where {}
Here we can't use a newtype either, even though there is only
one field, because equality predicates are unboxed, and classes
are boxed.
-}

newImplicitBinder :: Name                       -- Base name
                  -> (OccName -> OccName)       -- Occurrence name modifier
                  -> TcRnIf m n Name            -- Implicit name
-- Called in BuildTyCl to allocate the implicit binders of type/class decls
-- For source type/class decls, this is the first occurrence
-- For iface ones, the LoadIface has already allocated a suitable name in the cache
newImplicitBinder base_name mk_sys_occ
  = newImplicitBinderLoc base_name mk_sys_occ (nameSrcSpan base_name)

newImplicitBinderLoc :: Name                       -- Base name
                     -> (OccName -> OccName)       -- Occurrence name modifier
                     -> SrcSpan
                     -> TcRnIf m n Name            -- Implicit name
-- Just the same, but lets you specify the SrcSpan
newImplicitBinderLoc base_name mk_sys_occ loc
  | Just mod <- nameModule_maybe base_name
  = newGlobalBinder mod occ loc
  | otherwise           -- When typechecking a [d| decl bracket |],
                        -- TH generates types, classes etc with Internal names,
                        -- so we follow suit for the implicit binders
  = do  { uniq <- newUnique
        ; return (mkInternalName uniq occ loc) }
  where
    occ = mk_sys_occ (nameOccName base_name)

-- | Make the 'TyConRepName' for this 'TyCon'
newTyConRepName :: Name -> TcRnIf gbl lcl TyConRepName
newTyConRepName tc_name
  | Just mod <- nameModule_maybe tc_name
  , (mod, occ) <- tyConRepModOcc mod (nameOccName tc_name)
  = newGlobalBinder mod occ noSrcSpan
  | otherwise
  = newImplicitBinder tc_name mkTyConRepOcc