ghc-mod/Language/Haskell/GhcMod/Debug.hs
2015-03-28 19:13:48 +01:00

94 lines
3.2 KiB
Haskell

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