{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UnicodeSyntax #-}

module URI.ByteString.Extended (module URI.ByteString.Extended, module URI.ByteString) where

import Data.Aeson.Extended
import Data.Type.Equality
import Imm.Pretty
import URI.ByteString

data AnyURI = ∀ a. AnyURI (URIRef a)

deriving instance Show AnyURI

instance Eq AnyURI where
  (AnyURI URIRef a
a) == :: AnyURI -> AnyURI -> Bool
== (AnyURI URIRef a
b) = case URIRef a -> URIRef a -> Maybe (URIRef a :~: URIRef a)
forall a1 a2.
URIRef a1 -> URIRef a2 -> Maybe (URIRef a1 :~: URIRef a2)
sameURIType URIRef a
a URIRef a
b of
    Just URIRef a :~: URIRef a
Refl → URIRef a
a URIRef a -> URIRef a -> Bool
forall a. Eq a => a -> a -> Bool
== URIRef a
URIRef a
b
    Maybe (URIRef a :~: URIRef a)
_ → Bool
False

instance Ord AnyURI where
  compare :: AnyURI -> AnyURI -> Ordering
compare (AnyURI URIRef a
a) (AnyURI URIRef a
b) = case (URIRef a
a, URIRef a
b) of
    (URI{}, URI{}) → URIRef a -> URIRef a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare URIRef a
a URIRef a
URIRef a
b
    (RelativeRef{}, RelativeRef{}) → URIRef a -> URIRef a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare URIRef a
a URIRef a
URIRef a
b
    (URI{}, RelativeRef{}) → Ordering
LT
    (RelativeRef{}, URI{}) → Ordering
GT

instance Pretty AnyURI where
  pretty :: forall ann. AnyURI -> Doc ann
pretty (AnyURI a :: URIRef a
a@URI{}) = URIRef a -> Doc ann
forall a b. URIRef a -> Doc b
prettyURI URIRef a
a
  pretty (AnyURI a :: URIRef a
a@RelativeRef{}) = URIRef a -> Doc ann
forall a b. URIRef a -> Doc b
prettyURI URIRef a
a

instance ToJSON AnyURI where
  toJSON :: AnyURI -> Value
toJSON (AnyURI a :: URIRef a
a@URI{}) = Value -> Value
forall a. ToJSON a => a -> Value
toJSON (Value -> Value) -> Value -> Value
forall a b. (a -> b) -> a -> b
$ Text -> Value
String (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ URIRef a -> ByteString
forall a. URIRef a -> ByteString
serializeURIRef' URIRef a
a
  toJSON (AnyURI a :: URIRef a
a@RelativeRef{}) = Value -> Value
forall a. ToJSON a => a -> Value
toJSON (Value -> Value) -> Value -> Value
forall a b. (a -> b) -> a -> b
$ Text -> Value
String (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ URIRef a -> ByteString
forall a. URIRef a -> ByteString
serializeURIRef' URIRef a
a

instance FromJSON AnyURI where
  parseJSON :: Value -> Parser AnyURI
parseJSON = String -> (Text -> Parser AnyURI) -> Value -> Parser AnyURI
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"URI" ((Text -> Parser AnyURI) -> Value -> Parser AnyURI)
-> (Text -> Parser AnyURI) -> Value -> Parser AnyURI
forall a b. (a -> b) -> a -> b
$ \Text
s →
    let bytes :: ByteString
bytes = Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 Text
s
        uri :: Either URIParseError (URIRef Absolute)
uri = URIParserOptions
-> ByteString -> Either URIParseError (URIRef Absolute)
parseURI URIParserOptions
laxURIParserOptions ByteString
bytes
        relativeRef :: Either URIParseError (URIRef Relative)
relativeRef = URIParserOptions
-> ByteString -> Either URIParseError (URIRef Relative)
parseRelativeRef URIParserOptions
laxURIParserOptions ByteString
bytes
     in (URIParseError -> Parser AnyURI)
-> (AnyURI -> Parser AnyURI)
-> Either URIParseError AnyURI
-> Parser AnyURI
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Parser AnyURI -> URIParseError -> Parser AnyURI
forall a b. a -> b -> a
const (Parser AnyURI -> URIParseError -> Parser AnyURI)
-> Parser AnyURI -> URIParseError -> Parser AnyURI
forall a b. (a -> b) -> a -> b
$ String -> Parser AnyURI
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid URI") AnyURI -> Parser AnyURI
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either URIParseError AnyURI -> Parser AnyURI)
-> Either URIParseError AnyURI -> Parser AnyURI
forall a b. (a -> b) -> a -> b
$ (URIRef Absolute -> AnyURI
forall a. URIRef a -> AnyURI
AnyURI (URIRef Absolute -> AnyURI)
-> Either URIParseError (URIRef Absolute)
-> Either URIParseError AnyURI
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either URIParseError (URIRef Absolute)
uri) Either URIParseError AnyURI
-> Either URIParseError AnyURI -> Either URIParseError AnyURI
forall a. Semigroup a => a -> a -> a
<> (URIRef Relative -> AnyURI
forall a. URIRef a -> AnyURI
AnyURI (URIRef Relative -> AnyURI)
-> Either URIParseError (URIRef Relative)
-> Either URIParseError AnyURI
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either URIParseError (URIRef Relative)
relativeRef)

sameURIType ∷ URIRef a1 → URIRef a2 → Maybe (URIRef a1 :~: URIRef a2)
sameURIType :: forall a1 a2.
URIRef a1 -> URIRef a2 -> Maybe (URIRef a1 :~: URIRef a2)
sameURIType URIRef a1
a URIRef a2
b = case (URIRef a1
a, URIRef a2
b) of
  (URI{}, URI{}) → (URIRef a1 :~: URIRef a2) -> Maybe (URIRef a1 :~: URIRef a2)
forall a. a -> Maybe a
Just URIRef a1 :~: URIRef a1
URIRef a1 :~: URIRef a2
forall {k} (a :: k). a :~: a
Refl
  (RelativeRef{}, RelativeRef{}) → (URIRef a1 :~: URIRef a2) -> Maybe (URIRef a1 :~: URIRef a2)
forall a. a -> Maybe a
Just URIRef a1 :~: URIRef a1
URIRef a1 :~: URIRef a2
forall {k} (a :: k). a :~: a
Refl
  (URIRef a1, URIRef a2)
_ → Maybe (URIRef a1 :~: URIRef a2)
forall a. Maybe a
Nothing

withAnyURI ∷ (∀ a. URIRef a → b) → AnyURI → b
withAnyURI :: forall b. (forall a. URIRef a -> b) -> AnyURI -> b
withAnyURI forall a. URIRef a -> b
f (AnyURI URIRef a
a) = URIRef a -> b
forall a. URIRef a -> b
f URIRef a
a

toAbsoluteURI ∷ Scheme → AnyURI → URI
toAbsoluteURI :: Scheme -> AnyURI -> URIRef Absolute
toAbsoluteURI Scheme
scheme (AnyURI URIRef a
a) = Scheme -> URIRef a -> URIRef Absolute
forall a. Scheme -> URIRef a -> URIRef Absolute
toAbsolute Scheme
scheme URIRef a
a