basicTypes/PatSyn.lhs

% % (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1998 % \section[PatSyn]{@PatSyn@: Pattern synonyms} \begin{code}


module PatSyn (
        -- * Main data types
        PatSyn, mkPatSyn,

        -- ** Type deconstruction
        patSynId, patSynType, patSynArity, patSynIsInfix,
        patSynArgs, patSynArgTys, patSynTyDetails,
        patSynWrapper, patSynMatcher,
        patSynExTyVars, patSynSig, patSynInstArgTys
    ) where

#include "HsVersions.h"

import Type
import Name
import Outputable
import Unique
import Util
import BasicTypes
import FastString
import Var
import Id
import TcType
import HsBinds( HsPatSynDetails(..) )

import qualified Data.Data as Data
import qualified Data.Typeable
import Data.Function

\end{code} Pattern synonym representation ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider the following pattern synonym declaration pattern P x = MkT [x] (Just 42) where data T a where MkT :: (Show a, Ord b) => [b] -> a -> T a so pattern P has type b -> T (Maybe t) with the following typeclass constraints: provides: (Show (Maybe t), Ord b) requires: (Eq t, Num t) In this case, the fields of MkPatSyn will be set as follows: psArgs = [x :: b] psArity = 1 psInfix = False psUnivTyVars = [t] psExTyVars = [b] psTheta = ((Show (Maybe t), Ord b), (Eq t, Num t)) psOrigResTy = T (Maybe t) %************************************************************************ %* * \subsection{Pattern synonyms} %* * %************************************************************************ \begin{code}

-- | A pattern synonym
data PatSyn
  = MkPatSyn {
        psId          :: Id,
        psUnique      :: Unique,                 -- Cached from Name
        psMatcher     :: Id,
        psWrapper     :: Maybe Id,

        psArgs        :: [Var],
        psArity       :: Arity,                  -- == length psArgs
        psInfix       :: Bool,                   -- True <=> declared infix

        psUnivTyVars  :: [TyVar],                -- Universially-quantified type variables
        psExTyVars    :: [TyVar],                -- Existentially-quantified type vars
        psTheta       :: (ThetaType, ThetaType), -- Provided and required dictionaries
        psOrigResTy   :: Type
  }
  deriving Data.Typeable.Typeable

\end{code} %************************************************************************ %* * \subsection{Instances} %* * %************************************************************************ \begin{code}

instance Eq PatSyn where
    (==) = (==) `on` getUnique
    (/=) = (/=) `on` getUnique

instance Ord PatSyn where
    (<=) = (<=) `on` getUnique
    (<) = (<) `on` getUnique
    (>=) = (>=) `on` getUnique
    (>) = (>) `on` getUnique
    compare = compare `on` getUnique

instance Uniquable PatSyn where
    getUnique = psUnique

instance NamedThing PatSyn where
    getName = getName . psId

instance Outputable PatSyn where
    ppr = ppr . getName

instance OutputableBndr PatSyn where
    pprInfixOcc = pprInfixName . getName
    pprPrefixOcc = pprPrefixName . getName

instance Data.Data PatSyn where
    -- don't traverse?
    toConstr _   = abstractConstr "PatSyn"
    gunfold _ _  = error "gunfold"
    dataTypeOf _ = mkNoRepType "PatSyn"

\end{code} %************************************************************************ %* * \subsection{Construction} %* * %************************************************************************ \begin{code}

-- | Build a new pattern synonym
mkPatSyn :: Name
         -> Bool       -- ^ Is the pattern synonym declared infix?
         -> [Var]      -- ^ Original arguments
         -> [TyVar]    -- ^ Universially-quantified type variables
         -> [TyVar]    -- ^ Existentially-quantified type variables
         -> ThetaType  -- ^ Wanted dicts
         -> ThetaType  -- ^ Given dicts
         -> Type       -- ^ Original result type
         -> Id         -- ^ Name of matcher
         -> Maybe Id   -- ^ Name of wrapper
         -> PatSyn
mkPatSyn name declared_infix orig_args
         univ_tvs ex_tvs
         prov_theta req_theta
         orig_res_ty
         matcher wrapper
    = MkPatSyn {psId = id, psUnique = getUnique name,
                psUnivTyVars = univ_tvs, psExTyVars = ex_tvs,
                psTheta = (prov_theta, req_theta),
                psInfix = declared_infix,
                psArgs = orig_args,
                psArity = length orig_args,
                psOrigResTy = orig_res_ty,
                psMatcher = matcher,
                psWrapper = wrapper }
  where
    pat_ty = mkSigmaTy univ_tvs req_theta $
             mkSigmaTy ex_tvs prov_theta $
             mkFunTys (map varType orig_args) orig_res_ty
    id = mkLocalId name pat_ty

\end{code} \begin{code}

-- | The 'Name' of the 'PatSyn', giving it a unique, rooted identification
patSynId :: PatSyn -> Id
patSynId = psId

patSynType :: PatSyn -> Type
patSynType = psOrigResTy

-- | Should the 'PatSyn' be presented infix?
patSynIsInfix :: PatSyn -> Bool
patSynIsInfix = psInfix

-- | Arity of the pattern synonym
patSynArity :: PatSyn -> Arity
patSynArity = psArity

patSynArgs :: PatSyn -> [Var]
patSynArgs = psArgs

patSynArgTys :: PatSyn -> [Type]
patSynArgTys = map varType . patSynArgs

patSynTyDetails :: PatSyn -> HsPatSynDetails Type
patSynTyDetails ps = case (patSynIsInfix ps, patSynArgTys ps) of
    (True, [left, right]) -> InfixPatSyn left right
    (_, tys) -> PrefixPatSyn tys

patSynExTyVars :: PatSyn -> [TyVar]
patSynExTyVars = psExTyVars

patSynSig :: PatSyn -> ([TyVar], [TyVar], (ThetaType, ThetaType))
patSynSig ps = (psUnivTyVars ps, psExTyVars ps, psTheta ps)

patSynWrapper :: PatSyn -> Maybe Id
patSynWrapper = psWrapper

patSynMatcher :: PatSyn -> Id
patSynMatcher = psMatcher

patSynInstArgTys :: PatSyn -> [Type] -> [Type]
patSynInstArgTys ps inst_tys
  = ASSERT2( length tyvars == length inst_tys
          , ptext (sLit "patSynInstArgTys") <+> ppr ps $$ ppr tyvars $$ ppr inst_tys )
    map (substTyWith tyvars inst_tys) arg_tys
  where
    (univ_tvs, ex_tvs, _) = patSynSig ps
    arg_tys = map varType (psArgs ps)
    tyvars = univ_tvs ++ ex_tvs

\end{code}