{- This file is part of Vervis.
 -
 - Written in 2023 by fr33domlover <fr33domlover@riseup.net>.
 -
 - ♡ Copying is an act of love. Please copy, reuse and share.
 -
 - The author(s) have dedicated all copyright and related and neighboring
 - rights to this software to the public domain worldwide. This software is
 - distributed without any warranty.
 -
 - You should have received a copy of the CC0 Public Domain Dedication along
 - with this software. If not, see
 - <http://creativecommons.org/publicdomain/zero/1.0/>.
 -}

-- For the fundep in FaceType - is that fundep needed? haven't verified yet
{-# LANGUAGE TypeFamilyDependencies #-}

{-# LANGUAGE DataKinds #-}

-- | This module is only for use when implementing new backends, i.e.
-- 'Workshop' instances. It exports everything 'Data.Slab' does, in addition to
-- types needed for implementing a backend.
module Data.Slab.Backend
    ( SlabValue (..)
    , Hard (..)
    , Face (..)
    , FaceType ()
    , Engrave (..)
    , EngraveShow ()
    , EngraveJSON ()
    , EngraveSerialize ()
    , Slab (..)
    , Workshop (..)
    )
where

import Data.Bifunctor
import Data.ByteString (ByteString)
import Data.Kind
import Data.Proxy
import Data.Text (Text)
import Data.Typeable
import Text.Read (readEither)

import qualified Data.Aeson as A
import qualified Data.ByteString.Lazy as BL
import qualified Data.Serialize as S
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.Text.Encoding.Error as TEE

data SlabValue = SlabText Text | SlabByteString ByteString deriving Show

{-
data SlabValue (a :: Type) :: Type where
    SlabText :: Text -> SlabValue Text
    SlabByteString :: ByteString -> SlabValue ByteString
-}

class Hard (f :: Face) where
    toSlabValue :: FaceType f -> SlabValue
    fromSlabValue :: SlabValue -> Either Text (FaceType f)

data Face = FaceText | FaceByteString

type family FaceType (a :: Face) {-:: Type-} = t | t -> a where
    FaceType 'FaceText       = Text
    FaceType 'FaceByteString = ByteString

instance Hard 'FaceText where
    toSlabValue = SlabText
    fromSlabValue (SlabText t) = Right t
    fromSlabValue s  =
        Left $ "fromSlabValue FaceText: Got " <> T.pack (show s)

instance Hard 'FaceByteString where
    toSlabValue = SlabByteString
    fromSlabValue (SlabByteString b) = Right b
    fromSlabValue s  =
        Left $ "fromSlabValue FaceByteString: Got " <> T.pack (show s)

class Hard (EngraveFace a) => Engrave a where
    type EngraveFace a :: Face
    engrave :: a -> FaceType (EngraveFace a)
    see :: FaceType (EngraveFace a) -> Either Text a

{-
engrave :: Engrave a => a -> SlabValue
engrave = toSlabValue . engrave

see :: Engrave a => SlabValue -> Either Text a
see = see <=< fromSlabValue
-}

instance Engrave Text where
    type EngraveFace Text = 'FaceText
    engrave = id
    see = Right

instance Engrave ByteString where
    type EngraveFace ByteString = 'FaceByteString
    engrave = id
    see = Right

showError :: Typeable a => Either (Proxy a, Text -> Text) a -> Either Text a
showError = bimap (uncurry errorText) id
    where
    errorText :: Typeable b => Proxy b -> (Text -> Text) -> Text
    errorText p mk = mk $ T.pack $ show $ typeRep p

newtype EngraveShow a = EngraveShow { unEngraveShow :: a }

instance (Typeable a, Show a, Read a) => Engrave (EngraveShow a) where
    type EngraveFace (EngraveShow a) = EngraveFace Text
    engrave = engrave . T.pack . show . unEngraveShow
    see v = do
        t <- see v
        showError $
            case readEither $ T.unpack t of
                Left e ->
                    Left $ (Proxy,) $ \ typ ->
                        T.concat [ "Invalid ", typ,  ": ", T.pack e, ": ", t]
                Right x -> Right $ EngraveShow x

newtype EngraveJSON a = EngraveJSON { unEngraveJSON :: a }

instance (Typeable a, A.FromJSON a, A.ToJSON a) => Engrave (EngraveJSON a) where
    type EngraveFace (EngraveJSON a) = EngraveFace ByteString
    engrave = BL.toStrict . A.encode . unEngraveJSON
    see v = do
        bs <- see v
        let input = TE.decodeUtf8With TEE.lenientDecode bs -- TE.decodeUtf8Lenient bs
        showError $
            case A.eitherDecodeStrict' bs of
                Left e ->
                    Left $ (Proxy,) $ \ typ ->
                        T.concat
                            [ "JSON decoding error for ", typ, ": "
                            , T.pack e, " on input: ", input
                            ]
                Right x -> Right $ EngraveJSON x

newtype EngraveSerialize a = EngraveSerialize { unEngraveSerialize :: a }

instance (Typeable a, S.Serialize a) => Engrave (EngraveSerialize a) where
    type EngraveFace (EngraveSerialize a) = EngraveFace ByteString
    engrave = engrave . S.encode . unEngraveSerialize
    see v = do
        b <- see v
        showError $
            case S.decode b of
                Left e ->
                    Left $ (Proxy,) $
                        \ typ -> T.concat ["Invalid ", typ, ": ", T.pack e]
                Right x -> Right $ EngraveSerialize x

class Slab (s :: Type -> Type) where
    -- | Once the slab has been created, it's meant to be used from a single
    -- thread. As long as this thread hasn't obliterated the slab, it can
    -- 'retrieve' it as many times as it wants.
    --
    -- Most likely you want to retrieve once when the thread starts, and
    -- retrieve again whenever the thread crashes/restarts and loses access to
    -- the slab.
    --
    -- If you want multiple threads to have access to the slab's value,
    -- 'retrieve' the slab once and then pass the value to those threads.
    retrieve :: Engrave a => s a -> IO a
    -- | Permanently deletes the slab from the workshop. Meant to be used only
    -- from a single thread. Meant to be used only once. After that one use,
    -- retrieving or obliterating again will raise an exception.
    obliterate :: Engrave a => s a -> IO ()

class Slab (WorkshopSlab w) => Workshop w where
    data WorkshopSlab w :: Type -> Type
    data WorkshopConfig w :: Type
    -- | Unless a specific 'Workshop' instance says otherwise, it's safe to
    -- 'load' a workshop only when nothing else is holding access to it: Not
    -- your program, not another thread, not another process.
    --
    -- You probably want to load your workshop once when your application
    -- starts, and reload when the component of your program that uses the
    -- workshop is restarted.
    load :: Engrave a => WorkshopConfig w -> IO (w a, [WorkshopSlab w a])
    -- | Create a new slab with the given value. This must be thread-safe, i.e.
    -- different threads can concurrently create new slabs. However, once the
    -- slab is obtained, only one thread should use it.
    --
    -- If you want multiple threads to have access to the slab's value,
    -- 'retrieve' the slab once and then pass the value to those threads.
    conceive :: Engrave a => w a -> a -> IO (WorkshopSlab w a)
    -- | Clear the workshop. Like 'load', this is safe only if nothing else
    -- holds access to the workshop.
    vacate :: Engrave a => w a -> IO ()