lots of portability changes (#1405)

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

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

-{-# OPTIONS_GHC -w #-}
+{-# 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
 -- 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/WorkingConventions#Warnings
+--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings

 -- for details
 
 module HsUtils where
 -- for details
 
 module HsUtils where

@@ -32,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

@@ -87,7 +88,15 @@ mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e)
 
 mkHsWrap :: HsWrapper -> HsExpr id -> HsExpr id
 mkHsWrap co_fn e | isIdHsWrapper co_fn = e
 
 mkHsWrap :: HsWrapper -> HsExpr id -> HsExpr id
 mkHsWrap co_fn e | isIdHsWrapper co_fn = e

-                | otherwise          = HsWrap 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
+
+coiToHsWrapper :: CoercionI -> HsWrapper
+coiToHsWrapper IdCo     = idHsWrapper
+coiToHsWrapper (ACo co) = WpCo co

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

@@ -127,9 +136,16 @@ 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
 
 mkNPlusKPat id lit = NPlusKPat id lit noSyntaxExpr noSyntaxExpr
 

+mkTransformStmt   stmts usingExpr        = TransformStmt (stmts, []) usingExpr Nothing
+mkTransformByStmt stmts usingExpr byExpr = TransformStmt (stmts, []) usingExpr (Just byExpr)
+
+mkGroupUsingStmt   stmts usingExpr        = GroupStmt (stmts, []) (GroupByNothing usingExpr)
+mkGroupByStmt      stmts byExpr           = GroupStmt (stmts, []) (GroupBySomething (Right noSyntaxExpr) byExpr)
+mkGroupByUsingStmt stmts byExpr usingExpr = GroupStmt (stmts, []) (GroupBySomething (Left usingExpr) byExpr)
+

 mkExprStmt expr            = ExprStmt expr noSyntaxExpr placeHolderType
 mkBindStmt pat expr = BindStmt pat expr noSyntaxExpr noSyntaxExpr
 mkRecStmt stmts            = RecStmt stmts [] [] [] emptyLHsBinds
 mkExprStmt expr            = ExprStmt expr noSyntaxExpr placeHolderType
 mkBindStmt pat expr = BindStmt pat expr noSyntaxExpr noSyntaxExpr
 mkRecStmt stmts            = RecStmt stmts [] [] [] emptyLHsBinds

@@ -239,20 +255,20 @@ mkFunBind fn ms = FunBind { fun_id = fn, fun_infix = False, fun_matches = mkMatc
                            fun_tick = Nothing }
 
 
                            fun_tick = Nothing }
 
 

-mkVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> LHsBind RdrName
+mkVarBind :: SrcSpan -> id -> LHsExpr id -> LHsBind id

 mkVarBind loc var rhs = mk_easy_FunBind loc var [] rhs
 
 ------------
 mkVarBind loc var rhs = mk_easy_FunBind loc var [] rhs
 
 ------------

-mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName]
-               -> LHsExpr RdrName -> LHsBind RdrName
+mk_easy_FunBind :: SrcSpan -> id -> [LPat id]
+               -> LHsExpr id -> LHsBind id

 
 mk_easy_FunBind loc fun pats expr
   = L loc $ mkFunBind (L loc fun) [mkMatch pats expr emptyLocalBinds]
 
 ------------
 
 mk_easy_FunBind loc fun pats expr
   = L loc $ mkFunBind (L loc fun) [mkMatch pats expr emptyLocalBinds]
 
 ------------

-mk_FunBind :: SrcSpan -> RdrName
-          -> [([LPat RdrName], LHsExpr RdrName)]
-          -> LHsBind RdrName
+mk_FunBind :: SrcSpan -> id
+          -> [([LPat id], LHsExpr id)]
+          -> LHsBind id

 
 mk_FunBind loc fun [] = panic "TcGenDeriv:mk_FunBind"
 mk_FunBind loc fun pats_and_exprs
 
 mk_FunBind loc fun [] = panic "TcGenDeriv:mk_FunBind"
 mk_FunBind loc fun pats_and_exprs

@@ -289,18 +305,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

@@ -311,10 +327,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}
 

@@ -326,24 +342,25 @@ 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
 collectStmtBinders (ExprStmt _ _ _)     = []
 collectStmtBinders (ParStmt xs)         = collectLStmtsBinders
                                         $ concatMap fst xs
   -- 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 (ParStmt xs)         = collectLStmtsBinders
                                         $ concatMap fst xs

+collectStmtBinders (TransformStmt (stmts, _) _ _) = collectLStmtsBinders stmts
+collectStmtBinders (GroupStmt (stmts, _) _)     = collectLStmtsBinders stmts

 collectStmtBinders (RecStmt ss _ _ _ _) = collectLStmtsBinders ss
 collectStmtBinders (RecStmt ss _ _ _ _) = collectLStmtsBinders ss

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

 \end{code}
 
 
 \end{code}
 
 

@@ -384,6 +401,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

@@ -394,7 +412,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

@@ -413,6 +431,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