{-# LANGUAGE FlexibleInstances #-}
-- Copyright 2024 United States Government as represented by the Administrator
-- of the National Aeronautics and Space Administration. All Rights Reserved.
--
-- No Warranty: THE SUBJECT SOFTWARE IS PROVIDED "AS IS" WITHOUT ANY WARRANTY
-- OF ANY KIND, EITHER EXPRESSED, IMPLIED, OR STATUTORY, INCLUDING, BUT NOT
-- LIMITED TO, ANY WARRANTY THAT THE SUBJECT SOFTWARE WILL CONFORM TO
-- SPECIFICATIONS, ANY IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A
-- PARTICULAR PURPOSE, OR FREEDOM FROM INFRINGEMENT, ANY WARRANTY THAT THE
-- SUBJECT SOFTWARE WILL BE ERROR FREE, OR ANY WARRANTY THAT DOCUMENTATION, IF
-- PROVIDED, WILL CONFORM TO THE SUBJECT SOFTWARE. THIS AGREEMENT DOES NOT, IN
-- ANY MANNER, CONSTITUTE AN ENDORSEMENT BY GOVERNMENT AGENCY OR ANY PRIOR
-- RECIPIENT OF ANY RESULTS, RESULTING DESIGNS, HARDWARE, SOFTWARE PRODUCTS OR
-- ANY OTHER APPLICATIONS RESULTING FROM USE OF THE SUBJECT SOFTWARE. FURTHER,
-- GOVERNMENT AGENCY DISCLAIMS ALL WARRANTIES AND LIABILITIES REGARDING
-- THIRD-PARTY SOFTWARE, IF PRESENT IN THE ORIGINAL SOFTWARE, AND DISTRIBUTES
-- IT "AS IS."
--
-- Waiver and Indemnity: RECIPIENT AGREES TO WAIVE ANY AND ALL CLAIMS AGAINST
-- THE UNITED STATES GOVERNMENT, ITS CONTRACTORS AND SUBCONTRACTORS, AS WELL AS
-- ANY PRIOR RECIPIENT. IF RECIPIENT'S USE OF THE SUBJECT SOFTWARE RESULTS IN
-- ANY LIABILITIES, DEMANDS, DAMAGES, EXPENSES OR LOSSES ARISING FROM SUCH USE,
-- INCLUDING ANY DAMAGES FROM PRODUCTS BASED ON, OR RESULTING FROM, RECIPIENT'S
-- USE OF THE SUBJECT SOFTWARE, RECIPIENT SHALL INDEMNIFY AND HOLD HARMLESS THE
-- UNITED STATES GOVERNMENT, ITS CONTRACTORS AND SUBCONTRACTORS, AS WELL AS ANY
-- PRIOR RECIPIENT, TO THE EXTENT PERMITTED BY LAW. RECIPIENT'S SOLE REMEDY
-- FOR ANY SUCH MATTER SHALL BE THE IMMEDIATE, UNILATERAL TERMINATION OF THIS
-- AGREEMENT.

-- | 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 :: Doc -> String
flattenDoc = Style -> Doc -> String
renderStyle (Mode -> Int -> Float -> Style
Style Mode
LeftMode Int
0 Float
0)

-- | Class for values that can be converted into a document.
class Pretty x where
  pretty :: x -> Doc

instance Pretty [XmlTree] where
  pretty :: [NTree XNode] -> Doc
pretty = [Doc] -> Doc
hcat ([Doc] -> Doc) -> ([NTree XNode] -> [Doc]) -> [NTree XNode] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NTree XNode -> Doc) -> [NTree XNode] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map NTree XNode -> Doc
forall x. Pretty x => x -> Doc
pretty

instance Pretty XmlTree where
  pretty :: NTree XNode -> Doc
pretty (NTree (XText String
s) [NTree XNode]
_) =
      String -> Doc
text (String -> String
textEscapeXml' String
s)
    where
      -- | Auxiliary function to escape certain XML characters
      textEscapeXml' :: String -> String
      textEscapeXml' :: String -> String
textEscapeXml' = (Char -> String) -> String -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> String
textEscapeChar
        where
          textEscapeChar :: Char -> String
