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

import RIO

import Data.FileEmbed qualified
import Data.Typeable
import GHC.Records (HasField(..))
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 HasField "label" Source (Maybe Text) where
  {-# INLINE getField #-}
  getField :: Source -> Maybe Text
getField = \case
    Bytes Maybe Text
label ByteString
_bytes     -> Maybe Text
label
    BytesZstd Maybe Text
label Compressed ByteString
_bytes -> Maybe Text
label
    File Maybe Text
label FilePath
_path       -> Maybe Text
label

instance Show Source where
  show :: Source -> FilePath
show = \case
    Bytes Maybe Text
mlabel ByteString
_bs ->
      FilePath -> (Text -> FilePath) -> Maybe Text -> FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe FilePath
"<buffer>" Text -> FilePath
Text.unpack Maybe Text
mlabel
    BytesZstd Maybe Text
mlabel Compressed ByteString
_zbs ->
      FilePath -> (Text -> FilePath) -> Maybe Text -> FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe FilePath
"<zstd buffer>" Text -> FilePath
Text.unpack Maybe Text
mlabel
    File Maybe Text
mlabel FilePath
filePath ->
      FilePath -> (Text -> FilePath) -> Maybe Text -> FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe FilePath
filePath Text -> FilePath
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 :: 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 = \case
  Bytes Maybe Text
label !ByteString
bytes -> do
    (HasCallStack => m ()) -> m ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => m ()) -> m ()) -> (HasCallStack => m ()) -> m ()
forall a b. (a -> b) -> a -> b
$
      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
$ forall t. Proxy t
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
$ forall t. Proxy t
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 FilePath
filePath -> do
    !ByteString
bytes <- (ByteString -> m ByteString)
-> (FilePath -> m ByteString) -> FilePath -> m ByteString
forall (m :: * -> *) b.
MonadIO m =>
(ByteString -> m b) -> (FilePath -> m b) -> FilePath -> m b
Zstd.fromFileWith ByteString -> m ByteString
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IO ByteString -> m ByteString
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m ByteString)
-> (FilePath -> IO ByteString) -> FilePath -> m ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO ByteString
forall (m :: * -> *). MonadIO m => FilePath -> m ByteString
ByteString.readFile) FilePath
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 a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> Maybe Text
forall a. a -> Maybe a
Just (FilePath -> Text
forall a. IsString a => FilePath -> a
fromString FilePath
filePath))
        ByteString
bytes

embedFile :: FilePath -> TH.Q TH.Exp
embedFile :: FilePath -> Q Exp
embedFile FilePath
filePath =
  case ShowS
takeExtension FilePath
filePath of
    FilePath
".zst" -> do
      Exp
bytesZstd <- FilePath -> Q Exp
Data.FileEmbed.embedFile FilePath
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

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