aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/Haddock/Interface/AttachInstances.hs55
-rw-r--r--src/Haddock/Interface/Create.hs1
-rw-r--r--src/Haddock/InterfaceFile.hs11
-rw-r--r--src/Haddock/Types.hs3
4 files changed, 40 insertions, 30 deletions
diff --git a/src/Haddock/Interface/AttachInstances.hs b/src/Haddock/Interface/AttachInstances.hs
index 8c9d45c4..88512c1a 100644
--- a/src/Haddock/Interface/AttachInstances.hs
+++ b/src/Haddock/Interface/AttachInstances.hs
@@ -16,10 +16,12 @@ module Haddock.Interface.AttachInstances (attachInstances) where
import Haddock.Types
import Haddock.Convert
+import Haddock.GhcUtils
import Control.Arrow
import Data.List
import Data.Ord (comparing)
+import Data.Function (on)
import qualified Data.Map as Map
import qualified Data.Set as Set
@@ -45,6 +47,7 @@ type ExportedNames = Set.Set Name
type Modules = Set.Set Module
type ExportInfo = (ExportedNames, Modules)
+-- Also attaches fixities
attachInstances :: ExportInfo -> [Interface] -> InstIfaceMap -> Ghc [Interface]
attachInstances expInfo ifaces instIfaceMap = mapM attach ifaces
where
@@ -59,19 +62,19 @@ attachInstances expInfo ifaces instIfaceMap = mapM attach ifaces
attachToExportItem :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap -> ExportItem Name -> Ghc (ExportItem Name)
attachToExportItem expInfo iface ifaceMap instIfaceMap export =
- case export of
- ExportDecl { expItemDecl = L _ (TyClD d) } -> do
+ case attachFixities export of
+ e@ExportDecl { expItemDecl = L _ (TyClD d) } -> do
mb_info <- getAllInfo (tcdName d)
let export' =
- export {
+ e {
expItemInstances =
case mb_info of
Just (_, _, cls_instances, fam_instances) ->
let fam_insts = [ (synifyFamInst i, n)
| i <- sortBy (comparing instFam) fam_instances
- , let n = lookupInstDoc (getName i) iface ifaceMap instIfaceMap
+ , let n = instLookup instDocMap (getName i) iface ifaceMap instIfaceMap
]
- cls_insts = [ (synifyInstHead i, lookupInstDoc n iface ifaceMap instIfaceMap)
+ cls_insts = [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap)
| let is = [ (instanceHead' i, getName i) | i <- cls_instances ]
, (i@(_,_,cls,tys), n) <- sortBy (comparing $ first instHead) is
, not $ isInstanceHidden expInfo cls tys
@@ -80,28 +83,28 @@ attachToExportItem expInfo iface ifaceMap instIfaceMap export =
Nothing -> []
}
return export'
- _ -> return export
-
-
-lookupInstDoc :: Name -> Interface -> IfaceMap -> InstIfaceMap -> Maybe (Doc Name)
--- TODO: capture this pattern in a function (when we have streamlined the
--- handling of instances)
-lookupInstDoc name iface ifaceMap instIfaceMap =
- case Map.lookup name (ifaceDocMap iface) of
- Just doc -> Just doc
- Nothing ->
- case Map.lookup modName ifaceMap of
- Just iface2 ->
- case Map.lookup name (ifaceDocMap iface2) of
- Just doc -> Just doc
- Nothing -> Nothing
- Nothing ->
- case Map.lookup modName instIfaceMap of
- Just instIface -> Map.lookup name (instDocMap instIface)
- Nothing -> Nothing
+ e -> return e
where
- modName = nameModule name
-
+ attachFixities e@ExportDecl{ expItemDecl = L _ d } = e { expItemFixities =
+ nubBy ((==) `on` fst) $ expItemFixities e ++
+ [ (n',f) | n <- getMainDeclBinder d
+ , Just subs <- [instLookup instSubMap n iface ifaceMap instIfaceMap]
+ , n' <- n : subs
+ , Just f <- [instLookup instFixMap n' iface ifaceMap instIfaceMap]
+ ] }
+
+ attachFixities e = e
+
+
+instLookup :: (InstalledInterface -> Map.Map Name a) -> Name
+ -> Interface -> IfaceMap -> InstIfaceMap -> Maybe a
+instLookup f name iface ifaceMap instIfaceMap =
+ case Map.lookup name (f $ toInstalledIface iface) of
+ res@(Just _) -> res
+ Nothing -> do
+ let ifaceMaps = Map.union (fmap toInstalledIface ifaceMap) instIfaceMap
+ iface' <- Map.lookup (nameModule name) ifaceMaps
+ Map.lookup name (f iface')
-- | Like GHC's 'instanceHead' but drops "silent" arguments.
instanceHead' :: ClsInst -> ([TyVar], ThetaType, Class, [Type])
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs
index e23e9922..aef2cd8f 100644
--- a/src/Haddock/Interface/Create.hs
+++ b/src/Haddock/Interface/Create.hs
@@ -141,6 +141,7 @@ createInterface tm flags modMap instIfaceMap = do
, ifaceVisibleExports = visibleNames
, ifaceDeclMap = declMap
, ifaceSubMap = subMap
+ , ifaceFixMap = fixMap
, ifaceModuleAliases = aliases
, ifaceInstances = instances
, ifaceFamInstances = fam_instances
diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs
index b4d5406d..924829d7 100644
--- a/src/Haddock/InterfaceFile.hs
+++ b/src/Haddock/InterfaceFile.hs
@@ -77,7 +77,7 @@ binaryInterfaceMagic = 0xD0Cface
--
binaryInterfaceVersion :: Word16
#if __GLASGOW_HASKELL__ == 709
-binaryInterfaceVersion = 24
+binaryInterfaceVersion = 25
binaryInterfaceVersionCompatibility :: [Word16]
binaryInterfaceVersionCompatibility = [binaryInterfaceVersion]
@@ -365,15 +365,17 @@ instance Binary InterfaceFile where
instance Binary InstalledInterface where
- put_ bh (InstalledInterface modu info docMap argMap exps visExps opts subMap) = do
+ put_ bh (InstalledInterface modu info docMap argMap
+ exps visExps opts subMap fixMap) = do
put_ bh modu
put_ bh info
put_ bh docMap
- put_ bh argMap
+ put_ bh argMap
put_ bh exps
put_ bh visExps
put_ bh opts
put_ bh subMap
+ put_ bh fixMap
get bh = do
modu <- get bh
@@ -384,9 +386,10 @@ instance Binary InstalledInterface where
visExps <- get bh
opts <- get bh
subMap <- get bh
+ fixMap <- get bh
return (InstalledInterface modu info docMap argMap
- exps visExps opts subMap)
+ exps visExps opts subMap fixMap)
instance Binary DocOption where
diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs
index 179413ea..9538f3bf 100644
--- a/src/Haddock/Types.hs
+++ b/src/Haddock/Types.hs
@@ -100,6 +100,7 @@ data Interface = Interface
, ifaceRnArgMap :: !(ArgMap DocName)
, ifaceSubMap :: !(Map Name [Name])
+ , ifaceFixMap :: !(Map Name Fixity)
, ifaceExportItems :: ![ExportItem Name]
, ifaceRnExportItems :: ![ExportItem DocName]
@@ -158,6 +159,7 @@ data InstalledInterface = InstalledInterface
, instOptions :: [DocOption]
, instSubMap :: Map Name [Name]
+ , instFixMap :: Map Name Fixity
}
@@ -172,6 +174,7 @@ toInstalledIface interface = InstalledInterface
, instVisibleExports = ifaceVisibleExports interface
, instOptions = ifaceOptions interface
, instSubMap = ifaceSubMap interface
+ , instFixMap = ifaceFixMap interface
}
generated by cgit v1.2.3 (git 2.39.1) at 2024-09-22 12:24:32 +0000