Whitespace

1 files changed, 110 insertions, 109 deletions

diff --git a/compiler/stgSyn/StgLint.lhs b/compiler/stgSyn/StgLint.lhs
index e4ebb08602..2007433c29 100644
--- a/compiler/stgSyn/StgLint.lhs
+++ b/compiler/stgSyn/StgLint.lhs
@@ -17,35 +17,35 @@ module StgLint ( lintStgBindings ) where
 
 import StgSyn
 
-import Bag		( Bag, emptyBag, isEmptyBag, snocBag, bagToList )
-import Id		( Id, idType, isLocalId )
+import Bag              ( Bag, emptyBag, isEmptyBag, snocBag, bagToList )
+import Id               ( Id, idType, isLocalId )
 import VarSet
-import DataCon		( DataCon, dataConInstArgTys, dataConRepType )
-import CoreSyn		( AltCon(..) )
-import PrimOp		( primOpType )
-import Literal		( literalType )
+import DataCon          ( DataCon, dataConInstArgTys, dataConRepType )
+import CoreSyn          ( AltCon(..) )
+import PrimOp           ( primOpType )
+import Literal          ( literalType )
 import Maybes
-import Name		( getSrcLoc )
-import ErrUtils		( Message, mkLocMessage )
-import Type		( mkFunTys, splitFunTys, splitTyConApp_maybe,
-			  isUnLiftedType, isTyVarTy, dropForAlls, Type
-			)
-import TyCon		( isAlgTyCon, isNewTyCon, tyConDataCons )
-import Util		( zipEqual, equalLength )
-import SrcLoc		( srcLocSpan )
+import Name             ( getSrcLoc )
+import ErrUtils         ( Message, mkLocMessage )
+import Type             ( mkFunTys, splitFunTys, splitTyConApp_maybe,
+                          isUnLiftedType, isTyVarTy, dropForAlls, Type
+                        )
+import TyCon            ( isAlgTyCon, isNewTyCon, tyConDataCons )
+import Util             ( zipEqual, equalLength )
+import SrcLoc           ( srcLocSpan )
 import Outputable
 import Control.Monad
 \end{code}
 
 Checks for
-	(a) *some* type errors
-	(b) locally-defined variables used but not defined
+        (a) *some* type errors
+        (b) locally-defined variables used but not defined
 
 
 Note: unless -dverbose-stg is on, display of lint errors will result
 in "panic: bOGUS_LVs".
 
-WARNING: 
+WARNING:
 ~~~~~~~~
 
 This module has suffered bit-rot; it is likely to yield lint errors
@@ -54,9 +54,9 @@ generation.  Solution: don't use it!  (KSW 2000-05).
 
 
 %************************************************************************
-%*									*
+%*                                                                      *
 \subsection{``lint'' for various constructs}
-%*									*
+%*                                                                      *
 %************************************************************************
 
 @lintStgBindings@ is the top-level interface function.
@@ -69,11 +69,12 @@ lintStgBindings whodunnit binds
     case (initL (lint_binds binds)) of
       Nothing  -> binds
       Just msg -> pprPanic "" (vcat [
-			ptext SLIT("*** Stg Lint ErrMsgs: in") <+> text whodunnit <+> ptext SLIT("***"),
-			msg,
-			ptext SLIT("*** Offending Program ***"),
-			pprStgBindings binds,
-			ptext SLIT("*** End of Offense ***")])
+                        ptext SLIT("*** Stg Lint ErrMsgs: in") <+>
+                              text whodunnit <+> ptext SLIT("***"),
+                        msg,
+                        ptext SLIT("*** Offending Program ***"),
+                        pprStgBindings binds,
+                        ptext SLIT("*** End of Offense ***")])
   where
     lint_binds :: [StgBinding] -> LintM ()
 
@@ -95,7 +96,7 @@ lintStgVar v = do checkInScope v
 \end{code}
 
 \begin{code}
-lintStgBinds :: StgBinding -> LintM [Id]		-- Returns the binders
+lintStgBinds :: StgBinding -> LintM [Id] -- Returns the binders
 lintStgBinds (StgNonRec binder rhs) = do
     lint_binds_help (binder,rhs)
     return [binder]
