{-# LANGUAGE BangPatterns #-}

-- ------------------------------------------------------------

{- |
   Module     : Text.XML.HXT.RelaxNG.Validation
   Copyright  : Copyright (C) 2008 Torben Kuseler, Uwe Schmidt
   License    : MIT

   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
   Stability  : stable
   Portability: portable

   Validation of a XML document with respect to a valid Relax NG schema in simple form.
   Copied and modified from \"An algorithm for RELAX NG validation\" by James Clark
   (<http://www.thaiopensource.com/relaxng/derivative.html>).

-}

-- ------------------------------------------------------------

module Text.XML.HXT.RelaxNG.Validation
    ( validateWithRelax
    , validateDocWithRelax
    , validateRelax
    , validateRelax'
    , readForRelax
    , normalizeForRelaxValidation
    , contains
    )
where

import           Control.Arrow.ListArrows

import           Data.Char.Properties.XMLCharProps      (isXmlSpaceChar)
import           Data.Maybe                             (fromJust)

import           Text.XML.HXT.DOM.Interface
import qualified Text.XML.HXT.DOM.XmlNode               as XN

import           Text.XML.HXT.Arrow.Edit                (canonicalizeAllNodes,
                                                         collapseAllXText)
import           Text.XML.HXT.Arrow.XmlArrow

import           Text.XML.HXT.Arrow.ProcessDocument     (getDocumentContents,
                                                         parseXmlDocument, propagateAndValidateNamespaces)
import           Text.XML.HXT.Arrow.XmlState
import           Text.XML.HXT.Arrow.XmlState.TypeDefs

import           Text.XML.HXT.RelaxNG.CreatePattern
import           Text.XML.HXT.RelaxNG.DataTypeLibraries
import           Text.XML.HXT.RelaxNG.DataTypes
import           Text.XML.HXT.RelaxNG.PatternToString
import           Text.XML.HXT.RelaxNG.Utils             (compareURI,
                                                         formatStringListQuot)

{-
import qualified Debug.Trace                            as T
-- -}

-- ------------------------------------------------------------

validateWithRelax       :: IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
validateWithRelax :: IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
validateWithRelax IOSArrow XmlTree XmlTree
theSchema
    = Int -> String -> IOSArrow XmlTree XmlTree
forall s b. Int -> String -> IOStateArrow s b b
traceMsg Int
2 String
"normalize document for validation"
      IOSArrow XmlTree XmlTree
-> IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
      IOSArrow XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
normalizeForRelaxValidation             -- prepare the document for validation
      IOSArrow XmlTree XmlTree
-> IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
      Int -> String -> IOSArrow XmlTree XmlTree
forall s b. Int -> String -> IOStateArrow s b b
traceMsg Int
2 String
"start validation"
      IOSArrow XmlTree XmlTree
-> IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
      ( XmlTree -> IOSArrow XmlTree XmlTree
validateRelax (XmlTree -> IOSArrow XmlTree XmlTree)
-> IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
forall c b d.
(c -> IOSLA (XIOState ()) b d)
-> IOSLA (XIOState ()) b c -> IOSLA (XIOState ()) b d
forall (a :: * -> * -> *) c b d.
ArrowList a =>
(c -> a b d) -> a b c -> a b d
$< IOSArrow XmlTree XmlTree
theSchema )          -- compute and issue validation errors

{- |
   normalize a document for validation with Relax NG: remove all namespace declaration attributes,
   remove all processing instructions and merge all sequences of text nodes into a single text node
-}

normalizeForRelaxValidation :: ArrowXml a => a XmlTree XmlTree
normalizeForRelaxValidation :: forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
normalizeForRelaxValidation
  = a XmlTree XmlTree -> a XmlTree XmlTree
forall (a :: * -> * -> *).
ArrowXml a =>
a XmlTree XmlTree -> a XmlTree XmlTree
processTopDownWithAttrl
    (
     ( a XmlTree XmlTree
forall b c. a b c
forall (a :: * -> * -> *) b c. ArrowList a => a b c
none a XmlTree XmlTree -> a XmlTree String -> a XmlTree XmlTree
forall b c. a b b -> a b c -> a b b
forall (a :: * -> * -> *) b c. ArrowIf a => a b b -> a b c -> a b b
`when`                      -- remove all namespace attributes
       ( a XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isAttr
         a XmlTree XmlTree -> a XmlTree String -> a XmlTree String
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
         a XmlTree String
forall (a :: * -> * -> *). ArrowXml a => a XmlTree String
getNamespaceUri
         a XmlTree String -> a String String -> a XmlTree String
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
         (String -> Bool) -> a String String
forall b. (b -> Bool) -> a b b
forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA (String -> String -> Bool
compareURI String
xmlnsNamespace)
       )
     )
     a XmlTree XmlTree -> a XmlTree XmlTree -> a XmlTree XmlTree
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
     (a XmlTree XmlTree
forall b c. a b c
forall (a :: * -> * -> *) b c. ArrowList a => a b c
none a XmlTree XmlTree -> a XmlTree XmlTree -> a XmlTree XmlTree
forall b c. a b b -> a b c -> a b b
forall (a :: * -> * -> *) b c. ArrowIf a => a b b -> a b c -> a b b
`when` a XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isPi)                 -- processing instructions
    )
    a XmlTree XmlTree -> a XmlTree XmlTree -> a XmlTree XmlTree
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
    a XmlTree XmlTree
forall (a :: * -> * -> *). ArrowList a => a XmlTree XmlTree
collapseAllXText                    -- all text node sequences are merged into a single text node

-- ------------------------------------------------------------

{- | Validates a xml document with respect to a Relax NG schema

   * 1.parameter  :  the arrow for computing the Relax NG schema

   - 2.parameter  :  list of configuration options for reading and validating

   - 3.parameter  :  XML document URI

   - arrow-input  :  ignored

   - arrow-output :  list of errors or 'none'
-}

validateDocWithRelax :: IOSArrow XmlTree XmlTree -> SysConfigList -> String -> IOSArrow XmlTree XmlTree
validateDocWithRelax :: IOSArrow XmlTree XmlTree
-> SysConfigList -> String -> IOSArrow XmlTree XmlTree
validateDocWithRelax IOSArrow XmlTree XmlTree
theSchema SysConfigList
config String
doc
    = IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
forall s a b. IOStateArrow s a b -> IOStateArrow s a b
localSysEnv
      ( SysConfigList -> IOSArrow XmlTree XmlTree
forall s c. SysConfigList -> IOStateArrow s c c
configSysVars SysConfigList
config
        IOSArrow XmlTree XmlTree
-> IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
        String -> IOSArrow XmlTree XmlTree
forall b. String -> IOSArrow b XmlTree
readForRelax String
doc
        IOSArrow XmlTree XmlTree
-> IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
        IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
validateWithRelax IOSArrow XmlTree XmlTree
theSchema
      )

{- | Validates an XML document with respect to a Relax NG schema
   and issues error messages.

   See also: `validateRelax'`

   * 1.parameter  :  Relax NG schema

   - arrow-input  :  XML document

   - arrow-output :  the document or in case of errors none
-}

-- ------------------------------------------------------------

validateRelax :: XmlTree -> IOSArrow XmlTree XmlTree
validateRelax :: XmlTree -> IOSArrow XmlTree XmlTree
validateRelax XmlTree
rngSchema
    = LA XmlTree XmlTree -> IOSArrow XmlTree XmlTree
forall (a :: * -> * -> *) b c. ArrowList a => LA b c -> a b c
fromLA (XmlTree -> LA XmlTree XmlTree
validateRelax' XmlTree
rngSchema)
      IOSArrow XmlTree XmlTree
-> IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
      IOSArrow XmlTree XmlTree
forall s. IOStateArrow s XmlTree XmlTree
filterErrorMsg

{- | Validates an XML document with respect to a Relax NG schema
   This arrow is pure. It does not need IO or any configuration parameters.

   * 1.parameter  :  Relax NG schema

   - arrow-input  :  XML document

   - arrow-output :  the unchanged document or an error message
-}

validateRelax' :: XmlTree -> LA XmlTree XmlTree
validateRelax' :: XmlTree -> LA XmlTree XmlTree
validateRelax' XmlTree
rngSchema
    = ( ( ( XmlTree -> LA XmlTree XmlTree
forall c b. c -> LA b c
forall (a :: * -> * -> *) c b. ArrowList a => c -> a b c
constA XmlTree
rngSchema
            LA XmlTree XmlTree -> LA XmlTree Pattern -> LA XmlTree Pattern
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
            LA XmlTree Pattern
createPatternFromXmlTree
          )
          LA XmlTree Pattern
-> LA XmlTree XmlTree -> LA XmlTree (Pattern, XmlTree)
forall b c c'. LA b c -> LA b c' -> LA b (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&&
          ( LA XmlTree XmlTree
forall (t :: * -> *) b. Tree t => LA (t b) (t b)
forall (a :: * -> * -> *) (t :: * -> *) b.
(ArrowTree a, Tree t) =>
a (t b) (t b)
getChildren                       -- remove the root node
            LA XmlTree XmlTree -> LA XmlTree XmlTree -> LA XmlTree XmlTree
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
            LA XmlTree XmlTree
forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isElem                            -- and select the root element
          )
        )
        LA XmlTree (Pattern, XmlTree)
-> LA (Pattern, XmlTree) XmlTree -> LA XmlTree XmlTree
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
        (Pattern -> XmlTree -> Pattern) -> LA (Pattern, XmlTree) Pattern
forall b1 b2 c. (b1 -> b2 -> c) -> LA (b1, b2) c
forall (a :: * -> * -> *) b1 b2 c.
ArrowList a =>
(b1 -> b2 -> c) -> a (b1, b2) c
arr2 (\ !Pattern
pattern !XmlTree
xmlDoc -> Context -> Pattern -> XmlTree -> Pattern
childDeriv (String
"", []) Pattern
pattern XmlTree
xmlDoc)
        LA (Pattern, XmlTree) Pattern
-> LA Pattern XmlTree -> LA (Pattern, XmlTree) XmlTree
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
        (Pattern -> Bool) -> LA Pattern Pattern
forall b. (b -> Bool) -> LA b b
forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA (Bool -> Bool
not (Bool -> Bool) -> (Pattern -> Bool) -> Pattern -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pattern -> Bool
nullable)
        LA Pattern Pattern -> LA Pattern XmlTree -> LA Pattern XmlTree
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
        (Pattern -> String) -> LA Pattern String
forall b c. (b -> c) -> LA b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr ( Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
1024                      -- pattern may be recursive, so the string representation
                                             -- is truncated to 1024 chars to assure termination
              (String -> String) -> (Pattern -> String) -> Pattern -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"when validating with Relax NG schema: " String -> String -> String
forall a. [a] -> [a] -> [a]
++)
              (String -> String) -> (Pattern -> String) -> Pattern -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pattern -> String
forall a. Show a => a -> String
show
            )
        LA Pattern String -> LA String XmlTree -> LA Pattern XmlTree
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
        Int -> LA String XmlTree
forall (a :: * -> * -> *). ArrowXml a => Int -> a String XmlTree
mkError Int
c_err
      )
      LA XmlTree XmlTree -> LA XmlTree XmlTree -> LA XmlTree XmlTree
forall b c. LA b c -> LA b c -> LA b c
forall (a :: * -> * -> *) b c. ArrowIf a => a b c -> a b c -> a b c
`orElse`
      LA XmlTree XmlTree
forall b. LA b b
forall (a :: * -> * -> *) b. ArrowList a => a b b
this

-- ------------------------------------------------------------

readForRelax    :: String -> IOSArrow b XmlTree
readForRelax :: forall b. String -> IOSArrow b XmlTree
readForRelax String
schema
    = String -> IOStateArrow () b XmlTree
forall s b. String -> IOStateArrow s b XmlTree
getDocumentContents String
schema
      IOStateArrow () b XmlTree
-> IOSArrow XmlTree XmlTree -> IOStateArrow () b XmlTree
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
      Bool -> Bool -> Bool -> Bool -> IOSArrow XmlTree XmlTree
forall s.
Bool -> Bool -> Bool -> Bool -> IOStateArrow s XmlTree XmlTree
parseXmlDocument Bool
False Bool
True Bool
False Bool
True
      IOSArrow XmlTree XmlTree
-> IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
      IOSArrow XmlTree XmlTree
forall (a :: * -> * -> *). ArrowList a => a XmlTree XmlTree
canonicalizeAllNodes
      IOSArrow XmlTree XmlTree
-> IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
      IOSArrow XmlTree XmlTree
forall s. IOStateArrow s XmlTree XmlTree
propagateAndValidateNamespaces

-- ------------------------------------------------------------
--
-- | tests whether a 'NameClass' contains a particular 'QName'

contains :: NameClass -> QName -> Bool
contains :: NameClass -> QName -> Bool
contains NameClass
AnyName QName
_                      = Bool
True
contains (AnyNameExcept NameClass
nc)    QName
n        = Bool -> Bool
not (NameClass -> QName -> Bool
contains NameClass
nc QName
n)
contains (NsName String
ns1)          QName
qn       = String
ns1 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== QName -> String
namespaceUri QName
qn
contains (NsNameExcept String
ns1 NameClass
nc) QName
qn       = String
ns1 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== QName -> String
namespaceUri QName
qn Bool -> Bool -> Bool
&& Bool -> Bool
not (NameClass -> QName -> Bool
contains NameClass
nc QName
qn)
contains (Name String
ns1 String
ln1)        QName
qn       = (String
ns1 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== QName -> String
namespaceUri QName
qn) Bool -> Bool -> Bool
&& (String
ln1 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== QName -> String
localPart QName
qn)
contains (NameClassChoice NameClass
nc1 NameClass
nc2) QName
n    = (NameClass -> QName -> Bool
contains NameClass
nc1 QName
n) Bool -> Bool -> Bool
|| (NameClass -> QName -> Bool
contains NameClass
nc2 QName
n)
contains (NCError String
_) QName
_                  = Bool
False


-- ------------------------------------------------------------
--
-- | tests whether a pattern matches the empty sequence
nullable:: Pattern -> Bool
nullable :: Pattern -> Bool
nullable (Group Pattern
p1 Pattern
p2)          = Pattern -> Bool
nullable Pattern
p1 Bool -> Bool -> Bool
&& Pattern -> Bool
nullable Pattern
p2
nullable (Interleave Pattern
p1 Pattern
p2)     = Pattern -> Bool
nullable Pattern
p1 Bool -> Bool -> Bool
&& Pattern -> Bool
nullable Pattern
p2
nullable (Choice Pattern
p1 Pattern
p2)         = Pattern -> Bool
nullable Pattern
p1 Bool -> Bool -> Bool
|| Pattern -> Bool
nullable Pattern
p2
nullable (OneOrMore Pattern
p)          = Pattern -> Bool
nullable Pattern
p
nullable (Element NameClass
_ Pattern
_)          = Bool
False
nullable (Attribute NameClass
_ Pattern
_)        = Bool
False
nullable (List Pattern
_)               = Bool
False
nullable (Value (String, String)
_ String
_ Context
_)          = Bool
False
nullable (Data (String, String)
_ [(String, String)]
_)             = Bool
False
nullable (DataExcept (String, String)
_ [(String, String)]
_ Pattern
_)     = Bool
False
nullable (NotAllowed ErrMessage
_)         = Bool
False
nullable Pattern
Empty                  = Bool
True
nullable Pattern
Text                   = Bool
True
nullable (After Pattern
_ Pattern
_)            = Bool
False


-- ------------------------------------------------------------
--
-- | computes the derivative of a pattern with respect to a XML-Child and a 'Context'

childDeriv :: Context -> Pattern -> XmlTree -> Pattern

childDeriv :: Context -> Pattern -> XmlTree -> Pattern
childDeriv Context
cx Pattern
p XmlTree
t
    | XmlTree -> Bool
forall a. XmlNode a => a -> Bool
XN.isText XmlTree
t       = Context -> Pattern -> String -> Pattern
textDeriv{- ' -}Context
cx Pattern
p (String -> Pattern) -> (XmlTree -> String) -> XmlTree -> Pattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe String -> String
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe String -> String)
-> (XmlTree -> Maybe String) -> XmlTree -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XmlTree -> Maybe String
forall a. XmlNode a => a -> Maybe String
XN.getText (XmlTree -> Pattern) -> XmlTree -> Pattern
forall a b. (a -> b) -> a -> b
$ XmlTree
t
    | XmlTree -> Bool
forall a. XmlNode a => a -> Bool
XN.isElem XmlTree
t       = Pattern -> Pattern
endTagDeriv{- ' -} Pattern
p4
    | Bool
otherwise         = String -> Pattern
notAllowed String
"Call to childDeriv with wrong arguments"
    where
    children :: [XmlTree]
children    =            XmlTree -> [XmlTree]
forall a. NTree a -> [NTree a]
forall (t :: * -> *) a. Tree t => t a -> [t a]
XN.getChildren (XmlTree -> [XmlTree]) -> XmlTree -> [XmlTree]
forall a b. (a -> b) -> a -> b
$ XmlTree
t
    qn :: QName
qn          = Maybe QName -> QName
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe QName -> QName)
-> (XmlTree -> Maybe QName) -> XmlTree -> QName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XmlTree -> Maybe QName
forall a. XmlNode a => a -> Maybe QName
XN.getElemName (XmlTree -> QName) -> XmlTree -> QName
forall a b. (a -> b) -> a -> b
$ XmlTree
t
    atts :: [XmlTree]
atts        = Maybe [XmlTree] -> [XmlTree]
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe [XmlTree] -> [XmlTree])
-> (XmlTree -> Maybe [XmlTree]) -> XmlTree -> [XmlTree]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XmlTree -> Maybe [XmlTree]
forall a. XmlNode a => a -> Maybe [XmlTree]
XN.getAttrl    (XmlTree -> [XmlTree]) -> XmlTree -> [XmlTree]
forall a b. (a -> b) -> a -> b
$ XmlTree
t
    cx1 :: (String, [a])
cx1         = (String
"",[])
    p1 :: Pattern
p1          = Pattern -> QName -> Pattern
startTagOpenDeriv Pattern
p QName
qn
    p2 :: Pattern
p2          = Context -> Pattern -> [XmlTree] -> Pattern
attsDeriv{- ' -} Context
forall {a}. (String, [a])
cx1 Pattern
p1 [XmlTree]
atts
    p3 :: Pattern
p3          = Pattern -> Pattern
startTagCloseDeriv Pattern
p2
    p4 :: Pattern
p4          = Context -> Pattern -> [XmlTree] -> Pattern
childrenDeriv Context
forall {a}. (String, [a])
cx1 Pattern
p3 [XmlTree]
children

-- ------------------------------------------------------------
--
-- | computes the derivative of a pattern with respect to a text node

{-
textDeriv' cx p t
    = T.trace ("textDeriv: p=\n" ++ (take 10000 . show) p ++ ", t=\n" ++ t) $
      T.trace ("res=\n" ++ (take 10000 . show) res) res
    where
    res = textDeriv cx p t
-- -}


textDeriv :: Context -> Pattern -> String -> Pattern

textDeriv :: Context -> Pattern -> String -> Pattern
textDeriv Context
cx (Choice Pattern
p1 Pattern
p2) String
s
    = Pattern -> Pattern -> Pattern
choice (Context -> Pattern -> String -> Pattern
textDeriv Context
cx Pattern
p1 String
s) (Context -> Pattern -> String -> Pattern
textDeriv Context
cx Pattern
p2 String
s)

textDeriv Context
cx (Interleave Pattern
p1 Pattern
p2) String
s
    = Pattern -> Pattern -> Pattern
choice
      (Pattern -> Pattern -> Pattern
interleave (Context -> Pattern -> String -> Pattern
textDeriv Context
cx Pattern
p1 String
s) Pattern
p2)
      (Pattern -> Pattern -> Pattern
interleave Pattern
p1 (Context -> Pattern -> String -> Pattern
textDeriv Context
cx Pattern
p2 String
s))

textDeriv Context
cx (Group Pattern
p1 Pattern
p2) String
s
    = let
      p :: Pattern
p = Pattern -> Pattern -> Pattern
group (Context -> Pattern -> String -> Pattern
textDeriv Context
cx Pattern
p1 String
s) Pattern
p2
      in
      if Pattern -> Bool
nullable Pattern
p1
      then Pattern -> Pattern -> Pattern
choice Pattern
p (Context -> Pattern -> String -> Pattern
textDeriv Context
cx Pattern
p2 String
s)
      else Pattern
p

textDeriv Context
cx (After Pattern
p1 Pattern
p2) String
s
    = Pattern -> Pattern -> Pattern
after (Context -> Pattern -> String -> Pattern
textDeriv Context
cx Pattern
p1 String
s) Pattern
p2

textDeriv Context
cx (OneOrMore Pattern
p) String
s
    = Pattern -> Pattern -> Pattern
group (Context -> Pattern -> String -> Pattern
textDeriv Context
cx Pattern
p String
s) (Pattern -> Pattern -> Pattern
choice (Pattern -> Pattern
OneOrMore Pattern
p) Pattern
Empty)

textDeriv Context
_ Pattern
Text String
_
    = Pattern
Text

textDeriv Context
cx1 (Value (String
uri, String
s) String
value Context
cx2) String
s1
    = case String -> DatatypeEqual
datatypeEqual String
uri String
s String
value Context
cx2 String
s1 Context
cx1
      of
      Maybe String
Nothing     -> Pattern
Empty
      Just String
errStr -> String -> Pattern
notAllowed String
errStr

textDeriv Context
cx (Data (String
uri, String
s) [(String, String)]
params) String
s1
    = case String -> DatatypeAllows
datatypeAllows String
uri String
s [(String, String)]
params String
s1 Context
cx
      of
      Maybe String
Nothing     -> Pattern
Empty
      Just String
errStr -> String -> Pattern
notAllowed2 String
errStr

textDeriv Context
cx (DataExcept (String
uri, String
s) [(String, String)]
params Pattern
p) String
s1
    = case (String -> DatatypeAllows
datatypeAllows String
uri String
s [(String, String)]
params String
s1 Context
cx)
      of
      Maybe String
Nothing     -> if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Pattern -> Bool
nullable (Pattern -> Bool) -> Pattern -> Bool
forall a b. (a -> b) -> a -> b
$ Context -> Pattern -> String -> Pattern
textDeriv Context
cx Pattern
p String
s1
                     then Pattern
Empty
                     else String -> Pattern
notAllowed
                              ( String
"Any value except " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                String -> String
forall a. Show a => a -> String
show (Pattern -> String
forall a. Show a => a -> String
show Pattern
p) String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                String
" expected, but value " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                String -> String
forall a. Show a => a -> String
show (String -> String
forall a. Show a => a -> String
show String
s1) String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                String
" found"
                              )
      Just String
errStr -> String -> Pattern
notAllowed String
errStr

textDeriv Context
cx (List Pattern
p) String
s
    = if Pattern -> Bool
nullable (Context -> Pattern -> [String] -> Pattern
listDeriv Context
cx Pattern
p (String -> [String]
words String
s))
      then Pattern
Empty
      else String -> Pattern
notAllowed
               ( String
"List with value(s) " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                 Pattern -> String
forall a. Show a => a -> String
show Pattern
p String -> String -> String
forall a. [a] -> [a] -> [a]
++
                 String
" expected, but value(s) " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                 [String] -> String
formatStringListQuot (String -> [String]
words String
s) String -> String -> String
forall a. [a] -> [a] -> [a]
++
                 String
" found"
               )

textDeriv Context
_ n :: Pattern
n@(NotAllowed ErrMessage
_) String
_
    = Pattern
n

textDeriv Context
_ Pattern
p String
s
    = String -> Pattern
notAllowed
      ( String
"Pattern " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show (Pattern -> String
getPatternName Pattern
p) String -> String -> String
forall a. [a] -> [a] -> [a]
++
        String
" expected, but text " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" found"
      )


-- ------------------------------------------------------------
--
-- | To compute the derivative of a pattern with respect to a list of strings,
-- simply compute the derivative with respect to each member of the list in turn.

listDeriv :: Context -> Pattern -> [String] -> Pattern

listDeriv :: Context -> Pattern -> [String] -> Pattern
listDeriv Context
_ !Pattern
p []
    = Pattern
p

listDeriv Context
cx !Pattern
p (String
x:[String]
xs)
    = Context -> Pattern -> [String] -> Pattern
listDeriv Context
cx (Context -> Pattern -> String -> Pattern
textDeriv Context
cx Pattern
p String
x) [String]
xs


-- ------------------------------------------------------------
--
-- | computes the derivative of a pattern with respect to a start tag open

startTagOpenDeriv :: Pattern -> QName -> Pattern

startTagOpenDeriv :: Pattern -> QName -> Pattern
startTagOpenDeriv (Choice Pattern
p1 Pattern
p2) QName
qn
    = Pattern -> Pattern -> Pattern
choice (Pattern -> QName -> Pattern
startTagOpenDeriv Pattern
p1 QName
qn) (Pattern -> QName -> Pattern
startTagOpenDeriv Pattern
p2 QName
qn)

startTagOpenDeriv (Element NameClass
nc Pattern
p) QName
qn
    | NameClass -> QName -> Bool
contains NameClass
nc QName
qn
        = Pattern -> Pattern -> Pattern
after Pattern
p Pattern
Empty
    | Bool
otherwise
        = String -> Pattern
notAllowed (String -> Pattern) -> String -> Pattern
forall a b. (a -> b) -> a -> b
$
          String
"Element with name " String -> String -> String
forall a. [a] -> [a] -> [a]
++ NameClass -> String
nameClassToString NameClass
nc String -> String -> String
forall a. [a] -> [a] -> [a]
++
            String
" expected, but " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QName -> String
universalName QName
qn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" found"

startTagOpenDeriv (Interleave Pattern
p1 Pattern
p2) QName
qn
    = Pattern -> Pattern -> Pattern
choice
      ((Pattern -> Pattern) -> Pattern -> Pattern
applyAfter ((Pattern -> Pattern -> Pattern) -> Pattern -> Pattern -> Pattern
forall a b c. (a -> b -> c) -> b -> a -> c
flip Pattern -> Pattern -> Pattern
interleave Pattern
p2) (Pattern -> QName -> Pattern
startTagOpenDeriv Pattern
p1 QName
qn))
      ((Pattern -> Pattern) -> Pattern -> Pattern
applyAfter (Pattern -> Pattern -> Pattern
interleave Pattern
p1) (Pattern -> QName -> Pattern
startTagOpenDeriv Pattern
p2 QName
qn))

startTagOpenDeriv (OneOrMore Pattern
p) QName
qn
    = (Pattern -> Pattern) -> Pattern -> Pattern
applyAfter
      ((Pattern -> Pattern -> Pattern) -> Pattern -> Pattern -> Pattern
forall a b c. (a -> b -> c) -> b -> a -> c
flip Pattern -> Pattern -> Pattern
group (Pattern -> Pattern -> Pattern
choice (Pattern -> Pattern
OneOrMore Pattern
p) Pattern
Empty))
      (Pattern -> QName -> Pattern
startTagOpenDeriv Pattern
p QName
qn)

startTagOpenDeriv (Group Pattern
p1 Pattern
p2) QName
qn
    = let
      x :: Pattern
x = (Pattern -> Pattern) -> Pattern -> Pattern
applyAfter ((Pattern -> Pattern -> Pattern) -> Pattern -> Pattern -> Pattern
forall a b c. (a -> b -> c) -> b -> a -> c
flip Pattern -> Pattern -> Pattern
group Pattern
p2) (Pattern -> QName -> Pattern
startTagOpenDeriv Pattern
p1 QName
qn)
      in
      if Pattern -> Bool
nullable Pattern
p1
      then Pattern -> Pattern -> Pattern
choice Pattern
x (Pattern -> QName -> Pattern
startTagOpenDeriv Pattern
p2 QName
qn)
      else Pattern
x

startTagOpenDeriv (After Pattern
p1 Pattern
p2) QName
qn
    = (Pattern -> Pattern) -> Pattern -> Pattern
applyAfter ((Pattern -> Pattern -> Pattern) -> Pattern -> Pattern -> Pattern
forall a b c. (a -> b -> c) -> b -> a -> c
flip Pattern -> Pattern -> Pattern
after Pattern
p2) (Pattern -> QName -> Pattern
startTagOpenDeriv Pattern
p1 QName
qn)

startTagOpenDeriv n :: Pattern
n@(NotAllowed ErrMessage
_) QName
_
    = Pattern
n

startTagOpenDeriv Pattern
p QName
qn
    = String -> Pattern
notAllowed ( Pattern -> String
forall a. Show a => a -> String
show Pattern
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" expected, but Element " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QName -> String
universalName QName
qn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" found" )

-- ------------------------------------------------------------

-- auxiliary functions for tracing

{-
attsDeriv' cx p ts
    = T.trace ("attsDeriv: p=" ++ (take 1000 . show) p ++ ", t=" ++ showXts ts) $
      T.trace ("res= " ++ (take 1000 . show) res) res
    where
    res = attsDeriv cx p ts
-- -}

{-
attDeriv' cx p t
    = T.trace ("attDeriv: p=\n" ++ (take 10000 . show) p ++ ", t=\n" ++ showXts [t]) $
      T.trace ("res=\n" ++ (take 1000 . show) res) res
    where
    res = attDeriv cx p t
-- -}

-- | To compute the derivative of a pattern with respect to a sequence of attributes,
-- simply compute the derivative with respect to each attribute in turn.

attsDeriv :: Context -> Pattern -> XmlTrees -> Pattern

attsDeriv :: Context -> Pattern -> [XmlTree] -> Pattern
attsDeriv Context
_ !Pattern
p []
    = Pattern
p
attsDeriv Context
cx !Pattern
p (XmlTree
t : [XmlTree]
ts)
    | XmlTree -> Bool
forall a. XmlNode a => a -> Bool
XN.isAttr XmlTree
t
        = Context -> Pattern -> [XmlTree] -> Pattern
attsDeriv Context
cx (Context -> Pattern -> XmlTree -> Pattern
attDeriv{- ' -} Context
cx Pattern
p XmlTree
t) [XmlTree]
ts
    | Bool
otherwise
        = String -> Pattern
notAllowed String
"Call to attsDeriv with wrong arguments"

attDeriv :: Context -> Pattern -> XmlTree -> Pattern

attDeriv :: Context -> Pattern -> XmlTree -> Pattern
attDeriv Context
cx (After Pattern
p1 Pattern
p2) XmlTree
att
    = Pattern -> Pattern -> Pattern
after (Context -> Pattern -> XmlTree -> Pattern
attDeriv Context
cx Pattern
p1 XmlTree
att) Pattern
p2

attDeriv Context
cx (Choice Pattern
p1 Pattern
p2) XmlTree
att
    = Pattern -> Pattern -> Pattern
choice (Context -> Pattern -> XmlTree -> Pattern
attDeriv Context
cx Pattern
p1 XmlTree
att) (Context -> Pattern -> XmlTree -> Pattern
attDeriv Context
cx Pattern
p2 XmlTree
att)

attDeriv Context
cx (Group Pattern
p1 Pattern
p2) XmlTree
att
    = Pattern -> Pattern -> Pattern
choice
      (Pattern -> Pattern -> Pattern
group (Context -> Pattern -> XmlTree -> Pattern
attDeriv Context
cx Pattern
p1 XmlTree
att) Pattern
p2)
      (Pattern -> Pattern -> Pattern
group Pattern
p1 (Context -> Pattern -> XmlTree -> Pattern
attDeriv Context
cx Pattern
p2 XmlTree
att))

attDeriv Context
cx (Interleave Pattern
p1 Pattern
p2) XmlTree
att
    = Pattern -> Pattern -> Pattern
choice
      (Pattern -> Pattern -> Pattern
interleave (Context -> Pattern -> XmlTree -> Pattern
attDeriv Context
cx Pattern
p1 XmlTree
att) Pattern
p2)
      (Pattern -> Pattern -> Pattern
interleave Pattern
p1 (Context -> Pattern -> XmlTree -> Pattern
attDeriv Context
cx Pattern
p2 XmlTree
att))

attDeriv Context
cx (OneOrMore Pattern
p) XmlTree
att
    = Pattern -> Pattern -> Pattern
group
      (Context -> Pattern -> XmlTree -> Pattern
attDeriv Context
cx Pattern
p XmlTree
att)
      (Pattern -> Pattern -> Pattern
choice (Pattern -> Pattern
OneOrMore Pattern
p) Pattern
Empty)

attDeriv Context
cx (Attribute NameClass
nc Pattern
p) XmlTree
att
    | Bool
isa
      Bool -> Bool -> Bool
&&
      Bool -> Bool
not (NameClass -> QName -> Bool
contains NameClass
nc QName
qn)
        = String -> Pattern
notAllowed1 (String -> Pattern) -> String -> Pattern
forall a b. (a -> b) -> a -> b
$
          String
"Attribute with name " String -> String -> String
forall a. [a] -> [a] -> [a]
++ NameClass -> String
nameClassToString NameClass
nc
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" expected, but " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QName -> String
universalName QName
qn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" found"
    | Bool
isa
      Bool -> Bool -> Bool
&&
      ( ( Pattern -> Bool
nullable Pattern
p
          Bool -> Bool -> Bool
&&
          String -> Bool
whitespace String
val
        )
        Bool -> Bool -> Bool
|| Pattern -> Bool
nullable Pattern
p'
      )
        = Pattern
Empty
    | Bool
isa
        = Pattern -> Pattern
err' Pattern
p'
    where
    isa :: Bool
isa =            XmlTree -> Bool
forall a. XmlNode a => a -> Bool
XN.isAttr      (XmlTree -> Bool) -> XmlTree -> Bool
forall a b. (a -> b) -> a -> b
$ XmlTree
att
    qn :: QName
qn  = Maybe QName -> QName
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe QName -> QName)
-> (XmlTree -> Maybe QName) -> XmlTree -> QName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XmlTree -> Maybe QName
forall a. XmlNode a => a -> Maybe QName
XN.getAttrName (XmlTree -> QName) -> XmlTree -> QName
forall a b. (a -> b) -> a -> b
$ XmlTree
att
    av :: [XmlTree]
av  =            XmlTree -> [XmlTree]
forall a. NTree a -> [NTree a]
forall (t :: * -> *) a. Tree t => t a -> [t a]
XN.getChildren (XmlTree -> [XmlTree]) -> XmlTree -> [XmlTree]
forall a b. (a -> b) -> a -> b
$ XmlTree
att
    val :: String
val = [XmlTree] -> String
showXts [XmlTree]
av
    p' :: Pattern
p'  = Context -> Pattern -> String -> Pattern
textDeriv Context
cx Pattern
p String
val

    err' :: Pattern -> Pattern
err' (NotAllowed (ErrMsg Int
_l [String]
es))
        = String -> Pattern
