[project @ 1998-02-24 15:51:44 by simonpj]

Better pattern binding desugaring

diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs
index cdc3fdd..d82217d 100644 (file)
--- a/ghc/compiler/deSugar/DsUtils.lhs
+++ b/ghc/compiler/deSugar/DsUtils.lhs
@@ -20,7 +20,6 @@ module DsUtils (
        mkFailurePair,
        mkGuardedMatchResult,
        mkSelectorBinds,
-       mkTupleBind,
        mkTupleExpr,
        mkTupleSelector,
        selectMatchVars,
@@ -51,7 +50,7 @@ import Type           ( mkRhoTy, mkFunTy,
                        )
 import BasicTypes      ( Unused )
 import TysPrim         ( voidTy )
-import TysWiredIn      ( unitDataCon, tupleCon )
+import TysWiredIn      ( unitDataCon, tupleCon, stringTy )
 import UniqSet         ( mkUniqSet, minusUniqSet, uniqSetToList, UniqSet )
 import Unique          ( Unique )
 import Outputable
@@ -373,50 +372,63 @@ mkSelectorBinds (VarPat v) val_expr
   = returnDs [(v, val_expr)]
 
 mkSelectorBinds pat val_expr
-  | is_simple_tuple_pat pat 
-  = mkTupleBind binders val_expr
-
-  | otherwise
-  = mkErrorAppDs iRREFUT_PAT_ERROR_ID res_ty pat_string                `thenDs` \ error_expr ->
-    matchSimply val_expr LetMatch pat res_ty local_tuple error_expr    `thenDs` \ tuple_expr ->
-    mkTupleBind binders tuple_expr
-
-  where
-    binders    = collectTypedPatBinders pat
-    local_tuple = mkTupleExpr binders
-    res_ty      = coreExprType local_tuple
-
-    is_simple_tuple_pat (TuplePat ps) = all is_var_pat ps
-    is_simple_tuple_pat other         = False
-
-    is_var_pat (VarPat v) = True
-    is_var_pat other      = False -- Even wild-card patterns aren't acceptable
-
-    pat_string = showSDoc (ppr pat)
-\end{code}
-
-
-\begin{code}
-mkTupleBind :: [Id]                    -- Names of tuple components
-           -> CoreExpr                 -- Expr whose value is a tuple of correct type
-           -> DsM [(Id, CoreExpr)]     -- Bindings for the globals
+  | length binders == 1 || is_simple_pat pat
+  = newSysLocalDs (coreExprType val_expr)      `thenDs` \ val_var ->
 
+       -- For the error message we don't use mkErrorAppDs to avoid
+       -- duplicating the string literal each time
+    newSysLocalDs stringTy                     `thenDs` \ msg_var ->
+    getSrcLocDs                                        `thenDs` \ src_loc ->
+    let
+       full_msg = showSDoc (hcat [ppr src_loc, text "|", ppr pat])
+       msg_lit  = NoRepStr (_PK_ full_msg)
+    in
+    mapDs (mk_bind val_var msg_var) binders    `thenDs` \ binds ->
+    returnDs ( (val_var, val_expr) : 
+              (msg_var, Lit msg_lit) :
+              binds )
 
-mkTupleBind [local] tuple_expr
-  = returnDs [(local, tuple_expr)]
 
-mkTupleBind locals tuple_expr
-  = newSysLocalDs (coreExprType tuple_expr)    `thenDs` \ tuple_var ->
+  | otherwise
+  = mkErrorAppDs iRREFUT_PAT_ERROR_ID tuple_ty (showSDoc (ppr pat))    `thenDs` \ error_expr ->
+    matchSimply val_expr LetMatch pat tuple_ty local_tuple error_expr  `thenDs` \ tuple_expr ->
+    newSysLocalDs tuple_ty                                             `thenDs` \ tuple_var ->
     let
-       mk_bind local = (local, mkTupleSelector locals local (Var tuple_var))
+       mk_tup_bind binder = (binder, mkTupleSelector binders binder (Var tuple_var))
     in
-    returnDs ( (tuple_var, tuple_expr) :
-              map mk_bind locals )
+    returnDs ( (tuple_var, tuple_expr) : map mk_tup_bind binders )
+  where
+    binders    = collectTypedPatBinders pat
+    local_tuple = mkTupleExpr binders
+    tuple_ty    = coreExprType local_tuple
+
+    mk_bind scrut_var msg_var bndr_var
+    -- (mk_bind sv bv) generates
+    --         bv = case sv of { pat -> bv; other -> error-msg }
+    -- Remember, pat binds bv
+      = matchSimply (Var scrut_var) LetMatch pat binder_ty 
+                   (Var bndr_var) error_expr                   `thenDs` \ rhs_expr ->
+        returnDs (bndr_var, rhs_expr)
+      where
+        binder_ty = idType bndr_var
+        error_expr = mkApp (Var iRREFUT_PAT_ERROR_ID) [binder_ty] [VarArg msg_var]
+
+    is_simple_pat (TuplePat ps)        = all is_triv_pat ps
+    is_simple_pat (ConPat _ _ ps)      = all is_triv_pat ps
+    is_simple_pat (VarPat _)          = True
+    is_simple_pat (ConOpPat p1 _ p2 _) = is_triv_pat p1 && is_triv_pat p2
+    is_simple_pat (RecPat _ _ ps)      = and [is_triv_pat p | (_,p,_) <- ps]
+    is_simple_pat other                       = False
+
+    is_triv_pat (VarPat v)  = True
+    is_triv_pat (WildPat _) = True
+    is_triv_pat other       = False
 \end{code}
 
 
 @mkTupleExpr@ builds a tuple; the inverse to @mkTupleSelector@.  If it
 has only one element, it is the identity function.
+
 \begin{code}
 mkTupleExpr :: [Id] -> CoreExpr
 
@@ -443,17 +455,13 @@ mkTupleSelector :: [Id]                   -- The tuple args
                -> CoreExpr             -- Scrutinee
                -> CoreExpr
 
-mkTupleSelector [] the_var scrut = panic "mkTupleSelector"
-
 mkTupleSelector [var] should_be_the_same_var scrut
   = ASSERT(var == should_be_the_same_var)
     scrut
 
 mkTupleSelector vars the_var scrut
- = Case scrut (AlgAlts [(tupleCon arity, vars, Var the_var)]
-                         NoDefault)
- where
-   arity = length vars
+  = ASSERT( not (null vars) )
+    Case scrut (AlgAlts [(tupleCon (length vars), vars, Var the_var)] NoDefault)
 \end{code}