{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Network.Socket.ReadShow where

import Control.Monad (mzero)
import Text.Read ((<++))
import qualified Text.Read as P
import qualified Text.Read.Lex as P

-- type alias for individual correspondences of a (possibly partial) bijection
type Pair a b = (a, b)

-- | helper function for equality on first tuple element
{-# INLINE eqFst #-}
eqFst :: Eq a => a -> (a, b) -> Bool
eqFst :: forall a b. Eq a => a -> (a, b) -> Bool
eqFst a
x = \(a
x', b
_) -> a
x' a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
x

-- | helper function for equality on snd tuple element
{-# INLINE eqSnd #-}
eqSnd :: Eq b => b -> (a, b) -> Bool
eqSnd :: forall b a. Eq b => b -> (a, b) -> Bool
eqSnd b
y = \(a
_, b
y') -> b
y' b -> b -> Bool
forall a. Eq a => a -> a -> Bool
== b
y

-- | Unified automorphic involution over @Either a b@ that converts between
--   LHS and RHS elements of a list of @Pair a b@ mappings and is the identity
--   function if no matching pair is found
--
--   If list contains duplicate matches, short-circuits to the first matching @Pair@
lookBetween :: (Eq a, Eq b) => [Pair a b] -> Either a b -> Either a b
lookBetween :: forall a b. (Eq a, Eq b) => [Pair a b] -> Either a b -> Either a b
lookBetween [Pair a b]
ps = \case
    Left a
x | (a
_, b
y) : [Pair a b]
_ <- (Pair a b -> Bool) -> [Pair a b] -> [Pair a b]
forall a. (a -> Bool) -> [a] -> [a]
filter (a -> Pair a b -> Bool
forall a b. Eq a => a -> (a, b) -> Bool
eqFst a
x) [Pair a b]
ps -> b -> Either a b
forall a b. b -> Either a b
Right b
y
    Right b
y | (a
x, b
_) : [Pair a b]
_ <- (Pair a b -> Bool) -> [Pair a b] -> [Pair a b]
forall a. (a -> Bool) -> [a] -> [a]
filter (b -> Pair a b -> Bool
forall b a. Eq b => b -> (a, b) -> Bool
eqSnd b
y) [Pair a b]
ps -> a -> Either a b
forall a b. a -> Either a b
Left a
x
    Either a b
z -> Either a b
z

-- Type alias for partial bijections between two types, consisting of a list
-- of individual correspondences that are checked in order and short-circuit
-- on first match
--
-- Depending on how this is used, may not actually be a true bijection over
-- the partial types, as no overlap-checking is currently implemented. If
-- overlaps are unavoidable, the canonical short-circuit pair should appear
-- first to avoid round-trip inconsistencies.
type Bijection a b = [Pair a b]

-- | Helper function for prefixing an optional constructor name before arbitrary values,
-- which only enforces high precedence on subsequent output if the constructor name is not
-- blank and space-separates for non-blank constructor names
namePrefix :: Int -> String -> (Int -> b -> ShowS) -> b -> ShowS
namePrefix :: forall b. Int -> String -> (Int -> b -> ShowS) -> b -> ShowS
namePrefix Int
i String
name Int -> b -> ShowS
f b
x
    | String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
name = Int -> b -> ShowS
f Int
i b
x
    | Bool
otherwise =
        Bool -> ShowS -> ShowS
showParen (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
app_prec) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String -> ShowS
showString String
name ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
' ' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> b -> ShowS
f (Int
app_prec Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) b
x
{-# INLINE namePrefix #-}

-- | Helper function for defining bijective Show instances that represents
-- a common use-case where a constructor (or constructor-like pattern) name
-- (optionally) precedes an internal value with a separate show function
defShow
    :: Eq a => String -> (a -> b) -> (Int -> b -> ShowS) -> (Int -> a -> ShowS)
defShow :: forall a b.
Eq a =>
String -> (a -> b) -> (Int -> b -> ShowS) -> Int -> a -> ShowS
defShow String
name a -> b
unwrap Int -> b -> ShowS
shoPrec = \Int
i a
x -> Int -> String -> (Int -> b -> ShowS) -> b -> ShowS
forall b. Int -> String -> (Int -> b -> ShowS) -> b -> ShowS
namePrefix Int
i String
name Int -> b -> ShowS
shoPrec (a -> b
unwrap a
x)
{-# INLINE defShow #-}

-- Helper function for stripping an optional constructor-name prefix before parsing
-- an arbitrary value, which only consumes an extra token and increases precedence
-- if the provided name prefix is non-blank
expectPrefix :: String -> P.ReadPrec a -> P.ReadPrec a
expectPrefix :: forall a. String -> ReadPrec a -> ReadPrec a
expectPrefix String
name ReadPrec a
pars
    | String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
name = ReadPrec a
pars
    | Bool
otherwise = do
        ReadP () -> ReadPrec ()
forall a. ReadP a -> ReadPrec a
P.lift (ReadP () -> ReadPrec ()) -> ReadP () -> ReadPrec ()
forall a b. (a -> b) -> a -> b
$ Lexeme -> ReadP ()
P.expect (Lexeme -> ReadP ()) -> Lexeme -> ReadP ()
forall a b. (a -> b) -> a -> b
$ String -> Lexeme
P.Ident String
name
        ReadPrec a -> ReadPrec a
forall a. ReadPrec a -> ReadPrec a
P.step ReadPrec a
pars
{-# INLINE expectPrefix #-}

-- | Helper function for defining bijective Read instances that represent a
-- common use case where a constructor (or constructor-like pattern) name
-- (optionally) precedes an internal value with a separate parse function
defRead :: Eq a => String -> (b -> a) -> P.ReadPrec b -> P.ReadPrec a
defRead :: forall a b. Eq a => String -> (b -> a) -> ReadPrec b -> ReadPrec a
defRead String
name b -> a
wrap ReadPrec b
redPrec = String -> ReadPrec a -> ReadPrec a
forall a. String -> ReadPrec a -> ReadPrec a
expectPrefix String
name (ReadPrec a -> ReadPrec a) -> ReadPrec a -> ReadPrec a
forall a b. (a -> b) -> a -> b
$ b -> a
wrap (b -> a) -> ReadPrec b -> ReadPrec a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadPrec b
redPrec
{-# INLINE defRead #-}

-- | Alias for showsPrec that pairs well with `_readInt`
_showInt :: Show a => Int -> a -> ShowS
_showInt :: forall a. Show a => Int -> a -> ShowS
_showInt = Int -> a -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec
{-# INLINE _showInt #-}

-- | More descriptive alias for `safeInt`
_readInt :: (Bounded a, Integral a) => P.ReadPrec a
_readInt :: forall a. (Bounded a, Integral a) => ReadPrec a
_readInt = ReadPrec a
forall a. (Bounded a, Integral a) => ReadPrec a
safeInt
{-# INLINE _readInt #-}

-- | show two elements of a tuple separated by a space character
-- inverse function to readIntInt when used on integer-like values
showIntInt :: (Show a, Show b) => Int -> (a, b) -> ShowS
showIntInt :: forall a b. (Show a, Show b) => Int -> (a, b) -> ShowS
showIntInt Int
i (a
x, b
y) = Int -> a -> ShowS
forall a. Show a => Int -> a -> ShowS
_showInt Int
i a
x ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
' ' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> b -> ShowS
forall a. Show a => Int -> a -> ShowS
_showInt Int
i b
y
{-# INLINE showIntInt #-}

-- | consume and return two integer-like values from two consecutive lexical tokens
readIntInt
    :: (Bounded a, Integral a, Bounded b, Integral b) => P.ReadPrec (a, b)
readIntInt :: forall a b.
(Bounded a, Integral a, Bounded b, Integral b) =>
ReadPrec (a, b)
readIntInt = do
    a
x <- ReadPrec a
forall a. (Bounded a, Integral a) => ReadPrec a
_readInt
    b
y <- ReadPrec b
forall a. (Bounded a, Integral a) => ReadPrec a
_readInt
    (a, b) -> ReadPrec (a, b)
forall a. a -> ReadPrec a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
x, b
y)
{-# INLINE readIntInt #-}

bijectiveShow
    :: Eq a => Bijection a String -> (Int -> a -> ShowS) -> (Int -> a -> ShowS)
bijectiveShow :: forall a.
Eq a =>
Bijection a String -> (Int -> a -> ShowS) -> Int -> a -> ShowS
bijectiveShow Bijection a String
bi Int -> a -> ShowS
def = \Int
i a
x ->
    case Bijection a String -> Either a String -> Either a String
forall a b. (Eq a, Eq b) => [Pair a b] -> Either a b -> Either a b
lookBetween Bijection a String
bi (a -> Either a String
forall a b. a -> Either a b
Left a
x) of
        Right String
y -> String -> ShowS
showString String
y
        Either a String
_ -> Int -> a -> ShowS
def Int
i a
x

bijectiveRead :: Eq a => Bijection a String -> P.ReadPrec a -> P.ReadPrec a
bijectiveRead :: forall a. Eq a => Bijection a String -> ReadPrec a -> ReadPrec a
bijectiveRead Bijection a String
bi ReadPrec a
def = ReadPrec a -> ReadPrec a
forall a. ReadPrec a -> ReadPrec a
P.parens (ReadPrec a -> ReadPrec a) -> ReadPrec a -> ReadPrec a
forall a b. (a -> b) -> a -> b
$ ReadPrec a
bijective ReadPrec a -> ReadPrec a -> ReadPrec a
forall a. ReadPrec a -> ReadPrec a -> ReadPrec a
<++ ReadPrec a
def
  where
    bijective :: ReadPrec a
bijective = do
        (P.Ident String
y) <- ReadPrec Lexeme
P.lexP
        case Bijection a String -> Either a String -> Either a String
forall a b. (Eq a, Eq b) => [Pair a b] -> Either a b -> Either a b
lookBetween Bijection a String
bi (String -> Either a String
forall a b. b -> Either a b
Right String
y) of
            Left a
x -> a -> ReadPrec a
forall a. a -> ReadPrec a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
            Either a String
_ -> ReadPrec a
forall a. ReadPrec a
forall (m :: * -> *) a. MonadPlus m => m a
mzero

app_prec :: Int
app_prec :: Int
app_prec = Int
10
{-# INLINE app_prec #-}

-- Parse integral values with type-specific overflow and underflow bounds-checks
safeInt :: forall a. (Bounded a, Integral a) => P.ReadPrec a
safeInt :: forall a. (Bounded a, Integral a) => ReadPrec a
safeInt = do
    Integer
i <- ReadPrec Integer
signed
    if (Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= a -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a
forall a. Bounded a => a
minBound :: a) Bool -> Bool -> Bool
&& Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= a -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a
forall a. Bounded a => a
maxBound :: a))
        then a -> ReadPrec a
forall a. a -> ReadPrec a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> ReadPrec a) -> a -> ReadPrec a
forall a b. (a -> b) -> a -> b
$ Integer -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i
        else ReadPrec a
forall a. ReadPrec a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
  where
    signed :: P.ReadPrec Integer
    signed :: ReadPrec Integer
signed = ReadPrec Integer
forall a. Read a => ReadPrec a
P.readPrec