{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE OverloadedStrings #-}
module Symantic.XML.RelaxNG.Compact.Write where
import Control.Applicative (Applicative(..), Alternative(..))
import Control.Monad (forM)
import Data.Bool
import Data.Eq (Eq(..))
import Data.Foldable (Foldable(..))
import Data.Function (($), (.), id, const)
import Data.Functor ((<$>))
import Data.Int (Int)
import Data.Maybe (Maybe(..), maybe, catMaybes, isNothing)
import Data.Monoid (Monoid(..))
import Data.Semigroup (Semigroup(..))
import Data.String (IsString(..), String)
import Numeric.Natural (Natural)
import Prelude (Integer)
import qualified Control.Monad.Trans.State.Strict as S
import qualified Data.HashMap.Strict as HM
import qualified Data.HashSet as HS
import qualified Data.List as List
import qualified Data.Map.Strict as Map
import qualified Data.Text as Text
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TLB
import Symantic.Base.Fixity
import Symantic.XML.Language
import Symantic.XML.RelaxNG.Language
writeRNC :: RNCWriteSyn a k -> TL.Text
writeRNC = TLB.toLazyText . runRNCWriteSyn
runRNCWriteSyn :: RNCWriteSyn a k -> TLB.Builder
runRNCWriteSyn RNCWriteSyn{..} =
mconcat $
List.concat
[ [ "default namespace = \""<>textify (namespaces_default rncWriteInh_namespaces)<>"\"\n"
| not $ TL.null $ unNamespace (namespaces_default rncWriteInh_namespaces)
]
, [ "namespace "<>textify p<>" = \""<>textify n<>"\"\n"
| (Namespace n, NCName p) <-
HM.toList (namespaces_prefixes rncWriteInh_namespaces)
]
, Map.foldrWithKey
(\n v -> ((textify n<>" = "<>v<>"\n") :)) []
defs
]
where
RNCWriteState{..} = rncWriteSyn_state $ RNCWriteState mempty mempty
defs :: Map.Map DefineName TLB.Builder
defs = Map.mapMaybe ($ inh) rncWriteState_defines
inh = RNCWriteInh
{ rncWriteInh_namespaces
, rncWriteInh_op = (infixN0, SideL)
, rncWriteInh_pair = pairParen
}
rncWriteInh_namespaces :: Namespaces NCName
rncWriteInh_namespaces = rncWriteState_namespaces
{ namespaces_prefixes =
(`S.evalState` HS.empty) $
forM prefixByNamespace $ \mp -> do
usedPrefixes <- S.get
let
freshPrefix = maybe
(freshNCName usedPrefixes)
(freshifyNCName usedPrefixes)
mp
S.modify' $ HS.insert freshPrefix
pure freshPrefix
}
prefixByNamespace :: HM.HashMap Namespace (Maybe NCName)
prefixByNamespace =
HM.union
(HM.intersectionWith (<|>)
(namespaces_prefixes rncWriteState_namespaces)
(Just <$> namespaces_prefixes defaultNamespaces)) $
namespaces_prefixes rncWriteState_namespaces
data RNCWriteState
= RNCWriteState
{ rncWriteState_namespaces :: Namespaces (Maybe NCName)
, rncWriteState_defines :: Map.Map DefineName (RNCWriteInh -> Maybe TLB.Builder)
}
data RNCWriteSyn a k
= RNCWriteSyn
{ rncWriteSyn_state :: Chained RNCWriteState
, rncWriteSyn_schema :: RNCWriteInh -> Maybe TLB.Builder
}
instance IsString (RNCWriteSyn a k) where
fromString s = RNCWriteSyn
{ rncWriteSyn_state = id
, rncWriteSyn_schema = const $
if List.null s then Nothing
else Just (textify s)
}
type Chained a = a -> a
coerceRNCWriteSyn :: RNCWriteSyn a k -> RNCWriteSyn a' k'
coerceRNCWriteSyn RNCWriteSyn{..} = RNCWriteSyn{..}
{-# INLINE coerceRNCWriteSyn #-}
pairRNCWriteInh ::
Semigroup s => IsString s =>
RNCWriteInh -> Infix -> Maybe s -> Maybe s
pairRNCWriteInh inh op s =
if isPairNeeded (rncWriteInh_op inh) op
then Just (fromString o<>" ")<>s<>Just (" "<>fromString c)
else s
where (o,c) = rncWriteInh_pair inh
data RNCWriteInh
= RNCWriteInh
{ rncWriteInh_namespaces :: Namespaces NCName
, rncWriteInh_op :: (Infix, Side)
, rncWriteInh_pair :: Pair
}
instance Emptyable RNCWriteSyn where
empty = "empty"
instance Unitable RNCWriteSyn where
unit = ""
instance Voidable RNCWriteSyn where
void _a = coerceRNCWriteSyn
instance Constant RNCWriteSyn where
constant _a = ""
instance Composable RNCWriteSyn where
x <.> y = RNCWriteSyn
(rncWriteSyn_state x . rncWriteSyn_state y) $ \inh ->
let
inh' side = inh
{ rncWriteInh_op = (op, side)
, rncWriteInh_pair = pairParen
} in
case rncWriteSyn_schema x (inh' SideL) of
Nothing -> rncWriteSyn_schema y (inh' SideR)
Just xw ->
case rncWriteSyn_schema y (inh' SideR) of
Nothing -> Just xw
Just yw ->
pairRNCWriteInh inh op $
Just $ xw <> ", " <> yw
where
op = infixB SideL 2
instance Tupable RNCWriteSyn where
x <:> y = coerceRNCWriteSyn x <.> coerceRNCWriteSyn y
instance Eitherable RNCWriteSyn where
x <+> y = RNCWriteSyn
(rncWriteSyn_state x . rncWriteSyn_state y) $ \inh ->
pairRNCWriteInh inh op $
rncWriteSyn_schema x inh
{ rncWriteInh_op = (op, SideL)
, rncWriteInh_pair = pairParen
} <>
Just " | " <>
rncWriteSyn_schema y inh
{ rncWriteInh_op = (op, SideR)
, rncWriteInh_pair = pairParen
}
where op = infixB SideL 3
instance Optionable RNCWriteSyn where
option = coerceRNCWriteSyn . optional . coerceRNCWriteSyn
optional w = w{ rncWriteSyn_schema = \inh ->
pairRNCWriteInh inh op $
rncWriteSyn_schema w inh
{ rncWriteInh_op = (op, SideL)
, rncWriteInh_pair = pairParen
} <> Just "?"
}
where op = infixN 9
instance Dimapable RNCWriteSyn where
dimap _a2b _b2a = coerceRNCWriteSyn
instance Dicurryable RNCWriteSyn where
dicurry _args _constr _destr = coerceRNCWriteSyn
instance Repeatable RNCWriteSyn where
many0 w = w{ rncWriteSyn_schema = \inh ->
pairRNCWriteInh inh op $
rncWriteSyn_schema w inh
{ rncWriteInh_op = (op, SideL)
, rncWriteInh_pair = pairParen
} <> Just "*"
}
where op = infixN 9
many1 w = w{ rncWriteSyn_schema = \inh ->
pairRNCWriteInh inh op $
rncWriteSyn_schema w inh
{ rncWriteInh_op = (op, SideL)
, rncWriteInh_pair = pairParen
} <> Just "+"
}
where op = infixN 9
instance Textable RNCWriteSyn where
type TextConstraint RNCWriteSyn a = RNCText a
text :: forall a k. TextConstraint RNCWriteSyn a => RNCWriteSyn (a -> k) k
text = RNCWriteSyn
{ rncWriteSyn_state = \st ->
case HM.lookup
(qNameSpace (rncText_qname @a))
(namespaces_prefixes (rncWriteState_namespaces st)) of
Just{} -> st
Nothing ->
let ns = qNameSpace (rncText_qname @a) in
if ns == xmlns_empty then st else st
{ rncWriteState_namespaces = (rncWriteState_namespaces st)
{ namespaces_prefixes =
HM.insertWith (<|>) ns Nothing $
namespaces_prefixes (rncWriteState_namespaces st) } }
, rncWriteSyn_schema = \inh ->
let n = rncText_qname @a in
let t = if TL.null (unNamespace (qNameSpace n))
then textify (qNameLocal n)
else textify (prefixifyQName (rncWriteInh_namespaces inh) n)
in if null (rncText_params @a)
then Just t
else
pairRNCWriteInh inh (infixN 8) $
Just $
t<>" {"<>Map.foldMapWithKey
(\k v -> " "<>textify k<>" = \""<>textify v<>"\"")
(rncText_params @a)<>" }"
}
instance XML RNCWriteSyn where
namespace mp ns = RNCWriteSyn
{ rncWriteSyn_state = \st -> st
{ rncWriteState_namespaces =
let nss = rncWriteState_namespaces st in
Namespaces
{ namespaces_prefixes =
HM.insertWith (<|>) ns mp (namespaces_prefixes nss)
, namespaces_default =
if isNothing mp
then ns
else namespaces_default nss
}
}
, rncWriteSyn_schema = const Nothing
}
element n w = w
{ rncWriteSyn_state = \st ->
rncWriteSyn_state w $ st
{ rncWriteState_namespaces = (rncWriteState_namespaces st)
{ namespaces_prefixes =
HM.insertWith (<|>) (qNameSpace n) Nothing
(namespaces_prefixes (rncWriteState_namespaces st)) } }
, rncWriteSyn_schema = \inh ->
pairRNCWriteInh inh (infixN 8) $
Just ("element "
<> textify (prefixifyQName (rncWriteInh_namespaces inh) n)
<> " {")
<> rncWriteSyn_schema w inh
{ rncWriteInh_op = (infixN0, SideR)
, rncWriteInh_pair = pairBrace
}
<> Just "}"
}
attribute n w = w
{ rncWriteSyn_state = \st ->
rncWriteSyn_state w $
if qNameSpace n == xmlns_empty then st else st
{ rncWriteState_namespaces = (rncWriteState_namespaces st)
{ namespaces_prefixes =
HM.insertWith (<|>) (qNameSpace n) Nothing
(namespaces_prefixes (rncWriteState_namespaces st)) } }
, rncWriteSyn_schema = \inh ->
pairRNCWriteInh inh (infixN 8) $
Just ("attribute "
<> textify (prefixifyQName (rncWriteInh_namespaces inh){namespaces_default=xmlns_empty} n)
<> " {")
<> rncWriteSyn_schema w inh
{ rncWriteInh_op = (infixN0, SideR)
, rncWriteInh_pair = pairBrace
}
<> Just "}"
}
literal lit = RNCWriteSyn
{ rncWriteSyn_state = id
, rncWriteSyn_schema = \_inh -> Just ("\""<>textify lit<>"\"")
}
pi _n = ""
comment = ""
cdata = ""
instance Definable RNCWriteSyn where
define n w = w
{ rncWriteSyn_state = \st ->
let defs = rncWriteState_defines st in
case Map.lookup n defs of
Nothing ->
rncWriteSyn_state w $ st
{ rncWriteState_defines =
Map.insert n (rncWriteSyn_schema w) defs
}
Just{} -> st
, rncWriteSyn_schema = const $ Just $ textify n
}
instance Permutable RNCWriteSyn where
type Permutation RNCWriteSyn = RNCWriteSynPerm
permutable (RNCWriteSynPerm ps) = RNCWriteSyn
{ rncWriteSyn_state = List.foldl' (.) id (rncWriteSyn_state <$> ps)
, rncWriteSyn_schema = case ps of
[] -> const Nothing
_ -> \inh ->
case
List.intersperse " & " $
catMaybes $ (<$> ps) $ \w ->
rncWriteSyn_schema w inh{rncWriteInh_op=(op, SideL)}
of
[] -> Nothing
[x] -> Just x
xs -> pairRNCWriteInh inh op $ Just $ mconcat xs
}
where op = infixR 3
perm = RNCWriteSynPerm . pure
noPerm = RNCWriteSynPerm []
permWithDefault _def p = RNCWriteSynPerm
[coerceRNCWriteSyn (optional p)]
instance RelaxNG RNCWriteSyn where
elementMatch nc w = w
{ rncWriteSyn_state = \st ->
rncWriteSyn_state w $ st
{ rncWriteState_namespaces = (rncWriteState_namespaces st)
{ namespaces_prefixes =
namespacesNameClass nc <>
namespaces_prefixes (rncWriteState_namespaces st)
} }
, rncWriteSyn_schema = \inh ->
pairRNCWriteInh inh (infixN 8) $
Just ("element "
<> textify (rncWriteInh_namespaces inh, (infixN0,SideL), nc)
<> " ")
<> rncWriteSyn_schema w inh
{ rncWriteInh_op = (infixN 9, SideR)
, rncWriteInh_pair = pairBrace
}
}
attributeMatch nc w = w
{ rncWriteSyn_state = \st ->
let nss = HM.delete xmlns_empty $ namespacesNameClass nc in
rncWriteSyn_state w $
if null nss then st else st
{ rncWriteState_namespaces = (rncWriteState_namespaces st)
{ namespaces_prefixes =
HM.unionWith (<|>) nss $
namespaces_prefixes (rncWriteState_namespaces st)
} }
, rncWriteSyn_schema = \inh ->
pairRNCWriteInh inh (infixN 8) $
Just ("attribute "
<> textify ( (rncWriteInh_namespaces inh){namespaces_default=xmlns_empty}
, (infixN0,SideL)
, nc )
<> " ")
<> rncWriteSyn_schema w inh
{ rncWriteInh_op = (infixN 9, SideR)
, rncWriteInh_pair = pairBrace
}
}
newtype RNCWriteSynPerm a k
= RNCWriteSynPerm
{ rncWriteSynPerm_alternatives :: [RNCWriteSyn a k]
}
instance Composable RNCWriteSynPerm where
RNCWriteSynPerm x <.> RNCWriteSynPerm y =
RNCWriteSynPerm $
(coerceRNCWriteSyn <$> x) <>
(coerceRNCWriteSyn <$> y)
instance Dimapable RNCWriteSynPerm where
dimap _a2b _b2a (RNCWriteSynPerm x) =
RNCWriteSynPerm (coerceRNCWriteSyn <$> x)
instance Tupable RNCWriteSynPerm where
RNCWriteSynPerm x <:> RNCWriteSynPerm y =
RNCWriteSynPerm $
(coerceRNCWriteSyn <$> x) <>
(coerceRNCWriteSyn <$> y)
instance Definable RNCWriteSynPerm where
define n (RNCWriteSynPerm ps) =
RNCWriteSynPerm $ pure $
coerceRNCWriteSyn $ define n $
permutable $ RNCWriteSynPerm $
coerceRNCWriteSyn <$> ps
class RNCText a where
rncText_qname :: QName
rncText_params :: Map.Map TL.Text TL.Text
rncText_params = mempty
instance RNCText String where
rncText_qname = QName (Namespace "") "text"
instance RNCText Text.Text where
rncText_qname = QName (Namespace "") "text"
instance RNCText TL.Text where
rncText_qname = QName (Namespace "") "text"
instance RNCText Bool where
rncText_qname = QName xmlns_xsd "boolean"
instance RNCText Int where
rncText_qname = QName xmlns_xsd "int"
instance RNCText Integer where
rncText_qname = QName xmlns_xsd "integer"
instance RNCText Natural where
rncText_qname = QName xmlns_xsd "nonNegativeInteger"