content: {-# 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
      = createPatternFromXmlTree
        >>^
        show
  
  
  -- | Returns a string representation of a nameclass.
  
  nameClassToString :: NameClass -> String
  nameClassToString AnyName
      = "AnyName"
  
  nameClassToString (AnyNameExcept nc)
      = "AnyNameExcept " ++ nameClassToString nc
  
  nameClassToString (Name uri local)
      = "{" ++ uri ++ "}" ++ local
  
  nameClassToString (NsName uri)
      = "{" ++ uri ++ "}"
  
  nameClassToString (NsNameExcept uri nc)
      = uri ++ "except (NsName) " ++ nameClassToString nc
  
  nameClassToString (NameClassChoice nc1 nc2)
      = nameClassToString nc1 ++ " " ++ nameClassToString nc2
  
  nameClassToString (NCError e)
      = "NameClass Error: " ++ 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
      = fromSLA [] pattern2PatternTree
        >>^
        (\p -> formatTree id p ++ "\n")
  
  
  -- | Returns a tree representation of the pattern structure.
  -- (see also: 'createPatternFromXmlTree' and 'patternToStringTree')
  
  xmlTreeToPatternStringTree :: LA XmlTree String
  xmlTreeToPatternStringTree
      = createPatternFromXmlTree
        >>>
        patternToStringTree
  
  
  pattern2PatternTree :: SLA [NameClass] Pattern PatternTree
  pattern2PatternTree
      = choiceA
        [ isA isRelaxEmpty      :-> (constA $ NTree "empty" [])
        , isA isRelaxNotAllowed :-> notAllowed2PatternTree
        , isA isRelaxText       :-> (constA $ NTree "text" [])
        , isA isRelaxChoice     :-> choice2PatternTree
        , isA isRelaxInterleave :-> children2PatternTree "interleave"
        , isA isRelaxGroup      :-> children2PatternTree "group"
        , isA isRelaxOneOrMore  :-> children2PatternTree "oneOrMore"
        , isA isRelaxList       :-> children2PatternTree "list"
        , isA isRelaxData       :-> data2PatternTree
        , isA isRelaxDataExcept :-> dataExcept2PatternTree
        , isA isRelaxValue      :-> value2PatternTree
        , isA isRelaxAttribute  :-> createPatternTreeFromElement "attribute"
        , isA isRelaxElement    :-> element2PatternTree
        , isA isRelaxAfter      :-> children2PatternTree "after"
        ]
  
  notAllowed2PatternTree :: SLA [NameClass] Pattern PatternTree
  notAllowed2PatternTree
      = arr $ \(NotAllowed (ErrMsg _l sl)) -> NTree "notAllowed" $ map (\ s -> NTree s []) sl
  
  
  data2PatternTree :: SLA [NameClass] Pattern PatternTree
  data2PatternTree
      = arr $ \ (Data d p) -> NTree "data" [ datatype2PatternTree d
                                           , mapping2PatternTree "parameter" p
                                           ]
  
  dataExcept2PatternTree :: SLA [NameClass] Pattern PatternTree
  dataExcept2PatternTree
      = this &&& (listA $ arrL getChildrenPattern >>> pattern2PatternTree)
        >>>
        arr2 ( \ (DataExcept d param _) pattern ->
               NTree "dataExcept" ([ datatype2PatternTree d
                                   , mapping2PatternTree "parameter" param
                                   ] ++ pattern)
             )
  
  value2PatternTree :: SLA [NameClass] Pattern PatternTree
  value2PatternTree
      = arr $ \ (Value d v c) -> NTree ("value = " ++ v) [ datatype2PatternTree d
                                                         , context2PatternTree c
                                                         ]
  
  
  createPatternTreeFromElement :: String -> SLA [NameClass] Pattern PatternTree
  createPatternTreeFromElement name
      = ( arr getNameClassFromPattern
          &&&
          listA (arrL getChildrenPattern >>> pattern2PatternTree)
        )
        >>>
        arr2 (\nc rl -> NTree (name ++ " " ++ show nc) rl)
  
  children2PatternTree :: String -> SLA [NameClass] Pattern PatternTree
  children2PatternTree name
      = listA (arrL getChildrenPattern >>> pattern2PatternTree)
        >>^
        (NTree name)
  
  choice2PatternTree :: SLA [NameClass] Pattern PatternTree
  choice2PatternTree
      = ifA ( -- wenn das zweite kind ein noch nicht ausgegebenes element ist,
              -- muss dieses anders behandelt werden
              -- nur fuer bessere formatierung des outputs
              arr (last . getChildrenPattern) >>> isA (isRelaxElement) >>>
              (arr getNameClassFromPattern &&& getState) >>>
              isA(\ (nc, liste) -> not $ elem nc liste)
            )
        ( -- element in status aufnehmen, wird dann nicht mehr vom erste kind ausgegeben
          arr getChildrenPattern
          >>>
          changeState (\s p -> (getNameClassFromPattern (last p)) : s)
          >>>
          ( ( head ^>> pattern2PatternTree )              -- erstes kind normal verarbeiten
            &&&                                           -- zweites kind, das element, verarbeiten
            ( last ^>> createPatternTreeFromElement "element" )
          )
          >>>
          arr2 ( \ l1 l2 -> NTree "choice" [l1, l2] )
        )
        ( children2PatternTree "choice" )
  
  
  element2PatternTree :: SLA [NameClass] Pattern PatternTree
  element2PatternTree
      = ifA ( (arr getNameClassFromPattern &&& getState)
              >>>
              isA (\ (nc, liste) -> elem nc liste)
            )
        ( arr getNameClassFromPattern
          >>>
          arr (\nc -> NTree ("reference to element " ++ show nc) [])
        )
        ( changeState (\ s p -> (getNameClassFromPattern p) : s)
          >>>
          createPatternTreeFromElement "element"
        )
  
  
  mapping2PatternTree :: String -> [(Prefix, Uri)] -> PatternTree
  mapping2PatternTree name mapping
      = NTree name (map (\(a, b) -> NTree (a ++ " = " ++ b) []) mapping)
  
  
  datatype2PatternTree :: Datatype -> PatternTree
  datatype2PatternTree dt
      = NTree (datatype2String dt) []
  
  
  context2PatternTree :: Context -> PatternTree
  context2PatternTree (base, mapping)
      = NTree "context" [ NTree ("base-uri = " ++ base) []
                        , mapping2PatternTree "namespace environment" mapping
                        ]
  
  -- ------------------------------------------------------------
  
  -- | Returns a formated string representation of the pattern structure.
  -- (see also: 'createPatternFromXmlTree' and 'patternToFormatedString')
  xmlTreeToPatternFormatedString :: LA XmlTree String
  xmlTreeToPatternFormatedString
      = createPatternFromXmlTree
        >>>
        fromSLA [] 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
      = choiceA
        [ isA isRelaxEmpty      :-> (constA " empty ")
        , isA isRelaxNotAllowed :-> (arr $ \ (NotAllowed errorEnv) -> show errorEnv)
        , isA isRelaxText       :-> (constA " text ")
        , isA isRelaxChoice     :-> children2FormatedString "choice"
        , isA isRelaxInterleave :-> children2FormatedString "interleave"
        , isA isRelaxGroup      :-> children2FormatedString "group"
        , isA isRelaxOneOrMore  :-> children2FormatedString "oneOrMore"
        , isA isRelaxList       :-> children2FormatedString "list"
        , isA isRelaxData       :-> data2FormatedString
        , isA isRelaxDataExcept :-> dataExcept2FormatedString
        , isA isRelaxValue      :-> value2FormatedString
        , isA isRelaxAttribute  :-> createFormatedStringFromElement "attribute"
        , isA isRelaxElement    :-> element2FormatedString
        , isA isRelaxAfter      :-> children2FormatedString "after"
        ]
  
  children2FormatedString :: String -> SLA [NameClass] Pattern String
  children2FormatedString name
      = listA (arrL getChildrenPattern >>> patternToFormatedString)
        >>^
        (\ l -> name ++ " (" ++ formatStringListPatt l ++ ") " )
  
  data2FormatedString :: SLA [NameClass] Pattern String
  data2FormatedString
      = arr ( \ (Data datatype paramList) ->
              "Data " ++ datatype2String datatype ++ "\n " ++
              mapping2String "parameter" paramList ++ "\n"
            )
  
  dataExcept2FormatedString :: SLA [NameClass] Pattern String
  dataExcept2FormatedString
   = arr ( \ (DataExcept datatype paramList _) ->
           "DataExcept " ++ show datatype ++ "\n " ++
           mapping2String "parameter" paramList ++ "\n "
         )
     &&&
     ( arr (\ (DataExcept _ _ p) -> p) >>> patternToFormatedString )
     >>>
     arr2 (++)
  
  
  value2FormatedString :: SLA [NameClass] Pattern String
  value2FormatedString
   = arr $ \(Value datatype val context) ->
             "Value = " ++ val ++ ", " ++ datatype2String datatype ++
             "\n " ++ context2String context ++ "\n"
  
  
  element2FormatedString :: SLA [NameClass] Pattern String
  element2FormatedString
      = ifA ( (arr getNameClassFromPattern &&& getState)
              >>>
              isA (\ (nc, liste) -> elem nc liste)
            )
        ( arr getNameClassFromPattern
          >>^
          ( \nc -> "reference to element " ++ nameClassToString nc ++ " " )
        )
        ( changeState (\ s p -> (getNameClassFromPattern p) : s)
          >>>
          createFormatedStringFromElement "element"
        )
  
  
  createFormatedStringFromElement :: String -> SLA [NameClass] Pattern String
  createFormatedStringFromElement name
      = ( arr getNameClassFromPattern
          &&&
          ( listA (arrL getChildrenPattern >>> patternToFormatedString)
            >>^
            formatStringListId
          )
        )
        >>>
        arr2 (\ nc rl -> name ++ " " ++ nameClassToString nc ++ " (" ++ rl ++ ")")
  
  
  -- ------------------------------------------------------------
  
  mapping2String :: String -> [(Prefix, Uri)] -> String
  mapping2String name mapping
      = name ++ ": " ++
        formatStringList id ", " (map (\(a, b) -> a ++ " = " ++ b) mapping)
  
  datatype2String :: Datatype -> String
  datatype2String (lib, localName)
      = "datatypelibrary = " ++ getLib ++ ", type = " ++ localName
      where
      getLib = if lib == "" then relaxNamespace else lib
  
  context2String :: Context -> String
  context2String (base, mapping)
      = "context (base-uri = " ++ base ++ ", " ++
        mapping2String "namespace environment" mapping ++ ")"
  
  -- ------------------------------------------------------------
  