GHC api annoyances - I just want to show some things

ghc-api-annoyances.hs

module List (listModules) where

import Control.Applicative
import Control.Monad
import Data.List
import GHC
import GHCApi
import GhcMonad
import Packages
import Types
import UniqFM
import Module
import Outputable
import Fingerprint
import Doc
import LoadIface
import HscMain          ( newHscEnv )
import HscTypes

import TcRnMonad
import BinIface

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

listModules :: Options -> IO String
listModules opt = convert opt . nub . sort <$> list opt

-- list :: Options -> IO [String]
-- list opt = withGHCDummyFile $ do
--     initializeFlags opt
--     getExposedModules <$> getSessionDynFlags
--   where
--     getExposedModules = map moduleNameString
--                       . concatMap exposedModules
--                       . eltsUFM . pkgIdMap . pkgState

showOutputable :: Outputable a => DynFlags -> a -> String
showOutputable dflag = unwords . lines . showUnqualifiedPage dflag . ppr


doShowIface :: DynFlags -> FilePath -> IO ()
doShowIface dflags file = do
  hsc_env <- newHscEnv dflags
  showIface hsc_env file


getIfaceFromHiFile :: DynFlags -> FilePath -> IO ModIface
getIfaceFromHiFile dflags filename = do
  hsc_env <- newHscEnv dflags -- TODO reuse env?

  -- skip the hi way check; we don't want to worry about profiled vs.
  -- non-profiled interfaces, for example.
  iface <- initTcRnIf 's' hsc_env () () $
      readBinIface IgnoreHiWay TraceBinIFaceReading filename
  return iface

-- getIface :: DynFlags -> Module -> IO ModIface
-- getIface dflags m = do
--   hsc_env <- newHscEnv dflags -- TODO reuse env?

--   -- skip the hi way check; we don't want to worry about profiled vs.
--   -- non-profiled interfaces, for example.
--   iface <- initTcRnIf 's' hsc_env () () $
--     loadModuleInterface Outputable.empty mod
--   return iface


showUsage dflags UsagePackageModule{ usg_mod = m, usg_mod_hash = h } = "Package " ++ showSDoc dflags (pprModule m) ++ "                " ++ showOutputable dflags h
showUsage dflags UsageHomeModule{ usg_mod_name = n, usg_mod_hash = h } = "Home " ++ showSDoc dflags (pprModuleName n) ++ "                " ++ showOutputable dflags h


data UsedModule = UsedModule Module Fingerprint


list :: Options -> IO [String]
list opt = withGHCDummyFile $ do
    initializeFlags opt
    dflags <- getSessionDynFlags
    let showO :: Outputable a => a -> String
        showO = showOutputable dflags

    let m = mkModule (stringToPackageId "iteratee-0.8.4.2") (mkModuleName "Data.Iteratee")

    Just mi <- getModuleInfo m

    let Just info = modInfoIface mi

    let hash = mi_mod_hash info

    iface <- liftIO $ getIfaceFromHiFile dflags "/home/niklas/tsuru/trader/src/trader/dist/build/Tools/SReport/Main.hi"
    -- liftIO $ print ("iface", showSDoc dflags $ pprModIface iface)

    let ModIface{ mi_usages = usages } = iface
        usedModules = [ UsedModule m h | UsagePackageModule{ usg_mod = m, usg_mod_hash = h } <- usages ]

    liftIO $ print "usages"
    liftIO $ mapM (putStrLn . showUsage dflags) usages

    --
    liftIO $ putStrLn ""
    liftIO $ print "modinfos"

    -- let packageModules = [ m | UsagePackageModule{ usg_mod = m } <- usages ]

    let getHashInPackageDB m = do m'mi <- getModuleInfo m
                                  return $ mi_mod_hash <$> (modInfoIface =<< m'mi)

    res <- zip usedModules <$> mapM (\(UsedModule m _) -> getHashInPackageDB m) usedModules

    liftIO $ mapM_ print [ (showO m, showO <$> hash) | (UsedModule m _, hash) <- res ]

    forM usedModules $ \(UsedModule m wantedHash) -> do

      -- Check if hash available in package DB is the wanted one
      m'packageDBHash <- getHashInPackageDB m
      return ()
      liftIO $ case m'packageDBHash of
        Nothing                  -> putStrLn $ "Module has no hash: " ++ showO m
        Just h | h /= wantedHash -> putStrLn $ "Wanted hash is different from package DB hash: " ++ showO m
        _                        -> return ()


    return [""]
  where
    getExposedModules = map moduleNameString
                      . concatMap exposedModules
                      . eltsUFM . pkgIdMap . pkgState