{-# 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 :: a -> SDoc
showAstDataHtml a
a0 = SDoc -> SDoc
html (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
    SDoc
header SDoc -> SDoc -> SDoc
$$
    SDoc -> SDoc
body ([(String, SDoc)] -> String -> SDoc -> SDoc
tag' [(String
"id",String -> SDoc
text (String -> String
forall a. Show a => a -> String
show @String String
"myUL"))] String
"ul" (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
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
            SDoc -> SDoc
li (SDoc -> SDoc -> SDoc
nested SDoc
"Raw" (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> SDoc
pre (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ BlankSrcSpan -> a -> SDoc
forall a. Data a => BlankSrcSpan -> a -> SDoc
showAstData BlankSrcSpan
NoBlankSrcSpan a
a0)
#endif
        ])
  where
    tag :: String -> SDoc -> SDoc
tag = [(String, SDoc)] -> String -> SDoc -> SDoc
tag' []
    tag' :: [(String, SDoc)] -> String -> SDoc -> SDoc
tag' [(String, SDoc)]
attrs String
t SDoc
cont =
        SDoc -> SDoc
angleBrackets (String -> SDoc
text String
t SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
hcat [String -> SDoc
text String
aSDoc -> SDoc -> SDoc
<>Char -> SDoc
char Char
'=' SDoc -> SDoc -> SDoc
<>SDoc
v | (String
a,SDoc
v) <- [(String, SDoc)]
attrs])
        SDoc -> SDoc -> SDoc
<> SDoc
cont
        SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
angleBrackets (Char -> SDoc
char Char
'/' SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
t)
    ul :: SDoc -> SDoc
ul = [(String, SDoc)] -> String -> SDoc -> SDoc
tag' [(String
"class", String -> SDoc
text (String -> String
forall a. Show a => a -> String
show @String String
"nested"))] String
"ul"
    li :: SDoc -> SDoc
li = String -> SDoc -> SDoc
tag String
"li"
    caret :: SDoc -> SDoc
caret SDoc
x = [(String, SDoc)] -> String -> SDoc -> SDoc
tag' [(String
"class", String -> SDoc
text String
"caret")] String
"span" SDoc
"" SDoc -> SDoc -> SDoc
<+> SDoc
x
    nested :: SDoc -> SDoc -> SDoc
nested SDoc
foo SDoc
cts
#if MIN_VERSION_ghc(9,2,1)
      | cts == empty = foo
#endif
      | Bool
otherwise = SDoc
foo SDoc -> SDoc -> SDoc
$$ (SDoc -> SDoc
caret (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> SDoc
ul SDoc
cts)
    body :: SDoc -> SDoc
body SDoc
cts = String -> SDoc -> SDoc
tag String
"body" (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc
cts SDoc -> SDoc -> SDoc
$$ String -> SDoc -> SDoc
tag String
"script" (String -> SDoc
text String
js)
    header :: SDoc
header = String -> SDoc -> SDoc
tag String
"head" (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc -> SDoc
tag String
"style" (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
css
    html :: SDoc -> SDoc
html = String -> SDoc -> SDoc
tag String
"html"
    pre :: SDoc -> SDoc
pre = String -> SDoc -> SDoc
tag String
"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 :: String -> String
normalize_newlines (Char
'\\':Char
'r':Char
'\\':Char
'n':String
xs) = Char
'\\'Char -> String -> String
forall a. a -> [a] -> [a]
:Char
'n'Char -> String -> String
forall a. a -> [a] -> [a]
:String -> String
normalize_newlines String
xs
normalize_newlines (Char
x:String
xs)                 = Char
xChar -> String -> String
forall a. a -> [a] -> [a]
:String -> String
normalize_newlines String
xs
normalize_newlines []                     = []

css :: String
css :: String
css = [String] -> String
unlines
  [ String
"body {background-color: black; color: white ;}"
  , String
"/* Remove default bullets */"
  , String
"ul, #myUL {"
  , String
"  list-style-type: none;"
  , String
"}"
  , String
"/* Remove margins and padding from the parent ul */"
  , String
"#myUL {"
  , String
"  margin: 0;                       "
  , String
"  padding: 0;                      "
  , String
"}                                  "
  , String
"/* Style the caret/arrow */        "
  , String
".caret {                           "
  , String
"  cursor: pointer;                 "
  , String
"  user-select: none; /* Prevent text selection */"
  , String
"}                                  "
  , String
"/* Create the caret/arrow with a unicode, and style it */"
  , String
".caret::before {                   "
  , String
"  content: \"\\25B6 \";                "
  , String
"  color: white;                    "
  , String
"  display: inline-block;           "
  , String
"  margin-right: 6px;               "
  , String
"}                                  "
  , String
"/* Rotate the caret/arrow icon when clicked on (using JavaScript) */"
  , String
".caret-down::before {              "
  , String
"  transform: rotate(90deg);        "
  , String
"}                                  "
  , String
"/* Hide the nested list */         "
  , String
".nested {                          "
  , String
"  display: none;                   "
  , String
"}                                  "
  , String
"/* Show the nested list when the user clicks on the caret/arrow (with JavaScript) */"
  , String
".active {                          "
  , String
"  display: block;}"
  ]

js :: String
js :: String
js = [String] -> String
unlines
  [ String
"var toggler = document.getElementsByClassName(\"caret\");"
  , String
"var i;"
  , String
"for (i = 0; i < toggler.length; i++) {"
  , String
"  toggler[i].addEventListener(\"click\", function() {"
  , String
"    this.parentElement.querySelector(\".nested\").classList.toggle(\"active\");"
  , String
"    this.classList.toggle(\"caret-down\");"
  , String
"  }); }"
  ]