@@ -109,21 +110,21 @@ lintStgBinds (StgRec pairs)
 
 lint_binds_help (binder, rhs)
   = addLoc (RhsOf binder) $ do
-	-- Check the rhs
-	maybe_rhs_ty <- lintStgRhs rhs
+        -- Check the rhs
+        maybe_rhs_ty <- lintStgRhs rhs
 
-	-- Check binder doesn't have unlifted type
-	checkL (not (isUnLiftedType binder_ty))
-	       (mkUnLiftedTyMsg binder rhs)
+        -- Check binder doesn't have unlifted type
+        checkL (not (isUnLiftedType binder_ty))
+               (mkUnLiftedTyMsg binder rhs)
 
-	-- Check match to RHS type
-	case maybe_rhs_ty of
-	  Nothing     -> return ()
-	  Just rhs_ty -> checkTys  binder_ty
-				   rhs_ty
-				   (mkRhsMsg binder rhs_ty)
+        -- Check match to RHS type
+        case maybe_rhs_ty of
+          Nothing     -> return ()
+          Just rhs_ty -> checkTys binder_ty
+                                  rhs_ty
+                                  (mkRhsMsg binder rhs_ty)
 
-	return ()
+        return ()
   where
     binder_ty = idType binder
 \end{code}
@@ -148,7 +149,7 @@ lintStgRhs (StgRhsCon _ con args) = runMaybeT $ do
 \end{code}
 
 \begin{code}
-lintStgExpr :: StgExpr -> LintM (Maybe Type)	-- Nothing if error found
+lintStgExpr :: StgExpr -> LintM (Maybe Type) -- Nothing if error found
 
 lintStgExpr (StgLit l) = return (Just (literalType l))
 
@@ -164,8 +165,8 @@ lintStgExpr e@(StgConApp con args) = runMaybeT $ do
     con_ty = dataConRepType con
 
 lintStgExpr e@(StgOpApp (StgFCallOp _ _) args res_ty) = runMaybeT $ do
-	-- We don't have enough type information to check
-	-- the application; ToDo
+        -- We don't have enough type information to check
+        -- the application; ToDo
     maybe_arg_tys <- mapM (MaybeT . lintStgArg) args
     return res_ty
 
@@ -191,7 +192,7 @@ lintStgExpr (StgLetNoEscape _ _ binds body) = do
       addInScopeVars binders $
         lintStgExpr body
 
-lintStgExpr (StgSCC _ expr)	= lintStgExpr expr
+lintStgExpr (StgSCC _ expr) = lintStgExpr expr
 
 lintStgExpr e@(StgCase scrut _ _ bndr _ alts_type alts) = runMaybeT $ do
     MaybeT $ lintStgExpr scrut
@@ -204,7 +205,7 @@ lintStgExpr e@(StgCase scrut _ _ bndr _ alts_type alts) = runMaybeT $ do
         PolyAlt      -> return ()
 
     MaybeT $ trace (showSDoc (ppr e)) $ do
-	-- we only allow case of tail-call or primop.
+        -- we only allow case of tail-call or primop.
      case scrut of
         StgApp _ _     -> return ()
         StgConApp _ _  -> return ()
@@ -214,28 +215,28 @@ lintStgExpr e@(StgCase scrut _ _ bndr _ alts_type alts) = runMaybeT $ do
      addInScopeVars [bndr] $
         lintStgAlts alts scrut_ty
   where
-    scrut_ty	  = idType bndr
+    scrut_ty      = idType bndr
     bad_bndr      = mkDefltMsg bndr
     check_bndr tc = case splitTyConApp_maybe scrut_ty of
-			Just (bndr_tc, _) -> checkL (tc == bndr_tc) bad_bndr
-			Nothing		  -> addErrL bad_bndr
+                        Just (bndr_tc, _) -> checkL (tc == bndr_tc) bad_bndr
+                        Nothing           -> addErrL bad_bndr
 
 
 lintStgAlts :: [StgAlt]
