URI.hs

-- | An implementation of URI (RFC 3986): <https://doi.org/10.17487/RFC3986>
module Mini.String.URI (
  -- * Types
  URI (
    URI
  ),
  Authority (
    Authority
  ),
  Host (
    IPv4,
    IPv6,
    IPvF,
    RegName
  ),
  Path (
    Path
  ),
  Address (
    Address
  ),
  Fragment (
    Fragment
  ),
  Port (
    Port
  ),
  Query (
    Query
  ),
  Scheme (
    Scheme
  ),
  Segment (
    Segment
  ),
  UserInfo (
    UserInfo
  ),
  Version (
    Version
  ),

  -- * Parsers
  absoluteURI,
  genericURI,
  relativeURI,

  -- * Combinators
  relativeTo,

  -- * Encoding
  encode,
  decode,

  -- * Normalization
  normalizeCase,
  normalizeDots,
  normalizeEncoding,
) where

import Control.Applicative (
  empty,
  many,
  optional,
  some,
  (<|>),
 )
import Control.Monad (
  replicateM,
 )
import Data.Bits (
  shiftL,
  shiftR,
  (.&.),
  (.|.),
 )
import Data.Bool (
  Bool,
  bool,
 )
import Data.Char (
  digitToInt,
  toLower,
  toUpper,
 )
import Data.Functor.Identity (
  runIdentity,
 )
import Data.List (
  intercalate,
 )
import Data.Maybe (
  isJust,
 )
import Data.Word (
  Word8,
 )
import qualified Mini.String.UTF8 as UTF8 (
  decode,
  encode,
 )
import Mini.Transformers.Parser (
  ParserT,
  atMost,
  match,
  oneOf,
  option,
  range,
  reject,
  sat,
  string,
  symbol,
 )
import Prelude (
  Bool (
    False,
    True
  ),
  Char,
  Eq,
  Int,
  Maybe (
    Just,
    Nothing
  ),
  Monad,
  Ord,
  Show,
  String,
  concat,
  concatMap,
  drop,
  fmap,
  fromEnum,
  id,
  maybe,
  not,
  null,
  pure,
  reverse,
  show,
  toEnum,
  uncurry,
  ($),
  (&&),
  (*>),
  (+),
  (.),
  (<$),
  (<$>),
  (<*),
  (<*>),
  (<=),
  (<>),
  (>=),
  (>>=),
 )

-- Types

-- | An absolute, generic, or relative URI
data URI
  = URI
      (Maybe Scheme)
      (Maybe Authority)
      Path
      (Maybe Query)
      (Maybe Fragment)
  deriving (Eq, Ord)

instance Show URI where
  show (URI s a p q f) =
    maybe "" ((<> ":") . show) s
      <> maybe "" (("//" <>) . show) a
      <> show p
      <> maybe "" (("?" <>) . show) q
      <> maybe "" (("#" <>) . show) f

-- | The authority component of a URI
data Authority
  = -- | without the leading @"\/\/"@
    Authority (Maybe UserInfo) Host (Maybe Port)
  deriving (Eq, Ord)

instance Show Authority where
  show (Authority u h p) =
    maybe "" ((<> "@") . show) u
      <> show h
      <> maybe "" ((":" <>) . show) p

-- | The host component of an authority
data Host
  = IPv4 Address
  | IPv6 Address
  | IPvF Version Address
  | RegName Address
  deriving (Eq, Ord)

instance Show Host where
  show (IPv4 a) = show a
  show (IPv6 a) = show a
  show (IPvF v a) = "v" <> show v <> "." <> show a
  show (RegName a) = show a

-- | The path component of a URI
data Path
  = Path
      Bool
      -- ^ Leading slash
      [Segment]
      Bool
      -- ^ Trailing slash
  deriving (Eq, Ord)

instance Show Path where
  show (Path l segs t) =
    bool "" "/" l
      <> intercalate "/" (fmap show segs)
      <> bool "" "/" t

-- | The address of a host
newtype Address = Address String
  deriving (Eq, Ord)

instance Show Address where
  show (Address a) = a

-- | The fragment component of a URI
newtype Fragment
  = -- | without the leading @"#"@
    Fragment String
  deriving (Eq, Ord)

instance Show Fragment where
  show (Fragment f) = f

-- | The port component of an authority
newtype Port
  = -- | without the leading @":"@
    Port String
  deriving (Eq, Ord)

instance Show Port where
  show (Port p) = p

