X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FCheck.lhs;h=1e4a18684581f3617b7645c9b42a5ac4e3f8f5fb;hb=a3e01707ebc2e7180840b5ab3534f818b43c2873;hp=2fc2e8e0897247dcdba309b539d7c96ccc63c812;hpb=9af77fa423926fbda946b31e174173d0ec5ebac8;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/Check.lhs b/ghc/compiler/deSugar/Check.lhs index 2fc2e8e..1e4a186 100644 --- a/ghc/compiler/deSugar/Check.lhs +++ b/ghc/compiler/deSugar/Check.lhs @@ -11,19 +11,19 @@ module Check ( check , ExhaustivePat ) where import HsSyn -import TcHsSyn ( TypecheckedPat, hsPatType ) +import TcHsSyn ( hsPatType ) import TcType ( tcTyConAppTyCon ) -import DsUtils ( EquationInfo(..), MatchResult(..), EqnSet, - CanItFail(..), tidyLitPat, tidyNPat, - ) -import Id ( idType ) +import DsUtils ( EquationInfo(..), MatchResult(..), + CanItFail(..), firstPat ) +import MatchLit ( tidyLitPat, tidyNPat ) +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 @@ -96,17 +96,22 @@ Then we need to use InPats. Juan Quintela 5 JUL 1998\\ User-friendliness and compiler writers are no friends. \end{quotation} -\begin{code} +\begin{code} type WarningPat = InPat Name type ExhaustivePat = ([WarningPat], [(Name, [HsLit])]) +type EqnNo = Int +type EqnSet = UniqSet EqnNo -check :: [EquationInfo] -> ([ExhaustivePat],EqnSet) -check qs = (untidy_warns, incomplete) +check :: [EquationInfo] -> ([ExhaustivePat], [EquationInfo]) + -- Second result is the shadowed equations +check qs = (untidy_warns, shadowed_eqns) where - (warns, incomplete) = check' (simplify_eqns qs) + (warns, used_nos) = check' ([1..] `zip` map simplify_eqn qs) untidy_warns = map untidy_exhaustive warns + shadowed_eqns = [eqn | (eqn,i) <- qs `zip` [1..], + not (i `elementOfUniqSet` used_nos)] untidy_exhaustive :: ExhaustivePat -> ExhaustivePat untidy_exhaustive ([pat], messages) = @@ -131,23 +136,25 @@ untidy_pars :: WarningPat -> WarningPat untidy_pars p = untidy True p untidy :: NeedPars -> WarningPat -> WarningPat -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 (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 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 -> WarningPat +pars :: NeedPars -> WarningPat -> Pat Name pars True p = ParPat p -pars _ p = p +pars _ p = unLoc p untidy_lit :: HsLit -> HsLit untidy_lit (HsCharPrim c) = HsChar c @@ -182,21 +189,19 @@ There are several cases: \begin{code} -check' :: [EquationInfo] -> ([ExhaustivePat],EqnSet) -check' [] = ([([],[])],emptyUniqSet) +check' :: [(EqnNo, EquationInfo)] -> ([ExhaustivePat], EqnSet) +check' [] = ([([],[])],emptyUniqSet) -check' [EqnInfo n ctx ps (MatchResult CanFail _)] - | all_vars ps = ([(takeList ps (repeat new_wild_pat),[])], unitUniqSet n) +check' [(n, EqnInfo { eqn_pats = ps, eqn_rhs = MatchResult CanFail _ })] + | all_vars ps = ([(takeList ps (repeat nlWildPat),[])], unitUniqSet n) -check' qs@((EqnInfo n ctx ps (MatchResult CanFail _)):rs) +check' ((n, EqnInfo { eqn_pats = ps, eqn_rhs = MatchResult CanFail _}) : rs) | all_vars ps = (pats, addOneToUniqSet indexs n) where (pats,indexs) = check' rs -check' qs@((EqnInfo n ctx ps result):_) +check' qs@((n, EqnInfo { eqn_pats = ps }) : _) | all_vars ps = ([], unitUniqSet n) --- | nplusk = panic "Check.check': Work in progress: nplusk" --- | npat = panic "Check.check': Work in progress: npat ?????" | literals = split_by_literals qs | constructors = split_by_constructor qs | only_vars = first_column_only_vars qs @@ -204,12 +209,10 @@ check' qs@((EqnInfo n ctx ps result):_) where -- Note: RecPats will have been simplified to ConPats -- at this stage. - first_pats = ASSERT2( okGroup qs, pprGroup qs ) map firstPat qs + first_pats = ASSERT2( okGroup qs, pprGroup qs ) map firstPatN 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} Here begins the code to deal with literals, we need to split the matrix @@ -217,7 +220,7 @@ in different matrix beginning by each literal and a last matrix with the rest of values. \begin{code} -split_by_literals :: [EquationInfo] -> ([ExhaustivePat],EqnSet) +split_by_literals :: [(EqnNo, EquationInfo)] -> ([ExhaustivePat], EqnSet) split_by_literals qs = process_literals used_lits qs where used_lits = get_used_lits qs @@ -227,12 +230,11 @@ split_by_literals qs = process_literals used_lits qs in the column of the matrix. \begin{code} -process_explicit_literals :: [HsLit] -> [EquationInfo] -> ([ExhaustivePat],EqnSet) +process_explicit_literals :: [HsLit] -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet) process_explicit_literals lits qs = (concat pats, unionManyUniqSets indexs) where pats_indexs = map (\x -> construct_literal_matrix x qs) lits (pats,indexs) = unzip pats_indexs - \end{code} @@ -242,16 +244,16 @@ must be one Variable to be complete. \begin{code} -process_literals :: [HsLit] -> [EquationInfo] -> ([ExhaustivePat],EqnSet) +process_literals :: [HsLit] -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet) process_literals used_lits qs - | null default_eqns = ([make_row_vars used_lits (head qs)]++pats,indexs) + | 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 = ASSERT2( okGroup qs, pprGroup qs ) - map remove_var (filter (is_var . firstPat) qs) + [remove_var q | q <- qs, is_var (firstPatN q)] (pats',indexs') = check' default_eqns - pats_default = [(new_wild_pat:ps,constraints) | (ps,constraints) <- (pats')] ++ pats + pats_default = [(nlWildPat:ps,constraints) | (ps,constraints) <- (pats')] ++ pats indexs_default = unionUniqSets indexs' indexs \end{code} @@ -259,50 +261,45 @@ Here we have selected the literal and we will select all the equations that begins for that literal and create a new matrix. \begin{code} -construct_literal_matrix :: HsLit -> [EquationInfo] -> ([ExhaustivePat],EqnSet) +construct_literal_matrix :: HsLit -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet) 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 = LitPat lit + new_lit = nlLitPat lit remove_first_column_lit :: HsLit - -> [EquationInfo] - -> [EquationInfo] + -> [(EqnNo, EquationInfo)] + -> [(EqnNo, EquationInfo)] remove_first_column_lit lit qs = ASSERT2( okGroup qs, pprGroup qs ) - map shift_pat (filter (is_var_lit lit . firstPat) qs) + [(n, shift_pat eqn) | q@(n,eqn) <- qs, is_var_lit lit (firstPatN q)] 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 - + shift_pat eqn@(EqnInfo { eqn_pats = _:ps}) = eqn { eqn_pats = ps } + shift_pat eqn@(EqnInfo { eqn_pats = []}) = panic "Check.shift_var: no patterns" \end{code} This function splits the equations @qs@ in groups that deal with the same constructor. \begin{code} - -split_by_constructor :: [EquationInfo] -> ([ExhaustivePat],EqnSet) - +split_by_constructor :: [(EqnNo, EquationInfo)] -> ([ExhaustivePat], EqnSet) 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 - \end{code} The first column of the patterns matrix only have vars, then there is 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 :: [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet) +first_column_only_vars qs = (map (\ (xs,ys) -> (nlWildPat:xs,ys)) pats,indexs) where - (pats,indexs) = check' (map remove_var qs) - + (pats, indexs) = check' (map remove_var qs) \end{code} This equation takes a matrix of patterns and split the equations by @@ -314,19 +311,20 @@ 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] -> [(EqnNo, 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] -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet) need_default_case used_cons unused_cons qs | 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 = ASSERT2( okGroup qs, pprGroup qs ) map remove_var (filter (is_var . firstPat) qs) + default_eqns = ASSERT2( okGroup qs, pprGroup qs ) + [remove_var q | q <- qs, is_var (firstPatN q)] (pats',indexs') = check' default_eqns pats_default = [(make_whole_con c:ps,constraints) | c <- unused_cons, (ps,constraints) <- pats'] ++ pats @@ -334,7 +332,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 -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet) construct_matrix con qs = (map (make_con con) pats,indexs) where @@ -356,42 +354,48 @@ is transformed in: \end{verbatim} \begin{code} -remove_first_column :: TypecheckedPat -- Constructor - -> [EquationInfo] - -> [EquationInfo] -remove_first_column (ConPatOut con (PrefixCon con_pats) _ _ _) qs +remove_first_column :: Pat Id -- Constructor + -> [(EqnNo, EquationInfo)] + -> [(EqnNo, EquationInfo)] +remove_first_column (ConPatOut (L _ con) _ _ _ (PrefixCon con_pats) _) qs = ASSERT2( okGroup qs, pprGroup qs ) - map shift_var (filter (is_var_con con . firstPat) qs) + [(n, shift_var eqn) | q@(n, eqn) <- qs, is_var_con con (firstPatN q)] where new_wilds = [WildPat (hsPatType arg_pat) | arg_pat <- con_pats] - shift_var (EqnInfo n ctx (ConPatOut _ (PrefixCon ps') _ _ _:ps) result) = - EqnInfo n ctx (ps'++ps) result - shift_var (EqnInfo n ctx (WildPat _ :ps) result) = - EqnInfo n ctx (new_wilds ++ ps) result + shift_var eqn@(EqnInfo { eqn_pats = ConPatOut _ _ _ _ (PrefixCon ps') _ : ps}) + = eqn { eqn_pats = map unLoc ps' ++ ps } + shift_var eqn@(EqnInfo { eqn_pats = WildPat _ : ps }) + = eqn { eqn_pats = new_wilds ++ ps } shift_var _ = panic "Check.Shift_var:No done" -make_row_vars :: [HsLit] -> EquationInfo -> ExhaustivePat -make_row_vars used_lits (EqnInfo _ _ pats _ ) = - (VarPat new_var:takeList (tail pats) (repeat new_wild_pat),[(new_var,used_lits)]) - where new_var = hash_x +make_row_vars :: [HsLit] -> (EqnNo, EquationInfo) -> ExhaustivePat +make_row_vars used_lits (_, EqnInfo { eqn_pats = pats}) + = (nlVarPat new_var:takeList (tail pats) (repeat nlWildPat),[(new_var,used_lits)]) + where + new_var = hash_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 _ ) = takeList (tail pats) (repeat new_wild_pat) +make_row_vars_for_constructor :: (EqnNo, EquationInfo) -> [WarningPat] +make_row_vars_for_constructor (_, EqnInfo { eqn_pats = pats}) + = takeList (tail pats) (repeat nlWildPat) -compare_cons :: TypecheckedPat -> TypecheckedPat -> Bool -compare_cons (ConPatOut id1 _ _ _ _) (ConPatOut id2 _ _ _ _) = id1 == id2 +compare_cons :: Pat Id -> Pat Id -> Bool +compare_cons (ConPatOut (L _ id1) _ _ _ _ _) (ConPatOut (L _ 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@(ConPatOut _ _ _ _ _):_) _) <- qs ] +get_used_cons :: [(EqnNo, EquationInfo)] -> [Pat Id] +get_used_cons qs = remove_dups [pat | q <- qs, let pat = firstPatN q, + isConPatOut pat] + +isConPatOut (ConPatOut {}) = True +isConPatOut other = False remove_dups' :: [HsLit] -> [HsLit] remove_dups' [] = [] @@ -399,48 +403,44 @@ remove_dups' (x:xs) | x `elem` xs = remove_dups' xs | otherwise = x : remove_dups' xs -get_used_lits :: [EquationInfo] -> [HsLit] +get_used_lits :: [(EqnNo, EquationInfo)] -> [HsLit] get_used_lits qs = remove_dups' all_literals where all_literals = get_used_lits' qs -get_used_lits' :: [EquationInfo] -> [HsLit] +get_used_lits' :: [(EqnNo, EquationInfo)] -> [HsLit] get_used_lits' [] = [] -get_used_lits' ((EqnInfo _ _ ((LitPat lit):_) _):qs) = - lit : get_used_lits 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_used_lits' (q:qs) + | LitPat lit <- first_pat = lit : get_used_lits qs + | NPatOut lit _ _ <- first_pat = lit : get_used_lits qs + | otherwise = get_used_lits qs + where + first_pat = firstPatN q + +get_unused_cons :: [Pat Id] -> [DataCon] get_unused_cons used_cons = unused_cons where - (ConPatOut _ _ ty _ _) = head used_cons + (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 + used_cons_as_id = map (\ (ConPatOut (L _ 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" +remove_var :: (EqnNo, EquationInfo) -> (EqnNo, EquationInfo) +remove_var (n, eqn@(EqnInfo { eqn_pats = WildPat _ : ps})) = (n, eqn { eqn_pats = ps }) +remove_var _ = panic "Check.remove_var: equation does not begin with a variable" ----------------------- -eqnPats :: EquationInfo -> [TypecheckedPat] -eqnPats (EqnInfo _ _ ps _) = ps - -firstPat :: EquationInfo -> TypecheckedPat -firstPat eqn_info = head (eqnPats eqn_info) +eqnPats :: (EqnNo, EquationInfo) -> [Pat Id] +eqnPats (_, eqn) = eqn_pats eqn -okGroup :: [EquationInfo] -> Bool +okGroup :: [(EqnNo, EquationInfo)] -> Bool -- True if all equations have at least one pattern, and -- all have the same number of patterns okGroup [] = True @@ -452,33 +452,29 @@ okGroup (e:es) = n_pats > 0 && and [length (eqnPats e) == n_pats | e <- es] pprGroup es = vcat (map pprEqnInfo es) pprEqnInfo e = ppr (eqnPats e) -is_con :: TypecheckedPat -> Bool -is_con (ConPatOut _ _ _ _ _) = True + +firstPatN :: (EqnNo, EquationInfo) -> Pat Id +firstPatN (_, eqn) = firstPat eqn + +is_con :: Pat Id -> Bool +is_con (ConPatOut _ _ _ _ _ _) = True is_con _ = False -is_lit :: TypecheckedPat -> Bool +is_lit :: Pat Id -> Bool is_lit (LitPat _) = True is_lit (NPatOut _ _ _) = True is_lit _ = False -is_npat :: TypecheckedPat -> Bool -is_npat (NPatOut _ _ _) = True -is_npat _ = False - -is_nplusk :: TypecheckedPat -> Bool -is_nplusk (NPlusKPatOut _ _ _ _) = True -is_nplusk _ = False - -is_var :: TypecheckedPat -> Bool +is_var :: Pat Id -> Bool is_var (WildPat _) = True is_var _ = False -is_var_con :: DataCon -> TypecheckedPat -> Bool -is_var_con con (WildPat _) = True -is_var_con con (ConPatOut id _ _ _ _) | id == con = True -is_var_con con _ = False +is_var_con :: DataCon -> Pat Id -> Bool +is_var_con con (WildPat _) = True +is_var_con con (ConPatOut (L _ id) _ _ _ _ _) | id == con = True +is_var_con con _ = False -is_var_lit :: HsLit -> TypecheckedPat -> Bool +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 @@ -525,7 +521,7 @@ not the second. \fbox{\ ???\ } \begin{code} isInfixCon con = isDataSymOcc (getOccName con) -is_nil (ConPatIn con (PrefixCon [])) = con == getName nilDataCon +is_nil (ConPatIn con (PrefixCon [])) = unLoc con == getName nilDataCon is_nil _ = False is_list (ListPat _ _) = True @@ -537,15 +533,16 @@ 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 :: TypecheckedPat -> ExhaustivePat -> ExhaustivePat -make_con (ConPatOut id _ _ _ _) (p:q:ps, constraints) - | return_list id q = (make_list p q : ps, constraints) - | isInfixCon id = (ConPatIn (getName id) (InfixCon p q) : ps, constraints) +make_con :: Pat Id -> ExhaustivePat -> ExhaustivePat +make_con (ConPatOut (L _ 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 q = unLoc lq -make_con (ConPatOut id (PrefixCon pats) _ _ _) (ps, constraints) - | isTupleTyCon tc = (TuplePat pats_con (tupleTyConBoxity tc) : rest_pats, constraints) - | isPArrFakeCon id = (PArrPat pats_con placeHolderType : rest_pats, constraints) - | otherwise = (ConPatIn name (PrefixCon pats_con) : rest_pats, constraints) +make_con (ConPatOut (L _ 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 @@ -558,14 +555,11 @@ make_con (ConPatOut id (PrefixCon pats) _ _ _) (ps, constraints) -- representation make_whole_con :: DataCon -> WarningPat -make_whole_con con | isInfixCon con = ConPatIn name (InfixCon new_wild_pat new_wild_pat) - | otherwise = ConPatIn name (PrefixCon pats) +make_whole_con con | isInfixCon con = nlInfixConPat name nlWildPat nlWildPat + | otherwise = nlConPat name pats where name = getName con - pats = [new_wild_pat | t <- dataConOrigArgTys con] - -new_wild_pat :: WarningPat -new_wild_pat = WildPat placeHolderType + pats = [nlWildPat | t <- dataConOrigArgTys con] \end{code} This equation makes the same thing as @tidy@ in @Match.lhs@, the @@ -575,90 +569,86 @@ constraints. \begin{code} -simplify_eqns :: [EquationInfo] -> [EquationInfo] -simplify_eqns [] = [] -simplify_eqns ((EqnInfo n ctx pats result):qs) = - (EqnInfo n ctx pats' result) : simplify_eqns qs - where - pats' = map simplify_pat pats +simplify_eqn :: EquationInfo -> EquationInfo +simplify_eqn eqn = eqn { eqn_pats = map simplify_pat (eqn_pats eqn) } -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 (VarPatOut id _) = WildPat (idType id) -- Ignore the bindings +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 _) = unLoc (simplify_lpat p) -- I'm not sure this is right -simplify_pat (ParPat p) = simplify_pat p -simplify_pat (LazyPat p) = simplify_pat p -simplify_pat (AsPat id p) = simplify_pat p -simplify_pat (SigPatOut p ty fn) = simplify_pat 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 (ConPatOut (L loc id) tvs dicts binds ps ty) + = ConPatOut (L loc id) tvs dicts binds (simplify_con id ps) ty -simplify_pat (ListPat ps ty) = foldr (\ x y -> mkPrefixConPat consDataCon [x,y] list_ty) - (mkNilPat list_ty) - (map simplify_pat ps) - where list_ty = mkListTy ty +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_pat ps)) - (mkPArrTy ty) [] [] - where - arity = length ps + = mk_simple_con_pat (parrFakeCon (length ps)) + (PrefixCon (map simplify_lpat ps)) + (mkPArrTy ty) simplify_pat (TuplePat ps boxity) - = ConPatOut (tupleCon boxity arity) - (PrefixCon (map simplify_pat ps)) - (mkTupleTy boxity arity (map hsPatType ps)) [] [] + = mk_simple_con_pat (tupleCon boxity arity) + (PrefixCon (map simplify_lpat ps)) + (mkTupleTy boxity arity (map hsPatType ps)) where arity = length ps -simplify_pat pat@(LitPat lit) = 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@(NPatOut (HsString s) _ _) = - foldr (\c pat -> ConPatOut consDataCon (PrefixCon [mk_char_lit c,pat]) stringTy [] []) - (ConPatOut nilDataCon (PrefixCon []) stringTy [] []) (unpackIntFS s) + foldr (\c pat -> mk_simple_con_pat consDataCon (PrefixCon [mk_char_lit c,noLoc pat]) stringTy) + (mk_simple_con_pat nilDataCon (PrefixCon []) stringTy) (unpackFS s) where - mk_char_lit c = ConPatOut charDataCon (PrefixCon [LitPat (HsCharPrim c)]) - charTy [] [] + mk_char_lit c = noLoc (mk_simple_con_pat charDataCon (PrefixCon [nlLitPat (HsCharPrim c)]) charTy) -simplify_pat pat@(NPatOut 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 (NPlusKPatOut id hslit hsexpr1 hsexpr2) - = WildPat (idType id) + = WildPat (idType (unLoc id)) 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) +mk_simple_con_pat con args ty = ConPatOut (noLoc con) [] [] emptyLHsBinds args ty + ----------------- -simplify_con con (PrefixCon ps) = PrefixCon (map simplify_pat ps) -simplify_con con (InfixCon p1 p2) = PrefixCon [simplify_pat p1, simplify_pat p2] +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 [wild_pat | t <- dataConOrigArgTys con] + | null fs = PrefixCon [nlWildPat | t <- dataConOrigArgTys con] -- Special case for null patterns; maybe not a record at all - | otherwise = PrefixCon (map (simplify_pat.snd) all_pats) + | otherwise = PrefixCon (map (simplify_lpat.snd) all_pats) where -- pad out all the missing fields with WildPats. - field_pats = map (\ f -> (getName f, wild_pat)) - (dataConFieldLabels con) - all_pats = foldr (\ (id,p) acc -> insertNm (getName id) p acc) + field_pats = map (\ f -> (f, nlWildPat)) (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 - - wild_pat = WildPat (panic "Check.simplify_con") \end{code}