-	    -> Type 		-- Type of scrutinee
-	    -> LintM (Maybe Type)	-- Type of alternatives
+            -> Type               -- Type of scrutinee
+            -> LintM (Maybe Type) -- Type of alternatives
 
 lintStgAlts alts scrut_ty = do
     maybe_result_tys <- mapM (lintAlt scrut_ty) alts
 
-	 -- Check the result types
+    -- Check the result types
     case catMaybes (maybe_result_tys) of
       []             -> return Nothing
 
       (first_ty:tys) -> do mapM_ check tys
                            return (Just first_ty)
-	where
-	  check ty = checkTys first_ty ty (mkCaseAltMsg alts)
+        where
+          check ty = checkTys first_ty ty (mkCaseAltMsg alts)
 
 lintAlt scrut_ty (DEFAULT, _, _, rhs)
  = lintStgExpr rhs
@@ -246,37 +247,37 @@ lintAlt scrut_ty (LitAlt lit, _, _, rhs) = do
 
 lintAlt scrut_ty (DataAlt con, args, _, rhs) = do
     case splitTyConApp_maybe scrut_ty of
-      Just (tycon, tys_applied) | isAlgTyCon tycon && 
-				  not (isNewTyCon tycon) -> do
-	 let
-	   cons    = tyConDataCons tycon
-	   arg_tys = dataConInstArgTys con tys_applied
-		-- This almost certainly does not work for existential constructors
-	 
-	 checkL (con `elem` cons) (mkAlgAltMsg2 scrut_ty con)
-	 checkL (equalLength arg_tys args) (mkAlgAltMsg3 con args)
-	 mapM_ check (zipEqual "lintAlgAlt:stg" arg_tys args)
-	 return ()
+      Just (tycon, tys_applied) | isAlgTyCon tycon &&
+                                  not (isNewTyCon tycon) -> do
+         let
+           cons    = tyConDataCons tycon
+           arg_tys = dataConInstArgTys con tys_applied
+                -- This almost certainly does not work for existential constructors
+
+         checkL (con `elem` cons) (mkAlgAltMsg2 scrut_ty con)
+         checkL (equalLength arg_tys args) (mkAlgAltMsg3 con args)
+         mapM_ check (zipEqual "lintAlgAlt:stg" arg_tys args)
+         return ()
       other ->
-	 addErrL (mkAltMsg1 scrut_ty)
+         addErrL (mkAltMsg1 scrut_ty)
 
     addInScopeVars args $
-	 lintStgExpr rhs
+         lintStgExpr rhs
   where
     check (ty, arg) = checkTys ty (idType arg) (mkAlgAltMsg4 ty arg)
 
     -- elem: yes, the elem-list here can sometimes be long-ish,
     -- but as it's use-once, probably not worth doing anything different
     -- We give it its own copy, so it isn't overloaded.
-    elem _ []	    = False
+    elem _ []       = False
     elem x (y:ys)   = x==y || elem x ys
 \end{code}
 
 
 %************************************************************************
-%*									*
+%*                                                                      *
 \subsection[lint-monad]{The Lint monad}
-%*									*
+%*                                                                      *
 %************************************************************************
 
 \begin{code}
@@ -288,9 +289,9 @@ newtype LintM a = LintM
     }
 
 data LintLocInfo
-  = RhsOf Id		-- The variable bound
-  | LambdaBodyOf [Id]	-- The lambda-binder
-  | BodyOfLetRec [Id]	-- One of the binders
+  = RhsOf Id            -- The variable bound
+  | LambdaBodyOf [Id]   -- The lambda-binder
+  | BodyOfLetRec [Id]   -- One of the binders
 
 dumpLoc (RhsOf v) =
   (srcLocSpan (getSrcLoc v), ptext SLIT(" [RHS of ") <> pp_binders [v] <> char ']' )
@@ -314,9 +315,9 @@ initL :: LintM a -> Maybe Message
 initL (LintM m)
   = case (m [] emptyVarSet emptyBag) of { (_, errs) ->
     if isEmptyBag errs then
-	Nothing
+        Nothing
     else
-	Just (vcat (punctuate (text "") (bagToList errs)))
+        Just (vcat (punctuate (text "") (bagToList errs)))
     }
 
 instance Monad LintM where
