showUnqualifiedPage is now in Doc.hs.

This commit is contained in:
Kazu Yamamoto 2013-07-14 17:07:30 +09:00
parent cbcbae052b
commit 1cd83ce2e0
5 changed files with 43 additions and 39 deletions

View File

@ -6,7 +6,7 @@ import Data.List
import Data.Maybe (fromMaybe)
import DataCon (dataConRepType)
import GHC
import qualified Language.Haskell.GhcMod.Gap as Gap
import Language.Haskell.GhcMod.Doc (showUnqualifiedPage)
import Language.Haskell.GhcMod.GHCApi
import Language.Haskell.GhcMod.Types
import Name
@ -102,4 +102,4 @@ removeForAlls' ty (Just (pre, ftype))
| otherwise = ty
showOutputable :: Outputable a => DynFlags -> a -> String
showOutputable dflag = unwords . lines . Gap.showUnqualifiedPage dflag . ppr
showOutputable dflag = unwords . lines . showUnqualifiedPage dflag . ppr

View File

@ -1,17 +1,39 @@
module Language.Haskell.GhcMod.Doc where
import DynFlags (DynFlags)
import Language.Haskell.GhcMod.Gap (withStyle, styleUnqualified)
import Language.Haskell.GhcMod.Gap (withStyle)
import Outputable
import Pretty
----------------------------------------------------------------
{-
pretty :: Outputable a => a -> String
pretty = showSDocForUser neverQualify . ppr
debug :: Outputable a => a -> b -> b
debug x v = trace (pretty x) v
-}
----------------------------------------------------------------
styleQualified :: PprStyle
styleQualified = mkUserStyle alwaysQualify AllTheWay
styleUnqualified :: PprStyle
styleUnqualified = mkUserStyle neverQualify AllTheWay
----------------------------------------------------------------
-- For "ghc-mod type"
showQualifiedPage :: DynFlags -> SDoc -> String
showQualifiedPage dflag = showDocWith PageMode . withStyle dflag styleQualified
-- For "ghc-mod browse" and show GHC's error messages.
showUnqualifiedPage :: DynFlags -> SDoc -> String
showUnqualifiedPage dflag = Pretty.showDocWith Pretty.PageMode
. withStyle dflag styleUnqualified
-- Not used
showQualifiedOneLine :: DynFlags -> SDoc -> String
showQualifiedOneLine dflag = showDocWith OneLineMode . withStyle dflag styleQualified

View File

@ -14,6 +14,7 @@ import DynFlags
import ErrUtils
import GHC
import HscTypes
import Language.Haskell.GhcMod.Doc (showUnqualifiedPage)
import qualified Language.Haskell.GhcMod.Gap as Gap
import Outputable
import System.FilePath (normalise)
@ -72,7 +73,7 @@ ppMsg spn sev dflag msg = prefix ++ cts ++ "\0"
----------------------------------------------------------------
showMsg :: DynFlags -> SDoc -> String
showMsg dflag sdoc = map toNull $ Gap.showUnqualifiedPage dflag sdoc
showMsg dflag sdoc = map toNull $ showUnqualifiedPage dflag sdoc
where
toNull '\n' = '\0'
toNull x = x

View File

