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

172 lines
5.8 KiB
Haskell
Raw Normal View History

2015-03-28 01:33:42 +00:00
module Language.Haskell.GhcMod.Debug (debugInfo, rootInfo, componentInfo) where
2013-03-04 02:21:41 +00:00
import Control.Arrow (first)
2015-04-13 22:51:03 +00:00
import Control.Applicative
import Control.Monad
2015-10-30 18:05:41 +00:00
import Control.Monad.Trans.Journal
import qualified Data.Map as Map
import qualified Data.Set as Set
2015-03-28 01:33:42 +00:00
import Data.Char
import Data.Version
2015-04-13 22:51:03 +00:00
import Data.List.Split
import System.Directory
import Text.PrettyPrint
import Language.Haskell.GhcMod.Monad
2013-05-17 01:00:01 +00:00
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Internal
import Language.Haskell.GhcMod.Target
import Language.Haskell.GhcMod.Pretty
2015-04-13 22:51:03 +00:00
import Language.Haskell.GhcMod.Utils
import Language.Haskell.GhcMod.Cradle
2015-09-15 03:25:00 +00:00
import Language.Haskell.GhcMod.Stack
import Language.Haskell.GhcMod.Output
import Paths_ghc_mod (version)
import Config (cProjectVersion)
2013-03-04 02:21:41 +00:00
----------------------------------------------------------------
2013-05-20 05:28:56 +00:00
-- | Obtaining debug information.
debugInfo :: IOish m => GhcModT m String
debugInfo = do
Options {..} <- options
Cradle {..} <- cradle
2014-03-20 07:21:48 +00:00
cabal <-
case cradleProject of
2015-08-12 07:25:13 +00:00
CabalProject -> cabalDebug
StackProject {} -> (++) <$> stackPaths <*> cabalDebug
2015-08-12 07:25:13 +00:00
_ -> return []
pkgOpts <- packageGhcOptions
readProc <- gmReadProcess
ghcVersion <- liftIO $
dropWhileEnd isSpace <$> readProc "ghc" ["--numeric-version"] ""
return $ unlines $
[ "Version: ghc-mod-" ++ showVersion version
, "Library GHC Version: " ++ cProjectVersion
, "System GHC Version: " ++ ghcVersion
, "Root directory: " ++ cradleRootDir
, "Current directory: " ++ cradleCurrentDir
, "GHC Package flags:\n" ++ render (nest 4 $
fsep $ map text pkgOpts)
, "GHC System libraries: " ++ ghcLibDir
] ++ cabal
2015-09-02 03:30:00 +00:00
stackPaths :: IOish m => GhcModT m [String]
stackPaths = do
Cradle { cradleProject = StackProject senv } <- cradle
ghc <- getStackGhcPath senv
ghcPkg <- getStackGhcPkgPath senv
2015-09-02 03:30:00 +00:00
return $
[ "Stack ghc executable: " ++ show ghc
, "Stack ghc-pkg executable:" ++ show ghcPkg
]
cabalDebug :: IOish m => GhcModT m [String]
cabalDebug = do
Cradle {..} <- cradle
mcs <- cabalResolvedComponents
let entrypoints = Map.map gmcEntrypoints mcs
graphs = Map.map gmcHomeModuleGraph mcs
opts = Map.map gmcGhcOpts mcs
srcOpts = Map.map gmcGhcSrcOpts mcs
readProc <- gmReadProcess
cabalExists <- liftIO $ (/=Nothing) <$> findExecutable "cabal"
cabalInstVersion <-
if cabalExists
then liftIO $
dropWhileEnd isSpace <$> readProc "cabal" ["--numeric-version"] ""
else return ""
packages <- liftIO $ readProc "ghc-pkg" ["list", "--simple-output"] ""
let cabalPackages = filter ((== ["Cabal"]) . take 1 . splitOn "-") $ splitWhen isSpace packages
return $
[ "cabal-install Version: " ++ cabalInstVersion
, "Cabal Library Versions:\n" ++ render (nest 4 $
fsep $ map text cabalPackages)
, "Cabal file: " ++ show cradleCabalFile
, "Project: " ++ show cradleProject
, "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)
]
2015-03-28 01:33:42 +00:00
componentInfo :: IOish m => [String] -> GhcModT m String
componentInfo ts = do
2015-04-12 00:48:05 +00:00
-- TODO: most of this is copypasta of targetGhcOptions. Factor out more
-- useful function from there.
2015-03-28 01:33:42 +00:00
crdl <- cradle
2015-04-13 22:51:03 +00:00
sefnmn <- Set.fromList `liftM` mapM guessModuleFile ts
mcs <- cabalResolvedComponents
2015-04-12 00:48:05 +00:00
let
mdlcs = moduleComponents mcs `zipMap` Set.toList sefnmn
candidates = findCandidates $ map snd mdlcs
cn = pickComponent candidates
opts <- targetGhcOptions crdl sefnmn
2015-03-28 01:33:42 +00:00
return $ unlines $
2015-04-12 00:48:05 +00:00
[ "Matching Components:\n" ++ render (nest 4 $
alistDoc (either text mnDoc) (setDoc gmComponentNameDoc) mdlcs)
, "Picked Component:\n" ++ render (nest 4 $
gmComponentNameDoc cn)
, "GHC Cabal options:\n" ++ render (nest 4 $ fsep $ map text opts)
2015-03-28 01:33:42 +00:00
]
2015-04-12 00:48:05 +00:00
where
zipMap f l = l `zip` (f `map` l)
2015-03-28 01:33:42 +00:00
2015-04-13 22:51:03 +00:00
guessModuleFile :: MonadIO m => String -> m (Either FilePath ModuleName)
guessModuleFile m
| (isUpper . head .&&. (all $ all $ isAlphaNum .||. (=='.')) . splitOn ".") m =
return $ Right $ mkModuleName m
where
infixr 1 .||.
infixr 2 .&&.
(.||.) = liftA2 (||)
(.&&.) = liftA2 (&&)
guessModuleFile str = Left `liftM` liftIO (canonFilePath str)
2015-03-28 01:33:42 +00:00
graphDoc :: GmModuleGraph -> Doc
graphDoc GmModuleGraph{..} =
2015-04-12 00:48:05 +00:00
mapDoc mpDoc smpDoc' gmgGraph
where
smpDoc' smp = vcat $ map mpDoc' $ Set.toList smp
mpDoc' = text . moduleNameString . mpModule
2015-04-12 00:48:05 +00:00
setDoc :: (a -> Doc) -> Set.Set a -> Doc
setDoc f s = vcat $ map f $ Set.toList s
smpDoc :: Set.Set ModulePath -> Doc
2015-04-12 00:48:05 +00:00
smpDoc smp = setDoc mpDoc smp
mpDoc :: ModulePath -> Doc
mpDoc (ModulePath mn fn) = text (moduleNameString mn) <+> parens (text fn)
2015-04-12 00:48:05 +00:00
mnDoc :: ModuleName -> Doc
mnDoc mn = text (moduleNameString mn)
alistDoc :: Ord k => (k -> Doc) -> (a -> Doc) -> [(k, a)] -> Doc
alistDoc fk fa alist = mapDoc fk fa (Map.fromList alist)
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
2014-03-20 07:21:48 +00:00
----------------------------------------------------------------
-- | Obtaining root information.
2015-10-30 18:05:41 +00:00
rootInfo :: forall m. (IOish m, GmOut m) => m String
rootInfo = (++"\n") . cradleRootDir <$> fst `liftM` (runJournalT findCradle :: m (Cradle, GhcModLog))