ghc-mod/Language/Haskell/GhcMod/Debug.hs

module Language.Haskell.GhcMod.Debug (debugInfo, rootInfo, componentInfo) where

import Control.Arrow (first)
import Control.Applicative ((<$>))
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Char
import Text.PrettyPrint
import Language.Haskell.GhcMod.Convert
import Language.Haskell.GhcMod.Monad
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Internal
import Language.Haskell.GhcMod.CabalHelper
import Language.Haskell.GhcMod.Target
import Language.Haskell.GhcMod.Pretty

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

-- | Obtaining debug information.
debugInfo :: IOish m => GhcModT m String
debugInfo = do
    Options {..} <- options
    Cradle {..} <- cradle

    cabal <-
        case cradleCabalFile of
          Just _ -> cabalDebug
          Nothing -> return []

    return $ unlines $
      [ "Root directory:       " ++ cradleRootDir
      , "Current directory:    " ++ cradleCurrentDir
      , "GHC System libraries: " ++ ghcLibDir
      , "GHC user options:     " ++ render (fsep $ map text ghcUserOptions)
      ] ++ cabal

cabalDebug :: IOish m => GhcModT m [String]
cabalDebug = do
    crdl@Cradle {..} <- cradle
    mcs <- resolveGmComponents Nothing =<< mapM (resolveEntrypoint crdl) =<< getComponents
    let entrypoints = Map.map gmcEntrypoints mcs
        graphs      = Map.map gmcHomeModuleGraph mcs
        opts        = Map.map gmcGhcOpts mcs
        srcOpts     = Map.map gmcGhcSrcOpts mcs

    return $
         [ "Cabal file:           " ++ show cradleCabalFile
         , "Cabal entrypoints:\n"       ++ render (nest 4 $
              mapDoc gmComponentNameDoc smpDoc entrypoints)
         , "Cabal components:\n"        ++ render (nest 4 $
              mapDoc gmComponentNameDoc graphDoc graphs)
         , "GHC Cabal options:\n"       ++ render (nest 4 $
              mapDoc gmComponentNameDoc (fsep . map text) opts)
         , "GHC search path options:\n" ++ render (nest 4 $
              mapDoc gmComponentNameDoc (fsep . map text) srcOpts)
         ]

componentInfo :: IOish m => [String] -> GhcModT m String
componentInfo ts = do
    crdl <- cradle
    opts <- targetGhcOptions crdl $ Set.fromList $ map guessModuleFile ts

    return $ unlines $
         [ "GHC Cabal options:\n"       ++ render (nest 4 $ fsep $ map text opts)
         ]

guessModuleFile :: String -> Either FilePath ModuleName
guessModuleFile mn@(h:r)
    | isUpper h && all isAlphaNum r = Right $ mkModuleName mn
guessModuleFile str = Left str

graphDoc :: GmModuleGraph -> Doc
graphDoc GmModuleGraph{..} =
    mapDoc mpDoc' smpDoc' gmgGraph
 where
   smpDoc' smp = vcat $ map mpDoc' $ Set.toList smp
   mpDoc' = text . moduleNameString . mpModule

smpDoc :: Set.Set ModulePath -> Doc
smpDoc smp = vcat $ map mpDoc $ Set.toList smp

mpDoc :: ModulePath -> Doc
mpDoc (ModulePath mn fn) = text (moduleNameString mn) <+> parens (text fn)


mapDoc :: (k -> Doc) -> (a -> Doc) -> Map.Map k a -> Doc
mapDoc kd ad m = vcat $
    map (uncurry ($+$)) $ map (first kd) $ Map.toList $ Map.map (nest 4 . ad) m
----------------------------------------------------------------

-- | Obtaining root information.
rootInfo :: IOish m => GhcModT m String
rootInfo = convert' =<< cradleRootDir <$> cradle