[project @ 2002-02-11 08:20:38 by chak]

[ghc-hetmet.git] / ghc / compiler / deSugar / Check.lhs

diff --git a/ghc/compiler/deSugar/Check.lhs b/ghc/compiler/deSugar/Check.lhs
index ebdadb4..d445834 100644 (file)
--- a/ghc/compiler/deSugar/Check.lhs
+++ b/ghc/compiler/deSugar/Check.lhs
@@ -1,176 +1,187 @@
 %
 %

-% (c) The GRASP/AQUA Project, Glasgow University, 1997
+% (c) The GRASP/AQUA Project, Glasgow University, 1997-1998

 %
 %

-% Author: Juan J. Quintela    <quintela@dc.fi.udc.es>
+% Author: Juan J. Quintela    <quintela@krilin.dc.fi.udc.es>
+\section{Module @Check@ in @deSugar@}

 
 \begin{code}
 
 
 \begin{code}
 

-#include "HsVersions.h"

 
 

-module Check ( check , SYN_IE(ExhaustivePat), SYN_IE(WarningPat), BoxedString(..) ) where
+module Check ( check , ExhaustivePat ) where

 
 

-IMP_Ubiq()
-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
-IMPORT_DELOOPER(DsLoop)        -- here for paranoia-checking reasons
-                       -- and to break dsExpr/dsBinds-ish loop
-#else
-import {-# SOURCE #-} DsExpr  ( dsExpr  )
-import {-# SOURCE #-} DsBinds ( dsBinds )
-#endif

 
 import HsSyn           
 
 import HsSyn           

-import TcHsSyn         ( SYN_IE(TypecheckedPat), 
-                          SYN_IE(TypecheckedMatch),
-                         SYN_IE(TypecheckedHsBinds), 
-                          SYN_IE(TypecheckedHsExpr)    
-                        )
-import DsHsSyn         ( outPatType ) 
-import CoreSyn         
-
-import DsMonad         ( DsMatchContext(..),
-                         DsMatchKind(..)
-                        )
-import DsUtils         ( EquationInfo(..),
-                         MatchResult(..),
-                         SYN_IE(EqnNo),
-                         SYN_IE(EqnSet),
-                         CanItFail(..)
+import TcHsSyn         ( TypecheckedPat, outPatType )
+import TcType          ( tcTyConAppTyCon, tcTyConAppArgs )
+import DsUtils         ( EquationInfo(..), MatchResult(..), EqnSet, 
+                         CanItFail(..),  tidyLitPat, tidyNPat, 

                        )
                        )

-import Id              ( idType,
-                         GenId{-instance-}, 
-                          SYN_IE(Id),
-                         idName,
-                          isTupleCon,                     
-                          getIdArity
-                       )
-import IdInfo          ( ArityInfo(..) )
-import Lex              ( isLexConSym )
-import Name             ( occNameString,
-                          Name,
-                          getName,
-                          nameUnique,
-                          getOccName,
-                          getOccString
-                        )
-import Outputable      ( PprStyle(..),
-                          Outputable(..)
-                       )
-import PprType         ( GenType{-instance-}, 
-                          GenTyVar{-ditto-} 
-                        )        
-import Pretty          
-import Type            ( isPrimType, 
-                          eqTy, 
-                          SYN_IE(Type), 
-                          getAppTyCon
-                       )
-import TyVar           ( GenTyVar{-instance Eq-}, SYN_IE(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, dataConArgTys,
+                         dataConSourceArity, dataConFieldLabels )
+import Name             ( Name, mkLocalName, getOccName, isDataSymOcc, getName, mkVarOcc )
+import TcType          ( mkTyVarTys )
+import TysPrim         ( charPrimTy )
+import TysWiredIn
+import PrelNames       ( unboundKey )
+import TyCon            ( tyConDataCons, tupleTyConBoxity, isTupleTyCon )
+import BasicTypes      ( Boxity(..) )
+import SrcLoc          ( noSrcLoc )

 import UniqSet
 import UniqSet

-import Unique          ( Unique{-instance Eq-} )
-import Util            ( pprTrace, 
-                          panic, 
-                          pprPanic 
-                        )
-\end{code}
+import Util             ( takeList, splitAtList )
+import Outputable

 
 

-This module perfoms checks about if one list of equations are:
-       - Overlapped
-       - Non exhaustive
+#include "HsVersions.h"
+\end{code}

 
 

+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.
 
 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)
        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:
 
 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:
 
 The problem appear with things like:

+\begin{verbatim}

   f [x,y]   = ....
   f (x:xs)  = .....
   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)         = .....
   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.
 Pretty Printer are not friends.

- 
-\begin{code}

 
 

-data BoxedString = BS String
+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}

 
 

