Make DsArrows warning-free

diff --git a/compiler/deSugar/DsArrows.lhs b/compiler/deSugar/DsArrows.lhs
index 46a8049..adc449c 100644 (file)
--- a/compiler/deSugar/DsArrows.lhs
+++ b/compiler/deSugar/DsArrows.lhs
@@ -6,13 +6,6 @@
 Desugaring arrow commands
 
 \begin{code}
 Desugaring arrow commands
 
 \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 DsArrows ( dsProcExpr ) where
 
 #include "HsVersions.h"
 module DsArrows ( dsProcExpr ) where
 
 #include "HsVersions.h"

@@ -38,14 +31,14 @@ import CoreSyn
 import CoreFVs
 import CoreUtils
 
 import CoreFVs
 import CoreUtils
 

-import Id

 import Name
 import Name

+import Var

 import PrelInfo
 import DataCon
 import TysWiredIn
 import BasicTypes
 import PrelNames
 import PrelInfo
 import DataCon
 import TysWiredIn
 import BasicTypes
 import PrelNames

-import Util
+import Outputable

 
 import VarSet
 import SrcLoc
 
 import VarSet
 import SrcLoc

@@ -251,7 +244,7 @@ dsProcExpr
 dsProcExpr pat (L _ (HsCmdTop cmd [] cmd_ty ids)) = do
     meth_ids <- mkCmdEnv ids
     let locals = mkVarSet (collectPatBinders pat)
 dsProcExpr pat (L _ (HsCmdTop cmd [] cmd_ty ids)) = do
     meth_ids <- mkCmdEnv ids
     let locals = mkVarSet (collectPatBinders pat)

-    (core_cmd, free_vars, env_ids) <- dsfixCmd meth_ids locals [] cmd_ty cmd
+    (core_cmd, _free_vars, env_ids) <- dsfixCmd meth_ids locals [] cmd_ty cmd

     let env_ty = mkBigCoreVarTupTy env_ids
     fail_expr <- mkFailExpr ProcExpr env_ty
     var <- selectSimpleMatchVarL pat
     let env_ty = mkBigCoreVarTupTy env_ids
     fail_expr <- mkFailExpr ProcExpr env_ty
     var <- selectSimpleMatchVarL pat

@@ -261,6 +254,7 @@ dsProcExpr pat (L _ (HsCmdTop cmd [] cmd_ty ids)) = do
                     (Lam var match_code)
                     core_cmd
     return (bindCmdEnv meth_ids proc_code)
                     (Lam var match_code)
                     core_cmd
     return (bindCmdEnv meth_ids proc_code)

+dsProcExpr _ c = pprPanic "dsProcExpr" (ppr c)

 \end{code}
 
 Translation of command judgements of the form
 \end{code}
 
 Translation of command judgements of the form

@@ -268,6 +262,8 @@ Translation of command judgements of the form
        A | xs |- c :: [ts] t
 
 \begin{code}
        A | xs |- c :: [ts] t
 
 \begin{code}

+dsLCmd :: DsCmdEnv -> IdSet -> [Id] -> [Type] -> Type -> LHsCmd Id
+       -> DsM (CoreExpr, IdSet)

 dsLCmd ids local_vars env_ids stack res_ty cmd
   = dsCmd ids local_vars env_ids stack res_ty (unLoc cmd)
 
 dsLCmd ids local_vars env_ids stack res_ty cmd
   = dsCmd ids local_vars env_ids stack res_ty (unLoc cmd)
 

