content: {-# LANGUAGE FlexibleInstances #-}
  -- Copyright 2024 United States Government as represented by the Administrator
  -- of the National Aeronautics and Space Administration. All Rights Reserved.
  --
  -- Licensed under the Apache License, Version 2.0 (the "License"); you may
  -- not use this file except in compliance with the License. You may obtain a
  -- copy of the License at
  --
  --      https://www.apache.org/licenses/LICENSE-2.0
  --
  -- Unless required by applicable law or agreed to in writing, software
  -- distributed under the License is distributed on an "AS IS" BASIS, WITHOUT
  -- WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the
  -- License for the specific language governing permissions and limitations
  -- under the License.
  
  -- | Print XML trees.
  --
  -- This variant of the function to show XML trees available in HXT is needed
  -- because of issues with values being quoted by HXT's default function.
  --
  -- It's based on the same ideas, but it's been implemented using the
  -- pretty-library instead of using plain string functions.
  module Language.XMLSpec.PrintTrees where
  
  -- External imports
  import Data.Maybe                   (fromMaybe, isNothing)
  import Data.Tree.NTree.TypeDefs     (NTree (NTree))
  import Prelude                      hiding (quot, (<>))
  import Text.PrettyPrint.HughesPJ    (Doc, Mode (..), Style (..), brackets, char,
                                       colon, doubleQuotes, empty, equals, hcat,
                                       int, isEmpty, parens, renderStyle, space,
                                       text, vcat, (<+>), (<>))
  import Text.Regex.XMLSchema.Generic (sed)
  import Text.XML.HXT.Core            hiding (getDTDAttrl, getNode, mkDTDElem,
                                       xshow, (<+>), txt)
  import Text.XML.HXT.DOM.ShowXml     (xshow)
  import Text.XML.HXT.DOM.XmlNode     (getDTDAttrl, getNode, mkDTDElem)
  
  -- | Render a document into a string.
  flattenDoc :: Doc -> String
  flattenDoc = renderStyle (Style LeftMode 0 0)
  
  -- | Class for values that can be converted into a document.
  class Pretty x where
    pretty :: x -> Doc
  
  instance Pretty [XmlTree] where
    pretty = hcat . map pretty
  
  instance Pretty XmlTree where
    pretty (NTree (XText s) _) =
        text (textEscapeXml' s)
      where
        -- | Auxiliary function to escape certain XML characters
        textEscapeXml' :: String -> String
        textEscapeXml' = concatMap textEscapeChar
          where
            textEscapeChar '<' = "&lt;"
            textEscapeChar '>' = "&gt;"
            textEscapeChar '&' = "&amp;"
            textEscapeChar x   = [x]
  
    pretty (NTree (XBlob blob) _) =
      text (blobToString blob)
  
    pretty (NTree (XCharRef ref) _) =
      text "&#" <> int ref <> char ';'
  
    pretty (NTree (XEntityRef ref) _) =
      text "&" <> text ref <> char ';'
  
    pretty (NTree (XCmt comment) _) =
      text "<!--" <> text comment <> text "-->"
  
    pretty (NTree (XCdata txt) _) =
        text "<![CDATA[" <> text txt' <> text "]]>"
      where
        -- Escape "]]>" if present in the data contents
        txt' = sed (const "]]&gt;") "\\]\\]>" txt
  
    pretty (NTree (XPi iName attributes) _) =
           text "<?"
        <> pretty iName
        <> hcat (map prettyPIAttr attributes)
        <> text "?>"
      where
        -- Print an attribute of a processing instruction.
        prettyPIAttr :: XmlTree -> Doc
        prettyPIAttr attrs
          | (NTree (XAttr attrQName) children) <- attrs
          , qualifiedName attrQName == a_value
          = space <> pretty children
  
          -- <?xml version="..." ... ?>
          | otherwise
          = pretty attrs
  
    pretty (NTree (XTag tagQName attributeList) []) =
      angles (pretty tagQName <> pretty attributeList <> slash)
  
    pretty (NTree (XTag tagQName attributeList) children) =
         angles (pretty tagQName <> pretty attributeList) <> pretty children
      <> angles (slash <> pretty tagQName)
  
    pretty (NTree (XDTD dtdElem attributeList) children) =
      pretty (dtdElem, attributeList, children)
  
    pretty (NTree (XAttr attrQName) children) =
      space <> pretty attrQName <> equals <> doubleQuotes (pretty children)
  
    pretty (NTree (XError level txt) _) =
          text "<!-- ERROR" <+> parens (int level) <> colon
      <|> text txt <|> text "-->"
  
  instance Pretty (DTDElem, Attributes, XmlTrees) where
    pretty (DOCTYPE, attributeList, children) =
            text "<!DOCTYPE "
        <>  pretty (a_name, attributeList)
        <>  prettyExternalId attributeList
        <+> prettyInternalDTD children
        <>  text ">"
      where
        prettyInternalDTD [] = empty
        prettyInternalDTD ds = brackets $ nl <> vcat (map pretty ds)
  
    pretty (ELEMENT, attributeList, children) =
          text "<!ELEMENT "
      <>  pretty (a_name, attributeList)
      <+> prettyElemType (lookup1 a_type attributeList) children
      <>  text " >"
  
    pretty (CONTENT, attributeList, children) =
      prettyContent (mkDTDElem CONTENT attributeList children)
  
    pretty (ATTLIST, attributeList, children) =
           text "<!ATTLIST "
        <> ( if isNothing (lookup a_name attributeList)
              then pretty children
              else pretty (a_name, attributeList)
                     <+> prettyValue attributeList children
           )
        <> text " >"
  
    pretty (ENTITY, attributeList, children) =
      prettyEntity "" attributeList children
  
    pretty (PENTITY, attributeList, children) =
      prettyEntity "% " attributeList children
  
    pretty (NOTATION, attributeList, _children) =
         text "<!NOTATION "
      <> pretty (a_name, attributeList)
      <> prettyExternalId attributeList
      <> text " >"
  
    pretty (CONDSECT, _, child:children) =
         text "<![ "
      <> pretty child
      <> text " [\n"
      <> pretty children
      <> text "]]>"
  
    pretty (CONDSECT, _, []) =
      empty
  
    pretty (NAME, attributeList, _children) =
      pretty (a_name, attributeList)
  
    pretty (PEREF, attributeList, _children) =
      prettyPEAttr attributeList
  
  instance Pretty QName where
    pretty = text . qualifiedName
  
  instance Pretty (String, Attributes) where
    pretty (k, attributeList) = text (lookup1 k attributeList)
  
  -- * Auxiliary functions related to pretty printing XML trees.
  
  -- | Pretty print an attribute followed by its value.
  prettyAttr :: String -> Attributes -> Doc
  prettyAttr k attributeList
    | Just v <- lookup k attributeList
    = text k <+> text v
    | otherwise
    = empty
  
  -- | Pretty print a content element.
  prettyContent :: XmlTree -> Doc
  prettyContent (NTree (XDTD NAME attributeList) _) =
    pretty (a_name, attributeList)
  prettyContent (NTree (XDTD PEREF attributeList) _) =
    prettyPEAttr attributeList
  prettyContent (NTree (XDTD CONTENT attributeList) children) =
         parens (sepBy separator (map prettyContent children))
      <> pretty (a_modifier, attributeList)
    where
      separator = text (if a_kind == v_seq then ", " else " | ")
  prettyContent (NTree (XDTD n _) _) =
    error $ "prettyContent " ++ show n ++ " is undefined"
  prettyContent tree = pretty tree
  
  -- | Pretty print the type of an element.
  prettyElemType :: String -> XmlTrees -> Doc
  prettyElemType elemType children
      | elemType == v_pcdata
      = parens (text v_pcdata)
  
      | elemType == v_mixed && not (null children)
      , let [NTree (XDTD CONTENT attributeList') children'] = children
      = parens
          ( sepBy
              (text " | ")
              ( text v_pcdata
              : map (prettyEnum . treeElemAttributes. getNode) children'
              )
          )
      <> pretty (a_modifier, attributeList')
  
      | elemType == v_mixed -- incorrect tree
      = parens empty
  
      | elemType == v_children && not (null children)
      = prettyContent (head children)
  
      | elemType == v_children
      = parens empty
  
      | elemType == k_peref
      = hcat $ map prettyContent children
  
      | otherwise
      = text elemType
  
    where
      treeElemAttributes (XDTD _ attributeList') = attributeList'
      treeElemAttributes (XText txt) = [(a_name, txt)]
      treeElemAttributes _           = []
  
  -- | Pretty print an entity.
  prettyEntity :: String -> Attributes -> XmlTrees -> Doc
  prettyEntity kind attributeList children =
        text "<!ENTITY "
    <>  text kind
    <>  pretty (a_name, attributeList)
    <>  prettyExternalId attributeList
    <+> prettyAttr k_ndata attributeList
    <+> prettyLiteralTrees children
    <>  text " >"
  
  -- | Pretty print trees as text, quoting them.
  prettyLiteralTrees :: XmlTrees -> Doc
  prettyLiteralTrees []       = empty
  prettyLiteralTrees children = doubleQuotes $ text $ xshow children
  
  -- | Pretty print an external ID.
  prettyExternalId :: Attributes -> Doc
  prettyExternalId attributeList =
    case (lookup k_system attributeList, lookup k_public attributeList) of
      (Nothing, Nothing) -> empty
      (Just s,  Nothing) -> text k_system <+> doubleQuotes (text s)
      (Nothing, Just p ) -> space <> text k_public <+> doubleQuotes (text p)
      (Just s,  Just p ) -> space <> text k_public <+> doubleQuotes (text p)
                              <+> doubleQuotes (text s)
  
  -- | Pretty print a Parameter Entity Reference.
  prettyPEAttr :: Attributes -> Doc
  prettyPEAttr = maybe empty (\pe -> char '%' <> text pe <> char ';')
               . lookup a_peref
  
  -- | Given a list of attributes, pretty print the value in them.
  prettyValue :: Attributes -> XmlTrees -> Doc
  prettyValue attributeList children
      | Just aValue <- lookup a_value attributeList
      =     text aValue
        <+> prettyAttrType (lookup1 a_type attributeList)
        <+> prettyAttrKind (lookup1 a_kind attributeList)
  
      | otherwise
      = prettyPEAttr $ fromMaybe [] $ getDTDAttrl $ head children
    where
  
      prettyAttrType attrType
        | attrType == k_peref       = prettyPEAttr attributeList
        | attrType == k_enumeration = prettyAttrEnum
        | attrType == k_notation    = text k_notation <+> prettyAttrEnum
        | otherwise                 = text attrType
  
      prettyAttrEnum =
          parens $ sepBy (text " | ") $
            map (prettyEnum . fromMaybe [] . getDTDAttrl) children
        where
  
      prettyAttrKind kind
        | kind == k_default
        = doubleQuotes (text (lookup1 a_default attributeList))
  
        | kind == k_fixed
        = text k_fixed
          <+> doubleQuotes (text (lookup1 a_default attributeList))
  
        | otherwise
        = text kind
  
  -- Pretty print the name of an attribute, followed by the PE Reference.
  prettyEnum :: Attributes -> Doc
  prettyEnum attributes = pretty (a_name, attributes) <> prettyPEAttr attributes
  
  -- ** Generic document constructors
  
  -- | Forward slash character.
  slash :: Doc
  slash = char '/'
  
  -- | New line character.
  nl :: Doc
  nl = char '\n'
  
  -- | Enclose document in angle brackets.
  angles :: Doc -> Doc
  angles s = char '<' <> s <> char '>'
  
  -- | Compose two documents, separating them by a new line.
  --
  -- The new line is not inserted if either document is empty.
  (<|>) :: Doc -> Doc -> Doc
  (<|>) x y
    | isEmpty x = y
    | isEmpty y = x
    | otherwise = x <> nl <> y
  
  -- | Concatenate a list od documents, separating them by a given separator.
  sepBy :: Doc   -- ^ Separator
        -> [Doc] -- ^ List of documents
        -> Doc
  sepBy _   []     = empty
  sepBy _   [x]    = x
  sepBy sep (x:xs) = x <> sep <> sepBy sep xs
  