-type WarningPat = InPat BoxedString --Name --String 
-type ExhaustivePat = ([WarningPat], [(BoxedString, [HsLit])])
+type WarningPat = InPat Name
+type ExhaustivePat = ([WarningPat], [(Name, [HsLit])])

 
 
 
 

-instance Outputable BoxedString where
-    ppr sty (BS s) = text s
+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}

 
 

+The function @untidy@ does the reverse work of the @simplify_pat@ funcion.

 
 

-check :: [EquationInfo] -> ([ExhaustivePat],EqnSet)
-check qs = check' (simplify_eqns qs)
+\begin{code}

 
 

+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@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 _ (PArrPatIn pats)  = 
+       panic "Check.untidy: Shouldn't get a parallel array here!"
+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_lit :: HsLit -> HsLit
+untidy_lit (HsCharPrim c) = HsChar c
+--untidy_lit (HsStringPrim s) = HsString s
+untidy_lit lit = lit

 \end{code}
 
 This equation is the same that check, the only difference is that the
 \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:
 
 
 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 
 \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}
 
 
 \begin{code}

@@ -178,13 +189,13 @@ There are several cases:
 check' :: [EquationInfo] -> ([ExhaustivePat],EqnSet)  
 check' []                                              = ([([],[])],emptyUniqSet)
 
 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
    | 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)
 
 check' qs@((EqnInfo n ctx ps result):_) 
    | all_vars ps  = ([],  unitUniqSet n)

@@ -195,15 +206,18 @@ check' qs@((EqnInfo n ctx ps result):_)
    | only_vars    = first_column_only_vars qs
    | otherwise    = panic "Check.check': Not implemented :-("
   where
    | only_vars    = first_column_only_vars qs
    | otherwise    = panic "Check.check': Not implemented :-("
   where

+     -- Note: RecPats will have been simplified to ConPats
+     --       at this stage.

     constructors = or (map is_con qs)
     literals     = or (map is_lit qs)    
     constructors = or (map is_con qs)
     literals     = or (map is_lit qs)    

+    only_vars    = and (map is_var qs) 

 --    npat         = or (map is_npat qs)
 --    nplusk       = or (map is_nplusk qs)
 --    npat         = or (map is_npat qs)
 --    nplusk       = or (map is_nplusk qs)

-    only_vars    = and (map is_var qs) 

 \end{code}
 
 \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)
 
 \begin{code}
 split_by_literals :: [EquationInfo] -> ([ExhaustivePat],EqnSet)

@@ -212,8 +226,8 @@ split_by_literals qs = process_literals used_lits qs
              used_lits = get_used_lits qs
 \end{code}
 
              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)
 
 \begin{code}
 process_explicit_literals :: [HsLit] -> [EquationInfo] -> ([ExhaustivePat],EqnSet)

@@ -225,15 +239,16 @@ process_explicit_literals lits qs = (concat pats, unionManyUniqSets indexs)
 \end{code}
 
 
 \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 
 
 \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))
      where
        (pats,indexs)   = process_explicit_literals used_lits qs
        default_eqns    = (map remove_var (filter is_var qs))

@@ -242,8 +257,8 @@ process_literals used_lits qs
        indexs_default  = unionUniqSets indexs' indexs
 \end{code}
 
        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)
 
 \begin{code}
 construct_literal_matrix :: HsLit -> [EquationInfo] -> ([ExhaustivePat],EqnSet)

@@ -264,36 +279,40 @@ remove_first_column_lit lit qs =
 
 \end{code}
 
 
 \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)
 
 
 \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 
+  | not (null 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}
 
                        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)
 
 \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}
 
                           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)
 
 \begin{code}
 no_need_default_case :: [TypecheckedPat] -> [EquationInfo] -> ([ExhaustivePat],EqnSet)

@@ -302,10 +321,10 @@ no_need_default_case cons qs = (concat pats, unionManyUniqSets indexs)
       pats_indexs   = map (\x -> construct_matrix x qs) cons
       (pats,indexs) = unzip pats_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 
 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))
      where
        (pats,indexs)   = no_need_default_case used_cons qs
        default_eqns    = (map remove_var (filter is_var qs))