@@ -294,7 +290,6 @@ dsCmd ids local_vars env_ids stack res_ty
     let
         (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
         (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty
     let
         (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
         (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty

-        env_ty = mkBigCoreVarTupTy env_ids

     core_arrow <- dsLExpr arrow
     core_arg   <- dsLExpr arg
     stack_ids  <- mapM newSysLocalDs stack
     core_arrow <- dsLExpr arrow
     core_arg   <- dsLExpr arg
     stack_ids  <- mapM newSysLocalDs stack

@@ -320,7 +315,6 @@ dsCmd ids local_vars env_ids stack res_ty
     let
         (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
         (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty
     let
         (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
         (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty

-        env_ty = mkBigCoreVarTupTy env_ids

     
     core_arrow <- dsLExpr arrow
     core_arg   <- dsLExpr arg
     
     core_arrow <- dsLExpr arrow
     core_arg   <- dsLExpr arg

@@ -538,7 +532,7 @@ dsCmd ids local_vars env_ids stack res_ty (HsLet binds body) = do
         defined_vars = mkVarSet (map unLoc (collectLocalBinders binds))
         local_vars' = local_vars `unionVarSet` defined_vars
     
         defined_vars = mkVarSet (map unLoc (collectLocalBinders binds))
         local_vars' = local_vars `unionVarSet` defined_vars
     

-    (core_body, free_vars, env_ids') <- dsfixCmd ids local_vars' stack res_ty body
+    (core_body, _free_vars, env_ids') <- dsfixCmd ids local_vars' stack res_ty body

     stack_ids <- mapM newSysLocalDs stack
     -- build a new environment, plus the stack, using the let bindings
     core_binds <- dsLocalBinds binds (buildEnvStack env_ids' stack_ids)
     stack_ids <- mapM newSysLocalDs stack
     -- build a new environment, plus the stack, using the let bindings
     core_binds <- dsLocalBinds binds (buildEnvStack env_ids' stack_ids)

@@ -573,6 +567,8 @@ dsCmd ids local_vars env_ids stack res_ty (HsTick ix vars expr) = do
     expr2 <- mkTickBox ix vars expr1
     return (expr2,id_set)
 
     expr2 <- mkTickBox ix vars expr1
     return (expr2,id_set)
 

+dsCmd _ _ _ _ _ c = pprPanic "dsCmd" (ppr c)
+

 --     A | ys |- c :: [ts] t   (ys <= xs)
 --     ---------------------
 --     A | xs |- c :: [ts] t   ---> arr_ts (\ (xs) -> (ys)) >>> c
 --     A | ys |- c :: [ts] t   (ys <= xs)
 --     ---------------------
 --     A | xs |- c :: [ts] t   ---> arr_ts (\ (xs) -> (ys)) >>> c

@@ -642,7 +638,7 @@ dsCmdDo ids local_vars env_ids res_ty (stmt:stmts) body = do
     let
         bound_vars = mkVarSet (map unLoc (collectLStmtBinders stmt))
         local_vars' = local_vars `unionVarSet` bound_vars
     let
         bound_vars = mkVarSet (map unLoc (collectLStmtBinders stmt))
         local_vars' = local_vars `unionVarSet` bound_vars

-    (core_stmts, fv_stmts, env_ids') <- fixDs (\ ~(_,_,env_ids') -> do
+    (core_stmts, _, env_ids') <- fixDs (\ ~(_,_,env_ids') -> do

         (core_stmts, fv_stmts) <- dsCmdDo ids local_vars' env_ids' res_ty stmts body
         return (core_stmts, fv_stmts, varSetElems fv_stmts))
     (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids env_ids' stmt
         (core_stmts, fv_stmts) <- dsCmdDo ids local_vars' env_ids' res_ty stmts body
         return (core_stmts, fv_stmts, varSetElems fv_stmts))
     (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids env_ids' stmt

@@ -659,6 +655,8 @@ A statement maps one local environment to another, and is represented
 as an arrow from one tuple type to another.  A statement sequence is
 translated to a composition of such arrows.
 \begin{code}
 as an arrow from one tuple type to another.  A statement sequence is
 translated to a composition of such arrows.
 \begin{code}

+dsCmdLStmt :: DsCmdEnv -> IdSet -> [Id] -> [Id] -> LStmt Id
+           -> DsM (CoreExpr, IdSet)

 dsCmdLStmt ids local_vars env_ids out_ids cmd
   = dsCmdStmt ids local_vars env_ids out_ids (unLoc cmd)
 
 dsCmdLStmt ids local_vars env_ids out_ids cmd
   = dsCmdStmt ids local_vars env_ids out_ids (unLoc cmd)
 

@@ -784,7 +782,7 @@ dsCmdStmt ids local_vars env_ids out_ids (LetStmt binds) = do
 --                     first (loop (arr (\((ys1),~(ys2)) -> (ys)) >>> ss)) >>>
 --                     arr (\((xs1),(xs2)) -> (xs')) >>> ss'
 
 --                     first (loop (arr (\((ys1),~(ys2)) -> (ys)) >>> ss)) >>>
 --                     arr (\((xs1),(xs2)) -> (xs')) >>> ss'
 

-dsCmdStmt ids local_vars env_ids out_ids (RecStmt stmts later_ids rec_ids rhss binds) = do
+dsCmdStmt ids local_vars env_ids out_ids (RecStmt stmts later_ids rec_ids rhss _binds) = do

     let         -- ToDo: ****** binds not desugared; ROSS PLEASE FIX ********
         env2_id_set = mkVarSet out_ids `minusVarSet` mkVarSet later_ids
         env2_ids = varSetElems env2_id_set
     let         -- ToDo: ****** binds not desugared; ROSS PLEASE FIX ********
         env2_id_set = mkVarSet out_ids `minusVarSet` mkVarSet later_ids
         env2_ids = varSetElems env2_id_set

@@ -831,10 +829,14 @@ dsCmdStmt ids local_vars env_ids out_ids (RecStmt stmts later_ids rec_ids rhss b
 
     return (core_body, env1_id_set `unionVarSet` env2_id_set)
 
 
     return (core_body, env1_id_set `unionVarSet` env2_id_set)
 

+dsCmdStmt _ _ _ _ s = pprPanic "dsCmdStmt" (ppr s)
+

 --     loop (arr (\ ((env1_ids), ~(rec_ids)) -> (env_ids)) >>>
 --           ss >>>
 --           arr (\ (out_ids) -> ((later_ids),(rhss))) >>>
 
 --     loop (arr (\ ((env1_ids), ~(rec_ids)) -> (env_ids)) >>>
 --           ss >>>
 --           arr (\ (out_ids) -> ((later_ids),(rhss))) >>>
 

+dsRecCmd :: DsCmdEnv -> VarSet -> [LStmt Id] -> [Var] -> [Var] -> [HsExpr Id]
+         -> DsM (CoreExpr, VarSet, [Var])

 dsRecCmd ids local_vars stmts later_ids rec_ids rhss = do
     let
         rec_id_set = mkVarSet rec_ids
 dsRecCmd ids local_vars stmts later_ids rec_ids rhss = do
     let
         rec_id_set = mkVarSet rec_ids

@@ -924,7 +926,7 @@ dsCmdStmts ids local_vars env_ids out_ids (stmt:stmts) = do
     let
         bound_vars = mkVarSet (map unLoc (collectLStmtBinders stmt))
         local_vars' = local_vars `unionVarSet` bound_vars
     let
         bound_vars = mkVarSet (map unLoc (collectLStmtBinders stmt))
         local_vars' = local_vars `unionVarSet` bound_vars

-    (core_stmts, fv_stmts, env_ids') <- dsfixCmdStmts ids local_vars' out_ids stmts
+    (core_stmts, _fv_stmts, env_ids') <- dsfixCmdStmts ids local_vars' out_ids stmts

     (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids env_ids' stmt
     return (do_compose ids
                 (mkBigCoreVarTupTy env_ids)
     (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids env_ids' stmt
     return (do_compose ids
                 (mkBigCoreVarTupTy env_ids)

@@ -934,6 +936,8 @@ dsCmdStmts ids local_vars env_ids out_ids (stmt:stmts) = do
                 core_stmts,
               fv_stmt)
 
                 core_stmts,
               fv_stmt)
 

+dsCmdStmts _ _ _ _ [] = panic "dsCmdStmts []"
+

 \end{code}
 
 Match a list of expressions against a list of patterns, left-to-right.
 \end{code}
 
 Match a list of expressions against a list of patterns, left-to-right.

@@ -949,6 +953,7 @@ matchSimplys [] _ctxt [] result_expr _fail_expr = return result_expr
 matchSimplys (exp:exps) ctxt (pat:pats) result_expr fail_expr = do
     match_code <- matchSimplys exps ctxt pats result_expr fail_expr
     matchSimply exp ctxt pat match_code fail_expr
 matchSimplys (exp:exps) ctxt (pat:pats) result_expr fail_expr = do
     match_code <- matchSimplys exps ctxt pats result_expr fail_expr
     matchSimply exp ctxt pat match_code fail_expr

+matchSimplys _ _ _ _ _ = panic "matchSimplys"

 \end{code}
 
 List of leaf expressions, with set of variables bound in each
 \end{code}
 
 List of leaf expressions, with set of variables bound in each

@@ -976,7 +981,7 @@ replaceLeavesMatch
        -> LMatch Id    -- the matches of a case command
        -> ([LHsExpr Id],-- remaining leaf expressions
            LMatch Id)  -- updated match
        -> LMatch Id    -- the matches of a case command
        -> ([LHsExpr Id],-- remaining leaf expressions
            LMatch Id)  -- updated match

-replaceLeavesMatch res_ty leaves (L loc (Match pat mt (GRHSs grhss binds)))
+replaceLeavesMatch _res_ty leaves (L loc (Match pat mt (GRHSs grhss binds)))

   = let
        (leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss
     in
   = let
        (leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss
     in

@@ -987,8 +992,9 @@ replaceLeavesGRHS
        -> LGRHS Id     -- rhss of a case command
        -> ([LHsExpr Id],-- remaining leaf expressions
            LGRHS Id)   -- updated GRHS
        -> LGRHS Id     -- rhss of a case command
        -> ([LHsExpr Id],-- remaining leaf expressions
            LGRHS Id)   -- updated GRHS

-replaceLeavesGRHS (leaf:leaves) (L loc (GRHS stmts rhs))
+replaceLeavesGRHS (leaf:leaves) (L loc (GRHS stmts _))

   = (leaves, L loc (GRHS stmts leaf))
   = (leaves, L loc (GRHS stmts leaf))

+replaceLeavesGRHS [] _ = panic "replaceLeavesGRHS []"

 \end{code}
 
 Balanced fold of a non-empty list.
 \end{code}
 
 Balanced fold of a non-empty list.

@@ -1023,19 +1029,20 @@ See comments in HsUtils for why the other version does not include
 these bindings.
 
 \begin{code}
 these bindings.
 
 \begin{code}

-collectPatBinders :: LPat a -> [a]
+collectPatBinders :: OutputableBndr a => LPat a -> [a]

 collectPatBinders pat = map unLoc (collectLocatedPatBinders pat)
 
 collectPatBinders pat = map unLoc (collectLocatedPatBinders pat)
 

-collectLocatedPatBinders :: LPat a -> [Located a]
+collectLocatedPatBinders :: OutputableBndr a => LPat a -> [Located a]

 collectLocatedPatBinders pat = collectl pat []
 
 collectLocatedPatBinders pat = collectl pat []
 

-collectPatsBinders :: [LPat a] -> [a]
+collectPatsBinders :: OutputableBndr a => [LPat a] -> [a]

 collectPatsBinders pats = map unLoc (collectLocatedPatsBinders pats)
 
 collectPatsBinders pats = map unLoc (collectLocatedPatsBinders pats)
 

-collectLocatedPatsBinders :: [LPat a] -> [Located a]
+collectLocatedPatsBinders :: OutputableBndr a => [LPat a] -> [Located a]

 collectLocatedPatsBinders pats = foldr collectl [] pats
 
 ---------------------
 collectLocatedPatsBinders pats = foldr collectl [] pats
 
 ---------------------

+collectl :: OutputableBndr a => LPat a -> [Located a] -> [Located a]

 collectl (L l pat) bndrs
   = go pat
   where
 collectl (L l pat) bndrs
   = go pat
   where

@@ -1052,7 +1059,7 @@ collectl (L l pat) bndrs
     go (PArrPat pats _)           = foldr collectl bndrs pats
     go (TuplePat pats _ _)        = foldr collectl bndrs pats
 
     go (PArrPat pats _)           = foldr collectl bndrs pats
     go (TuplePat pats _ _)        = foldr collectl bndrs pats
 

-    go (ConPatIn c ps)            = foldr collectl bndrs (hsConPatArgs ps)
+    go (ConPatIn _ ps)            = foldr collectl bndrs (hsConPatArgs ps)

     go (ConPatOut {pat_args=ps, pat_binds=ds}) =
                                     collectHsBindLocatedBinders ds
                                     ++ foldr collectl bndrs (hsConPatArgs ps)
     go (ConPatOut {pat_args=ps, pat_binds=ds}) =
                                     collectHsBindLocatedBinders ds
                                     ++ foldr collectl bndrs (hsConPatArgs ps)

@@ -1062,6 +1069,7 @@ collectl (L l pat) bndrs
 
     go (SigPatIn pat _)           = collectl pat bndrs
     go (SigPatOut pat _)          = collectl pat bndrs
 
     go (SigPatIn pat _)           = collectl pat bndrs
     go (SigPatOut pat _)          = collectl pat bndrs

-    go (TypePat ty)               = bndrs
-    go (CoPat _ pat ty)           = collectl (noLoc pat) bndrs
+    go (TypePat _)                = bndrs
+    go (CoPat _ pat _)            = collectl (noLoc pat) bndrs
+    go p                          = pprPanic "collectl/go" (ppr p)

 \end{code}
 \end{code}

diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs
index cef711f..542f166 100644 (file)
--- a/compiler/hsSyn/HsExpr.lhs
+++ b/compiler/hsSyn/HsExpr.lhs
@@ -491,6 +491,9 @@ pprCmdArg (HsCmdTop cmd@(L _ (HsArrForm _ Nothing [])) _ _ _)
 pprCmdArg (HsCmdTop cmd _ _ _)
   = parens (ppr_lexpr cmd)
 
 pprCmdArg (HsCmdTop cmd _ _ _)
   = parens (ppr_lexpr cmd)
 

+instance OutputableBndr id => Outputable (HsCmdTop id) where
+    ppr = pprCmdArg
+

 -- Put a var in backquotes if it's not an operator already
 pprInfix :: Outputable name => name -> SDoc
 pprInfix v | isOperator ppr_v = ppr_v
 -- Put a var in backquotes if it's not an operator already
 pprInfix :: Outputable name => name -> SDoc
 pprInfix v | isOperator ppr_v = ppr_v