{-# LANGUAGE DataKinds        #-}
{-# LANGUAGE DeriveAnyClass   #-}
{-# LANGUAGE DeriveGeneric    #-}
{-# LANGUAGE KindSignatures   #-}
{-# LANGUAGE TemplateHaskell  #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators    #-}

module Playground.TH
    ( mkFunction
    , mkFunctions
    , ensureKnownCurrencies
    , mkSchemaDefinitions
    , mkSingleFunction
    , mkKnownCurrencies
    ) where

import Language.Haskell.TH (Body (NormalB), Clause (Clause), Dec (FunD, SigD, TySynD, ValD), Exp (ListE, VarE),
                            Info (TyConI, VarI), Name, Pat (VarP), Q,
                            Type (AppT, ArrowT, ConT, ForallT, ListT, TupleT, VarT), lookupValueName, mkName, nameBase,
                            normalB, reify, sigD, valD, varP)
import Playground.Schema (endpointsToSchemas)
import Playground.Types (FunctionSchema (FunctionSchema), adaCurrency)
import Schema (FormSchema, toSchema)
import Wallet.Types (EndpointDescription (EndpointDescription))

mkFunctions :: [Name] -> Q [Dec]
mkFunctions :: [Name] -> Q [Dec]
mkFunctions [Name]
names = do
    [Dec]
fns <- (Name -> Q Dec) -> [Name] -> Q [Dec]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Name -> Q Dec
mkFunction' [Name]
names
    let newNames :: [Exp]
newNames = (Name -> Exp) -> [Name] -> [Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Exp
mkNewName [Name]
names
        schemas :: Dec
schemas = Pat -> Body -> [Dec] -> Dec
ValD (Name -> Pat
VarP (String -> Name
mkName String
"schemas")) (Exp -> Body
NormalB ([Exp] -> Exp
ListE [Exp]
newNames)) []
    [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]
fns [Dec] -> [Dec] -> [Dec]
forall a. Semigroup a => a -> a -> a
<> [Dec
schemas]
  where
    mkNewName :: Name -> Exp
mkNewName Name
name = Name -> Exp
VarE (Name -> Exp) -> (String -> Name) -> String -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName (String -> Exp) -> String -> Exp
forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase Name
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Schema"

registeredKnownCurrenciesBindingName :: String
registeredKnownCurrenciesBindingName :: String
registeredKnownCurrenciesBindingName = String
"registeredKnownCurrencies"

unlessBound :: String -> (Name -> Q [Dec]) -> Q [Dec]
unlessBound :: String -> (Name -> Q [Dec]) -> Q [Dec]
unlessBound String
bindingName Name -> Q [Dec]
definition = do
    Maybe Name
bound <- String -> Q (Maybe Name)
lookupValueName String
bindingName
    case Maybe Name
bound of
        Just Name
_  -> [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
        Maybe Name
Nothing -> Name -> Q [Dec]
definition (Name -> Q [Dec]) -> Name -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
bindingName

ensureKnownCurrencies :: Q [Dec]
ensureKnownCurrencies :: Q [Dec]
ensureKnownCurrencies =
    String -> (Name -> Q [Dec]) -> Q [Dec]
unlessBound String
registeredKnownCurrenciesBindingName ((Name -> Q [Dec]) -> Q [Dec]) -> (Name -> Q [Dec]) -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ \Name
_ ->
        [Name] -> Q [Dec]
mkKnownCurrencies []

schemaBindingName :: String
schemaBindingName :: String
schemaBindingName = String
"schemas"

{-# ANN mkSchemaDefinitions
          ("HLint: ignore Redundant bracket" :: String)
        #-}

mkSchemaDefinitions :: Name -> Q [Dec]
mkSchemaDefinitions :: Name -> Q [Dec]
mkSchemaDefinitions Name
ts = do
    Info
info <- Name -> Q Info
reify Name
ts
    case Info
info of
        TyConI (TySynD Name
_ [] Type
t) -> do
            Exp
schemas <- [|endpointsToSchemas @($(pure t)) |]
            String -> (Name -> Q [Dec]) -> Q [Dec]
unlessBound String
schemaBindingName ((Name -> Q [Dec]) -> Q [Dec]) -> (Name -> Q [Dec]) -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ \Name
name -> do
                Dec
sig <- Name -> TypeQ -> Q Dec
sigD Name
name [t|[FunctionSchema FormSchema]|]
                Dec
body <- PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD (Name -> PatQ
varP Name
name) (ExpQ -> BodyQ
normalB (Exp -> ExpQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
schemas)) []
                [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec
sig, Dec
body]
        Info
other ->
            String -> Q [Dec]
forall a. HasCallStack => String -> a
error (String -> Q [Dec]) -> String -> Q [Dec]
forall a b. (a -> b) -> a -> b
$
            String
"Incorrect Name type provided to mkSchemaDefinitions. Got: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
            Info -> String
forall a. Show a => a -> String
show Info
other

{-{- HLINT ignore mkFunction -}-}

mkFunction :: Name -> Q [Dec]
mkFunction :: Name -> Q [Dec]
mkFunction Name
_ =
    String -> Q [Dec]
forall a. HasCallStack => String -> a
error (String -> Q [Dec]) -> String -> Q [Dec]
forall a b. (a -> b) -> a -> b
$
    String
"" String -> String -> String
</> String
"mkFunction has been replaced by mkFunctions" String -> String -> String
</> String
" " String -> String -> String
</>
    String
"replace all calls to mkFunction with a single call to mkFunctions, e.g." String -> String -> String
</>
    String
" " String -> String -> String
</>
    String
" | $(mkFunction 'functionOne)" String -> String -> String
</>
    String
" | $(mkFunction 'functionTwo)" String -> String -> String
</>
    String
" " String -> String -> String
</>
    String
"becomes:" String -> String -> String
</>
    String
" " String -> String -> String
</>
    String
" | $(mkFunctions ['functionOne, 'functionTwo])" String -> String -> String
</>
    String
" "
  where
    String
a </> :: String -> String -> String
</> String
b = String
a String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
b

mkSingleFunction :: Name -> Q [Dec]
mkSingleFunction :: Name -> Q [Dec]
mkSingleFunction Name
name = do
    Dec
dec <- Name -> Q Dec
mkFunction' Name
name
    [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec
dec]

mkFunction' :: Name -> Q Dec
mkFunction' :: Name -> Q Dec
mkFunction' Name
name = do
    let newName :: Name
newName = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase Name
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Schema"
        fn :: EndpointDescription
fn = String -> EndpointDescription
EndpointDescription (String -> EndpointDescription) -> String -> EndpointDescription
forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase Name
name
    Exp
expression <- Name -> EndpointDescription -> ExpQ
mkFunctionExp Name
name EndpointDescription
fn
    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
$ Name -> [Clause] -> Dec
FunD Name
newName [[Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB Exp
expression) []]

{-{- HLINT ignore mkFunctionExp -}-}

mkFunctionExp :: Name -> EndpointDescription -> Q Exp
mkFunctionExp :: Name -> EndpointDescription -> ExpQ
mkFunctionExp Name
name EndpointDescription
fn = do
    Info
r <- Name -> Q Info
reify Name
name
    case Info
r of
        (VarI Name
_ Type
as Maybe Dec
_) ->
            let ts :: [Type]
ts = Type -> [Type]
args Type
as
             in EndpointDescription -> [Type] -> ExpQ
toSchemas EndpointDescription
fn [Type]
ts
        Info
_ -> String -> ExpQ
forall a. HasCallStack => String -> a
error String
"Incorrect Name type provided to mkFunction"

{- HLINT ignore toSchemas "Redundant bracket" -}

toSchemas :: EndpointDescription -> [Type] -> Q Exp
toSchemas :: EndpointDescription -> [Type] -> ExpQ
toSchemas EndpointDescription
fn [Type]
ts = do
    Exp
es <- (Type -> ExpQ -> ExpQ) -> ExpQ -> [Type] -> ExpQ
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Type
t ExpQ
e -> [|toSchema @($(pure t)) : $e|]) [|[]|] [Type]
ts
    [|FunctionSchema fn $(pure es)|]

{-{- HLINT ignore args -}-}

args :: Type -> [Type]
args :: Type -> [Type]
args (AppT (AppT Type
ArrowT Type
t1) Type
as) = Type
t1 Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: Type -> [Type]
args Type
as
args (AppT (ConT Name
_) Type
_)          = []
args (AppT (AppT (ConT Name
_) Type
_) Type
_) = []
args (ForallT [TyVarBndr]
_ [Type]
_ Type
as)           = Type -> [Type]
args Type
as
args (ConT Name
_)                   = []
args (TupleT Int
_)                 = []
args (AppT (VarT Name
_) Type
t)          = Type -> [Type]
args Type
t
args Type
a                          = String -> [Type]
forall a. HasCallStack => String -> a
error (String -> [Type]) -> String -> [Type]
forall a b. (a -> b) -> a -> b
$ String
"incorrect type in template haskell function: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
a

mkKnownCurrencies :: [Name] -> Q [Dec]
mkKnownCurrencies :: [Name] -> Q [Dec]
mkKnownCurrencies [Name]
ks = do
    let name :: Name
name = String -> Name
mkName String
registeredKnownCurrenciesBindingName
        sig :: Dec
sig = Name -> Type -> Dec
SigD Name
name (Type -> Type -> Type
AppT Type
ListT (Name -> Type
ConT (String -> Name
mkName String
"KnownCurrency")))
        names :: [Exp]
names = (Name -> Exp) -> [Name] -> [Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Exp
VarE ('Playground.Types.adaCurrency Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: [Name]
ks)
        body :: Body
body = Exp -> Body
NormalB ([Exp] -> Exp
ListE [Exp]
names)
        val :: Dec
val = Pat -> Body -> [Dec] -> Dec
ValD (Name -> Pat
VarP Name
name) Body
body []
    [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec
sig, Dec
val]