View patterns, record wildcards, and record puns

[ghc-hetmet.git] / compiler / hsSyn / HsUtils.lhs

diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs
index e16a0bd..e9d80c0 100644 (file)
--- a/compiler/hsSyn/HsUtils.lhs
+++ b/compiler/hsSyn/HsUtils.lhs
@@ -13,6 +13,13 @@ which deal with the intantiated versions are located elsewhere:
    Id                  typecheck/TcHsSyn       
 
 \begin{code}
    Id                  typecheck/TcHsSyn       
 
 \begin{code}

+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+

 module HsUtils where
 
 #include "HsVersions.h"
 module HsUtils where
 
 #include "HsVersions.h"

@@ -25,6 +32,7 @@ import HsLit
 
 import RdrName
 import Var
 
 import RdrName
 import Var

+import Coercion

 import Type
 import DataCon
 import Name
 import Type
 import DataCon
 import Name

@@ -82,6 +90,10 @@ mkHsWrap :: HsWrapper -> HsExpr id -> HsExpr id
 mkHsWrap co_fn e | isIdHsWrapper co_fn = e
                 | otherwise          = HsWrap co_fn e
 
 mkHsWrap co_fn e | isIdHsWrapper co_fn = e
                 | otherwise          = HsWrap co_fn e
 

+mkHsWrapCoI :: CoercionI -> HsExpr id -> HsExpr id
+mkHsWrapCoI IdCo     e = e
+mkHsWrapCoI (ACo co) e = mkHsWrap (WpCo co) e
+

 mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id
 mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches))
        where
 mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id
 mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches))
        where

@@ -100,7 +112,7 @@ mkHsDictLet binds expr
                            val_binds = ValBindsOut [(Recursive, binds)] []
 
 mkHsConApp :: DataCon -> [Type] -> [HsExpr Id] -> LHsExpr Id
                            val_binds = ValBindsOut [(Recursive, binds)] []
 
 mkHsConApp :: DataCon -> [Type] -> [HsExpr Id] -> LHsExpr Id

--- Used for constructing dictinoary terms etc, so no locations 
+-- Used for constructing dictionary terms etc, so no locations 

 mkHsConApp data_con tys args 
   = foldl mk_app (nlHsTyApp (dataConWrapId data_con) tys) args
   where
 mkHsConApp data_con tys args 
   = foldl mk_app (nlHsTyApp (dataConWrapId data_con) tys) args
   where

@@ -120,7 +132,7 @@ mkHsFractional f       = HsFractional f  noSyntaxExpr
 mkHsIsString   s       = HsIsString   s  noSyntaxExpr
 mkHsDo ctxt stmts body = HsDo ctxt stmts body placeHolderType
 
 mkHsIsString   s       = HsIsString   s  noSyntaxExpr
 mkHsDo ctxt stmts body = HsDo ctxt stmts body placeHolderType
 

-mkNPat lit neg     = NPat lit neg noSyntaxExpr placeHolderType
+mkNPat lit neg     = NPat lit neg noSyntaxExpr

 mkNPlusKPat id lit = NPlusKPat id lit noSyntaxExpr noSyntaxExpr
 
 mkExprStmt expr            = ExprStmt expr noSyntaxExpr placeHolderType
 mkNPlusKPat id lit = NPlusKPat id lit noSyntaxExpr noSyntaxExpr
 
 mkExprStmt expr            = ExprStmt expr noSyntaxExpr placeHolderType

@@ -282,18 +294,18 @@ where
 it should return [x, y, f, a, b] (remember, order important).
 
 \begin{code}
 it should return [x, y, f, a, b] (remember, order important).
 
 \begin{code}

-collectLocalBinders :: HsLocalBinds name -> [Located name]
+collectLocalBinders :: HsLocalBindsLR idL idR -> [Located idL]

 collectLocalBinders (HsValBinds val_binds) = collectHsValBinders val_binds
 collectLocalBinders (HsIPBinds _)   = []
 collectLocalBinders EmptyLocalBinds = []
 
 collectLocalBinders (HsValBinds val_binds) = collectHsValBinders val_binds
 collectLocalBinders (HsIPBinds _)   = []
 collectLocalBinders EmptyLocalBinds = []
 

