X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FCheck.lhs;h=4885b13b792a1fe53f9d949297f153a8d46d7715;hb=3721dd37a707d2aacb5cac814410a78096e28a2c;hp=0d8e76aeb0c8fabec88e93e94329e6aad8d67ba5;hpb=ab46fd8e68f10b6162e77cfc0b216510d9b1d933;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/Check.lhs b/ghc/compiler/deSugar/Check.lhs index 0d8e76a..4885b13 100644 --- a/ghc/compiler/deSugar/Check.lhs +++ b/ghc/compiler/deSugar/Check.lhs @@ -11,24 +11,23 @@ module Check ( check , ExhaustivePat ) where import HsSyn -import TcHsSyn ( TypecheckedPat, outPatType ) -import TcType ( tcTyConAppTyCon, tcTyConAppArgs ) +import TcHsSyn ( hsPatType ) +import TcType ( tcTyConAppTyCon ) import DsUtils ( EquationInfo(..), MatchResult(..), EqnSet, CanItFail(..), tidyLitPat, tidyNPat, ) -import Id ( idType ) -import DataCon ( DataCon, dataConTyCon, dataConArgTys, - dataConSourceArity, dataConFieldLabels ) -import Name ( Name, mkLocalName, getOccName, isDataSymOcc, getName, mkVarOcc ) -import TcType ( mkTyVarTys ) -import TysPrim ( charPrimTy ) +import Id ( Id, idType ) +import DataCon ( DataCon, dataConTyCon, dataConOrigArgTys, dataConFieldLabels ) +import Name ( Name, mkInternalName, getOccName, isDataSymOcc, getName, mkVarOcc ) import TysWiredIn import PrelNames ( unboundKey ) import TyCon ( tyConDataCons, tupleTyConBoxity, isTupleTyCon ) import BasicTypes ( Boxity(..) ) -import SrcLoc ( noSrcLoc ) +import SrcLoc ( noSrcLoc, Located(..), unLoc, noLoc ) import UniqSet +import Util ( takeList, splitAtList, notNull ) import Outputable +import FastString #include "HsVersions.h" \end{code} @@ -132,27 +131,29 @@ untidy_pars :: WarningPat -> WarningPat untidy_pars p = untidy True p untidy :: NeedPars -> WarningPat -> WarningPat -untidy _ p@WildPatIn = p -untidy _ p@(VarPatIn name) = p -untidy _ (LitPatIn lit) = LitPatIn (untidy_lit lit) -untidy _ p@(ConPatIn name []) = p -untidy b (ConPatIn name pats) = - pars b (ConPatIn name (map untidy_pars pats)) -untidy b (ConOpPatIn pat1 name fixity pat2) = - pars b (ConOpPatIn (untidy_pars pat1) name fixity (untidy_pars pat2)) -untidy _ (ListPatIn pats) = ListPatIn (map untidy_no_pars pats) -untidy _ (TuplePatIn pats boxed) = TuplePatIn (map untidy_no_pars pats) boxed - -untidy _ pat = pprPanic "Check.untidy: SigPatIn" (ppr pat) - -pars :: NeedPars -> WarningPat -> WarningPat -pars True p = ParPatIn p -pars _ p = p +untidy b (L loc p) = L loc (untidy' b p) + where + untidy' _ p@(WildPat _) = p + untidy' _ p@(VarPat name) = p + untidy' _ (LitPat lit) = LitPat (untidy_lit lit) + untidy' _ p@(ConPatIn name (PrefixCon [])) = p + untidy' b (ConPatIn name ps) = pars b (L loc (ConPatIn name (untidy_con ps))) + untidy' _ (ListPat pats ty) = ListPat (map untidy_no_pars pats) ty + untidy' _ (TuplePat pats boxed) = TuplePat (map untidy_no_pars pats) boxed + untidy' _ (PArrPat _ _) = panic "Check.untidy: Shouldn't get a parallel array here!" + untidy' _ (SigPatIn _ _) = panic "Check.untidy: SigPat" + +untidy_con (PrefixCon pats) = PrefixCon (map untidy_pars pats) +untidy_con (InfixCon p1 p2) = InfixCon (untidy_pars p1) (untidy_pars p2) +untidy_con (RecCon bs) = RecCon [(f,untidy_pars p) | (f,p) <- bs] + +pars :: NeedPars -> WarningPat -> Pat Name +pars True p = ParPat p +pars _ p = unLoc p untidy_lit :: HsLit -> HsLit untidy_lit (HsCharPrim c) = HsChar c ---untidy_lit (HsStringPrim s) = HsString s -untidy_lit lit = lit +untidy_lit lit = lit \end{code} This equation is the same that check, the only difference is that the @@ -187,7 +188,7 @@ check' :: [EquationInfo] -> ([ExhaustivePat],EqnSet) check' [] = ([([],[])],emptyUniqSet) check' [EqnInfo n ctx ps (MatchResult CanFail _)] - | all_vars ps = ([(take (length ps) (repeat new_wild_pat),[])], unitUniqSet n) + | all_vars ps = ([(takeList ps (repeat wildPat),[])], unitUniqSet n) check' qs@((EqnInfo n ctx ps (MatchResult CanFail _)):rs) | all_vars ps = (pats, addOneToUniqSet indexs n) @@ -201,13 +202,14 @@ check' qs@((EqnInfo n ctx ps result):_) | literals = split_by_literals qs | constructors = split_by_constructor qs | only_vars = first_column_only_vars qs - | otherwise = panic "Check.check': Not implemented :-(" + | otherwise = pprPanic "Check.check': Not implemented :-(" (ppr first_pats) where -- Note: RecPats will have been simplified to ConPats -- at this stage. - constructors = or (map is_con qs) - literals = or (map is_lit qs) - only_vars = and (map is_var qs) + first_pats = ASSERT2( okGroup qs, pprGroup qs ) map firstPat qs + constructors = any is_con first_pats + literals = any is_lit first_pats + only_vars = all is_var first_pats -- npat = or (map is_npat qs) -- nplusk = or (map is_nplusk qs) \end{code} @@ -244,13 +246,14 @@ must be one Variable to be complete. process_literals :: [HsLit] -> [EquationInfo] -> ([ExhaustivePat],EqnSet) process_literals used_lits qs - | length default_eqns == 0 = ([make_row_vars used_lits (head qs)]++pats,indexs) - | otherwise = (pats_default,indexs_default) + | null default_eqns = ([make_row_vars used_lits (head qs)]++pats,indexs) + | otherwise = (pats_default,indexs_default) where (pats,indexs) = process_explicit_literals used_lits qs - default_eqns = (map remove_var (filter is_var qs)) + default_eqns = ASSERT2( okGroup qs, pprGroup qs ) + map remove_var (filter (is_var . firstPat) qs) (pats',indexs') = check' default_eqns - pats_default = [(new_wild_pat:ps,constraints) | (ps,constraints) <- (pats')] ++ pats + pats_default = [(wildPat:ps,constraints) | (ps,constraints) <- (pats')] ++ pats indexs_default = unionUniqSets indexs' indexs \end{code} @@ -263,13 +266,14 @@ construct_literal_matrix lit qs = (map (\ (xs,ys) -> (new_lit:xs,ys)) pats,indexs) where (pats,indexs) = (check' (remove_first_column_lit lit qs)) - new_lit = LitPatIn lit + new_lit = nlLitPat lit remove_first_column_lit :: HsLit -> [EquationInfo] -> [EquationInfo] -remove_first_column_lit lit qs = - map shift_pat (filter (is_var_lit lit) qs) +remove_first_column_lit lit qs + = ASSERT2( okGroup qs, pprGroup qs ) + map shift_pat (filter (is_var_lit lit . firstPat) qs) where shift_pat (EqnInfo n ctx [] result) = panic "Check.shift_var: no patterns" shift_pat (EqnInfo n ctx (_:ps) result) = EqnInfo n ctx ps result @@ -283,8 +287,9 @@ same constructor. split_by_constructor :: [EquationInfo] -> ([ExhaustivePat],EqnSet) -split_by_constructor qs | length unused_cons /= 0 = need_default_case used_cons unused_cons qs - | otherwise = no_need_default_case used_cons qs +split_by_constructor qs + | notNull unused_cons = need_default_case used_cons unused_cons qs + | otherwise = no_need_default_case used_cons qs where used_cons = get_used_cons qs unused_cons = get_unused_cons used_cons @@ -296,7 +301,7 @@ nothing to do. \begin{code} first_column_only_vars :: [EquationInfo] -> ([ExhaustivePat],EqnSet) -first_column_only_vars qs = (map (\ (xs,ys) -> (new_wild_pat:xs,ys)) pats,indexs) +first_column_only_vars qs = (map (\ (xs,ys) -> (wildPat:xs,ys)) pats,indexs) where (pats,indexs) = check' (map remove_var qs) @@ -311,19 +316,19 @@ constructors or not explicitly. The reasoning is similar to @process_literals@, the difference is that here the default case is not always needed. \begin{code} -no_need_default_case :: [TypecheckedPat] -> [EquationInfo] -> ([ExhaustivePat],EqnSet) +no_need_default_case :: [Pat Id] -> [EquationInfo] -> ([ExhaustivePat],EqnSet) no_need_default_case cons qs = (concat pats, unionManyUniqSets indexs) where pats_indexs = map (\x -> construct_matrix x qs) cons (pats,indexs) = unzip pats_indexs -need_default_case :: [TypecheckedPat] -> [DataCon] -> [EquationInfo] -> ([ExhaustivePat],EqnSet) +need_default_case :: [Pat Id] -> [DataCon] -> [EquationInfo] -> ([ExhaustivePat],EqnSet) need_default_case used_cons unused_cons qs - | length default_eqns == 0 = (pats_default_no_eqns,indexs) - | otherwise = (pats_default,indexs_default) + | null default_eqns = (pats_default_no_eqns,indexs) + | otherwise = (pats_default,indexs_default) where (pats,indexs) = no_need_default_case used_cons qs - default_eqns = (map remove_var (filter is_var qs)) + default_eqns = ASSERT2( okGroup qs, pprGroup qs ) map remove_var (filter (is_var . firstPat) qs) (pats',indexs') = check' default_eqns pats_default = [(make_whole_con c:ps,constraints) | c <- unused_cons, (ps,constraints) <- pats'] ++ pats @@ -331,7 +336,7 @@ need_default_case used_cons unused_cons qs pats_default_no_eqns = [(make_whole_con c:new_wilds,[]) | c <- unused_cons] ++ pats indexs_default = unionUniqSets indexs' indexs -construct_matrix :: TypecheckedPat -> [EquationInfo] -> ([ExhaustivePat],EqnSet) +construct_matrix :: Pat Id -> [EquationInfo] -> ([ExhaustivePat],EqnSet) construct_matrix con qs = (map (make_con con) pats,indexs) where @@ -353,41 +358,42 @@ is transformed in: \end{verbatim} \begin{code} -remove_first_column :: TypecheckedPat -- Constructor +remove_first_column :: Pat Id -- Constructor -> [EquationInfo] -> [EquationInfo] -remove_first_column (ConPat con _ _ _ con_pats) qs = - map shift_var (filter (is_var_con con) qs) +remove_first_column (ConPatOut con (PrefixCon con_pats) _ _ _) qs + = ASSERT2( okGroup qs, pprGroup qs ) + map shift_var (filter (is_var_con con . firstPat) qs) where - new_wilds = [WildPat (outPatType arg_pat) | arg_pat <- con_pats] - shift_var (EqnInfo n ctx (ConPat _ _ _ _ ps':ps) result) = - EqnInfo n ctx (ps'++ps) result + new_wilds = [WildPat (hsPatType arg_pat) | arg_pat <- con_pats] + shift_var (EqnInfo n ctx (ConPatOut _ (PrefixCon ps') _ _ _:ps) result) = + EqnInfo n ctx (map unLoc ps'++ps) result shift_var (EqnInfo n ctx (WildPat _ :ps) result) = EqnInfo n ctx (new_wilds ++ ps) result shift_var _ = panic "Check.Shift_var:No done" make_row_vars :: [HsLit] -> EquationInfo -> ExhaustivePat make_row_vars used_lits (EqnInfo _ _ pats _ ) = - (VarPatIn new_var:take (length (tail pats)) (repeat new_wild_pat),[(new_var,used_lits)]) + (nlVarPat new_var:takeList (tail pats) (repeat wildPat),[(new_var,used_lits)]) where new_var = hash_x -hash_x = mkLocalName unboundKey {- doesn't matter much -} - (mkVarOcc SLIT("#x")) +hash_x = mkInternalName unboundKey {- doesn't matter much -} + (mkVarOcc FSLIT("#x")) noSrcLoc make_row_vars_for_constructor :: EquationInfo -> [WarningPat] -make_row_vars_for_constructor (EqnInfo _ _ pats _ ) = take (length (tail pats)) (repeat new_wild_pat) +make_row_vars_for_constructor (EqnInfo _ _ pats _ ) = takeList (tail pats) (repeat wildPat) -compare_cons :: TypecheckedPat -> TypecheckedPat -> Bool -compare_cons (ConPat id1 _ _ _ _) (ConPat id2 _ _ _ _) = id1 == id2 +compare_cons :: Pat Id -> Pat Id -> Bool +compare_cons (ConPatOut id1 _ _ _ _) (ConPatOut id2 _ _ _ _) = id1 == id2 -remove_dups :: [TypecheckedPat] -> [TypecheckedPat] +remove_dups :: [Pat Id] -> [Pat Id] remove_dups [] = [] remove_dups (x:xs) | or (map (\y -> compare_cons x y) xs) = remove_dups xs | otherwise = x : remove_dups xs -get_used_cons :: [EquationInfo] -> [TypecheckedPat] -get_used_cons qs = remove_dups [con | (EqnInfo _ _ (con@(ConPat _ _ _ _ _):_) _) <- qs ] +get_used_cons :: [EquationInfo] -> [Pat Id] +get_used_cons qs = remove_dups [con | (EqnInfo _ _ (con@(ConPatOut _ _ _ _ _):_) _) <- qs ] remove_dups' :: [HsLit] -> [HsLit] remove_dups' [] = [] @@ -402,64 +408,83 @@ get_used_lits qs = remove_dups' all_literals get_used_lits' :: [EquationInfo] -> [HsLit] get_used_lits' [] = [] -get_used_lits' ((EqnInfo _ _ ((LitPat lit _):_) _):qs) = +get_used_lits' ((EqnInfo _ _ ((LitPat lit):_) _):qs) = lit : get_used_lits qs -get_used_lits' ((EqnInfo _ _ ((NPat lit _ _):_) _):qs) = +get_used_lits' ((EqnInfo _ _ ((NPatOut lit _ _):_) _):qs) = lit : get_used_lits qs get_used_lits' (q:qs) = get_used_lits qs -get_unused_cons :: [TypecheckedPat] -> [DataCon] +get_unused_cons :: [Pat Id] -> [DataCon] get_unused_cons used_cons = unused_cons where - (ConPat _ ty _ _ _) = head used_cons - ty_con = tcTyConAppTyCon ty -- Newtype observable - all_cons = tyConDataCons ty_con - used_cons_as_id = map (\ (ConPat d _ _ _ _) -> d) used_cons - unused_cons = uniqSetToList + (ConPatOut _ _ ty _ _) = head used_cons + ty_con = tcTyConAppTyCon ty -- Newtype observable + all_cons = tyConDataCons ty_con + used_cons_as_id = map (\ (ConPatOut d _ _ _ _) -> d) used_cons + unused_cons = uniqSetToList (mkUniqSet all_cons `minusUniqSet` mkUniqSet used_cons_as_id) -all_vars :: [TypecheckedPat] -> Bool -all_vars [] = True -all_vars (WildPat _:ps) = all_vars ps -all_vars _ = False +all_vars :: [Pat Id] -> Bool +all_vars [] = True +all_vars (WildPat _:ps) = all_vars ps +all_vars _ = False remove_var :: EquationInfo -> EquationInfo remove_var (EqnInfo n ctx (WildPat _:ps) result) = EqnInfo n ctx ps result remove_var _ = panic "Check.remove_var: equation does not begin with a variable" -is_con :: EquationInfo -> Bool -is_con (EqnInfo _ _ ((ConPat _ _ _ _ _):_) _) = True -is_con _ = False - -is_lit :: EquationInfo -> Bool -is_lit (EqnInfo _ _ ((LitPat _ _):_) _) = True -is_lit (EqnInfo _ _ ((NPat _ _ _):_) _) = True -is_lit _ = False - -is_npat :: EquationInfo -> Bool -is_npat (EqnInfo _ _ ((NPat _ _ _):_) _) = True -is_npat _ = False - -is_nplusk :: EquationInfo -> Bool -is_nplusk (EqnInfo _ _ ((NPlusKPat _ _ _ _ _):_) _) = True -is_nplusk _ = False - -is_var :: EquationInfo -> Bool -is_var (EqnInfo _ _ ((WildPat _):_) _) = True -is_var _ = False - -is_var_con :: DataCon -> EquationInfo -> Bool -is_var_con con (EqnInfo _ _ ((WildPat _):_) _) = True -is_var_con con (EqnInfo _ _ ((ConPat id _ _ _ _):_) _) | id == con = True -is_var_con con _ = False - -is_var_lit :: HsLit -> EquationInfo -> Bool -is_var_lit lit (EqnInfo _ _ ((WildPat _):_) _) = True -is_var_lit lit (EqnInfo _ _ ((LitPat lit' _):_) _) | lit == lit' = True -is_var_lit lit (EqnInfo _ _ ((NPat lit' _ _):_) _) | lit == lit' = True -is_var_lit lit _ = False +----------------------- +eqnPats :: EquationInfo -> [Pat Id] +eqnPats (EqnInfo _ _ ps _) = ps + +firstPat :: EquationInfo -> Pat Id +firstPat eqn_info = head (eqnPats eqn_info) + +okGroup :: [EquationInfo] -> Bool +-- True if all equations have at least one pattern, and +-- all have the same number of patterns +okGroup [] = True +okGroup (e:es) = n_pats > 0 && and [length (eqnPats e) == n_pats | e <- es] + where + n_pats = length (eqnPats e) + +-- Half-baked print +pprGroup es = vcat (map pprEqnInfo es) +pprEqnInfo e = ppr (eqnPats e) + +is_con :: Pat Id -> Bool +is_con (ConPatOut _ _ _ _ _) = True +is_con _ = False + +is_lit :: Pat Id -> Bool +is_lit (LitPat _) = True +is_lit (NPatOut _ _ _) = True +is_lit _ = False + +is_npat :: Pat Id -> Bool +is_npat (NPatOut _ _ _) = True +is_npat _ = False + +is_nplusk :: Pat Id -> Bool +is_nplusk (NPlusKPatOut _ _ _ _) = True +is_nplusk _ = False + +is_var :: Pat Id -> Bool +is_var (WildPat _) = True +is_var _ = False + +is_var_con :: DataCon -> Pat Id -> Bool +is_var_con con (WildPat _) = True +is_var_con con (ConPatOut id _ _ _ _) | id == con = True +is_var_con con _ = False + +is_var_lit :: HsLit -> Pat Id -> Bool +is_var_lit lit (WildPat _) = True +is_var_lit lit (LitPat lit') | lit == lit' = True +is_var_lit lit (NPatOut lit' _ _) | lit == lit' = True +is_var_lit lit _ = False \end{code} The difference beteewn @make_con@ and @make_whole_con@ is that @@ -502,47 +527,46 @@ not the second. \fbox{\ ???\ } \begin{code} isInfixCon con = isDataSymOcc (getOccName con) -is_nil (ConPatIn con []) = con == getName nilDataCon -is_nil _ = False +is_nil (ConPatIn con (PrefixCon [])) = unLoc con == getName nilDataCon +is_nil _ = False -is_list (ListPatIn _) = True +is_list (ListPat _ _) = True is_list _ = False return_list id q = id == consDataCon && (is_nil q || is_list q) -make_list p q | is_nil q = ListPatIn [p] -make_list p (ListPatIn ps) = ListPatIn (p:ps) -make_list _ _ = panic "Check.make_list: Invalid argument" - -make_con :: TypecheckedPat -> ExhaustivePat -> ExhaustivePat -make_con (ConPat id _ _ _ _) (p:q:ps, constraints) - | return_list id q = (make_list p q : ps, constraints) - | isInfixCon id = ((ConOpPatIn p name fixity q) : ps, constraints) - where name = getName id - fixity = panic "Check.make_con: Guessing fixity" - -make_con (ConPat id _ _ _ pats) (ps,constraints) - | isTupleTyCon tc = (TuplePatIn pats_con (tupleTyConBoxity tc) : rest_pats, constraints) - | otherwise = (ConPatIn name pats_con : rest_pats, constraints) - where num_args = length pats - name = getName id - pats_con = take num_args ps - rest_pats = drop num_args ps - tc = dataConTyCon id - +make_list p q | is_nil q = ListPat [p] placeHolderType +make_list p (ListPat ps ty) = ListPat (p:ps) ty +make_list _ _ = panic "Check.make_list: Invalid argument" + +make_con :: Pat Id -> ExhaustivePat -> ExhaustivePat +make_con (ConPatOut id _ _ _ _) (lp:lq:ps, constraints) + | return_list id q = (noLoc (make_list lp q) : ps, constraints) + | isInfixCon id = (nlInfixConPat (getName id) lp lq : ps, constraints) + where p = unLoc lp + q = unLoc lq + +make_con (ConPatOut id (PrefixCon pats) _ _ _) (ps, constraints) + | isTupleTyCon tc = (noLoc (TuplePat pats_con (tupleTyConBoxity tc)) : rest_pats, constraints) + | isPArrFakeCon id = (noLoc (PArrPat pats_con placeHolderType) : rest_pats, constraints) + | otherwise = (nlConPat name pats_con : rest_pats, constraints) + where + name = getName id + (pats_con, rest_pats) = splitAtList pats ps + tc = dataConTyCon id + +-- reconstruct parallel array pattern +-- +-- * don't check for the type only; we need to make sure that we are really +-- dealing with one of the fake constructors and not with the real +-- representation make_whole_con :: DataCon -> WarningPat -make_whole_con con | isInfixCon con = ConOpPatIn new_wild_pat name fixity new_wild_pat - | otherwise = ConPatIn name pats +make_whole_con con | isInfixCon con = nlInfixConPat name wildPat wildPat + | otherwise = nlConPat name pats where - fixity = panic "Check.make_whole_con: Guessing fixity" name = getName con - arity = dataConSourceArity con - pats = take arity (repeat new_wild_pat) - - -new_wild_pat :: WarningPat -new_wild_pat = WildPatIn + pats = [wildPat | t <- dataConOrigArgTys con] \end{code} This equation makes the same thing as @tidy@ in @Match.lhs@, the @@ -559,81 +583,85 @@ simplify_eqns ((EqnInfo n ctx pats result):qs) = where pats' = map simplify_pat pats -simplify_pat :: TypecheckedPat -> TypecheckedPat +simplify_lpat :: LPat Id -> LPat Id +simplify_lpat p = fmap simplify_pat p +simplify_pat :: Pat Id -> Pat Id simplify_pat pat@(WildPat gt) = pat simplify_pat (VarPat id) = WildPat (idType id) -simplify_pat (LazyPat p) = simplify_pat p -simplify_pat (AsPat id p) = simplify_pat p - -simplify_pat (ConPat id ty tvs dicts ps) = ConPat id ty tvs dicts (map simplify_pat ps) - -simplify_pat (ListPat ty ps) = foldr (\ x -> \y -> ConPat consDataCon list_ty [] [] [x, y]) - (ConPat nilDataCon list_ty [] [] []) - (map simplify_pat ps) - where list_ty = mkListTy ty - - -simplify_pat (TuplePat ps boxity) - = ConPat (tupleCon boxity arity) - (mkTupleTy boxity arity (map outPatType ps)) [] [] - (map simplify_pat ps) +simplify_pat (ParPat p) = unLoc (simplify_lpat p) +simplify_pat (LazyPat p) = unLoc (simplify_lpat p) +simplify_pat (AsPat id p) = unLoc (simplify_lpat p) +simplify_pat (SigPatOut p ty fn) = unLoc (simplify_lpat p) -- I'm not sure this is right + +simplify_pat (ConPatOut id ps ty tvs dicts) = ConPatOut id (simplify_con id ps) ty tvs dicts + +simplify_pat (ListPat ps ty) = + unLoc $ foldr (\ x y -> mkPrefixConPat consDataCon [x,y] list_ty) + (mkNilPat list_ty) + (map simplify_lpat ps) + where list_ty = mkListTy ty + +-- introduce fake parallel array constructors to be able to handle parallel +-- arrays with the existing machinery for constructor pattern +-- +simplify_pat (PArrPat ps ty) + = ConPatOut (parrFakeCon arity) + (PrefixCon (map simplify_lpat ps)) + (mkPArrTy ty) [] [] where arity = length ps -simplify_pat (RecPat dc ty ex_tvs dicts []) - = ConPat dc ty ex_tvs dicts all_wild_pats - where - all_wild_pats = map WildPat con_arg_tys - - -- Identical to machinations in Match.tidy1: - inst_tys = tcTyConAppArgs ty -- Newtype is observable - con_arg_tys = dataConArgTys dc (inst_tys ++ mkTyVarTys ex_tvs) - -simplify_pat (RecPat dc ty ex_tvs dicts idps) - = ConPat dc ty ex_tvs dicts pats +simplify_pat (TuplePat ps boxity) + = ConPatOut (tupleCon boxity arity) + (PrefixCon (map simplify_lpat ps)) + (mkTupleTy boxity arity (map hsPatType ps)) [] [] where - pats = map (simplify_pat.snd) all_pats - - -- pad out all the missing fields with WildPats. - field_pats = map (\ f -> (getName f, WildPat (panic "simplify_pat(RecPat-2)"))) - (dataConFieldLabels dc) - all_pats = - foldr - ( \ (id,p,_) acc -> insertNm (getName id) p acc) - field_pats - idps - - insertNm nm p [] = [(nm,p)] - insertNm nm p (x@(n,_):xs) - | nm == n = (nm,p):xs - | otherwise = x : insertNm nm p xs + arity = length ps -simplify_pat pat@(LitPat lit lit_ty) = tidyLitPat lit pat +simplify_pat pat@(LitPat lit) = unLoc (tidyLitPat lit (noLoc pat)) -- unpack string patterns fully, so we can see when they overlap with -- each other, or even explicit lists of Chars. -simplify_pat pat@(NPat (HsString s) _ _) = - foldr (\c pat -> ConPat consDataCon stringTy [] [] [mk_char_lit c,pat]) - (ConPat nilDataCon stringTy [] [] []) (_UNPK_INT_ s) +simplify_pat pat@(NPatOut (HsString s) _ _) = + foldr (\c pat -> ConPatOut consDataCon (PrefixCon [mk_char_lit c,noLoc pat]) stringTy [] []) + (ConPatOut nilDataCon (PrefixCon []) stringTy [] []) (unpackFS s) where - mk_char_lit c = ConPat charDataCon charTy [] [] - [LitPat (HsCharPrim c) charPrimTy] + mk_char_lit c = noLoc $ + ConPatOut charDataCon (PrefixCon [nlLitPat (HsCharPrim c)]) + charTy [] [] -simplify_pat pat@(NPat lit lit_ty hsexpr) = tidyNPat lit lit_ty pat +simplify_pat pat@(NPatOut lit lit_ty hsexpr) = unLoc (tidyNPat lit lit_ty (noLoc pat)) -simplify_pat (NPlusKPat id hslit ty hsexpr1 hsexpr2) = - WildPat ty - where ty = panic "Check.simplify_pat: Gessing ty" +simplify_pat (NPlusKPatOut id hslit hsexpr1 hsexpr2) + = WildPat (idType (unLoc id)) -simplify_pat (DictPat dicts methods) = - case num_of_d_and_ms of +simplify_pat (DictPat dicts methods) + = case num_of_d_and_ms of 0 -> simplify_pat (TuplePat [] Boxed) 1 -> simplify_pat (head dict_and_method_pats) - _ -> simplify_pat (TuplePat dict_and_method_pats Boxed) + _ -> simplify_pat (TuplePat (map noLoc dict_and_method_pats) Boxed) where num_of_d_and_ms = length dicts + length methods dict_and_method_pats = map VarPat (dicts ++ methods) +----------------- +simplify_con con (PrefixCon ps) = PrefixCon (map simplify_lpat ps) +simplify_con con (InfixCon p1 p2) = PrefixCon [simplify_lpat p1, simplify_lpat p2] +simplify_con con (RecCon fs) + | null fs = PrefixCon [wildPat | t <- dataConOrigArgTys con] + -- Special case for null patterns; maybe not a record at all + | otherwise = PrefixCon (map (simplify_lpat.snd) all_pats) + where + -- pad out all the missing fields with WildPats. + field_pats = map (\ f -> (getName f, wildPat)) + (dataConFieldLabels con) + all_pats = foldr (\ (id,p) acc -> insertNm (getName (unLoc id)) p acc) + field_pats fs + + insertNm nm p [] = [(nm,p)] + insertNm nm p (x@(n,_):xs) + | nm == n = (nm,p):xs + | otherwise = x : insertNm nm p xs \end{code}