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

{-# LANGUAGE CPP #-}

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

#include "HsVersions.h"

import GhcPrelude

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

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


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

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

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

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

        ; SDoc -> TcRnIf m n ()
forall m n. SDoc -> TcRnIf m n ()
traceIf (String -> SDoc
text "buildDataCon 1" SDoc -> SDoc -> SDoc
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
src_name)
        ; UniqSupply
us <- TcRnIf m n UniqSupply
forall gbl lcl. TcRnIf gbl lcl UniqSupply
newUniqueSupply
        ; DynFlags
dflags <- IOEnv (Env m n) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
        ; let stupid_ctxt :: [Type]
stupid_ctxt = TyCon -> [Type] -> [TyVar] -> [Type]
mkDataConStupidTheta TyCon
rep_tycon [Type]
arg_tys [TyVar]
univ_tvs
              tag :: ConTag
tag = NameEnv ConTag -> Name -> ConTag
forall a. NameEnv a -> Name -> a
lookupNameEnv_NF NameEnv ConTag
tag_map Name
src_name
              -- See Note [Constructor tag allocation], fixes #14657
              data_con :: DataCon
data_con = Name
-> Bool
-> Name
-> [HsSrcBang]
-> [FieldLabel]
-> [TyVar]
-> [TyVar]
-> [TyVarBinder]
-> [EqSpec]
-> [Type]
-> [Type]
-> Type
-> RuntimeRepInfo
-> TyCon
-> ConTag
-> [Type]
-> TyVar
-> DataConRep
-> DataCon
mkDataCon Name
src_name Bool
declared_infix Name
prom_info
                                   [HsSrcBang]
src_bangs [FieldLabel]
field_lbls
                                   [TyVar]
univ_tvs [TyVar]
ex_tvs [TyVarBinder]
user_tvbs [EqSpec]
eq_spec [Type]
ctxt
                                   [Type]
arg_tys Type
res_ty RuntimeRepInfo
NoRRI TyCon
rep_tycon ConTag
tag
                                   [Type]
stupid_ctxt TyVar
dc_wrk DataConRep
dc_rep
              dc_wrk :: TyVar
dc_wrk = Name -> DataCon -> TyVar
mkDataConWorkId Name
work_name DataCon
data_con
              dc_rep :: DataConRep
dc_rep = UniqSupply -> UniqSM DataConRep -> DataConRep
forall a. UniqSupply -> UniqSM a -> a
initUs_ UniqSupply
us (DynFlags
-> FamInstEnvs
-> Name
-> Maybe [HsImplBang]
-> DataCon
-> UniqSM DataConRep
mkDataConRep DynFlags
dflags FamInstEnvs
fam_envs Name
wrap_name
                                                Maybe [HsImplBang]
impl_bangs DataCon
data_con)

        ; SDoc -> TcRnIf m n ()
forall m n. SDoc -> TcRnIf m n ()
traceIf (String -> SDoc
text "buildDataCon 2" SDoc -> SDoc -> SDoc
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
src_name)
        ; DataCon -> TcRnIf m n DataCon
forall (m :: * -> *) a. Monad m => a -> m a
return DataCon
data_con }


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

    arg_tyvars :: VarSet
arg_tyvars      = [Type] -> VarSet
tyCoVarsOfTypes [Type]
arg_tys
    in_arg_tys :: Type -> Bool
in_arg_tys pred :: Type
pred = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ VarSet -> Bool
isEmptyVarSet (VarSet -> Bool) -> VarSet -> Bool
forall a b. (a -> b) -> a -> b
$
                      Type -> VarSet
tyCoVarsOfType Type
pred VarSet -> VarSet -> VarSet
`intersectVarSet` VarSet
arg_tyvars


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

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


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

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

buildClass :: Name
-> [TyConBinder]
-> [Role]
-> [FunDep TyVar]
-> Maybe
     ([Type], [ClassATItem], [KnotTied MethInfo], ClassMinimalDef)
-> TcRnIf m n Class
buildClass tycon_name :: Name
tycon_name binders :: [TyConBinder]
binders roles :: [Role]
roles fds :: [FunDep TyVar]
fds Nothing
  = (Class -> TcRnIf m n Class) -> TcRnIf m n Class