-collectHsValBinders :: HsValBinds name -> [Located name]
+collectHsValBinders :: HsValBindsLR idL idR -> [Located idL]

 collectHsValBinders (ValBindsIn binds sigs)  = collectHsBindLocatedBinders binds
 collectHsValBinders (ValBindsOut binds sigs) = foldr collect_one [] binds
   where
    collect_one (_,binds) acc = foldrBag (collectAcc . unLoc) acc binds
 
 collectHsValBinders (ValBindsIn binds sigs)  = collectHsBindLocatedBinders binds
 collectHsValBinders (ValBindsOut binds sigs) = foldr collect_one [] binds
   where
    collect_one (_,binds) acc = foldrBag (collectAcc . unLoc) acc binds
 

-collectAcc :: HsBind name -> [Located name] -> [Located name]
+collectAcc :: HsBindLR idL idR -> [Located idL] -> [Located idL]

 collectAcc (PatBind { pat_lhs = p }) acc = collectLocatedPatBinders p ++ acc
 collectAcc (FunBind { fun_id = f })  acc    = f : acc
 collectAcc (VarBind { var_id = f })  acc    = noLoc f : acc
 collectAcc (PatBind { pat_lhs = p }) acc = collectLocatedPatBinders p ++ acc
 collectAcc (FunBind { fun_id = f })  acc    = f : acc
 collectAcc (VarBind { var_id = f })  acc    = noLoc f : acc

@@ -304,10 +316,10 @@ collectAcc (AbsBinds { abs_exports = dbinds, abs_binds = binds }) acc
        -- The only time we collect binders from a typechecked 
        -- binding (hence see AbsBinds) is in zonking in TcHsSyn
 
        -- The only time we collect binders from a typechecked 
        -- binding (hence see AbsBinds) is in zonking in TcHsSyn
 

-collectHsBindBinders :: LHsBinds name -> [name]
+collectHsBindBinders :: LHsBindsLR idL idR -> [idL]

 collectHsBindBinders binds = map unLoc (collectHsBindLocatedBinders binds)
 
 collectHsBindBinders binds = map unLoc (collectHsBindLocatedBinders binds)
 

-collectHsBindLocatedBinders :: LHsBinds name -> [Located name]
+collectHsBindLocatedBinders :: LHsBindsLR idL idR -> [Located idL]

 collectHsBindLocatedBinders binds = foldrBag (collectAcc . unLoc) [] binds
 \end{code}
 
 collectHsBindLocatedBinders binds = foldrBag (collectAcc . unLoc) [] binds
 \end{code}
 

@@ -319,16 +331,16 @@ collectHsBindLocatedBinders binds = foldrBag (collectAcc . unLoc) [] binds
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}

-collectLStmtsBinders :: OutputableBndr id => [LStmt id] -> [Located id]
+collectLStmtsBinders :: [LStmtLR idL idR] -> [Located idL]

 collectLStmtsBinders = concatMap collectLStmtBinders
 
 collectLStmtsBinders = concatMap collectLStmtBinders
 

-collectStmtsBinders :: OutputableBndr id => [Stmt id] -> [Located id]
+collectStmtsBinders :: [StmtLR idL idR] -> [Located idL]

 collectStmtsBinders = concatMap collectStmtBinders
 
 collectStmtsBinders = concatMap collectStmtBinders
 

-collectLStmtBinders :: OutputableBndr id => LStmt id -> [Located id]
+collectLStmtBinders :: LStmtLR idL idR -> [Located idL]

 collectLStmtBinders = collectStmtBinders . unLoc
 
 collectLStmtBinders = collectStmtBinders . unLoc
 

