TH.hs

-- SPDX-FileCopyrightText: 2021 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA

-- | Lorentz template-haskell and quasiquote utilities.
module Lorentz.Util.TH
  ( entrypointDoc
  , errorDocArg
  , typeDoc
  ) where

import Prelude

import Data.Char (isSpace)
import Language.Haskell.TH (Dec, Q, conE, conT, litE, litT, mkName, strTyLit, stringL, varE)
import Language.Haskell.TH.Quote (QuasiQuoter(..))
import Text.ParserCombinators.ReadP (ReadP, choice, eof, munch1, 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> [\<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 = mkParserQQ "entrypointDoc"
  "Parameter <parameter-type> [<root-annotation>]"
  [ "Parameter plain"
  , "Parameter recursive"
  , "Parameter plain \"root\""
  ] do
    skipSpaces
    typeName <- conT . mkName <$> hsIdent
    skipSpaces
    paramType <- conT <$> choice
      [ string "plain"     $> ''EpdPlain
      , string "delegate"  $> ''EpdDelegate
      , string "recursive" $> ''EpdRecursive
      , string "none"      $> ''EpdNone
      ]
    skipSpaces
    mbRootAnn <- optional $ litT . strTyLit <$> hsString
    skipSpaces
    eof
    let epd = maybe paramType (\ann -> [t|EpdWithRoot $ann $paramType|]) mbRootAnn
    pure $ [d|
      instance ParameterHasEntrypoints $typeName where
        type ParameterEntrypointsDerivation $typeName = $epd
      |]

-- | 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 = mkParserQQ "errorDocArg"
  "<error-name> <error-type> <error-description> [<error-arg-type>]"
  [ "\"errorName\" exception \"Error description\""
  , "\"myError\" bad-argument \"An error happened\" ()"
  , "\"ctrError\" contract-internal \"Internal counter error\" Integer"
  ] do
    skipSpaces
    errorName <- litT . strTyLit <$> hsString
    skipSpaces
    errorClass <- conE <$> choice
      [ string "exception"         $> 'ErrClassActionException
      , string "bad-argument"      $> 'ErrClassBadArgument
      , string "contract-internal" $> 'ErrClassContractInternal
      , string "unknown"           $> 'ErrClassUnknown
      ]
    skipSpaces
    errorDesc <- litE . stringL <$> hsString
    skipSpaces
    errorArg <- optional $ conT . mkName <$> hsIdent
    skipSpaces
    eof
    let errorArgType = fromMaybe [t|NoErrorArg|] errorArg
    pure [d|
      type instance ErrorArg $errorName = $errorArgType
      instance CustomErrorHasDoc $errorName where
        customErrClass = $errorClass
        customErrDocMdCause = $errorDesc
      |]

-- | QuasiQuote that helps generating @TypeHasDoc@ instance.
--
-- Usage:
--
-- @
-- [typeDoc| \<type> \<description> [\<field naming strategy>] |]
-- [typeDoc| Storage "This is storage description" |]
-- [typeDoc| Storage "This is storage description" stripFieldPrefix |]
-- @
--
-- @field naming strategy@ is optional, and is a function with signature @Text
-- -> Text@. Common strategies include 'id' and @stripFieldPrefix@. If
-- unspecified, ultimately defaults to 'id'.
--
-- See this [tutorial](https://indigo-lang.gitlab.io/contract-docs/) which
-- includes this quasiquote.
--
typeDoc :: QuasiQuoter
typeDoc = mkParserQQ "typeDoc"
  "<type> <description> [<field naming strategy>]"
  [ "Storage \"This is storage description\""
  , "Storage \"This is storage description\" stripFieldPrefix"
  ] do
    skipSpaces
    typeName <- conT . mkName <$> hsIdent
    skipSpaces
    desc <- litE . stringL <$> hsString
    skipSpaces
    fnstrategy <- optional $ varE . mkName <$> hsIdent
    skipSpaces
    eof
    pure $ liftA2 (<>)
      [d|
      instance TypeHasDoc $typeName where
        typeDocMdDescription = $desc
      |]
      case fnstrategy of
        Nothing -> mempty
        Just strat' ->
          [d|
          instance TypeHasFieldNamingStrategy $typeName where
            typeFieldNamingStrategy = $strat'
          |]

--------------------------------------------------
-- 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

mkParserQQ :: Text -> Text -> [Text] -> ReadP (Q [Dec]) -> QuasiQuoter
mkParserQQ qqName format examples parser = QuasiQuoter
  { quoteExp  = const $ failQQType qqName "expression"
  , quotePat  = const $ failQQType qqName "pattern"
  , quoteType = const $ failQQType qqName "type"
  , quoteDec  = go
  }
  where
    parse = readP_to_S parser
    mkSample text = "        - [" <> qqName <> "| " <> text <> " |]"
    go input = case parse input of
      [(res, "")] -> res
      _ -> failQQ qqName $ errTemplate <> toText input
    errTemplate = unlines $
        [ "Invalid arguments."
        , "      Expected arguments to be in the format of:"
        , "        - [" <> qqName <> "| " <> format <> " |]"
        , "      Examples:"
        ] <> map mkSample examples <>
        [ "      But instead got: " ]

hsIdent :: ReadP String
hsIdent = munch1 (not . isSpace)

hsString :: ReadP String
hsString = do
  String x <- lex
  pure x