clean up the code for Doc/SDoc.

Browse.hs

@@ -4,16 +4,16 @@ import Control.Applicative
 import Data.Char
 import Data.List
 import Data.Maybe (fromMaybe)
+import DataCon (dataConRepType)
+import Doc
 import GHC
 import GHCApi
-import Gap
 import Name
 import Outputable
 import TyCon
 import Type
 import Types
 import Var
-import DataCon (dataConRepType)
 
 ----------------------------------------------------------------
 
@@ -55,20 +55,21 @@ processModule minfo = mapM processName names
         tyInfo <- modInfoLookupName minfo nm
         -- If nothing found, load dependent module and lookup global
         tyResult <- maybe (inOtherModule nm) (return . Just) tyInfo
-        return $ fromMaybe (getOccString nm) (tyResult >>= showThing)
+        dflag <- getSessionDynFlags
+        return $ fromMaybe (getOccString nm) (tyResult >>= showThing dflag)
     inOtherModule :: Name -> Ghc (Maybe TyThing)
     inOtherModule nm = getModuleInfo (nameModule nm) >> lookupGlobalName nm
 
-showThing :: TyThing -> Maybe String
+showThing :: DynFlags -> TyThing -> Maybe String
-showThing (AnId i)     = Just $ formatType varType i
+showThing dflag (AnId i)     = Just $ formatType dflag varType i
-showThing (ADataCon d) = Just $ formatType dataConRepType d
+showThing dflag (ADataCon d) = Just $ formatType dflag dataConRepType d
-showThing (ATyCon t)   = unwords . toList <$> tyType t
+showThing _     (ATyCon t)   = unwords . toList <$> tyType t
   where
     toList t' = t' : getOccString t : map getOccString (tyConTyVars t)
-showThing _          = Nothing
+showThing _     _            = Nothing
 
-formatType :: NamedThing a => (a -> Type) -> a -> String
+formatType :: NamedThing a => DynFlags -> (a -> Type) -> a -> String
-formatType f x = getOccString x ++ " :: " ++ showOutputable (removeForAlls $ f x)
+formatType dflag f x = getOccString x ++ " :: " ++ showOutputable dflag (removeForAlls $ f x)
 
 tyType :: TyCon -> Maybe String
 tyType typ
@@ -92,5 +93,5 @@ removeForAlls' ty (Just (pre, ftype))
     | isPredTy pre        = mkFunTy pre (dropForAlls ftype)
     | otherwise           = ty
 
-showOutputable :: Outputable a => a -> String
+showOutputable :: Outputable a => DynFlags -> a -> String
-showOutputable = unwords . lines . showDocForUser neverQualify . ppr
+showOutputable dflag = unwords . lines . showUnqualifiedPage dflag . ppr

Doc.hs

@@ -0,0 +1,24 @@
+module Doc where
+
+import DynFlags (DynFlags)
+import Gap (withStyle)
+import Outputable
+import Pretty
+
+styleQualified :: PprStyle
+styleQualified = mkUserStyle alwaysQualify AllTheWay
+
+styleUnqualified :: PprStyle
+styleUnqualified = mkUserStyle neverQualify AllTheWay
+
+showQualifiedPage :: DynFlags -> SDoc -> String
+showQualifiedPage dflag = showDocWith PageMode . withStyle dflag styleQualified
+
+showUnqualifiedPage :: DynFlags -> SDoc -> String
+showUnqualifiedPage dflag = showDocWith PageMode . withStyle dflag styleUnqualified
+
+showQualifiedOneLine :: DynFlags -> SDoc -> String
+showQualifiedOneLine dflag = showDocWith OneLineMode . withStyle dflag styleQualified
+
+showUnqualifiedOneLine :: DynFlags -> SDoc -> String
+showUnqualifiedOneLine dflag = showDocWith OneLineMode . withStyle dflag styleUnqualified

Gap.hs

