TH.hs

{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes     #-}
{-# LANGUAGE CPP             #-}
-- |
-- Module      :  Network.Ethereum.Web3.TH
-- Copyright   :  Alexander Krupenkin 2016
-- License     :  BSD3
--
-- Maintainer  :  mail@akru.me
-- Stability   :  experimental
-- Portability :  unportable
--
-- TemplateHaskell based Ethereum contract ABI
-- methods & event generator for Haskell native API.
--
-- @
-- [abiFrom|data/sample.json|]
--
-- main = do
--     runWeb3 $ event "0x..." $
--        \(Action2 n x) -> liftIO $ do print n
--                                      print x
--     wait
--   where wait = threadDelay 1000000 >> wait
-- @
--
module Network.Ethereum.Web3.TH (
  -- ** Quasiquoter's
    abi
  , abiFrom
  -- ** Used by TH data types
  , Bytes
  , Text
  , Singleton(..)
  , ABIEncoding(..)
  ) where

import qualified Data.Text.Lazy.Encoding as LT
import qualified Data.Text.Lazy.Builder  as B
import qualified Data.Text.Lazy          as LT
import qualified Data.Attoparsec.Text    as P
import qualified Data.Text               as T

import Network.Ethereum.Web3.Address (Address)
import Network.Ethereum.Web3.Encoding.Tuple
import Network.Ethereum.Web3.Encoding
import Network.Ethereum.Web3.Provider
import Network.Ethereum.Web3.Internal
import Network.Ethereum.Web3.Contract
import Network.Ethereum.Web3.JsonAbi
import Network.Ethereum.Web3.Types
import Network.Ethereum.Unit

import Control.Monad (replicateM)

import Data.Text (Text, isPrefixOf)
import Data.List (groupBy, sortBy)
import Data.Monoid (mconcat, (<>))
import Data.ByteArray (Bytes)
import Data.Aeson

import Language.Haskell.TH.Quote
import Language.Haskell.TH.Lib
import Language.Haskell.TH

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

-- | QQ reader for contract ABI
abi :: QuasiQuoter
abi = QuasiQuoter
  { quoteDec  = quoteAbiDec
  , quoteExp  = quoteAbiExp
  , quotePat  = undefined
  , quoteType = undefined
  }

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

-- | Simple data type declaration with one constructor
dataD' :: Name -> ConQ -> [Name] -> DecQ
dataD' name rec derive =
#if MIN_VERSION_template_haskell(2,12,0)
    dataD (cxt []) name [] Nothing [rec] [derivClause Nothing (conT <$> derive)]
#else
    dataD (cxt []) name [] Nothing [rec] $ cxt (conT <$> derive)
#endif

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

-- | ABI and Haskell types association
typeQ :: Text -> TypeQ
typeQ typ | T.any (== '[') typ = appT listT (go (T.takeWhile (/= '[') typ))
          | otherwise          = go typ
  where go x | "string"  == x         = conT (mkName "Text")
             | "address" == x         = conT (mkName "Address")
             | "bytes"   == x         = conT (mkName "BytesD")
             | "bool"    == x         = conT (mkName "Bool")
             | "bytes" `isPrefixOf` x = appT (conT (mkName "BytesN"))
                                             (numLit (T.drop 5 x))
             | "int"   `isPrefixOf` x = conT (mkName "Integer")
             | "uint"  `isPrefixOf` x = conT (mkName "Integer")
             | otherwise = fail ("Unknown type: " ++ T.unpack x)
        numLit n = litT (numTyLit (read (T.unpack n)))

-- | Event argument to TH type
eventBangType :: EventArg -> BangTypeQ
eventBangType (EventArg _ typ _) =
    bangType (bang sourceNoUnpack sourceStrict) (typeQ typ)

-- | Function argument to TH type
funBangType :: FunctionArg -> BangTypeQ
funBangType (FunctionArg _ typ) =
    bangType (bang sourceNoUnpack sourceStrict) (typeQ typ)

-- | Solidity dynamic type predicate
isDynType :: Text -> Bool
isDynType "bytes"  = True
isDynType "string" = True
isDynType x | T.any (== '[') x = True
            | otherwise        = False

eventEncodigD :: Name -> [EventArg] -> [DecQ]
eventEncodigD eventName args =
    [ funD' (mkName "toDataBuilder")  []
        [|error "Event to data conversion isn't available!"|]
    , funD' (mkName "fromDataParser") [] fromDataP ]
  where
    indexed = map eveArgIndexed args
    newVars = replicateM (length args) (newName "t")

    parseArg v = bindS (varP v) [|fromDataParser|]

    parseData []   = []
    parseData [v]  = pure $ bindS (varP v) [|unSingleton <$> fromDataParser|]
    parseData vars = pure $ bindS (tupP (varP <$> vars)) [|fromDataParser|]

    fromDataP = do
        vars <- zip indexed <$> newVars
        let ixVars   = [v | (isIndexed, v) <- vars, isIndexed]
            noIxVars = [v | (isIndexed, v) <- vars, not isIndexed]
            expVars  = [varE v | (_, v) <- vars]
        doE $ fmap parseArg ixVars
           ++ parseData noIxVars
           ++ [noBindS [|return $(appsE (conE eventName : expVars))|]]

funEncodigD :: Name -> Int -> String -> [DecQ]
funEncodigD funName paramLen ident =
    [ funDtoDataB
    , funD' (mkName "fromDataParser") []
        [|error "Function from data conversion isn't available!"|] ]
  where
    newVars = replicateM paramLen (newName "t")
    sVar    = mkName "a"
    funDtoDataB
        | paramLen == 0 = funD' (mkName "toDataBuilder") [conP funName []] [|ident|]
        | paramLen == 1 = funD' (mkName "toDataBuilder")
                            [conP funName [varP sVar]]
                                [|ident <> toDataBuilder (Singleton $(varE sVar))|]
        | otherwise = do
            vars <- newVars
            funD' (mkName "toDataBuilder")
              [conP funName $ fmap varP vars]
              [|ident <> toDataBuilder $(tupE $ fmap varE vars)|]

eventFilterD :: String -> [DecQ]
eventFilterD topic0 = let addr = mkName "a" in
  [ funD' (mkName "eventFilter") [wildP, varP addr]
    [|Filter (Just $(varE addr))
             (Just [Just topic0, Nothing])
             Nothing
             Nothing
     |]
  ]

funWrapper :: Bool
           -- ^ Is constant?
           -> Name
           -- ^ Function name
           -> Name
           -- ^ Function data name
           -> [FunctionArg]
           -- ^ Parameters
           -> Maybe [FunctionArg]
           -- ^ Results
           -> Q [Dec]
funWrapper c name dname args result = do
    a : b : vars <- replicateM (length args + 2) (newName "t")
    let params = appsE $ conE dname : fmap varE vars

    sequence $ if c
        then
          [ sigD name $ [t|Provider $p =>
                            $(arrowing $ [t|Address|] : inputT ++ [outputT])
                          |]
          , funD' name (varP <$> a : vars) $
              case result of
                Just [_] -> [|unSingleton <$> call $(varE a) Latest $(params)|]
                _        -> [|call $(varE a) Latest $(params)|]
          ]

        else
          [ sigD name $ [t|(Provider $p, Unit $(varT b)) =>
                            $(arrowing $ [t|Address|] : varT b : inputT ++ [[t|Web3 $p TxHash|]])
                          |]
          , funD' name (varP <$> a : b : vars) $
                [|sendTx $(varE a) $(varE b) $(params)|] ]
  where
    p = varT (mkName "p")
    arrowing [x] = x
    arrowing (x : xs) = [t|$x -> $(arrowing xs)|]
    inputT  = fmap (typeQ . funArgType) args
    outputT = case result of
        Nothing  -> [t|Web3 $p ()|]
        Just [x] -> [t|Web3 $p $(typeQ $ funArgType x)|]
        Just xs  -> let outs = fmap (typeQ . funArgType) xs
                    in  [t|Web3 $p $(foldl appT (tupleT (length xs)) outs)|]

-- | Event declarations maker
mkEvent :: Declaration -> Q [Dec]
mkEvent eve@(DEvent name inputs _) = sequence
    [ dataD' eventName eventFields derivingD
    , instanceD' eventName encodingT (eventEncodigD eventName inputs)
    , instanceD' eventName eventT    (eventFilterD (T.unpack $ eventId eve))
    ]
  where eventName   = mkName (toUpperFirst (T.unpack name))
        derivingD   = [mkName "Show", mkName "Eq", mkName "Ord"]
        eventFields = normalC eventName (eventBangType <$> inputs)
        encodingT   = conT (mkName "ABIEncoding")
        eventT      = conT (mkName "Event")

-- | Method delcarations maker
mkFun :: Declaration -> Q [Dec]
mkFun fun@(DFunction name constant inputs outputs) = (++)
  <$> funWrapper constant funName dataName inputs outputs
  <*> sequence
        [ dataD' dataName (normalC dataName bangInput) derivingD
        , instanceD' dataName encodingT
            (funEncodigD dataName (length inputs) mIdent)
        , instanceD' dataName methodT [] ]
  where mIdent    = T.unpack (methodId $ fun{funName = T.replace "'" "" name})
        dataName  = mkName (toUpperFirst (T.unpack $ name <> "Data"))
        funName   = mkName (toLowerFirst (T.unpack name))
        bangInput = fmap funBangType inputs
        derivingD = [mkName "Show", mkName "Eq", mkName "Ord"]
        encodingT = conT (mkName "ABIEncoding")
        methodT   = conT (mkName "Method")

escape :: [Declaration] -> [Declaration]
escape = concat . escapeNames . groupBy fnEq . sortBy fnCompare
  where fnEq (DFunction n1 _ _ _) (DFunction n2 _ _ _) = n1 == n2
        fnEq _ _ = False
        fnCompare (DFunction n1 _ _ _) (DFunction n2 _ _ _) = compare n1 n2
        fnCompare _ _ = GT

escapeNames :: [[Declaration]] -> [[Declaration]]
escapeNames = fmap go
  where go (x : xs) = x : zipWith appendToName xs hats
        hats = [T.replicate n "'" | n <- [1..]]
        appendToName dfn addition = dfn { funName = funName dfn <> addition }

-- | Declaration parser
mkDecl :: Declaration -> Q [Dec]
mkDecl x@DFunction{} = mkFun x
mkDecl x@DEvent{}    = mkEvent x
mkDecl _ = return []

-- | ABI to declarations converter
quoteAbiDec :: String -> Q [Dec]
quoteAbiDec abi_string =
    case decode abi_lbs of
        Just (ContractABI abi) -> concat <$> mapM mkDecl (escape abi)
        _ -> fail "Unable to parse ABI!"
  where abi_lbs = LT.encodeUtf8 (LT.pack abi_string)

-- | ABI information string
quoteAbiExp :: String -> ExpQ
quoteAbiExp abi_string = stringE $
    case eitherDecode abi_lbs of
        Left e    -> "Error: " ++ show e
        Right abi -> show (abi :: ContractABI)
  where abi_lbs = LT.encodeUtf8 (LT.pack abi_string)