{-# LANGUAGE OverloadedStrings #-}
module Swish.QName
( QName
, LName
, emptyLName
, newLName
, getLName
, newQName
, qnameFromURI
, getNamespace
, getLocalName
, getQNameURI
, qnameFromFilePath
)
where
import Control.Monad (liftM)
import Data.Char (isAscii)
import Data.Maybe (fromMaybe)
import Data.Interned (intern, unintern)
import Data.Interned.URI (InternedURI)
import Data.Ord (comparing)
import Data.String (IsString(..))
import Network.URI (URI(..), URIAuth(..), parseURIReference)
import System.Directory (canonicalizePath)
import System.FilePath (splitFileName)
import qualified Data.Text as T
newtype LName = LName T.Text
deriving (LName -> LName -> Bool
(LName -> LName -> Bool) -> (LName -> LName -> Bool) -> Eq LName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LName -> LName -> Bool
$c/= :: LName -> LName -> Bool
== :: LName -> LName -> Bool
$c== :: LName -> LName -> Bool
Eq, Eq LName
Eq LName =>
(LName -> LName -> Ordering)
-> (LName -> LName -> Bool)
-> (LName -> LName -> Bool)
-> (LName -> LName -> Bool)
-> (LName -> LName -> Bool)
-> (LName -> LName -> LName)
-> (LName -> LName -> LName)
-> Ord LName
LName -> LName -> Bool
LName -> LName -> Ordering
LName -> LName -> LName
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: LName -> LName -> LName
$cmin :: LName -> LName -> LName
max :: LName -> LName -> LName
$cmax :: LName -> LName -> LName
>= :: LName -> LName -> Bool
$c>= :: LName -> LName -> Bool
> :: LName -> LName -> Bool
$c> :: LName -> LName -> Bool
<= :: LName -> LName -> Bool
$c<= :: LName -> LName -> Bool
< :: LName -> LName -> Bool
$c< :: LName -> LName -> Bool
compare :: LName -> LName -> Ordering
$ccompare :: LName -> LName -> Ordering
$cp1Ord :: Eq LName
Ord)
instance Show LName where
show :: LName -> String
show (LName t :: Text
t) = Text -> String
forall a. Show a => a -> String
show Text
t
instance IsString LName where
fromString :: String -> LName
fromString s :: String
s =
LName -> Maybe LName -> LName
forall a. a -> Maybe a -> a
fromMaybe (String -> LName
forall a. HasCallStack => String -> a
error ("Invalid local name: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s)) (Maybe LName -> LName) -> Maybe LName -> LName
forall a b. (a -> b) -> a -> b
$
Text -> Maybe LName
newLName (String -> Text
T.pack String
s)
emptyLName :: LName
emptyLName :: LName
emptyLName = Text -> LName
LName ""
newLName :: T.Text -> Maybe LName
newLName :: Text -> Maybe LName
newLName l :: Text
l = if (Char -> Bool) -> Text -> Bool
T.any (\c :: Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ' ' Bool -> Bool -> Bool
|| Bool -> Bool
not (Char -> Bool
isAscii Char
c)) Text
l then Maybe LName
forall a. Maybe a
Nothing else LName -> Maybe LName
forall a. a -> Maybe a
Just (Text -> LName
LName Text
l)
getLName :: LName -> T.Text
getLName :: LName -> Text
getLName (LName l :: Text
l) = Text
l
data QName = QName !InternedURI URI LName
instance IsString QName where
fromString :: String -> QName
fromString s :: String
s =
QName -> Maybe QName -> QName
forall a. a -> Maybe a -> a
fromMaybe (String -> QName
forall a. HasCallStack => String -> a
error ("QName conversion given an invalid URI: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s))
(String -> Maybe URI
parseURIReference String
s Maybe URI -> (URI -> Maybe QName) -> Maybe QName
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= URI -> Maybe QName
qnameFromURI)
instance Eq QName where
u1 :: QName
u1 == :: QName -> QName -> Bool
== u2 :: QName
u2 = QName -> URI
getQNameURI QName
u1 URI -> URI -> Bool
forall a. Eq a => a -> a -> Bool
== QName -> URI
getQNameURI QName
u2
instance Ord QName where
compare :: QName -> QName -> Ordering
compare = (QName -> URI) -> QName -> QName -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing QName -> URI
getQNameURI
instance Show QName where
show :: QName -> String
show (QName u :: InternedURI
u _ _) = "<" String -> ShowS
forall a. [a] -> [a] -> [a]
++ InternedURI -> String
forall a. Show a => a -> String
show InternedURI
u String -> ShowS
forall a. [a] -> [a] -> [a]
++ ">"
newQName ::
URI
-> LName
-> QName
newQName :: URI -> LName -> QName
newQName ns :: URI
ns l :: LName
l@(LName local :: Text
local) =
let lstr :: String
lstr = Text -> String
T.unpack Text
local
uristr :: String
uristr = URI -> String
forall a. Show a => a -> String
show URI
ns String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
lstr
in case String -> Maybe URI
parseURIReference String
uristr of
Just uri :: URI
uri -> InternedURI -> URI -> LName -> QName
QName (Uninterned InternedURI -> InternedURI
forall t. Interned t => Uninterned t -> t
intern URI
Uninterned InternedURI
uri) URI
ns LName
l
_ -> String -> QName
forall a. HasCallStack => String -> a
error (String -> QName) -> String -> QName
forall a b. (a -> b) -> a -> b
$ "Unable to combine " String -> ShowS
forall a. [a] -> [a] -> [a]
++ URI -> String
forall a. Show a => a -> String
show URI
ns String -> ShowS
forall a. [a] -> [a] -> [a]
++ " with " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
lstr
qnameFromURI ::
URI
-> Maybe QName
qnameFromURI :: URI -> Maybe QName
qnameFromURI uri :: URI
uri =
let uf :: String
uf = URI -> String
uriFragment URI
uri
up :: String
up = URI -> String
uriPath URI
uri
q0 :: Maybe QName
q0 = QName -> Maybe QName
forall a. a -> Maybe a
Just (QName -> Maybe QName) -> QName -> Maybe QName
forall a b. (a -> b) -> a -> b
$ URI -> LName -> QName
start URI
uri LName
emptyLName
start :: URI -> LName -> QName
start = InternedURI -> URI -> LName -> QName
QName (Uninterned InternedURI -> InternedURI
forall t. Interned t => Uninterned t -> t
intern URI
Uninterned InternedURI
uri)
in case String
uf of
"#" -> Maybe QName
q0
'#':xs :: String
xs -> URI -> LName -> QName
start (URI
uri {uriFragment :: String
uriFragment = "#"}) (LName -> QName) -> Maybe LName -> Maybe QName
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` Text -> Maybe LName
newLName (String -> Text
T.pack String
xs)
"" -> case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
=='/') (ShowS
forall a. [a] -> [a]
reverse String
up) of
("",_) -> Maybe QName
q0
(_,"") -> Maybe QName
q0
(rlname :: String
rlname,rpath :: String
rpath) ->
URI -> LName -> QName
start (URI
uri {uriPath :: String
uriPath = ShowS
forall a. [a] -> [a]
reverse String
rpath}) (LName -> QName) -> Maybe LName -> Maybe QName
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM`
Text -> Maybe LName
newLName (String -> Text
T.pack (ShowS
forall a. [a] -> [a]
reverse String
rlname))
_ -> Maybe QName
forall a. Maybe a
Nothing
getNamespace :: QName -> URI
getNamespace :: QName -> URI
getNamespace (QName _ ns :: URI
ns _) = URI
ns
getLocalName :: QName -> LName
getLocalName :: QName -> LName
getLocalName (QName _ _ l :: LName
l) = LName
l
getQNameURI :: QName -> URI
getQNameURI :: QName -> URI
getQNameURI (QName u :: InternedURI
u _ _) = InternedURI -> Uninterned InternedURI
forall t. Uninternable t => t -> Uninterned t
unintern InternedURI
u
qnameFromFilePath :: FilePath -> IO QName
qnameFromFilePath :: String -> IO QName
qnameFromFilePath fname :: String
fname = do
String
ipath <- String -> IO String
canonicalizePath String
fname
let (dname :: String
dname, lname :: String
lname) = String -> (String, String)
splitFileName String
ipath
nsuri :: URI
nsuri = String -> Maybe URIAuth -> String -> String -> String -> URI
URI "file:" Maybe URIAuth
emptyAuth String
dname "" ""
uri :: URI
uri = String -> Maybe URIAuth -> String -> String -> String -> URI
URI "file:" Maybe URIAuth
emptyAuth String
ipath "" ""
case String
lname of
"" -> QName -> IO QName
forall (m :: * -> *) a. Monad m => a -> m a
return (QName -> IO QName) -> QName -> IO QName
forall a b. (a -> b) -> a -> b
$ InternedURI -> URI -> LName -> QName
QName (Uninterned InternedURI -> InternedURI
forall t. Interned t => Uninterned t -> t
intern URI
Uninterned InternedURI
nsuri) URI
nsuri LName
emptyLName
_ -> QName -> IO QName
forall (m :: * -> *) a. Monad m => a -> m a
return (QName -> IO QName) -> QName -> IO QName
forall a b. (a -> b) -> a -> b
$ InternedURI -> URI -> LName -> QName
QName (Uninterned InternedURI -> InternedURI
forall t. Interned t => Uninterned t -> t
intern URI
Uninterned InternedURI
uri) URI
nsuri (Text -> LName
LName (String -> Text
T.pack String
lname))
emptyAuth :: Maybe URIAuth
emptyAuth :: Maybe URIAuth
emptyAuth = URIAuth -> Maybe URIAuth
forall a. a -> Maybe a
Just (URIAuth -> Maybe URIAuth) -> URIAuth -> Maybe URIAuth
forall a b. (a -> b) -> a -> b
$ String -> String -> String -> URIAuth
URIAuth "" "" ""