@@ -3,9 +3,7 @@
 module Gap (
     Gap.ClsInst
   , mkTarget
-  , showDocForUser
+  , withStyle
-  , showDoc
-  , styleDoc
   , setLogAction
   , supportedExtensions
   , getSrcSpan
@@ -77,25 +75,11 @@ mkTarget tid allowObjCode = Target tid allowObjCode . (fmap . second) convert
 ----------------------------------------------------------------
 ----------------------------------------------------------------
 
-showDocForUser :: PrintUnqualified -> SDoc -> String
+withStyle :: DynFlags -> PprStyle -> SDoc -> Pretty.Doc
 #if __GLASGOW_HASKELL__ >= 706
-showDocForUser = showSDocForUser tracingDynFlags
+withStyle = withPprStyleDoc
 #else
-showDocForUser = showSDocForUser
+withStyle _ = withPprStyleDoc
-#endif
-
-showDoc :: SDoc -> String
-#if __GLASGOW_HASKELL__ >= 706
-showDoc = showSDoc tracingDynFlags
-#else
-showDoc = showSDoc
-#endif
-
-styleDoc :: PprStyle -> SDoc -> Pretty.Doc
-#if __GLASGOW_HASKELL__ >= 706
-styleDoc = withPprStyleDoc tracingDynFlags
-#else
-styleDoc = withPprStyleDoc
 #endif
 
 setLogAction :: DynFlags

Info.hs

@@ -12,6 +12,7 @@ import Data.Maybe
 import Data.Ord as O
 import Data.Time.Clock
 import Desugar
+import Doc
 import GHC
 import GHC.SYB.Utils
 import GHCApi
@@ -21,7 +22,6 @@ import HscTypes
 import NameSet
 import Outputable
 import PprTyThing
-import Pretty (showDocWith, Mode(OneLineMode))
 import TcHsSyn (hsPatType)
 import TcRnTypes
 import Types
@@ -81,11 +81,12 @@ typeOf opt cradle fileName modstr lineNo colNo =
       bts <- mapM (getType tcm) bs
       ets <- mapM (getType tcm) es
       pts <- mapM (getType tcm) ps
-      let sss = map toTup $ sortBy (cmp `on` fst) $ catMaybes $ concat [ets, bts, pts]
+      dflag <- getSessionDynFlags
+      let sss = map (toTup dflag) $ sortBy (cmp `on` fst) $ catMaybes $ concat [ets, bts, pts]
       return $ convert opt sss
 
-    toTup :: (SrcSpan, Type) -> ((Int,Int,Int,Int),String)
+    toTup :: DynFlags -> (SrcSpan, Type) -> ((Int,Int,Int,Int),String)
-    toTup (spn, typ) = (fourInts spn, pretty typ)
+    toTup dflag (spn, typ) = (fourInts spn, pretty dflag typ)
 
     fourInts :: SrcSpan -> (Int,Int,Int,Int)
     fourInts = fromMaybe (0,0,0,0) . Gap.getSrcSpan
@@ -105,8 +106,8 @@ listifySpans tcs lc = listifyStaged TypeChecker p tcs
 listifyStaged :: Typeable r => Stage -> (r -> Bool) -> GenericQ [r]
 listifyStaged s p = everythingStaged s (++) [] ([] `mkQ` (\x -> [x | p x]))
 
-pretty :: Type -> String
+pretty :: DynFlags -> Type -> String
-pretty = showDocWith OneLineMode . Gap.styleDoc (mkUserStyle neverQualify AllTheWay) . pprTypeForUser False
+pretty dflag = showUnqualifiedOneLine dflag . pprTypeForUser False
 
 ----------------------------------------------------------------
 -- from ghc/InteractiveUI.hs
@@ -116,8 +117,8 @@ infoThing str = do
     names <- parseName str
     mb_stuffs <- mapM getInfo names
     let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)
-    unqual <- getPrintUnqual
+    dflag <- getSessionDynFlags
-    return $ Gap.showDocForUser unqual $ vcat (intersperse (text "") $ map (pprInfo False) filtered)
+    return $ showUnqualifiedPage dflag $ vcat (intersperse (text "") $ map (pprInfo False) filtered)
 
 filterOutChildren :: (a -> TyThing) -> [a] -> [a]
 filterOutChildren get_thing xs
@@ -153,7 +154,8 @@ inModuleContext opt cradle fileName modstr action errmsg =
         doif setContextFromTarget action
     setTargetBuffer = do
         modgraph <- depanal [mkModuleName modstr] True
-        let imports = concatMap (map (Gap.showDoc . ppr . unLoc)) $
+        dflag <- getSessionDynFlags
+        let imports = concatMap (map (showQualifiedPage dflag . ppr . unLoc)) $
                       map ms_imps modgraph ++ map ms_srcimps modgraph
             moddef = "module " ++ sanitize modstr ++ " where"
             header = moddef : imports

ghc-mod.cabal

@@ -40,6 +40,7 @@ Executable ghc-mod
                         CabalApi
                         Check
                         Cradle
+                        Doc
                         Debug
                         ErrMsg
                         Flag