[commit: haddock] master: Include fixity information in the Interface file (28e685d)
git at git.haskell.org
git at git.haskell.org
Tue Mar 11 09:49:10 UTC 2014
Repository : ssh://git@git.haskell.org/haddock
On branch : master
Link : http://git.haskell.org/haddock.git/commitdiff/28e685d2589e4cd6847c21fe45a3b702c15090ea
>---------------------------------------------------------------
commit 28e685d2589e4cd6847c21fe45a3b702c15090ea
Author: Niklas Haas <git at nand.wakku.to>
Date: Mon Mar 10 21:03:22 2014 +0100
Include fixity information in the Interface file
This resolves fixity information not appearing across package borders.
The binary file version has been increased accordingly.
>---------------------------------------------------------------
28e685d2589e4cd6847c21fe45a3b702c15090ea
src/Haddock/Interface/AttachInstances.hs | 55 ++++++++++++++++--------------
src/Haddock/Interface/Create.hs | 1 +
src/Haddock/InterfaceFile.hs | 11 +++---
src/Haddock/Types.hs | 3 ++
4 files changed, 40 insertions(+), 30 deletions(-)
diff --git a/src/Haddock/Interface/AttachInstances.hs b/src/Haddock/Interface/AttachInstances.hs
index 8c9d45c..88512c1 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 at 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 at 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 e23e992..aef2cd8 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 b4d5406..924829d 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 179413e..9538f3b 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
}
More information about the ghc-commits
mailing list