{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE TemplateHaskell #-}

module Dormouse.Url.Types
  ( UrlComponents(..)
  , UrlScheme(..)
  , Url(..)
  , AnyUrl(..)
  ) where

import Dormouse.Uri.Types
import GHC.TypeLits
import Language.Haskell.TH.Syntax (Lift(..))

data UrlComponents = UrlComponents
  { UrlComponents -> Authority
urlAuthority :: Authority
  , UrlComponents -> Path 'Absolute
urlPath :: Path 'Absolute
  , UrlComponents -> Maybe Query
urlQuery :: Maybe Query
  , UrlComponents -> Maybe Fragment
urlFragment :: Maybe Fragment
  } deriving (UrlComponents -> UrlComponents -> Bool
(UrlComponents -> UrlComponents -> Bool)
-> (UrlComponents -> UrlComponents -> Bool) -> Eq UrlComponents
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: UrlComponents -> UrlComponents -> Bool
== :: UrlComponents -> UrlComponents -> Bool
$c/= :: UrlComponents -> UrlComponents -> Bool
/= :: UrlComponents -> UrlComponents -> Bool
Eq, Int -> UrlComponents -> ShowS
[UrlComponents] -> ShowS
UrlComponents -> String
(Int -> UrlComponents -> ShowS)
-> (UrlComponents -> String)
-> ([UrlComponents] -> ShowS)
-> Show UrlComponents
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UrlComponents -> ShowS
showsPrec :: Int -> UrlComponents -> ShowS
$cshow :: UrlComponents -> String
show :: UrlComponents -> String
$cshowList :: [UrlComponents] -> ShowS
showList :: [UrlComponents] -> ShowS
Show, (forall (m :: * -> *). Quote m => UrlComponents -> m Exp)
-> (forall (m :: * -> *).
    Quote m =>
    UrlComponents -> Code m UrlComponents)
-> Lift UrlComponents
forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => UrlComponents -> m Exp
forall (m :: * -> *).
Quote m =>
UrlComponents -> Code m UrlComponents
$clift :: forall (m :: * -> *). Quote m => UrlComponents -> m Exp
lift :: forall (m :: * -> *). Quote m => UrlComponents -> m Exp
$cliftTyped :: forall (m :: * -> *).
Quote m =>
UrlComponents -> Code m UrlComponents
liftTyped :: forall (m :: * -> *).
Quote m =>
UrlComponents -> Code m UrlComponents
Lift)

data UrlScheme
  = HttpScheme
  | HttpsScheme

-- | A 'Url' is defined here as an absolute URI in the @http@ or @https@ schemes.  Authority components are requried by the http / https
-- Uri schemes.
data Url (scheme :: Symbol) where
  HttpUrl  :: UrlComponents -> Url "http"
  HttpsUrl :: UrlComponents -> Url "https"

instance Eq (Url scheme) where
  == :: Url scheme -> Url scheme -> Bool
(==) (HttpUrl UrlComponents
u1)  (HttpUrl UrlComponents
u2)  = UrlComponents -> String
forall a. Show a => a -> String
show UrlComponents
u1 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== UrlComponents -> String
forall a. Show a => a -> String
show UrlComponents
u2
  (==) (HttpsUrl UrlComponents
u1) (HttpsUrl UrlComponents
u2) = UrlComponents -> String
forall a. Show a => a -> String
show UrlComponents
u1 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== UrlComponents -> String
forall a. Show a => a -> String
show UrlComponents
u2

instance Show (Url scheme) where
  show :: Url scheme -> String
show (HttpUrl UrlComponents
wu)  = String
"http " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> UrlComponents -> String
forall a. Show a => a -> String
show UrlComponents
wu
  show (HttpsUrl UrlComponents
wu) = String
"https " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> UrlComponents -> String
forall a. Show a => a -> String
show UrlComponents
wu

instance Lift (Url scheme) where
  lift :: forall (m :: * -> *). Quote m => Url scheme -> m Exp
lift (HttpUrl UrlComponents
uc)  = [| HttpUrl uc |]
  lift (HttpsUrl UrlComponents
uc) = [| HttpsUrl uc |]

-- | `AnyUrl` is a wrapper aroud `Url` which allows either @http@ or @https@ urls.
data AnyUrl = forall scheme. AnyUrl (Url scheme)

instance Eq AnyUrl where
  == :: AnyUrl -> AnyUrl -> Bool
(==) (AnyUrl (HttpUrl UrlComponents
d1)) (AnyUrl (HttpUrl UrlComponents
d2))   = UrlComponents
d1 UrlComponents -> UrlComponents -> Bool
forall a. Eq a => a -> a -> Bool
== UrlComponents
d2
  (==) (AnyUrl (HttpsUrl UrlComponents
d1)) (AnyUrl (HttpsUrl UrlComponents
d2)) = UrlComponents
d1 UrlComponents -> UrlComponents -> Bool
forall a. Eq a => a -> a -> Bool
== UrlComponents
d2
  (==) AnyUrl
_  AnyUrl
_                                          = Bool
False

instance Show AnyUrl where
  show :: AnyUrl -> String
show (AnyUrl Url scheme
u) = Url scheme -> String
forall a. Show a => a -> String
show Url scheme
u

instance Lift AnyUrl where
  lift :: forall (m :: * -> *). Quote m => AnyUrl -> m Exp
lift (AnyUrl Url scheme
u)  = [| AnyUrl u |]