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



module GHC.Core.Class (
        Class,
        ClassOpItem,
        ClassATItem(..), ATValidityInfo(..),
        ClassMinimalDef,
        DefMethInfo, pprDefMethInfo,

        FunDep, pprFundeps, pprFunDep,

        mkClass, mkAbstractClass, classTyVars, classArity,
        classKey, className, classATs, classATItems, classTyCon, classMethods,
        classOpItems, classBigSig, classExtraBigSig, classTvsFds, classSCTheta,
        classAllSelIds, classSCSelId, classSCSelIds, classMinimalDef, classHasFds,
        isAbstractClass,
    ) where

import GHC.Prelude

import {-# SOURCE #-} GHC.Core.TyCon    ( TyCon )
import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type, PredType )
import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprType )
import GHC.Types.Var
import GHC.Types.Name
import GHC.Types.Basic
import GHC.Types.Unique
import GHC.Utils.Misc
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Types.SrcLoc
import GHC.Utils.Outputable
import GHC.Data.BooleanFormula (BooleanFormula, mkTrue)

import qualified Data.Data as Data

{-
************************************************************************
*                                                                      *
\subsection[Class-basic]{@Class@: basic definition}
*                                                                      *
************************************************************************

A @Class@ corresponds to a Greek kappa in the static semantics:
-}

data Class
  = Class {
        Class -> TyCon
classTyCon :: TyCon,    -- The data type constructor for
                                -- dictionaries of this class
                                -- See Note [ATyCon for classes] in GHC.Core.TyCo.Rep

        Class -> Name
className :: Name,              -- Just the cached name of the TyCon
        Class -> Unique
classKey  :: Unique,            -- Cached unique of TyCon

        Class -> [TyVar]
classTyVars  :: [TyVar],        -- The class kind and type variables;
                                        -- identical to those of the TyCon
           -- If you want visibility info, look at the classTyCon
           -- This field is redundant because it's duplicated in the
           -- classTyCon, but classTyVars is used quite often, so maybe
           -- it's a bit faster to cache it here

        Class -> [FunDep TyVar]
classFunDeps :: [FunDep TyVar],  -- The functional dependencies

        Class -> ClassBody
classBody :: ClassBody -- Superclasses, ATs, methods

     }

--  | e.g.
--
-- >  class C a b c | a b -> c, a c -> b where...
--
--  Here fun-deps are [([a,b],[c]), ([a,c],[b])]
--
--  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnRarrow'',

-- For details on above see Note [exact print annotations] in GHC.Parser.Annotation
type FunDep a = ([a],[a])

type ClassOpItem = (Id, DefMethInfo)
        -- Selector function; contains unfolding
        -- Default-method info

type DefMethInfo = Maybe (Name, DefMethSpec Type)
   -- Nothing                    No default method
   -- Just ($dm, VanillaDM)      A polymorphic default method, name $dm
   -- Just ($gm, GenericDM ty)   A generic default method, name $gm, type ty
   --                              The generic dm type is *not* quantified
   --                              over the class variables; ie has the
   --                              class variables free

data ClassATItem
  = ATI TyCon         -- See Note [Associated type tyvar names]
        (Maybe (Type, ATValidityInfo))
                      -- Default associated type (if any) from this template
                      -- Note [Associated type defaults]

-- | Information about an associated type family default implementation. This
-- is used solely for validity checking.
-- See @Note [Type-checking default assoc decls]@ in "GHC.Tc.TyCl".
data ATValidityInfo
  = NoATVI               -- Used for associated type families that are imported
                         -- from another module, for which we don't need to
                         -- perform any validity checking.

  | ATVI SrcSpan [Type]  -- Used for locally defined associated type families.
                         -- The [Type] are the LHS patterns.

type ClassMinimalDef = BooleanFormula Name -- Required methods

data ClassBody
  = AbstractClass
  | ConcreteClass {
        -- Superclasses: eg: (F a ~ b, F b ~ G a, Eq a, Show b)
        -- We need value-level selectors for both the dictionary
        -- superclasses and the equality superclasses
        ClassBody -> [PredType]
cls_sc_theta :: [PredType],     -- Immediate superclasses,
        ClassBody -> [TyVar]
cls_sc_sel_ids :: [Id],          -- Selector functions to extract the
                                        --   superclasses from a
                                        --   dictionary of this class
        -- Associated types
        ClassBody -> [ClassATItem]
cls_ats :: [ClassATItem],  -- Associated type families

        -- Class operations (methods, not superclasses)
        ClassBody -> [ClassOpItem]
cls_ops :: [ClassOpItem],  -- Ordered by tag

        -- Minimal complete definition
        ClassBody -> ClassMinimalDef
cls_min_def :: ClassMinimalDef
    }
    -- TODO: maybe super classes should be allowed in abstract class definitions

