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

{- |
   Module     : Text.XML.HXT.RelaxNG.Utils
   Copyright  : Copyright (C) 2008 Uwe Schmidt
   License    : MIT

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

   Helper functions for RelaxNG validation

-}

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

module Text.XML.HXT.RelaxNG.Utils
    ( isRelaxAnyURI
    , compareURI
    , normalizeURI
    , isNumber
    , isNmtoken
    , isName
    , formatStringList
    , formatStringListPatt
    , formatStringListId
    , formatStringListQuot
    , formatStringListPairs
    , formatStringListArr
    )
where

import Text.ParserCombinators.Parsec

import Text.XML.HXT.Parser.XmlCharParser
    ( SimpleXParser
    , withNormNewline
    )

import Text.XML.HXT.Parser.XmlTokenParser
    ( skipS0
    , nmtoken
    , name
    )

import Network.URI
    ( isURI
    , isRelativeReference
    , parseURI
    , URI(..)
    )

import Data.Maybe
    ( fromMaybe
    )

import Data.Char
    ( toLower
    )


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


-- | Tests whether a URI matches the Relax NG anyURI symbol

isRelaxAnyURI :: String -> Bool
isRelaxAnyURI s
    = s == "" ||
      ( isURI s && not (isRelativeReference s) &&
        ( let (URI _ _ path _ frag) = fromMaybe (URI "" Nothing "" "" "") $ parseURI s
          in (frag == "" && path /= "")
        )
      )


-- | Tests whether two URIs are equal after 'normalizeURI' is performed

compareURI :: String -> String -> Bool
compareURI uri1 uri2
    = normalizeURI uri1 == normalizeURI uri2


-- |  Converts all letters to the corresponding lower-case letter
-- and removes a trailing \"\/\"

normalizeURI :: String -> String
normalizeURI ""
    = ""
normalizeURI uri
    = map toLower ( if last uri == '/'
                    then init uri
                    else uri
                  )

checkByParsing  :: SimpleXParser String -> String -> Bool
checkByParsing p s
    = either (const False)
             (const True)
             (runParser p' (withNormNewline ()) "" s)
      where
      p' = do
           r <- p
           eof
           return r

-- | Tests whether a string matches a number [-](0-9)*
isNumber :: String -> Bool
isNumber
    = checkByParsing parseNumber'
    where
    parseNumber' :: SimpleXParser String
    parseNumber'
        = do
          skipS0
          m <- option "" (string "-")
          n <- many1 digit
          skipS0
          return $ m ++ n

isNmtoken       :: String -> Bool
isNmtoken    = checkByParsing nmtoken

isName  :: String -> Bool
isName  = checkByParsing name

{- |

Formats a list of strings into a single string.
The first parameter formats the elements, the 2. is inserted
between two elements.

example:

> formatStringList show ", " ["foo", "bar", "baz"] -> "foo", "bar", "baz"

-}

formatStringListPatt :: [String] -> String
formatStringListPatt
    = formatStringList (++ "-") ", "

formatStringListPairs :: [(String,String)] -> String
formatStringListPairs
    = formatStringList id ", "
      . map (\ (a, b) -> a ++ " = " ++ show b)

formatStringListQuot :: [String] -> String
formatStringListQuot
    = formatStringList show ", "

formatStringListId :: [String] -> String
formatStringListId
    = formatStringList id ", "

formatStringListArr :: [String] -> String
formatStringListArr
    = formatStringList show " -> "

formatStringList :: (String -> String) -> String -> [String] -> String
formatStringList _sf _sp []
    = ""
formatStringList sf spacer l
    = reverse $ drop (length spacer) $ reverse $
      foldr (\e -> ((if e /= "" then sf e ++ spacer else "") ++)) "" l

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