X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FCheck.lhs;h=2fc2e8e0897247dcdba309b539d7c96ccc63c812;hb=16e4ce4c0c02650082f2e11982017c903c549ad5;hp=e61c03a3f1f32ccfe625f8a662b84bc1070f18ce;hpb=3a29dbba4d71f2a50f98ecefe3261c5424b68eed;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/Check.lhs b/ghc/compiler/deSugar/Check.lhs index e61c03a..2fc2e8e 100644 --- a/ghc/compiler/deSugar/Check.lhs +++ b/ghc/compiler/deSugar/Check.lhs @@ -1,149 +1,183 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1997 +% (c) The GRASP/AQUA Project, Glasgow University, 1997-1998 % -% Author: Juan J. Quintela +% Author: Juan J. Quintela +\section{Module @Check@ in @deSugar@} \begin{code} -module Check ( check , ExhaustivePat, WarningPat, BoxedString(..) ) where +module Check ( check , ExhaustivePat ) where import HsSyn -import TcHsSyn ( TypecheckedPat ) -import DsHsSyn ( outPatType ) -import CoreSyn - -import DsUtils ( EquationInfo(..), - MatchResult(..), - EqnNo, - EqnSet, - CanItFail(..) +import TcHsSyn ( TypecheckedPat, hsPatType ) +import TcType ( tcTyConAppTyCon ) +import DsUtils ( EquationInfo(..), MatchResult(..), EqnSet, + CanItFail(..), tidyLitPat, tidyNPat, ) -import Id ( idType, - Id, - isTupleCon, - getIdArity - ) -import IdInfo ( ArityInfo(..) ) -import Lex ( isLexConSym ) -import Name ( occNameString, - Name, - getName, - nameUnique, - getOccName, - getOccString - ) -import Type ( Type, - isUnboxedType, - splitTyConApp_maybe - ) -import TyVar ( TyVar ) -import TysPrim ( intPrimTy, - charPrimTy, - floatPrimTy, - doublePrimTy, - addrPrimTy, - wordPrimTy - ) -import TysWiredIn ( nilDataCon, consDataCon, - mkTupleTy, tupleCon, - mkListTy, - charTy, charDataCon, - intTy, intDataCon, - floatTy, floatDataCon, - doubleTy, doubleDataCon, - addrTy, addrDataCon, - wordTy, wordDataCon - ) -import TyCon ( tyConDataCons ) +import 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 UniqSet -import Unique ( Unique ) +import Util ( takeList, splitAtList, notNull ) import Outputable +import FastString #include "HsVersions.h" \end{code} -This module perfoms checks about if one list of equations are: - - Overlapped - - Non exhaustive - +This module performs checks about if one list of equations are: +\begin{itemize} +\item Overlapped +\item Non exhaustive +\end{itemize} To discover that we go through the list of equations in a tree-like fashion. -If you like theory, a similar algoritm is described in: - Two Tecniques for Compiling Lazy Pattern Matching - Luc Maranguet +If you like theory, a similar algorithm is described in: +\begin{quotation} + {\em Two Techniques for Compiling Lazy Pattern Matching}, + Luc Maranguet, INRIA Rocquencourt (RR-2385, 1994) - -The algorithm is based in the first Technique, but there are somo diferences: - - We don't generate code - - We have constructors and literals (not only literals as in the article) - - We don't use directions, we must select the columns from left-to-right - -(By the wat the second technique is really similar to the one used in MAtch.lhs to generate code) - +\end{quotation} +The algorithm is based on the first technique, but there are some differences: +\begin{itemize} +\item We don't generate code +\item We have constructors and literals (not only literals as in the + article) +\item We don't use directions, we must select the columns from + left-to-right +\end{itemize} +(By the way the second technique is really similar to the one used in + @Match.lhs@ to generate code) This function takes the equations of a pattern and returns: - - The patterns that are not recognized - - The equations that are not overlapped - -It symplify the patterns and then call check' (the same semantics),and it needs to -reconstruct the patterns again .... +\begin{itemize} +\item The patterns that are not recognized +\item The equations that are not overlapped +\end{itemize} +It simplify the patterns and then call @check'@ (the same semantics), and it +needs to reconstruct the patterns again .... The problem appear with things like: +\begin{verbatim} f [x,y] = .... f (x:xs) = ..... - -We want to put the two patterns with the same syntax, (prefix form) and then all the -constructors are equal: +\end{verbatim} +We want to put the two patterns with the same syntax, (prefix form) and +then all the constructors are equal: +\begin{verbatim} f (: x (: y [])) = .... f (: x xs) = ..... +\end{verbatim} +(more about that in @simplify_eqns@) -(more about that in symplify_eqns) - -We would preffer to have a WarningPat of type String, but Strings and the +We would prefer to have a @WarningPat@ of type @String@, but Strings and the Pretty Printer are not friends. - + +We use @InPat@ in @WarningPat@ instead of @OutPat@ +because we need to print the +warning messages in the same way they are introduced, i.e. if the user +wrote: +\begin{verbatim} + f [x,y] = .. +\end{verbatim} +He don't want a warning message written: +\begin{verbatim} + f (: x (: y [])) ........ +\end{verbatim} +Then we need to use InPats. +\begin{quotation} + Juan Quintela 5 JUL 1998\\ + User-friendliness and compiler writers are no friends. +\end{quotation} \begin{code} -newtype BoxedString = BS String +type WarningPat = InPat Name +type ExhaustivePat = ([WarningPat], [(Name, [HsLit])]) -type WarningPat = InPat BoxedString --Name --String -type ExhaustivePat = ([WarningPat], [(BoxedString, [HsLit])]) +check :: [EquationInfo] -> ([ExhaustivePat],EqnSet) +check qs = (untidy_warns, incomplete) + where + (warns, incomplete) = check' (simplify_eqns qs) + untidy_warns = map untidy_exhaustive warns + +untidy_exhaustive :: ExhaustivePat -> ExhaustivePat +untidy_exhaustive ([pat], messages) = + ([untidy_no_pars pat], map untidy_message messages) +untidy_exhaustive (pats, messages) = + (map untidy_pars pats, map untidy_message messages) + +untidy_message :: (Name, [HsLit]) -> (Name, [HsLit]) +untidy_message (string, lits) = (string, map untidy_lit lits) +\end{code} -instance Outputable BoxedString where - ppr (BS s) = text s +The function @untidy@ does the reverse work of the @simplify_pat@ funcion. +\begin{code} -check :: [EquationInfo] -> ([ExhaustivePat],EqnSet) -check qs = check' (simplify_eqns qs) +type NeedPars = Bool + +untidy_no_pars :: WarningPat -> WarningPat +untidy_no_pars p = untidy False p + +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_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 True p = ParPat p +pars _ p = p + +untidy_lit :: HsLit -> HsLit +untidy_lit (HsCharPrim c) = HsChar c +untidy_lit lit = lit \end{code} This equation is the same that check, the only difference is that the -boring work is done, that woprk needs to be done only once, this is -the reason top have two funtions, check is the external interface, -check' is called recursively. +boring work is done, that work needs to be done only once, this is +the reason top have two functions, check is the external interface, +@check'@ is called recursively. There are several cases: -\begin{item} -\item There are no equations: Everything is okey. +\begin{itemize} +\item There are no equations: Everything is OK. \item There are only one equation, that can fail, and all the patterns are variables. Then that equation is used and the same equation is - nonexhaustive. -\item All the patterns are variables, and the match can fail,therr are more equations - then the results is the result of the rest of equations and this equation is used also. + non-exhaustive. +\item All the patterns are variables, and the match can fail, there are + more equations then the results is the result of the rest of equations + and this equation is used also. -\item The general case, if all the patterns are variables (here the match can't fail) - then the result is that this equation is used and this equation doesn't generate - non-exustive cases. +\item The general case, if all the patterns are variables (here the match + can't fail) then the result is that this equation is used and this + equation doesn't generate non-exhaustive cases. -\item In the general case, there can exist literals ,constructors or only vars in the - first column, we actuate in consecuence. +\item In the general case, there can exist literals ,constructors or only + vars in the first column, we actuate in consequence. -\end{item} +\end{itemize} \begin{code} @@ -151,13 +185,13 @@ There are several cases: 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) +check' [EqnInfo n ctx ps (MatchResult CanFail _)] + | all_vars ps = ([(takeList ps (repeat new_wild_pat),[])], unitUniqSet n) -check' qs@((EqnInfo n ctx ps (MatchResult CanFail _ _)):_) +check' qs@((EqnInfo n ctx ps (MatchResult CanFail _)):rs) | all_vars ps = (pats, addOneToUniqSet indexs n) where - (pats,indexs) = check' (tail qs) + (pats,indexs) = check' rs check' qs@((EqnInfo n ctx ps result):_) | all_vars ps = ([], unitUniqSet n) @@ -166,17 +200,21 @@ 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 - constructors = or (map is_con qs) - literals = or (map is_lit qs) + -- Note: RecPats will have been simplified to ConPats + -- at this stage. + 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) - only_vars = and (map is_var qs) \end{code} -Here begins the code to deal with literals, we need to split the matrix in diferent matrix -begining by each literal and a last matrix with the rest of values. +Here begins the code to deal with literals, we need to split the matrix +in different matrix beginning by each literal and a last matrix with the +rest of values. \begin{code} split_by_literals :: [EquationInfo] -> ([ExhaustivePat],EqnSet) @@ -185,8 +223,8 @@ split_by_literals qs = process_literals used_lits qs used_lits = get_used_lits qs \end{code} -process_explicit_literals is a funtion taht process each literal that appears in -the column of the matrix. +@process_explicit_literals@ is a function that process each literal that appears +in the column of the matrix. \begin{code} process_explicit_literals :: [HsLit] -> [EquationInfo] -> ([ExhaustivePat],EqnSet) @@ -198,25 +236,27 @@ process_explicit_literals lits qs = (concat pats, unionManyUniqSets indexs) \end{code} -Process_literals calls process_explicit_literals to deal with the literals taht apears in -the matrix and deal also sith ther rest of the cases. It must be one Variable to be complete. +@process_literals@ calls @process_explicit_literals@ to deal with the literals +that appears in the matrix and deal also with the rest of the cases. It +must be one Variable to be complete. \begin{code} 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 indexs_default = unionUniqSets indexs' indexs \end{code} -Here we have selected the literal and we will select all the equations that begins for that -literal and create a new matrix. +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) @@ -224,49 +264,54 @@ 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 = LitPat 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 \end{code} -This function splits the equations @qs@ in groups that deal with the same constructor +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 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 \end{code} -The first column of the patterns matrix only have vars, then there is nothing to do. +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) -> (WildPatIn:xs,ys)) pats,indexs) +first_column_only_vars qs = (map (\ (xs,ys) -> (new_wild_pat:xs,ys)) pats,indexs) where (pats,indexs) = check' (map remove_var qs) \end{code} -This equation takes a matrix of patterns and split the equations by constructor, using all -the constructors that appears in the first column of the pattern matching. +This equation takes a matrix of patterns and split the equations by +constructor, using all the constructors that appears in the first column +of the pattern matching. -We can need a default clause or not ...., it depends if we used all the constructors or not -explicitily. The reasoning is similar to process_literals, the difference is that here -the default case is not allways needed. +We can need a default clause or not ...., it depends if we used all the +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) @@ -275,13 +320,13 @@ no_need_default_case cons qs = (concat pats, unionManyUniqSets indexs) pats_indexs = map (\x -> construct_matrix x qs) cons (pats,indexs) = unzip pats_indexs -need_default_case :: [TypecheckedPat] -> [Id] -> [EquationInfo] -> ([ExhaustivePat],EqnSet) +need_default_case :: [TypecheckedPat] -> [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 @@ -291,50 +336,54 @@ need_default_case used_cons unused_cons qs construct_matrix :: TypecheckedPat -> [EquationInfo] -> ([ExhaustivePat],EqnSet) construct_matrix con qs = - (map (make_con con) pats,indexs) where (pats,indexs) = (check' (remove_first_column con qs)) \end{code} -Here remove first column is more difficult that with literals due to the fact that -constructors can have arguments. - -for instance, the matrix +Here remove first column is more difficult that with literals due to the fact +that constructors can have arguments. +For instance, the matrix +\begin{verbatim} (: x xs) y z y - +\end{verbatim} is transformed in: - +\begin{verbatim} x xs y _ _ y - +\end{verbatim} \begin{code} remove_first_column :: TypecheckedPat -- 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 - shift_var (EqnInfo n ctx (WildPat _ :ps) result) = - EqnInfo n ctx (new_wilds ++ ps) result - shift_var _ = panic "Check.Shift_var:No done" + 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 _ = 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 WildPatIn),[(new_var,used_lits)]) - where new_var = BS "#x" + (VarPat new_var:takeList (tail pats) (repeat new_wild_pat),[(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 _ ) = take (length (tail pats)) (repeat WildPatIn) +make_row_vars_for_constructor (EqnInfo _ _ pats _ ) = takeList (tail pats) (repeat new_wild_pat) compare_cons :: TypecheckedPat -> TypecheckedPat -> Bool -compare_cons (ConPat id1 _ _) (ConPat id2 _ _) = id1 == id2 +compare_cons (ConPatOut id1 _ _ _ _) (ConPatOut id2 _ _ _ _) = id1 == id2 remove_dups :: [TypecheckedPat] -> [TypecheckedPat] remove_dups [] = [] @@ -342,7 +391,7 @@ 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 qs = remove_dups [con | (EqnInfo _ _ (con@(ConPatOut _ _ _ _ _):_) _) <- qs ] remove_dups' :: [HsLit] -> [HsLit] remove_dups' [] = [] @@ -351,22 +400,28 @@ remove_dups' (x:xs) | x `elem` xs = remove_dups' xs get_used_lits :: [EquationInfo] -> [HsLit] -get_used_lits qs = remove_dups' (get_used_lits' qs) +get_used_lits qs = remove_dups' all_literals + where + all_literals = get_used_lits' qs get_used_lits' :: [EquationInfo] -> [HsLit] -get_used_lits' [] = [] -get_used_lits' ((EqnInfo _ _ ((LitPat lit _):_) _):qs) = lit : get_used_lits qs -get_used_lits' ((EqnInfo _ _ ((NPat lit _ _):_) _):qs) = lit : get_used_lits qs -get_used_lits' (q:qs) = get_used_lits qs - -get_unused_cons :: [TypecheckedPat] -> [Id] +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_unused_cons used_cons = unused_cons where - (ConPat _ ty _) = head used_cons - Just (ty_con,_) = splitTyConApp_maybe ty - all_cons = tyConDataCons ty_con - used_cons_as_id = map (\ (ConPat id _ _) -> id) used_cons - unused_cons = uniqSetToList (mkUniqSet all_cons `minusUniqSet` mkUniqSet used_cons_as_id) + (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 @@ -375,134 +430,147 @@ 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 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 :: Id -> 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 +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) + +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 :: TypecheckedPat -> Bool +is_con (ConPatOut _ _ _ _ _) = True +is_con _ = False + +is_lit :: TypecheckedPat -> 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 (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_lit :: HsLit -> TypecheckedPat -> 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 make_wole_con creates a new -constructor with all their arguments, and make_Con takes a list of argumntes, creates -the contructor geting thir argumnts from the list. See where are used for details. +The difference beteewn @make_con@ and @make_whole_con@ is that +@make_wole_con@ creates a new constructor with all their arguments, and +@make_con@ takes a list of argumntes, creates the contructor getting their +arguments from the list. See where \fbox{\ ???\ } are used for details. -We need to reconstruct the patterns (make the constructors infix and similar) at the -same time that we create the constructors. +We need to reconstruct the patterns (make the constructors infix and +similar) at the same time that we create the constructors. You can tell tuple constructors using - +\begin{verbatim} Id.isTupleCon - -You can see if one contructur is infix with this clearer code :-)))))))))) - +\end{verbatim} +You can see if one constructor is infix with this clearer code :-)))))))))) +\begin{verbatim} Lex.isLexConSym (Name.occNameString (Name.getOccName con)) +\end{verbatim} Rather clumsy but it works. (Simon Peyton Jones) -We con't mind the nilDataCon because it doesn't change the way to print the messsage, -we are searching only for things like: [1,2,3], not x:xs .... +We don't mind the @nilDataCon@ because it doesn't change the way to +print the messsage, we are searching only for things like: @[1,2,3]@, +not @x:xs@ .... - -In recontruct_pat we want to "undo" the work taht we have done in simplify_pat +In @reconstruct_pat@ we want to ``undo'' the work +that we have done in @simplify_pat@. In particular: - ((,) x y) returns to be (x, y) - ((:) x xs) returns to be (x:xs) - (x:(...:[]) returns to be [x,...] - -The dificult case is the third one becouse we need to follow all the contructors until the [] -to know taht we need to use the second case, not the second. - +\begin{tabular}{lll} + @((,) x y)@ & returns to be & @(x, y)@ +\\ @((:) x xs)@ & returns to be & @(x:xs)@ +\\ @(x:(...:[])@ & returns to be & @[x,...]@ +\end{tabular} +% +The difficult case is the third one becouse we need to follow all the +contructors until the @[]@ to know that we need to use the second case, +not the second. \fbox{\ ???\ } +% \begin{code} +isInfixCon con = isDataSymOcc (getOccName con) -isInfixCon con = isLexConSym (occNameString (getOccName con)) +is_nil (ConPatIn con (PrefixCon [])) = con == getName nilDataCon +is_nil _ = False -is_nil (ConPatIn (BS con) []) = con == getOccString 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_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 (ConPat id ty pats) (p:q:ps, constraints) +make_con (ConPatOut id _ _ _ _) (p:q:ps, constraints) | return_list id q = (make_list p q : ps, constraints) - | isInfixCon id = (ParPatIn (ConOpPatIn p name fixity q) : ps, constraints) - where name = BS (getOccString id) - fixity = panic "Check.make_con: Guessing fixity" -make_con (ConPat id ty pats) (ps,constraints) - | isTupleCon id = (TuplePatIn pats_con : rest_pats, constraints) - | otherwise = (ConPatIn name pats_con : rest_pats, constraints) - where num_args = length pats - name = BS (getOccString id) - pats_con = map paren_conpat_arg (take num_args ps) - rest_pats = drop num_args ps - --- if needed, wrap a ParPatIn around a ConPatIn arg --- (for prettier printing.) -paren_conpat_arg p@(ConPatIn _ []) = p -paren_conpat_arg p@(ConPatIn _ _) = ParPatIn p -paren_conpat_arg p@(ConOpPatIn _ _ _ _) = ParPatIn p -paren_conpat_arg p = p - - -make_whole_con :: Id -> WarningPat -make_whole_con con | isInfixCon con = ParPatIn(ConOpPatIn new_wild_pat name fixity new_wild_pat) - | otherwise = ConPatIn name pats + | isInfixCon id = (ConPatIn (getName id) (InfixCon p q) : ps, constraints) + +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) + 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 = ConPatIn name (InfixCon new_wild_pat new_wild_pat) + | otherwise = ConPatIn name (PrefixCon pats) where - fixity = panic "Check.make_whole_con: Guessing fixity" - name = BS (getOccString con) - arity = get_int_arity con - pats = map paren_conpat_arg (take arity (repeat new_wild_pat)) - + name = getName con + pats = [new_wild_pat | t <- dataConOrigArgTys con] new_wild_pat :: WarningPat -new_wild_pat = WildPatIn - -get_int_arity :: Id -> Int -get_int_arity id = arity_to_int (getIdArity id) - where - arity_to_int (ArityExactly n) = n - arity_to_int _ = panic "getIntArity: Unknown arity" - +new_wild_pat = WildPat placeHolderType \end{code} -This equation makes the same thing that tidy in Match.lhs, the -diference is that here we can do all the tidy in one place and in the -Match tidy it must be done one column each time due to bookeping +This equation makes the same thing as @tidy@ in @Match.lhs@, the +difference is that here we can do all the tidy in one place and in the +@Match@ tidy it must be done one column each time due to bookkeeping constraints. \begin{code} @@ -519,96 +587,78 @@ simplify_pat :: TypecheckedPat -> TypecheckedPat 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 (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 (ConPat id ty ps) = ConPat id ty (map simplify_pat ps) +simplify_pat (ConPatOut id ps ty tvs dicts) = ConPatOut id (simplify_con id ps) ty tvs dicts -simplify_pat (ConOpPat p1 id p2 ty) = ConPat id ty (map simplify_pat [p1,p2]) - -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) = ConPat (tupleCon arity) - (mkTupleTy arity (map outPatType ps)) +simplify_pat (ListPat ps ty) = foldr (\ x y -> mkPrefixConPat consDataCon [x,y] list_ty) + (mkNilPat list_ty) (map simplify_pat ps) - where - arity = length ps - -simplify_pat (RecPat id ty idps) = ConPat id ty pats - where - pats = map (\ (id,p,_)-> simplify_pat p) idps - -simplify_pat pat@(LitPat lit lit_ty) - | isUnboxedType lit_ty = pat - - | lit_ty == charTy = ConPat charDataCon charTy [LitPat (mk_char lit) charPrimTy] + where list_ty = mkListTy ty - | otherwise = pprPanic "tidy1:LitPat:" (ppr pat) +-- 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 - mk_char (HsChar c) = HsCharPrim c + arity = length ps -simplify_pat (NPat lit lit_ty hsexpr) = better_pat +simplify_pat (TuplePat ps boxity) + = ConPatOut (tupleCon boxity arity) + (PrefixCon (map simplify_pat ps)) + (mkTupleTy boxity arity (map hsPatType ps)) [] [] where - better_pat - | lit_ty == charTy = ConPat charDataCon lit_ty [LitPat (mk_char lit) charPrimTy] - | lit_ty == intTy = ConPat intDataCon lit_ty [LitPat (mk_int lit) intPrimTy] - | lit_ty == wordTy = ConPat wordDataCon lit_ty [LitPat (mk_word lit) wordPrimTy] - | lit_ty == addrTy = ConPat addrDataCon lit_ty [LitPat (mk_addr lit) addrPrimTy] - | lit_ty == floatTy = ConPat floatDataCon lit_ty [LitPat (mk_float lit) floatPrimTy] - | lit_ty == doubleTy = ConPat doubleDataCon lit_ty [LitPat (mk_double lit) doublePrimTy] - - -- Convert the literal pattern "" to the constructor pattern []. - | null_str_lit lit = ConPat nilDataCon lit_ty [] - | one_str_lit lit = ConPat consDataCon list_ty - [ ConPat charDataCon lit_ty [LitPat (mk_head_char lit) charPrimTy] - , ConPat nilDataCon lit_ty []] - - | otherwise = NPat lit lit_ty hsexpr - - list_ty = mkListTy lit_ty - - mk_int (HsInt i) = HsIntPrim i - mk_int l@(HsLitLit s) = l - - mk_head_char (HsString s) = HsCharPrim (_HEAD_ s) - - mk_char (HsChar c) = HsCharPrim c - mk_char l@(HsLitLit s) = l + arity = length ps - mk_word l@(HsLitLit s) = l +simplify_pat pat@(LitPat lit) = tidyLitPat lit pat - mk_addr l@(HsLitLit s) = l - - mk_float (HsInt i) = HsFloatPrim (fromInteger i) - mk_float (HsFrac f) = HsFloatPrim f - mk_float l@(HsLitLit s) = l - - mk_double (HsInt i) = HsDoublePrim (fromInteger i) - mk_double (HsFrac f) = HsDoublePrim f - mk_double l@(HsLitLit s) = l - - null_str_lit (HsString s) = _NULL_ s - null_str_lit other_lit = False +-- 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) + where + mk_char_lit c = ConPatOut charDataCon (PrefixCon [LitPat (HsCharPrim c)]) + charTy [] [] - one_str_lit (HsString s) = _LENGTH_ s == (1::Int) - one_str_lit other_lit = False +simplify_pat pat@(NPatOut lit lit_ty hsexpr) = tidyNPat lit lit_ty pat -simplify_pat (NPlusKPat id hslit ty hsexpr1 hsexpr2) = --NPlusKPat id hslit ty hsexpr1 hsexpr2 - WildPat ty - where ty = panic "Check.simplify_pat: Never used" +simplify_pat (NPlusKPatOut id hslit hsexpr1 hsexpr2) + = WildPat (idType id) -simplify_pat (DictPat dicts methods) = - case num_of_d_and_ms of - 0 -> simplify_pat (TuplePat []) +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) + _ -> simplify_pat (TuplePat 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_pat ps) +simplify_con con (InfixCon p1 p2) = PrefixCon [simplify_pat p1, simplify_pat p2] +simplify_con con (RecCon fs) + | null fs = PrefixCon [wild_pat | t <- dataConOrigArgTys con] + -- Special case for null patterns; maybe not a record at all + | otherwise = PrefixCon (map (simplify_pat.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 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}