src/Symantic/XML/Write.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 {-# LANGUAGE StrictData #-}
   3 {-# LANGUAGE UndecidableInstances #-}
   4 module Symantic.XML.Write where
   5
   6 import Control.Applicative (Applicative(..), Alternative((<|>)))
   7 import Data.Bool
   8 import Data.Either (Either(..))
   9 import Data.Eq (Eq(..))
  10 import Data.Foldable (Foldable(..))
  11 import Data.Function (($), (.), id)
  12 import Data.Functor ((<$>), (<$))
  13 import Data.Int (Int)
  14 import Data.Maybe (Maybe(..), fromMaybe)
  15 import Data.Monoid (Monoid(..))
  16 import Data.Semigroup (Semigroup(..))
  17 import Data.String (String)
  18 import Data.Traversable (Traversable(..))
  19 import Data.Tuple (fst)
  20 import Numeric.Natural (Natural)
  21 import Prelude (Integer, error)
  22 import System.IO (IO, FilePath)
  23 import Text.Show (Show(..))
  24 import qualified Control.Exception as Exn
  25 import qualified Control.Monad.Trans.State as S
  26 import qualified Data.ByteString.Lazy as BSL
  27 import qualified Data.HashMap.Strict as HM
  28 import qualified Data.HashSet as HS
  29 import qualified Data.List as List
  30 import qualified Data.Text as Text
  31 import qualified Data.Text.Lazy as TL
  32 import qualified Data.Text.Lazy.Builder as TLB
  33 import qualified Data.Text.Lazy.Encoding as TL
  34 import qualified System.IO.Error as IO
  35
  36 import Symantic.Base.CurryN
  37 import Symantic.XML.Language
  38 import Symantic.XML.RelaxNG.Language
  39
  40 -- * Type 'Write'
  41 newtype Write params k
  42  =      Write
  43  {    unWrite :: (WriteSyn -> k) -> params
  44  }
  45
  46 write :: Write params BSL.ByteString -> params
  47 write = runWrite defaultWriteInh
  48
  49 runWrite :: WriteInh -> Write params BSL.ByteString -> params
  50 runWrite def (Write params) = params $ \syn ->
  51   TL.encodeUtf8 $ TLB.toLazyText $
  52   fromMaybe mempty $ writeSyn_result syn def
  53
  54 writeUtf8 :: FilePath -> Write params (IO (Maybe ErrorWrite)) -> params
  55 writeUtf8 path (Write params) = params $ \syn ->
  56   let txt =
  57        TL.encodeUtf8 $ TLB.toLazyText $
  58        fromMaybe mempty $
  59        writeSyn_result syn defaultWriteInh in
  60   (Nothing <$ BSL.writeFile path txt)
  61   `Exn.catch` \e ->
  62     if IO.isAlreadyInUseError e
  63     || IO.isPermissionError   e
  64     then pure $ Just e
  65     else IO.ioError e
  66
  67 -- ** Type 'Write'
  68 type ErrorWrite = IO.IOError
  69
  70 -- ** Type 'WriteInh'
  71 -- | Top-down inheritage.
  72 data WriteInh
  73  =   WriteInh
  74  {   writeInh_namespaces   :: Namespaces NCName
  75      -- ^ 'Namespaces' from the parent element.
  76  ,   writeInh_indent       :: TLB.Builder
  77  ,   writeInh_indent_delta :: TL.Text
  78  }
  79
  80 defaultWriteInh :: WriteInh
  81 defaultWriteInh = WriteInh
  82  { writeInh_namespaces   = defaultNamespaces
  83  , writeInh_indent       = mempty
  84  , writeInh_indent_delta = "  "
  85  }
  86
  87 -- ** Type 'WriteSyn'
  88 -- | Bottom-up synthesis to build 'element' or 'attribute'.
  89 data WriteSyn
  90  =   WriteSyn
  91  {   writeSyn_attrs :: HM.HashMap QName TL.Text
  92  ,   writeSyn_attr :: TL.Text
  93  ,   writeSyn_namespaces_default :: Maybe Namespace
  94  ,   writeSyn_namespaces_prefixes :: HM.HashMap Namespace NCName
  95  ,   writeSyn_result :: WriteInh -> Maybe TLB.Builder
  96  }
  97
  98 instance Semigroup WriteSyn where
  99   x <> y = WriteSyn
 100    { writeSyn_attrs = writeSyn_attrs x <> writeSyn_attrs y
 101    , writeSyn_attr = writeSyn_attr x <> writeSyn_attr y
 102    , writeSyn_namespaces_default = writeSyn_namespaces_default x <|> writeSyn_namespaces_default y
 103    , writeSyn_namespaces_prefixes = writeSyn_namespaces_prefixes x <> writeSyn_namespaces_prefixes y
 104    , writeSyn_result = writeSyn_result x <> writeSyn_result y
 105    }
 106 instance Monoid WriteSyn where
 107   mempty = WriteSyn
 108    { writeSyn_attrs = mempty
 109    , writeSyn_attr = mempty
 110    , writeSyn_namespaces_default = Nothing
 111    , writeSyn_namespaces_prefixes = mempty
 112    , writeSyn_result = mempty
 113    }
 114
 115 instance Emptyable Write where
 116   empty = Write (\k -> k mempty)
 117 instance Unitable Write where
 118   unit = Write (\k () -> k mempty)
 119 instance Voidable Write where
 120   void a (Write x) = Write (\k -> x k a)
 121 instance Dimapable Write where
 122   dimap _a2b b2a (Write x) = Write $ \k b ->
 123     x k (b2a b)
 124 instance Dicurryable Write where
 125   dicurry (_::proxy args) _construct destruct (Write x) =
 126     Write $ \k r ->
 127       uncurryN @args (x k) (destruct r)
 128 instance Composable Write where
 129   Write x <.> Write y = Write $ \k ->
 130     x (\mx -> y $ \my -> k (mx<>my))
 131 instance Tupable Write where
 132   Write x <:> Write y = Write $ \k (a,b) ->
 133     x (\mx -> y (\my -> k (mx<>my)) b) a
 134 instance Eitherable Write where
 135   Write x <+> Write y = Write $ \k -> \case
 136    Left  a -> x k a
 137    Right b -> y k b
 138 instance Constant Write where
 139   constant _a = Write $ \k _a -> k mempty
 140 instance Optionable Write where
 141   option = id
 142   optional (Write x) = Write $ \k ->
 143     \case
 144      Nothing -> k mempty
 145      Just a -> x k a
 146 {-
 147 instance Routable Write where
 148   Write x <!> Write y = Write $ \k ->
 149     x k :!: y k
 150 -}
 151 instance Repeatable Write where
 152   many0 (Write x) = Write $ \k -> \case
 153    [] -> k mempty
 154    a:as -> x (\ma ->
 155     unWrite (many0 (Write x))
 156      (\mas -> k (ma<>mas)) as) a
 157   many1 (Write x) = Write $ \k -> \case
 158    [] -> k mempty
 159    a:as -> x (\ma ->
 160     unWrite (many0 (Write x))
 161      (\mas -> k (ma<>mas)) as) a
 162 instance Textable Write where
 163   type TextConstraint Write a = EncodeText a
 164   text = Write $ \k v ->
 165     let t = encodeText v in
 166     k mempty
 167      { writeSyn_attr = t
 168      , writeSyn_result = \_inh -> Just $ textify $ escapeText t
 169      }
 170 instance XML Write where
 171   namespace nm ns = Write $ \k ->
 172     k $ case nm of
 173      Nothing -> mempty{writeSyn_namespaces_default=Just ns}
 174      Just p  -> mempty{writeSyn_namespaces_prefixes=HM.singleton ns p}
 175   element elemQName (Write x) = Write $ \k ->
 176     x $ \syn ->
 177       k mempty{ writeSyn_result = \inh ->
 178       let
 179         hasIndenting = not $ TL.null $ writeInh_indent_delta inh
 180         defNS = fromMaybe
 181          (namespaces_default (writeInh_namespaces inh))
 182          (writeSyn_namespaces_default syn)
 183         usedNS =
 184           HS.singleton (qNameSpace elemQName) <>
 185           HS.delete xmlns_empty (HS.fromList (qNameSpace <$> HM.keys (writeSyn_attrs syn)))
 186         -- The inherited namespaces,
 187         -- including those declared at this element.
 188         inhNS =
 189           HM.union
 190            (writeSyn_namespaces_prefixes syn)
 191            (namespaces_prefixes (writeInh_namespaces inh))
 192         -- The namespaces used but not declared nor default,
 193         -- with fresh prefixes.
 194         autoNS =
 195           -- HM.delete defNS $
 196           (`S.evalState` HS.empty) $
 197           traverse
 198            (\() -> S.gets freshNCName)
 199            (HS.toMap usedNS `HM.difference` inhNS)
 200         write_xmlnsAttrs =
 201           (if defNS == namespaces_default (writeInh_namespaces inh)
 202           then mempty
 203           else textifyAttr (PName Nothing "xmlns") (escapeAttr (unNamespace defNS))) <>
 204           HM.foldrWithKey (\(Namespace ns) qNameLocal acc ->
 205             textifyAttr (PName (Just "xmlns") qNameLocal) (escapeAttr ns) <> acc
 206            ) mempty
 207            (autoNS <> writeSyn_namespaces_prefixes syn)
 208         scopeNS = Namespaces
 209          { namespaces_prefixes = autoNS <> inhNS
 210          , namespaces_default = defNS
 211          }
 212         write_elemPName = textify $ prefixifyQName scopeNS elemQName
 213         write_elemAttrs =
 214           foldMap (\(an, av) -> textifyAttr
 215            (prefixifyQName scopeNS{namespaces_default=xmlns_empty} an)
 216            (escapeAttr av)) $
 217           List.sortOn fst $ -- This makes the rendition more predictible, but this is useless.
 218           HM.toList (writeSyn_attrs syn)
 219         write_elemChilds = writeSyn_result syn inh
 220          { writeInh_namespaces = scopeNS
 221          -- Disable indenting unless hasIndenting.
 222          , writeInh_indent =
 223           if hasIndenting
 224           then
 225             writeInh_indent inh <>
 226             textify (writeInh_indent_delta inh)
 227           else mempty
 228          , writeInh_indent_delta =
 229           if hasIndenting
 230           then writeInh_indent_delta inh
 231           else mempty
 232          }
 233       in Just $
 234       writeInh_indent inh
 235        <> "<"
 236        <> write_elemPName
 237        <> write_xmlnsAttrs
 238        <> write_elemAttrs
 239        <> case write_elemChilds of
 240        Nothing -> "/>" <> nl inh
 241        Just w -> ">"
 242          <> nl inh
 243          <> w
 244          <> (if hasIndenting then writeInh_indent inh else mempty)
 245          <> "</"<>write_elemPName<>">"
 246          <> nl inh
 247       }
 248   attribute n@(QName ans aln) (Write x) = Write $ \k ->
 249     x $ \syn ->
 250       if ans == xmlns_xmlns
 251       then unWrite (namespace (Just aln) (Namespace (writeSyn_attr syn))) k
 252       else if ans == xmlns_empty && aln == NCName "xmlns"
 253       then unWrite (namespace Nothing (Namespace (writeSyn_attr syn))) k
 254       else k mempty{writeSyn_attrs = HM.insert n (writeSyn_attr syn) (writeSyn_attrs syn)}
 255   literal lit = Write $ \k ->
 256     k mempty
 257      { writeSyn_attr = lit
 258      , writeSyn_result = \_inh ->
 259       Just $ textify $ escapeText lit
 260      }
 261   pi n = Write $ \k v ->
 262     k mempty{ writeSyn_result = \inh ->
 263       let s | TL.null v = ""
 264             | otherwise  = " " in
 265       Just $
 266       writeInh_indent inh <>
 267       "<?"<>textify n<>s <>
 268       textify (TL.replace "?>" "?&gt;" v) <>
 269       "?>"<>nl inh
 270     }
 271   comment = Write $ \k v ->
 272     k mempty{ writeSyn_result = \inh ->
 273       Just $
 274       writeInh_indent inh <>
 275       "<!--"<>textify (TL.replace "-->" "--&gt;" v)<>"-->"<>nl inh
 276     }
 277   cdata = Write $ \k v ->
 278     k mempty{ writeSyn_result = \inh ->
 279       Just $
 280       writeInh_indent inh <>
 281       "<[CDATA[["<>textify (TL.replace "]]>" "]]&gt;" v)<>"]]>"<>nl inh
 282     }
 283 instance Permutable Write where
 284   type Permutation Write = WritePerm Write
 285   permutable = unWritePerm
 286   perm = WritePerm
 287   noPerm = WritePerm empty
 288   permWithDefault _a = WritePerm
 289 instance Definable Write where
 290   define _n = id
 291 instance RelaxNG Write where
 292   elementMatch nc x = Write $ \k n ->
 293     if matchNameClass nc n
 294     then error "elementMatch: given QName does not match expected NameClass"
 295     else unWrite (element n x) k
 296   attributeMatch nc x = Write $ \k n ->
 297     if matchNameClass nc n
 298     then error "attributeMatch: given QName does not match expected NameClass"
 299     else unWrite (attribute n x) k
 300
 301 -- ** Type 'WritePerm'
 302 newtype WritePerm repr xml k
 303  =      WritePerm
 304  {    unWritePerm :: repr xml k }
 305 instance Transformable (WritePerm repr) where
 306   type UnTrans (WritePerm repr) = repr
 307   noTrans = WritePerm
 308   unTrans = unWritePerm
 309 instance Dimapable (WritePerm Write)
 310 instance Composable (WritePerm Write)
 311 instance Tupable (WritePerm Write)
 312
 313 nl :: WriteInh -> TLB.Builder
 314 nl inh | TL.null (writeInh_indent_delta inh) = mempty
 315        | otherwise = "\n"
 316
 317 -- * Class 'EncodeText'
 318 class EncodeText a where
 319   encodeText :: a -> TL.Text
 320   default encodeText :: Show a => a -> TL.Text
 321   encodeText = TL.pack . show
 322 instance EncodeText String where
 323   encodeText = TL.pack
 324 instance EncodeText Text.Text where
 325   encodeText = TL.fromStrict
 326 instance EncodeText TL.Text where
 327   encodeText = id
 328 instance EncodeText Bool where
 329   encodeText = \case
 330    False -> "0"
 331    True  -> "1"
 332 instance EncodeText Int
 333 instance EncodeText Integer
 334 instance EncodeText Natural