aboutsummaryrefslogtreecommitdiff
path: root/src/Haddock/Interface
diff options
context:
space:
mode:
authorNiklas Haas <git@nand.wakku.to>2014-03-10 21:03:22 +0100
committerNiklas Haas <git@nand.wakku.to>2014-03-11 10:26:04 +0100
commit28e685d2589e4cd6847c21fe45a3b702c15090ea (patch)
treee31e82b089480ab91c8e1454f0cf306751595821 /src/Haddock/Interface
parentc40ee25c4a9cc4952b237d1b5a659eaeb0023c05 (diff)
Include fixity information in the Interface file
This resolves fixity information not appearing across package borders. The binary file version has been increased accordingly.
Diffstat (limited to 'src/Haddock/Interface')
-rw-r--r--src/Haddock/Interface/AttachInstances.hs55
-rw-r--r--src/Haddock/Interface/Create.hs1
2 files changed, 30 insertions, 26 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