haskell-language-server-2.7.0.0: plugins/hls-refactor-plugin/src/Development/IDE/GHC/Dump.hs
{-# LANGUAGE CPP #-}
module Development.IDE.GHC.Dump(showAstDataHtml) where
import qualified Data.ByteString as B
import Data.Data hiding (Fixity)
import Development.IDE.GHC.Compat hiding (LocatedA,
NameAnn)
import Development.IDE.GHC.Compat.ExactPrint
import Development.IDE.GHC.Compat.Util
import Generics.SYB (ext1Q, ext2Q, extQ)
import GHC.Hs hiding (AnnLet)
import GHC.Hs.Dump
import GHC.Plugins hiding (AnnLet)
import Prelude hiding ((<>))
-- | Show a GHC syntax tree in HTML.
showAstDataHtml :: (Data a, ExactPrint a) => a -> SDoc
showAstDataHtml a0 = html $
header $$
body (tag' [("id",text (show @String "myUL"))] "ul" $ vcat
[
li (pre $ text (exactPrint a0)),
li (showAstDataHtml' a0),
li (nested "Raw" $ pre $ showAstData NoBlankSrcSpan NoBlankEpAnnotations a0)
])
where
tag = tag' []
tag' attrs t cont =
angleBrackets (text t <+> hcat [text a<>char '=' <>v | (a,v) <- attrs])
<> cont
<> angleBrackets (char '/' <> text t)
ul = tag' [("class", text (show @String "nested"))] "ul"
li = tag "li"
caret x = tag' [("class", text "caret")] "span" "" <+> x
nested foo cts
#if !MIN_VERSION_ghc(9,3,0)
| cts == empty = foo
#endif
| otherwise = foo $$ (caret $ ul cts)
body cts = tag "body" $ cts $$ tag "script" (text js)
header = tag "head" $ tag "style" $ text css
html = tag "html"
pre = tag "pre"
showAstDataHtml' :: Data a => a -> SDoc
showAstDataHtml' =
generic
`ext1Q` list
`extQ` string `extQ` fastString `extQ` srcSpan `extQ` realSrcSpan
`extQ` annotation
`extQ` annotationModule
`extQ` annotationAddEpAnn
`extQ` annotationGrhsAnn
`extQ` annotationEpAnnHsCase
`extQ` annotationEpAnnHsLet
`extQ` annotationAnnList
`extQ` annotationEpAnnImportDecl
`extQ` annotationAnnParen
`extQ` annotationTrailingAnn
`extQ` annotationEpaLocation
`extQ` addEpAnn
`extQ` lit `extQ` litr `extQ` litt
`extQ` sourceText
`extQ` deltaPos
`extQ` epaAnchor
`extQ` anchorOp
`extQ` bytestring
`extQ` name `extQ` occName `extQ` moduleName `extQ` var
`extQ` dataCon
`extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet
`extQ` fixity
`ext2Q` located
`extQ` srcSpanAnnA
`extQ` srcSpanAnnL
`extQ` srcSpanAnnP
`extQ` srcSpanAnnC
`extQ` srcSpanAnnN
where generic :: Data a => a -> SDoc
generic t = nested (text $ showConstr (toConstr t))
(vcat (gmapQ (li . showAstDataHtml') t))
string :: String -> SDoc
string = text . normalize_newlines . show
fastString :: FastString -> SDoc
fastString s = braces $
text "FastString:"
<+> text (normalize_newlines . show $ s)
bytestring :: B.ByteString -> SDoc
bytestring = text . normalize_newlines . show
list [] = brackets empty
list [x] = "[]" $$ showAstDataHtml' x
list xs = nested "[]" (vcat $ map (li . showAstDataHtml') xs)
-- Eliminate word-size dependence
lit :: HsLit GhcPs -> SDoc
lit (HsWordPrim s x) = numericLit "HsWord{64}Prim" x s
lit (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s
lit (HsIntPrim s x) = numericLit "HsInt{64}Prim" x s
lit (HsInt64Prim s x) = numericLit "HsInt{64}Prim" x s
lit l = generic l
litr :: HsLit GhcRn -> SDoc
litr (HsWordPrim s x) = numericLit "HsWord{64}Prim" x s
litr (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s
litr (HsIntPrim s x) = numericLit "HsInt{64}Prim" x s
litr (HsInt64Prim s x) = numericLit "HsInt{64}Prim" x s
litr l = generic l
litt :: HsLit GhcTc -> SDoc
litt (HsWordPrim s x) = numericLit "HsWord{64}Prim" x s
litt (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s
litt (HsIntPrim s x) = numericLit "HsInt{64}Prim" x s
litt (HsInt64Prim s x) = numericLit "HsInt{64}Prim" x s
litt l = generic l
numericLit :: String -> Integer -> SourceText -> SDoc
numericLit tag x s = braces $ hsep [ text tag
, generic x
, generic s ]
sourceText :: SourceText -> SDoc
sourceText NoSourceText = text "NoSourceText"
#if MIN_VERSION_ghc(9,7,0)
sourceText (SourceText src) = text "SourceText" <+> ftext src
#else
sourceText (SourceText src) = text "SourceText" <+> text src
#endif
epaAnchor :: EpaLocation -> SDoc
#if MIN_VERSION_ghc(9,5,0)
epaAnchor (EpaSpan r _) = text "EpaSpan" <+> realSrcSpan r
#else
epaAnchor (EpaSpan r) = text "EpaSpan" <+> realSrcSpan r
#endif
epaAnchor (EpaDelta d cs) = text "EpaDelta" <+> deltaPos d <+> showAstDataHtml' cs
anchorOp :: AnchorOperation -> SDoc
anchorOp UnchangedAnchor = "UnchangedAnchor"
anchorOp (MovedAnchor dp) = "MovedAnchor " <> deltaPos dp
deltaPos :: DeltaPos -> SDoc
deltaPos (SameLine c) = text "SameLine" <+> ppr c
deltaPos (DifferentLine l c) = text "DifferentLine" <+> ppr l <+> ppr c
name :: Name -> SDoc
name nm = braces $ text "Name:" <+> ppr nm
occName n = braces $
text "OccName:"
<+> text (occNameString n)
moduleName :: ModuleName -> SDoc
moduleName m = braces $ text "ModuleName:" <+> ppr m
srcSpan :: SrcSpan -> SDoc
srcSpan ss = char ' ' <>
hang (ppr ss) 1
-- TODO: show annotations here
(text "")
realSrcSpan :: RealSrcSpan -> SDoc
realSrcSpan ss = braces $ char ' ' <>
hang (ppr ss) 1
-- TODO: show annotations here
(text "")
addEpAnn :: AddEpAnn -> SDoc
addEpAnn (AddEpAnn a s) = text "AddEpAnn" <+> ppr a <+> epaAnchor s
var :: Var -> SDoc
var v = braces $ text "Var:" <+> ppr v
dataCon :: DataCon -> SDoc
dataCon c = braces $ text "DataCon:" <+> ppr c
bagRdrName:: Bag (LocatedA (HsBind GhcPs)) -> SDoc
bagRdrName bg = braces $
text "Bag(LocatedA (HsBind GhcPs)):"
$$ (list . bagToList $ bg)
bagName :: Bag (LocatedA (HsBind GhcRn)) -> SDoc
bagName bg = braces $
text "Bag(LocatedA (HsBind Name)):"
$$ (list . bagToList $ bg)
bagVar :: Bag (LocatedA (HsBind GhcTc)) -> SDoc
bagVar bg = braces $
text "Bag(LocatedA (HsBind Var)):"
$$ (list . bagToList $ bg)
nameSet ns = braces $
text "NameSet:"
$$ (list . nameSetElemsStable $ ns)
fixity :: Fixity -> SDoc
fixity fx = braces $
text "Fixity:"
<+> ppr fx
located :: (Data a, Data b) => GenLocated a b -> SDoc
located (L ss a)
= nested "L" (li (showAstDataHtml' ss) $$ li (showAstDataHtml' a))
-- -------------------------
annotation :: EpAnn [AddEpAnn] -> SDoc
annotation = annotation' (text "EpAnn [AddEpAnn]")
annotationModule :: EpAnn AnnsModule -> SDoc
annotationModule = annotation' (text "EpAnn AnnsModule")
annotationAddEpAnn :: EpAnn AddEpAnn -> SDoc
annotationAddEpAnn = annotation' (text "EpAnn AddEpAnn")
annotationGrhsAnn :: EpAnn GrhsAnn -> SDoc
annotationGrhsAnn = annotation' (text "EpAnn GrhsAnn")
annotationEpAnnHsCase :: EpAnn EpAnnHsCase -> SDoc
annotationEpAnnHsCase = annotation' (text "EpAnn EpAnnHsCase")
#if MIN_VERSION_ghc(9,4,0)
annotationEpAnnHsLet :: EpAnn NoEpAnns -> SDoc
annotationEpAnnHsLet = annotation' (text "EpAnn NoEpAnns")
#else
annotationEpAnnHsLet :: EpAnn AnnsLet -> SDoc
annotationEpAnnHsLet = annotation' (text "EpAnn AnnsLet")
#endif
annotationAnnList :: EpAnn AnnList -> SDoc
annotationAnnList = annotation' (text "EpAnn AnnList")
annotationEpAnnImportDecl :: EpAnn EpAnnImportDecl -> SDoc
annotationEpAnnImportDecl = annotation' (text "EpAnn EpAnnImportDecl")
annotationAnnParen :: EpAnn AnnParen -> SDoc
annotationAnnParen = annotation' (text "EpAnn AnnParen")
annotationTrailingAnn :: EpAnn TrailingAnn -> SDoc
annotationTrailingAnn = annotation' (text "EpAnn TrailingAnn")
annotationEpaLocation :: EpAnn EpaLocation -> SDoc
annotationEpaLocation = annotation' (text "EpAnn EpaLocation")
annotation' :: forall a. Data a => SDoc -> EpAnn a -> SDoc
annotation' _tag anns = nested (text $ showConstr (toConstr anns))
(vcat (map li $ gmapQ showAstDataHtml' anns))
-- -------------------------
srcSpanAnnA :: SrcSpanAnn' (EpAnn AnnListItem) -> SDoc
srcSpanAnnA = locatedAnn'' (text "SrcSpanAnnA")
srcSpanAnnL :: SrcSpanAnn' (EpAnn AnnList) -> SDoc
srcSpanAnnL = locatedAnn'' (text "SrcSpanAnnL")
srcSpanAnnP :: SrcSpanAnn' (EpAnn AnnPragma) -> SDoc
srcSpanAnnP = locatedAnn'' (text "SrcSpanAnnP")
srcSpanAnnC :: SrcSpanAnn' (EpAnn AnnContext) -> SDoc
srcSpanAnnC = locatedAnn'' (text "SrcSpanAnnC")
srcSpanAnnN :: SrcSpanAnn' (EpAnn NameAnn) -> SDoc
srcSpanAnnN = locatedAnn'' (text "SrcSpanAnnN")
locatedAnn'' :: forall a. Data a
=> SDoc -> SrcSpanAnn' a -> SDoc
locatedAnn'' tag ss =
case cast ss of
Just ((SrcSpanAnn ann s) :: SrcSpanAnn' a) ->
nested "SrcSpanAnn" (
li(showAstDataHtml' ann)
$$ li(srcSpan s))
Nothing -> text "locatedAnn:unmatched" <+> tag
<+> text (showConstr (toConstr ss))
normalize_newlines :: String -> String
normalize_newlines ('\\':'r':'\\':'n':xs) = '\\':'n':normalize_newlines xs
normalize_newlines (x:xs) = x:normalize_newlines xs
normalize_newlines [] = []
css :: String
css = unlines
[ "body {background-color: black; color: white ;}"
, "/* Remove default bullets */"
, "ul, #myUL {"
, " list-style-type: none;"
, "}"
, "/* Remove margins and padding from the parent ul */"
, "#myUL {"
, " margin: 0; "
, " padding: 0; "
, "} "
, "/* Style the caret/arrow */ "
, ".caret { "
, " cursor: pointer; "
, " user-select: none; /* Prevent text selection */"
, "} "
, "/* Create the caret/arrow with a unicode, and style it */"
, ".caret::before { "
, " content: \"\\25B6 \"; "
, " color: white; "
, " display: inline-block; "
, " margin-right: 6px; "
, "} "
, "/* Rotate the caret/arrow icon when clicked on (using JavaScript) */"
, ".caret-down::before { "
, " transform: rotate(90deg); "
, "} "
, "/* Hide the nested list */ "
, ".nested { "
, " display: none; "
, "} "
, "/* Show the nested list when the user clicks on the caret/arrow (with JavaScript) */"
, ".active { "
, " display: block;}"
]
js :: String
js = unlines
[ "var toggler = document.getElementsByClassName(\"caret\");"
, "var i;"
, "for (i = 0; i < toggler.length; i++) {"
, " toggler[i].addEventListener(\"click\", function() {"
, " this.parentElement.querySelector(\".nested\").classList.toggle(\"active\");"
, " this.classList.toggle(\"caret-down\");"
, " }); }"
]