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

{- |
   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 :: String -> Bool
isRelaxAnyURI s :: String
s
    = String
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "" Bool -> Bool -> Bool
||
      ( String -> Bool
isURI String
s Bool -> Bool -> Bool
&& Bool -> Bool
not (String -> Bool
isRelativeReference String
s) Bool -> Bool -> Bool
&&
        ( let (URI _ _ path :: String
path _ frag :: String
frag) = URI -> Maybe URI -> URI
forall a. a -> Maybe a -> a
fromMaybe (String -> Maybe URIAuth -> String -> String -> String -> URI
URI "" Maybe URIAuth
forall a. Maybe a
Nothing "" "" "") (Maybe URI -> URI) -> Maybe URI -> URI
forall a b. (a -> b) -> a -> b
$ String -> Maybe URI
parseURI String
s
          in (String
frag String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "" Bool -> Bool -> Bool
&& String
path String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= "")
        )
      )


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

compareURI :: String -> String -> Bool
compareURI :: String -> String -> Bool
compareURI uri1 :: String
uri1 uri2 :: String
uri2
    = String -> String
normalizeURI String
uri1 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String -> String
normalizeURI String
uri2


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

normalizeURI :: String -> String
normalizeURI :: String -> String
normalizeURI ""
    = ""
normalizeURI uri :: String
uri
    = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower ( if String -> Char
forall a. [a] -> a
last String
uri Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '/'
                    then String -> String
forall a. [a] -> [a]
init String
uri
                    else String
uri
                  )

checkByParsing  :: SimpleXParser String -> String -> Bool
checkByParsing :: SimpleXParser String -> String -> Bool
checkByParsing p :: SimpleXParser String
p s :: String
s
    = (ParseError -> Bool)
-> (String -> Bool) -> Either ParseError String -> Bool
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Bool -> ParseError -> Bool
forall a b. a -> b -> a
const Bool
False)
             (Bool -> String -> Bool
forall a b. a -> b -> a
const Bool
True)
             (SimpleXParser String
-> XPState () -> String -> String -> Either ParseError String
forall tok st a.
GenParser tok st a -> st -> String -> [tok] -> Either ParseError a
runParser SimpleXParser String
p' (() -> XPState ()
forall a. a -> XPState a
withNormNewline ()) "" String
s)
      where
      p' :: SimpleXParser String
p' = do
           String
r <- SimpleXParser String
p
           ParsecT String (XPState ()) Identity ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof
           String -> SimpleXParser String
forall (m :: * -> *) a. Monad m => a -> m a
return String
r

-- | Tests whether a string matches a number [-](0-9)*
isNumber :: String -> Bool
isNumber :: String -> Bool
isNumber
    = SimpleXParser String -> String -> Bool
checkByParsing SimpleXParser String
parseNumber'
    where
    parseNumber' :: SimpleXParser String
    parseNumber' :: SimpleXParser String
parseNumber'
        = do
          ParsecT String (XPState ()) Identity ()
forall s. XParser s ()
skipS0
          String
m <- String -> SimpleXParser String -> SimpleXParser String
forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option "" (String -> SimpleXParser String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string "-")
          String
n <- ParsecT String (XPState ()) Identity Char -> SimpleXParser String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT String (XPState ()) Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit
          ParsecT String (XPState ()) Identity ()
forall s. XParser s ()
skipS0
          String -> SimpleXParser String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> SimpleXParser String) -> String -> SimpleXParser String
forall a b. (a -> b) -> a -> b
$ String
m String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
n

isNmtoken       :: String -> Bool
isNmtoken :: String -> Bool
isNmtoken    = SimpleXParser String -> String -> Bool
checkByParsing SimpleXParser String
forall s. XParser s String
nmtoken

isName  :: String -> Bool
isName :: String -> Bool
isName  = SimpleXParser String -> String -> Bool
checkByParsing SimpleXParser String
forall s. XParser s String
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 :: [String] -> String
formatStringListPatt
    = (String -> String) -> String -> [String] -> String
formatStringList (String -> String -> String
forall a. [a] -> [a] -> [a]
++ "-") ", "

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

formatStringListQuot :: [String] -> String
formatStringListQuot :: [String] -> String
formatStringListQuot
    = (String -> String) -> String -> [String] -> String
formatStringList String -> String
forall a. Show a => a -> String
show ", "

formatStringListId :: [String] -> String
formatStringListId :: [String] -> String
formatStringListId
    = (String -> String) -> String -> [String] -> String
formatStringList String -> String
forall a. a -> a
id ", "

formatStringListArr :: [String] -> String
formatStringListArr :: [String] -> String
formatStringListArr
    = (String -> String) -> String -> [String] -> String
formatStringList String -> String
forall a. Show a => a -> String
show " -> "

formatStringList :: (String -> String) -> String -> [String] -> String
formatStringList :: (String -> String) -> String -> [String] -> String
formatStringList _sf :: String -> String
_sf _sp :: String
_sp []
    = ""
formatStringList sf :: String -> String
sf spacer :: String
spacer l :: [String]
l
    = String -> String
forall a. [a] -> [a]
reverse (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Int -> String -> String
forall a. Int -> [a] -> [a]
drop (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
spacer) (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. [a] -> [a]
reverse (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$
      (String -> String -> String) -> String -> [String] -> String
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\e :: String
e -> ((if String
e String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= "" then String -> String
sf String
e String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
spacer else "") String -> String -> String
forall a. [a] -> [a] -> [a]
++)) "" [String]
l

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