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
131
132
133
134
135
136
137
138
139
140
141
142
143
144
|
{-# LANGUAGE OverloadedStrings #-}
module Haddock.Backends.Hyperlinker.Utils
( hypSrcDir, hypSrcModuleFile, hypSrcModuleFile'
, hypSrcModuleUrl, hypSrcModuleUrl'
, hypSrcNameUrl
, hypSrcLineUrl
, hypSrcModuleNameUrl, hypSrcModuleLineUrl
, hypSrcModuleUrlFormat
, hypSrcModuleNameUrlFormat, hypSrcModuleLineUrlFormat
, spliceURL, spliceURL'
-- * HIE file processing
, PrintedType
, recoverFullIfaceTypes
) where
import Haddock.Utils
import Haddock.Backends.Xhtml.Utils
import GHC
import GHC.Iface.Ext.Types ( HieAST(..), HieType(..), HieArgs(..), TypeIndex, HieTypeFlat )
import GHC.Iface.Type
import GHC.Types.Name ( getOccFS, getOccString )
import GHC.Driver.Ppr ( showSDoc )
import GHC.Types.Var ( VarBndr(..) )
import System.FilePath.Posix ((</>), (<.>))
import qualified Data.Array as A
{-# INLINE hypSrcDir #-}
hypSrcDir :: FilePath
hypSrcDir = "src"
{-# INLINE hypSrcModuleFile #-}
hypSrcModuleFile :: Module -> FilePath
hypSrcModuleFile m = moduleNameString (moduleName m) <.> "html"
hypSrcModuleFile' :: ModuleName -> FilePath
hypSrcModuleFile' mdl = spliceURL'
Nothing (Just mdl) Nothing Nothing moduleFormat
hypSrcModuleUrl :: Module -> String
hypSrcModuleUrl = hypSrcModuleFile
hypSrcModuleUrl' :: ModuleName -> String
hypSrcModuleUrl' = hypSrcModuleFile'
{-# INLINE hypSrcNameUrl #-}
hypSrcNameUrl :: Name -> String
hypSrcNameUrl = escapeStr . getOccString
{-# INLINE hypSrcLineUrl #-}
hypSrcLineUrl :: Int -> String
hypSrcLineUrl line = "line-" ++ show line
{-# INLINE hypSrcModuleNameUrl #-}
hypSrcModuleNameUrl :: Module -> Name -> String
hypSrcModuleNameUrl mdl name = hypSrcModuleUrl mdl ++ "#" ++ hypSrcNameUrl name
{-# INLINE hypSrcModuleLineUrl #-}
hypSrcModuleLineUrl :: Module -> Int -> String
hypSrcModuleLineUrl mdl line = hypSrcModuleUrl mdl ++ "#" ++ hypSrcLineUrl line
hypSrcModuleUrlFormat :: String
hypSrcModuleUrlFormat = hypSrcDir </> moduleFormat
hypSrcModuleNameUrlFormat :: String
hypSrcModuleNameUrlFormat = hypSrcModuleUrlFormat ++ "#" ++ nameFormat
hypSrcModuleLineUrlFormat :: String
hypSrcModuleLineUrlFormat = hypSrcModuleUrlFormat ++ "#" ++ lineFormat
moduleFormat :: String
moduleFormat = "%{MODULE}.html"
nameFormat :: String
nameFormat = "%{NAME}"
lineFormat :: String
lineFormat = "line-%{LINE}"
-- * HIE file processing
-- This belongs in GHC.Iface.Ext.Utils...
-- | Pretty-printed type, ready to be turned into HTML by @xhtml@
type PrintedType = String
-- | Expand the flattened HIE AST into one where the types printed out and
-- ready for end-users to look at.
--
-- Using just primitives found in GHC's HIE utilities, we could write this as
-- follows:
--
-- > 'recoverFullIfaceTypes' dflags hieTypes hieAst
-- > = 'fmap' (\ti -> 'showSDoc' df .
-- > 'pprIfaceType' $
-- > 'recoverFullType' ti hieTypes)
-- > hieAst
--
-- However, this is very inefficient (both in time and space) because the
-- mutliple calls to 'recoverFullType' don't share intermediate results. This
-- function fixes that.
recoverFullIfaceTypes
:: DynFlags
-> A.Array TypeIndex HieTypeFlat -- ^ flat types
-> HieAST TypeIndex -- ^ flattened AST
-> HieAST PrintedType -- ^ full AST
recoverFullIfaceTypes df flattened ast = fmap (printed A.!) ast
where
-- Splitting this out into its own array is also important: we don't want
-- to pretty print the same type many times
printed :: A.Array TypeIndex PrintedType
printed = fmap (showSDoc df . pprIfaceType) unflattened
-- The recursion in 'unflattened' is crucial - it's what gives us sharing
-- between the IfaceType's produced
unflattened :: A.Array TypeIndex IfaceType
unflattened = fmap (\flatTy -> go (fmap (unflattened A.!) flatTy)) flattened
-- Unfold an 'HieType' whose subterms have already been unfolded
go :: HieType IfaceType -> IfaceType
go (HTyVarTy n) = IfaceTyVar (getOccFS n)
go (HAppTy a b) = IfaceAppTy a (hieToIfaceArgs b)
go (HLitTy l) = IfaceLitTy l
go (HForAllTy ((n,k),af) t) = let b = (getOccFS n, k)
in IfaceForAllTy (Bndr (IfaceTvBndr b) af) t
go (HFunTy w a b) = IfaceFunTy VisArg w a b
go (HQualTy con b) = IfaceFunTy InvisArg many_ty con b
go (HCastTy a) = a
go HCoercionTy = IfaceTyVar "<coercion type>"
go (HTyConApp a xs) = IfaceTyConApp a (hieToIfaceArgs xs)
-- This isn't fully faithful - we can't produce the 'Inferred' case
hieToIfaceArgs :: HieArgs IfaceType -> IfaceAppArgs
hieToIfaceArgs (HieArgs args) = go' args
where
go' [] = IA_Nil
go' ((True ,x):xs) = IA_Arg x Required $ go' xs
go' ((False,x):xs) = IA_Arg x Specified $ go' xs
|
