{-# LANGUAGE FunctionalDependencies #-}

module Binrep.Get
  ( Getter, Get(..), runGet, runGetter
  , E(..), EBase(..), EGeneric(..), EGenericSum(..)
  , eBase
  , getEWrap, getEBase
  , cutEBase
  , GetWith(..), runGetWith
  ) where

import FlatParse.Basic qualified as FP

import Data.ByteString qualified as B

import GHC.Exts ( TYPE, type LiftedRep )

import Data.Word
import Data.Int
import Data.Void ( Void )

import GHC.Generics ( Generic )

import Data.Text ( Text )

import Binrep.BLen ( BLenT )

import Numeric.Natural

type Getter a = FP.Parser E a

data E
  = EBase EBase

  | EGeneric String {- ^ datatype name -} EGeneric

    deriving stock (E -> E -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: E -> E -> Bool
$c/= :: E -> E -> Bool
== :: E -> E -> Bool
$c== :: E -> E -> Bool
Eq, Int -> E -> ShowS
[E] -> ShowS
E -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [E] -> ShowS
$cshowList :: [E] -> ShowS
show :: E -> String
$cshow :: E -> String
showsPrec :: Int -> E -> ShowS
$cshowsPrec :: Int -> E -> ShowS
Show, forall x. Rep E x -> E
forall x. E -> Rep E x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep E x -> E
$cfrom :: forall x. E -> Rep E x
Generic)

eBase :: EBase -> Getter a
eBase :: forall a. EBase -> Getter a
eBase = forall e a. e -> Parser e a
FP.err forall b c a. (b -> c) -> (a -> b) -> a -> c
. EBase -> E
EBase

-- | TODO confirm correct operation (error combination)
getEWrap :: Get a => (E -> E) -> Getter a
getEWrap :: forall a. Get a => (E -> E) -> Getter a
getEWrap E -> E
f = forall e a. Parser e a -> e -> (e -> e -> e) -> Parser e a
FP.cutting forall a. Get a => Getter a
get (E -> E
f forall a b. (a -> b) -> a -> b
$ EBase -> E
EBase EBase
EFail) (\E
e E
_ -> E -> E
f E
e)

getEBase :: Get a => EBase -> Getter a
getEBase :: forall a. Get a => EBase -> Getter a
getEBase = forall e a. Parser e a -> e -> Parser e a
FP.cut forall a. Get a => Getter a
get forall b c a. (b -> c) -> (a -> b) -> a -> c
. EBase -> E
EBase

cutEBase :: Getter a -> EBase -> Getter a
cutEBase :: forall a. Getter a -> EBase -> Getter a
cutEBase Getter a
f EBase
e = forall e a. Parser e a -> e -> Parser e a
FP.cut Getter a
f forall a b. (a -> b) -> a -> b
$ EBase -> E
EBase EBase
e

data EBase
  = ENoVoid
  | EFail

  | EExpectedByte Word8 Word8
  -- ^ expected first, got second

  | EOverlong BLenT BLenT
  -- ^ expected first, got second

  | EExpected B.ByteString B.ByteString
  -- ^ expected first, got second

  | EFailNamed String
  -- ^ known fail

  | EFailParse String B.ByteString Word8
  -- ^ parse fail (where you parse a larger object, then a smaller one in it)

  | ERanOut Natural
  -- ^ ran out of input, needed precisely @n@ bytes for this part (n > 0)

    deriving stock (EBase -> EBase -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EBase -> EBase -> Bool
$c/= :: EBase -> EBase -> Bool
== :: EBase -> EBase -> Bool
$c== :: EBase -> EBase -> Bool
Eq, Int -> EBase -> ShowS
[EBase] -> ShowS
EBase -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EBase] -> ShowS
$cshowList :: [EBase] -> ShowS
show :: EBase -> String
$cshow :: EBase -> String
showsPrec :: Int -> EBase -> ShowS
$cshowsPrec :: Int -> EBase -> ShowS
Show, forall x. Rep EBase x -> EBase
forall x. EBase -> Rep EBase x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep EBase x -> EBase
$cfrom :: forall x. EBase -> Rep EBase x
Generic)

data EGeneric
  = EGenericSum EGenericSum
  | EGenericField String (Maybe String) Natural E
    deriving stock (EGeneric -> EGeneric -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EGeneric -> EGeneric -> Bool
$c/= :: EGeneric -> EGeneric -> Bool
== :: EGeneric -> EGeneric -> Bool
$c== :: EGeneric -> EGeneric -> Bool
Eq, Int -> EGeneric -> ShowS
[EGeneric] -> ShowS
EGeneric -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EGeneric] -> ShowS
$cshowList :: [EGeneric] -> ShowS
show :: EGeneric -> String
$cshow :: EGeneric -> String
showsPrec :: Int -> EGeneric -> ShowS
$cshowsPrec :: Int -> EGeneric -> ShowS
Show, forall x. Rep EGeneric x -> EGeneric
forall x. EGeneric -> Rep EGeneric x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep EGeneric x -> EGeneric
$cfrom :: forall x. EGeneric -> Rep EGeneric x
Generic)

