{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}

module Text.XML.HXT.RelaxNG.PatternToString
  ( patternToStringTree
  , patternToFormatedString
  , xmlTreeToPatternStringTree
  , xmlTreeToPatternFormatedString
  , xmlTreeToPatternString
  , nameClassToString
  )
where

import Control.Arrow.ListArrows

import Data.Tree.Class                  ( formatTree )
import Data.Tree.NTree.TypeDefs

import Text.XML.HXT.DOM.Interface

import Text.XML.HXT.RelaxNG.DataTypes
import Text.XML.HXT.RelaxNG.CreatePattern
import Text.XML.HXT.RelaxNG.Utils

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

type PatternTree = NTree String


{- |
Returns a string representation of the pattern structure.
(see also: 'createPatternFromXmlTree')

Example:

> Element {}foo (Choice (Choice (Value ("","token") "abc"
> ("foo","www.bar.baz")]))(Data ("http://www.mysql.com","VARCHAR")
> [("length","2"),("maxLength","5")])) (Element {}bar (Group (Element {}baz

The function can @not@ be used to display circular ref-pattern structures.
-}

xmlTreeToPatternString :: LA XmlTree String
xmlTreeToPatternString :: LA XmlTree [Char]
xmlTreeToPatternString
    = LA XmlTree Pattern
createPatternFromXmlTree
      LA XmlTree Pattern -> (Pattern -> [Char]) -> LA XmlTree [Char]
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> (c -> d) -> a b d
>>^
      Pattern -> [Char]
forall a. Show a => a -> [Char]
show


-- | Returns a string representation of a nameclass.

nameClassToString :: NameClass -> String
nameClassToString :: NameClass -> [Char]
nameClassToString NameClass
AnyName
    = [Char]
"AnyName"

nameClassToString (AnyNameExcept NameClass
nc)
    = [Char]
"AnyNameExcept " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ NameClass -> [Char]
nameClassToString NameClass
nc

nameClassToString (Name [Char]
uri [Char]
local)
    = [Char]
"{" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
uri [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"}" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
local

nameClassToString (NsName [Char]
uri)
    = [Char]
"{" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
uri [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"}"

nameClassToString (NsNameExcept [Char]
uri NameClass
nc)
    = [Char]
uri [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"except (NsName) " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ NameClass -> [Char]
nameClassToString NameClass
nc

nameClassToString (NameClassChoice NameClass
nc1 NameClass
nc2)
    = NameClass -> [Char]
nameClassToString NameClass
nc1 [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ NameClass -> [Char]
nameClassToString NameClass
nc2

nameClassToString (NCError [Char]
e)
    = [Char]
"NameClass Error: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
e


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

{- |
Returns a tree representation of the pattern structure.
The hard work is done by 'formatTree'.

Example:

> +---element {}bar
>     |
>     +---group
>         |
>         +---oneOrMore
>         |   |
>         |   +---attribute AnyName
>         |       |
>         |       +---text
>         |
>         +---text

The function can be used to display circular ref-pattern structures.

Example:

> <define name="baz">
>   <element name="baz">
>     ... <ref name="baz"/> ...
>   </element>
> </define>

-}

patternToStringTree :: LA Pattern String
patternToStringTree :: LA Pattern [Char]
patternToStringTree
    = [NameClass]
-> SLA [NameClass] Pattern PatternTree -> LA Pattern PatternTree
forall (a :: * -> * -> *) s b c.
ArrowList a =>
s -> SLA s b c -> a b c
fromSLA [] SLA [NameClass] Pattern PatternTree
pattern2PatternTree
      LA Pattern PatternTree
-> (PatternTree -> [Char]) -> LA Pattern [Char]
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> (c -> d) -> a b d
>>^
      (\PatternTree
p -> ([Char] -> [Char]) -> PatternTree -> [Char]
forall a. (a -> [Char]) -> NTree a -> [Char]
forall (t :: * -> *) a. Tree t => (a -> [Char]) -> t a -> [Char]
formatTree [Char] -> [Char]
forall a. a -> a
id PatternTree
p [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n")


-- | Returns a tree representation of the pattern structure.
-- (see also: 'createPatternFromXmlTree' and 'patternToStringTree')

xmlTreeToPatternStringTree :: LA XmlTree String
xmlTreeToPatternStringTree :: LA XmlTree [Char]
xmlTreeToPatternStringTree
    = LA XmlTree Pattern
createPatternFromXmlTree
      LA XmlTree Pattern -> LA Pattern [Char] -> LA XmlTree [Char]
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
      LA Pattern [Char]
patternToStringTree


pattern2PatternTree :: SLA [NameClass] Pattern PatternTree
pattern2PatternTree :: SLA [NameClass] Pattern PatternTree
pattern2PatternTree
    = [IfThen
   (SLA [NameClass] Pattern Pattern)
   (SLA [NameClass] Pattern PatternTree)]
-> SLA [NameClass] Pattern PatternTree
forall b c d.
[IfThen (SLA [NameClass] b c) (SLA [NameClass] b d)]
-> SLA [NameClass] b d
forall (a :: * -> * -> *) b c d.
ArrowIf a =>
[IfThen (a b c) (a b d)] -> a b d
choiceA
      [ (Pattern -> Bool) -> SLA [NameClass] Pattern Pattern
forall b. (b -> Bool) -> SLA [NameClass] b b
forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA Pattern -> Bool
isRelaxEmpty      SLA [NameClass] Pattern Pattern
-> SLA [NameClass] Pattern PatternTree
-> IfThen
     (SLA [NameClass] Pattern Pattern)
     (SLA [NameClass] Pattern PatternTree)
forall a b. a -> b -> IfThen a b
:-> (PatternTree -> SLA [NameClass] Pattern PatternTree
forall c b. c -> SLA [NameClass] b c
forall (a :: * -> * -> *) c b. ArrowList a => c -> a b c
constA (PatternTree -> SLA [NameClass] Pattern PatternTree)
-> PatternTree -> SLA [NameClass] Pattern PatternTree
forall a b. (a -> b) -> a -> b
$ [Char] -> NTrees [Char] -> PatternTree
forall a. a -> NTrees a -> NTree a
NTree [Char]
"empty" [])
      , (Pattern -> Bool) -> SLA [NameClass] Pattern Pattern
forall b. (b -> Bool) -> SLA [NameClass] b b
forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA Pattern -> Bool
isRelaxNotAllowed SLA [NameClass] Pattern Pattern
-> SLA [NameClass] Pattern PatternTree
-> IfThen
     (SLA [NameClass] Pattern Pattern)
     (SLA [NameClass] Pattern PatternTree)
forall a b. a -> b -> IfThen a b
:-> SLA [NameClass] Pattern PatternTree
notAllowed2PatternTree
      , (Pattern -> Bool) -> SLA [NameClass] Pattern Pattern
forall b. (b -> Bool) -> SLA [NameClass] b b
forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA Pattern -> Bool
isRelaxText       SLA [NameClass] Pattern Pattern
-> SLA [NameClass] Pattern PatternTree
-> IfThen
     (SLA [NameClass] Pattern Pattern)
     (SLA [NameClass] Pattern PatternTree)
forall a b. a -> b -> IfThen a b
:-> (PatternTree -> SLA [NameClass] Pattern PatternTree
forall c b. c -> SLA [NameClass] b c
forall (a :: * -> * -> *) c b. ArrowList a => c -> a b c
constA (PatternTree -> SLA [NameClass] Pattern PatternTree)
-> PatternTree -> SLA [NameClass] Pattern PatternTree
forall a b. (a -> b) -> a -> b
$ [Char] -> NTrees [Char] -> PatternTree
forall a. a -> NTrees a -> NTree a
NTree [Char]
"text" [])
      , (Pattern -> Bool) -> SLA [NameClass] Pattern Pattern
forall b. (b -> Bool) -> SLA [NameClass] b b
forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA Pattern -> Bool
isRelaxChoice     SLA [NameClass] Pattern Pattern
-> SLA [NameClass] Pattern PatternTree
-> IfThen
     (SLA [NameClass] Pattern Pattern)
     (SLA [NameClass] Pattern PatternTree)
forall a b. a -> b -> IfThen a b
:-> SLA [NameClass] Pattern PatternTree
choice2PatternTree
      , (Pattern -> Bool) -> SLA [NameClass] Pattern Pattern
forall b. (b -> Bool) -> SLA [NameClass] b b
forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA Pattern -> Bool
isRelaxInterleave SLA [NameClass] Pattern Pattern
-> SLA [NameClass] Pattern PatternTree
-> IfThen
     (SLA [NameClass] Pattern Pattern)
     (SLA [NameClass] Pattern PatternTree)
forall a b. a -> b -> IfThen a b
:-> [Char] -> SLA [NameClass] Pattern PatternTree
children2PatternTree [Char]
"interleave"
      , (Pattern -> Bool) -> SLA [NameClass] Pattern Pattern
forall b. (b -> Bool) -> SLA [NameClass] b b
forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA Pattern -> Bool
isRelaxGroup      SLA [NameClass] Pattern Pattern
-> SLA [NameClass] Pattern PatternTree
-> IfThen
     (SLA [NameClass] Pattern Pattern)
     (SLA [NameClass] Pattern PatternTree)
forall a b. a -> b -> IfThen a b
:-> [Char] -> SLA [NameClass] Pattern PatternTree
children2PatternTree [Char]
"group"
      , (Pattern -> Bool) -> SLA [NameClass] Pattern Pattern
forall b. (b -> Bool) -> SLA [NameClass] b b
forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA Pattern -> Bool
isRelaxOneOrMore  SLA [NameClass] Pattern Pattern
-> SLA [NameClass] Pattern PatternTree
-> IfThen
     (SLA [NameClass] Pattern Pattern)
     (SLA [NameClass] Pattern PatternTree)
forall a b. a -> b -> IfThen a b
:-> [Char] -> SLA [NameClass] Pattern PatternTree
children2PatternTree [Char]
"oneOrMore"
      , (Pattern -> Bool) -> SLA [NameClass] Pattern Pattern
forall b. (b -> Bool) -> SLA [NameClass] b b
forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA Pattern -> Bool
isRelaxList       SLA [NameClass] Pattern Pattern
-> SLA [NameClass] Pattern PatternTree
-> IfThen
     (SLA [NameClass] Pattern Pattern)
     (SLA [NameClass] Pattern PatternTree)
forall a b. a -> b -> IfThen a b
:-> [Char] -> SLA [NameClass] Pattern PatternTree
children2PatternTree [Char]
"list"
      , (Pattern -> Bool) -> SLA [NameClass] Pattern Pattern
forall b. (b -> Bool) -> SLA [NameClass] b b
forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA Pattern -> Bool
isRelaxData       SLA [NameClass] Pattern Pattern
-> SLA [NameClass] Pattern PatternTree
-> IfThen
     (SLA [NameClass] Pattern Pattern)
     (SLA [NameClass] Pattern PatternTree)
forall a b. a -> b -> IfThen a b
:-> SLA [NameClass] Pattern PatternTree
data2PatternTree
      , (Pattern -> Bool) -> SLA [NameClass] Pattern Pattern
forall b. (b -> Bool) -> SLA [NameClass] b b
forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA Pattern -> Bool
isRelaxDataExcept SLA [NameClass] Pattern Pattern
-> SLA [NameClass] Pattern PatternTree
-> IfThen
     (SLA [NameClass] Pattern Pattern)
     (SLA [NameClass] Pattern PatternTree)
forall a b. a -> b -> IfThen a b
:-> SLA [NameClass] Pattern PatternTree
dataExcept2PatternTree
      , (Pattern -> Bool) -> SLA [NameClass] Pattern Pattern
forall b. (b -> Bool) -> SLA [NameClass] b b
forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA Pattern -> Bool
isRelaxValue      SLA [NameClass] Pattern Pattern
-> SLA [NameClass] Pattern PatternTree
-> IfThen
     (SLA [NameClass] Pattern Pattern)
     (SLA [NameClass] Pattern PatternTree)
forall a b. a -> b -> IfThen a b
:-> SLA [NameClass] Pattern PatternTree
value2PatternTree
      , (Pattern -> Bool) -> SLA [NameClass] Pattern Pattern
forall b. (b -> Bool) -> SLA [NameClass] b b
forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA Pattern -> Bool
isRelaxAttribute  SLA [NameClass] Pattern Pattern
-> SLA [NameClass] Pattern PatternTree
-> IfThen
     (SLA [NameClass] Pattern Pattern)
     (SLA [NameClass] Pattern PatternTree)
forall a b. a -> b -> IfThen a b
:-> [Char] -> SLA [NameClass] Pattern PatternTree
createPatternTreeFromElement [Char]
"attribute"
      , (Pattern -> Bool) -> SLA [NameClass] Pattern Pattern
forall b. (b -> Bool) -> SLA [NameClass] b b
forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA Pattern -> Bool
isRelaxElement    SLA [NameClass] Pattern Pattern
-> SLA [NameClass] Pattern PatternTree
-> IfThen
     (SLA [NameClass] Pattern Pattern)
     (SLA [NameClass] Pattern PatternTree)
forall a b. a -> b -> IfThen a b
:-> SLA [NameClass] Pattern PatternTree
element2PatternTree
      , (Pattern -> Bool) -> SLA [NameClass] Pattern Pattern
forall b. (b -> Bool) -> SLA [NameClass] b b
forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA Pattern -> Bool
isRelaxAfter      SLA [NameClass] Pattern Pattern
-> SLA [NameClass] Pattern PatternTree
-> IfThen
     (SLA [NameClass] Pattern Pattern)
     (SLA [NameClass] Pattern PatternTree)
forall a b. a -> b -> IfThen a b
:-> [Char] -> SLA [NameClass] Pattern PatternTree
children2PatternTree [Char]
"after"
      ]

notAllowed2PatternTree :: SLA [NameClass] Pattern PatternTree
notAllowed2PatternTree :: SLA [NameClass] Pattern PatternTree
notAllowed2PatternTree
    = (Pattern -> PatternTree) -> SLA [NameClass] Pattern PatternTree
forall b c. (b -> c) -> SLA [NameClass] b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr ((Pattern -> PatternTree) -> SLA [NameClass] Pattern PatternTree)
-> (Pattern -> PatternTree) -> SLA [NameClass] Pattern PatternTree
forall a b. (a -> b) -> a -> b
$ \(NotAllowed (ErrMsg ErrLevel
_l [[Char]]
sl)) -> [Char] -> NTrees [Char] -> PatternTree
forall a. a -> NTrees a -> NTree a
NTree [Char]
"notAllowed" (NTrees [Char] -> PatternTree) -> NTrees [Char] -> PatternTree
forall a b. (a -> b) -> a -> b
$ ([Char] -> PatternTree) -> [[Char]] -> NTrees [Char]
forall a b. (a -> b) -> [a] -> [b]
map (\ [Char]
s -> [Char] -> NTrees [Char] -> PatternTree
forall a. a -> NTrees a -> NTree a
NTree [Char]
s []) [[Char]]
sl


data2PatternTree :: SLA [NameClass] Pattern PatternTree
data2PatternTree :: SLA [NameClass] Pattern PatternTree
data2PatternTree
    = (Pattern -> PatternTree) -> SLA [NameClass] Pattern PatternTree
forall b c. (b -> c) -> SLA [NameClass] b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr ((Pattern -> PatternTree) -> SLA [NameClass] Pattern PatternTree)
-> (Pattern -> PatternTree) -> SLA [NameClass] Pattern PatternTree
forall a b. (a -> b) -> a -> b
$ \ (Data Datatype
d ParamList
p) -> [Char] -> NTrees [Char] -> PatternTree
forall a. a -> NTrees a -> NTree a
NTree [Char]
"data" [ Datatype -> PatternTree
datatype2PatternTree Datatype
d
                                         , [Char] -> ParamList -> PatternTree
mapping2PatternTree [Char]
"parameter" ParamList
p
                                         ]

dataExcept2PatternTree :: SLA [NameClass] Pattern PatternTree
dataExcept2PatternTree :: SLA [NameClass] Pattern PatternTree
dataExcept2PatternTree
    = SLA [NameClass] Pattern Pattern
forall b. SLA [NameClass] b b
forall (a :: * -> * -> *) b. ArrowList a => a b b
this SLA [NameClass] Pattern Pattern
-> SLA [NameClass] Pattern (NTrees [Char])
-> SLA [NameClass] Pattern (Pattern, NTrees [Char])
forall b c c'.
SLA [NameClass] b c
-> SLA [NameClass] b c' -> SLA [NameClass] b (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (SLA [NameClass] Pattern PatternTree
-> SLA [NameClass] Pattern (NTrees [Char])
forall b c. SLA [NameClass] b c -> SLA [NameClass] b [c]
forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b [c]
listA (SLA [NameClass] Pattern PatternTree
 -> SLA [NameClass] Pattern (NTrees [Char]))
-> SLA [NameClass] Pattern PatternTree
-> SLA [NameClass] Pattern (NTrees [Char])
forall a b. (a -> b) -> a -> b
$ (Pattern -> [Pattern]) -> SLA [NameClass] Pattern Pattern
forall b c. (b -> [c]) -> SLA [NameClass] b c
forall (a :: * -> * -> *) b c. ArrowList a => (b -> [c]) -> a b c
arrL Pattern -> [Pattern]
getChildrenPattern SLA [NameClass] Pattern Pattern
-> SLA [NameClass] Pattern PatternTree
-> SLA [NameClass] Pattern PatternTree
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> SLA [NameClass] Pattern PatternTree
pattern2PatternTree)
      SLA [NameClass] Pattern (Pattern, NTrees [Char])
-> SLA [NameClass] (Pattern, NTrees [Char]) PatternTree
-> SLA [NameClass] Pattern PatternTree
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
      (Pattern -> NTrees [Char] -> PatternTree)
-> SLA [NameClass] (Pattern, NTrees [Char]) PatternTree
forall b1 b2 c. (b1 -> b2 -> c) -> SLA [NameClass] (b1, b2) c
forall (a :: * -> * -> *) b1 b2 c.
ArrowList a =>
(b1 -> b2 -> c) -> a (b1, b2) c
arr2 ( \ (DataExcept Datatype
d ParamList
param Pattern
_) NTrees [Char]
pattern ->
             [Char] -> NTrees [Char] -> PatternTree
forall a. a -> NTrees a -> NTree a
NTree [Char]
"dataExcept" ([ Datatype -> PatternTree
datatype2PatternTree Datatype
d
                                 , [Char] -> ParamList -> PatternTree
mapping2PatternTree [Char]
"parameter" ParamList
param
                                 ] NTrees [Char] -> NTrees [Char] -> NTrees [Char]
forall a. [a] -> [a] -> [a]
++ NTrees [Char]
pattern)
           )

value2PatternTree :: SLA [NameClass] Pattern PatternTree
value2PatternTree :: SLA [NameClass] Pattern PatternTree
value2PatternTree
    = (Pattern -> PatternTree) -> SLA [NameClass] Pattern PatternTree
forall b c. (b -> c) -> SLA [NameClass] b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr ((Pattern -> PatternTree) -> SLA [NameClass] Pattern PatternTree)
-> (Pattern -> PatternTree) -> SLA [NameClass] Pattern PatternTree
forall a b. (a -> b) -> a -> b
$ \ (Value Datatype
d [Char]
v Context
c) -> [Char] -> NTrees [Char] -> PatternTree
forall a. a -> NTrees a -> NTree a
NTree ([Char]
"value = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
v) [ Datatype -> PatternTree
datatype2PatternTree Datatype
d
                                                       , Context -> PatternTree
context2PatternTree Context
c
                                                       ]


createPatternTreeFromElement :: String -> SLA [NameClass] Pattern PatternTree
createPatternTreeFromElement :: [Char] -> SLA [NameClass] Pattern PatternTree
createPatternTreeFromElement [Char]
name
    = ( (Pattern -> NameClass) -> SLA [NameClass] Pattern NameClass
forall b c. (b -> c) -> SLA [NameClass] b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr Pattern -> NameClass
getNameClassFromPattern
        SLA [NameClass] Pattern NameClass
-> SLA [NameClass] Pattern (NTrees [Char])
-> SLA [NameClass] Pattern (NameClass, NTrees [Char])
forall b c c'.
SLA [NameClass] b c
-> SLA [NameClass] b c' -> SLA [NameClass] b (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&&
        SLA [NameClass] Pattern PatternTree
-> SLA [NameClass] Pattern (NTrees [Char])
forall b c. SLA [NameClass] b c -> SLA [NameClass] b [c]
forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b [c]
listA ((Pattern -> [Pattern]) -> SLA [NameClass] Pattern Pattern
forall b c. (b -> [c]) -> SLA [NameClass] b c
forall (a :: * -> * -> *) b c. ArrowList a => (b -> [c]) -> a b c
arrL Pattern -> [Pattern]
getChildrenPattern SLA [NameClass] Pattern Pattern
-> SLA [NameClass] Pattern PatternTree
-> SLA [NameClass] Pattern PatternTree
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> SLA [NameClass] Pattern PatternTree
pattern2PatternTree)
      )
      SLA [NameClass] Pattern (NameClass, NTrees [Char])
-> SLA [NameClass] (NameClass, NTrees [Char]) PatternTree
-> SLA [NameClass] Pattern PatternTree
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
      (NameClass -> NTrees [Char] -> PatternTree)
-> SLA [NameClass] (NameClass, NTrees [Char]) PatternTree
forall b1 b2 c. (b1 -> b2 -> c) -> SLA [NameClass] (b1, b2) c
forall (a :: * -> * -> *) b1 b2 c.
ArrowList a =>
(b1 -> b2 -> c) -> a (b1, b2) c
arr2 (\NameClass
nc NTrees [Char]
rl -> [Char] -> NTrees [Char] -> PatternTree
forall a. a -> NTrees a -> NTree a
NTree ([Char]
name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ NameClass -> [Char]
forall a. Show a => a -> [Char]
show NameClass
nc) NTrees [Char]
rl)

children2PatternTree :: String -> SLA [NameClass] Pattern PatternTree
children2PatternTree :: [Char] -> SLA [NameClass] Pattern PatternTree
children2PatternTree [Char]
name
    = SLA [NameClass] Pattern PatternTree
-> SLA [NameClass] Pattern (NTrees [Char])
forall b c. SLA [NameClass] b c -> SLA [NameClass] b [c]
forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b [c]
listA ((Pattern -> [Pattern]) -> SLA [NameClass] Pattern Pattern
forall b c. (b -> [c]) -> SLA [NameClass] b c
forall (a :: * -> * -> *) b c. ArrowList a => (b -> [c]) -> a b c
arrL Pattern -> [Pattern]
getChildrenPattern SLA [NameClass] Pattern Pattern
-> SLA [NameClass] Pattern PatternTree
-> SLA [NameClass] Pattern PatternTree
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> SLA [NameClass] Pattern PatternTree
pattern2PatternTree)
      SLA [NameClass] Pattern (NTrees [Char])
-> (NTrees [Char] -> PatternTree)
-> SLA [NameClass] Pattern PatternTree
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> (c -> d) -> a b d
>>^
      ([Char] -> NTrees [Char] -> PatternTree
forall a. a -> NTrees a -> NTree a
NTree [Char]
name)

choice2PatternTree :: SLA [NameClass] Pattern PatternTree
choice2PatternTree :: SLA [NameClass] Pattern PatternTree
choice2PatternTree
    = SLA [NameClass] Pattern (NameClass, [NameClass])
-> SLA [NameClass] Pattern PatternTree
-> SLA [NameClass] Pattern PatternTree
-> SLA [NameClass] Pattern PatternTree
forall b c d.
SLA [NameClass] b c
-> SLA [NameClass] b d
-> SLA [NameClass] b d
-> SLA [NameClass] b d
forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d -> a b d
ifA ( -- wenn das zweite kind ein noch nicht ausgegebenes element ist,
            -- muss dieses anders behandelt werden
            -- nur fuer bessere formatierung des outputs
            (Pattern -> Pattern) -> SLA [NameClass] Pattern Pattern
forall b c. (b -> c) -> SLA [NameClass] b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr ([Pattern] -> Pattern
forall a. HasCallStack => [a] -> a
last ([Pattern] -> Pattern)
-> (Pattern -> [Pattern]) -> Pattern -> Pattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pattern -> [Pattern]
getChildrenPattern) SLA [NameClass] Pattern Pattern
-> SLA [NameClass] Pattern (NameClass, [NameClass])
-> SLA [NameClass] Pattern (NameClass, [NameClass])
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (Pattern -> Bool) -> SLA [NameClass] Pattern Pattern
forall b. (b -> Bool) -> SLA [NameClass] b b
forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA (Pattern -> Bool
isRelaxElement) SLA [NameClass] Pattern Pattern
-> SLA [NameClass] Pattern (NameClass, [NameClass])
-> SLA [NameClass] Pattern (NameClass, [NameClass])
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
            ((Pattern -> NameClass) -> SLA [NameClass] Pattern NameClass
forall b c. (b -> c) -> SLA [NameClass] b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr Pattern -> NameClass
getNameClassFromPattern SLA [NameClass] Pattern NameClass
-> SLA [NameClass] Pattern [NameClass]
-> SLA [NameClass] Pattern (NameClass, [NameClass])
forall b c c'.
SLA [NameClass] b c
-> SLA [NameClass] b c' -> SLA [NameClass] b (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& SLA [NameClass] Pattern [NameClass]
forall b. SLA [NameClass] b [NameClass]
forall s (a :: * -> * -> *) b. ArrowState s a => a b s
getState) SLA [NameClass] Pattern (NameClass, [NameClass])
-> SLA
     [NameClass] (NameClass, [NameClass]) (NameClass, [NameClass])
-> SLA [NameClass] Pattern (NameClass, [NameClass])
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
            ((NameClass, [NameClass]) -> Bool)
-> SLA
     [NameClass] (NameClass, [NameClass]) (NameClass, [NameClass])
forall b. (b -> Bool) -> SLA [NameClass] b b
forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA(\ (NameClass
nc, [NameClass]
liste) -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ NameClass -> [NameClass] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem NameClass
nc [NameClass]
liste)
          )
      ( -- element in status aufnehmen, wird dann nicht mehr vom erste kind ausgegeben
        (Pattern -> [Pattern]) -> SLA [NameClass] Pattern [Pattern]
forall b c. (b -> c) -> SLA [NameClass] b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr Pattern -> [Pattern]
getChildrenPattern
        SLA [NameClass] Pattern [Pattern]
-> SLA [NameClass] [Pattern] PatternTree
-> SLA [NameClass] Pattern PatternTree
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
        ([NameClass] -> [Pattern] -> [NameClass])
-> SLA [NameClass] [Pattern] [Pattern]
forall b. ([NameClass] -> b -> [NameClass]) -> SLA [NameClass] b b
forall s (a :: * -> * -> *) b.
ArrowState s a =>
(s -> b -> s) -> a b b
changeState (\[NameClass]
s [Pattern]
p -> (Pattern -> NameClass
getNameClassFromPattern ([Pattern] -> Pattern
forall a. HasCallStack => [a] -> a
last [Pattern]
p)) NameClass -> [NameClass] -> [NameClass]
forall a. a -> [a] -> [a]
: [NameClass]
s)
        SLA [NameClass] [Pattern] [Pattern]
-> SLA [NameClass] [Pattern] PatternTree
-> SLA [NameClass] [Pattern] PatternTree
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
        ( ( [Pattern] -> Pattern
forall a. HasCallStack => [a] -> a
head ([Pattern] -> Pattern)
-> SLA [NameClass] Pattern PatternTree
-> SLA [NameClass] [Pattern] PatternTree
forall (a :: * -> * -> *) b c d.
Arrow a =>
(b -> c) -> a c d -> a b d
^>> SLA [NameClass] Pattern PatternTree
pattern2PatternTree )              -- erstes kind normal verarbeiten
          SLA [NameClass] [Pattern] PatternTree
-> SLA [NameClass] [Pattern] PatternTree
-> SLA [NameClass] [Pattern] (PatternTree, PatternTree)
forall b c c'.
SLA [NameClass] b c
-> SLA [NameClass] b c' -> SLA [NameClass] b (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&&                                           -- zweites kind, das element, verarbeiten
          ( [Pattern] -> Pattern
forall a. HasCallStack => [a] -> a
last ([Pattern] -> Pattern)
-> SLA [NameClass] Pattern PatternTree
-> SLA [NameClass] [Pattern] PatternTree
forall (a :: * -> * -> *) b c d.
Arrow a =>
(b -> c) -> a c d -> a b d
^>> [Char] -> SLA [NameClass] Pattern PatternTree
createPatternTreeFromElement [Char]
"element" )
        )
        SLA [NameClass] [Pattern] (PatternTree, PatternTree)
-> SLA [NameClass] (PatternTree, PatternTree) PatternTree
-> SLA [NameClass] [Pattern] PatternTree
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
        (PatternTree -> PatternTree -> PatternTree)
-> SLA [NameClass] (PatternTree, PatternTree) PatternTree
forall b1 b2 c. (b1 -> b2 -> c) -> SLA [NameClass] (b1, b2) c
forall (a :: * -> * -> *) b1 b2 c.
ArrowList a =>
(b1 -> b2 -> c) -> a (b1, b2) c
arr2 ( \ PatternTree
l1 PatternTree
l2 -> [Char] -> NTrees [Char] -> PatternTree
forall a. a -> NTrees a -> NTree a
NTree [Char]
"choice" [PatternTree
l1, PatternTree
l2] )
      )
      ( [Char] -> SLA [NameClass] Pattern PatternTree
children2PatternTree [Char]
"choice" )


element2PatternTree :: SLA [NameClass] Pattern PatternTree
element2PatternTree :: SLA [NameClass] Pattern PatternTree
element2PatternTree
    = SLA [NameClass] Pattern (NameClass, [NameClass])
-> SLA [NameClass] Pattern PatternTree
-> SLA [NameClass] Pattern PatternTree
-> SLA [NameClass] Pattern PatternTree
forall b c d.
SLA [NameClass] b c
-> SLA [NameClass] b d
-> SLA [NameClass] b d
-> SLA [NameClass] b d
forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d -> a b d
ifA ( ((Pattern -> NameClass) -> SLA [NameClass] Pattern NameClass
forall b c. (b -> c) -> SLA [NameClass] b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr Pattern -> NameClass
getNameClassFromPattern SLA [NameClass] Pattern NameClass
-> SLA [NameClass] Pattern [NameClass]
-> SLA [NameClass] Pattern (NameClass, [NameClass])
forall b c c'.
SLA [NameClass] b c
-> SLA [NameClass] b c' -> SLA [NameClass] b (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& SLA [NameClass] Pattern [NameClass]
forall b. SLA [NameClass] b [NameClass]
forall s (a :: * -> * -> *) b. ArrowState s a => a b s
getState)
            SLA [NameClass] Pattern (NameClass, [NameClass])
-> SLA
     [NameClass] (NameClass, [NameClass]) (NameClass, [NameClass])
-> SLA [NameClass] Pattern (NameClass, [NameClass])
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
            ((NameClass, [NameClass]) -> Bool)
-> SLA
     [NameClass] (NameClass, [NameClass]) (NameClass, [NameClass])
forall b. (b -> Bool) -> SLA [NameClass] b b
forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA (\ (NameClass
nc, [NameClass]
liste) -> NameClass -> [NameClass] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem NameClass
nc [NameClass]
liste)
          )
      ( (Pattern -> NameClass) -> SLA [NameClass] Pattern NameClass
forall b c. (b -> c) -> SLA [NameClass] b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr Pattern -> NameClass
getNameClassFromPattern
        SLA [NameClass] Pattern NameClass
-> SLA [NameClass] NameClass PatternTree
-> SLA [NameClass] Pattern PatternTree
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
        (NameClass -> PatternTree) -> SLA [NameClass] NameClass PatternTree
forall b c. (b -> c) -> SLA [NameClass] b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (\NameClass
nc -> [Char] -> NTrees [Char] -> PatternTree
forall a. a -> NTrees a -> NTree a
NTree ([Char]
"reference to element " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ NameClass -> [Char]
forall a. Show a => a -> [Char]
show NameClass
nc) [])
      )
      ( ([NameClass] -> Pattern -> [NameClass])
-> SLA [NameClass] Pattern Pattern
forall b. ([NameClass] -> b -> [NameClass]) -> SLA [NameClass] b b
forall s (a :: * -> * -> *) b.
ArrowState s a =>
(s -> b -> s) -> a b b
changeState (\ [NameClass]
s Pattern
p -> (Pattern -> NameClass
getNameClassFromPattern Pattern
p) NameClass -> [NameClass] -> [NameClass]
forall a. a -> [a] -> [a]
: [NameClass]
s)
        SLA [NameClass] Pattern Pattern
-> SLA [NameClass] Pattern PatternTree
-> SLA [NameClass] Pattern PatternTree
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
        [Char] -> SLA [NameClass] Pattern PatternTree
createPatternTreeFromElement [Char]
"element"
      )


mapping2PatternTree :: String -> [(Prefix, Uri)] -> PatternTree
mapping2PatternTree :: [Char] -> ParamList -> PatternTree
mapping2PatternTree [Char]
name ParamList
mapping
    = [Char] -> NTrees [Char] -> PatternTree
forall a. a -> NTrees a -> NTree a
NTree [Char]
name ((Datatype -> PatternTree) -> ParamList -> NTrees [Char]
forall a b. (a -> b) -> [a] -> [b]
map (\([Char]
a, [Char]
b) -> [Char] -> NTrees [Char] -> PatternTree
forall a. a -> NTrees a -> NTree a
NTree ([Char]
a [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
b) []) ParamList
mapping)


datatype2PatternTree :: Datatype -> PatternTree
datatype2PatternTree :: Datatype -> PatternTree
datatype2PatternTree Datatype
dt
    = [Char] -> NTrees [Char] -> PatternTree
forall a. a -> NTrees a -> NTree a
NTree (Datatype -> [Char]
datatype2String Datatype
dt) []


context2PatternTree :: Context -> PatternTree
context2PatternTree :: Context -> PatternTree
context2PatternTree ([Char]
base, ParamList
mapping)
    = [Char] -> NTrees [Char] -> PatternTree
forall a. a -> NTrees a -> NTree a
NTree [Char]
"context" [ [Char] -> NTrees [Char] -> PatternTree
forall a. a -> NTrees a -> NTree a
NTree ([Char]
"base-uri = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
base) []
                      , [Char] -> ParamList -> PatternTree
mapping2PatternTree [Char]
"namespace environment" ParamList
mapping
                      ]

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

-- | Returns a formated string representation of the pattern structure.
-- (see also: 'createPatternFromXmlTree' and 'patternToFormatedString')
xmlTreeToPatternFormatedString :: LA XmlTree String
xmlTreeToPatternFormatedString :: LA XmlTree [Char]
xmlTreeToPatternFormatedString
    = LA XmlTree Pattern
createPatternFromXmlTree
      LA XmlTree Pattern -> LA Pattern [Char] -> LA XmlTree [Char]
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
      [NameClass] -> SLA [NameClass] Pattern [Char] -> LA Pattern [Char]
forall (a :: * -> * -> *) s b c.
ArrowList a =>
s -> SLA s b c -> a b c
fromSLA [] SLA [NameClass] Pattern [Char]
patternToFormatedString


{- |
Returns a formated string representation of the pattern structure.

Example:

> Element {}foo (Choice (Choice ( Value = abc,
> datatypelibrary = http://relaxng.org/ns/structure/1.0, type = token,
> context (base-uri =file://test.rng,
> parameter: xml = http://www.w3.org/XML/1998/namespaces, foo = www.bar.baz),

The function can be used to display circular ref-pattern structures.
-}

patternToFormatedString :: SLA [NameClass] Pattern String
patternToFormatedString :: SLA [NameClass] Pattern [Char]
patternToFormatedString
    = [IfThen
   (SLA [NameClass] Pattern Pattern) (SLA [NameClass] Pattern [Char])]
-> SLA [NameClass] Pattern [Char]
forall b c d.
[IfThen (SLA [NameClass] b c) (SLA [NameClass] b d)]
-> SLA [NameClass] b d
forall (a :: * -> * -> *) b c d.
ArrowIf a =>
[IfThen (a b c) (a b d)] -> a b d
choiceA
      [ (Pattern -> Bool) -> SLA [NameClass] Pattern Pattern
forall b. (b -> Bool) -> SLA [NameClass] b b
forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA Pattern -> Bool
isRelaxEmpty      SLA [NameClass] Pattern Pattern
-> SLA [NameClass] Pattern [Char]
-> IfThen
     (SLA [NameClass] Pattern Pattern) (SLA [NameClass] Pattern [Char])
forall a b. a -> b -> IfThen a b
:-> ([Char] -> SLA [NameClass] Pattern [Char]
forall c b. c -> SLA [NameClass] b c
forall (a :: * -> * -> *) c b. ArrowList a => c -> a b c
constA [Char]
" empty ")
      , (Pattern -> Bool) -> SLA [NameClass] Pattern Pattern
forall b. (b -> Bool) -> SLA [NameClass] b b
forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA Pattern -> Bool
isRelaxNotAllowed SLA [NameClass] Pattern Pattern
-> SLA [NameClass] Pattern [Char]
-> IfThen
     (SLA [NameClass] Pattern Pattern) (SLA [NameClass] Pattern [Char])
forall a b. a -> b -> IfThen a b
:-> ((Pattern -> [Char]) -> SLA [NameClass] Pattern [Char]
forall b c. (b -> c) -> SLA [NameClass] b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr ((Pattern -> [Char]) -> SLA [NameClass] Pattern [Char])
-> (Pattern -> [Char]) -> SLA [NameClass] Pattern [Char]
forall a b. (a -> b) -> a -> b
$ \ (NotAllowed ErrMessage
errorEnv) -> ErrMessage -> [Char]
forall a. Show a => a -> [Char]
show ErrMessage
errorEnv)
      , (Pattern -> Bool) -> SLA [NameClass] Pattern Pattern
forall b. (b -> Bool) -> SLA [NameClass] b b
forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA Pattern -> Bool
isRelaxText       SLA [NameClass] Pattern Pattern
-> SLA [NameClass] Pattern [Char]
-> IfThen
     (SLA [NameClass] Pattern Pattern) (SLA [NameClass] Pattern [Char])
forall a b. a -> b -> IfThen a b
:-> ([Char] -> SLA [NameClass] Pattern [Char]
forall c b. c -> SLA [NameClass] b c
forall (a :: * -> * -> *) c b. ArrowList a => c -> a b c
constA [Char]
" text ")
      , (Pattern -> Bool) -> SLA [NameClass] Pattern Pattern
forall b. (b -> Bool) -> SLA [NameClass] b b
forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA Pattern -> Bool
isRelaxChoice     SLA [NameClass] Pattern Pattern
-> SLA [NameClass] Pattern [Char]
-> IfThen
     (SLA [NameClass] Pattern Pattern) (SLA [NameClass] Pattern [Char])
forall a b. a -> b -> IfThen a b
:-> [Char] -> SLA [NameClass] Pattern [Char]
children2FormatedString [Char]
"choice"
      , (Pattern -> Bool) -> SLA [NameClass] Pattern Pattern
forall b. (b -> Bool) -> SLA [NameClass] b b
forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA Pattern -> Bool
isRelaxInterleave SLA [NameClass] Pattern Pattern
-> SLA [NameClass] Pattern [Char]
-> IfThen
     (SLA [NameClass] Pattern Pattern) (SLA [NameClass] Pattern [Char])
forall a b. a -> b -> IfThen a b
:-> [Char] -> SLA [NameClass] Pattern [Char]
children2FormatedString [Char]
"interleave"
      , (Pattern -> Bool) -> SLA [NameClass] Pattern Pattern
forall b. (b -> Bool) -> SLA [NameClass] b b
forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA Pattern -> Bool
isRelaxGroup      SLA [NameClass] Pattern Pattern
-> SLA [NameClass] Pattern [Char]
-> IfThen
     (SLA [NameClass] Pattern Pattern) (SLA [NameClass] Pattern [Char])
forall a b. a -> b -> IfThen a b
:-> [Char] -> SLA [NameClass] Pattern [Char]
children2FormatedString [Char]
"group"
      , (Pattern -> Bool) -> SLA [NameClass] Pattern Pattern
forall b. (b -> Bool) -> SLA [NameClass] b b
forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA Pattern -> Bool
isRelaxOneOrMore  SLA [NameClass] Pattern Pattern
-> SLA [NameClass] Pattern [Char]
-> IfThen
     (SLA [NameClass] Pattern Pattern) (SLA [NameClass] Pattern [Char])
forall a b. a -> b -> IfThen a b
:-> [Char] -> SLA [NameClass] Pattern [Char]
children2FormatedString [Char]
"oneOrMore"
      , (Pattern -> Bool) -> SLA [NameClass] Pattern Pattern
forall b. (b -> Bool) -> SLA [NameClass] b b
forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA Pattern -> Bool
isRelaxList       SLA [NameClass] Pattern Pattern
-> SLA [NameClass] Pattern [Char]
-> IfThen
     (SLA [NameClass] Pattern Pattern) (SLA [NameClass] Pattern [Char])
forall a b. a -> b -> IfThen a b
:-> [Char] -> SLA [NameClass] Pattern [Char]
children2FormatedString [Char]
"list"
      , (Pattern -> Bool) -> SLA [NameClass] Pattern Pattern
forall b. (b -> Bool) -> SLA [NameClass] b b
forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA Pattern -> Bool
isRelaxData       SLA [NameClass] Pattern Pattern
-> SLA [NameClass] Pattern [Char]
-> IfThen
     (SLA [NameClass] Pattern Pattern) (SLA [NameClass] Pattern [Char])
forall a b. a -> b -> IfThen a b
:-> SLA [NameClass] Pattern [Char]
data2FormatedString
      , (Pattern -> Bool) -> SLA [NameClass] Pattern Pattern
forall b. (b -> Bool) -> SLA [NameClass] b b
forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA Pattern -> Bool
isRelaxDataExcept SLA [NameClass] Pattern Pattern
-> SLA [NameClass] Pattern [Char]
-> IfThen
     (SLA [NameClass] Pattern Pattern) (SLA [NameClass] Pattern [Char])
forall a b. a -> b -> IfThen a b
:-> SLA [NameClass] Pattern [Char]
dataExcept2FormatedString
      , (Pattern -> Bool) -> SLA [NameClass] Pattern Pattern
forall b. (b -> Bool) -> SLA [NameClass] b b
forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA Pattern -> Bool
isRelaxValue      SLA [NameClass] Pattern Pattern
-> SLA [NameClass] Pattern [Char]
-> IfThen
     (SLA [NameClass] Pattern Pattern) (SLA [NameClass] Pattern [Char])
forall a b. a -> b -> IfThen a b
:-> SLA [NameClass] Pattern [Char]
value2FormatedString
      , (Pattern -> Bool) -> SLA [NameClass] Pattern Pattern
forall b. (b -> Bool) -> SLA [NameClass] b b
forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA Pattern -> Bool
isRelaxAttribute  SLA [NameClass] Pattern Pattern
-> SLA [NameClass] Pattern [Char]
-> IfThen
     (SLA [NameClass] Pattern Pattern) (SLA [NameClass] Pattern [Char])
forall a b. a -> b -> IfThen a b
:-> [Char] -> SLA [NameClass] Pattern [Char]
createFormatedStringFromElement [Char]
"attribute"
      , (Pattern -> Bool) -> SLA [NameClass] Pattern Pattern
forall b. (b -> Bool) -> SLA [NameClass] b b
forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA Pattern -> Bool
isRelaxElement    SLA [NameClass] Pattern Pattern
-> SLA [NameClass] Pattern [Char]
-> IfThen
     (SLA [NameClass] Pattern Pattern) (SLA [NameClass] Pattern [Char])
forall a b. a -> b -> IfThen a b
:-> SLA [NameClass] Pattern [Char]
element2FormatedString
      , (Pattern -> Bool) -> SLA [NameClass] Pattern Pattern
forall b. (b -> Bool) -> SLA [NameClass] b b
forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA Pattern -> Bool
isRelaxAfter      SLA [NameClass] Pattern Pattern
-> SLA [NameClass] Pattern [Char]
-> IfThen
     (SLA [NameClass] Pattern Pattern) (SLA [NameClass] Pattern [Char])
forall a b. a -> b -> IfThen a b
:-> [Char] -> SLA [NameClass] Pattern [Char]
children2FormatedString [Char]
"after"
      ]

children2FormatedString :: String -> SLA [NameClass] Pattern String
children2FormatedString :: [Char] -> SLA [NameClass] Pattern [Char]
children2FormatedString [Char]
name
    = SLA [NameClass] Pattern [Char] -> SLA [NameClass] Pattern [[Char]]
forall b c. SLA [NameClass] b c -> SLA [NameClass] b [c]
forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b [c]
listA ((Pattern -> [Pattern]) -> SLA [NameClass] Pattern Pattern
forall b c. (b -> [c]) -> SLA [NameClass] b c
forall (a :: * -> * -> *) b c. ArrowList a => (b -> [c]) -> a b c
arrL Pattern -> [Pattern]
getChildrenPattern SLA [NameClass] Pattern Pattern
-> SLA [NameClass] Pattern [Char] -> SLA [NameClass] Pattern [Char]
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> SLA [NameClass] Pattern [Char]
patternToFormatedString)
      SLA [NameClass] Pattern [[Char]]
-> ([[Char]] -> [Char]) -> SLA [NameClass] Pattern [Char]
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> (c -> d) -> a b d
>>^
      (\ [[Char]]
l -> [Char]
name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" (" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
formatStringListPatt [[Char]]
l [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
") " )

data2FormatedString :: SLA [NameClass] Pattern String
data2FormatedString :: SLA [NameClass] Pattern [Char]
data2FormatedString
    = (Pattern -> [Char]) -> SLA [NameClass] Pattern [Char]
forall b c. (b -> c) -> SLA [NameClass] b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr ( \ (Data Datatype
datatype ParamList
paramList) ->
            [Char]
"Data " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Datatype -> [Char]
datatype2String Datatype
datatype [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
            [Char] -> ParamList -> [Char]
mapping2String [Char]
"parameter" ParamList
paramList [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n"
          )

dataExcept2FormatedString :: SLA [NameClass] Pattern String
dataExcept2FormatedString :: SLA [NameClass] Pattern [Char]
dataExcept2FormatedString
 = (Pattern -> [Char]) -> SLA [NameClass] Pattern [Char]
forall b c. (b -> c) -> SLA [NameClass] b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr ( \ (DataExcept Datatype
datatype ParamList
paramList Pattern
_) ->
         [Char]
"DataExcept " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Datatype -> [Char]
forall a. Show a => a -> [Char]
show Datatype
datatype [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
         [Char] -> ParamList -> [Char]
mapping2String [Char]
"parameter" ParamList
paramList [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n "
       )
   SLA [NameClass] Pattern [Char]
-> SLA [NameClass] Pattern [Char]
-> SLA [NameClass] Pattern Datatype
forall b c c'.
SLA [NameClass] b c
-> SLA [NameClass] b c' -> SLA [NameClass] b (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&&
   ( (Pattern -> Pattern) -> SLA [NameClass] Pattern Pattern
forall b c. (b -> c) -> SLA [NameClass] b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (\ (DataExcept Datatype
_ ParamList
_ Pattern
p) -> Pattern
p) SLA [NameClass] Pattern Pattern
-> SLA [NameClass] Pattern [Char] -> SLA [NameClass] Pattern [Char]
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> SLA [NameClass] Pattern [Char]
patternToFormatedString )
   SLA [NameClass] Pattern Datatype
-> SLA [NameClass] Datatype [Char]
-> SLA [NameClass] Pattern [Char]
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
   ([Char] -> [Char] -> [Char]) -> SLA [NameClass] Datatype [Char]
forall b1 b2 c. (b1 -> b2 -> c) -> SLA [NameClass] (b1, b2) c
forall (a :: * -> * -> *) b1 b2 c.
ArrowList a =>
(b1 -> b2 -> c) -> a (b1, b2) c
arr2 [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
(++)


value2FormatedString :: SLA [NameClass] Pattern String
value2FormatedString :: SLA [NameClass] Pattern [Char]
value2FormatedString
 = (Pattern -> [Char]) -> SLA [NameClass] Pattern [Char]
forall b c. (b -> c) -> SLA [NameClass] b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr ((Pattern -> [Char]) -> SLA [NameClass] Pattern [Char])
-> (Pattern -> [Char]) -> SLA [NameClass] Pattern [Char]
forall a b. (a -> b) -> a -> b
$ \(Value Datatype
datatype [Char]
val Context
context) ->
           [Char]
"Value = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
val [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
", " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Datatype -> [Char]
datatype2String Datatype
datatype [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
           [Char]
"\n " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Context -> [Char]
context2String Context
context [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n"


element2FormatedString :: SLA [NameClass] Pattern String
element2FormatedString :: SLA [NameClass] Pattern [Char]
element2FormatedString
    = SLA [NameClass] Pattern (NameClass, [NameClass])
-> SLA [NameClass] Pattern [Char]
-> SLA [NameClass] Pattern [Char]
-> SLA [NameClass] Pattern [Char]
forall b c d.
SLA [NameClass] b c
-> SLA [NameClass] b d
-> SLA [NameClass] b d
-> SLA [NameClass] b d
forall (a :: * -> * -> *) b c d.
ArrowIf a =>
a b c -> a b d -> a b d -> a b d
ifA ( ((Pattern -> NameClass) -> SLA [NameClass] Pattern NameClass
forall b c. (b -> c) -> SLA [NameClass] b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr Pattern -> NameClass
getNameClassFromPattern SLA [NameClass] Pattern NameClass
-> SLA [NameClass] Pattern [NameClass]
-> SLA [NameClass] Pattern (NameClass, [NameClass])
forall b c c'.
SLA [NameClass] b c
-> SLA [NameClass] b c' -> SLA [NameClass] b (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& SLA [NameClass] Pattern [NameClass]
forall b. SLA [NameClass] b [NameClass]
forall s (a :: * -> * -> *) b. ArrowState s a => a b s
getState)
            SLA [NameClass] Pattern (NameClass, [NameClass])
-> SLA
     [NameClass] (NameClass, [NameClass]) (NameClass, [NameClass])
-> SLA [NameClass] Pattern (NameClass, [NameClass])
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
            ((NameClass, [NameClass]) -> Bool)
-> SLA
     [NameClass] (NameClass, [NameClass]) (NameClass, [NameClass])
forall b. (b -> Bool) -> SLA [NameClass] b b
forall (a :: * -> * -> *) b. ArrowList a => (b -> Bool) -> a b b
isA (\ (NameClass
nc, [NameClass]
liste) -> NameClass -> [NameClass] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem NameClass
nc [NameClass]
liste)
          )
      ( (Pattern -> NameClass) -> SLA [NameClass] Pattern NameClass
forall b c. (b -> c) -> SLA [NameClass] b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr Pattern -> NameClass
getNameClassFromPattern
        SLA [NameClass] Pattern NameClass
-> (NameClass -> [Char]) -> SLA [NameClass] Pattern [Char]
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> (c -> d) -> a b d
>>^
        ( \NameClass
nc -> [Char]
"reference to element " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ NameClass -> [Char]
nameClassToString NameClass
nc [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " )
      )
      ( ([NameClass] -> Pattern -> [NameClass])
-> SLA [NameClass] Pattern Pattern
forall b. ([NameClass] -> b -> [NameClass]) -> SLA [NameClass] b b
forall s (a :: * -> * -> *) b.
ArrowState s a =>
(s -> b -> s) -> a b b
changeState (\ [NameClass]
s Pattern
p -> (Pattern -> NameClass
getNameClassFromPattern Pattern
p) NameClass -> [NameClass] -> [NameClass]
forall a. a -> [a] -> [a]
: [NameClass]
s)
        SLA [NameClass] Pattern Pattern
-> SLA [NameClass] Pattern [Char] -> SLA [NameClass] Pattern [Char]
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
        [Char] -> SLA [NameClass] Pattern [Char]
createFormatedStringFromElement [Char]
"element"
      )


createFormatedStringFromElement :: String -> SLA [NameClass] Pattern String
createFormatedStringFromElement :: [Char] -> SLA [NameClass] Pattern [Char]
createFormatedStringFromElement [Char]
name
    = ( (Pattern -> NameClass) -> SLA [NameClass] Pattern NameClass
forall b c. (b -> c) -> SLA [NameClass] b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr Pattern -> NameClass
getNameClassFromPattern
        SLA [NameClass] Pattern NameClass
-> SLA [NameClass] Pattern [Char]
-> SLA [NameClass] Pattern (NameClass, [Char])
forall b c c'.
SLA [NameClass] b c
-> SLA [NameClass] b c' -> SLA [NameClass] b (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&&
        ( SLA [NameClass] Pattern [Char] -> SLA [NameClass] Pattern [[Char]]
forall b c. SLA [NameClass] b c -> SLA [NameClass] b [c]
forall (a :: * -> * -> *) b c. ArrowList a => a b c -> a b [c]
listA ((Pattern -> [Pattern]) -> SLA [NameClass] Pattern Pattern
forall b c. (b -> [c]) -> SLA [NameClass] b c
forall (a :: * -> * -> *) b c. ArrowList a => (b -> [c]) -> a b c
arrL Pattern -> [Pattern]
getChildrenPattern SLA [NameClass] Pattern Pattern
-> SLA [NameClass] Pattern [Char] -> SLA [NameClass] Pattern [Char]
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> SLA [NameClass] Pattern [Char]
patternToFormatedString)
          SLA [NameClass] Pattern [[Char]]
-> ([[Char]] -> [Char]) -> SLA [NameClass] Pattern [Char]
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> (c -> d) -> a b d
>>^
          [[Char]] -> [Char]
formatStringListId
        )
      )
      SLA [NameClass] Pattern (NameClass, [Char])
-> SLA [NameClass] (NameClass, [Char]) [Char]
-> SLA [NameClass] Pattern [Char]
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
      (NameClass -> [Char] -> [Char])
-> SLA [NameClass] (NameClass, [Char]) [Char]
forall b1 b2 c. (b1 -> b2 -> c) -> SLA [NameClass] (b1, b2) c
forall (a :: * -> * -> *) b1 b2 c.
ArrowList a =>
(b1 -> b2 -> c) -> a (b1, b2) c
arr2 (\ NameClass
nc [Char]
rl -> [Char]
name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ NameClass -> [Char]
nameClassToString NameClass
nc [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" (" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
rl [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")")


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

mapping2String :: String -> [(Prefix, Uri)] -> String
mapping2String :: [Char] -> ParamList -> [Char]
mapping2String [Char]
name ParamList
mapping
    = [Char]
name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
      ([Char] -> [Char]) -> [Char] -> [[Char]] -> [Char]
formatStringList [Char] -> [Char]
forall a. a -> a
id [Char]
", " ((Datatype -> [Char]) -> ParamList -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (\([Char]
a, [Char]
b) -> [Char]
a [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
b) ParamList
mapping)

datatype2String :: Datatype -> String
datatype2String :: Datatype -> [Char]
datatype2String ([Char]
lib, [Char]
localName)
    = [Char]
"datatypelibrary = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
getLib [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
", type = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
localName
    where
    getLib :: [Char]
getLib = if [Char]
lib [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"" then [Char]
relaxNamespace else [Char]
lib

context2String :: Context -> String
context2String :: Context -> [Char]
context2String ([Char]
base, ParamList
mapping)
    = [Char]
"context (base-uri = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
base [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
", " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
      [Char] -> ParamList -> [Char]
mapping2String [Char]
"namespace environment" ParamList
mapping [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"

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