diff --git a/Check.hs b/Check.hs index 78a52c3..64939af 100644 --- a/Check.hs +++ b/Check.hs @@ -3,7 +3,6 @@ module Check (checkSyntax) where import Bag import Control.Applicative import Data.IORef -import DynFlags import ErrUtils import Exception import FastString @@ -23,28 +22,18 @@ checkSyntax _ file = unlines <$> check file check :: String -> IO [String] check fileName = withGHC $ do - ref <- liftIO $ newIORef [] - initSession + ref <- newRef [] + initSession ["-Wall","-fno-warn-unused-do-bind"] setTargetFile fileName loadWithLogger (refLogger ref) LoadAllTargets `gcatch` handleParseError ref clearWarnings - liftIO $ readIORef ref + readRef ref where - -- I don't know why, but parseDynamicFlags must be used. - initSession = do - dflags <- getSessionDynFlags - (dflags',_,_) <- parseDynamicFlags dflags cmdOptions - setSessionDynFlags $ setFlags dflags' - setTargetFile file = do - target <- guessTarget file Nothing - setTargets [target] handleParseError ref e = do liftIO . writeIORef ref $ errBagToStrList . srcErrorMessages $ e return Succeeded - --- I don't know why, but parseDynamicFlags must be used. -cmdOptions :: [Located String] -cmdOptions = map noLoc ["-Wall","-fno-warn-unused-do-bind"] + newRef = liftIO . newIORef + readRef = liftIO . readIORef ---------------------------------------------------------------- @@ -59,24 +48,6 @@ errBagToStrList = map showErrMsg . reverse . bagToList ---------------------------------------------------------------- -setFlags :: DynFlags -> DynFlags -setFlags d = d { - importPaths = importPaths d ++ importDirs - , packageFlags = ghcPackage : packageFlags d - , ghcLink = NoLink --- GHC.desugarModule does not produces the pattern warnings, why? --- , hscTarget = HscNothing - , hscTarget = HscInterpreted - } - -importDirs :: [String] -importDirs = ["..","../..","../../..","../../../../.."] - -ghcPackage :: PackageFlag -ghcPackage = ExposePackage "ghc" - ----------------------------------------------------------------- - showErrMsg :: ErrMsg -> String showErrMsg err = file ++ ":" ++ line ++ ":" ++ col ++ ":" ++ msg ++ "\0" ++ ext where diff --git a/GHCMod.hs b/GHCMod.hs index a49d185..83b3f83 100644 --- a/GHCMod.hs +++ b/GHCMod.hs @@ -7,6 +7,7 @@ import Check import Control.Applicative import Control.Exception import Data.Typeable +import Info import Lang import Lint import List @@ -26,6 +27,7 @@ usage = "ghc-mod version 0.4.4\n" ++ "\t ghc-mod [-l] lang\n" ++ "\t ghc-mod [-l] browse [ ...]\n" ++ "\t ghc-mod check \n" + ++ "\t ghc-mod info \n" ++ "\t ghc-mod [-h opt] lint \n" ++ "\t ghc-mod boot\n" ++ "\t ghc-mod help\n" @@ -72,6 +74,7 @@ main = flip catches handlers $ do "browse" -> concat <$> mapM (browseModule opt) (tail cmdArg) "list" -> listModules opt "check" -> withFile (checkSyntax opt) (safelist cmdArg 1) + "info" -> withFile (infoExpr opt (safelist cmdArg 2)) (safelist cmdArg 1) "lint" -> withFile (lintSyntax opt) (safelist cmdArg 1) "lang" -> listLanguages opt "boot" -> do diff --git a/Info.hs b/Info.hs new file mode 100644 index 0000000..7c4795e --- /dev/null +++ b/Info.hs @@ -0,0 +1,24 @@ +module Info where + +import Control.Applicative +import GHC +import Outputable +import PprTyThing +import Types + +infoExpr :: Options -> String -> String -> IO String +infoExpr _ expr file = (++ "\n") <$> info file expr + +info :: String -> String -> IO String +info fileName expr = withGHC $ do + initSession [] + setTargetFile fileName + load LoadAllTargets + setContextFromTarget + pretty <$> exprType expr + where + setContextFromTarget = do + [mdlsum,_] <- depanal [] False + mdl <- findModule (ms_mod_name mdlsum) Nothing + setContext [mdl] [] + pretty = showSDocForUser neverQualify . pprTypeForUser False diff --git a/Types.hs b/Types.hs index 50d2b59..51ee086 100644 --- a/Types.hs +++ b/Types.hs @@ -1,19 +1,57 @@ module Types where +import Control.Monad +import DynFlags import Exception import GHC import GHC.Paths (libdir) +---------------------------------------------------------------- + data Options = Options { convert :: [String] -> String , hlintOpts :: [String] } -withGHC :: Ghc [String] -> IO [String] +withGHC :: (MonadPlus m) => Ghc (m a) -> IO (m a) withGHC body = ghandle ignore $ runGhc (Just libdir) body where - ignore :: SomeException -> IO [String] - ignore _ = return [] + ignore :: (MonadPlus m) => SomeException -> IO (m a) + ignore _ = return mzero + +---------------------------------------------------------------- initSession0 :: Ghc [PackageId] initSession0 = getSessionDynFlags >>= setSessionDynFlags + +initSession :: [String] -> Ghc [PackageId] +initSession cmdOpts = do + dflags <- getSessionDynFlags + let opts = map noLoc cmdOpts + (dflags',_,_) <- parseDynamicFlags dflags opts + setSessionDynFlags $ setFlags dflags' + +---------------------------------------------------------------- + +setFlags :: DynFlags -> DynFlags +setFlags d = d { + importPaths = importPaths d ++ importDirs + , packageFlags = ghcPackage : packageFlags d + , ghcLink = NoLink +-- GHC.desugarModule does not produces the pattern warnings, why? +-- , hscTarget = HscNothing + , hscTarget = HscInterpreted + } + +importDirs :: [String] +importDirs = ["..","../..","../../..","../../../../.."] + +ghcPackage :: PackageFlag +ghcPackage = ExposePackage "ghc" + +---------------------------------------------------------------- + +setTargetFile :: (GhcMonad m) => String -> m () +setTargetFile file = do + target <- guessTarget file Nothing + setTargets [target] diff --git a/ghc-mod.cabal b/ghc-mod.cabal index fae18fc..a510717 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -23,7 +23,7 @@ Data-Files: Makefile ghc.el ghc-func.el ghc-doc.el ghc-comp.el ghc-flymake.el ghc-command.el Executable ghc-mod Main-Is: GHCMod.hs - Other-Modules: List Browse Check Lang Lint Types + Other-Modules: List Browse Check Info Lang Lint Types if impl(ghc >= 6.12) GHC-Options: -Wall -fno-warn-unused-do-bind else