classMinimalDef :: Class -> ClassMinimalDef
classMinimalDef :: Class -> ClassMinimalDef
classMinimalDef Class{ classBody :: Class -> ClassBody
classBody = ConcreteClass{ cls_min_def :: ClassBody -> ClassMinimalDef
cls_min_def = ClassMinimalDef
d } } = ClassMinimalDef
d
classMinimalDef Class
_ = ClassMinimalDef
forall a. BooleanFormula a
mkTrue -- TODO: make sure this is the right direction

{-
Note [Associated type defaults]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The following is an example of associated type defaults:
   class C a where
     data D a r

     type F x a b :: *
     type F p q r = (p,q)->r    -- Default

Note that

 * The TyCons for the associated types *share type variables* with the
   class, so that we can tell which argument positions should be
   instantiated in an instance decl.  (The first for 'D', the second
   for 'F'.)

 * We can have default definitions only for *type* families,
   not data families

 * In the default decl, the "patterns" should all be type variables,
   but (in the source language) they don't need to be the same as in
   the 'type' decl signature or the class.  It's more like a
   free-standing 'type instance' declaration.

 * HOWEVER, in the internal ClassATItem we rename the RHS to match the
   tyConTyVars of the family TyCon.  So in the example above we'd get
   a ClassATItem of
        ATI F ((x,a) -> b)
   So the tyConTyVars of the family TyCon bind the free vars of
   the default Type rhs

The @mkClass@ function fills in the indirect superclasses.

The SrcSpan is for the entire original declaration.
-}

mkClass :: Name -> [TyVar]
        -> [FunDep TyVar]
        -> [PredType] -> [Id]
        -> [ClassATItem]
        -> [ClassOpItem]
        -> ClassMinimalDef
        -> TyCon
        -> Class

mkClass :: Name
-> [TyVar]
-> [FunDep TyVar]
-> [PredType]
-> [TyVar]
-> [ClassATItem]
-> [ClassOpItem]
-> ClassMinimalDef
-> TyCon
-> Class
mkClass Name
cls_name [TyVar]
tyvars [FunDep TyVar]
fds [PredType]
super_classes [TyVar]
superdict_sels [ClassATItem]
at_stuff
        [ClassOpItem]
op_stuff ClassMinimalDef
mindef TyCon
tycon
  = Class { classKey :: Unique
classKey     = Name -> Unique
nameUnique Name
cls_name,
            className :: Name
className    = Name
cls_name,
                -- NB:  tyConName tycon = cls_name,
                -- But it takes a module loop to assert it here
            classTyVars :: [TyVar]
classTyVars  = [TyVar]
tyvars,
            classFunDeps :: [FunDep TyVar]
classFunDeps = [FunDep TyVar]
fds,
            classBody :: ClassBody
classBody = ConcreteClass {
                    cls_sc_theta :: [PredType]
cls_sc_theta = [PredType]
super_classes,
                    cls_sc_sel_ids :: [TyVar]
cls_sc_sel_ids = [TyVar]
superdict_sels,
                    cls_ats :: [ClassATItem]
cls_ats  = [ClassATItem]
at_stuff,
                    cls_ops :: [ClassOpItem]
cls_ops  = [ClassOpItem]
op_stuff,
                    cls_min_def :: ClassMinimalDef
cls_min_def = ClassMinimalDef
mindef
                },
            classTyCon :: TyCon
classTyCon   = TyCon
tycon }

mkAbstractClass :: Name -> [TyVar]
        -> [FunDep TyVar]
        -> TyCon
        -> Class

