From 28e685d2589e4cd6847c21fe45a3b702c15090ea Mon Sep 17 00:00:00 2001
From: Niklas Haas <git@nand.wakku.to>
Date: Mon, 10 Mar 2014 21:03:22 +0100
Subject: Include fixity information in the Interface file

This resolves fixity information not appearing across package borders.

The binary file version has been increased accordingly.
---
 src/Haddock/Interface/AttachInstances.hs | 55 +++++++++++++++++---------------
 src/Haddock/Interface/Create.hs          |  1 +
 2 files changed, 30 insertions(+), 26 deletions(-)

(limited to 'src/Haddock/Interface')

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
-- 
cgit v1.2.3