err'' (String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. HasCallStack => [a] -> a
head [String]
es)
    err' Pattern
_
        = String -> Pattern
err'' String
""
    err'' :: String -> Pattern
err'' String
e
        = String -> Pattern
notAllowed2 (String -> Pattern) -> String -> Pattern
forall a b. (a -> b) -> a -> b
$
          String
"Attribute value \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
val String -> String -> String
forall a. [a] -> [a] -> [a]
++
          String
"\" does not match datatype spec " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Pattern -> String
forall a. Show a => a -> String
show Pattern
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
e

attDeriv Context
_ n :: Pattern
n@(NotAllowed ErrMessage
_) XmlTree
_
    = Pattern
n

attDeriv Context
_ Pattern
_p XmlTree
att
    = String -> Pattern
notAllowed (String -> Pattern) -> String -> Pattern
forall a b. (a -> b) -> a -> b
$
      String
"No matching pattern for attribute '" String -> String -> String
forall a. [a] -> [a] -> [a]
++  [XmlTree] -> String
showXts [XmlTree
att] String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' found"

-- ------------------------------------------------------------
--
-- | computes the derivative of a pattern with respect to a start tag close

startTagCloseDeriv :: Pattern -> Pattern

startTagCloseDeriv :: Pattern -> Pattern
startTagCloseDeriv (After Pattern
p1 Pattern
p2)
    = Pattern -> Pattern -> Pattern
