From a03f1b96b464b09ce9679bc1bbd45fea221e89b6 Mon Sep 17 00:00:00 2001 From: David Waern Date: Sun, 5 Apr 2009 12:42:53 +0000 Subject: Move H.GHC.Utils to H.GhcUtils --- haddock.cabal | 5 +- src/Haddock/Backends/Hoogle.hs | 2 +- src/Haddock/Backends/Html.hs | 2 +- src/Haddock/GHC.hs | 4 +- src/Haddock/GHC/Utils.hs | 195 ---------------------------------------- src/Haddock/GhcUtils.hs | 195 ++++++++++++++++++++++++++++++++++++++++ src/Haddock/Interface.hs | 2 +- src/Haddock/Interface/Create.hs | 2 +- src/Haddock/Interface/Rename.hs | 2 +- src/Haddock/Utils.hs | 2 +- 10 files changed, 205 insertions(+), 206 deletions(-) delete mode 100644 src/Haddock/GHC/Utils.hs create mode 100644 src/Haddock/GhcUtils.hs diff --git a/haddock.cabal b/haddock.cabal index 73b92dad..9fe53e43 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -112,8 +112,7 @@ executable haddock Haddock.InterfaceFile Haddock.Exception Haddock.Options - Haddock.GHC.Utils - Haddock.GHC + Haddock.GhcUtils -- Cabal doesn't define __GHC_PATCHLEVEL__ if impl(ghc == 6.10.1) @@ -133,7 +132,7 @@ library Haddock.InterfaceFile Haddock.Exception Haddock.Utils - Haddock.GHC.Utils + Haddock.GhcUtils -- Cabal doesn't define __GHC_PATCHLEVEL__ if impl(ghc == 6.10.1) diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs index 242d075c..089e58de 100644 --- a/src/Haddock/Backends/Hoogle.hs +++ b/src/Haddock/Backends/Hoogle.hs @@ -12,7 +12,7 @@ module Haddock.Backends.Hoogle ( ) where -import Haddock.GHC.Utils +import Haddock.GhcUtils import Haddock.Types import Haddock.Utils hiding (out) import GHC diff --git a/src/Haddock/Backends/Html.hs b/src/Haddock/Backends/Html.hs index 746fcbbd..3503900f 100644 --- a/src/Haddock/Backends/Html.hs +++ b/src/Haddock/Backends/Html.hs @@ -23,7 +23,7 @@ import Haddock.Version import Haddock.Utils import Haddock.Utils.Html hiding ( name, title, p ) import qualified Haddock.Utils.Html as Html -import Haddock.GHC.Utils +import Haddock.GhcUtils import qualified Haddock.Utils.Html as Html import Control.Exception ( bracket ) diff --git a/src/Haddock/GHC.hs b/src/Haddock/GHC.hs index 8ec4be82..c7ef9b88 100644 --- a/src/Haddock/GHC.hs +++ b/src/Haddock/GHC.hs @@ -7,11 +7,11 @@ module Haddock.GHC ( startGhc, - module Haddock.GHC.Utils + module Haddock.GhcUtils ) where -import Haddock.GHC.Utils +import Haddock.GhcUtils import Haddock.Exception import Data.Maybe diff --git a/src/Haddock/GHC/Utils.hs b/src/Haddock/GHC/Utils.hs deleted file mode 100644 index 7cbcf07f..00000000 --- a/src/Haddock/GHC/Utils.hs +++ /dev/null @@ -1,195 +0,0 @@ --- --- Haddock - A Haskell Documentation Tool --- --- (c) Simon Marlow 2003 --- - - -{-# LANGUAGE FlexibleInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# OPTIONS_HADDOCK hide #-} - - -module Haddock.GHC.Utils where - - -import Data.Char -import Data.Version -import qualified Data.Map as Map -import Control.Arrow -import Data.Foldable hiding (concatMap) -import Data.Traversable - -import HsSyn -import SrcLoc -import Outputable -import Name -import Packages -import Module - - -moduleString :: Module -> String -moduleString = moduleNameString . moduleName - - --- return the name of the package, with version info -modulePackageString :: Module -> String -modulePackageString = packageIdString . modulePackageId - - --- return the (name,version) of the package -modulePackageInfo :: Module -> (String, [Char]) -modulePackageInfo modu = case unpackPackageId pkg of - Nothing -> (packageIdString pkg, "") -#if __GLASGOW_HASKELL__ >= 609 - Just x -> (display $ pkgName x, showVersion (pkgVersion x)) -#else - Just x -> (pkgName x, showVersion (pkgVersion x)) -#endif - where pkg = modulePackageId modu - - -mkModuleNoPackage :: String -> Module -mkModuleNoPackage str = mkModule (stringToPackageId "") (mkModuleName str) - - -instance (Outputable a, Outputable b) => Outputable (Map.Map a b) where - ppr m = ppr (Map.toList m) - - -isNameSym :: Name -> Bool -isNameSym = isSymOcc . nameOccName - - -isVarSym :: OccName -> Bool -isVarSym = isLexVarSym . occNameFS - - -getMainDeclBinder :: HsDecl name -> Maybe name -getMainDeclBinder (TyClD d) = Just (tcdName d) -getMainDeclBinder (ValD d) - = case collectAcc d [] of - [] -> Nothing - (name:_) -> Just (unLoc name) -getMainDeclBinder (SigD d) = sigNameNoLoc d -getMainDeclBinder (ForD (ForeignImport name _ _)) = Just (unLoc name) -getMainDeclBinder (ForD (ForeignExport _ _ _)) = Nothing -getMainDeclBinder _ = Nothing - - -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 (TyClD d) = isFamInstDecl d -isInstD _ = False - - -declATs :: HsDecl a -> [a] -declATs (TyClD d) | isClassDecl d = map (tcdName . unL) $ tcdATs d -declATs _ = [] - - -pretty :: Outputable a => a -> String -pretty x = showSDoc (ppr x) - - -trace_ppr :: Outputable a => a -> b -> b -trace_ppr x y = trace (pretty x) y - - -------------------------------------------------------------------------------- --- Located -------------------------------------------------------------------------------- - - -unL :: Located a -> a -unL (L _ x) = x - - -reL :: a -> Located a -reL = L undefined - - -instance Foldable Located where - foldMap f (L _ x) = f x - - -instance Traversable Located where - mapM f (L l x) = (return . 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) . tcdCons $ d - | isClassDecl d = - map (tcdName . unL) (tcdATs d) ++ - [ unL n | L _ (TypeSig n _) <- tcdSigs d ] - | 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) (tcdCons d) - | isClassDecl d = family d : concatMap (families . unL) (tcdATs 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 _ _ = [] diff --git a/src/Haddock/GhcUtils.hs b/src/Haddock/GhcUtils.hs new file mode 100644 index 00000000..af091a7a --- /dev/null +++ b/src/Haddock/GhcUtils.hs @@ -0,0 +1,195 @@ +-- +-- Haddock - A Haskell Documentation Tool +-- +-- (c) Simon Marlow 2003 +-- + + +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_HADDOCK hide #-} + + +module Haddock.GhcUtils where + + +import Data.Char +import Data.Version +import qualified Data.Map as Map +import Control.Arrow +import Data.Foldable hiding (concatMap) +import Data.Traversable + +import HsSyn +import SrcLoc +import Outputable +import Name +import Packages +import Module + + +moduleString :: Module -> String +moduleString = moduleNameString . moduleName + + +-- return the name of the package, with version info +modulePackageString :: Module -> String +modulePackageString = packageIdString . modulePackageId + + +-- return the (name,version) of the package +modulePackageInfo :: Module -> (String, [Char]) +modulePackageInfo modu = case unpackPackageId pkg of + Nothing -> (packageIdString pkg, "") +#if __GLASGOW_HASKELL__ >= 609 + Just x -> (display $ pkgName x, showVersion (pkgVersion x)) +#else + Just x -> (pkgName x, showVersion (pkgVersion x)) +#endif + where pkg = modulePackageId modu + + +mkModuleNoPackage :: String -> Module +mkModuleNoPackage str = mkModule (stringToPackageId "") (mkModuleName str) + + +instance (Outputable a, Outputable b) => Outputable (Map.Map a b) where + ppr m = ppr (Map.toList m) + + +isNameSym :: Name -> Bool +isNameSym = isSymOcc . nameOccName + + +isVarSym :: OccName -> Bool +isVarSym = isLexVarSym . occNameFS + + +getMainDeclBinder :: HsDecl name -> Maybe name +getMainDeclBinder (TyClD d) = Just (tcdName d) +getMainDeclBinder (ValD d) + = case collectAcc d [] of + [] -> Nothing + (name:_) -> Just (unLoc name) +getMainDeclBinder (SigD d) = sigNameNoLoc d +getMainDeclBinder (ForD (ForeignImport name _ _)) = Just (unLoc name) +getMainDeclBinder (ForD (ForeignExport _ _ _)) = Nothing +getMainDeclBinder _ = Nothing + + +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 (TyClD d) = isFamInstDecl d +isInstD _ = False + + +declATs :: HsDecl a -> [a] +declATs (TyClD d) | isClassDecl d = map (tcdName . unL) $ tcdATs d +declATs _ = [] + + +pretty :: Outputable a => a -> String +pretty x = showSDoc (ppr x) + + +trace_ppr :: Outputable a => a -> b -> b +trace_ppr x y = trace (pretty x) y + + +------------------------------------------------------------------------------- +-- Located +------------------------------------------------------------------------------- + + +unL :: Located a -> a +unL (L _ x) = x + + +reL :: a -> Located a +reL = L undefined + + +instance Foldable Located where + foldMap f (L _ x) = f x + + +instance Traversable Located where + mapM f (L l x) = (return . 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) . tcdCons $ d + | isClassDecl d = + map (tcdName . unL) (tcdATs d) ++ + [ unL n | L _ (TypeSig n _) <- tcdSigs d ] + | 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) (tcdCons d) + | isClassDecl d = family d : concatMap (families . unL) (tcdATs 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 _ _ = [] diff --git a/src/Haddock/Interface.hs b/src/Haddock/Interface.hs index 79bb00cf..b5f73ddb 100644 --- a/src/Haddock/Interface.hs +++ b/src/Haddock/Interface.hs @@ -19,7 +19,7 @@ import Haddock.Interface.AttachInstances import Haddock.Interface.Rename import Haddock.Types import Haddock.Options -import Haddock.GHC.Utils +import Haddock.GhcUtils import Haddock.Utils import Haddock.InterfaceFile diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index e5beffd1..0b271900 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -10,7 +10,7 @@ module Haddock.Interface.Create (createInterface) where import Haddock.Types import Haddock.Options -import Haddock.GHC.Utils +import Haddock.GhcUtils import Haddock.Utils import qualified Data.Map as Map diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs index 7a9a3292..733a372f 100644 --- a/src/Haddock/Interface/Rename.hs +++ b/src/Haddock/Interface/Rename.hs @@ -9,7 +9,7 @@ module Haddock.Interface.Rename (renameInterface) where import Haddock.Types -import Haddock.GHC.Utils +import Haddock.GhcUtils import GHC hiding (NoLink) import Name diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs index 86049d62..a3679dba 100644 --- a/src/Haddock/Utils.hs +++ b/src/Haddock/Utils.hs @@ -47,7 +47,7 @@ module Haddock.Utils ( ) where import Haddock.Types -import Haddock.GHC.Utils +import Haddock.GhcUtils import GHC import SrcLoc -- cgit v1.2.3