mkAbstractClass :: Name -> [TyVar] -> [FunDep TyVar] -> TyCon -> Class
mkAbstractClass Name
cls_name [TyVar]
tyvars [FunDep TyVar]
fds TyCon
tycon
  = Class { classKey :: Unique
classKey     = Name -> Unique
nameUnique Name
cls_name,
            className :: Name
className    = Name
cls_name,
                -- NB:  tyConName tycon = cls_name,
                -- But it takes a module loop to assert it here
            classTyVars :: [TyVar]
classTyVars  = [TyVar]
tyvars,
            classFunDeps :: [FunDep TyVar]
classFunDeps = [FunDep TyVar]
fds,
            classBody :: ClassBody
classBody = ClassBody
AbstractClass,
            classTyCon :: TyCon
classTyCon   = TyCon
tycon }

{-
Note [Associated type tyvar names]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The TyCon of an associated type should use the same variable names as its
parent class. Thus
    class C a b where
      type F b x a :: *
We make F use the same Name for 'a' as C does, and similarly 'b'.

The reason for this is when checking instances it's easier to match
them up, to ensure they match.  Eg
    instance C Int [d] where
      type F [d] x Int = ....
we should make sure that the first and third args match the instance
header.

Having the same variables for class and tycon is also used in checkValidRoles
(in GHC.Tc.TyCl) when checking a class's roles.


************************************************************************
*                                                                      *
\subsection[Class-selectors]{@Class@: simple selectors}
*                                                                      *
************************************************************************

The rest of these functions are just simple selectors.
-}

classArity :: Class -> Arity
classArity :: Class -> Int
classArity Class
clas = [TyVar] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Class -> [TyVar]
classTyVars Class
clas)
        -- Could memoise this

classAllSelIds :: Class -> [Id]
-- Both superclass-dictionary and method selectors
classAllSelIds :: Class -> [TyVar]
classAllSelIds c :: Class
c@(Class { classBody :: Class -> ClassBody
classBody = ConcreteClass { cls_sc_sel_ids :: ClassBody -> [TyVar]
cls_sc_sel_ids = [TyVar]
sc_sels }})
  = [TyVar]
sc_sels [TyVar] -> [TyVar] -> [TyVar]
forall a. [a] -> [a] -> [a]
++ Class -> [TyVar]
classMethods Class
c
classAllSelIds Class
c = Bool -> [TyVar] -> [TyVar]
forall a. HasCallStack => Bool -> a -> a
assert ([TyVar] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Class -> [TyVar]
classMethods Class
c) ) []

classSCSelIds :: Class -> [Id]
-- Both superclass-dictionary and method selectors
classSCSelIds :: Class -> [TyVar]
classSCSelIds (Class { classBody :: Class -> ClassBody
classBody = ConcreteClass { cls_sc_sel_ids :: ClassBody -> [TyVar]
cls_sc_sel_ids = [TyVar]
sc_sels }})
  = [TyVar]
sc_sels
classSCSelIds Class
c = Bool -> [TyVar] -> [TyVar]
forall a. HasCallStack => Bool -> a -> a
assert ([TyVar] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Class -> [TyVar]
classMethods Class
c) ) []

classSCSelId :: Class -> Int -> Id
-- Get the n'th superclass selector Id
-- where n is 0-indexed, and counts
--    *all* superclasses including equalities
classSCSelId :: Class -> Int -> TyVar
classSCSelId (Class { classBody :: Class -> ClassBody
classBody = ConcreteClass { cls_sc_sel_ids :: ClassBody -> [TyVar]
cls_sc_sel_ids = [TyVar]
sc_sels } }) Int
n
  = Bool -> [TyVar] -> [TyVar]
forall a. HasCallStack => Bool -> a -> a
assert (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 Bool -> Bool -> Bool
&& [TyVar] -> Int -> Bool
forall a. [a] -> Int -> Bool
lengthExceeds [TyVar]
sc_sels Int
n )
    [TyVar]
sc_sels [TyVar] -> Int -> TyVar
forall a. HasCallStack => [a] -> Int -> a
!! Int
n
classSCSelId Class
c Int
n = String -> SDoc -> TyVar
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"classSCSelId" (Class -> SDoc
forall a. Outputable a => a -> SDoc
ppr Class
c SDoc -> SDoc -> SDoc
<+> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
n)

classMethods :: Class -> [Id]
classMethods :: Class -> [TyVar]
classMethods (Class { classBody :: Class -> ClassBody
classBody = ConcreteClass { cls_ops :: ClassBody -> [ClassOpItem]
cls_ops = [ClassOpItem]
op_stuff } })
  = [TyVar
op_sel | (TyVar
op_sel, DefMethInfo
_) <- [ClassOpItem]
op_stuff]
classMethods Class
_ = []