after (Pattern -> Pattern
startTagCloseDeriv Pattern
p1) Pattern
p2

startTagCloseDeriv (Choice Pattern
p1 Pattern
p2)
    = Pattern -> Pattern -> Pattern
choice
      (Pattern -> Pattern
startTagCloseDeriv Pattern
p1)
      (Pattern -> Pattern
startTagCloseDeriv Pattern
p2)

startTagCloseDeriv (Group Pattern
p1 Pattern
p2)
    = Pattern -> Pattern -> Pattern
group
      (Pattern -> Pattern
startTagCloseDeriv Pattern
p1)
      (Pattern -> Pattern
startTagCloseDeriv Pattern
p2)

startTagCloseDeriv (Interleave Pattern
p1 Pattern
p2)
    = Pattern -> Pattern -> Pattern
interleave
      (Pattern -> Pattern
startTagCloseDeriv Pattern
p1)
      (Pattern -> Pattern
startTagCloseDeriv Pattern
p2)

startTagCloseDeriv (OneOrMore Pattern
p)
    = Pattern -> Pattern
oneOrMore (Pattern -> Pattern
startTagCloseDeriv Pattern
p)

startTagCloseDeriv (Attribute NameClass
nc Pattern
_)
    = String -> Pattern
notAllowed1 (String -> Pattern) -> String -> Pattern
forall a b. (a -> b) -> a -> b
$
      String
