{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
#if (__GLASGOW_HASKELL__ >= 802)
{-# LANGUAGE DerivingStrategies #-}
#endif
module Swish.QName
( QName
, LName
, emptyLName
, newLName
, getLName
, newQName
, qnameFromURI
, getNamespace
, getLocalName
, getQNameURI
, qnameFromFilePath
)
where
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
#if (__GLASGOW_HASKELL__ >= 802)
stock
#endif
(LName -> LName -> Bool
(LName -> LName -> Bool) -> (LName -> LName -> Bool) -> Eq LName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LName -> LName -> Bool
== :: LName -> LName -> Bool
$c/= :: LName -> LName -> Bool
/= :: 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
$ccompare :: LName -> LName -> Ordering
compare :: LName -> LName -> Ordering
$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
>= :: LName -> LName -> Bool
$cmax :: LName -> LName -> LName
max :: LName -> LName -> LName
$cmin :: LName -> LName -> LName
min :: LName -> LName -> LName
Ord)
instance Show LName where
show :: LName -> [Char]
show (LName Text
t) = Text -> [Char]
forall a. Show a => a -> [Char]
show Text
t
instance IsString LName where
fromString :: [Char] -> LName
fromString [Char]
s =
LName -> Maybe LName -> LName
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> LName
forall a. HasCallStack => [Char] -> a
error ([Char]
"Invalid local name: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
s)) (Maybe LName -> LName) -> Maybe LName -> LName
forall a b. (a -> b) -> a -> b
$
Text -> Maybe LName
newLName ([Char] -> Text
T.pack [Char]
s)
emptyLName :: LName
emptyLName :: LName
emptyLName = Text -> LName
LName Text
""
newLName :: T.Text -> Maybe LName
newLName :: Text -> Maybe LName
newLName Text
l = if (Char -> Bool) -> Text -> Bool
T.any (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ' 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 Text
l) = Text
l
data QName = QName !InternedURI URI LName
instance IsString QName where
fromString :: [Char] -> QName
fromString [Char]
s =
QName -> Maybe QName -> QName
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> QName
forall a. HasCallStack => [Char] -> a
error ([Char]
"QName conversion given an invalid URI: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
s))
([Char] -> Maybe URI
parseURIReference [Char]
s Maybe URI -> (URI -> Maybe QName) -> Maybe QName
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= URI -> Maybe QName
qnameFromURI)
instance Eq QName where
QName
u1 == :: QName -> QName -> Bool
== 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 -> [Char]
show (QName InternedURI
u URI
_ LName
_) = [Char]
"<" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ InternedURI -> [Char]
forall a. Show a => a -> [Char]
show InternedURI
u [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
">"
newQName ::
URI
-> LName
-> QName
newQName :: URI -> LName -> QName
newQName URI
ns l :: LName
l@(LName Text
local) =
let lstr :: [Char]
lstr = Text -> [Char]
T.unpack Text
local
uristr :: [Char]
uristr = URI -> [Char]
forall a. Show a => a -> [Char]
show URI
ns [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
lstr
in case [Char] -> Maybe URI
parseURIReference [Char]
uristr of
Just URI
uri -> InternedURI -> URI -> LName -> QName
QName (Uninterned InternedURI -> InternedURI
forall t. Interned t => Uninterned t -> t
intern Uninterned InternedURI
URI
uri) URI
ns LName
l
Maybe URI
_ -> [Char] -> QName
forall a. HasCallStack => [Char] -> a
error ([Char] -> QName) -> [Char] -> QName
forall a b. (a -> b) -> a -> b
$ [Char]
"Unable to combine " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ URI -> [Char]
forall a. Show a => a -> [Char]
show URI
ns [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" with " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
lstr
qnameFromURI ::
URI
-> Maybe QName
qnameFromURI :: URI -> Maybe QName
qnameFromURI URI
uri =
let uf :: [Char]
uf = URI -> [Char]
uriFragment URI
uri
up :: [Char]
up = URI -> [Char]
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 Uninterned InternedURI
URI
uri)
in case [Char]
uf of
[Char]
"#" -> Maybe QName
q0
Char
'#':[Char]
xs -> URI -> LName -> QName
start (URI
uri {uriFragment = "#"}) (LName -> QName) -> Maybe LName -> Maybe QName
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Text -> Maybe LName
newLName ([Char] -> Text
T.pack [Char]
xs)
[Char]
"" -> case (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/') (ShowS
forall a. [a] -> [a]
reverse [Char]
up) of
([Char]
"",[Char]
_) -> Maybe QName
q0
([Char]
_,[Char]
"") -> Maybe QName
q0
([Char]
rlname,[Char]
rpath) ->
URI -> LName -> QName
start (URI
uri {uriPath = reverse rpath}) (LName -> QName) -> Maybe LName -> Maybe QName
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap`
Text -> Maybe LName
newLName ([Char] -> Text
T.pack (ShowS
forall a. [a] -> [a]
reverse [Char]
rlname))
[Char]
_ -> Maybe QName
forall a. Maybe a
Nothing
getNamespace :: QName -> URI
getNamespace :: QName -> URI
getNamespace (QName InternedURI
_ URI
ns LName
_) = URI
ns
getLocalName :: QName -> LName
getLocalName :: QName -> LName
getLocalName (QName InternedURI
_ URI
_ LName
l) = LName
l
getQNameURI :: QName -> URI
getQNameURI :: QName -> URI
getQNameURI (QName InternedURI
u URI
_ LName
_) = InternedURI -> Uninterned InternedURI
forall t. Uninternable t => t -> Uninterned t
unintern InternedURI
u
qnameFromFilePath :: FilePath -> IO QName
qnameFromFilePath :: [Char] -> IO QName
qnameFromFilePath [Char]
fname = do
[Char]
ipath <- [Char] -> IO [Char]
canonicalizePath [Char]
fname
let ([Char]
dname, [Char]
lname) = [Char] -> ([Char], [Char])
splitFileName [Char]
ipath
nsuri :: URI
nsuri = [Char] -> Maybe URIAuth -> [Char] -> [Char] -> [Char] -> URI
URI [Char]
"file:" Maybe URIAuth
emptyAuth [Char]
dname [Char]
"" [Char]
""
uri :: URI
uri = [Char] -> Maybe URIAuth -> [Char] -> [Char] -> [Char] -> URI
URI [Char]
"file:" Maybe URIAuth
emptyAuth [Char]
ipath [Char]
"" [Char]
""
case [Char]
lname of
[Char]
"" -> QName -> IO QName
forall a. a -> IO a
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 Uninterned InternedURI
URI
nsuri) URI
nsuri LName
emptyLName
[Char]
_ -> QName -> IO QName
forall a. a -> IO a
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 Uninterned InternedURI
URI
uri) URI
nsuri (Text -> LName
LName ([Char] -> Text
T.pack [Char]
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
$ [Char] -> [Char] -> [Char] -> URIAuth
URIAuth [Char]
"" [Char]
"" [Char]
""