Extended.hs

{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GADTs                     #-}
{-# LANGUAGE RankNTypes                #-}
{-# LANGUAGE StandaloneDeriving        #-}
{-# LANGUAGE TypeOperators             #-}
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 = forall a . AnyURI (URIRef a)

deriving instance Show AnyURI
instance Eq AnyURI where
  (AnyURI a) == (AnyURI b) = case sameURIType a b of
    Just Refl -> a == b
    _         -> False

instance Ord AnyURI where
  compare (AnyURI a) (AnyURI b) = case (a, b) of
    (URI{}, URI{})                 -> compare a b
    (RelativeRef{}, RelativeRef{}) -> compare a b
    (URI{}, RelativeRef{})         -> LT
    (RelativeRef{}, URI{})         -> GT

instance Pretty AnyURI where
  pretty (AnyURI a@URI{})         = prettyURI a
  pretty (AnyURI a@RelativeRef{}) = prettyURI a

instance ToJSON AnyURI where
  toJSON (AnyURI a@URI{})         = toJSON $ String $ decodeUtf8 $ serializeURIRef' a
  toJSON (AnyURI a@RelativeRef{}) = toJSON $ String $ decodeUtf8 $ serializeURIRef' a

instance FromJSON AnyURI where
  parseJSON = withText "URI" $ \s ->
    let bytes = encodeUtf8 s
        uri = parseURI laxURIParserOptions bytes
        relativeRef = parseRelativeRef laxURIParserOptions bytes
    in either (const $ fail "Invalid URI") pure $ (AnyURI <$> uri) <> (AnyURI <$> relativeRef)


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

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

toAbsoluteURI :: Scheme -> AnyURI -> URI
toAbsoluteURI scheme (AnyURI a) = toAbsolute scheme a