{-# LANGUAGE CPP #-} module Development.IDE.GHC.Dump(showAstDataHtml) where import Data.Data hiding (Fixity) import Development.IDE.GHC.Compat hiding (NameAnn) #if MIN_VERSION_ghc(8,10,1) import GHC.Hs.Dump #else import HsDumpAst #endif #if MIN_VERSION_ghc(9,2,1) import qualified Data.ByteString as B import Development.IDE.GHC.Compat.Util import GHC.Hs import Generics.SYB (ext1Q, ext2Q, extQ) #endif #if MIN_VERSION_ghc(9,0,1) import GHC.Plugins #else import GhcPlugins #endif 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 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) | 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 epaAnchor (EpaSpan r) = text "EpaSpan" <+> realSrcSpan r 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") annotationEpAnnHsLet :: EpAnn AnnsLet -> SDoc annotationEpAnnHsLet = annotation' (text "EpAnn AnnsLet") 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\");" , " }); }" ]