@@ -318,50 +337,53 @@ need_default_case used_cons unused_cons qs
 
 construct_matrix :: TypecheckedPat -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
 construct_matrix con 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}
 
     (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
  (: x xs) y
  z        y

-
+\end{verbatim}

 is transformed in:
 is transformed in:

-
+\begin{verbatim}

  x xs y
  _ _  y
  x xs y
  _ _  y

-
+\end{verbatim}

 
 \begin{code}
 remove_first_column :: TypecheckedPat                -- Constructor 
                     -> [EquationInfo] 
                     -> [EquationInfo]
 
 \begin{code}
 remove_first_column :: TypecheckedPat                -- Constructor 
                     -> [EquationInfo] 
                     -> [EquationInfo]

-remove_first_column (ConPat con _ con_pats) qs = 
+remove_first_column (ConPat con _ _ _ con_pats) qs = 

     map shift_var (filter (is_var_con con) qs)
   where
      new_wilds = [WildPat (outPatType arg_pat) | arg_pat <- con_pats]
     map shift_var (filter (is_var_con con) 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"
+     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"

 
 make_row_vars :: [HsLit] -> EquationInfo -> ExhaustivePat
 make_row_vars used_lits (EqnInfo _ _ pats _ ) = 
 
 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"   
+   (VarPatIn new_var:takeList (tail pats) (repeat new_wild_pat),[(new_var,used_lits)])
+  where new_var = hash_x
+
+hash_x = mkLocalName unboundKey {- doesn't matter much -}
+                    (mkVarOcc SLIT("#x"))
+                    noSrcLoc

 
 make_row_vars_for_constructor :: EquationInfo -> [WarningPat]
 
 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 :: TypecheckedPat -> TypecheckedPat -> Bool

-compare_cons (ConPat id1 _ _) (ConPat id2 _ _) = id1 == id2  
+compare_cons (ConPat id1 _ _ _ _) (ConPat id2 _ _ _ _) = id1 == id2  

 
 remove_dups :: [TypecheckedPat] -> [TypecheckedPat]
 remove_dups []     = []
 
 remove_dups :: [TypecheckedPat] -> [TypecheckedPat]
 remove_dups []     = []

@@ -369,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]
                    | 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@(ConPat _ _ _ _ _):_) _) <- qs ]

 
 remove_dups' :: [HsLit] -> [HsLit] 
 remove_dups' []                   = []
 
 remove_dups' :: [HsLit] -> [HsLit] 
 remove_dups' []                   = []

@@ -378,22 +400,28 @@ remove_dups' (x:xs) | x `elem` xs = remove_dups' xs
 
 
 get_used_lits :: [EquationInfo] -> [HsLit]
 
 
 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' :: [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 _ _ ((NPat 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
 get_unused_cons used_cons = unused_cons
      where

