{-# LANGUAGE QuasiQuotes     #-}
{-# LANGUAGE TemplateHaskell #-}

module Tendermint.SDK.BaseApp.Store.TH
  ( makeSubStore
  , module Tendermint.SDK.BaseApp.Store.RawStore
  , module Tendermint.SDK.BaseApp.Store.Var
  , module Tendermint.SDK.BaseApp.Store.Array
  , module Tendermint.SDK.BaseApp.Store.List
  , module Tendermint.SDK.BaseApp.Store.Map
  ) where


import           Control.Lens                          (iso)
import           Data.ByteString                       (ByteString)
import           Data.String.Conversions               (cs)
import           Language.Haskell.TH
import           Tendermint.SDK.BaseApp.Store.Array    (Array, makeArray)
import           Tendermint.SDK.BaseApp.Store.List     (List, makeList)
import           Tendermint.SDK.BaseApp.Store.Map      (Map, makeMap)
import           Tendermint.SDK.BaseApp.Store.RawStore (IsKey (..), RawKey (..))
import           Tendermint.SDK.BaseApp.Store.Var      (Var, makeVar)


makeSubStore
  :: Name
  -- ^ store
  -> String
  -- ^ substoreName
  -> TypeQ
  -- ^ store type
  -> ByteString
  -- ^ key
  -> Q [Dec]
makeSubStore :: Name -> String -> TypeQ -> ByteString -> Q [Dec]
makeSubStore storeName :: Name
storeName substoreName :: String
substoreName t :: TypeQ
t key :: ByteString
key = do
    Name
namespaceName <- Q Name
getStoreNamespace
    KeyType
keyType <- Type -> KeyType
parseKeyType (Type -> KeyType) -> TypeQ -> Q KeyType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeQ
t
    let keyTypeName :: Name
keyTypeName = KeyType -> Name
mkKeyName KeyType
keyType
    Dec
dataDecl <- Name -> Q Dec
mkDataDecl Name
keyTypeName
    Dec
rawKeyInst <- ByteString -> Name -> Q Dec
mkRawKeyInstance ByteString
key Name
keyTypeName
    Dec
isKeyInst <- Name -> Name -> TypeQ -> Q Dec
mkIsKeyInstance Name
namespaceName Name
keyTypeName TypeQ
t
    [Dec]
storeDecl <- Name -> String -> TypeQ -> Q [Dec]
mkSubStoreDecl Name
storeName String
substoreName TypeQ
t
    [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [Dec
dataDecl, Dec
rawKeyInst, Dec
isKeyInst] [Dec] -> [Dec] -> [Dec]
forall a. Semigroup a => a -> a -> a
<> [Dec]
storeDecl
  where
    getStoreNamespace :: Q Name
getStoreNamespace  = do
      Info
info <- Name -> Q Info
reify Name
storeName
      case Info
info of
        VarI _ _t :: Type
_t _ -> case Type
_t of
          AppT (ConT n :: Name
n) (ConT m :: Name
m) ->
            if Name -> String
nameBase Name
n String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "Store"
              then Name -> Q Name
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
m
              else String -> Q Name
forall a. HasCallStack => String -> a
error "Unable to find Store Namespace, make sure store is of type (Store ns)"
          _ -> String -> Q Name
forall a. HasCallStack => String -> a
error "Unable to find Store Namespace, make sure store is of type (Store ns)"
        _ -> String -> Q Name
forall a. HasCallStack => String -> a
error "Unable to find Store Namespace, make sure store is of type (Store ns)"

data KeyType =
    Var Name
  | List Name
  | Array Name
  | Map Name Name

parseKeyType :: Type -> KeyType
parseKeyType :: Type -> KeyType
parseKeyType = \case
  AppT (ConT n :: Name
n) (ConT m :: Name
m) -> case Name -> String
nameBase Name
n of
    "Var" -> Name -> KeyType
Var Name
m
    "List" -> Name -> KeyType
List Name
m
    "Array" -> Name -> KeyType
Array Name
m
    a :: String
a -> String -> KeyType
forall a. HasCallStack => String -> a
error (String -> KeyType) -> String -> KeyType
forall a b. (a -> b) -> a -> b
$ "Unrecognized KeyType " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
a String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ", expected Var, List, Array, Map."
  AppT (AppT (ConT n :: Name
n) (ConT m :: Name
m)) (ConT o :: Name
o) -> case Name -> String
nameBase Name
n of
    "Map" -> Name -> Name -> KeyType
Map Name
m Name
o
    a :: String
a -> String -> KeyType
forall a. HasCallStack => String -> a
error (String -> KeyType) -> String -> KeyType
forall a b. (a -> b) -> a -> b
$ "Unrecognized KeyType " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
a String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ", expected Var, List, Array, Map."
  _ -> String -> KeyType
forall a. HasCallStack => String -> a
error (String -> KeyType) -> String -> KeyType
forall a b. (a -> b) -> a -> b
$ "Unrecognized Store type, expected (Var a), (List a), (Array a), (Map k v)."

mkKeyName :: KeyType -> Name
mkKeyName :: KeyType -> Name
mkKeyName = String -> Name
mkName (String -> Name) -> (KeyType -> String) -> KeyType -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
  Var n :: Name
n -> Name -> String
nameBase Name
n String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "VarKey"
  Array n :: Name
n -> Name -> String
nameBase Name
n String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "ArrayKey"
  List n :: Name
n -> Name -> String
nameBase Name
n String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "ListKey"
  Map n :: Name
n m :: Name
m -> Name -> String
nameBase Name
n String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Name -> String
nameBase Name
m String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "MapKey"


mkDataDecl :: Name -> Q Dec
mkDataDecl :: Name -> Q Dec
mkDataDecl keyTypeName :: Name
keyTypeName =
  CxtQ
-> Name
-> [TyVarBndr]
-> Maybe Type
-> [ConQ]
-> [DerivClauseQ]
-> Q Dec
dataD ([Type] -> CxtQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure []) Name
keyTypeName [] Maybe Type
forall a. Maybe a
Nothing [Name -> [BangTypeQ] -> ConQ
normalC Name
keyTypeName []] []

mkRawKeyInstance :: ByteString -> Name -> Q Dec
mkRawKeyInstance :: ByteString -> Name -> Q Dec
mkRawKeyInstance keyBytes :: ByteString
keyBytes keyTypeName :: Name
keyTypeName =
  let keyBytesStr :: String
keyBytesStr = ByteString -> String
forall a b. ConvertibleStrings a b => a -> b
cs ByteString
keyBytes
      genRawKeyClause :: Q Clause
genRawKeyClause = do
        Exp
body <- [| iso (const $ cs @String @ByteString $(litE $ StringL keyBytesStr)) (const $(conE keyTypeName)) |]
        Clause -> Q Clause
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Clause -> Q Clause) -> Clause -> Q Clause
forall a b. (a -> b) -> a -> b
$ [Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB Exp
body) []
  in CxtQ -> TypeQ -> [Q Dec] -> Q Dec
instanceD ([Type] -> CxtQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure []) (Name -> TypeQ
conT ''RawKey TypeQ -> TypeQ -> TypeQ
`appT` Name -> TypeQ
conT Name
keyTypeName) [Name -> [Q Clause] -> Q Dec
funD 'rawKey [Q Clause
genRawKeyClause]]

mkIsKeyInstance
  :: Name
  -- Namespace name
  -> Name
  -- KeyType name
  -> TypeQ
  -- store type
  -> Q Dec
mkIsKeyInstance :: Name -> Name -> TypeQ -> Q Dec
mkIsKeyInstance namespaceName :: Name
namespaceName keyTypeName :: Name
keyTypeName t :: TypeQ
t =
  CxtQ -> TypeQ -> [Q Dec] -> Q Dec
instanceD ([Type] -> CxtQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure []) (Name -> TypeQ
conT ''IsKey TypeQ -> TypeQ -> TypeQ
`appT` Name -> TypeQ
conT Name
keyTypeName TypeQ -> TypeQ -> TypeQ
`appT` Name -> TypeQ
conT Name
namespaceName)
    [TySynEqnQ -> Q Dec
tySynInstD (TySynEqnQ -> Q Dec) -> TySynEqnQ -> Q Dec
forall a b. (a -> b) -> a -> b
$ Maybe [TyVarBndr] -> TypeQ -> TypeQ -> TySynEqnQ
tySynEqn Maybe [TyVarBndr]
forall a. Maybe a
Nothing (Name -> TypeQ
conT ''Value TypeQ -> TypeQ -> TypeQ
`appT` Name -> TypeQ
conT Name
keyTypeName TypeQ -> TypeQ -> TypeQ
`appT` Name -> TypeQ
conT Name
namespaceName) TypeQ
t]



mkSubStoreDecl
  :: Name
  -> String
  -> TypeQ
  -> Q [Dec]
mkSubStoreDecl :: Name -> String -> TypeQ -> Q [Dec]
mkSubStoreDecl store :: Name
store substoreName :: String
substoreName t :: TypeQ
t = do
  KeyType
kt <- Type -> KeyType
parseKeyType (Type -> KeyType) -> TypeQ -> Q KeyType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeQ
t
  let keyName :: Name
keyName = KeyType -> Name
mkKeyName KeyType
kt
      storeBody :: ExpQ
storeBody = case KeyType
kt of
        Var _   -> [| makeVar $(conE keyName) $(varE store) |]
        List _  -> [| makeList $(conE keyName) $(varE store) |]
        Array _ -> [| makeArray $(conE keyName) $(varE store) |]
        Map _ _ -> [| makeMap $(conE keyName) $(varE store) |]
  Dec
sig <- Name -> TypeQ -> Q Dec
sigD (String -> Name
mkName String
substoreName) TypeQ
t
  Dec
val <- PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD (Name -> PatQ
varP (Name -> PatQ) -> Name -> PatQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
substoreName) (ExpQ -> BodyQ
normalB ExpQ
storeBody) []
  [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec
sig,Dec
val]