src/Symantic/XML/RelaxNG/Language.hs

   1 {-# LANGUAGE AllowAmbiguousTypes #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 module Symantic.XML.RelaxNG.Language where
   4
   5 import Data.Bool
   6 import Data.Eq (Eq(..))
   7 import Data.Function (($), (.))
   8 import Data.Maybe (Maybe(..))
   9 import Data.Semigroup (Semigroup(..))
  10 import Data.String (String, IsString(..))
  11 import Prelude (error)
  12 import Text.Show (Show(..))
  13 import qualified Data.List as List
  14 import qualified Data.HashMap.Strict as HM
  15
  16 import Symantic.Base.Fixity
  17 import Symantic.XML.Language
  18
  19 -- * Class 'RelaxNG'
  20 class
  21  ( XML repr
  22  , Permutable repr
  23  , Definable repr
  24  ) => RelaxNG repr where
  25   default elementMatch ::
  26                   Transformable repr =>
  27                   RelaxNG (UnTrans repr) =>
  28                   NameClass -> repr a k -> repr (QName -> a) k
  29   -- | Like 'element' but with a matching pattern
  30   -- instead of a specific 'QName'.
  31   elementMatch :: NameClass -> repr a k -> repr (QName -> a) k
  32   elementMatch nc = noTrans . elementMatch nc . unTrans
  33   default attributeMatch ::
  34                   Transformable repr =>
  35                   RelaxNG (UnTrans repr) =>
  36                   NameClass -> repr a k -> repr (QName -> a) k
  37   -- | Like 'attribute' but with a matching pattern
  38   -- instead of a specific 'QName'.
  39   attributeMatch :: NameClass -> repr a k -> repr (QName -> a) k
  40   attributeMatch nc = noTrans . attributeMatch nc . unTrans
  41
  42 -- * Type 'Definable'
  43 class Definable repr where
  44   -- | @(define name expr)@ declares a rule named @(name)@
  45   -- and matching the 'RelaxNG' schema @(expr)@.
  46   --
  47   -- Useful for rendering the 'RelaxNG' schema,
  48   -- and necessary to avoid infinite recursion when
  49   -- printing a 'RelaxNG' schema calling itself recursively.
  50   --
  51   -- WARNING: 'DefineName's must be unique inside
  52   -- a whole 'RelaxNG' schema.
  53   define :: DefineName -> repr a k -> repr a k
  54   default define ::
  55    Transformable repr => RelaxNG (UnTrans repr) =>
  56    DefineName -> repr f k -> repr f k
  57   define n = noTrans . define n . unTrans
  58
  59 -- ** Type 'DefineName'
  60 type DefineName = String
  61
  62 -- * Type 'NameClass'
  63 data NameClass
  64  =   NameClass_Any
  65  |   (:::) Namespace NCName
  66  |   (:*) Namespace
  67  |   (:-:) NameClass NameClass
  68  |   (:|:) NameClass NameClass
  69
  70 infix 9 :::
  71 infixr 2 :|:
  72 infixl 6 :-:
  73
  74 (*:*) :: NameClass
  75 (*:*) = NameClass_Any
  76
  77 -- | @('matchNameClass' nc q)@ returns 'True' iif. the 'NameClass' @(nc)@ matches the 'QName' @(q)@.
  78 matchNameClass :: NameClass -> QName -> Bool
  79 matchNameClass NameClass_Any _q = True
  80 matchNameClass (ns:::nl) q = qNameSpace q == ns && qNameLocal q == nl
  81 matchNameClass ((:*) ns) q = qNameSpace q == ns
  82 matchNameClass (x:|:y) q = matchNameClass x q || matchNameClass y q
  83 matchNameClass (x:-:y) q = matchNameClass x q && not (matchNameClass y q)
  84
  85 -- | Return the namespaces used by the given 'NameClass'
  86 namespacesNameClass :: NameClass -> HM.HashMap Namespace (Maybe NCName)
  87 namespacesNameClass = \case
  88  NameClass_Any -> HM.empty
  89  ns ::: _ -> HM.singleton ns Nothing
  90  (:*) ns -> HM.singleton ns Nothing
  91  x :|: y -> namespacesNameClass x <> namespacesNameClass y
  92  x :-: y -> namespacesNameClass x <> namespacesNameClass y
  93
  94 -- | Only parses "*", "{some-namespace}*", or "{some-namespace}some-localname".
  95 instance IsString NameClass where
  96   fromString = \case
  97    "*" -> NameClass_Any
  98    full@('{':rest) ->
  99     case List.break (== '}') rest of
 100      (_, "") -> error $ "Invalid XML Clark notation: "<>show full
 101      (ns, "*") -> (:*) (fromString ns)
 102      (ns, local) -> fromString ns ::: fromString (List.drop 1 local)
 103    s -> let QName ns nl = fromString s in ns:::nl
 104 instance Textify (Namespaces NCName, (Infix,Side), NameClass) where
 105   textify (nss,po,nc) = case nc of
 106    NameClass_Any -> textify '*'
 107    ns:::nl ->
 108     textify (prefixifyQName nss (QName ns nl))
 109    (:*) ns ->
 110     case HM.lookup ns (namespaces_prefixes nss) of
 111      Nothing -> "{"<>textify ns<>"}*"
 112      Just p -> textify p <> ":*"
 113    x :|: y -> pairIfNeeded pairParen po op $
 114     textify (nss,(op,SideL),x) <> " | " <> textify (nss,(op,SideR),y)
 115     where op = infixR 2
 116    x :-: y ->
 117     pairIfNeeded pairParen po op $
 118     textify (nss,(op,SideL),x) <> " - " <> textify (nss,(op,SideR),y)
 119     where op = infixL 6