{-# LANGUAGE BangPatterns, FlexibleInstances, ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_HADDOCK hide #-}
module Haddock.GhcUtils where
import Control.Arrow
import Exception
import Outputable
import Name
import NameSet
import Lexeme
import Module
import HscTypes
import GHC
import Class
moduleString :: Module -> String
moduleString = moduleNameString . moduleName
isNameSym :: Name -> Bool
isNameSym = isSymOcc . nameOccName
isVarSym :: OccName -> Bool
isVarSym = isLexVarSym . occNameFS
isConSym :: OccName -> Bool
isConSym = isLexConSym . occNameFS
getMainDeclBinder :: HsDecl name -> [IdP name]
getMainDeclBinder (TyClD d) = [tcdName d]
getMainDeclBinder (ValD d) =
case collectHsBindBinders d of
[] -> []
(name:_) -> [name]
getMainDeclBinder (SigD d) = sigNameNoLoc d
getMainDeclBinder (ForD (ForeignImport name _ _ _)) = [unLoc name]
getMainDeclBinder (ForD (ForeignExport _ _ _ _)) = []
getMainDeclBinder _ = []
getInstLoc :: InstDecl name -> SrcSpan
getInstLoc (ClsInstD (ClsInstDecl { cid_poly_ty = ty })) = getLoc (hsSigType ty)
getInstLoc (DataFamInstD (DataFamInstDecl
{ dfid_eqn = HsIB { hsib_body = FamEqn { feqn_tycon = L l _ }}})) = l
getInstLoc (TyFamInstD (TyFamInstDecl
{ tfid_eqn = HsIB { hsib_body = FamEqn { feqn_rhs = L l _ }}})) = l
filterLSigNames :: (IdP name -> Bool) -> LSig name -> Maybe (LSig name)
filterLSigNames p (L loc sig) = L loc <$> (filterSigNames p sig)
filterSigNames :: (IdP name -> Bool) -> Sig name -> Maybe (Sig name)
filterSigNames p orig@(SpecSig n _ _) = ifTrueJust (p $ unLoc n) orig
filterSigNames p orig@(InlineSig n _) = ifTrueJust (p $ unLoc n) orig
filterSigNames p (FixSig (FixitySig ns ty)) =
case filter (p . unLoc) ns of
[] -> Nothing
filtered -> Just (FixSig (FixitySig filtered ty))
filterSigNames _ orig@(MinimalSig _ _) = Just orig
filterSigNames p (TypeSig ns ty) =
case filter (p . unLoc) ns of
[] -> Nothing
filtered -> Just (TypeSig filtered ty)
filterSigNames p (ClassOpSig is_default ns ty) =
case filter (p . unLoc) ns of
[] -> Nothing
filtered -> Just (ClassOpSig is_default filtered ty)
filterSigNames p (PatSynSig ns ty) =
case filter (p . unLoc) ns of
[] -> Nothing
filtered -> Just (PatSynSig filtered ty)
filterSigNames _ _ = Nothing
ifTrueJust :: Bool -> name -> Maybe name
ifTrueJust True = Just
ifTrueJust False = const Nothing
sigName :: LSig name -> [IdP name]
sigName (L _ sig) = sigNameNoLoc sig
sigNameNoLoc :: Sig name -> [IdP name]
sigNameNoLoc (TypeSig ns _) = map unLoc ns
sigNameNoLoc (ClassOpSig _ ns _) = map unLoc ns
sigNameNoLoc (PatSynSig ns _) = map unLoc ns
sigNameNoLoc (SpecSig n _ _) = [unLoc n]
sigNameNoLoc (InlineSig n _) = [unLoc n]
sigNameNoLoc (FixSig (FixitySig ns _)) = map unLoc ns
sigNameNoLoc _ = []
isUserLSig :: LSig name -> Bool
isUserLSig (L _(TypeSig {})) = True
isUserLSig (L _(ClassOpSig {})) = True
isUserLSig (L _(PatSynSig {})) = True
isUserLSig _ = False
isClassD :: HsDecl a -> Bool
isClassD (TyClD d) = isClassDecl d
isClassD _ = False
isValD :: HsDecl a -> Bool
isValD (ValD _) = True
isValD _ = False
declATs :: HsDecl a -> [IdP a]
declATs (TyClD d) | isClassDecl d = map (unL . fdLName . unL) $ tcdATs d
declATs _ = []
pretty :: Outputable a => DynFlags -> a -> String
pretty = showPpr
nubByName :: (a -> Name) -> [a] -> [a]
nubByName f ns = go emptyNameSet ns
where
go !_ [] = []
go !s (x:xs)
| y `elemNameSet` s = go s xs
| otherwise = let !s' = extendNameSet s y
in x : go s' xs
where
y = f x
unL :: Located a -> a
unL (L _ x) = x
reL :: a -> Located a
reL = L undefined
instance NamedThing (TyClDecl GhcRn) where
getName = tcdName
class Parent a where
children :: a -> [Name]
instance Parent (ConDecl GhcRn) where
children con =
case getConDetails con of
RecCon fields -> map (selectorFieldOcc . unL) $
concatMap (cd_fld_names . unL) (unL fields)
_ -> []
instance Parent (TyClDecl GhcRn) where
children d
| isDataDecl d = map unL $ concatMap (getConNames . unL)
$ (dd_cons . tcdDataDefn) $ d
| isClassDecl d =
map (unL . fdLName . unL) (tcdATs d) ++
[ unL n | L _ (TypeSig ns _) <- tcdSigs d, n <- ns ]
| otherwise = []
family :: (NamedThing a, Parent a) => a -> (Name, [Name])
family = getName &&& children
familyConDecl :: ConDecl GHC.GhcRn -> [(Name, [Name])]
familyConDecl d = zip (map unL (getConNames d)) (repeat $ children d)
families :: TyClDecl GhcRn -> [(Name, [Name])]
families d
| isDataDecl d = family d : concatMap (familyConDecl . unL) (dd_cons (tcdDataDefn d))
| isClassDecl d = [family d]
| otherwise = []
parentMap :: TyClDecl GhcRn -> [(Name, Name)]
parentMap d = [ (c, p) | (p, cs) <- families d, c <- cs ]
parents :: Name -> HsDecl GhcRn -> [Name]
parents n (TyClD d) = [ p | (c, p) <- parentMap d, c == n ]
parents _ _ = []
modifySessionDynFlags :: (DynFlags -> DynFlags) -> Ghc ()
modifySessionDynFlags f = do
dflags <- getSessionDynFlags
_ <- setSessionDynFlags (f dflags)
return ()
gbracket_ :: ExceptionMonad m => m a -> m b -> m c -> m c
gbracket_ before_ after thing = gbracket before_ (const after) (const thing)
minimalDef :: GhcMonad m => Name -> m (Maybe ClassMinimalDef)
minimalDef n = do
mty <- lookupGlobalName n
case mty of
Just (ATyCon (tyConClass_maybe -> Just c)) -> return . Just $ classMinimalDef c
_ -> return Nothing
setObjectDir, setHiDir, setStubDir, setOutputDir :: String -> DynFlags -> DynFlags
setObjectDir f d = d{ objectDir = Just f}
setHiDir f d = d{ hiDir = Just f}
setStubDir f d = d{ stubDir = Just f, includePaths = f : includePaths d }
setOutputDir f = setObjectDir f . setHiDir f . setStubDir f