src/Symantic/XML/Tree/Write.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 {-# LANGUAGE StrictData #-}
   3 module Symantic.XML.Tree.Write where
   4
   5 import Data.Bool
   6 import Data.Eq (Eq(..))
   7 import Data.Foldable (Foldable(..), all)
   8 import Data.Function (($), (.), const)
   9 import Data.Maybe (Maybe(..))
  10 import Data.Monoid (Monoid(..))
  11 import Data.Semigroup (Semigroup(..))
  12 import Data.String (IsString(..))
  13 import Data.Traversable (Traversable(..))
  14 import Data.Tuple (fst)
  15 import System.IO (IO, FilePath)
  16 import qualified Control.Monad.Trans.State as S
  17 import qualified Data.ByteString.Lazy as BSL
  18 import qualified Data.Char as Char
  19 import qualified Data.HashMap.Strict as HM
  20 import qualified Data.HashSet as HS
  21 import qualified Data.List as List
  22 import qualified Data.Text.Lazy as TL
  23 import qualified Data.Text.Lazy.Builder as TLB
  24 import qualified Data.Text.Lazy.Encoding as TL
  25 import qualified Data.TreeSeq.Strict as TS
  26
  27 import Symantic.XML.Language
  28 import Symantic.XML.Tree.Source
  29 import Symantic.XML.Tree.Data
  30 import Symantic.XML.Write
  31
  32 writeTree :: UnSource src => Trees src -> TL.Text
  33 writeTree ts = TLB.toLazyText $ unTreeWrite (write_Trees ts) defaultWriteInh
  34
  35 writeTreeIndented :: UnSource src => TL.Text -> Trees src -> TL.Text
  36 writeTreeIndented ind xs =
  37   TLB.toLazyText $
  38   unTreeWrite (write_Trees xs) defaultWriteInh
  39    { writeInh_indent_delta = ind }
  40
  41 writeFile :: FilePath -> TL.Text -> IO ()
  42 writeFile fp = BSL.writeFile fp . TL.encodeUtf8
  43
  44 -- * Type 'TreeWrite'
  45 newtype TreeWrite
  46  =      TreeWrite
  47  {    unTreeWrite :: WriteInh -> TLB.Builder
  48  }
  49 instance Semigroup TreeWrite where
  50   TreeWrite x <> TreeWrite y = TreeWrite (x <> y)
  51 instance Monoid TreeWrite where
  52   mempty = TreeWrite (const "")
  53   mappend = (<>)
  54 instance IsString TreeWrite where
  55   fromString = TreeWrite . const . fromString
  56
  57 write_Trees :: UnSource src => Trees src -> TreeWrite
  58 write_Trees = foldMap write_Tree
  59
  60 write_Tree :: UnSource src => Tree src -> TreeWrite
  61 write_Tree (TS.Tree node elemChilds) = TreeWrite $ \inh ->
  62  case unSource node of
  63   NodeText et@(EscapedText t)
  64    -- Remove spaces when indenting
  65    | not $ TL.null (writeInh_indent_delta inh)
  66    , all (\case
  67      EscapedPlain p -> TL.all Char.isSpace p
  68      _ -> False
  69     ) t -> mempty
  70    | otherwise -> textify et
  71   NodePI pn pv ->
  72     writeInh_indent inh <>
  73     "<?"<>textify pn<>
  74     (case pn of
  75      -- Special case: the value of the "xml" PI is parsed
  76      -- as children NodePI
  77      "xml" -> foldMap (\case
  78        TS.Tree nod _ ->
  79         case unSource nod of
  80          NodePI n v -> " "<>textify n<>"=\""<>textify v<>"\""
  81          _ -> mempty
  82       ) elemChilds
  83      _ -> s<>textify pv
  84     ) <> "?>" <> nl inh
  85     where s | TL.null pv = ""
  86             | otherwise  = " "
  87   NodeCDATA t ->
  88     writeInh_indent inh <>
  89     "<[CDATA[["<>textify (TL.replace "]]>" "]]&gt;" t)<>"]]>"<>nl inh
  90   NodeComment t ->
  91     writeInh_indent inh <>
  92     "<!--"<>textify (TL.replace "-->" "--&gt;" t)<>"-->"<>nl inh
  93   NodeElem elemQName elemAttrs ->
  94     writeInh_indent inh
  95      <> "<"
  96      <> write_elemPName
  97      <> write_xmlnsAttrs
  98      <> write_elemAttrs
  99      <> if noChild
 100     then "/>" <> nl inh
 101     else ">"
 102      <> (if hasIndenting then nl inh else mempty)
 103      <> write_elemChilds
 104      <> (if hasIndenting then writeInh_indent inh else mempty)
 105      <> "</"<>write_elemPName<>">"
 106      <> nl inh
 107     where
 108     -- Empty NodeText do not count as a child
 109     noChild =
 110       all (\case
 111        TS.Tree n _ts
 112         | NodeText (EscapedText t) <- unSource n ->
 113           all (\case
 114            EscapedPlain p -> TL.null p
 115            _ -> False
 116           ) t
 117         | otherwise -> False
 118       ) elemChilds
 119     -- Follow xmllint --format rules to detect indenting:
 120     -- if there is any NodeText it should only contain whites
 121     hasIndenting =
 122       (`all` elemChilds) $ \case
 123        TS.Tree n _ts
 124         | NodeText (EscapedText t) <- unSource n ->
 125           all (\case
 126            EscapedPlain p -> TL.all Char.isSpace p
 127            _ -> False
 128           ) t
 129         | otherwise -> True
 130     (usedNS, declNS) =
 131       HM.foldlWithKey' go (initUsedNS, initDeclNS) elemAttrs
 132       where
 133       initUsedNS = HS.singleton $ qNameSpace elemQName
 134       initDeclNS = (writeInh_namespaces inh){namespaces_prefixes=mempty}
 135       go acc@(uNS, dNS) an sav =
 136         case unSource sav of
 137          av
 138          -- xmlns:prefix="namespace"
 139           | qNameSpace an == xmlns_xmlns ->
 140           let ns = unescapeAttr av in
 141           (uNS, dNS
 142            { namespaces_prefixes =
 143             (if TL.null ns
 144             then HM.delete
 145             -- Empty namespace means removal
 146             -- of the prefix from scope.
 147             else (`HM.insert` qNameLocal an))
 148              (Namespace ns)
 149              (namespaces_prefixes dNS)
 150            })
 151          -- xmlns="namespace"
 152           | qNameSpace an == xmlns_empty
 153           , qNameLocal an == NCName "xmlns" ->
 154           (uNS, dNS{namespaces_default = Namespace (unescapeAttr av)})
 155          -- name="value"
 156           | qNameSpace an == xmlns_empty -> acc
 157          -- {namespace}name="value"
 158           | otherwise -> (HS.insert (qNameSpace an) uNS, dNS)
 159     -- The inherited namespaces,
 160     -- including those declared at this element.
 161     inhNS =
 162       HM.union
 163        (namespaces_prefixes declNS)
 164        (namespaces_prefixes (writeInh_namespaces inh))
 165     -- The namespaces used but not declared nor default,
 166     -- with fresh prefixes.
 167     autoNS =
 168       HM.delete (namespaces_default declNS) $
 169       (`S.evalState` HS.empty) $
 170       traverse
 171        (\() -> S.gets freshNCName)
 172        (HS.toMap usedNS `HM.difference` inhNS)
 173     write_xmlnsAttrs =
 174       foldMap (\(Namespace ns, qNameLocal) ->
 175         textifyAttr (PName (Just "xmlns") qNameLocal) (escapeAttr ns)) $
 176       List.sortOn fst $
 177       HM.toList autoNS
 178     scopeNS = declNS{ namespaces_prefixes = autoNS <> inhNS }
 179     write_elemPName = textify $ prefixifyQName scopeNS elemQName
 180     write_elemAttrs =
 181       foldMap (\(an, av) -> textifyAttr
 182        (prefixifyQName scopeNS{namespaces_default=xmlns_empty} an)
 183        (unSource av)) $
 184       List.sortOn fst $ -- This makes the rendition more predictible, but this is useless.
 185       HM.toList elemAttrs
 186     write_elemChilds = unTreeWrite (write_Trees elemChilds) inh
 187      { writeInh_namespaces = scopeNS
 188      -- Disable indenting unless hasIndenting.
 189      , writeInh_indent =
 190       if hasIndenting
 191       then
 192         writeInh_indent inh <>
 193         textify (writeInh_indent_delta inh)
 194       else mempty
 195      , writeInh_indent_delta =
 196       if hasIndenting
 197       then writeInh_indent_delta inh
 198       else mempty
 199      }