{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# OPTIONS_GHC -Wno-unrecognised-warning-flags -Wno-x-data-list-nonempty-unzip #-} {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 Pattern-matching constructors -} module GHC.HsToCore.Match.Constructor ( matchConFamily, matchPatSyn ) where import GHC.Prelude import {-# SOURCE #-} GHC.HsToCore.Match ( match ) import GHC.Hs import GHC.HsToCore.Binds import GHC.Core.ConLike import GHC.Tc.Utils.TcType import GHC.Core.Multiplicity import GHC.HsToCore.Monad import GHC.HsToCore.Utils import GHC.Core ( CoreExpr ) import GHC.Core.Make ( mkCoreLets ) import GHC.Utils.Misc import GHC.Types.Id import GHC.Types.Name.Env import GHC.Types.FieldLabel ( flSelector ) import GHC.Types.SrcLoc import GHC.Utils.Outputable import GHC.Utils.Panic import Control.Monad(liftM) import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NE {- We are confronted with the first column of patterns in a set of equations, all beginning with constructors from one ``family'' (e.g., @[]@ and @:@ make up the @List@ ``family''). We want to generate the alternatives for a @Case@ expression. There are several choices: \begin{enumerate} \item Generate an alternative for every constructor in the family, whether they are used in this set of equations or not; this is what the Wadler chapter does. \begin{description} \item[Advantages:] (a)~Simple. (b)~It may also be that large sparsely-used constructor families are mainly handled by the code for literals. \item[Disadvantages:] (a)~Not practical for large sparsely-used constructor families, e.g., the ASCII character set. (b)~Have to look up a list of what constructors make up the whole family. \end{description} \item Generate an alternative for each constructor used, then add a default alternative in case some constructors in the family weren't used. \begin{description} \item[Advantages:] (a)~Alternatives aren't generated for unused constructors. (b)~The STG is quite happy with defaults. (c)~No lookup in an environment needed. \item[Disadvantages:] (a)~A spurious default alternative may be generated. \end{description} \item ``Do it right:'' generate an alternative for each constructor used, and add a default alternative if all constructors in the family weren't used. \begin{description} \item[Advantages:] (a)~You will get cases with only one alternative (and no default), which should be amenable to optimisation. Tuples are a common example. \item[Disadvantages:] (b)~Have to look up constructor families in TDE (as above). \end{description} \end{enumerate} We are implementing the ``do-it-right'' option for now. The arguments to @matchConFamily@ are the same as to @match@; the extra @Int@ returned is the number of constructors in the family. The function @matchConFamily@ is concerned with this have-we-used-all-the-constructors? question; the local function @match_cons_used@ does all the real work. -} matchConFamily :: NonEmpty Id -> Type -> NonEmpty (NonEmpty EquationInfoNE) -> DsM (MatchResult CoreExpr) -- Each group of eqns is for a single constructor matchConFamily :: NonEmpty Id -> Type -> NonEmpty (NonEmpty EquationInfo) -> DsM (MatchResult CoreExpr) matchConFamily (Id var :| [Id] vars) Type ty NonEmpty (NonEmpty EquationInfo) groups = do let mult :: Type mult = Id -> Type idMult Id var -- Each variable in the argument list correspond to one column in the -- pattern matching equations. Its multiplicity is the context -- multiplicity of the pattern. We extract that multiplicity, so that -- 'matchOneconLike' knows the context multiplicity, in case it needs -- to come up with new variables. alts <- (NonEmpty EquationInfo -> IOEnv (Env DsGblEnv DsLclEnv) (CaseAlt DataCon)) -> NonEmpty (NonEmpty EquationInfo) -> IOEnv (Env DsGblEnv DsLclEnv) (NonEmpty (CaseAlt DataCon)) forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => (a -> m b) -> t a -> m (t b) forall (m :: * -> *) a b. Monad m => (a -> m b) -> NonEmpty a -> m (NonEmpty b) mapM ((CaseAlt ConLike -> CaseAlt DataCon) -> IOEnv (Env DsGblEnv DsLclEnv) (CaseAlt ConLike) -> IOEnv (Env DsGblEnv DsLclEnv) (CaseAlt DataCon) forall a b. (a -> b) -> IOEnv (Env DsGblEnv DsLclEnv) a -> IOEnv (Env DsGblEnv DsLclEnv) b forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap CaseAlt ConLike -> CaseAlt DataCon toRealAlt (IOEnv (Env DsGblEnv DsLclEnv) (CaseAlt ConLike) -> IOEnv (Env DsGblEnv DsLclEnv) (CaseAlt DataCon)) -> (NonEmpty EquationInfo -> IOEnv (Env DsGblEnv DsLclEnv) (CaseAlt ConLike)) -> NonEmpty EquationInfo -> IOEnv (Env DsGblEnv DsLclEnv) (CaseAlt DataCon) forall b c a. (b -> c) -> (a -> b) -> a -> c . [Id] -> Type -> Type -> NonEmpty EquationInfo -> IOEnv (Env DsGblEnv DsLclEnv) (CaseAlt ConLike) matchOneConLike [Id] vars Type ty Type mult) NonEmpty (NonEmpty EquationInfo) groups return (mkCoAlgCaseMatchResult var ty alts) where toRealAlt :: CaseAlt ConLike -> CaseAlt DataCon toRealAlt CaseAlt ConLike alt = case CaseAlt ConLike -> ConLike forall a. CaseAlt a -> a alt_pat CaseAlt ConLike alt of RealDataCon DataCon dcon -> CaseAlt ConLike alt{ alt_pat = dcon } ConLike _ -> String -> CaseAlt DataCon forall a. HasCallStack => String -> a panic String "matchConFamily: not RealDataCon" matchPatSyn :: NonEmpty Id -> Type -> NonEmpty EquationInfoNE -> DsM (MatchResult CoreExpr) matchPatSyn :: NonEmpty Id -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr) matchPatSyn (Id var :| [Id] vars) Type ty NonEmpty EquationInfo eqns = do let mult :: Type mult = Id -> Type idMult Id var alt <- (CaseAlt ConLike -> CaseAlt PatSyn) -> IOEnv (Env DsGblEnv DsLclEnv) (CaseAlt ConLike) -> IOEnv (Env DsGblEnv DsLclEnv) (CaseAlt PatSyn) forall a b. (a -> b) -> IOEnv (Env DsGblEnv DsLclEnv) a -> IOEnv (Env DsGblEnv DsLclEnv) b forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap CaseAlt ConLike -> CaseAlt PatSyn toSynAlt (IOEnv (Env DsGblEnv DsLclEnv) (CaseAlt ConLike) -> IOEnv (Env DsGblEnv DsLclEnv) (CaseAlt PatSyn)) -> IOEnv (Env DsGblEnv DsLclEnv) (CaseAlt ConLike) -> IOEnv (Env DsGblEnv DsLclEnv) (CaseAlt PatSyn) forall a b. (a -> b) -> a -> b $ [Id] -> Type -> Type -> NonEmpty EquationInfo -> IOEnv (Env DsGblEnv DsLclEnv) (CaseAlt ConLike) matchOneConLike [Id] vars Type ty Type mult NonEmpty EquationInfo eqns return (mkCoSynCaseMatchResult var ty alt) where toSynAlt :: CaseAlt ConLike -> CaseAlt PatSyn toSynAlt CaseAlt ConLike alt = case CaseAlt ConLike -> ConLike forall a. CaseAlt a -> a alt_pat CaseAlt ConLike alt of PatSynCon PatSyn psyn -> CaseAlt ConLike alt{ alt_pat = psyn } ConLike _ -> String -> CaseAlt PatSyn forall a. HasCallStack => String -> a panic String "matchPatSyn: not PatSynCon" type ConArgPats = HsConPatDetails GhcTc matchOneConLike :: [Id] -> Type -> Mult -> NonEmpty EquationInfoNE -> DsM (CaseAlt ConLike) matchOneConLike :: [Id] -> Type -> Type -> NonEmpty EquationInfo -> IOEnv (Env DsGblEnv DsLclEnv) (CaseAlt ConLike) matchOneConLike [Id] vars Type ty Type mult (EquationInfo eqn1 :| [EquationInfo] eqns) -- All eqns for a single constructor = do { let inst_tys :: [Type] inst_tys = Bool -> [Type] -> [Type] forall a. HasCallStack => Bool -> a -> a assert ((Id -> Bool) -> [Id] -> Bool forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool all Id -> Bool tcIsTcTyVar [Id] ex_tvs) ([Type] -> [Type]) -> [Type] -> [Type] forall a b. (a -> b) -> a -> b $ -- ex_tvs can only be tyvars as data types in source -- Haskell cannot mention covar yet (Aug 2018). Bool -> [Type] -> [Type] forall a. HasCallStack => Bool -> a -> a assert ([Id] tvs1 [Id] -> [Id] -> Bool forall a b. [a] -> [b] -> Bool `equalLength` [Id] ex_tvs) ([Type] -> [Type]) -> [Type] -> [Type] forall a b. (a -> b) -> a -> b $ [Type] arg_tys [Type] -> [Type] -> [Type] forall a. [a] -> [a] -> [a] ++ [Id] -> [Type] mkTyVarTys [Id] tvs1 val_arg_tys :: [Scaled Type] val_arg_tys = ConLike -> [Type] -> [Scaled Type] conLikeInstOrigArgTys ConLike con1 [Type] inst_tys -- dataConInstOrigArgTys takes the univ and existential tyvars -- and returns the types of the *value* args, which is what we want match_group :: [Id] -> NonEmpty (ConArgPats, EquationInfoNE) -> DsM (MatchResult CoreExpr) -- All members of the group have compatible ConArgPats match_group :: [Id] -> NonEmpty (ConArgPats, EquationInfo) -> DsM (MatchResult CoreExpr) match_group [Id] arg_vars NonEmpty (ConArgPats, EquationInfo) arg_eqn_prs = do { (wraps, eqns') <- (NonEmpty (CoreExpr -> CoreExpr, EquationInfo) -> (NonEmpty (CoreExpr -> CoreExpr), NonEmpty EquationInfo)) -> IOEnv (Env DsGblEnv DsLclEnv) (NonEmpty (CoreExpr -> CoreExpr, EquationInfo)) -> IOEnv (Env DsGblEnv DsLclEnv) (NonEmpty (CoreExpr -> CoreExpr), NonEmpty EquationInfo) forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r liftM NonEmpty (CoreExpr -> CoreExpr, EquationInfo) -> (NonEmpty (CoreExpr -> CoreExpr), NonEmpty EquationInfo) forall (f :: * -> *) a b. Functor f => f (a, b) -> (f a, f b) NE.unzip (((HsConDetails (HsConPatTyArg (GhcPass 'Renamed)) (GenLocated SrcSpanAnnA (Pat GhcTc)) (HsRecFields GhcTc (GenLocated SrcSpanAnnA (Pat GhcTc))), EquationInfo) -> IOEnv (Env DsGblEnv DsLclEnv) (CoreExpr -> CoreExpr, EquationInfo)) -> NonEmpty (HsConDetails (HsConPatTyArg (GhcPass 'Renamed)) (GenLocated SrcSpanAnnA (Pat GhcTc)) (HsRecFields GhcTc (GenLocated SrcSpanAnnA (Pat GhcTc))), EquationInfo) -> IOEnv (Env DsGblEnv DsLclEnv) (NonEmpty (CoreExpr -> CoreExpr, EquationInfo)) forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => (a -> m b) -> t a -> m (t b) forall (m :: * -> *) a b. Monad m => (a -> m b) -> NonEmpty a -> m (NonEmpty b) mapM (HsConDetails (HsConPatTyArg (GhcPass 'Renamed)) (GenLocated SrcSpanAnnA (Pat GhcTc)) (HsRecFields GhcTc (GenLocated SrcSpanAnnA (Pat GhcTc))), EquationInfo) -> IOEnv (Env DsGblEnv DsLclEnv) (CoreExpr -> CoreExpr, EquationInfo) shift NonEmpty (ConArgPats, EquationInfo) NonEmpty (HsConDetails (HsConPatTyArg (GhcPass 'Renamed)) (GenLocated SrcSpanAnnA (Pat GhcTc)) (HsRecFields GhcTc (GenLocated SrcSpanAnnA (Pat GhcTc))), EquationInfo) arg_eqn_prs) ; let group_arg_vars = [Id] -> NonEmpty (ConArgPats, EquationInfo) -> [Id] select_arg_vars [Id] arg_vars NonEmpty (ConArgPats, EquationInfo) arg_eqn_prs ; match_result <- match (group_arg_vars ++ vars) ty (NE.toList eqns') ; return $ foldr1 (.) wraps <$> match_result } shift :: (HsConDetails (HsConPatTyArg (GhcPass 'Renamed)) (GenLocated SrcSpanAnnA (Pat GhcTc)) (HsRecFields GhcTc (GenLocated SrcSpanAnnA (Pat GhcTc))), EquationInfo) -> IOEnv (Env DsGblEnv DsLclEnv) (CoreExpr -> CoreExpr, EquationInfo) shift (HsConDetails (HsConPatTyArg (GhcPass 'Renamed)) (GenLocated SrcSpanAnnA (Pat GhcTc)) (HsRecFields GhcTc (GenLocated SrcSpanAnnA (Pat GhcTc))) _, EqnMatch { eqn_pat :: EquationInfo -> LPat GhcTc eqn_pat = L SrcSpanAnnA _ (ConPat { pat_args :: forall p. Pat p -> HsConPatDetails p pat_args = ConArgPats args , pat_con_ext :: forall p. Pat p -> XConPat p pat_con_ext = ConPatTc { cpt_tvs :: ConPatTc -> [Id] cpt_tvs = [Id] tvs , cpt_dicts :: ConPatTc -> [Id] cpt_dicts = [Id] ds , cpt_binds :: ConPatTc -> TcEvBinds cpt_binds = TcEvBinds bind }}) , eqn_rest :: EquationInfo -> EquationInfo eqn_rest = EquationInfo rest }) = do TcEvBinds -> ([CoreBind] -> IOEnv (Env DsGblEnv DsLclEnv) (CoreExpr -> CoreExpr, EquationInfo)) -> IOEnv (Env DsGblEnv DsLclEnv) (CoreExpr -> CoreExpr, EquationInfo) forall a. TcEvBinds -> ([CoreBind] -> DsM a) -> DsM a dsTcEvBinds TcEvBinds bind (([CoreBind] -> IOEnv (Env DsGblEnv DsLclEnv) (CoreExpr -> CoreExpr, EquationInfo)) -> IOEnv (Env DsGblEnv DsLclEnv) (CoreExpr -> CoreExpr, EquationInfo)) -> ([CoreBind] -> IOEnv (Env DsGblEnv DsLclEnv) (CoreExpr -> CoreExpr, EquationInfo)) -> IOEnv (Env DsGblEnv DsLclEnv) (CoreExpr -> CoreExpr, EquationInfo) forall a b. (a -> b) -> a -> b $ \[CoreBind] ds_bind -> (CoreExpr -> CoreExpr, EquationInfo) -> IOEnv (Env DsGblEnv DsLclEnv) (CoreExpr -> CoreExpr, EquationInfo) forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a forall (m :: * -> *) a. Monad m => a -> m a return ( [(Id, Id)] -> CoreExpr -> CoreExpr wrapBinds ([Id] tvs [Id] -> [Id] -> [(Id, Id)] forall a b. [a] -> [b] -> [(a, b)] `zip` [Id] tvs1) (CoreExpr -> CoreExpr) -> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr forall b c a. (b -> c) -> (a -> b) -> a -> c . [(Id, Id)] -> CoreExpr -> CoreExpr wrapBinds ([Id] ds [Id] -> [Id] -> [(Id, Id)] forall a b. [a] -> [b] -> [(a, b)] `zip` [Id] dicts1) (CoreExpr -> CoreExpr) -> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr forall b c a. (b -> c) -> (a -> b) -> a -> c . [CoreBind] -> CoreExpr -> CoreExpr mkCoreLets [CoreBind] ds_bind , [LPat GhcTc] -> EquationInfo -> EquationInfo prependPats ([Scaled Type] -> ConArgPats -> [LPat GhcTc] conArgPats [Scaled Type] val_arg_tys ConArgPats args) EquationInfo rest ) shift (HsConDetails (HsConPatTyArg (GhcPass 'Renamed)) (GenLocated SrcSpanAnnA (Pat GhcTc)) (HsRecFields GhcTc (GenLocated SrcSpanAnnA (Pat GhcTc))) _, EquationInfo eqn) = String -> SDoc -> IOEnv (Env DsGblEnv DsLclEnv) (CoreExpr -> CoreExpr, EquationInfo) forall a. HasCallStack => String -> SDoc -> a pprPanic String "matchOneCon/shift" (EquationInfo -> SDoc forall a. Outputable a => a -> SDoc ppr EquationInfo eqn) ; let scaled_arg_tys :: [Scaled Type] scaled_arg_tys = (Scaled Type -> Scaled Type) -> [Scaled Type] -> [Scaled Type] forall a b. (a -> b) -> [a] -> [b] map (Type -> Scaled Type -> Scaled Type forall a. Type -> Scaled a -> Scaled a scaleScaled Type mult) [Scaled Type] val_arg_tys -- The 'val_arg_tys' are taken from the data type definition, they -- do not take into account the context multiplicity, therefore we -- need to scale them back to get the correct context multiplicity -- to desugar the sub-pattern in each field. We need to know these -- multiplicity because of the invariant that, in Core, binders in a -- constructor pattern must be scaled by the multiplicity of the -- case. See Note [Case expression invariants]. ; arg_vars <- [Scaled Type] -> ConArgPats -> DsM [Id] selectConMatchVars [Scaled Type] scaled_arg_tys ConArgPats args1 -- Use the first equation as a source of -- suggestions for the new variables -- Divide into sub-groups; see Note [Record patterns] ; let groups :: NonEmpty (NonEmpty (ConArgPats, EquationInfoNE)) groups = ((ConArgPats, EquationInfo) -> (ConArgPats, EquationInfo) -> Bool) -> NonEmpty (ConArgPats, EquationInfo) -> NonEmpty (NonEmpty (ConArgPats, EquationInfo)) forall a. (a -> a -> Bool) -> NonEmpty a -> NonEmpty (NonEmpty a) NE.groupBy1 (ConArgPats, EquationInfo) -> (ConArgPats, EquationInfo) -> Bool forall a. (ConArgPats, a) -> (ConArgPats, a) -> Bool compatible_pats (NonEmpty (ConArgPats, EquationInfo) -> NonEmpty (NonEmpty (ConArgPats, EquationInfo))) -> NonEmpty (ConArgPats, EquationInfo) -> NonEmpty (NonEmpty (ConArgPats, EquationInfo)) forall a b. (a -> b) -> a -> b $ (EquationInfo -> (ConArgPats, EquationInfo)) -> NonEmpty EquationInfo -> NonEmpty (ConArgPats, EquationInfo) forall a b. (a -> b) -> NonEmpty a -> NonEmpty b forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (\EquationInfo eqn -> (Pat GhcTc -> ConArgPats forall p. Pat p -> HsConPatDetails p pat_args (EquationInfo -> Pat GhcTc firstPat EquationInfo eqn), EquationInfo eqn)) (EquationInfo eqn1 EquationInfo -> [EquationInfo] -> NonEmpty EquationInfo forall a. a -> [a] -> NonEmpty a :| [EquationInfo] eqns) ; match_results <- mapM (match_group arg_vars) groups ; return $ MkCaseAlt{ alt_pat = con1, alt_bndrs = tvs1 ++ dicts1 ++ arg_vars, alt_wrapper = wrapper1, alt_result = foldr1 combineMatchResults match_results } } where ConPat { pat_con :: forall p. Pat p -> XRec p (ConLikeP p) pat_con = L SrcSpanAnnN _ ConLike con1 , pat_args :: forall p. Pat p -> HsConPatDetails p pat_args = ConArgPats args1 , pat_con_ext :: forall p. Pat p -> XConPat p pat_con_ext = ConPatTc { cpt_arg_tys :: ConPatTc -> [Type] cpt_arg_tys = [Type] arg_tys , cpt_wrap :: ConPatTc -> HsWrapper cpt_wrap = HsWrapper wrapper1 , cpt_tvs :: ConPatTc -> [Id] cpt_tvs = [Id] tvs1 , cpt_dicts :: ConPatTc -> [Id] cpt_dicts = [Id] dicts1 } } = EquationInfo -> Pat GhcTc firstPat EquationInfo eqn1 fields1 :: [Name] fields1 = (FieldLabel -> Name) -> [FieldLabel] -> [Name] forall a b. (a -> b) -> [a] -> [b] map FieldLabel -> Name flSelector (ConLike -> [FieldLabel] conLikeFieldLabels ConLike con1) ex_tvs :: [Id] ex_tvs = ConLike -> [Id] conLikeExTyCoVars ConLike con1 -- Choose the right arg_vars in the right order for this group -- Note [Record patterns] select_arg_vars :: [Id] -> NonEmpty (ConArgPats, EquationInfo) -> [Id] select_arg_vars :: [Id] -> NonEmpty (ConArgPats, EquationInfo) -> [Id] select_arg_vars [Id] arg_vars ((ConArgPats arg_pats, EquationInfo _) :| [(ConArgPats, EquationInfo)] _) | RecCon HsRecFields GhcTc (LPat GhcTc) flds <- ConArgPats arg_pats , let rpats :: [LHsRecField GhcTc (GenLocated SrcSpanAnnA (Pat GhcTc))] rpats = HsRecFields GhcTc (GenLocated SrcSpanAnnA (Pat GhcTc)) -> [LHsRecField GhcTc (GenLocated SrcSpanAnnA (Pat GhcTc))] forall p arg. HsRecFields p arg -> [LHsRecField p arg] rec_flds HsRecFields GhcTc (LPat GhcTc) HsRecFields GhcTc (GenLocated SrcSpanAnnA (Pat GhcTc)) flds , Bool -> Bool not ([GenLocated SrcSpanAnnA (HsFieldBind (GenLocated SrcSpanAnnA (FieldOcc GhcTc)) (GenLocated SrcSpanAnnA (Pat GhcTc)))] -> Bool forall a. [a] -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null [LHsRecField GhcTc (GenLocated SrcSpanAnnA (Pat GhcTc))] [GenLocated SrcSpanAnnA (HsFieldBind (GenLocated SrcSpanAnnA (FieldOcc GhcTc)) (GenLocated SrcSpanAnnA (Pat GhcTc)))] rpats) -- Treated specially; cf conArgPats = Bool -> SDoc -> [Id] -> [Id] forall a. HasCallStack => Bool -> SDoc -> a -> a assertPpr ([Name] fields1 [Name] -> [Id] -> Bool forall a b. [a] -> [b] -> Bool `equalLength` [Id] arg_vars) (ConLike -> SDoc forall a. Outputable a => a -> SDoc ppr ConLike con1 SDoc -> SDoc -> SDoc forall doc. IsDoc doc => doc -> doc -> doc $$ [Name] -> SDoc forall a. Outputable a => a -> SDoc ppr [Name] fields1 SDoc -> SDoc -> SDoc forall doc. IsDoc doc => doc -> doc -> doc $$ [Id] -> SDoc forall a. Outputable a => a -> SDoc ppr [Id] arg_vars) ([Id] -> [Id]) -> [Id] -> [Id] forall a b. (a -> b) -> a -> b $ (GenLocated SrcSpanAnnA (HsFieldBind (GenLocated SrcSpanAnnA (FieldOcc GhcTc)) (GenLocated SrcSpanAnnA (Pat GhcTc))) -> Id) -> [GenLocated SrcSpanAnnA (HsFieldBind (GenLocated SrcSpanAnnA (FieldOcc GhcTc)) (GenLocated SrcSpanAnnA (Pat GhcTc)))] -> [Id] forall a b. (a -> b) -> [a] -> [b] map GenLocated SrcSpanAnnA (HsFieldBind (GenLocated SrcSpanAnnA (FieldOcc GhcTc)) (GenLocated SrcSpanAnnA (Pat GhcTc))) -> Id lookup_fld [LHsRecField GhcTc (GenLocated SrcSpanAnnA (Pat GhcTc))] [GenLocated SrcSpanAnnA (HsFieldBind (GenLocated SrcSpanAnnA (FieldOcc GhcTc)) (GenLocated SrcSpanAnnA (Pat GhcTc)))] rpats | Bool otherwise = [Id] arg_vars where fld_var_env :: NameEnv Id fld_var_env = [(Name, Id)] -> NameEnv Id forall a. [(Name, a)] -> NameEnv a mkNameEnv ([(Name, Id)] -> NameEnv Id) -> [(Name, Id)] -> NameEnv Id forall a b. (a -> b) -> a -> b $ String -> [Name] -> [Id] -> [(Name, Id)] forall a b. HasDebugCallStack => String -> [a] -> [b] -> [(a, b)] zipEqual String "get_arg_vars" [Name] fields1 [Id] arg_vars lookup_fld :: GenLocated SrcSpanAnnA (HsFieldBind (GenLocated SrcSpanAnnA (FieldOcc GhcTc)) (GenLocated SrcSpanAnnA (Pat GhcTc))) -> Id lookup_fld (L SrcSpanAnnA _ HsFieldBind (GenLocated SrcSpanAnnA (FieldOcc GhcTc)) (GenLocated SrcSpanAnnA (Pat GhcTc)) rpat) = NameEnv Id -> Name -> Id forall a. NameEnv a -> Name -> a lookupNameEnv_NF NameEnv Id fld_var_env (Id -> Name idName (HsRecField GhcTc (GenLocated SrcSpanAnnA (Pat GhcTc)) -> Id forall arg. HsRecField GhcTc arg -> Id hsRecFieldId HsRecField GhcTc (GenLocated SrcSpanAnnA (Pat GhcTc)) HsFieldBind (GenLocated SrcSpanAnnA (FieldOcc GhcTc)) (GenLocated SrcSpanAnnA (Pat GhcTc)) rpat)) ----------------- compatible_pats :: (ConArgPats,a) -> (ConArgPats,a) -> Bool -- Two constructors have compatible argument patterns if the number -- and order of sub-matches is the same in both cases compatible_pats :: forall a. (ConArgPats, a) -> (ConArgPats, a) -> Bool compatible_pats (RecCon HsRecFields GhcTc (LPat GhcTc) flds1, a _) (RecCon HsRecFields GhcTc (LPat GhcTc) flds2, a _) = HsRecFields GhcTc (LPat GhcTc) -> HsRecFields GhcTc (LPat GhcTc) -> Bool same_fields HsRecFields GhcTc (LPat GhcTc) flds1 HsRecFields GhcTc (LPat GhcTc) flds2 compatible_pats (RecCon HsRecFields GhcTc (LPat GhcTc) flds1, a _) (ConArgPats, a) _ = [GenLocated SrcSpanAnnA (HsFieldBind (GenLocated SrcSpanAnnA (FieldOcc GhcTc)) (GenLocated SrcSpanAnnA (Pat GhcTc)))] -> Bool forall a. [a] -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null (HsRecFields GhcTc (GenLocated SrcSpanAnnA (Pat GhcTc)) -> [LHsRecField GhcTc (GenLocated SrcSpanAnnA (Pat GhcTc))] forall p arg. HsRecFields p arg -> [LHsRecField p arg] rec_flds HsRecFields GhcTc (LPat GhcTc) HsRecFields GhcTc (GenLocated SrcSpanAnnA (Pat GhcTc)) flds1) compatible_pats (ConArgPats, a) _ (RecCon HsRecFields GhcTc (LPat GhcTc) flds2, a _) = [GenLocated SrcSpanAnnA (HsFieldBind (GenLocated SrcSpanAnnA (FieldOcc GhcTc)) (GenLocated SrcSpanAnnA (Pat GhcTc)))] -> Bool forall a. [a] -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null (HsRecFields GhcTc (GenLocated SrcSpanAnnA (Pat GhcTc)) -> [LHsRecField GhcTc (GenLocated SrcSpanAnnA (Pat GhcTc))] forall p arg. HsRecFields p arg -> [LHsRecField p arg] rec_flds HsRecFields GhcTc (LPat GhcTc) HsRecFields GhcTc (GenLocated SrcSpanAnnA (Pat GhcTc)) flds2) compatible_pats (ConArgPats, a) _ (ConArgPats, a) _ = Bool True -- Prefix or infix con same_fields :: HsRecFields GhcTc (LPat GhcTc) -> HsRecFields GhcTc (LPat GhcTc) -> Bool same_fields :: HsRecFields GhcTc (LPat GhcTc) -> HsRecFields GhcTc (LPat GhcTc) -> Bool same_fields HsRecFields GhcTc (LPat GhcTc) flds1 HsRecFields GhcTc (LPat GhcTc) flds2 = (GenLocated SrcSpanAnnA (HsFieldBind (GenLocated SrcSpanAnnA (FieldOcc GhcTc)) (GenLocated SrcSpanAnnA (Pat GhcTc))) -> GenLocated SrcSpanAnnA (HsFieldBind (GenLocated SrcSpanAnnA (FieldOcc GhcTc)) (GenLocated SrcSpanAnnA (Pat GhcTc))) -> Bool) -> [GenLocated SrcSpanAnnA (HsFieldBind (GenLocated SrcSpanAnnA (FieldOcc GhcTc)) (GenLocated SrcSpanAnnA (Pat GhcTc)))] -> [GenLocated SrcSpanAnnA (HsFieldBind (GenLocated SrcSpanAnnA (FieldOcc GhcTc)) (GenLocated SrcSpanAnnA (Pat GhcTc)))] -> Bool forall a b. (a -> b -> Bool) -> [a] -> [b] -> Bool all2 (\(L SrcSpanAnnA _ HsFieldBind (GenLocated SrcSpanAnnA (FieldOcc GhcTc)) (GenLocated SrcSpanAnnA (Pat GhcTc)) f1) (L SrcSpanAnnA _ HsFieldBind (GenLocated SrcSpanAnnA (FieldOcc GhcTc)) (GenLocated SrcSpanAnnA (Pat GhcTc)) f2) -> HsRecField GhcTc (GenLocated SrcSpanAnnA (Pat GhcTc)) -> Id forall arg. HsRecField GhcTc arg -> Id hsRecFieldId HsRecField GhcTc (GenLocated SrcSpanAnnA (Pat GhcTc)) HsFieldBind (GenLocated SrcSpanAnnA (FieldOcc GhcTc)) (GenLocated SrcSpanAnnA (Pat GhcTc)) f1 Id -> Id -> Bool forall a. Eq a => a -> a -> Bool == HsRecField GhcTc (GenLocated SrcSpanAnnA (Pat GhcTc)) -> Id forall arg. HsRecField GhcTc arg -> Id hsRecFieldId HsRecField GhcTc (GenLocated SrcSpanAnnA (Pat GhcTc)) HsFieldBind (GenLocated SrcSpanAnnA (FieldOcc GhcTc)) (GenLocated SrcSpanAnnA (Pat GhcTc)) f2) (HsRecFields GhcTc (GenLocated SrcSpanAnnA (Pat GhcTc)) -> [LHsRecField GhcTc (GenLocated SrcSpanAnnA (Pat GhcTc))] forall p arg. HsRecFields p arg -> [LHsRecField p arg] rec_flds HsRecFields GhcTc (LPat GhcTc) HsRecFields GhcTc (GenLocated SrcSpanAnnA (Pat GhcTc)) flds1) (HsRecFields GhcTc (GenLocated SrcSpanAnnA (Pat GhcTc)) -> [LHsRecField GhcTc (GenLocated SrcSpanAnnA (Pat GhcTc))] forall p arg. HsRecFields p arg -> [LHsRecField p arg] rec_flds HsRecFields GhcTc (LPat GhcTc) HsRecFields GhcTc (GenLocated SrcSpanAnnA (Pat GhcTc)) flds2) ----------------- selectConMatchVars :: [Scaled Type] -> ConArgPats -> DsM [Id] selectConMatchVars :: [Scaled Type] -> ConArgPats -> DsM [Id] selectConMatchVars [Scaled Type] arg_tys ConArgPats con = case ConArgPats con of RecCon {} -> [Scaled Type] -> DsM [Id] newSysLocalsDs [Scaled Type] arg_tys PrefixCon [HsConPatTyArg (NoGhcTc GhcTc)] _ [LPat GhcTc] ps -> [(Type, Pat GhcTc)] -> DsM [Id] selectMatchVars ([Scaled Type] -> [GenLocated SrcSpanAnnA (Pat GhcTc)] -> [(Type, Pat GhcTc)] forall {a} {l} {b}. [Scaled a] -> [GenLocated l b] -> [(Type, b)] zipMults [Scaled Type] arg_tys [LPat GhcTc] [GenLocated SrcSpanAnnA (Pat GhcTc)] ps) InfixCon LPat GhcTc p1 LPat GhcTc p2 -> [(Type, Pat GhcTc)] -> DsM [Id] selectMatchVars ([Scaled Type] -> [GenLocated SrcSpanAnnA (Pat GhcTc)] -> [(Type, Pat GhcTc)] forall {a} {l} {b}. [Scaled a] -> [GenLocated l b] -> [(Type, b)] zipMults [Scaled Type] arg_tys [LPat GhcTc GenLocated SrcSpanAnnA (Pat GhcTc) p1, LPat GhcTc GenLocated SrcSpanAnnA (Pat GhcTc) p2]) where zipMults :: [Scaled a] -> [GenLocated l b] -> [(Type, b)] zipMults = String -> (Scaled a -> GenLocated l b -> (Type, b)) -> [Scaled a] -> [GenLocated l b] -> [(Type, b)] forall a b c. HasDebugCallStack => String -> (a -> b -> c) -> [a] -> [b] -> [c] zipWithEqual String "selectConMatchVar" (\Scaled a a GenLocated l b b -> (Scaled a -> Type forall a. Scaled a -> Type scaledMult Scaled a a, GenLocated l b -> b forall l e. GenLocated l e -> e unLoc GenLocated l b b)) conArgPats :: [Scaled Type]-- Instantiated argument types -- Used only to fill in the types of WildPats, which -- are probably never looked at anyway -> ConArgPats -> [LPat GhcTc] conArgPats :: [Scaled Type] -> ConArgPats -> [LPat GhcTc] conArgPats [Scaled Type] _arg_tys (PrefixCon [HsConPatTyArg (NoGhcTc GhcTc)] _ [LPat GhcTc] ps) = [LPat GhcTc] ps conArgPats [Scaled Type] _arg_tys (InfixCon LPat GhcTc p1 LPat GhcTc p2) = [LPat GhcTc p1, LPat GhcTc p2] conArgPats [Scaled Type] arg_tys (RecCon (HsRecFields { rec_flds :: forall p arg. HsRecFields p arg -> [LHsRecField p arg] rec_flds = [LHsRecField GhcTc (LPat GhcTc)] rpats })) | [GenLocated SrcSpanAnnA (HsFieldBind (GenLocated SrcSpanAnnA (FieldOcc GhcTc)) (GenLocated SrcSpanAnnA (Pat GhcTc)))] -> Bool forall a. [a] -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null [LHsRecField GhcTc (LPat GhcTc)] [GenLocated SrcSpanAnnA (HsFieldBind (GenLocated SrcSpanAnnA (FieldOcc GhcTc)) (GenLocated SrcSpanAnnA (Pat GhcTc)))] rpats = (Scaled Type -> GenLocated SrcSpanAnnA (Pat GhcTc)) -> [Scaled Type] -> [GenLocated SrcSpanAnnA (Pat GhcTc)] forall a b. (a -> b) -> [a] -> [b] map (Pat GhcTc -> GenLocated SrcSpanAnnA (Pat GhcTc) forall e a. HasAnnotation e => a -> GenLocated e a noLocA (Pat GhcTc -> GenLocated SrcSpanAnnA (Pat GhcTc)) -> (Scaled Type -> Pat GhcTc) -> Scaled Type -> GenLocated SrcSpanAnnA (Pat GhcTc) forall b c a. (b -> c) -> (a -> b) -> a -> c . XWildPat GhcTc -> Pat GhcTc Type -> Pat GhcTc forall p. XWildPat p -> Pat p WildPat (Type -> Pat GhcTc) -> (Scaled Type -> Type) -> Scaled Type -> Pat GhcTc forall b c a. (b -> c) -> (a -> b) -> a -> c . Scaled Type -> Type forall a. Scaled a -> a scaledThing) [Scaled Type] arg_tys -- Important special case for C {}, which can be used for a -- datacon that isn't declared to have fields at all | Bool otherwise = (GenLocated SrcSpanAnnA (HsFieldBind (GenLocated SrcSpanAnnA (FieldOcc GhcTc)) (GenLocated SrcSpanAnnA (Pat GhcTc))) -> GenLocated SrcSpanAnnA (Pat GhcTc)) -> [GenLocated SrcSpanAnnA (HsFieldBind (GenLocated SrcSpanAnnA (FieldOcc GhcTc)) (GenLocated SrcSpanAnnA (Pat GhcTc)))] -> [GenLocated SrcSpanAnnA (Pat GhcTc)] forall a b. (a -> b) -> [a] -> [b] map (HsFieldBind (GenLocated SrcSpanAnnA (FieldOcc GhcTc)) (GenLocated SrcSpanAnnA (Pat GhcTc)) -> GenLocated SrcSpanAnnA (Pat GhcTc) forall lhs rhs. HsFieldBind lhs rhs -> rhs hfbRHS (HsFieldBind (GenLocated SrcSpanAnnA (FieldOcc GhcTc)) (GenLocated SrcSpanAnnA (Pat GhcTc)) -> GenLocated SrcSpanAnnA (Pat GhcTc)) -> (GenLocated SrcSpanAnnA (HsFieldBind (GenLocated SrcSpanAnnA (FieldOcc GhcTc)) (GenLocated SrcSpanAnnA (Pat GhcTc))) -> HsFieldBind (GenLocated SrcSpanAnnA (FieldOcc GhcTc)) (GenLocated SrcSpanAnnA (Pat GhcTc))) -> GenLocated SrcSpanAnnA (HsFieldBind (GenLocated SrcSpanAnnA (FieldOcc GhcTc)) (GenLocated SrcSpanAnnA (Pat GhcTc))) -> GenLocated SrcSpanAnnA (Pat GhcTc) forall b c a. (b -> c) -> (a -> b) -> a -> c . GenLocated SrcSpanAnnA (HsFieldBind (GenLocated SrcSpanAnnA (FieldOcc GhcTc)) (GenLocated SrcSpanAnnA (Pat GhcTc))) -> HsFieldBind (GenLocated SrcSpanAnnA (FieldOcc GhcTc)) (GenLocated SrcSpanAnnA (Pat GhcTc)) forall l e. GenLocated l e -> e unLoc) [LHsRecField GhcTc (LPat GhcTc)] [GenLocated SrcSpanAnnA (HsFieldBind (GenLocated SrcSpanAnnA (FieldOcc GhcTc)) (GenLocated SrcSpanAnnA (Pat GhcTc)))] rpats {- Note [Record patterns] ~~~~~~~~~~~~~~~~~~~~~~ Consider data T = T { x,y,z :: Bool } f (T { y=True, x=False }) = ... We must match the patterns IN THE ORDER GIVEN, thus for the first one we match y=True before x=False. See #246; or imagine matching against (T { y=False, x=undefined }): should fail without touching the undefined. Now consider: f (T { y=True, x=False }) = ... f (T { x=True, y= False}) = ... In the first we must test y first; in the second we must test x first. So we must divide even the equations for a single constructor T into sub-groups, based on whether they match the same field in the same order. That's what the (groupBy compatible_pats) grouping. All non-record patterns are "compatible" in this sense, because the positional patterns (T a b) and (a `T` b) all match the arguments in order. Also T {} is special because it's equivalent to (T _ _). Hence the (null rpats) checks here and there. -}