lorentz-0.14.0: src/Lorentz/Util/TH.hs
-- SPDX-FileCopyrightText: 2021 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA
-- | Lorentz template-haskell and quasiquote utilities.
module Lorentz.Util.TH
( entrypointDoc
, errorDoc
, errorDocArg
, typeDoc
) where
import Prelude hiding (lift)
import Data.Text (strip, stripPrefix, stripSuffix)
import Language.Haskell.TH (Dec, Q, TypeQ, appT, conT, litE, litT, mkName, strTyLit, stringL)
import Language.Haskell.TH.Quote (QuasiQuoter(..))
import Language.Haskell.TH.Syntax (lift)
import Text.ParserCombinators.ReadP (choice, readP_to_S, skipSpaces, string)
import Text.Read.Lex (Lexeme(..), lex)
import Lorentz.Doc
import Lorentz.Entrypoints
import Lorentz.Errors
-- | QuasiQuote that helps generating @ParameterHasEntrypoints@ instance.
--
-- Usage:
--
-- @
-- [entrypointDoc| Parameter \<parameter-type> \<optional-root-annotation> |]
-- [entrypointDoc| Parameter plain |]
-- [entrypointDoc| Parameter plain "root"|]
-- @
--
-- See this [tutorial](https://indigo-lang.gitlab.io/contract-docs/) which
-- includes this quasiquote.
--
entrypointDoc :: QuasiQuoter
entrypointDoc = QuasiQuoter
{ quoteExp = const $ failQQType qqName "expression"
, quotePat = const $ failQQType qqName "pattern"
, quoteType = const $ failQQType qqName "type"
, quoteDec = go
}
where
qqName = "entrypointDoc"
go :: String -> Q [Dec]
go input =
let
mkEpdWithRoot :: Text -> Text -> TypeQ
mkEpdWithRoot epd r =
appT (appT (conT $ mkName "EpdWithRoot") (litT $ strTyLit $ toString $ stripQuote r))
(conT $ mkName (toString epd))
extract :: [Text] -> Either Text (Text, TypeQ)
extract a =
case a of
[x, "plain"] -> Right (x, conT $ mkName $ "EpdPlain")
[x, "delegate"] -> Right (x, conT $ mkName $ "EpdDelegate")
[x, "recursive"] -> Right (x, conT $ mkName $ "EpdRecursive")
[x, "none"] -> Right (x, conT $ mkName $ "EpdNone")
[x, "plain", r] -> Right (x, mkEpdWithRoot "EpdPlain" r)
[x, "delegate", r] -> Right (x, mkEpdWithRoot "EpdDelegate" r)
[x, "recursive", r] -> Right (x, mkEpdWithRoot "EpdRecursive" r)
i -> Left $ unlines
[ "Invalid arguments."
, " Expected arguments to be in the format of:"
, " - [" <> qqName <> "| Parameter <parameter-type> <optional-root-annotation> |]"
, " Examples:"
, " - [" <> qqName <> "| Parameter plain |]"
, " - [" <> qqName <> "| Parameter recursive |]"
, " - [" <> qqName <> "| Parameter plain \"root\" |]"
, " But instead got: " <> unwords i
]
in case extract $ words $ toText input of
Right (param, paramValue) -> [d|
instance ParameterHasEntrypoints $(conT $ mkName $ toString param) where
type ParameterEntrypointsDerivation $(conT $ mkName $ toString param) = $(paramValue)
|]
Left err -> failQQ qqName err
-- | QuasiQuote that helps generating @CustomErrorHasDoc@ instance.
--
-- Usage:
--
-- @
-- [errorDoc| \<error-name> \<error-type> \<error-description> |]
-- [errorDoc| "errorName" exception "Error description" |]
-- @
--
-- This is equivalent to 'errorDocArg' with @()@ specified as error argument type.
--
errorDoc :: QuasiQuoter
errorDoc = QuasiQuoter
{ quoteExp = const $ failQQType qqName "expression"
, quotePat = const $ failQQType qqName "pattern"
, quoteType = const $ failQQType qqName "type"
, quoteDec = quoteDec errorDocArg . (<> " ()")
}
where
qqName = "errorDoc"
{-# DEPRECATED errorDoc "errorDoc is deprecated, use errorDocArg with () argument instead" #-}
-- | QuasiQuote that helps generating @CustomErrorHasDoc@ instance.
--
-- Usage:
--
-- @
-- [errorDocArg| \<error-name> \<error-type> \<error-description> [\<error-arg-type>] |]
-- [errorDocArg| "errorName" exception "Error description" |]
-- [errorDocArg| "errorName" contract-internal "Error description" () |]
-- [errorDocArg| "errorName" bad-argument "Error description" Integer |]
-- @
--
-- The default argument type is 'NoErrorArg'. Only a type name can be used,
-- if you need complex type, define a type synonym.
--
-- See this [tutorial](https://indigo-lang.gitlab.io/contract-docs/) which
-- includes this quasiquote.
--
errorDocArg :: QuasiQuoter
errorDocArg = QuasiQuoter
{ quoteExp = const $ failQQType qqName "expression"
, quotePat = const $ failQQType qqName "pattern"
, quoteType = const $ failQQType qqName "type"
, quoteDec = go
}
where
qqName = "errorDocArg"
errMsg i = unlines
[ "Invalid arguments."
, " Expected arguments to be in the format of:"
, " - [" <> qqName <> "| <error-name> <error-type> <error-description> [<error-argument>] |]"
, " Examples:"
, " - [" <> qqName <> "| \"errorName\" exception \"Error description\" |]"
, " - [" <> qqName <> "| \"myError\" bad-argument \"An error happened\" () |]"
, " But instead got: " <> fromString i
]
go :: String -> Q [Dec]
go input =
let
parser = do
skipSpaces
String errorName <- lex
skipSpaces
errorClass <- choice
[ string "exception" $> ErrClassActionException
, string "bad-argument" $> ErrClassBadArgument
, string "contract-internal" $> ErrClassContractInternal
, string "unknown" $> ErrClassUnknown
]
skipSpaces
String errorDesc <- lex
skipSpaces
pure (errorName, errorClass, errorDesc)
extract :: String -> Either Text ((String, ErrorClass, String), String)
extract i = readP_to_S parser i & \case
[(res, type_)] -> Right (res, toString . strip $ fromString type_)
_ -> Left $ errMsg i
in case extract input of
Right ((errorName, errorClassVal, errorDesc), errorArg) -> do
let errorArgType = case errorArg of
[] -> [t|NoErrorArg|]
_ -> conT $ mkName errorArg
[d|
type instance ErrorArg $(litT . strTyLit $ toString $ errorName) = $errorArgType
instance CustomErrorHasDoc $(litT . strTyLit $ toString $ errorName) where
customErrClass = $(lift errorClassVal)
customErrDocMdCause = $(litE $ stringL $ toString $ errorDesc)
|]
Left err -> failQQ qqName err
-- | QuasiQuote that helps generating @TypeHasDoc@ instance.
--
-- Usage:
--
-- @
-- [typeDoc| \<type> \<description> |]
-- [typeDoc| Storage "This is storage description" |]
-- @
--
-- See this [tutorial](https://indigo-lang.gitlab.io/contract-docs/) which
-- includes this quasiquote.
--
typeDoc :: QuasiQuoter
typeDoc = QuasiQuoter
{ quoteExp = const $ failQQType qqName "expression"
, quotePat = const $ failQQType qqName "pattern"
, quoteType = const $ failQQType qqName "type"
, quoteDec = go
}
where
qqName = "typeDoc"
go :: String -> Q [Dec]
go input =
case words $ toText $ input of
(param:value) ->
[d|
instance TypeHasDoc $(conT $ mkName $ toString $ param) where
typeDocMdDescription = $(litE $ stringL $ toString $ stripQuote $ unwords value)
|]
i ->
failQQ qqName $ unlines
[ "Invalid arguments."
, " Expected arguments to be in the format of:"
, " - [" <> qqName <> "| <type> <description> |]"
, " Example:"
, " - [" <> qqName <> "| Storage \"This is storage description\" |]"
, " But instead got: " <> unwords i
]
--------------------------------------------------
-- Helper
--------------------------------------------------
failQQ :: MonadFail m => Text -> Text -> m a
failQQ qq errTxt =
fail $ "Lorentz.Util.TH." <> toString (qq <> ": " <> errTxt)
failQQType :: MonadFail m => Text -> Text -> m a
failQQType qq typeTxt = failQQ qq $ "This QuasiQuoter cannot be used as a " <> typeTxt
stripQuote :: Text -> Text
stripQuote txt =
let
h = stripPrefix "\"" txt ?: txt
g = stripSuffix "\"" h ?: h
in g