1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
|
{-# LANGUAGE MagicHash #-}
-----------------------------------------------------------------------------
-- |
-- Module : Haddock.Interface.AttachInstances
-- Copyright : (c) David Waern 2006-2009
-- License : BSD-like
--
-- Maintainer : haddock@projects.haskell.org
-- Stability : experimental
-- Portability : portable
-----------------------------------------------------------------------------
module Haddock.Interface.AttachInstances (attachInstances) where
import Haddock.Types
import Haddock.Convert
import qualified Data.Map as Map
import Data.Map (Map)
import Data.List
import GHC
import Name
import InstEnv
import Class
#if __GLASGOW_HASKELL__ >= 610 && __GHC_PATCHLEVEL__ >= 2
import TypeRep hiding (funTyConName)
#else
import TypeRep
#endif
import Var hiding (varName)
import TyCon
import PrelNames
import FastString
#define FSLIT(x) (mkFastString# (x#))
attachInstances :: [Interface] -> [Name] -> [Interface]
attachInstances ifaces filterNames = map attach ifaces
where
instMap =
fmap (map toHsInstHead . sortImage instHead) $
collectInstances ifaces filterNames
attach iface = iface { ifaceExportItems = newItems }
where
newItems = map attachExport (ifaceExportItems iface)
attachExport (ExportDecl decl@(L _ (TyClD d)) doc subs _)
| isClassDecl d || isDataDecl d || isFamilyDecl d =
ExportDecl decl doc subs (case Map.lookup (tcdName d) instMap of
Nothing -> []
Just instheads -> instheads)
attachExport export = export
--------------------------------------------------------------------------------
-- Collecting and sorting instances
--------------------------------------------------------------------------------
-- | Simplified type for sorting types, ignoring qualification (not visible
-- in Haddock output) and unifying special tycons with normal ones.
data SimpleType = SimpleType Name [SimpleType] deriving (Eq,Ord)
collectInstances
:: [Interface]
-> [Name]
-> Map Name [([TyVar], [PredType], Class, [Type])] -- maps class/type names to instances
collectInstances ifaces _ -- filterNames
= Map.fromListWith (flip (++)) tyInstPairs `Map.union`
Map.fromListWith (flip (++)) classInstPairs
where
allInstances = concatMap ifaceInstances ifaces
classInstPairs = [ (is_cls inst, [instanceHead inst]) |
inst <- allInstances ]
-- unfinished filtering of internal instances
-- Just n <- nub (is_tcs inst) ]
-- n `elem` filterNames ]
tyInstPairs = [ (tycon, [instanceHead inst]) | inst <- allInstances,
Just tycon <- nub (is_tcs inst) ]
-- TODO: should we support PredTy here?
instHead :: ([TyVar], [PredType], Class, [Type]) -> ([Int], Name, [SimpleType])
instHead (_, _, cls, args)
= (map argCount args, className cls, map simplify args)
where
argCount (AppTy t _) = argCount t + 1
argCount (TyConApp _ ts) = length ts
argCount (FunTy _ _ ) = 2
argCount (ForAllTy _ t) = argCount t
argCount _ = 0
simplify (ForAllTy _ t) = simplify t
simplify (FunTy t1 t2) =
SimpleType funTyConName [simplify t1, simplify t2]
simplify (AppTy t1 t2) = SimpleType s (ts ++ [simplify t2])
where (SimpleType s ts) = simplify t1
simplify (TyVarTy v) = SimpleType (tyVarName v) []
simplify (TyConApp tc ts) = SimpleType (tyConName tc) (map simplify ts)
simplify _ = error "simplify"
-- sortImage f = sortBy (\x y -> compare (f x) (f y))
sortImage :: Ord b => (a -> b) -> [a] -> [a]
sortImage f xs = map snd $ sortBy cmp_fst [(f x, x) | x <- xs]
where cmp_fst (x,_) (y,_) = compare x y
funTyConName :: Name
funTyConName = mkWiredInName gHC_PRIM
(mkOccNameFS tcName FSLIT("(->)"))
funTyConKey
(ATyCon funTyCon) -- Relevant TyCon
BuiltInSyntax
toHsInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead Name
toHsInstHead (_, preds, cls, ts) =
( map (unLoc . synifyPred) preds
, getName cls
, map (unLoc . synifyType WithinType) ts
)
|