-collectStmtBinders :: OutputableBndr id => Stmt id -> [Located id]
+collectStmtBinders :: StmtLR idL idR -> [Located idL]

   -- Id Binders for a Stmt... [but what about pattern-sig type vars]?
 collectStmtBinders (BindStmt pat _ _ _) = collectLocatedPatBinders pat
 collectStmtBinders (LetStmt binds)      = collectLocalBinders binds
   -- Id Binders for a Stmt... [but what about pattern-sig type vars]?
 collectStmtBinders (BindStmt pat _ _ _) = collectLocatedPatBinders pat
 collectStmtBinders (LetStmt binds)      = collectLocalBinders binds

@@ -336,7 +348,6 @@ collectStmtBinders (ExprStmt _ _ _)     = []
 collectStmtBinders (ParStmt xs)         = collectLStmtsBinders
                                         $ concatMap fst xs
 collectStmtBinders (RecStmt ss _ _ _ _) = collectLStmtsBinders ss
 collectStmtBinders (ParStmt xs)         = collectLStmtsBinders
                                         $ concatMap fst xs
 collectStmtBinders (RecStmt ss _ _ _ _) = collectLStmtsBinders ss

-collectStmtBinders s                    = pprPanic "collectStmtBinders" (ppr s)

 \end{code}
 
 
 \end{code}
 
 

@@ -377,6 +388,7 @@ collectl (L l pat) bndrs
     go (LazyPat pat)             = collectl pat bndrs
     go (BangPat pat)             = collectl pat bndrs
     go (AsPat a pat)             = a : collectl pat bndrs
     go (LazyPat pat)             = collectl pat bndrs
     go (BangPat pat)             = collectl pat bndrs
     go (AsPat a pat)             = a : collectl pat bndrs

+    go (ViewPat exp pat _)     = collectl pat bndrs

     go (ParPat  pat)             = collectl pat bndrs
                                  
     go (ListPat pats _)          = foldr collectl bndrs pats
     go (ParPat  pat)             = collectl pat bndrs
                                  
     go (ListPat pats _)          = foldr collectl bndrs pats

@@ -387,7 +399,7 @@ collectl (L l pat) bndrs
     go (ConPatOut {pat_args=ps})  = foldr collectl bndrs (hsConPatArgs ps)
        -- See Note [Dictionary binders in ConPatOut]
     go (LitPat _)                = bndrs
     go (ConPatOut {pat_args=ps})  = foldr collectl bndrs (hsConPatArgs ps)
        -- See Note [Dictionary binders in ConPatOut]
     go (LitPat _)                = bndrs

-    go (NPat _ _ _ _)            = bndrs
+    go (NPat _ _ _)              = bndrs

     go (NPlusKPat n _ _ _)        = n : bndrs
                                  
     go (SigPatIn pat _)                  = collectl pat bndrs
     go (NPlusKPat n _ _ _)        = n : bndrs
                                  
     go (SigPatIn pat _)                  = collectl pat bndrs

@@ -406,6 +418,22 @@ collectPatBinders.  In a lazy pattern, for example f ~(C x y) = ...,
 we want to generate bindings for x,y but not for dictionaries bound by
 C.  (The type checker ensures they would not be used.)
 
 we want to generate bindings for x,y but not for dictionaries bound by
 C.  (The type checker ensures they would not be used.)
 

+Desugaring of arrow case expressions needs these bindings (see DsArrows
+and arrowcase1), but SPJ (Jan 2007) says it's safer for it to use its
+own pat-binder-collector:
+
+Here's the problem.  Consider
+
+data T a where
+   C :: Num a => a -> Int -> T a
+
+f ~(C (n+1) m) = (n,m)
+
+Here, the pattern (C (n+1)) binds a hidden dictionary (d::Num a),
+and *also* uses that dictionary to match the (n+1) pattern.  Yet, the
+variables bound by the lazy pattern are n,m, *not* the dictionary d.
+So in mkSelectorBinds in DsUtils, we want just m,n as the variables bound.
+

 \begin{code}
 collectSigTysFromPats :: [InPat name] -> [LHsType name]
 collectSigTysFromPats pats = foldr collect_lpat [] pats
 \begin{code}
 collectSigTysFromPats :: [InPat name] -> [LHsType name]
 collectSigTysFromPats pats = foldr collect_lpat [] pats