TH.hs

-- SPDX-FileCopyrightText: 2020 Tocqueville Group
--
-- SPDX-License-Identifier: LicenseRef-MIT-TQ

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

import Data.Text (stripPrefix, stripSuffix)
import Language.Haskell.TH
import Language.Haskell.TH.Quote
import Language.Haskell.TH.Syntax
import Prelude hiding (lift)

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" |]
-- @
--
-- See this [tutorial](https://indigo-lang.gitlab.io/contract-docs/) which
-- includes this quasiquote.
--
errorDoc :: QuasiQuoter
errorDoc = QuasiQuoter
  { quoteExp  = const $ failQQType qqName "expression"
  , quotePat  = const $ failQQType qqName "pattern"
  , quoteType = const $ failQQType qqName "type"
  , quoteDec  = go
  }
  where
    qqName = "errorDoc"

    errMsg i = unlines
      [ "Invalid arguments."
      , "      Expected arguments to be in the format of:"
      , "        - [" <> qqName <> "| <error-name> <error-type> <error-description> |]"
      , "      Examples:"
      , "        - [" <> qqName <> "| \"errorName\" exception \"Error description\" |]"
      , "        - [" <> qqName <> "| \"myError\" bad-argument \"An error happened\" |]"
      , "      But instead got: " <> unwords i
      ]

    go :: String -> Q [Dec]
    go input =
      let
        extract :: [Text] -> Either Text (Text, ExpQ, Text)
        extract i = case i of
            errorName:errorClassString:errorDesc ->
              case readMaybe @ErrorClass (toString errorClassString) of
                Just errorClass -> Right
                  ( stripQuote $ errorName
                  , lift errorClass
                  , stripQuote . unwords $ errorDesc
                  )
                Nothing -> Left . errMsg $ i
            _ -> Left . errMsg $ i
      in case  extract $ words $ toText input of
            Right (errorName, errorClassVal, errorDesc) ->
              [d|
                type instance ErrorArg $(litT . strTyLit $ toString $ errorName) = ()
                instance CustomErrorHasDoc $(litT . strTyLit $ toString $ errorName) where
                  customErrClass = $(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