-       (ConPat _ ty _) = head used_cons
-       (ty_con,_)      = getAppTyCon 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) 
+       (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
+                (mkUniqSet all_cons `minusUniqSet` mkUniqSet used_cons_as_id) 

 
 all_vars :: [TypecheckedPat] -> Bool
 all_vars []              = True
 
 all_vars :: [TypecheckedPat] -> Bool
 all_vars []              = True

@@ -402,11 +430,12 @@ all_vars _               = False
 
 remove_var :: EquationInfo -> EquationInfo
 remove_var (EqnInfo n ctx (WildPat _:ps) result) = EqnInfo n ctx ps result
 
 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"
+remove_var _                                     =
+        panic "Check.remove_var: equation does not begin with a variable"

 
 is_con :: EquationInfo -> Bool
 
 is_con :: EquationInfo -> Bool

-is_con (EqnInfo _ _ ((ConPat _ _ _):_) _) = True
-is_con _                                  = False
+is_con (EqnInfo _ _ ((ConPat _ _ _ _ _):_) _) = True
+is_con _                                      = False

 
 is_lit :: EquationInfo -> Bool
 is_lit (EqnInfo _ _ ((LitPat _ _):_) _) = True
 
 is_lit :: EquationInfo -> Bool
 is_lit (EqnInfo _ _ ((LitPat _ _):_) _) = True

@@ -425,10 +454,10 @@ is_var :: EquationInfo -> Bool
 is_var (EqnInfo _ _ ((WildPat _):_) _)  = True
 is_var _                                = False
 
 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_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 :: HsLit -> EquationInfo -> Bool
 is_var_lit lit (EqnInfo _ _ ((WildPat _):_)     _)               = True

@@ -437,43 +466,48 @@ is_var_lit lit (EqnInfo _ _ ((NPat lit' _ _):_) _) | lit == lit' = True
 is_var_lit lit _                                                 = False
 \end{code}
 
 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
 
 You can tell tuple constructors using

-
+\begin{verbatim}

         Id.isTupleCon
         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))
         Lex.isLexConSym (Name.occNameString (Name.getOccName con))

+\end{verbatim}

 
        Rather clumsy but it works. (Simon Peyton Jones)
 
 
 
        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:
 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}
 \begin{code}

+isInfixCon con = isDataSymOcc (getOccName con)

 
 

-isInfixCon con = isLexConSym (occNameString (getOccName con))
-
-is_nil (ConPatIn (BS con) []) = con == getOccString nilDataCon
-is_nil _                      = False
+is_nil (ConPatIn con []) = con == getName nilDataCon
+is_nil _                 = False

 
 is_list (ListPatIn _) = True
 is_list _             = False
 
 is_list (ListPatIn _) = True
 is_list _             = False

@@ -485,43 +519,51 @@ make_list p (ListPatIn ps) = ListPatIn (p:ps)
 make_list _ _              = panic "Check.make_list: Invalid argument"
 
 make_con :: TypecheckedPat -> ExhaustivePat -> ExhaustivePat           
 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 (ConPat id _ _ _ _) (p:q:ps, constraints) 

      | return_list id q = (make_list 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)
+     | isInfixCon id = ((ConOpPatIn p name fixity q) : ps, constraints) 
+    where name   = getName id

           fixity = panic "Check.make_con: Guessing fixity"
           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  = (take num_args ps)
-          rest_pats = drop num_args ps         
-
-make_whole_con :: Id -> WarningPat
-make_whole_con con | isInfixCon con = ParPatIn(ConOpPatIn new_wild_pat name fixity new_wild_pat)
+
+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 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_con (ConPat id _ _ _ pats) (ps, constraints) 
+  | isPArrFakeCon id = (PArrPatIn patsCon     : restPats, constraints) 
+  | otherwise        = (ConPatIn name patsCon : restPats, constraints)
+  where 
+    name                = getName id
+    (patsCon, restPats) = splitAtList pats ps
+    tc                 = dataConTyCon id
+         
+
+make_whole_con :: DataCon -> WarningPat
+make_whole_con con | isInfixCon con = ConOpPatIn new_wild_pat name fixity new_wild_pat

                    | otherwise      = ConPatIn name pats
                 where 
                   fixity = panic "Check.make_whole_con: Guessing fixity"
                    | otherwise      = ConPatIn name pats
                 where 
                   fixity = panic "Check.make_whole_con: Guessing fixity"

-                  name   = BS (getOccString con)
-                  arity  = get_int_arity con 
-                  pats   = take arity (repeat new_wild_pat)
+                  name   = getName con
+                  arity  = dataConSourceArity con 
+                  pats   = replicate arity new_wild_pat

 
 
 new_wild_pat :: WarningPat
 new_wild_pat = WildPatIn
 
 
 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"      
-

 \end{code}
 
 \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}
 constraints.
 
 \begin{code}

@@ -529,94 +571,92 @@ constraints.
 simplify_eqns :: [EquationInfo] -> [EquationInfo]
 simplify_eqns []                               = []
 simplify_eqns ((EqnInfo n ctx pats result):qs) = 
 simplify_eqns :: [EquationInfo] -> [EquationInfo]
 simplify_eqns []                               = []
 simplify_eqns ((EqnInfo n ctx pats result):qs) = 

