{- TODO
  * Via -> Strategy (? I do like the brevity of Via)
  * Rename Compare (but not sure what to...)
-}

{-# LANGUAGE AllowAmbiguousTypes, UndecidableInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}

module StreamPatch.Patch.Compare where

import GHC.Generics ( Generic )
import Data.Data ( Typeable, Data )

import Numeric.Natural
import Data.ByteString qualified as BS
import Data.Text qualified as Text
import Data.Text ( Text )

import Data.Void
import Control.Monad ( void )

import GHC.Exts ( Proxy#, proxy# )
import GHC.TypeLits ( KnownSymbol, symbolVal' )

import Binrep.Extra.HexByteString

import Data.Aeson qualified as Aeson
import Data.Aeson ( ToJSON(..), FromJSON(..) )

import Text.Megaparsec
import Text.Megaparsec.Char qualified as MC
import Text.Megaparsec.Char.Lexer qualified as MCL

import BLAKE3 qualified as B3
import Data.ByteArray.Sized qualified as BA
import Data.ByteString qualified as B
import Data.Word ( Word8 )

import Data.Singletons.TH
-- required for deriving instances (seems like bug)
import Prelude.Singletons hiding ( AbsSym0, Compare )
import Data.Singletons.Base.TH ( FromString, sFromString )

$(singletons [d|
    -- | What sort of equality check to do.
    data EqualityCheck
      = Exact -- ^ "Exact equality" is defined as whatever the 'Eq' class does. (lol)
      | PrefixOf
        deriving stock (Show, Eq)
    |])
deriving stock instance Generic  EqualityCheck
deriving stock instance Typeable EqualityCheck
deriving stock instance Data     EqualityCheck

$(singletons [d|
    data HashFunc
      = B3
      | SHA256
      | MD5
        deriving stock (Show, Eq)
    |])
deriving stock instance Generic  HashFunc
deriving stock instance Typeable HashFunc
deriving stock instance Data     HashFunc

$(singletons [d|
    -- | How should we compare two values?
    data Via
      -- | Are they equal in some way?
      = ViaEq EqualityCheck

      -- | Do they have the same size?
      | ViaSize

      -- | Do they have the same digest under the given hash function?
      | ViaDigest HashFunc
        deriving stock (Show, Eq)
    |])
deriving stock instance Generic  Via
deriving stock instance Typeable Via
deriving stock instance Data     Via

data Meta (v :: Via) a = Meta
  { forall (v :: Via) a. Meta v a -> Maybe (CompareRep v a)
mCompare :: Maybe (CompareRep v a)
  } deriving stock (forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (v :: Via) a x. Rep (Meta v a) x -> Meta v a
forall (v :: Via) a x. Meta v a -> Rep (Meta v a) x
$cto :: forall (v :: Via) a x. Rep (Meta v a) x -> Meta v a
$cfrom :: forall (v :: Via) a x. Meta v a -> Rep (Meta v a) x
Generic)

deriving stock instance Eq   (CompareRep v a) => Eq   (Meta v a)
deriving stock instance Show (CompareRep v a) => Show (Meta v a)

deriving anyclass instance ToJSON   (CompareRep v a) => ToJSON   (Meta v a)
deriving anyclass instance FromJSON (CompareRep v a) => FromJSON (Meta v a)

instance SingI v => Functor     (Meta v) where
    fmap :: forall a b. (a -> b) -> Meta v a -> Meta v b
fmap a -> b
f (Meta Maybe (CompareRep v a)
c) = case forall {k} (a :: k). SingI a => Sing a
sing @v of
      SViaEq     Sing n
_ -> forall (v :: Via) a. Maybe (CompareRep v a) -> Meta v a
Meta forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Maybe (CompareRep v a)
c
      Sing v
SVia v
SViaSize     -> forall (v :: Via) a. Maybe (CompareRep v a) -> Meta v a
Meta Maybe (CompareRep v a)
c
      SViaDigest Sing n
_ -> forall (v :: Via) a. Maybe (CompareRep v a) -> Meta v a
Meta Maybe (CompareRep v a)
c

instance SingI v => Foldable    (Meta v) where
    foldMap :: forall m a. Monoid m => (a -> m) -> Meta v a -> m
foldMap a -> m
f (Meta Maybe (CompareRep v a)
c) = case forall {k} (a :: k). SingI a => Sing a
sing @v of
      SViaEq     Sing n
_ -> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f Maybe (CompareRep v a)
c
      Sing v
SVia v
SViaSize     -> forall a. Monoid a => a
mempty
      SViaDigest Sing n
_ -> forall a. Monoid a => a
mempty

instance SingI v => Traversable (Meta v) where
    traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Meta v a -> f (Meta v b)
traverse a -> f b
f (Meta Maybe (CompareRep v a)
c) = case forall {k} (a :: k). SingI a => Sing a
sing @v of
      SViaEq     Sing n
_ -> forall (v :: Via) a. Maybe (CompareRep v a) -> Meta v a
Meta forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f Maybe (CompareRep v a)
c
      Sing v
SVia v
SViaSize     -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (v :: Via) a. Maybe (CompareRep v a) -> Meta v a
Meta Maybe (CompareRep v a)
c
      SViaDigest Sing n
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (v :: Via) a. Maybe (CompareRep v a) -> Meta v a
Meta Maybe (CompareRep v a)
c

type family CompareRep (v :: Via) a where
    CompareRep ('ViaEq _)     a = a
    CompareRep 'ViaSize       _ = Natural
    CompareRep ('ViaDigest h) _ = Digest h B.ByteString

-- | The resulting digest from hashing some data using the given hash function.
--
-- TODO
-- As of 2022, most good cryptographic hash functions produce digest sizes
-- between 256-512 bits. That's 32-64 bytes. So I want to use a ShortByteString,
-- but the BLAKE3 library uses the memory library, which I can't figure out. I
-- bet it'd be more efficient. So, I'm polymorphising in preparation.
newtype Digest (h :: HashFunc) a = Digest { forall (h :: HashFunc) a. Digest h a -> a
getDigest :: a }
    deriving stock (forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (h :: HashFunc) a x. Rep (Digest h a) x -> Digest h a
forall (h :: HashFunc) a x. Digest h a -> Rep (Digest h a) x
$cto :: forall (h :: HashFunc) a x. Rep (Digest h a) x -> Digest h a
$cfrom :: forall (h :: HashFunc) a x. Digest h a -> Rep (Digest h a) x
Generic, Digest h a -> Digest h a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (h :: HashFunc) a. Eq a => Digest h a -> Digest h a -> Bool
/= :: Digest h a -> Digest h a -> Bool
$c/= :: forall (h :: HashFunc) a. Eq a => Digest h a -> Digest h a -> Bool
== :: Digest h a -> Digest h a -> Bool
$c== :: forall (h :: HashFunc) a. Eq a => Digest h a -> Digest h a -> Bool
Eq, Int -> Digest h a -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (h :: HashFunc) a. Show a => Int -> Digest h a -> ShowS
forall (h :: HashFunc) a. Show a => [Digest h a] -> ShowS
forall (h :: HashFunc) a. Show a => Digest h a -> String
showList :: [Digest h a] -> ShowS
$cshowList :: forall (h :: HashFunc) a. Show a => [Digest h a] -> ShowS
show :: Digest h a -> String
$cshow :: forall (h :: HashFunc) a. Show a => Digest h a -> String
showsPrec :: Int -> Digest h a -> ShowS
$cshowsPrec :: forall (h :: HashFunc) a. Show a => Int -> Digest h a -> ShowS
Show)

type Digest' h = Digest h B.ByteString

type family HashFuncLabel (h :: HashFunc) where
    HashFuncLabel 'B3     = "b3"
    HashFuncLabel 'SHA256 = "sha256"
    HashFuncLabel 'MD5    = "md5"

hashFuncLabel :: forall h l. (l ~ HashFuncLabel h, KnownSymbol l) => Text
hashFuncLabel :: forall (h :: HashFunc) (l :: Symbol).
(l ~ HashFuncLabel h, KnownSymbol l) =>
Text
hashFuncLabel = String -> Text
Text.pack (forall (n :: Symbol). KnownSymbol n => Proxy# n -> String
symbolVal' (forall {k} (a :: k). Proxy# a
proxy# :: Proxy# l))

-- | Add a @digest:@ prefix to better separate from regular text.
instance (l ~ HashFuncLabel h, KnownSymbol l) => ToJSON   (Digest h B.ByteString) where
    toJSON :: Digest h ByteString -> Value
toJSON = Text -> Value
Aeson.String forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text
Text.append Text
"digest:" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (h :: HashFunc) a (l :: Symbol).
(l ~ HashFuncLabel h, KnownSymbol l) =>
(a -> [Word8]) -> Digest h a -> Text
prettyDigest ByteString -> [Word8]
B.unpack

instance (l ~ HashFuncLabel h, KnownSymbol l) => FromJSON (Digest h B.ByteString) where
    parseJSON :: Value -> Parser (Digest h ByteString)
parseJSON = forall a. String -> (Text -> Parser a) -> Value -> Parser a
Aeson.withText String
"hex hash digest" forall a b. (a -> b) -> a -> b
$ \Text
t ->
        case forall e s a. (Ord e, Stream s) => Parsec e s a -> s -> Maybe a
parseMaybe @Void forall (h :: HashFunc) (l :: Symbol) e s (m :: * -> *).
(l ~ HashFuncLabel h, KnownSymbol l, MonadParsec e s m,
 Token s ~ Char, Tokens s ~ Text) =>
m (Digest h ByteString)
parseDigest Text
t of
          Maybe (Digest h ByteString)
Nothing   -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"failed to parse hex hash digest"
          Just Digest h ByteString
hash -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Digest h ByteString
hash

-- | Pretty print a hash like @hashfunc:123abc@.
prettyDigest
    :: forall h a l. (l ~ HashFuncLabel h, KnownSymbol l)
    => (a -> [Word8]) -> Digest h a -> Text
prettyDigest :: forall (h :: HashFunc) a (l :: Symbol).
(l ~ HashFuncLabel h, KnownSymbol l) =>
(a -> [Word8]) -> Digest h a -> Text
prettyDigest a -> [Word8]
unpack (Digest a
d) =
       forall (h :: HashFunc) (l :: Symbol).
(l ~ HashFuncLabel h, KnownSymbol l) =>
Text
hashFuncLabel @h
    forall a. Semigroup a => a -> a -> a
<> Char -> Text
Text.singleton Char
':'
    forall a. Semigroup a => a -> a -> a
<> forall a. (a -> [Word8]) -> a -> Text
prettyHexByteStringCompact a -> [Word8]
unpack a
d

-- Bad naming, these maybe aren't symbols/lexemes in the expected sense
-- (horizontal spacing is optional).
parseDigest
    :: forall h l e s m
    .  (l ~ HashFuncLabel h, KnownSymbol l, MonadParsec e s m, Token s ~ Char, Tokens s ~ Text)
    => m (Digest h B.ByteString)
parseDigest :: forall (h :: HashFunc) (l :: Symbol) e s (m :: * -> *).
(l ~ HashFuncLabel h, KnownSymbol l, MonadParsec e s m,
 Token s ~ Char, Tokens s ~ Text) =>
m (Digest h ByteString)
parseDigest = do
    Tokens s -> m ()
symbol Tokens s
"digest"
    Tokens s -> m ()
symbol Tokens s
":"
    Tokens s -> m ()
symbol forall a b. (a -> b) -> a -> b
$ forall (h :: HashFunc) (l :: Symbol).
(l ~ HashFuncLabel h, KnownSymbol l) =>
Text
hashFuncLabel @h
    Tokens s -> m ()
symbol Tokens s
":"
    forall (h :: HashFunc) a. a -> Digest h a
Digest forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char) =>
([Word8] -> a) -> m a
parseHexByteString [Word8] -> ByteString
B.pack
  where symbol :: Tokens s -> m ()
symbol = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e s (m :: * -> *) a. MonadParsec e s m => m () -> m a -> m a
MCL.lexeme forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
MC.hspace forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk

class Compare (v :: Via) a where
    compare'     :: CompareRep v a -> CompareRep v a -> Maybe String
    toCompareRep :: a -> CompareRep v a

compareTo :: forall v a. Compare v a => CompareRep v a -> a -> Maybe String
compareTo :: forall (v :: Via) a.
Compare v a =>
CompareRep v a -> a -> Maybe String
compareTo CompareRep v a
cmp = forall (v :: Via) a.
Compare v a =>
CompareRep v a -> CompareRep v a -> Maybe String
compare' @v @a CompareRep v a
cmp forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (v :: Via) a. Compare v a => a -> CompareRep v a
toCompareRep @v @a

-- Free instance: Compare for exact equality via 'Eq'.
-- TODO show is bandaid. no need to handle it here.
instance (Eq a, Show a) => Compare ('ViaEq 'Exact) a where
    toCompareRep :: a -> CompareRep ('ViaEq 'Exact) a
toCompareRep = forall a. a -> a
id
    compare' :: CompareRep ('ViaEq 'Exact) a
-> CompareRep ('ViaEq 'Exact) a -> Maybe String
compare' CompareRep ('ViaEq 'Exact) a
c1 CompareRep ('ViaEq 'Exact) a
c2 | CompareRep ('ViaEq 'Exact) a
c1 forall a. Eq a => a -> a -> Bool
== CompareRep ('ViaEq 'Exact) a
c2  = forall a. Maybe a
Nothing
                   | Bool
otherwise = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ String
"values not equal: "forall a. Semigroup a => a -> a -> a
<>forall a. Show a => a -> String
show CompareRep ('ViaEq 'Exact) a
c1forall a. Semigroup a => a -> a -> a
<>String
" /= "forall a. Semigroup a => a -> a -> a
<>forall a. Show a => a -> String
show CompareRep ('ViaEq 'Exact) a
c2

instance Compare ('ViaDigest 'B3) BS.ByteString where
    toCompareRep :: ByteString -> CompareRep ('ViaDigest 'B3) ByteString
toCompareRep = forall (h :: HashFunc) a. a -> Digest h a
Digest forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
hashB3
    compare' :: CompareRep ('ViaDigest 'B3) ByteString
-> CompareRep ('ViaDigest 'B3) ByteString -> Maybe String
compare' CompareRep ('ViaDigest 'B3) ByteString
c1 CompareRep ('ViaDigest 'B3) ByteString
c2 | CompareRep ('ViaDigest 'B3) ByteString
c1 forall a. Eq a => a -> a -> Bool
== CompareRep ('ViaDigest 'B3) ByteString
c2  = forall a. Maybe a
Nothing
                   | Bool
otherwise = forall a. a -> Maybe a
Just String
"digests not equal"

-- TODO I need to define the compare class better lol, I'm confused which is
-- real and which is test.
instance Compare ('ViaEq 'PrefixOf) BS.ByteString where
    toCompareRep :: ByteString -> CompareRep ('ViaEq 'PrefixOf) ByteString
toCompareRep = forall a. a -> a
id
    compare' :: CompareRep ('ViaEq 'PrefixOf) ByteString
-> CompareRep ('ViaEq 'PrefixOf) ByteString -> Maybe String
compare' CompareRep ('ViaEq 'PrefixOf) ByteString
c1 CompareRep ('ViaEq 'PrefixOf) ByteString
c2 | CompareRep ('ViaEq 'PrefixOf) ByteString
c2 ByteString -> ByteString -> Bool
`B.isPrefixOf` CompareRep ('ViaEq 'PrefixOf) ByteString
c1 = forall a. Maybe a
Nothing
                   | Bool
otherwise = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ String
"prefix compare check fail: "forall a. Semigroup a => a -> a -> a
<>forall a. Show a => a -> String
show CompareRep ('ViaEq 'PrefixOf) ByteString
c1forall a. Semigroup a => a -> a -> a
<>String
" vs. "forall a. Semigroup a => a -> a -> a
<>forall a. Show a => a -> String
show CompareRep ('ViaEq 'PrefixOf) ByteString
c2

-- I unpack to '[Word8]' then repack to 'ByteString' because the memory library
-- is very keen on complicated unsafe IO. cheers no thanks
hashB3 :: BS.ByteString -> BS.ByteString
hashB3 :: ByteString -> ByteString
hashB3 ByteString
bs = forall (n :: Nat) ba. SizedByteArray n ba -> ba
BA.unSizedByteArray forall a b. (a -> b) -> a -> b
$ forall (len :: Nat) digest bin.
(ByteArrayN len digest, ByteArrayAccess bin) =>
Maybe Key -> [bin] -> digest
B3.hash @B3.DEFAULT_DIGEST_LEN forall a. Maybe a
Nothing [ByteString
bs]

class SwapCompare a (vFrom :: Via) (vTo :: Via) where
    swapCompare :: CompareRep vFrom a -> Either String (CompareRep vTo a)

instance SwapCompare a v v where
    swapCompare :: CompareRep v a -> Either String (CompareRep v a)
swapCompare = forall a b. b -> Either a b
Right

instance SwapCompare BS.ByteString ('ViaEq 'Exact) ('ViaDigest 'B3) where
    swapCompare :: CompareRep ('ViaEq 'Exact) ByteString
-> Either String (CompareRep ('ViaDigest 'B3) ByteString)
swapCompare = forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (h :: HashFunc) a. a -> Digest h a
Digest forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
hashB3