{-# 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 ++ ")"

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