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

The @Inst@ type: dictionaries or method instances
-}

{-# LANGUAGE CPP, MultiWayIf, TupleSections #-}
{-# LANGUAGE FlexibleContexts #-}

module Inst (
       deeplySkolemise,
       topInstantiate, topInstantiateInferred, deeplyInstantiate,
       instCall, instDFunType, instStupidTheta, instTyVarsWith,
       newWanted, newWanteds,

       tcInstInvisibleTyBinders, tcInstInvisibleTyBinder,

       newOverloadedLit, mkOverLit,

       newClsInst,
       tcGetInsts, tcGetInstEnvs, getOverlapFlag,
       tcExtendLocalInstEnv,
       instCallConstraints, newMethodFromName,
       tcSyntaxName,

       -- Simple functions over evidence variables
       tyCoVarsOfWC,
       tyCoVarsOfCt, tyCoVarsOfCts,
    ) where

#include "HsVersions.h"

import GhcPrelude

import {-# SOURCE #-}   TcExpr( tcPolyExpr, tcSyntaxOp )
import {-# SOURCE #-}   TcUnify( unifyType, unifyKind )

import BasicTypes ( IntegralLit(..), SourceText(..) )
import FastString
import HsSyn
import TcHsSyn
import TcRnMonad
import TcEnv
import TcEvidence
import InstEnv
import TysWiredIn  ( heqDataCon, eqDataCon )
import CoreSyn     ( isOrphan )
import FunDeps
import TcMType
import Type
import TyCoRep
import TcType
import HscTypes
import Class( Class )
import MkId( mkDictFunId )
import CoreSyn( Expr(..) )  -- For the Coercion constructor
import Id
import Name
import Var      ( EvVar, tyVarName, VarBndr(..) )
import DataCon
import VarEnv
import PrelNames
import SrcLoc
import DynFlags
import Util
import Outputable
import qualified GHC.LanguageExtensions as LangExt

import Control.Monad( unless )

{-
************************************************************************
*                                                                      *
                Creating and emittind constraints
*                                                                      *
************************************************************************
-}

newMethodFromName :: CtOrigin -> Name -> TcRhoType -> TcM (HsExpr GhcTcId)
-- Used when Name is the wired-in name for a wired-in class method,
-- so the caller knows its type for sure, which should be of form
--    forall a. C a => <blah>
-- newMethodFromName is supposed to instantiate just the outer
-- type variable and constraint

newMethodFromName origin name inst_ty
  = do { id <- tcLookupId name
              -- Use tcLookupId not tcLookupGlobalId; the method is almost
              -- always a class op, but with -XRebindableSyntax GHC is
              -- meant to find whatever thing is in scope, and that may
              -- be an ordinary function.

       ; let ty = piResultTy (idType id) inst_ty
             (theta, _caller_knows_this) = tcSplitPhiTy ty
       ; wrap <- ASSERT( not (isForAllTy ty) && isSingleton theta )
                 instCall origin [inst_ty] theta

       ; return (mkHsWrap wrap (HsVar noExt (noLoc id))) }

{-
************************************************************************
*                                                                      *
        Deep instantiation and skolemisation
*                                                                      *
************************************************************************

Note [Deep skolemisation]
~~~~~~~~~~~~~~~~~~~~~~~~~
deeplySkolemise decomposes and skolemises a type, returning a type
with all its arrows visible (ie not buried under foralls)

Examples:

  deeplySkolemise (Int -> forall a. Ord a => blah)
    =  ( wp, [a], [d:Ord a], Int -> blah )
    where wp = \x:Int. /\a. \(d:Ord a). <hole> x

  deeplySkolemise  (forall a. Ord a => Maybe a -> forall b. Eq b => blah)
    =  ( wp, [a,b], [d1:Ord a,d2:Eq b], Maybe a -> blah )
    where wp = /\a.\(d1:Ord a).\(x:Maybe a)./\b.\(d2:Ord b). <hole> x

In general,
  if      deeplySkolemise ty = (wrap, tvs, evs, rho)
    and   e :: rho
  then    wrap e :: ty
    and   'wrap' binds tvs, evs

ToDo: this eta-abstraction plays fast and loose with termination,
      because it can introduce extra lambdas.  Maybe add a `seq` to
      fix this
-}

deeplySkolemise :: TcSigmaType
                -> TcM ( HsWrapper
                       , [(Name,TyVar)]     -- All skolemised variables
                       , [EvVar]            -- All "given"s
                       , TcRhoType )

deeplySkolemise ty
  = go init_subst ty
  where
    init_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ty))

    go subst ty
      | Just (arg_tys, tvs, theta, ty') <- tcDeepSplitSigmaTy_maybe ty
      = do { let arg_tys' = substTys subst arg_tys
           ; ids1           <- newSysLocalIds (fsLit "dk") arg_tys'
           ; (subst', tvs1) <- tcInstSkolTyVarsX subst tvs
           ; ev_vars1       <- newEvVars (substTheta subst' theta)
           ; (wrap, tvs_prs2, ev_vars2, rho) <- go subst' ty'
           ; let tv_prs1 = map tyVarName tvs `zip` tvs1
           ; return ( mkWpLams ids1
                      <.> mkWpTyLams tvs1
                      <.> mkWpLams ev_vars1
                      <.> wrap
                      <.> mkWpEvVarApps ids1
                    , tv_prs1  ++ tvs_prs2
                    , ev_vars1 ++ ev_vars2
                    , mkVisFunTys arg_tys' rho ) }

      | otherwise
      = return (idHsWrapper, [], [], substTy subst ty)
        -- substTy is a quick no-op on an empty substitution

-- | Instantiate all outer type variables
-- and any context. Never looks through arrows.
topInstantiate :: CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType)
-- if    topInstantiate ty = (wrap, rho)
-- and   e :: ty
-- then  wrap e :: rho  (that is, wrap :: ty "->" rho)
topInstantiate = top_instantiate True

-- | Instantiate all outer 'Inferred' binders
-- and any context. Never looks through arrows or specified type variables.
-- Used for visible type application.
topInstantiateInferred :: CtOrigin -> TcSigmaType
                       -> TcM (HsWrapper, TcSigmaType)
-- if    topInstantiate ty = (wrap, rho)
-- and   e :: ty
-- then  wrap e :: rho
topInstantiateInferred = top_instantiate False

top_instantiate :: Bool   -- True  <=> instantiate *all* variables
                          -- False <=> instantiate only the inferred ones
                -> CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType)
top_instantiate inst_all orig ty
  | not (null binders && null theta)
  = do { let (inst_bndrs, leave_bndrs) = span should_inst binders
             (inst_theta, leave_theta)
               | null leave_bndrs = (theta, [])
               | otherwise        = ([], theta)
             in_scope    = mkInScopeSet (tyCoVarsOfType ty)
             empty_subst = mkEmptyTCvSubst in_scope
             inst_tvs    = binderVars inst_bndrs
       ; (subst, inst_tvs') <- mapAccumLM newMetaTyVarX empty_subst inst_tvs
       ; let inst_theta' = substTheta subst inst_theta
             sigma'      = substTy subst (mkForAllTys leave_bndrs $
                                          mkPhiTy leave_theta rho)
             inst_tv_tys' = mkTyVarTys inst_tvs'

       ; wrap1 <- instCall orig inst_tv_tys' inst_theta'
       ; traceTc "Instantiating"
                 (vcat [ text "all tyvars?" <+> ppr inst_all
                       , text "origin" <+> pprCtOrigin orig
                       , text "type" <+> debugPprType ty
                       , text "theta" <+> ppr theta
                       , text "leave_bndrs" <+> ppr leave_bndrs
                       , text "with" <+> vcat (map debugPprType inst_tv_tys')
                       , text "theta:" <+>  ppr inst_theta' ])

       ; (wrap2, rho2) <-
           if null leave_bndrs

         -- account for types like forall a. Num a => forall b. Ord b => ...
           then top_instantiate inst_all orig sigma'

         -- but don't loop if there were any un-inst'able tyvars
           else return (idHsWrapper, sigma')

       ; return (wrap2 <.> wrap1, rho2) }

  | otherwise = return (idHsWrapper, ty)
  where
    (binders, phi) = tcSplitForAllVarBndrs ty
    (theta, rho)   = tcSplitPhiTy phi

    should_inst bndr
      | inst_all  = True
      | otherwise = binderArgFlag bndr == Inferred

deeplyInstantiate :: CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType)
--   Int -> forall a. a -> a  ==>  (\x:Int. [] x alpha) :: Int -> alpha
-- In general if
-- if    deeplyInstantiate ty = (wrap, rho)
-- and   e :: ty
-- then  wrap e :: rho
-- That is, wrap :: ty ~> rho
--
-- If you don't need the HsWrapper returned from this function, consider
-- using tcSplitNestedSigmaTys in TcType, which is a pure alternative that
-- only computes the returned TcRhoType.

deeplyInstantiate orig ty =
  deeply_instantiate orig
                     (mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ty)))
                     ty

deeply_instantiate :: CtOrigin
                   -> TCvSubst
                   -> TcSigmaType -> TcM (HsWrapper, TcRhoType)
-- Internal function to deeply instantiate that builds on an existing subst.
-- It extends the input substitution and applies the final subtitution to
-- the types on return.  See #12549.

deeply_instantiate orig subst ty
  | Just (arg_tys, tvs, theta, rho) <- tcDeepSplitSigmaTy_maybe ty
  = do { (subst', tvs') <- newMetaTyVarsX subst tvs
       ; let arg_tys' = substTys   subst' arg_tys
             theta'   = substTheta subst' theta
       ; ids1  <- newSysLocalIds (fsLit "di") arg_tys'
       ; wrap1 <- instCall orig (mkTyVarTys tvs') theta'
       ; traceTc "Instantiating (deeply)" (vcat [ text "origin" <+> pprCtOrigin orig
                                                , text "type" <+> ppr ty
                                                , text "with" <+> ppr tvs'
                                                , text "args:" <+> ppr ids1
                                                , text "theta:" <+>  ppr theta'
                                                , text "subst:" <+> ppr subst'])
       ; (wrap2, rho2) <- deeply_instantiate orig subst' rho
       ; return (mkWpLams ids1
                    <.> wrap2
                    <.> wrap1
                    <.> mkWpEvVarApps ids1,
                 mkVisFunTys arg_tys' rho2) }

  | otherwise
  = do { let ty' = substTy subst ty
       ; traceTc "deeply_instantiate final subst"
                 (vcat [ text "origin:"   <+> pprCtOrigin orig
                       , text "type:"     <+> ppr ty
                       , text "new type:" <+> ppr ty'
                       , text "subst:"    <+> ppr subst ])
      ; return (idHsWrapper, ty') }

instTyVarsWith :: CtOrigin -> [TyVar] -> [TcType] -> TcM TCvSubst
-- Use this when you want to instantiate (forall a b c. ty) with
-- types [ta, tb, tc], but when the kinds of 'a' and 'ta' might
-- not yet match (perhaps because there are unsolved constraints; Trac #14154)
-- If they don't match, emit a kind-equality to promise that they will
-- eventually do so, and thus make a kind-homongeneous substitution.
instTyVarsWith orig tvs tys
  = go empty_subst tvs tys
  where
    empty_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfTypes tys))

    go subst [] []
      = return subst
    go subst (tv:tvs) (ty:tys)
      | tv_kind `tcEqType` ty_kind
      = go (extendTCvSubst subst tv ty) tvs tys
      | otherwise
      = do { co <- emitWantedEq orig KindLevel Nominal ty_kind tv_kind
           ; go (extendTCvSubst subst tv (ty `mkCastTy` co)) tvs tys }
      where
        tv_kind = substTy subst (tyVarKind tv)
        ty_kind = tcTypeKind ty

    go _ _ _ = pprPanic "instTysWith" (ppr tvs $$ ppr tys)

{-
************************************************************************
*                                                                      *
            Instantiating a call
*                                                                      *
************************************************************************

Note [Handling boxed equality]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The solver deals entirely in terms of unboxed (primitive) equality.
There should never be a boxed Wanted equality. Ever. But, what if
we are calling `foo :: forall a. (F a ~ Bool) => ...`? That equality
is boxed, so naive treatment here would emit a boxed Wanted equality.

So we simply check for this case and make the right boxing of evidence.

-}

----------------
instCall :: CtOrigin -> [TcType] -> TcThetaType -> TcM HsWrapper
-- Instantiate the constraints of a call
--      (instCall o tys theta)
-- (a) Makes fresh dictionaries as necessary for the constraints (theta)
-- (b) Throws these dictionaries into the LIE
-- (c) Returns an HsWrapper ([.] tys dicts)

instCall orig tys theta
  = do  { dict_app <- instCallConstraints orig theta
        ; return (dict_app <.> mkWpTyApps tys) }

----------------
instCallConstraints :: CtOrigin -> TcThetaType -> TcM HsWrapper
-- Instantiates the TcTheta, puts all constraints thereby generated
-- into the LIE, and returns a HsWrapper to enclose the call site.

instCallConstraints orig preds
  | null preds
  = return idHsWrapper
  | otherwise
  = do { evs <- mapM go preds
       ; traceTc "instCallConstraints" (ppr evs)
       ; return (mkWpEvApps evs) }
  where
    go :: TcPredType -> TcM EvTerm
    go pred
     | Just (Nominal, ty1, ty2) <- getEqPredTys_maybe pred -- Try short-cut #1
     = do  { co <- unifyType Nothing ty1 ty2
           ; return (evCoercion co) }

       -- Try short-cut #2
     | Just (tc, args@[_, _, ty1, ty2]) <- splitTyConApp_maybe pred
     , tc `hasKey` heqTyConKey
     = do { co <- unifyType Nothing ty1 ty2
          ; return (evDFunApp (dataConWrapId heqDataCon) args [Coercion co]) }

     | otherwise
     = emitWanted orig pred

instDFunType :: DFunId -> [DFunInstType]
             -> TcM ( [TcType]      -- instantiated argument types
                    , TcThetaType ) -- instantiated constraint
-- See Note [DFunInstType: instantiating types] in InstEnv
instDFunType dfun_id dfun_inst_tys
  = do { (subst, inst_tys) <- go empty_subst dfun_tvs dfun_inst_tys
       ; return (inst_tys, substTheta subst dfun_theta) }
  where
    dfun_ty = idType dfun_id
    (dfun_tvs, dfun_theta, _) = tcSplitSigmaTy dfun_ty
    empty_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType dfun_ty))
                  -- With quantified constraints, the
                  -- type of a dfun may not be closed

    go :: TCvSubst -> [TyVar] -> [DFunInstType] -> TcM (TCvSubst, [TcType])
    go subst [] [] = return (subst, [])
    go subst (tv:tvs) (Just ty : mb_tys)
      = do { (subst', tys) <- go (extendTvSubstAndInScope subst tv ty)
                                 tvs
                                 mb_tys
           ; return (subst', ty : tys) }
    go subst (tv:tvs) (Nothing : mb_tys)
      = do { (subst', tv') <- newMetaTyVarX subst tv
           ; (subst'', tys) <- go subst' tvs mb_tys
           ; return (subst'', mkTyVarTy tv' : tys) }
    go _ _ _ = pprPanic "instDFunTypes" (ppr dfun_id $$ ppr dfun_inst_tys)

----------------
instStupidTheta :: CtOrigin -> TcThetaType -> TcM ()
-- Similar to instCall, but only emit the constraints in the LIE
-- Used exclusively for the 'stupid theta' of a data constructor
instStupidTheta orig theta
  = do  { _co <- instCallConstraints orig theta -- Discard the coercion
        ; return () }

{- *********************************************************************
*                                                                      *
         Instantiating Kinds
*                                                                      *
********************************************************************* -}

-- | Instantiates up to n invisible binders
-- Returns the instantiating types, and body kind
tcInstInvisibleTyBinders :: Int -> TcKind -> TcM ([TcType], TcKind)

tcInstInvisibleTyBinders 0 kind
  = return ([], kind)
tcInstInvisibleTyBinders n ty
  = go n empty_subst ty
  where
    empty_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ty))

    go n subst kind
      | n > 0
      , Just (bndr, body) <- tcSplitPiTy_maybe kind
      , isInvisibleBinder bndr
      = do { (subst', arg) <- tcInstInvisibleTyBinder subst bndr
           ; (args, inner_ty) <- go (n-1) subst' body
           ; return (arg:args, inner_ty) }
      | otherwise
      = return ([], substTy subst kind)

-- | Used only in *types*
tcInstInvisibleTyBinder :: TCvSubst -> TyBinder -> TcM (TCvSubst, TcType)
tcInstInvisibleTyBinder subst (Named (Bndr tv _))
  = do { (subst', tv') <- newMetaTyVarX subst tv
       ; return (subst', mkTyVarTy tv') }

tcInstInvisibleTyBinder subst (Anon af ty)
  | Just (mk, k1, k2) <- get_eq_tys_maybe (substTy subst ty)
    -- Equality is the *only* constraint currently handled in types.
    -- See Note [Constraints in kinds] in TyCoRep
  = ASSERT( af == InvisArg )
    do { co <- unifyKind Nothing k1 k2
       ; arg' <- mk co
       ; return (subst, arg') }

  | otherwise  -- This should never happen
               -- See TyCoRep Note [Constraints in kinds]
  = pprPanic "tcInvisibleTyBinder" (ppr ty)

-------------------------------
get_eq_tys_maybe :: Type
                 -> Maybe ( Coercion -> TcM Type
                             -- given a coercion proving t1 ~# t2, produce the
                             -- right instantiation for the TyBinder at hand
                          , Type  -- t1
                          , Type  -- t2
                          )
-- See Note [Constraints in kinds] in TyCoRep
get_eq_tys_maybe ty
  -- Lifted heterogeneous equality (~~)
  | Just (tc, [_, _, k1, k2]) <- splitTyConApp_maybe ty
  , tc `hasKey` heqTyConKey
  = Just (\co -> mkHEqBoxTy co k1 k2, k1, k2)

  -- Lifted homogeneous equality (~)
  | Just (tc, [_, k1, k2]) <- splitTyConApp_maybe ty
  , tc `hasKey` eqTyConKey
  = Just (\co -> mkEqBoxTy co k1 k2, k1, k2)

  | otherwise
  = Nothing

-- | This takes @a ~# b@ and returns @a ~~ b@.
mkHEqBoxTy :: TcCoercion -> Type -> Type -> TcM Type
-- monadic just for convenience with mkEqBoxTy
mkHEqBoxTy co ty1 ty2
  = return $
    mkTyConApp (promoteDataCon heqDataCon) [k1, k2, ty1, ty2, mkCoercionTy co]
  where k1 = tcTypeKind ty1
        k2 = tcTypeKind ty2

-- | This takes @a ~# b@ and returns @a ~ b@.
mkEqBoxTy :: TcCoercion -> Type -> Type -> TcM Type
mkEqBoxTy co ty1 ty2
  = return $
    mkTyConApp (promoteDataCon eqDataCon) [k, ty1, ty2, mkCoercionTy co]
  where k = tcTypeKind ty1

{-
************************************************************************
*                                                                      *
                Literals
*                                                                      *
************************************************************************

-}

{-
In newOverloadedLit we convert directly to an Int or Integer if we
know that's what we want.  This may save some time, by not
temporarily generating overloaded literals, but it won't catch all
cases (the rest are caught in lookupInst).

-}

newOverloadedLit :: HsOverLit GhcRn
                 -> ExpRhoType
                 -> TcM (HsOverLit GhcTcId)
newOverloadedLit
  lit@(OverLit { ol_val = val, ol_ext = rebindable }) res_ty
  | not rebindable
    -- all built-in overloaded lits are tau-types, so we can just
    -- tauify the ExpType
  = do { res_ty <- expTypeToType res_ty
       ; dflags <- getDynFlags
       ; case shortCutLit dflags val res_ty of
        -- Do not generate a LitInst for rebindable syntax.
        -- Reason: If we do, tcSimplify will call lookupInst, which
        --         will call tcSyntaxName, which does unification,
        --         which tcSimplify doesn't like
           Just expr -> return (lit { ol_witness = expr
                                    , ol_ext = OverLitTc False res_ty })
           Nothing   -> newNonTrivialOverloadedLit orig lit
                                                   (mkCheckExpType res_ty) }

  | otherwise
  = newNonTrivialOverloadedLit orig lit res_ty
  where
    orig = LiteralOrigin lit
newOverloadedLit XOverLit{} _ = panic "newOverloadedLit"

-- Does not handle things that 'shortCutLit' can handle. See also
-- newOverloadedLit in TcUnify
newNonTrivialOverloadedLit :: CtOrigin
                           -> HsOverLit GhcRn
                           -> ExpRhoType
                           -> TcM (HsOverLit GhcTcId)
newNonTrivialOverloadedLit orig
  lit@(OverLit { ol_val = val, ol_witness = HsVar _ (L _ meth_name)
               , ol_ext = rebindable }) res_ty
  = do  { hs_lit <- mkOverLit val
        ; let lit_ty = hsLitType hs_lit
        ; (_, fi') <- tcSyntaxOp orig (mkRnSyntaxExpr meth_name)
                                      [synKnownType lit_ty] res_ty $
                      \_ -> return ()
        ; let L _ witness = nlHsSyntaxApps fi' [nlHsLit hs_lit]
        ; res_ty <- readExpType res_ty
        ; return (lit { ol_witness = witness
                      , ol_ext = OverLitTc rebindable res_ty }) }
newNonTrivialOverloadedLit _ lit _
  = pprPanic "newNonTrivialOverloadedLit" (ppr lit)

------------
mkOverLit ::OverLitVal -> TcM (HsLit GhcTc)
mkOverLit (HsIntegral i)
  = do  { integer_ty <- tcMetaTy integerTyConName
        ; return (HsInteger (il_text i)
                            (il_value i) integer_ty) }

mkOverLit (HsFractional r)
  = do  { rat_ty <- tcMetaTy rationalTyConName
        ; return (HsRat noExt r rat_ty) }

mkOverLit (HsIsString src s) = return (HsString src s)

{-
************************************************************************
*                                                                      *
                Re-mappable syntax

     Used only for arrow syntax -- find a way to nuke this
*                                                                      *
************************************************************************

Suppose we are doing the -XRebindableSyntax thing, and we encounter
a do-expression.  We have to find (>>) in the current environment, which is
done by the rename. Then we have to check that it has the same type as
Control.Monad.(>>).  Or, more precisely, a compatible type. One 'customer' had
this:

  (>>) :: HB m n mn => m a -> n b -> mn b

So the idea is to generate a local binding for (>>), thus:

        let then72 :: forall a b. m a -> m b -> m b
            then72 = ...something involving the user's (>>)...
        in
        ...the do-expression...

Now the do-expression can proceed using then72, which has exactly
the expected type.

In fact tcSyntaxName just generates the RHS for then72, because we only
want an actual binding in the do-expression case. For literals, we can
just use the expression inline.
-}

tcSyntaxName :: CtOrigin
             -> TcType                 -- ^ Type to instantiate it at
             -> (Name, HsExpr GhcRn)   -- ^ (Standard name, user name)
             -> TcM (Name, HsExpr GhcTcId)
                                       -- ^ (Standard name, suitable expression)
-- USED ONLY FOR CmdTop (sigh) ***
-- See Note [CmdSyntaxTable] in HsExpr

tcSyntaxName orig ty (std_nm, HsVar _ (L _ user_nm))
  | std_nm == user_nm
  = do rhs <- newMethodFromName orig std_nm ty
       return (std_nm, rhs)

tcSyntaxName orig ty (std_nm, user_nm_expr) = do
    std_id <- tcLookupId std_nm
    let
        -- C.f. newMethodAtLoc
        ([tv], _, tau) = tcSplitSigmaTy (idType std_id)
        sigma1         = substTyWith [tv] [ty] tau
        -- Actually, the "tau-type" might be a sigma-type in the
        -- case of locally-polymorphic methods.

    addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $ do

        -- Check that the user-supplied thing has the
        -- same type as the standard one.
        -- Tiresome jiggling because tcCheckSigma takes a located expression
     span <- getSrcSpanM
     expr <- tcPolyExpr (L span user_nm_expr) sigma1
     return (std_nm, unLoc expr)

syntaxNameCtxt :: HsExpr GhcRn -> CtOrigin -> Type -> TidyEnv
               -> TcRn (TidyEnv, SDoc)
syntaxNameCtxt name orig ty tidy_env
  = do { inst_loc <- getCtLocM orig (Just TypeLevel)
       ; let msg = vcat [ text "When checking that" <+> quotes (ppr name)
                          <+> text "(needed by a syntactic construct)"
                        , nest 2 (text "has the required type:"
                                  <+> ppr (tidyType tidy_env ty))
                        , nest 2 (pprCtLoc inst_loc) ]
       ; return (tidy_env, msg) }

{-
************************************************************************
*                                                                      *
                Instances
*                                                                      *
************************************************************************
-}

getOverlapFlag :: Maybe OverlapMode -> TcM OverlapFlag
-- Construct the OverlapFlag from the global module flags,
-- but if the overlap_mode argument is (Just m),
--     set the OverlapMode to 'm'
getOverlapFlag overlap_mode
  = do  { dflags <- getDynFlags
        ; let overlap_ok    = xopt LangExt.OverlappingInstances dflags
              incoherent_ok = xopt LangExt.IncoherentInstances  dflags
              use x = OverlapFlag { isSafeOverlap = safeLanguageOn dflags
                                  , overlapMode   = x }
              default_oflag | incoherent_ok = use (Incoherent NoSourceText)
                            | overlap_ok    = use (Overlaps NoSourceText)
                            | otherwise     = use (NoOverlap NoSourceText)

              final_oflag = setOverlapModeMaybe default_oflag overlap_mode
        ; return final_oflag }

tcGetInsts :: TcM [ClsInst]
-- Gets the local class instances.
tcGetInsts = fmap tcg_insts getGblEnv

newClsInst :: Maybe OverlapMode -> Name -> [TyVar] -> ThetaType
           -> Class -> [Type] -> TcM ClsInst
newClsInst overlap_mode dfun_name tvs theta clas tys
  = do { (subst, tvs') <- freshenTyVarBndrs tvs
             -- Be sure to freshen those type variables,
             -- so they are sure not to appear in any lookup
       ; let tys' = substTys subst tys

             dfun = mkDictFunId dfun_name tvs theta clas tys
             -- The dfun uses the original 'tvs' because
             -- (a) they don't need to be fresh
             -- (b) they may be mentioned in the ib_binds field of
             --     an InstInfo, and in TcEnv.pprInstInfoDetails it's
             --     helpful to use the same names

       ; oflag <- getOverlapFlag overlap_mode
       ; let inst = mkLocalInstance dfun oflag tvs' clas tys'
       ; warnIfFlag Opt_WarnOrphans
                    (isOrphan (is_orphan inst))
                    (instOrphWarn inst)
       ; return inst }

instOrphWarn :: ClsInst -> SDoc
instOrphWarn inst
  = hang (text "Orphan instance:") 2 (pprInstanceHdr inst)
    $$ text "To avoid this"
    $$ nest 4 (vcat possibilities)
  where
    possibilities =
      text "move the instance declaration to the module of the class or of the type, or" :
      text "wrap the type with a newtype and declare the instance on the new type." :
      []

tcExtendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a
  -- Add new locally-defined instances
tcExtendLocalInstEnv dfuns thing_inside
 = do { traceDFuns dfuns
      ; env <- getGblEnv
      ; (inst_env', cls_insts') <- foldlM addLocalInst
                                          (tcg_inst_env env, tcg_insts env)
                                          dfuns
      ; let env' = env { tcg_insts    = cls_insts'
                       , tcg_inst_env = inst_env' }
      ; setGblEnv env' thing_inside }

addLocalInst :: (InstEnv, [ClsInst]) -> ClsInst -> TcM (InstEnv, [ClsInst])
-- Check that the proposed new instance is OK,
-- and then add it to the home inst env
-- If overwrite_inst, then we can overwrite a direct match
addLocalInst (home_ie, my_insts) ispec
   = do {
             -- Load imported instances, so that we report
             -- duplicates correctly

             -- 'matches'  are existing instance declarations that are less
             --            specific than the new one
             -- 'dups'     are those 'matches' that are equal to the new one
         ; isGHCi <- getIsGHCi
         ; eps    <- getEps
         ; tcg_env <- getGblEnv

           -- In GHCi, we *override* any identical instances
           -- that are also defined in the interactive context
           -- See Note [Override identical instances in GHCi]
         ; let home_ie'
                 | isGHCi    = deleteFromInstEnv home_ie ispec
                 | otherwise = home_ie

               global_ie = eps_inst_env eps
               inst_envs = InstEnvs { ie_global  = global_ie
                                    , ie_local   = home_ie'
                                    , ie_visible = tcVisibleOrphanMods tcg_env }

             -- Check for inconsistent functional dependencies
         ; let inconsistent_ispecs = checkFunDeps inst_envs ispec
         ; unless (null inconsistent_ispecs) $
           funDepErr ispec inconsistent_ispecs

             -- Check for duplicate instance decls.
         ; let (_tvs, cls, tys) = instanceHead ispec
               (matches, _, _)  = lookupInstEnv False inst_envs cls tys
               dups             = filter (identicalClsInstHead ispec) (map fst matches)
         ; unless (null dups) $
           dupInstErr ispec (head dups)

         ; return (extendInstEnv home_ie' ispec, ispec : my_insts) }

{-
Note [Signature files and type class instances]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Instances in signature files do not have an effect when compiling:
when you compile a signature against an implementation, you will
see the instances WHETHER OR NOT the instance is declared in
the file (this is because the signatures go in the EPS and we
can't filter them out easily.)  This is also why we cannot
place the instance in the hi file: it would show up as a duplicate,
and we don't have instance reexports anyway.

However, you might find them useful when typechecking against
a signature: the instance is a way of indicating to GHC that
some instance exists, in case downstream code uses it.

Implementing this is a little tricky.  Consider the following
situation (sigof03):

 module A where
     instance C T where ...

 module ASig where
     instance C T

When compiling ASig, A.hi is loaded, which brings its instances
into the EPS.  When we process the instance declaration in ASig,
we should ignore it for the purpose of doing a duplicate check,
since it's not actually a duplicate. But don't skip the check
entirely, we still want this to fail (tcfail221):

 module ASig where
     instance C T
     instance C T

Note that in some situations, the interface containing the type
class instances may not have been loaded yet at all.  The usual
situation when A imports another module which provides the
instances (sigof02m):

 module A(module B) where
     import B

See also Note [Signature lazy interface loading].  We can't
rely on this, however, since sometimes we'll have spurious
type class instances in the EPS, see #9422 (sigof02dm)

************************************************************************
*                                                                      *
        Errors and tracing
*                                                                      *
************************************************************************
-}

traceDFuns :: [ClsInst] -> TcRn ()
traceDFuns ispecs
  = traceTc "Adding instances:" (vcat (map pp ispecs))
  where
    pp ispec = hang (ppr (instanceDFunId ispec) <+> colon)
                  2 (ppr ispec)
        -- Print the dfun name itself too

funDepErr :: ClsInst -> [ClsInst] -> TcRn ()
funDepErr ispec ispecs
  = addClsInstsErr (text "Functional dependencies conflict between instance declarations:")
                    (ispec : ispecs)

dupInstErr :: ClsInst -> ClsInst -> TcRn ()
dupInstErr ispec dup_ispec
  = addClsInstsErr (text "Duplicate instance declarations:")
                    [ispec, dup_ispec]

addClsInstsErr :: SDoc -> [ClsInst] -> TcRn ()
addClsInstsErr herald ispecs
  = setSrcSpan (getSrcSpan (head sorted)) $
    addErr (hang herald 2 (pprInstances sorted))
 where
   sorted = sortWith getSrcLoc ispecs
   -- The sortWith just arranges that instances are dislayed in order
   -- of source location, which reduced wobbling in error messages,
   -- and is better for users


{-
(c) The University of Glasgow 2006
(c) The AQUA Project, Glasgow University, 1993-1998

\section[TcAnnotations]{Typechecking annotations}
-}

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

module TcAnnotations ( tcAnnotations, annCtxt ) where

import GhcPrelude

import {-# SOURCE #-} TcSplice ( runAnnotation )
import Module
import DynFlags
import Control.Monad ( when )

import HsSyn
import Name
import Annotations
import TcRnMonad
import SrcLoc
import Outputable

-- Some platforms don't support the external interpreter, and
-- compilation on those platforms shouldn't fail just due to
-- annotations
#ifndef GHCI
tcAnnotations :: [LAnnDecl GhcRn] -> TcM [Annotation]
tcAnnotations anns = do
  dflags <- getDynFlags
  case gopt Opt_ExternalInterpreter dflags of
    True  -> tcAnnotations' anns
    False -> warnAnns anns
warnAnns :: [LAnnDecl GhcRn] -> TcM [Annotation]
--- No GHCI; emit a warning (not an error) and ignore. cf Trac #4268
warnAnns [] = return []
warnAnns anns@(L loc _ : _)
  = do { setSrcSpan loc $ addWarnTc NoReason $
             (text "Ignoring ANN annotation" <> plural anns <> comma
             <+> text "because this is a stage-1 compiler without -fexternal-interpreter or doesn't support GHCi")
       ; return [] }
#else
tcAnnotations :: [LAnnDecl GhcRn] -> TcM [Annotation]
tcAnnotations = tcAnnotations'
#endif

tcAnnotations' :: [LAnnDecl GhcRn] -> TcM [Annotation]
tcAnnotations' anns = mapM tcAnnotation anns

tcAnnotation :: LAnnDecl GhcRn -> TcM Annotation
tcAnnotation (L loc ann@(HsAnnotation _ _ provenance expr)) = do
    -- Work out what the full target of this annotation was
    mod <- getModule
    let target = annProvenanceToTarget mod provenance

    -- Run that annotation and construct the full Annotation data structure
    setSrcSpan loc $ addErrCtxt (annCtxt ann) $ do
      -- See #10826 -- Annotations allow one to bypass Safe Haskell.
      dflags <- getDynFlags
      when (safeLanguageOn dflags) $ failWithTc safeHsErr
      runAnnotation target expr
    where
      safeHsErr = vcat [ text "Annotations are not compatible with Safe Haskell."
                  , text "See https://ghc.haskell.org/trac/ghc/ticket/10826" ]
tcAnnotation (L _ (XAnnDecl _)) = panic "tcAnnotation"

annProvenanceToTarget :: Module -> AnnProvenance Name
                      -> AnnTarget Name
annProvenanceToTarget _   (ValueAnnProvenance (L _ name)) = NamedTarget name
annProvenanceToTarget _   (TypeAnnProvenance (L _ name))  = NamedTarget name
annProvenanceToTarget mod ModuleAnnProvenance             = ModuleTarget mod

annCtxt :: (OutputableBndrId (GhcPass p)) => AnnDecl (GhcPass p) -> SDoc
annCtxt ann
  = hang (text "In the annotation:") 2 (ppr ann)


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

Typecheck arrow notation
-}

{-# LANGUAGE RankNTypes, TupleSections #-}
{-# LANGUAGE TypeFamilies #-}

module TcArrows ( tcProc ) where

import GhcPrelude

import {-# SOURCE #-}   TcExpr( tcMonoExpr, tcInferRho, tcSyntaxOp, tcCheckId, tcPolyExpr )

import HsSyn
import TcMatches
import TcHsSyn( hsLPatType )
import TcType
import TcMType
import TcBinds
import TcPat
import TcUnify
import TcRnMonad
import TcEnv
import TcEvidence
import Id( mkLocalId )
import Inst
import Name
import TysWiredIn
import VarSet
import TysPrim
import BasicTypes( Arity )
import SrcLoc
import Outputable
import Util

import Control.Monad

{-
Note [Arrow overview]
~~~~~~~~~~~~~~~~~~~~~
Here's a summary of arrows and how they typecheck.  First, here's
a cut-down syntax:

  expr ::= ....
        |  proc pat cmd

  cmd ::= cmd exp                    -- Arrow application
       |  \pat -> cmd                -- Arrow abstraction
       |  (| exp cmd1 ... cmdn |)    -- Arrow form, n>=0
       |  ... -- If, case in the usual way

  cmd_type ::= carg_type --> type

  carg_type ::= ()
             |  (type, carg_type)

Note that
 * The 'exp' in an arrow form can mention only
   "arrow-local" variables

 * An "arrow-local" variable is bound by an enclosing
   cmd binding form (eg arrow abstraction)

 * A cmd_type is here written with a funny arrow "-->",
   The bit on the left is a carg_type (command argument type)
   which itself is a nested tuple, finishing with ()

 * The arrow-tail operator (e1 -< e2) means
       (| e1 <<< arr snd |) e2

************************************************************************
*                                                                      *
                Proc
*                                                                      *
************************************************************************
-}

tcProc :: InPat GhcRn -> LHsCmdTop GhcRn        -- proc pat -> expr
       -> ExpRhoType                            -- Expected type of whole proc expression
       -> TcM (OutPat GhcTcId, LHsCmdTop GhcTcId, TcCoercion)

tcProc pat cmd exp_ty
  = newArrowScope $
    do  { exp_ty <- expTypeToType exp_ty  -- no higher-rank stuff with arrows
        ; (co, (exp_ty1, res_ty)) <- matchExpectedAppTy exp_ty
        ; (co1, (arr_ty, arg_ty)) <- matchExpectedAppTy exp_ty1
        ; let cmd_env = CmdEnv { cmd_arr = arr_ty }
        ; (pat', cmd') <- tcPat ProcExpr pat (mkCheckExpType arg_ty) $
                          tcCmdTop cmd_env cmd (unitTy, res_ty)
        ; let res_co = mkTcTransCo co
                         (mkTcAppCo co1 (mkTcNomReflCo res_ty))
        ; return (pat', cmd', res_co) }

{-
************************************************************************
*                                                                      *
                Commands
*                                                                      *
************************************************************************
-}

-- See Note [Arrow overview]
type CmdType    = (CmdArgType, TcTauType)    -- cmd_type
type CmdArgType = TcTauType                  -- carg_type, a nested tuple

data CmdEnv
  = CmdEnv {
        cmd_arr :: TcType -- arrow type constructor, of kind *->*->*
    }

mkCmdArrTy :: CmdEnv -> TcTauType -> TcTauType -> TcTauType
mkCmdArrTy env t1 t2 = mkAppTys (cmd_arr env) [t1, t2]

---------------------------------------
tcCmdTop :: CmdEnv
         -> LHsCmdTop GhcRn
         -> CmdType
         -> TcM (LHsCmdTop GhcTcId)

tcCmdTop env (L loc (HsCmdTop names cmd)) cmd_ty@(cmd_stk, res_ty)
  = setSrcSpan loc $
    do  { cmd'   <- tcCmd env cmd cmd_ty
        ; names' <- mapM (tcSyntaxName ProcOrigin (cmd_arr env)) names
        ; return (L loc $ HsCmdTop (CmdTopTc cmd_stk res_ty names') cmd') }
tcCmdTop _ (L _ XCmdTop{}) _ = panic "tcCmdTop"

----------------------------------------
tcCmd  :: CmdEnv -> LHsCmd GhcRn -> CmdType -> TcM (LHsCmd GhcTcId)
        -- The main recursive function
tcCmd env (L loc cmd) res_ty
  = setSrcSpan loc $ do
        { cmd' <- tc_cmd env cmd res_ty
        ; return (L loc cmd') }

tc_cmd :: CmdEnv -> HsCmd GhcRn  -> CmdType -> TcM (HsCmd GhcTcId)
tc_cmd env (HsCmdPar x cmd) res_ty
  = do  { cmd' <- tcCmd env cmd res_ty
        ; return (HsCmdPar x cmd') }

tc_cmd env (HsCmdLet x (L l binds) (L body_loc body)) res_ty
  = do  { (binds', body') <- tcLocalBinds binds         $
                             setSrcSpan body_loc        $
                             tc_cmd env body res_ty
        ; return (HsCmdLet x (L l binds') (L body_loc body')) }

tc_cmd env in_cmd@(HsCmdCase x scrut matches) (stk, res_ty)
  = addErrCtxt (cmdCtxt in_cmd) $ do
      (scrut', scrut_ty) <- tcInferRho scrut
      matches' <- tcMatchesCase match_ctxt scrut_ty matches (mkCheckExpType res_ty)
      return (HsCmdCase x scrut' matches')
  where
    match_ctxt = MC { mc_what = CaseAlt,
                      mc_body = mc_body }
    mc_body body res_ty' = do { res_ty' <- expTypeToType res_ty'
                              ; tcCmd env body (stk, res_ty') }

tc_cmd env (HsCmdIf x Nothing pred b1 b2) res_ty    -- Ordinary 'if'
  = do  { pred' <- tcMonoExpr pred (mkCheckExpType boolTy)
        ; b1'   <- tcCmd env b1 res_ty
        ; b2'   <- tcCmd env b2 res_ty
        ; return (HsCmdIf x Nothing pred' b1' b2')
    }

tc_cmd env (HsCmdIf x (Just fun) pred b1 b2) res_ty -- Rebindable syntax for if
  = do  { pred_ty <- newOpenFlexiTyVarTy
        -- For arrows, need ifThenElse :: forall r. T -> r -> r -> r
        -- because we're going to apply it to the environment, not
        -- the return value.
        ; (_, [r_tv]) <- tcInstSkolTyVars [alphaTyVar]
        ; let r_ty = mkTyVarTy r_tv
        ; checkTc (not (r_tv `elemVarSet` tyCoVarsOfType pred_ty))
                  (text "Predicate type of `ifThenElse' depends on result type")
        ; (pred', fun')
            <- tcSyntaxOp IfOrigin fun (map synKnownType [pred_ty, r_ty, r_ty])
                                       (mkCheckExpType r_ty) $ \ _ ->
               tcMonoExpr pred (mkCheckExpType pred_ty)

        ; b1'   <- tcCmd env b1 res_ty
        ; b2'   <- tcCmd env b2 res_ty
        ; return (HsCmdIf x (Just fun') pred' b1' b2')
    }

-------------------------------------------
--              Arrow application
--          (f -< a)   or   (f -<< a)
--
--   D   |- fun :: a t1 t2
--   D,G |- arg :: t1
--  ------------------------
--   D;G |-a  fun -< arg :: stk --> t2
--
--   D,G |- fun :: a t1 t2
--   D,G |- arg :: t1
--  ------------------------
--   D;G |-a  fun -<< arg :: stk --> t2
--
-- (plus -<< requires ArrowApply)

tc_cmd env cmd@(HsCmdArrApp _ fun arg ho_app lr) (_, res_ty)
  = addErrCtxt (cmdCtxt cmd)    $
    do  { arg_ty <- newOpenFlexiTyVarTy
        ; let fun_ty = mkCmdArrTy env arg_ty res_ty
        ; fun' <- select_arrow_scope (tcMonoExpr fun (mkCheckExpType fun_ty))

        ; arg' <- tcMonoExpr arg (mkCheckExpType arg_ty)

        ; return (HsCmdArrApp fun_ty fun' arg' ho_app lr) }
  where
       -- Before type-checking f, use the environment of the enclosing
       -- proc for the (-<) case.
       -- Local bindings, inside the enclosing proc, are not in scope
       -- inside f.  In the higher-order case (-<<), they are.
       -- See Note [Escaping the arrow scope] in TcRnTypes
    select_arrow_scope tc = case ho_app of
        HsHigherOrderApp -> tc
        HsFirstOrderApp  -> escapeArrowScope tc

-------------------------------------------
--              Command application
--
-- D,G |-  exp : t
-- D;G |-a cmd : (t,stk) --> res
-- -----------------------------
-- D;G |-a cmd exp : stk --> res

tc_cmd env cmd@(HsCmdApp x fun arg) (cmd_stk, res_ty)
  = addErrCtxt (cmdCtxt cmd)    $
    do  { arg_ty <- newOpenFlexiTyVarTy
        ; fun'   <- tcCmd env fun (mkPairTy arg_ty cmd_stk, res_ty)
        ; arg'   <- tcMonoExpr arg (mkCheckExpType arg_ty)
        ; return (HsCmdApp x fun' arg') }

-------------------------------------------
--              Lambda
--
-- D;G,x:t |-a cmd : stk --> res
-- ------------------------------
-- D;G |-a (\x.cmd) : (t,stk) --> res

tc_cmd env
       (HsCmdLam x (MG { mg_alts = L l [L mtch_loc
                                   (match@(Match { m_pats = pats, m_grhss = grhss }))],
                         mg_origin = origin }))
       (cmd_stk, res_ty)
  = addErrCtxt (pprMatchInCtxt match)        $
    do  { (co, arg_tys, cmd_stk') <- matchExpectedCmdArgs n_pats cmd_stk

                -- Check the patterns, and the GRHSs inside
        ; (pats', grhss') <- setSrcSpan mtch_loc                                 $
                             tcPats LambdaExpr pats (map mkCheckExpType arg_tys) $
                             tc_grhss grhss cmd_stk' (mkCheckExpType res_ty)

        ; let match' = L mtch_loc (Match { m_ext = noExt
                                         , m_ctxt = LambdaExpr, m_pats = pats'
                                         , m_grhss = grhss' })
              arg_tys = map hsLPatType pats'
              cmd' = HsCmdLam x (MG { mg_alts = L l [match']
                                    , mg_ext = MatchGroupTc arg_tys res_ty
                                    , mg_origin = origin })
        ; return (mkHsCmdWrap (mkWpCastN co) cmd') }
  where
    n_pats     = length pats
    match_ctxt = (LambdaExpr :: HsMatchContext Name)    -- Maybe KappaExpr?
    pg_ctxt    = PatGuard match_ctxt

    tc_grhss (GRHSs x grhss (L l binds)) stk_ty res_ty
        = do { (binds', grhss') <- tcLocalBinds binds $
                                   mapM (wrapLocM (tc_grhs stk_ty res_ty)) grhss
             ; return (GRHSs x grhss' (L l binds')) }
    tc_grhss (XGRHSs _) _ _ = panic "tc_grhss"

    tc_grhs stk_ty res_ty (GRHS x guards body)
        = do { (guards', rhs') <- tcStmtsAndThen pg_ctxt tcGuardStmt guards res_ty $
                                  \ res_ty -> tcCmd env body
                                                (stk_ty, checkingExpType "tc_grhs" res_ty)
             ; return (GRHS x guards' rhs') }
    tc_grhs _ _ (XGRHS _) = panic "tc_grhs"

-------------------------------------------
--              Do notation

tc_cmd env (HsCmdDo _ (L l stmts) ) (cmd_stk, res_ty)
  = do  { co <- unifyType Nothing unitTy cmd_stk  -- Expecting empty argument stack
        ; stmts' <- tcStmts ArrowExpr (tcArrDoStmt env) stmts res_ty
        ; return (mkHsCmdWrap (mkWpCastN co) (HsCmdDo res_ty (L l stmts') )) }

-----------------------------------------------------------------
--      Arrow ``forms''       (| e c1 .. cn |)
--
--      D; G |-a1 c1 : stk1 --> r1
--      ...
--      D; G |-an cn : stkn --> rn
--      D |-  e :: forall e. a1 (e, stk1) t1
--                                ...
--                        -> an (e, stkn) tn
--                        -> a  (e, stk) t
--      e \not\in (stk, stk1, ..., stkm, t, t1, ..., tn)
--      ----------------------------------------------
--      D; G |-a  (| e c1 ... cn |)  :  stk --> t

tc_cmd env cmd@(HsCmdArrForm x expr f fixity cmd_args) (cmd_stk, res_ty)
  = addErrCtxt (cmdCtxt cmd)    $
    do  { (cmd_args', cmd_tys) <- mapAndUnzipM tc_cmd_arg cmd_args
                              -- We use alphaTyVar for 'w'
        ; let e_ty = mkInvForAllTy alphaTyVar $
                     mkVisFunTys cmd_tys $
                     mkCmdArrTy env (mkPairTy alphaTy cmd_stk) res_ty
        ; expr' <- tcPolyExpr expr e_ty
        ; return (HsCmdArrForm x expr' f fixity cmd_args') }

  where
    tc_cmd_arg :: LHsCmdTop GhcRn -> TcM (LHsCmdTop GhcTcId, TcType)
    tc_cmd_arg cmd
       = do { arr_ty <- newFlexiTyVarTy arrowTyConKind
            ; stk_ty <- newFlexiTyVarTy liftedTypeKind
            ; res_ty <- newFlexiTyVarTy liftedTypeKind
            ; let env' = env { cmd_arr = arr_ty }
            ; cmd' <- tcCmdTop env' cmd (stk_ty, res_ty)
            ; return (cmd',  mkCmdArrTy env' (mkPairTy alphaTy stk_ty) res_ty) }

tc_cmd _ (XCmd {}) _ = panic "tc_cmd"

-----------------------------------------------------------------
--              Base case for illegal commands
-- This is where expressions that aren't commands get rejected

tc_cmd _ cmd _
  = failWithTc (vcat [text "The expression", nest 2 (ppr cmd),
                      text "was found where an arrow command was expected"])

matchExpectedCmdArgs :: Arity -> TcType -> TcM (TcCoercionN, [TcType], TcType)
matchExpectedCmdArgs 0 ty
  = return (mkTcNomReflCo ty, [], ty)
matchExpectedCmdArgs n ty
  = do { (co1, [ty1, ty2]) <- matchExpectedTyConApp pairTyCon ty
       ; (co2, tys, res_ty) <- matchExpectedCmdArgs (n-1) ty2
       ; return (mkTcTyConAppCo Nominal pairTyCon [co1, co2], ty1:tys, res_ty) }

{-
************************************************************************
*                                                                      *
                Stmts
*                                                                      *
************************************************************************
-}

--------------------------------
--      Mdo-notation
-- The distinctive features here are
--      (a) RecStmts, and
--      (b) no rebindable syntax

tcArrDoStmt :: CmdEnv -> TcCmdStmtChecker
tcArrDoStmt env _ (LastStmt x rhs noret _) res_ty thing_inside
  = do  { rhs' <- tcCmd env rhs (unitTy, res_ty)
        ; thing <- thing_inside (panic "tcArrDoStmt")
        ; return (LastStmt x rhs' noret noSyntaxExpr, thing) }

tcArrDoStmt env _ (BodyStmt _ rhs _ _) res_ty thing_inside
  = do  { (rhs', elt_ty) <- tc_arr_rhs env rhs
        ; thing          <- thing_inside res_ty
        ; return (BodyStmt elt_ty rhs' noSyntaxExpr noSyntaxExpr, thing) }

tcArrDoStmt env ctxt (BindStmt _ pat rhs _ _) res_ty thing_inside
  = do  { (rhs', pat_ty) <- tc_arr_rhs env rhs
        ; (pat', thing)  <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $
                            thing_inside res_ty
        ; return (mkTcBindStmt pat' rhs', thing) }

tcArrDoStmt env ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names
                            , recS_rec_ids = rec_names }) res_ty thing_inside
  = do  { let tup_names = rec_names ++ filterOut (`elem` rec_names) later_names
        ; tup_elt_tys <- newFlexiTyVarTys (length tup_names) liftedTypeKind
        ; let tup_ids = zipWith mkLocalId tup_names tup_elt_tys
        ; tcExtendIdEnv tup_ids $ do
        { (stmts', tup_rets)
                <- tcStmtsAndThen ctxt (tcArrDoStmt env) stmts res_ty   $ \ _res_ty' ->
                        -- ToDo: res_ty not really right
                   zipWithM tcCheckId tup_names (map mkCheckExpType tup_elt_tys)

        ; thing <- thing_inside res_ty
                -- NB:  The rec_ids for the recursive things
                --      already scope over this part. This binding may shadow
                --      some of them with polymorphic things with the same Name
                --      (see note [RecStmt] in HsExpr)

        ; let rec_ids = takeList rec_names tup_ids
        ; later_ids <- tcLookupLocalIds later_names

        ; let rec_rets = takeList rec_names tup_rets
        ; let ret_table = zip tup_ids tup_rets
        ; let later_rets = [r | i <- later_ids, (j, r) <- ret_table, i == j]

        ; return (emptyRecStmtId { recS_stmts = stmts'
                                 , recS_later_ids = later_ids
                                 , recS_rec_ids = rec_ids
                                 , recS_ext = unitRecStmtTc
                                     { recS_later_rets = later_rets
                                     , recS_rec_rets = rec_rets
                                     , recS_ret_ty = res_ty} }, thing)
        }}

tcArrDoStmt _ _ stmt _ _
  = pprPanic "tcArrDoStmt: unexpected Stmt" (ppr stmt)

tc_arr_rhs :: CmdEnv -> LHsCmd GhcRn -> TcM (LHsCmd GhcTcId, TcType)
tc_arr_rhs env rhs = do { ty <- newFlexiTyVarTy liftedTypeKind
                        ; rhs' <- tcCmd env rhs (unitTy, ty)
                        ; return (rhs', ty) }

{-
************************************************************************
*                                                                      *
                Helpers
*                                                                      *
************************************************************************
-}

mkPairTy :: Type -> Type -> Type
mkPairTy t1 t2 = mkTyConApp pairTyCon [t1,t2]

arrowTyConKind :: Kind          --  *->*->*
arrowTyConKind = mkVisFunTys [liftedTypeKind, liftedTypeKind] liftedTypeKind

{-
************************************************************************
*                                                                      *
                Errors
*                                                                      *
************************************************************************
-}

cmdCtxt :: HsCmd GhcRn -> SDoc
cmdCtxt cmd = text "In the command:" <+> ppr cmd


{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
module TcBackpack (
    findExtraSigImports',
    findExtraSigImports,
    implicitRequirements',
    implicitRequirements,
    checkUnitId,
    tcRnCheckUnitId,
    tcRnMergeSignatures,
    mergeSignatures,
    tcRnInstantiateSignature,
    instantiateSignature,
) where

import GhcPrelude

import BasicTypes (defaultFixity)
import Packages
import TcRnExports
import DynFlags
import HsSyn
import RdrName
import TcRnMonad
import TcTyDecls
import InstEnv
import FamInstEnv
import Inst
import TcIface
import TcMType
import TcType
import TcSimplify
import LoadIface
import RnNames
import ErrUtils
import Id
import Module
import Name
import NameEnv
import NameSet
import Avail
import SrcLoc
import HscTypes
import Outputable
import Type
import FastString
import RnFixity ( lookupFixityRn )
import Maybes
import TcEnv
import Var
import IfaceSyn
import PrelNames
import qualified Data.Map as Map

import Finder
import UniqDSet
import NameShape
import TcErrors
import TcUnify
import RnModIface
import Util

import Control.Monad
import Data.List (find)

import {-# SOURCE #-} TcRnDriver

#include "HsVersions.h"

fixityMisMatch :: TyThing -> Fixity -> Fixity -> SDoc
fixityMisMatch real_thing real_fixity sig_fixity =
    vcat [ppr real_thing <+> text "has conflicting fixities in the module",
          text "and its hsig file",
          text "Main module:" <+> ppr_fix real_fixity,
          text "Hsig file:" <+> ppr_fix sig_fixity]
  where
    ppr_fix f =
        ppr f <+>
        (if f == defaultFixity
            then parens (text "default")
            else empty)

checkHsigDeclM :: ModIface -> TyThing -> TyThing -> TcRn ()
checkHsigDeclM sig_iface sig_thing real_thing = do
    let name = getName real_thing
    -- TODO: Distinguish between signature merging and signature
    -- implementation cases.
    checkBootDeclM False sig_thing real_thing
    real_fixity <- lookupFixityRn name
    let sig_fixity = case mi_fix_fn sig_iface (occName name) of
                        Nothing -> defaultFixity
                        Just f -> f
    when (real_fixity /= sig_fixity) $
      addErrAt (nameSrcSpan name)
        (fixityMisMatch real_thing real_fixity sig_fixity)

-- | Given a 'ModDetails' of an instantiated signature (note that the
-- 'ModDetails' must be knot-tied consistently with the actual implementation)
-- and a 'GlobalRdrEnv' constructed from the implementor of this interface,
-- verify that the actual implementation actually matches the original
-- interface.
--
-- Note that it is already assumed that the implementation *exports*
-- a sufficient set of entities, since otherwise the renaming and then
-- typechecking of the signature 'ModIface' would have failed.
checkHsigIface :: TcGblEnv -> GlobalRdrEnv -> ModIface -> ModDetails -> TcRn ()
checkHsigIface tcg_env gr sig_iface
  ModDetails { md_insts = sig_insts, md_fam_insts = sig_fam_insts,
               md_types = sig_type_env, md_exports = sig_exports   } = do
    traceTc "checkHsigIface" $ vcat
        [ ppr sig_type_env, ppr sig_insts, ppr sig_exports ]
    mapM_ check_export (map availName sig_exports)
    unless (null sig_fam_insts) $
        panic ("TcRnDriver.checkHsigIface: Cannot handle family " ++
               "instances in hsig files yet...")
    -- Delete instances so we don't look them up when
    -- checking instance satisfiability
    -- TODO: this should not be necessary
    tcg_env <- getGblEnv
    setGblEnv tcg_env { tcg_inst_env = emptyInstEnv,
                        tcg_fam_inst_env = emptyFamInstEnv,
                        tcg_insts = [],
                        tcg_fam_insts = [] } $ do
    mapM_ check_inst sig_insts
    failIfErrsM
  where
    -- NB: the Names in sig_type_env are bogus.  Let's say we have H.hsig
    -- in package p that defines T; and we implement with himpl:H.  Then the
    -- Name is p[himpl:H]:H.T, NOT himplH:H.T.  That's OK but we just
    -- have to look up the right name.
    sig_type_occ_env = mkOccEnv
                     . map (\t -> (nameOccName (getName t), t))
                     $ nameEnvElts sig_type_env
    dfun_names = map getName sig_insts
    check_export name
      -- Skip instances, we'll check them later
      -- TODO: Actually this should never happen, because DFuns are
      -- never exported...
      | name `elem` dfun_names = return ()
      -- See if we can find the type directly in the hsig ModDetails
      -- TODO: need to special case wired in names
      | Just sig_thing <- lookupOccEnv sig_type_occ_env (nameOccName name) = do
        -- NB: We use tcLookupImported_maybe because we want to EXCLUDE
        -- tcg_env (TODO: but maybe this isn't relevant anymore).
        r <- tcLookupImported_maybe name
        case r of
          Failed err -> addErr err
          Succeeded real_thing -> checkHsigDeclM sig_iface sig_thing real_thing

      -- The hsig did NOT define this function; that means it must
      -- be a reexport.  In this case, make sure the 'Name' of the
      -- reexport matches the 'Name exported here.
      | [GRE { gre_name = name' }] <- lookupGlobalRdrEnv gr (nameOccName name) =
        when (name /= name') $ do
            -- See Note [Error reporting bad reexport]
            -- TODO: Actually this error swizzle doesn't work
            let p (L _ ie) = name `elem` ieNames ie
                loc = case tcg_rn_exports tcg_env of
                       Just es | Just e <- find p (map fst es)
                         -- TODO: maybe we can be a little more
                         -- precise here and use the Located
                         -- info for the *specific* name we matched.
                         -> getLoc e
                       _ -> nameSrcSpan name
            dflags <- getDynFlags
            addErrAt loc
                (badReexportedBootThing dflags False name name')
      -- This should actually never happen, but whatever...
      | otherwise =
        addErrAt (nameSrcSpan name)
            (missingBootThing False name "exported by")

-- Note [Error reporting bad reexport]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- NB: You want to be a bit careful about what location you report on reexports.
-- If the name was declared in the hsig file, 'nameSrcSpan name' is indeed the
-- correct source location.  However, if it was *reexported*, obviously the name
-- is not going to have the right location.  In this case, we need to grovel in
-- tcg_rn_exports to figure out where the reexport came from.

-- | Checks if a 'ClsInst' is "defined". In general, for hsig files we can't
-- assume that the implementing file actually implemented the instances (they
-- may be reexported from elsewhere).  Where should we look for the instances?
-- We do the same as we would otherwise: consult the EPS.  This isn't perfect
-- (we might conclude the module exports an instance when it doesn't, see
-- #9422), but we will never refuse to compile something.
check_inst :: ClsInst -> TcM ()
check_inst sig_inst = do
    -- TODO: This could be very well generalized to support instance
    -- declarations in boot files.
    tcg_env <- getGblEnv
    -- NB: Have to tug on the interface, not necessarily
    -- tugged... but it didn't work?
    mapM_ tcLookupImported_maybe (nameSetElemsStable (orphNamesOfClsInst sig_inst))
    -- Based off of 'simplifyDeriv'
    let ty = idType (instanceDFunId sig_inst)
        skol_info = InstSkol
        -- Based off of tcSplitDFunTy
        (tvs, theta, pred) =
           case tcSplitForAllTys ty of { (tvs, rho)   ->
           case splitFunTys rho     of { (theta, pred) ->
           (tvs, theta, pred) }}
        origin = InstProvidedOrigin (tcg_semantic_mod tcg_env) sig_inst
    (skol_subst, tvs_skols) <- tcInstSkolTyVars tvs -- Skolemize
    (tclvl,cts) <- pushTcLevelM $ do
       wanted <- newWanted origin
                           (Just TypeLevel)
                           (substTy skol_subst pred)
       givens <- forM theta $ \given -> do
           loc <- getCtLocM origin (Just TypeLevel)
           let given_pred = substTy skol_subst given
           new_ev <- newEvVar given_pred
           return CtGiven { ctev_pred = given_pred
                          -- Doesn't matter, make something up
                          , ctev_evar = new_ev
                          , ctev_loc = loc
                          }
       return $ wanted : givens
    unsolved <- simplifyWantedsTcM cts

    (implic, _) <- buildImplicationFor tclvl skol_info tvs_skols [] unsolved
    reportAllUnsolved (mkImplicWC implic)

-- | Return this list of requirement interfaces that need to be merged
-- to form @mod_name@, or @[]@ if this is not a requirement.
requirementMerges :: DynFlags -> ModuleName -> [IndefModule]
requirementMerges dflags mod_name =
    fromMaybe [] (Map.lookup mod_name (requirementContext (pkgState dflags)))

-- | For a module @modname@ of type 'HscSource', determine the list
-- of extra "imports" of other requirements which should be considered part of
-- the import of the requirement, because it transitively depends on those
-- requirements by imports of modules from other packages.  The situation
-- is something like this:
--
--      unit p where
--          signature A
--          signature B
--              import A
--
--      unit q where
--          dependency p[A=<A>,B=<B>]
--          signature A
--          signature B
--
-- Although q's B does not directly import A, we still have to make sure we
-- process A first, because the merging process will cause B to indirectly
-- import A.  This function finds the TRANSITIVE closure of all such imports
-- we need to make.
findExtraSigImports' :: HscEnv
                     -> HscSource
                     -> ModuleName
                     -> IO (UniqDSet ModuleName)
findExtraSigImports' hsc_env HsigFile modname =
    fmap unionManyUniqDSets (forM reqs $ \(IndefModule iuid mod_name) ->
        (initIfaceLoad hsc_env
            . withException
            $ moduleFreeHolesPrecise (text "findExtraSigImports")
                (mkModule (IndefiniteUnitId iuid) mod_name)))
  where
    reqs = requirementMerges (hsc_dflags hsc_env) modname

findExtraSigImports' _ _ _ = return emptyUniqDSet

-- | 'findExtraSigImports', but in a convenient form for "GhcMake" and
-- "TcRnDriver".
findExtraSigImports :: HscEnv -> HscSource -> ModuleName
                    -> IO [(Maybe FastString, Located ModuleName)]
findExtraSigImports hsc_env hsc_src modname = do
    extra_requirements <- findExtraSigImports' hsc_env hsc_src modname
    return [ (Nothing, noLoc mod_name)
           | mod_name <- uniqDSetToList extra_requirements ]

-- A version of 'implicitRequirements'' which is more friendly
-- for "GhcMake" and "TcRnDriver".
implicitRequirements :: HscEnv
                     -> [(Maybe FastString, Located ModuleName)]
                     -> IO [(Maybe FastString, Located ModuleName)]
implicitRequirements hsc_env normal_imports
  = do mns <- implicitRequirements' hsc_env normal_imports
       return [ (Nothing, noLoc mn) | mn <- mns ]

-- Given a list of 'import M' statements in a module, figure out
-- any extra implicit requirement imports they may have.  For
-- example, if they 'import M' and M resolves to p[A=<B>], then
-- they actually also import the local requirement B.
implicitRequirements' :: HscEnv
                     -> [(Maybe FastString, Located ModuleName)]
                     -> IO [ModuleName]
implicitRequirements' hsc_env normal_imports
  = fmap concat $
    forM normal_imports $ \(mb_pkg, L _ imp) -> do
        found <- findImportedModule hsc_env imp mb_pkg
        case found of
            Found _ mod | thisPackage dflags /= moduleUnitId mod ->
                return (uniqDSetToList (moduleFreeHoles mod))
            _ -> return []
  where dflags = hsc_dflags hsc_env

-- | Given a 'UnitId', make sure it is well typed.  This is because
-- unit IDs come from Cabal, which does not know if things are well-typed or
-- not; a component may have been filled with implementations for the holes
-- that don't actually fulfill the requirements.
--
-- INVARIANT: the UnitId is NOT a InstalledUnitId
checkUnitId :: UnitId -> TcM ()
checkUnitId uid = do
    case splitUnitIdInsts uid of
      (_, Just indef) ->
        let insts = indefUnitIdInsts indef in
        forM_ insts $ \(mod_name, mod) ->
            -- NB: direct hole instantiations are well-typed by construction
            -- (because we FORCE things to be merged in), so don't check them
            when (not (isHoleModule mod)) $ do
                checkUnitId (moduleUnitId mod)
                _ <- mod `checkImplements` IndefModule indef mod_name
                return ()
      _ -> return () -- if it's hashed, must be well-typed

-- | Top-level driver for signature instantiation (run when compiling
-- an @hsig@ file.)
tcRnCheckUnitId ::
    HscEnv -> UnitId ->
    IO (Messages, Maybe ())
tcRnCheckUnitId hsc_env uid =
   withTiming (pure dflags)
              (text "Check unit id" <+> ppr uid)
              (const ()) $
   initTc hsc_env
          HsigFile -- bogus
          False
          mAIN -- bogus
          (realSrcLocSpan (mkRealSrcLoc (fsLit loc_str) 0 0)) -- bogus
    $ checkUnitId uid
  where
   dflags = hsc_dflags hsc_env
   loc_str = "Command line argument: -unit-id " ++ showSDoc dflags (ppr uid)

-- TODO: Maybe lcl_iface0 should be pre-renamed to the right thing? Unclear...

-- | Top-level driver for signature merging (run after typechecking
-- an @hsig@ file).
tcRnMergeSignatures :: HscEnv -> HsParsedModule -> TcGblEnv {- from local sig -} -> ModIface
                    -> IO (Messages, Maybe TcGblEnv)
tcRnMergeSignatures hsc_env hpm orig_tcg_env iface =
  withTiming (pure dflags)
             (text "Signature merging" <+> brackets (ppr this_mod))
             (const ()) $
  initTc hsc_env HsigFile False this_mod real_loc $
    mergeSignatures hpm orig_tcg_env iface
 where
  dflags   = hsc_dflags hsc_env
  this_mod = mi_module iface
  real_loc = tcg_top_loc orig_tcg_env

thinModIface :: [AvailInfo] -> ModIface -> ModIface
thinModIface avails iface =
    iface {
        mi_exports = avails,
        -- mi_fixities = ...,
        -- mi_warns = ...,
        -- mi_anns = ...,
        -- TODO: The use of nameOccName here is a bit dodgy, because
        -- perhaps there might be two IfaceTopBndr that are the same
        -- OccName but different Name.  Requires better understanding
        -- of invariants here.
        mi_decls = exported_decls ++ non_exported_decls ++ dfun_decls
        -- mi_insts = ...,
        -- mi_fam_insts = ...,
    }
  where
    decl_pred occs decl = nameOccName (ifName decl) `elemOccSet` occs
    filter_decls occs = filter (decl_pred occs . snd) (mi_decls iface)

    exported_occs = mkOccSet [ occName n
                             | a <- avails
                             , n <- availNames a ]
    exported_decls = filter_decls exported_occs

    non_exported_occs = mkOccSet [ occName n
                                 | (_, d) <- exported_decls
                                 , n <- ifaceDeclNeverExportedRefs d ]
    non_exported_decls = filter_decls non_exported_occs

    dfun_pred IfaceId{ ifIdDetails = IfDFunId } = True
    dfun_pred _ = False
    dfun_decls = filter (dfun_pred . snd) (mi_decls iface)

-- | The list of 'Name's of *non-exported* 'IfaceDecl's which this
-- 'IfaceDecl' may refer to.  A non-exported 'IfaceDecl' should be kept
-- after thinning if an *exported* 'IfaceDecl' (or 'mi_insts', perhaps)
-- refers to it; we can't decide to keep it by looking at the exports
-- of a module after thinning.  Keep this synchronized with
-- 'rnIfaceDecl'.
ifaceDeclNeverExportedRefs :: IfaceDecl -> [Name]
ifaceDeclNeverExportedRefs d@IfaceFamily{} =
    case ifFamFlav d of
        IfaceClosedSynFamilyTyCon (Just (n, _))
            -> [n]
        _   -> []
ifaceDeclNeverExportedRefs _ = []

-- Note [Blank hsigs for all requirements]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- One invariant that a client of GHC must uphold is that there
-- must be an hsig file for every requirement (according to
-- @-this-unit-id@); this ensures that for every interface
-- file (hi), there is a source file (hsig), which helps grease
-- the wheels of recompilation avoidance which assumes that
-- source files always exist.

{-
inheritedSigPvpWarning :: WarningTxt
inheritedSigPvpWarning =
    WarningTxt (noLoc NoSourceText) [noLoc (StringLiteral NoSourceText (fsLit msg))]
  where
    msg = "Inherited requirements from non-signature libraries (libraries " ++
          "with modules) should not be used, as this mode of use is not " ++
          "compatible with PVP-style version bounds.  Instead, copy the " ++
          "declaration to the local hsig file or move the signature to a " ++
          "library of its own and add that library as a dependency."
-}

-- Note [Handling never-exported TyThings under Backpack]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--   DEFINITION: A "never-exported TyThing" is a TyThing whose 'Name' will
--   never be mentioned in the export list of a module (mi_avails).
--   Unlike implicit TyThings (Note [Implicit TyThings]), non-exported
--   TyThings DO have a standalone IfaceDecl declaration in their
--   interface file.
--
-- Originally, Backpack was designed under the assumption that anything
-- you could declare in a module could also be exported; thus, merging
-- the export lists of two signatures is just merging the declarations
-- of two signatures writ small.  Of course, in GHC Haskell, there are a
-- few important things which are not explicitly exported but still can
-- be used:  in particular, dictionary functions for instances, Typeable
-- TyCon bindings, and coercion axioms for type families also count.
--
-- When handling these non-exported things, there two primary things
-- we need to watch out for:
--
--  * Signature matching/merging is done by comparing each
--    of the exported entities of a signature and a module.  These exported
--    entities may refer to non-exported TyThings which must be tested for
--    consistency.  For example, an instance (ClsInst) will refer to a
--    non-exported DFunId.  In this case, 'checkBootDeclM' directly compares the
--    embedded 'DFunId' in 'is_dfun'.
--
--    For this to work at all, we must ensure that pointers in 'is_dfun' refer
--    to DISTINCT 'DFunId's, even though the 'Name's (may) be the same.
--    Unfortunately, this is the OPPOSITE of how we treat most other references
--    to 'Name's, so this case needs to be handled specially.
--
--    The details are in the documentation for 'typecheckIfacesForMerging'.
--    and the Note [Resolving never-exported Names in TcIface].
--
--  * When we rename modules and signatures, we use the export lists to
--    decide how the declarations should be renamed.  However, this
--    means we don't get any guidance for how to rename non-exported
--    entities.  Fortunately, we only need to rename these entities
--    *consistently*, so that 'typecheckIfacesForMerging' can wire them
--    up as needed.
--
--    The details are in Note [rnIfaceNeverExported] in 'RnModIface'.
--
-- The root cause for all of these complications is the fact that these
-- logically "implicit" entities are defined indirectly in an interface
-- file.  #13151 gives a proposal to make these *truly* implicit.

merge_msg :: ModuleName -> [IndefModule] -> SDoc
merge_msg mod_name [] =
    text "while checking the local signature" <+> ppr mod_name <+>
    text "for consistency"
merge_msg mod_name reqs =
  hang (text "while merging the signatures from" <> colon)
   2 (vcat [ bullet <+> ppr req | req <- reqs ] $$
      bullet <+> text "...and the local signature for" <+> ppr mod_name)

-- | Given a local 'ModIface', merge all inherited requirements
-- from 'requirementMerges' into this signature, producing
-- a final 'TcGblEnv' that matches the local signature and
-- all required signatures.
mergeSignatures :: HsParsedModule -> TcGblEnv -> ModIface -> TcRn TcGblEnv
mergeSignatures
  (HsParsedModule { hpm_module = L loc (HsModule { hsmodExports = mb_exports }),
                    hpm_src_files = src_files })
  orig_tcg_env lcl_iface0 = setSrcSpan loc $ do
    -- The lcl_iface0 is the ModIface for the local hsig
    -- file, which is guaranteed to exist, see
    -- Note [Blank hsigs for all requirements]
    hsc_env <- getTopEnv
    dflags  <- getDynFlags

    -- Copy over some things from the original TcGblEnv that
    -- we want to preserve
    updGblEnv (\env -> env {
        -- Renamed imports/declarations are often used
        -- by programs that use the GHC API, e.g., Haddock.
        -- These won't get filled by the merging process (since
        -- we don't actually rename the parsed module again) so
        -- we need to take them directly from the previous
        -- typechecking.
        --
        -- NB: the export declarations aren't in their final
        -- form yet.  We'll fill those in when we reprocess
        -- the export declarations.
        tcg_rn_imports = tcg_rn_imports orig_tcg_env,
        tcg_rn_decls   = tcg_rn_decls   orig_tcg_env,
        -- Annotations
        tcg_ann_env    = tcg_ann_env    orig_tcg_env,
        -- Documentation header
        tcg_doc_hdr    = tcg_doc_hdr orig_tcg_env
        -- tcg_dus?
        -- tcg_th_used           = tcg_th_used orig_tcg_env,
        -- tcg_th_splice_used    = tcg_th_splice_used orig_tcg_env
        -- tcg_th_top_level_locs = tcg_th_top_level_locs orig_tcg_env
       }) $ do
    tcg_env <- getGblEnv

    let outer_mod = tcg_mod tcg_env
        inner_mod = tcg_semantic_mod tcg_env
        mod_name = moduleName (tcg_mod tcg_env)

    -- STEP 1: Figure out all of the external signature interfaces
    -- we are going to merge in.
    let reqs = requirementMerges dflags mod_name

    addErrCtxt (merge_msg mod_name reqs) $ do

    -- STEP 2: Read in the RAW forms of all of these interfaces
    ireq_ifaces0 <- forM reqs $ \(IndefModule iuid mod_name) ->
        let m = mkModule (IndefiniteUnitId iuid) mod_name
            im = fst (splitModuleInsts m)
        in fmap fst
         . withException
         $ findAndReadIface (text "mergeSignatures") im m False

    -- STEP 3: Get the unrenamed exports of all these interfaces,
    -- thin it according to the export list, and do shaping on them.
    let extend_ns nsubst as = liftIO $ extendNameShape hsc_env nsubst as
        -- This function gets run on every inherited interface, and
        -- it's responsible for:
        --
        --  1. Merging the exports of the interface into @nsubst@,
        --  2. Adding these exports to the "OK to import" set (@oks@)
        --  if they came from a package with no exposed modules
        --  (this means we won't report a PVP error in this case), and
        --  3. Thinning the interface according to an explicit export
        --  list.
        --
        gen_subst (nsubst,oks,ifaces) (imod@(IndefModule iuid _), ireq_iface) = do
            let insts = indefUnitIdInsts iuid
                isFromSignaturePackage =
                    let inst_uid = fst (splitUnitIdInsts (IndefiniteUnitId iuid))
                        pkg = getInstalledPackageDetails dflags inst_uid
                    in null (exposedModules pkg)
            -- 3(a). Rename the exports according to how the dependency
            -- was instantiated.  The resulting export list will be accurate
            -- except for exports *from the signature itself* (which may
            -- be subsequently updated by exports from other signatures in
            -- the merge.
            as1 <- tcRnModExports insts ireq_iface
            -- 3(b). Thin the interface if it comes from a signature package.
            (thinned_iface, as2) <- case mb_exports of
                    Just (L loc _)
                      -- Check if the package containing this signature is
                      -- a signature package (i.e., does not expose any
                      -- modules.)  If so, we can thin it.
                      | isFromSignaturePackage
                      -> setSrcSpan loc $ do
                        -- Suppress missing errors; they might be used to refer
                        -- to entities from other signatures we are merging in.
                        -- If an identifier truly doesn't exist in any of the
                        -- signatures that are merged in, we will discover this
                        -- when we run exports_from_avail on the final merged
                        -- export list.
                        (msgs, mb_r) <- tryTc $ do
                            -- Suppose that we have written in a signature:
                            --  signature A ( module A ) where {- empty -}
                            -- If I am also inheriting a signature from a
                            -- signature package, does 'module A' scope over
                            -- all of its exports?
                            --
                            -- There are two possible interpretations:
                            --
                            --  1. For non self-reexports, a module reexport
                            --  is interpreted only in terms of the local
                            --  signature module, and not any of the inherited
                            --  ones.  The reason for this is because after
                            --  typechecking, module exports are completely
                            --  erased from the interface of a file, so we
                            --  have no way of "interpreting" a module reexport.
                            --  Thus, it's only useful for the local signature
                            --  module (where we have a useful GlobalRdrEnv.)
                            --
                            --  2. On the other hand, a common idiom when
                            --  you want to "export everything, plus a reexport"
                            --  in modules is to say module A ( module A, reex ).
                            --  This applies to signature modules too; and in
                            --  particular, you probably still want the entities
                            --  from the inherited signatures to be preserved
                            --  too.
                            --
                            -- We think it's worth making a special case for
                            -- self reexports to make use case (2) work.  To
                            -- do this, we take the exports of the inherited
                            -- signature @as1@, and bundle them into a
                            -- GlobalRdrEnv where we treat them as having come
                            -- from the import @import A@.  Thus, we will
                            -- pick them up if they are referenced explicitly
                            -- (@foo@) or even if we do a module reexport
                            -- (@module A@).
                            let ispec = ImpSpec ImpDeclSpec{
                                            -- NB: This needs to be mod name
                                            -- of the local signature, not
                                            -- the (original) module name of
                                            -- the inherited signature,
                                            -- because we need module
                                            -- LocalSig (from the local
                                            -- export list) to match it!
                                            is_mod  = mod_name,
                                            is_as   = mod_name,
                                            is_qual = False,
                                            is_dloc = loc
                                          } ImpAll
                                rdr_env = mkGlobalRdrEnv (gresFromAvails (Just ispec) as1)
                            setGblEnv tcg_env {
                                tcg_rdr_env = rdr_env
                            } $ exports_from_avail mb_exports rdr_env
                                    -- NB: tcg_imports is also empty!
                                    emptyImportAvails
                                    (tcg_semantic_mod tcg_env)
                        case mb_r of
                            Just (_, as2) -> return (thinModIface as2 ireq_iface, as2)
                            Nothing -> addMessages msgs >> failM
                    -- We can't think signatures from non signature packages
                    _ -> return (ireq_iface, as1)
            -- 3(c). Only identifiers from signature packages are "ok" to
            -- import (that is, they are safe from a PVP perspective.)
            -- (NB: This code is actually dead right now.)
            let oks' | isFromSignaturePackage
                     = extendOccSetList oks (exportOccs as2)
                     | otherwise
                     = oks
            -- 3(d). Extend the name substitution (performing shaping)
            mb_r <- extend_ns nsubst as2
            case mb_r of
                Left err -> failWithTc err
                Right nsubst' -> return (nsubst',oks',(imod, thinned_iface):ifaces)
        nsubst0 = mkNameShape (moduleName inner_mod) (mi_exports lcl_iface0)
        ok_to_use0 = mkOccSet (exportOccs (mi_exports lcl_iface0))
    -- Process each interface, getting the thinned interfaces as well as
    -- the final, full set of exports @nsubst@ and the exports which are
    -- "ok to use" (we won't attach 'inheritedSigPvpWarning' to them.)
    (nsubst, ok_to_use, rev_thinned_ifaces)
        <- foldM gen_subst (nsubst0, ok_to_use0, []) (zip reqs ireq_ifaces0)
    let thinned_ifaces = reverse rev_thinned_ifaces
        exports        = nameShapeExports nsubst
        rdr_env        = mkGlobalRdrEnv (gresFromAvails Nothing exports)
        _warn_occs     = filter (not . (`elemOccSet` ok_to_use)) (exportOccs exports)
        warns          = NoWarnings
        {-
        -- TODO: Warnings are transitive, but this is not what we want here:
        -- if a module reexports an entity from a signature, that should be OK.
        -- Not supported in current warning framework
        warns | null warn_occs = NoWarnings
              | otherwise = WarnSome $ map (\o -> (o, inheritedSigPvpWarning)) warn_occs
        -}
    setGblEnv tcg_env {
        -- The top-level GlobalRdrEnv is quite interesting.  It consists
        -- of two components:
        --  1. First, we reuse the GlobalRdrEnv of the local signature.
        --     This is very useful, because it means that if we have
        --     to print a message involving some entity that the local
        --     signature imported, we'll qualify it accordingly.
        --  2. Second, we need to add all of the declarations we are
        --     going to merge in (as they need to be in scope for the
        --     final test of the export list.)
        tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env orig_tcg_env,
        -- Inherit imports from the local signature, so that module
        -- rexports are picked up correctly
        tcg_imports = tcg_imports orig_tcg_env,
        tcg_exports = exports,
        tcg_dus     = usesOnly (availsToNameSetWithSelectors exports),
        tcg_warns   = warns
        } $ do
    tcg_env <- getGblEnv

    -- Make sure we didn't refer to anything that doesn't actually exist
    -- pprTrace "mergeSignatures: exports_from_avail" (ppr exports) $ return ()
    (mb_lies, _) <- exports_from_avail mb_exports rdr_env
                        (tcg_imports tcg_env) (tcg_semantic_mod tcg_env)

    {- -- NB: This is commented out, because warns above is disabled.
    -- If you tried to explicitly export an identifier that has a warning
    -- attached to it, that's probably a mistake.  Warn about it.
    case mb_lies of
      Nothing -> return ()
      Just lies ->
        forM_ (concatMap (\(L loc x) -> map (L loc) (ieNames x)) lies) $ \(L loc n) ->
          setSrcSpan loc $
            unless (nameOccName n `elemOccSet` ok_to_use) $
                addWarn NoReason $ vcat [
                    text "Exported identifier" <+> quotes (ppr n) <+> text "will cause warnings if used.",
                    parens (text "To suppress this warning, remove" <+> quotes (ppr n) <+> text "from the export list of this signature.")
                    ]
    -}

    failIfErrsM

    -- Save the exports
    setGblEnv tcg_env { tcg_rn_exports = mb_lies } $ do
    tcg_env <- getGblEnv

    -- STEP 4: Rename the interfaces
    ext_ifaces <- forM thinned_ifaces $ \((IndefModule iuid _), ireq_iface) ->
        tcRnModIface (indefUnitIdInsts iuid) (Just nsubst) ireq_iface
    lcl_iface <- tcRnModIface (thisUnitIdInsts dflags) (Just nsubst) lcl_iface0
    let ifaces = lcl_iface : ext_ifaces

    -- STEP 4.1: Merge fixities (we'll verify shortly) tcg_fix_env
    let fix_env = mkNameEnv [ (gre_name rdr_elt, FixItem occ f)
                            | (occ, f) <- concatMap mi_fixities ifaces
                            , rdr_elt <- lookupGlobalRdrEnv rdr_env occ ]

    -- STEP 5: Typecheck the interfaces
    let type_env_var = tcg_type_env_var tcg_env

    -- typecheckIfacesForMerging does two things:
    --      1. It merges the all of the ifaces together, and typechecks the
    --      result to type_env.
    --      2. It typechecks each iface individually, but with their 'Name's
    --      resolving to the merged type_env from (1).
    -- See typecheckIfacesForMerging for more details.
    (type_env, detailss) <- initIfaceTcRn $
                            typecheckIfacesForMerging inner_mod ifaces type_env_var
    let infos = zip ifaces detailss

    -- Test for cycles
    checkSynCycles (thisPackage dflags) (typeEnvTyCons type_env) []

    -- NB on type_env: it contains NO dfuns.  DFuns are recorded inside
    -- detailss, and given a Name that doesn't correspond to anything real.  See
    -- also Note [Signature merging DFuns]

    -- Add the merged type_env to TcGblEnv, so that it gets serialized
    -- out when we finally write out the interface.
    --
    -- NB: Why do we set tcg_tcs/tcg_patsyns/tcg_type_env directly,
    -- rather than use tcExtendGlobalEnv (the normal method to add newly
    -- defined types to TcGblEnv?)  tcExtendGlobalEnv adds these
    -- TyThings to 'tcg_type_env_var', which is consulted when
    -- we read in interfaces to tie the knot.  But *these TyThings themselves
    -- come from interface*, so that would result in deadlock.  Don't
    -- update it!
    setGblEnv tcg_env {
        tcg_tcs = typeEnvTyCons type_env,
        tcg_patsyns = typeEnvPatSyns type_env,
        tcg_type_env = type_env,
        tcg_fix_env = fix_env
        } $ do
    tcg_env <- getGblEnv

    -- STEP 6: Check for compatibility/merge things
    tcg_env <- (\x -> foldM x tcg_env infos)
             $ \tcg_env (iface, details) -> do

        let check_export name
              | Just sig_thing <- lookupTypeEnv (md_types details) name
              = case lookupTypeEnv type_env (getName sig_thing) of
                  Just thing -> checkHsigDeclM iface sig_thing thing
                  Nothing -> panic "mergeSignatures: check_export"
              -- Oops! We're looking for this export but it's
              -- not actually in the type environment of the signature's
              -- ModDetails.
              --
              -- NB: This case happens because the we're iterating
              -- over the union of all exports, so some interfaces
              -- won't have everything.  Note that md_exports is nonsense
              -- (it's the same as exports); maybe we should fix this
              -- eventually.
              | otherwise
              = return ()
        mapM_ check_export (map availName exports)

        -- Note [Signature merging instances]
        -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
        -- Merge instances into the global environment.  The algorithm here is
        -- dumb and simple: if an instance has exactly the same DFun type
        -- (tested by 'memberInstEnv') as an existing instance, we drop it;
        -- otherwise, we add it even, even if this would cause overlap.
        --
        -- Why don't we deduplicate instances with identical heads?  There's no
        -- good choice if they have premises:
        --
        --      instance K1 a => K (T a)
        --      instance K2 a => K (T a)
        --
        -- Why not eagerly error in this case?  The overlapping head does not
        -- necessarily mean that the instances are unimplementable: in fact,
        -- they may be implemented without overlap (if, for example, the
        -- implementing module has 'instance K (T a)'; both are implemented in
        -- this case.)  The implements test just checks that the wanteds are
        -- derivable assuming the givens.
        --
        -- Still, overlapping instances with hypotheses like above are going
        -- to be a bad deal, because instance resolution when we're typechecking
        -- against the merged signature is going to have a bad time when
        -- there are overlapping heads like this: we never backtrack, so it
        -- may be difficult to see that a wanted is derivable.  For now,
        -- we hope that we get lucky / the overlapping instances never
        -- get used, but it is not a very good situation to be in.
        --
        let merge_inst (insts, inst_env) inst
                | memberInstEnv inst_env inst -- test DFun Type equality
                = (insts, inst_env)
                | otherwise
                -- NB: is_dfun_name inst is still nonsense here,
                -- see Note [Signature merging DFuns]
                = (inst:insts, extendInstEnv inst_env inst)
            (insts, inst_env) = foldl' merge_inst
                                    (tcg_insts tcg_env, tcg_inst_env tcg_env)
                                    (md_insts details)
            -- This is a HACK to prevent calculateAvails from including imp_mod
            -- in the listing.  We don't want it because a module is NOT
            -- supposed to include itself in its dep_orphs/dep_finsts.  See #13214
            iface' = iface { mi_orphan = False, mi_finsts = False }
            avails = plusImportAvails (tcg_imports tcg_env) $
                        calculateAvails dflags iface' False False ImportedBySystem
        return tcg_env {
            tcg_inst_env = inst_env,
            tcg_insts    = insts,
            tcg_imports  = avails,
            tcg_merged   =
                if outer_mod == mi_module iface
                    -- Don't add ourselves!
                    then tcg_merged tcg_env
                    else (mi_module iface, mi_mod_hash iface) : tcg_merged tcg_env
            }

    -- Note [Signature merging DFuns]
    -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    -- Once we know all of instances which will be defined by this merged
    -- signature, we go through each of the DFuns and rename them with a fresh,
    -- new, unique DFun Name, and add these DFuns to tcg_type_env (thus fixing
    -- up the "bogus" names that were setup in 'typecheckIfacesForMerging'.
    --
    -- We can't do this fixup earlier, because we need a way to identify each
    -- source DFun (from each of the signatures we are merging in) so that
    -- when we have a ClsInst, we can pull up the correct DFun to check if
    -- the types match.
    --
    -- See also Note [rnIfaceNeverExported] in RnModIface
    dfun_insts <- forM (tcg_insts tcg_env) $ \inst -> do
        n <- newDFunName (is_cls inst) (is_tys inst) (nameSrcSpan (is_dfun_name inst))
        let dfun = setVarName (is_dfun inst) n
        return (dfun, inst { is_dfun_name = n, is_dfun = dfun })
    tcg_env <- return tcg_env {
            tcg_insts = map snd dfun_insts,
            tcg_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) (map fst dfun_insts)
        }

    addDependentFiles src_files

    return tcg_env

-- | Top-level driver for signature instantiation (run when compiling
-- an @hsig@ file.)
tcRnInstantiateSignature ::
    HscEnv -> Module -> RealSrcSpan ->
    IO (Messages, Maybe TcGblEnv)
tcRnInstantiateSignature hsc_env this_mod real_loc =
   withTiming (pure dflags)
              (text "Signature instantiation"<+>brackets (ppr this_mod))
              (const ()) $
   initTc hsc_env HsigFile False this_mod real_loc $ instantiateSignature
  where
   dflags = hsc_dflags hsc_env

exportOccs :: [AvailInfo] -> [OccName]
exportOccs = concatMap (map occName . availNames)

impl_msg :: Module -> IndefModule -> SDoc
impl_msg impl_mod (IndefModule req_uid req_mod_name) =
  text "while checking that" <+> ppr impl_mod <+>
  text "implements signature" <+> ppr req_mod_name <+>
  text "in" <+> ppr req_uid

-- | Check if module implements a signature.  (The signature is
-- always un-hashed, which is why its components are specified
-- explicitly.)
checkImplements :: Module -> IndefModule -> TcRn TcGblEnv
checkImplements impl_mod req_mod@(IndefModule uid mod_name) =
  addErrCtxt (impl_msg impl_mod req_mod) $ do
    let insts = indefUnitIdInsts uid

    -- STEP 1: Load the implementing interface, and make a RdrEnv
    -- for its exports.  Also, add its 'ImportAvails' to 'tcg_imports',
    -- so that we treat all orphan instances it provides as visible
    -- when we verify that all instances are checked (see #12945), and so that
    -- when we eventually write out the interface we record appropriate
    -- dependency information.
    impl_iface <- initIfaceTcRn $
        loadSysInterface (text "checkImplements 1") impl_mod
    let impl_gr = mkGlobalRdrEnv
                    (gresFromAvails Nothing (mi_exports impl_iface))
        nsubst = mkNameShape (moduleName impl_mod) (mi_exports impl_iface)

    -- Load all the orphans, so the subsequent 'checkHsigIface' sees
    -- all the instances it needs to
    loadModuleInterfaces (text "Loading orphan modules (from implementor of hsig)")
                         (dep_orphs (mi_deps impl_iface))

    dflags <- getDynFlags
    let avails = calculateAvails dflags
                    impl_iface False{- safe -} False{- boot -} ImportedBySystem
        fix_env = mkNameEnv [ (gre_name rdr_elt, FixItem occ f)
                            | (occ, f) <- mi_fixities impl_iface
                            , rdr_elt <- lookupGlobalRdrEnv impl_gr occ ]
    updGblEnv (\tcg_env -> tcg_env {
        -- Setting tcg_rdr_env to treat all exported entities from
        -- the implementing module as in scope improves error messages,
        -- as it reduces the amount of qualification we need.  Unfortunately,
        -- we still end up qualifying references to external modules
        -- (see bkpfail07 for an example); we'd need to record more
        -- information in ModIface to solve this.
        tcg_rdr_env = tcg_rdr_env tcg_env `plusGlobalRdrEnv` impl_gr,
        tcg_imports = tcg_imports tcg_env `plusImportAvails` avails,
        -- This is here so that when we call 'lookupFixityRn' for something
        -- directly implemented by the module, we grab the right thing
        tcg_fix_env = fix_env
        }) $ do

    -- STEP 2: Load the *unrenamed, uninstantiated* interface for
    -- the ORIGINAL signature.  We are going to eventually rename it,
    -- but we must proceed slowly, because it is NOT known if the
    -- instantiation is correct.
    let sig_mod = mkModule (IndefiniteUnitId uid) mod_name
        isig_mod = fst (splitModuleInsts sig_mod)
    mb_isig_iface <- findAndReadIface (text "checkImplements 2") isig_mod sig_mod False
    isig_iface <- case mb_isig_iface of
        Succeeded (iface, _) -> return iface
        Failed err -> failWithTc $
            hang (text "Could not find hi interface for signature" <+>
                  quotes (ppr isig_mod) <> colon) 4 err

    -- STEP 3: Check that the implementing interface exports everything
    -- we need.  (Notice we IGNORE the Modules in the AvailInfos.)
    forM_ (exportOccs (mi_exports isig_iface)) $ \occ ->
        case lookupGlobalRdrEnv impl_gr occ of
            [] -> addErr $ quotes (ppr occ)
                    <+> text "is exported by the hsig file, but not"
                    <+> text "exported by the implementing module"
                    <+> quotes (ppr impl_mod)
            _ -> return ()
    failIfErrsM

    -- STEP 4: Now that the export is complete, rename the interface...
    sig_iface <- tcRnModIface insts (Just nsubst) isig_iface

    -- STEP 5: ...and typecheck it.  (Note that in both cases, the nsubst
    -- lets us determine how top-level identifiers should be handled.)
    sig_details <- initIfaceTcRn $ typecheckIfaceForInstantiate nsubst sig_iface

    -- STEP 6: Check that it's sufficient
    tcg_env <- getGblEnv
    checkHsigIface tcg_env impl_gr sig_iface sig_details

    -- STEP 7: Return the updated 'TcGblEnv' with the signature exports,
    -- so we write them out.
    return tcg_env {
        tcg_exports = mi_exports sig_iface
        }

-- | Given 'tcg_mod', instantiate a 'ModIface' from the indefinite
-- library to use the actual implementations of the relevant entities,
-- checking that the implementation matches the signature.
instantiateSignature :: TcRn TcGblEnv
instantiateSignature = do
    tcg_env <- getGblEnv
    dflags <- getDynFlags
    let outer_mod = tcg_mod tcg_env
        inner_mod = tcg_semantic_mod tcg_env
    -- TODO: setup the local RdrEnv so the error messages look a little better.
    -- But this information isn't stored anywhere. Should we RETYPECHECK
    -- the local one just to get the information?  Hmm...
    MASSERT( moduleUnitId outer_mod == thisPackage dflags )
    inner_mod `checkImplements`
        IndefModule
            (newIndefUnitId (thisComponentId dflags)
                            (thisUnitIdInsts dflags))
            (moduleName outer_mod)