"Attribut with name, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ NameClass -> String
forall a. Show a => a -> String
show NameClass
nc String -> String -> String
forall a. [a] -> [a] -> [a]
++
      String
" expected, but no more attributes found"

startTagCloseDeriv Pattern
p
    = Pattern
p


-- ------------------------------------------------------------
--
-- | Computing the derivative of a pattern with respect to a list of children involves
-- computing the derivative with respect to each pattern in turn, except
-- that whitespace requires special treatment.

childrenDeriv :: Context -> Pattern -> XmlTrees -> Pattern
childrenDeriv :: Context -> Pattern -> [XmlTree] -> Pattern
childrenDeriv Context
_cx p :: Pattern
p@(NotAllowed ErrMessage
_) [XmlTree]
_
    = Pattern
p

childrenDeriv Context
cx Pattern
p []
    = Context -> Pattern -> [XmlTree] -> Pattern
childrenDeriv Context
cx Pattern
p [String -> XmlTree
forall a. XmlNode a => String -> a
XN.mkText String
""]

childrenDeriv Context
cx Pattern
p [XmlTree
tt]
    | Bool
ist
      Bool -> Bool -> Bool
&&
      String -> Bool
whitespace String
s
        = Pattern -> Pattern -> Pattern
choice Pattern
p Pattern
p1
    | Bool