-- | The query component of a URI
newtype Query
  = -- | without the leading @"?"@
    Query String
  deriving (Eq, Ord)

instance Show Query where
  show (Query q) = q

-- | The scheme component of a URI
newtype Scheme
  = -- | without the trailing @":"@
    Scheme String
  deriving (Eq, Ord)

instance Show Scheme where
  show (Scheme s) = s

-- | A segment of a path
newtype Segment
  = -- | without any delimiting @"\/"@
    Segment String
  deriving (Eq, Ord)

instance Show Segment where
  show (Segment s) = s

-- | The userinfo component of an authority
newtype UserInfo
  = -- | without the trailing @"\@"@
    UserInfo String
  deriving (Eq, Ord)

instance Show UserInfo where
  show (UserInfo u) = u

-- | The version of a future IP
newtype Version
  = -- | without the leading @"v"@ and trailing @"."@
    Version String
  deriving (Eq, Ord)

instance Show Version where
  show (Version v) = v

-- Parsers

-- | Parse an absolute URI (a generic URI without a fragment)
absoluteURI :: (Monad m) => ParserT Char m URI
absoluteURI =
  ( \(AbsoluteURI_ s h q) ->
      let (a, p) = fromHierPart_ h
       in URI (Just $ Scheme s) a p (Query <$> q) Nothing
  )
    <$> absoluteURI_

-- | Parse a generic URI (an absolute URI with an optional fragment)
genericURI :: (Monad m) => ParserT Char m URI
genericURI =
  ( \(URI_ s h q f) ->
      let (a, p) = fromHierPart_ h
       in URI (Just $ Scheme s) a p (Query <$> q) (Fragment <$> f)
  )
    <$> uri_

-- | Parse a relative URI (a generic URI without a scheme)
relativeURI :: (Monad m) => ParserT Char m URI
relativeURI =
  ( \(RelativeRef_ r q f) ->
      let (a, p) = fromRelativePart_ r
       in URI Nothing a p (Query <$> q) (Fragment <$> f)
  )
    <$> relativeRef_

-- Combinators

