hls-refactor-plugin-2.3.0.0: src/Development/IDE/GHC/Dump.hs
{-# LANGUAGE CPP #-}
module Development.IDE.GHC.Dump(showAstDataHtml) where
import Data.Data hiding (Fixity)
import Development.IDE.GHC.Compat hiding (LocatedA,
NameAnn)
import Development.IDE.GHC.Compat.ExactPrint
import GHC.Hs.Dump
#if MIN_VERSION_ghc(9,2,1)
import qualified Data.ByteString as B
import Development.IDE.GHC.Compat.Util
import Generics.SYB (ext1Q, ext2Q, extQ)
import GHC.Hs hiding (AnnLet)
#endif
import GHC.Plugins hiding (AnnLet)
import Prelude hiding ((<>))
-- | Show a GHC syntax tree in HTML.
#if MIN_VERSION_ghc(9,2,1)
showAstDataHtml :: (Data a, ExactPrint a, Outputable a) => a -> SDoc
#else
showAstDataHtml :: (Data a, Outputable a) => a -> SDoc
#endif
showAstDataHtml a0 = html $
header $$
body (tag' [("id",text (show @String "myUL"))] "ul" $ vcat
[
#if MIN_VERSION_ghc(9,2,1)
li (pre $ text (exactPrint a0)),
li (showAstDataHtml' a0),
li (nested "Raw" $ pre $ showAstData NoBlankSrcSpan NoBlankEpAnnotations a0)
#else
li (nested "Raw" $ pre $ showAstData NoBlankSrcSpan
#if MIN_VERSION_ghc(9,3,0)
NoBlankEpAnnotations
#endif
a0)
#endif
])
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,2,1) && !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"
#if MIN_VERSION_ghc(9,2,1)
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"
sourceText (SourceText src) = text "SourceText" <+> text src
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, Typeable 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. (Typeable 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)))
#endif
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\");"
, " }); }"
]