aboutsummaryrefslogtreecommitdiff
path: root/src/Haddock/GhcUtils.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Haddock/GhcUtils.hs')
-rw-r--r--src/Haddock/GhcUtils.hs304
1 files changed, 0 insertions, 304 deletions
diff --git a/src/Haddock/GhcUtils.hs b/src/Haddock/GhcUtils.hs
deleted file mode 100644
index c06b34a6..00000000
--- a/src/Haddock/GhcUtils.hs
+++ /dev/null
@@ -1,304 +0,0 @@
-{-# LANGUAGE FlexibleInstances, ViewPatterns #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-{-# OPTIONS_HADDOCK hide #-}
------------------------------------------------------------------------------
--- |
--- Module : Haddock.GhcUtils
--- Copyright : (c) David Waern 2006-2009
--- License : BSD-like
---
--- Maintainer : haddock@projects.haskell.org
--- Stability : experimental
--- Portability : portable
---
--- Utils for dealing with types from the GHC API
------------------------------------------------------------------------------
-module Haddock.GhcUtils where
-
-
-import Data.Version
-import Control.Applicative ( (<$>) )
-import Control.Arrow
-import Data.Foldable hiding (concatMap)
-import Data.Function
-import Data.Traversable
-import Distribution.Compat.ReadP
-import Distribution.Text
-
-import Exception
-import Outputable
-import Name
-import Packages
-import Module
-import RdrName (GlobalRdrEnv)
-import GhcMonad (withSession)
-import HscTypes
-import UniqFM
-import GHC
-import Class
-
-
-moduleString :: Module -> String
-moduleString = moduleNameString . moduleName
-
-
--- return the (name,version) of the package
-modulePackageInfo :: Module -> (String, [Char])
-modulePackageInfo modu = case unpackPackageId pkg of
- Nothing -> (packageIdString pkg, "")
- Just x -> (display $ pkgName x, showVersion (pkgVersion x))
- where pkg = modulePackageId modu
-
-
--- This was removed from GHC 6.11
--- XXX we shouldn't be using it, probably
-
--- | Try and interpret a GHC 'PackageId' as a cabal 'PackageIdentifer'. Returns @Nothing@ if
--- we could not parse it as such an object.
-unpackPackageId :: PackageId -> Maybe PackageIdentifier
-unpackPackageId p
- = case [ pid | (pid,"") <- readP_to_S parse str ] of
- [] -> Nothing
- (pid:_) -> Just pid
- where str = packageIdString p
-
-
-lookupLoadedHomeModuleGRE :: GhcMonad m => ModuleName -> m (Maybe GlobalRdrEnv)
-lookupLoadedHomeModuleGRE mod_name = withSession $ \hsc_env ->
- case lookupUFM (hsc_HPT hsc_env) mod_name of
- Just mod_info -> return (mi_globals (hm_iface mod_info))
- _not_a_home_module -> return Nothing
-
-
-isNameSym :: Name -> Bool
-isNameSym = isSymOcc . nameOccName
-
-
-isVarSym :: OccName -> Bool
-isVarSym = isLexVarSym . occNameFS
-
-isConSym :: OccName -> Bool
-isConSym = isLexConSym . occNameFS
-
-
-getMainDeclBinder :: HsDecl name -> [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 _ = []
-
--- Extract the source location where an instance is defined. This is used
--- to correlate InstDecls with their Instance/CoAxiom Names, via the
--- instanceMap.
-getInstLoc :: InstDecl name -> SrcSpan
-getInstLoc (ClsInstD (ClsInstDecl { cid_poly_ty = L l _ })) = l
-getInstLoc (DataFamInstD (DataFamInstDecl { dfid_tycon = L l _ })) = l
-getInstLoc (TyFamInstD (TyFamInstDecl
- -- Since CoAxioms' Names refer to the whole line for type family instances
- -- in particular, we need to dig a bit deeper to pull out the entire
- -- equation. This does not happen for data family instances, for some reason.
- { tfid_eqn = L _ (TyFamInstEqn { tfie_rhs = L l _ })})) = l
-
--- Useful when there is a signature with multiple names, e.g.
--- foo, bar :: Types..
--- but only one of the names is exported and we have to change the
--- type signature to only include the exported names.
-filterLSigNames :: (name -> Bool) -> LSig name -> Maybe (LSig name)
-filterLSigNames p (L loc sig) = L loc <$> (filterSigNames p sig)
-
-filterSigNames :: (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 orig@(FixSig (FixitySig n _)) = ifTrueJust (p $ unLoc n) orig
-filterSigNames _ orig@(MinimalSig _) = Just orig
-filterSigNames p (TypeSig ns ty) =
- case filter (p . unLoc) ns of
- [] -> Nothing
- filtered -> Just (TypeSig filtered ty)
-filterSigNames _ _ = Nothing
-
-ifTrueJust :: Bool -> name -> Maybe name
-ifTrueJust True = Just
-ifTrueJust False = const Nothing
-
-sigName :: LSig name -> [name]
-sigName (L _ sig) = sigNameNoLoc sig
-
-sigNameNoLoc :: Sig name -> [name]
-sigNameNoLoc (TypeSig ns _) = map unLoc ns
-sigNameNoLoc (PatSynSig n _ _ _ _) = [unLoc n]
-sigNameNoLoc (SpecSig n _ _) = [unLoc n]
-sigNameNoLoc (InlineSig n _) = [unLoc n]
-sigNameNoLoc (FixSig (FixitySig n _)) = [unLoc n]
-sigNameNoLoc _ = []
-
-
-isTyClD :: HsDecl a -> Bool
-isTyClD (TyClD _) = True
-isTyClD _ = False
-
-
-isClassD :: HsDecl a -> Bool
-isClassD (TyClD d) = isClassDecl d
-isClassD _ = False
-
-
-isDocD :: HsDecl a -> Bool
-isDocD (DocD _) = True
-isDocD _ = False
-
-
-isInstD :: HsDecl a -> Bool
-isInstD (InstD _) = True
-isInstD _ = False
-
-
-isValD :: HsDecl a -> Bool
-isValD (ValD _) = True
-isValD _ = False
-
-
-declATs :: HsDecl a -> [a]
-declATs (TyClD d) | isClassDecl d = map (unL . fdLName . unL) $ tcdATs d
-declATs _ = []
-
-
-pretty :: Outputable a => DynFlags -> a -> String
-pretty = showPpr
-
-
-trace_ppr :: Outputable a => DynFlags -> a -> b -> b
-trace_ppr dflags x y = trace (pretty dflags x) y
-
-
--------------------------------------------------------------------------------
--- * Located
--------------------------------------------------------------------------------
-
-
-unL :: Located a -> a
-unL (L _ x) = x
-
-
-reL :: a -> Located a
-reL = L undefined
-
-
-before :: Located a -> Located a -> Bool
-before = (<) `on` getLoc
-
-
-instance Foldable (GenLocated l) where
- foldMap f (L _ x) = f x
-
-
-instance Traversable (GenLocated l) where
- mapM f (L l x) = (return . L l) =<< f x
- traverse f (L l x) = L l <$> f x
-
--------------------------------------------------------------------------------
--- * NamedThing instances
--------------------------------------------------------------------------------
-
-
-instance NamedThing (TyClDecl Name) where
- getName = tcdName
-
-
-instance NamedThing (ConDecl Name) where
- getName = unL . con_name
-
-
--------------------------------------------------------------------------------
--- * Subordinates
--------------------------------------------------------------------------------
-
-
-class Parent a where
- children :: a -> [Name]
-
-
-instance Parent (ConDecl Name) where
- children con =
- case con_details con of
- RecCon fields -> map (unL . cd_fld_name) fields
- _ -> []
-
-
-instance Parent (TyClDecl Name) where
- children d
- | isDataDecl d = map (unL . con_name . unL) . dd_cons . tcdDataDefn $ d
- | isClassDecl d =
- map (unL . fdLName . unL) (tcdATs d) ++
- [ unL n | L _ (TypeSig ns _) <- tcdSigs d, n <- ns ]
- | otherwise = []
-
-
--- | A parent and its children
-family :: (NamedThing a, Parent a) => a -> (Name, [Name])
-family = getName &&& children
-
-
--- | A mapping from the parent (main-binder) to its children and from each
--- child to its grand-children, recursively.
-families :: TyClDecl Name -> [(Name, [Name])]
-families d
- | isDataDecl d = family d : map (family . unL) (dd_cons (tcdDataDefn d))
- | isClassDecl d = [family d]
- | otherwise = []
-
-
--- | A mapping from child to parent
-parentMap :: TyClDecl Name -> [(Name, Name)]
-parentMap d = [ (c, p) | (p, cs) <- families d, c <- cs ]
-
-
--- | The parents of a subordinate in a declaration
-parents :: Name -> HsDecl Name -> [Name]
-parents n (TyClD d) = [ p | (c, p) <- parentMap d, c == n ]
-parents _ _ = []
-
-
--------------------------------------------------------------------------------
--- * Utils that work in monads defined by GHC
--------------------------------------------------------------------------------
-
-
-modifySessionDynFlags :: (DynFlags -> DynFlags) -> Ghc ()
-modifySessionDynFlags f = do
- dflags <- getSessionDynFlags
- _ <- setSessionDynFlags (f dflags)
- return ()
-
-
--- | A variant of 'gbracket' where the return value from the first computation
--- is not required.
-gbracket_ :: ExceptionMonad m => m a -> m b -> m c -> m c
-gbracket_ before_ after thing = gbracket before_ (const after) (const thing)
-
--- Extract the minimal complete definition of a Name, if one exists
-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
-
--------------------------------------------------------------------------------
--- * DynFlags
--------------------------------------------------------------------------------
-
-
-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 }
- -- -stubdir D adds an implicit -I D, so that gcc can find the _stub.h file
- -- \#included from the .hc file when compiling with -fvia-C.
-setOutputDir f = setObjectDir f . setHiDir f . setStubDir f
-
generated by cgit v1.2.3 (git 2.39.1) at 2024-09-21 08:26:59 +0000