{-# 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 theSchema :: IOSArrow XmlTree XmlTree
theSchema
    = Int -> String -> IOSArrow XmlTree XmlTree
forall s b. Int -> String -> IOStateArrow s b b
traceMsg 2 "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 2 "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 (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 :: 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 (a :: * -> * -> *) b c. ArrowList a => a b c
none a XmlTree XmlTree -> a XmlTree String -> a XmlTree XmlTree
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 (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 (a :: * -> * -> *) b c. ArrowList a => a b c
none a XmlTree XmlTree -> a XmlTree XmlTree -> a XmlTree XmlTree
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 theSchema :: IOSArrow XmlTree XmlTree
theSchema config :: SysConfigList
config doc :: 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 rngSchema :: 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' rngSchema :: XmlTree
rngSchema
    = ( ( ( XmlTree -> LA XmlTree XmlTree
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 (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&&
          ( LA XmlTree XmlTree
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 (a :: * -> * -> *) b1 b2 c.
ArrowList a =>
(b1 -> b2 -> c) -> a (b1, b2) c
arr2 (\ !Pattern
pattern !XmlTree
xmlDoc -> Context -> Pattern -> XmlTree -> Pattern
childDeriv ("", []) 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 (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 (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr ( Int -> String -> String
forall a. Int -> [a] -> [a]
take 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
. ("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 (a :: * -> * -> *) b c. ArrowIf a => a b c -> a b c -> a b c
`orElse`
      LA XmlTree XmlTree
forall (a :: * -> * -> *) b. ArrowList a => a b b
this

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

readForRelax    :: String -> IOSArrow b XmlTree
readForRelax :: String -> IOSArrow b XmlTree
readForRelax schema :: String
schema
    = String -> IOSArrow b XmlTree
forall s b. String -> IOStateArrow s b XmlTree
getDocumentContents String
schema
      IOSArrow b XmlTree
-> IOSArrow XmlTree XmlTree -> IOSArrow 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 AnyName _                      = Bool
True
contains (AnyNameExcept nc :: NameClass
nc)    n :: QName
n        = Bool -> Bool
not (NameClass -> QName -> Bool
contains NameClass
nc QName
n)
contains (NsName ns1 :: String
ns1)          qn :: QName
qn       = String
ns1 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== QName -> String
namespaceUri QName
qn
contains (NsNameExcept ns1 :: String
ns1 nc :: NameClass
nc) qn :: 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 ns1 :: String
ns1 ln1 :: String
ln1)        qn :: 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 nc1 :: NameClass
nc1 nc2 :: NameClass
nc2) n :: QName
n    = (NameClass -> QName -> Bool
contains NameClass
nc1 QName
n) Bool -> Bool -> Bool
|| (NameClass -> QName -> Bool
contains NameClass
nc2 QName
n)
contains (NCError _) _                  = Bool
False


-- ------------------------------------------------------------
--
-- | tests whether a pattern matches the empty sequence
nullable:: Pattern -> Bool
nullable :: Pattern -> Bool
nullable (Group p1 :: Pattern
p1 p2 :: Pattern
p2)          = Pattern -> Bool
nullable Pattern
p1 Bool -> Bool -> Bool
&& Pattern -> Bool
nullable Pattern
p2
nullable (Interleave p1 :: Pattern
p1 p2 :: Pattern
p2)     = Pattern -> Bool
nullable Pattern
p1 Bool -> Bool -> Bool
&& Pattern -> Bool
nullable Pattern
p2
nullable (Choice p1 :: Pattern
p1 p2 :: Pattern
p2)         = Pattern -> Bool
nullable Pattern
p1 Bool -> Bool -> Bool
|| Pattern -> Bool
nullable Pattern
p2
nullable (OneOrMore p :: Pattern
p)          = Pattern -> Bool
nullable Pattern
p
nullable (Element _ _)          = Bool
False
nullable (Attribute _ _)        = Bool
False
nullable (List _)               = Bool
False
nullable (Value _ _ _)          = Bool
False
nullable (Data _ _)             = Bool
False
nullable (DataExcept _ _ _)     = Bool
False
nullable (NotAllowed _)         = Bool
False
nullable Empty                  = Bool
True
nullable Text                   = Bool
True
nullable (After _ _)            = 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 cx :: Context
cx p :: Pattern
p t :: 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 "Call to childDeriv with wrong arguments"
    where
    children :: [XmlTree]
children    =            XmlTree -> [XmlTree]
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         = ("",[])
    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 cx :: Context
cx (Choice p1 :: Pattern
p1 p2 :: Pattern
p2) s :: 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 cx :: Context
cx (Interleave p1 :: Pattern
p1 p2 :: Pattern
p2) s :: 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 cx :: Context
cx (Group p1 :: Pattern
p1 p2 :: Pattern
p2) s :: 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 cx :: Context
cx (After p1 :: Pattern
p1 p2 :: Pattern
p2) s :: String
s
    = Pattern -> Pattern -> Pattern
after (Context -> Pattern -> String -> Pattern
textDeriv Context
cx Pattern
p1 String
s) Pattern
p2

textDeriv cx :: Context
cx (OneOrMore p :: Pattern
p) s :: 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 _ Text _
    = Pattern
Text

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

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

textDeriv cx :: Context
cx (DataExcept (uri :: String
uri, s :: String
s) params :: ParamList
params p :: Pattern
p) s1 :: String
s1
    = case (String -> DatatypeAllows
datatypeAllows String
uri String
s ParamList
params String
s1 Context
cx)
      of
      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
                              ( "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]
++
                                " 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]
++
                                " found"
                              )
      Just errStr :: String
errStr -> String -> Pattern
notAllowed String
errStr

textDeriv cx :: Context
cx (List p :: Pattern
p) s :: 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
               ( "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]
++
                 " 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]
++
                 " found"
               )

textDeriv _ n :: Pattern
n@(NotAllowed _) _
    = Pattern
n

textDeriv _ p :: Pattern
p s :: String
s
    = String -> Pattern
notAllowed
      ( "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]
++
        " 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]
++ " 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 _ !Pattern
p []
    = Pattern
p

listDeriv cx :: Context
cx !Pattern
p (x :: String
x:xs :: [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 p1 :: Pattern
p1 p2 :: Pattern
p2) qn :: QName
qn
    = Pattern -> Pattern -> Pattern
choice (Pattern -> QName -> Pattern
startTagOpenDeriv Pattern
p1 QName
qn) (Pattern -> QName -> Pattern
startTagOpenDeriv Pattern
p2 QName
qn)

startTagOpenDeriv (Element nc :: NameClass
nc p :: Pattern
p) qn :: 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
$
          "Element with name " String -> String -> String
forall a. [a] -> [a] -> [a]
++ NameClass -> String
nameClassToString NameClass
nc String -> String -> String
forall a. [a] -> [a] -> [a]
++
            " expected, but " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QName -> String
universalName QName
qn String -> String -> String
forall a. [a] -> [a] -> [a]
++ " found"

startTagOpenDeriv (Interleave p1 :: Pattern
p1 p2 :: Pattern
p2) qn :: 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 p :: Pattern
p) qn :: 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 p1 :: Pattern
p1 p2 :: Pattern
p2) qn :: 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 p1 :: Pattern
p1 p2 :: Pattern
p2) qn :: 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 _) _
    = Pattern
n

startTagOpenDeriv p :: Pattern
p qn :: QName
qn
    = String -> Pattern
notAllowed ( Pattern -> String
forall a. Show a => a -> String
show Pattern
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ " expected, but Element " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QName -> String
universalName QName
qn String -> String -> String
forall a. [a] -> [a] -> [a]
++ " 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 _ !Pattern
p []
    = Pattern
p
attsDeriv cx :: Context
cx !Pattern
p (t :: XmlTree
t : ts :: [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 "Call to attsDeriv with wrong arguments"

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

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

attDeriv cx :: Context
cx (Choice p1 :: Pattern
p1 p2 :: Pattern
p2) att :: 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 cx :: Context
cx (Group p1 :: Pattern
p1 p2 :: Pattern
p2) att :: 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 cx :: Context
cx (Interleave p1 :: Pattern
p1 p2 :: Pattern
p2) att :: 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 cx :: Context
cx (OneOrMore p :: Pattern
p) att :: 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 cx :: Context
cx (Attribute nc :: NameClass
nc p :: Pattern
p) att :: 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
$
          "Attribute with name " String -> String -> String
forall a. [a] -> [a] -> [a]
++ NameClass -> String
nameClassToString NameClass
nc
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ " expected, but " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QName -> String
universalName QName
qn String -> String -> String
forall a. [a] -> [a] -> [a]
++ " 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 (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 _l :: Int
_l es :: [String]
es))
        = String -> Pattern
err'' (": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. [a] -> a
head [String]
es)
    err' _
        = String -> Pattern
err'' ""
    err'' :: String -> Pattern
err'' e :: String
e
        = String -> Pattern
notAllowed2 (String -> Pattern) -> String -> Pattern
forall a b. (a -> b) -> a -> b
$
          "Attribute value \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
val String -> String -> String
forall a. [a] -> [a] -> [a]
++
          "\" 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 _ n :: Pattern
n@(NotAllowed _) _
    = Pattern
n

attDeriv _ _p :: Pattern
_p att :: XmlTree
att
    = String -> Pattern
notAllowed (String -> Pattern) -> String -> Pattern
forall a b. (a -> b) -> a -> b
$
      "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]
++ "' found"

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

startTagCloseDeriv :: Pattern -> Pattern

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

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

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

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

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

startTagCloseDeriv (Attribute nc :: NameClass
nc _)
    = String -> Pattern
notAllowed1 (String -> Pattern) -> String -> Pattern
forall a b. (a -> b) -> a -> b
$
      "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]
++
      " expected, but no more attributes found"

startTagCloseDeriv p :: 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 _cx :: Context
_cx p :: Pattern
p@(NotAllowed _) _
    = Pattern
p

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

childrenDeriv cx :: Context
cx p :: Pattern
p [tt :: 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 cx :: Context
cx p :: Pattern
p children :: [XmlTree]
children
    = Context -> Pattern -> [XmlTree] -> Pattern
stripChildrenDeriv Context
cx Pattern
p [XmlTree]
children

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

stripChildrenDeriv cx :: Context
cx !Pattern
p (h :: XmlTree
h:t :: [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 p1 :: Pattern
p1 p2 :: Pattern
p2)
    = Pattern -> Pattern -> Pattern
choice (Pattern -> Pattern
endTagDeriv Pattern
p1) (Pattern -> Pattern
endTagDeriv Pattern
p2)

endTagDeriv (After p1 :: Pattern
p1 p2 :: 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]
++ " expected"

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

endTagDeriv _
    = String -> Pattern
notAllowed "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 f :: Pattern -> Pattern
f (After p1 :: Pattern
p1 p2 :: Pattern
p2)      = Pattern -> Pattern -> Pattern
after Pattern
p1 (Pattern -> Pattern
f Pattern
p2)
applyAfter f :: Pattern -> Pattern
f (Choice p1 :: Pattern
p1 p2 :: 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 _ n :: Pattern
n@(NotAllowed _)   = Pattern
n
applyAfter _ _                  = String -> Pattern
notAllowed "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 (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 (a :: * -> * -> *) b c. ArrowList a => (b -> [c]) -> a b c
arrL [XmlTree] -> [XmlTree]
forall a. a -> a
id)

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