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


module Network.Socket.ReadShow where

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

-- 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 x = \(x',_) -> x' == x

-- | helper function for equality on snd tuple element
{-# INLINE eqSnd #-}
eqSnd :: Eq b => b -> (a, b) -> Bool
eqSnd y = \(_,y') -> y' == 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 ps = \case
  Left  x | (_,y):_ <- filter (eqFst x) ps -> Right y
  Right y | (x,_):_ <- filter (eqSnd y) ps -> Left  x
  z -> 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 i name f x
    | null name = f i x
    | otherwise = showParen (i > app_prec) $ showString name . showChar ' ' . f (app_prec+1) 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 name unwrap shoPrec = \i x -> namePrefix i name shoPrec (unwrap 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 name pars
    | null name = pars
    | otherwise = do
        P.lift $ P.expect $ P.Ident name
        P.step 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 name wrap redPrec = expectPrefix name $ wrap <$> redPrec
{-# INLINE defRead #-}

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

-- | More descriptive alias for `safeInt`
_readInt :: (Bounded a, Integral a) => P.ReadPrec a
_readInt = 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 i (x, y) = _showInt i x . showChar ' ' . _showInt i 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 = do
  x <- _readInt
  y <- _readInt
  return (x, y)
{-# INLINE readIntInt #-}

bijectiveShow :: (Eq a) => Bijection a String -> (Int -> a -> ShowS) -> (Int -> a -> ShowS)
bijectiveShow bi def = \i x ->
    case lookBetween bi (Left x) of
        Right y -> showString y
        _ -> def i x

bijectiveRead :: (Eq a) => Bijection a String -> P.ReadPrec a -> P.ReadPrec a
bijectiveRead bi def = P.parens $ bijective <++ def
  where
    bijective = do
      (P.Ident y) <- P.lexP
      case lookBetween bi (Right y) of
          Left x -> return x
          _ -> mzero

app_prec :: Int
app_prec = 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 = do
    i <- signed
    if (i >= fromIntegral (minBound :: a) && i <= fromIntegral (maxBound :: a))
    then return $ fromIntegral i
    else mzero
  where
    signed :: P.ReadPrec Integer
    signed = P.readPrec