src/Symantic/XML/RelaxNG/Compact/Write.hs

   1 {-# LANGUAGE AllowAmbiguousTypes #-}
   2 {-# LANGUAGE InstanceSigs #-}
   3 {-# LANGUAGE Rank2Types #-}
   4 {-# LANGUAGE OverloadedStrings #-}
   5 module Symantic.XML.RelaxNG.Compact.Write where
   6
   7 import Control.Applicative (Applicative(..), Alternative(..))
   8 import Control.Monad (forM)
   9 import Data.Bool
  10 import Data.Eq (Eq(..))
  11 import Data.Foldable (Foldable(..))
  12 import Data.Function (($), (.), id, const)
  13 import Data.Functor ((<$>))
  14 import Data.Int (Int)
  15 import Data.Maybe (Maybe(..), maybe, catMaybes, isNothing)
  16 import Data.Monoid (Monoid(..))
  17 import Data.Semigroup (Semigroup(..))
  18 import Data.String (IsString(..), String)
  19 import Numeric.Natural (Natural)
  20 import Prelude (Integer)
  21 import qualified Control.Monad.Trans.State.Strict as S
  22 import qualified Data.HashMap.Strict as HM
  23 import qualified Data.HashSet as HS
  24 import qualified Data.List as List
  25 import qualified Data.Map.Strict as Map
  26 import qualified Data.Text as Text
  27 import qualified Data.Text.Lazy as TL
  28 import qualified Data.Text.Lazy.Builder as TLB
  29
  30 import Symantic.Base.Fixity
  31 import Symantic.XML.Language
  32 import Symantic.XML.RelaxNG.Language
  33
  34 -- | Get textual rendition of given 'RNCWriteSyn'.
  35 writeRNC :: RNCWriteSyn a k -> TL.Text
  36 writeRNC = TLB.toLazyText . runRNCWriteSyn
  37
  38 -- | Get textual rendition of given 'RNCWriteSyn'.
  39 runRNCWriteSyn :: RNCWriteSyn a k -> TLB.Builder
  40 runRNCWriteSyn RNCWriteSyn{..} =
  41   mconcat $
  42   List.concat
  43    [ [ "default namespace = \""<>textify (namespaces_default rncWriteInh_namespaces)<>"\"\n"
  44      | not $ TL.null $ unNamespace (namespaces_default rncWriteInh_namespaces)
  45      ]
  46    , [ "namespace "<>textify p<>" = \""<>textify n<>"\"\n"
  47      | (Namespace n, NCName p) <-
  48       HM.toList (namespaces_prefixes rncWriteInh_namespaces)
  49      ]
  50    , Map.foldrWithKey
  51      (\n v -> ((textify n<>" = "<>v<>"\n") :)) []
  52      defs
  53    ]
  54   where
  55   RNCWriteState{..} = rncWriteSyn_state $ RNCWriteState mempty mempty
  56   defs :: Map.Map DefineName TLB.Builder
  57   defs = Map.mapMaybe ($ inh) rncWriteState_defines
  58   inh = RNCWriteInh
  59    { rncWriteInh_namespaces
  60    , rncWriteInh_op = (infixN0, SideL)
  61    , rncWriteInh_pair = pairParen
  62    }
  63   rncWriteInh_namespaces :: Namespaces NCName
  64   rncWriteInh_namespaces = rncWriteState_namespaces
  65    { namespaces_prefixes =
  66     (`S.evalState` HS.empty) $
  67       forM prefixByNamespace $ \mp -> do
  68         usedPrefixes <- S.get
  69         let
  70          freshPrefix = maybe
  71            (freshNCName usedPrefixes)
  72            (freshifyNCName usedPrefixes)
  73            mp
  74         S.modify' $ HS.insert freshPrefix
  75         pure freshPrefix
  76    }
  77   prefixByNamespace :: HM.HashMap Namespace (Maybe NCName)
  78   prefixByNamespace =
  79     -- Add default prefixes if their 'Namespace' is used.
  80     HM.union
  81      (HM.intersectionWith (<|>)
  82        (namespaces_prefixes rncWriteState_namespaces)
  83        (Just <$> namespaces_prefixes defaultNamespaces)) $
  84     namespaces_prefixes rncWriteState_namespaces
  85
  86 -- * Type 'RNCWriteState'
  87 -- | Chained values.
  88 data RNCWriteState
  89  =   RNCWriteState
  90  {   rncWriteState_namespaces :: Namespaces (Maybe NCName)
  91      -- ^ The 'Namespaces' used throughout the 'RelaxNG' schema.
  92  ,   rncWriteState_defines    :: Map.Map DefineName (RNCWriteInh -> Maybe TLB.Builder)
  93      -- ^ Used to avoid infinite recursion,
  94      -- by looking up the 'DefineName' of 'define'.
  95  }
  96
  97 -- * Type 'RNCWriteSyn'
  98 -- | Synthetized (bottom-up) values.
  99 data RNCWriteSyn a k
 100  =   RNCWriteSyn
 101  {   rncWriteSyn_state  :: Chained RNCWriteState
 102  ,   rncWriteSyn_schema :: RNCWriteInh -> Maybe TLB.Builder
 103  }
 104 instance IsString (RNCWriteSyn a k) where
 105   fromString s = RNCWriteSyn
 106    { rncWriteSyn_state = id
 107    , rncWriteSyn_schema = const $
 108     if List.null s then Nothing
 109     else Just (textify s)
 110    }
 111
 112 -- | Like the @State st ()@ monad, but without @()@.
 113 -- The name comme from chained-attribute from Attribute Grammar.
 114 type Chained a = a -> a
 115
 116 coerceRNCWriteSyn :: RNCWriteSyn a k -> RNCWriteSyn a' k'
 117 coerceRNCWriteSyn RNCWriteSyn{..} = RNCWriteSyn{..}
 118 {-# INLINE coerceRNCWriteSyn #-}
 119
 120 pairRNCWriteInh ::
 121  Semigroup s => IsString s =>
 122  RNCWriteInh -> Infix -> Maybe s -> Maybe s
 123 pairRNCWriteInh inh op s =
 124   if isPairNeeded (rncWriteInh_op inh) op
 125   then Just (fromString o<>" ")<>s<>Just (" "<>fromString c)
 126   else s
 127   where (o,c) = rncWriteInh_pair inh
 128
 129 -- ** Type 'RNCWriteInh'
 130 -- Inherited (top-down) values.
 131 data RNCWriteInh
 132  =   RNCWriteInh
 133  {   rncWriteInh_namespaces :: Namespaces NCName
 134  ,   rncWriteInh_op :: (Infix, Side)
 135  ,   rncWriteInh_pair :: Pair
 136  }
 137
 138 instance Emptyable RNCWriteSyn where
 139   empty = "empty"
 140 instance Unitable RNCWriteSyn where
 141   unit = ""
 142 instance Voidable RNCWriteSyn where
 143   void _a = coerceRNCWriteSyn
 144 instance Constant RNCWriteSyn where
 145   constant _a = ""
 146 instance Composable RNCWriteSyn where
 147   x <.> y = RNCWriteSyn
 148    (rncWriteSyn_state x . rncWriteSyn_state y) $ \inh ->
 149     let
 150      inh' side = inh
 151       { rncWriteInh_op   = (op, side)
 152       , rncWriteInh_pair = pairParen
 153       } in
 154     case rncWriteSyn_schema x (inh' SideL) of
 155      Nothing -> rncWriteSyn_schema y (inh' SideR)
 156      Just xw ->
 157       case rncWriteSyn_schema y (inh' SideR) of
 158        Nothing -> Just xw
 159        Just yw ->
 160         pairRNCWriteInh inh op $
 161           Just $ xw <> ", " <> yw
 162     where
 163     op = infixB SideL 2
 164 instance Tupable RNCWriteSyn where
 165   x <:> y = coerceRNCWriteSyn x <.> coerceRNCWriteSyn y
 166 instance Eitherable RNCWriteSyn where
 167   x <+> y = RNCWriteSyn
 168    (rncWriteSyn_state x . rncWriteSyn_state y) $ \inh ->
 169     pairRNCWriteInh inh op $
 170     rncWriteSyn_schema x inh
 171      { rncWriteInh_op   = (op, SideL)
 172      , rncWriteInh_pair = pairParen
 173      } <>
 174     Just " | " <>
 175     rncWriteSyn_schema y inh
 176      { rncWriteInh_op   = (op, SideR)
 177      , rncWriteInh_pair = pairParen
 178      }
 179     where op = infixB SideL 3
 180 instance Optionable RNCWriteSyn where
 181   option = coerceRNCWriteSyn . optional . coerceRNCWriteSyn
 182   optional w = w{ rncWriteSyn_schema = \inh ->
 183     pairRNCWriteInh inh op $
 184     rncWriteSyn_schema w inh
 185      { rncWriteInh_op   = (op, SideL)
 186      , rncWriteInh_pair = pairParen
 187      } <> Just "?"
 188     }
 189     where op = infixN 9
 190 instance Dimapable RNCWriteSyn where
 191   dimap _a2b _b2a = coerceRNCWriteSyn
 192 instance Dicurryable RNCWriteSyn where
 193   dicurry _args _constr _destr = coerceRNCWriteSyn
 194 instance Repeatable RNCWriteSyn where
 195   many0 w = w{ rncWriteSyn_schema = \inh ->
 196     pairRNCWriteInh inh op $
 197     rncWriteSyn_schema w inh
 198      { rncWriteInh_op   = (op, SideL)
 199      , rncWriteInh_pair = pairParen
 200      } <> Just "*"
 201     }
 202     where op = infixN 9
 203   many1 w = w{ rncWriteSyn_schema = \inh ->
 204     pairRNCWriteInh inh op $
 205     rncWriteSyn_schema w inh
 206      { rncWriteInh_op   = (op, SideL)
 207      , rncWriteInh_pair = pairParen
 208      } <> Just "+"
 209     }
 210     where op = infixN 9
 211 instance Textable RNCWriteSyn where
 212   type TextConstraint RNCWriteSyn a = RNCText a
 213   text :: forall a k. TextConstraint RNCWriteSyn a => RNCWriteSyn (a -> k) k
 214   text = RNCWriteSyn
 215    { rncWriteSyn_state = \st ->
 216     case HM.lookup
 217      (qNameSpace (rncText_qname @a))
 218      (namespaces_prefixes (rncWriteState_namespaces st)) of
 219      Just{} -> st
 220      Nothing ->
 221       let ns = qNameSpace (rncText_qname @a) in
 222       if ns == xmlns_empty then st else st
 223        { rncWriteState_namespaces = (rncWriteState_namespaces st)
 224         { namespaces_prefixes =
 225         HM.insertWith (<|>) ns Nothing $
 226         namespaces_prefixes (rncWriteState_namespaces st) } }
 227    , rncWriteSyn_schema = \inh ->
 228     let n = rncText_qname @a in
 229     let t = if TL.null (unNamespace (qNameSpace n))
 230             then textify (qNameLocal n)
 231             else textify (prefixifyQName (rncWriteInh_namespaces inh) n)
 232     in if null (rncText_params @a)
 233     then Just t
 234     else
 235       pairRNCWriteInh inh (infixN 8) $
 236       Just $
 237       t<>" {"<>Map.foldMapWithKey
 238        (\k v -> " "<>textify k<>" = \""<>textify v<>"\"")
 239        (rncText_params @a)<>" }"
 240    }
 241 instance XML RNCWriteSyn where
 242   namespace mp ns = RNCWriteSyn
 243    { rncWriteSyn_state = \st -> st
 244     { rncWriteState_namespaces =
 245       let nss = rncWriteState_namespaces st in
 246       Namespaces
 247        { namespaces_prefixes =
 248         HM.insertWith (<|>) ns mp (namespaces_prefixes nss)
 249        , namespaces_default =
 250         if isNothing mp
 251         then ns
 252         else namespaces_default nss
 253        }
 254     }
 255    , rncWriteSyn_schema = const Nothing
 256    }
 257   element n w = w
 258    { rncWriteSyn_state = \st ->
 259     rncWriteSyn_state w $ st
 260      { rncWriteState_namespaces = (rncWriteState_namespaces st)
 261        { namespaces_prefixes =
 262         -- Insert this 'qNameSpace' even if this is the default namespace,
 263         -- because the default namespace here may not end up
 264         -- being the global default namespace
 265         -- if there is a default 'namespace' declaration after this one.
 266         -- at worse this will just add a superfluous ns# declaration
 267         -- in the schema rendering.
 268         HM.insertWith (<|>) (qNameSpace n) Nothing
 269          (namespaces_prefixes (rncWriteState_namespaces st)) } }
 270    , rncWriteSyn_schema = \inh ->
 271     pairRNCWriteInh inh (infixN 8) $
 272     Just ("element "
 273      <> textify (prefixifyQName (rncWriteInh_namespaces inh) n)
 274      <> " {")
 275     <> rncWriteSyn_schema w inh
 276      { rncWriteInh_op   = (infixN0, SideR)
 277      , rncWriteInh_pair = pairBrace
 278      }
 279     <> Just "}"
 280    }
 281   attribute n w = w
 282    { rncWriteSyn_state = \st ->
 283     rncWriteSyn_state w $
 284     if qNameSpace n == xmlns_empty then st else st
 285      { rncWriteState_namespaces = (rncWriteState_namespaces st)
 286        { namespaces_prefixes =
 287         HM.insertWith (<|>) (qNameSpace n) Nothing
 288          (namespaces_prefixes (rncWriteState_namespaces st)) } }
 289    , rncWriteSyn_schema = \inh ->
 290     pairRNCWriteInh inh (infixN 8) $
 291     Just ("attribute "
 292      -- The namespace name for an unprefixed attribute name always has no value.
 293      <> textify (prefixifyQName (rncWriteInh_namespaces inh){namespaces_default=xmlns_empty} n)
 294      <> " {")
 295     <> rncWriteSyn_schema w inh
 296      { rncWriteInh_op   = (infixN0, SideR)
 297      , rncWriteInh_pair = pairBrace
 298      }
 299     <> Just "}"
 300    }
 301   literal lit = RNCWriteSyn
 302    { rncWriteSyn_state = id
 303    , rncWriteSyn_schema = \_inh -> Just ("\""<>textify lit<>"\"")
 304    }
 305   pi _n   = ""
 306   comment = ""
 307   cdata   = ""
 308 instance Definable RNCWriteSyn where
 309   define n w = w
 310    { rncWriteSyn_state = \st ->
 311     let defs = rncWriteState_defines st in
 312     case Map.lookup n defs of
 313      Nothing ->
 314       rncWriteSyn_state w $ st
 315        { rncWriteState_defines =
 316         Map.insert n (rncWriteSyn_schema w) defs
 317        }
 318      Just{} -> st
 319    , rncWriteSyn_schema = const $ Just $ textify n
 320    }
 321 instance Permutable RNCWriteSyn where
 322   type Permutation RNCWriteSyn = RNCWriteSynPerm
 323   permutable (RNCWriteSynPerm ps) = RNCWriteSyn
 324    { rncWriteSyn_state = List.foldl' (.) id (rncWriteSyn_state <$> ps)
 325    , rncWriteSyn_schema = case ps of
 326      [] -> const Nothing
 327      _ -> \inh ->
 328       case
 329         List.intersperse " & " $
 330         catMaybes $ (<$> ps) $ \w ->
 331           rncWriteSyn_schema w inh{rncWriteInh_op=(op, SideL)}
 332       of
 333        [] -> Nothing
 334        [x] -> Just x
 335        xs -> pairRNCWriteInh inh op $ Just $ mconcat xs
 336    }
 337     where op = infixR 3
 338   perm = RNCWriteSynPerm . pure
 339   noPerm = RNCWriteSynPerm []
 340   permWithDefault _def p = RNCWriteSynPerm
 341    [coerceRNCWriteSyn (optional p)]
 342 instance RelaxNG RNCWriteSyn where
 343   elementMatch nc w = w
 344    { rncWriteSyn_state = \st ->
 345     rncWriteSyn_state w $ st
 346      { rncWriteState_namespaces = (rncWriteState_namespaces st)
 347        { namespaces_prefixes =
 348         namespacesNameClass nc <>
 349         namespaces_prefixes (rncWriteState_namespaces st)
 350        } }
 351    , rncWriteSyn_schema = \inh ->
 352     pairRNCWriteInh inh (infixN 8) $
 353     Just ("element "
 354      <> textify (rncWriteInh_namespaces inh, (infixN0,SideL), nc)
 355      <> " ")
 356     <> rncWriteSyn_schema w inh
 357      { rncWriteInh_op = (infixN 9, SideR)
 358      , rncWriteInh_pair = pairBrace
 359      }
 360    }
 361   attributeMatch nc w = w
 362    { rncWriteSyn_state = \st ->
 363     let nss = HM.delete xmlns_empty $ namespacesNameClass nc in
 364     rncWriteSyn_state w $
 365     if null nss then st else st
 366      { rncWriteState_namespaces = (rncWriteState_namespaces st)
 367        { namespaces_prefixes =
 368         HM.unionWith (<|>) nss $
 369         namespaces_prefixes (rncWriteState_namespaces st)
 370        } }
 371    , rncWriteSyn_schema = \inh ->
 372     pairRNCWriteInh inh (infixN 8) $
 373     Just ("attribute "
 374      <> textify ( (rncWriteInh_namespaces inh){namespaces_default=xmlns_empty}
 375               , (infixN0,SideL)
 376               , nc )
 377      <> " ")
 378     <> rncWriteSyn_schema w inh
 379      { rncWriteInh_op   = (infixN 9, SideR)
 380      , rncWriteInh_pair = pairBrace
 381      }
 382    }
 383
 384 -- ** Type 'RNCWriteSynPerm'
 385 newtype RNCWriteSynPerm a k
 386  =      RNCWriteSynPerm
 387  {      rncWriteSynPerm_alternatives :: [RNCWriteSyn a k]
 388         -- ^ Collect alternatives for rendering
 389         -- them all at once in 'runPermutation'.
 390  }
 391 instance Composable RNCWriteSynPerm where
 392   RNCWriteSynPerm x <.> RNCWriteSynPerm y =
 393     RNCWriteSynPerm $
 394       (coerceRNCWriteSyn <$> x) <>
 395       (coerceRNCWriteSyn <$> y)
 396 instance Dimapable RNCWriteSynPerm where
 397   dimap _a2b _b2a (RNCWriteSynPerm x) =
 398     RNCWriteSynPerm (coerceRNCWriteSyn <$> x)
 399 instance Tupable RNCWriteSynPerm where
 400   RNCWriteSynPerm x <:> RNCWriteSynPerm y =
 401     RNCWriteSynPerm $
 402       (coerceRNCWriteSyn <$> x) <>
 403       (coerceRNCWriteSyn <$> y)
 404 instance Definable RNCWriteSynPerm where
 405   define n (RNCWriteSynPerm ps) =
 406     RNCWriteSynPerm $ pure $
 407       coerceRNCWriteSyn $ define n $
 408         permutable $ RNCWriteSynPerm $
 409           coerceRNCWriteSyn <$> ps
 410
 411 -- * Class 'RNCText'
 412 class RNCText a where
 413   rncText_qname  :: QName
 414   rncText_params :: Map.Map TL.Text TL.Text
 415   rncText_params = mempty
 416 instance RNCText String where
 417   rncText_qname = QName (Namespace "") "text"
 418 instance RNCText Text.Text where
 419   rncText_qname = QName (Namespace "") "text"
 420 instance RNCText TL.Text where
 421   rncText_qname = QName (Namespace "") "text"
 422 instance RNCText Bool where
 423   rncText_qname = QName xmlns_xsd "boolean"
 424 instance RNCText Int where
 425   rncText_qname = QName xmlns_xsd "int"
 426 instance RNCText Integer where
 427   rncText_qname = QName xmlns_xsd "integer"
 428 instance RNCText Natural where
 429   rncText_qname = QName xmlns_xsd "nonNegativeInteger"