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