FIX: Make boxy splitters aware of type families

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

diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs
index b80145a..0f75769 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}
+{-# 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"
@@ -22,10 +29,10 @@ import HsExpr
 import HsPat
 import HsTypes 
 import HsLit
-import HsDecls
 
 import RdrName
 import Var
+import Coercion
 import Type
 import DataCon
 import Name
@@ -83,6 +90,10 @@ mkHsWrap :: HsWrapper -> HsExpr id -> HsExpr id
 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
@@ -101,7 +112,7 @@ mkHsDictLet binds expr
                            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
@@ -118,6 +129,7 @@ mkSimpleHsAlt pat expr
 
 mkHsIntegral   i       = HsIntegral   i  noSyntaxExpr
 mkHsFractional f       = HsFractional f  noSyntaxExpr
+mkHsIsString   s       = HsIsString   s  noSyntaxExpr
 mkHsDo ctxt stmts body = HsDo ctxt stmts body placeHolderType
 
 mkNPat lit neg     = NPat lit neg noSyntaxExpr placeHolderType
@@ -319,22 +331,24 @@ collectHsBindLocatedBinders binds = foldrBag (collectAcc . unLoc) [] binds
 %************************************************************************
 
 \begin{code}
-collectLStmtsBinders :: [LStmt id] -> [Located id]
+collectLStmtsBinders :: OutputableBndr id => [LStmt id] -> [Located id]
 collectLStmtsBinders = concatMap collectLStmtBinders
 
-collectStmtsBinders :: [Stmt id] -> [Located id]
+collectStmtsBinders :: OutputableBndr id => [Stmt id] -> [Located id]
 collectStmtsBinders = concatMap collectStmtBinders
 
-collectLStmtBinders :: LStmt id -> [Located id]
+collectLStmtBinders :: OutputableBndr id => LStmt id -> [Located id]
 collectLStmtBinders = collectStmtBinders . unLoc
 
-collectStmtBinders :: Stmt id -> [Located id]
+collectStmtBinders :: OutputableBndr id => Stmt id -> [Located id]
   -- Id Binders for a Stmt... [but what about pattern-sig type vars]?
 collectStmtBinders (BindStmt pat _ _ _) = collectLocatedPatBinders pat
 collectStmtBinders (LetStmt binds)      = collectLocalBinders binds
-collectStmtBinders (ExprStmt _ _ _)    = []
-collectStmtBinders (RecStmt ss _ _ _ _)        = collectLStmtsBinders ss
-collectStmtBinders other               = panic "collectStmtBinders"
+collectStmtBinders (ExprStmt _ _ _)     = []
+collectStmtBinders (ParStmt xs)         = collectLStmtsBinders
+                                        $ concatMap fst xs
+collectStmtBinders (RecStmt ss _ _ _ _) = collectLStmtsBinders ss
+collectStmtBinders s                    = pprPanic "collectStmtBinders" (ppr s)
 \end{code}
 
 
@@ -381,8 +395,8 @@ collectl (L l pat) bndrs
     go (PArrPat pats _)          = foldr collectl bndrs pats
     go (TuplePat pats _ _)       = foldr collectl bndrs pats
                                  
-    go (ConPatIn c ps)           = foldr collectl bndrs (hsConArgs ps)
-    go (ConPatOut {pat_args=ps})  = foldr collectl bndrs (hsConArgs ps)
+    go (ConPatIn c ps)           = foldr collectl bndrs (hsConPatArgs ps)
+    go (ConPatOut {pat_args=ps})  = foldr collectl bndrs (hsConPatArgs ps)
        -- See Note [Dictionary binders in ConPatOut]
     go (LitPat _)                = bndrs
     go (NPat _ _ _ _)            = bndrs
@@ -391,8 +405,6 @@ collectl (L l pat) bndrs
     go (SigPatIn pat _)                  = collectl pat bndrs
     go (SigPatOut pat _)         = collectl pat bndrs
     go (TypePat ty)               = bndrs
-    go (DictPat ids1 ids2)        = map noLoc ids1 ++ map noLoc ids2
-                                   ++ bndrs
     go (CoPat _ pat ty)           = collectl (noLoc pat) bndrs
 \end{code}
 
@@ -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.)
 
+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
@@ -425,27 +453,6 @@ collect_pat (ParPat  pat)          acc = collect_lpat pat acc
 collect_pat (ListPat pats _)           acc = foldr collect_lpat acc pats
 collect_pat (PArrPat pats _)           acc = foldr collect_lpat acc pats
 collect_pat (TuplePat pats _ _) acc = foldr collect_lpat acc pats
-collect_pat (ConPatIn c ps)     acc = foldr collect_lpat acc (hsConArgs ps)
+collect_pat (ConPatIn c ps)     acc = foldr collect_lpat acc (hsConPatArgs ps)
 collect_pat other              acc = acc       -- Literals, vars, wildcard
 \end{code}
-
-%************************************************************************
-%*                                                                     *
-%*     Getting the main binder name of a top declaration
-%*                                                                     *
-%************************************************************************
-
-\begin{code}
-
-getMainDeclBinder :: HsDecl name -> Maybe name
-getMainDeclBinder (TyClD d) = Just (tcdName d)
-getMainDeclBinder (ValD d)
-   = case collectAcc d [] of
-        []       -> Nothing   -- see rn003
-        (name:_) -> Just (unLoc name)
-getMainDeclBinder (SigD d) = sigNameNoLoc d
-getMainDeclBinder (ForD (ForeignImport name _ _)) = Just (unLoc name)
-getMainDeclBinder (ForD (ForeignExport name _ _)) = Just (unLoc name)
-getMainDeclBinder _ = Nothing
-
-\end{code}