forall a env. (a -> IOEnv env a) -> IOEnv env a
fixM  ((Class -> TcRnIf m n Class) -> TcRnIf m n Class)
-> (Class -> TcRnIf m n Class) -> TcRnIf m n Class
forall a b. (a -> b) -> a -> b
$ \ rec_clas :: Class
rec_clas ->       -- Only name generation inside loop
    do  { SDoc -> TcRnIf m n ()
forall m n. SDoc -> TcRnIf m n ()
traceIf (String -> SDoc
text "buildClass")

        ; Name
tc_rep_name  <- Name -> TcRnIf m n Name
forall gbl lcl. Name -> TcRnIf gbl lcl Name
newTyConRepName Name
tycon_name
        ; let univ_bndrs :: [TyVarBinder]
univ_bndrs = [TyConBinder] -> [TyVarBinder]
tyConTyVarBinders [TyConBinder]
binders
              univ_tvs :: [TyVar]
univ_tvs   = [TyVarBinder] -> [TyVar]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [TyVarBinder]
univ_bndrs
              tycon :: TyCon
tycon = Name
-> [TyConBinder] -> [Role] -> AlgTyConRhs -> Class -> Name -> TyCon
mkClassTyCon Name
tycon_name [TyConBinder]
binders [Role]
roles
                                   AlgTyConRhs
AbstractTyCon Class
rec_clas Name
tc_rep_name
              result :: Class
result = Name -> [TyVar] -> [FunDep TyVar] -> TyCon -> Class
mkAbstractClass Name
tycon_name [TyVar]
univ_tvs [FunDep TyVar]
fds TyCon
tycon
        ; SDoc -> TcRnIf m n ()
forall m n. SDoc -> TcRnIf m n ()
traceIf (String -> SDoc
text "buildClass" SDoc -> SDoc -> SDoc
<+> TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tycon)
        ; Class -> TcRnIf m n Class
forall (m :: * -> *) a. Monad m => a -> m a
return Class
result }

buildClass tycon_name :: Name
tycon_name binders :: [TyConBinder]
binders roles :: [Role]
roles fds :: [FunDep TyVar]
fds
           (Just (sc_theta :: [Type]
sc_theta, at_items :: [ClassATItem]
at_items, sig_stuff :: [KnotTied MethInfo]
sig_stuff, mindef :: ClassMinimalDef
mindef))
  = (Class -> TcRnIf m n Class) -> TcRnIf m n Class
forall a env. (a -> IOEnv env a) -> IOEnv env a
fixM  ((Class -> TcRnIf m n Class) -> TcRnIf m n Class)
-> (Class -> TcRnIf m n Class) -> TcRnIf m n Class
forall a b. (a -> b) -> a -> b
$ \ rec_clas :: Class
rec_clas ->       -- Only name generation inside loop
    do  { SDoc -> TcRnIf m n ()
forall m n. SDoc -> TcRnIf m n ()
traceIf (String -> SDoc
text "buildClass")

        ; Name
datacon_name <- Name -> (OccName -> OccName) -> TcRnIf m n Name
forall m n. Name -> (OccName -> OccName) -> TcRnIf m n Name
newImplicitBinder Name
tycon_name OccName -> OccName
mkClassDataConOcc
        ; Name
tc_rep_name  <- Name -> TcRnIf m n Name
forall gbl lcl. Name -> TcRnIf gbl lcl Name
newTyConRepName Name
tycon_name

        ; [ClassOpItem]
op_items <- (KnotTied MethInfo -> IOEnv (Env m n) ClassOpItem)
-> [KnotTied MethInfo] -> IOEnv (Env m n) [ClassOpItem]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Class -> KnotTied MethInfo -> IOEnv (Env m n) ClassOpItem
forall n m. Class -> KnotTied MethInfo -> TcRnIf n m ClassOpItem
mk_op_item Class
rec_clas) [KnotTied MethInfo]
sig_stuff
                        -- Build the selector id and default method id

              -- Make selectors for the superclasses
        ; [Name]
