HsDeadCodeElim.hs

module HsDeadCodeElim where

-------------------------------------------------------------------------------

-- This module implements dead code elimination for Haskell.
-- Under construction!!!
-- We are not yet faithfully dealing with qualified vs. unqualified names.
-- Same holds for module level analysis.

-------------------------------------------------------------------------------

import Language.Haskell.Syntax
import HsModuleCollection
import SyntaxTermInstances
import StrategyLib
import HsFreeNames
import Monad
import List

-- Dead code elimination ------------------------------------------------------

-- This function removes unused local declarations

hsElimDeadCode :: (Term t, MonadPlus m) => t -> m t
hsElimDeadCode = applyTP (full_tdTP worker)
  where
    worker = idTP `adhocTP` match

    match (HsMatch sl fun pats rhs {-where-} decls)
      = do (pf,pd) <- hsFreeAndDeclared pats
           (rf,rd) <- hsFreeAndDeclared rhs
           (df,dd) <- hsFreeAndDeclaredList decls
           decls'  <- filterM (hsTestDecl ((df `union` rf) \\ pd)) decls
           return (HsMatch sl fun pats rhs decls')

hsTestDecl :: MonadPlus m => [HsQName] -> HsDecl -> m Bool
hsTestDecl names decl
  = do (_,[name]) <- hsFreeAndDeclared decl
       return $ name `elem` names
       
-- Application extraction ----------------------------------------------------

-- This function removed unused top declarations from
-- a list of modules, until it reaches a fixpoint.

hsExtrAppl :: MonadPlus m
         => [(ModuleName,[ModuleName],HsModule)] 
         -> m [(ModuleName,[ModuleName],HsModule)]

hsExtrAppl l@(h:t)
  = do l' <- mapM worker t >>= return . (:) h
       if l==l' then return l else hsExtrAppl l'
  where
    worker (n,i,m@(HsModule sl n' i' e' ds))
      = do clients <- return $ filter (\e@(_,i',_) -> n `elem` i') l
           (imp,_) <- hsFreeAndDeclared clients
           ds'     <- filterM (hsTestDecl imp) ds
           return (n,i,HsModule sl n' i' e' ds')

-- Missing instance generated by DrIFT --------------------------------------	   
	   
instance Eq HsModule where
    (HsModule aa ab ac ad ae) == (HsModule aa' ab' ac' ad' ae') 
           = aa == aa' && ab == ab' && ac == ac' && ad == ad' && ae == ae'
    _ == _ = False

-------------------------------------------------------------------------------