Add {-# OPTIONS_GHC -w #-} and some blurb to all compiler modules

[ghc-hetmet.git] / compiler / deSugar / DsArrows.lhs

diff --git a/compiler/deSugar/DsArrows.lhs b/compiler/deSugar/DsArrows.lhs
index 4251b20..e819872 100644 (file)
--- a/compiler/deSugar/DsArrows.lhs
+++ b/compiler/deSugar/DsArrows.lhs
@@ -1,23 +1,28 @@
 %
+% (c) The University of Glasgow 2006
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
-\section[DsArrows]{Desugaring arrow commands}
+
+Desugaring arrow commands
 
 \begin{code}
+{-# OPTIONS_GHC -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/WorkingConventions#Warnings
+-- for details
+
 module DsArrows ( dsProcExpr ) where
 
 #include "HsVersions.h"
 
-import Match           ( matchSimply )
-import DsUtils         ( mkErrorAppDs,
-                         mkCoreTupTy, mkCoreTup, selectSimpleMatchVarL,
-                         mkTupleCase, mkBigCoreTup, mkTupleType,
-                         mkTupleExpr, mkTupleSelector,
-                         dsSyntaxTable, lookupEvidence )
+import Match
+import DsUtils
 import DsMonad
 
 import HsSyn
-import TcHsSyn         ( hsLPatType )
+import TcHsSyn
 
 -- NB: The desugarer, which straddles the source and Core worlds, sometimes
 --     needs to see source types (newtypes etc), and sometimes not
@@ -26,29 +31,26 @@ import TcHsSyn              ( hsLPatType )
 
 import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLocalBinds )
 
-import TcType          ( Type, tcSplitAppTy, mkFunTy )
-import Type            ( mkTyConApp, funArgTy )
+import TcType
+import Type
 import CoreSyn
-import CoreFVs         ( exprFreeVars )
-import CoreUtils       ( mkIfThenElse, bindNonRec, exprType )
-
-import Id              ( Id, idType )
-import Name            ( Name )
-import PrelInfo                ( pAT_ERROR_ID )
-import DataCon         ( dataConWrapId )
-import TysWiredIn      ( tupleCon )
-import BasicTypes      ( Boxity(..) )
-import PrelNames       ( eitherTyConName, leftDataConName, rightDataConName,
-                         arrAName, composeAName, firstAName,
-                         appAName, choiceAName, loopAName )
-import Util            ( mapAccumL )
-import Outputable
-
-import HsUtils         ( collectPatBinders, collectPatsBinders )
-import VarSet          ( IdSet, mkVarSet, varSetElems,
-                         intersectVarSet, minusVarSet, extendVarSetList, 
-                         unionVarSet, unionVarSets, elemVarSet )
-import SrcLoc          ( Located(..), unLoc, noLoc )
+import CoreFVs
+import CoreUtils
+
+import Id
+import Name
+import PrelInfo
+import DataCon
+import TysWiredIn
+import BasicTypes
+import PrelNames
+import Util
+
+import HsUtils
+import VarSet
+import SrcLoc
+
+import Data.List
 \end{code}
 
 \begin{code}
@@ -593,6 +595,12 @@ dsCmd _ids local_vars env_ids _stack _res_ty (HsArrForm op _ args)
     returnDs (mkApps (App core_op (Type env_ty)) core_args,
              unionVarSets fv_sets)
 
+
+dsCmd ids local_vars env_ids stack res_ty (HsTick ix vars expr)
+  = dsLCmd ids local_vars env_ids stack res_ty expr `thenDs` \ (expr1,id_set) ->
+    mkTickBox ix vars expr1                                `thenDs` \ expr2 ->
+    return (expr2,id_set)
+
 --     A | ys |- c :: [ts] t   (ys <= xs)
 --     ---------------------
 --     A | xs |- c :: [ts] t   ---> arr_ts (\ (xs) -> (ys)) >>> c