sc_sel_names <- (ConTag -> TcRnIf m n Name) -> [ConTag] -> IOEnv (Env m n) [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM  (Name -> (OccName -> OccName) -> TcRnIf m n Name
forall m n. Name -> (OccName -> OccName) -> TcRnIf m n Name
newImplicitBinder Name
tycon_name ((OccName -> OccName) -> TcRnIf m n Name)
-> (ConTag -> OccName -> OccName) -> ConTag -> TcRnIf m n Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConTag -> OccName -> OccName
mkSuperDictSelOcc)
                                ([Type] -> [ConTag] -> [ConTag]
forall b a. [b] -> [a] -> [a]
takeList [Type]
sc_theta [ConTag
fIRST_TAG..])
        ; let sc_sel_ids :: [TyVar]
sc_sel_ids = [ Name -> Class -> TyVar
mkDictSelId Name
sc_name Class
rec_clas
                           | Name
sc_name <- [Name]
sc_sel_names]
              -- We number off the Dict superclass selectors, 1, 2, 3 etc so that we
              -- can construct names for the selectors. Thus
              --      class (C a, C b) => D a b where ...
              -- gives superclass selectors
              --      D_sc1, D_sc2
              -- (We used to call them D_C, but now we can have two different
              --  superclasses both called C!)

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

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

        ; Name
rep_nm   <- Name -> TcRnIf m n Name
forall gbl lcl. Name -> TcRnIf gbl lcl Name
newTyConRepName Name
datacon_name
        ; DataCon
dict_con <- FamInstEnvs
-> Name
-> Bool
-> Name
-> [HsSrcBang]
-> Maybe [HsImplBang]
-> [FieldLabel]
-> [TyVar]
-> [TyVar]
-> [TyVarBinder]
-> [EqSpec]
-> [Type]
-> [Type]
-> Type
-> TyCon
-> NameEnv ConTag
-> TcRnIf m n DataCon
forall m n.
FamInstEnvs
-> Name
-> Bool
-> Name
-> [HsSrcBang]
-> Maybe [HsImplBang]
-> [FieldLabel]
-> [TyVar]
-> [TyVar]
-> [TyVarBinder]
-> [EqSpec]
-> [Type]
-> [Type]
-> Type
-> TyCon
-> NameEnv ConTag
-> TcRnIf m n DataCon
buildDataCon (String -> FamInstEnvs
forall a. String -> a
panic "buildClass: FamInstEnvs")
                                   Name
datacon_name
                                   Bool
False        -- Not declared infix
                                   Name
rep_nm
                                   ((Name -> HsSrcBang) -> [Name] -> [HsSrcBang]
forall a b. (a -> b) -> [a] -> [b]
map (HsSrcBang -> Name -> HsSrcBang
forall a b. a -> b -> a
const HsSrcBang
no_bang) [Name]
args)
                                   ([HsImplBang] -> Maybe [HsImplBang]
forall a. a -> Maybe a
Just ((Name -> HsImplBang) -> [Name] -> [HsImplBang]
forall a b. (a -> b) -> [a] -> [b]
map (HsImplBang -> Name -> HsImplBang
forall a b. a -> b -> a
const HsImplBang
HsLazy) [Name]
args))
                                   [{- No fields -}]
                                   [TyVar]
univ_tvs
                                   [{- no existentials -}]
                                   [TyVarBinder]
univ_bndrs
                                   [{- No GADT equalities -}]
                                   [{- No theta -}]
                                   [Type]
arg_tys
                                   (TyCon -> [Type] -> Type
mkTyConApp TyCon
rec_tycon ([TyVar] -> [Type]
mkTyVarTys [TyVar]
univ_tvs))
                                   TyCon
rec_tycon
                                   (TyCon -> NameEnv ConTag
mkTyConTagMap TyCon
rec_tycon)

        ; AlgTyConRhs
rhs <- case () of
                  _ | Bool
use_newtype
                    -> Name -> TyCon -> DataCon -> TcRnIf m n AlgTyConRhs
forall m n. Name -> TyCon -> DataCon -> TcRnIf m n AlgTyConRhs
mkNewTyConRhs Name
tycon_name TyCon
rec_tycon DataCon
dict_con
                    | Name -> Bool
isCTupleTyConName Name
tycon_name
                    -> AlgTyConRhs -> TcRnIf m n AlgTyConRhs
forall (m :: * -> *) a. Monad m => a -> m a
return (TupleTyCon :: DataCon -> TupleSort -> AlgTyConRhs
TupleTyCon { data_con :: DataCon
data_con = DataCon
dict_con
                                          , tup_sort :: TupleSort
tup_sort = TupleSort
ConstraintTuple })
                    | Bool
otherwise
                    -> AlgTyConRhs -> TcRnIf m n AlgTyConRhs
forall (m :: * -> *) a. Monad m => a -> m a
return ([DataCon] -> AlgTyConRhs
mkDataTyConRhs [DataCon
dict_con])

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

              ; result :: Class
result = Name
-> [TyVar]
-> [FunDep TyVar]
-> [Type]
-> [TyVar]
-> [ClassATItem]
-> [ClassOpItem]
-> ClassMinimalDef
-> TyCon
-> Class
mkClass Name
tycon_name [TyVar]
univ_tvs [FunDep TyVar]
fds
                                 [Type]
sc_theta [TyVar]
sc_sel_ids [ClassATItem]
at_items
                                 [ClassOpItem]
op_items ClassMinimalDef
mindef TyCon
tycon
              }
        ; SDoc -> TcRnIf m n ()
