Language/Symantic/XML/Write.hs

   1 {-# LANGUAGE BangPatterns #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 module Language.Symantic.XML.Write where
   4
   5 import Control.Applicative (Applicative(..), liftA2)
   6 import Control.Monad (Monad(..))
   7 import Data.Bool
   8 import Data.Default.Class (Default(..))
   9 import Data.Eq (Eq(..))
  10 import Data.Foldable (Foldable(..))
  11 import Data.Function (($), (.))
  12 import Data.Maybe (Maybe(..))
  13 import Data.Monoid (Monoid(..))
  14 import Data.Semigroup (Semigroup(..))
  15 import Data.String (String, IsString(..))
  16 import Data.Traversable (Traversable(..))
  17 import System.IO (IO, FilePath)
  18 import Text.Show (Show(..))
  19 import qualified Control.Monad.Trans.Reader as R
  20 import qualified Control.Monad.Trans.State as S
  21 import qualified Data.ByteString.Lazy as BSL
  22 import qualified Data.Char as Char
  23 import qualified Data.HashMap.Strict as HM
  24 import qualified Data.HashSet as HS
  25 import qualified Data.Sequence as Seq
  26 import qualified Data.Text.Lazy as TL
  27 import qualified Data.Text.Lazy.Builder as TLB
  28 import qualified Data.Text.Lazy.Encoding as TL
  29
  30 import Language.Symantic.XML.Document as XML
  31
  32 writeXML :: XMLs -> TL.Text
  33 writeXML x = TLB.toLazyText $ write x `R.runReader` Reader
  34  { reader_ns_scope = def
  35  }
  36
  37 writeFile :: FilePath -> TL.Text -> IO ()
  38 writeFile fp t = BSL.writeFile fp $ TL.encodeUtf8 t
  39
  40 -- * Type 'Write'
  41 type Write = R.Reader Reader TLB.Builder
  42 instance Semigroup Write where
  43         (<>) = liftA2 (<>)
  44 instance Monoid Write where
  45         mempty = return ""
  46         mappend = (<>)
  47
  48 -- ** Type 'Reader'
  49 newtype Reader = Reader
  50  { reader_ns_scope :: Namespaces NCName
  51  }
  52 instance IsString Write where
  53         fromString = return . fromString
  54
  55 -- * Class 'Buildable'
  56 class Buildable a where
  57         build :: a -> TLB.Builder
  58 instance Buildable Char.Char where
  59         build = TLB.singleton
  60 instance Buildable String where
  61         build = TLB.fromString
  62 instance Buildable TL.Text where
  63         build = TLB.fromLazyText
  64 instance Buildable NCName where
  65         build = build . unNCName
  66 instance Buildable Name where
  67         build = build . unName
  68 instance Buildable PName where
  69         build PName{..} =
  70                 case pNameSpace of
  71                  Nothing -> build pNameLocal
  72                  Just p -> build p<>":"<> build pNameLocal
  73 instance Buildable Namespace where
  74         build = build . unNamespace
  75 instance Buildable EntityRef where
  76         build EntityRef{..} = "&"<>build entityRef_name<>";"
  77 instance Buildable CharRef where
  78         build (CharRef c) = "&#"<>build (show (Char.ord c))<>";"
  79 instance Buildable Text where
  80         build = foldMap $ \case
  81          TextLexemePlain     t -> build t
  82          TextLexemeEntityRef r -> build r
  83          TextLexemeCharRef   r -> build r
  84
  85 -- * Class 'Writable'
  86 class Writeable a where
  87         write :: a -> Write
  88 instance Writeable NCName where
  89         write = return . TLB.fromLazyText . unNCName
  90 instance Writeable XMLs where
  91         write = foldMap write
  92 instance Writeable XML where
  93         write (Tree (Sourced _src nod) xs) =
  94                 case nod of
  95                  NodeElem elemQName -> do
  96                         ro <- R.ask
  97                         let (elemAttrs, elemChilds) =
  98                                 (`Seq.spanl` xs) $ \case
  99                                          Tree (Sourced _ NodeAttr{}) _ -> True
 100                                          _ -> False
 101                         let (usedNS, declNS) ::
 102                                 ( HS.HashSet Namespace
 103                                 , Namespaces NCName
 104                                 ) =
 105                                 foldl' go (initUsedNS, initDeclNS) elemAttrs
 106                                 where
 107                                 initUsedNS = HS.singleton $ qNameSpace elemQName
 108                                 initDeclNS = def{namespaces_default = namespaces_default $ reader_ns_scope ro}
 109                                 go (!uNS, !dNS) = \case
 110                                  Tree (Sourced _ (NodeAttr QName{..})) vs
 111                                   -- xmlns:prefix="namespace"
 112                                   | qNameSpace == xmlns_xmlns
 113                                   , [Tree (Sourced _ (NodeText t)) _] <- toList vs ->
 114                                                 let n = flatText t in
 115                                                 (uNS,) dNS
 116                                                  { namespaces_prefixes =
 117                                                         (if TL.null n
 118                                                         then HM.delete
 119                                                         -- NOTE: empty namespace means removal of the prefix from scope.
 120                                                         else (`HM.insert` qNameLocal))
 121                                                          (Namespace n)
 122                                                          (namespaces_prefixes dNS)
 123                                                  }
 124                                   -- xmlns="namespace"
 125                                   | qNameSpace == xmlns_empty
 126                                   , qNameLocal == NCName "xmlns"
 127                                   , [Tree (Sourced _ (NodeText t)) _] <- toList vs ->
 128                                                 (uNS,)
 129                                                 dNS{namespaces_default = Namespace $ flatText t}
 130                                   -- name="value"
 131                                   | qNameSpace == xmlns_empty -> (uNS, dNS)
 132                                   -- {namespace}name="value"
 133                                   | otherwise -> (HS.insert qNameSpace uNS, dNS)
 134                                  _ -> (uNS, dNS)
 135                         let inhNS =
 136                                 -- NOTE: the inherited namespaces,
 137                                 -- including those declared at this element.
 138                                 HM.union
 139                                  (namespaces_prefixes declNS)
 140                                  (namespaces_prefixes (reader_ns_scope ro))
 141                         let autoNS =
 142                                 -- NOTE: the namespaces used but not declared,
 143                                 -- with fresh prefixes.
 144                                 (`S.evalState` HS.empty) $
 145                                 traverse
 146                                  (\() -> S.gets freshNCName)
 147                                  (HS.toMap usedNS `HM.difference` inhNS)
 148                         let autoAttrs =
 149                                 -- NOTE: XMLify autoNS
 150                                 HM.foldlWithKey' (\acc (Namespace v) p ->
 151                                         (acc Seq.|>) $
 152                                                 Tree (notSourced $ NodeAttr QName{qNameSpace=xmlns_xmlns, qNameLocal=p}) $
 153                                                         pure $ tree0 $ notSourced $ NodeText $ pure $ TextLexemePlain v
 154                                  ) mempty autoNS
 155                         let scopeNS = declNS { namespaces_prefixes = autoNS <> inhNS }
 156                         return $
 157                                 let build_elemPName = build $ prefixifyQName scopeNS elemQName in
 158                                 let build_elemAttrs =
 159                                         (`foldMap` (autoAttrs <> elemAttrs)) $ \case
 160                                          Tree (Sourced _ (NodeAttr an)) vs
 161                                           | [Tree (Sourced _ (NodeText av)) _] <- toList vs ->
 162                                                 " "<>buildAttr (prefixifyQName scopeNS{namespaces_default=""} an) av
 163                                          _ -> mempty in
 164                                 "<"<>build_elemPName<>build_elemAttrs<>
 165                                 let build_elemChilds = write elemChilds
 166                                         `R.runReader` ro{reader_ns_scope = scopeNS} in
 167                                 if null elemChilds
 168                                 then "/>"
 169                                 else ">"<>build_elemChilds<>"</"<>build_elemPName<>">"
 170                  NodeAttr an
 171                   | [Tree (Sourced _ (NodeText av)) _] <- toList xs -> do
 172                         ro <- R.ask
 173                         return $ " "<>buildAttr (prefixifyQName (reader_ns_scope ro) an) av
 174                   | otherwise -> mempty
 175                  NodePI pn pv
 176                   | pn == "xml" -> do
 177                         write_xs <- write xs
 178                         return $ "<?"<>build pn<>s<>write_xs<>"?>"
 179                   | otherwise ->
 180                         return $ "<?"<>build pn<>s<>build pv<>"?>"
 181                         where s | TL.null pv = ""
 182                                 | otherwise  = " "
 183                  NodeText    t -> return $ build t
 184                  NodeComment t -> return $ "<!--"<>build t<>"-->"
 185                  NodeCDATA   t -> return $ "<[CDATA[["<>build t<>"]]>"
 186
 187 buildAttr :: PName -> Text -> TLB.Builder
 188 buildAttr n v = build n<>"=\""<>buildAttrValue v<>"\""
 189
 190 buildAttrValue :: Text -> TLB.Builder
 191 buildAttrValue = foldMap $ \case
 192  TextLexemePlain p -> build p
 193  TextLexemeEntityRef EntityRef{..} ->
 194         build $ TL.replace "\"" "&quot;" entityRef_value
 195  TextLexemeCharRef (CharRef c)
 196         | c == '\"' -> "&quot;"
 197         | otherwise -> build c