diff --git a/Debug.hs b/Debug.hs new file mode 100644 index 0000000..ae281ae --- /dev/null +++ b/Debug.hs @@ -0,0 +1,39 @@ +module Debug where + +import CabalApi +import GHCApi +import Control.Applicative +import Data.List (intercalate) +import Data.Maybe +import Prelude +import Types + +---------------------------------------------------------------- + +debugInfo :: Options -> Cradle -> String -> IO String +debugInfo opt cradle fileName = unlines <$> debug opt cradle fileName + +debug :: Options -> Cradle -> String -> IO [String] +debug opt cradle fileName = do + (gopts, incDir, pkgs, langext) <- + if cabal then + fromCabalFile (ghcOpts opt) cradle + else + return (ghcOpts opt, [], [], []) + dflags <- getDynFlags + hdrext <- getHeaderExtension dflags fileName + let th = useTemplateHaskell (Just langext) hdrext + return [ + "GHC version: " ++ ghcVer + , "Current directory: " ++ currentDir + , "Cabal file: " ++ cabalFile + , "GHC options: " ++ intercalate " " gopts + , "Include directories: " ++ intercalate " " incDir + , "Dependent packages: " ++ intercalate ", " pkgs + , "Fast check: " ++ if th then "No" else "Yes" + ] + where + ghcVer = cradleGHCVersion cradle + currentDir = cradleCurrentDir cradle + cabal = isJust $ cradleCabalFile cradle + cabalFile = fromMaybe "" $ cradleCabalFile cradle diff --git a/GHCApi.hs b/GHCApi.hs index d4bacd5..da2e812 100644 --- a/GHCApi.hs +++ b/GHCApi.hs @@ -61,16 +61,24 @@ initSession :: Options -> FilePath -> Ghc LogReader initSession opt cmdOpts idirs mDepPkgs mLangExts logging file = do - dflags <- getSessionDynFlags - hdrExts <- liftIO $ map unLoc <$> getOptionsFromFile dflags file + dflags0 <- getSessionDynFlags + hdrExts <- liftIO $ getHeaderExtension dflags0 file let th = useTemplateHaskell mLangExts hdrExts opts = map noLoc cmdOpts - (dflags',_,_) <- parseDynamicFlags dflags opts - (dflags'',readLog) <- liftIO . (>>= setLogger logging) - . setGhcFlags opt . setFlags opt dflags' idirs mDepPkgs $ th - _ <- setSessionDynFlags dflags'' + (dflags1,_,_) <- parseDynamicFlags dflags0 opts + let dflags2 = modifyFlags opt dflags1 idirs mDepPkgs th + dflags3 <- setGhcFlags opt dflags2 + (dflags4,readLog) <- liftIO $ setLogger logging dflags3 + _ <- setSessionDynFlags dflags4 return readLog +---------------------------------------------------------------- + +getHeaderExtension :: DynFlags -> FilePath -> IO [String] +getHeaderExtension dflags file = map unLoc <$> getOptionsFromFile dflags file + +---------------------------------------------------------------- + useTemplateHaskell :: Maybe [LangExt] -> [HeaderExt] -> Bool useTemplateHaskell mLangExts hdrExts = th1 || th2 where @@ -79,25 +87,28 @@ useTemplateHaskell mLangExts hdrExts = th1 || th2 ---------------------------------------------------------------- -setFlags :: Options -> DynFlags -> [IncludeDir] -> Maybe [Package] -> Bool -> DynFlags -setFlags opt d idirs mDepPkgs th - | expandSplice opt = dopt_set d' Opt_D_dump_splices - | otherwise = d' +modifyFlags :: Options -> DynFlags -> [IncludeDir] -> Maybe [Package] -> Bool -> DynFlags +modifyFlags opt d idirs mDepPkgs th + | expandSplice opt = dopt_set d'' Opt_D_dump_splices + | otherwise = d'' where - d' = addDevPkgs mDepPkgs $ d { + d' = d { importPaths = idirs , ghcLink = if th then LinkInMemory else NoLink , hscTarget = if th then HscInterpreted else HscNothing , flags = flags d } + d'' = maybe d' (addDevPkgs d') mDepPkgs -addDevPkgs :: Maybe [Package] -> DynFlags -> DynFlags -addDevPkgs Nothing df = df -addDevPkgs (Just pkgs) df = df' { - packageFlags = map ExposePackage pkgs ++ packageFlags df - } +addDevPkgs :: DynFlags -> [Package] -> DynFlags +addDevPkgs df pkgs = df'' where df' = dopt_set df Opt_HideAllPackages + df'' = df' { + packageFlags = map ExposePackage pkgs ++ packageFlags df + } + +---------------------------------------------------------------- setGhcFlags :: Monad m => Options -> DynFlags -> m DynFlags setGhcFlags opt flagset = @@ -110,3 +121,8 @@ setTargetFile :: (GhcMonad m) => String -> m () setTargetFile file = do target <- guessTarget file Nothing setTargets [target] + +---------------------------------------------------------------- + +getDynFlags :: IO DynFlags +getDynFlags = runGhc (Just libdir) getSessionDynFlags diff --git a/GHCMod.hs b/GHCMod.hs index f34dd31..441f49c 100644 --- a/GHCMod.hs +++ b/GHCMod.hs @@ -9,6 +9,7 @@ import Control.Exception import Cradle import Data.Typeable import Data.Version +import Debug import Flag import Info import Lang @@ -98,6 +99,7 @@ main = flip catches handlers $ do "list" -> listModules opt "check" -> withFile (checkSyntax opt cradle) cmdArg1 "expand" -> withFile (checkSyntax opt { expandSplice = True } cradle) cmdArg1 + "debug" -> withFile (debugInfo opt cradle) cmdArg1 "type" -> withFile (typeExpr opt cradle cmdArg2 (read cmdArg3) (read cmdArg4)) cmdArg1 "info" -> withFile (infoExpr opt cradle cmdArg2 cmdArg3) cmdArg1 "lint" -> withFile (lintSyntax opt) cmdArg1