{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes       #-}
{-# LANGUAGE TemplateHaskell   #-}

-- |
-- Module      :  Network.Ethereum.Contract.TH
-- Copyright   :  Aleksandr Krupenkin 2016-2021
-- License     :  Apache-2.0
--
-- Maintainer  :  mail@akru.me
-- Stability   :  experimental
-- Portability :  unportable
--
-- Contract abstraction is a high level interface of web3 library.
--
-- The Application Binary Interface is the standard way to interact
-- with contracts in the Ethereum ecosystem. It can be described by
-- specially JSON file, like @ERC20.json@. This module use TemplateHaskell
-- for generation described in Abi contract methods and events. Helper
-- functions and instances inserted in haskell module and can be used in
-- another modules or in place.
--
-- @
-- import Network.Ethereum.Contract.TH
--
-- [abiFrom|examples/ERC20.json|]
--
-- main = do
--     runWeb3 $ event' def $
--        \(Transfer _ to val) -> liftIO $ do print to
--                                            print val
-- @
--
-- Full code example available in examples folder.
--

module Network.Ethereum.Contract.TH
    (
    -- * The contract quasiquoters
      abi
    , abiFrom
    ) where

import           Control.Applicative              ((<|>))
import           Control.Monad                    (replicateM, (<=<))
import qualified Data.Aeson                       as Aeson (encode)
import           Data.ByteArray                   (convert)
import           Data.Char                        (toLower, toUpper)
import qualified Data.Char                        as Char
import           Data.Default                     (Default (..))
import           Data.List                        (group, sort, uncons)
import           Data.Tagged                      (Tagged)
import           Data.Text                        (Text)
import qualified Data.Text                        as T
import qualified Data.Text.Lazy                   as LT
import qualified Data.Text.Lazy.Encoding          as LT
import           Data.Tuple.OneTuple              (OneTuple, only)
import           Generics.SOP                     (Generic)
import qualified GHC.Generics                     as GHC (Generic)
import           Language.Haskell.TH
import           Language.Haskell.TH.Quote
import           Lens.Micro                       (over, (^?), _head)
import           Lens.Micro.Aeson                 (key, _JSON, _String)

import           Data.Solidity.Abi                (AbiGet, AbiPut, AbiType (..))
import           Data.Solidity.Event              (IndexedEvent (..))
import           Data.Solidity.Prim               (Address, Bytes, BytesN, IntN,
                                                   ListN, UIntN)
import           Language.Solidity.Abi            (ContractAbi (..),
                                                   Declaration (..),
                                                   EventArg (..),
                                                   FunctionArg (..),
                                                   SolidityType (..),
                                                   eventId,
                                                   methodId,
                                                   parseSolidityEventArgType,
                                                   parseSolidityFunctionArgType)
import           Network.Ethereum.Account.Class   (Account (..))
import           Network.Ethereum.Api.Types       (DefaultBlock (..),
                                                   Filter (..), TxReceipt)
import qualified Network.Ethereum.Contract        as Contract (Contract (..))
import           Network.Ethereum.Contract.Method (Method (..))
import           Network.JsonRpc.TinyClient       (JsonRpc)

-- | Read contract Abi from file
abiFrom :: QuasiQuoter
abiFrom :: QuasiQuoter
abiFrom = QuasiQuoter -> QuasiQuoter
quoteFile QuasiQuoter
abi

-- | QQ reader for contract Abi
abi :: QuasiQuoter
abi :: QuasiQuoter
abi = QuasiQuoter :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter
    { quoteDec :: String -> Q [Dec]
quoteDec  = String -> Q [Dec]
quoteAbiDec
    , quoteExp :: String -> Q Exp
quoteExp  = String -> Q Exp
quoteAbiExp
    , quotePat :: String -> Q Pat
quotePat  = String -> Q Pat
forall a. HasCallStack => a
undefined
    , quoteType :: String -> Q Type
quoteType = String -> Q Type
forall a. HasCallStack => a
undefined }

-- | Instance declaration with empty context
instanceD' :: Name -> TypeQ -> [DecQ] -> DecQ
instanceD' :: Name -> Q Type -> [DecQ] -> DecQ
instanceD' Name
name Q Type
insType =
    CxtQ -> Q Type -> [DecQ] -> DecQ
instanceD ([Q Type] -> CxtQ
cxt []) (Q Type -> Q Type -> Q Type
appT Q Type
insType (Name -> Q Type
conT Name
name))

-- | Simple data type declaration with one constructor
dataD' :: Name -> ConQ -> [Name] -> DecQ
dataD' :: Name -> ConQ -> [Name] -> DecQ
dataD' Name
name ConQ
rec' [Name]
derive =
    CxtQ
-> Name
-> [TyVarBndr]
-> Maybe Type
-> [ConQ]
-> [DerivClauseQ]
-> DecQ
dataD ([Q Type] -> CxtQ
cxt []) Name
name [] Maybe Type
forall a. Maybe a
Nothing [ConQ
rec'] [Maybe DerivStrategy -> [Q Type] -> DerivClauseQ
derivClause Maybe DerivStrategy
forall a. Maybe a
Nothing (Name -> Q Type
conT (Name -> Q Type) -> [Name] -> [Q Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
derive)]

-- | Simple function declaration
funD' :: Name -> [PatQ] -> ExpQ -> DecQ
funD' :: Name -> [Q Pat] -> Q Exp -> DecQ
funD' Name
name [Q Pat]
p Q Exp
f = Name -> [ClauseQ] -> DecQ
funD Name
name [[Q Pat] -> BodyQ -> [DecQ] -> ClauseQ
clause [Q Pat]
p (Q Exp -> BodyQ
normalB Q Exp
f) []]

-- | Abi and Haskell types association
toHSType :: SolidityType -> TypeQ
toHSType :: SolidityType -> Q Type
toHSType SolidityType
s = case SolidityType
s of
    SolidityType
SolidityBool        -> Name -> Q Type
conT ''Bool
    SolidityType
SolidityAddress     -> Name -> Q Type
conT ''Address
    SolidityUint Int
n      -> Q Type -> Q Type -> Q Type
appT (Name -> Q Type
conT ''UIntN) (Int -> Q Type
forall a. Integral a => a -> Q Type
numLit Int
n)
    SolidityInt Int
n       -> Q Type -> Q Type -> Q Type
appT (Name -> Q Type
conT ''IntN) (Int -> Q Type
forall a. Integral a => a -> Q Type
numLit Int
n)
    SolidityType
SolidityString      -> Name -> Q Type
conT ''Text
    SolidityBytesN Int
n    -> Q Type -> Q Type -> Q Type
appT (Name -> Q Type
conT ''BytesN) (Int -> Q Type
forall a. Integral a => a -> Q Type
numLit Int
n)
    SolidityType
SolidityBytes       -> Name -> Q Type
conT ''Bytes
    SolidityTuple [SolidityType
a]   -> Q Type -> Q Type -> Q Type
appT (Name -> Q Type
conT ''OneTuple) (SolidityType -> Q Type
toHSType SolidityType
a)
    SolidityTuple [SolidityType]
as    -> (Q Type -> SolidityType -> Q Type)
-> Q Type -> [SolidityType] -> Q Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ( \Q Type
b SolidityType
a -> Q Type -> Q Type -> Q Type
appT Q Type
b (Q Type -> Q Type) -> Q Type -> Q Type
forall a b. (a -> b) -> a -> b
$ SolidityType -> Q Type
toHSType SolidityType
a ) ( Int -> Q Type
tupleT ([SolidityType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SolidityType]
as) ) [SolidityType]
as
    SolidityVector [Int]
ns SolidityType
a -> [Int] -> SolidityType -> Q Type
expandVector [Int]
ns SolidityType
a
    SolidityArray SolidityType
a     -> Q Type -> Q Type -> Q Type
appT Q Type
listT (Q Type -> Q Type) -> Q Type -> Q Type
forall a b. (a -> b) -> a -> b
$ SolidityType -> Q Type
toHSType SolidityType
a
  where
    numLit :: a -> Q Type
numLit a
n = TyLitQ -> Q Type
litT (Integer -> TyLitQ
numTyLit (Integer -> TyLitQ) -> Integer -> TyLitQ
forall a b. (a -> b) -> a -> b
$ a -> Integer
forall a. Integral a => a -> Integer
toInteger a
n)
    expandVector :: [Int] -> SolidityType -> TypeQ
    expandVector :: [Int] -> SolidityType -> Q Type
expandVector [Int]
ns SolidityType
a = case [Int] -> Maybe (Int, [Int])
forall a. [a] -> Maybe (a, [a])
uncons [Int]
ns of
      Just (Int
n, [Int]
rest) ->
        if [Int] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
rest
          then Name -> Q Type
conT ''ListN Q Type -> Q Type -> Q Type
`appT` Int -> Q Type
forall a. Integral a => a -> Q Type
numLit Int
n Q Type -> Q Type -> Q Type
`appT` SolidityType -> Q Type
toHSType SolidityType
a
          else Name -> Q Type
conT ''ListN Q Type -> Q Type -> Q Type
`appT` Int -> Q Type
forall a. Integral a => a -> Q Type
numLit Int
n Q Type -> Q Type -> Q Type
`appT` [Int] -> SolidityType -> Q Type
expandVector [Int]
rest SolidityType
a
      Maybe (Int, [Int])
_ -> String -> Q Type
forall a. HasCallStack => String -> a
error (String -> Q Type) -> String -> Q Type
forall a b. (a -> b) -> a -> b
$ String
"Impossible Nothing branch in `expandVector`: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Int] -> String
forall a. Show a => a -> String
show [Int]
ns String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SolidityType -> String
forall a. Show a => a -> String
show SolidityType
a

typeFuncQ :: FunctionArg -> TypeQ
typeFuncQ :: FunctionArg -> Q Type
typeFuncQ FunctionArg
t = case FunctionArg -> Either ParseError SolidityType
parseSolidityFunctionArgType FunctionArg
t of
  Left ParseError
e   -> String -> Q Type
forall a. HasCallStack => String -> a
error (String -> Q Type) -> String -> Q Type
forall a b. (a -> b) -> a -> b
$ String
"Unable to parse solidity type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ParseError -> String
forall a. Show a => a -> String
show ParseError
e
  Right SolidityType
ty -> SolidityType -> Q Type
toHSType SolidityType
ty

typeEventQ :: EventArg -> TypeQ
typeEventQ :: EventArg -> Q Type
typeEventQ EventArg
t = case EventArg -> Either ParseError SolidityType
parseSolidityEventArgType EventArg
t of
  Left ParseError
e   -> String -> Q Type
forall a. HasCallStack => String -> a
error (String -> Q Type) -> String -> Q Type
forall a b. (a -> b) -> a -> b
$ String
"Unable to parse solidity type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ParseError -> String
forall a. Show a => a -> String
show ParseError
e
  Right SolidityType
ty -> SolidityType -> Q Type
toHSType SolidityType
ty


-- | Function argument to TH type
funBangType :: FunctionArg -> BangTypeQ
funBangType :: FunctionArg -> BangTypeQ
funBangType FunctionArg
fa =
    BangQ -> Q Type -> BangTypeQ
bangType (SourceUnpackednessQ -> SourceStrictnessQ -> BangQ
bang SourceUnpackednessQ
sourceNoUnpack SourceStrictnessQ
sourceStrict) (FunctionArg -> Q Type
typeFuncQ FunctionArg
fa)

funWrapper :: Bool
           -- ^ Is constant?
           -> Name
           -- ^ Function name
           -> Name
           -- ^ Function data name
           -> [FunctionArg]
           -- ^ Parameters
           -> Maybe [FunctionArg]
           -- ^ Results
           -> DecsQ
funWrapper :: Bool
-> Name -> Name -> [FunctionArg] -> Maybe [FunctionArg] -> Q [Dec]
funWrapper Bool
c Name
name Name
dname [FunctionArg]
args Maybe [FunctionArg]
result = do
    [Name]
vars <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM ([FunctionArg] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [FunctionArg]
args) (String -> Q Name
newName String
"t")
    Q Type
a <- Name -> Q Type
varT (Name -> Q Type) -> Q Name -> Q (Q Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q Name
newName String
"a"
    Q Type
t <- Name -> Q Type
varT (Name -> Q Type) -> Q Name -> Q (Q Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q Name
newName String
"t"
    Q Type
m <- Name -> Q Type
varT (Name -> Q Type) -> Q Name -> Q (Q Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q Name
newName String
"m"


    let params :: Q Exp
params  = [Q Exp] -> Q Exp
appsE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
conE Name
dname Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
: (Name -> Q Exp) -> [Name] -> [Q Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Q Exp
varE [Name]
vars
        inputT :: [Q Type]
inputT  = (FunctionArg -> Q Type) -> [FunctionArg] -> [Q Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FunctionArg -> Q Type
typeFuncQ [FunctionArg]
args
        outputT :: Q Type
outputT = case Maybe [FunctionArg]
result of
            Maybe [FunctionArg]
Nothing  -> [t|$t $m ()|]
            Just [FunctionArg
x] -> [t|$t $m $(typeFuncQ x)|]
            Just [FunctionArg]
xs  -> let outs :: [Q Type]
outs = (FunctionArg -> Q Type) -> [FunctionArg] -> [Q Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FunctionArg -> Q Type
typeFuncQ [FunctionArg]
xs
                         in  [t|$t $m $(foldl appT (tupleT (length xs)) outs)|]

    [DecQ] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [
        Name -> Q Type -> DecQ
sigD Name
name (Q Type -> DecQ) -> Q Type -> DecQ
forall a b. (a -> b) -> a -> b
$ [t|
            (JsonRpc $m, Account $a $t, Functor ($t $m)) =>
                $(arrowing $ inputT ++ [if c then outputT else [t|$t $m TxReceipt|]])
            |]
      , if Bool
c
            then Name -> [Q Pat] -> Q Exp -> DecQ
funD' Name
name (Name -> Q Pat
varP (Name -> Q Pat) -> [Name] -> [Q Pat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
vars) (Q Exp -> DecQ) -> Q Exp -> DecQ
forall a b. (a -> b) -> a -> b
$ case Maybe [FunctionArg]
result of
                    Just [FunctionArg
_] -> [|only <$> call $(params)|]
                    Maybe [FunctionArg]
_        -> [|call $(params)|]
            else Name -> [Q Pat] -> Q Exp -> DecQ
funD' Name
name (Name -> Q Pat
varP (Name -> Q Pat) -> [Name] -> [Q Pat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
vars) (Q Exp -> DecQ) -> Q Exp -> DecQ
forall a b. (a -> b) -> a -> b
$ [|send $(params)|]
      ]
  where
    arrowing :: [Q Type] -> Q Type
arrowing []       = String -> Q Type
forall a. HasCallStack => String -> a
error String
"Impossible branch call"
    arrowing [Q Type
x]      = Q Type
x
    arrowing (Q Type
x : [Q Type]
xs) = [t|$x -> $(arrowing xs)|]

mkDecl :: Declaration -> DecsQ

mkDecl :: Declaration -> Q [Dec]
mkDecl ev :: Declaration
ev@(DEvent Text
uncheckedName [EventArg]
inputs Bool
anonymous) = [DecQ] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
    [ Name -> ConQ -> [Name] -> DecQ
dataD' Name
indexedName (Name -> [BangTypeQ] -> ConQ
normalC Name
indexedName (((Integer, EventArg) -> BangTypeQ)
-> [(Integer, EventArg)] -> [BangTypeQ]
forall a b. (a -> b) -> [a] -> [b]
map (Type -> BangTypeQ
toBang (Type -> BangTypeQ)
-> ((Integer, EventArg) -> Q Type)
-> (Integer, EventArg)
-> BangTypeQ
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< (Integer, EventArg) -> Q Type
tag) [(Integer, EventArg)]
indexedArgs)) [Name]
derivingD
    , Name -> Q Type -> [DecQ] -> DecQ
instanceD' Name
indexedName (Name -> Q Type
conT ''Generic) []
    , Name -> Q Type -> [DecQ] -> DecQ
instanceD' Name
indexedName (Name -> Q Type
conT ''AbiType) [Name -> [Q Pat] -> Q Exp -> DecQ
funD' 'isDynamic [] [|const False|]]
    , Name -> Q Type -> [DecQ] -> DecQ
instanceD' Name
indexedName (Name -> Q Type
conT ''AbiGet) []
    , Name -> ConQ -> [Name] -> DecQ
dataD' Name
nonIndexedName (Name -> [BangTypeQ] -> ConQ
normalC Name
nonIndexedName (((Integer, EventArg) -> BangTypeQ)
-> [(Integer, EventArg)] -> [BangTypeQ]
forall a b. (a -> b) -> [a] -> [b]
map (Type -> BangTypeQ
toBang (Type -> BangTypeQ)
-> ((Integer, EventArg) -> Q Type)
-> (Integer, EventArg)
-> BangTypeQ
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< (Integer, EventArg) -> Q Type
tag) [(Integer, EventArg)]
nonIndexedArgs)) [Name]
derivingD
    , Name -> Q Type -> [DecQ] -> DecQ
instanceD' Name
nonIndexedName (Name -> Q Type
conT ''Generic) []
    , Name -> Q Type -> [DecQ] -> DecQ
instanceD' Name
nonIndexedName (Name -> Q Type
conT ''AbiType) [Name -> [Q Pat] -> Q Exp -> DecQ
funD' 'isDynamic [] [|const False|]]
    , Name -> Q Type -> [DecQ] -> DecQ
instanceD' Name
nonIndexedName (Name -> Q Type
conT ''AbiGet) []
    , Name -> ConQ -> [Name] -> DecQ
dataD' Name
allName (Name -> [VarBangTypeQ] -> ConQ
recC Name
allName (((Name, EventArg) -> VarBangTypeQ)
-> [(Name, EventArg)] -> [VarBangTypeQ]
forall a b. (a -> b) -> [a] -> [b]
map (\(Name
n, EventArg
a) -> (\(Bang
b,Type
t) -> (Name, Bang, Type) -> VarBangTypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
n,Bang
b,Type
t)) ((Bang, Type) -> VarBangTypeQ)
-> (EventArg -> BangTypeQ) -> EventArg -> VarBangTypeQ
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Type -> BangTypeQ
toBang (Type -> BangTypeQ)
-> (EventArg -> Q Type) -> EventArg -> BangTypeQ
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< EventArg -> Q Type
typeEventQ (EventArg -> VarBangTypeQ) -> EventArg -> VarBangTypeQ
forall a b. (a -> b) -> a -> b
$ EventArg
a) [(Name, EventArg)]
allArgs)) [Name]
derivingD
    , Name -> Q Type -> [DecQ] -> DecQ
instanceD' Name
allName (Name -> Q Type
conT ''Generic) []
    , CxtQ -> Q Type -> [DecQ] -> DecQ
instanceD ([Q Type] -> CxtQ
cxt [])
        (Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ Name -> Type
ConT ''IndexedEvent Type -> Type -> Type
`AppT` Name -> Type
ConT Name
indexedName Type -> Type -> Type
`AppT` Name -> Type
ConT Name
nonIndexedName Type -> Type -> Type
`AppT` Name -> Type
ConT Name
allName)
        [Name -> [Q Pat] -> Q Exp -> DecQ
funD' 'isAnonymous [] [|const anonymous|]]
    , CxtQ -> Q Type -> [DecQ] -> DecQ
instanceD ([Q Type] -> CxtQ
cxt [])
        (Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ Name -> Type
ConT ''Default Type -> Type -> Type
`AppT` (Name -> Type
ConT ''Filter Type -> Type -> Type
`AppT` Name -> Type
ConT Name
allName))
        [Name -> [Q Pat] -> Q Exp -> DecQ
funD' 'def [] [|Filter Nothing Latest Latest $ Just topics|] ]
    ]
  where
    name :: Text
name = if Char -> Char
toLower (Text -> Char
T.head Text
uncheckedName) Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char -> Char
Char.toUpper (Text -> Char
T.head Text
uncheckedName) then Text
"EvT" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
uncheckedName else Text
uncheckedName
    topics :: [Maybe String]
topics    = [String -> Maybe String
forall a. a -> Maybe a
Just (Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Declaration -> Text
eventId Declaration
ev)] [Maybe String] -> [Maybe String] -> [Maybe String]
forall a. Semigroup a => a -> a -> a
<> Int -> Maybe String -> [Maybe String]
forall a. Int -> a -> [a]
replicate ([(Integer, EventArg)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Integer, EventArg)]
indexedArgs) Maybe String
forall a. Maybe a
Nothing
    toBang :: Type -> BangTypeQ
toBang Type
ty = BangQ -> Q Type -> BangTypeQ
bangType (SourceUnpackednessQ -> SourceStrictnessQ -> BangQ
bang SourceUnpackednessQ
sourceNoUnpack SourceStrictnessQ
sourceStrict) (Type -> Q Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty)
    tag :: (Integer, EventArg) -> Q Type
tag (Integer
n, EventArg
ty) = Type -> Type -> Type
AppT (Type -> Type -> Type
AppT (Name -> Type
ConT ''Tagged) (TyLit -> Type
LitT (TyLit -> Type) -> TyLit -> Type
forall a b. (a -> b) -> a -> b
$ Integer -> TyLit
NumTyLit Integer
n)) (Type -> Type) -> Q Type -> Q Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EventArg -> Q Type
typeEventQ EventArg
ty
    labeledArgs :: [(Integer, EventArg)]
labeledArgs = [Integer] -> [EventArg] -> [(Integer, EventArg)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Integer
1..] [EventArg]
inputs
    indexedArgs :: [(Integer, EventArg)]
indexedArgs = ((Integer, EventArg) -> (Integer, EventArg))
-> [(Integer, EventArg)] -> [(Integer, EventArg)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Integer
n, EventArg
ea) -> (Integer
n, EventArg
ea)) ([(Integer, EventArg)] -> [(Integer, EventArg)])
-> ([(Integer, EventArg)] -> [(Integer, EventArg)])
-> [(Integer, EventArg)]
-> [(Integer, EventArg)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Integer, EventArg) -> Bool)
-> [(Integer, EventArg)] -> [(Integer, EventArg)]
forall a. (a -> Bool) -> [a] -> [a]
filter (EventArg -> Bool
eveArgIndexed (EventArg -> Bool)
-> ((Integer, EventArg) -> EventArg) -> (Integer, EventArg) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integer, EventArg) -> EventArg
forall a b. (a, b) -> b
snd) ([(Integer, EventArg)] -> [(Integer, EventArg)])
-> [(Integer, EventArg)] -> [(Integer, EventArg)]
forall a b. (a -> b) -> a -> b
$ [(Integer, EventArg)]
labeledArgs
    indexedName :: Name
indexedName = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ ASetter String String Char Char
-> (Char -> Char) -> String -> String
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter String String Char Char
forall s a. Cons s s a a => Traversal' s a
_head Char -> Char
toUpper (Text -> String
T.unpack Text
name) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"Indexed"
    nonIndexedArgs :: [(Integer, EventArg)]
nonIndexedArgs = ((Integer, EventArg) -> (Integer, EventArg))
-> [(Integer, EventArg)] -> [(Integer, EventArg)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Integer
n, EventArg
ea) -> (Integer
n, EventArg
ea)) ([(Integer, EventArg)] -> [(Integer, EventArg)])
-> ([(Integer, EventArg)] -> [(Integer, EventArg)])
-> [(Integer, EventArg)]
-> [(Integer, EventArg)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Integer, EventArg) -> Bool)
-> [(Integer, EventArg)] -> [(Integer, EventArg)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((Integer, EventArg) -> Bool) -> (Integer, EventArg) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EventArg -> Bool
eveArgIndexed (EventArg -> Bool)
-> ((Integer, EventArg) -> EventArg) -> (Integer, EventArg) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integer, EventArg) -> EventArg
forall a b. (a, b) -> b
snd) ([(Integer, EventArg)] -> [(Integer, EventArg)])
-> [(Integer, EventArg)] -> [(Integer, EventArg)]
forall a b. (a -> b) -> a -> b
$ [(Integer, EventArg)]
labeledArgs
    nonIndexedName :: Name
nonIndexedName = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ ASetter String String Char Char
-> (Char -> Char) -> String -> String
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter String String Char Char
forall s a. Cons s s a a => Traversal' s a
_head Char -> Char
toUpper (Text -> String
T.unpack Text
name) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"NonIndexed"
    allArgs :: [(Name, EventArg)]
    allArgs :: [(Name, EventArg)]
allArgs = Text -> [(Text, EventArg)] -> [(Name, EventArg)]
makeArgs Text
name ([(Text, EventArg)] -> [(Name, EventArg)])
-> [(Text, EventArg)] -> [(Name, EventArg)]
forall a b. (a -> b) -> a -> b
$ (EventArg -> (Text, EventArg)) -> [EventArg] -> [(Text, EventArg)]
forall a b. (a -> b) -> [a] -> [b]
map (\EventArg
i -> (EventArg -> Text
eveArgName EventArg
i, EventArg
i)) [EventArg]
inputs
    allName :: Name
allName = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ ASetter String String Char Char
-> (Char -> Char) -> String -> String
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter String String Char Char
forall s a. Cons s s a a => Traversal' s a
_head Char -> Char
toUpper (Text -> String
T.unpack Text
name)
    derivingD :: [Name]
derivingD = [''Show, ''Eq, ''Ord, ''GHC.Generic]

-- TODO change this type name also
-- | Method declarations maker
mkDecl fun :: Declaration
fun@(DFunction Text
name Bool
constant [FunctionArg]
inputs Maybe [FunctionArg]
outputs) = [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
(++)
  ([Dec] -> [Dec] -> [Dec]) -> Q [Dec] -> Q ([Dec] -> [Dec])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool
-> Name -> Name -> [FunctionArg] -> Maybe [FunctionArg] -> Q [Dec]
funWrapper Bool
constant Name
fnName Name
dataName [FunctionArg]
inputs Maybe [FunctionArg]
outputs
  Q ([Dec] -> [Dec]) -> Q [Dec] -> Q [Dec]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [DecQ] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
        [ Name -> ConQ -> [Name] -> DecQ
dataD' Name
dataName (Name -> [BangTypeQ] -> ConQ
normalC Name
dataName [BangTypeQ]
bangInput) [Name]
derivingD
        , Name -> Q Type -> [DecQ] -> DecQ
instanceD' Name
dataName (Name -> Q Type
conT ''Generic) []
        , Name -> Q Type -> [DecQ] -> DecQ
instanceD' Name
dataName (Name -> Q Type
conT ''AbiType)
          [Name -> [Q Pat] -> Q Exp -> DecQ
funD' 'isDynamic [] [|const False|]]
        , Name -> Q Type -> [DecQ] -> DecQ
instanceD' Name
dataName (Name -> Q Type
conT ''AbiPut) []
        , Name -> Q Type -> [DecQ] -> DecQ
instanceD' Name
dataName (Name -> Q Type
conT ''AbiGet) []
        , Name -> Q Type -> [DecQ] -> DecQ
instanceD' Name
dataName (Name -> Q Type
conT ''Method)
          [Name -> [Q Pat] -> Q Exp -> DecQ
funD' 'selector [] [|const mIdent|]]
        ]
  where mIdent :: String
mIdent    = Text -> String
T.unpack (Declaration -> Text
methodId (Declaration -> Text) -> Declaration -> Text
forall a b. (a -> b) -> a -> b
$ Declaration
fun {funName :: Text
funName = Text -> Text -> Text -> Text
T.replace Text
"'" Text
"" Text
name})
        dataName :: Name
dataName  = String -> Name
mkName (ASetter String String Char Char
-> (Char -> Char) -> String -> String
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter String String Char Char
forall s a. Cons s s a a => Traversal' s a
_head Char -> Char
toUpper (Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Text
T.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_') Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"Data"))
        fnName :: Name
fnName    = String -> Name
mkName (ASetter String String Char Char
-> (Char -> Char) -> String -> String
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter String String Char Char
forall s a. Cons s s a a => Traversal' s a
_head Char -> Char
toLower (Text -> String
T.unpack Text
name))
        bangInput :: [BangTypeQ]
bangInput = (FunctionArg -> BangTypeQ) -> [FunctionArg] -> [BangTypeQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FunctionArg -> BangTypeQ
funBangType [FunctionArg]
inputs
        derivingD :: [Name]
derivingD = [''Show, ''Eq, ''Ord, ''GHC.Generic]

mkDecl Declaration
_ = [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return []

mkContractDecl :: Text -> Text -> Text -> Declaration -> DecsQ
mkContractDecl :: Text -> Text -> Text -> Declaration -> Q [Dec]
mkContractDecl Text
name Text
a Text
b (DConstructor [FunctionArg]
inputs) = [DecQ] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
    [ Name -> ConQ -> [Name] -> DecQ
dataD' Name
dataName (Name -> [BangTypeQ] -> ConQ
normalC Name
dataName [BangTypeQ]
bangInput) [Name]
derivingD
    , Name -> Q Type -> [DecQ] -> DecQ
instanceD' Name
dataName (Name -> Q Type
conT ''Generic) []
    , Name -> Q Type -> [DecQ] -> DecQ
instanceD' Name
dataName (Name -> Q Type
conT ''AbiType)
        [Name -> [Q Pat] -> Q Exp -> DecQ
funD' 'isDynamic [] [|const False|]]
    , Name -> Q Type -> [DecQ] -> DecQ
instanceD' Name
dataName (Name -> Q Type
conT ''AbiPut) []
    , Name -> Q Type -> [DecQ] -> DecQ
instanceD' Name
dataName (Name -> Q Type
conT ''Method)
        [Name -> [Q Pat] -> Q Exp -> DecQ
funD' 'selector [] [|convert . Contract.bytecode|]]
    , Name -> Q Type -> [DecQ] -> DecQ
instanceD' Name
dataName (Name -> Q Type
conT ''Contract.Contract)
        [ Name -> [Q Pat] -> Q Exp -> DecQ
funD' 'Contract.abi [] [|const abiString|]
        , Name -> [Q Pat] -> Q Exp -> DecQ
funD' 'Contract.bytecode [] [|const bytecodeString|]
        ]
    ]
  where abiString :: String
abiString = Text -> String
T.unpack Text
a
        bytecodeString :: String
bytecodeString = Text -> String
T.unpack Text
b
        dataName :: Name
dataName = String -> Name
mkName (ASetter String String Char Char
-> (Char -> Char) -> String -> String
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter String String Char Char
forall s a. Cons s s a a => Traversal' s a
_head Char -> Char
toUpper (Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"Contract"))
        bangInput :: [BangTypeQ]
bangInput = (FunctionArg -> BangTypeQ) -> [FunctionArg] -> [BangTypeQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FunctionArg -> BangTypeQ
funBangType [FunctionArg]
inputs
        derivingD :: [Name]
derivingD = [''Show, ''Eq, ''Ord, ''GHC.Generic]

mkContractDecl Text
_ Text
_ Text
_ Declaration
_ = [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return []

-- | this function gives appropriate names for the accessors in the following way
-- | argName -> evArgName
-- | arg_name -> evArg_name
-- | _argName -> evArgName
-- | "" -> evi , for example Transfer(address, address uint256) ~> Transfer {transfer1 :: address, transfer2 :: address, transfer3 :: Integer}
makeArgs :: Text -> [(Text, EventArg)] -> [(Name, EventArg)]
makeArgs :: Text -> [(Text, EventArg)] -> [(Name, EventArg)]
makeArgs Text
prefix [(Text, EventArg)]
ns = Int -> [(Text, EventArg)] -> [(Name, EventArg)]
go Int
1 [(Text, EventArg)]
ns
  where
    prefixStr :: String
prefixStr = ASetter String String Char Char
-> (Char -> Char) -> String -> String
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter String String Char Char
forall s a. Cons s s a a => Traversal' s a
_head Char -> Char
toLower (String -> String) -> (Text -> String) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text
prefix
    go :: Int -> [(Text, EventArg)] -> [(Name, EventArg)]
    go :: Int -> [(Text, EventArg)] -> [(Name, EventArg)]
go Int
_ [] = []
    go Int
i ((Text
h, EventArg
ty) : [(Text, EventArg)]
tail')
        | Text -> Bool
T.null Text
h  = (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
prefixStr String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i, EventArg
ty) (Name, EventArg) -> [(Name, EventArg)] -> [(Name, EventArg)]
forall a. a -> [a] -> [a]
: Int -> [(Text, EventArg)] -> [(Name, EventArg)]
go (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [(Text, EventArg)]
tail'
        | Bool
otherwise = (String -> Name
mkName (String -> Name) -> (Text -> String) -> Text -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_") (String -> String) -> (Text -> String) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
forall a. [a] -> [a] -> [a]
(++) String
prefixStr (String -> String) -> (Text -> String) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASetter String String Char Char
-> (Char -> Char) -> String -> String
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter String String Char Char
forall s a. Cons s s a a => Traversal' s a
_head Char -> Char
toUpper (String -> String) -> (Text -> String) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> Name) -> Text -> Name
forall a b. (a -> b) -> a -> b
$ Text
h, EventArg
ty) (Name, EventArg) -> [(Name, EventArg)] -> [(Name, EventArg)]
forall a. a -> [a] -> [a]
: Int -> [(Text, EventArg)] -> [(Name, EventArg)]
go (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [(Text, EventArg)]
tail'

escape :: [Declaration] -> [Declaration]
escape :: [Declaration] -> [Declaration]
escape = [Declaration] -> [Declaration]
escapeEqualNames ([Declaration] -> [Declaration])
-> ([Declaration] -> [Declaration])
-> [Declaration]
-> [Declaration]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Declaration -> Declaration) -> [Declaration] -> [Declaration]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Declaration -> Declaration
escapeReservedNames

escapeEqualNames :: [Declaration] -> [Declaration]
escapeEqualNames :: [Declaration] -> [Declaration]
escapeEqualNames = ([Declaration] -> [Declaration])
-> [[Declaration]] -> [Declaration]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [Declaration] -> [Declaration]
go ([[Declaration]] -> [Declaration])
-> ([Declaration] -> [[Declaration]])
-> [Declaration]
-> [Declaration]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Declaration] -> [[Declaration]]
forall a. Eq a => [a] -> [[a]]
group ([Declaration] -> [[Declaration]])
-> ([Declaration] -> [Declaration])
-> [Declaration]
-> [[Declaration]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Declaration] -> [Declaration]
forall a. Ord a => [a] -> [a]
sort
  where go :: [Declaration] -> [Declaration]
go []       = []
        go (Declaration
x : [Declaration]
xs) = Declaration
x Declaration -> [Declaration] -> [Declaration]
forall a. a -> [a] -> [a]
: (Declaration -> Text -> Declaration)
-> [Declaration] -> [Text] -> [Declaration]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Declaration -> Text -> Declaration
appendToName [Declaration]
xs [Text]
hats
        hats :: [Text]
hats = [Int -> Text -> Text
T.replicate Int
n Text
"'" | Int
n <- [Int
1..]]
        appendToName :: Declaration -> Text -> Declaration
appendToName d :: Declaration
d@(DFunction Text
n Bool
_ [FunctionArg]
_ Maybe [FunctionArg]
_) Text
a = Declaration
d { funName :: Text
funName = Text
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
a }
        appendToName d :: Declaration
d@(DEvent Text
n [EventArg]
_ Bool
_) Text
a      = Declaration
d { eveName :: Text
eveName = Text
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
a }
        appendToName Declaration
d Text
_                     = Declaration
d

escapeReservedNames :: Declaration -> Declaration
escapeReservedNames :: Declaration -> Declaration
escapeReservedNames d :: Declaration
d@(DFunction Text
n Bool
_ [FunctionArg]
_ Maybe [FunctionArg]
_)
  | Text -> Bool
isKeyword Text
n = Declaration
d { funName :: Text
funName = Text
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'" }
  | Bool
otherwise = Declaration
d
escapeReservedNames Declaration
d = Declaration
d

isKeyword :: Text -> Bool
isKeyword :: Text -> Bool
isKeyword = (Text -> [Text] -> Bool) -> [Text] -> Text -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem [ Text
"as", Text
"case", Text
"of", Text
"class"
                      , Text
"data", Text
"family", Text
"instance"
                      , Text
"default", Text
"deriving", Text
"do"
                      , Text
"forall", Text
"foreign", Text
"hiding"
                      , Text
"if", Text
"then", Text
"else", Text
"import"
                      , Text
"infix", Text
"infixl", Text
"infixr"
                      , Text
"let", Text
"in", Text
"mdo", Text
"module"
                      , Text
"newtype", Text
"proc", Text
"qualified"
                      , Text
"rec", Text
"type", Text
"where"
                      ]

constructorSpec :: String -> Maybe (Text, Text, Text, Declaration)
constructorSpec :: String -> Maybe (Text, Text, Text, Declaration)
constructorSpec String
str = do
    Text
name     <- String
str String -> Getting (First Text) String Text -> Maybe Text
forall s a. s -> Getting (First a) s a -> Maybe a
^? Text -> Traversal' String Value
forall t. AsValue t => Text -> Traversal' t Value
key Text
"contractName" ((Value -> Const (First Text) Value)
 -> String -> Const (First Text) String)
-> ((Text -> Const (First Text) Text)
    -> Value -> Const (First Text) Value)
-> Getting (First Text) String Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Const (First Text) Text)
-> Value -> Const (First Text) Value
forall t. AsPrimitive t => Traversal' t Text
_String
    Value
abiValue <- String
str String -> Getting (First Value) String Value -> Maybe Value
forall s a. s -> Getting (First a) s a -> Maybe a
^? Text -> Traversal' String Value
forall t. AsValue t => Text -> Traversal' t Value
key Text
"abi"
    Text
bytecode <- String
str String -> Getting (First Text) String Text -> Maybe Text
forall s a. s -> Getting (First a) s a -> Maybe a
^? Text -> Traversal' String Value
forall t. AsValue t => Text -> Traversal' t Value
key Text
"bytecode" ((Value -> Const (First Text) Value)
 -> String -> Const (First Text) String)
-> ((Text -> Const (First Text) Text)
    -> Value -> Const (First Text) Value)
-> Getting (First Text) String Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Const (First Text) Text)
-> Value -> Const (First Text) Value
forall t. AsPrimitive t => Traversal' t Text
_String
    [Declaration]
decl     <- (Declaration -> Bool) -> [Declaration] -> [Declaration]
forall a. (a -> Bool) -> [a] -> [a]
filter Declaration -> Bool
isContructor ([Declaration] -> [Declaration])
-> (ContractAbi -> [Declaration]) -> ContractAbi -> [Declaration]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContractAbi -> [Declaration]
unAbi (ContractAbi -> [Declaration])
-> Maybe ContractAbi -> Maybe [Declaration]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
str String
-> Getting (First ContractAbi) String ContractAbi
-> Maybe ContractAbi
forall s a. s -> Getting (First a) s a -> Maybe a
^? Text -> Traversal' String Value
forall t. AsValue t => Text -> Traversal' t Value
key Text
"abi" ((Value -> Const (First ContractAbi) Value)
 -> String -> Const (First ContractAbi) String)
-> ((ContractAbi -> Const (First ContractAbi) ContractAbi)
    -> Value -> Const (First ContractAbi) Value)
-> Getting (First ContractAbi) String ContractAbi
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ContractAbi -> Const (First ContractAbi) ContractAbi)
-> Value -> Const (First ContractAbi) Value
forall t a. (AsJSON t, FromJSON a, ToJSON a) => Traversal' t a
_JSON
    (Text, Text, Text, Declaration)
-> Maybe (Text, Text, Text, Declaration)
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
name, Value -> Text
jsonEncode Value
abiValue, Text
bytecode, [Declaration] -> Declaration
toConstructor [Declaration]
decl)
  where
    jsonEncode :: Value -> Text
jsonEncode = Text -> Text
LT.toStrict (Text -> Text) -> (Value -> Text) -> Value -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
LT.decodeUtf8 (ByteString -> Text) -> (Value -> ByteString) -> Value -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode
    isContructor :: Declaration -> Bool
isContructor (DConstructor [FunctionArg]
_) = Bool
True
    isContructor Declaration
_                = Bool
False
    toConstructor :: [Declaration] -> Declaration
toConstructor []  = [FunctionArg] -> Declaration
DConstructor []
    toConstructor [Declaration
a] = Declaration
a
    toConstructor [Declaration]
_   = String -> Declaration
forall a. HasCallStack => String -> a
error String
"Broken ABI: more that one constructor"

-- | Abi to declarations converter
quoteAbiDec :: String -> DecsQ
quoteAbiDec :: String -> Q [Dec]
quoteAbiDec String
str =
    case String
str String
-> Getting (First ContractAbi) String ContractAbi
-> Maybe ContractAbi
forall s a. s -> Getting (First a) s a -> Maybe a
^? Getting (First ContractAbi) String ContractAbi
forall t a. (AsJSON t, FromJSON a, ToJSON a) => Traversal' t a
_JSON Maybe ContractAbi -> Maybe ContractAbi -> Maybe ContractAbi
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String
str String
-> Getting (First ContractAbi) String ContractAbi
-> Maybe ContractAbi
forall s a. s -> Getting (First a) s a -> Maybe a
^? Text -> Traversal' String Value
forall t. AsValue t => Text -> Traversal' t Value
key Text
"abi" ((Value -> Const (First ContractAbi) Value)
 -> String -> Const (First ContractAbi) String)
-> ((ContractAbi -> Const (First ContractAbi) ContractAbi)
    -> Value -> Const (First ContractAbi) Value)
-> Getting (First ContractAbi) String ContractAbi
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ContractAbi -> Const (First ContractAbi) ContractAbi)
-> Value -> Const (First ContractAbi) Value
forall t a. (AsJSON t, FromJSON a, ToJSON a) => Traversal' t a
_JSON Maybe ContractAbi -> Maybe ContractAbi -> Maybe ContractAbi
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String
str String
-> Getting (First ContractAbi) String ContractAbi
-> Maybe ContractAbi
forall s a. s -> Getting (First a) s a -> Maybe a
^? Text -> Traversal' String Value
forall t. AsValue t => Text -> Traversal' t Value
key Text
"compilerOutput" ((Value -> Const (First ContractAbi) Value)
 -> String -> Const (First ContractAbi) String)
-> ((ContractAbi -> Const (First ContractAbi) ContractAbi)
    -> Value -> Const (First ContractAbi) Value)
-> Getting (First ContractAbi) String ContractAbi
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Traversal' Value Value
forall t. AsValue t => Text -> Traversal' t Value
key Text
"abi" ((Value -> Const (First ContractAbi) Value)
 -> Value -> Const (First ContractAbi) Value)
-> ((ContractAbi -> Const (First ContractAbi) ContractAbi)
    -> Value -> Const (First ContractAbi) Value)
-> (ContractAbi -> Const (First ContractAbi) ContractAbi)
-> Value
-> Const (First ContractAbi) Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ContractAbi -> Const (First ContractAbi) ContractAbi)
-> Value -> Const (First ContractAbi) Value
forall t a. (AsJSON t, FromJSON a, ToJSON a) => Traversal' t a
_JSON of
        Maybe ContractAbi
Nothing                 -> String -> Q [Dec]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unable to decode contract ABI"
        Just (ContractAbi [Declaration]
decs) -> do
            [Dec]
funEvDecs <- [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Declaration -> Q [Dec]) -> [Declaration] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Declaration -> Q [Dec]
mkDecl ([Declaration] -> [Declaration]
escape [Declaration]
decs)
            case String -> Maybe (Text, Text, Text, Declaration)
constructorSpec String
str of
                Maybe (Text, Text, Text, Declaration)
Nothing -> [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return [Dec]
funEvDecs
                Just (Text
a, Text
b, Text
c, Declaration
d) -> ([Dec]
funEvDecs [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++) ([Dec] -> [Dec]) -> Q [Dec] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Text -> Text -> Declaration -> Q [Dec]
mkContractDecl Text
a Text
b Text
c Declaration
d

-- | Abi information string
quoteAbiExp :: String -> ExpQ
quoteAbiExp :: String -> Q Exp
quoteAbiExp String
str =
    case String
str String
-> Getting (First ContractAbi) String ContractAbi
-> Maybe ContractAbi
forall s a. s -> Getting (First a) s a -> Maybe a
^? Getting (First ContractAbi) String ContractAbi
forall t a. (AsJSON t, FromJSON a, ToJSON a) => Traversal' t a
_JSON Maybe ContractAbi -> Maybe ContractAbi -> Maybe ContractAbi
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String
str String
-> Getting (First ContractAbi) String ContractAbi
-> Maybe ContractAbi
forall s a. s -> Getting (First a) s a -> Maybe a
^? Text -> Traversal' String Value
forall t. AsValue t => Text -> Traversal' t Value
key Text
"abi" ((Value -> Const (First ContractAbi) Value)
 -> String -> Const (First ContractAbi) String)
-> ((ContractAbi -> Const (First ContractAbi) ContractAbi)
    -> Value -> Const (First ContractAbi) Value)
-> Getting (First ContractAbi) String ContractAbi
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ContractAbi -> Const (First ContractAbi) ContractAbi)
-> Value -> Const (First ContractAbi) Value
forall t a. (AsJSON t, FromJSON a, ToJSON a) => Traversal' t a
_JSON of
        Maybe ContractAbi
Nothing                -> String -> Q Exp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unable to decode contract ABI"
        Just a :: ContractAbi
a@(ContractAbi [Declaration]
_) -> String -> Q Exp
stringE (ContractAbi -> String
forall a. Show a => a -> String
show ContractAbi
a)