aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock/Backends/Hyperlinker/Utils.hs
blob: 5daa5522665ce95164e36b8009bcaad9c474cc31 (plain) (blame)
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