-- | Provides the 'Direction' type and singletons.
--
-- @since 0.1
module Data.Bytes.Network.Direction
  ( -- * Direction Tags
    Direction (..),
    SDirection (..),
    SingDirection (..),
    Directed (..),
    withSingDirection,
    sdirectionToDirection,

    -- * Optics
    _Down,
    _Up,
  )
where

import Control.DeepSeq (NFData (rnf))
import Data.Bytes.Class.Parser (Parser (parser))
import Data.Hashable (Hashable)
import Data.Kind (Constraint, Type)
import Data.Type.Equality (TestEquality (testEquality), (:~:) (Refl))
import GHC.Generics (Generic)
import Optics.Core (Prism', prism)
import Text.Megaparsec qualified as MP
import Text.Megaparsec.Char qualified as MPC

-- | Tags for differentiating downloaded vs. uploaded bytes.
--
-- @since 0.1
type Direction :: Type
data Direction
  = -- | @since 0.1
    Down
  | -- | @since 0.1
    Up
  deriving stock
    ( -- | @since 0.1
      Direction -> Direction -> Bool
(Direction -> Direction -> Bool)
-> (Direction -> Direction -> Bool) -> Eq Direction
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Direction -> Direction -> Bool
== :: Direction -> Direction -> Bool
$c/= :: Direction -> Direction -> Bool
/= :: Direction -> Direction -> Bool
Eq,
      -- | @since 0.1
      (forall x. Direction -> Rep Direction x)
-> (forall x. Rep Direction x -> Direction) -> Generic Direction
forall x. Rep Direction x -> Direction
forall x. Direction -> Rep Direction x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Direction -> Rep Direction x
from :: forall x. Direction -> Rep Direction x
$cto :: forall x. Rep Direction x -> Direction
to :: forall x. Rep Direction x -> Direction
Generic,
      -- | @since 0.1
      Int -> Direction -> ShowS
[Direction] -> ShowS
Direction -> String
(Int -> Direction -> ShowS)
-> (Direction -> String)
-> ([Direction] -> ShowS)
-> Show Direction
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Direction -> ShowS
showsPrec :: Int -> Direction -> ShowS
$cshow :: Direction -> String
show :: Direction -> String
$cshowList :: [Direction] -> ShowS
showList :: [Direction] -> ShowS
Show
    )
  deriving anyclass
    ( -- | @since 0.1
      Eq Direction
Eq Direction =>
(Int -> Direction -> Int)
-> (Direction -> Int) -> Hashable Direction
Int -> Direction -> Int
Direction -> Int
forall a. Eq a => (Int -> a -> Int) -> (a -> Int) -> Hashable a
$chashWithSalt :: Int -> Direction -> Int
hashWithSalt :: Int -> Direction -> Int
$chash :: Direction -> Int
hash :: Direction -> Int
Hashable,
      -- | @since 0.1
      Direction -> ()
(Direction -> ()) -> NFData Direction
forall a. (a -> ()) -> NFData a
$crnf :: Direction -> ()
rnf :: Direction -> ()
NFData
    )

-- | @since 0.1
instance Parser Direction where
  parser :: Parsec Void Text Direction
parser =
    [Parsec Void Text Direction] -> Parsec Void Text Direction
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
MP.choice
      [ Direction -> Char -> Tokens Text -> Parsec Void Text Direction
forall {s} {f :: * -> *} {e} {b}.
(Token s ~ Char, MonadParsec e s f, FoldCase (Tokens s)) =>
b -> Char -> Tokens s -> f b
parseU Direction
Up Char
'u' Tokens Text
"p",
        Direction -> Char -> Tokens Text -> Parsec Void Text Direction
forall {s} {f :: * -> *} {e} {b}.
(Token s ~ Char, MonadParsec e s f, FoldCase (Tokens s)) =>
b -> Char -> Tokens s -> f b
parseU Direction
Down Char
'd' Tokens Text
"own"
      ]
    where
      parseU :: b -> Char -> Tokens s -> f b
parseU b
u Char
ushort Tokens s
ulong = do
        Char
_ <- Token s -> f (Token s)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
MPC.char' Char
Token s
ushort
        Maybe (Tokens s)
_ <- f (Tokens s) -> f (Maybe (Tokens s))
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
MP.optional (Tokens s -> f (Tokens s)
forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
MPC.string' Tokens s
ulong)
        pure b
u
  {-# INLINEABLE parser #-}

-- | Singleton for 'Direction'.
--
-- @since 0.1
type SDirection :: Direction -> Type
data SDirection (d :: Direction) where
  -- | @since 0.1
  SDown :: SDirection Down
  -- | @since 0.1
  SUp :: SDirection Up

-- | @since 0.1
deriving stock instance Show (SDirection d)

-- | @since 0.1
instance NFData (SDirection d) where
  rnf :: SDirection d -> ()
rnf SDirection d
SDown = ()
  rnf SDirection d
SUp = ()

-- | @since 0.1
sdirectionToDirection :: SDirection d -> Direction
sdirectionToDirection :: forall (d :: Direction). SDirection d -> Direction
sdirectionToDirection SDirection d
SDown = Direction
Down
sdirectionToDirection SDirection d
SUp = Direction
Up
{-# INLINEABLE sdirectionToDirection #-}

-- | @since 0.1
instance TestEquality SDirection where
  testEquality :: forall (a :: Direction) (b :: Direction).
SDirection a -> SDirection b -> Maybe (a :~: b)
testEquality SDirection a
x SDirection b
y = case (SDirection a
x, SDirection b
y) of
    (SDirection a
SDown, SDirection b
SDown) -> (a :~: b) -> Maybe (a :~: b)
forall a. a -> Maybe a
Just a :~: a
a :~: b
forall {k} (a :: k). a :~: a
Refl
    (SDirection a
SUp, SDirection b
SUp) -> (a :~: b) -> Maybe (a :~: b)
forall a. a -> Maybe a
Just a :~: a
a :~: b
forall {k} (a :: k). a :~: a
Refl
    (SDirection a, SDirection b)
_ -> Maybe (a :~: b)
forall a. Maybe a
Nothing
  {-# INLINEABLE testEquality #-}

-- | Typeclass for recovering the 'Direction' at runtime.
--
-- @since 0.1
type SingDirection :: Direction -> Constraint
class SingDirection (d :: Direction) where
  -- | @since 0.1
  singDirection :: SDirection d

-- | @since 0.1
instance SingDirection Down where
  singDirection :: SDirection 'Down
singDirection = SDirection 'Down
SDown
  {-# INLINE singDirection #-}

-- | @since 0.1
instance SingDirection Up where
  singDirection :: SDirection 'Up
singDirection = SDirection 'Up
SUp
  {-# INLINE singDirection #-}

-- | Singleton \"with\"-style convenience function. Allows us to run a
-- computation @SingDirection d => r@ without explicitly pattern-matching
-- every time.
--
-- @since 0.1
withSingDirection :: SDirection d -> ((SingDirection d) => r) -> r
withSingDirection :: forall (d :: Direction) r.
SDirection d -> (SingDirection d => r) -> r
withSingDirection SDirection d
s SingDirection d => r
x = case SDirection d
s of
  SDirection d
SDown -> r
SingDirection d => r
x
  SDirection d
SUp -> r
SingDirection d => r
x
{-# INLINEABLE withSingDirection #-}

-- | Types that have a direction.
--
-- @since 0.1
class Directed a where
  -- | Type used to hide the size.
  --
  -- @since 0.1
  type HideDirection a

  -- | Retrieve the direction.
  --
  -- ==== __Examples__
  --
  -- >>> import Data.Bytes.Network
  -- >>> directionOf (MkNetBytesP @Up @G 7)
  -- Up
  --
  -- >>> directionOf (hideSize $ hideDirection $ MkNetBytesP @Down @M 100)
  -- Down
  --
  -- @since 0.1
  directionOf :: a -> Direction

  -- | Hides the direction.
  --
  -- ==== __Examples__
  --
  -- >>> import Data.Bytes.Network (NetBytes (..), Size (..))
  -- >>> hideDirection (MkNetBytesP @Up @G 7)
  -- MkSomeNetDir SUp (MkNetBytes (MkBytes 7))
  --
  -- @since 0.1
  hideDirection :: a -> HideDirection a

-- | @since 0.1
_Down :: Prism' Direction ()
_Down :: Prism' Direction ()
_Down = (() -> Direction)
-> (Direction -> Either Direction ()) -> Prism' Direction ()
forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
prism (Direction -> () -> Direction
forall a b. a -> b -> a
const Direction
Down) Direction -> Either Direction ()
f
  where
    f :: Direction -> Either Direction ()
f Direction
Down = () -> Either Direction ()
forall a b. b -> Either a b
Right ()
    f Direction
x = Direction -> Either Direction ()
forall a b. a -> Either a b
Left Direction
x
{-# INLINE _Down #-}

-- | @since 0.1
_Up :: Prism' Direction ()
_Up :: Prism' Direction ()
_Up = (() -> Direction)
-> (Direction -> Either Direction ()) -> Prism' Direction ()
forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
prism (Direction -> () -> Direction
forall a b. a -> b -> a
const Direction
Up) Direction -> Either Direction ()
f
  where
    f :: Direction -> Either Direction ()
f Direction
Up = () -> Either Direction ()
forall a b. b -> Either a b
Right ()
    f Direction
x = Direction -> Either Direction ()
forall a b. a -> Either a b
Left Direction
x
{-# INLINE _Up #-}