ist
        = Pattern
p1
    where
    ist :: Bool
ist =            XmlTree -> Bool
forall a. XmlNode a => a -> Bool
XN.isText    XmlTree
tt
    s :: String
s   = Maybe String -> String
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe String -> String)
-> (XmlTree -> Maybe String) -> XmlTree -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XmlTree -> Maybe String
forall a. XmlNode a => a -> Maybe String
XN.getText (XmlTree -> String) -> XmlTree -> String
forall a b. (a -> b) -> a -> b
$ XmlTree
tt
    p1 :: Pattern
p1  = Context -> Pattern -> XmlTree -> Pattern
childDeriv Context
cx Pattern
p XmlTree
tt

childrenDeriv Context
cx Pattern
p [XmlTree]
children
    = Context -> Pattern -> [XmlTree] -> Pattern
stripChildrenDeriv Context
cx Pattern
p [XmlTree]
children

stripChildrenDeriv :: Context -> Pattern -> XmlTrees -> Pattern
stripChildrenDeriv :: Context -> Pattern -> [XmlTree] -> Pattern
stripChildrenDeriv Context
_ !Pattern
p []
    = Pattern
p

stripChildrenDeriv Context
cx !Pattern
p (XmlTree
h:[XmlTree]
t)
    = Context -> Pattern -> [XmlTree] -> Pattern
