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

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


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

compareURI :: String -> String -> Bool
compareURI :: String -> String -> Bool
compareURI String
uri1 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 String
""
    = String
""
normalizeURI String
uri
    = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower ( if String -> Char
forall a. HasCallStack => [a] -> a
last String
uri Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/'
                    then String -> String
forall a. HasCallStack => [a] -> [a]
init String
uri
                    else String
uri
                  )

checkByParsing  :: SimpleXParser String -> String -> Bool
checkByParsing :: SimpleXParser String -> String -> Bool
checkByParsing SimpleXParser String
p 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
"" 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 a. a -> ParsecT String (XPState ()) Identity a
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
"" (String -> SimpleXParser String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
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 a. a -> ParsecT String (XPState ()) Identity a
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]
++ String
"-") String
", "

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)] -> 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 (\ (String
a, String
b) -> String
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" = " 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 String
", "

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

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

formatStringList :: (String -> String) -> String -> [String] -> String
formatStringList :: (String -> String) -> String -> [String] -> String
formatStringList String -> String
_sf String
_sp []
    = String
""
formatStringList String -> String
sf String
spacer [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 a. [a] -> 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 a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\String
e -> ((if String
e String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"" then String -> String
sf String
e String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
spacer else String
"") String -> String -> String
forall a. [a] -> [a] -> [a]
++)) String
"" [String]
l

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