{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE UndecidableInstances #-}
module Symantic.XML.Write where
import Control.Applicative (Applicative(..), Alternative((<|>)))
import Data.Bool
import Data.Either (Either(..))
import Data.Eq (Eq(..))
import Data.Foldable (Foldable(..))
import Data.Function (($), (.), id)
import Data.Functor ((<$>), (<$))
import Data.Int (Int)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Monoid (Monoid(..))
import Data.Semigroup (Semigroup(..))
import Data.String (String)
import Data.Traversable (Traversable(..))
import Data.Tuple (fst)
import Numeric.Natural (Natural)
import Prelude (Integer, error)
import System.IO (IO, FilePath)
import Text.Show (Show(..))
import qualified Control.Exception as Exn
import qualified Control.Monad.Trans.State as S
import qualified Data.ByteString.Lazy as BSL
import qualified Data.HashMap.Strict as HM
import qualified Data.HashSet as HS
import qualified Data.List as List
import qualified Data.Text as Text
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TLB
import qualified Data.Text.Lazy.Encoding as TL
import qualified System.IO.Error as IO
import Symantic.Base.CurryN
import Symantic.XML.Language
import Symantic.XML.RelaxNG.Language
newtype Write params k
= Write
{ unWrite :: (WriteSyn -> k) -> params
}
write :: Write params BSL.ByteString -> params
write = runWrite defaultWriteInh
runWrite :: WriteInh -> Write params BSL.ByteString -> params
runWrite def (Write params) = params $ \syn ->
TL.encodeUtf8 $ TLB.toLazyText $
fromMaybe mempty $ writeSyn_result syn def
writeUtf8 :: FilePath -> Write params (IO (Maybe ErrorWrite)) -> params
writeUtf8 path (Write params) = params $ \syn ->
let txt =
TL.encodeUtf8 $ TLB.toLazyText $
fromMaybe mempty $
writeSyn_result syn defaultWriteInh in
(Nothing <$ BSL.writeFile path txt)
`Exn.catch` \e ->
if IO.isAlreadyInUseError e
|| IO.isPermissionError e
then pure $ Just e
else IO.ioError e
type ErrorWrite = IO.IOError
data WriteInh
= WriteInh
{ writeInh_namespaces :: Namespaces NCName
, writeInh_indent :: TLB.Builder
, writeInh_indent_delta :: TL.Text
}
defaultWriteInh :: WriteInh
defaultWriteInh = WriteInh
{ writeInh_namespaces = defaultNamespaces
, writeInh_indent = mempty
, writeInh_indent_delta = " "
}
data WriteSyn
= WriteSyn
{ writeSyn_attrs :: HM.HashMap QName TL.Text
, writeSyn_attr :: TL.Text
, writeSyn_namespaces_default :: Maybe Namespace
, writeSyn_namespaces_prefixes :: HM.HashMap Namespace NCName
, writeSyn_result :: WriteInh -> Maybe TLB.Builder
}
instance Semigroup WriteSyn where
x <> y = WriteSyn
{ writeSyn_attrs = writeSyn_attrs x <> writeSyn_attrs y
, writeSyn_attr = writeSyn_attr x <> writeSyn_attr y
, writeSyn_namespaces_default = writeSyn_namespaces_default x <|> writeSyn_namespaces_default y
, writeSyn_namespaces_prefixes = writeSyn_namespaces_prefixes x <> writeSyn_namespaces_prefixes y
, writeSyn_result = writeSyn_result x <> writeSyn_result y
}
instance Monoid WriteSyn where
mempty = WriteSyn
{ writeSyn_attrs = mempty
, writeSyn_attr = mempty
, writeSyn_namespaces_default = Nothing
, writeSyn_namespaces_prefixes = mempty
, writeSyn_result = mempty
}
instance Emptyable Write where
empty = Write (\k -> k mempty)
instance Unitable Write where
unit = Write (\k () -> k mempty)
instance Voidable Write where
void a (Write x) = Write (\k -> x k a)
instance Dimapable Write where
dimap _a2b b2a (Write x) = Write $ \k b ->
x k (b2a b)
instance Dicurryable Write where
dicurry (_::proxy args) _construct destruct (Write x) =
Write $ \k r ->
uncurryN @args (x k) (destruct r)
instance Composable Write where
Write x <.> Write y = Write $ \k ->
x (\mx -> y $ \my -> k (mx<>my))
instance Tupable Write where
Write x <:> Write y = Write $ \k (a,b) ->
x (\mx -> y (\my -> k (mx<>my)) b) a
instance Eitherable Write where
Write x <+> Write y = Write $ \k -> \case
Left a -> x k a
Right b -> y k b
instance Constant Write where
constant _a = Write $ \k _a -> k mempty
instance Optionable Write where
option = id
optional (Write x) = Write $ \k ->
\case
Nothing -> k mempty
Just a -> x k a
instance Repeatable Write where
many0 (Write x) = Write $ \k -> \case
[] -> k mempty
a:as -> x (\ma ->
unWrite (many0 (Write x))
(\mas -> k (ma<>mas)) as) a
many1 (Write x) = Write $ \k -> \case
[] -> k mempty
a:as -> x (\ma ->
unWrite (many0 (Write x))
(\mas -> k (ma<>mas)) as) a
instance Textable Write where
type TextConstraint Write a = EncodeText a
text = Write $ \k v ->
let t = encodeText v in
k mempty
{ writeSyn_attr = t
, writeSyn_result = \_inh -> Just $ textify $ escapeText t
}
instance XML Write where
namespace nm ns = Write $ \k ->
k $ case nm of
Nothing -> mempty{writeSyn_namespaces_default=Just ns}
Just p -> mempty{writeSyn_namespaces_prefixes=HM.singleton ns p}
element elemQName (Write x) = Write $ \k ->
x $ \syn ->
k mempty{ writeSyn_result = \inh ->
let
hasIndenting = not $ TL.null $ writeInh_indent_delta inh
defNS = fromMaybe
(namespaces_default (writeInh_namespaces inh))
(writeSyn_namespaces_default syn)
usedNS =
HS.singleton (qNameSpace elemQName) <>
HS.delete xmlns_empty (HS.fromList (qNameSpace <$> HM.keys (writeSyn_attrs syn)))
inhNS =
HM.union
(writeSyn_namespaces_prefixes syn)
(namespaces_prefixes (writeInh_namespaces inh))
autoNS =
(`S.evalState` HS.empty) $
traverse
(\() -> S.gets freshNCName)
(HS.toMap usedNS `HM.difference` inhNS)
write_xmlnsAttrs =
(if defNS == namespaces_default (writeInh_namespaces inh)
then mempty
else textifyAttr (PName Nothing "xmlns") (escapeAttr (unNamespace defNS))) <>
HM.foldrWithKey (\(Namespace ns) qNameLocal acc ->
textifyAttr (PName (Just "xmlns") qNameLocal) (escapeAttr ns) <> acc
) mempty
(autoNS <> writeSyn_namespaces_prefixes syn)
scopeNS = Namespaces
{ namespaces_prefixes = autoNS <> inhNS
, namespaces_default = defNS
}
write_elemPName = textify $ prefixifyQName scopeNS elemQName
write_elemAttrs =
foldMap (\(an, av) -> textifyAttr
(prefixifyQName scopeNS{namespaces_default=xmlns_empty} an)
(escapeAttr av)) $
List.sortOn fst $
HM.toList (writeSyn_attrs syn)
write_elemChilds = writeSyn_result syn inh
{ writeInh_namespaces = scopeNS
, writeInh_indent =
if hasIndenting
then
writeInh_indent inh <>
textify (writeInh_indent_delta inh)
else mempty
, writeInh_indent_delta =
if hasIndenting
then writeInh_indent_delta inh
else mempty
}
in Just $
writeInh_indent inh
<> "<"
<> write_elemPName
<> write_xmlnsAttrs
<> write_elemAttrs
<> case write_elemChilds of
Nothing -> "/>" <> nl inh
Just w -> ">"
<> nl inh
<> w
<> (if hasIndenting then writeInh_indent inh else mempty)
<> "</"<>write_elemPName<>">"
<> nl inh
}
attribute n@(QName ans aln) (Write x) = Write $ \k ->
x $ \syn ->
if ans == xmlns_xmlns
then unWrite (namespace (Just aln) (Namespace (writeSyn_attr syn))) k
else if ans == xmlns_empty && aln == NCName "xmlns"
then unWrite (namespace Nothing (Namespace (writeSyn_attr syn))) k
else k mempty{writeSyn_attrs = HM.insert n (writeSyn_attr syn) (writeSyn_attrs syn)}
literal lit = Write $ \k ->
k mempty
{ writeSyn_attr = lit
, writeSyn_result = \_inh ->
Just $ textify $ escapeText lit
}
pi n = Write $ \k v ->
k mempty{ writeSyn_result = \inh ->
let s | TL.null v = ""
| otherwise = " " in
Just $
writeInh_indent inh <>
"<?"<>textify n<>s <>
textify (TL.replace "?>" "?>" v) <>
"?>"<>nl inh
}
comment = Write $ \k v ->
k mempty{ writeSyn_result = \inh ->
Just $
writeInh_indent inh <>
"<!--"<>textify (TL.replace "-->" "-->" v)<>"-->"<>nl inh
}
cdata = Write $ \k v ->
k mempty{ writeSyn_result = \inh ->
Just $
writeInh_indent inh <>
"<[CDATA[["<>textify (TL.replace "]]>" "]]>" v)<>"]]>"<>nl inh
}
instance Permutable Write where
type Permutation Write = WritePerm Write
permutable = unWritePerm
perm = WritePerm
noPerm = WritePerm empty
permWithDefault _a = WritePerm
instance Definable Write where
define _n = id
instance RelaxNG Write where
elementMatch nc x = Write $ \k n ->
if matchNameClass nc n
then error "elementMatch: given QName does not match expected NameClass"
else unWrite (element n x) k
attributeMatch nc x = Write $ \k n ->
if matchNameClass nc n
then error "attributeMatch: given QName does not match expected NameClass"
else unWrite (attribute n x) k
newtype WritePerm repr xml k
= WritePerm
{ unWritePerm :: repr xml k }
instance Transformable (WritePerm repr) where
type UnTrans (WritePerm repr) = repr
noTrans = WritePerm
unTrans = unWritePerm
instance Dimapable (WritePerm Write)
instance Composable (WritePerm Write)
instance Tupable (WritePerm Write)
nl :: WriteInh -> TLB.Builder
nl inh | TL.null (writeInh_indent_delta inh) = mempty
| otherwise = "\n"
class EncodeText a where
encodeText :: a -> TL.Text
default encodeText :: Show a => a -> TL.Text
encodeText = TL.pack . show
instance EncodeText String where
encodeText = TL.pack
instance EncodeText Text.Text where
encodeText = TL.fromStrict
instance EncodeText TL.Text where
encodeText = id
instance EncodeText Bool where
encodeText = \case
False -> "0"
True -> "1"
instance EncodeText Int
instance EncodeText Integer
instance EncodeText Natural