stripChildrenDeriv Context
cx
      ( if XmlTree -> Bool
strip XmlTree
h
        then Pattern
p
        else (Context -> Pattern -> XmlTree -> Pattern
childDeriv Context
cx Pattern
p XmlTree
h)
      ) [XmlTree]
t


-- ------------------------------------------------------------
--
-- | computes the derivative of a pattern with respect to a end tag

{-
endTagDeriv' p
    = T.trace ("endTagDeriv: p=\n" ++ (take 10000 . show) p) $
      T.trace ("res=\n" ++ (take 10000 . show) res) res
    where
    res = endTagDeriv p
-- -}

endTagDeriv :: Pattern -> Pattern
endTagDeriv :: Pattern -> Pattern
endTagDeriv (Choice Pattern
p1 Pattern
p2)
    = Pattern -> Pattern -> Pattern
choice (Pattern -> Pattern
endTagDeriv Pattern
p1) (Pattern -> Pattern
endTagDeriv Pattern
p2)

endTagDeriv (After Pattern
p1 Pattern
p2)
    | Pattern -> Bool
nullable Pattern
p1
        = Pattern
p2
    | Bool
otherwise
        = String -> Pattern
notAllowed (String -> Pattern) -> String -> Pattern
forall a b. (a -> b) -> a -> b
$
          Pattern -> String
