clean up the code for Doc/SDoc.
This commit is contained in:
parent
864666490a
commit
c354001577
25
Browse.hs
25
Browse.hs
@ -4,16 +4,16 @@ import Control.Applicative
|
|||||||
import Data.Char
|
import Data.Char
|
||||||
import Data.List
|
import Data.List
|
||||||
import Data.Maybe (fromMaybe)
|
import Data.Maybe (fromMaybe)
|
||||||
|
import DataCon (dataConRepType)
|
||||||
|
import Doc
|
||||||
import GHC
|
import GHC
|
||||||
import GHCApi
|
import GHCApi
|
||||||
import Gap
|
|
||||||
import Name
|
import Name
|
||||||
import Outputable
|
import Outputable
|
||||||
import TyCon
|
import TyCon
|
||||||
import Type
|
import Type
|
||||||
import Types
|
import Types
|
||||||
import Var
|
import Var
|
||||||
import DataCon (dataConRepType)
|
|
||||||
|
|
||||||
----------------------------------------------------------------
|
----------------------------------------------------------------
|
||||||
|
|
||||||
@ -55,20 +55,21 @@ processModule minfo = mapM processName names
|
|||||||
tyInfo <- modInfoLookupName minfo nm
|
tyInfo <- modInfoLookupName minfo nm
|
||||||
-- If nothing found, load dependent module and lookup global
|
-- If nothing found, load dependent module and lookup global
|
||||||
tyResult <- maybe (inOtherModule nm) (return . Just) tyInfo
|
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 :: Name -> Ghc (Maybe TyThing)
|
||||||
inOtherModule nm = getModuleInfo (nameModule nm) >> lookupGlobalName nm
|
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
|
where
|
||||||
toList t' = t' : getOccString t : map getOccString (tyConTyVars t)
|
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 :: TyCon -> Maybe String
|
||||||
tyType typ
|
tyType typ
|
||||||
@ -92,5 +93,5 @@ removeForAlls' ty (Just (pre, ftype))
|
|||||||
| isPredTy pre = mkFunTy pre (dropForAlls ftype)
|
| isPredTy pre = mkFunTy pre (dropForAlls ftype)
|
||||||
| otherwise = ty
|
| 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
|
||||||
|
24
Doc.hs
Normal file
24
Doc.hs
Normal file
@ -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
|
24
Gap.hs
24
Gap.hs
@ -3,9 +3,7 @@
|
|||||||
module Gap (
|
module Gap (
|
||||||
Gap.ClsInst
|
Gap.ClsInst
|
||||||
, mkTarget
|
, mkTarget
|
||||||
, showDocForUser
|
, withStyle
|
||||||
, showDoc
|
|
||||||
, styleDoc
|
|
||||||
, setLogAction
|
, setLogAction
|
||||||
, supportedExtensions
|
, supportedExtensions
|
||||||
, getSrcSpan
|
, 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
|
#if __GLASGOW_HASKELL__ >= 706
|
||||||
showDocForUser = showSDocForUser tracingDynFlags
|
withStyle = withPprStyleDoc
|
||||||
#else
|
#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
|
#endif
|
||||||
|
|
||||||
setLogAction :: DynFlags
|
setLogAction :: DynFlags
|
||||||
|
20
Info.hs
20
Info.hs
@ -12,6 +12,7 @@ import Data.Maybe
|
|||||||
import Data.Ord as O
|
import Data.Ord as O
|
||||||
import Data.Time.Clock
|
import Data.Time.Clock
|
||||||
import Desugar
|
import Desugar
|
||||||
|
import Doc
|
||||||
import GHC
|
import GHC
|
||||||
import GHC.SYB.Utils
|
import GHC.SYB.Utils
|
||||||
import GHCApi
|
import GHCApi
|
||||||
@ -21,7 +22,6 @@ import HscTypes
|
|||||||
import NameSet
|
import NameSet
|
||||||
import Outputable
|
import Outputable
|
||||||
import PprTyThing
|
import PprTyThing
|
||||||
import Pretty (showDocWith, Mode(OneLineMode))
|
|
||||||
import TcHsSyn (hsPatType)
|
import TcHsSyn (hsPatType)
|
||||||
import TcRnTypes
|
import TcRnTypes
|
||||||
import Types
|
import Types
|
||||||
@ -81,11 +81,12 @@ typeOf opt cradle fileName modstr lineNo colNo =
|
|||||||
bts <- mapM (getType tcm) bs
|
bts <- mapM (getType tcm) bs
|
||||||
ets <- mapM (getType tcm) es
|
ets <- mapM (getType tcm) es
|
||||||
pts <- mapM (getType tcm) ps
|
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
|
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 :: SrcSpan -> (Int,Int,Int,Int)
|
||||||
fourInts = fromMaybe (0,0,0,0) . Gap.getSrcSpan
|
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 :: Typeable r => Stage -> (r -> Bool) -> GenericQ [r]
|
||||||
listifyStaged s p = everythingStaged s (++) [] ([] `mkQ` (\x -> [x | p x]))
|
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
|
-- from ghc/InteractiveUI.hs
|
||||||
@ -116,8 +117,8 @@ infoThing str = do
|
|||||||
names <- parseName str
|
names <- parseName str
|
||||||
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)
|
||||||
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 :: (a -> TyThing) -> [a] -> [a]
|
||||||
filterOutChildren get_thing xs
|
filterOutChildren get_thing xs
|
||||||
@ -153,7 +154,8 @@ inModuleContext opt cradle fileName modstr action errmsg =
|
|||||||
doif setContextFromTarget action
|
doif setContextFromTarget action
|
||||||
setTargetBuffer = do
|
setTargetBuffer = do
|
||||||
modgraph <- depanal [mkModuleName modstr] True
|
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
|
map ms_imps modgraph ++ map ms_srcimps modgraph
|
||||||
moddef = "module " ++ sanitize modstr ++ " where"
|
moddef = "module " ++ sanitize modstr ++ " where"
|
||||||
header = moddef : imports
|
header = moddef : imports
|
||||||
|
@ -40,6 +40,7 @@ Executable ghc-mod
|
|||||||
CabalApi
|
CabalApi
|
||||||
Check
|
Check
|
||||||
Cradle
|
Cradle
|
||||||
|
Doc
|
||||||
Debug
|
Debug
|
||||||
ErrMsg
|
ErrMsg
|
||||||
Flag
|
Flag
|
||||||
|
Loading…
Reference in New Issue
Block a user