183 lines
6.1 KiB
Haskell
183 lines
6.1 KiB
Haskell
module GhcModExe.Debug (debugInfo, rootInfo, componentInfo) where
|
|
|
|
import Control.Arrow (first)
|
|
import Control.Applicative
|
|
import Control.Monad
|
|
import qualified Data.Map as Map
|
|
import qualified Data.Set as Set
|
|
import Data.Char
|
|
import Data.Maybe
|
|
import Data.Version
|
|
import Data.List.Split
|
|
import System.Directory
|
|
|
|
import GhcModExe.Internal
|
|
import Language.Haskell.GhcMod.Cradle
|
|
import Language.Haskell.GhcMod.Monad
|
|
import Language.Haskell.GhcMod.Output
|
|
import Language.Haskell.GhcMod.Pretty
|
|
import Language.Haskell.GhcMod.Stack
|
|
import Language.Haskell.GhcMod.Target
|
|
import Language.Haskell.GhcMod.Types
|
|
import Language.Haskell.GhcMod.Utils
|
|
|
|
import Paths_ghc_mod (version)
|
|
|
|
import Config (cProjectVersion)
|
|
import Pretty
|
|
|
|
----------------------------------------------------------------
|
|
|
|
-- | Obtaining debug information.
|
|
debugInfo :: IOish m => GhcModT m String
|
|
debugInfo = do
|
|
Options {..} <- options
|
|
Cradle {..} <- cradle
|
|
|
|
[ghcPath, ghcPkgPath] <- liftIO $
|
|
case cradleProject of
|
|
StackProject se ->
|
|
catMaybes <$> sequence [getStackGhcPath se, getStackGhcPkgPath se]
|
|
_ ->
|
|
return ["ghc", "ghc-pkg"]
|
|
|
|
cabal <-
|
|
case cradleProject of
|
|
CabalProject -> cabalDebug ghcPkgPath
|
|
StackProject {} -> (++) <$> stackPaths <*> cabalDebug ghcPkgPath
|
|
_ -> return []
|
|
|
|
pkgOpts <- packageGhcOptions
|
|
|
|
readProc <- gmReadProcess
|
|
|
|
ghcVersion <- liftIO $
|
|
dropWhileEnd isSpace <$> readProc ghcPath ["--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" ++ renderGm (nest 4 $
|
|
fsep $ map text pkgOpts)
|
|
, "GHC System libraries: " ++ ghcLibDir
|
|
] ++ cabal
|
|
|
|
stackPaths :: IOish m => GhcModT m [String]
|
|
stackPaths = do
|
|
Cradle { cradleProject = StackProject senv } <- cradle
|
|
ghc <- getStackGhcPath senv
|
|
ghcPkg <- getStackGhcPkgPath senv
|
|
return $
|
|
[ "Stack ghc executable: " ++ show ghc
|
|
, "Stack ghc-pkg executable:" ++ show ghcPkg
|
|
]
|
|
|
|
cabalDebug :: IOish m => FilePath -> GhcModT m [String]
|
|
cabalDebug ghcPkgPath = 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 ghcPkgPath ["list", "--simple-output"] ""
|
|
let cabalPackages = filter ((== ["Cabal"]) . take 1 . splitOn "-") $ splitWhen isSpace packages
|
|
|
|
return $
|
|
[ "cabal-install Version: " ++ cabalInstVersion
|
|
, "Cabal Library Versions:\n" ++ renderGm (nest 4 $
|
|
fsep $ map text cabalPackages)
|
|
, "Cabal file: " ++ show cradleCabalFile
|
|
, "Project: " ++ show cradleProject
|
|
, "Cabal entrypoints:\n" ++ renderGm (nest 4 $
|
|
mapDoc gmComponentNameDoc smpDoc entrypoints)
|
|
, "Cabal components:\n" ++ renderGm (nest 4 $
|
|
mapDoc gmComponentNameDoc graphDoc graphs)
|
|
, "GHC Cabal options:\n" ++ renderGm (nest 4 $
|
|
mapDoc gmComponentNameDoc (fsep . map text) opts)
|
|
, "GHC search path options:\n" ++ renderGm (nest 4 $
|
|
mapDoc gmComponentNameDoc (fsep . map text) srcOpts)
|
|
]
|
|
|
|
componentInfo :: IOish m => [String] -> GhcModT m String
|
|
componentInfo ts = do
|
|
-- TODO: most of this is copypasta of targetGhcOptions. Factor out more
|
|
-- useful function from there.
|
|
crdl <- cradle
|
|
sefnmn <- Set.fromList `liftM` mapM guessModuleFile ts
|
|
mcs <- cabalResolvedComponents
|
|
let
|
|
mdlcs = moduleComponents mcs `zipMap` Set.toList sefnmn
|
|
candidates = findCandidates $ map snd mdlcs
|
|
cn = pickComponent candidates
|
|
opts <- targetGhcOptions crdl sefnmn
|
|
|
|
return $ unlines $
|
|
[ "Matching Components:\n" ++ renderGm (nest 4 $
|
|
alistDoc (either text mnDoc) (setDoc gmComponentNameDoc) mdlcs)
|
|
, "Picked Component:\n" ++ renderGm (nest 4 $
|
|
gmComponentNameDoc cn)
|
|
, "GHC Cabal options:\n" ++ renderGm (nest 4 $ fsep $ map text opts)
|
|
]
|
|
where
|
|
zipMap f l = l `zip` (f `map` l)
|
|
|
|
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)
|
|
|
|
graphDoc :: GmModuleGraph -> Doc
|
|
graphDoc GmModuleGraph{..} =
|
|
mapDoc mpDoc smpDoc' gmgGraph
|
|
where
|
|
smpDoc' smp = vcat $ map mpDoc' $ Set.toList smp
|
|
mpDoc' = text . moduleNameString . mpModule
|
|
|
|
setDoc :: (a -> Doc) -> Set.Set a -> Doc
|
|
setDoc f s = vcat $ map f $ Set.toList s
|
|
|
|
smpDoc :: Set.Set ModulePath -> Doc
|
|
smpDoc smp = setDoc mpDoc smp
|
|
|
|
mpDoc :: ModulePath -> Doc
|
|
mpDoc (ModulePath mn fn) = text (moduleNameString mn) <+> parens (text fn)
|
|
|
|
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
|
|
----------------------------------------------------------------
|
|
|
|
-- | Obtaining root information.
|
|
rootInfo :: forall m. (IOish m, GmOut m, GmEnv m) => m String
|
|
rootInfo = do
|
|
crdl <- findCradleNoLog =<< (optPrograms <$> options)
|
|
liftIO $ cleanupCradle crdl
|
|
return $ cradleRootDir crdl ++ "\n"
|