Cache.hs

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.App.Internal.Resolving.Cache
  ( CacheKey (..),
    CacheStore (..),
    printSelectionKey,
    useCached,
    isCached,
    withDebug,
    cacheResolverValues,
    cacheValue,
    CacheValue (..),
    CacheT,
  )
where

import Control.Monad.Except
import Data.ByteString.Lazy.Char8 (unpack)
import qualified Data.HashMap.Lazy as HM
import Data.Morpheus.App.Internal.Resolving.ResolverState
import Data.Morpheus.App.Internal.Resolving.Types (ResolverValue)
import Data.Morpheus.App.Internal.Resolving.Utils (ResolverMonad)
import Data.Morpheus.Core (Config (debug), RenderGQL, render)
import Data.Morpheus.Internal.Utils
  ( Empty (..),
    IsMap (..),
  )
import Data.Morpheus.Types.Internal.AST
  ( Msg (msg),
    SelectionContent,
    TypeName,
    VALID,
    ValidValue,
    internal,
  )
import Debug.Trace (trace)
import Relude hiding (Show, empty, show, trace)
import Prelude (Show (show))

type CacheT m = (StateT (CacheStore m) m)

printSelectionKey :: (RenderGQL a) => a -> String
printSelectionKey sel = map replace $ filter ignoreSpaces $ unpack (render sel)
  where
    ignoreSpaces x = x /= ' '
    replace '\n' = ' '
    replace x = x

data CacheKey = CacheKey
  { cachedSel :: SelectionContent VALID,
    cachedTypeName :: TypeName,
    cachedArg :: ValidValue
  }
  deriving (Eq, Generic)

data CacheValue m
  = CachedValue ValidValue
  | CachedResolver (ResolverValue m)

instance Show (CacheValue m) where
  show (CachedValue v) = unpack (render v)
  show (CachedResolver v) = show v

instance Show CacheKey where
  show (CacheKey sel typename dep) = printSelectionKey sel <> ":" <> toString typename <> ":" <> unpack (render dep)

instance Hashable CacheKey where
  hashWithSalt s (CacheKey sel tyName arg) = hashWithSalt s (sel, tyName, render arg)

newtype CacheStore m = CacheStore {_unpackStore :: HashMap CacheKey (CacheValue m)}

instance Show (CacheStore m) where
  show (CacheStore cache) = "\nCACHE:\n" <> intercalate "\n" (map printKeyValue $ toAssoc cache) <> "\n"
    where
      printKeyValue (key, v) = " " <> show key <> ": " <> show v

instance Empty (CacheStore m) where
  empty = CacheStore empty

cacheResolverValues :: (ResolverMonad m) => [(CacheKey, ResolverValue m)] -> CacheT m ()
cacheResolverValues pres = do
  CacheStore oldCache <- get
  let updates = unsafeFromList (map (second CachedResolver) pres)
  cache <- labeledDebug "\nUPDATE|>" $ CacheStore $ updates <> oldCache
  modify (const cache)

useCached :: (ResolverMonad m) => CacheKey -> CacheT m (CacheValue m)
useCached v = do
  cache <- get >>= labeledDebug "\nUSE|>"
  case lookup v (_unpackStore cache) of
    Just x -> pure x
    Nothing -> throwError (internal $ "cache value could not found for key" <> msg (show v :: String))

isCached :: (Monad m) => CacheKey -> CacheT m Bool
isCached key = isJust . lookup key . _unpackStore <$> get

setValue :: (CacheKey, ValidValue) -> CacheStore m -> CacheStore m
setValue (key, value) = CacheStore . HM.insert key (CachedValue value) . _unpackStore

labeledDebug :: (Show a, MonadReader ResolverContext m) => String -> a -> m a
labeledDebug label v = showValue <$> asks (debug . config)
  where
    showValue enabled
      | enabled = trace (label <> show v) v
      | otherwise = v

withDebug :: (Show a, MonadReader ResolverContext m) => a -> m a
withDebug = labeledDebug ""

cacheValue :: (Monad m) => CacheKey -> ValidValue -> CacheT m ValidValue
cacheValue key value = modify (setValue (key, value)) $> value