@ -4,8 +4,6 @@ module Language.Haskell.GhcMod.Gap (
Language.Haskell.GhcMod.Gap.ClsInst
, mkTarget
, withStyle
, styleUnqualified
, showUnqualifiedPage
, setLogAction
, supportedExtensions
, getSrcSpan
@ -29,20 +27,20 @@ module Language.Haskell.GhcMod.Gap (
import Control.Applicative hiding (empty)
import Control.Monad
import Data.Time.Clock
import Data.List
import Data.Maybe
import Data.Time.Clock
import DynFlags
import ErrUtils
import FastString
import HscTypes
import Language.Haskell.GhcMod.GHCChoice
import Language.Haskell.GhcMod.Types hiding (convert)
import NameSet
import Outputable
import PprTyThing
import StringBuffer
import TcType
import NameSet
import HscTypes
import PprTyThing
import qualified InstEnv
import qualified Pretty
@ -70,14 +68,6 @@ import Control.Arrow hiding ((<+>))
import Data.Convertible
#endif
{-
pretty :: Outputable a => a -> String
pretty = showSDocForUser neverQualify . ppr
debug :: Outputable a => a -> b -> b
debug x v = trace (pretty x) v
-}
----------------------------------------------------------------
----------------------------------------------------------------
--
@ -117,16 +107,6 @@ setLogAction df f =
----------------------------------------------------------------
----------------------------------------------------------------
showUnqualifiedPage :: DynFlags -> SDoc -> String
showUnqualifiedPage dflag = Pretty.showDocWith Pretty.PageMode
. withStyle dflag styleUnqualified
styleUnqualified :: PprStyle
styleUnqualified = mkUserStyle neverQualify AllTheWay
----------------------------------------------------------------
----------------------------------------------------------------
supportedExtensions :: [String]
#if __GLASGOW_HASKELL__ >= 700
supportedExtensions = supportedLanguagesAndExtensions
@ -231,9 +211,9 @@ addDevPkgs df pkgs = df''
where
#if __GLASGOW_HASKELL__ >= 707
df' = gopt_set df Opt_HideAllPackages
#else
#else
df' = dopt_set df Opt_HideAllPackages
#endif
#endif
df'' = df' {
packageFlags = map ExposePackage pkgs ++ packageFlags df
}
@ -249,9 +229,9 @@ instance HasType (LHsBind Id) where
#if __GLASGOW_HASKELL__ >= 707
getType _ (L spn FunBind{fun_matches = MG _ in_tys out_typ}) = return $ Just (spn, typ)
where typ = mkFunTys in_tys out_typ
#else
#else
getType _ (L spn FunBind{fun_matches = MatchGroup _ typ}) = return $ Just (spn, typ)
#endif
#endif
getType _ _ = return Nothing
----------------------------------------------------------------
@ -264,19 +244,17 @@ filterOutChildren get_thing xs
where
implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]
infoThing :: String -> Ghc String
infoThing :: String -> Ghc SDoc
infoThing str = do
names <- parseName str
#if __GLASGOW_HASKELL__ >= 707
mb_stuffs <- mapM (getInfo False) names
let filtered = filterOutChildren (\(t,_f,_i,_fam) -> t) (catMaybes mb_stuffs)
#else
#else
mb_stuffs <- mapM getInfo names
let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)
#endif
dflag <- getSessionDynFlags
return $ showUnqualifiedPage dflag $ vcat (intersperse (text "") $ map (pprInfo False) filtered)
return $ vcat (intersperse (text "") $ map (pprInfo False) filtered)
#if __GLASGOW_HASKELL__ >= 707
pprInfo :: PrintExplicitForalls -> (TyThing, GHC.Fixity, [ClsInst], [FamInst]) -> SDoc
@ -289,7 +267,7 @@ pprInfo pefas (thing, fixity, insts, famInsts)
show_fixity fx
| fx == defaultFixity = Outputable.empty
| otherwise = ppr fx <+> ppr (getName thing)
#else
#else
pprInfo :: PrintExplicitForalls -> (TyThing, GHC.Fixity, [ClsInst]) -> SDoc
pprInfo pefas (thing, fixity, insts)
= pprTyThingInContextLoc pefas thing

View File

@ -58,7 +58,10 @@ info :: Options
info opt cradle file modstr expr =
inModuleContext Info opt cradle file modstr exprToInfo "Cannot show info"
where
exprToInfo = Gap.infoThing expr
exprToInfo = do
dflag <- getSessionDynFlags
sdoc <- Gap.infoThing expr
return $ showUnqualifiedPage dflag sdoc
----------------------------------------------------------------