diff --git a/Browse.hs b/Browse.hs index ce3939c..4d78550 100644 --- a/Browse.hs +++ b/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 (AnId i) = Just $ formatType varType i -showThing (ADataCon d) = Just $ formatType dataConRepType d -showThing (ATyCon t) = unwords . toList <$> tyType t +showThing :: DynFlags -> TyThing -> Maybe String +showThing dflag (AnId i) = Just $ formatType dflag varType i +showThing dflag (ADataCon d) = Just $ formatType dflag dataConRepType d +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 f x = getOccString x ++ " :: " ++ showOutputable (removeForAlls $ f x) +formatType :: NamedThing a => DynFlags -> (a -> Type) -> a -> String +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 = unwords . lines . showDocForUser neverQualify . ppr +showOutputable :: Outputable a => DynFlags -> a -> String +showOutputable dflag = unwords . lines . showUnqualifiedPage dflag . ppr diff --git a/Doc.hs b/Doc.hs new file mode 100644 index 0000000..10d88ef --- /dev/null +++ b/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 diff --git a/Gap.hs b/Gap.hs index c3f8dea..f47231f 100644 --- a/Gap.hs +++ b/Gap.hs @@ -3,9 +3,7 @@ module Gap ( Gap.ClsInst , mkTarget - , showDocForUser - , showDoc - , styleDoc + , withStyle , 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 -#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 +withStyle _ = withPprStyleDoc #endif setLogAction :: DynFlags diff --git a/Info.hs b/Info.hs index 3aa87e1..73b7962 100644 --- a/Info.hs +++ b/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 (spn, typ) = (fourInts spn, pretty typ) + toTup :: DynFlags -> (SrcSpan, Type) -> ((Int,Int,Int,Int),String) + 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 = showDocWith OneLineMode . Gap.styleDoc (mkUserStyle neverQualify AllTheWay) . pprTypeForUser False +pretty :: DynFlags -> Type -> String +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 - return $ Gap.showDocForUser unqual $ vcat (intersperse (text "") $ map (pprInfo False) filtered) + dflag <- getSessionDynFlags + 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 diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 6564432..8328e9c 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -40,6 +40,7 @@ Executable ghc-mod CabalApi Check Cradle + Doc Debug ErrMsg Flag