classOpItems :: Class -> [ClassOpItem]
classOpItems :: Class -> [ClassOpItem]
classOpItems (Class { classBody :: Class -> ClassBody
classBody = ConcreteClass { cls_ops :: ClassBody -> [ClassOpItem]
cls_ops = [ClassOpItem]
op_stuff }})
  = [ClassOpItem]
op_stuff
classOpItems Class
_ = []

classATs :: Class -> [TyCon]
classATs :: Class -> [TyCon]
classATs (Class { classBody :: Class -> ClassBody
classBody = ConcreteClass { cls_ats :: ClassBody -> [ClassATItem]
cls_ats = [ClassATItem]
at_stuff } })
  = [TyCon
tc | ATI TyCon
tc Maybe (PredType, ATValidityInfo)
_ <- [ClassATItem]
at_stuff]
classATs Class
_ = []

classATItems :: Class -> [ClassATItem]
classATItems :: Class -> [ClassATItem]
classATItems (Class { classBody :: Class -> ClassBody
classBody = ConcreteClass { cls_ats :: ClassBody -> [ClassATItem]
cls_ats = [ClassATItem]
at_stuff }})
  = [ClassATItem]
at_stuff
classATItems Class
_ = []

classSCTheta :: Class -> [PredType]
classSCTheta :: Class -> [PredType]
classSCTheta (Class { classBody :: Class -> ClassBody
classBody = ConcreteClass { cls_sc_theta :: ClassBody -> [PredType]
cls_sc_theta = [PredType]
theta_stuff }})
  = [PredType]
theta_stuff
classSCTheta Class
_ = []

classTvsFds :: Class -> ([TyVar], [FunDep TyVar])
classTvsFds :: Class -> ([TyVar], [FunDep TyVar])
classTvsFds Class
c = (Class -> [TyVar]
classTyVars Class
c, Class -> [FunDep TyVar]
classFunDeps Class
c)

classHasFds :: Class -> Bool
classHasFds :: Class -> Bool
classHasFds (Class { classFunDeps :: Class -> [FunDep TyVar]
classFunDeps = [FunDep TyVar]
fds }) = Bool -> Bool
not ([FunDep TyVar] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FunDep TyVar]
fds)

classBigSig :: Class -> ([TyVar], [PredType], [Id], [ClassOpItem])
classBigSig :: Class -> ([TyVar], [PredType], [TyVar], [ClassOpItem])
classBigSig (Class {classTyVars :: Class -> [TyVar]
classTyVars = [TyVar]
tyvars,
                    classBody :: Class -> ClassBody
classBody = ClassBody
AbstractClass})
  = ([TyVar]
tyvars, [], [], [])
classBigSig (Class {classTyVars :: Class -> [TyVar]
classTyVars = [TyVar]
tyvars,
                    classBody :: Class -> ClassBody
classBody = ConcreteClass {
                        cls_sc_theta :: ClassBody -> [PredType]
cls_sc_theta = [PredType]
sc_theta,
                        cls_sc_sel_ids :: ClassBody -> [TyVar]
cls_sc_sel_ids = [TyVar]
sc_sels,
                        cls_ops :: ClassBody -> [ClassOpItem]
cls_ops  = [ClassOpItem]
op_stuff
                    }})
  = ([TyVar]
tyvars, [PredType]
sc_theta, [TyVar]
sc_sels, [ClassOpItem]
op_stuff)

classExtraBigSig :: Class -> ([TyVar], [FunDep TyVar], [PredType], [Id], [ClassATItem], [ClassOpItem])
classExtraBigSig :: Class
-> ([TyVar], [FunDep TyVar], [PredType], [TyVar], [ClassATItem],
    [ClassOpItem])