textEscapeChar Char
'<' = String
"&lt;"
          textEscapeChar Char
'>' = String
"&gt;"
          textEscapeChar Char
'&' = String
"&amp;"
          textEscapeChar Char
x   = [Char
x]

  pretty (NTree (XBlob Blob
blob) [NTree XNode]
_) =
    String -> Doc
text (Blob -> String
blobToString Blob
blob)

  pretty (NTree (XCharRef Int
ref) [NTree XNode]
_) =
    String -> Doc
text String
"&#" Doc -> Doc -> Doc
<> Int -> Doc
int Int
ref Doc -> Doc -> Doc
<> Char -> Doc
char Char
';'

  pretty (NTree (XEntityRef String
ref) [NTree XNode]
_) =
    String -> Doc
text String
"&" Doc -> Doc -> Doc
<> String -> Doc
text String
ref Doc -> Doc -> Doc
<> Char -> Doc
char Char
';'

  pretty (NTree (XCmt String
comment) [NTree XNode]
_) =
    String -> Doc
text String
"<!--" Doc -> Doc -> Doc
<> String -> Doc
text String
comment Doc -> Doc -> Doc
<> String -> Doc
text String
"-->"

  pretty (NTree (XCdata String
txt) [NTree XNode]
_) =
      String -> Doc
text String
"<![CDATA[" Doc -> Doc -> Doc
<> String -> Doc
text String
txt' Doc -> Doc -> Doc
<> String -> Doc
text String
"]]>"
    where
      -- Escape "]]>" if present in the data contents
      txt' :: String
txt' = (String -> String) -> String -> String -> String
forall s. StringLike s => (s -> s) -> s -> s -> s
sed (String -> String -> String
forall a b. a -> b -> a
const String
"]]&gt;") String
"\\]\\]>" String
txt

  pretty (NTree (XPi QName
iName [NTree XNode]
attributes) [NTree XNode]
_) =
         String -> Doc
text String
"<?"
      Doc -> Doc -> Doc
<> QName -> Doc
forall x. Pretty x => x -> Doc
pretty QName
iName
      Doc -> Doc -> Doc
<> [Doc] -> Doc
hcat ((NTree XNode -> Doc) -> [NTree XNode] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map NTree XNode -> Doc
prettyPIAttr [NTree XNode]
attributes)
      Doc -> Doc -> Doc
<> String -> Doc
text String
"?>"
    where
      -- Print an attribute of a processing instruction.
      prettyPIAttr :: XmlTree -> Doc
      prettyPIAttr :: NTree XNode -> Doc
prettyPIAttr NTree XNode
attrs
        | (NTree (XAttr QName
attrQName) [NTree XNode]
children) <- NTree XNode
attrs
        , QName -> String
qualifiedName QName
attrQName String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
a_value
        = Doc
space Doc -> Doc -> Doc
<> [NTree XNode] -> Doc
forall x. Pretty x => x -> Doc
pretty [NTree XNode]
children

        -- <?xml version="..." ... ?>
        | Bool
otherwise
        = NTree XNode -> Doc
forall x. Pretty x => x -> Doc
pretty NTree XNode
attrs

  pretty (NTree (XTag QName
tagQName [NTree XNode]
attributeList) []) =
    Doc -> Doc
angles (QName -> Doc
forall x. Pretty x => x -> Doc
pretty QName
tagQName Doc -> Doc -> Doc
<> [NTree XNode] -> Doc
forall x. Pretty x => x -> Doc
pretty [NTree XNode]
attributeList Doc -> Doc -> Doc
<> Doc
slash)

  pretty (NTree (XTag QName
tagQName [NTree XNode]
attributeList) [NTree XNode]
children) =
       Doc -> Doc
angles (QName -> Doc
forall x. Pretty x => x -> Doc
pretty QName
tagQName Doc -> Doc -> Doc
<> [NTree XNode] -> Doc
forall x. Pretty x => x -> Doc
pretty [NTree XNode]
attributeList) Doc -> Doc -> Doc
<> [NTree XNode] -> Doc
forall x. Pretty x => x -> Doc
pretty [NTree XNode]
children
    Doc -> Doc -> Doc
