{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE OverloadedStrings #-}
module Symantic.XML.RelaxNG.Language where
import Data.Bool
import Data.Eq (Eq(..))
import Data.Function (($), (.))
import Data.Maybe (Maybe(..))
import Data.Semigroup (Semigroup(..))
import Data.String (String, IsString(..))
import Prelude (error)
import Text.Show (Show(..))
import qualified Data.List as List
import qualified Data.HashMap.Strict as HM
import Symantic.Base.Fixity
import Symantic.XML.Language
class
( XML repr
, Permutable repr
, Definable repr
) => RelaxNG repr where
default elementMatch ::
Transformable repr =>
RelaxNG (UnTrans repr) =>
NameClass -> repr a k -> repr (QName -> a) k
elementMatch :: NameClass -> repr a k -> repr (QName -> a) k
elementMatch nc = noTrans . elementMatch nc . unTrans
default attributeMatch ::
Transformable repr =>
RelaxNG (UnTrans repr) =>
NameClass -> repr a k -> repr (QName -> a) k
attributeMatch :: NameClass -> repr a k -> repr (QName -> a) k
attributeMatch nc = noTrans . attributeMatch nc . unTrans
class Definable repr where
define :: DefineName -> repr a k -> repr a k
default define ::
Transformable repr => RelaxNG (UnTrans repr) =>
DefineName -> repr f k -> repr f k
define n = noTrans . define n . unTrans
type DefineName = String
data NameClass
= NameClass_Any
| (:::) Namespace NCName
| (:*) Namespace
| (:-:) NameClass NameClass
| (:|:) NameClass NameClass
infix 9 :::
infixr 2 :|:
infixl 6 :-:
(*:*) :: NameClass
(*:*) = NameClass_Any
matchNameClass :: NameClass -> QName -> Bool
matchNameClass NameClass_Any _q = True
matchNameClass (ns:::nl) q = qNameSpace q == ns && qNameLocal q == nl
matchNameClass ((:*) ns) q = qNameSpace q == ns
matchNameClass (x:|:y) q = matchNameClass x q || matchNameClass y q
matchNameClass (x:-:y) q = matchNameClass x q && not (matchNameClass y q)
namespacesNameClass :: NameClass -> HM.HashMap Namespace (Maybe NCName)
namespacesNameClass = \case
NameClass_Any -> HM.empty
ns ::: _ -> HM.singleton ns Nothing
(:*) ns -> HM.singleton ns Nothing
x :|: y -> namespacesNameClass x <> namespacesNameClass y
x :-: y -> namespacesNameClass x <> namespacesNameClass y
instance IsString NameClass where
fromString = \case
"*" -> NameClass_Any
full@('{':rest) ->
case List.break (== '}') rest of
(_, "") -> error $ "Invalid XML Clark notation: "<>show full
(ns, "*") -> (:*) (fromString ns)
(ns, local) -> fromString ns ::: fromString (List.drop 1 local)
s -> let QName ns nl = fromString s in ns:::nl
instance Textify (Namespaces NCName, (Infix,Side), NameClass) where
textify (nss,po,nc) = case nc of
NameClass_Any -> textify '*'
ns:::nl ->
textify (prefixifyQName nss (QName ns nl))
(:*) ns ->
case HM.lookup ns (namespaces_prefixes nss) of
Nothing -> "{"<>textify ns<>"}*"
Just p -> textify p <> ":*"
x :|: y -> pairIfNeeded pairParen po op $
textify (nss,(op,SideL),x) <> " | " <> textify (nss,(op,SideR),y)
where op = infixR 2
x :-: y ->
pairIfNeeded pairParen po op $
textify (nss,(op,SideL),x) <> " - " <> textify (nss,(op,SideR),y)
where op = infixL 6