De-tabify and remove trailing whitespace
authorSimon Peyton Jones <simonpj@microsoft.com>
Fri, 26 Sep 2014 11:58:41 +0000 (12:58 +0100)
committerSimon Peyton Jones <simonpj@microsoft.com>
Fri, 26 Sep 2014 12:55:11 +0000 (13:55 +0100)
26 files changed:
compiler/basicTypes/MkId.lhs
compiler/basicTypes/OccName.lhs
compiler/basicTypes/VarSet.lhs
compiler/coreSyn/CoreArity.lhs
compiler/coreSyn/CoreSyn.lhs
compiler/coreSyn/CoreUnfold.lhs
compiler/deSugar/DsArrows.lhs
compiler/deSugar/DsBinds.lhs
compiler/deSugar/DsUtils.lhs
compiler/deSugar/MatchCon.lhs
compiler/iface/BuildTyCl.lhs
compiler/iface/IfaceEnv.lhs
compiler/simplCore/FloatIn.lhs
compiler/simplCore/FloatOut.lhs
compiler/typecheck/FamInst.lhs
compiler/typecheck/Inst.lhs
compiler/typecheck/TcClassDcl.lhs
compiler/typecheck/TcDefaults.lhs
compiler/typecheck/TcErrors.lhs
compiler/typecheck/TcHsType.lhs
compiler/typecheck/TcMType.lhs
compiler/typecheck/TcMatches.lhs
compiler/typecheck/TcRules.lhs
compiler/types/Class.lhs
compiler/types/OptCoercion.lhs
compiler/types/TypeRep.lhs