-- | Resolve a reference @r@ relative to a base @b@ via @r \`relativeTo\` b@
relativeTo :: URI -> URI -> URI
relativeTo (URI s' a' p'@(Path l' segs' t') q' f') (URI s a p q _) =
  bool
    ( bool
        ( bool
            (URI s a (removeDots $ bool (merge p p') p' l') q' f')
            (URI s a p (bool q q' $ isJust q') f')
            $ null segs' && not l' && not t'
        )
        (URI s a' (removeDots p') q' f')
        $ isJust a'
    )
    (URI s' a' (removeDots p') q' f')
    $ isJust s'

-- Encoding

-- | Turn a character into a percent-encoded octet sequence in UTF-8 format
encode :: Char -> String
encode = concatMap (('%' :) . twoDigitHex) . UTF8.encode
 where
  twoDigitHex w = [hex $ w `shiftR` 4, hex $ w .&. 0x0f]
  hex n = toEnum . fromEnum . (+ n) . bool 0x37 0x30 $ n <= 9

-- | Parse a percent-encoded octet sequence in UTF-8 format into a character
decode :: (Monad m) => ParserT Char m Char
decode =
  next >>= \w0 ->
    maybe
      ( next >>= \w1 ->
          maybe
            ( next >>= \w2 ->
                maybe
                  ( next >>= \w3 ->
                      maybe
                        empty
                        pure
                        . runIdentity
                        $ match UTF8.decode [w0, w1, w2, w3]
                  )
                  pure
                  . runIdentity
                  $ match UTF8.decode [w0, w1, w2]
            )
            pure
            . runIdentity
            $ match UTF8.decode [w0, w1]
      )
      pure
      . runIdentity
      $ match UTF8.decode [w0]
 where
  next :: (Monad m) => ParserT Char m Word8
  next = do
    hi <- symbol '%' *> hexdig
    lo <- hexdig
    pure . toEnum $ (digitToInt hi `shiftL` 4) .|. digitToInt lo

-- Normalization

-- | Lowercase scheme and host components, and uppercase percent-encoded octets
normalizeCase :: URI -> URI
normalizeCase (URI s a p q f) =
  URI
    (ncScheme <$> s)
    (ncAuthority <$> a)
    (ncPath p)
    (ncQuery <$> q)
    (ncFragment <$> f)
 where
  ncScheme (Scheme s') = Scheme $ fmap toLower s'
  ncAuthority (Authority u h p') = Authority u (ncHost h) p'
  ncHost (IPv6 (Address addr)) = IPv6 . Address $ fmap toLower addr
  ncHost (IPvF (Version v) (Address addr)) =
    IPvF (Version $ fmap toLower v) (Address $ fmap toLower addr)
  ncHost (RegName (Address addr)) = RegName . Address $ go toLower addr
  ncHost h@(IPv4 _) = h
  ncPath (Path l segs t) =
    Path l (fmap (\(Segment seg) -> Segment $ go id seg) segs) t
  ncQuery (Query q') = Query $ go id q'
  ncFragment (Fragment f') = Fragment $ go id f'
  go z ('%' : h1 : h2 : rest) = '%' : toUpper h1 : toUpper h2 : go z rest
  go z (c : rest) = z c : go z rest
  go _ [] = []

-- | Remove dot segments
normalizeDots :: URI -> URI
normalizeDots (URI s a p q f) = URI s a (removeDots p) q f

-- | Decode percent-encoded octets that correspond to unreserved characters
normalizeEncoding :: URI -> URI
normalizeEncoding (URI s a p q f) =
  URI
    s
    (neAuthority <$> a)
    (nePath p)
    (neQuery <$> q)
    (neFragment <$> f)
 where
  neAuthority (Authority u h p') = Authority (neUserInfo <$> u) h p'
   where
    neUserInfo (UserInfo u') = UserInfo $ go u'
  nePath (Path l segs t) =
    Path
      l
      (fmap (\(Segment seg) -> Segment $ go seg) segs)
      t
  neQuery (Query q') = Query $ go q'
  neFragment (Fragment f') = Fragment $ go f'
  go ('%' : h1 : h2 : rest) =
    maybe ('%' : h1 : h2 : go rest) (: go rest)
      . maybe
        Nothing
        (runIdentity . match unreserved . pure)
      . runIdentity
      $ match decode ['%', h1, h2]
  go (c : rest) = c : go rest
  go [] = []

-- Syntax

-- URI = scheme ":" hier-part [ "?" query ] [ "#" fragment ]
data URI_ = URI_ String HierPart_ (Maybe String) (Maybe String)

uri_ :: (Monad m) => ParserT Char m URI_
uri_ =
  URI_
    <$> scheme
    <* symbol ':'
    <*> hierPart_
    <*> optional (symbol '?' *> query)
    <*> optional (symbol '#' *> fragment)

-- hier-part
--   = "//" authority path-abempty
--   / path-absolute
--   / path-rootless
--   / path-empty
data HierPart_
  = HierPartAbempty_ Authority_ [String]
  | HierPartAbsolute_ [String]
  | HierPartRootless_ [String]
  | HierPartEmpty_

hierPart_ :: (Monad m) => ParserT Char m HierPart_
hierPart_ =
  (HierPartAbempty_ <$> (string "//" *> authority_) <*> path_abempty)
    <|> (HierPartAbsolute_ <$> path_absolute)
    <|> (HierPartRootless_ <$> path_rootless)
    <|> (HierPartEmpty_ <$ path_empty)

-- absolute-URI = scheme ":" hier-part [ "?" query ]
data AbsoluteURI_ = AbsoluteURI_ String HierPart_ (Maybe String)

absoluteURI_ :: (Monad m) => ParserT Char m AbsoluteURI_
absoluteURI_ =
  AbsoluteURI_
    <$> scheme
    <* symbol ':'
    <*> hierPart_
    <*> optional (symbol '?' *> query)

-- relative-ref = relative-part [ "?" query ] [ "#" fragment ]
data RelativeRef_ = RelativeRef_ RelativePart_ (Maybe String) (Maybe String)

relativeRef_ :: (Monad m) => ParserT Char m RelativeRef_
relativeRef_ =
  RelativeRef_
    <$> relativePart_
    <*> optional (symbol '?' *> query)
    <*> optional (symbol '#' *> fragment)

-- relative-part
--   = "//" authority path-abempty
--   / path-absolute
--   / path-noscheme
--   / path-empty
data RelativePart_
  = RelativePartAbempty_ Authority_ [String]
  | RelativePartAbsolute_ [String]
  | RelativePartNoScheme_ [String]
  | RelativePartEmpty_

relativePart_ :: (Monad m) => ParserT Char m RelativePart_
relativePart_ =
  (RelativePartAbempty_ <$> (string "//" *> authority_) <*> path_abempty)
    <|> (RelativePartAbsolute_ <$> path_absolute)
    <|> (RelativePartNoScheme_ <$> path_noscheme)
    <|> (RelativePartEmpty_ <$ path_empty)

-- scheme = ALPHA *( ALPHA / DIGIT / "+" / "-" / "." )
scheme :: (Monad m) => ParserT Char m String
scheme = (:) <$> alpha <*> many (alpha <|> digit <|> oneOf "+-.")

-- authority = [ userinfo "@" ] host [ ":" port ]
data Authority_ = Authority_ (Maybe String) Host_ (Maybe String)

authority_ :: (Monad m) => ParserT Char m Authority_
authority_ =
  Authority_
    <$> optional (userinfo <* symbol '@')
    <*> host_
    <*> optional (symbol ':' *> port)

-- userinfo = *( unreserved / pct-encoded / sub-delims / ":" )
userinfo :: (Monad m) => ParserT Char m String
userinfo =
  concat
    <$> many
      ( fmap pure unreserved
          <|> pct_encoded
          <|> fmap pure sub_delims
          <|> string ":"
      )

-- host = IP-literal / IPv4address / reg-name
data Host_
  = HostIPLiteral_ IPLiteral_
  | HostIPv4Address_ String
  | HostRegName_ String

host_ :: (Monad m) => ParserT Char m Host_
host_ =
  (HostIPLiteral_ <$> ipLiteral_)
    <|> (HostIPv4Address_ <$> ipv4address)
    <|> (HostRegName_ <$> reg_name)

-- port = *DIGIT
port :: (Monad m) => ParserT Char m String
port = many digit

-- IP-literal = "[" ( IPv6address / IPvFuture ) "]"
data IPLiteral_
  = IPLiteralIPv6Address_ String
  | IPLiteralIPvFuture_ IPvFuture_

ipLiteral_ :: (Monad m) => ParserT Char m IPLiteral_
ipLiteral_ =
  symbol '['
    *> ( (IPLiteralIPv6Address_ <$> ipv6address)
           <|> (IPLiteralIPvFuture_ <$> ipvFuture_)
       )
    <* symbol ']'

-- IPvFuture = "v" 1*HEXDIG "." 1*( unreserved / sub-delims / ":" )
-- NOTE: ABNF strings are case-insensitive
data IPvFuture_ = IPvFuture_ String String

ipvFuture_ :: (Monad m) => ParserT Char m IPvFuture_
ipvFuture_ =
  IPvFuture_
    <$> (oneOf "vV" *> some hexdig <* symbol '.')
    <*> some (unreserved <|> sub_delims <|> symbol ':')

-- IPv6address
--   =                            6( h16 ":" ) ls32
--   /                       "::" 5( h16 ":" ) ls32
--   / [               h16 ] "::" 4( h16 ":" ) ls32
--   / [ *1( h16 ":" ) h16 ] "::" 3( h16 ":" ) ls32
--   / [ *2( h16 ":" ) h16 ] "::" 2( h16 ":" ) ls32
--   / [ *3( h16 ":" ) h16 ] "::"    h16 ":"   ls32
--   / [ *4( h16 ":" ) h16 ] "::"              ls32
--   / [ *5( h16 ":" ) h16 ] "::"              h16
--   / [ *6( h16 ":" ) h16 ] "::"
-- NOTE: parsing [     *n( h16 ":" ) h16 ]
--       as      [ h16 *n( ":" h16 )     ]
--       to avoid consuming part of "::"
ipv6address :: (Monad m) => ParserT Char m String
ipv6address =
  (fmap concat (replicateM 6 $ h16 <> string ":") <> ls32)
    <|> ( string "::"
            <> fmap concat (replicateM 5 $ h16 <> string ":")
            <> ls32
        )
    <|> ( option [] h16
            <> string "::"
            <> fmap concat (replicateM 4 $ h16 <> string ":")
            <> ls32
        )
    <|> ( option [] (h16 <> fmap concat (atMost 1 $ string ":" <> h16))
            <> string "::"
            <> fmap concat (replicateM 3 $ h16 <> string ":")
            <> ls32
        )
    <|> ( option [] (h16 <> fmap concat (atMost 2 $ string ":" <> h16))
            <> string "::"
            <> fmap concat (replicateM 2 $ h16 <> string ":")
            <> ls32
        )
    <|> ( option [] (h16 <> fmap concat (atMost 3 $ string ":" <> h16))
            <> string "::"
            <> h16
            <> string ":"
            <> ls32
        )
    <|> ( option [] (h16 <> fmap concat (atMost 4 $ string ":" <> h16))
            <> string "::"
            <> ls32
        )
    <|> ( option [] (h16 <> fmap concat (atMost 5 $ string ":" <> h16))
            <> string "::"
            <> h16
        )
    <|> ( option [] (h16 <> fmap concat (atMost 6 $ string ":" <> h16))
            <> string "::"
        )

-- h16 = 1*4HEXDIG
h16 :: (Monad m) => ParserT Char m String
h16 = range 1 4 hexdig

-- ls32 = ( h16 ":" h16 ) / IPv4address
ls32 :: (Monad m) => ParserT Char m String
ls32 = (h16 <> string ":" <> h16) <|> ipv4address

-- IPv4address = dec-octet "." dec-octet "." dec-octet "." dec-octet
ipv4address :: (Monad m) => ParserT Char m String
ipv4address =
  dec_octet
    <> string "."
    <> dec_octet
    <> string "."
    <> dec_octet
    <> string "."
    <> dec_octet

-- dec-octet
--   = DIGIT
--   / %x31-39 DIGIT
--   / "1" 2DIGIT
--   / "2" %x30-34 DIGIT
--   / "25" %x30-35
-- NOTE: ordered by descending length below
--       to avoid stopping early
dec_octet :: (Monad m) => ParserT Char m String
dec_octet =
  (string "1" <> replicateM 2 digit)
    <|> (string "2" <> fmap pure (octetRange (0x30, 0x34)) <> fmap pure digit)
    <|> (string "25" <> fmap pure (octetRange (0x30, 0x35)))
    <|> (fmap pure (octetRange (0x31, 0x39)) <> fmap pure digit)
    <|> (fmap pure digit)

-- reg-name = *( unreserved / pct-encoded / sub-delims )
reg_name :: (Monad m) => ParserT Char m String
reg_name =
  concat
    <$> many (fmap pure unreserved <|> pct_encoded <|> fmap pure sub_delims)

-- path-abempty = *( "/" segment )
path_abempty :: (Monad m) => ParserT Char m [String]
path_abempty = many (symbol '/' *> segment)

-- path-absolute = "/" [ segment-nz *( "/" segment ) ]
path_absolute :: (Monad m) => ParserT Char m [String]
path_absolute =
  symbol '/' *> option [] ((:) <$> segment_nz <*> many (symbol '/' *> segment))

-- path-noscheme = segment-nz-nc *( "/" segment )
path_noscheme :: (Monad m) => ParserT Char m [String]
path_noscheme = (:) <$> segment_nz_nc <*> many (symbol '/' *> segment)

-- path-rootless = segment-nz *( "/" segment )
path_rootless :: (Monad m) => ParserT Char m [String]
path_rootless = (:) <$> segment_nz <*> many (symbol '/' *> segment)

-- path-empty = 0<pchar>
path_empty :: (Monad m) => ParserT Char m [String]
path_empty = [] <$ reject pchar

-- segment = *pchar
segment :: (Monad m) => ParserT Char m String
segment = concat <$> many pchar

-- segment-nz = 1*pchar
segment_nz :: (Monad m) => ParserT Char m String
segment_nz = concat <$> some pchar

-- segment-nz-nc = 1*( unreserved / pct-encoded / sub-delims / "@" )
segment_nz_nc :: (Monad m) => ParserT Char m String
segment_nz_nc =
  concat
    <$> some
      ( fmap pure unreserved
          <|> pct_encoded
          <|> fmap pure sub_delims
          <|> string "@"
      )

-- pchar = unreserved / pct-encoded / sub-delims / ":" / "@"
pchar :: (Monad m) => ParserT Char m String
pchar =
  fmap pure unreserved
    <|> pct_encoded
    <|> fmap pure sub_delims
    <|> string ":"
    <|> string "@"

-- query = *( pchar / "/" / "?" )
query :: (Monad m) => ParserT Char m String
query = concat <$> many (pchar <|> string "/" <|> string "?")

-- fragment = *( pchar / "/" / "?" )
fragment :: (Monad m) => ParserT Char m String
fragment = concat <$> many (pchar <|> string "/" <|> string "?")

-- pct-encoded = "%" HEXDIG HEXDIG
pct_encoded :: (Monad m) => ParserT Char m String
pct_encoded = string "%" <> replicateM 2 hexdig

-- unreserved = ALPHA / DIGIT / "-" / "." / "_" / "~"
unreserved :: (Monad m) => ParserT Char m Char
unreserved = alpha <|> digit <|> oneOf "-._~"

-- sub-delims = "!" / "$" / "&" / "'" / "(" / ")" / "*" / "+" / "," / ";" / "="
sub_delims :: (Monad m) => ParserT Char m Char
sub_delims = oneOf "!$&'()*+,;="

-- ALPHA = %x41-5A / %x61-7A
alpha :: (Monad m) => ParserT Char m Char
alpha = octetRange (0x41, 0x5A) <|> octetRange (0x61, 0x7A)

-- DIGIT = %x30-39
digit :: (Monad m) => ParserT Char m Char
digit = octetRange (0x30, 0x39)

-- HEXDIG = DIGIT / "A" / "B" / "C" / "D" / "E" / "F"
-- NOTE: ABNF strings are case-insensitive
hexdig :: (Monad m) => ParserT Char m Char
hexdig = digit <|> oneOf (['A' .. 'F'] <> ['a' .. 'f'])

-- Helpers

octetRange :: (Monad m) => (Int, Int) -> ParserT Char m Char
octetRange (lo, hi) = sat $ (\n -> n >= lo && n <= hi) . fromEnum

fromHierPart_ :: HierPart_ -> (Maybe Authority, Path)
fromHierPart_ (HierPartAbempty_ a segs) =
  (Just $ fromAuthority_ a, bool (mkAbsolute segs) mkEmpty $ null segs)
fromHierPart_ (HierPartAbsolute_ segs) = (Nothing, mkAbsolute segs)
fromHierPart_ (HierPartRootless_ segs) = (Nothing, mkRootless segs)
fromHierPart_ HierPartEmpty_ = (Nothing, mkEmpty)

fromAuthority_ :: Authority_ -> Authority
fromAuthority_ (Authority_ u h p) =
  Authority
    (UserInfo <$> u)
    ( case h of
        HostIPLiteral_ (IPLiteralIPv6Address_ addr) -> IPv6 (Address addr)
        HostIPLiteral_ (IPLiteralIPvFuture_ (IPvFuture_ v addr)) ->
          IPvF (Version v) (Address addr)
        HostIPv4Address_ addr -> IPv4 (Address addr)
        HostRegName_ addr -> RegName (Address addr)
    )
    (Port <$> p)

fromRelativePart_ :: RelativePart_ -> (Maybe Authority, Path)
fromRelativePart_ (RelativePartAbempty_ a segs) =
  (Just $ fromAuthority_ a, bool (mkAbsolute segs) mkEmpty $ null segs)
fromRelativePart_ (RelativePartAbsolute_ segs) =
  (Nothing, mkAbsolute segs)
fromRelativePart_ (RelativePartNoScheme_ segs) =
  (Nothing, mkRootless segs)
fromRelativePart_ RelativePartEmpty_ = (Nothing, mkEmpty)

mkEmpty :: Path
mkEmpty = Path False [] False

mkAbsolute :: [String] -> Path
mkAbsolute ("" : []) = Path True [] False -- edge case: path_abempty "/"
mkAbsolute segs = mkPath (Path True) segs

mkRootless :: [String] -> Path
mkRootless = mkPath (Path False)

mkPath :: ([Segment] -> Bool -> Path) -> [String] -> Path
mkPath c = uncurry c . go
 where
  go ("" : []) = ([], True)
  go (x : xs) =
    let (xs', t) = go xs
     in (Segment x : xs', t)
  go [] = ([], False)

merge :: Path -> Path -> Path
merge (Path l segs t) (Path _ segs' t') =
  bool
    (Path l (bool (go segs segs') (segs <> segs') t) t')
    (Path False segs' t')
    $ null segs && not l && not t
 where
  go (_ : []) xs' = xs'
  go (x : xs) xs' = x : go xs xs'
  go [] xs' = xs'

removeDots :: Path -> Path
removeDots (Path l segs t) = uncurry (Path l) $ go [] segs
 where
  go os (Segment "." : []) = (reverse os, not $ null os)
  go os (Segment "." : is) = go os is
  go os (Segment ".." : []) = (reverse $ drop 1 os, not . null $ drop 1 os)
  go os (Segment ".." : is) = go (drop 1 os) is
  go os (i : is) = go (i : os) is
  go os [] = (reverse os, t)