<> Doc -> Doc
angles (Doc
slash Doc -> Doc -> Doc
<> QName -> Doc
forall x. Pretty x => x -> Doc
pretty QName
tagQName)

  pretty (NTree (XDTD DTDElem
dtdElem Attributes
attributeList) [NTree XNode]
children) =
    (DTDElem, Attributes, [NTree XNode]) -> Doc
forall x. Pretty x => x -> Doc
pretty (DTDElem
dtdElem, Attributes
attributeList, [NTree XNode]
children)

  pretty (NTree (XAttr QName
attrQName) [NTree XNode]
children) =
    Doc
space Doc -> Doc -> Doc
<> QName -> Doc
forall x. Pretty x => x -> Doc
pretty QName
attrQName Doc -> Doc -> Doc
<> Doc
equals Doc -> Doc -> Doc
<> Doc -> Doc
doubleQuotes ([NTree XNode] -> Doc
forall x. Pretty x => x -> Doc
pretty [NTree XNode]
children)

  pretty (NTree (XError Int
level String
txt) [NTree XNode]
_) =
        String -> Doc
text String
"<!-- ERROR" Doc -> Doc -> Doc
<+> Doc -> Doc
parens (Int -> Doc
int Int
level) Doc -> Doc -> Doc
<> Doc
colon
    Doc -> Doc -> Doc
<|> String -> Doc
text String
txt Doc -> Doc -> Doc
<|> String -> Doc
text String
"-->"

instance Pretty (DTDElem, Attributes, XmlTrees) where
  pretty :: (DTDElem, Attributes, [NTree XNode]) -> Doc
pretty (DTDElem
DOCTYPE, Attributes
attributeList, [NTree XNode]
children) =
          String -> Doc
text String
"<!DOCTYPE "
      Doc -> Doc -> Doc
<>  (String, Attributes) -> Doc
forall x. Pretty x => x -> Doc
pretty (String
a_name, Attributes
attributeList)
      Doc -> Doc -> Doc
<>  Attributes -> Doc
prettyExternalId Attributes
attributeList
      Doc -> Doc -> Doc
<+> [NTree XNode] -> Doc
forall {a}. Pretty a => [a] -> Doc
prettyInternalDTD [NTree XNode]
children
      Doc -> Doc -> Doc
<>  String -> Doc
text String
">"
    where
      prettyInternalDTD :: [a] -> Doc
prettyInternalDTD [] = Doc
empty
      prettyInternalDTD [a]