forall a. Show a => a -> String
show Pattern
p1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" expected"

endTagDeriv n :: Pattern
n@(NotAllowed ErrMessage
_)
    = Pattern
n

endTagDeriv Pattern
_
    = String -> Pattern
notAllowed String
"Call to endTagDeriv with wrong arguments"

-- ------------------------------------------------------------
--
-- | applies a function (first parameter) to the second part of a after pattern

applyAfter :: (Pattern -> Pattern) -> Pattern -> Pattern

applyAfter :: (Pattern -> Pattern) -> Pattern -> Pattern
applyAfter Pattern -> Pattern
f (After Pattern
p1 Pattern
p2)      = Pattern -> Pattern -> Pattern
after Pattern
p1 (Pattern -> Pattern
f Pattern
p2)
applyAfter Pattern -> Pattern
f (Choice Pattern
p1 Pattern
p2)     = Pattern -> Pattern -> Pattern
choice ((Pattern -> Pattern) -> Pattern -> Pattern
applyAfter Pattern -> Pattern
f Pattern
p1) ((Pattern -> Pattern) -> Pattern -> Pattern
applyAfter Pattern -> Pattern
f Pattern
p2)
applyAfter Pattern -> Pattern
_ n :: Pattern
n@(NotAllowed ErrMessage
_)   = Pattern
n
applyAfter Pattern -> Pattern
_ Pattern
_                  = String -> Pattern
notAllowed String
"Call to applyAfter with wrong arguments"

