From 3fe640b29fccb30943612ec1b99b8cd1dbc0fa9f Mon Sep 17 00:00:00 2001 From: David Waern Date: Wed, 11 Jul 2007 20:37:11 +0000 Subject: Follow changes to record constructor representation --- src/Haddock/Html.hs | 10 +++++----- src/Haddock/InterfaceFile.hs | 2 +- src/Haddock/Rename.hs | 14 +++++++------- src/Haddock/Types.hs | 2 +- src/Haddock/Utils.hs | 4 ++-- src/Haddock/Version.hs | 4 ++-- src/Main.hs | 16 ++++++++-------- 7 files changed, 26 insertions(+), 26 deletions(-) (limited to 'src') diff --git a/src/Haddock/Html.hs b/src/Haddock/Html.hs index 6bd80687..c6b4edf0 100644 --- a/src/Haddock/Html.hs +++ b/src/Haddock/Html.hs @@ -33,7 +33,7 @@ import Debug.Trace ( trace ) import Data.Map ( Map ) import qualified Data.Map as Map hiding ( Map ) -import GHC +import GHC hiding ( NoLink ) import Name import Module import PackageConfig ( stringToPackageId ) @@ -1044,8 +1044,8 @@ ppSideBySideConstr (L _ con) = case con_res con of mbLDoc = con_doc con mkFunTy a b = noLoc (HsFunTy a b) -ppSideBySideField :: HsRecField DocName (LHsType DocName) -> HtmlTable -ppSideBySideField (HsRecField lname ltype mbLDoc) = +ppSideBySideField :: ConDeclField DocName -> HtmlTable +ppSideBySideField (ConDeclField lname ltype mbLDoc) = argBox (ppBinder False (orig lname) <+> dcolon <+> ppLType ltype) <-> maybeRDocBox mbLDoc @@ -1077,8 +1077,8 @@ ppHsFullConstr (HsRecDecl _ nm tvs ctxt fields doc) = ) -} -ppShortField :: Bool -> HsRecField DocName (LHsType DocName)-> HtmlTable -ppShortField summary (HsRecField lname ltype mbLDoc) +ppShortField :: Bool -> ConDeclField DocName -> HtmlTable +ppShortField summary (ConDeclField lname ltype _) = tda [theclass "recfield"] << ( ppBinder summary (orig lname) <+> dcolon <+> ppLType ltype diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs index c4f24bef..5e8a9424 100644 --- a/src/Haddock/InterfaceFile.hs +++ b/src/Haddock/InterfaceFile.hs @@ -182,7 +182,7 @@ fromOnDiskName arr nc (pid, mod_name, occ) = let us = nsUniqs nc uniq = uniqFromSupply us - name = mkExternalName uniq mod occ noSrcLoc + name = mkExternalName uniq mod occ noSrcSpan new_cache = extendNameCache cache mod occ name in case splitUniqSupply us of { (us',_) -> diff --git a/src/Haddock/Rename.hs b/src/Haddock/Rename.hs index 7e12a412..6ba07215 100644 --- a/src/Haddock/Rename.hs +++ b/src/Haddock/Rename.hs @@ -11,7 +11,7 @@ module Haddock.Rename ( import Haddock.Types -import GHC +import GHC hiding ( NoLink ) import BasicTypes import SrcLoc import Bag ( emptyBag ) @@ -186,7 +186,7 @@ renameType t = case t of return (HsDocTy t' doc') _ -> error "renameType" - + renameLTyVarBndr (L loc tv) = do name' <- rename (hsTyVarName tv) return $ L loc (replaceTyVarName tv name') @@ -261,11 +261,11 @@ renameTyClD d = case d of a' <- renameLType a b' <- renameLType b return (InfixCon a' b') - - renameField (HsRecField id arg doc) = do - arg' <- renameLType arg - doc' <- mapM renameLDoc doc - return (HsRecField (keepL id) arg' doc') + + renameField (ConDeclField name t doc) = do + t' <- renameLType t + doc' <- mapM renameLDoc doc + return (ConDeclField (keepL name) t' doc') renameResType (ResTyH98) = return ResTyH98 renameResType (ResTyGADT t) = return . ResTyGADT =<< renameLType t diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs index 4c4587ac..6ae2309e 100644 --- a/src/Haddock/Types.hs +++ b/src/Haddock/Types.hs @@ -8,7 +8,7 @@ module Haddock.Types where -import GHC +import GHC hiding (NoLink) import Outputable import Data.Map diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs index 27f60e4a..a7f5f8a9 100644 --- a/src/Haddock/Utils.hs +++ b/src/Haddock/Utils.hs @@ -95,8 +95,8 @@ restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] -- it's the best we can do. InfixCon _ _ -> Just d where - field_avail (HsRecField n _ _) = (unLoc n) `elem` names - field_types flds = [ ty | HsRecField n ty _ <- flds] + field_avail (ConDeclField n _ _) = (unLoc n) `elem` names + field_types flds = [ t | ConDeclField _ t _ <- flds ] keep d | otherwise = Nothing diff --git a/src/Haddock/Version.hs b/src/Haddock/Version.hs index f4d02b7d..3df24f1c 100644 --- a/src/Haddock/Version.hs +++ b/src/Haddock/Version.hs @@ -8,8 +8,8 @@ module Haddock.Version ( projectName, projectVersion, projectUrl ) where -import Paths_haddock_ghc ( version ) -import Data.Version ( showVersion ) +import Paths_haddock ( version ) +import Data.Version ( showVersion ) projectName, projectUrl :: String projectName = "Haddock-GHC" diff --git a/src/Main.hs b/src/Main.hs index 28723e71..e5132378 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -17,7 +17,7 @@ import Haddock.Version import Haddock.InterfaceFile import Haddock.Exception import Haddock.Utils.GHC -import Paths_haddock_ghc ( getDataDir ) +import Paths_haddock ( getDataDir ) import Prelude hiding ( catch ) import Control.Exception @@ -47,7 +47,7 @@ import qualified Data.Map as Map import Data.Map (Map) import Distribution.InstalledPackageInfo ( InstalledPackageInfo(..) ) -import Distribution.Simple.Utils ( withTempFile ) +import Distribution.Simple.Utils import GHC import Outputable @@ -301,8 +301,8 @@ byeVersion = startGHC :: String -> IO (Session, DynFlags) startGHC libDir = do - let ghcMode = BatchCompile - session <- newSession ghcMode (Just libDir) + --let ghcMode = BatchCompile + session <- newSession (Just libDir) flags <- getSessionDynFlags session flags' <- liftM fst (initPackages flags) let flags'' = dopt_set flags' Opt_Haddock @@ -575,7 +575,7 @@ mkDocMap group = Map.fromList (topDeclDocs ++ classMethDocs ++ recordFieldDocs) classMethDocs = concatMap (collectDocs . collectClassEntities) classes recordFieldDocs = [ (unLoc lname, doc) | - HsRecField lname _ (Just (L _ doc)) <- fields ] + ConDeclField lname _ (Just (L _ doc)) <- fields ] -------------------------------------------------------------------------------- -- Source code entities @@ -937,11 +937,11 @@ extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found" extractRecSel nm mdl t tvs (L _ con : rest) = case con_details con of - RecCon fields | (HsRecField n ty _ : _) <- matching_fields fields -> + RecCon fields | (ConDeclField n ty _ : _) <- matching_fields fields -> L (getLoc n) (TypeSig (noLoc nm) (noLoc (HsFunTy data_ty (getBangType ty)))) _ -> extractRecSel nm mdl t tvs rest where - matching_fields flds = [ f | f@(HsRecField n _ _) <- flds, (unLoc n) == nm ] + matching_fields flds = [ f | f@(ConDeclField n _ _) <- flds, (unLoc n) == nm ] data_ty = foldl (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar t)) (map toTypeNoLoc tvs) -- ----------------------------------------------------------------------------- @@ -1044,7 +1044,7 @@ buildGlobalDocEnv modules keep_new env n = Map.insert n (nameSetMod n modName) env nameSetMod n newMod = mkExternalName (nameUnique n) newMod (nameOccName n) - (nameSrcLoc n) + (nameSrcSpan n) -- ----------------------------------------------------------------------------- -- Named documentation -- cgit v1.2.3