ds = Doc -> Doc
brackets (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Doc
nl Doc -> Doc -> Doc
<> [Doc] -> Doc
vcat ((a -> Doc) -> [a] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map a -> Doc
forall x. Pretty x => x -> Doc
pretty [a]
ds)

  pretty (DTDElem
ELEMENT, Attributes
attributeList, [NTree XNode]
children) =
        String -> Doc
text String
"<!ELEMENT "
    Doc -> Doc -> Doc
<>  (String, Attributes) -> Doc
forall x. Pretty x => x -> Doc
pretty (String
a_name, Attributes
attributeList)
    Doc -> Doc -> Doc
<+> String -> [NTree XNode] -> Doc
prettyElemType (String -> Attributes -> String
forall k e. Eq k => k -> AssocList k [e] -> [e]
lookup1 String
a_type Attributes
attributeList) [NTree XNode]
children
    Doc -> Doc -> Doc
<>  String -> Doc
text String
" >"

  pretty (DTDElem
CONTENT, Attributes
attributeList, [NTree XNode]
children) =
    NTree XNode -> Doc
prettyContent (DTDElem -> Attributes -> [NTree XNode] -> NTree XNode
mkDTDElem DTDElem
CONTENT Attributes
attributeList [NTree XNode]
children)

  pretty (DTDElem
ATTLIST, Attributes
attributeList, [NTree XNode]
children) =
         String -> Doc
text String
"<!ATTLIST "
      Doc -> Doc -> Doc
<> ( if Maybe String -> Bool
forall a. Maybe a -> Bool
isNothing (String -> Attributes -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
a_name Attributes
attributeList)
            then [NTree XNode] -> Doc
forall x. Pretty x => x -> Doc
pretty [NTree XNode]
children
            else (String, Attributes) -> Doc
forall x. Pretty x => x -> Doc
pretty (String
a_name, Attributes
attributeList)
                   Doc -> Doc -> Doc
<+> Attributes -> [NTree XNode] -> Doc
prettyValue Attributes
attributeList [NTree XNode]
children
         )
      Doc -> Doc -> Doc
<> String -> Doc
text String
" >"

  pretty (DTDElem
ENTITY, Attributes
attributeList, [NTree XNode]
children) =
    String -> Attributes -> [NTree XNode] -> Doc
prettyEntity String
"" Attributes
attributeList [NTree XNode]
children

  pretty (DTDElem
PENTITY, Attributes
attributeList, [NTree XNode]
children) =
    String -> Attributes -> [NTree XNode] -> Doc
prettyEntity String
"% " Attributes
attributeList [NTree XNode]
children

  pretty (DTDElem
NOTATION, Attributes
attributeList, [NTree XNode]
_children) =
       String -> Doc
text String
"<!NOTATION "
    Doc -> Doc -> Doc
<> (String, Attributes) -> Doc
forall x. Pretty x => x -> Doc
pretty (String
a_name, Attributes
attributeList)
    Doc -> Doc -> Doc
<> Attributes -> Doc
prettyExternalId Attributes
attributeList
    Doc -> Doc -> Doc
<> String -> Doc
text String
" >"

  pretty (DTDElem
CONDSECT, Attributes
_, NTree XNode
child:[NTree XNode]
children) =
       String -> Doc
text String
"<![ "
    Doc -> Doc -> Doc
<> NTree XNode -> Doc
forall x. Pretty x => x -> Doc
pretty NTree XNode
child
    Doc -> Doc -> Doc
<> String -> Doc
text String
" [\n"
    Doc -> Doc -> Doc
<> [NTree XNode] -> Doc
forall x. Pretty x => x -> Doc
pretty [NTree XNode]
children
    Doc -> Doc -> Doc
<> String -> Doc
text String
"]]>"

  pretty (DTDElem
CONDSECT, Attributes
_, []) =
    Doc
empty

  pretty (DTDElem
NAME, Attributes
attributeList, [NTree XNode]
_children) =
    (String, Attributes) -> Doc
forall x. Pretty x => x -> Doc
pretty (String
a_name, Attributes
attributeList)

  pretty (DTDElem
PEREF, Attributes
attributeList, [NTree XNode]
_children) =
    Attributes -> Doc
prettyPEAttr Attributes
attributeList

instance Pretty QName where
  pretty :: QName -> Doc
pretty = String -> Doc
text (String -> Doc) -> (QName -> String) -> QName -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> String
qualifiedName

instance Pretty (String, Attributes) where
  pretty :: (String, Attributes) -> Doc
pretty (String
k, Attributes
attributeList) = String -> Doc
text (String -> Attributes -> String
forall k e. Eq k => k -> AssocList k [e] -> [e]
lookup1 String
k Attributes
attributeList)

-- * Auxiliary functions related to pretty printing XML trees.

-- | Pretty print an attribute followed by its value.
prettyAttr :: String -> Attributes -> Doc
prettyAttr :: String -> Attributes -> Doc
prettyAttr String
k Attributes
attributeList
  | Just String
v <- String -> Attributes -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
k Attributes
attributeList
  = String -> Doc
text String
k Doc -> Doc -> Doc
<+> String -> Doc
text String
v
  | Bool
otherwise
  = Doc
empty

-- | Pretty print a content element.
prettyContent :: XmlTree -> Doc
prettyContent :: NTree XNode -> Doc
prettyContent (NTree (XDTD DTDElem
NAME Attributes
attributeList) [NTree XNode]
_) =
  (String, Attributes) -> Doc
forall x. Pretty x => x -> Doc
pretty (String
a_name, Attributes
attributeList)
prettyContent (NTree (XDTD DTDElem
PEREF Attributes
attributeList) [NTree XNode]
_) =
  Attributes -> Doc
prettyPEAttr Attributes
attributeList
prettyContent (NTree (XDTD DTDElem
CONTENT Attributes
attributeList) [NTree XNode]
children) =
       Doc -> Doc
parens (Doc -> [Doc] -> Doc
sepBy Doc
separator ((NTree XNode -> Doc) -> [NTree XNode] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map NTree XNode -> Doc
prettyContent [NTree XNode]
children))
    Doc -> Doc -> Doc
<> (String, Attributes) -> Doc
forall x. Pretty x => x -> Doc
pretty (String
a_modifier, Attributes
attributeList)
  where
    separator :: Doc
separator = String -> Doc
text (if String
a_kind String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
v_seq then String
", " else String
" | ")
prettyContent (NTree (XDTD DTDElem
n Attributes
_) [NTree XNode]
_) =
  String -> Doc
forall a. HasCallStack => String -> a
error (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ String
"prettyContent " String -> String -> String
forall a. [a] -> [a] -> [a]
++ DTDElem -> String
forall a. Show a => a -> String
show DTDElem
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is undefined"
prettyContent NTree XNode
tree = NTree XNode -> Doc
forall x. Pretty x => x -> Doc
pretty NTree XNode
tree

-- | Pretty print the type of an element.
prettyElemType :: String -> XmlTrees -> Doc
prettyElemType :: String -> [NTree XNode] -> Doc
prettyElemType String
elemType [NTree XNode]
children
    | String
elemType String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
v_pcdata
    = Doc -> Doc
parens (String -> Doc
text String
v_pcdata)

    | String
elemType String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
v_mixed Bool -> Bool -> Bool
&& Bool -> Bool
not ([NTree XNode] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [NTree XNode]
children)
    , let [NTree (XDTD DTDElem
CONTENT Attributes
attributeList') [NTree XNode]
children'] = [NTree XNode]
children
    = Doc -> Doc
parens
        ( Doc -> [Doc] -> Doc
sepBy
            (String -> Doc
text String
" | ")
            ( String -> Doc
text String
v_pcdata
            Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: (NTree XNode -> Doc) -> [NTree XNode] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Attributes -> Doc
prettyEnum (Attributes -> Doc)
-> (NTree XNode -> Attributes) -> NTree XNode -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XNode -> Attributes
treeElemAttributes(XNode -> Attributes)
-> (NTree XNode -> XNode) -> NTree XNode -> Attributes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NTree XNode -> XNode
forall a. NTree a -> a
forall (t :: * -> *) a. Tree t => t a -> a
getNode) [NTree XNode]
children'
            )
        )
    Doc -> Doc -> Doc
<> (String, Attributes) -> Doc
forall x. Pretty x => x -> Doc
pretty (String
a_modifier, Attributes
attributeList')

    | String
elemType String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
v_mixed -- incorrect tree
    = Doc -> Doc
parens Doc
empty

    | String
elemType String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
v_children Bool -> Bool -> Bool
&& Bool -> Bool
not ([NTree XNode] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [NTree XNode]
children)
    = NTree XNode -> Doc
prettyContent ([NTree XNode] -> NTree XNode
forall a. HasCallStack => [a] -> a
head [NTree XNode]
children)

    | String
elemType String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
v_children
    = Doc -> Doc
parens Doc
empty

    | String
elemType String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
k_peref
    = [Doc] -> Doc
hcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (NTree XNode -> Doc) -> [NTree XNode] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map NTree XNode -> Doc
prettyContent [NTree XNode]
children

    | Bool
otherwise
    = String -> Doc
text String
elemType

  where
    treeElemAttributes :: XNode -> Attributes
treeElemAttributes (XDTD DTDElem
_ Attributes
attributeList') = Attributes
attributeList'
    treeElemAttributes (XText String
txt) = [(String
a_name, String
txt)]
    treeElemAttributes XNode
_           = []

-- | Pretty print an entity.
prettyEntity :: String -> Attributes -> XmlTrees -> Doc
prettyEntity :: String -> Attributes -> [NTree XNode] -> Doc
prettyEntity String
kind Attributes
attributeList [NTree XNode]
children =
      String -> Doc
text String
"<!ENTITY "
  Doc -> Doc -> Doc
<>  String -> Doc
text String
kind
  Doc -> Doc -> Doc
<>  (String, Attributes) -> Doc
forall x. Pretty x => x -> Doc
pretty (String
a_name, Attributes
attributeList)
  Doc -> Doc -> Doc
<>  Attributes -> Doc
prettyExternalId Attributes
attributeList
  Doc -> Doc -> Doc
<+> String -> Attributes -> Doc
prettyAttr String
k_ndata Attributes
attributeList
  Doc -> Doc -> Doc
<+> [NTree XNode] -> Doc
prettyLiteralTrees [NTree XNode]
children
  Doc -> Doc -> Doc
<>  String -> Doc
text String
" >"

-- | Pretty print trees as text, quoting them.
prettyLiteralTrees :: XmlTrees -> Doc
prettyLiteralTrees :: [NTree XNode] -> Doc
prettyLiteralTrees []       = Doc
empty
prettyLiteralTrees [NTree XNode]
children = Doc -> Doc
doubleQuotes (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ [NTree XNode] -> String
xshow [NTree XNode]
children

-- | Pretty print an external ID.
prettyExternalId :: Attributes -> Doc
prettyExternalId :: Attributes -> Doc
prettyExternalId Attributes
attributeList =
  case (String -> Attributes -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
k_system Attributes
attributeList, String -> Attributes -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
k_public Attributes
attributeList) of
    (Maybe String
Nothing, Maybe String
Nothing) -> Doc
empty
    (Just String
s,  Maybe String
Nothing) -> String -> Doc
text String
k_system Doc -> Doc -> Doc
<+> Doc -> Doc
doubleQuotes (String -> Doc
text String
s)
    (Maybe String
Nothing, Just String
p ) -> Doc
space Doc -> Doc -> Doc
<> String -> Doc
text String
k_public Doc -> Doc -> Doc
<+> Doc -> Doc
doubleQuotes (String -> Doc
text String
p)
    (Just String
s,  Just String
p ) -> Doc
space Doc -> Doc -> Doc
<> String -> Doc
text String
k_public Doc -> Doc -> Doc
<+> Doc -> Doc
doubleQuotes (String -> Doc
text String
p)
                            Doc -> Doc -> Doc
<+> Doc -> Doc
doubleQuotes (String -> Doc
text String
s)

-- | Pretty print a Parameter Entity Reference.
prettyPEAttr :: Attributes -> Doc
prettyPEAttr :: Attributes -> Doc
prettyPEAttr = Doc -> (String -> Doc) -> Maybe String -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
empty (\String
pe -> Char -> Doc
char Char
'%' Doc -> Doc -> Doc
<> String -> Doc
text String
pe Doc -> Doc -> Doc
<> Char -> Doc
char Char
';')
             (Maybe String -> Doc)
-> (Attributes -> Maybe String) -> Attributes -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Attributes -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
a_peref

-- | Given a list of attributes, pretty print the value in them.
prettyValue :: Attributes -> XmlTrees -> Doc
prettyValue :: Attributes -> [NTree XNode] -> Doc
prettyValue Attributes
attributeList [NTree XNode]
children
    | Just String
aValue <- String -> Attributes -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
a_value Attributes
attributeList
    =     String -> Doc
text String
aValue
      Doc -> Doc -> Doc
<+> String -> Doc
prettyAttrType (String -> Attributes -> String
forall k e. Eq k => k -> AssocList k [e] -> [e]
lookup1 String
a_type Attributes
attributeList)
      Doc -> Doc -> Doc
<+> String -> Doc
prettyAttrKind (String -> Attributes -> String
forall k e. Eq k => k -> AssocList k [e] -> [e]
lookup1 String
a_kind Attributes
attributeList)

    | Bool
otherwise
    = Attributes -> Doc
prettyPEAttr (Attributes -> Doc) -> Attributes -> Doc
forall a b. (a -> b) -> a -> b
$ Attributes -> Maybe Attributes -> Attributes
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe Attributes -> Attributes) -> Maybe Attributes -> Attributes
forall a b. (a -> b) -> a -> b
$ NTree XNode -> Maybe Attributes
forall a. XmlNode a => a -> Maybe Attributes
getDTDAttrl (NTree XNode -> Maybe Attributes)
-> NTree XNode -> Maybe Attributes
forall a b. (a -> b) -> a -> b
$ [NTree XNode] -> NTree XNode
forall a. HasCallStack => [a] -> a
head [NTree XNode]
children
  where

    prettyAttrType :: String -> Doc
prettyAttrType String
attrType
      | String
attrType String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
k_peref       = Attributes -> Doc
prettyPEAttr Attributes
attributeList
      | String
attrType String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
k_enumeration = Doc
prettyAttrEnum
      | String
attrType String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
k_notation    = String -> Doc
text String
k_notation Doc -> Doc -> Doc
<+> Doc
prettyAttrEnum
      | Bool
otherwise                 = String -> Doc
text String
attrType

    prettyAttrEnum :: Doc
prettyAttrEnum =
        Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> Doc
sepBy (String -> Doc
text String
" | ") ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$
          (NTree XNode -> Doc) -> [NTree XNode] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Attributes -> Doc
prettyEnum (Attributes -> Doc)
-> (NTree XNode -> Attributes) -> NTree XNode -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Attributes -> Maybe Attributes -> Attributes
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe Attributes -> Attributes)
-> (NTree XNode -> Maybe Attributes) -> NTree XNode -> Attributes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NTree XNode -> Maybe Attributes
forall a. XmlNode a => a -> Maybe Attributes
getDTDAttrl) [NTree XNode]
children
      where

    prettyAttrKind :: String -> Doc
prettyAttrKind String
kind
      | String
kind String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
k_default
      = Doc -> Doc
doubleQuotes (String -> Doc
text (String -> Attributes -> String
forall k e. Eq k => k -> AssocList k [e] -> [e]
lookup1 String
a_default Attributes
attributeList))

      | String
kind String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
k_fixed
      = String -> Doc
text String
k_fixed
        Doc -> Doc -> Doc
<+> Doc -> Doc
doubleQuotes (String -> Doc
text (String -> Attributes -> String
forall k e. Eq k => k -> AssocList k [e] -> [e]
lookup1 String
a_default Attributes
attributeList))

      | Bool
otherwise
      = String -> Doc
text String
kind

-- Pretty print the name of an attribute, followed by the PE Reference.
prettyEnum :: Attributes -> Doc
prettyEnum :: Attributes -> Doc
prettyEnum Attributes
attributes = (String, Attributes) -> Doc
forall x. Pretty x => x -> Doc
pretty (String
a_name, Attributes
attributes) Doc -> Doc -> Doc
<> Attributes -> Doc
prettyPEAttr Attributes
attributes

-- ** Generic document constructors

-- | Forward slash character.
slash :: Doc
slash :: Doc
slash = Char -> Doc
char Char
'/'

-- | New line character.
nl :: Doc
nl :: Doc
nl = Char -> Doc
char Char
'\n'

-- | Enclose document in angle brackets.
angles :: Doc -> Doc
angles :: Doc -> Doc
angles Doc
s = Char -> Doc
char Char
'<' Doc -> Doc -> Doc
<> Doc
s Doc -> Doc -> Doc
<> Char -> Doc
char Char
'>'

-- | Compose two documents, separating them by a new line.
--
-- The new line is not inserted if either document is empty.
(<|>) :: Doc -> Doc -> Doc
<|> :: Doc -> Doc -> Doc
(<|>) Doc
x Doc
y
  | Doc -> Bool
isEmpty Doc
x = Doc
y
  | Doc -> Bool
isEmpty Doc
y = Doc
x
  | Bool
otherwise = Doc
x Doc -> Doc -> Doc
<> Doc
nl Doc -> Doc -> Doc
<> Doc
y

-- | Concatenate a list od documents, separating them by a given separator.
sepBy :: Doc   -- ^ Separator
      -> [Doc] -- ^ List of documents
      -> Doc
sepBy :: Doc -> [Doc] -> Doc
sepBy Doc
_   []     = Doc
empty
sepBy Doc
_   [Doc
x]    = Doc
x
sepBy Doc
sep (Doc
x:[Doc]
xs) = Doc
x Doc -> Doc -> Doc
<> Doc
sep Doc -> Doc -> Doc
<> Doc -> [Doc] -> Doc
sepBy Doc
sep [Doc]
xs