-    (EqnInfo n ctx(map simplify_pat pats) result) : 
-    simplify_eqns qs
+ (EqnInfo n ctx pats' result) : simplify_eqns qs
+ where
+  pats' = map simplify_pat pats

 
 simplify_pat :: TypecheckedPat -> TypecheckedPat  
 
 simplify_pat :: TypecheckedPat -> TypecheckedPat  

-simplify_pat (WildPat gt ) = WildPat gt        
-
-simplify_pat (VarPat id)   = WildPat (idType id) 
-
-simplify_pat (LazyPat p)   = simplify_pat p

 
 

-simplify_pat (AsPat id p)  = simplify_pat p
+simplify_pat pat@(WildPat gt) = pat
+simplify_pat (VarPat id)      = WildPat (idType id) 

 
 

-simplify_pat (ConPat id ty ps) = ConPat id ty (map simplify_pat ps)
-
-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 (LazyPat p)      = simplify_pat p
+simplify_pat (AsPat id p)     = simplify_pat p
+simplify_pat (SigPat p ty fn) = simplify_pat p -- I'm not sure this is right

 
 

+simplify_pat (ConPat id ty tvs dicts ps) = ConPat id ty tvs dicts (map simplify_pat ps)

 
 

-simplify_pat (TuplePat ps) = ConPat (tupleCon arity)
-                                    (mkTupleTy arity (map outPatType ps))
+simplify_pat (ListPat ty ps) = foldr (\ x -> \y -> ConPat consDataCon list_ty [] [] [x, y])
+                                    (ConPat nilDataCon list_ty [] [] [])

                                     (map simplify_pat ps)
                                     (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) 
-  | isPrimType lit_ty = LitPat lit lit_ty
-
-  | lit_ty `eqTy` charTy = ConPat charDataCon charTy [LitPat (mk_char lit) charPrimTy]
+                             where list_ty = mkListTy ty

 
 

-  | otherwise = pprPanic "tidy1:LitPat:" (ppr PprDebug pat)
+-- introduce fake parallel array constructors to be able to handle parallel
+-- arrays with the existing machinery for constructor pattern
+--
+simplify_pat (PArrPat ty ps)
+  = ConPat (parrFakeCon arity) (mkPArrTy ty) [] [] (map simplify_pat ps)

   where
   where

-    mk_char (HsChar c)    = HsCharPrim c
+    arity = length ps

 
 

-simplify_pat (NPat lit lit_ty hsexpr) = better_pat
+simplify_pat (TuplePat ps boxity)
+  = ConPat (tupleCon boxity arity)
+          (mkTupleTy boxity arity (map outPatType ps)) [] []
+          (map simplify_pat ps)

   where
   where

-    better_pat
-      | lit_ty `eqTy` charTy   = ConPat charDataCon   lit_ty [LitPat (mk_char lit)   charPrimTy]
-      | lit_ty `eqTy` intTy    = ConPat intDataCon    lit_ty [LitPat (mk_int lit)    intPrimTy]
-      | lit_ty `eqTy` wordTy   = ConPat wordDataCon   lit_ty [LitPat (mk_word lit)   wordPrimTy]
-      | lit_ty `eqTy` addrTy   = ConPat addrDataCon   lit_ty [LitPat (mk_addr lit)   addrPrimTy]
-      | lit_ty `eqTy` floatTy  = ConPat floatDataCon  lit_ty [LitPat (mk_float lit)  floatPrimTy]
-      | lit_ty `eqTy` 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 [] 
-
-      | otherwise             = NPat lit lit_ty hsexpr
-
-    mk_int    (HsInt i)      = HsIntPrim i
-    mk_int    l@(HsLitLit s) = l
+    arity = length ps

 
 

-    mk_char   (HsChar c)     = HsCharPrim c
-    mk_char   l@(HsLitLit s) = l
-
-    mk_word   l@(HsLitLit s) = l
-
-    mk_addr   l@(HsLitLit s) = l
+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

 
 

-    mk_float  (HsInt i)      = HsFloatPrim (fromInteger i)
-    mk_float  (HsFrac f)     = HsFloatPrim f
-    mk_float  l@(HsLitLit s) = l
+      -- Identical to machinations in Match.tidy1:
+    inst_tys    = tcTyConAppArgs ty    -- Newtype is observable
+    con_arg_tys = dataConArgTys dc (inst_tys ++ mkTyVarTys ex_tvs)

 
 

-    mk_double (HsInt i)      = HsDoublePrim (fromInteger i)
-    mk_double (HsFrac f)     = HsDoublePrim f
-    mk_double l@(HsLitLit s) = l
+simplify_pat (RecPat dc ty ex_tvs dicts idps) 
+  = ConPat dc ty ex_tvs dicts pats
+  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
+
+simplify_pat pat@(LitPat lit lit_ty)        = tidyLitPat lit 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)
+  where
+    mk_char_lit c = ConPat charDataCon charTy [] [] 
+                       [LitPat (HsCharPrim c) charPrimTy]

 
 

-    null_str_lit (HsString s) = _NULL_ s
-    null_str_lit other_lit    = False
+simplify_pat pat@(NPat lit lit_ty hsexpr) = tidyNPat lit lit_ty pat

 
 

-simplify_pat (NPlusKPat        id hslit ty hsexpr1 hsexpr2) = --NPlusKPat id hslit ty hsexpr1 hsexpr2 
+simplify_pat (NPlusKPat        id hslit ty hsexpr1 hsexpr2) = 

      WildPat ty
      WildPat ty

-   where ty = panic "Check.simplify_pat: Never used"
+   where ty = panic "Check.simplify_pat: Gessing ty"

 
 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 []) 
+       0 -> simplify_pat (TuplePat [] Boxed) 

        1 -> simplify_pat (head dict_and_method_pats) 
        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)
     where
        num_of_d_and_ms  = length dicts + length methods
        dict_and_method_pats = map VarPat (dicts ++ methods)

-

 \end{code}
 \end{code}