-- --------------------

-- mothers little helpers

strip           :: XmlTree -> Bool
strip :: XmlTree -> Bool
strip           = Bool -> (String -> Bool) -> Maybe String -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False String -> Bool
whitespace (Maybe String -> Bool)
-> (XmlTree -> Maybe String) -> XmlTree -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XmlTree -> Maybe String
forall a. XmlNode a => a -> Maybe String
XN.getText

whitespace      :: String -> Bool
whitespace :: String -> Bool
whitespace      = (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isXmlSpaceChar

showXts         :: XmlTrees -> String
showXts :: [XmlTree] -> String
showXts         = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String)
-> ([XmlTree] -> [String]) -> [XmlTree] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LA [XmlTree] String -> [XmlTree] -> [String]
forall a b. LA a b -> a -> [b]
runLA (LA [XmlTree] XmlTree -> LA [XmlTree] String
forall n. LA n XmlTree -> LA n String
forall (a :: * -> * -> *) n.
ArrowXml a =>
a n XmlTree -> a n String
xshow (LA [XmlTree] XmlTree -> LA [XmlTree] String)
-> LA [XmlTree] XmlTree -> LA [XmlTree] String
forall a b. (a -> b) -> a -> b
$ ([XmlTree] -> [XmlTree]) -> LA [XmlTree] XmlTree
forall b c. (b -> [c]) -> LA b c
forall (a :: * -> * -> *) b c. ArrowList a => (b -> [c]) -> a b c
arrL [XmlTree] -> [XmlTree]
forall a. a -> a
id)

-- ------------------------------------------------------------