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
  , typeDoc
  ) where

import Data.Text (stripPrefix, stripSuffix)
import Language.Haskell.TH (Dec, ExpQ, Q, TypeQ, appT, conT, litE, litT, mkName, strTyLit, stringL)
import Language.Haskell.TH.Quote (QuasiQuoter(..))
import Language.Haskell.TH.Syntax (lift)
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