{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Swish.RDF.Parser.Utils
( SpecialMap
, prefixTable, specialTable
, runParserWithError
, ParseResult
, ignore
, char
, ichar
, string
, stringT
, symbol
, isymbol
, lexeme
, notFollowedBy
, whiteSpace
, skipMany
, skipMany1
, endBy
, sepEndBy
, sepEndBy1
, manyTill
, noneOf
, eoln
, fullStop
, hex4
, hex8
, appendURIs
)
where
import Swish.Namespace (Namespace, makeNamespace, ScopedName)
import Swish.RDF.Graph (RDFGraph)
import Swish.RDF.Vocabulary
( namespaceRDF
, namespaceRDFS
, namespaceRDFD
, namespaceOWL
, namespaceLOG
, rdfType
, rdfFirst, rdfRest, rdfNil
, owlSameAs, logImplies
, defaultBase
)
import Data.Char (isSpace, isHexDigit, chr)
#if MIN_VERSION_base(4, 7, 0)
import Data.Functor (($>))
#endif
import Data.Maybe (fromMaybe, fromJust)
import Network.URI (URI(..), relativeTo, parseURIReference)
import Text.ParserCombinators.Poly.StateText
import qualified Data.Map as M
import qualified Data.Text as T
import qualified Data.Text.Lazy as L
import qualified Data.Text.Read as R
#if !MIN_VERSION_base(4, 7, 0)
($>) :: Functor f => f a -> b -> f b
($>) = flip (<$)
#endif
appendURIs ::
URI
-> URI
-> Either String URI
appendURIs :: URI -> URI -> Either String URI
appendURIs URI
base URI
uri =
case URI -> String
uriScheme URI
uri of
String
"" -> URI -> Either String URI
forall a b. b -> Either a b
Right (URI -> Either String URI) -> URI -> Either String URI
forall a b. (a -> b) -> a -> b
$ URI
uri URI -> URI -> URI
`relativeTo` URI
base
String
_ -> URI -> Either String URI
forall a b. b -> Either a b
Right URI
uri
type SpecialMap = M.Map String ScopedName
prefixTable :: [Namespace]
prefixTable :: [Namespace]
prefixTable = [ Namespace
namespaceRDF
, Namespace
namespaceRDFS
, Namespace
namespaceRDFD
, Namespace
namespaceOWL
, Namespace
namespaceLOG
, Maybe Text -> URI -> Namespace
makeNamespace Maybe Text
forall a. Maybe a
Nothing (URI -> Namespace) -> URI -> Namespace
forall a b. (a -> b) -> a -> b
$ Maybe URI -> URI
forall a. HasCallStack => Maybe a -> a
fromJust (String -> Maybe URI
parseURIReference String
"#")
]
specialTable ::
Maybe ScopedName
-> [(String,ScopedName)]
specialTable :: Maybe ScopedName -> [(String, ScopedName)]
specialTable Maybe ScopedName
mbase =
[ (String
"a", ScopedName
rdfType ),
(String
"equals", ScopedName
owlSameAs ),
(String
"implies", ScopedName
logImplies ),
(String
"listfirst", ScopedName
rdfFirst ),
(String
"listrest", ScopedName
rdfRest ),
(String
"listnull", ScopedName
rdfNil ),
(String
"base", ScopedName -> Maybe ScopedName -> ScopedName
forall a. a -> Maybe a -> a
fromMaybe ScopedName
defaultBase Maybe ScopedName
mbase )
]
runParserWithError ::
Parser a b
-> a
-> L.Text
-> Either String b
runParserWithError :: Parser a b -> a -> Text -> Either String b
runParserWithError Parser a b
parser a
state0 Text
input =
let (Either String b
result, a
_, Text
unparsed) = Parser a b -> a -> Text -> (Either String b, a, Text)
forall s a. Parser s a -> s -> Text -> (Either String a, s, Text)
runParser Parser a b
parser a
state0 Text
input
econtext :: String
econtext = if Text -> Bool
L.null Text
unparsed
then String
"\n(at end of the text)\n"
else String
"\nRemaining input:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
case Text -> Int64 -> Ordering
L.compareLength Text
unparsed Int64
40 of
Ordering
GT -> Text -> String
L.unpack (Int64 -> Text -> Text
L.take Int64
40 Text
unparsed) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"..."
Ordering
_ -> Text -> String
L.unpack Text
unparsed
in case Either String b
result of
Left String
emsg -> String -> Either String b
forall a b. a -> Either a b
Left (String -> Either String b) -> String -> Either String b
forall a b. (a -> b) -> a -> b
$ String
emsg String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
econtext
Either String b
_ -> Either String b
result
type ParseResult = Either String RDFGraph
ignore :: (Applicative f) => f a -> f ()
ignore :: f a -> f ()
ignore f a
f = f a
f f a -> () -> f ()
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ()
char :: Char -> Parser s Char
char :: Char -> Parser s Char
char Char
c = (Char -> Bool) -> Parser s Char
forall s. (Char -> Bool) -> Parser s Char
satisfy (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
c)
ichar :: Char -> Parser s ()
ichar :: Char -> Parser s ()
ichar = Parser s Char -> Parser s ()
forall (f :: * -> *) a. Applicative f => f a -> f ()
ignore (Parser s Char -> Parser s ())
-> (Char -> Parser s Char) -> Char -> Parser s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Parser s Char
forall s. Char -> Parser s Char
char
string :: String -> Parser s String
string :: String -> Parser s String
string = (Char -> Parser s Char) -> String -> Parser s String
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Char -> Parser s Char
forall s. Char -> Parser s Char
char
stringT :: T.Text -> Parser s T.Text
stringT :: Text -> Parser s Text
stringT Text
s = String -> Parser s String
forall s. String -> Parser s String
string (Text -> String
T.unpack Text
s) Parser s String -> Parser s Text -> Parser s Text
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Text -> Parser s Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
s
skipMany :: Parser s a -> Parser s ()
skipMany :: Parser s a -> Parser s ()
skipMany = Parser s [a] -> Parser s ()
forall (f :: * -> *) a. Applicative f => f a -> f ()
ignore (Parser s [a] -> Parser s ())
-> (Parser s a -> Parser s [a]) -> Parser s a -> Parser s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser s a -> Parser s [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many
skipMany1 :: Parser s a -> Parser s ()
skipMany1 :: Parser s a -> Parser s ()
skipMany1 = Parser s [a] -> Parser s ()
forall (f :: * -> *) a. Applicative f => f a -> f ()
ignore (Parser s [a] -> Parser s ())
-> (Parser s a -> Parser s [a]) -> Parser s a -> Parser s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser s a -> Parser s [a]
forall (p :: * -> *) a. PolyParse p => p a -> p [a]
many1
endBy ::
Parser s a
-> Parser s b
-> Parser s [a]
endBy :: Parser s a -> Parser s b -> Parser s [a]
endBy Parser s a
p Parser s b
sep = Parser s a -> Parser s [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Parser s a
p Parser s a -> Parser s b -> Parser s a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser s b
sep)
sepEndBy ::
Parser s a
-> Parser s b
-> Parser s [a]
sepEndBy :: Parser s a -> Parser s b -> Parser s [a]
sepEndBy Parser s a
p Parser s b
sep = Parser s a -> Parser s b -> Parser s [a]
forall s a b. Parser s a -> Parser s b -> Parser s [a]
sepEndBy1 Parser s a
p Parser s b
sep Parser s [a] -> Parser s [a] -> Parser s [a]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [a] -> Parser s [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
sepEndBy1 ::
Parser s a
-> Parser s b
-> Parser s [a]
sepEndBy1 :: Parser s a -> Parser s b -> Parser s [a]
sepEndBy1 Parser s a
p Parser s b
sep = do
a
x <- Parser s a
p
(Parser s b
sep Parser s b -> Parser s [a] -> Parser s [a]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ((a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:) ([a] -> [a]) -> Parser s [a] -> Parser s [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser s a -> Parser s b -> Parser s [a]
forall s a b. Parser s a -> Parser s b -> Parser s [a]
sepEndBy Parser s a
p Parser s b
sep)) Parser s [a] -> Parser s [a] -> Parser s [a]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [a] -> Parser s [a]
forall (m :: * -> *) a. Monad m => a -> m a
return [a
x]
manyTill ::
Parser s a
-> Parser s b
-> Parser s [a]
manyTill :: Parser s a -> Parser s b -> Parser s [a]
manyTill Parser s a
p Parser s b
end = Parser s [a]
go
where
go :: Parser s [a]
go = (Parser s b
end Parser s b -> [a] -> Parser s [a]
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> [])
Parser s [a] -> Parser s [a] -> Parser s [a]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
((:) (a -> [a] -> [a]) -> Parser s a -> Parser s ([a] -> [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser s a
p Parser s ([a] -> [a]) -> Parser s [a] -> Parser s [a]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser s [a]
go)
noneOf :: String -> Parser s Char
noneOf :: String -> Parser s Char
noneOf String
istr = (Char -> Bool) -> Parser s Char
forall s. (Char -> Bool) -> Parser s Char
satisfy (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` String
istr)
fullStop :: Parser s ()
fullStop :: Parser s ()
fullStop = Char -> Parser s ()
forall s. Char -> Parser s ()
ichar Char
'.'
eoln :: Parser s ()
eoln :: Parser s ()
eoln = Parser s String -> Parser s ()
forall (f :: * -> *) a. Applicative f => f a -> f ()
ignore ([Parser s String] -> Parser s String
forall (p :: * -> *) a. PolyParse p => [p a] -> p a
oneOf [String -> Parser s String
forall s. String -> Parser s String
string String
"\r\n", String -> Parser s String
forall s. String -> Parser s String
string String
"\r", String -> Parser s String
forall s. String -> Parser s String
string String
"\n"])
notFollowedBy :: (Char -> Bool) -> Parser s ()
notFollowedBy :: (Char -> Bool) -> Parser s ()
notFollowedBy Char -> Bool
p = do
Char
c <- Parser s Char
forall s. Parser s Char
next
if Char -> Bool
p Char
c
then String -> Parser s ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser s ()) -> String -> Parser s ()
forall a b. (a -> b) -> a -> b
$ String
"Unexpected character: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show [Char
c]
else Text -> Parser s ()
forall s. Text -> Parser s ()
reparse (Text -> Parser s ()) -> Text -> Parser s ()
forall a b. (a -> b) -> a -> b
$ Char -> Text
L.singleton Char
c
symbol :: String -> Parser s String
symbol :: String -> Parser s String
symbol = Parser s String -> Parser s String
forall s a. Parser s a -> Parser s a
lexeme (Parser s String -> Parser s String)
-> (String -> Parser s String) -> String -> Parser s String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Parser s String
forall s. String -> Parser s String
string
isymbol :: String -> Parser s ()
isymbol :: String -> Parser s ()
isymbol = Parser s String -> Parser s ()
forall (f :: * -> *) a. Applicative f => f a -> f ()
ignore (Parser s String -> Parser s ())
-> (String -> Parser s String) -> String -> Parser s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Parser s String
forall s. String -> Parser s String
symbol
lexeme :: Parser s a -> Parser s a
lexeme :: Parser s a -> Parser s a
lexeme Parser s a
p = Parser s a
p Parser s a -> Parser s () -> Parser s a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser s ()
forall s. Parser s ()
whiteSpace
whiteSpace :: Parser s ()
whiteSpace :: Parser s ()
whiteSpace = Parser s () -> Parser s ()
forall s a. Parser s a -> Parser s ()
skipMany (Parser s ()
forall s. Parser s ()
simpleSpace Parser s () -> Parser s () -> Parser s ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser s ()
forall s. Parser s ()
oneLineComment)
simpleSpace :: Parser s ()
simpleSpace :: Parser s ()
simpleSpace = Parser s Text -> Parser s ()
forall (f :: * -> *) a. Applicative f => f a -> f ()
ignore (Parser s Text -> Parser s ()) -> Parser s Text -> Parser s ()
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Parser s Text
forall s. (Char -> Bool) -> Parser s Text
many1Satisfy Char -> Bool
isSpace
oneLineComment :: Parser s ()
= (Char -> Parser s ()
forall s. Char -> Parser s ()
ichar Char
'#' Parser s () -> Parser s Text -> Parser s Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Char -> Bool) -> Parser s Text
forall s. (Char -> Bool) -> Parser s Text
manySatisfy (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n')) Parser s Text -> () -> Parser s ()
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ()
hexDigit :: Parser a Char
hexDigit :: Parser a Char
hexDigit = (Char -> Bool) -> Parser a Char
forall s. (Char -> Bool) -> Parser s Char
satisfy Char -> Bool
isHexDigit
hex4 :: Parser a Char
hex4 :: Parser a Char
hex4 = do
String
digs <- Int -> Parser a Char -> Parser a String
forall (p :: * -> *) a. PolyParse p => Int -> p a -> p [a]
exactly Int
4 Parser a Char
forall s. Parser s Char
hexDigit
let mhex :: Either String (Int, Text)
mhex = Reader Int
forall a. Integral a => Reader a
R.hexadecimal (String -> Text
T.pack String
digs)
case Either String (Int, Text)
mhex of
Left String
emsg -> String -> Parser a Char
forall (p :: * -> *) a. PolyParse p => String -> p a
failBad (String -> Parser a Char) -> String -> Parser a Char
forall a b. (a -> b) -> a -> b
$ String
"Internal error: unable to parse hex4: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
emsg
Right (Int
v, Text
"") -> Char -> Parser a Char
forall (m :: * -> *) a. Monad m => a -> m a
return (Char -> Parser a Char) -> Char -> Parser a Char
forall a b. (a -> b) -> a -> b
$ Int -> Char
chr Int
v
Right (Int
_, Text
vs) -> String -> Parser a Char
forall (p :: * -> *) a. PolyParse p => String -> p a
failBad (String -> Parser a Char) -> String -> Parser a Char
forall a b. (a -> b) -> a -> b
$ String
"Internal error: hex4 remainder = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
vs
hex8 :: Parser a Char
hex8 :: Parser a Char
hex8 = do
String
digs <- Int -> Parser a Char -> Parser a String
forall (p :: * -> *) a. PolyParse p => Int -> p a -> p [a]
exactly Int
8 Parser a Char
forall s. Parser s Char
hexDigit
let mhex :: Either String (Int, Text)
mhex = Reader Int
forall a. Integral a => Reader a
R.hexadecimal (String -> Text
T.pack String
digs)
case Either String (Int, Text)
mhex of
Left String
emsg -> String -> Parser a Char
forall (p :: * -> *) a. PolyParse p => String -> p a
failBad (String -> Parser a Char) -> String -> Parser a Char
forall a b. (a -> b) -> a -> b
$ String
"Internal error: unable to parse hex8: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
emsg
Right (Int
v, Text
"") -> if Int
v Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0x10FFFF
then Char -> Parser a Char
forall (m :: * -> *) a. Monad m => a -> m a
return (Char -> Parser a Char) -> Char -> Parser a Char
forall a b. (a -> b) -> a -> b
$ Int -> Char
chr Int
v
else String -> Parser a Char
forall (p :: * -> *) a. PolyParse p => String -> p a
failBad String
"\\UHHHHHHHH format is limited to a maximum of \\U0010FFFF"
Right (Int
_, Text
vs) -> String -> Parser a Char
forall (p :: * -> *) a. PolyParse p => String -> p a
failBad (String -> Parser a Char) -> String -> Parser a Char
forall a b. (a -> b) -> a -> b
$ String
"Internal error: hex8 remainder = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
vs