@@ -347,8 +348,8 @@ addErr :: Bag Message -> Message -> [LintLocInfo] -> Bag Message
 addErr errs_so_far msg locs
   = errs_so_far `snocBag` mk_msg locs
   where
-    mk_msg (loc:_) = let (l,hdr) = dumpLoc loc 
-		     in  mkLocMessage l (hdr $$ msg)
+    mk_msg (loc:_) = let (l,hdr) = dumpLoc loc
+                     in  mkLocMessage l (hdr $$ msg)
     mk_msg []      = msg
 
 addLoc :: LintLocInfo -> LintM a -> LintM a
@@ -362,7 +363,7 @@ addInScopeVars ids m = LintM $ \loc scope errs
     -- For now, it's just a "trace"; we may make
     -- a real error out of it...
     let
-	new_set = mkVarSet ids
+        new_set = mkVarSet ids
     in
 --  After adding -fliberate-case, Simon decided he likes shadowed
 --  names after all.  WDP 94/07
@@ -379,10 +380,10 @@ applications and type lambdas that we use to calculate accurate types
 have long since disappeared.
 
 \begin{code}
-checkFunApp :: Type 		    -- The function type
-	    -> [Type]		    -- The arg type(s)
-	    -> Message		    -- Error messgae
-	    -> LintM (Maybe Type)   -- The result type
+checkFunApp :: Type                 -- The function type
+            -> [Type]               -- The arg type(s)
+            -> Message              -- Error messgae
+            -> LintM (Maybe Type)   -- The result type
 
 checkFunApp fun_ty arg_tys msg = LintM checkFunApp'
  where
@@ -391,19 +392,19 @@ checkFunApp fun_ty arg_tys msg = LintM checkFunApp'
    where
     (expected_arg_tys, res_ty) = splitFunTys (dropForAlls fun_ty)
 
-    cfa res_ty expected []	-- Args have run out; that's fine
+    cfa res_ty expected []      -- Args have run out; that's fine
       = (Just (mkFunTys expected res_ty), errs)
 
-    cfa res_ty [] arg_tys	-- Expected arg tys ran out first;
-				-- first see if res_ty is a tyvar template;
-				-- otherwise, maybe res_ty is a
-				-- dictionary type which is actually a function?
+    cfa res_ty [] arg_tys       -- Expected arg tys ran out first;
+                                -- first see if res_ty is a tyvar template;
+                                -- otherwise, maybe res_ty is a
+                                -- dictionary type which is actually a function?
       | isTyVarTy res_ty
       = (Just res_ty, errs)
       | otherwise
       = case splitFunTys res_ty of
-	  ([], _) 		  -> (Nothing, addErr errs msg loc)	-- Too many args
-	  (new_expected, new_res) -> cfa new_res new_expected arg_tys
+          ([], _)                 -> (Nothing, addErr errs msg loc)     -- Too many args
+          (new_expected, new_res) -> cfa new_res new_expected arg_tys
 
     cfa res_ty (expected_arg_ty:expected_arg_tys) (arg_ty:arg_tys)
       = cfa res_ty expected_arg_tys arg_tys
@@ -413,9 +414,9 @@ checkFunApp fun_ty arg_tys msg = LintM checkFunApp'
 checkInScope :: Id -> LintM ()
 checkInScope id = LintM $ \loc scope errs
  -> if isLocalId id && not (id `elemVarSet` scope) then
-	((), addErr errs (hsep [ppr id, ptext SLIT("is out of scope")]) loc)
+        ((), addErr errs (hsep [ppr id, ptext SLIT("is out of scope")]) loc)
     else
-	((), errs)
+        ((), errs)
 
 checkTys :: Type -> Type -> Message -> LintM ()
 checkTys ty1 ty2 msg = LintM $ \loc scope errs
@@ -428,53 +429,53 @@ checkTys ty1 ty2 msg = LintM $ \loc scope errs
 mkCaseAltMsg :: [StgAlt] -> Message
 mkCaseAltMsg alts
   = ($$) (text "In some case alternatives, type of alternatives not all same:")