forall m n. SDoc -> TcRnIf m n ()
traceIf (String -> SDoc
text "buildClass" SDoc -> SDoc -> SDoc
<+> TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tycon)
        ; Class -> TcRnIf m n Class
forall (m :: * -> *) a. Monad m => a -> m a
return Class
result }
  where
    no_bang :: HsSrcBang
no_bang = SourceText -> SrcUnpackedness -> SrcStrictness -> HsSrcBang
HsSrcBang SourceText
NoSourceText SrcUnpackedness
NoSrcUnpack SrcStrictness
NoSrcStrict

    mk_op_item :: Class -> TcMethInfo -> TcRnIf n m ClassOpItem
    mk_op_item :: Class -> KnotTied MethInfo -> TcRnIf n m ClassOpItem
mk_op_item rec_clas :: Class
rec_clas (op_name :: Name
op_name, _, dm_spec :: Maybe (DefMethSpec (SrcSpan, Type))
dm_spec)
      = do { Maybe (Name, DefMethSpec Type)
dm_info <- Name
-> Maybe (DefMethSpec (SrcSpan, Type))
-> TcRnIf n m (Maybe (Name, DefMethSpec Type))
forall n m.
Name
-> Maybe (DefMethSpec (SrcSpan, Type))
-> TcRnIf n m (Maybe (Name, DefMethSpec Type))
mk_dm_info Name
op_name Maybe (DefMethSpec (SrcSpan, Type))
dm_spec
           ; ClassOpItem -> TcRnIf n m ClassOpItem
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Class -> TyVar
mkDictSelId Name
op_name Class
rec_clas, Maybe (Name, DefMethSpec Type)
dm_info) }

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

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

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

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

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

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

-- | Make the 'TyConRepName' for this 'TyCon'
newTyConRepName :: Name -> TcRnIf gbl lcl TyConRepName
newTyConRepName :: Name -> TcRnIf gbl lcl Name
newTyConRepName tc_name :: Name
tc_name
  | Just mod :: Module
mod <- Name -> Maybe Module
nameModule_maybe Name
tc_name
  , (mod :: Module
mod, occ :: OccName
occ) <- Module -> OccName -> (Module, OccName)
tyConRepModOcc Module
mod (Name -> OccName
nameOccName Name
tc_name)
  = Module -> OccName -> SrcSpan -> TcRnIf gbl lcl Name
forall a b. Module -> OccName -> SrcSpan -> TcRnIf a b Name
newGlobalBinder Module
mod OccName
occ SrcSpan
noSrcSpan
  | Bool
otherwise
  = Name -> (OccName -> OccName) -> TcRnIf gbl lcl Name
forall m n. Name -> (OccName -> OccName) -> TcRnIf m n Name
newImplicitBinder Name
tc_name OccName -> OccName
mkTyConRepOcc