{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}

-- | COMPLETE signature
module GHC.Types.CompleteMatch
  ( CompleteMatchX(..)
  , CompleteMatch, CompleteMatches
  , DsCompleteMatch, DsCompleteMatches
  , mkCompleteMatch, vanillaCompleteMatch
  , completeMatchAppliesAtType
  ) where

import GHC.Prelude
import GHC.Core.TyCo.Rep
import GHC.Types.Unique
import GHC.Core.ConLike
import GHC.Core.TyCon
import GHC.Core.Type ( splitTyConApp_maybe )
import GHC.Types.Name ( Name )
import GHC.Types.Unique.DSet
import GHC.Utils.Outputable

type CompleteMatch   = CompleteMatchX Name
type DsCompleteMatch = CompleteMatchX ConLike

type CompleteMatches   = [CompleteMatch]
type DsCompleteMatches = [DsCompleteMatch]

-- | A list of conlikes which represents a complete pattern match.
-- These arise from @COMPLETE@ signatures.
-- See also Note [Implementation of COMPLETE pragmas].
data CompleteMatchX con = CompleteMatch
  { forall con. CompleteMatchX con -> UniqDSet con
cmConLikes :: UniqDSet con  -- ^ The set of constructor names
  , forall con. CompleteMatchX con -> Maybe Name
cmResultTyCon :: Maybe Name -- ^ The optional, concrete result TyCon name the set applies to
  }
  deriving CompleteMatchX con -> CompleteMatchX con -> Bool
(CompleteMatchX con -> CompleteMatchX con -> Bool)
-> (CompleteMatchX con -> CompleteMatchX con -> Bool)
-> Eq (CompleteMatchX con)
forall con. CompleteMatchX con -> CompleteMatchX con -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall con. CompleteMatchX con -> CompleteMatchX con -> Bool
== :: CompleteMatchX con -> CompleteMatchX con -> Bool
$c/= :: forall con. CompleteMatchX con -> CompleteMatchX con -> Bool
/= :: CompleteMatchX con -> CompleteMatchX con -> Bool
Eq

mkCompleteMatch :: UniqDSet con -> Maybe Name -> CompleteMatchX con
mkCompleteMatch :: forall con. UniqDSet con -> Maybe Name -> CompleteMatchX con
mkCompleteMatch UniqDSet con
nms Maybe Name
mb_tc = CompleteMatch { cmConLikes :: UniqDSet con
cmConLikes = UniqDSet con
nms, cmResultTyCon :: Maybe Name
cmResultTyCon = Maybe Name
mb_tc }

vanillaCompleteMatch :: UniqDSet con -> CompleteMatchX con
vanillaCompleteMatch :: forall con. UniqDSet con -> CompleteMatchX con
vanillaCompleteMatch UniqDSet con
nms = UniqDSet con -> Maybe Name -> CompleteMatchX con
forall con. UniqDSet con -> Maybe Name -> CompleteMatchX con
mkCompleteMatch UniqDSet con
nms Maybe Name
forall a. Maybe a
Nothing

instance Outputable con => Outputable (CompleteMatchX con) where
  ppr :: CompleteMatchX con -> SDoc
ppr (CompleteMatch UniqDSet con
cls Maybe Name
mty) = case Maybe Name
mty of
    Maybe Name
Nothing -> UniqDSet con -> SDoc
forall a. Outputable a => a -> SDoc
ppr UniqDSet con
cls
    Just Name
ty -> UniqDSet con -> SDoc
forall a. Outputable a => a -> SDoc
ppr UniqDSet con
cls SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"@" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
ty)

-- | Does this 'COMPLETE' set apply at this type?
--
-- See the part about "result type constructors" in
-- Note [Implementation of COMPLETE pragmas] in GHC.HsToCore.Pmc.Solver.
completeMatchAppliesAtType :: Type -> CompleteMatchX con -> Bool
completeMatchAppliesAtType :: forall con. Type -> CompleteMatchX con -> Bool
completeMatchAppliesAtType Type
ty CompleteMatchX con
cm = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all @Maybe Unique -> Bool
ty_matches (Name -> Unique
forall a. Uniquable a => a -> Unique
getUnique (Name -> Unique) -> Maybe Name -> Maybe Unique
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CompleteMatchX con -> Maybe Name
forall con. CompleteMatchX con -> Maybe Name
cmResultTyCon CompleteMatchX con
cm)
  where
    ty_matches :: Unique -> Bool
    ty_matches :: Unique -> Bool
ty_matches Unique
sig_tc
      | Just (TyCon
tc, [Type]
_arg_tys) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty
      , TyCon
tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
sig_tc
      Bool -> Bool -> Bool
|| Unique
sig_tc Unique -> TyCon -> Bool
`is_family_ty_con_of` TyCon
tc
         -- #24326: sig_tc might be the data Family TyCon of the representation
         --         TyCon tc -- this CompleteMatch still applies
      = Bool
True
      | Bool
otherwise
      = Bool
False
    Unique
fam_tc is_family_ty_con_of :: Unique -> TyCon -> Bool
`is_family_ty_con_of` TyCon
repr_tc =
      case (TyCon, [Type]) -> TyCon
forall a b. (a, b) -> a
fst ((TyCon, [Type]) -> TyCon) -> Maybe (TyCon, [Type]) -> Maybe TyCon
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TyCon -> Maybe (TyCon, [Type])
tyConFamInst_maybe TyCon
repr_tc of
        Just TyCon
tc -> TyCon
tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
fam_tc
        Maybe TyCon
Nothing -> Bool
False