module Resource.Source
  ( Source(..)
  , load
  , embedFile
  ) where

import RIO

import Data.FileEmbed qualified
import Data.Typeable
import GHC.Stack (withFrozenCallStack)
import Language.Haskell.TH.Syntax qualified as TH
import Resource.Compressed.Zstd qualified as Zstd
import RIO.ByteString qualified as ByteString
import RIO.FilePath (takeFileName, takeExtension)
import RIO.Text qualified as Text

data Source
  = Bytes     (Maybe Text) ByteString
  | BytesZstd (Maybe Text) (Zstd.Compressed ByteString)
  | File      (Maybe Text) FilePath

instance Show Source where
  show :: Source -> String
show = \case
    Bytes Maybe Text
mlabel ByteString
_bs ->
      String -> (Text -> String) -> Maybe Text -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"<buffer>" Text -> String
Text.unpack Maybe Text
mlabel
    BytesZstd Maybe Text
mlabel Compressed ByteString
_zbs ->
      String -> (Text -> String) -> Maybe Text -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"<zstd buffer>" Text -> String
Text.unpack Maybe Text
mlabel
    File Maybe Text
mlabel String
filePath ->
      String -> (Text -> String) -> Maybe Text -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
filePath Text -> String
Text.unpack Maybe Text
mlabel

load
  :: forall a m env
  .  ( MonadIO m
     , MonadReader env m
     , HasLogFunc env
     , Typeable a
     , HasCallStack
     )
  => (ByteString -> m a)
  -> Source
  -> m a
load :: (ByteString -> m a) -> Source -> m a
load ByteString -> m a
action = \case
  Bytes Maybe Text
label !ByteString
bytes -> do
    m () -> m ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (m () -> m ()) -> (Utf8Builder -> m ()) -> Utf8Builder -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> m ()) -> Utf8Builder -> m ()
forall a b. (a -> b) -> a -> b
$
      case Maybe Text
label of
        Maybe Text
Nothing ->
          Utf8Builder
"Loading " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> TypeRep -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow (Proxy a -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy a -> TypeRep) -> Proxy a -> TypeRep
forall a b. (a -> b) -> a -> b
$ Proxy a
forall k (t :: k). Proxy t
Proxy @a)
        Just Text
someText ->
          Utf8Builder
"Loading " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> TypeRep -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow (Proxy a -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy a -> TypeRep) -> Proxy a -> TypeRep
forall a b. (a -> b) -> a -> b
$ Proxy a
forall k (t :: k). Proxy t
Proxy @a) Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" from " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Text
someText
    ByteString -> m a
action ByteString
bytes

  BytesZstd Maybe Text
label !Compressed ByteString
bytesZstd ->
    case Compressed ByteString -> Either CompressedError ByteString
Zstd.decompressBytes Compressed ByteString
bytesZstd of
      Left CompressedError
zstdError ->
        CompressedError -> m a
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO CompressedError
zstdError
      Right !ByteString
bytes ->
        (ByteString -> m a) -> Source -> m a
forall a (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, Typeable a,
 HasCallStack) =>
(ByteString -> m a) -> Source -> m a
load ByteString -> m a
action (Source -> m a) -> Source -> m a
forall a b. (a -> b) -> a -> b
$
          Maybe Text -> ByteString -> Source
Bytes Maybe Text
label ByteString
bytes

  File Maybe Text
label String
filePath -> do
    !ByteString
bytes <- (ByteString -> m ByteString)
-> (String -> m ByteString) -> String -> m ByteString
forall (m :: * -> *) b.
MonadIO m =>
(ByteString -> m b) -> (String -> m b) -> String -> m b
Zstd.fromFileWith ByteString -> m ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IO ByteString -> m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m ByteString)
-> (String -> IO ByteString) -> String -> m ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ByteString
forall (m :: * -> *). MonadIO m => String -> m ByteString
ByteString.readFile) String
filePath
    (ByteString -> m a) -> Source -> m a
forall a (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, Typeable a,
 HasCallStack) =>
(ByteString -> m a) -> Source -> m a
load ByteString -> m a
action (Source -> m a) -> Source -> m a
forall a b. (a -> b) -> a -> b
$
      Maybe Text -> ByteString -> Source
Bytes
        (Maybe Text
label Maybe Text -> Maybe Text -> Maybe Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> Maybe Text
forall a. a -> Maybe a
Just (String -> Text
forall a. IsString a => String -> a
fromString String
filePath))
        ByteString
bytes

embedFile :: FilePath -> TH.Q TH.Exp
embedFile :: String -> Q Exp
embedFile String
filePath =
  case ShowS
takeExtension String
filePath of
    String
".zst" -> do
      Exp
bytesZstd <- String -> Q Exp
Data.FileEmbed.embedFile String
filePath
      Exp
compressed <- [| Zstd.Compressed |]
      let bytesZstdExpr :: Exp
bytesZstdExpr = Exp
compressed Exp -> Exp -> Exp
`TH.AppE` Exp
bytesZstd

      Exp
constr <- [| BytesZstd label |]
      pure $ Exp
constr Exp -> Exp -> Exp
`TH.AppE` Exp
bytesZstdExpr

    String
_ -> do
      Exp
bytes <- String -> Q Exp
Data.FileEmbed.embedFile String
filePath
      Exp
constr <- [| Bytes label |]
      pure $ Exp
constr Exp -> Exp -> Exp
`TH.AppE` Exp
bytes
  where
    label :: Maybe String
label = String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> ShowS -> String -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
forall a. Monoid a => a -> a -> a
mappend String
"embedded|" (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ ShowS
takeFileName String
filePath