1{-# LANGUAGE RecordWildCards #-} 2{-# LANGUAGE ViewPatterns #-} 3{-# LANGUAGE PatternSynonyms #-} 4{-# LANGUAGE OverloadedStrings #-} 5{-# LANGUAGE BangPatterns #-} 6 7module Haddock.Backends.Hyperlinker.Renderer (render) where 8 9 10import Haddock.Backends.Hyperlinker.Types 11import Haddock.Backends.Hyperlinker.Utils 12 13import qualified Data.ByteString as BS 14 15import HieTypes 16import Module ( ModuleName, moduleNameString ) 17import Name ( getOccString, isInternalName, Name, nameModule, nameUnique ) 18import SrcLoc 19import Unique ( getKey ) 20import Encoding ( utf8DecodeByteString ) 21 22import System.FilePath.Posix ((</>)) 23 24import qualified Data.Map as Map 25import qualified Data.Set as Set 26 27import Text.XHtml (Html, HtmlAttr, (!)) 28import qualified Text.XHtml as Html 29 30 31type StyleClass = String 32 33-- | Produce the HTML corresponding to a hyperlinked Haskell source 34render 35 :: Maybe FilePath -- ^ path to the CSS file 36 -> Maybe FilePath -- ^ path to the JS file 37 -> SrcMaps -- ^ Paths to sources 38 -> HieAST PrintedType -- ^ ASTs from @.hie@ files 39 -> [Token] -- ^ tokens to render 40 -> Html 41render mcss mjs srcs ast tokens = header mcss mjs <> body srcs ast tokens 42 43body :: SrcMaps -> HieAST PrintedType -> [Token] -> Html 44body srcs ast tokens = Html.body . Html.pre $ hypsrc 45 where 46 hypsrc = renderWithAst srcs ast tokens 47 48header :: Maybe FilePath -> Maybe FilePath -> Html 49header Nothing Nothing = Html.noHtml 50header mcss mjs = Html.header $ css mcss <> js mjs 51 where 52 css Nothing = Html.noHtml 53 css (Just cssFile) = Html.thelink Html.noHtml ! 54 [ Html.rel "stylesheet" 55 , Html.thetype "text/css" 56 , Html.href cssFile 57 ] 58 js Nothing = Html.noHtml 59 js (Just scriptFile) = Html.script Html.noHtml ! 60 [ Html.thetype "text/javascript" 61 , Html.src scriptFile 62 ] 63 64 65splitTokens :: HieAST PrintedType -> [Token] -> ([Token],[Token],[Token]) 66splitTokens ast toks = (before,during,after) 67 where 68 (before,rest) = span leftOf toks 69 (during,after) = span inAst rest 70 leftOf t = realSrcSpanEnd (tkSpan t) <= realSrcSpanStart nodeSp 71 inAst t = nodeSp `containsSpan` tkSpan t 72 nodeSp = nodeSpan ast 73 74-- | Turn a list of tokens into hyperlinked sources, threading in relevant link 75-- information from the 'HieAST'. 76renderWithAst :: SrcMaps -> HieAST PrintedType -> [Token] -> Html 77renderWithAst srcs Node{..} toks = anchored $ case toks of 78 79 [tok] | nodeSpan == tkSpan tok -> richToken srcs nodeInfo tok 80 81 -- NB: the GHC lexer lexes backquoted identifiers and parenthesized operators 82 -- as multiple tokens. 83 -- 84 -- * @a `elem` b@ turns into @[a, `, elem, `, b]@ (excluding space tokens) 85 -- * @(+) 1 2@ turns into @[(, +, ), 1, 2]@ (excluding space tokens) 86 -- 87 -- However, the HIE ast considers @`elem`@ and @(+)@ to be single nodes. In 88 -- order to make sure these get hyperlinked properly, we intercept these 89 -- special sequences of tokens and merge them into just one identifier or 90 -- operator token. 91 [BacktickTok s1, tok@Token{ tkType = TkIdentifier }, BacktickTok s2] 92 | realSrcSpanStart s1 == realSrcSpanStart nodeSpan 93 , realSrcSpanEnd s2 == realSrcSpanEnd nodeSpan 94 -> richToken srcs nodeInfo 95 (Token{ tkValue = "`" <> tkValue tok <> "`" 96 , tkType = TkOperator 97 , tkSpan = nodeSpan }) 98 [OpenParenTok s1, tok@Token{ tkType = TkOperator }, CloseParenTok s2] 99 | realSrcSpanStart s1 == realSrcSpanStart nodeSpan 100 , realSrcSpanEnd s2 == realSrcSpanEnd nodeSpan 101 -> richToken srcs nodeInfo 102 (Token{ tkValue = "(" <> tkValue tok <> ")" 103 , tkType = TkOperator 104 , tkSpan = nodeSpan }) 105 106 _ -> go nodeChildren toks 107 where 108 go _ [] = mempty 109 go [] xs = foldMap renderToken xs 110 go (cur:rest) xs = 111 foldMap renderToken before <> renderWithAst srcs cur during <> go rest after 112 where 113 (before,during,after) = splitTokens cur xs 114 anchored c = Map.foldrWithKey anchorOne c (nodeIdentifiers nodeInfo) 115 anchorOne n dets c = externalAnchor n d $ internalAnchor n d c 116 where d = identInfo dets 117 118renderToken :: Token -> Html 119renderToken Token{..} 120 | BS.null tkValue = mempty 121 | tkType == TkSpace = renderSpace (srcSpanStartLine tkSpan) tkValue' 122 | otherwise = tokenSpan ! [ multiclass style ] 123 where 124 tkValue' = filterCRLF $ utf8DecodeByteString tkValue 125 style = tokenStyle tkType 126 tokenSpan = Html.thespan (Html.toHtml tkValue') 127 128 129-- | Given information about the source position of definitions, render a token 130richToken :: SrcMaps -> NodeInfo PrintedType -> Token -> Html 131richToken srcs details Token{..} 132 | tkType == TkSpace = renderSpace (srcSpanStartLine tkSpan) tkValue' 133 | otherwise = annotate details $ linked content 134 where 135 tkValue' = filterCRLF $ utf8DecodeByteString tkValue 136 content = tokenSpan ! [ multiclass style ] 137 tokenSpan = Html.thespan (Html.toHtml tkValue') 138 style = tokenStyle tkType ++ concatMap (richTokenStyle (null (nodeType details))) contexts 139 140 contexts = concatMap (Set.elems . identInfo) . Map.elems . nodeIdentifiers $ details 141 142 -- pick an arbitary identifier to hyperlink with 143 identDet = Map.lookupMin . nodeIdentifiers $ details 144 145 -- If we have name information, we can make links 146 linked = case identDet of 147 Just (n,_) -> hyperlink srcs n 148 Nothing -> id 149 150-- | Remove CRLFs from source 151filterCRLF :: String -> String 152filterCRLF ('\r':'\n':cs) = '\n' : filterCRLF cs 153filterCRLF (c:cs) = c : filterCRLF cs 154filterCRLF [] = [] 155 156annotate :: NodeInfo PrintedType -> Html -> Html 157annotate ni content = 158 Html.thespan (annot <> content) ! [ Html.theclass "annot" ] 159 where 160 annot 161 | not (null annotation) = 162 Html.thespan (Html.toHtml annotation) ! [ Html.theclass "annottext" ] 163 | otherwise = mempty 164 annotation = typ ++ identTyps 165 typ = unlines (nodeType ni) 166 typedIdents = [ (n,t) | (n, identType -> Just t) <- Map.toList $ nodeIdentifiers ni ] 167 identTyps 168 | length typedIdents > 1 || null (nodeType ni) 169 = concatMap (\(n,t) -> printName n ++ " :: " ++ t ++ "\n") typedIdents 170 | otherwise = "" 171 172 printName :: Either ModuleName Name -> String 173 printName = either moduleNameString getOccString 174 175richTokenStyle 176 :: Bool -- ^ are we lacking a type annotation? 177 -> ContextInfo -- ^ in what context did this token show up? 178 -> [StyleClass] 179richTokenStyle True Use = ["hs-type"] 180richTokenStyle False Use = ["hs-var"] 181richTokenStyle _ RecField{} = ["hs-var"] 182richTokenStyle _ PatternBind{} = ["hs-var"] 183richTokenStyle _ MatchBind{} = ["hs-var"] 184richTokenStyle _ TyVarBind{} = ["hs-type"] 185richTokenStyle _ ValBind{} = ["hs-var"] 186richTokenStyle _ TyDecl = ["hs-type"] 187richTokenStyle _ ClassTyDecl{} = ["hs-type"] 188richTokenStyle _ Decl{} = ["hs-var"] 189richTokenStyle _ IEThing{} = [] -- could be either a value or type 190 191tokenStyle :: TokenType -> [StyleClass] 192tokenStyle TkIdentifier = ["hs-identifier"] 193tokenStyle TkKeyword = ["hs-keyword"] 194tokenStyle TkString = ["hs-string"] 195tokenStyle TkChar = ["hs-char"] 196tokenStyle TkNumber = ["hs-number"] 197tokenStyle TkOperator = ["hs-operator"] 198tokenStyle TkGlyph = ["hs-glyph"] 199tokenStyle TkSpecial = ["hs-special"] 200tokenStyle TkSpace = [] 201tokenStyle TkComment = ["hs-comment"] 202tokenStyle TkCpp = ["hs-cpp"] 203tokenStyle TkPragma = ["hs-pragma"] 204tokenStyle TkUnknown = [] 205 206multiclass :: [StyleClass] -> HtmlAttr 207multiclass = Html.theclass . unwords 208 209externalAnchor :: Identifier -> Set.Set ContextInfo -> Html -> Html 210externalAnchor (Right name) contexts content 211 | not (isInternalName name) 212 , any isBinding contexts 213 = Html.thespan content ! [ Html.identifier $ externalAnchorIdent name ] 214externalAnchor _ _ content = content 215 216isBinding :: ContextInfo -> Bool 217isBinding (ValBind RegularBind _ _) = True 218isBinding PatternBind{} = True 219isBinding Decl{} = True 220isBinding (RecField RecFieldDecl _) = True 221isBinding TyVarBind{} = True 222isBinding ClassTyDecl{} = True 223isBinding _ = False 224 225internalAnchor :: Identifier -> Set.Set ContextInfo -> Html -> Html 226internalAnchor (Right name) contexts content 227 | isInternalName name 228 , any isBinding contexts 229 = Html.thespan content ! [ Html.identifier $ internalAnchorIdent name ] 230internalAnchor _ _ content = content 231 232externalAnchorIdent :: Name -> String 233externalAnchorIdent = hypSrcNameUrl 234 235internalAnchorIdent :: Name -> String 236internalAnchorIdent = ("local-" ++) . show . getKey . nameUnique 237 238-- | Generate the HTML hyperlink for an identifier 239hyperlink :: SrcMaps -> Identifier -> Html -> Html 240hyperlink (srcs, srcs') ident = case ident of 241 Right name | isInternalName name -> internalHyperlink name 242 | otherwise -> externalNameHyperlink name 243 Left name -> externalModHyperlink name 244 245 where 246 internalHyperlink name content = 247 Html.anchor content ! [ Html.href $ "#" ++ internalAnchorIdent name ] 248 249 externalNameHyperlink name content = case Map.lookup mdl srcs of 250 Just SrcLocal -> Html.anchor content ! 251 [ Html.href $ hypSrcModuleNameUrl mdl name ] 252 Just (SrcExternal path) -> Html.anchor content ! 253 [ Html.href $ spliceURL Nothing (Just mdl) (Just name) Nothing (".." </> path) ] 254 Nothing -> content 255 where 256 mdl = nameModule name 257 258 externalModHyperlink moduleName content = 259 case Map.lookup moduleName srcs' of 260 Just SrcLocal -> Html.anchor content ! 261 [ Html.href $ hypSrcModuleUrl' moduleName ] 262 Just (SrcExternal path) -> Html.anchor content ! 263 [ Html.href $ spliceURL' Nothing (Just moduleName) Nothing Nothing (".." </> path) ] 264 Nothing -> content 265 266 267renderSpace :: Int -> String -> Html 268renderSpace !_ "" = Html.noHtml 269renderSpace !line ('\n':rest) = mconcat 270 [ Html.thespan (Html.toHtml '\n') 271 , lineAnchor (line + 1) 272 , renderSpace (line + 1) rest 273 ] 274renderSpace line space = 275 let (hspace, rest) = span (/= '\n') space 276 in (Html.thespan . Html.toHtml) hspace <> renderSpace line rest 277 278 279lineAnchor :: Int -> Html 280lineAnchor line = Html.thespan Html.noHtml ! [ Html.identifier $ hypSrcLineUrl line ] 281