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 Data.Maybe (fromMaybe)
import DataCon (dataConRepType) import DataCon (dataConRepType)
import GHC 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.GHCApi
import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Types
import Name import Name
@ -102,4 +102,4 @@ removeForAlls' ty (Just (pre, ftype))
| otherwise = ty | otherwise = ty
showOutputable :: Outputable a => DynFlags -> a -> String 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 module Language.Haskell.GhcMod.Doc where
import DynFlags (DynFlags) import DynFlags (DynFlags)
import Language.Haskell.GhcMod.Gap (withStyle, styleUnqualified) import Language.Haskell.GhcMod.Gap (withStyle)
import Outputable import Outputable
import Pretty 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 :: PprStyle
styleQualified = mkUserStyle alwaysQualify AllTheWay styleQualified = mkUserStyle alwaysQualify AllTheWay
styleUnqualified :: PprStyle
styleUnqualified = mkUserStyle neverQualify AllTheWay
----------------------------------------------------------------
-- For "ghc-mod type" -- For "ghc-mod type"
showQualifiedPage :: DynFlags -> SDoc -> String showQualifiedPage :: DynFlags -> SDoc -> String
showQualifiedPage dflag = showDocWith PageMode . withStyle dflag styleQualified 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 -- Not used
showQualifiedOneLine :: DynFlags -> SDoc -> String showQualifiedOneLine :: DynFlags -> SDoc -> String
showQualifiedOneLine dflag = showDocWith OneLineMode . withStyle dflag styleQualified showQualifiedOneLine dflag = showDocWith OneLineMode . withStyle dflag styleQualified

View File

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

View File

@ -4,8 +4,6 @@ module Language.Haskell.GhcMod.Gap (
Language.Haskell.GhcMod.Gap.ClsInst Language.Haskell.GhcMod.Gap.ClsInst
, mkTarget , mkTarget
, withStyle , withStyle
, styleUnqualified
, showUnqualifiedPage
, setLogAction , setLogAction
, supportedExtensions , supportedExtensions
, getSrcSpan , getSrcSpan
@ -29,20 +27,20 @@ module Language.Haskell.GhcMod.Gap (
import Control.Applicative hiding (empty) import Control.Applicative hiding (empty)
import Control.Monad import Control.Monad
import Data.Time.Clock
import Data.List import Data.List
import Data.Maybe import Data.Maybe
import Data.Time.Clock
import DynFlags import DynFlags
import ErrUtils import ErrUtils
import FastString import FastString
import HscTypes
import Language.Haskell.GhcMod.GHCChoice import Language.Haskell.GhcMod.GHCChoice
import Language.Haskell.GhcMod.Types hiding (convert) import Language.Haskell.GhcMod.Types hiding (convert)
import NameSet
import Outputable import Outputable
import PprTyThing
import StringBuffer import StringBuffer
import TcType import TcType
import NameSet
import HscTypes
import PprTyThing
import qualified InstEnv import qualified InstEnv
import qualified Pretty import qualified Pretty
@ -70,14 +68,6 @@ import Control.Arrow hiding ((<+>))
import Data.Convertible import Data.Convertible
#endif #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] supportedExtensions :: [String]
#if __GLASGOW_HASKELL__ >= 700 #if __GLASGOW_HASKELL__ >= 700
supportedExtensions = supportedLanguagesAndExtensions supportedExtensions = supportedLanguagesAndExtensions
@ -264,8 +244,7 @@ filterOutChildren get_thing xs
where where
implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)] implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]
infoThing :: String -> Ghc SDoc
infoThing :: String -> Ghc String
infoThing str = do infoThing str = do
names <- parseName str names <- parseName str
#if __GLASGOW_HASKELL__ >= 707 #if __GLASGOW_HASKELL__ >= 707
@ -275,8 +254,7 @@ infoThing str = do
mb_stuffs <- mapM getInfo names mb_stuffs <- mapM getInfo names
let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs) let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)
#endif #endif
dflag <- getSessionDynFlags return $ vcat (intersperse (text "") $ map (pprInfo False) filtered)
return $ showUnqualifiedPage dflag $ vcat (intersperse (text "") $ map (pprInfo False) filtered)
#if __GLASGOW_HASKELL__ >= 707 #if __GLASGOW_HASKELL__ >= 707
pprInfo :: PrintExplicitForalls -> (TyThing, GHC.Fixity, [ClsInst], [FamInst]) -> SDoc pprInfo :: PrintExplicitForalls -> (TyThing, GHC.Fixity, [ClsInst], [FamInst]) -> SDoc

View File

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