data IRIType = Full | ExpandedAbbrev | ExpandedSimple | Abbreviated | Simple
deriving (Eq, Show, Typeable, Ord)
-- | do we have a full (possibly expanded) IRI (
i.e. for comparisons)
hasFullIRI :: IRI -> Bool
hasFullIRI i = not . null $ iriScheme i ++ iriPath i
-- | do we have an abbreviated IRI (
i.e. for pretty printing)
isAbbrev i = not . null $ prefixName i ++ abbrevPath i
-- | do we have an expanded IRI with a full and an abbreviated IRI
isExpanded :: IRI -> Bool
isExpanded i = hasFullIRI i && isAbbrev i
{- | do we have a simple IRI that is a (possibly expanded) abbreviated IRI
isSimple i = null (prefixName i) && isAbbrev i
-- | Returns Type of an IRI
iriType :: IRI -> IRIType
if (not . null) $ iriPath i then (
if (null $ abbrevPath i) && (null $ prefixName i) then Full else
if null $ prefixName i then ExpandedSimple else ExpandedAbbrev
) else if null $ prefixName i then Simple else Abbreviated
{- IRI as instance of Show. Note that for security reasons, the default
behaviour is to suppress any iuserinfo field (see RFC3986, section 7.5).
This can be overridden by using iriToString directly with first
argument @id@ (noting that this returns a ShowS value rather than a string).
[[[Another design would be to embed the iuserinfo mapping function in
the IRIAuth value, with the default value suppressing iuserinfo formatting,
but providing a function to return a new IRI value with iuserinfo
showsPrec _ i = iriToString defaultUserInfoMap i
-- equal iff expansion is equal or abbreviation is equal
(==) i j = compare i j == EQ
-- compares
full/expanded IRI (if expanded) or abbreviated part if not expanded
compare i j = case (iriType i, iriType j) of
(Simple, Simple) -> abbrevPath i `compare` abbrevPath j
(Abbreviated, Abbreviated) ->
let pnC = prefixName i `compare` prefixName j
apC = abbrevPath i `compare` abbrevPath j
in if pnC /= EQ then pnC else apC
(Simple, _) -> compare (expandCurie empty i) j
(_, Simple) -> compare i (expandCurie empty j)
(Abbreviated, _) -> compare (expandCurie empty i) j
(_, Abbreviated) -> compare i (expandCurie empty j)
let scC = iriScheme i `compare` iriScheme j
auC = iriAuthority i `compare` iriAuthority j
paC = iriPath i `compare` iriPath j
quC = iriQuery i `compare` iriQuery j
frC = iriFragment i `compare` iriFragment j
in if scC /= EQ then scC else
if auC /= EQ then auC else
if paC /= EQ then paC else
if quC /= EQ then quC else frC
-- |converts IRI to String of expanded form, also showing Auth info
iriToStringUnsecure :: IRI -> String
iriToStringUnsecure i = (iriToString id i) ""
-- |converts IRI to String of abbreviated form, also showing Auth info
iriToStringShortUnsecure :: IRI -> String
iriToStringShortUnsecure i = (iriToStringShort id i) ""
defaultUserInfoMap :: String -> String
defaultUserInfoMap uinf = user ++ newpass
(user, pass) = break (== ':') uinf
newpass = if null pass || (pass == "@")
instance GetRange IRI where
-- | Converts a Simple_ID to an IRI
simpleIdToIRI :: SIMPLE_ID -> IRI
simpleIdToIRI sid = nullIRI { abbrevPath = tokStr sid
{- | Turn a string containing an RFC3987 IRI into an 'IRI'.
Returns 'Nothing' if the string is not a valid IRI;
(an absolute IRI with optional fragment identifier). -}
parseIRI :: String -> Maybe IRI
parseIRI = parseIRIAny iri
{- | Parse a IRI reference to an 'IRI' value.
Returns 'Nothing' if the string is not a valid IRI reference.
(an absolute or relative IRI with optional fragment identifier). -}
parseIRIReference :: String -> Maybe IRI
parseIRIReference = parseIRIAny iriReference
{- | Parse a relative IRI to an 'IRI' value.
Returns 'Nothing' if the string is not a valid relative IRI.
(a relative IRI with optional fragment identifier). -}
parseRelativeReference :: String -> Maybe IRI
parseRelativeReference = parseIRIAny irelativeRef
{- | Parse an absolute IRI to an 'IRI' value.
Returns 'Nothing' if the string is not a valid absolute IRI.
(an absolute IRI without a fragment identifier). -}
parseAbsoluteIRI :: String -> Maybe IRI
parseAbsoluteIRI = parseIRIAny absoluteIRI
-- | Turn a string containing a CURIE into an 'IRI'
parseCurie :: String -> Maybe IRI
parseCurie = parseIRIAny curie
{- | Turn a string containing an IRI or a CURIE into an 'IRI'.
Returns 'Nothing' if the string is not a valid IRI;
(an absolute IRI enclosed in '<' and '>' with optional fragment identifier
parseIRICurie :: String -> Maybe IRI
parseIRICurie = parseIRIAny iriCurie
{- | Parse an absolute or relative IRI enclosed in '<', '>' or a CURIE to an 'IRI' value.
Returns 'Nothing' if the string is not a valid IRI reference or CURIE. -}
parseIRIReferenceCurie :: String -> Maybe IRI
parseIRIReferenceCurie = parseIRIAny iriReferenceCurie
{- | Turn a string containing an IRI (by Manchester-syntax) into an 'IRI'.
Returns 'Nothing' if the string is not a valid IRI;
(an absolute IRI enclosed in '<' and '>' with optional fragment identifier,
an abbreviated IRI or a simple IRI). -}
parseIRIManchester :: String -> Maybe IRI
parseIRIManchester = parseIRIAny iriManchester
{- |Test if string contains a valid IRI
(an absolute IRI with optional fragment identifier). -}
{- | Test if string contains a valid IRI reference
(an absolute or relative IRI with optional fragment identifier). -}
isIRIReference :: String -> Bool
isIRIReference = isValidParse iriReference
{- |Test if string contains a valid relative IRI
(a relative IRI with optional fragment identifier). -}
isRelativeReference :: String -> Bool
isRelativeReference = isValidParse irelativeRef
{- | Test if string contains a valid absolute IRI
(an absolute IRI without a fragment identifier). -}
isAbsoluteIRI :: String -> Bool
isAbsoluteIRI = isValidParse absoluteIRI
{- | Test if string contains a valid IRI or CURIE
(an absolute IRI enclosed in '<' and '>' with optional fragment identifier
isIRICurie :: String -> Bool
isIRICurie = isValidParse iriCurie
{- | Test if string contains a valid absolute or relative IRI enclosed in '<', '>' or a CURIE -}
isIRIReferenceCurie :: String -> Bool
isIRIReferenceCurie = isValidParse iriReferenceCurie
-- | Test if string contains a valid CURIE
isCurie :: String -> Bool
isCurie = isValidParse curie
{- | Test if string contains a valid IRI by Manchester-syntax
(an absolute IRI enclosed in '<' and '>' with optional fragment identifier,
an abbreviated IRI or a simple IRI). -}
isIRIManchester :: String -> Bool
isIRIManchester = isValidParse iriManchester
-- | Test if string contains a valid IPv6 address
isIPv6address :: String -> Bool
isIPv6address = isValidParse ipv6address
-- | Test if string contains a valid IPv4 address
isIPv4address :: String -> Bool
isIPv4address = isValidParse ipv4address
-- Helper function for turning a string into a IRI
parseIRIAny :: IRIParserDirect IRI -> String -> Maybe IRI
parseIRIAny parser iristr = case parseAll parser "" iristr of
-- Helper function to test a string match to a parser
isValidParse :: IRIParserDirect a -> String -> Bool
isValidParse parser iristr = case parseAll parser "" iristr of
parseAll :: IRIParserDirect a -> String -> String -> Either ParseError a
parseAll parser = parse (parser << eof)
-- * IRI parser body based on Parsec elements and combinators
-- Parser parser type. Currently:
type IRIParserDirect a = GenParser Char () a
type IRIParser st a = GenParser Char st a
-- | Parse and return a 'pct-encoded' sequence
escaped :: IRIParser st String
escaped = char '%' <:> hexDigitChar <:> single hexDigitChar
{- | Returns 'True' if the character is a \"reserved\" character in a
IRI. To include a literal instance of one of these characters in a
component of a IRI, it must be escaped. -}
isReserved :: Char -> Bool
isReserved c = isGenDelims c || isSubDelims c
isGenDelims :: Char -> Bool
isGenDelims c = c `elem` ":/?#[]@"
isSubDelims :: Char -> Bool
isSubDelims c = c `elem` "!$&'()*+,;="
subDelims :: IRIParser st String
subDelims = single $ satisfy isSubDelims
{- |Returns 'True' if the character is an \"unreserved\" character in
a IRI. These characters do not need to be escaped in a IRI. The
only characters allowed in a IRI are either \"reserved\",
\"unreserved\", or an escape sequence (@%@ followed by two hex digits). -}
isUnreserved :: Char -> Bool
isUnreserved c = isAlphaNumChar c || (c `elem` "-_.~") || (isUcsChar c)
iunreservedChar :: IRIParser st String
iunreservedChar = single $ satisfy isUnreserved
iriWithPos :: IRIParser st IRI -> IRIParser st IRI
return $ i {iriPos = appRange (Range [p, q]) $ iriPos i}
-- | Parses an absolute IRI enclosed in '<', '>' or a CURIE
iriCurie :: IRIParser st IRI
{- | Parses an absolute or relative IRI enclosed in '<', '>' or a CURIE
iriReferenceCurie :: IRIParser st IRI
i <- iri <|> irelativeRef
curie :: IRIParser st IRI
return $ i { prefixName = c }
return $ i { prefixName = pn }
reference :: IRIParser st IRI
reference = iriWithPos $ do
uf <- option "" uifragment
-- | Prefix part of CURIE in @prefix_part:reference@
ncname :: GenParser Char st String
ncname = nameStartChar <:> many nameChar
nameStartChar :: GenParser Char st Char
nameStartChar = satisfy nameStartCharP
nameChar :: GenParser Char st Char
nameChar = satisfy nameCharP
{- NOTE: Usually ':' is allowed. Here, only ncname uses nameStartChar, however.
nameStartCharP :: Char -> Bool
(c == '_') || -- usually: (c `elem` ":_") ||
(0x00C0 <= n && n <= 0x00D6) ||
(0x00D8 <= n && n <= 0x00F6) ||
(0x00F8 <= n && n <= 0x02FF) ||
(0x0370 <= n && n <= 0x037D) ||
(0x037F <= n && n <= 0x1FFF) ||
(0x200C <= n && n <= 0x200D) ||
(0x2070 <= n && n <= 0x218F) ||
(0x2C00 <= n && n <= 0x2FEF) ||
(0x3001 <= n && n <= 0xD7FF) ||
(0xF900 <= n && n <= 0xFDCF) ||
(0xFDF0 <= n && n <= 0xFFFD) ||
(0x10000 <= n && n <= 0xEFFFF)
nameCharP :: Char -> Bool
(0x0300 <= n && n <= 0x036F) ||
(0x203F <= n && n <= 0x2040)
pn_chars_baseP :: Char -> Bool
(0x00C0 <= n && n <= 0x00D6) ||
(0x00D8 <= n && n <= 0x00F6) ||
(0x00F8 <= n && n <= 0x02FF) ||
(0x0370 <= n && n <= 0x037D) ||
(0x037F <= n && n <= 0x1FFF) ||
(0x200C <= n && n <= 0x200D) ||
(0x2070 <= n && n <= 0x218F) ||
(0x2C00 <= n && n <= 0x2FEF) ||
(0x00D8 <= n && n <= 0x00F6) ||
(0x3001 <= n && n <= 0xD7FF) ||
(0xF900 <= n && n <= 0xFDCF) ||
(0xFDF0 <= n && n <= 0xFFFD) ||
(0x10000 <= n && n <= 0xEFFFF)
pn_chars_base :: GenParser Char st Char
pn_chars_base = satisfy pn_chars_baseP
pn_chars_u :: GenParser Char st Char
pn_chars_u = satisfy pn_chars_uP
pn_chars :: GenParser Char st Char
pn_chars = satisfy pn_charsP
pn_chars_uP :: Char -> Bool
pn_chars_uP c = (pn_chars_baseP c) || (c == '_')
pn_charsP :: Char -> Bool
(0x0300 <= n && n <= 0x036F) ||
(0x203F <= n && n <= 0x2040)
{- fullIRI := an IRI as defined in [RFC 3987], enclosed in a pair of < (U+3C)
prefixName := a finite sequence of characters matching the PNAME_NS production
of [SPARQL] and not matching any of the keyword terminals of the syntax
abbreviatedIRI := a finite sequence of characters matching the PNAME_LN#
simpleIRI := a finite sequence of characters matching the PN_LOCAL production
of [SPARQL] and not matching any of the keyword terminals of the syntax
IRI := fullIRI | abbreviatedIRI | simpleIRI -}
iriManchester :: IRIParser st IRI
iriManchester = iriWithPos $ do
i <- iri <|> irelativeRef
(PName_Ln prefix loc) <- try pname_ln
data PNAME_LN = PName_Ln PNAME_NS PN_LOCAL deriving (Show, Eq, Ord)
pname_ln :: GenParser Char st PNAME_LN
pname_ns :: GenParser Char st PNAME_NS
pname_ns = string ":" <|> pn_prefix <++> string ":"
pn_prefix :: GenParser Char st PN_PREFIX
s1 <- many (pn_chars <|> char '.')
if null s1 then return Nothing else case last s1 of
'.' -> fail "Last character in prefix must not be '.'"
Just str -> return $ c1 : str
pn_local :: GenParser Char st PN_LOCAL
c1 <- pn_chars_u <|> digit
s1 <- many (pn_chars <|> char '.')
if null s1 then return Nothing else case last s1 of
'.' -> fail "Last character in prefix must not be '.'"
Just str -> return $ c1 : str
-- IRI = scheme ":" ihier-part [ "?" iquery ] [ "#" ifragment ]
{- ihier-part = "//" iauthority ipath-abempty
uf <- option "" uifragment
ihierPart :: IRIParser st (Maybe IRIAuth, String)
<|> fmap (\ s -> (Nothing, s)) ihierPartNoAuth
ihierPartNoAuth :: IRIParser st String
ihierPartNoAuth = ipathAbs <|> ipathRootLess <|> return ""
uscheme :: IRIParser st String
uscheme = oneThenMany alphaChar (satisfy isSchemeChar) <++> string ":"
uiauthority :: IRIParser st (Maybe IRIAuth)
uu <- option "" (try iuserinfo)
iuserinfo :: IRIParser st String
iuserinfo = flat (many $ uchar ";:&=+$,") <++> string "@"
ihost :: IRIParser st String
ihost = ipLiteral <|> try ipv4address <|> iregName
ipLiteral :: IRIParser st String
ipLiteral = char '[' <:> (ipv6address <|> ipvFuture) <++> string "]"
ipvFuture :: IRIParser st String
ipvFuture = char 'v' <:> hexDigitChar <:> char '.'
<:> many1 (satisfy isIpvFutureChar)
isIpvFutureChar :: Char -> Bool
isIpvFutureChar c = isUnreserved c || isSubDelims c || c == ';'
ipv6address :: IRIParser st String
; return $ concat a2 ++ a3
; return $ "::" ++ concat a2 ++ a3
; return $ a1 ++ "::" ++ concat a2 ++ a3
; return $ a1 ++ "::" ++ concat a2 ++ a3
; return $ a1 ++ "::" ++ concat a2 ++ a3
; return $ a1 ++ "::" ++ a2 ++ a3
; return $ a1 ++ "::" ++ a3
; return $ a1 ++ "::" ++ a3
opt_n_h4c_h4 :: Int -> IRIParser st String
opt_n_h4c_h4 n = option "" $ flat (countMinMax 0 n h4c) <++> h4
ls32 :: IRIParser st String
h4c :: IRIParser st String
h4c = try $ h4 <++> (string ":" << notFollowedBy (char ':'))
h4 :: IRIParser st String
h4 = countMinMax 1 4 hexDigitChar
ipv4address :: IRIParser st String
ipv4address = decOctet <++> string "."
<++> decOctet <++> string "."
<++> decOctet <++> string "."
decOctet :: IRIParser st String
a1 <- countMinMax 1 3 digitChar
if (read a1 :: Int) > 255 then
fail "Decimal octet value too large"
iregName :: IRIParser st String
flat (countMinMax 0 255 $ iunreservedChar <|> escaped <|> subDelims)
-- RFC3986, section 3.2.3
port :: IRIParser st String
port = char ':' <:> many digitChar
{- ipath = ipath-abempty ; begins with "/" or is empty
/ ipath-absolute ; begins with "/" but not "//"
/ ipath-noscheme ; begins with a non-colon isegment
/ ipath-rootless ; begins with a isegment
/ ipath-empty ; zero characters -}
{- ipath-abempty = *( "/" iisegment )
ipath-absolute = "/" [ iisegment-nz *( "/" iisegment ) ]
ipath-noscheme = iisegment-nz-nc *( "/" iisegment )
ipath-rootless = iisegment-nz *( "/" iisegment )
ipath-empty = 0<iipchar> -}
iisegment-nz-nc = 1*( iunreserved / pct-encoded / sub-delims
; non-zero-length isegment without any colon ":" -}
{- iipchar = iunreserved / pct-encoded / sub-delims / ":"
ipathAbEmpty :: IRIParser st String
ipathAbEmpty = flat $ many slashIsegment
ipathAbs :: IRIParser st String
ipathAbs = char '/' <:> option "" ipathRootLess
ipathRootLess :: IRIParser st String
ipathRootLess = flat $ isegmentNz <:> many slashIsegment
ipathNoScheme :: IRIParser st String
ipathNoScheme = flat $ isegmentNzc <:> many slashIsegment
slashIsegment :: IRIParser st String
slashIsegment = char '/' <:> isegment
isegment :: IRIParser st String
isegment = flat $ many ipchar
isegmentNz :: IRIParser st String
isegmentNz = flat $ many1 ipchar
isegmentNzc :: IRIParser st String
isegmentNzc = flat . many1 $ uchar "@"
ipchar :: IRIParser st String
-- helper function for ipchar and friends
uchar :: String -> IRIParser st String
<|> single (oneOf extras)
uiquery :: IRIParser st String
uiquery = char '?' <:> flat (many iqueryPart)
iqueryPart :: IRIParser st String
iqueryPart = many1 iprivate <|> uchar ":@/?"
uifragment :: IRIParser st String
uifragment = char '#' <:> flat (many $ uchar ":@/?")
-- Reference, Relative and Absolute IRI forms
iriReference :: IRIParser st IRI
iriReference = iri <|> irelativeRef
-- irelative-ref = irelative-part [ "?" iquery ] [ "#" ifragment ]
{- irelative-part = "//" iauthority ipath-abempty
irelativeRef :: IRIParser st IRI
irelativeRef = iriWithPos $ do
(ua, up) <- irelativePart
uf <- option "" uifragment
irelativePart :: IRIParser st ((Maybe IRIAuth), String)
<|> fmap (\ s -> (Nothing, s)) (ipathAbs <|> ipathNoScheme <|> return "")
absoluteIRI :: IRIParser st IRI
absoluteIRI = iriWithPos $ do
{- NOTE: can't use isAlphaNum etc. because these deal with ISO 8859
(and possibly Unicode!) chars.
when IRIs are introduced then most codepoints above 128(?) should
be treated as unreserved, and higher codepoints for letters should
isAlphaChar :: Char -> Bool
isAlphaChar c = (c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z')
isDigitChar :: Char -> Bool
isDigitChar c = (c >= '0' && c <= '9')
isAlphaNumChar :: Char -> Bool
isAlphaNumChar c = isAlphaChar c || isDigitChar c
isUcsChar :: Char -> Bool
in (0xA0 <= n && n <= 0xD7FF) ||
(0x20000 <= n && n <= 0x2FFFD) ||
(0x30000 <= n && n <= 0x3FFFD) ||
(0x40000 <= n && n <= 0x4FFFD) ||
(0x50000 <= n && n <= 0x5FFFD) ||
(0x60000 <= n && n <= 0x6FFFD) ||
(0x70000 <= n && n <= 0x7FFFD) ||
(0x80000 <= n && n <= 0x8FFFD) ||
(0x90000 <= n && n <= 0x9FFFD) ||
(0xA0000 <= n && n <= 0xAFFFD) ||
(0xB0000 <= n && n <= 0xBFFFD) ||
(0xC0000 <= n && n <= 0xCFFFD) ||
(0xD0000 <= n && n <= 0xDFFFD) ||
(0xE0000 <= n && n <= 0xEFFFD)
isIprivate :: Char -> Bool
in (0xE000 <= n && n <= 0xF8FF) ||
(0xF000 <= n && n <= 0xFFFD) ||
(0x100000 <= n && n <= 0x10FFFD)
isHexDigitChar :: Char -> Bool
isHexDigitChar c = isHexDigit c
isSchemeChar :: Char -> Bool
isSchemeChar c = (isAlphaNumChar c) || (c `elem` "+-.")
alphaChar :: IRIParser st Char
digitChar :: IRIParser st Char
hexDigitChar :: IRIParser st Char
iprivate :: IRIParser st Char
iprivate = satisfy isIprivate
-- Additional parser combinators for common patterns
oneThenMany :: GenParser t s a -> GenParser t s a -> GenParser t s [a]
oneThenMany p1 pr = p1 <:> many pr
countMinMax :: Int -> Int -> GenParser t s a -> GenParser t s [a]
countMinMax m n p | m > 0 = p <:> countMinMax (m - 1) (n - 1) p
countMinMax _ n _ | n <= 0 = return []
countMinMax _ n p = option [] $ p <:> countMinMax 0 (n - 1) p
notMatching :: Show a => GenParser tok st a -> GenParser tok st ()
-- * Reconstruct a IRI string
{- | Turn an 'IRI' into a string.
Uses a supplied function to map the iuserinfo part of the IRI.
The Show instance for IRI uses a mapping that hides any password
that may be present in the IRI. Use this function with argument @id@
to preserve the password in the formatted output. -}
iriToString :: (String -> String) -> IRI -> ShowS
iriToString iuserinfomap i@(IRI { iriScheme = scheme
, iriAuthority = authority
Abbreviated -> (pname ++) . (aPath ++)
_ -> (scheme ++) . (iriAuthToString iuserinfomap authority)
. (path ++) . (query ++) . (fragment ++)
iriToStringShort :: (String -> String) -> IRI -> ShowS
iriToStringShort iuserinfomap i@(IRI { iriScheme = scheme
, iriAuthority = authority
Full -> (scheme ++) . (iriAuthToString iuserinfomap authority)
. (path ++) . (query ++) . (fragment ++)
_ -> (pname ++) . (aPath ++)
iriAuthToString :: (String -> String) -> (Maybe IRIAuth) -> ShowS
iriAuthToString _ Nothing = id -- shows ""
iriAuthToString iuserinfomap
(Just IRIAuth { iriUserInfo = uinfo
("//" ++) . (if null uinfo then id else (iuserinfomap uinfo ++))
-- | Returns 'True' if the character is allowed in a IRI.
isAllowedInIRI :: Char -> Bool
isAllowedInIRI c = isReserved c || isUnreserved c || c == '%' -- escape char
-- | Returns 'True' if the character is allowed unescaped in a IRI.
isUnescapedInIRI :: Char -> Bool
isUnescapedInIRI c = isReserved c || isUnreserved c
-- * Escape sequence handling
{- | Escape character if supplied predicate is not satisfied,
otherwise return character as singleton string. -}
escapeIRIChar :: (Char -> Bool) -> Char -> String
| otherwise = '%' : myShowHex (ord c) ""
myShowHex :: Int -> ShowS
myShowHex n r = case showIntAtBase 16 (toChrHex) n r of
| d < 10 = chr (ord '0' + fromIntegral d)
| otherwise = chr (ord 'A' + fromIntegral (d - 10))
-- | Can be used to make a string valid for use in a IRI.
:: (Char -> Bool) {- ^ a predicate which returns 'False'
if the character should be escaped -}
-> String -- ^ the string to process
-> String -- ^ the resulting IRI string
escapeIRIString p s = concatMap (escapeIRIChar p) s
{- | Turns all instances of escaped characters in the string back
into literal characters. -}
unEscapeString :: String -> String
unEscapeString ('%' : x1 : x2 : s) | isHexDigit x1 && isHexDigit x2 =
chr (digitToInt x1 * 16 + digitToInt x2) : unEscapeString s
unEscapeString (c : s) = c : unEscapeString s
-- * Resolving a relative IRI relative to a base IRI
{- | Returns a new 'IRI' which represents the value of the
first 'IRI' interpreted as relative to the second 'IRI'.
Algorithm from RFC3986 [3], section 5.2.2 -}
nonStrictRelativeTo :: IRI -> IRI -> Maybe IRI
nonStrictRelativeTo ref base = relativeTo ref' base
ref' = if iriScheme ref == iriScheme base
then ref { iriScheme = "" }
isDefined :: ( MonadPlus m, Eq (m a) ) => m a -> Bool
{- | Compute an absolute 'IRI' for a supplied IRI
relative to a given base. -}
relativeTo :: IRI -> IRI -> Maybe IRI
| isDefined ( iriScheme ref ) =
| isDefined ( iriAuthority ref ) =
just_isegments ref { iriScheme = iriScheme base }
| isDefined ( iriPath ref ) =
if (head (iriPath ref) == '/') then
{ iriScheme = iriScheme base
, iriAuthority = iriAuthority base
{ iriScheme = iriScheme base
, iriAuthority = iriAuthority base
, iriPath = mergePaths base ref
| isDefined ( iriQuery ref ) =
{ iriScheme = iriScheme base
, iriAuthority = iriAuthority base
{ iriScheme = iriScheme base
, iriAuthority = iriAuthority base
, iriQuery = iriQuery base
Just $ u { iriPath = removeDotSegments (iriPath u) }
| isDefined (iriAuthority b) && null pb = '/' : pr
| otherwise = dropLast pb ++ pr
dropLast = fst . splitLast -- reverse . dropWhile (/='/') . reverse
-- Remove dot isegments, but protect leading '/' character
removeDotSegments :: String -> String
removeDotSegments ('/' : ps) = '/' : elimDots ps []
removeDotSegments ps = elimDots ps []
-- Second arg accumulates isegments processed so far in reverse order
elimDots :: String -> [String] -> String
elimDots [] rs = concat (reverse rs)
elimDots ( '.' : '/' : ps) rs = elimDots ps rs
elimDots ( '.' : [] ) rs = elimDots [] rs
elimDots ( '.' : '.' : '/' : ps) rs = elimDots ps (dropHead rs)
elimDots ( '.' : '.' : [] ) rs = elimDots [] (dropHead rs)
elimDots ps rs = elimDots ps1 (r : rs)
(r, ps1) = nextSegment ps
-- Return tail of non-null list, otherwise return null list
{- Returns the next isegment and the rest of the path from a path string.
Each isegment ends with the next '/' or the end of string. -}
nextSegment :: String -> (String, String)
case break (== '/') ps of
(r, '/' : ps1) -> (r ++ "/", ps1)
-- Split last (name) isegment from path, returning (path,name)
splitLast :: String -> (String, String)
splitLast path = (reverse revpath, reverse revname)
(revname, revpath) = break (== '/') $ reverse path
-- * Finding a IRI relative to a base IRI
{- | Returns a new 'IRI' which represents the relative location of
the first 'IRI' with respect to the second 'IRI'. Thus, the
values supplied are expected to be absolute IRIs, and the result
returned may be a relative IRI.
There is no single correct implementation of this function,
but any acceptable implementation must satisfy the following:
> (uabs `relativeFrom` ubase) `relativeTo` ubase == uabs
For any valid absolute IRI.
relativeFrom :: IRI -> IRI -> IRI
| diff iriScheme uabs base = uabs
| diff iriAuthority uabs base = uabs { iriScheme = "" }
| diff iriPath uabs base = uabs
, iriPath = relPathFrom (removeBodyDotSegments $ iriPath uabs)
(removeBodyDotSegments $ iriPath base)
| diff iriQuery uabs base = uabs
| otherwise = uabs -- Always carry fragment from uabs
diff :: Eq b => (a -> b) -> a -> a -> Bool
diff sel u1 u2 = sel u1 /= sel u2
-- Remove dot isegments except the final isegment
removeBodyDotSegments p = removeDotSegments p1 ++ p2
relPathFrom :: String -> String -> String
relPathFrom pabs [] = pabs
relPathFrom pabs base = -- Construct a relative path isegments
if sa1 == sb1 -- if the paths share a leading isegment
then if (sa1 == "/") -- other than a leading '/'
then relPathFrom1 ra2 rb2
else relPathFrom1 ra1 rb1
(sa1, ra1) = nextSegment pabs
(sb1, rb1) = nextSegment base
(sa2, ra2) = nextSegment ra1
(sb2, rb2) = nextSegment rb1
{- relPathFrom1 strips off trailing names from the supplied paths,
and calls difPathFrom to find the relative path from base to
relPathFrom1 :: String -> String -> String
relPathFrom1 pabs base = relName
(sa, na) = splitLast pabs
(sb, nb) = splitLast base
relName = if null rp then
else if protect na then "./" ++ na
-- Precede name with some path if it is null or contains a ':'
protect n = null n || ':' `elem` n
{- relSegsFrom discards any common leading isegments from both paths,
then invokes difSegsFrom to calculate a relative path from the end
of the base path to the end of the target path.
The final name is handled separately, so this deals only with
"directory" segtments. -}
relSegsFrom :: String -> String -> String
relSegsFrom [] [] = "" -- paths are identical
else difSegsFrom sabs base
(sa1, ra1) = nextSegment sabs
(sb1, rb1) = nextSegment base
{- difSegsFrom calculates a path difference from base to target,
not including the final name at the end of the path
(
i.e. results always ends with '/')
This function operates under the invariant that the supplied
value of sabs is the desired path relative to the beginning of
base. Thus, when base is empty, the desired path has been found. -}
difSegsFrom :: String -> String -> String
difSegsFrom sabs "" = sabs
difSegsFrom sabs base = difSegsFrom ("../" ++ sabs) (snd $ nextSegment base)
-- * Other normalization functions
-- |Expands a CURIE to an IRI
expandCurie :: Map String IRI -> IRI -> IRI
expandCurie prefixMap c =
if iriType c == Full then c else
let i = findWithDefault nullIRI (prefixName c) prefixMap in
{ prefixName = prefixName c
, abbrevPath = abbrevPath c
{- |'mergeCurie' merges the CURIE @c@ into IRI @i@, appending path and
query-part of @c@ to @i@. Also replacing fragment of @c@ with @i@
if both are not empty. -}
mergeCurie :: IRI -> IRI -> IRI
i { iriPath = iriPath i ++ abbrevPath c
, iriQuery = iriQuery i ++ case iriQuery c of
, iriFragment = case iriFragment i of
{- | Case normalization; cf. RFC3986 section 6.2.2.1
NOTE: authority case normalization is not performed -}
normalizeCase :: String -> String
normalizeCase iristr = ncScheme iristr
ncScheme (':' : cs) = ':' : ncEscape cs
ncScheme (c : cs) | isSchemeChar c = toLower c : ncScheme cs
ncScheme _ = ncEscape iristr -- no scheme present
ncEscape ('%' : h1 : h2 : cs) =
'%' : toUpper h1 : toUpper h2 : ncEscape cs
ncEscape (c : cs) = c : ncEscape cs
-- | Encoding normalization; cf. RFC3986 section 6.2.2.2
normalizeEscape :: String -> String
normalizeEscape ('%' : h1 : h2 : cs)
| isHexDigit h1 && isHexDigit h2 && isUnreserved escval =
escval : normalizeEscape cs
escval = chr (digitToInt h1 * 16 + digitToInt h2)
normalizeEscape (c : cs) = c : normalizeEscape cs
-- | Path isegment normalization; cf. RFC3986 section 6.2.2.4
normalizePathSegments :: String -> String
normalizePathSegments iristr = normstr jiri
normstr (Just u) = show (normiri u)
normiri u = u { iriPath = removeDotSegments (iriPath u) }
-- FIX: where do the instances fit the best?
instance ShATermConvertible IRI where
(att1, is) <- toShATerm' att0 ((iriToString id u) "")
return $ addATerm (ShAAppl "IRI" [is] []) att1
case getShATerm ix att0 of
x@(ShAAppl "IRI" [is] _) ->
case fromShATerm' is att0 of
case parseIRICurie is' of
case parseIRIReference is' of
Nothing -> fromShATermError "IRI" x
i -> fromShATermError "IRI" i