Include fixity information in the Interface file

This resolves fixity information not appearing across package borders.

The binary file version has been increased accordingly.

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
   }