{- This file is part of network-iri.
 -
 - Written in 2018, 2019 by fr33domlover <fr33domlover@riseup.net>.
 -
 - ♡ Copying is an act of love. Please copy, reuse and share.
 -
 - The author(s) have dedicated all copyright and related and neighboring
 - rights to this software to the public domain worldwide. This software is
 - distributed without any warranty.
 -
 - You should have received a copy of the CC0 Public Domain Dedication along
 - with this software. If not, see
 - <http://creativecommons.org/publicdomain/zero/1.0/>.
 -}

{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE DeriveLift                 #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE TemplateHaskellQuotes      #-}

module Network.IRI
    ( -- * URI
      -- ** Types
      URI ()
    , Gen
    , Ref
    , Abs
    , Rel
      -- ** Components and predicates
    , hasAuthority
      -- ** Parsing
    , parseURI
    , parseURIReference
    , parseAbsoluteURI
    , parseRelativeReference
      -- ** Rendering
    , renderURI
      -- ** Relative URIs
    , resolveURIReference
    , resolveRelativeReference
    , makeRelative
      -- ** Static URIs
    , staticURI
    , staticURIReference
    , staticAbsoluteURI
    , staticRelativeReference
    , quotedURI
    , quotedURIReference
    , quotedAbsoluteURI
    , quotedRelativeReference
      -- ** Attoparsec parsers
    , uri
    , uriReference
    , absoluteURI
    , relativeRef

      -- * Compact and split URI
      -- ** Types
    , RelNoAuth ()
    , CompactURI ()
      -- ** Components and predicates
    , compactURIPrefix
      -- ** Parsing
    , parseRelNoAuth
    , parseCompactURI
      -- ** Conversion to and from URI
    , relNoAuthFromRelative
    , relativeFromNoAuth
    , parseCompactFromURI
    , parseCompactFromRel
    , parseURIFromCompact
      -- ** Rendering
    , renderRelNoAuth
    , renderCompactURI
      -- ** Splitting and compaction
    , splitURI
    , compactURI
      -- ** Concatenation and expansion
    , uriConcat
    , expandCompactURI

      -- * Token
    , RelToken ()
    , parseRelToken
    , renderRelToken
    , relFromRelToken
    , relTokenFromRel
    , splitRelToken
    )
where

import Control.Applicative (many, optional, (<|>))
import Control.Arrow ((***))
import Control.Exception (displayException)
import Control.Monad (when, guard)
import Data.Attoparsec.ByteString.Char8
import Data.Bifunctor (first)
import Data.Bits (shiftL, (.|.))
import Data.ByteString (ByteString)
import Data.Char hiding (isDigit)
import Data.Foldable (foldl')
import Data.Hashable
import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
import Data.Maybe (isNothing, isJust)
import Data.Semigroup (Semigroup ((<>)))
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8, decodeUtf8, decodeUtf8')
import Data.Word (Word8, Word16, Word32, Word64)
import GHC.Generics (Generic)
import Instances.TH.Lift ()
import Language.Haskell.TH.Quote (QuasiQuoter (..))
import Language.Haskell.TH.Syntax (Q (), TExp (), Lift (..), unTypeQ)
import Numeric (showHex)

import qualified Data.Attoparsec.ByteString.Char8 as A (takeWhile)
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BC
import qualified Data.List.NonEmpty as N (toList)
import qualified Data.Text as T

instance Lift a => Lift (NonEmpty a) where
    lift (x :| xs) = [| x :| xs |]

newtype Scheme = Scheme ByteString deriving (Eq, Ord, Lift, Generic)

instance Hashable Scheme

newtype Prefix = Prefix ByteString deriving (Eq, Ord, Lift, Generic)

instance Hashable Prefix

newtype UserInfo = UserInfo Text deriving (Eq, Ord, Lift, Generic)

instance Hashable UserInfo

newtype IPv4 = IPv4 Word32 deriving (Eq, Ord, Lift, Generic)

instance Hashable IPv4

data IPv6 = IPv6 Word64 Word64 deriving (Eq, Ord, Lift, Generic)

instance Hashable IPv6

data IPvFuture = IPvFuture Integer ByteString deriving (Eq, Ord, Lift, Generic)

instance Hashable IPvFuture

newtype DomainSegment = DomainSegment Text deriving (Eq, Ord, Lift, Generic)

instance Hashable DomainSegment

newtype RegName = RegName [DomainSegment] deriving (Eq, Ord, Lift, Generic)

instance Hashable RegName

data Host
    = HostIPv4 IPv4
    | HostIPv6 IPv6
    | HostIPvFuture IPvFuture
    | HostRegName RegName
    deriving (Eq, Ord, Lift, Generic)

instance Hashable Host

newtype Port = Port Word16 deriving (Eq, Ord, Lift, Generic)

instance Hashable Port

data Authority = Authority
    { _authorityUserInfo :: Maybe UserInfo
    , _authorityHost     :: Host
    , _authorityPort     :: Maybe Port
    }
    deriving (Eq, Ord, Lift, Generic)

instance Hashable Authority

newtype PathSegment = PathSegment Text deriving (Eq, Ord, Lift, Generic)

instance Hashable PathSegment

data HierarchyNoAuth
    = HierarchyAbsolute [PathSegment]
    | HierarchyRootless (NonEmpty PathSegment)
    | HierarchyEmpty
    deriving (Eq, Ord, Lift, Generic)

instance Hashable HierarchyNoAuth

data Hierarchy
    = HierarchyAuthorized Authority [PathSegment]
    | HierarchyOther HierarchyNoAuth
    deriving (Eq, Ord, Lift, Generic)

instance Hashable Hierarchy

newtype Query = Query Text deriving (Eq, Ord, Lift, Generic)

instance Hashable Query

newtype Fragment = Fragment Text deriving (Eq, Ord, Lift, Generic)

instance Hashable Fragment

data Gen

data Ref

data Abs

data Rel

data URI t = URI
    { uriScheme    :: Scheme
    , uriHierarchy :: Hierarchy
    , uriQuery     :: Maybe Query
    , uriFragment  :: Maybe Fragment
    }
    deriving
        ( Eq
        , Ord
        -- ^ NOTE: This is the default instance generated by GHC, it doesn't
        --   necessarily correcpond to the textual comparison of URIs!
        , Lift
        , Generic
        )

instance Hashable (URI t)

data RelNoAuth = RelNoAuth
    { rnaHierarchy :: HierarchyNoAuth
    , rnaQuery     :: Maybe Query
    , rnaFragment  :: Maybe Fragment
    }
    deriving (Eq, Ord, Lift, Generic)

instance Hashable RelNoAuth

data CompactURI = CompactURI
    { compactPrefix :: Prefix
    , compactSuffix :: RelNoAuth
    }
    deriving
        ( Eq
        , Ord
        -- ^ NOTE: This is the default instance generated by GHC, it doesn't
        --   necessarily correcpond to the textual comparison of compact URIs!
        , Lift
        , Generic
        )

instance Hashable CompactURI

newtype RelToken = RelToken
    { _unToken :: ByteString
    }
    deriving (Eq, Ord, Lift, Semigroup, Generic, Hashable)

data CompactError
    = BothBaseAndSuffixHaveFragments
    | SuffixHeadWouldAppendToAuth
    | AuthWouldBeCreatedFromSuffixHead
    | SuffixHeadWouldAppendToBaseLast

compactURIPrefix :: CompactURI -> RelNoAuth
compactURIPrefix (CompactURI (Prefix b) _) = RelNoAuth
    { rnaHierarchy = HierarchyRootless $ PathSegment (decodeUtf8 b) :| []
    , rnaQuery     = Nothing
    , rnaFragment  = Nothing
    }

hasAuthority :: URI t -> Bool
hasAuthority u =
    case uriHierarchy u of
        HierarchyAuthorized _ _ -> True
        HierarchyOther _        -> False

parseURI :: ByteString -> Maybe (URI Gen)
parseURI = parseOnly' uri

parseURIReference :: ByteString -> Maybe (URI Ref)
parseURIReference = parseOnly' uriReference

parseAbsoluteURI :: ByteString -> Maybe (URI Abs)
parseAbsoluteURI = parseOnly' absoluteURI

parseRelativeReference :: ByteString -> Maybe (URI Rel)
parseRelativeReference = parseOnly' relativeRef

parseOnly' :: Parser a -> ByteString -> Maybe a
parseOnly' p = maybeRight . parseOnly (p <* endOfInput)

maybeRight :: Either a b -> Maybe b
maybeRight (Left _)  = Nothing
maybeRight (Right x) = Just x

renderURI :: URI t -> ByteString
renderURI (URI (Scheme s) hier q f) = B.concat
    [ if B.null s
        then B.empty
        else s <> ":"
    , case hier of
        HierarchyAuthorized (Authority mui h mp) segs -> B.concat
            [ "//"
            , case mui of
                Nothing           -> B.empty
                Just (UserInfo t) -> percentEncode userinfoChar t <> "@"
            , case h of
                HostIPv4 (IPv4 w) ->
                    B.intercalate "." $ map hex $ split 0xff w
                HostIPv6 (IPv6 w v) -> B.concat
                    [ "["
                    , B.intercalate ":" $
                        map hex $
                        split 0xffff w ++ split 0xffff v
                    , "]"
                    ]
                HostIPvFuture (IPvFuture i b) -> B.concat
                    [ "[v"
                    , hex i
                    , "."
                    , b
                    , "]"
                    ]
                HostRegName (RegName dsegs) ->
                    B.intercalate "." $ map unsegD dsegs
            , case mp of
                Nothing       -> B.empty
                Just (Port w) -> ":" <> BC.pack (show w)
            , if null segs
                then B.empty
                else "/" <> B.intercalate "/" (map unsegP segs)
            ]
        HierarchyOther hier' ->
            case hier' of
                HierarchyAbsolute segs ->
                    "/" <> B.intercalate "/" (map unsegP segs)
                HierarchyRootless (x :| xs) ->
                    if B.null s
                        then B.intercalate "/" $ unsegPC x : map unsegP xs
                        else B.intercalate "/" $ map unsegP $ x : xs
                HierarchyEmpty -> B.empty
    , case q of
        Nothing        -> B.empty
        Just (Query t) -> "?" <> percentEncode queryOrFragmentChar t
    , case f of
        Nothing           -> B.empty
        Just (Fragment t) -> "#" <> percentEncode queryOrFragmentChar t
    ]
    where
    unsegP (PathSegment t) = percentEncode isPathCharLit t
    unsegPC (PathSegment t) = percentEncode isPathCharLitNoColon t
    unsegD (DomainSegment t) = percentEncode regNameSegChar t
    split :: Integral i => i -> i -> [i]
    split b n =
        let dm = flip divMod b
            (((n1, n2), n3), n4) = first (first dm . dm) . dm $ n
        in  [n1, n2, n3, n4]
    hex :: (Integral i, Show i) => i -> ByteString
    hex = BC.pack . flip showHex ""

percentEncode :: (Char -> Bool) -> Text -> ByteString
percentEncode p =
    let enc c =
            if p c
                then BC.singleton c
                else BC.pack $ (:) '%' $ map toUpper $ showHex (ord c) ""
    in  BC.concatMap enc . encodeUtf8

resolveURIReference :: URI Gen -> URI Ref -> URI Gen
resolveURIReference base (URI s@(Scheme b) h q f) =
    if B.null b
        then resolveRelativeReference base $ URI s h q f
        else URI s (removeDotSegments h) q f

resolveRelativeReference :: URI Gen -> URI Rel -> URI Gen
resolveRelativeReference base rel = URI s h q f
    where
    s = uriScheme base
    f = uriFragment rel
    (h, q) = case uriHierarchy rel of
        HierarchyAuthorized auth path ->
            ( removeDotSegments $ HierarchyAuthorized auth path
            , uriQuery rel
            )
        HierarchyOther hier ->
            case hier of
                HierarchyAbsolute path ->
                    ( removeDotSegments $
                      case uriHierarchy base of
                        HierarchyAuthorized auth _ ->
                            HierarchyAuthorized auth path
                        _ ->
                            HierarchyOther $ HierarchyAbsolute path
                    , uriQuery rel
                    )
                HierarchyRootless path ->
                    ( removeDotSegments $ mergePaths (uriHierarchy base) path
                    , uriQuery rel
                    )
                HierarchyEmpty ->
                    ( uriHierarchy base
                    , case uriQuery rel of
                        Nothing  -> uriQuery base
                        Just qry -> Just qry
                    )

mergePaths :: Hierarchy -> NonEmpty PathSegment -> Hierarchy
mergePaths hier segs =
    case hier of
        HierarchyAuthorized auth path ->
            HierarchyAuthorized auth $
            if null path
                then N.toList segs
                else init path ++ N.toList segs
        HierarchyOther hier' ->
            HierarchyOther $
            case hier' of
                HierarchyAbsolute path ->
                    HierarchyAbsolute $
                    if null path
                        then N.toList segs
                        else init path ++ N.toList segs
                HierarchyRootless (h :| t) ->
                    HierarchyRootless $
                    if null t
                        then segs
                        else (h :| init t) <> segs
                HierarchyEmpty ->
                    HierarchyRootless segs

removeDotSegments :: Hierarchy -> Hierarchy
removeDotSegments hier =
    case hier of
        HierarchyAuthorized a ss -> HierarchyAuthorized a $ foldSegs ss
        HierarchyOther hier' -> case hier' of
            HierarchyAbsolute ss ->
                case foldSegs ss of
                    [] ->
                        HierarchyOther $
                        if null ss
                            then HierarchyAbsolute []
                            else HierarchyEmpty
                    l@(PathSegment t : _) ->
                        if T.null t
                            then HierarchyAuthorized emptyAuth l
                            else HierarchyOther $ HierarchyAbsolute l
            HierarchyRootless ss ->
                case foldSegs $ N.toList ss of
                    []                     -> HierarchyOther HierarchyEmpty
                    [PathSegment ""]       -> HierarchyOther HierarchyEmpty
                    l@(PathSegment "" : _) -> HierarchyAuthorized emptyAuth l
                    h:t                    ->
                        HierarchyOther $ HierarchyRootless $ h :| t
            HierarchyEmpty -> HierarchyOther HierarchyEmpty
    where
    emptyAuth = Authority Nothing (HostRegName (RegName [])) Nothing
    foldSegs = reverse . foldl' handleDots []
    handleDots l (PathSegment ".")  = l
    handleDots l (PathSegment "..") =
        case l of
            []    -> []
            (_:t) -> t
    handleDots l s                  = s : l

makeRelative :: URI Gen -> URI Gen -> Maybe (URI Rel)
makeRelative = error "TODO implement"

splitURI :: URI Gen -> URI Gen -> Maybe RelNoAuth
splitURI (URI bs bh bq bf) (URI us uh uq uf) = do
    guard $ bs == us
    h <- case (bh, uh) of
        (HierarchyAuthorized a xs, HierarchyAuthorized b ys) -> do
            guard $ a == b
            absDiff xs ys
        (HierarchyOther hb, HierarchyOther hu) ->
            case (hb, hu) of
                (HierarchyAbsolute xs, HierarchyAbsolute ys) ->
                    case xs of
                        [] ->
                            case ys of
                                [] -> Just HierarchyEmpty
                                v@(PathSegment t) : vs -> do
                                    guard $ noColon t
                                    Just $ HierarchyRootless $ v :| vs
                        _ -> absDiff xs ys
                (HierarchyRootless (x :| xs), HierarchyRootless (y :| ys)) ->
                    do  guard $ x == y
                        absDiff xs ys
                (HierarchyEmpty, _) -> Just hu
                _ -> Nothing
        _ -> Nothing
    case h of
        HierarchyEmpty ->
            case (bq, bf, uq, uf) of
                (Nothing, Nothing, _, _) -> do
                    guard $ isJust uq || isJust uf
                    Just $ RelNoAuth h uq uf
                (_, Just (Fragment f), _, Just (Fragment f')) -> do
                    guard $ bq == uq
                    s <- T.stripPrefix f f'
                    guard $ not $ T.null s
                    parseOnly' relativeNoAuth $
                        percentEncode queryOrFragmentChar s
                (Just (Query q), Nothing, Just (Query q'), _) -> do
                    s <- T.stripPrefix q q'
                    when (isNothing uf) $ guard $ not $ T.null s
                    (r, mq) <-
                        parseOnly' rel $
                            percentEncode queryOrFragmentChar s
                    Just $ RelNoAuth r mq uf
                    where
                    rel = (,)
                        <$> relativePartNoAuth
                        <*> optional (char '?' *> query)
                _ -> Nothing
        _ -> do
            guard $ isNothing bq && isNothing bf
            Just $ RelNoAuth h uq uf
    where
    stripPrefix' :: Eq a => [a] -> [a] -> Maybe (Maybe (a, a), [a])
    stripPrefix' []     ys     = Just (Nothing, ys)
    stripPrefix' (_:_)  []     = Nothing
    stripPrefix' (x:xs) (y:ys) =
        if x == y
            then stripPrefix' xs ys
            else if null xs
                then Just (Just (x, y), ys)
                else Nothing
    noColon = isNothing . T.find (== ':')
    absDiff xs ys = do
        (mpair, zs) <- stripPrefix' xs ys
        case mpair of
            Nothing ->
                case zs of
                    [] -> Just HierarchyEmpty
                    (PathSegment t) : ws ->
                        if T.null t
                            then do
                                guard $ null ws
                                Just $ HierarchyAbsolute []
                            else Just $ HierarchyAbsolute zs
            Just (PathSegment t, y@(PathSegment u)) -> do
                guard $ T.null t && noColon u
                Just $ HierarchyRootless $ y :| ys

compactURI :: ByteString -> URI Gen -> URI Gen -> Maybe CompactURI
compactURI p b u = parseCompactFromRel p =<< splitURI b u

parseRelNoAuth :: ByteString -> Maybe RelNoAuth
parseRelNoAuth = parseOnly' relativeNoAuth

relNoAuthFromRelative :: URI Rel -> Maybe RelNoAuth
relNoAuthFromRelative (URI _ h q f) =
    case h of
        HierarchyAuthorized _ _ -> Nothing
        HierarchyOther h'       -> Just $ RelNoAuth h' q f

relativeFromNoAuth :: RelNoAuth -> URI Rel
relativeFromNoAuth (RelNoAuth h q f) =
    URI (Scheme B.empty) (HierarchyOther h) q f

renderRelNoAuth :: RelNoAuth -> ByteString
renderRelNoAuth (RelNoAuth hier mq mf) = B.concat
    [ case hier of
        HierarchyAbsolute segs ->
            "/" <> B.intercalate "/" (map unsegP segs)
        HierarchyRootless (x :| xs) ->
            B.intercalate "/" $ unsegPC x : map unsegP xs
        HierarchyEmpty -> B.empty
    , case mq of
        Nothing        -> B.empty
        Just (Query q) -> "?" <> percentEncode queryOrFragmentChar q
    , case mf of
        Nothing           -> B.empty
        Just (Fragment f) -> "#" <> percentEncode queryOrFragmentChar f
    ]
    where
    unsegP (PathSegment t) = percentEncode isPathCharLit t
    unsegPC (PathSegment t) = percentEncode isPathCharLitNoColon t

parseCompactURI :: ByteString -> Maybe CompactURI
parseCompactURI = parseOnly' compact

renderCompactURI :: CompactURI -> ByteString
renderCompactURI (CompactURI (Prefix p) rel) =
    p <> ":" <> renderRelNoAuth rel

uriConcat :: URI Gen -> RelNoAuth -> Maybe (URI Gen)
uriConcat (URI bs bh bq bf) (RelNoAuth rh rq rf) =
    maybeRight $
    case bf of
        Just (Fragment f) ->
            URI bs bh bq . Just . Fragment . (f <>) <$> rel2fragment rh rq rf
        Nothing ->
            case bq of
                Just (Query q) ->
                    Right $ URI bs bh (Just $ Query $ q <> rel2query rh rq) rf
                Nothing ->
                    (\ h -> URI bs h rq rf) <$> concatPaths bh rh
    where
    unseg (PathSegment t) = t
    h2t h = case h of
            HierarchyAbsolute segs ->
                "/" <> T.intercalate "/" (map unseg segs)
            HierarchyRootless segs ->
                T.intercalate "/" $ map unseg $ N.toList segs
            HierarchyEmpty -> T.empty
    rel2fragment _ _                (Just _) =
        Left BothBaseAndSuffixHaveFragments
    rel2fragment h Nothing          Nothing  = Right $ h2t h
    rel2fragment h (Just (Query q)) Nothing  = Right $ h2t h <> "?" <> q
    rel2query h Nothing          = h2t h
    rel2query h (Just (Query q)) = h2t h <> "?" <> q
    concatPaths (HierarchyAuthorized auth xs) h =
        HierarchyAuthorized auth <$>
            case h of
                HierarchyAbsolute ys -> Right $ xs ++ ys
                HierarchyRootless ys ->
                    if null xs
                        then Left SuffixHeadWouldAppendToAuth
                        else
                            if T.null $ unseg $ last xs
                                then Right $ init xs ++ N.toList ys
                                else Left SuffixHeadWouldAppendToBaseLast
                HierarchyEmpty -> Right xs
    concatPaths (HierarchyOther hier) h =
        HierarchyOther <$>
        case hier of
            HierarchyAbsolute xs ->
                HierarchyAbsolute <$>
                case h of
                    HierarchyAbsolute ys ->
                        if null xs
                            then Left AuthWouldBeCreatedFromSuffixHead
                            else Right $
                                    if null ys
                                        then xs ++ [PathSegment ""]
                                        else xs ++ ys
                    HierarchyRootless ys ->
                        if null xs
                            then Right $ N.toList ys
                            else
                                if T.null $ unseg $ last xs
                                    then Right $ init xs ++ N.toList ys
                                    else Left SuffixHeadWouldAppendToBaseLast
                    HierarchyEmpty -> Right xs
            HierarchyRootless xs@(x :| l) ->
                HierarchyRootless <$>
                case h of
                    HierarchyAbsolute ys ->
                        Right $
                        case nonEmpty ys of
                            Nothing  -> x :| l ++ [PathSegment ""]
                            Just ys' -> xs <> ys'
                    HierarchyRootless ys ->
                        if null l
                            then Left SuffixHeadWouldAppendToBaseLast
                            else
                                if T.null $ unseg $ last l
                                    then Right $ (x :| init l) <> ys
                                    else Left SuffixHeadWouldAppendToBaseLast
                    HierarchyEmpty -> Right xs
            HierarchyEmpty -> Right h

-- TODO RDFa core says use pathRootless i.e. ALLOW literal colon in relative's
-- head! Update my code for that, hopefully it makes it simpler!
--
-- On the other hand, it also means that a compact suffix now can look like an
-- absolute URI; but is that a problem? Hmm I hope not; let's just go with the
-- stuff RDFa core spec says, and see how it goes.
--
-- NOTE: Right now, since colons aren't allowed, every RelNoAuth is also a
-- valid URI Rel. If I make colons valid, it won't be so anymore. Since
-- RelNoAuth is used for CURIE expansion / uriConcat and URI Rel is used for
-- relative URI resolution, I'll need to allow for a type that supports both,
-- i.e. like AbsoluteOrCompact except it will be RelOrRNA or something like
-- that.

expandCompactURI :: URI Gen -> CompactURI -> Maybe (URI Gen)
expandCompactURI base (CompactURI _ rel) = uriConcat base rel

parseCompactFromURI :: URI Gen -> Maybe CompactURI
parseCompactFromURI (URI _          (HierarchyAuthorized _ _) _ _) = Nothing
parseCompactFromURI (URI (Scheme s) (HierarchyOther h)        q f) =
    case h of
        HierarchyRootless ((PathSegment t) :| _) ->
             case T.find (== ':') t of
                Just _ -> Nothing
                Nothing -> c
        _ -> c
    where
    c = if '+' `BC.elem` s
            then Nothing
            else Just $ CompactURI (Prefix s) (RelNoAuth h q f)

parseCompactFromRel :: ByteString -> RelNoAuth -> Maybe CompactURI
parseCompactFromRel p r = flip CompactURI r <$> parseOnly' prefix p

parseURIFromCompact :: CompactURI -> Maybe (URI Gen)
parseURIFromCompact (CompactURI (Prefix p) (RelNoAuth h q f)) =
    case h of
        HierarchyRootless ((PathSegment t) :| _) ->
             case T.find (== ':') t of
                Just _ -> Nothing
                Nothing -> u
        _ -> u
    where
    validFirst c = isAsciiLower c || isAsciiUpper c
    validRest c = isAsciiLower c || isAsciiUpper c || c == '-' || c == '.'
    u = if validFirst (BC.head p) && BC.all validRest (B.tail p)
            then Just $ URI (Scheme p) (HierarchyOther h) q f
            else Nothing

staticURI :: String -> Q (TExp (URI Gen))
staticURI s =
    case parseURI $ encodeUtf8 $ T.pack s of
        Nothing -> fail $ "Invalid static URI Gen: " ++ s
        Just u  -> [|| u ||]

staticURIReference :: String -> Q (TExp (URI Ref))
staticURIReference s =
    case parseURIReference $ encodeUtf8 $ T.pack s of
        Nothing -> fail $ "Invalid static URI Ref: " ++ s
        Just u  -> [|| u ||]

staticAbsoluteURI :: String -> Q (TExp (URI Abs))
staticAbsoluteURI s =
    case parseAbsoluteURI $ encodeUtf8 $ T.pack s of
        Nothing -> fail $ "Invalid static URI Abs: " ++ s
        Just u  -> [|| u ||]

staticRelativeReference :: String -> Q (TExp (URI Rel))
staticRelativeReference s =
    case parseRelativeReference $ encodeUtf8 $ T.pack s of
        Nothing -> fail $ "Invalid static URI Rel: " ++ s
        Just u  -> [|| u ||]

quoter :: (String -> Q (TExp a)) -> QuasiQuoter
quoter static = QuasiQuoter
    { quoteExp  = unTypeQ . static
    , quotePat  = err
    , quoteType = err
    , quoteDec  = err
    }
    where
    err = error "This quasi-quoter supports only expressions"

quotedURI :: QuasiQuoter
quotedURI = quoter staticURI

quotedURIReference :: QuasiQuoter
quotedURIReference = quoter staticURIReference

quotedAbsoluteURI :: QuasiQuoter
quotedAbsoluteURI = quoter staticAbsoluteURI

quotedRelativeReference :: QuasiQuoter
quotedRelativeReference = quoter staticRelativeReference

parseRelToken :: ByteString -> Maybe RelToken
parseRelToken = parseOnly' relToken

renderRelToken :: RelToken -> ByteString
renderRelToken (RelToken b) = b

relFromRelToken :: RelToken -> RelNoAuth
relFromRelToken (RelToken b) = RelNoAuth
    { rnaHierarchy = HierarchyRootless $ PathSegment (decodeUtf8 b) :| []
    , rnaQuery     = Nothing
    , rnaFragment  = Nothing
    }

relTokenFromRel :: RelNoAuth -> Maybe RelToken
relTokenFromRel
    (RelNoAuth (HierarchyRootless (PathSegment t :| [])) Nothing Nothing) =
        parseRelToken $ encodeUtf8 t
relTokenFromRel _ = Nothing

splitRelToken :: RelToken -> RelToken -> Maybe RelToken
splitRelToken (RelToken base) (RelToken val) = do
    rel <- B.stripPrefix base val
    guard $ not $ B.null rel
    Just $ RelToken rel

relToken :: Parser RelToken
relToken = RelToken <$> takeWhile1 isPathCharLitNoColon

uri' :: Parser (URI t)
uri' = URI
    <$> scheme <* char ':'
    <*> hierPart
    <*> optional (char '?' *> query)
    <*> optional (char '#' *> fragment)

uri :: Parser (URI Gen)
uri = uri'

hierPart :: Parser Hierarchy
hierPart
    =   HierarchyAuthorized <$> (string "//" *> authority) <*> pathAbEmpty
    <|> HierarchyOther <$>
            (   HierarchyAbsolute <$> pathAbsolute
            <|> HierarchyRootless <$> pathRootless
            <|> pure HierarchyEmpty
            )

uriReference :: Parser (URI Ref)
uriReference = uri' <|> relativeRef'

absoluteURI :: Parser (URI Abs)
absoluteURI = URI
    <$> scheme <* char ':'
    <*> hierPart
    <*> optional (char '?' *> query)
    <*> pure Nothing

relativeNoAuth :: Parser RelNoAuth
relativeNoAuth = RelNoAuth
    <$> relativePartNoAuth
    <*> optional (char '?' *> query)
    <*> optional (char '#' *> fragment)

relativeRef' :: Parser (URI t)
relativeRef' = URI
    <$> pure (Scheme B.empty)
    <*> relativePart
    <*> optional (char '?' *> query)
    <*> optional (char '#' *> fragment)

relativeRef :: Parser (URI Rel)
relativeRef = relativeRef'

relativePartNoAuth :: Parser HierarchyNoAuth
relativePartNoAuth
    =   HierarchyAbsolute <$> pathAbsolute
    <|> HierarchyRootless <$> pathNoScheme
    <|> pure HierarchyEmpty

relativePart :: Parser Hierarchy
relativePart
    =   HierarchyAuthorized <$> (string "//" *> authority) <*> pathAbEmpty
    <|> HierarchyOther <$> relativePartNoAuth

prefix :: Parser Prefix
prefix = fmap Prefix
    $   BC.cons <$> letter_ascii <*> A.takeWhile prefixChar
    <|> BC.cons <$> char '_' <*> takeWhile1 prefixChar
    where
    prefixChar c =
        isAsciiLower c || isAsciiUpper c || isDigit c ||
        c == '_' || c == '-' || c == '.'

compact :: Parser CompactURI
compact = CompactURI <$> prefix <* char ':' <*> relativeNoAuth

scheme :: Parser Scheme
scheme = (Scheme .) . BC.cons <$> letter_ascii <*> A.takeWhile schemeChar
    where
    schemeChar c =
        isAsciiLower c || isAsciiUpper c || c == '+' || c == '-' || c == '.'

authority :: Parser Authority
authority = Authority
    <$> optional (userinfo <* char '@')
    <*> host
    <*> optional (char ':' *> port)

userinfoChar :: Char -> Bool
userinfoChar c = unreserved c || subDelim c || c == ':'

userinfo :: Parser UserInfo
userinfo = UserInfo <$> bsOrPercentText0 userinfoChar

host :: Parser Host
host
    =   either HostIPv6 HostIPvFuture <$> ipLiteral
    <|> (\ (h, l) ->
            HostIPv4 $ IPv4 $ fromIntegral h `shiftL` 16 .|. fromIntegral l)
        <$> ipv4Address
    <|> HostRegName <$> regName

port :: Parser Port
port = do
    d <- decimal
    if d > 65535
        then fail "port > 65535"
        else return . Port $ fromInteger d

ipLiteral :: Parser (Either IPv6 IPvFuture)
ipLiteral = char '[' *> eitherP ipv6Address ipvFuture <* char ']'

ipvFuture :: Parser IPvFuture
ipvFuture = IPvFuture
    <$> (char 'v' *> hexadecimal) <* char '.'
    <*> takeWhile1 (\ c -> unreserved c || subDelim c || c == ':')

ipv6Address :: Parser IPv6
ipv6Address = do
    mhs <- optional $ sepBy0n colon h16 7 <* string "::"
    uncurry IPv6 . (mult *** mult) . splitAt 4 <$>
        case mhs of
            Nothing -> sepByExactPair colon h16 ipv4Address 8
            Just hs -> do
                let l = length hs
                rest <- sepBy0nPair colon h16 ipv4Address $ 7 - l
                return $ hs ++ replicate (8 - l - length rest) 0 ++ rest
    where
    colon = char ':'

    mult = foldl' (\ n w -> n `shiftL` 16 .|. fromIntegral w) 0

    sepBy1n :: Parser s -> Parser a -> Int -> Parser [a]
    sepBy1n s p x =
        let go 1 = pure <$> p
            go n = (:) <$> p <* s <*> option [] (go $ n - 1)
        in  go x

    sepBy0n :: Parser s -> Parser a -> Int -> Parser [a]
    sepBy0n _ _ 0 = pure []
    sepBy0n s p n = option [] $ sepBy1n s p n

    sepByExactPair
        :: Parser s -> Parser a -> Parser (a, a) -> Int -> Parser [a]
    sepByExactPair s p m x =
        let go 2 =   (\ a   b  -> [a, b]) <$> p <* s <*> p
                 <|> (\ (a, b) -> [a, b]) <$> m
            go n = (:) <$> p <* s <*> go (n - 1)
        in  go x

    sepBy1nPair :: Parser s -> Parser a -> Parser (a, a) -> Int -> Parser [a]
    sepBy1nPair _ p _ 1 = pure <$> p
    sepBy1nPair s p m x =
        let go 2 =   (\ a   b  -> [a, b]) <$> p <* s <*> p
                 <|> (\ (a, b) -> [a, b]) <$> m
            go n =   (\ (a, b) -> [a, b]) <$> m
                 <|> (:) <$> p <* s
                         <*> option [] (go $ n - 1)
        in  go x

    sepBy0nPair :: Parser s -> Parser a -> Parser (a, a) -> Int -> Parser [a]
    sepBy0nPair _ _ _ 0 = pure []
    sepBy0nPair s p m n = option [] $ sepBy1nPair s p m n

h16 :: Parser Word16
h16 = mult <$> many1n hexDigit 4
    where
    hexDigit = fromIntegral . digitToInt <$> satisfy isHexDigit

    many1n :: Parser a -> Int -> Parser [a]
    many1n p 1 = pure <$> p
    many1n p n = (:) <$> p <*> option [] (many1n p $ n - 1)

    mult = foldl' (\ n w -> n `shiftL` 4 .|. w) 0

ipv4Address :: Parser (Word16, Word16)
ipv4Address = (,) <$> w16 <* dot <*> w16
    where
    dot = char '.'
    mult h l = fromIntegral h `shiftL` 8 .|. fromIntegral l
    w16 = mult <$> decOctet <* dot <*> decOctet

decOctet :: Parser Word8
decOctet = do
    d <- decimal
    if d > 255
        then fail "decOctet > 255"
        else return $ fromInteger d

regNameSegChar :: Char -> Bool
regNameSegChar c = (unreserved c || subDelim c) && c /= '.'

regName :: Parser RegName
regName = RegName <$> seg `sepBy` char '.'
    where
    seg = DomainSegment <$> bsOrPercentText1 regNameSegChar

pathAbEmpty :: Parser [PathSegment]
pathAbEmpty = many $ char '/' *> segment

pathAbsolute :: Parser [PathSegment]
pathAbsolute =
    char '/' *>
    option [] ((:) <$> segmentNZ <*> many (char '/' *> segment))

pathNoScheme :: Parser (NonEmpty PathSegment)
pathNoScheme = (:|) <$> segmentNZNC <*> many (char '/' *> segment)

pathRootless :: Parser (NonEmpty PathSegment)
pathRootless = (:|) <$> segmentNZ <*> many (char '/' *> segment)

segment :: Parser PathSegment
segment = PathSegment <$> bsOrPercentText0 isPathCharLit

segmentNZ :: Parser PathSegment
segmentNZ = PathSegment <$> bsOrPercentText1 isPathCharLit

segmentNZNC :: Parser PathSegment
segmentNZNC = PathSegment <$> bsOrPercentText1 isPathCharLitNoColon

isPathCharLit :: Char -> Bool
isPathCharLit c = isPathCharLitNoColon c || c == ':'

isPathCharLitNoColon :: Char -> Bool
isPathCharLitNoColon c = unreserved c || subDelim c || c == '@'

query :: Parser Query
query = Query <$> queryOrFragment

fragment :: Parser Fragment
fragment = Fragment <$> queryOrFragment

queryOrFragmentChar :: Char -> Bool
queryOrFragmentChar c = isPathCharLit c || c == '/' || c == '?'

queryOrFragment :: Parser Text
queryOrFragment = bsOrPercentText0 queryOrFragmentChar

bsOrPercentText0 :: (Char -> Bool) -> Parser Text
bsOrPercentText0 p = T.concat <$> many (bsOrPercentChunk p)

bsOrPercentText1 :: (Char -> Bool) -> Parser Text
bsOrPercentText1 p = T.concat <$> many1 (bsOrPercentChunk p)

bsOrPercentChunk :: (Char -> Bool) -> Parser Text
bsOrPercentChunk p
    =   decodeUtf8
            <$> takeWhile1 p
    <|> (either (fail . displayException) return =<< decodeUtf8' . B.pack)
            <$> many1 pctEncoded

pctEncoded :: Parser Word8
pctEncoded = mkoctet <$> (char '%' *> hexDigit) <*> hexDigit
    where
    mkoctet high low = high `shiftL` 4 .|. low
    hexDigit = fromIntegral . digitToInt <$> satisfy isHexDigit

unreserved :: Char -> Bool
unreserved c
    =  isAsciiLower c
    || isAsciiUpper c
    || isDigit c
    || c == '-'
    || c == '.'
    || c == '_'
    || c == '~'

{-
reserved :: Char -> Bool
reserved c = genDelim c || subDelim c

genDelim :: Char -> Bool
genDelim ':' = True
genDelim '/' = True
genDelim '?' = True
genDelim '#' = True
genDelim '[' = True
genDelim ']' = True
genDelim '@' = True
genDelim _ = False
-}

subDelim :: Char -> Bool
subDelim '!'  = True
subDelim '$'  = True
subDelim '&'  = True
subDelim '\'' = True
subDelim '('  = True
subDelim ')'  = True
subDelim '*'  = True
subDelim '+'  = True
subDelim ','  = True
subDelim ';'  = True
subDelim '='  = True
subDelim _    = False