index 7816ad9..5a317e2 100644 (file)
@@ -13,12 +13,6 @@ have a standard form, namely:
 
 \begin{code}
 {-# LANGUAGE CPP #-}
-{-# OPTIONS_GHC -fno-warn-tabs #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and
--- detab the module (please do the detabbing in a separate patch). See
---     http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
 
 module MkId (
         mkDictFunId, mkDictFunTy, mkDictSelId, mkDictSelRhs,
@@ -39,8 +33,8 @@ module MkId (
         nullAddrId, seqId, lazyId, lazyIdKey,
         coercionTokenId, magicDictId, coerceId,
 
-       -- Re-export error Ids
-       module PrelRules
+        -- Re-export error Ids
+        module PrelRules
     ) where
 
 #include "HsVersions.h"
@@ -54,7 +48,7 @@ import FamInstEnv
 import Coercion
 import TcType
 import MkCore
-import CoreUtils       ( exprType, mkCast )
+import CoreUtils        ( exprType, mkCast )
 import CoreUnfold
 import Literal
 import TyCon
@@ -106,8 +100,8 @@ There are several reasons why an Id might appear in the wiredInIds:
     is 'open'; that is can be unified with an unboxed type
 
     [The interface file format now carry such information, but there's
-    no way yet of expressing at the definition site for these 
-    error-reporting functions that they have an 'open' 
+    no way yet of expressing at the definition site for these
+    error-reporting functions that they have an 'open'
     result type. -- sof 1/99]
 
 (3) Other error functions (rUNTIME_ERROR_ID) are wired in (a) because
@@ -118,7 +112,7 @@ There are several reasons why an Id might appear in the wiredInIds:
     strictness of the version defined in GHC.Base
 
 In cases (2-4), the function has a definition in a library module, and
-can be called; but the wired-in version means that the details are 
+can be called; but the wired-in version means that the details are
 never read from that module's interface file; instead, the full definition
 is right here.
 
@@ -126,7 +120,7 @@ is right here.
 wiredInIds :: [Id]
 wiredInIds
   =  [lazyId, dollarId]
-  ++ errorIds          -- Defined in MkCore
+  ++ errorIds           -- Defined in MkCore
   ++ ghcPrimIds
 
 -- These Ids are exported from GHC.Prim
@@ -159,7 +153,7 @@ We're going to build a constructor that looks like:
 
         data (Data a, C b) =>  T a b = T1 !a !Int b
 
-        T1 = /\ a b -> 
+        T1 = /\ a b ->
              \d1::Data a, d2::C b ->
              \p q r -> case p of { p ->
                        case q of { q ->
@@ -175,7 +169,7 @@ Notice that
   the types a and Int.  Once we've done that we can throw d1 away too.
 
 * We use (case p of q -> ...) to evaluate p, rather than "seq" because
-  all that matters is that the arguments are evaluated.  "seq" is 
+  all that matters is that the arguments are evaluated.  "seq" is
   very careful to preserve evaluation order, which we don't need
   to be here.
 
@@ -254,7 +248,7 @@ part of the theta-type, so all is well.
 %************************************************************************
 
 Selecting a field for a dictionary.  If there is just one field, then
-there's nothing to do.  
+there's nothing to do.
 
 Dictionary selectors may get nested forall-types.  Thus:
 
@@ -263,8 +257,8 @@ Dictionary selectors may get nested forall-types.  Thus:
 
 Then the top-level type for op is
 
-        op :: forall a. Foo a => 
-              forall b. Ord b => 
+        op :: forall a. Foo a =>
+              forall b. Ord b =>
               a -> b -> b
 
 This is unlike ordinary record selectors, which have all the for-alls
@@ -272,18 +266,18 @@ at the outside.  When dealing with classes it's very convenient to
 recover the original type signature from the class op selector.
 
 \begin{code}
-mkDictSelId :: Name         -- Name of one of the *value* selectors 
-                            -- (dictionary superclass or method)
+mkDictSelId :: Name          -- Name of one of the *value* selectors
+                             -- (dictionary superclass or method)
             -> Class -> Id
 mkDictSelId name clas
   = mkGlobalId (ClassOpId clas) name sel_ty info
   where
-    tycon                 = classTyCon clas
+    tycon          = classTyCon clas
     sel_names      = map idName (classAllSelIds clas)
-    new_tycon             = isNewTyCon tycon
-    [data_con]            = tyConDataCons tycon
-    tyvars                = dataConUnivTyVars data_con
-    arg_tys               = dataConRepArgTys data_con  -- Includes the dictionary superclasses
+    new_tycon      = isNewTyCon tycon
+    [data_con]     = tyConDataCons tycon
+    tyvars         = dataConUnivTyVars data_con
+    arg_tys        = dataConRepArgTys data_con  -- Includes the dictionary superclasses
     val_index      = assoc "MkId.mkDictSelId" (sel_names `zip` [0..]) name
 
     sel_ty = mkForAllTys tyvars (mkFunTy (mkClassPred clas (mkTyVarTys tyvars))
@@ -296,23 +290,23 @@ mkDictSelId name clas
     info | new_tycon
          = base_info `setInlinePragInfo` alwaysInlinePragma
                      `setUnfoldingInfo`  mkInlineUnfolding (Just 1) (mkDictSelRhs clas val_index)
-                  -- See Note [Single-method classes] in TcInstDcls
-                  -- for why alwaysInlinePragma
+                   -- See Note [Single-method classes] in TcInstDcls
+                   -- for why alwaysInlinePragma
 
          | otherwise
          = base_info `setSpecInfo` mkSpecInfo [rule]
-                  -- Add a magic BuiltinRule, but no unfolding
-                  -- so that the rule is always available to fire.
-                  -- See Note [ClassOp/DFun selection] in TcInstDcls
+                   -- Add a magic BuiltinRule, but no unfolding
+                   -- so that the rule is always available to fire.
+                   -- See Note [ClassOp/DFun selection] in TcInstDcls
 
     n_ty_args = length tyvars
 
     -- This is the built-in rule that goes
-    --             op (dfT d1 d2) --->  opT d1 d2
-    rule = BuiltinRule { ru_name = fsLit "Class op " `appendFS` 
-                                    occNameFS (getOccName name)
+    --      op (dfT d1 d2) --->  opT d1 d2
+    rule = BuiltinRule { ru_name = fsLit "Class op " `appendFS`
+                                     occNameFS (getOccName name)
                        , ru_fn    = name
-                      , ru_nargs = n_ty_args + 1
+                       , ru_nargs = n_ty_args + 1
                        , ru_try   = dictSelRule val_index n_ty_args }
 
         -- The strictness signature is of the form U(AAAVAAAA) -> T
@@ -332,22 +326,22 @@ mkDictSelRhs :: Class
 mkDictSelRhs clas val_index
   = mkLams tyvars (Lam dict_id rhs_body)
   where
-    tycon                 = classTyCon clas
-    new_tycon             = isNewTyCon tycon
-    [data_con]            = tyConDataCons tycon
-    tyvars                = dataConUnivTyVars data_con
-    arg_tys               = dataConRepArgTys data_con  -- Includes the dictionary superclasses
+    tycon          = classTyCon clas
+    new_tycon      = isNewTyCon tycon
+    [data_con]     = tyConDataCons tycon
+    tyvars         = dataConUnivTyVars data_con
+    arg_tys        = dataConRepArgTys data_con  -- Includes the dictionary superclasses
 
     the_arg_id     = getNth arg_ids val_index
-    pred                  = mkClassPred clas (mkTyVarTys tyvars)
-    dict_id               = mkTemplateLocal 1 pred
-    arg_ids               = mkTemplateLocalsNum 2 arg_tys
+    pred           = mkClassPred clas (mkTyVarTys tyvars)
+    dict_id        = mkTemplateLocal 1 pred
+    arg_ids        = mkTemplateLocalsNum 2 arg_tys
 
     rhs_body | new_tycon = unwrapNewTypeBody tycon (map mkTyVarTy tyvars) (Var dict_id)
              | otherwise = Case (Var dict_id) dict_id (idType the_arg_id)
                                 [(DataAlt data_con, arg_ids, varToCoreExpr the_arg_id)]
-                               -- varToCoreExpr needed for equality superclass selectors
-                               --   sel a b d = case x of { MkC _ (g:a~b) _ -> CO g }
+                                -- varToCoreExpr needed for equality superclass selectors
+                                --   sel a b d = case x of { MkC _ (g:a~b) _ -> CO g }
 
 dictSelRule :: Int -> Arity -> RuleFun
 -- Tries to persuade the argument to look like a constructor
@@ -403,7 +397,7 @@ mkDataConWorkId wkr_name data_con
         -- the simplifier thinks that y is "sure to be evaluated" (because
         --  $wMkT is strict) and drops the case.  No, $wMkT is not strict.
         --
-        -- When the simplifer sees a pattern 
+        -- When the simplifer sees a pattern
         --      case e of MkT x -> ...
         -- it uses the dataConRepStrictness of MkT to mark x as evaluated;
         -- but that's fine... dataConRepStrictness comes from the data con
@@ -420,16 +414,16 @@ mkDataConWorkId wkr_name data_con
     id_arg1      = mkTemplateLocal 1 (head nt_arg_tys)
     newtype_unf  = ASSERT2( isVanillaDataCon data_con &&
                             isSingleton nt_arg_tys, ppr data_con  )
-                             -- Note [Newtype datacons]
-                   mkCompulsoryUnfolding $ 
-                   mkLams nt_tvs $ Lam id_arg1 $ 
+                              -- Note [Newtype datacons]
+                   mkCompulsoryUnfolding $
+                   mkLams nt_tvs $ Lam id_arg1 $
                    wrapNewTypeBody tycon res_ty_args (Var id_arg1)
 
 dataConCPR :: DataCon -> DmdResult
 dataConCPR con
-  | isDataTyCon tycon     -- Real data types only; that is, 
+  | isDataTyCon tycon     -- Real data types only; that is,
                           -- not unboxed tuples or newtypes
-  , isVanillaDataCon con  -- No existentials 
+  , isVanillaDataCon con  -- No existentials
   , wkr_arity > 0
   , wkr_arity <= mAX_CPR_SIZE
   = if is_prod then vanillaCprProdRes (dataConRepArity con)
@@ -444,9 +438,9 @@ dataConCPR con
     mAX_CPR_SIZE :: Arity
     mAX_CPR_SIZE = 10
     -- We do not treat very big tuples as CPR-ish:
-    --      a) for a start we get into trouble because there aren't 
-    --         "enough" unboxed tuple types (a tiresome restriction, 
-    --         but hard to fix), 
+    --      a) for a start we get into trouble because there aren't
+    --         "enough" unboxed tuple types (a tiresome restriction,
+    --         but hard to fix),
     --      b) more importantly, big unboxed tuples get returned mainly
     --         on the stack, and are often then allocated in the heap
     --         by the caller.  So doing CPR for them may in fact make
@@ -455,8 +449,8 @@ dataConCPR con
 
 -------------------------------------------------
 --         Data constructor representation
--- 
--- This is where we decide how to wrap/unwrap the 
+--
+-- This is where we decide how to wrap/unwrap the
 -- constructor fields
 --
 --------------------------------------------------
@@ -480,39 +474,39 @@ mkDataConRep dflags fam_envs wrap_name data_con
 
   | otherwise
   = do { wrap_args <- mapM newLocal wrap_arg_tys
-       ; wrap_body <- mk_rep_app (wrap_args `zip` dropList eq_spec unboxers) 
+       ; wrap_body <- mk_rep_app (wrap_args `zip` dropList eq_spec unboxers)
                                  initial_wrap_app
 
        ; let wrap_id = mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty wrap_info
              wrap_info = noCafIdInfo
-                        `setArityInfo`         wrap_arity
-                            -- It's important to specify the arity, so that partial
-                            -- applications are treated as values
-                        `setInlinePragInfo`    alwaysInlinePragma
-                        `setUnfoldingInfo`     wrap_unf
-                        `setStrictnessInfo`    wrap_sig
-                            -- We need to get the CAF info right here because TidyPgm
-                            -- does not tidy the IdInfo of implicit bindings (like the wrapper)
-                            -- so it not make sure that the CAF info is sane
-
-            wrap_sig = mkClosedStrictSig wrap_arg_dmds (dataConCPR data_con)
-            wrap_arg_dmds = map mk_dmd (dropList eq_spec wrap_bangs)
-            mk_dmd str | isBanged str = evalDmd
-                       | otherwise    = topDmd
-                -- The Cpr info can be important inside INLINE rhss, where the
-                -- wrapper constructor isn't inlined.
-                -- And the argument strictness can be important too; we
-                -- may not inline a contructor when it is partially applied.
-                -- For example:
-                --      data W = C !Int !Int !Int
-                --      ...(let w = C x in ...(w p q)...)...
-                -- we want to see that w is strict in its two arguments
-
-            wrap_unf = mkInlineUnfolding (Just wrap_arity) wrap_rhs
+                         `setArityInfo`         wrap_arity
+                             -- It's important to specify the arity, so that partial
+                             -- applications are treated as values
+                         `setInlinePragInfo`    alwaysInlinePragma
+                         `setUnfoldingInfo`     wrap_unf
+                         `setStrictnessInfo`    wrap_sig
+                             -- We need to get the CAF info right here because TidyPgm
+                             -- does not tidy the IdInfo of implicit bindings (like the wrapper)
+                             -- so it not make sure that the CAF info is sane
+
+             wrap_sig = mkClosedStrictSig wrap_arg_dmds (dataConCPR data_con)
+             wrap_arg_dmds = map mk_dmd (dropList eq_spec wrap_bangs)
+             mk_dmd str | isBanged str = evalDmd
+                        | otherwise    = topDmd
+                 -- The Cpr info can be important inside INLINE rhss, where the
+                 -- wrapper constructor isn't inlined.
+                 -- And the argument strictness can be important too; we
+                 -- may not inline a contructor when it is partially applied.
+                 -- For example:
+                 --      data W = C !Int !Int !Int
+                 --      ...(let w = C x in ...(w p q)...)...
+                 -- we want to see that w is strict in its two arguments
+
+             wrap_unf = mkInlineUnfolding (Just wrap_arity) wrap_rhs
              wrap_tvs = (univ_tvs `minusList` map fst eq_spec) ++ ex_tvs
-            wrap_rhs = mkLams wrap_tvs $ 
-                       mkLams wrap_args $
-                       wrapFamInstBody tycon res_ty_args $
+             wrap_rhs = mkLams wrap_tvs $
+                        mkLams wrap_args $
+                        wrapFamInstBody tycon res_ty_args $
                         wrap_body
 
        ; return (DCR { dcr_wrap_id = wrap_id
@@ -532,9 +526,9 @@ mkDataConRep dflags fam_envs wrap_name data_con
 
     wrap_arg_tys = theta ++ orig_arg_tys
     wrap_arity   = length wrap_arg_tys
-            -- The wrap_args are the arguments *other than* the eq_spec
-            -- Because we are going to apply the eq_spec args manually in the
-            -- wrapper
+             -- The wrap_args are the arguments *other than* the eq_spec
+             -- Because we are going to apply the eq_spec args manually in the
+             -- wrapper
 
     (wrap_bangs, rep_tys_w_strs, wrappers)
        = unzip3 (zipWith (dataConArgRep dflags fam_envs) all_arg_tys orig_bangs)
@@ -548,16 +542,16 @@ mkDataConRep dflags fam_envs wrap_name data_con
 
     initial_wrap_app = Var (dataConWorkId data_con)
                       `mkTyApps`  res_ty_args
-                     `mkVarApps` ex_tvs                 
-                     `mkCoApps`  map (mkReflCo Nominal . snd) eq_spec
-                       -- Dont box the eq_spec coercions since they are
-                       -- marked as HsUnpack by mk_dict_strict_mark
+                      `mkVarApps` ex_tvs
+                      `mkCoApps`  map (mkReflCo Nominal . snd) eq_spec
+                        -- Dont box the eq_spec coercions since they are
+                        -- marked as HsUnpack by mk_dict_strict_mark
 
     mk_boxer :: [Boxer] -> DataConBoxer
-    mk_boxer boxers = DCB (\ ty_args src_vars -> 
+    mk_boxer boxers = DCB (\ ty_args src_vars ->
                       do { let ex_vars = takeList ex_tvs src_vars
                                subst1 = mkTopTvSubst (univ_tvs `zip` ty_args)
-                               subst2 = extendTvSubstList subst1 ex_tvs 
+                               subst2 = extendTvSubstList subst1 ex_tvs
                                                           (mkTyVarTys ex_vars)
                          ; (rep_ids, binds) <- go subst2 boxers (dropList ex_tvs src_vars)
                          ; return (ex_vars ++ rep_ids, binds) } )
@@ -573,21 +567,21 @@ mkDataConRep dflags fam_envs wrap_name data_con
     go _ (_:_) [] = pprPanic "mk_boxer" (ppr data_con)
 
     mk_rep_app :: [(Id,Unboxer)] -> CoreExpr -> UniqSM CoreExpr
-    mk_rep_app [] con_app 
+    mk_rep_app [] con_app
       = return con_app
-    mk_rep_app ((wrap_arg, unboxer) : prs) con_app 
+    mk_rep_app ((wrap_arg, unboxer) : prs) con_app
       = do { (rep_ids, unbox_fn) <- unboxer wrap_arg
            ; expr <- mk_rep_app prs (mkVarApps con_app rep_ids)
            ; return (unbox_fn expr) }
 
 -------------------------
 newLocal :: Type -> UniqSM Var
-newLocal ty = do { uniq <- getUniqueUs 
+newLocal ty = do { uniq <- getUniqueUs
                  ; return (mkSysLocal (fsLit "dt") uniq ty) }
 
 -------------------------
 dataConArgRep
-   :: DynFlags 
+   :: DynFlags
    -> FamInstEnvs
    -> Type -> HsBang
    -> ( HsBang   -- Like input but with HsUnpackFailed if necy
@@ -600,10 +594,10 @@ dataConArgRep _ _ arg_ty HsNoBang
 dataConArgRep _ _ arg_ty (HsUserBang _ False)  -- No '!'
   = (HsNoBang, [(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer))
 
-dataConArgRep dflags fam_envs arg_ty 
+dataConArgRep dflags fam_envs arg_ty
     (HsUserBang unpk_prag True)  -- {-# UNPACK #-} !
   | not (gopt Opt_OmitInterfacePragmas dflags) -- Don't unpack if -fomit-iface-pragmas
-          -- Don't unpack if we aren't optimising; rather arbitrarily, 
+          -- Don't unpack if we aren't optimising; rather arbitrarily,
           -- we use -fomit-iface-pragmas as the indication
   , let mb_co   = topNormaliseType_maybe fam_envs arg_ty
                      -- Unwrap type families and newtypes
@@ -612,7 +606,7 @@ dataConArgRep dflags fam_envs arg_ty
   , (rep_tys, wrappers) <- dataConArgUnpack arg_ty'
   , case unpk_prag of
       Nothing -> gopt Opt_UnboxStrictFields dflags
-              || (gopt Opt_UnboxSmallStrictFields dflags 
+              || (gopt Opt_UnboxSmallStrictFields dflags
                    && length rep_tys <= 1)  -- See Note [Unpack one-wide fields]
       Just unpack_me -> unpack_me
   = case mb_co of
@@ -647,8 +641,8 @@ wrapCo co rep_ty (unbox_rep, box_rep)  -- co :: arg_ty ~ rep_ty
                         ; (rep_ids, rep_fn) <- unbox_rep rep_id
                         ; let co_bind = NonRec rep_id (Var arg_id `Cast` co)
                         ; return (rep_ids, Let co_bind . rep_fn) }
-    boxer = Boxer $ \ subst -> 
-            do { (rep_ids, rep_expr) 
+    boxer = Boxer $ \ subst ->
+            do { (rep_ids, rep_expr)
                     <- case box_rep of
                          UnitBox -> do { rep_id <- newLocal (TcType.substTy subst rep_ty)
                                        ; return ([rep_id], Var rep_id) }
@@ -676,7 +670,7 @@ dataConArgUnpack arg_ty
   | Just (tc, tc_args) <- splitTyConApp_maybe arg_ty
   , Just con <- tyConSingleAlgDataCon_maybe tc
       -- NB: check for an *algebraic* data type
-      -- A recursive newtype might mean that 
+      -- A recursive newtype might mean that
       -- 'arg_ty' is a newtype
   , let rep_tys = dataConInstArgTys con tc_args
   = ASSERT( isVanillaDataCon con )
@@ -697,7 +691,7 @@ dataConArgUnpack arg_ty
     -- An interface file specified Unpacked, but we couldn't unpack it
 
 isUnpackableType :: FamInstEnvs -> Type -> Bool
--- True if we can unpack the UNPACK the argument type 
+-- True if we can unpack the UNPACK the argument type
 -- See Note [Recursive unboxing]
 -- We look "deeply" inside rather than relying on the DataCons
 -- we encounter on the way, because otherwise we might well
@@ -721,12 +715,12 @@ isUnpackableType fam_envs ty
             Just con | isVanillaDataCon con
                     -> ok_con_args (tcs `addOneToNameSet` getName tc) con
             _ -> True
-      | otherwise 
+      | otherwise
       = True
 
     ok_con_args tcs con
        = all (ok_arg tcs) (dataConOrigArgTys con `zip` dataConStrictMarks con)
-         -- NB: dataConStrictMarks gives the *user* request; 
+         -- NB: dataConStrictMarks gives the *user* request;
          -- We'd get a black hole if we used dataConRepBangs
 
     attempt_unpack (HsUnpack {})                 = True
@@ -751,9 +745,9 @@ For example:
     data G = G !F !F
 
 All of these should have an Int# as their representation, except
-G which should have two Int#s.  
+G which should have two Int#s.
 
-However 
+However
 
     data T = T !(S Int)
     data S = S !a
@@ -769,22 +763,22 @@ The representation arguments of MkR are the *representation* arguments
 of S (plus Int); the rep args of MkS are Int#.  This is all fine.
 
 But be careful not to try to unbox this!
-       data T = MkT {-# UNPACK #-} !T Int
+        data T = MkT {-# UNPACK #-} !T Int
 Because then we'd get an infinite number of arguments.
 
 Here is a more complicated case:
-       data S = MkS {-# UNPACK #-} !T Int
-       data T = MkT {-# UNPACK #-} !S Int
+        data S = MkS {-# UNPACK #-} !T Int
+        data T = MkT {-# UNPACK #-} !S Int
 Each of S and T must decide independendently whether to unpack
 and they had better not both say yes. So they must both say no.
 
 Also behave conservatively when there is no UNPACK pragma
-       data T = MkS !T Int
+        data T = MkS !T Int
 with -funbox-strict-fields or -funbox-small-strict-fields
 we need to behave as if there was an UNPACK pragma there.
 
 But it's the *argument* type that matters. This is fine:
-       data S = MkS S !Int
+        data S = MkS S !Int
 because Int is non-recursive.
 
 
@@ -800,8 +794,8 @@ space for each equality predicate, so it's pretty important!
 
 \begin{code}
 mk_pred_strict_mark :: PredType -> HsBang
-mk_pred_strict_mark pred 
-  | isEqPred pred = HsUnpack Nothing   -- Note [Unpack equality predicates]
+mk_pred_strict_mark pred
+  | isEqPred pred = HsUnpack Nothing    -- Note [Unpack equality predicates]
   | otherwise     = HsNoBang
 \end{code}
 
@@ -824,7 +818,7 @@ wrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
 --      e `cast` (CoT [a])
 --
 -- If a coercion constructor is provided in the newtype, then we use
--- it, otherwise the wrap/unwrap are both no-ops 
+-- it, otherwise the wrap/unwrap are both no-ops
 --
 -- If the we are dealing with a newtype *instance*, we have a second coercion
 -- identifying the family instance with the constructor of the newtype
@@ -895,39 +889,39 @@ unwrapTypeUnbranchedFamInstScrut axiom
 
 \begin{code}
 mkPrimOpId :: PrimOp -> Id
-mkPrimOpId prim_op 
+mkPrimOpId prim_op
   = id
   where
     (tyvars,arg_tys,res_ty, arity, strict_sig) = primOpSig prim_op
     ty   = mkForAllTys tyvars (mkFunTys arg_tys res_ty)
-    name = mkWiredInName gHC_PRIM (primOpOcc prim_op) 
+    name = mkWiredInName gHC_PRIM (primOpOcc prim_op)
                          (mkPrimOpIdUnique (primOpTag prim_op))
                          (AnId id) UserSyntax
     id   = mkGlobalId (PrimOpId prim_op) name ty info
-                
+
     info = noCafIdInfo
            `setSpecInfo`          mkSpecInfo (maybeToList $ primOpRules name prim_op)
            `setArityInfo`         arity
            `setStrictnessInfo`    strict_sig
            `setInlinePragInfo`    neverInlinePragma
                -- We give PrimOps a NOINLINE pragma so that we don't
-               -- get silly warnings from Desugar.dsRule (the inline_shadows_rule 
+               -- get silly warnings from Desugar.dsRule (the inline_shadows_rule
                -- test) about a RULE conflicting with a possible inlining
                -- cf Trac #7287
 
 -- For each ccall we manufacture a separate CCallOpId, giving it
 -- a fresh unique, a type that is correct for this particular ccall,
 -- and a CCall structure that gives the correct details about calling
--- convention etc.  
+-- convention etc.
 --
 -- The *name* of this Id is a local name whose OccName gives the full
--- details of the ccall, type and all.  This means that the interface 
+-- details of the ccall, type and all.  This means that the interface
 -- file reader can reconstruct a suitable Id
 
 mkFCallId :: DynFlags -> Unique -> ForeignCall -> Type -> Id
 mkFCallId dflags uniq fcall ty
   = ASSERT( isEmptyVarSet (tyVarsOfType ty) )
-    -- A CCallOpId should have no free type variables; 
+    -- A CCallOpId should have no free type variables;
     -- when doing substitutions won't substitute over it
     mkGlobalId (FCallId fcall) name ty info
   where
@@ -966,7 +960,7 @@ NB: See also Note [Exported LocalIds] in Id
 mkDictFunId :: Name      -- Name to use for the dict fun;
             -> [TyVar]
             -> ThetaType
-            -> Class 
+            -> Class
             -> [Type]
             -> Id
 -- Implements the DFun Superclass Invariant (see TcInstDcls)
@@ -985,8 +979,8 @@ mkDictFunTy tvs theta clas tys
   = (length silent_theta, dfun_ty)
   where
     dfun_ty = mkSigmaTy tvs (silent_theta ++ theta) (mkClassPred clas tys)
-    silent_theta 
-      | null tvs, null theta 
+    silent_theta
+      | null tvs, null theta
       = []
       | otherwise
       = filterOut discard $
@@ -1070,7 +1064,7 @@ unsafeCoerceId
   where
     info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma
                        `setUnfoldingInfo`  mkCompulsoryUnfolding rhs
-           
+
 
     ty  = mkForAllTys [openAlphaTyVar,openBetaTyVar]
                       (mkFunTy openAlphaTy openBetaTy)
@@ -1081,7 +1075,7 @@ unsafeCoerceId
 ------------------------------------------------
 nullAddrId :: Id
 -- nullAddr# :: Addr#
--- The reason is is here is because we don't provide 
+-- The reason is is here is because we don't provide
 -- a way to write this literal in Haskell.
 nullAddrId = pcMiscPrelId nullAddrName addrPrimTy info
   where
@@ -1089,13 +1083,13 @@ nullAddrId = pcMiscPrelId nullAddrName addrPrimTy info
                        `setUnfoldingInfo`  mkCompulsoryUnfolding (Lit nullAddrLit)
 
 ------------------------------------------------
-seqId :: Id    -- See Note [seqId magic]
+seqId :: Id     -- See Note [seqId magic]
 seqId = pcMiscPrelId seqName ty info
   where
     info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma
                        `setUnfoldingInfo`  mkCompulsoryUnfolding rhs
                        `setSpecInfo`       mkSpecInfo [seq_cast_rule]
-           
+
 
     ty  = mkForAllTys [alphaTyVar,betaTyVar]
                       (mkFunTy alphaTy (mkFunTy betaTy betaTy))
@@ -1119,7 +1113,7 @@ match_seq_of_cast _ _ _ [Type _, Type res_ty, Cast scrut co, expr]
 match_seq_of_cast _ _ _ _ = Nothing
 
 ------------------------------------------------
-lazyId :: Id   -- See Note [lazyId magic]
+lazyId :: Id    -- See Note [lazyId magic]
 lazyId = pcMiscPrelId lazyIdName ty info
   where
     info = noCafIdInfo
@@ -1151,7 +1145,7 @@ coerceId = pcMiscPrelId coerceName ty info
     [eqR,x,eq] = mkTemplateLocals [eqRTy, aTy,eqRPrimTy]
     rhs = mkLams [kv,a,b,eqR,x] $
           mkWildCase (Var eqR) eqRTy bTy $
-         [(DataAlt coercibleDataCon, [eq], Cast (Var x) (CoVarCo eq))]
+          [(DataAlt coercibleDataCon, [eq], Cast (Var x) (CoVarCo eq))]
 \end{code}
 
 Note [dollarId magic]
@@ -1186,7 +1180,7 @@ it on unboxed things, (unsafeCoerce# 3#) :: Int. Its type is
 
 Note [seqId magic]
 ~~~~~~~~~~~~~~~~~~
-'GHC.Prim.seq' is special in several ways. 
+'GHC.Prim.seq' is special in several ways.
 
 a) Its second arg can have an unboxed type
       x `seq` (v +# w)
@@ -1194,7 +1188,7 @@ a) Its second arg can have an unboxed type
 
 b) Its fixity is set in LoadIface.ghcPrimIface
 
-c) It has quite a bit of desugaring magic. 
+c) It has quite a bit of desugaring magic.
    See DsUtils.lhs Note [Desugaring seq (1)] and (2) and (3)
 
 d) There is some special rule handing: Note [User-defined RULES for seq]
@@ -1231,10 +1225,10 @@ We also have the following built-in rule for seq
   seq (x `cast` co) y = seq x y
 
 This eliminates unnecessary casts and also allows other seq rules to
-match more often.  Notably,     
+match more often.  Notably,
 
    seq (f x `cast` co) y  -->  seq (f x) y
-  
+
 and now a user-defined rule for seq (see Note [User-defined RULES for seq])
 may fire.
 
@@ -1250,7 +1244,7 @@ not from GHC.Base.hi.   This is important, because the strictness
 analyser will spot it as strict!
 
 Also no unfolding in lazyId: it gets "inlined" by a HACK in CorePrep.
-It's very important to do this inlining *after* unfoldings are exposed 
+It's very important to do this inlining *after* unfoldings are exposed
 in the interface file.  Otherwise, the unfolding for (say) pseq in the
 interface file will not mention 'lazy', so if we inline 'pseq' we'll totally
 miss the very thing that 'lazy' was there for in the first place.
@@ -1337,9 +1331,9 @@ voidPrimId  = pcMiscPrelId voidPrimIdName voidPrimTy
 voidArgId :: Id       -- Local lambda-bound :: Void#
 voidArgId = mkSysLocal (fsLit "void") voidArgIdKey voidPrimTy
 
-coercionTokenId :: Id        -- :: () ~ ()
+coercionTokenId :: Id         -- :: () ~ ()
 coercionTokenId -- Used to replace Coercion terms when we go to STG
-  = pcMiscPrelId coercionTokenName 
+  = pcMiscPrelId coercionTokenName
                  (mkTyConApp eqPrimTyCon [liftedTypeKind, unitTy, unitTy])
                  noCafIdInfo
 \end{code}
index d942362..1f1fda8 100644 (file)
 --
 -- * 'Var.Var': see "Var#name_types"
 
-{-# OPTIONS_GHC -fno-warn-tabs #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and
--- detab the module (please do the detabbing in a separate patch). See
---     http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
-
 module OccName (
-       -- * The 'NameSpace' type
-       NameSpace, -- Abstract
+        -- * The 'NameSpace' type
+        NameSpace, -- Abstract
 
         nameSpacesRelated,
-       
-       -- ** Construction
-       -- $real_vs_source_data_constructors
-       tcName, clsName, tcClsName, dataName, varName, 
-       tvName, srcDataName,
-
-       -- ** Pretty Printing
-       pprNameSpace, pprNonVarNameSpace, pprNameSpaceBrief,
-
-       -- * The 'OccName' type
-       OccName,        -- Abstract, instance of Outputable
-       pprOccName, 
-
-       -- ** Construction      
-       mkOccName, mkOccNameFS, 
-       mkVarOcc, mkVarOccFS,
-       mkDataOcc, mkDataOccFS,
-       mkTyVarOcc, mkTyVarOccFS,
-       mkTcOcc, mkTcOccFS,
-       mkClsOcc, mkClsOccFS,
+
+        -- ** Construction
+        -- $real_vs_source_data_constructors
+        tcName, clsName, tcClsName, dataName, varName,
+        tvName, srcDataName,
+
+        -- ** Pretty Printing
+        pprNameSpace, pprNonVarNameSpace, pprNameSpaceBrief,
+
+        -- * The 'OccName' type
+        OccName,        -- Abstract, instance of Outputable
+        pprOccName,
+
+        -- ** Construction
+        mkOccName, mkOccNameFS,
+        mkVarOcc, mkVarOccFS,
+        mkDataOcc, mkDataOccFS,
+        mkTyVarOcc, mkTyVarOccFS,
+        mkTcOcc, mkTcOccFS,
+        mkClsOcc, mkClsOccFS,
         mkDFunOcc,
-       setOccNameSpace,
+        setOccNameSpace,
         demoteOccName,
         HasOccName(..),
 
-       -- ** Derived 'OccName's
+        -- ** Derived 'OccName's
         isDerivedOccName,
-       mkDataConWrapperOcc, mkWorkerOcc, mkMatcherOcc, mkDefaultMethodOcc,
-        mkGenDefMethodOcc, 
-       mkDerivedTyConOcc, mkNewTyCoOcc, mkClassOpAuxOcc,
+        mkDataConWrapperOcc, mkWorkerOcc, mkMatcherOcc, mkDefaultMethodOcc,
+        mkGenDefMethodOcc,
+        mkDerivedTyConOcc, mkNewTyCoOcc, mkClassOpAuxOcc,
         mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc,
-       mkClassDataConOcc, mkDictOcc, mkIPOcc,
-       mkSpecOcc, mkForeignExportOcc, mkRepEqOcc, mkGenOcc1, mkGenOcc2,
-       mkGenD, mkGenR, mkGen1R, mkGenRCo, mkGenC, mkGenS,
+        mkClassDataConOcc, mkDictOcc, mkIPOcc,
+        mkSpecOcc, mkForeignExportOcc, mkRepEqOcc, mkGenOcc1, mkGenOcc2,
+        mkGenD, mkGenR, mkGen1R, mkGenRCo, mkGenC, mkGenS,
         mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc,
-       mkSuperDictSelOcc, mkLocalOcc, mkMethodOcc, mkInstTyTcOcc,
-       mkInstTyCoOcc, mkEqPredCoOcc,
+        mkSuperDictSelOcc, mkLocalOcc, mkMethodOcc, mkInstTyTcOcc,
+        mkInstTyCoOcc, mkEqPredCoOcc,
         mkVectOcc, mkVectTyConOcc, mkVectDataConOcc, mkVectIsoOcc,
         mkPDataTyConOcc,  mkPDataDataConOcc,
-       mkPDatasTyConOcc, mkPDatasDataConOcc,
-        mkPReprTyConOcc, 
+        mkPDatasTyConOcc, mkPDatasDataConOcc,
+        mkPReprTyConOcc,
         mkPADFunOcc,
 
-       -- ** Deconstruction
-       occNameFS, occNameString, occNameSpace, 
+        -- ** Deconstruction
+        occNameFS, occNameString, occNameSpace,
+
+        isVarOcc, isTvOcc, isTcOcc, isDataOcc, isDataSymOcc, isSymOcc, isValOcc,
+        parenSymOcc, startsWithUnderscore,
 
-       isVarOcc, isTvOcc, isTcOcc, isDataOcc, isDataSymOcc, isSymOcc, isValOcc,
-       parenSymOcc, startsWithUnderscore, 
-       
-       isTcClsNameSpace, isTvNameSpace, isDataConNameSpace, isVarNameSpace, isValNameSpace,
+        isTcClsNameSpace, isTvNameSpace, isDataConNameSpace, isVarNameSpace, isValNameSpace,
 
-       -- * The 'OccEnv' type
-       OccEnv, emptyOccEnv, unitOccEnv, extendOccEnv, mapOccEnv,
-       lookupOccEnv, mkOccEnv, mkOccEnv_C, extendOccEnvList, elemOccEnv,
-       occEnvElts, foldOccEnv, plusOccEnv, plusOccEnv_C, extendOccEnv_C,
+        -- * The 'OccEnv' type
+        OccEnv, emptyOccEnv, unitOccEnv, extendOccEnv, mapOccEnv,
+        lookupOccEnv, mkOccEnv, mkOccEnv_C, extendOccEnvList, elemOccEnv,
+        occEnvElts, foldOccEnv, plusOccEnv, plusOccEnv_C, extendOccEnv_C,
         extendOccEnv_Acc, filterOccEnv, delListFromOccEnv, delFromOccEnv,
         alterOccEnv, pprOccEnv,
 
-       -- * The 'OccSet' type
-       OccSet, emptyOccSet, unitOccSet, mkOccSet, extendOccSet, 
-       extendOccSetList,
-       unionOccSets, unionManyOccSets, minusOccSet, elemOccSet, occSetElts, 
-       foldOccSet, isEmptyOccSet, intersectOccSet, intersectsOccSet,
-                  
-       -- * Tidying up
-       TidyOccEnv, emptyTidyOccEnv, tidyOccName, initTidyOccEnv,
+        -- * The 'OccSet' type
+        OccSet, emptyOccSet, unitOccSet, mkOccSet, extendOccSet,
+        extendOccSetList,
+        unionOccSets, unionManyOccSets, minusOccSet, elemOccSet, occSetElts,
+        foldOccSet, isEmptyOccSet, intersectOccSet, intersectsOccSet,
 
-       -- * Lexical characteristics of Haskell names
-       isLexCon, isLexVar, isLexId, isLexSym,
-       isLexConId, isLexConSym, isLexVarId, isLexVarSym,
-       startsVarSym, startsVarId, startsConSym, startsConId,
+        -- * Tidying up
+        TidyOccEnv, emptyTidyOccEnv, tidyOccName, initTidyOccEnv,
+
+        -- * Lexical characteristics of Haskell names
+        isLexCon, isLexVar, isLexId, isLexSym,
+        isLexConId, isLexConSym, isLexVarId, isLexVarSym,
+        startsVarSym, startsVarId, startsConSym, startsConId,
 
         -- FsEnv
         FastStringEnv, emptyFsEnv, lookupFsEnv, extendFsEnv, mkFsEnv
@@ -123,9 +116,9 @@ import Data.Data
 \end{code}
 
 %************************************************************************
-%*                                                                     *
+%*                                                                      *
               FastStringEnv
-%*                                                                     *
+%*                                                                      *
 %************************************************************************
 
 FastStringEnv can't be in FastString because the env depends on UniqFM
@@ -146,29 +139,29 @@ mkFsEnv     = listToUFM
 \end{code}
 
 %************************************************************************
-%*                                                                     *
+%*                                                                      *
 \subsection{Name space}
-%*                                                                     *
+%*                                                                      *
 %************************************************************************
 
 \begin{code}
-data NameSpace = VarName       -- Variables, including "real" data constructors
-              | DataName       -- "Source" data constructors 
-              | TvName         -- Type variables
-              | TcClsName      -- Type constructors and classes; Haskell has them
-                               -- in the same name space for now.
-              deriving( Eq, Ord )
+data NameSpace = VarName        -- Variables, including "real" data constructors
+               | DataName       -- "Source" data constructors
+               | TvName         -- Type variables
+               | TcClsName      -- Type constructors and classes; Haskell has them
+                                -- in the same name space for now.
+               deriving( Eq, Ord )
    {-! derive: Binary !-}
 
--- Note [Data Constructors]  
+-- Note [Data Constructors]
 -- see also: Note [Data Constructor Naming] in DataCon.lhs
 --
 -- $real_vs_source_data_constructors
 -- There are two forms of data constructor:
 --
---     [Source data constructors] The data constructors mentioned in Haskell source code
+--      [Source data constructors] The data constructors mentioned in Haskell source code
 --
---     [Real data constructors] The data constructors of the representation type, which may not be the same as the source type
+--      [Real data constructors] The data constructors of the representation type, which may not be the same as the source type
 --
 -- For example:
 --
@@ -185,13 +178,13 @@ tvName, varName            :: NameSpace
 
 -- Though type constructors and classes are in the same name space now,
 -- the NameSpace type is abstract, so we can easily separate them later
-tcName    = TcClsName          -- Type constructors
-clsName   = TcClsName          -- Classes
-tcClsName = TcClsName          -- Not sure which!
+tcName    = TcClsName           -- Type constructors
+clsName   = TcClsName           -- Classes
+tcClsName = TcClsName           -- Not sure which!
 
 dataName    = DataName
-srcDataName = DataName -- Haskell-source data constructors should be
-                       -- in the Data name space
+srcDataName = DataName  -- Haskell-source data constructors should be
+                        -- in the Data name space
 
 tvName      = TvName
 varName     = VarName
@@ -208,7 +201,7 @@ isTvNameSpace :: NameSpace -> Bool
 isTvNameSpace TvName = True
 isTvNameSpace _      = False
 
-isVarNameSpace :: NameSpace -> Bool    -- Variables or type variables, but not constructors
+isVarNameSpace :: NameSpace -> Bool     -- Variables or type variables, but not constructors
 isVarNameSpace TvName  = True
 isVarNameSpace VarName = True
 isVarNameSpace _       = False
@@ -246,13 +239,13 @@ demoteNameSpace TcClsName = Just DataName
 
 
 %************************************************************************
-%*                                                                     *
+%*                                                                      *
 \subsection[Name-pieces-datatypes]{The @OccName@ datatypes}
-%*                                                                     *
+%*                                                                      *
 %************************************************************************
 
 \begin{code}
-data OccName = OccName 
+data OccName = OccName
     { occNameSpace  :: !NameSpace
     , occNameFS     :: !FastString
     }
@@ -265,9 +258,9 @@ instance Eq OccName where
     (OccName sp1 s1) == (OccName sp2 s2) = s1 == s2 && sp1 == sp2
 
 instance Ord OccName where
-       -- Compares lexicographically, *not* by Unique of the string
-    compare (OccName sp1 s1) (OccName sp2 s2) 
-       = (s1  `compare` s2) `thenCmp` (sp1 `compare` sp2)
+        -- Compares lexicographically, *not* by Unique of the string
+    compare (OccName sp1 s1) (OccName sp2 s2)
+        = (s1  `compare` s2) `thenCmp` (sp1 `compare` sp2)
 
 instance Data OccName where
   -- don't traverse?
@@ -281,11 +274,11 @@ instance HasOccName OccName where
 
 
 %************************************************************************
-%*                                                                     *
+%*                                                                      *
 \subsection{Printing}
-%*                                                                     *
+%*                                                                      *
 %************************************************************************
+
 \begin{code}
 instance Outputable OccName where
     ppr = pprOccName
@@ -296,21 +289,21 @@ instance OutputableBndr OccName where
     pprPrefixOcc n = pprPrefixVar (isSymOcc n) (ppr n)
 
 pprOccName :: OccName -> SDoc
-pprOccName (OccName sp occ) 
+pprOccName (OccName sp occ)
   = getPprStyle $ \ sty ->
-    if codeStyle sty 
+    if codeStyle sty
     then ztext (zEncodeFS occ)
     else pp_occ <> pp_debug sty
   where
     pp_debug sty | debugStyle sty = braces (pprNameSpaceBrief sp)
-                | otherwise      = empty
+                 | otherwise      = empty
 
     pp_occ = sdocWithDynFlags $ \dflags ->
              if gopt Opt_SuppressUniques dflags
              then text (strip_th_unique (unpackFS occ))
              else ftext occ
 
-       -- See Note [Suppressing uniques in OccNames]
+        -- See Note [Suppressing uniques in OccNames]
     strip_th_unique ('[' : c : _) | isAlphaNum c = []
     strip_th_unique (c : cs) = c : strip_th_unique cs
     strip_th_unique []       = []
@@ -323,9 +316,9 @@ Template Haskell that have been turned into a string in the OccName.
 See Note [Unique OccNames from Template Haskell] in Convert.hs
 
 %************************************************************************
-%*                                                                     *
+%*                                                                      *
 \subsection{Construction}
-%*                                                                     *
+%*                                                                      *
 %************************************************************************
 
 \begin{code}
@@ -393,9 +386,9 @@ class HasOccName name where
 
 
 %************************************************************************
-%*                                                                     *
-               Environments
-%*                                                                     *
+%*                                                                      *
+                Environments
+%*                                                                      *
 %************************************************************************
 
 OccEnvs are used mainly for the envts in ModIfaces.
@@ -403,11 +396,11 @@ OccEnvs are used mainly for the envts in ModIfaces.
 Note [The Unique of an OccName]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 They are efficient, because FastStrings have unique Int# keys.  We assume
-this key is less than 2^24, and indeed FastStrings are allocated keys 
+this key is less than 2^24, and indeed FastStrings are allocated keys
 sequentially starting at 0.
 
 So we can make a Unique using
-       mkUnique ns key  :: Unique
+        mkUnique ns key  :: Unique
 where 'ns' is a Char representing the name space.  This in turn makes it
 easy to build an OccEnv.
 
@@ -436,25 +429,25 @@ extendOccEnv_Acc :: (a->b->b) -> (a->b) -> OccEnv b -> OccName -> a -> OccEnv b
 plusOccEnv     :: OccEnv a -> OccEnv a -> OccEnv a
 plusOccEnv_C   :: (a->a->a) -> OccEnv a -> OccEnv a -> OccEnv a
 mapOccEnv      :: (a->b) -> OccEnv a -> OccEnv b
-delFromOccEnv     :: OccEnv a -> OccName -> OccEnv a
+delFromOccEnv      :: OccEnv a -> OccName -> OccEnv a
 delListFromOccEnv :: OccEnv a -> [OccName] -> OccEnv a
-filterOccEnv      :: (elt -> Bool) -> OccEnv elt -> OccEnv elt
-alterOccEnv       :: (Maybe elt -> Maybe elt) -> OccEnv elt -> OccName -> OccEnv elt
+filterOccEnv       :: (elt -> Bool) -> OccEnv elt -> OccEnv elt
+alterOccEnv        :: (Maybe elt -> Maybe elt) -> OccEnv elt -> OccName -> OccEnv elt
 
-emptyOccEnv     = A emptyUFM
-unitOccEnv x y = A $ unitUFM x y 
+emptyOccEnv      = A emptyUFM
+unitOccEnv x y = A $ unitUFM x y
 extendOccEnv (A x) y z = A $ addToUFM x y z
 extendOccEnvList (A x) l = A $ addListToUFM x l
 lookupOccEnv (A x) y = lookupUFM x y
 mkOccEnv     l    = A $ listToUFM l
-elemOccEnv x (A y)      = elemUFM x y
-foldOccEnv a b (A c)    = foldUFM a b c 
-occEnvElts (A x)        = eltsUFM x
-plusOccEnv (A x) (A y)  = A $ plusUFM x y 
-plusOccEnv_C f (A x) (A y)      = A $ plusUFM_C f x y 
+elemOccEnv x (A y)       = elemUFM x y
+foldOccEnv a b (A c)     = foldUFM a b c
+occEnvElts (A x)         = eltsUFM x
+plusOccEnv (A x) (A y)   = A $ plusUFM x y
+plusOccEnv_C f (A x) (A y)       = A $ plusUFM_C f x y
 extendOccEnv_C f (A x) y z   = A $ addToUFM_C f x y z
 extendOccEnv_Acc f g (A x) y z   = A $ addToUFM_Acc f g x y z
-mapOccEnv f (A x)       = A $ mapUFM f x
+mapOccEnv f (A x)        = A $ mapUFM f x
 mkOccEnv_C comb l = A $ addListToUFM_C comb emptyUFM l
 delFromOccEnv (A x) y    = A $ delFromUFM x y
 delListFromOccEnv (A x) y  = A $ delListFromUFM x y
@@ -469,32 +462,32 @@ pprOccEnv ppr_elt (A env) = pprUniqFM ppr_elt env
 
 type OccSet = UniqSet OccName
 
-emptyOccSet      :: OccSet
-unitOccSet       :: OccName -> OccSet
+emptyOccSet       :: OccSet
+unitOccSet        :: OccName -> OccSet
 mkOccSet          :: [OccName] -> OccSet
 extendOccSet      :: OccSet -> OccName -> OccSet
 extendOccSetList  :: OccSet -> [OccName] -> OccSet
-unionOccSets     :: OccSet -> OccSet -> OccSet
+unionOccSets      :: OccSet -> OccSet -> OccSet
 unionManyOccSets  :: [OccSet] -> OccSet
-minusOccSet      :: OccSet -> OccSet -> OccSet
-elemOccSet       :: OccName -> OccSet -> Bool
-occSetElts       :: OccSet -> [OccName]
-foldOccSet       :: (OccName -> b -> b) -> b -> OccSet -> b
-isEmptyOccSet    :: OccSet -> Bool
+minusOccSet       :: OccSet -> OccSet -> OccSet
+elemOccSet        :: OccName -> OccSet -> Bool
+occSetElts        :: OccSet -> [OccName]
+foldOccSet        :: (OccName -> b -> b) -> b -> OccSet -> b
+isEmptyOccSet     :: OccSet -> Bool
 intersectOccSet   :: OccSet -> OccSet -> OccSet
 intersectsOccSet  :: OccSet -> OccSet -> Bool
 
-emptyOccSet      = emptyUniqSet
-unitOccSet       = unitUniqSet
+emptyOccSet       = emptyUniqSet
+unitOccSet        = unitUniqSet
 mkOccSet          = mkUniqSet
-extendOccSet     = addOneToUniqSet
+extendOccSet      = addOneToUniqSet
 extendOccSetList  = addListToUniqSet
 unionOccSets      = unionUniqSets
 unionManyOccSets  = unionManyUniqSets
-minusOccSet      = minusUniqSet
+minusOccSet       = minusUniqSet
 elemOccSet        = elementOfUniqSet
 occSetElts        = uniqSetToList
-foldOccSet       = foldUniqSet
+foldOccSet        = foldUniqSet
 isEmptyOccSet     = isEmptyUniqSet
 intersectOccSet   = intersectUniqSets
 intersectsOccSet s1 s2 = not (isEmptyOccSet (s1 `intersectOccSet` s2))
@@ -502,9 +495,9 @@ intersectsOccSet s1 s2 = not (isEmptyOccSet (s1 `intersectOccSet` s2))
 
 
 %************************************************************************
-%*                                                                     *
+%*                                                                      *
 \subsection{Predicates and taking them apart}
-%*                                                                     *
+%*                                                                      *
 %************************************************************************
 
 \begin{code}
@@ -525,7 +518,7 @@ isTvOcc _                  = False
 isTcOcc (OccName TcClsName _) = True
 isTcOcc _                     = False
 
--- | /Value/ 'OccNames's are those that are either in 
+-- | /Value/ 'OccNames's are those that are either in
 -- the variable or data constructor namespaces
 isValOcc :: OccName -> Bool
 isValOcc (OccName VarName  _) = True
@@ -542,7 +535,7 @@ isDataSymOcc (OccName DataName s) = isLexConSym s
 isDataSymOcc _                    = False
 -- Pretty inefficient!
 
--- | Test if the 'OccName' is that for any operator (whether 
+-- | Test if the 'OccName' is that for any operator (whether
 -- it is a data constructor or variable or whatever)
 isSymOcc :: OccName -> Bool
 isSymOcc (OccName DataName s)  = isLexConSym s
@@ -554,7 +547,7 @@ isSymOcc (OccName TvName s)    = isLexSym s
 parenSymOcc :: OccName -> SDoc -> SDoc
 -- ^ Wrap parens around an operator
 parenSymOcc occ doc | isSymOcc occ = parens doc
-                   | otherwise    = doc
+                    | otherwise    = doc
 \end{code}
 
 
@@ -563,39 +556,39 @@ startsWithUnderscore :: OccName -> Bool
 -- ^ Haskell 98 encourages compilers to suppress warnings about unsed
 -- names in a pattern if they start with @_@: this implements that test
 startsWithUnderscore occ = case occNameString occ of
-                            ('_' : _) -> True
-                            _other    -> False
+                             ('_' : _) -> True
+                             _other    -> False
 \end{code}
 
 
 %************************************************************************
-%*                                                                     *
+%*                                                                      *
 \subsection{Making system names}
-%*                                                                     *
+%*                                                                      *
 %************************************************************************
 
 Here's our convention for splitting up the interface file name space:
 
-   d...                dictionary identifiers
-               (local variables, so no name-clash worries)
+   d...         dictionary identifiers
+                (local variables, so no name-clash worries)
 
 All of these other OccNames contain a mixture of alphabetic
 and symbolic characters, and hence cannot possibly clash with
 a user-written type or function name
 
-   $f...       Dict-fun identifiers (from inst decls)
-   $dmop       Default method for 'op'
-   $pnC                n'th superclass selector for class C
-   $wf         Worker for functtoin 'f'
-   $sf..       Specialised version of f
-   T:C         Tycon for dictionary for class C
-   D:C         Data constructor for dictionary for class C
+   $f...        Dict-fun identifiers (from inst decls)
+   $dmop        Default method for 'op'
+   $pnC         n'th superclass selector for class C
+   $wf          Worker for functtoin 'f'
+   $sf..        Specialised version of f
+   T:C          Tycon for dictionary for class C
+   D:C          Data constructor for dictionary for class C
    NTCo:T       Coercion connecting newtype T with its representation type
    TFCo:R       Coercion connecting a data family to its respresentation type R
 
 In encoded form these appear as Zdfxxx etc
 
-       :...            keywords (export:, letrec: etc.)
+        :...            keywords (export:, letrec: etc.)
 --- I THINK THIS IS WRONG!
 
 This knowledge is encoded in the following functions.
@@ -604,15 +597,15 @@ This knowledge is encoded in the following functions.
 NB: The string must already be encoded!
 
 \begin{code}
-mk_deriv :: NameSpace 
-        -> String              -- Distinguishes one sort of derived name from another
-        -> String
-        -> OccName
+mk_deriv :: NameSpace
+         -> String              -- Distinguishes one sort of derived name from another
+         -> String
+         -> OccName
 
 mk_deriv occ_sp sys_prefix str = mkOccName occ_sp (sys_prefix ++ str)
 
 isDerivedOccName :: OccName -> Bool
-isDerivedOccName occ = 
+isDerivedOccName occ =
    case occNameString occ of
      '$':c:_ | isAlphaNum c -> True
      ':':c:_ | isAlphaNum c -> True
@@ -622,10 +615,10 @@ isDerivedOccName occ =
 \begin{code}
 mkDataConWrapperOcc, mkWorkerOcc, mkMatcherOcc, mkDefaultMethodOcc,
         mkGenDefMethodOcc, mkDerivedTyConOcc, mkClassDataConOcc, mkDictOcc,
-       mkIPOcc, mkSpecOcc, mkForeignExportOcc, mkRepEqOcc, mkGenOcc1, mkGenOcc2,
-       mkGenD, mkGenR, mkGen1R, mkGenRCo,
-       mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, mkNewTyCoOcc,
-       mkInstTyCoOcc, mkEqPredCoOcc, mkClassOpAuxOcc,
+        mkIPOcc, mkSpecOcc, mkForeignExportOcc, mkRepEqOcc, mkGenOcc1, mkGenOcc2,
+        mkGenD, mkGenR, mkGen1R, mkGenRCo,
+        mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, mkNewTyCoOcc,
+        mkInstTyCoOcc, mkEqPredCoOcc, mkClassOpAuxOcc,
         mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc
    :: OccName -> OccName
 
@@ -636,17 +629,17 @@ mkMatcherOcc        = mk_simple_deriv varName  "$m"
 mkDefaultMethodOcc  = mk_simple_deriv varName  "$dm"
 mkGenDefMethodOcc   = mk_simple_deriv varName  "$gdm"
 mkClassOpAuxOcc     = mk_simple_deriv varName  "$c"
-mkDerivedTyConOcc   = mk_simple_deriv tcName   ":"     -- The : prefix makes sure it classifies as a tycon/datacon
-mkClassDataConOcc   = mk_simple_deriv dataName "D:"    -- We go straight to the "real" data con
-                                                       -- for datacons from classes
-mkDictOcc          = mk_simple_deriv varName  "$d"
-mkIPOcc                    = mk_simple_deriv varName  "$i"
-mkSpecOcc          = mk_simple_deriv varName  "$s"
+mkDerivedTyConOcc   = mk_simple_deriv tcName   ":"      -- The : prefix makes sure it classifies as a tycon/datacon
+mkClassDataConOcc   = mk_simple_deriv dataName "D:"     -- We go straight to the "real" data con
+                                                        -- for datacons from classes
+mkDictOcc           = mk_simple_deriv varName  "$d"
+mkIPOcc             = mk_simple_deriv varName  "$i"
+mkSpecOcc           = mk_simple_deriv varName  "$s"
 mkForeignExportOcc  = mk_simple_deriv varName  "$f"
 mkRepEqOcc          = mk_simple_deriv tvName   "$r"      -- In RULES involving Coercible
-mkNewTyCoOcc        = mk_simple_deriv tcName   "NTCo:" -- Coercion for newtypes
+mkNewTyCoOcc        = mk_simple_deriv tcName   "NTCo:"  -- Coercion for newtypes
 mkInstTyCoOcc       = mk_simple_deriv tcName   "TFCo:"   -- Coercion for type functions
-mkEqPredCoOcc      = mk_simple_deriv tcName   "$co"
+mkEqPredCoOcc       = mk_simple_deriv tcName   "$co"
 
 -- used in derived instances
 mkCon2TagOcc        = mk_simple_deriv varName  "$con2tag_"
@@ -655,7 +648,7 @@ mkMaxTagOcc         = mk_simple_deriv varName  "$maxtag_"
 
 -- Generic derivable classes (old)
 mkGenOcc1           = mk_simple_deriv varName  "$gfrom"
-mkGenOcc2           = mk_simple_deriv varName  "$gto" 
+mkGenOcc2           = mk_simple_deriv varName  "$gto"
 
 -- Generic deriving mechanism (new)
 mkGenD         = mk_simple_deriv tcName "D1"
@@ -671,9 +664,9 @@ mkGenR   = mk_simple_deriv tcName "Rep_"
 mkGen1R  = mk_simple_deriv tcName "Rep1_"
 mkGenRCo = mk_simple_deriv tcName "CoRep_"
 
--- data T = MkT ... deriving( Data ) needs definitions for 
---     $tT   :: Data.Generics.Basics.DataType
---     $cMkT :: Data.Generics.Basics.Constr
+-- data T = MkT ... deriving( Data ) needs definitions for
+--      $tT   :: Data.Generics.Basics.DataType
+--      $cMkT :: Data.Generics.Basics.Constr
 mkDataTOcc = mk_simple_deriv varName  "$t"
 mkDataCOcc = mk_simple_deriv varName  "$c"
 
@@ -704,41 +697,41 @@ mk_simple_deriv_with sp px (Just with) occ = mk_deriv sp (px ++ with ++ "_") (oc
 -- Data constructor workers are made by setting the name space
 -- of the data constructor OccName (which should be a DataName)
 -- to VarName
-mkDataConWorkerOcc datacon_occ = setOccNameSpace varName datacon_occ 
+mkDataConWorkerOcc datacon_occ = setOccNameSpace varName datacon_occ
 \end{code}
 
 \begin{code}
-mkSuperDictSelOcc :: Int       -- ^ Index of superclass, e.g. 3
-                 -> OccName    -- ^ Class, e.g. @Ord@
-                 -> OccName    -- ^ Derived 'Occname', e.g. @$p3Ord@
+mkSuperDictSelOcc :: Int        -- ^ Index of superclass, e.g. 3
+                  -> OccName    -- ^ Class, e.g. @Ord@
+                  -> OccName    -- ^ Derived 'Occname', e.g. @$p3Ord@
 mkSuperDictSelOcc index cls_tc_occ
   = mk_deriv varName "$p" (show index ++ occNameString cls_tc_occ)
 
-mkLocalOcc :: Unique           -- ^ Unique to combine with the 'OccName'
-          -> OccName           -- ^ Local name, e.g. @sat@
-          -> OccName           -- ^ Nice unique version, e.g. @$L23sat@
+mkLocalOcc :: Unique            -- ^ Unique to combine with the 'OccName'
+           -> OccName           -- ^ Local name, e.g. @sat@
+           -> OccName           -- ^ Nice unique version, e.g. @$L23sat@
 mkLocalOcc uniq occ
    = mk_deriv varName ("$L" ++ show uniq) (occNameString occ)
-       -- The Unique might print with characters 
-       -- that need encoding (e.g. 'z'!)
+        -- The Unique might print with characters
+        -- that need encoding (e.g. 'z'!)
 \end{code}
 
 \begin{code}
 -- | Derive a name for the representation type constructor of a
 -- @data@\/@newtype@ instance.
-mkInstTyTcOcc :: String                -- ^ Family name, e.g. @Map@
+mkInstTyTcOcc :: String                 -- ^ Family name, e.g. @Map@
               -> OccSet                 -- ^ avoid these Occs
-             -> OccName                -- ^ @R:Map@
+              -> OccName                -- ^ @R:Map@
 mkInstTyTcOcc str set =
   chooseUniqueOcc tcName ('R' : ':' : str) set
 \end{code}
 
 \begin{code}
-mkDFunOcc :: String            -- ^ Typically the class and type glommed together e.g. @OrdMaybe@.
-                               -- Only used in debug mode, for extra clarity
-         -> Bool               -- ^ Is this a hs-boot instance DFun?
+mkDFunOcc :: String             -- ^ Typically the class and type glommed together e.g. @OrdMaybe@.
+                                -- Only used in debug mode, for extra clarity
+          -> Bool               -- ^ Is this a hs-boot instance DFun?
           -> OccSet             -- ^ avoid these Occs
-         -> OccName            -- ^ E.g. @$f3OrdMaybe@
+          -> OccName            -- ^ E.g. @$f3OrdMaybe@
 
 -- In hs-boot files we make dict funs like $fx7ClsTy, which get bound to the real
 -- thing when we compile the mother module. Reason: we don't know exactly
@@ -748,7 +741,7 @@ mkDFunOcc info_str is_boot set
   = chooseUniqueOcc VarName (prefix ++ info_str) set
   where
     prefix | is_boot   = "$fx"
-          | otherwise = "$f"
+           | otherwise = "$f"
 \end{code}
 
 Sometimes we need to pick an OccName that has not already been used,
@@ -777,9 +770,9 @@ because overloaded constructors (blarg) generate methods too.
 And convert to VarName space
 
 e.g. a call to constructor MkFoo where
-       data (Ord a) => Foo a = MkFoo a
+        data (Ord a) => Foo a = MkFoo a
 
-If this is necessary, we do it by prefixing '$m'.  These 
+If this is necessary, we do it by prefixing '$m'.  These
 guys never show up in error messages.  What a hack.
 
 \begin{code}
@@ -790,9 +783,9 @@ mkMethodOcc occ                     = mk_simple_deriv varName "$m" occ
 
 
 %************************************************************************
-%*                                                                     *
+%*                                                                      *
 \subsection{Tidying them up}
-%*                                                                     *
+%*                                                                      *
 %************************************************************************
 
 Before we print chunks of code we like to rename it so that
@@ -802,7 +795,7 @@ OccName alone unless it accidentally clashes with one that is already
 in scope; if so, we tack on '1' at the end and try again, then '2', and
 so on till we find a unique one.
 
-There's a wrinkle for operators.  Consider '>>='.  We can't use '>>=1' 
+There's a wrinkle for operators.  Consider '>>='.  We can't use '>>=1'
 because that isn't a single lexeme.  So we encode it to 'lle' and *then*
 tack on the '1', if necessary.
 
@@ -814,7 +807,7 @@ type TidyOccEnv = UniqFM Int
            make sure that we don't re-use
 
 * Int, n = A plausible starting point for new guesses
-           There is no guarantee that "FSn" is available; 
+           There is no guarantee that "FSn" is available;
            you must look that up in the TidyOccEnv.  But
            it's a good place to start looking.
 
@@ -822,13 +815,13 @@ type TidyOccEnv = UniqFM Int
   with "foo".  Otherwise if we tidy twice we get silly names like foo23.
 
 \begin{code}
-type TidyOccEnv = UniqFM Int   -- The in-scope OccNames
+type TidyOccEnv = UniqFM Int    -- The in-scope OccNames
   -- See Note [TidyOccEnv]
 
 emptyTidyOccEnv :: TidyOccEnv
 emptyTidyOccEnv = emptyUFM
 
-initTidyOccEnv :: [OccName] -> TidyOccEnv      -- Initialise with names to avoid!
+initTidyOccEnv :: [OccName] -> TidyOccEnv       -- Initialise with names to avoid!
 initTidyOccEnv = foldl add emptyUFM
   where
     add env (OccName _ fs) = addToUFM env fs 1
@@ -836,13 +829,13 @@ initTidyOccEnv = foldl add emptyUFM
 tidyOccName :: TidyOccEnv -> OccName -> (TidyOccEnv, OccName)
 tidyOccName env occ@(OccName occ_sp fs)
   = case lookupUFM env fs of
-       Just n  -> find n
-       Nothing -> (addToUFM env fs 1, occ)
+        Just n  -> find n
+        Nothing -> (addToUFM env fs 1, occ)
   where
     base :: String  -- Drop trailing digits (see Note [TidyOccEnv])
     base = reverse (dropWhile isDigit (reverse (unpackFS fs)))
-    find n 
+
+    find n
       = case lookupUFM env new_fs of
           Just n' -> find (n1 `max` n')
                      -- The max ensures that n increases, avoiding loops
@@ -857,9 +850,9 @@ tidyOccName env occ@(OccName occ_sp fs)
 \end{code}
 
 %************************************************************************
-%*                                                                     *
+%*                                                                      *
 \subsection{Lexical categories}
-%*                                                                     *
+%*                                                                      *
 %************************************************************************
 
 These functions test strings to see if they fit the lexical categories
@@ -886,21 +879,21 @@ isLexSym cs = isLexConSym cs || isLexVarSym cs
 
 -------------
 
-isLexConId cs                          -- Prefix type or data constructors
-  | nullFS cs         = False          --      e.g. "Foo", "[]", "(,)" 
+isLexConId cs                           -- Prefix type or data constructors
+  | nullFS cs          = False          --      e.g. "Foo", "[]", "(,)"
   | cs == (fsLit "[]") = True
-  | otherwise         = startsConId (headFS cs)
+  | otherwise          = startsConId (headFS cs)
 
-isLexVarId cs                          -- Ordinary prefix identifiers
-  | nullFS cs        = False           --      e.g. "x", "_x"
+isLexVarId cs                           -- Ordinary prefix identifiers
+  | nullFS cs         = False           --      e.g. "x", "_x"
   | otherwise         = startsVarId (headFS cs)
 
-isLexConSym cs                         -- Infix type or data constructors
-  | nullFS cs         = False          --      e.g. ":-:", ":", "->"
+isLexConSym cs                          -- Infix type or data constructors
+  | nullFS cs          = False          --      e.g. ":-:", ":", "->"
   | cs == (fsLit "->") = True
-  | otherwise         = startsConSym (headFS cs)
+  | otherwise          = startsConSym (headFS cs)
 
-isLexVarSym fs                         -- Infix identifiers e.g. "+"
+isLexVarSym fs                          -- Infix identifiers e.g. "+"
   | fs == (fsLit "~R#") = True
   | otherwise
   = case (if nullFS fs then [] else unpackFS fs) of
@@ -911,9 +904,9 @@ isLexVarSym fs                              -- Infix identifiers e.g. "+"
 -------------
 startsVarSym, startsVarId, startsConSym, startsConId :: Char -> Bool
 startsVarSym c = isSymbolASCII c || (ord c > 0x7f && isSymbol c)  -- Infix Ids
-startsConSym c = c == ':'              -- Infix data constructors
-startsVarId c  = isLower c || c == '_' -- Ordinary Ids
-startsConId c  = isUpper c || c == '(' -- Ordinary type constructors and data constructors
+startsConSym c = c == ':'               -- Infix data constructors
+startsVarId c  = isLower c || c == '_'  -- Ordinary Ids
+startsConId c  = isUpper c || c == '('  -- Ordinary type constructors and data constructors
 
 isSymbolASCII :: Char -> Bool
 isSymbolASCII c = c `elem` "!#$%&*+./<=>?@\\^|~-"
@@ -923,36 +916,36 @@ isVarSymChar c = c == ':' || startsVarSym c
 \end{code}
 
 %************************************************************************
-%*                                                                     *
-               Binary instance
+%*                                                                      *
+                Binary instance
     Here rather than BinIface because OccName is abstract
-%*                                                                     *
+%*                                                                      *
 %************************************************************************
 
 \begin{code}
 instance Binary NameSpace where
     put_ bh VarName = do
-           putByte bh 0
+            putByte bh 0
     put_ bh DataName = do
-           putByte bh 1
+            putByte bh 1
     put_ bh TvName = do
-           putByte bh 2
+            putByte bh 2
     put_ bh TcClsName = do
-           putByte bh 3
+            putByte bh 3
     get bh = do
-           h <- getByte bh
-           case h of
-             0 -> do return VarName
-             1 -> do return DataName
-             2 -> do return TvName
-             _ -> do return TcClsName
+            h <- getByte bh
+            case h of
+              0 -> do return VarName
+              1 -> do return DataName
+              2 -> do return TvName
+              _ -> do return TcClsName
 
 instance Binary OccName where
     put_ bh (OccName aa ab) = do
-           put_ bh aa
-           put_ bh ab
+            put_ bh aa
+            put_ bh ab
     get bh = do
-         aa <- get bh
-         ab <- get bh
-         return (OccName aa ab)
+          aa <- get bh
+          ab <- get bh
+          return (OccName aa ab)
 \end{code}
index 368be68..362f408 100644 (file)
@@ -5,27 +5,21 @@
 
 \begin{code}
 {-# LANGUAGE CPP #-}
-{-# OPTIONS_GHC -fno-warn-tabs #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and
--- detab the module (please do the detabbing in a separate patch). See
---     http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
 
 module VarSet (
         -- * Var, Id and TyVar set types
-       VarSet, IdSet, TyVarSet, CoVarSet,
-
-       -- ** Manipulating these sets
-       emptyVarSet, unitVarSet, mkVarSet,
-       extendVarSet, extendVarSetList, extendVarSet_C,
-       elemVarSet, varSetElems, subVarSet,
-       unionVarSet, unionVarSets, mapUnionVarSet,
-       intersectVarSet, intersectsVarSet, disjointVarSet,
-       isEmptyVarSet, delVarSet, delVarSetList, delVarSetByKey,
-       minusVarSet, foldVarSet, filterVarSet, fixVarSet,
-       lookupVarSet, mapVarSet, sizeVarSet, seqVarSet,
-       elemVarSetByKey, partitionVarSet
+        VarSet, IdSet, TyVarSet, CoVarSet,
+
+        -- ** Manipulating these sets
+        emptyVarSet, unitVarSet, mkVarSet,
+        extendVarSet, extendVarSetList, extendVarSet_C,
+        elemVarSet, varSetElems, subVarSet,
+        unionVarSet, unionVarSets, mapUnionVarSet,
+        intersectVarSet, intersectsVarSet, disjointVarSet,
+        isEmptyVarSet, delVarSet, delVarSetList, delVarSetByKey,
+        minusVarSet, foldVarSet, filterVarSet, fixVarSet,
+        lookupVarSet, mapVarSet, sizeVarSet, seqVarSet,
+        elemVarSetByKey, partitionVarSet
     ) where
 
 #include "HsVersions.h"
@@ -36,78 +30,78 @@ import UniqSet
 \end{code}
 
 %************************************************************************
-%*                                                                     *
+%*                                                                      *
 \subsection{@VarSet@s}
-%*                                                                     *
+%*                                                                      *
 %************************************************************************
 
 \begin{code}
 type VarSet       = UniqSet Var
-type IdSet       = UniqSet Id
-type TyVarSet    = UniqSet TyVar
+type IdSet        = UniqSet Id
+type TyVarSet     = UniqSet TyVar
 type CoVarSet     = UniqSet CoVar
 
-emptyVarSet    :: VarSet
-intersectVarSet        :: VarSet -> VarSet -> VarSet
-unionVarSet    :: VarSet -> VarSet -> VarSet
-unionVarSets   :: [VarSet] -> VarSet
+emptyVarSet     :: VarSet
+intersectVarSet :: VarSet -> VarSet -> VarSet
+unionVarSet     :: VarSet -> VarSet -> VarSet
+unionVarSets    :: [VarSet] -> VarSet
 
 mapUnionVarSet  :: (a -> VarSet) -> [a] -> VarSet
 -- ^ map the function oer the list, and union the results
 
-varSetElems    :: VarSet -> [Var]
-unitVarSet     :: Var -> VarSet
-extendVarSet   :: VarSet -> Var -> VarSet
+varSetElems     :: VarSet -> [Var]
+unitVarSet      :: Var -> VarSet
+extendVarSet    :: VarSet -> Var -> VarSet
 extendVarSetList:: VarSet -> [Var] -> VarSet
-elemVarSet     :: Var -> VarSet -> Bool
-delVarSet      :: VarSet -> Var -> VarSet
-delVarSetList  :: VarSet -> [Var] -> VarSet
-minusVarSet    :: VarSet -> VarSet -> VarSet
-isEmptyVarSet  :: VarSet -> Bool
-mkVarSet       :: [Var] -> VarSet
-foldVarSet     :: (Var -> a -> a) -> a -> VarSet -> a
-lookupVarSet   :: VarSet -> Var -> Maybe Var
-                       -- Returns the set element, which may be
-                       -- (==) to the argument, but not the same as
-mapVarSet      :: (Var -> Var) -> VarSet -> VarSet
-sizeVarSet     :: VarSet -> Int
-filterVarSet   :: (Var -> Bool) -> VarSet -> VarSet
+elemVarSet      :: Var -> VarSet -> Bool
+delVarSet       :: VarSet -> Var -> VarSet
+delVarSetList   :: VarSet -> [Var] -> VarSet
+minusVarSet     :: VarSet -> VarSet -> VarSet
+isEmptyVarSet   :: VarSet -> Bool
+mkVarSet        :: [Var] -> VarSet
+foldVarSet      :: (Var -> a -> a) -> a -> VarSet -> a
+lookupVarSet    :: VarSet -> Var -> Maybe Var
+                        -- Returns the set element, which may be
+                        -- (==) to the argument, but not the same as
+mapVarSet       :: (Var -> Var) -> VarSet -> VarSet
+sizeVarSet      :: VarSet -> Int
+filterVarSet    :: (Var -> Bool) -> VarSet -> VarSet
 extendVarSet_C  :: (Var->Var->Var) -> VarSet -> Var -> VarSet
 
-delVarSetByKey :: VarSet -> Unique -> VarSet
+delVarSetByKey  :: VarSet -> Unique -> VarSet
 elemVarSetByKey :: Unique -> VarSet -> Bool
 fixVarSet       :: (VarSet -> VarSet) -> VarSet -> VarSet
 partitionVarSet :: (Var -> Bool) -> VarSet -> (VarSet, VarSet)
 
-emptyVarSet    = emptyUniqSet
-unitVarSet     = unitUniqSet
-extendVarSet   = addOneToUniqSet
+emptyVarSet     = emptyUniqSet
+unitVarSet      = unitUniqSet
+extendVarSet    = addOneToUniqSet
 extendVarSetList= addListToUniqSet
-intersectVarSet        = intersectUniqSets
-
-intersectsVarSet:: VarSet -> VarSet -> Bool    -- True if non-empty intersection
-disjointVarSet  :: VarSet -> VarSet -> Bool    -- True if empty intersection
-subVarSet      :: VarSet -> VarSet -> Bool     -- True if first arg is subset of second
-       -- (s1 `intersectsVarSet` s2) doesn't compute s2 if s1 is empty; 
-       -- ditto disjointVarSet, subVarSet
-
-unionVarSet    = unionUniqSets
-unionVarSets   = unionManyUniqSets
-varSetElems    = uniqSetToList
-elemVarSet     = elementOfUniqSet
-minusVarSet    = minusUniqSet
-delVarSet      = delOneFromUniqSet
-delVarSetList  = delListFromUniqSet
-isEmptyVarSet  = isEmptyUniqSet
-mkVarSet       = mkUniqSet
-foldVarSet     = foldUniqSet
-lookupVarSet   = lookupUniqSet
-mapVarSet      = mapUniqSet
-sizeVarSet     = sizeUniqSet
-filterVarSet   = filterUniqSet
+intersectVarSet = intersectUniqSets
+
+intersectsVarSet:: VarSet -> VarSet -> Bool     -- True if non-empty intersection
+disjointVarSet  :: VarSet -> VarSet -> Bool     -- True if empty intersection
+subVarSet       :: VarSet -> VarSet -> Bool     -- True if first arg is subset of second
+        -- (s1 `intersectsVarSet` s2) doesn't compute s2 if s1 is empty;
+        -- ditto disjointVarSet, subVarSet
+
+unionVarSet     = unionUniqSets
+unionVarSets    = unionManyUniqSets
+varSetElems     = uniqSetToList
+elemVarSet      = elementOfUniqSet
+minusVarSet     = minusUniqSet
+delVarSet       = delOneFromUniqSet
+delVarSetList   = delListFromUniqSet
+isEmptyVarSet   = isEmptyUniqSet
+mkVarSet        = mkUniqSet
+foldVarSet      = foldUniqSet
+lookupVarSet    = lookupUniqSet
+mapVarSet       = mapUniqSet
+sizeVarSet      = sizeUniqSet
+filterVarSet    = filterUniqSet
 extendVarSet_C = addOneToUniqSet_C
-delVarSetByKey = delOneFromUniqSet_Directly
-elemVarSetByKey        = elemUniqSet_Directly
+delVarSetByKey  = delOneFromUniqSet_Directly
+elemVarSetByKey = elemUniqSet_Directly
 partitionVarSet = partitionUniqSet
 \end{code}
 
@@ -121,9 +115,9 @@ subVarSet        s1 s2 = isEmptyVarSet (s1 `minusVarSet` s2)
 
 -- Iterate f to a fixpoint
 fixVarSet f s | new_s `subVarSet` s = s
-             | otherwise           = fixVarSet f new_s 
-             where
-               new_s = f s
+              | otherwise           = fixVarSet f new_s
+              where
+                new_s = f s
 \end{code}
 
 \begin{code}
index 26669b6..37517d6 100644 (file)
@@ -3,21 +3,15 @@
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
 
-       Arity and eta expansion
+        Arity and eta expansion
 
 \begin{code}
 {-# LANGUAGE CPP #-}
-{-# OPTIONS_GHC -fno-warn-tabs #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and
--- detab the module (please do the detabbing in a separate patch). See
---     http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
-
--- | Arit and eta expansion
+
+-- | Arity and eta expansion
 module CoreArity (
-       manifestArity, exprArity, typeArity, exprBotStrictness_maybe,
-       exprEtaExpandArity, findRhsArity, CheapFun, etaExpand
+        manifestArity, exprArity, typeArity, exprBotStrictness_maybe,
+        exprEtaExpandArity, findRhsArity, CheapFun, etaExpand
     ) where
 
 #include "HsVersions.h"
@@ -31,7 +25,7 @@ import Var
 import VarEnv
 import Id
 import Type
-import TyCon   ( initRecTc, checkRecTc )
+import TyCon    ( initRecTc, checkRecTc )
 import Coercion
 import BasicTypes
 import Unique
@@ -43,9 +37,9 @@ import Util     ( debugIsOn )
 \end{code}
 
 %************************************************************************
-%*                                                                     *
+%*                                                                      *
               manifestArity and exprArity
-%*                                                                     *
+%*                                                                      *
 %************************************************************************
 
 exprArity is a cheap-and-cheerful version of exprEtaExpandArity.
@@ -53,52 +47,52 @@ It tells how many things the expression can be applied to before doing
 any work.  It doesn't look inside cases, lets, etc.  The idea is that
 exprEtaExpandArity will do the hard work, leaving something that's easy
 for exprArity to grapple with.  In particular, Simplify uses exprArity to
-compute the ArityInfo for the Id. 
+compute the ArityInfo for the Id.
 
 Originally I thought that it was enough just to look for top-level lambdas, but
 it isn't.  I've seen this
 
-       foo = PrelBase.timesInt
+        foo = PrelBase.timesInt
 
 We want foo to get arity 2 even though the eta-expander will leave it
 unchanged, in the expectation that it'll be inlined.  But occasionally it
-isn't, because foo is blacklisted (used in a rule).  
+isn't, because foo is blacklisted (used in a rule).
 
-Similarly, see the ok_note check in exprEtaExpandArity.  So 
-       f = __inline_me (\x -> e)
+Similarly, see the ok_note check in exprEtaExpandArity.  So
+        f = __inline_me (\x -> e)
 won't be eta-expanded.
 
 And in any case it seems more robust to have exprArity be a bit more intelligent.
-But note that  (\x y z -> f x y z)
+But note that   (\x y z -> f x y z)
 should have arity 3, regardless of f's arity.
 
 \begin{code}
 manifestArity :: CoreExpr -> Arity
 -- ^ manifestArity sees how many leading value lambdas there are,
 --   after looking through casts
-manifestArity (Lam v e) | isId v       = 1 + manifestArity e
-                       | otherwise     = manifestArity e
+manifestArity (Lam v e) | isId v        = 1 + manifestArity e
+                        | otherwise     = manifestArity e
 manifestArity (Tick t e) | not (tickishIsCode t) =  manifestArity e
-manifestArity (Cast e _)               = manifestArity e
-manifestArity _                        = 0
+manifestArity (Cast e _)                = manifestArity e
+manifestArity _                         = 0
 
 ---------------
 exprArity :: CoreExpr -> Arity
 -- ^ An approximate, fast, version of 'exprEtaExpandArity'
 exprArity e = go e
   where
-    go (Var v)                            = idArity v
-    go (Lam x e) | isId x         = go e + 1
-                | otherwise       = go e
+    go (Var v)                     = idArity v
+    go (Lam x e) | isId x          = go e + 1
+                 | otherwise       = go e
     go (Tick t e) | not (tickishIsCode t) = go e
     go (Cast e co)                 = trim_arity (go e) (pSnd (coercionKind co))
                                         -- Note [exprArity invariant]
     go (App e (Type _))            = go e
     go (App f a) | exprIsTrivial a = (go f - 1) `max` 0
         -- See Note [exprArity for applications]
-       -- NB: coercions count as a value argument
+        -- NB: coercions count as a value argument
 
-    go _                          = 0
+    go _                           = 0
 
     trim_arity :: Arity -> Type -> Arity
     trim_arity arity ty = arity `min` length (typeArity ty)
@@ -108,26 +102,26 @@ typeArity :: Type -> [OneShotInfo]
 -- How many value arrows are visible in the type?
 -- We look through foralls, and newtypes
 -- See Note [exprArity invariant]
-typeArity ty 
+typeArity ty
   = go initRecTc ty
   where
-    go rec_nts ty 
-      | Just (_, ty')  <- splitForAllTy_maybe ty 
+    go rec_nts ty
+      | Just (_, ty')  <- splitForAllTy_maybe ty
       = go rec_nts ty'
 
-      | Just (arg,res) <- splitFunTy_maybe ty    
+      | Just (arg,res) <- splitFunTy_maybe ty
       = typeOneShot arg : go rec_nts res
-      | Just (tc,tys) <- splitTyConApp_maybe ty 
+      | Just (tc,tys) <- splitTyConApp_maybe ty
       , Just (ty', _) <- instNewTyCon_maybe tc tys
       , Just rec_nts' <- checkRecTc rec_nts tc  -- See Note [Expanding newtypes]
                                                 -- in TyCon
---   , not (isClassTyCon tc)   -- Do not eta-expand through newtype classes
---                             -- See Note [Newtype classes and eta expansion]
+--   , not (isClassTyCon tc)    -- Do not eta-expand through newtype classes
+--                              -- See Note [Newtype classes and eta expansion]
 --                              (no longer required)
       = go rec_nts' ty'
-       -- Important to look through non-recursive newtypes, so that, eg 
-       --      (f x)   where f has arity 2, f :: Int -> IO ()
-       -- Here we want to get arity 1 for the result!
+        -- Important to look through non-recursive newtypes, so that, eg
+        --      (f x)   where f has arity 2, f :: Int -> IO ()
+        -- Here we want to get arity 1 for the result!
         --
         -- AND through a layer of recursive newtypes
         -- e.g. newtype Stream m a b = Stream (m (Either b (a, Stream m a b)))
@@ -142,8 +136,8 @@ exprBotStrictness_maybe :: CoreExpr -> Maybe (Arity, StrictSig)
 -- float-out
 exprBotStrictness_maybe e
   = case getBotArity (arityType env e) of
-       Nothing -> Nothing
-       Just ar -> Just (ar, sig ar)
+        Nothing -> Nothing
+        Just ar -> Just (ar, sig ar)
   where
     env    = AE { ae_ped_bot = True, ae_cheap_fn = \ _ _ -> False }
     sig ar = mkClosedStrictSig (replicate ar topDmd) botRes
@@ -156,19 +150,19 @@ exprArity has the following invariant:
 
   (1) If typeArity (exprType e) = n,
       then manifestArity (etaExpand e n) = n
+
       That is, etaExpand can always expand as much as typeArity says
       So the case analysis in etaExpand and in typeArity must match
-  (2) exprArity e <= typeArity (exprType e)      
+
+  (2) exprArity e <= typeArity (exprType e)
 
   (3) Hence if (exprArity e) = n, then manifestArity (etaExpand e n) = n
 
-      That is, if exprArity says "the arity is n" then etaExpand really 
+      That is, if exprArity says "the arity is n" then etaExpand really
       can get "n" manifest lambdas to the top.
 
-Why is this important?  Because 
-  - In TidyPgm we use exprArity to fix the *final arity* of 
+Why is this important?  Because
+  - In TidyPgm we use exprArity to fix the *final arity* of
     each top-level Id, and in
   - In CorePrep we use etaExpand on each rhs, so that the visible lambdas
     actually match that arity, which in turn means
@@ -186,9 +180,9 @@ Note [Newtype classes and eta expansion]
 
 -------- Old out of date comments, just for interest -----------
 We have to be careful when eta-expanding through newtypes.  In general
-it's a good idea, but annoyingly it interacts badly with the class-op 
+it's a good idea, but annoyingly it interacts badly with the class-op
 rule mechanism.  Consider
+
    class C a where { op :: a -> a }
    instance C b => C [b] where
      op x = ...
@@ -206,7 +200,7 @@ These translate to
 
 Now suppose we have:
 
-   dCInt :: C Int    
+   dCInt :: C Int
 
    blah :: [Int] -> [Int]
    blah = op ($dfList dCInt)
@@ -230,7 +224,7 @@ The test simplCore/should_compile/T3722 is an excellent example.
 Note [exprArity for applications]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 When we come to an application we check that the arg is trivial.
-   eg  f (fac x) does not have arity 2, 
+   eg  f (fac x) does not have arity 2,
                  even if f has arity 3!
 
 * We require that is trivial rather merely cheap.  Suppose f has arity 2.
@@ -245,9 +239,9 @@ When we come to an application we check that the arg is trivial.
 
 
 %************************************************************************
-%*                                                                     *
-          Computing the "arity" of an expression
-%*                                                                     *
+%*                                                                      *
+           Computing the "arity" of an expression
+%*                                                                      *
 %************************************************************************
 
 Note [Definition of arity]
@@ -275,7 +269,7 @@ It's all a bit more subtle than it looks:
 Note [One-shot lambdas]
 ~~~~~~~~~~~~~~~~~~~~~~~
 Consider one-shot lambdas
-               let x = expensive in \y z -> E
+                let x = expensive in \y z -> E
 We want this to have arity 1 if the \y-abstraction is a 1-shot lambda.
 
 Note [Dealing with bottom]
@@ -291,21 +285,21 @@ In this case we do eta-expand, in order to get that \s to the
 top, and give f arity 2.
 
 This isn't really right in the presence of seq.  Consider
-       (f bot) `seq` 1
+        (f bot) `seq` 1
 
 This should diverge!  But if we eta-expand, it won't.  We ignore this
 "problem" (unless -fpedantic-bottoms is on), because being scrupulous
-would lose an important transformation for many programs. (See 
+would lose an important transformation for many programs. (See
 Trac #5587 for an example.)
 
 Consider also
-       f = \x -> error "foo"
+        f = \x -> error "foo"
 Here, arity 1 is fine.  But if it is
-       f = \x -> case x of 
-                       True  -> error "foo"
-                       False -> \y -> x+y
+        f = \x -> case x of
+                        True  -> error "foo"
+                        False -> \y -> x+y
 then we want to get arity 2.  Technically, this isn't quite right, because
-       (f True) `seq` 1
+        (f True) `seq` 1
 should diverge, but it'll converge if we eta-expand f.  Nevertheless, we
 do so; it improves some programs significantly, and increasing convergence
 isn't a bad thing.  Hence the ABot/ATop in ArityType.
@@ -318,11 +312,11 @@ this transformation.  So we try to limit it as much as possible:
        case undefined of { (a,b) -> \y -> e }
      This showed up in Trac #5557
 
- (2) Do NOT move a lambda outside a case if all the branches of 
+ (2) Do NOT move a lambda outside a case if all the branches of
      the case are known to return bottom.
         case x of { (a,b) -> \y -> error "urk" }
-     This case is less important, but the idea is that if the fn is 
-     going to diverge eventually anyway then getting the best arity 
+     This case is less important, but the idea is that if the fn is
+     going to diverge eventually anyway then getting the best arity
      isn't an issue, so we might as well play safe
 
  (3) Do NOT move a lambda outside a case unless
@@ -337,34 +331,34 @@ Of course both (1) and (2) are readily defeated by disguising the bottoms.
 Non-recursive newtypes are transparent, and should not get in the way.
 We do (currently) eta-expand recursive newtypes too.  So if we have, say
 
-       newtype T = MkT ([T] -> Int)
+        newtype T = MkT ([T] -> Int)
 
 Suppose we have
-       e = coerce T f
-where f has arity 1.  Then: etaExpandArity e = 1; 
+        e = coerce T f
+where f has arity 1.  Then: etaExpandArity e = 1;
 that is, etaExpandArity looks through the coerce.
 
 When we eta-expand e to arity 1: eta_expand 1 e T
-we want to get:                 coerce T (\x::[T] -> (coerce ([T]->Int) e) x)
+we want to get:                  coerce T (\x::[T] -> (coerce ([T]->Int) e) x)
 
   HOWEVER, note that if you use coerce bogusly you can ge
-       coerce Int negate
+        coerce Int negate
   And since negate has arity 2, you might try to eta expand.  But you can't
   decopose Int to a function type.   Hence the final case in eta_expand.
-  
+
 Note [The state-transformer hack]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose we have 
-       f = e
+Suppose we have
+        f = e
 where e has arity n.  Then, if we know from the context that f has
 a usage type like
-       t1 -> ... -> tn -1-> t(n+1) -1-> ... -1-> tm -> ...
+        t1 -> ... -> tn -1-> t(n+1) -1-> ... -1-> tm -> ...
 then we can expand the arity to m.  This usage type says that
 any application (x e1 .. en) will be applied to uniquely to (m-n) more args
-Consider f = \x. let y = <expensive> 
-                in case x of
-                     True  -> foo
-                     False -> \(s:RealWorld) -> e
+Consider f = \x. let y = <expensive>
+                 in case x of
+                      True  -> foo
+                      False -> \(s:RealWorld) -> e
 where foo has arity 1.  Then we want the state hack to
 apply to foo too, so we can eta expand the case.
 
@@ -409,16 +403,16 @@ This arose in another guise in Trac #3959.  Here we had
      catch# (throw exn >> return ())
 
 Note that (throw :: forall a e. Exn e => e -> a) is called with [a = IO ()].
-After inlining (>>) we get 
+After inlining (>>) we get
 
      catch# (\_. throw {IO ()} exn)
 
-We must *not* eta-expand to 
+We must *not* eta-expand to
 
      catch# (\_ _. throw {...} exn)
 
 because 'catch#' expects to get a (# _,_ #) after applying its argument to
-a State#, not another function!  
+a State#, not another function!
 
 In short, we use the state hack to allow us to push let inside a lambda,
 but not to introduce a new lambda.
@@ -430,24 +424,24 @@ ArityType is the result of a compositional analysis on expressions,
 from which we can decide the real arity of the expression (extracted
 with function exprEtaExpandArity).
 
-Here is what the fields mean. If an arbitrary expression 'f' has 
+Here is what the fields mean. If an arbitrary expression 'f' has
 ArityType 'at', then
 
  * If at = ABot n, then (f x1..xn) definitely diverges. Partial
    applications to fewer than n args may *or may not* diverge.
 
    We allow ourselves to eta-expand bottoming functions, even
-   if doing so may lose some `seq` sharing, 
+   if doing so may lose some `seq` sharing,
        let x = <expensive> in \y. error (g x y)
        ==> \y. let x = <expensive> in error (g x y)
 
- * If at = ATop as, and n=length as, 
-   then expanding 'f' to (\x1..xn. f x1 .. xn) loses no sharing, 
+ * If at = ATop as, and n=length as,
+   then expanding 'f' to (\x1..xn. f x1 .. xn) loses no sharing,
    assuming the calls of f respect the one-shot-ness of of
-   its definition.  
+   its definition.
 
    NB 'f' is an arbitary expression, eg (f = g e1 e2).  This 'f'
-   can have ArityType as ATop, with length as > 0, only if e1 e2 are 
+   can have ArityType as ATop, with length as > 0, only if e1 e2 are
    themselves.
 
  * In both cases, f, (f x1), ... (f x1 ... f(n-1)) are definitely
@@ -457,8 +451,8 @@ ArityType 'at', then
    So eta expansion is dynamically ok; see Note [State hack and
    bottoming functions], the part about catch#
 
-Example: 
-      f = \x\y. let v = <expensive> in 
+Example:
+      f = \x\y. let v = <expensive> in
           \s(one-shot) \t(one-shot). blah
       'f' has ArityType [ManyShot,ManyShot,OneShot,OneShot]
       The one-shot-ness means we can, in effect, push that
@@ -467,8 +461,8 @@ Example:
 
 Suppose f = \xy. x+y
 Then  f             :: AT [False,False] ATop
-      f v           :: AT [False]      ATop
-      f <expensive> :: AT []           ATop
+      f v           :: AT [False]       ATop
+      f <expensive> :: AT []            ATop
 
 -------------------- Main arity code ----------------------------
 \begin{code}
@@ -478,13 +472,13 @@ data ArityType = ATop [OneShotInfo] | ABot Arity
      -- to justify the [OneShot], or the Arity
 
 vanillaArityType :: ArityType
-vanillaArityType = ATop []     -- Totally uninformative
+vanillaArityType = ATop []      -- Totally uninformative
 
 -- ^ The Arity returned is the number of value args the
 -- expression can be applied to without doing much work
 exprEtaExpandArity :: DynFlags -> CoreExpr -> Arity
 -- exprEtaExpandArity is used when eta expanding
---     e  ==>  \xy -> e x y
+--      e  ==>  \xy -> e x y
 exprEtaExpandArity dflags e
   = case (arityType env e) of
       ATop oss -> length oss
@@ -548,11 +542,11 @@ findRhsArity dflags bndr rhs old_arity
 -- expression can be applied to without doing much work
 rhsEtaExpandArity :: DynFlags -> CheapAppFun -> CoreExpr -> Arity
 -- exprEtaExpandArity is used when eta expanding
---     e  ==>  \xy -> e x y
+--      e  ==>  \xy -> e x y
 rhsEtaExpandArity dflags cheap_app e
   = case (arityType env e) of
       ATop (os:oss)
-        | isOneShotInfo os || has_lam e -> 1 + length oss  
+        | isOneShotInfo os || has_lam e -> 1 + length oss
                                    -- Don't expand PAPs/thunks
                                    -- Note [Eta expanding thunks]
         | otherwise       -> 0
@@ -602,13 +596,13 @@ dictionary bindings.  This improves arities. Thereby, it also
 means that full laziness is less prone to floating out the
 application of a function to its dictionary arguments, which
 can thereby lose opportunities for fusion.  Example:
-       foo :: Ord a => a -> ...
+        foo :: Ord a => a -> ...
      foo = /\a \(d:Ord a). let d' = ...d... in \(x:a). ....
-       -- So foo has arity 1
+        -- So foo has arity 1
 
      f = \x. foo dInt $ bar x
 
-The (foo DInt) is floated out, and makes ineffective a RULE 
+The (foo DInt) is floated out, and makes ineffective a RULE
      foo (bar x) = ...
 
 One could go further and make exprIsCheap reply True to any
@@ -626,12 +620,12 @@ We don't eta-expand
 
 When we see
      f = case y of p -> \x -> blah
-should we eta-expand it? Well, if 'x' is a one-shot state token 
+should we eta-expand it? Well, if 'x' is a one-shot state token
 then 'yes' because 'f' will only be applied once.  But otherwise
 we (conservatively) say no.  My main reason is to avoid expanding
 PAPSs
-       f = g d  ==>  f = \x. g d x
-because that might in turn make g inline (if it has an inline pragma), 
+        f = g d  ==>  f = \x. g d x
+because that might in turn make g inline (if it has an inline pragma),
 which we might not want.  After all, INLINE pragmas say "inline only
 when saturated" so we don't want to be too gung-ho about saturating!
 
@@ -662,7 +656,7 @@ andArityType (ABot n1) (ABot n2)
 andArityType (ATop as)  (ABot _)  = ATop as
 andArityType (ABot _)   (ATop bs) = ATop bs
 andArityType (ATop as)  (ATop bs) = ATop (as `combine` bs)
-  where             -- See Note [Combining case branches]
+  where      -- See Note [Combining case branches]
     combine (a:as) (b:bs) = (a `bestOneShot` b) : combine as bs
     combine []     bs     = takeWhile isOneShotInfo bs
     combine as     []     = takeWhile isOneShotInfo as
@@ -689,11 +683,11 @@ basis that if we know one branch is one-shot, then they all must be.
 \begin{code}
 ---------------------------
 type CheapFun = CoreExpr -> Maybe Type -> Bool
-       -- How to decide if an expression is cheap
-       -- If the Maybe is Just, the type is the type
-       -- of the expression; Nothing means "don't know"
+        -- How to decide if an expression is cheap
+        -- If the Maybe is Just, the type is the type
+        -- of the expression; Nothing means "don't know"
 
-data ArityEnv 
+data ArityEnv
   = AE { ae_cheap_fn :: CheapFun
        , ae_ped_bot  :: Bool       -- True <=> be pedantic about bottoms
   }
@@ -723,37 +717,37 @@ arityType _ (Var v)
   | otherwise
   = ATop (take (idArity v) one_shots)
   where
-    one_shots :: [OneShotInfo] -- One-shot-ness derived from the type
+    one_shots :: [OneShotInfo]  -- One-shot-ness derived from the type
     one_shots = typeArity (idType v)
 
-       -- Lambdas; increase arity
+        -- Lambdas; increase arity
 arityType env (Lam x e)
   | isId x    = arityLam x (arityType env e)
   | otherwise = arityType env e
 
-       -- Applications; decrease arity, except for types
+        -- Applications; decrease arity, except for types
 arityType env (App fun (Type _))
    = arityType env fun
 arityType env (App fun arg )
    = arityApp (arityType env fun) (ae_cheap_fn env arg Nothing)
 
-       -- Case/Let; keep arity if either the expression is cheap
-       -- or it's a 1-shot lambda
-       -- The former is not really right for Haskell
-       --      f x = case x of { (a,b) -> \y. e }
-       --  ===>
-       --      f x y = case x of { (a,b) -> e }
-       -- The difference is observable using 'seq'
-       --
+        -- Case/Let; keep arity if either the expression is cheap
+        -- or it's a 1-shot lambda
+        -- The former is not really right for Haskell
+        --      f x = case x of { (a,b) -> \y. e }
+        --  ===>
+        --      f x y = case x of { (a,b) -> e }
+        -- The difference is observable using 'seq'
+        --
 arityType env (Case scrut _ _ alts)
   | exprIsBottom scrut || null alts
   = ABot 0     -- Do not eta expand
                -- See Note [Dealing with bottom (1)]
   | otherwise
   = case alts_type of
-     ABot n  | n>0       -> ATop []    -- Don't eta expand 
-            | otherwise -> ABot 0     -- if RHS is bottomming
-                                      -- See Note [Dealing with bottom (2)]
+     ABot n  | n>0       -> ATop []    -- Don't eta expand
+             | otherwise -> ABot 0     -- if RHS is bottomming
+                                       -- See Note [Dealing with bottom (2)]
 
      ATop as | not (ae_ped_bot env)    -- See Note [Dealing with bottom (3)]
              , ae_cheap_fn env scrut Nothing -> ATop as
@@ -762,7 +756,7 @@ arityType env (Case scrut _ _ alts)
   where
     alts_type = foldr1 andArityType [arityType env rhs | (_,_,rhs) <- alts]
 
-arityType env (Let b e) 
+arityType env (Let b e)
   = floatIn (cheap_bind b) (arityType env e)
   where
     cheap_bind (NonRec b e) = is_cheap (b,e)
@@ -774,32 +768,32 @@ arityType env (Tick t e)
 
 arityType _ _ = vanillaArityType
 \end{code}
-  
-  
+
+
 %************************************************************************
-%*                                                                     *
-              The main eta-expander                                                            
-%*                                                                     *
+%*                                                                      *
+              The main eta-expander
+%*                                                                      *
 %************************************************************************
 
 We go for:
    f = \x1..xn -> N  ==>   f = \x1..xn y1..ym -> N y1..ym
-                                (n >= 0)
+                                 (n >= 0)
 
-where (in both cases) 
+where (in both cases)
 
-       * The xi can include type variables
+        * The xi can include type variables
 
-       * The yi are all value variables
+        * The yi are all value variables
 
-       * N is a NORMAL FORM (i.e. no redexes anywhere)
-         wanting a suitable number of extra args.
+        * N is a NORMAL FORM (i.e. no redexes anywhere)
+          wanting a suitable number of extra args.
 
 The biggest reason for doing this is for cases like
 
-       f = \x -> case x of
-                   True  -> \y -> e1
-                   False -> \y -> e2
+        f = \x -> case x of
+                    True  -> \y -> e1
+                    False -> \y -> e2
 
 Here we want to get the lambdas together.  A good example is the nofib
 program fibheaps, which gets 25% more allocation if you don't do this
@@ -818,15 +812,15 @@ returns a CoreExpr satisfying the same invariant. See Note [Eta
 expansion and the CorePrep invariants] in CorePrep.
 
 This means the eta-expander has to do a bit of on-the-fly
-simplification but it's not too hard.  The alernative, of relying on 
+simplification but it's not too hard.  The alernative, of relying on
 a subsequent clean-up phase of the Simplifier to de-crapify the result,
 means you can't really use it in CorePrep, which is painful.
 
 Note [Eta expansion and SCCs]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Note that SCCs are not treated specially by etaExpand.  If we have
-       etaExpand 2 (\x -> scc "foo" e)
-       = (\xy -> (scc "foo" e) y)
+        etaExpand 2 (\x -> scc "foo" e)
+        = (\xy -> (scc "foo" e) y)
 So the costs of evaluating 'e' (not 'e y') are attributed to "foo"
 
 \begin{code}
@@ -840,14 +834,14 @@ So the costs of evaluating 'e' (not 'e y') are attributed to "foo"
 -- We should have that:
 --
 -- > ty = exprType e = exprType e'
-etaExpand :: Arity             -- ^ Result should have this number of value args
-         -> CoreExpr           -- ^ Expression to expand
-         -> CoreExpr
+etaExpand :: Arity              -- ^ Result should have this number of value args
+          -> CoreExpr           -- ^ Expression to expand
+          -> CoreExpr
 -- etaExpand deals with for-alls. For example:
---             etaExpand 1 E
+--              etaExpand 1 E
 -- where  E :: forall a. a -> a
 -- would return
---     (/\b. \y::a -> E b y)
+--      (/\b. \y::a -> E b y)
 --
 -- It deals with coerces too, though they are now rare
 -- so perhaps the extra code isn't worth it
@@ -859,20 +853,20 @@ etaExpand n orig_expr
       -- Note [Eta expansion and SCCs]
     go 0 expr = expr
     go n (Lam v body) | isTyVar v = Lam v (go n     body)
-                             | otherwise = Lam v (go (n-1) body)
+                      | otherwise = Lam v (go (n-1) body)
     go n (Cast expr co) = Cast (go n expr) co
     go n expr           = -- pprTrace "ee" (vcat [ppr orig_expr, ppr expr, ppr etas]) $
-                                 etaInfoAbs etas (etaInfoApp subst' expr etas)
-                       where
-                           in_scope = mkInScopeSet (exprFreeVars expr)
-                           (in_scope', etas) = mkEtaWW n orig_expr in_scope (exprType expr)
-                           subst' = mkEmptySubst in_scope'
+                          etaInfoAbs etas (etaInfoApp subst' expr etas)
+                        where
+                            in_scope = mkInScopeSet (exprFreeVars expr)
+                            (in_scope', etas) = mkEtaWW n orig_expr in_scope (exprType expr)
+                            subst' = mkEmptySubst in_scope'
 
-                               -- Wrapper    Unwrapper
+                                -- Wrapper    Unwrapper
 --------------
-data EtaInfo = EtaVar Var      -- /\a. [],   [] a
-                               -- \x.  [],   [] x
-            | EtaCo Coercion   -- [] |> co,  [] |> (sym co)
+data EtaInfo = EtaVar Var       -- /\a. [],   [] a
+                                -- \x.  [],   [] x
+             | EtaCo Coercion   -- [] |> co,  [] |> (sym co)
 
 instance Outputable EtaInfo where
    ppr (EtaVar v) = ptext (sLit "EtaVar") <+> ppr v
@@ -881,7 +875,7 @@ instance Outputable EtaInfo where
 pushCoercion :: Coercion -> [EtaInfo] -> [EtaInfo]
 pushCoercion co1 (EtaCo co2 : eis)
   | isReflCo co = eis
-  | otherwise  = EtaCo co : eis
+  | otherwise   = EtaCo co : eis
   where
     co = co1 `mkTransCo` co2
 
@@ -895,10 +889,10 @@ etaInfoAbs (EtaCo co : eis) expr = Cast (etaInfoAbs eis expr) (mkSymCo co)
 
 --------------
 etaInfoApp :: Subst -> CoreExpr -> [EtaInfo] -> CoreExpr
--- (etaInfoApp s e eis) returns something equivalent to 
---            ((substExpr s e) `appliedto` eis)
+-- (etaInfoApp s e eis) returns something equivalent to
+--             ((substExpr s e) `appliedto` eis)
 
-etaInfoApp subst (Lam v1 e) (EtaVar v2 : eis) 
+etaInfoApp subst (Lam v1 e) (EtaVar v2 : eis)
   = etaInfoApp (CoreSubst.extendSubstWithVar subst v1 v2) e eis
 
 etaInfoApp subst (Cast e co1) eis
@@ -906,20 +900,20 @@ etaInfoApp subst (Cast e co1) eis
   where
     co' = CoreSubst.substCo subst co1
 
-etaInfoApp subst (Case e b ty alts) eis 
+etaInfoApp subst (Case e b ty alts) eis
   = Case (subst_expr subst e) b1 (mk_alts_ty (CoreSubst.substTy subst ty) eis) alts'
   where
     (subst1, b1) = substBndr subst b
     alts' = map subst_alt alts
-    subst_alt (con, bs, rhs) = (con, bs', etaInfoApp subst2 rhs eis) 
-             where
-                (subst2,bs') = substBndrs subst1 bs
+    subst_alt (con, bs, rhs) = (con, bs', etaInfoApp subst2 rhs eis)
+              where
+                 (subst2,bs') = substBndrs subst1 bs
 
     mk_alts_ty ty []               = ty
     mk_alts_ty ty (EtaVar v : eis) = mk_alts_ty (applyTypeToArg ty (varToCoreExpr v)) eis
     mk_alts_ty _  (EtaCo co : eis) = mk_alts_ty (pSnd (coercionKind co)) eis
-    
-etaInfoApp subst (Let b e) eis 
+
+etaInfoApp subst (Let b e) eis
   = Let b' (etaInfoApp subst' e eis)
   where
     (subst', b') = subst_bind subst b
@@ -936,18 +930,18 @@ etaInfoApp subst e eis
 
 --------------
 mkEtaWW :: Arity -> CoreExpr -> InScopeSet -> Type
-       -> (InScopeSet, [EtaInfo])
-       -- EtaInfo contains fresh variables,
-       --   not free in the incoming CoreExpr
-       -- Outgoing InScopeSet includes the EtaInfo vars
-       --   and the original free vars
+        -> (InScopeSet, [EtaInfo])
+        -- EtaInfo contains fresh variables,
+        --   not free in the incoming CoreExpr
+        -- Outgoing InScopeSet includes the EtaInfo vars
+        --   and the original free vars
 
 mkEtaWW orig_n orig_expr in_scope orig_ty
   = go orig_n empty_subst orig_ty []
   where
     empty_subst = TvSubst in_scope emptyTvSubstEnv
 
-    go n subst ty eis      -- See Note [exprArity invariant]
+    go n subst ty eis       -- See Note [exprArity invariant]
        | n == 0
        = (getTvInScope subst, reverse eis)
 
@@ -957,29 +951,29 @@ mkEtaWW orig_n orig_expr in_scope orig_ty
        = go n subst' ty' (EtaVar tv' : eis)
 
        | Just (arg_ty, res_ty) <- splitFunTy_maybe ty
-       , let (subst', eta_id') = freshEtaId n subst arg_ty 
+       , let (subst', eta_id') = freshEtaId n subst arg_ty
            -- Avoid free vars of the original expression
        = go (n-1) subst' res_ty (EtaVar eta_id' : eis)
-                                          
+
        | Just (co, ty') <- topNormaliseNewType_maybe ty
-       =       -- Given this:
-                       --      newtype T = MkT ([T] -> Int)
-                       -- Consider eta-expanding this
-                       --      eta_expand 1 e T
-                       -- We want to get
-                       --      coerce T (\x::[T] -> (coerce ([T]->Int) e) x)
+       =        -- Given this:
+                --      newtype T = MkT ([T] -> Int)
+                -- Consider eta-expanding this
+                --      eta_expand 1 e T
+                -- We want to get
+                --      coerce T (\x::[T] -> (coerce ([T]->Int) e) x)
          go n subst ty' (EtaCo co : eis)
 
-       | otherwise      -- We have an expression of arity > 0, 
-                                -- but its type isn't a function.                 
+       | otherwise       -- We have an expression of arity > 0,
+                         -- but its type isn't a function.
        = WARN( True, (ppr orig_n <+> ppr orig_ty) $$ ppr orig_expr )
          (getTvInScope subst, reverse eis)
-       -- This *can* legitmately happen:
-       -- e.g.  coerce Int (\x. x) Essentially the programmer is
-       -- playing fast and loose with types (Happy does this a lot).
-       -- So we simply decline to eta-expand.  Otherwise we'd end up
-       -- with an explicit lambda having a non-function type
-   
+        -- This *can* legitmately happen:
+        -- e.g.  coerce Int (\x. x) Essentially the programmer is
+        -- playing fast and loose with types (Happy does this a lot).
+        -- So we simply decline to eta-expand.  Otherwise we'd end up
+        -- with an explicit lambda having a non-function type
+
 
 --------------
 -- Avoiding unnecessary substitution; use short-cutting versions
@@ -997,14 +991,14 @@ freshEtaId :: Int -> TvSubst -> Type -> (TvSubst, Id)
 -- It should be "fresh" in the sense that it's not in the in-scope set
 -- of the TvSubstEnv; and it should itself then be added to the in-scope
 -- set of the TvSubstEnv
--- 
+--
 -- The Int is just a reasonable starting point for generating a unique;
 -- it does not necessarily have to be unique itself.
 freshEtaId n subst ty
       = (subst', eta_id')
       where
         ty'     = Type.substTy subst ty
-       eta_id' = uniqAway (getTvInScope subst) $
-                 mkSysLocal (fsLit "eta") (mkBuiltinUnique n) ty'
-       subst'  = extendTvInScope subst eta_id'           
+        eta_id' = uniqAway (getTvInScope subst) $
+                  mkSysLocal (fsLit "eta") (mkBuiltinUnique n) ty'
+        subst'  = extendTvInScope subst eta_id'
 \end{code}
index d739738..47418e2 100644 (file)
@@ -5,39 +5,33 @@
 
 \begin{code}
 {-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor #-}
-{-# OPTIONS_GHC -fno-warn-tabs #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and
--- detab the module (please do the detabbing in a separate patch). See
---     http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
 
 -- | CoreSyn holds all the main data types for use by for the Glasgow Haskell Compiler midsection
 module CoreSyn (
-       -- * Main data types
+        -- * Main data types
         Expr(..), Alt, Bind(..), AltCon(..), Arg, Tickish(..),
         CoreProgram, CoreExpr, CoreAlt, CoreBind, CoreArg, CoreBndr,
         TaggedExpr, TaggedAlt, TaggedBind, TaggedArg, TaggedBndr(..), deTagExpr,
 
         -- ** 'Expr' construction
-       mkLets, mkLams,
-       mkApps, mkTyApps, mkCoApps, mkVarApps,
-       
-       mkIntLit, mkIntLitInt,
-       mkWordLit, mkWordLitWord,
-       mkWord64LitWord64, mkInt64LitInt64,
-       mkCharLit, mkStringLit,
-       mkFloatLit, mkFloatLitFloat,
-       mkDoubleLit, mkDoubleLitDouble,
-       
-       mkConApp, mkConApp2, mkTyBind, mkCoBind,
-       varToCoreExpr, varsToCoreExprs,
+        mkLets, mkLams,
+        mkApps, mkTyApps, mkCoApps, mkVarApps,
+
+        mkIntLit, mkIntLitInt,
+        mkWordLit, mkWordLitWord,
+        mkWord64LitWord64, mkInt64LitInt64,
+        mkCharLit, mkStringLit,
+        mkFloatLit, mkFloatLitFloat,
+        mkDoubleLit, mkDoubleLitDouble,
+
+        mkConApp, mkConApp2, mkTyBind, mkCoBind,
+        varToCoreExpr, varsToCoreExprs,
 
         isId, cmpAltCon, cmpAlt, ltAlt,
-       
-       -- ** Simple 'Expr' access functions and predicates
-       bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts, 
-       collectBinders, collectTyBinders, collectValBinders, collectTyAndValBinders,
+
+        -- ** Simple 'Expr' access functions and predicates
+        bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts,
+        collectBinders, collectTyBinders, collectValBinders, collectTyAndValBinders,
         collectArgs, flattenBinds,
 
         isValArg, isTypeArg, isTyCoArg, valArgCount, valBndrCount,
@@ -49,42 +43,42 @@ module CoreSyn (
         -- * Unfolding data types
         Unfolding(..),  UnfoldingGuidance(..), UnfoldingSource(..),
 
-       -- ** Constructing 'Unfolding's
-       noUnfolding, evaldUnfolding, mkOtherCon,
+        -- ** Constructing 'Unfolding's
+        noUnfolding, evaldUnfolding, mkOtherCon,
         unSaturatedOk, needSaturated, boringCxtOk, boringCxtNotOk,
-       
-       -- ** Predicates and deconstruction on 'Unfolding'
-       unfoldingTemplate, expandUnfolding_maybe,
-       maybeUnfoldingTemplate, otherCons, 
-       isValueUnfolding, isEvaldUnfolding, isCheapUnfolding,
+
+        -- ** Predicates and deconstruction on 'Unfolding'
+        unfoldingTemplate, expandUnfolding_maybe,
+        maybeUnfoldingTemplate, otherCons,
+        isValueUnfolding, isEvaldUnfolding, isCheapUnfolding,
         isExpandableUnfolding, isConLikeUnfolding, isCompulsoryUnfolding,
         isStableUnfolding, hasStableCoreUnfolding_maybe,
-        isClosedUnfolding, hasSomeUnfolding, 
-       canUnfold, neverUnfoldGuidance, isStableSource,
+        isClosedUnfolding, hasSomeUnfolding,
+        canUnfold, neverUnfoldGuidance, isStableSource,
+
+        -- * Strictness
+        seqExpr, seqExprs, seqUnfolding,
 
-       -- * Strictness
-       seqExpr, seqExprs, seqUnfolding, 
+        -- * Annotated expression data types
+        AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt,
 
-       -- * Annotated expression data types
-       AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt,
-       
         -- ** Operations on annotated expressions
         collectAnnArgs,
 
-       -- ** Operations on annotations
-       deAnnotate, deAnnotate', deAnnAlt, collectAnnBndrs,
+        -- ** Operations on annotations
+        deAnnotate, deAnnotate', deAnnAlt, collectAnnBndrs,
+
+        -- * Core rule data types
+        CoreRule(..),   -- CoreSubst, CoreTidy, CoreFVs, PprCore only
+        RuleName, RuleFun, IdUnfoldingFun, InScopeEnv,
 
-       -- * Core rule data types
-       CoreRule(..),   -- CoreSubst, CoreTidy, CoreFVs, PprCore only
-       RuleName, RuleFun, IdUnfoldingFun, InScopeEnv,
-       
-       -- ** Operations on 'CoreRule's 
-       seqRules, ruleArity, ruleName, ruleIdName, ruleActivation,
-       setRuleIdName,
-       isBuiltinRule, isLocalRule, isAutoRule,
+        -- ** Operations on 'CoreRule's
+        seqRules, ruleArity, ruleName, ruleIdName, ruleActivation,
+        setRuleIdName,
+        isBuiltinRule, isLocalRule, isAutoRule,
 
-       -- * Core vectorisation declarations data type
-       CoreVect(..)
+        -- * Core vectorisation declarations data type
+        CoreVect(..)
     ) where
 
 #include "HsVersions.h"
@@ -114,9 +108,9 @@ infixl 4 `mkApps`, `mkTyApps`, `mkVarApps`, `App`, `mkCoApps`
 \end{code}
 
 %************************************************************************
-%*                                                                     *
+%*                                                                      *
 \subsection{The main data types}
-%*                                                                     *
+%*                                                                      *
 %************************************************************************
 
 These data types are the heart of the compiler
@@ -132,7 +126,7 @@ These data types are the heart of the compiler
 --    by the data type 'HsExpr.HsExpr' with the names being 'RdrName.RdrNames'
 --
 -- 2. This syntax tree is /renamed/, which attaches a 'Unique.Unique' to every 'RdrName.RdrName'
---    (yielding a 'Name.Name') to disambiguate identifiers which are lexically identical. 
+--    (yielding a 'Name.Name') to disambiguate identifiers which are lexically identical.
 --    For example, this program:
 --
 -- @
@@ -172,24 +166,24 @@ These data types are the heart of the compiler
 -- *  Recursive and non recursive @let@s. Operationally
 --    this corresponds to allocating a thunk for the things
 --    bound and then executing the sub-expression.
---    
+--
 --    #top_level_invariant#
 --    #letrec_invariant#
---    
+--
 --    The right hand sides of all top-level and recursive @let@s
 --    /must/ be of lifted type (see "Type#type_classification" for
 --    the meaning of /lifted/ vs. /unlifted/).
---    
+--
 --    See Note [CoreSyn let/app invariant]
 --
 --    #type_let#
 --    We allow a /non-recursive/ let to bind a type variable, thus:
---    
+--
 --    > Let (NonRec tv (Type ty)) body
---    
+--
 --    This can be very convenient for postponing type substitutions until
 --    the next run of the simplifier.
---    
+--
 --    At the moment, the rest of the compiler only deals with type-let
 --    in a Let expression, rather than at top level.  We may want to revist
 --    this choice.
@@ -198,43 +192,43 @@ These data types are the heart of the compiler
 --    the scrutinee (expression examined) to weak head normal form
 --    and then examining at most one level of resulting constructor (i.e. you
 --    cannot do nested pattern matching directly with this).
---    
+--
 --    The binder gets bound to the value of the scrutinee,
 --    and the 'Type' must be that of all the case alternatives
---    
+--
 --    #case_invariants#
---    This is one of the more complicated elements of the Core language, 
+--    This is one of the more complicated elements of the Core language,
 --    and comes with a number of restrictions:
---    
---    1. The list of alternatives may be empty; 
+--
+--    1. The list of alternatives may be empty;
 --       See Note [Empty case alternatives]
 --
---    2. The 'DEFAULT' case alternative must be first in the list, 
+--    2. The 'DEFAULT' case alternative must be first in the list,
 --       if it occurs at all.
---    
---    3. The remaining cases are in order of increasing 
---         tag (for 'DataAlts') or
---         lit (for 'LitAlts').
---       This makes finding the relevant constructor easy, 
+--
+--    3. The remaining cases are in order of increasing
+--         tag  (for 'DataAlts') or
+--         lit  (for 'LitAlts').
+--       This makes finding the relevant constructor easy,
 --       and makes comparison easier too.
---    
---    4. The list of alternatives must be exhaustive. An /exhaustive/ case 
+--
+--    4. The list of alternatives must be exhaustive. An /exhaustive/ case
 --       does not necessarily mention all constructors:
---    
---      @
---           data Foo = Red | Green | Blue
---      ... case x of 
---           Red   -> True
---           other -> f (case x of 
---                           Green -> ...
---                           Blue  -> ... ) ...
---      @
---    
---      The inner case does not need a @Red@ alternative, because @x@ 
---      can't be @Red@ at that program point.
 --
--- *  Cast an expression to a particular type. 
---    This is used to implement @newtype@s (a @newtype@ constructor or 
+--       @
+--            data Foo = Red | Green | Blue
+--       ... case x of
+--            Red   -> True
+--            other -> f (case x of
+--                            Green -> ...
+--                            Blue  -> ... ) ...
+--       @
+--
+--       The inner case does not need a @Red@ alternative, because @x@
+--       can't be @Red@ at that program point.
+--
+-- *  Cast an expression to a particular type.
+--    This is used to implement @newtype@s (a @newtype@ constructor or
 --    destructor just becomes a 'Cast' in Core) and GADTs.
 --
 -- *  Notes. These allow general information to be added to expressions
@@ -247,12 +241,12 @@ These data types are the heart of the compiler
 -- If you edit this type, you may need to update the GHC formalism
 -- See Note [GHC Formalism] in coreSyn/CoreLint.lhs
 data Expr b
-  = Var          Id
+  = Var   Id
   | Lit   Literal
   | App   (Expr b) (Arg b)
   | Lam   b (Expr b)
   | Let   (Bind b) (Expr b)
-  | Case  (Expr b) b Type [Alt b]      -- See #case_invariant#
+  | Case  (Expr b) b Type [Alt b]       -- See #case_invariant#
   | Cast  (Expr b) Coercion
   | Tick  (Tickish Id) (Expr b)
   | Type  Type
@@ -275,14 +269,14 @@ type Alt b = (AltCon, [b], Expr b)
 
 -- If you edit this type, you may need to update the GHC formalism
 -- See Note [GHC Formalism] in coreSyn/CoreLint.lhs
-data AltCon 
+data AltCon
   = DataAlt DataCon   --  ^ A plain data constructor: @case e of { Foo x -> ... }@.
                       -- Invariant: the 'DataCon' is always from a @data@ type, and never from a @newtype@
 
   | LitAlt  Literal   -- ^ A literal: @case e of { 1 -> ... }@
                       -- Invariant: always an *unlifted* literal
-                     -- See Note [Literal alternatives]
-                     
+                      -- See Note [Literal alternatives]
+
   | DEFAULT           -- ^ Trivial alternative: @case e of { _ -> ... }@
    deriving (Eq, Ord, Data, Typeable)
 
@@ -291,7 +285,7 @@ data AltCon
 -- If you edit this type, you may need to update the GHC formalism
 -- See Note [GHC Formalism] in coreSyn/CoreLint.lhs
 data Bind b = NonRec b (Expr b)
-           | Rec [(b, (Expr b))]
+            | Rec [(b, (Expr b))]
   deriving (Data, Typeable)
 \end{code}
 
@@ -385,7 +379,7 @@ The alternatives of a case expression should be exhaustive.  A case expression
 can have empty alternatives if (and only if) the scrutinee is bound to raise
 an exception or diverge.  So:
    Case (error Int "Hello") b Bool []
-is fine, and has type Bool.  This is one reason we need a type on 
+is fine, and has type Bool.  This is one reason we need a type on
 the case expression: if the alternatives are empty we can't get the type
 from the alternatives!  I'll write this
    case (error Int "Hello") of Bool {}
@@ -402,7 +396,7 @@ degnerate situation but we do NOT want to replace
    case x of Bool {}   -->   error Bool "Inaccessible case"
 because x might raise an exception, and *that*'s what we want to see!
 (Trac #6067 is an example.) To preserve semantics we'd have to say
-   x `seq` error Bool "Inaccessible case"   
+   x `seq` error Bool "Inaccessible case"
  but the 'seq' is just a case, so we are back to square 1.  Or I suppose
 we could say
    x |> UnsafeCoerce T Bool
@@ -414,7 +408,7 @@ one type to another.  For example
 
     f :: Int -> Int
     f n = error "urk"
-   
+
     g :: Int -> (# Char, Bool #)
     g x = case f x of { 0 -> ..., n -> ... }
 
@@ -424,14 +418,14 @@ and we can discard the alternatives since the scrutinee is bottom to give
     case (error Int "urk") of (# Char, Bool #) {}
 
 This is nicer than using an unsafe coerce between Int ~ (# Char,Bool #),
-if for no other reason that we don't need to instantiate the (~) at an 
+if for no other reason that we don't need to instantiate the (~) at an
 unboxed type.
 
 
 %************************************************************************
-%*                                                                     *
+%*                                                                      *
               Ticks
-%*                                                                     *
+%*                                                                      *
 %************************************************************************
 
 \begin{code}
@@ -523,9 +517,9 @@ tickishCanSplit _ = True
 
 
 %************************************************************************
-%*                                                                     *
+%*                                                                      *
 \subsection{Transformation rules}
-%*                                                                     *
+%*                                                                      *
 %************************************************************************
 
 The CoreRule type and its friends are dealt with mainly in CoreRules,
@@ -540,52 +534,52 @@ but CoreFVs, Subst, PprCore, CoreTidy also inspect the representation.
 -- * \"Orphan\" if nothing on the LHS is defined in the same module
 --   as the rule itself
 data CoreRule
-  = Rule { 
-       ru_name :: RuleName,            -- ^ Name of the rule, for communication with the user
-       ru_act  :: Activation,          -- ^ When the rule is active
-
-       -- Rough-matching stuff
-       -- see comments with InstEnv.ClsInst( is_cls, is_rough )
-       ru_fn    :: Name,               -- ^ Name of the 'Id.Id' at the head of this rule
-       ru_rough :: [Maybe Name],       -- ^ Name at the head of each argument to the left hand side
-       
-       -- Proper-matching stuff
-       -- see comments with InstEnv.ClsInst( is_tvs, is_tys )
-       ru_bndrs :: [CoreBndr],         -- ^ Variables quantified over
-       ru_args  :: [CoreExpr],         -- ^ Left hand side arguments
-       
-       -- And the right-hand side
-       ru_rhs   :: CoreExpr,           -- ^ Right hand side of the rule
-                                       -- Occurrence info is guaranteed correct
-                                       -- See Note [OccInfo in unfoldings and rules]
-
-       -- Locality
-        ru_auto :: Bool,       -- ^ @True@  <=> this rule is auto-generated
-                               --   @False@ <=> generated at the users behest
-                               --   Main effect: reporting of orphan-hood
-
-       ru_local :: Bool        -- ^ @True@ iff the fn at the head of the rule is
-                               -- defined in the same module as the rule
-                               -- and is not an implicit 'Id' (like a record selector,
-                               -- class operation, or data constructor)
-
-               -- NB: ru_local is *not* used to decide orphan-hood
-               --      c.g. MkIface.coreRuleToIfaceRule
+  = Rule {
+        ru_name :: RuleName,            -- ^ Name of the rule, for communication with the user
+        ru_act  :: Activation,          -- ^ When the rule is active
+
+        -- Rough-matching stuff
+        -- see comments with InstEnv.ClsInst( is_cls, is_rough )
+        ru_fn    :: Name,               -- ^ Name of the 'Id.Id' at the head of this rule
+        ru_rough :: [Maybe Name],       -- ^ Name at the head of each argument to the left hand side
+
+        -- Proper-matching stuff
+        -- see comments with InstEnv.ClsInst( is_tvs, is_tys )
+        ru_bndrs :: [CoreBndr],         -- ^ Variables quantified over
+        ru_args  :: [CoreExpr],         -- ^ Left hand side arguments
+
+        -- And the right-hand side
+        ru_rhs   :: CoreExpr,           -- ^ Right hand side of the rule
+                                        -- Occurrence info is guaranteed correct
+                                        -- See Note [OccInfo in unfoldings and rules]
+
+        -- Locality
+        ru_auto :: Bool,        -- ^ @True@  <=> this rule is auto-generated
+                                --   @False@ <=> generated at the users behest
+                                --   Main effect: reporting of orphan-hood
+
+        ru_local :: Bool        -- ^ @True@ iff the fn at the head of the rule is
+                                -- defined in the same module as the rule
+                                -- and is not an implicit 'Id' (like a record selector,
+                                -- class operation, or data constructor)
+
+                -- NB: ru_local is *not* used to decide orphan-hood
+                --      c.g. MkIface.coreRuleToIfaceRule
     }
 
   -- | Built-in rules are used for constant folding
   -- and suchlike.  They have no free variables.
-  | BuiltinRule {               
-       ru_name  :: RuleName,   -- ^ As above
-       ru_fn    :: Name,       -- ^ As above
-       ru_nargs :: Int,        -- ^ Number of arguments that 'ru_try' consumes,
-                               -- if it fires, including type arguments
-       ru_try   :: RuleFun
-               -- ^ This function does the rewrite.  It given too many
-               -- arguments, it simply discards them; the returned 'CoreExpr'
-               -- is just the rewrite of 'ru_fn' applied to the first 'ru_nargs' args
+  | BuiltinRule {
+        ru_name  :: RuleName,   -- ^ As above
+        ru_fn    :: Name,       -- ^ As above
+        ru_nargs :: Int,        -- ^ Number of arguments that 'ru_try' consumes,
+                                -- if it fires, including type arguments
+        ru_try   :: RuleFun
+                -- ^ This function does the rewrite.  It given too many
+                -- arguments, it simply discards them; the returned 'CoreExpr'
+                -- is just the rewrite of 'ru_fn' applied to the first 'ru_nargs' args
     }
-               -- See Note [Extra args in rule matching] in Rules.lhs
+                -- See Note [Extra args in rule matching] in Rules.lhs
 
 type RuleFun = DynFlags -> InScopeEnv -> Id -> [CoreExpr] -> Maybe CoreExpr
 type InScopeEnv = (InScopeSet, IdUnfoldingFun)
@@ -597,13 +591,13 @@ type IdUnfoldingFun = Id -> Unfolding
 
 isBuiltinRule :: CoreRule -> Bool
 isBuiltinRule (BuiltinRule {}) = True
-isBuiltinRule _                       = False
+isBuiltinRule _                = False
 
 isAutoRule :: CoreRule -> Bool
 isAutoRule (BuiltinRule {}) = False
 isAutoRule (Rule { ru_auto = is_auto }) = is_auto
 
--- | The number of arguments the 'ru_fn' must be applied 
+-- | The number of arguments the 'ru_fn' must be applied
 -- to before the rule can match on it
 ruleArity :: CoreRule -> Int
 ruleArity (BuiltinRule {ru_nargs = n}) = n
@@ -663,49 +657,49 @@ data Unfolding
   = NoUnfolding        -- ^ We have no information about the unfolding
 
   | OtherCon [AltCon]  -- ^ It ain't one of these constructors.
-                      -- @OtherCon xs@ also indicates that something has been evaluated
-                      -- and hence there's no point in re-evaluating it.
-                      -- @OtherCon []@ is used even for non-data-type values
-                      -- to indicated evaluated-ness.  Notably:
-                      --
-                      -- > data C = C !(Int -> Int)
-                      -- > case x of { C f -> ... }
-                      --
-                      -- Here, @f@ gets an @OtherCon []@ unfolding.
-
-  | DFunUnfolding {     -- The Unfolding of a DFunId  
-                       -- See Note [DFun unfoldings]
-                       --     df = /\a1..am. \d1..dn. MkD t1 .. tk
+                       -- @OtherCon xs@ also indicates that something has been evaluated
+                       -- and hence there's no point in re-evaluating it.
+                       -- @OtherCon []@ is used even for non-data-type values
+                       -- to indicated evaluated-ness.  Notably:
+                       --
+                       -- > data C = C !(Int -> Int)
+                       -- > case x of { C f -> ... }
+                       --
+                       -- Here, @f@ gets an @OtherCon []@ unfolding.
+
+  | DFunUnfolding {     -- The Unfolding of a DFunId
+                        -- See Note [DFun unfoldings]
+                        --     df = /\a1..am. \d1..dn. MkD t1 .. tk
                         --                                 (op1 a1..am d1..dn)
-                       --                                 (op2 a1..am d1..dn)
+                        --                                 (op2 a1..am d1..dn)
         df_bndrs :: [Var],      -- The bound variables [a1..m],[d1..dn]
         df_con   :: DataCon,    -- The dictionary data constructor (never a newtype datacon)
         df_args  :: [CoreExpr]  -- Args of the data con: types, superclasses and methods,
     }                           -- in positional order
 
-  | CoreUnfolding {            -- An unfolding for an Id with no pragma, 
+  | CoreUnfolding {             -- An unfolding for an Id with no pragma,
                                 -- or perhaps a NOINLINE pragma
-                               -- (For NOINLINE, the phase, if any, is in the 
+                                -- (For NOINLINE, the phase, if any, is in the
                                 -- InlinePragInfo for this Id.)
-       uf_tmpl       :: CoreExpr,        -- Template; occurrence info is correct
-       uf_src        :: UnfoldingSource, -- Where the unfolding came from
-       uf_is_top     :: Bool,          -- True <=> top level binding
-       uf_is_value   :: Bool,          -- exprIsHNF template (cached); it is ok to discard 
-                                       --      a `seq` on this variable
+        uf_tmpl       :: CoreExpr,        -- Template; occurrence info is correct
+        uf_src        :: UnfoldingSource, -- Where the unfolding came from
+        uf_is_top     :: Bool,          -- True <=> top level binding
+        uf_is_value   :: Bool,          -- exprIsHNF template (cached); it is ok to discard
+                                        --      a `seq` on this variable
         uf_is_conlike :: Bool,          -- True <=> applicn of constructor or CONLIKE function
                                         --      Cached version of exprIsConLike
-       uf_is_work_free :: Bool,                -- True <=> doesn't waste (much) work to expand 
+        uf_is_work_free :: Bool,                -- True <=> doesn't waste (much) work to expand
                                         --          inside an inlining
-                                       --      Cached version of exprIsCheap
-       uf_expandable :: Bool,          -- True <=> can expand in RULE matching
-                                       --      Cached version of exprIsExpandable
-       uf_guidance   :: UnfoldingGuidance      -- Tells about the *size* of the template.
+                                        --      Cached version of exprIsCheap
+        uf_expandable :: Bool,          -- True <=> can expand in RULE matching
+                                        --      Cached version of exprIsExpandable
+        uf_guidance   :: UnfoldingGuidance      -- Tells about the *size* of the template.
     }
   -- ^ An unfolding with redundant cached information. Parameters:
   --
-  --  uf_tmpl: Template used to perform unfolding; 
-  --           NB: Occurrence info is guaranteed correct: 
-  --              see Note [OccInfo in unfoldings and rules]
+  --  uf_tmpl: Template used to perform unfolding;
+  --           NB: Occurrence info is guaranteed correct:
+  --               see Note [OccInfo in unfoldings and rules]
   --
   --  uf_is_top: Is this a top level binding?
   --
@@ -721,11 +715,11 @@ data Unfolding
 ------------------------------------------------
 data UnfoldingSource
   = -- See also Note [Historical note: unfoldings for wrappers]
-   
+
     InlineRhs          -- The current rhs of the function
-                      -- Replace uf_tmpl each time around
+                       -- Replace uf_tmpl each time around
 
-  | InlineStable       -- From an INLINE or INLINABLE pragma 
+  | InlineStable       -- From an INLINE or INLINABLE pragma
                        --   INLINE     if guidance is UnfWhen
                        --   INLINABLE  if guidance is UnfIfGoodArgs/UnfoldNever
                        -- (well, technically an INLINABLE might be made
@@ -735,15 +729,15 @@ data UnfoldingSource
                        -- work so it is consistent with the intended
                        -- meaning of INLINABLE).
                        --
-                      -- uf_tmpl may change, but only as a result of
+                       -- uf_tmpl may change, but only as a result of
                        -- gentle simplification, it doesn't get updated
                        -- to the current RHS during compilation as with
                        -- InlineRhs.
                        --
-                      -- See Note [InlineRules]
+                       -- See Note [InlineRules]
 
   | InlineCompulsory   -- Something that *has* no binding, so you *must* inline it
-                      -- Only a few primop-like things have this property 
+                       -- Only a few primop-like things have this property
                        -- (see MkId.lhs, calls to mkCompulsoryUnfolding).
                        -- Inline absolutely always, however boring the context.
 
@@ -751,31 +745,31 @@ data UnfoldingSource
 
 -- | 'UnfoldingGuidance' says when unfolding should take place
 data UnfoldingGuidance
-  = UnfWhen {  -- Inline without thinking about the *size* of the uf_tmpl
-               -- Used (a) for small *and* cheap unfoldings
-               --      (b) for INLINE functions 
+  = UnfWhen {   -- Inline without thinking about the *size* of the uf_tmpl
+                -- Used (a) for small *and* cheap unfoldings
+                --      (b) for INLINE functions
                 -- See Note [INLINE for small functions] in CoreUnfold
-      ug_arity    :: Arity,            -- Number of value arguments expected
+      ug_arity    :: Arity,             -- Number of value arguments expected
 
-      ug_unsat_ok  :: Bool,    -- True <=> ok to inline even if unsaturated
+      ug_unsat_ok  :: Bool,     -- True <=> ok to inline even if unsaturated
       ug_boring_ok :: Bool      -- True <=> ok to inline even if the context is boring
-               -- So True,True means "always"
+                -- So True,True means "always"
     }
 
-  | UnfIfGoodArgs {    -- Arose from a normal Id; the info here is the
-                       -- result of a simple analysis of the RHS
+  | UnfIfGoodArgs {     -- Arose from a normal Id; the info here is the
+                        -- result of a simple analysis of the RHS
 
       ug_args ::  [Int],  -- Discount if the argument is evaluated.
-                         -- (i.e., a simplification will definitely
-                         -- be possible).  One elt of the list per *value* arg.
+                          -- (i.e., a simplification will definitely
+                          -- be possible).  One elt of the list per *value* arg.
 
-      ug_size :: Int,    -- The "size" of the unfolding.
+      ug_size :: Int,     -- The "size" of the unfolding.
 
-      ug_res :: Int      -- Scrutinee discount: the discount to substract if the thing is in
-    }                    -- a context (case (thing args) of ...),
-                         -- (where there are the right number of arguments.)
+      ug_res :: Int       -- Scrutinee discount: the discount to substract if the thing is in
+    }                     -- a context (case (thing args) of ...),
+                          -- (where there are the right number of arguments.)
 
-  | UnfNever       -- The RHS is big, so don't inline it
+  | UnfNever        -- The RHS is big, so don't inline it
 \end{code}
 
 Note [Historical note: unfoldings for wrappers]
@@ -801,7 +795,7 @@ an Id, so, eg, substitutions need not traverse them.
 Note [DFun unfoldings]
 ~~~~~~~~~~~~~~~~~~~~~~
 The Arity in a DFunUnfolding is total number of args (type and value)
-that the DFun needs to produce a dictionary.  That's not necessarily 
+that the DFun needs to produce a dictionary.  That's not necessarily
 related to the ordinary arity of the dfun Id, esp if the class has
 one method, so the dictionary is represented by a newtype.  Example
 
@@ -812,7 +806,7 @@ The instance translates to
 
      $dfCList :: forall a. C a => C [a]  -- Arity 2!
      $dfCList = /\a.\d. $copList {a} d |> co
+
      $copList :: forall a. C a => [a] -> Int  -- Arity 2!
      $copList = /\a.\d.\xs. op {a} d (head xs)
 
@@ -848,9 +842,9 @@ mkOtherCon :: [AltCon] -> Unfolding
 mkOtherCon = OtherCon
 
 seqUnfolding :: Unfolding -> ()
-seqUnfolding (CoreUnfolding { uf_tmpl = e, uf_is_top = top, 
-               uf_is_value = b1, uf_is_work_free = b2, 
-               uf_expandable = b3, uf_is_conlike = b4,
+seqUnfolding (CoreUnfolding { uf_tmpl = e, uf_is_top = top,
+                uf_is_value = b1, uf_is_work_free = b2,
+                uf_expandable = b3, uf_is_conlike = b4,
                 uf_guidance = g})
   = seqExpr e `seq` top `seq` b1 `seq` b2 `seq` b3 `seq` b4 `seq` seqGuidance g
 
@@ -884,7 +878,7 @@ maybeUnfoldingTemplate (DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args
 maybeUnfoldingTemplate _
   = Nothing
 
--- | The constructors that the unfolding could never be: 
+-- | The constructors that the unfolding could never be:
 -- returns @[]@ if no information is available
 otherCons :: Unfolding -> [AltCon]
 otherCons (OtherCon cons) = cons
@@ -893,7 +887,7 @@ otherCons _               = []
 -- | Determines if it is certainly the case that the unfolding will
 -- yield a value (something in HNF): returns @False@ if unsure
 isValueUnfolding :: Unfolding -> Bool
-       -- Returns False for OtherCon
+        -- Returns False for OtherCon
 isValueUnfolding (CoreUnfolding { uf_is_value = is_evald }) = is_evald
 isValueUnfolding _                                          = False
 
@@ -901,8 +895,8 @@ isValueUnfolding _                                          = False
 -- yield a value. Unlike 'isValueUnfolding' it returns @True@
 -- for 'OtherCon'
 isEvaldUnfolding :: Unfolding -> Bool
-       -- Returns True for OtherCon
-isEvaldUnfolding (OtherCon _)                              = True
+        -- Returns True for OtherCon
+isEvaldUnfolding (OtherCon _)                               = True
 isEvaldUnfolding (CoreUnfolding { uf_is_value = is_evald }) = is_evald
 isEvaldUnfolding _                                          = False
 
@@ -923,7 +917,7 @@ isExpandableUnfolding (CoreUnfolding { uf_expandable = is_expable }) = is_expabl
 isExpandableUnfolding _                                              = False
 
 expandUnfolding_maybe :: Unfolding -> Maybe CoreExpr
--- Expand an expandable unfolding; this is used in rule matching 
+-- Expand an expandable unfolding; this is used in rule matching
 --   See Note [Expanding variables] in Rules.lhs
 -- The key point here is that CONLIKE things can be expanded
 expandUnfolding_maybe (CoreUnfolding { uf_expandable = True, uf_tmpl = rhs }) = Just rhs
@@ -946,13 +940,13 @@ isCompulsoryUnfolding (CoreUnfolding { uf_src = InlineCompulsory }) = True
 isCompulsoryUnfolding _                                             = False
 
 isStableUnfolding :: Unfolding -> Bool
--- True of unfoldings that should not be overwritten 
+-- True of unfoldings that should not be overwritten
 -- by a CoreUnfolding for the RHS of a let-binding
 isStableUnfolding (CoreUnfolding { uf_src = src }) = isStableSource src
-isStableUnfolding (DFunUnfolding {})              = True
+isStableUnfolding (DFunUnfolding {})               = True
 isStableUnfolding _                                = False
 
-isClosedUnfolding :: Unfolding -> Bool         -- No free variables
+isClosedUnfolding :: Unfolding -> Bool          -- No free variables
 isClosedUnfolding (CoreUnfolding {}) = False
 isClosedUnfolding (DFunUnfolding {}) = False
 isClosedUnfolding _                  = True
@@ -968,28 +962,28 @@ neverUnfoldGuidance _        = False
 
 canUnfold :: Unfolding -> Bool
 canUnfold (CoreUnfolding { uf_guidance = g }) = not (neverUnfoldGuidance g)
-canUnfold _                                  = False
+canUnfold _                                   = False
 \end{code}
 
 Note [InlineRules]
 ~~~~~~~~~~~~~~~~~
-When you say 
+When you say
       {-# INLINE f #-}
       f x = <rhs>
 you intend that calls (f e) are replaced by <rhs>[e/x] So we
 should capture (\x.<rhs>) in the Unfolding of 'f', and never meddle
 with it.  Meanwhile, we can optimise <rhs> to our heart's content,
 leaving the original unfolding intact in Unfolding of 'f'. For example
-       all xs = foldr (&&) True xs
-       any p = all . map p  {-# INLINE any #-}
+        all xs = foldr (&&) True xs
+        any p = all . map p  {-# INLINE any #-}
 We optimise any's RHS fully, but leave the InlineRule saying "all . map p",
 which deforests well at the call site.
 
 So INLINE pragma gives rise to an InlineRule, which captures the original RHS.
 
 Moreover, it's only used when 'f' is applied to the
-specified number of arguments; that is, the number of argument on 
-the LHS of the '=' sign in the original source definition. 
+specified number of arguments; that is, the number of argument on
+the LHS of the '=' sign in the original source definition.
 For example, (.) is now defined in the libraries like this
    {-# INLINE (.) #-}
    (.) f g = \x -> f (g x)
@@ -1015,9 +1009,9 @@ the occurrence info is wrong
 
 
 %************************************************************************
-%*                                                                     *
+%*                                                                      *
                   AltCon
-%*                                                                     *
+%*                                                                      *
 %************************************************************************
 
 \begin{code}
@@ -1039,7 +1033,7 @@ ltAlt a1 a2 = (a1 `cmpAlt` a2) == LT
 
 cmpAltCon :: AltCon -> AltCon -> Ordering
 -- ^ Compares 'AltCon's within a single list of alternatives
-cmpAltCon DEFAULT      DEFAULT    = EQ
+cmpAltCon DEFAULT      DEFAULT     = EQ
 cmpAltCon DEFAULT      _           = LT
 
 cmpAltCon (DataAlt d1) (DataAlt d2) = dataConTag d1 `compare` dataConTag d2
@@ -1047,15 +1041,15 @@ cmpAltCon (DataAlt _)  DEFAULT      = GT
 cmpAltCon (LitAlt  l1) (LitAlt  l2) = l1 `compare` l2
 cmpAltCon (LitAlt _)   DEFAULT      = GT
 
-cmpAltCon con1 con2 = WARN( True, text "Comparing incomparable AltCons" <+> 
-                                 ppr con1 <+> ppr con2 )
-                     LT
+cmpAltCon con1 con2 = WARN( True, text "Comparing incomparable AltCons" <+>
+                                  ppr con1 <+> ppr con2 )
+                      LT
 \end{code}
 
 %************************************************************************
-%*                                                                     *
+%*                                                                      *
 \subsection{Useful synonyms}
-%*                                                                     *
+%*                                                                      *
 %************************************************************************
 
 Note [CoreProgram]
@@ -1076,13 +1070,13 @@ a list of CoreBind
    on each Rec binding, and splits it into a sequence of smaller
    bindings where possible.  So the program typically starts life as a
    single giant Rec, which is then dependency-analysed into smaller
-   chunks.  
+   chunks.
 
 \begin{code}
 
 -- If you edit this type, you may need to update the GHC formalism
 -- See Note [GHC Formalism] in coreSyn/CoreLint.lhs
-type CoreProgram = [CoreBind]  -- See Note [CoreProgram]
+type CoreProgram = [CoreBind]   -- See Note [CoreProgram]
 
 -- | The common case for the type of binders and variables when
 -- we are manipulating the Core language within GHC
@@ -1098,14 +1092,14 @@ type CoreAlt  = Alt  CoreBndr
 \end{code}
 
 %************************************************************************
-%*                                                                     *
+%*                                                                      *
 \subsection{Tagging}
-%*                                                                     *
+%*                                                                      *
 %************************************************************************
 
 \begin{code}
 -- | Binders are /tagged/ with a t
-data TaggedBndr t = TB CoreBndr t      -- TB for "tagged binder"
+data TaggedBndr t = TB CoreBndr t       -- TB for "tagged binder"
 
 type TaggedBind t = Bind (TaggedBndr t)
 type TaggedExpr t = Expr (TaggedBndr t)
@@ -1116,7 +1110,7 @@ instance Outputable b => Outputable (TaggedBndr b) where
   ppr (TB b l) = char '<' <> ppr b <> comma <> ppr l <> char '>'
 
 instance Outputable b => OutputableBndr (TaggedBndr b) where
-  pprBndr _ b = ppr b  -- Simple
+  pprBndr _ b = ppr b   -- Simple
   pprInfixOcc  b = ppr b
   pprPrefixOcc b = ppr b
 
@@ -1142,9 +1136,9 @@ deTagAlt (con, bndrs, rhs) = (con, [b | TB b _ <- bndrs], deTagExpr rhs)
 
 
 %************************************************************************
-%*                                                                     *
+%*                                                                      *
 \subsection{Core-constructing functions with checking}
-%*                                                                     *
+%*                                                                      *
 %************************************************************************
 
 \begin{code}
@@ -1161,14 +1155,14 @@ mkVarApps :: Expr b -> [Var] -> Expr b
 -- use 'MkCore.mkCoreConApps' if possible
 mkConApp      :: DataCon -> [Arg b] -> Expr b
 
-mkApps    f args = foldl App                      f args
+mkApps    f args = foldl App                       f args
 mkTyApps  f args = foldl (\ e a -> App e (Type a)) f args
 mkCoApps  f args = foldl (\ e a -> App e (Coercion a)) f args
 mkVarApps f vars = foldl (\ e a -> App e (varToCoreExpr a)) f vars
 mkConApp con args = mkApps (Var (dataConWorkId con)) args
 
 mkConApp2 :: DataCon -> [Type] -> [Var] -> Expr b
-mkConApp2 con tys arg_ids = Var (dataConWorkId con) 
+mkConApp2 con tys arg_ids = Var (dataConWorkId con)
                             `mkApps` map Type tys
                             `mkApps` map varToCoreExpr arg_ids
 
@@ -1232,10 +1226,10 @@ mkDoubleLitDouble d = Lit (mkMachDouble (toRational d))
 -- | Bind all supplied binding groups over an expression in a nested let expression. Assumes
 -- that the rhs satisfies the let/app invariant.  Prefer to use 'MkCore.mkCoreLets' if
 -- possible, which does guarantee the invariant
-mkLets       :: [Bind b] -> Expr b -> Expr b
+mkLets        :: [Bind b] -> Expr b -> Expr b
 -- | Bind all supplied binders over an expression in a nested lambda expression. Prefer to
 -- use 'MkCore.mkCoreLams' if possible
-mkLams       :: [b] -> Expr b -> Expr b
+mkLams        :: [b] -> Expr b -> Expr b
 
 mkLams binders body = foldr Lam body binders
 mkLets binds body   = foldr Let body binds
@@ -1263,9 +1257,9 @@ varsToCoreExprs vs = map varToCoreExpr vs
 
 
 %************************************************************************
-%*                                                                     *
+%*                                                                      *
 \subsection{Simple access functions}
-%*                                                                     *
+%*                                                                      *
 %************************************************************************
 
 \begin{code}
@@ -1292,27 +1286,27 @@ rhssOfAlts alts = [e | (_,_,e) <- alts]
 flattenBinds :: [Bind b] -> [(b, Expr b)]
 flattenBinds (NonRec b r : binds) = (b,r) : flattenBinds binds
 flattenBinds (Rec prs1   : binds) = prs1 ++ flattenBinds binds
-flattenBinds []                          = []
+flattenBinds []                   = []
 \end{code}
 
 \begin{code}
 -- | We often want to strip off leading lambdas before getting down to
 -- business. This function is your friend.
-collectBinders              :: Expr b -> ([b],         Expr b)
+collectBinders               :: Expr b -> ([b],         Expr b)
 -- | Collect as many type bindings as possible from the front of a nested lambda
-collectTyBinders                    :: CoreExpr -> ([TyVar],     CoreExpr)
+collectTyBinders             :: CoreExpr -> ([TyVar],     CoreExpr)
 -- | Collect as many value bindings as possible from the front of a nested lambda
-collectValBinders                   :: CoreExpr -> ([Id],        CoreExpr)
--- | Collect type binders from the front of the lambda first, 
+collectValBinders            :: CoreExpr -> ([Id],        CoreExpr)
+-- | Collect type binders from the front of the lambda first,
 -- then follow up by collecting as many value bindings as possible
 -- from the resulting stripped expression
-collectTyAndValBinders              :: CoreExpr -> ([TyVar], [Id], CoreExpr)
+collectTyAndValBinders       :: CoreExpr -> ([TyVar], [Id], CoreExpr)
 
 collectBinders expr
   = go [] expr
   where
     go bs (Lam b e) = go (b:bs) e
-    go bs e         = (reverse bs, e)
+    go bs e          = (reverse bs, e)
 
 collectTyAndValBinders expr
   = (tvs, ids, body)
@@ -1324,13 +1318,13 @@ collectTyBinders expr
   = go [] expr
   where
     go tvs (Lam b e) | isTyVar b = go (b:tvs) e
-    go tvs e                    = (reverse tvs, e)
+    go tvs e                     = (reverse tvs, e)
 
 collectValBinders expr
   = go [] expr
   where
     go ids (Lam b e) | isId b = go (b:ids) e
-    go ids body                      = (reverse ids, body)
+    go ids body               = (reverse ids, body)
 \end{code}
 
 \begin{code}
@@ -1341,24 +1335,24 @@ collectArgs expr
   = go expr []
   where
     go (App f a) as = go f (a:as)
-    go e        as = (e, as)
+    go e         as = (e, as)
 \end{code}
 
 %************************************************************************
-%*                                                                     *
+%*                                                                      *
 \subsection{Predicates}
-%*                                                                     *
+%*                                                                      *
 %************************************************************************
 
 At one time we optionally carried type arguments through to runtime.
 @isRuntimeVar v@ returns if (Lam v _) really becomes a lambda at runtime,
 i.e. if type applications are actual lambdas because types are kept around
-at runtime.  Similarly isRuntimeArg.  
+at runtime.  Similarly isRuntimeArg.
 
 \begin{code}
 -- | Will this variable exist at runtime?
 isRuntimeVar :: Var -> Bool
-isRuntimeVar = isId 
+isRuntimeVar = isId
 
 -- | Will this argument expression exist at runtime?
 isRuntimeArg :: CoreExpr -> Bool
@@ -1394,9 +1388,9 @@ valArgCount = count isValArg
 
 
 %************************************************************************
-%*                                                                     *
+%*                                                                      *
 \subsection{Seq stuff}
-%*                                                                     *
+%*                                                                      *
 %************************************************************************
 
 \begin{code}
@@ -1442,15 +1436,15 @@ seqAlts ((c,bs,e):alts) = c `seq` seqBndrs bs `seq` seqExpr e `seq` seqAlts alts
 
 seqRules :: [CoreRule] -> ()
 seqRules [] = ()
-seqRules (Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs } : rules) 
+seqRules (Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs } : rules)
   = seqBndrs bndrs `seq` seqExprs (rhs:args) `seq` seqRules rules
 seqRules (BuiltinRule {} : rules) = seqRules rules
 \end{code}
 
 %************************************************************************
-%*                                                                     *
+%*                                                                      *
 \subsection{Annotated core}
-%*                                                                     *
+%*                                                                      *
 %************************************************************************
 
 \begin{code}
@@ -1459,16 +1453,16 @@ type AnnExpr bndr annot = (annot, AnnExpr' bndr annot)
 
 -- | A clone of the 'Expr' type but allowing annotation at every tree node
 data AnnExpr' bndr annot
-  = AnnVar     Id
-  | AnnLit     Literal
-  | AnnLam     bndr (AnnExpr bndr annot)
-  | AnnApp     (AnnExpr bndr annot) (AnnExpr bndr annot)
-  | AnnCase    (AnnExpr bndr annot) bndr Type [AnnAlt bndr annot]
-  | AnnLet     (AnnBind bndr annot) (AnnExpr bndr annot)
+  = AnnVar      Id
+  | AnnLit      Literal
+  | AnnLam      bndr (AnnExpr bndr annot)
+  | AnnApp      (AnnExpr bndr annot) (AnnExpr bndr annot)
+  | AnnCase     (AnnExpr bndr annot) bndr Type [AnnAlt bndr annot]
+  | AnnLet      (AnnBind bndr annot) (AnnExpr bndr annot)
   | AnnCast     (AnnExpr bndr annot) (annot, Coercion)
-                  -- Put an annotation on the (root of) the coercion
+                   -- Put an annotation on the (root of) the coercion
   | AnnTick     (Tickish Id) (AnnExpr bndr annot)
-  | AnnType    Type
+  | AnnType     Type
   | AnnCoercion Coercion
 
 -- | A clone of the 'Alt' type but allowing annotation at every tree node
@@ -1488,7 +1482,7 @@ collectAnnArgs expr
   = go expr []
   where
     go (_, AnnApp f a) as = go f (a:as)
-    go e              as = (e, as)
+    go e               as = (e, as)
 \end{code}
 
 \begin{code}
@@ -1525,5 +1519,5 @@ collectAnnBndrs e
   = collect [] e
   where
     collect bs (_, AnnLam b body) = collect (b:bs) body
-    collect bs body              = (reverse bs, body)
+    collect bs body               = (reverse bs, body)
 \end{code}
index 3c9a1c8..fd485ae 100644 (file)
@@ -16,29 +16,23 @@ find, unsurprisingly, a Core expression.
 
 \begin{code}
 {-# LANGUAGE CPP #-}
-{-# OPTIONS_GHC -fno-warn-tabs #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and
--- detab the module (please do the detabbing in a separate patch). See
---     http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
 
 module CoreUnfold (
-       Unfolding, UnfoldingGuidance,   -- Abstract types
+        Unfolding, UnfoldingGuidance,   -- Abstract types
 
-       noUnfolding, mkImplicitUnfolding,
+        noUnfolding, mkImplicitUnfolding,
         mkUnfolding, mkCoreUnfolding,
-       mkTopUnfolding, mkSimpleUnfolding, mkWorkerUnfolding,
-       mkInlineUnfolding, mkInlinableUnfolding, mkWwInlineRule,
-       mkCompulsoryUnfolding, mkDFunUnfolding,
+        mkTopUnfolding, mkSimpleUnfolding, mkWorkerUnfolding,
+        mkInlineUnfolding, mkInlinableUnfolding, mkWwInlineRule,
+        mkCompulsoryUnfolding, mkDFunUnfolding,
         specUnfolding,
 
-       interestingArg, ArgSummary(..),
+        interestingArg, ArgSummary(..),
 
-       couldBeSmallEnoughToInline, inlineBoringOk,
-       certainlyWillInline, smallEnoughToInline,
+        couldBeSmallEnoughToInline, inlineBoringOk,
+        certainlyWillInline, smallEnoughToInline,
 
-       callSiteInline, CallCtxt(..),
+        callSiteInline, CallCtxt(..),
 
         -- Reexport from CoreSubst (it only live there so it can be used
         -- by the Very Simple Optimiser)
@@ -49,7 +43,7 @@ module CoreUnfold (
 
 import DynFlags
 import CoreSyn
-import PprCore         ()      -- Instances
+import PprCore          ()      -- Instances
 import OccurAnal        ( occurAnalyseExpr )
 import CoreSubst hiding( substTy )
 import CoreArity       ( manifestArity, exprBotStrictness_maybe )
@@ -59,7 +53,7 @@ import DataCon
 import Literal
 import PrimOp
 import IdInfo
-import BasicTypes      ( Arity )
+import BasicTypes       ( Arity )
 import Type
 import PrelNames
 import TysPrim          ( realWorldStatePrimTy )
@@ -76,9 +70,9 @@ import Data.Maybe
 
 
 %************************************************************************
-%*                                                                     *
+%*                                                                      *
 \subsection{Making unfoldings}
-%*                                                                     *
+%*                                                                      *
 %************************************************************************
 
 \begin{code}
@@ -114,7 +108,7 @@ mkWwInlineRule expr arity
                             , ug_boring_ok = boringCxtNotOk })
 
 mkCompulsoryUnfolding :: CoreExpr -> Unfolding
-mkCompulsoryUnfolding expr        -- Used for things that absolutely must be unfolded
+mkCompulsoryUnfolding expr         -- Used for things that absolutely must be unfolded
   = mkCoreUnfolding InlineCompulsory True
                     (simpleOptExpr expr)
                     (UnfWhen { ug_arity = 0    -- Arity of unfolding doesn't matter
@@ -136,7 +130,7 @@ mkWorkerUnfolding _ _ _ = noUnfolding
 mkInlineUnfolding :: Maybe Arity -> CoreExpr -> Unfolding
 mkInlineUnfolding mb_arity expr
   = mkCoreUnfolding InlineStable
-                   True         -- Note [Top-level flag on inline rules]
+                    True         -- Note [Top-level flag on inline rules]
                     expr' guide
   where
     expr' = simpleOptExpr expr
@@ -227,15 +221,15 @@ mkCoreUnfolding :: UnfoldingSource -> Bool -> CoreExpr
                 -> UnfoldingGuidance -> Unfolding
 -- Occurrence-analyses the expression before capturing it
 mkCoreUnfolding src top_lvl expr guidance
-  = CoreUnfolding { uf_tmpl        = occurAnalyseExpr expr,
+  = CoreUnfolding { uf_tmpl         = occurAnalyseExpr expr,
                       -- See Note [Occurrrence analysis of unfoldings]
-                   uf_src          = src,
-                   uf_is_top       = top_lvl,
-                   uf_is_value     = exprIsHNF        expr,
+                    uf_src          = src,
+                    uf_is_top       = top_lvl,
+                    uf_is_value     = exprIsHNF        expr,
                     uf_is_conlike   = exprIsConLike    expr,
-                   uf_is_work_free = exprIsWorkFree   expr,
-                   uf_expandable   = exprIsExpandable expr,
-                   uf_guidance     = guidance }
+                    uf_is_work_free = exprIsWorkFree   expr,
+                    uf_expandable   = exprIsExpandable expr,
+                    uf_guidance     = guidance }
 
 mkUnfolding :: DynFlags -> UnfoldingSource -> Bool -> Bool -> CoreExpr
             -> Unfolding
@@ -246,19 +240,19 @@ mkUnfolding dflags src top_lvl is_bottoming expr
   , not (exprIsTrivial expr)
   = NoUnfolding    -- See Note [Do not inline top-level bottoming functions]
   | otherwise
-  = CoreUnfolding { uf_tmpl        = occurAnalyseExpr expr,
+  = CoreUnfolding { uf_tmpl         = occurAnalyseExpr expr,
                       -- See Note [Occurrrence analysis of unfoldings]
-                   uf_src          = src,
-                   uf_is_top       = top_lvl,
-                   uf_is_value     = exprIsHNF        expr,
+                    uf_src          = src,
+                    uf_is_top       = top_lvl,
+                    uf_is_value     = exprIsHNF        expr,
                     uf_is_conlike   = exprIsConLike    expr,
-                   uf_expandable   = exprIsExpandable expr,
-                   uf_is_work_free = exprIsWorkFree   expr,
-                   uf_guidance     = guidance }
+                    uf_expandable   = exprIsExpandable expr,
+                    uf_is_work_free = exprIsWorkFree   expr,
+                    uf_guidance     = guidance }
   where
     guidance = calcUnfoldingGuidance dflags expr
         -- NB: *not* (calcUnfoldingGuidance (occurAnalyseExpr expr))!
-       -- See Note [Calculate unfolding guidance on the non-occ-anal'd expression]
+        -- See Note [Calculate unfolding guidance on the non-occ-anal'd expression]
 \end{code}
 
 Note [Occurrence analysis of unfoldings]
@@ -289,13 +283,13 @@ let-bound thing which has been substituted, and so is now dead; so
 expression doesn't.
 
 Nevertheless, we *don't* and *must not* occ-analyse before computing
-the size because 
+the size because
 
 a) The size computation bales out after a while, whereas occurrence
    analysis does not.
 
-b) Residency increases sharply if you occ-anal first.  I'm not 
-   100% sure why, but it's a large effect.  Compiling Cabal went 
+b) Residency increases sharply if you occ-anal first.  I'm not
+   100% sure why, but it's a large effect.  Compiling Cabal went
    from residency of 534M to over 800M with this one change.
 
 This can occasionally mean that the guidance is very pessimistic;
@@ -304,15 +298,15 @@ let-bound things that are dead are usually caught by preInlineUnconditionally
 
 
 %************************************************************************
-%*                                                                     *
+%*                                                                      *
 \subsection{The UnfoldingGuidance type}
-%*                                                                     *
+%*                                                                      *
 %************************************************************************
 
 \begin{code}
 inlineBoringOk :: CoreExpr -> Bool
 -- See Note [INLINE for small functions]
--- True => the result of inlining the expression is 
+-- True => the result of inlining the expression is
 --         no bigger than the expression itself
 --     eg      (\x y -> f y x)
 -- This is a quick and dirty version. It doesn't attempt
@@ -325,12 +319,12 @@ inlineBoringOk e
     go credit (Lam x e) | isId x           = go (credit+1) e
                         | otherwise        = go credit e
     go credit (App f (Type {}))            = go credit f
-    go credit (App f a) | credit > 0  
+    go credit (App f a) | credit > 0
                         , exprIsTrivial a  = go (credit-1) f
     go credit (Tick _ e)                 = go credit e -- dubious
-    go credit (Cast e _)                  = go credit e
-    go _      (Var {})                            = boringCxtOk
-    go _      _                                   = boringCxtNotOk
+    go credit (Cast e _)                   = go credit e
+    go _      (Var {})                     = boringCxtOk
+    go _      _                            = boringCxtNotOk
 
 calcUnfoldingGuidance
         :: DynFlags
@@ -347,7 +341,7 @@ calcUnfoldingGuidance dflags expr
         | otherwise
         -> UnfIfGoodArgs { ug_args  = map (mk_discount cased_bndrs) val_bndrs
                          , ug_size  = iBox size
-                        , ug_res   = iBox scrut_discount }
+                         , ug_res   = iBox scrut_discount }
 
   where
     (bndrs, body) = collectBinders expr
@@ -387,17 +381,17 @@ heuristics right has taken a long time.  Here's the basic strategy:
 
 Examples
 
-  Size Term
+  Size  Term
   --------------
-    0    42#
-    0    x
+    0     42#
+    0     x
     0     True
-    2    f x
-    1    Just x
-    4    f (g x)
+    2     f x
+    1     Just x
+    4     f (g x)
 
 Notice that 'x' counts 0, while (f x) counts 2.  That's deliberate: there's
-a function call to account for.  Notice also that constructor applications 
+a function call to account for.  Notice also that constructor applications
 are very cheap, because exposing them to a caller is so valuable.
 
 [25/5/11] All sizes are now multiplied by 10, except for primops
@@ -407,14 +401,14 @@ result of #4978.
 
 Note [Do not inline top-level bottoming functions]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The FloatOut pass has gone to some trouble to float out calls to 'error' 
+The FloatOut pass has gone to some trouble to float out calls to 'error'
 and similar friends.  See Note [Bottoming floats] in SetLevels.
 Do not re-inline them!  But we *do* still inline if they are very small
 (the uncondInline stuff).
 
 Note [INLINE for small functions]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider       {-# INLINE f #-}
+Consider        {-# INLINE f #-}
                 f x = Just x
                 g y = f y
 Then f's RHS is no larger than its LHS, so we should inline it into
@@ -426,11 +420,11 @@ Things to note:
 
 (1) We inline *unconditionally* if inlined thing is smaller (using sizeExpr)
     than the thing it's replacing.  Notice that
-      (f x) --> (g 3)            -- YES, unconditionally
-      (f x) --> x : []           -- YES, *even though* there are two
-                                 --      arguments to the cons
-      x     --> g 3              -- NO
-      x            --> Just v            -- NO
+      (f x) --> (g 3)             -- YES, unconditionally
+      (f x) --> x : []            -- YES, *even though* there are two
+                                  --      arguments to the cons
+      x     --> g 3               -- NO
+      x     --> Just v            -- NO
 
     It's very important not to unconditionally replace a variable by
     a non-atomic term.
@@ -469,7 +463,7 @@ uncondInline :: CoreExpr -> Arity -> Int -> Bool
 -- Inline unconditionally if there no size increase
 -- Size of call is arity (+1 for the function)
 -- See Note [INLINE for small functions]
-uncondInline rhs arity size 
+uncondInline rhs arity size
   | arity > 0 = size <= 10 * (arity + 1) -- See Note [INLINE for small functions] (1)
   | otherwise = exprIsTrivial rhs        -- See Note [INLINE for small functions] (4)
 \end{code}
@@ -477,11 +471,11 @@ uncondInline rhs arity size
 
 \begin{code}
 sizeExpr :: DynFlags
-         -> FastInt        -- Bomb out if it gets bigger than this
-        -> [Id]            -- Arguments; we're interested in which of these
-                           -- get case'd
-        -> CoreExpr
-        -> ExprSize
+         -> FastInt         -- Bomb out if it gets bigger than this
+         -> [Id]            -- Arguments; we're interested in which of these
+                            -- get case'd
+         -> CoreExpr
+         -> ExprSize
 
 -- Note [Computing the size of an expression]
 
@@ -508,40 +502,40 @@ sizeExpr dflags bOMB_OUT_SIZE top_args expr
       | otherwise = size_up e
 
     size_up (Let (NonRec binder rhs) body)
-      = size_up rhs            `addSizeNSD`
-       size_up body            `addSizeN`
+      = size_up rhs             `addSizeNSD`
+        size_up body            `addSizeN`
         (if isUnLiftedType (idType binder) then 0 else 10)
-               -- For the allocation
-               -- If the binder has an unlifted type there is no allocation
+                -- For the allocation
+                -- If the binder has an unlifted type there is no allocation
 
     size_up (Let (Rec pairs) body)
-      = foldr (addSizeNSD . size_up . snd) 
+      = foldr (addSizeNSD . size_up . snd)
               (size_up body `addSizeN` (10 * length pairs))     -- (length pairs) for the allocation
               pairs
 
-    size_up (Case (Var v) _ _ alts) 
-       | v `elem` top_args             -- We are scrutinising an argument variable
-       = alts_size (foldr addAltSize sizeZero alt_sizes)
-                   (foldr maxSize    sizeZero alt_sizes)
-               -- Good to inline if an arg is scrutinised, because
-               -- that may eliminate allocation in the caller
-               -- And it eliminates the case itself
-       where
-         alt_sizes = map size_up_alt alts
-
-               -- alts_size tries to compute a good discount for
-               -- the case when we are scrutinising an argument variable
-         alts_size (SizeIs tot tot_disc tot_scrut)  -- Size of all alternatives
-                   (SizeIs max _        _)          -- Size of biggest alternative
+    size_up (Case (Var v) _ _ alts)
+        | v `elem` top_args             -- We are scrutinising an argument variable
+        = alts_size (foldr addAltSize sizeZero alt_sizes)
+                    (foldr maxSize    sizeZero alt_sizes)
+                -- Good to inline if an arg is scrutinised, because
+                -- that may eliminate allocation in the caller
+                -- And it eliminates the case itself
+        where
+          alt_sizes = map size_up_alt alts
+
+                -- alts_size tries to compute a good discount for
+                -- the case when we are scrutinising an argument variable
+          alts_size (SizeIs tot tot_disc tot_scrut)  -- Size of all alternatives
+                    (SizeIs max _        _)          -- Size of biggest alternative
                 = SizeIs tot (unitBag (v, iBox (_ILIT(20) +# tot -# max)) `unionBags` tot_disc) tot_scrut
-                       -- If the variable is known, we produce a discount that
-                       -- will take us back to 'max', the size of the largest alternative
-                       -- The 1+ is a little discount for reduced allocation in the caller
-                       --
-                       -- Notice though, that we return tot_disc, the total discount from 
-                       -- all branches.  I think that's right.
+                        -- If the variable is known, we produce a discount that
+                        -- will take us back to 'max', the size of the largest alternative
+                        -- The 1+ is a little discount for reduced allocation in the caller
+                        --
+                        -- Notice though, that we return tot_disc, the total discount from
+                        -- all branches.  I think that's right.
 
-         alts_size tot_size _ = tot_size
+          alts_size tot_size _ = tot_size
 
     size_up (Case e _ _ alts) = size_up e  `addSizeNSD`
                                 foldr (addAltSize . size_up_alt) case_size alts
@@ -579,56 +573,56 @@ sizeExpr dflags bOMB_OUT_SIZE top_args expr
               | otherwise
                 = False
 
-    ------------ 
+    ------------
     -- size_up_app is used when there's ONE OR MORE value args
     size_up_app (App fun arg) args voids
-       | isTyCoArg arg                  = size_up_app fun args voids
-       | isRealWorldExpr arg            = size_up_app fun (arg:args) (voids + 1)
-       | otherwise                      = size_up arg  `addSizeNSD`
+        | isTyCoArg arg                  = size_up_app fun args voids
+        | isRealWorldExpr arg            = size_up_app fun (arg:args) (voids + 1)
+        | otherwise                      = size_up arg  `addSizeNSD`
                                            size_up_app fun (arg:args) voids
     size_up_app (Var fun)     args voids = size_up_call fun args voids
     size_up_app other         args voids = size_up other `addSizeN` (length args - voids)
 
-    ------------ 
+    ------------
     size_up_call :: Id -> [CoreExpr] -> Int -> ExprSize
     size_up_call fun val_args voids
        = case idDetails fun of
            FCallId _        -> sizeN (10 * (1 + length val_args))
            DataConWorkId dc -> conSize    dc (length val_args)
            PrimOpId op      -> primOpSize op (length val_args)
-          ClassOpId _      -> classOpSize dflags top_args val_args
-          _                -> funSize dflags top_args fun (length val_args) voids
+           ClassOpId _      -> classOpSize dflags top_args val_args
+           _                -> funSize dflags top_args fun (length val_args) voids
 
-    ------------ 
+    ------------
     size_up_alt (_con, _bndrs, rhs) = size_up rhs `addSizeN` 10
-       -- Don't charge for args, so that wrappers look cheap
-       -- (See comments about wrappers with Case)
-       --
-       -- IMPORATANT: *do* charge 1 for the alternative, else we 
-       -- find that giant case nests are treated as practically free
-       -- A good example is Foreign.C.Error.errrnoToIOError
+        -- Don't charge for args, so that wrappers look cheap
+        -- (See comments about wrappers with Case)
+        --
+        -- IMPORATANT: *do* charge 1 for the alternative, else we
+        -- find that giant case nests are treated as practically free
+        -- A good example is Foreign.C.Error.errrnoToIOError
 
     ------------
-       -- These addSize things have to be here because
-       -- I don't want to give them bOMB_OUT_SIZE as an argument
+        -- These addSize things have to be here because
+        -- I don't want to give them bOMB_OUT_SIZE as an argument
     addSizeN TooBig          _  = TooBig
-    addSizeN (SizeIs n xs d) m         = mkSizeIs bOMB_OUT_SIZE (n +# iUnbox m) xs d
-    
+    addSizeN (SizeIs n xs d) m  = mkSizeIs bOMB_OUT_SIZE (n +# iUnbox m) xs d
+
         -- addAltSize is used to add the sizes of case alternatives
-    addAltSize TooBig           _      = TooBig
-    addAltSize _                TooBig = TooBig
-    addAltSize (SizeIs n1 xs d1) (SizeIs n2 ys d2) 
-       = mkSizeIs bOMB_OUT_SIZE (n1 +# n2) 
-                                 (xs `unionBags` ys) 
+    addAltSize TooBig            _      = TooBig
+    addAltSize _                 TooBig = TooBig
+    addAltSize (SizeIs n1 xs d1) (SizeIs n2 ys d2)
+        = mkSizeIs bOMB_OUT_SIZE (n1 +# n2)
+                                 (xs `unionBags` ys)
                                  (d1 +# d2)   -- Note [addAltSize result discounts]
 
         -- This variant ignores the result discount from its LEFT argument
-       -- It's used when the second argument isn't part of the result
-    addSizeNSD TooBig           _      = TooBig
-    addSizeNSD _                TooBig = TooBig
-    addSizeNSD (SizeIs n1 xs _) (SizeIs n2 ys d2) 
-       = mkSizeIs bOMB_OUT_SIZE (n1 +# n2) 
-                                 (xs `unionBags` ys) 
+        -- It's used when the second argument isn't part of the result
+    addSizeNSD TooBig            _      = TooBig
+    addSizeNSD _                 TooBig = TooBig
+    addSizeNSD (SizeIs n1 xs _) (SizeIs n2 ys d2)
+        = mkSizeIs bOMB_OUT_SIZE (n1 +# n2)
+                                 (xs `unionBags` ys)
                                  d2  -- Ignore d1
 
     isRealWorldId id = idType id `eqType` realWorldStatePrimTy
@@ -643,14 +637,14 @@ sizeExpr dflags bOMB_OUT_SIZE top_args expr
 -- | Finds a nominal size of a string literal.
 litSize :: Literal -> Int
 -- Used by CoreUnfold.sizeExpr
-litSize (LitInteger {}) = 100  -- Note [Size of literal integers]
+litSize (LitInteger {}) = 100   -- Note [Size of literal integers]
 litSize (MachStr str)   = 10 + 10 * ((BS.length str + 3) `div` 4)
-       -- If size could be 0 then @f "x"@ might be too small
-       -- [Sept03: make literal strings a bit bigger to avoid fruitless 
-       --  duplication of little strings]
+        -- If size could be 0 then @f "x"@ might be too small
+        -- [Sept03: make literal strings a bit bigger to avoid fruitless
+        --  duplication of little strings]
 litSize _other = 0    -- Must match size of nullary constructors
-                     -- Key point: if  x |-> 4, then x must inline unconditionally
-                     --            (eg via case binding)
+                      -- Key point: if  x |-> 4, then x must inline unconditionally
+                      --            (eg via case binding)
 
 classOpSize :: DynFlags -> [Id] -> [CoreExpr] -> ExprSize
 -- See Note [Conlike is interesting]
@@ -664,10 +658,10 @@ classOpSize dflags top_args (arg1 : other_args)
     -- give it a discount, to encourage the inlining of this function
     -- The actual discount is rather arbitrarily chosen
     arg_discount = case arg1 of
-                    Var dict | dict `elem` top_args 
-                             -> unitBag (dict, ufDictDiscount dflags)
-                    _other   -> emptyBag
-                    
+                     Var dict | dict `elem` top_args
+                              -> unitBag (dict, ufDictDiscount dflags)
+                     _other   -> emptyBag
+
 funSize :: DynFlags -> [Id] -> Id -> Int -> Int -> ExprSize
 -- Size for functions that are not constructors or primops
 -- Note [Function applications]
@@ -680,20 +674,20 @@ funSize dflags top_args fun n_val_args voids
 
     size | some_val_args = 10 * (1 + n_val_args - voids)
          | otherwise     = 0
-       -- The 1+ is for the function itself
-       -- Add 1 for each non-trivial arg;
-       -- the allocation cost, as in let(rec)
-  
+        -- The 1+ is for the function itself
+        -- Add 1 for each non-trivial arg;
+        -- the allocation cost, as in let(rec)
+
         --                  DISCOUNTS
         --  See Note [Function and non-function discounts]
     arg_discount | some_val_args && fun `elem` top_args
-                = unitBag (fun, ufFunAppDiscount dflags)
-                | otherwise = emptyBag
-       -- If the function is an argument and is applied
-       -- to some values, give it an arg-discount
+                 = unitBag (fun, ufFunAppDiscount dflags)
+                 | otherwise = emptyBag
+        -- If the function is an argument and is applied
+        -- to some values, give it an arg-discount
 
     res_discount | idArity fun > n_val_args = ufFunAppDiscount dflags
-                | otherwise                = 0
+                 | otherwise                = 0
         -- If the function is partially applied, show a result discount
 
 conSize :: DataCon -> Int -> ExprSize
@@ -722,7 +716,7 @@ charge it to the function.  So the discount should at least match the
 cost of the constructor application, namely 10.  But to give a bit
 of extra incentive we give a discount of 10*(1 + n_val_args).
 
-Simon M tried a MUCH bigger discount: (10 * (10 + n_val_args)), 
+Simon M tried a MUCH bigger discount: (10 * (10 + n_val_args)),
 and said it was an "unambiguous win", but its terribly dangerous
 because a fuction with many many case branches, each finishing with
 a constructor, can have an arbitrarily large discount.  This led to
@@ -730,8 +724,8 @@ terrible code bloat: see Trac #6099.
 
 Note [Unboxed tuple size and result discount]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-However, unboxed tuples count as size zero. I found occasions where we had 
-       f x y z = case op# x y z of { s -> (# s, () #) }
+However, unboxed tuples count as size zero. I found occasions where we had
+        f x y z = case op# x y z of { s -> (# s, () #) }
 and f wasn't getting inlined.
 
 I tried giving unboxed tuples a *result discount* of zero (see the
@@ -752,7 +746,7 @@ monadic combinators with continuation arguments, where inlining is
 quite important.
 
 But we don't want a big discount when a function is called many times
-(see the detailed comments with Trac #6048) because if the function is 
+(see the detailed comments with Trac #6048) because if the function is
 big it won't be inlined at its many call sites and no benefit results.
 Indeed, we can get exponentially big inlinings this way; that is what
 Trac #6048 is about.
@@ -790,17 +784,17 @@ primOpSize op n_val_args
 
 buildSize :: ExprSize
 buildSize = SizeIs (_ILIT(0)) emptyBag (_ILIT(40))
-       -- We really want to inline applications of build
-       -- build t (\cn -> e) should cost only the cost of e (because build will be inlined later)
-       -- Indeed, we should add a result_discount becuause build is 
-       -- very like a constructor.  We don't bother to check that the
-       -- build is saturated (it usually is).  The "-2" discounts for the \c n, 
-       -- The "4" is rather arbitrary.
+        -- We really want to inline applications of build
+        -- build t (\cn -> e) should cost only the cost of e (because build will be inlined later)
+        -- Indeed, we should add a result_discount becuause build is
+        -- very like a constructor.  We don't bother to check that the
+        -- build is saturated (it usually is).  The "-2" discounts for the \c n,
+        -- The "4" is rather arbitrary.
 
 augmentSize :: ExprSize
 augmentSize = SizeIs (_ILIT(0)) emptyBag (_ILIT(40))
-       -- Ditto (augment t (\cn -> e) ys) should cost only the cost of
-       -- e plus ys. The -2 accounts for the \cn 
+        -- Ditto (augment t (\cn -> e) ys) should cost only the cost of
+        -- e plus ys. The -2 accounts for the \cn
 
 -- When we return a lambda, give a discount if it's used (applied)
 lamScrutDiscount :: DynFlags -> ExprSize -> ExprSize
@@ -813,7 +807,7 @@ Note [addAltSize result discounts]
 When adding the size of alternatives, we *add* the result discounts
 too, rather than take the *maximum*.  For a multi-branch case, this
 gives a discount for each branch that returns a constructor, making us
-keener to inline.  I did try using 'max' instead, but it makes nofib 
+keener to inline.  I did try using 'max' instead, but it makes nofib
 'rewrite' and 'puzzle' allocate significantly more, and didn't make
 binary sizes shrink significantly either.
 
@@ -831,7 +825,7 @@ ufUseThreshold
      this, then it's small enough inline
 
 ufKeenessFactor
-     Factor by which the discounts are multiplied before 
+     Factor by which the discounts are multiplied before
      subtracting from size
 
 ufDictDiscount
@@ -851,22 +845,22 @@ Note [Function applications]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 In a function application (f a b)
 
-  - If 'f' is an argument to the function being analysed, 
+  - If 'f' is an argument to the function being analysed,
     and there's at least one value arg, record a FunAppDiscount for f
 
   - If the application if a PAP (arity > 2 in this example)
     record a *result* discount (because inlining
-    with "extra" args in the call may mean that we now 
+    with "extra" args in the call may mean that we now
     get a saturated application)
 
 Code for manipulating sizes
 
 \begin{code}
 data ExprSize = TooBig
-             | SizeIs FastInt          -- Size found
-                      !(Bag (Id,Int))  -- Arguments cased herein, and discount for each such
-                      FastInt          -- Size to subtract if result is scrutinised 
-                                       -- by a case expression
+              | SizeIs FastInt          -- Size found
+                       !(Bag (Id,Int))  -- Arguments cased herein, and discount for each such
+                       FastInt          -- Size to subtract if result is scrutinised
+                                        -- by a case expression
 
 instance Outputable ExprSize where
   ppr TooBig         = ptext (sLit "TooBig")
@@ -874,18 +868,18 @@ instance Outputable ExprSize where
 
 -- subtract the discount before deciding whether to bale out. eg. we
 -- want to inline a large constructor application into a selector:
---     tup = (a_1, ..., a_99)
---     x = case tup of ...
+--      tup = (a_1, ..., a_99)
+--      x = case tup of ...
 --
 mkSizeIs :: FastInt -> FastInt -> Bag (Id, Int) -> FastInt -> ExprSize
 mkSizeIs max n xs d | (n -# d) ># max = TooBig
-                   | otherwise       = SizeIs n xs d
+                    | otherwise       = SizeIs n xs d
+
 maxSize :: ExprSize -> ExprSize -> ExprSize
-maxSize TooBig         _                                 = TooBig
-maxSize _              TooBig                            = TooBig
+maxSize TooBig         _                                  = TooBig
+maxSize _              TooBig                             = TooBig
 maxSize s1@(SizeIs n1 _ _) s2@(SizeIs n2 _ _) | n1 ># n2  = s1
-                                             | otherwise = s2
+                                              | otherwise = s2
 
 sizeZero :: ExprSize
 sizeN :: Int -> ExprSize
@@ -896,9 +890,9 @@ sizeN n  = SizeIs (iUnbox n) emptyBag (_ILIT(0))
 
 
 %************************************************************************
-%*                                                                     *
+%*                                                                      *
 \subsection[considerUnfolding]{Given all the info, do (not) do the unfolding}
-%*                                                                     *
+%*                                                                      *
 %************************************************************************
 
 We use 'couldBeSmallEnoughToInline' to avoid exporting inlinings that
@@ -908,7 +902,7 @@ actual arguments.
 
 \begin{code}
 couldBeSmallEnoughToInline :: DynFlags -> Int -> CoreExpr -> Bool
-couldBeSmallEnoughToInline dflags threshold rhs 
+couldBeSmallEnoughToInline dflags threshold rhs
   = case sizeExpr dflags (iUnbox threshold) [] body of
        TooBig -> False
        _      -> True
@@ -962,13 +956,13 @@ duplication.  Even if the work duplication is not great (eg is_cheap
 holds), it can make a big difference in an inner loop In Trac #5623 we
 found that the WorkWrap phase thought that
        y = case x of F# v -> F# (v +# v)
-was certainlyWillInline, so the addition got duplicated.  
+was certainlyWillInline, so the addition got duplicated.
 
 
 %************************************************************************
-%*                                                                     *
+%*                                                                      *
 \subsection{callSiteInline}
-%*                                                                     *
+%*                                                                      *
 %************************************************************************
 
 This is the key function.  It decides whether to inline a variable at a call site
@@ -976,25 +970,25 @@ This is the key function.  It decides whether to inline a variable at a call sit
 callSiteInline is used at call sites, so it is a bit more generous.
 It's a very important function that embodies lots of heuristics.
 A non-WHNF can be inlined if it doesn't occur inside a lambda,
-and occurs exactly once or 
+and occurs exactly once or
     occurs once in each branch of a case and is small
 
-If the thing is in WHNF, there's no danger of duplicating work, 
+If the thing is in WHNF, there's no danger of duplicating work,
 so we can inline if it occurs once, or is small
 
 NOTE: we don't want to inline top-level functions that always diverge.
 It just makes the code bigger.  Tt turns out that the convenient way to prevent
-them inlining is to give them a NOINLINE pragma, which we do in 
+them inlining is to give them a NOINLINE pragma, which we do in
 StrictAnal.addStrictnessInfoToTopId
 
 \begin{code}
 callSiteInline :: DynFlags
-              -> Id                    -- The Id
-              -> Bool                  -- True <=> unfolding is active
-              -> Bool                  -- True if there are are no arguments at all (incl type args)
-              -> [ArgSummary]          -- One for each value arg; True if it is interesting
-              -> CallCtxt              -- True <=> continuation is interesting
-              -> Maybe CoreExpr        -- Unfolding, if any
+               -> Id                    -- The Id
+               -> Bool                  -- True <=> unfolding is active
+               -> Bool                  -- True if there are are no arguments at all (incl type args)
+               -> [ArgSummary]          -- One for each value arg; True if it is interesting
+               -> CallCtxt              -- True <=> continuation is interesting
+               -> Maybe CoreExpr        -- Unfolding, if any
 
 instance Outputable ArgSummary where
   ppr TrivArg    = ptext (sLit "TrivArg")
@@ -1005,17 +999,17 @@ data CallCtxt
   = BoringCtxt
   | RhsCtxt             -- Rhs of a let-binding; see Note [RHS of lets]
   | DiscArgCtxt         -- Argument of a fuction with non-zero arg discount
-  | RuleArgCtxt                -- We are somewhere in the argument of a function with rules
+  | RuleArgCtxt         -- We are somewhere in the argument of a function with rules
 
-  | ValAppCtxt                 -- We're applied to at least one value arg
-                       -- This arises when we have ((f x |> co) y)
-                       -- Then the (f x) has argument 'x' but in a ValAppCtxt
+  | ValAppCtxt          -- We're applied to at least one value arg
+                        -- This arises when we have ((f x |> co) y)
+                        -- Then the (f x) has argument 'x' but in a ValAppCtxt
 
-  | CaseCtxt           -- We're the scrutinee of a case
-                       -- that decomposes its scrutinee
+  | CaseCtxt            -- We're the scrutinee of a case
+                        -- that decomposes its scrutinee
 
 instance Outputable CallCtxt where
-  ppr CaseCtxt           = ptext (sLit "CaseCtxt")
+  ppr CaseCtxt    = ptext (sLit "CaseCtxt")
   ppr ValAppCtxt  = ptext (sLit "ValAppCtxt")
   ppr BoringCtxt  = ptext (sLit "BoringCtxt")
   ppr RhsCtxt     = ptext (sLit "RhsCtxt")
@@ -1023,20 +1017,20 @@ instance Outputable CallCtxt where
   ppr RuleArgCtxt = ptext (sLit "RuleArgCtxt")
 
 callSiteInline dflags id active_unfolding lone_variable arg_infos cont_info
-  = case idUnfolding id of 
+  = case idUnfolding id of
       -- idUnfolding checks for loop-breakers, returning NoUnfolding
-      -- Things with an INLINE pragma may have an unfolding *and* 
+      -- Things with an INLINE pragma may have an unfolding *and*
       -- be a loop breaker  (maybe the knot is not yet untied)
-       CoreUnfolding { uf_tmpl = unf_template, uf_is_top = is_top 
-                     , uf_is_work_free = is_wf
+        CoreUnfolding { uf_tmpl = unf_template, uf_is_top = is_top
+                      , uf_is_work_free = is_wf
                       , uf_guidance = guidance, uf_expandable = is_exp }
-          | active_unfolding -> tryUnfolding dflags id lone_variable 
-                                    arg_infos cont_info unf_template is_top 
+          | active_unfolding -> tryUnfolding dflags id lone_variable
+                                    arg_infos cont_info unf_template is_top
                                     is_wf is_exp guidance
           | otherwise -> traceInline dflags "Inactive unfolding:" (ppr id) Nothing
-       NoUnfolding      -> Nothing 
-       OtherCon {}      -> Nothing 
-       DFunUnfolding {} -> Nothing     -- Never unfold a DFun
+        NoUnfolding      -> Nothing
+        OtherCon {}      -> Nothing
+        DFunUnfolding {} -> Nothing     -- Never unfold a DFun
 
 traceInline :: DynFlags -> String -> SDoc -> a -> a
 traceInline dflags str doc result
@@ -1047,7 +1041,7 @@ traceInline dflags str doc result
 
 tryUnfolding :: DynFlags -> Id -> Bool -> [ArgSummary] -> CallCtxt
              -> CoreExpr -> Bool -> Bool -> Bool -> UnfoldingGuidance
-            -> Maybe CoreExpr
+             -> Maybe CoreExpr
 tryUnfolding dflags id lone_variable
              arg_infos cont_info unf_template is_top
              is_wf is_exp guidance
@@ -1080,7 +1074,7 @@ tryUnfolding dflags id lone_variable
   where
     mk_doc some_benefit extra_doc yes_or_no
       = vcat [ text "arg infos" <+> ppr arg_infos
-            , text "interesting continuation" <+> ppr cont_info
+             , text "interesting continuation" <+> ppr cont_info
              , text "some_benefit" <+> ppr some_benefit
              , text "is exp:" <+> ppr is_exp
              , text "is work-free:" <+> ppr is_wf
@@ -1099,17 +1093,17 @@ tryUnfolding dflags id lone_variable
     calc_some_benefit :: Arity -> Bool   -- The Arity is the number of args
                                          -- expected by the unfolding
     calc_some_benefit uf_arity
-       | not saturated = interesting_args      -- Under-saturated
-                                       -- Note [Unsaturated applications]
-       | otherwise = interesting_args  -- Saturated or over-saturated
+       | not saturated = interesting_args       -- Under-saturated
+                                        -- Note [Unsaturated applications]
+       | otherwise = interesting_args   -- Saturated or over-saturated
                   || interesting_call
       where
         saturated      = n_val_args >= uf_arity
         over_saturated = n_val_args > uf_arity
         interesting_args = any nonTriv arg_infos
-               -- NB: (any nonTriv arg_infos) looks at the
-               -- over-saturated args too which is "wrong";
-               -- but if over-saturated we inline anyway.
+                -- NB: (any nonTriv arg_infos) looks at the
+                -- over-saturated args too which is "wrong";
+                -- but if over-saturated we inline anyway.
 
         interesting_call
           | over_saturated
@@ -1117,7 +1111,7 @@ tryUnfolding dflags id lone_variable
           | otherwise
           = case cont_info of
               CaseCtxt   -> not (lone_variable && is_wf)  -- Note [Lone variables]
-              ValAppCtxt -> True                             -- Note [Cast then apply]
+              ValAppCtxt -> True                              -- Note [Cast then apply]
               RuleArgCtxt -> uf_arity > 0  -- See Note [Unfold info lazy contexts]
               DiscArgCtxt -> uf_arity > 0  --
               RhsCtxt     -> uf_arity > 0  --
@@ -1147,9 +1141,9 @@ A good example is the Ord instance for Bool in Base:
 
  Rec {
     $fOrdBool =GHC.Classes.D:Ord
-                @ Bool
-                ...
-                $cmin_ajX
+                 @ Bool
+                 ...
+                 $cmin_ajX
 
     $cmin_ajX [Occ=LoopBreaker] :: Bool -> Bool -> Bool
     $cmin_ajX = GHC.Classes.$dmmin @ Bool $fOrdBool
@@ -1171,11 +1165,11 @@ Note [Things to watch]
 ~~~~~~~~~~~~~~~~~~~~~~
 *   { y = I# 3; x = y `cast` co; ...case (x `cast` co) of ... }
     Assume x is exported, so not inlined unconditionally.
-    Then we want x to inline unconditionally; no reason for it 
+    Then we want x to inline unconditionally; no reason for it
     not to, and doing so avoids an indirection.
 
 *   { x = I# 3; ....f x.... }
-    Make sure that x does not inline unconditionally!  
+    Make sure that x does not inline unconditionally!
     Lest we get extra allocation.
 
 Note [Inlining an InlineRule]
@@ -1188,7 +1182,7 @@ For (a) the RHS may be large, and our contract is that we *only* inline
 when the function is applied to all the arguments on the LHS of the
 source-code defn.  (The uf_arity in the rule.)
 
-However for worker/wrapper it may be worth inlining even if the 
+However for worker/wrapper it may be worth inlining even if the
 arity is not satisfied (as we do in the CoreUnfolding case) so we don't
 require saturation.
 
@@ -1224,44 +1218,44 @@ we end up inlining top-level stuff into useless places; eg
 This can make a very big difference: it adds 16% to nofib 'integer' allocs,
 and 20% to 'power'.
 
-At one stage I replaced this condition by 'True' (leading to the above 
+At one stage I replaced this condition by 'True' (leading to the above
 slow-down).  The motivation was test eyeball/inline1.hs; but that seems
 to work ok now.
 
 NOTE: arguably, we should inline in ArgCtxt only if the result of the
 call is at least CONLIKE.  At least for the cases where we use ArgCtxt
-for the RHS of a 'let', we only profit from the inlining if we get a 
+for the RHS of a 'let', we only profit from the inlining if we get a
 CONLIKE thing (modulo lets).
 
-Note [Lone variables]  See also Note [Interaction of exprIsWorkFree and lone variables]
+Note [Lone variables]   See also Note [Interaction of exprIsWorkFree and lone variables]
 ~~~~~~~~~~~~~~~~~~~~~   which appears below
 The "lone-variable" case is important.  I spent ages messing about
 with unsatisfactory varaints, but this is nice.  The idea is that if a
 variable appears all alone
 
-       as an arg of lazy fn, or rhs    BoringCtxt
-       as scrutinee of a case          CaseCtxt
-       as arg of a fn                  ArgCtxt
+        as an arg of lazy fn, or rhs    BoringCtxt
+        as scrutinee of a case          CaseCtxt
+        as arg of a fn                  ArgCtxt
 AND
-       it is bound to a cheap expression
+        it is bound to a cheap expression
 
 then we should not inline it (unless there is some other reason,
-e.g. is is the sole occurrence).  That is what is happening at 
+e.g. is is the sole occurrence).  That is what is happening at
 the use of 'lone_variable' in 'interesting_call'.
 
 Why?  At least in the case-scrutinee situation, turning
-       let x = (a,b) in case x of y -> ...
+        let x = (a,b) in case x of y -> ...
 into
-       let x = (a,b) in case (a,b) of y -> ...
-and thence to 
-       let x = (a,b) in let y = (a,b) in ...
+        let x = (a,b) in case (a,b) of y -> ...
+and thence to
+        let x = (a,b) in let y = (a,b) in ...
 is bad if the binding for x will remain.
 
 Another example: I discovered that strings
 were getting inlined straight back into applications of 'error'
 because the latter is strict.
-       s = "foo"
-       f = \x -> ...(error s)...
+        s = "foo"
+        f = \x -> ...(error s)...
 
 Fundamentally such contexts should not encourage inlining because the
 context can ``see'' the unfolding of the variable (e.g. case or a
@@ -1270,13 +1264,13 @@ RULE) so there's no gain.  If the thing is bound to a value.
 However, watch out:
 
  * Consider this:
-       foo = _inline_ (\n. [n])
-       bar = _inline_ (foo 20)
-       baz = \n. case bar of { (m:_) -> m + n }
+        foo = _inline_ (\n. [n])
+        bar = _inline_ (foo 20)
+        baz = \n. case bar of { (m:_) -> m + n }
    Here we really want to inline 'bar' so that we can inline 'foo'
-   and the whole thing unravels as it should obviously do.  This is 
+   and the whole thing unravels as it should obviously do.  This is
    important: in the NDP project, 'bar' generates a closure data
-   structure rather than a list. 
+   structure rather than a list.
 
    So the non-inlining of lone_variables should only apply if the
    unfolding is regarded as cheap; because that is when exprIsConApp_maybe
@@ -1285,24 +1279,24 @@ However, watch out:
 
  * Even a type application or coercion isn't a lone variable.
    Consider
-       case $fMonadST @ RealWorld of { :DMonad a b c -> c }
+        case $fMonadST @ RealWorld of { :DMonad a b c -> c }
    We had better inline that sucker!  The case won't see through it.
 
-   For now, I'm treating treating a variable applied to types 
+   For now, I'm treating treating a variable applied to types
    in a *lazy* context "lone". The motivating example was
-       f = /\a. \x. BIG
-       g = /\a. \y.  h (f a)
+        f = /\a. \x. BIG
+        g = /\a. \y.  h (f a)
    There's no advantage in inlining f here, and perhaps
    a significant disadvantage.  Hence some_val_args in the Stop case
 
 Note [Interaction of exprIsWorkFree and lone variables]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 The lone-variable test says "don't inline if a case expression
-scrutines a lone variable whose unfolding is cheap".  It's very 
+scrutines a lone variable whose unfolding is cheap".  It's very
 important that, under these circumstances, exprIsConApp_maybe
 can spot a constructor application. So, for example, we don't
 consider
-       let x = e in (x,x)
+        let x = e in (x,x)
 to be cheap, and that's good because exprIsConApp_maybe doesn't
 think that expression is a constructor application.
 
@@ -1312,8 +1306,8 @@ expression responds True to exprIsHNF, which is what sets is_value.
 
 This kind of thing can occur if you have
 
-       {-# INLINE foo #-}
-       foo = let x = e in (x,x)
+        {-# INLINE foo #-}
+        foo = let x = e in (x,x)
 
 which Roman did.
 
@@ -1321,26 +1315,26 @@ which Roman did.
 computeDiscount :: DynFlags -> [Int] -> Int -> [ArgSummary] -> CallCtxt
                 -> Int
 computeDiscount dflags arg_discounts res_discount arg_infos cont_info
-       -- We multiple the raw discounts (args_discount and result_discount)
-       -- ty opt_UnfoldingKeenessFactor because the former have to do with
-       --  *size* whereas the discounts imply that there's some extra 
-       --  *efficiency* to be gained (e.g. beta reductions, case reductions) 
-       -- by inlining.
+        -- We multiple the raw discounts (args_discount and result_discount)
+        -- ty opt_UnfoldingKeenessFactor because the former have to do with
+        --  *size* whereas the discounts imply that there's some extra
+        --  *efficiency* to be gained (e.g. beta reductions, case reductions)
+        -- by inlining.
 
   = 10          -- Discount of 10 because the result replaces the call
-               -- so we count 10 for the function itself
+                -- so we count 10 for the function itself
 
     + 10 * length actual_arg_discounts
-              -- Discount of 10 for each arg supplied,
-              -- because the result replaces the call
+               -- Discount of 10 for each arg supplied,
+               -- because the result replaces the call
 
     + round (ufKeenessFactor dflags *
-            fromIntegral (total_arg_discount + res_discount'))
+             fromIntegral (total_arg_discount + res_discount'))
   where
     actual_arg_discounts = zipWith mk_arg_discount arg_discounts arg_infos
     total_arg_discount   = sum actual_arg_discounts
 
-    mk_arg_discount _       TrivArg    = 0
+    mk_arg_discount _        TrivArg    = 0
     mk_arg_discount _        NonTrivArg = 10
     mk_arg_discount discount ValueArg   = discount
 
@@ -1349,10 +1343,10 @@ computeDiscount dflags arg_discounts res_discount arg_infos cont_info
       = res_discount   -- Over-saturated
       | otherwise
       = case cont_info of
-                       BoringCtxt  -> 0
-                       CaseCtxt    -> res_discount  -- Presumably a constructor
-                       ValAppCtxt  -> res_discount  -- Presumably a function
-                       _           -> 40 `min` res_discount
+                        BoringCtxt  -> 0
+                        CaseCtxt    -> res_discount  -- Presumably a constructor
+                        ValAppCtxt  -> res_discount  -- Presumably a function
+                        _           -> 40 `min` res_discount
                 -- ToDo: this 40 `min` res_discount doesn't seem right
                 --   for DiscArgCtxt it shouldn't matter because the function will
                 --    get the arg discount for any non-triv arg
@@ -1361,18 +1355,18 @@ computeDiscount dflags arg_discounts res_discount arg_infos cont_info
                 --   for RhsCtxt I suppose that exposing a data con is good in general
                 --   And 40 seems very arbitrary
                 --
-               -- res_discount can be very large when a function returns
-               -- constructors; but we only want to invoke that large discount
-               -- when there's a case continuation.
-               -- Otherwise we, rather arbitrarily, threshold it.  Yuk.
-               -- But we want to aovid inlining large functions that return 
-               -- constructors into contexts that are simply "interesting"
+                -- res_discount can be very large when a function returns
+                -- constructors; but we only want to invoke that large discount
+                -- when there's a case continuation.
+                -- Otherwise we, rather arbitrarily, threshold it.  Yuk.
+                -- But we want to aovid inlining large functions that return
+                -- constructors into contexts that are simply "interesting"
 \end{code}
 
 %************************************************************************
-%*                                                                     *
-       Interesting arguments
-%*                                                                     *
+%*                                                                      *
+        Interesting arguments
+%*                                                                      *
 %************************************************************************
 
 Note [Interesting arguments]
@@ -1398,33 +1392,33 @@ to now!
 Note [Conlike is interesting]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider
-       f d = ...((*) d x y)...
-       ... f (df d')...
+        f d = ...((*) d x y)...
+        ... f (df d')...
 where df is con-like. Then we'd really like to inline 'f' so that the
-rule for (*) (df d) can fire.  To do this 
+rule for (*) (df d) can fire.  To do this
   a) we give a discount for being an argument of a class-op (eg (*) d)
   b) we say that a con-like argument (eg (df d)) is interesting
 
 \begin{code}
-data ArgSummary = TrivArg      -- Nothing interesting
-               | NonTrivArg    -- Arg has structure
-               | ValueArg      -- Arg is a con-app or PAP
-                               -- ..or con-like. Note [Conlike is interesting]
+data ArgSummary = TrivArg       -- Nothing interesting
+                | NonTrivArg    -- Arg has structure
+                | ValueArg      -- Arg is a con-app or PAP
+                                -- ..or con-like. Note [Conlike is interesting]
 
 interestingArg :: CoreExpr -> ArgSummary
 -- See Note [Interesting arguments]
 interestingArg e = go e 0
   where
     -- n is # value args to which the expression is applied
-    go (Lit {}) _         = ValueArg
+    go (Lit {}) _          = ValueArg
     go (Var v)  n
-       | isConLikeId v     = ValueArg  -- Experimenting with 'conlike' rather that
-                                               --    data constructors here
-       | idArity v > n    = ValueArg   -- Catches (eg) primops with arity but no unfolding
-       | n > 0            = NonTrivArg -- Saturated or unknown call
-       | conlike_unfolding = ValueArg  -- n==0; look for an interesting unfolding
+       | isConLikeId v     = ValueArg   -- Experimenting with 'conlike' rather that
+                                        --    data constructors here
+       | idArity v > n     = ValueArg   -- Catches (eg) primops with arity but no unfolding
+       | n > 0             = NonTrivArg -- Saturated or unknown call
+       | conlike_unfolding = ValueArg   -- n==0; look for an interesting unfolding
                                         -- See Note [Conlike is interesting]
-       | otherwise        = TrivArg    -- n==0, no useful unfolding
+       | otherwise         = TrivArg    -- n==0, no useful unfolding
        where
          conlike_unfolding = isConLikeUnfolding (idUnfolding v)
 
@@ -1434,13 +1428,13 @@ interestingArg e = go e 0
     go (App fn (Coercion _)) n = go fn n
     go (App fn _)        n = go fn (n+1)
     go (Tick _ a)      n = go a n
-    go (Cast e _)       n = go e n
-    go (Lam v e)        
-       | isTyVar v        = go e n
-       | n>0              = go e (n-1)
-       | otherwise        = ValueArg
-    go (Let _ e)        n = case go e n of { ValueArg -> ValueArg; _ -> NonTrivArg }
-    go (Case {})        _ = NonTrivArg
+    go (Cast e _)        n = go e n
+    go (Lam v e)         n
+       | isTyVar v         = go e n
+       | n>0               = go e (n-1)
+       | otherwise         = ValueArg
+    go (Let _ e)         n = case go e n of { ValueArg -> ValueArg; _ -> NonTrivArg }
+    go (Case {})         _ = NonTrivArg
 
 nonTriv ::  ArgSummary -> Bool
 nonTriv TrivArg = False
index 35a2477..8f8e2d9 100644 (file)
@@ -7,12 +7,6 @@ Desugaring arrow commands
 
 \begin{code}
 {-# LANGUAGE CPP #-}
-{-# OPTIONS_GHC -fno-warn-tabs #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and
--- detab the module (please do the detabbing in a separate patch). See
---     http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
 
 module DsArrows ( dsProcExpr ) where
 
@@ -22,7 +16,7 @@ import Match
 import DsUtils
 import DsMonad
 
-import HsSyn   hiding (collectPatBinders, collectPatsBinders, collectLStmtsBinders, collectLStmtBinders, collectStmtBinders )
+import HsSyn    hiding (collectPatBinders, collectPatsBinders, collectLStmtsBinders, collectLStmtBinders, collectStmtBinders )
 import TcHsSyn
 
 -- NB: The desugarer, which straddles the source and Core worlds, sometimes
@@ -58,7 +52,7 @@ import Data.List
 
 \begin{code}
 data DsCmdEnv = DsCmdEnv {
-       arr_id, compose_id, first_id, app_id, choice_id, loop_id :: CoreExpr
+        arr_id, compose_id, first_id, app_id, choice_id, loop_id :: CoreExpr
     }
 
 mkCmdEnv :: CmdSyntaxTable Id -> DsM ([CoreBind], DsCmdEnv)
@@ -78,7 +72,7 @@ mkCmdEnv tc_meths
       = do { rhs <- dsExpr expr
            ; id <- newSysLocalDs (exprType rhs)
            ; return (NonRec id rhs, (std_name, id)) }
+
     find_meth prs std_name
       = assocDefault (mk_panic std_name) prs std_name
     mk_panic std_name = pprPanic "mkCmdEnv" (ptext (sLit "Not found:") <+> ppr std_name)
@@ -89,7 +83,7 @@ do_arr ids b_ty c_ty f = mkApps (arr_id ids) [Type b_ty, Type c_ty, f]
 
 -- (>>>) :: forall b c d. a b c -> a c d -> a b d
 do_compose :: DsCmdEnv -> Type -> Type -> Type ->
-               CoreExpr -> CoreExpr -> CoreExpr
+                CoreExpr -> CoreExpr -> CoreExpr
 do_compose ids b_ty c_ty d_ty f g
   = mkApps (compose_id ids) [Type b_ty, Type c_ty, Type d_ty, f, g]
 
@@ -105,7 +99,7 @@ do_app ids b_ty c_ty = mkApps (app_id ids) [Type b_ty, Type c_ty]
 -- (|||) :: forall b d c. a b d -> a c d -> a (Either b c) d
 -- note the swapping of d and c
 do_choice :: DsCmdEnv -> Type -> Type -> Type ->
-               CoreExpr -> CoreExpr -> CoreExpr
+                CoreExpr -> CoreExpr -> CoreExpr
 do_choice ids b_ty c_ty d_ty f g
   = mkApps (choice_id ids) [Type b_ty, Type d_ty, Type c_ty, f, g]
 
@@ -118,7 +112,7 @@ do_loop ids b_ty c_ty d_ty f
 -- premap :: forall b c d. (b -> c) -> a c d -> a b d
 -- premap f g = arr f >>> g
 do_premap :: DsCmdEnv -> Type -> Type -> Type ->
-               CoreExpr -> CoreExpr -> CoreExpr
+                CoreExpr -> CoreExpr -> CoreExpr
 do_premap ids b_ty c_ty d_ty f g
    = do_compose ids b_ty c_ty d_ty (do_arr ids b_ty c_ty f) g
 
@@ -150,7 +144,7 @@ because the list of variables is typically not yet defined.
 
 \begin{code}
 -- coreCaseTuple [u1..] v [x1..xn] body
---     = case v of v { (x1, .., xn) -> body }
+--      = case v of v { (x1, .., xn) -> body }
 -- But the matching may be nested if the tuple is very big
 
 coreCaseTuple :: UniqSupply -> Id -> [Id] -> CoreExpr -> CoreExpr
@@ -178,7 +172,7 @@ The input is divided into a local environment, which is a flat tuple
 (unless it's too big), and a stack, which is a right-nested pair.
 In general, the input has the form
 
-       ((x1,...,xn), (s1,...(sk,())...))
+        ((x1,...,xn), (s1,...(sk,())...))
 
 where xi are the environment values, and si the ones on the stack,
 with s1 being the "top", the first one to be matched with a lambda.
@@ -196,28 +190,28 @@ splitTypeAt n ty
       _ -> pprPanic "splitTypeAt" (ppr ty)
 
 ----------------------------------------------
---             buildEnvStack
+--              buildEnvStack
 --
---     ((x1,...,xn),stk)
+--      ((x1,...,xn),stk)
 
 buildEnvStack :: [Id] -> Id -> CoreExpr
 buildEnvStack env_ids stack_id
   = mkCorePairExpr (mkBigCoreVarTup env_ids) (Var stack_id)
 
 ----------------------------------------------
---             matchEnvStack
+--              matchEnvStack
 --
---     \ ((x1,...,xn),stk) -> body
---     =>
---     \ pair ->
---     case pair of (tup,stk) ->
---     case tup of (x1,...,xn) ->
---     body
-
-matchEnvStack  :: [Id]         -- x1..xn
-               -> Id           -- stk
-               -> CoreExpr     -- e
-               -> DsM CoreExpr
+--      \ ((x1,...,xn),stk) -> body
+--      =>
+--      \ pair ->
+--      case pair of (tup,stk) ->
+--      case tup of (x1,...,xn) ->
+--      body
+
+matchEnvStack   :: [Id]         -- x1..xn
+                -> Id           -- stk
+                -> CoreExpr     -- e
+                -> DsM CoreExpr
 matchEnvStack env_ids stack_id body = do
     uniqs <- newUniqueSupply
     tup_var <- newSysLocalDs (mkBigCoreVarTupTy env_ids)
@@ -226,30 +220,30 @@ matchEnvStack env_ids stack_id body = do
     return (Lam pair_id (coreCasePair pair_id tup_var stack_id match_env))
 
 ----------------------------------------------
---             matchEnv
+--              matchEnv
 --
---     \ (x1,...,xn) -> body
---     =>
---     \ tup ->
---     case tup of (x1,...,xn) ->
---     body
-
-matchEnv :: [Id]       -- x1..xn
-        -> CoreExpr    -- e
-        -> DsM CoreExpr
+--      \ (x1,...,xn) -> body
+--      =>
+--      \ tup ->
+--      case tup of (x1,...,xn) ->
+--      body
+
+matchEnv :: [Id]        -- x1..xn
+         -> CoreExpr    -- e
+         -> DsM CoreExpr
 matchEnv env_ids body = do
     uniqs <- newUniqueSupply
     tup_id <- newSysLocalDs (mkBigCoreVarTupTy env_ids)
     return (Lam tup_id (coreCaseTuple uniqs tup_id env_ids body))
 
 ----------------------------------------------
---             matchVarStack
+--              matchVarStack
 --
---     case (x1, ...(xn, s)...) -> e
---     =>
---     case z0 of (x1,z1) ->
---     case zn-1 of (xn,s) ->
---     e
+--      case (x1, ...(xn, s)...) -> e
+--      =>
+--      case z0 of (x1,z1) ->
+--      case zn-1 of (xn,s) ->
+--      e
 matchVarStack :: [Id] -> Id -> CoreExpr -> DsM (Id, CoreExpr)
 matchVarStack [] stack_id body = return (stack_id, body)
 matchVarStack (param_id:param_ids) stack_id body = do
@@ -268,16 +262,16 @@ Translation of arrow abstraction
 
 \begin{code}
 
--- D; xs |-a c : () --> t'     ---> c'
+-- D; xs |-a c : () --> t'      ---> c'
 -- --------------------------
--- D |- proc p -> c :: a t t'  ---> premap (\ p -> ((xs),())) c'
+-- D |- proc p -> c :: a t t'   ---> premap (\ p -> ((xs),())) c'
 --
---             where (xs) is the tuple of variables bound by p
+--              where (xs) is the tuple of variables bound by p
 
 dsProcExpr
-       :: LPat Id
-       -> LHsCmdTop Id
-       -> DsM CoreExpr
+        :: LPat Id
+        -> LHsCmdTop Id
+        -> DsM CoreExpr
 dsProcExpr pat (L _ (HsCmdTop cmd _unitTy cmd_ty ids)) = do
     (meth_binds, meth_ids) <- mkCmdEnv ids
     let locals = mkVarSet (collectPatBinders pat)
@@ -297,11 +291,11 @@ dsProcExpr pat (L _ (HsCmdTop cmd _unitTy cmd_ty ids)) = do
 
 Translation of a command judgement of the form
 
-       D; xs |-a c : stk --> t
+        D; xs |-a c : stk --> t
 
 to an expression e such that
 
-       D |- e :: a (xs, stk) t
+        D |- e :: a (xs, stk) t
 
 \begin{code}
 dsLCmd :: DsCmdEnv -> IdSet -> Type -> Type -> LHsCmd Id -> [Id]
@@ -309,23 +303,23 @@ dsLCmd :: DsCmdEnv -> IdSet -> Type -> Type -> LHsCmd Id -> [Id]
 dsLCmd ids local_vars stk_ty res_ty cmd env_ids
   = dsCmd ids local_vars stk_ty res_ty (unLoc cmd) env_ids
 
-dsCmd   :: DsCmdEnv            -- arrow combinators
-       -> IdSet                -- set of local vars available to this command
-       -> Type                 -- type of the stack (right-nested tuple)
-       -> Type                 -- return type of the command
-       -> HsCmd Id             -- command to desugar
-       -> [Id]                 -- list of vars in the input to this command
-                               -- This is typically fed back,
-                               -- so don't pull on it too early
-       -> DsM (CoreExpr,       -- desugared expression
-               IdSet)          -- subset of local vars that occur free
+dsCmd   :: DsCmdEnv             -- arrow combinators
+        -> IdSet                -- set of local vars available to this command
+        -> Type                 -- type of the stack (right-nested tuple)
+        -> Type                 -- return type of the command
+        -> HsCmd Id             -- command to desugar
+        -> [Id]                 -- list of vars in the input to this command
+                                -- This is typically fed back,
+                                -- so don't pull on it too early
+        -> DsM (CoreExpr,       -- desugared expression
+                IdSet)          -- subset of local vars that occur free
 
 -- D |- fun :: a t1 t2
 -- D, xs |- arg :: t1
 -- -----------------------------
 -- D; xs |-a fun -< arg : stk --> t2
 --
---             ---> premap (\ ((xs), _stk) -> arg) fun
+--              ---> premap (\ ((xs), _stk) -> arg) fun
 
 dsCmd ids local_vars stack_ty res_ty
         (HsCmdArrApp arrow arg arrow_ty HsFirstOrderApp _)
@@ -350,7 +344,7 @@ dsCmd ids local_vars stack_ty res_ty
 -- ------------------------------
 -- D; xs |-a fun -<< arg : stk --> t2
 --
---             ---> premap (\ ((xs), _stk) -> (fun, arg)) app
+--              ---> premap (\ ((xs), _stk) -> (fun, arg)) app
 
 dsCmd ids local_vars stack_ty res_ty
         (HsCmdArrApp arrow arg arrow_ty HsHigherOrderApp _)
@@ -358,7 +352,7 @@ dsCmd ids local_vars stack_ty res_ty
     let
         (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
         (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty
-    
+
     core_arrow <- dsLExpr arrow
     core_arg   <- dsLExpr arg
     stack_id   <- newSysLocalDs stack_ty
@@ -379,7 +373,7 @@ dsCmd ids local_vars stack_ty res_ty
 -- ------------------------
 -- D; xs |-a cmd exp : stk --> t'
 --
---             ---> premap (\ ((xs),stk) -> ((ys),(e,stk))) cmd
+--              ---> premap (\ ((xs),stk) -> ((ys),(e,stk))) cmd
 
 dsCmd ids local_vars stack_ty res_ty (HsCmdApp cmd arg) env_ids = do
     core_arg <- dsLExpr arg
@@ -392,9 +386,9 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdApp cmd arg) env_ids = do
     arg_id <- newSysLocalDs arg_ty
     -- push the argument expression onto the stack
     let
-       stack' = mkCorePairExpr (Var arg_id) (Var stack_id)
+        stack' = mkCorePairExpr (Var arg_id) (Var stack_id)
         core_body = bindNonRec arg_id core_arg
-                       (mkCorePairExpr (mkBigCoreVarTup env_ids') stack')
+                        (mkCorePairExpr (mkBigCoreVarTup env_ids') stack')
 
     -- match the environment and stack against the input
     core_map <- matchEnvStack env_ids stack_id core_body
@@ -411,7 +405,7 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdApp cmd arg) env_ids = do
 -- -----------------------------------------------
 -- D; xs |-a \ p1 ... pk -> cmd : (t1,...(tk,stk)...) t'
 --
---             ---> premap (\ ((xs), (p1, ... (pk,stk)...)) -> ((ys),stk)) cmd
+--              ---> premap (\ ((xs), (p1, ... (pk,stk)...)) -> ((ys),stk)) cmd
 
 dsCmd ids local_vars stack_ty res_ty
         (HsCmdLam (MG { mg_alts = [L _ (Match pats _ (GRHSs [L _ (GRHS [] body)] _ ))] }))
@@ -419,7 +413,7 @@ dsCmd ids local_vars stack_ty res_ty
     let
         pat_vars = mkVarSet (collectPatsBinders pats)
         local_vars' = pat_vars `unionVarSet` local_vars
-       (pat_tys, stack_ty') = splitTypeAt (length pats) stack_ty
+        (pat_tys, stack_ty') = splitTypeAt (length pats) stack_ty
     (core_body, free_vars, env_ids') <- dsfixCmd ids local_vars' stack_ty' res_ty body
     param_ids <- mapM newSysLocalDs pat_tys
     stack_id' <- newSysLocalDs stack_ty'
@@ -432,7 +426,7 @@ dsCmd ids local_vars stack_ty res_ty
         core_expr = buildEnvStack env_ids' stack_id'
         in_ty = envStackType env_ids stack_ty
         in_ty' = envStackType env_ids' stack_ty'
-    
+
     fail_expr <- mkFailExpr LambdaExpr in_ty'
     -- match the patterns against the parameters
     match_code <- matchSimplys (map Var param_ids) LambdaExpr pats core_expr fail_expr
@@ -452,9 +446,9 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdPar cmd) env_ids
 -- ----------------------------------------
 -- D; xs |-a if e then c1 else c2 : stk --> t
 --
---             ---> premap (\ ((xs),stk) ->
---                      if e then Left ((xs1),stk) else Right ((xs2),stk))
---                    (c1 ||| c2)
+--              ---> premap (\ ((xs),stk) ->
+--                       if e then Left ((xs1),stk) else Right ((xs2),stk))
+--                     (c1 ||| c2)
 
 dsCmd ids local_vars stack_ty res_ty (HsCmdIf mb_fun cond then_cmd else_cmd)
         env_ids = do
@@ -474,11 +468,11 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdIf mb_fun cond then_cmd else_cmd)
         else_ty = envStackType else_ids stack_ty
         sum_ty = mkTyConApp either_con [then_ty, else_ty]
         fvs_cond = exprFreeIds core_cond `intersectVarSet` local_vars
-        
+
         core_left  = mk_left_expr  then_ty else_ty (buildEnvStack then_ids stack_id)
         core_right = mk_right_expr then_ty else_ty (buildEnvStack else_ids stack_id)
 
-    core_if <- case mb_fun of 
+    core_if <- case mb_fun of
        Just fun -> do { core_fun <- dsExpr fun
                       ; matchEnvStack env_ids stack_id $
                         mkCoreApps core_fun [core_cond, core_left, core_right] }
@@ -494,15 +488,15 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdIf mb_fun cond then_cmd else_cmd)
 Case commands are treated in much the same way as if commands
 (see above) except that there are more alternatives.  For example
 
-       case e of { p1 -> c1; p2 -> c2; p3 -> c3 }
+        case e of { p1 -> c1; p2 -> c2; p3 -> c3 }
 
 is translated to
 
-       premap (\ ((xs)*ts) -> case e of
-               p1 -> (Left (Left (xs1)*ts))
-               p2 -> Left ((Right (xs2)*ts))
-               p3 -> Right ((xs3)*ts))
-       ((c1 ||| c2) ||| c3)
+        premap (\ ((xs)*ts) -> case e of
+                p1 -> (Left (Left (xs1)*ts))
+                p2 -> Left ((Right (xs2)*ts))
+                p3 -> Right ((xs3)*ts))
+        ((c1 ||| c2) ||| c3)
 
 The idea is to extract the commands from the case, build a balanced tree
 of choices, and replace the commands with expressions that build tagged
@@ -517,7 +511,7 @@ case bodies, containing the following fields:
    bodies with |||.
 
 \begin{code}
-dsCmd ids local_vars stack_ty res_ty 
+dsCmd ids local_vars stack_ty res_ty
       (HsCmdCase exp (MG { mg_alts = matches, mg_arg_tys = arg_tys, mg_origin = origin }))
       env_ids = do
     stack_id <- newSysLocalDs stack_ty
@@ -533,7 +527,7 @@ dsCmd ids local_vars stack_ty res_ty
             return ([mkHsEnvStackExpr leaf_ids stack_id],
                     envStackType leaf_ids stack_ty,
                     core_leaf)
-    
+
     branches <- mapM make_branch leaves
     either_con <- dsLookupTyCon eitherTyConName
     left_con <- dsLookupDataCon leftDataConName
@@ -574,13 +568,13 @@ dsCmd ids local_vars stack_ty res_ty
 -- ----------------------------------
 -- D; xs |-a let binds in cmd : stk --> t
 --
---             ---> premap (\ ((xs),stk) -> let binds in ((ys),stk)) c
+--              ---> premap (\ ((xs),stk) -> let binds in ((ys),stk)) c
 
 dsCmd ids local_vars stack_ty res_ty (HsCmdLet binds body) env_ids = do
     let
         defined_vars = mkVarSet (collectLocalBinders binds)
         local_vars' = defined_vars `unionVarSet` local_vars
-    
+
     (core_body, _free_vars, env_ids') <- dsfixCmd ids local_vars' stack_ty res_ty body
     stack_id <- newSysLocalDs stack_ty
     -- build a new environment, plus the stack, using the let bindings
@@ -599,24 +593,24 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdLet binds body) env_ids = do
 -- ----------------------------------
 -- D; xs |-a do { ss } : () --> t
 --
---             ---> premap (\ (env,stk) -> env) c
+--              ---> premap (\ (env,stk) -> env) c
 
 dsCmd ids local_vars stack_ty res_ty (HsCmdDo stmts _) env_ids = do
     (core_stmts, env_ids') <- dsCmdDo ids local_vars res_ty stmts env_ids
     let env_ty = mkBigCoreVarTupTy env_ids
     core_fst <- mkFstExpr env_ty stack_ty
     return (do_premap ids
-               (mkCorePairTy env_ty stack_ty)
-               env_ty
-               res_ty
-               core_fst
-               core_stmts,
-       env_ids')
+                (mkCorePairTy env_ty stack_ty)
+                env_ty
+                res_ty
+                core_fst
+                core_stmts,
+        env_ids')
 
 -- D |- e :: forall e. a1 (e,stk1) t1 -> ... an (e,stkn) tn -> a (e,stk) t
 -- D; xs |-a ci :: stki --> ti
 -- -----------------------------------
--- D; xs |-a (|e c1 ... cn|) :: stk --> t      ---> e [t_xs] c1 ... cn
+-- D; xs |-a (|e c1 ... cn|) :: stk --> t       ---> e [t_xs] c1 ... cn
 
 dsCmd _ids local_vars _stack_ty _res_ty (HsCmdArrForm op _ args) env_ids = do
     let env_ty = mkBigCoreVarTupTy env_ids
@@ -632,16 +626,16 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdCast coercion cmd) env_ids = do
 
 dsCmd _ _ _ _ _ c = pprPanic "dsCmd" (ppr c)
 
--- D; ys |-a c : stk --> t     (ys <= xs)
+-- D; ys |-a c : stk --> t      (ys <= xs)
 -- ---------------------
--- D; xs |-a c : stk --> t     ---> premap (\ ((xs),stk) -> ((ys),stk)) c
+-- D; xs |-a c : stk --> t      ---> premap (\ ((xs),stk) -> ((ys),stk)) c
 
 dsTrimCmdArg
-       :: IdSet                -- set of local vars available to this command
-       -> [Id]                 -- list of vars in the input to this command
-       -> LHsCmdTop Id         -- command argument to desugar
-       -> DsM (CoreExpr,       -- desugared expression
-               IdSet)          -- subset of local vars that occur free
+        :: IdSet                -- set of local vars available to this command
+        -> [Id]                 -- list of vars in the input to this command
+        -> LHsCmdTop Id         -- command argument to desugar
+        -> DsM (CoreExpr,       -- desugared expression
+                IdSet)          -- subset of local vars that occur free
 dsTrimCmdArg local_vars env_ids (L _ (HsCmdTop cmd stack_ty cmd_ty ids)) = do
     (meth_binds, meth_ids) <- mkCmdEnv ids
     (core_cmd, free_vars, env_ids') <- dsfixCmd meth_ids local_vars stack_ty cmd_ty cmd
@@ -658,14 +652,14 @@ dsTrimCmdArg local_vars env_ids (L _ (HsCmdTop cmd stack_ty cmd_ty ids)) = do
 -- Typically needs to be prefixed with arr (\(p, stk) -> ((xs),stk))
 
 dsfixCmd
-       :: DsCmdEnv             -- arrow combinators
-       -> IdSet                -- set of local vars available to this command
-       -> Type                 -- type of the stack (right-nested tuple)
-       -> Type                 -- return type of the command
-       -> LHsCmd Id            -- command to desugar
-       -> DsM (CoreExpr,       -- desugared expression
-               IdSet,          -- subset of local vars that occur free
-               [Id])           -- the same local vars as a list, fed back
+        :: DsCmdEnv             -- arrow combinators
+        -> IdSet                -- set of local vars available to this command
+        -> Type                 -- type of the stack (right-nested tuple)
+        -> Type                 -- return type of the command
+        -> LHsCmd Id            -- command to desugar
+        -> DsM (CoreExpr,       -- desugared expression
+                IdSet,          -- subset of local vars that occur free
+                [Id])           -- the same local vars as a list, fed back
 dsfixCmd ids local_vars stk_ty cmd_ty cmd
   = trimInput (dsLCmd ids local_vars stk_ty cmd_ty cmd)
 
@@ -673,12 +667,12 @@ dsfixCmd ids local_vars stk_ty cmd_ty cmd
 -- for use as the input tuple of the generated arrow.
 
 trimInput
-       :: ([Id] -> DsM (CoreExpr, IdSet))
-       -> DsM (CoreExpr,       -- desugared expression
-               IdSet,          -- subset of local vars that occur free
-               [Id])           -- same local vars as a list, fed back to
-                               -- the inner function to form the tuple of
-                               -- inputs to the arrow.
+        :: ([Id] -> DsM (CoreExpr, IdSet))
+        -> DsM (CoreExpr,       -- desugared expression
+                IdSet,          -- subset of local vars that occur free
+                [Id])           -- same local vars as a list, fed back to
+                                -- the inner function to form the tuple of
+                                -- inputs to the arrow.
 trimInput build_arrow
   = fixDs (\ ~(_,_,env_ids) -> do
         (core_cmd, free_vars) <- build_arrow env_ids
@@ -688,19 +682,19 @@ trimInput build_arrow
 
 Translation of command judgements of the form
 
-       D |-a do { ss } : t
+        D |-a do { ss } : t
 
 \begin{code}
 
-dsCmdDo :: DsCmdEnv            -- arrow combinators
-       -> IdSet                -- set of local vars available to this statement
-       -> Type                 -- return type of the statement
-       -> [CmdLStmt Id]        -- statements to desugar
-       -> [Id]                 -- list of vars in the input to this statement
-                               -- This is typically fed back,
-                               -- so don't pull on it too early
-       -> DsM (CoreExpr,       -- desugared expression
-               IdSet)          -- subset of local vars that occur free
+dsCmdDo :: DsCmdEnv             -- arrow combinators
+        -> IdSet                -- set of local vars available to this statement
+        -> Type                 -- return type of the statement
+        -> [CmdLStmt Id]        -- statements to desugar
+        -> [Id]                 -- list of vars in the input to this statement
+                                -- This is typically fed back,
+                                -- so don't pull on it too early
+        -> DsM (CoreExpr,       -- desugared expression
+                IdSet)          -- subset of local vars that occur free
 
 dsCmdDo _ _ _ [] _ = panic "dsCmdDo"
 
@@ -708,7 +702,7 @@ dsCmdDo _ _ _ [] _ = panic "dsCmdDo"
 -- --------------------------
 -- D; xs |-a do { c } : t
 --
---             ---> premap (\ (xs) -> ((xs), ())) c
+--              ---> premap (\ (xs) -> ((xs), ())) c
 
 dsCmdDo ids local_vars res_ty [L _ (LastStmt body _)] env_ids = do
     (core_body, env_ids') <- dsLCmd ids local_vars unitTy res_ty body env_ids
@@ -717,11 +711,11 @@ dsCmdDo ids local_vars res_ty [L _ (LastStmt body _)] env_ids = do
     let core_map = Lam env_var (mkCorePairExpr (Var env_var) mkCoreUnitExpr)
     return (do_premap ids
                         env_ty
-                       (mkCorePairTy env_ty unitTy)
+                        (mkCorePairTy env_ty unitTy)
                         res_ty
                         core_map
                         core_body,
-       env_ids')
+        env_ids')
 
 dsCmdDo ids local_vars res_ty (stmt:stmts) env_ids = do
     let
@@ -748,50 +742,50 @@ dsCmdLStmt ids local_vars out_ids cmd env_ids
   = dsCmdStmt ids local_vars out_ids (unLoc cmd) env_ids
 
 dsCmdStmt
-       :: DsCmdEnv             -- arrow combinators
-       -> IdSet                -- set of local vars available to this statement
-       -> [Id]                 -- list of vars in the output of this statement
-       -> CmdStmt Id           -- statement to desugar
-       -> [Id]                 -- list of vars in the input to this statement
-                               -- This is typically fed back,
-                               -- so don't pull on it too early
-       -> DsM (CoreExpr,       -- desugared expression
-               IdSet)          -- subset of local vars that occur free
+        :: DsCmdEnv             -- arrow combinators
+        -> IdSet                -- set of local vars available to this statement
+        -> [Id]                 -- list of vars in the output of this statement
+        -> CmdStmt Id           -- statement to desugar
+        -> [Id]                 -- list of vars in the input to this statement
+                                -- This is typically fed back,
+                                -- so don't pull on it too early
+        -> DsM (CoreExpr,       -- desugared expression
+                IdSet)          -- subset of local vars that occur free
 
 -- D; xs1 |-a c : () --> t
 -- D; xs' |-a do { ss } : t'
 -- ------------------------------
 -- D; xs  |-a do { c; ss } : t'
 --
---             ---> premap (\ ((xs)) -> (((xs1),()),(xs')))
---                     (first c >>> arr snd) >>> ss
+--              ---> premap (\ ((xs)) -> (((xs1),()),(xs')))
+--                      (first c >>> arr snd) >>> ss
 
 dsCmdStmt ids local_vars out_ids (BodyStmt cmd _ _ c_ty) env_ids = do
     (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy c_ty cmd
     core_mux <- matchEnv env_ids
         (mkCorePairExpr
-           (mkCorePairExpr (mkBigCoreVarTup env_ids1) mkCoreUnitExpr)
-           (mkBigCoreVarTup out_ids))
+            (mkCorePairExpr (mkBigCoreVarTup env_ids1) mkCoreUnitExpr)
+            (mkBigCoreVarTup out_ids))
     let
-       in_ty = mkBigCoreVarTupTy env_ids
-       in_ty1 = mkCorePairTy (mkBigCoreVarTupTy env_ids1) unitTy
-       out_ty = mkBigCoreVarTupTy out_ids
-       before_c_ty = mkCorePairTy in_ty1 out_ty
-       after_c_ty = mkCorePairTy c_ty out_ty
+        in_ty = mkBigCoreVarTupTy env_ids
+        in_ty1 = mkCorePairTy (mkBigCoreVarTupTy env_ids1) unitTy
+        out_ty = mkBigCoreVarTupTy out_ids
+        before_c_ty = mkCorePairTy in_ty1 out_ty
+        after_c_ty = mkCorePairTy c_ty out_ty
     snd_fn <- mkSndExpr c_ty out_ty
     return (do_premap ids in_ty before_c_ty out_ty core_mux $
-               do_compose ids before_c_ty after_c_ty out_ty
-                       (do_first ids in_ty1 c_ty out_ty core_cmd) $
-               do_arr ids after_c_ty out_ty snd_fn,
-             extendVarSetList fv_cmd out_ids)
+                do_compose ids before_c_ty after_c_ty out_ty
+                        (do_first ids in_ty1 c_ty out_ty core_cmd) $
+                do_arr ids after_c_ty out_ty snd_fn,
+              extendVarSetList fv_cmd out_ids)
 
 -- D; xs1 |-a c : () --> t
--- D; xs' |-a do { ss } : t'           xs2 = xs' - defs(p)
+-- D; xs' |-a do { ss } : t'            xs2 = xs' - defs(p)
 -- -----------------------------------
 -- D; xs  |-a do { p <- c; ss } : t'
 --
---             ---> premap (\ (xs) -> (((xs1),()),(xs2)))
---                     (first c >>> arr (\ (p, (xs2)) -> (xs'))) >>> ss
+--              ---> premap (\ (xs) -> (((xs1),()),(xs2)))
+--                      (first c >>> arr (\ (p, (xs2)) -> (xs'))) >>> ss
 --
 -- It would be simpler and more consistent to do this using second,
 -- but that's likely to be defined in terms of first.
@@ -799,53 +793,53 @@ dsCmdStmt ids local_vars out_ids (BodyStmt cmd _ _ c_ty) env_ids = do
 dsCmdStmt ids local_vars out_ids (BindStmt pat cmd _ _) env_ids = do
     (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy (hsLPatType pat) cmd
     let
-       pat_ty = hsLPatType pat
-       pat_vars = mkVarSet (collectPatBinders pat)
-       env_ids2 = varSetElems (mkVarSet out_ids `minusVarSet` pat_vars)
-       env_ty2 = mkBigCoreVarTupTy env_ids2
+        pat_ty = hsLPatType pat
+        pat_vars = mkVarSet (collectPatBinders pat)
+        env_ids2 = varSetElems (mkVarSet out_ids `minusVarSet` pat_vars)
+        env_ty2 = mkBigCoreVarTupTy env_ids2
 
     -- multiplexing function
-    --         \ (xs) -> (((xs1),()),(xs2))
+    --          \ (xs) -> (((xs1),()),(xs2))
 
     core_mux <- matchEnv env_ids
         (mkCorePairExpr
-           (mkCorePairExpr (mkBigCoreVarTup env_ids1) mkCoreUnitExpr)
-           (mkBigCoreVarTup env_ids2))
+            (mkCorePairExpr (mkBigCoreVarTup env_ids1) mkCoreUnitExpr)
+            (mkBigCoreVarTup env_ids2))
 
     -- projection function
-    --         \ (p, (xs2)) -> (zs)
+    --          \ (p, (xs2)) -> (zs)
 
     env_id <- newSysLocalDs env_ty2
     uniqs <- newUniqueSupply
     let
-       after_c_ty = mkCorePairTy pat_ty env_ty2
-       out_ty = mkBigCoreVarTupTy out_ids
-       body_expr = coreCaseTuple uniqs env_id env_ids2 (mkBigCoreVarTup out_ids)
-    
+        after_c_ty = mkCorePairTy pat_ty env_ty2
+        out_ty = mkBigCoreVarTupTy out_ids
+        body_expr = coreCaseTuple uniqs env_id env_ids2 (mkBigCoreVarTup out_ids)
+
     fail_expr <- mkFailExpr (StmtCtxt DoExpr) out_ty
     pat_id    <- selectSimpleMatchVarL pat
     match_code <- matchSimply (Var pat_id) (StmtCtxt DoExpr) pat body_expr fail_expr
     pair_id   <- newSysLocalDs after_c_ty
     let
-       proj_expr = Lam pair_id (coreCasePair pair_id pat_id env_id match_code)
+        proj_expr = Lam pair_id (coreCasePair pair_id pat_id env_id match_code)
 
     -- put it all together
     let
-       in_ty = mkBigCoreVarTupTy env_ids
-       in_ty1 = mkCorePairTy (mkBigCoreVarTupTy env_ids1) unitTy
-       in_ty2 = mkBigCoreVarTupTy env_ids2
-       before_c_ty = mkCorePairTy in_ty1 in_ty2
+        in_ty = mkBigCoreVarTupTy env_ids
+        in_ty1 = mkCorePairTy (mkBigCoreVarTupTy env_ids1) unitTy
+        in_ty2 = mkBigCoreVarTupTy env_ids2
+        before_c_ty = mkCorePairTy in_ty1 in_ty2
     return (do_premap ids in_ty before_c_ty out_ty core_mux $
-               do_compose ids before_c_ty after_c_ty out_ty
-                       (do_first ids in_ty1 pat_ty in_ty2 core_cmd) $
-               do_arr ids after_c_ty out_ty proj_expr,
-             fv_cmd `unionVarSet` (mkVarSet out_ids `minusVarSet` pat_vars))
+                do_compose ids before_c_ty after_c_ty out_ty
+                        (do_first ids in_ty1 pat_ty in_ty2 core_cmd) $
+                do_arr ids after_c_ty out_ty proj_expr,
+              fv_cmd `unionVarSet` (mkVarSet out_ids `minusVarSet` pat_vars))
 
 -- D; xs' |-a do { ss } : t
 -- --------------------------------------
 -- D; xs  |-a do { let binds; ss } : t
 --
---             ---> arr (\ (xs) -> let binds in (xs')) >>> ss
+--              ---> arr (\ (xs) -> let binds in (xs')) >>> ss
 
 dsCmdStmt ids local_vars out_ids (LetStmt binds) env_ids = do
     -- build a new environment using the let bindings
@@ -853,24 +847,24 @@ dsCmdStmt ids local_vars out_ids (LetStmt binds) env_ids = do
     -- match the old environment against the input
     core_map <- matchEnv env_ids core_binds
     return (do_arr ids
-                       (mkBigCoreVarTupTy env_ids)
-                       (mkBigCoreVarTupTy out_ids)
-                       core_map,
-           exprFreeIds core_binds `intersectVarSet` local_vars)
+                        (mkBigCoreVarTupTy env_ids)
+                        (mkBigCoreVarTupTy out_ids)
+                        core_map,
+            exprFreeIds core_binds `intersectVarSet` local_vars)
 
 -- D; ys  |-a do { ss; returnA -< ((xs1), (ys2)) } : ...
 -- D; xs' |-a do { ss' } : t
 -- ------------------------------------
 -- D; xs  |-a do { rec ss; ss' } : t
 --
---                     xs1 = xs' /\ defs(ss)
---                     xs2 = xs' - defs(ss)
---                     ys1 = ys - defs(ss)
---                     ys2 = ys /\ defs(ss)
+--                      xs1 = xs' /\ defs(ss)
+--                      xs2 = xs' - defs(ss)
+--                      ys1 = ys - defs(ss)
+--                      ys2 = ys /\ defs(ss)
 --
---             ---> arr (\(xs) -> ((ys1),(xs2))) >>>
---                     first (loop (arr (\((ys1),~(ys2)) -> (ys)) >>> ss)) >>>
---                     arr (\((xs1),(xs2)) -> (xs')) >>> ss'
+--              ---> arr (\(xs) -> ((ys1),(xs2))) >>>
+--                      first (loop (arr (\((ys1),~(ys2)) -> (ys)) >>> ss)) >>>
+--                      arr (\((xs1),(xs2)) -> (xs')) >>> ss'
 
 dsCmdStmt ids local_vars out_ids
         (RecStmt { recS_stmts = stmts
@@ -925,20 +919,20 @@ dsCmdStmt ids local_vars out_ids
 
 dsCmdStmt _ _ _ _ s = pprPanic "dsCmdStmt" (ppr s)
 
---     loop (premap (\ ((env1_ids), ~(rec_ids)) -> (env_ids))
---           (ss >>> arr (\ (out_ids) -> ((later_rets),(rec_rets))))) >>>
+--      loop (premap (\ ((env1_ids), ~(rec_ids)) -> (env_ids))
+--            (ss >>> arr (\ (out_ids) -> ((later_rets),(rec_rets))))) >>>
 
 dsRecCmd
-        :: DsCmdEnv            -- arrow combinators
-        -> IdSet               -- set of local vars available to this statement
+        :: DsCmdEnv             -- arrow combinators
+        -> IdSet                -- set of local vars available to this statement
         -> [CmdLStmt Id]        -- list of statements inside the RecCmd
-        -> [Id]                        -- list of vars defined here and used later
-        -> [HsExpr Id]         -- expressions corresponding to later_ids
-        -> [Id]                        -- list of vars fed back through the loop
-        -> [HsExpr Id]         -- expressions corresponding to rec_ids
-        -> DsM (CoreExpr,      -- desugared statement
-                IdSet,         -- subset of local vars that occur free
-                [Id])          -- same local vars as a list
+        -> [Id]                 -- list of vars defined here and used later
+        -> [HsExpr Id]          -- expressions corresponding to later_ids
+        -> [Id]                 -- list of vars fed back through the loop
+        -> [HsExpr Id]          -- expressions corresponding to rec_ids
+        -> DsM (CoreExpr,       -- desugared statement
+                IdSet,          -- subset of local vars that occur free
+                [Id])           -- same local vars as a list
 
 dsRecCmd ids local_vars stmts later_ids later_rets rec_ids rec_rets = do
     let
@@ -1006,25 +1000,25 @@ two environments (no stack)
 \begin{code}
 
 dsfixCmdStmts
-       :: DsCmdEnv             -- arrow combinators
-       -> IdSet                -- set of local vars available to this statement
-       -> [Id]                 -- output vars of these statements
-       -> [CmdLStmt Id]        -- statements to desugar
-       -> DsM (CoreExpr,       -- desugared expression
-               IdSet,          -- subset of local vars that occur free
-               [Id])           -- same local vars as a list
+        :: DsCmdEnv             -- arrow combinators
+        -> IdSet                -- set of local vars available to this statement
+        -> [Id]                 -- output vars of these statements
+        -> [CmdLStmt Id]        -- statements to desugar
+        -> DsM (CoreExpr,       -- desugared expression
+                IdSet,          -- subset of local vars that occur free
+                [Id])           -- same local vars as a list
 
 dsfixCmdStmts ids local_vars out_ids stmts
   = trimInput (dsCmdStmts ids local_vars out_ids stmts)
 
 dsCmdStmts
-       :: DsCmdEnv             -- arrow combinators
-       -> IdSet                -- set of local vars available to this statement
-       -> [Id]                 -- output vars of these statements
-       -> [CmdLStmt Id]        -- statements to desugar
-       -> [Id]                 -- list of vars in the input to these statements
-       -> DsM (CoreExpr,       -- desugared expression
-               IdSet)          -- subset of local vars that occur free
+        :: DsCmdEnv             -- arrow combinators
+        -> IdSet                -- set of local vars available to this statement
+        -> [Id]                 -- output vars of these statements
+        -> [CmdLStmt Id]        -- statements to desugar
+        -> [Id]                 -- list of vars in the input to these statements
+        -> DsM (CoreExpr,       -- desugared expression
+                IdSet)          -- subset of local vars that occur free
 
 dsCmdStmts ids local_vars out_ids [stmt] env_ids
   = dsCmdLStmt ids local_vars out_ids stmt env_ids
@@ -1050,11 +1044,11 @@ Match a list of expressions against a list of patterns, left-to-right.
 
 \begin{code}
 matchSimplys :: [CoreExpr]              -- Scrutinees
-            -> HsMatchContext Name     -- Match kind
-            -> [LPat Id]               -- Patterns they should match
-            -> CoreExpr                -- Return this if they all match
-            -> CoreExpr                -- Return this if they don't
-            -> DsM CoreExpr
+             -> HsMatchContext Name     -- Match kind
+             -> [LPat Id]               -- Patterns they should match
+             -> CoreExpr                -- Return this if they all match
+             -> CoreExpr                -- Return this if they don't
+             -> DsM CoreExpr
 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
@@ -1068,13 +1062,13 @@ List of leaf expressions, with set of variables bound in each
 leavesMatch :: LMatch Id (Located (body Id)) -> [(Located (body Id), IdSet)]
 leavesMatch (L _ (Match pats _ (GRHSs grhss binds)))
   = let
-       defined_vars = mkVarSet (collectPatsBinders pats)
-                       `unionVarSet`
-                      mkVarSet (collectLocalBinders binds)
+        defined_vars = mkVarSet (collectPatsBinders pats)
+                        `unionVarSet`
+                       mkVarSet (collectLocalBinders binds)
     in
-    [(body, 
-      mkVarSet (collectLStmtsBinders stmts) 
-       `unionVarSet` defined_vars) 
+    [(body,
+      mkVarSet (collectLStmtsBinders stmts)
+        `unionVarSet` defined_vars)
     | L _ (GRHS stmts body) <- grhss]
 \end{code}
 
@@ -1089,7 +1083,7 @@ replaceLeavesMatch
             LMatch Id (Located (body' Id)))     -- updated match
 replaceLeavesMatch _res_ty leaves (L loc (Match pat mt (GRHSs grhss binds)))
   = let
-       (leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss
+        (leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss
     in
     (leaves', L loc (Match pat mt (GRHSs grhss' binds)))
 
index 37c1632..a8d37a4 100644 (file)
@@ -11,12 +11,6 @@ lower levels it is preserved with @let@/@letrec@s).
 
 \begin{code}
 {-# LANGUAGE CPP #-}
-{-# OPTIONS_GHC -fno-warn-tabs #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and
--- detab the module (please do the detabbing in a separate patch). See
---     http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
 
 module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec,
                  dsHsWrapper, dsTcEvBinds, dsEvBinds
@@ -24,15 +18,15 @@ module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec,
 
 #include "HsVersions.h"
 
-import {-# SOURCE #-}  DsExpr( dsLExpr )
-import {-# SOURCE #-}  Match( matchWrapper )
+import {-# SOURCE #-}   DsExpr( dsLExpr )
+import {-# SOURCE #-}   Match( matchWrapper )
 
 import DsMonad
 import DsGRHSs
 import DsUtils
 
-import HsSyn           -- lots of things
-import CoreSyn         -- lots of things
+import HsSyn            -- lots of things
+import CoreSyn          -- lots of things
 import Literal          ( Literal(MachStr) )
 import CoreSubst
 import OccurAnal        ( occurAnalyseExpr )
@@ -54,9 +48,9 @@ import Coercion hiding (substCo)
 import TysWiredIn ( eqBoxDataCon, coercibleDataCon, tupleCon )
 import Id
 import Class
-import DataCon ( dataConWorkId )
+import DataCon  ( dataConWorkId )
 import Name
-import MkId    ( seqId )
+import MkId     ( seqId )
 import Var
 import VarSet
 import Rules
@@ -78,9 +72,9 @@ import Control.Monad(liftM)
 \end{code}
 
 %************************************************************************
-%*                                                                     *
+%*                                                                      *
 \subsection[dsMonoBinds]{Desugaring a @MonoBinds@}
-%*                                                                     *
+%*                                                                      *
 %************************************************************************
 
 \begin{code}
@@ -106,17 +100,17 @@ dsHsBind (VarBind { var_id = var, var_rhs = expr, var_inline = inline_regardless
   = do  { dflags <- getDynFlags
         ; core_expr <- dsLExpr expr
 
-               -- Dictionary bindings are always VarBinds,
-               -- so we only need do this here
+                -- Dictionary bindings are always VarBinds,
+                -- so we only need do this here
         ; let var' | inline_regardless = var `setIdUnfolding` mkCompulsoryUnfolding core_expr
-                  | otherwise         = var
+                   | otherwise         = var
 
         ; return (unitOL (makeCorePair dflags var' False 0 core_expr)) }
 
 dsHsBind (FunBind { fun_id = L _ fun, fun_matches = matches
                   , fun_co_fn = co_fn, fun_tick = tick
                   , fun_infix = inf })
- = do  { dflags <- getDynFlags
+ = do   { dflags <- getDynFlags
         ; (args, body) <- matchWrapper (FunRhs (idName fun) inf) matches
         ; let body' = mkOptTickBox tick body
         ; rhs <- dsHsWrapper co_fn (mkLams args body')
@@ -125,17 +119,17 @@ dsHsBind (FunBind { fun_id = L _ fun, fun_matches = matches
 
 dsHsBind (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty
                   , pat_ticks = (rhs_tick, var_ticks) })
-  = do { body_expr <- dsGuarded grhss ty
+  = do  { body_expr <- dsGuarded grhss ty
         ; let body' = mkOptTickBox rhs_tick body_expr
         ; sel_binds <- mkSelectorBinds var_ticks pat body'
-         -- We silently ignore inline pragmas; no makeCorePair
-         -- Not so cool, but really doesn't matter
+          -- We silently ignore inline pragmas; no makeCorePair
+          -- Not so cool, but really doesn't matter
     ; return (toOL sel_binds) }
 
-       -- A common case: one exported variable
-       -- Non-recursive bindings come through this way
-       -- So do self-recursive bindings, and recursive bindings
-       -- that have been chopped up with type signatures
+        -- A common case: one exported variable
+        -- Non-recursive bindings come through this way
+        -- So do self-recursive bindings, and recursive bindings
+        -- that have been chopped up with type signatures
 dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
                    , abs_exports = [export]
                    , abs_ev_binds = ev_binds, abs_binds = binds })
@@ -143,21 +137,21 @@ dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
         , abe_mono = local, abe_prags = prags } <- export
   = do  { dflags <- getDynFlags
         ; bind_prs    <- ds_lhs_binds binds
-       ; let   core_bind = Rec (fromOL bind_prs)
+        ; let   core_bind = Rec (fromOL bind_prs)
         ; ds_binds <- dsTcEvBinds ev_binds
         ; rhs <- dsHsWrapper wrap $  -- Usually the identity
-                           mkLams tyvars $ mkLams dicts $ 
-                           mkCoreLets ds_binds $
+                            mkLams tyvars $ mkLams dicts $
+                            mkCoreLets ds_binds $
                             Let core_bind $
                             Var local
-    
-       ; (spec_binds, rules) <- dsSpecs rhs prags
 
-       ; let   global'   = addIdSpecialisations global rules
-               main_bind = makeCorePair dflags global' (isDefaultMethod prags)
-                                         (dictArity dicts) rhs 
-    
-       ; return (main_bind `consOL` spec_binds) }
+        ; (spec_binds, rules) <- dsSpecs rhs prags
+
+        ; let   global'   = addIdSpecialisations global rules
+                main_bind = makeCorePair dflags global' (isDefaultMethod prags)
+                                         (dictArity dicts) rhs
+
+        ; return (main_bind `consOL` spec_binds) }
 
 dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
                    , abs_exports = exports, abs_ev_binds = ev_binds
@@ -167,39 +161,39 @@ dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
         ; bind_prs    <- ds_lhs_binds binds
         ; let core_bind = Rec [ makeCorePair dflags (add_inline lcl_id) False 0 rhs
                               | (lcl_id, rhs) <- fromOL bind_prs ]
-               -- Monomorphic recursion possible, hence Rec
+                -- Monomorphic recursion possible, hence Rec
 
-             locals       = map abe_mono exports
-             tup_expr     = mkBigCoreVarTup locals
-             tup_ty       = exprType tup_expr
+              locals       = map abe_mono exports
+              tup_expr     = mkBigCoreVarTup locals
+              tup_ty       = exprType tup_expr
         ; ds_binds <- dsTcEvBinds ev_binds
-       ; let poly_tup_rhs = mkLams tyvars $ mkLams dicts $
-                            mkCoreLets ds_binds $
-                            Let core_bind $
-                            tup_expr
+        ; let poly_tup_rhs = mkLams tyvars $ mkLams dicts $
+                             mkCoreLets ds_binds $
+                             Let core_bind $
+                             tup_expr
 
-       ; poly_tup_id <- newSysLocalDs (exprType poly_tup_rhs)
+        ; poly_tup_id <- newSysLocalDs (exprType poly_tup_rhs)
 
-       ; let mk_bind (ABE { abe_wrap = wrap, abe_poly = global
+        ; let mk_bind (ABE { abe_wrap = wrap, abe_poly = global
                            , abe_mono = local, abe_prags = spec_prags })
-               = do { tup_id  <- newSysLocalDs tup_ty
-                    ; rhs <- dsHsWrapper wrap $ 
+                = do { tup_id  <- newSysLocalDs tup_ty
+                     ; rhs <- dsHsWrapper wrap $
                                  mkLams tyvars $ mkLams dicts $
-                                mkTupleSelector locals local tup_id $
-                                mkVarApps (Var poly_tup_id) (tyvars ++ dicts)
+                                 mkTupleSelector locals local tup_id $
+                                 mkVarApps (Var poly_tup_id) (tyvars ++ dicts)
                      ; let rhs_for_spec = Let (NonRec poly_tup_id poly_tup_rhs) rhs
-                    ; (spec_binds, rules) <- dsSpecs rhs_for_spec spec_prags
-                    ; let global' = (global `setInlinePragma` defaultInlinePragma)
+                     ; (spec_binds, rules) <- dsSpecs rhs_for_spec spec_prags
+                     ; let global' = (global `setInlinePragma` defaultInlinePragma)
                                              `addIdSpecialisations` rules
                            -- Kill the INLINE pragma because it applies to
                            -- the user written (local) function.  The global
-                           -- Id is just the selector.  Hmm.  
-                    ; return ((global', rhs) `consOL` spec_binds) }
+                           -- Id is just the selector.  Hmm.
+                     ; return ((global', rhs) `consOL` spec_binds) }
 
         ; export_binds_s <- mapM mk_bind exports
 
-       ; return ((poly_tup_id, poly_tup_rhs) `consOL` 
-                   concatOL export_binds_s) }
+        ; return ((poly_tup_id, poly_tup_rhs) `consOL`
+                    concatOL export_binds_s) }
   where
     inline_env :: IdEnv Id   -- Maps a monomorphic local Id to one with
                              -- the inline pragma from the source
@@ -217,14 +211,14 @@ dsHsBind (PatSynBind{}) = panic "dsHsBind: PatSynBind"
 ------------------------
 makeCorePair :: DynFlags -> Id -> Bool -> Arity -> CoreExpr -> (Id, CoreExpr)
 makeCorePair dflags gbl_id is_default_method dict_arity rhs
-  | is_default_method                -- Default methods are *always* inlined
+  | is_default_method                 -- Default methods are *always* inlined
   = (gbl_id `setIdUnfolding` mkCompulsoryUnfolding rhs, rhs)
 
   | otherwise
   = case inlinePragmaSpec inline_prag of
-         EmptyInlineSpec -> (gbl_id, rhs)
-         NoInline        -> (gbl_id, rhs)
-         Inlinable       -> (gbl_id `setIdUnfolding` inlinable_unf, rhs)
+          EmptyInlineSpec -> (gbl_id, rhs)
+          NoInline        -> (gbl_id, rhs)
+          Inlinable       -> (gbl_id `setIdUnfolding` inlinable_unf, rhs)
           Inline          -> inline_pair
 
   where
@@ -232,8 +226,8 @@ makeCorePair dflags gbl_id is_default_method dict_arity rhs
     inlinable_unf = mkInlinableUnfolding dflags rhs
     inline_pair
        | Just arity <- inlinePragmaSat inline_prag
-       -- Add an Unfolding for an INLINE (but not for NOINLINE)
-       -- And eta-expand the RHS; see Note [Eta-expanding INLINE things]
+        -- Add an Unfolding for an INLINE (but not for NOINLINE)
+        -- And eta-expand the RHS; see Note [Eta-expanding INLINE things]
        , let real_arity = dict_arity + arity
         -- NB: The arity in the InlineRule takes account of the dictionaries
        = ( gbl_id `setIdUnfolding` mkInlineUnfolding (Just real_arity) rhs
@@ -264,22 +258,22 @@ Note [Rules and inlining]
 Common special case: no type or dictionary abstraction
 This is a bit less trivial than you might suppose
 The naive way woudl be to desguar to something like
-       f_lcl = ...f_lcl...     -- The "binds" from AbsBinds
-       M.f = f_lcl             -- Generated from "exports"
+        f_lcl = ...f_lcl...     -- The "binds" from AbsBinds
+        M.f = f_lcl             -- Generated from "exports"
 But we don't want that, because if M.f isn't exported,
-it'll be inlined unconditionally at every call site (its rhs is 
-trivial).  That would be ok unless it has RULES, which would 
+it'll be inlined unconditionally at every call site (its rhs is
+trivial).  That would be ok unless it has RULES, which would
 thereby be completely lost.  Bad, bad, bad.
 
 Instead we want to generate
-       M.f = ...f_lcl...
-       f_lcl = M.f
-Now all is cool. The RULES are attached to M.f (by SimplCore), 
+        M.f = ...f_lcl...
+        f_lcl = M.f
+Now all is cool. The RULES are attached to M.f (by SimplCore),
 and f_lcl is rapidly inlined away.
 
 This does not happen in the same way to polymorphic binds,
 because they desugar to
-       M.f = /\a. let f_lcl = ...f_lcl... in f_lcl
+        M.f = /\a. let f_lcl = ...f_lcl... in f_lcl
 Although I'm a bit worried about whether full laziness might
 float the f_lcl binding out and then inline M.f at its call site
 
@@ -297,7 +291,7 @@ So the overloading is in the nested AbsBinds. A good example is in GHC.Float:
   instance  RealFrac Float  where
     {-# SPECIALIZE round :: Float -> Int #-}
 
-The top-level AbsBinds for $cround has no tyvars or dicts (because the 
+The top-level AbsBinds for $cround has no tyvars or dicts (because the
 instance does not).  But the method is locally overloaded!
 
 Note [Abstracting over tyvars only]
@@ -305,36 +299,36 @@ Note [Abstracting over tyvars only]
 When abstracting over type variable only (not dictionaries), we don't really need to
 built a tuple and select from it, as we do in the general case. Instead we can take
 
-       AbsBinds [a,b] [ ([a,b], fg, fl, _),
-                        ([b],   gg, gl, _) ]
-               { fl = e1
-                 gl = e2
-                  h = e3 }
+        AbsBinds [a,b] [ ([a,b], fg, fl, _),
+                         ([b],   gg, gl, _) ]
+                { fl = e1
+                  gl = e2
+                   h = e3 }
 
 and desugar it to
 
-       fg = /\ab. let B in e1
-       gg = /\b. let a = () in let B in S(e2)
-       h  = /\ab. let B in e3
+        fg = /\ab. let B in e1
+        gg = /\b. let a = () in let B in S(e2)
+        h  = /\ab. let B in e3
 
 where B is the *non-recursive* binding
-       fl = fg a b
-       gl = gg b
-       h  = h a b    -- See (b); note shadowing!
+        fl = fg a b
+        gl = gg b
+        h  = h a b    -- See (b); note shadowing!
 
 Notice (a) g has a different number of type variables to f, so we must
-            use the mkArbitraryType thing to fill in the gaps.  
-            We use a type-let to do that.
+             use the mkArbitraryType thing to fill in the gaps.
+             We use a type-let to do that.
 
-        (b) The local variable h isn't in the exports, and rather than
-            clone a fresh copy we simply replace h by (h a b), where
-            the two h's have different types!  Shadowing happens here,
-            which looks confusing but works fine.
+         (b) The local variable h isn't in the exports, and rather than
+             clone a fresh copy we simply replace h by (h a b), where
+             the two h's have different types!  Shadowing happens here,
+             which looks confusing but works fine.
 
-        (c) The result is *still* quadratic-sized if there are a lot of
-            small bindings.  So if there are more than some small
-            number (10), we filter the binding set B by the free
-            variables of the particular RHS.  Tiresome.
+         (c) The result is *still* quadratic-sized if there are a lot of
+             small bindings.  So if there are more than some small
+             number (10), we filter the binding set B by the free
+             variables of the particular RHS.  Tiresome.
 
 Why got to this trouble?  It's a common case, and it removes the
 quadratic-sized tuple desugaring.  Less clutter, hopefullly faster
@@ -350,13 +344,13 @@ Consider
    foo x = ...
 
 If (foo d) ever gets floated out as a common sub-expression (which can
-happen as a result of method sharing), there's a danger that we never 
+happen as a result of method sharing), there's a danger that we never
 get to do the inlining, which is a Terribly Bad thing given that the
 user said "inline"!
 
 To avoid this we pre-emptively eta-expand the definition, so that foo
 has the arity with which it is declared in the source code.  In this
-example it has arity 2 (one for the Eq and one for x). Doing this 
+example it has arity 2 (one for the Eq and one for x). Doing this
 should mean that (foo d) is a PAP and we don't share it.
 
 Note [Nested arities]
@@ -379,8 +373,8 @@ thought!
 Note [Implementing SPECIALISE pragmas]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Example:
-       f :: (Eq a, Ix b) => a -> b -> Bool
-       {-# SPECIALISE f :: (Ix p, Ix q) => Int -> (p,q) -> Bool #-}
+        f :: (Eq a, Ix b) => a -> b -> Bool
+        {-# SPECIALISE f :: (Ix p, Ix q) => Int -> (p,q) -> Bool #-}
         f = <poly_rhs>
 
 From this the typechecker generates
@@ -390,7 +384,7 @@ From this the typechecker generates
     SpecPrag (wrap_fn :: forall a b. (Eq a, Ix b) => XXX
                       -> forall p q. (Ix p, Ix q) => XXX[ Int/a, (p,q)/b ])
 
-Note that wrap_fn can transform *any* function with the right type prefix 
+Note that wrap_fn can transform *any* function with the right type prefix
     forall ab. (Eq a, Ix b) => XXX
 regardless of XXX.  It's sort of polymorphic in XXX.  This is
 useful: we use the same wrapper to transform each of the class ops, as
@@ -398,26 +392,26 @@ well as the dict.
 
 From these we generate:
 
-    Rule:      forall p, q, (dp:Ix p), (dq:Ix q). 
+    Rule:       forall p, q, (dp:Ix p), (dq:Ix q).
                     f Int (p,q) dInt ($dfInPair dp dq) = f_spec p q dp dq
 
-    Spec bind: f_spec = wrap_fn <poly_rhs>
+    Spec bind:  f_spec = wrap_fn <poly_rhs>
 
-Note that 
+Note that
 
   * The LHS of the rule may mention dictionary *expressions* (eg
     $dfIxPair dp dq), and that is essential because the dp, dq are
     needed on the RHS.
 
-  * The RHS of f_spec, <poly_rhs> has a *copy* of 'binds', so that it 
+  * The RHS of f_spec, <poly_rhs> has a *copy* of 'binds', so that it
     can fully specialise it.
 
 \begin{code}
 ------------------------
 dsSpecs :: CoreExpr     -- Its rhs
         -> TcSpecPrags
-        -> DsM ( OrdList (Id,CoreExpr)         -- Binding for specialised Ids
-              , [CoreRule] )           -- Rules for the Global Ids
+        -> DsM ( OrdList (Id,CoreExpr)  -- Binding for specialised Ids
+               , [CoreRule] )           -- Rules for the Global Ids
 -- See Note [Implementing SPECIALISE pragmas]
 dsSpecs _ IsDefaultMethod = return (nilOL, [])
 dsSpecs poly_rhs (SpecPrags sps)
@@ -425,29 +419,29 @@ dsSpecs poly_rhs (SpecPrags sps)
        ; let (spec_binds_s, rules) = unzip pairs
        ; return (concatOL spec_binds_s, rules) }
 
-dsSpec :: Maybe CoreExpr       -- Just rhs => RULE is for a local binding
-                                       -- Nothing => RULE is for an imported Id
-                               --            rhs is in the Id's unfolding
+dsSpec :: Maybe CoreExpr        -- Just rhs => RULE is for a local binding
+                                -- Nothing => RULE is for an imported Id
+                                --            rhs is in the Id's unfolding
        -> Located TcSpecPrag
        -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))
 dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
   | isJust (isClassOpId_maybe poly_id)
-  = putSrcSpanDs loc $ 
-    do { warnDs (ptext (sLit "Ignoring useless SPECIALISE pragma for class method selector") 
+  = putSrcSpanDs loc $
+    do { warnDs (ptext (sLit "Ignoring useless SPECIALISE pragma for class method selector")
                  <+> quotes (ppr poly_id))
        ; return Nothing  }  -- There is no point in trying to specialise a class op
-                                   -- Moreover, classops don't (currently) have an inl_sat arity set
-                           -- (it would be Just 0) and that in turn makes makeCorePair bleat
+                            -- Moreover, classops don't (currently) have an inl_sat arity set
+                            -- (it would be Just 0) and that in turn makes makeCorePair bleat
 
-  | no_act_spec && isNeverActive rule_act 
-  = putSrcSpanDs loc $ 
+  | no_act_spec && isNeverActive rule_act
+  = putSrcSpanDs loc $
     do { warnDs (ptext (sLit "Ignoring useless SPECIALISE pragma for NOINLINE function:")
                  <+> quotes (ppr poly_id))
        ; return Nothing  }  -- Function is NOINLINE, and the specialiation inherits that
-                                   -- See Note [Activation pragmas for SPECIALISE]
+                            -- See Note [Activation pragmas for SPECIALISE]
 
   | otherwise
-  = putSrcSpanDs loc $ 
+  = putSrcSpanDs loc $
     do { uniq <- newUnique
        ; let poly_name = idName poly_id
              spec_occ  = mkSpecOcc (getOccName poly_name)
@@ -467,14 +461,14 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
              unf_fvs   = stableUnfoldingVars fn_unf `orElse` emptyVarSet
              in_scope  = mkInScopeSet (unf_fvs `unionVarSet` exprsFreeVars args)
              spec_unf  = specUnfolding dflags (mkEmptySubst in_scope) bndrs args fn_unf
-             spec_id   = mkLocalId spec_name spec_ty 
-                           `setInlinePragma` inl_prag
-                           `setIdUnfolding`  spec_unf
+             spec_id   = mkLocalId spec_name spec_ty
+                            `setInlinePragma` inl_prag
+                            `setIdUnfolding`  spec_unf
              rule =  mkRule False {- Not auto -} is_local_id
                         (mkFastString ("SPEC " ++ showPpr dflags poly_name))
-                               rule_act poly_name
-                               rule_bndrs args
-                               (mkVarApps (Var spec_id) bndrs)
+                        rule_act poly_name
+                        rule_bndrs args
+                        (mkVarApps (Var spec_id) bndrs)
 
        ; spec_rhs <- dsHsWrapper spec_co poly_rhs
 
@@ -489,21 +483,21 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
   where
     is_local_id = isJust mb_poly_rhs
     poly_rhs | Just rhs <-  mb_poly_rhs
-             = rhs         -- Local Id; this is its rhs
+             = rhs          -- Local Id; this is its rhs
              | Just unfolding <- maybeUnfoldingTemplate (realIdUnfolding poly_id)
              = unfolding    -- Imported Id; this is its unfolding
-                           -- Use realIdUnfolding so we get the unfolding 
-                           -- even when it is a loop breaker. 
-                           -- We want to specialise recursive functions!
+                            -- Use realIdUnfolding so we get the unfolding
+                            -- even when it is a loop breaker.
+                            -- We want to specialise recursive functions!
              | otherwise = pprPanic "dsImpSpecs" (ppr poly_id)
-                           -- The type checker has checked that it *has* an unfolding
+                            -- The type checker has checked that it *has* an unfolding
 
     id_inl = idInlinePragma poly_id
 
     -- See Note [Activation pragmas for SPECIALISE]
     inl_prag | not (isDefaultInlinePragma spec_inl)    = spec_inl
              | not is_local_id  -- See Note [Specialising imported functions]
-                                -- in OccurAnal
+                                 -- in OccurAnal
              , isStrongLoopBreaker (idOccInfo poly_id) = neverInlinePragma
              | otherwise                               = id_inl
      -- Get the INLINE pragma from SPECIALISE declaration, or,
@@ -522,7 +516,7 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
 
 
 specOnInline :: Name -> MsgDoc
-specOnInline f = ptext (sLit "SPECIALISE pragma on INLINE function probably won't fire:") 
+specOnInline f = ptext (sLit "SPECIALISE pragma on INLINE function probably won't fire:")
                  <+> quotes (ppr f)
 \end{code}
 
@@ -535,7 +529,7 @@ From a user SPECIALISE pragma for f, we generate
 
 We need two pragma-like things:
 
-* spec_fn's inline pragma: inherited from f's inline pragma (ignoring 
+* spec_fn's inline pragma: inherited from f's inline pragma (ignoring
                            activation on SPEC), unless overriden by SPEC INLINE
 
 * Activation of RULE: from SPECIALISE pragma (if activation given)
@@ -557,7 +551,7 @@ SPEC [n] f :: ty            [n]   NOINLINE [k]
                                   copy f's prag
 
 INLINE [k] f
-SPEC [n] f :: ty            [n]   INLINE [k] 
+SPEC [n] f :: ty            [n]   INLINE [k]
                                   copy f's prag
 
 SPEC INLINE [n] f :: ty     [n]   INLINE [n]
@@ -569,9 +563,9 @@ SPEC f :: ty                [n]   INLINE [k]
 
 
 %************************************************************************
-%*                                                                     *
+%*                                                                      *
 \subsection{Adding inline pragmas}
-%*                                                                     *
+%*                                                                      *
 %************************************************************************
 
 \begin{code}
@@ -598,11 +592,11 @@ decomposeRuleLhs orig_bndrs orig_lhs
     Right (bndrs1, fn_var, args)
 
   | Case scrut bndr ty [(DEFAULT, _, body)] <- fun
-  , isDeadBinder bndr  -- Note [Matching seqId]
+  , isDeadBinder bndr   -- Note [Matching seqId]
   , let args' = [Type (idType bndr), Type ty, scrut, body]
   = Right (bndrs1, seqId, args' ++ args)
 
-  | otherwise 
+  | otherwise
   = Left bad_shape_msg
  where
    lhs1       = drop_dicts orig_lhs
@@ -623,7 +617,7 @@ decomposeRuleLhs orig_bndrs orig_lhs
                       2 (vcat [ text "Optimised lhs:" <+> ppr lhs2
                               , text "Orig lhs:" <+> ppr orig_lhs])
    dead_msg bndr = hang (sep [ ptext (sLit "Forall'd") <+> pp_bndr bndr
-                            , ptext (sLit "is not bound in RULE lhs")])
+                             , ptext (sLit "is not bound in RULE lhs")])
                       2 (vcat [ text "Orig bndrs:" <+> ppr orig_bndrs
                               , text "Orig lhs:" <+> ppr orig_lhs
                               , text "optimised lhs:" <+> ppr lhs2 ])
@@ -633,12 +627,12 @@ decomposeRuleLhs orig_bndrs orig_lhs
     | otherwise                         = ptext (sLit "variable") <+> quotes (ppr bndr)
 
    drop_dicts :: CoreExpr -> CoreExpr
-   drop_dicts e 
+   drop_dicts e
        = wrap_lets needed bnds body
      where
        needed = orig_bndr_set `minusVarSet` exprFreeVars body
        (bnds, body) = split_lets (occurAnalyseExpr e)
-                  -- The occurAnalyseExpr drops dead bindings which is
+           -- The occurAnalyseExpr drops dead bindings which is
            -- crucial to ensure that every binding is used later;
            -- which in turn makes wrap_lets work right
 
@@ -663,22 +657,22 @@ decomposeRuleLhs orig_bndrs orig_lhs
 
 Note [Decomposing the left-hand side of a RULE]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-There are several things going on here.  
+There are several things going on here.
 * drop_dicts: see Note [Drop dictionary bindings on rule LHS]
 * simpleOptExpr: see Note [Simplify rule LHS]
 * extra_dict_bndrs: see Note [Free dictionaries]
 
 Note [Drop dictionary bindings on rule LHS]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-drop_dicts drops dictionary bindings on the LHS where possible.  
+drop_dicts drops dictionary bindings on the LHS where possible.
    E.g.  let d:Eq [Int] = $fEqList $fEqInt in f d
      --> f d
-   Reasoning here is that there is only one d:Eq [Int], and so we can 
+   Reasoning here is that there is only one d:Eq [Int], and so we can
    quantify over it. That makes 'd' free in the LHS, but that is later
    picked up by extra_dict_bndrs (Note [Dead spec binders]).
 
    NB 1: We can only drop the binding if the RHS doesn't bind
-         one of the orig_bndrs, which we assume occur on RHS. 
+         one of the orig_bndrs, which we assume occur on RHS.
          Example
             f :: (Eq a) => b -> a -> a
             {-# SPECIALISE f :: Eq a => b -> [a] -> [a] #-}
@@ -687,7 +681,7 @@ drop_dicts drops dictionary bindings on the LHS where possible.
          Of course, the ($dfEqlist d) in the pattern makes it less likely
          to match, but ther is no other way to get d:Eq a
 
-   NB 2: We do drop_dicts *before* simplOptEpxr, so that we expect all 
+   NB 2: We do drop_dicts *before* simplOptEpxr, so that we expect all
          the evidence bindings to be wrapped around the outside of the
          LHS.  (After simplOptExpr they'll usually have been inlined.)
          dsHsWrapper does dependency analysis, so that civilised ones
@@ -728,39 +722,39 @@ Note [Simplify rule LHS]
 ~~~~~~~~~~~~~~~~~~~~~~~~
 simplOptExpr occurrence-analyses and simplifies the LHS:
 
-   (a) Inline any remaining dictionary bindings (which hopefully 
+   (a) Inline any remaining dictionary bindings (which hopefully
        occur just once)
 
    (b) Substitute trivial lets so that they don't get in the way
-       Note that we substitute the function too; we might 
+       Note that we substitute the function too; we might
        have this as a LHS:  let f71 = M.f Int in f71
 
-   (c) Do eta reduction.  To see why, consider the fold/build rule, 
+   (c) Do eta reduction.  To see why, consider the fold/build rule,
        which without simplification looked like:
           fold k z (build (/\a. g a))  ==>  ...
        This doesn't match unless you do eta reduction on the build argument.
        Similarly for a LHS like
-                augment g (build h) 
+         augment g (build h)
        we do not want to get
-                augment (\a. g a) (build h)
+         augment (\a. g a) (build h)
        otherwise we don't match when given an argument like
           augment (\a. h a a) (build h)
 
 Note [Matching seqId]
 ~~~~~~~~~~~~~~~~~~~
 The desugarer turns (seq e r) into (case e of _ -> r), via a special-case hack
-and this code turns it back into an application of seq!  
+and this code turns it back into an application of seq!
 See Note [Rules for seq] in MkId for the details.
 
 Note [Unused spec binders]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider
-       f :: a -> a
-    &n