-- | TODO remove ASAP. figure out Aeson with Vinyl

{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}

module StreamPatch.Simple where

import StreamPatch.Patch
import StreamPatch.HFunctorList
import StreamPatch.Patch.Binary qualified as Bin
import StreamPatch.Patch.Compare qualified as Compare
import StreamPatch.Patch.Compare ( Via(..), CompareRep )
import StreamPatch.Patch.Align qualified as Align

import Numeric.Natural
import Data.Functor.Const
import Data.Vinyl
import Data.Vinyl.TypeLevel
import Data.Aeson
import GHC.Generics

data MultiPatch s (v :: Via) a = MultiPatch
  { forall s (v :: Via) a. MultiPatch s v a -> a
mpData           :: a
  , forall s (v :: Via) a. MultiPatch s v a -> s
mpSeek           :: s
  , forall s (v :: Via) a. MultiPatch s v a -> Maybe (CompareRep v a)
mpCompare        :: Maybe (CompareRep v a)
  , forall s (v :: Via) a. MultiPatch s v a -> Maybe Natural
mpNullTerminates :: Maybe Natural
  , forall s (v :: Via) a. MultiPatch s v a -> Maybe Natural
mpMaxBytes       :: Maybe Natural -- TODO confirm meaning, maybe improve name
  , forall s (v :: Via) a. MultiPatch s v a -> Maybe Integer
mpAligned        :: Maybe Integer
  } deriving (forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall s (v :: Via) a x.
Rep (MultiPatch s v a) x -> MultiPatch s v a
forall s (v :: Via) a x.
MultiPatch s v a -> Rep (MultiPatch s v a) x
$cto :: forall s (v :: Via) a x.
Rep (MultiPatch s v a) x -> MultiPatch s v a
$cfrom :: forall s (v :: Via) a x.
MultiPatch s v a -> Rep (MultiPatch s v a) x
Generic)

