{-# 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\");" , " }); }" ]