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