instance Functor (MultiPatch s ('ViaEq ec)) where
    fmap :: forall a b.
(a -> b)
-> MultiPatch s ('ViaEq ec) a -> MultiPatch s ('ViaEq ec) b
fmap a -> b
f (MultiPatch a
d s
s Maybe (CompareRep ('ViaEq ec) a)
c Maybe Natural
n Maybe Natural
m Maybe Integer
a) = forall s (v :: Via) a.
a
-> s
-> Maybe (CompareRep v a)
-> Maybe Natural
-> Maybe Natural
-> Maybe Integer
-> MultiPatch s v a
MultiPatch (a -> b
f a
d) s
s (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Maybe (CompareRep ('ViaEq ec) a)
c) Maybe Natural
n Maybe Natural
m Maybe Integer
a
instance Functor (MultiPatch s ('ViaDigest h)) where
    fmap :: forall a b.
(a -> b)
-> MultiPatch s ('ViaDigest h) a -> MultiPatch s ('ViaDigest h) b
fmap a -> b
f (MultiPatch a
d s
s Maybe (CompareRep ('ViaDigest h) a)
c Maybe Natural
n Maybe Natural
m Maybe Integer
a) = forall s (v :: Via) a.
a
-> s
-> Maybe (CompareRep v a)
-> Maybe Natural
-> Maybe Natural
-> Maybe Integer
-> MultiPatch s v a
MultiPatch (a -> b
f a
d) s
s Maybe (CompareRep ('ViaDigest h) a)
c          Maybe Natural
n Maybe Natural
m Maybe Integer
a

deriving instance (Eq   a, Eq   s, Eq   (CompareRep v a)) => Eq   (MultiPatch s v a)
deriving instance (Show a, Show s, Show (CompareRep v a)) => Show (MultiPatch s v a)

data Aligned p = Aligned
  { forall p. Aligned p -> Integer
alignedAlign   :: Integer
  , forall p. Aligned p -> [p]
alignedPatches :: [p]
  } deriving (Aligned p -> Aligned p -> Bool
forall p. Eq p => Aligned p -> Aligned p -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Aligned p -> Aligned p -> Bool
$c/= :: forall p. Eq p => Aligned p -> Aligned p -> Bool
== :: Aligned p -> Aligned p -> Bool
$c== :: forall p. Eq p => Aligned p -> Aligned p -> Bool
Eq, Int -> Aligned p -> ShowS
forall p. Show p => Int -> Aligned p -> ShowS
forall p. Show p => [Aligned p] -> ShowS
forall p. Show p => Aligned p -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Aligned p] -> ShowS
$cshowList :: forall p. Show p => [Aligned p] -> ShowS
show :: Aligned p -> String
$cshow :: forall p. Show p => Aligned p -> String
showsPrec :: Int -> Aligned p -> ShowS
$cshowsPrec :: forall p. Show p => Int -> Aligned p -> ShowS
Show, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall p x. Rep (Aligned p) x -> Aligned p
forall p x. Aligned p -> Rep (Aligned p) x
$cto :: forall p x. Rep (Aligned p) x -> Aligned p
$cfrom :: forall p x. Aligned p -> Rep (Aligned p) x
Generic)

--------------------------------------------------------------------------------

jsonCfgCamelDrop :: Int -> Options
jsonCfgCamelDrop :: Int -> Options
jsonCfgCamelDrop Int
x = Options
defaultOptions
  { fieldLabelModifier :: ShowS
fieldLabelModifier = Char -> ShowS
camelTo2 Char
'_' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
drop Int
x
  , rejectUnknownFields :: Bool
rejectUnknownFields = Bool
True }

instance (ToJSON   (CompareRep v a), ToJSON   a, ToJSON   s) => ToJSON   (MultiPatch s v a) where
    toJSON :: MultiPatch s v a -> Value
toJSON     = forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON     forall a b. (a -> b) -> a -> b
$ Int -> Options
jsonCfgCamelDrop Int
2
    toEncoding :: MultiPatch s v a -> Encoding
toEncoding = forall a.
(Generic a, GToJSON' Encoding Zero (Rep a)) =>
Options -> a -> Encoding
genericToEncoding forall a b. (a -> b) -> a -> b
$ Int -> Options
jsonCfgCamelDrop Int
2
instance (FromJSON (CompareRep v a), FromJSON a, FromJSON s) => FromJSON (MultiPatch s v a) where
    parseJSON :: Value -> Parser (MultiPatch s v a)
parseJSON  = forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON  forall a b. (a -> b) -> a -> b
$ Int -> Options
jsonCfgCamelDrop Int
2

instance (ToJSON   p) => ToJSON   (Aligned p) where
    toJSON :: Aligned p -> Value
toJSON     = forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON     forall a b. (a -> b) -> a -> b
$ Int -> Options
jsonCfgCamelDrop Int
7
    toEncoding :: Aligned p -> Encoding
toEncoding = forall a.
(Generic a, GToJSON' Encoding Zero (Rep a)) =>
Options -> a -> Encoding
genericToEncoding forall a b. (a -> b) -> a -> b
$ Int -> Options
jsonCfgCamelDrop Int
7
instance (FromJSON p) => FromJSON (Aligned p) where
    parseJSON :: Value -> Parser (Aligned p)
parseJSON  = forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON  forall a b. (a -> b) -> a -> b
$ Int -> Options
jsonCfgCamelDrop Int
7

--------------------------------------------------------------------------------

convert :: (MultiPatch s v a -> Rec (Flap a) fs) -> MultiPatch s v a -> Patch s fs a
convert :: forall s (v :: Via) a (fs :: [* -> *]).
(MultiPatch s v a -> Rec (Flap a) fs)
-> MultiPatch s v a -> Patch s fs a
convert MultiPatch s v a -> Rec (Flap a) fs
f MultiPatch s v a
p = Patch { patchData :: a
patchData = forall s (v :: Via) a. MultiPatch s v a -> a
mpData MultiPatch s v a
p
                    , patchSeek :: s
patchSeek = forall s (v :: Via) a. MultiPatch s v a -> s
mpSeek MultiPatch s v a
p
                    , patchMeta :: HFunctorList fs a
patchMeta = forall {k} (fs :: [k -> *]) (a :: k).
Rec (Flap a) fs -> HFunctorList fs a
HFunctorList forall a b. (a -> b) -> a -> b
$ MultiPatch s v a -> Rec (Flap a) fs
f MultiPatch s v a
p }

-- TODO how to clean up (it's like liftA2 over n instead of 2. like a fold)
-- likely 'ap'!
convertBinAlign
    :: forall a v
    .  MultiPatch Integer v a
    -> Patch Integer '[Const (Align.Meta Int), Const Bin.MetaPrep, Compare.Meta v, Bin.Meta] a
convertBinAlign :: forall a (v :: Via).
MultiPatch Integer v a
-> Patch
     Integer '[Const (Meta Int), Const MetaPrep, Meta v, Meta] a
convertBinAlign = forall s (v :: Via) a (fs :: [* -> *]).
(MultiPatch s v a -> Rec (Flap a) fs)
-> MultiPatch s v a -> Patch s fs a
convert forall {c :: Via} {a}.
MultiPatch Integer c a
-> Rec (Flap a) '[Const (Meta Int), Const MetaPrep, Meta c, Meta]
go
  where go :: MultiPatch Integer c a
-> Rec
     (Flap a) ('[Const (Meta Int)] ++ '[Const MetaPrep, Meta c, Meta])
go MultiPatch Integer c a
p = forall (c :: Via) a.
MultiPatch Integer c a -> Rec (Flap a) '[Const (Meta Int)]
cmAlign MultiPatch Integer c a
p forall {k} (f :: k -> *) (as :: [k]) (bs :: [k]).
Rec f as -> Rec f bs -> Rec f (as ++ bs)
<+> forall s (c :: Via) a.
MultiPatch s c a -> Rec (Flap a) '[Const MetaPrep]
cmBinPrep MultiPatch Integer c a
p forall {k} (f :: k -> *) (as :: [k]) (bs :: [k]).
Rec f as -> Rec f bs -> Rec f (as ++ bs)
<+> forall s (v :: Via) a. MultiPatch s v a -> Rec (Flap a) '[Meta v]
cmCompare MultiPatch Integer c a
p forall {k} (f :: k -> *) (as :: [k]) (bs :: [k]).
Rec f as -> Rec f bs -> Rec f (as ++ bs)
<+> forall s (c :: Via) a. MultiPatch s c a -> Rec (Flap a) '[Meta]
cmBin MultiPatch Integer c a
p

convertBin
    :: forall s a v
    .  MultiPatch s v a
    -> Patch s '[Const Bin.MetaPrep, Compare.Meta v, Bin.Meta] a
convertBin :: forall s a (v :: Via).
MultiPatch s v a -> Patch s '[Const MetaPrep, Meta v, Meta] a
convertBin MultiPatch s v a
p = forall s (v :: Via) a (fs :: [* -> *]).
(MultiPatch s v a -> Rec (Flap a) fs)
-> MultiPatch s v a -> Patch s fs a
convert forall {s} {c :: Via} {a}.
MultiPatch s c a -> Rec (Flap a) '[Const MetaPrep, Meta c, Meta]
go MultiPatch s v a
p
  where go :: MultiPatch s c a
-> Rec (Flap a) ('[Const MetaPrep] ++ '[Meta c, Meta])
go MultiPatch s c a
s = forall s (c :: Via) a.
MultiPatch s c a -> Rec (Flap a) '[Const MetaPrep]
cmBinPrep MultiPatch s c a
s forall {k} (f :: k -> *) (as :: [k]) (bs :: [k]).
Rec f as -> Rec f bs -> Rec f (as ++ bs)
<+> forall s (v :: Via) a. MultiPatch s v a -> Rec (Flap a) '[Meta v]
cmCompare MultiPatch s c a
s forall {k} (f :: k -> *) (as :: [k]) (bs :: [k]).
Rec f as -> Rec f bs -> Rec f (as ++ bs)
<+> forall s (c :: Via) a. MultiPatch s c a -> Rec (Flap a) '[Meta]
cmBin MultiPatch s c a
s

convertAlign
    :: forall a v
    .  MultiPatch Integer v a
    -> Patch Integer '[Const (Align.Meta Int)] a
convertAlign :: forall a (v :: Via).
MultiPatch Integer v a -> Patch Integer '[Const (Meta Int)] a
convertAlign MultiPatch Integer v a
p = forall s (v :: Via) a (fs :: [* -> *]).
(MultiPatch s v a -> Rec (Flap a) fs)
-> MultiPatch s v a -> Patch s fs a
convert forall (c :: Via) a.
MultiPatch Integer c a -> Rec (Flap a) '[Const (Meta Int)]
cmAlign MultiPatch Integer v a
p

convertEmpty
    :: forall s a v
    .  MultiPatch s v a
    -> Patch s '[] a
convertEmpty :: forall s a (v :: Via). MultiPatch s v a -> Patch s '[] a
convertEmpty MultiPatch s v a
p = forall s (v :: Via) a (fs :: [* -> *]).
(MultiPatch s v a -> Rec (Flap a) fs)
-> MultiPatch s v a -> Patch s fs a
convert (forall a b. a -> b -> a
const forall {u} (a :: u -> *). Rec a '[]
RNil) MultiPatch s v a
p

--------------------------------------------------------------------------------

align
    :: forall st a ss rs is i r
    .  ( r ~ Const (Align.Meta st)
       , Num st, Eq st
       , rs ~ RDelete r ss
       , RElem r ss i
       , RSubset rs ss is )
    => Aligned (Patch Integer ss a)
    -> Either (Align.Error st) [Patch st rs a]
align :: forall st a (ss :: [* -> *]) (rs :: [* -> *]) (is :: [Nat])
       (i :: Nat) (r :: * -> *).
(r ~ Const (Meta st), Num st, Eq st, rs ~ RDelete r ss,
 RElem r ss i, RSubset rs ss is) =>
Aligned (Patch Integer ss a) -> Either (Error st) [Patch st rs a]
align (Aligned Integer
a [Patch Integer ss a]
ps) = forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall sf st a (ss :: [* -> *]) (is :: [Nat]) (r :: * -> *)
       (rs :: [* -> *]).
(Integral sf, Num st, Eq st, r ~ Const (Meta st),
 rs ~ RDelete r ss, RElem r ss (RIndex r ss), RSubset rs ss is) =>
Integer -> Patch sf ss a -> Either (Error st) (Patch st rs a)
Align.align Integer
a) [Patch Integer ss a]
ps

--------------------------------------------------------------------------------

cmBin :: MultiPatch s c a -> Rec (Flap a) '[Bin.Meta]
cmBin :: forall s (c :: Via) a. MultiPatch s c a -> Rec (Flap a) '[Meta]
cmBin MultiPatch s c a
p = forall {k} (f :: k -> *) (a :: k). f a -> Rec (Flap a) '[f]
cm forall a b. (a -> b) -> a -> b
$ Bin.Meta { mNullTerminates :: Maybe Natural
Bin.mNullTerminates = forall s (v :: Via) a. MultiPatch s v a -> Maybe Natural
mpNullTerminates MultiPatch s c a
p }

cmCompare :: MultiPatch s v a -> Rec (Flap a) '[Compare.Meta v]
cmCompare :: forall s (v :: Via) a. MultiPatch s v a -> Rec (Flap a) '[Meta v]
cmCompare MultiPatch s v a
p = forall {k} (f :: k -> *) (a :: k). f a -> Rec (Flap a) '[f]
cm forall a b. (a -> b) -> a -> b
$ Compare.Meta { mCompare :: Maybe (CompareRep v a)
Compare.mCompare = forall s (v :: Via) a. MultiPatch s v a -> Maybe (CompareRep v a)
mpCompare MultiPatch s v a
p }

cmBinPrep :: MultiPatch s c a -> Rec (Flap a) '[Const Bin.MetaPrep]
cmBinPrep :: forall s (c :: Via) a.
MultiPatch s c a -> Rec (Flap a) '[Const MetaPrep]
cmBinPrep MultiPatch s c a
p = forall {k} (f :: k -> *) (a :: k). f a -> Rec (Flap a) '[f]
cm forall a b. (a -> b) -> a -> b
$ forall {k} a (b :: k). a -> Const a b
Const forall a b. (a -> b) -> a -> b
$ Bin.MetaPrep { mpMaxBytes :: Maybe Natural
Bin.mpMaxBytes = forall s (v :: Via) a. MultiPatch s v a -> Maybe Natural
mpMaxBytes MultiPatch s c a
p }

cmAlign :: MultiPatch Integer c a -> Rec (Flap a) '[Const (Align.Meta Int)]
cmAlign :: forall (c :: Via) a.
MultiPatch Integer c a -> Rec (Flap a) '[Const (Meta Int)]
cmAlign MultiPatch Integer c a
p = forall {k} (f :: k -> *) (a :: k). f a -> Rec (Flap a) '[f]
cm forall a b. (a -> b) -> a -> b
$ forall {k} a (b :: k). a -> Const a b
Const forall a b. (a -> b) -> a -> b
$ Align.Meta { mExpected :: Maybe Int
Align.mExpected = forall a. Num a => Integer -> a
fromInteger forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (v :: Via) a. MultiPatch s v a -> Maybe Integer
mpAligned MultiPatch Integer c a
p }

cm :: f a -> Rec (Flap a) '[f]
cm :: forall {k} (f :: k -> *) (a :: k). f a -> Rec (Flap a) '[f]
cm f a
fa = forall {k} (a :: k) (f :: k -> *). f a -> Flap a f
Flap f a
fa forall {u} (a :: u -> *) (r :: u) (rs :: [u]).
a r -> Rec a rs -> Rec a (r : rs)
:& forall {u} (a :: u -> *). Rec a '[]
RNil

--------------------------------------------------------------------------------

-- | Convenience function to wrap a single meta into an 'HFunctorList'.
metaWrap1 :: f a -> HFunctorList '[f] a
metaWrap1 :: forall {k} (f :: k -> *) (a :: k). f a -> HFunctorList '[f] a
metaWrap1 = forall {k} (fs :: [k -> *]) (a :: k).
Rec (Flap a) fs -> HFunctorList fs a
HFunctorList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (f :: k -> *) (a :: k). f a -> Rec (Flap a) '[f]
cm

-- | Convenience function for the empty 'HFunctorList'.
metaEmpty :: HFunctorList '[] a
metaEmpty :: forall {k} (a :: k). HFunctorList '[] a
metaEmpty = forall {k} (fs :: [k -> *]) (a :: k).
Rec (Flap a) fs -> HFunctorList fs a
HFunctorList forall {u} (a :: u -> *). Rec a '[]
RNil

--------------------------------------------------------------------------------

convertBackBin :: forall v s a. Patch s '[Compare.Meta v, Bin.Meta] a -> MultiPatch s v a
convertBackBin :: forall (v :: Via) s a.
Patch s '[Meta v, Meta] a -> MultiPatch s v a
convertBackBin Patch s '[Meta v, Meta] a
p = MultiPatch { mpData :: a
mpData           = forall s (fs :: [* -> *]) a. Patch s fs a -> a
patchData Patch s '[Meta v, Meta] a
p
                              , mpSeek :: s
mpSeek           = forall s (fs :: [* -> *]) a. Patch s fs a -> s
patchSeek Patch s '[Meta v, Meta] a
p
                              , mpCompare :: Maybe (CompareRep v a)
mpCompare        = forall (v :: Via) a. Meta v a -> Maybe (CompareRep v a)
Compare.mCompare @v forall a b. (a -> b) -> a -> b
$ forall {k} (f :: k -> *) (fs :: [k -> *]) (a :: k) (i :: Nat).
RElem f fs i =>
HFunctorList fs a -> f a
hflGet forall a b. (a -> b) -> a -> b
$ forall s (fs :: [* -> *]) a. Patch s fs a -> HFunctorList fs a
patchMeta Patch s '[Meta v, Meta] a
p
                              , mpNullTerminates :: Maybe Natural
mpNullTerminates = forall {k} (a :: k). Meta a -> Maybe Natural
Bin.mNullTerminates forall a b. (a -> b) -> a -> b
$ forall {k} (f :: k -> *) (fs :: [k -> *]) (a :: k) (i :: Nat).
RElem f fs i =>
HFunctorList fs a -> f a
hflGet forall a b. (a -> b) -> a -> b
$ forall s (fs :: [* -> *]) a. Patch s fs a -> HFunctorList fs a
patchMeta Patch s '[Meta v, Meta] a
p
                              , mpMaxBytes :: Maybe Natural
mpMaxBytes       = forall a. Maybe a
Nothing
                              , mpAligned :: Maybe Integer
mpAligned        = forall a. Maybe a
Nothing
                              }