data EGenericSum
  = EGenericSumTag E
  | EGenericSumTagNoMatch [String] Text
    deriving stock (EGenericSum -> EGenericSum -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EGenericSum -> EGenericSum -> Bool
$c/= :: EGenericSum -> EGenericSum -> Bool
== :: EGenericSum -> EGenericSum -> Bool
$c== :: EGenericSum -> EGenericSum -> Bool
Eq, Int -> EGenericSum -> ShowS
[EGenericSum] -> ShowS
EGenericSum -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EGenericSum] -> ShowS
$cshowList :: [EGenericSum] -> ShowS
show :: EGenericSum -> String
$cshow :: EGenericSum -> String
showsPrec :: Int -> EGenericSum -> ShowS
$cshowsPrec :: Int -> EGenericSum -> ShowS
Show, forall x. Rep EGenericSum x -> EGenericSum
forall x. EGenericSum -> Rep EGenericSum x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep EGenericSum x -> EGenericSum
$cfrom :: forall x. EGenericSum -> Rep EGenericSum x
Generic)

class Get a where
    -- | Parse from binary.
    get :: Getter a

runGet :: Get a => B.ByteString -> Either E (a, B.ByteString)
runGet :: forall a. Get a => ByteString -> Either E (a, ByteString)
runGet = forall a. Getter a -> ByteString -> Either E (a, ByteString)
runGetter forall a. Get a => Getter a
get

runGetter :: Getter a -> B.ByteString -> Either E (a, B.ByteString)
runGetter :: forall a. Getter a -> ByteString -> Either E (a, ByteString)
runGetter Getter a
g ByteString
bs = case forall e a. Parser e a -> ByteString -> Result e a
FP.runParser Getter a
g ByteString
bs of
                   FP.OK a
a ByteString
bs' -> forall a b. b -> Either a b
Right (a
a, ByteString
bs')
                   Result E a
FP.Fail     -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ EBase -> E
EBase EBase
EFail
                   FP.Err E
e    -> forall a b. a -> Either a b
Left E
e

-- | Impossible to parse 'Void'.
instance Get Void where
    get :: Getter Void
get = forall a. EBase -> Getter a
eBase EBase
ENoVoid

-- | Parse heterogeneous lists in order. No length indicator, so either fails or
--   succeeds by reaching EOF. Probably not what you usually want, but sometimes
--   used at the "top" of binary formats.
instance Get a => Get [a] where
    get :: Getter [a]
get = Getter [a]
go
      where
        go :: Getter [a]
go = do
            forall e a b.
Parser e a -> (a -> Parser e b) -> Parser e b -> Parser e b
FP.withOption forall e. Parser e ()
FP.eof (\() -> forall (f :: * -> *) a. Applicative f => a -> f a
pure []) forall a b. (a -> b) -> a -> b
$ do
                a
a <- forall a. Get a => Getter a
get
                [a]
as <- Getter [a]
go
                forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ a
a forall a. a -> [a] -> [a]
: [a]
as

instance (Get a, Get b) => Get (a, b) where
    get :: Getter (a, b)
get = do
        a
a <- forall a. Get a => Getter a
get
        b
b <- forall a. Get a => Getter a
get
        forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, b
b)

instance Get B.ByteString where
    get :: Getter ByteString
get = forall e. Parser e ByteString
FP.takeRestBs

instance Get Word8 where get :: Getter Word8
get = forall a. Getter a -> EBase -> Getter a
cutEBase forall e. Parser e Word8
FP.anyWord8 (Natural -> EBase
ERanOut Natural
1)
instance Get  Int8 where get :: Getter Int8
get = forall a. Getter a -> EBase -> Getter a
cutEBase forall e. Parser e Int8
FP.anyInt8  (Natural -> EBase
ERanOut Natural
1)

-- | A type that can be parsed from binary given some environment.
--
-- Making this levity polymorphic makes things pretty strange, but is useful.
-- See @Binrep.Example.FileTable@.
class GetWith (r :: TYPE rep) a | a -> r where
    -- | Parse from binary with the given environment.
    getWith :: r -> Getter a
    -- can no longer provide default implementation due to levity polymorphism
    --default getWith :: Get a => r -> Getter a
    --getWith _ = get

--deriving anyclass instance Get a => GetWith r [a]

-- Note that @r@ is not levity polymorphic, GHC forces it to be lifted. You
-- can't bind (LHS) a levity polymorphic value.
runGetWith
    :: GetWith (r :: TYPE LiftedRep) a
    => r -> B.ByteString -> Either E (a, B.ByteString)
runGetWith :: forall r a.
GetWith r a =>
r -> ByteString -> Either E (a, ByteString)
runGetWith r
r ByteString
bs = forall a. Getter a -> ByteString -> Either E (a, ByteString)
runGetter (forall r a. GetWith r a => r -> Getter a
getWith r
r) ByteString
bs