classExtraBigSig (Class {classTyVars :: Class -> [TyVar]
classTyVars = [TyVar]
tyvars, classFunDeps :: Class -> [FunDep TyVar]
classFunDeps = [FunDep TyVar]
fundeps,
                         classBody :: Class -> ClassBody
classBody = ClassBody
AbstractClass})
  = ([TyVar]
tyvars, [FunDep TyVar]
fundeps, [], [], [], [])
classExtraBigSig (Class {classTyVars :: Class -> [TyVar]
classTyVars = [TyVar]
tyvars, classFunDeps :: Class -> [FunDep TyVar]
classFunDeps = [FunDep TyVar]
fundeps,
                         classBody :: Class -> ClassBody
classBody = ConcreteClass {
                             cls_sc_theta :: ClassBody -> [PredType]
cls_sc_theta = [PredType]
sc_theta, cls_sc_sel_ids :: ClassBody -> [TyVar]
cls_sc_sel_ids = [TyVar]
sc_sels,
                             cls_ats :: ClassBody -> [ClassATItem]
cls_ats = [ClassATItem]
ats, cls_ops :: ClassBody -> [ClassOpItem]
cls_ops = [ClassOpItem]
op_stuff
                         }})
  = ([TyVar]
tyvars, [FunDep TyVar]
fundeps, [PredType]
sc_theta, [TyVar]
sc_sels, [ClassATItem]
ats, [ClassOpItem]
op_stuff)

isAbstractClass :: Class -> Bool
isAbstractClass :: Class -> Bool
isAbstractClass Class{ classBody :: Class -> ClassBody
classBody = ClassBody
AbstractClass } = Bool
True
isAbstractClass Class
_ = Bool
False

{-
************************************************************************
*                                                                      *
\subsection[Class-instances]{Instance declarations for @Class@}
*                                                                      *
************************************************************************

We compare @Classes@ by their keys (which include @Uniques@).
-}

instance Eq Class where
    Class
c1 == :: Class -> Class -> Bool
== Class
c2 = Class -> Unique
classKey Class
c1 Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Class -> Unique
classKey Class
c2
    Class
c1 /= :: Class -> Class -> Bool
/= Class
c2 = Class -> Unique
classKey Class
c1 Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
/= Class -> Unique
classKey Class
c2

instance Uniquable Class where
    getUnique :: Class -> Unique
getUnique Class
c = Class -> Unique
classKey Class
c

instance NamedThing Class where
    getName :: Class -> Name
getName Class
clas = Class -> Name
className Class
clas

instance Outputable Class where
    ppr :: Class -> SDoc
ppr Class
c = Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Class -> Name
forall a. NamedThing a => a -> Name
getName Class
c)

pprDefMethInfo :: DefMethInfo -> SDoc
pprDefMethInfo :: DefMethInfo -> SDoc
pprDefMethInfo DefMethInfo
Nothing                  = SDoc
empty   -- No default method
pprDefMethInfo (Just (Name
n, DefMethSpec PredType
VanillaDM))    = String -> SDoc
text String
"Default method" SDoc -> SDoc -> SDoc
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n
pprDefMethInfo (Just (Name
n, GenericDM PredType
ty)) = String -> SDoc
text String
"Generic default method"
                                          SDoc -> SDoc -> SDoc
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> PredType -> SDoc
pprType PredType
ty

pprFundeps :: Outputable a => [FunDep a] -> SDoc
pprFundeps :: forall a. Outputable a => [FunDep a] -> SDoc
pprFundeps []  = SDoc
empty
pprFundeps [FunDep a]
fds = [SDoc] -> SDoc
hsep (SDoc
vbar SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
: SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma ((FunDep a -> SDoc) -> [FunDep a] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map FunDep a -> SDoc
forall a. Outputable a => FunDep a -> SDoc
pprFunDep [FunDep a]
fds))

pprFunDep :: Outputable a => FunDep a -> SDoc
pprFunDep :: forall a. Outputable a => FunDep a -> SDoc
pprFunDep ([a]
us, [a]
vs) = [SDoc] -> SDoc
hsep [[a] -> SDoc
forall a. Outputable a => [a] -> SDoc
interppSP [a]
us, SDoc
arrow, [a] -> SDoc
forall a. Outputable a => [a] -> SDoc
interppSP [a]
vs]

instance Data.Data Class where
    -- don't traverse?
    toConstr :: Class -> Constr
toConstr Class
_   = String -> Constr
abstractConstr String
"Class"
    gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Class
gunfold forall b r. Data b => c (b -> r) -> c r
_ forall r. r -> c r
_  = String -> Constr -> c Class
forall a. HasCallStack => String -> a
error String
"gunfold"
    dataTypeOf :: Class -> DataType
dataTypeOf Class
_ = String -> DataType
mkNoRepType String
"Class"