-	    (empty) -- LATER: ppr alts
+            (empty) -- LATER: ppr alts
 
 mkDefltMsg :: Id -> Message
 mkDefltMsg bndr
   = ($$) (ptext SLIT("Binder of a case expression doesn't match type of scrutinee:"))
-	    (panic "mkDefltMsg")
+            (panic "mkDefltMsg")
 
 mkFunAppMsg :: Type -> [Type] -> StgExpr -> Message
 mkFunAppMsg fun_ty arg_tys expr
   = vcat [text "In a function application, function type doesn't match arg types:",
-	      hang (ptext SLIT("Function type:")) 4 (ppr fun_ty),
-	      hang (ptext SLIT("Arg types:")) 4 (vcat (map (ppr) arg_tys)),
-	      hang (ptext SLIT("Expression:")) 4 (ppr expr)]
+              hang (ptext SLIT("Function type:")) 4 (ppr fun_ty),
+              hang (ptext SLIT("Arg types:")) 4 (vcat (map (ppr) arg_tys)),
+              hang (ptext SLIT("Expression:")) 4 (ppr expr)]
 
 mkRhsConMsg :: Type -> [Type] -> Message
 mkRhsConMsg fun_ty arg_tys
   = vcat [text "In a RHS constructor application, con type doesn't match arg types:",
-	      hang (ptext SLIT("Constructor type:")) 4 (ppr fun_ty),
-	      hang (ptext SLIT("Arg types:")) 4 (vcat (map (ppr) arg_tys))]
+              hang (ptext SLIT("Constructor type:")) 4 (ppr fun_ty),
+              hang (ptext SLIT("Arg types:")) 4 (vcat (map (ppr) arg_tys))]
 
 mkAltMsg1 :: Type -> Message
 mkAltMsg1 ty
   = ($$) (text "In a case expression, type of scrutinee does not match patterns")
-	 (ppr ty)
+         (ppr ty)
 
 mkAlgAltMsg2 :: Type -> DataCon -> Message
 mkAlgAltMsg2 ty con
   = vcat [
-	text "In some algebraic case alternative, constructor is not a constructor of scrutinee type:",
-	ppr ty,
-	ppr con
+        text "In some algebraic case alternative, constructor is not a constructor of scrutinee type:",
+        ppr ty,
+        ppr con
     ]
 
 mkAlgAltMsg3 :: DataCon -> [Id] -> Message
 mkAlgAltMsg3 con alts
   = vcat [
-	text "In some algebraic case alternative, number of arguments doesn't match constructor:",
-	ppr con,
-	ppr alts
+        text "In some algebraic case alternative, number of arguments doesn't match constructor:",
+        ppr con,
+        ppr alts
     ]
 
 mkAlgAltMsg4 :: Type -> Id -> Message
 mkAlgAltMsg4 ty arg
   = vcat [
-	text "In some algebraic case alternative, type of argument doesn't match data constructor:",
-	ppr ty,
-	ppr arg
+        text "In some algebraic case alternative, type of argument doesn't match data constructor:",
+        ppr ty,
+        ppr arg
     ]
 
 mkCaseOfCaseMsg :: StgExpr -> Message
@@ -484,13 +485,13 @@ mkCaseOfCaseMsg e
 mkRhsMsg :: Id -> Type -> Message
 mkRhsMsg binder ty
   = vcat [hsep [ptext SLIT("The type of this binder doesn't match the type of its RHS:"),
-		     ppr binder],
-	      hsep [ptext SLIT("Binder's type:"), ppr (idType binder)],
-	      hsep [ptext SLIT("Rhs type:"), ppr ty]
-	     ]
+                     ppr binder],
+              hsep [ptext SLIT("Binder's type:"), ppr (idType binder)],
+              hsep [ptext SLIT("Rhs type:"), ppr ty]
+             ]
 
 mkUnLiftedTyMsg binder rhs
-  = (ptext SLIT("Let(rec) binder") <+> quotes (ppr binder) <+> 
+  = (ptext SLIT("Let(rec) binder") <+> quotes (ppr binder) <+>
      ptext SLIT("has unlifted type") <+> quotes (ppr (idType binder)))
     $$
     (ptext SLIT("RHS:") <+> ppr rhs)