-- 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 :: QuasiQuoter
entrypointDoc = Text -> Text -> [Text] -> ReadP (Q Decs) -> QuasiQuoter
mkParserQQ Text
"entrypointDoc"
  Text
"Parameter <parameter-type> [<root-annotation>]"
  [ Text
"Parameter plain"
  , Text
"Parameter recursive"
  , Text
"Parameter plain \"root\""
  ] do
    ReadP ()
skipSpaces
    Q Type
typeName <- Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT (Name -> Q Type) -> (String -> Name) -> String -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName (String -> Q Type) -> ReadP String -> ReadP (Q Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadP String
hsIdent
    ReadP ()
skipSpaces
    Q Type
paramType <- Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT (Name -> Q Type) -> ReadP Name -> ReadP (Q Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ReadP Name] -> ReadP Name
forall a. [ReadP a] -> ReadP a
choice
      [ String -> ReadP String
string String
"plain"     ReadP String -> Name -> ReadP Name
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ''EpdPlain
      , String -> ReadP String
string String
"delegate"  ReadP String -> Name -> ReadP Name
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ''EpdDelegate
      , String -> ReadP String
string String
"recursive" ReadP String -> Name -> ReadP Name
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ''EpdRecursive
      , String -> ReadP String
string String
"none"      ReadP String -> Name -> ReadP Name
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ''EpdNone
      ]
    ReadP ()
skipSpaces
    Maybe (Q Type)
mbRootAnn <- ReadP (Q Type) -> ReadP (Maybe (Q Type))
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (ReadP (Q Type) -> ReadP (Maybe (Q Type)))
-> ReadP (Q Type) -> ReadP (Maybe (Q Type))
forall a b. (a -> b) -> a -> b
$ Q TyLit -> Q Type
forall (m :: * -> *). Quote m => m TyLit -> m Type
litT (Q TyLit -> Q Type) -> (String -> Q TyLit) -> String -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Q TyLit
forall (m :: * -> *). Quote m => String -> m TyLit
strTyLit (String -> Q Type) -> ReadP String -> ReadP (Q Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadP String
hsString
    ReadP ()
skipSpaces
    ReadP ()
eof
    let epd :: Q Type
epd = Q Type -> (Q Type -> Q Type) -> Maybe (Q Type) -> Q Type
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Q Type
paramType (\Q Type
ann -> [t|EpdWithRoot $ann $paramType|]) Maybe (Q Type)
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 :: QuasiQuoter
errorDocArg = Text -> Text -> [Text] -> ReadP (Q Decs) -> QuasiQuoter
mkParserQQ Text
"errorDocArg"
  Text
"<error-name> <error-type> <error-description> [<error-arg-type>]"
  [ Text
"\"errorName\" exception \"Error description\""
  , Text
"\"myError\" bad-argument \"An error happened\" ()"
  , Text
"\"ctrError\" contract-internal \"Internal counter error\" Integer"
  ] do
    ReadP ()
skipSpaces
    Q Type
errorName <- Q TyLit -> Q Type
forall (m :: * -> *). Quote m => m TyLit -> m Type
litT (Q TyLit -> Q Type) -> (String -> Q TyLit) -> String -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Q TyLit
forall (m :: * -> *). Quote m => String -> m TyLit
strTyLit (String -> Q Type) -> ReadP String -> ReadP (Q Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadP String
hsString
    ReadP ()
skipSpaces
    Q Exp
errorClass <- Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE (Name -> Q Exp) -> ReadP Name -> ReadP (Q Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ReadP Name] -> ReadP Name
forall a. [ReadP a] -> ReadP a
choice
      [ String -> ReadP String
string String
"exception"         ReadP String -> Name -> ReadP Name
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> 'ErrClassActionException
      , String -> ReadP String
string String
"bad-argument"      ReadP String -> Name -> ReadP Name
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> 'ErrClassBadArgument
      , String -> ReadP String
string String
"contract-internal" ReadP String -> Name -> ReadP Name
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> 'ErrClassContractInternal
      , String -> ReadP String
string String
"unknown"           ReadP String -> Name -> ReadP Name
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> 'ErrClassUnknown
      ]
    ReadP ()
skipSpaces
    Q Exp
errorDesc <- Lit -> Q Exp
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (Lit -> Q Exp) -> (String -> Lit) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lit
stringL (String -> Q Exp) -> ReadP String -> ReadP (Q Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadP String
hsString
    ReadP ()
skipSpaces
    Maybe (Q Type)
errorArg <- ReadP (Q Type) -> ReadP (Maybe (Q Type))
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (ReadP (Q Type) -> ReadP (Maybe (Q Type)))
-> ReadP (Q Type) -> ReadP (Maybe (Q Type))
forall a b. (a -> b) -> a -> b
$ Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT (Name -> Q Type) -> (String -> Name) -> String -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName (String -> Q Type) -> ReadP String -> ReadP (Q Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadP String
hsIdent
    ReadP ()
skipSpaces
    ReadP ()
eof
    let errorArgType :: Q Type
errorArgType = Q Type -> Maybe (Q Type) -> Q Type
forall a. a -> Maybe a -> a
fromMaybe [t|NoErrorArg|] Maybe (Q Type)
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 :: QuasiQuoter
typeDoc = Text -> Text -> [Text] -> ReadP (Q Decs) -> QuasiQuoter
mkParserQQ Text
"typeDoc"
  Text
"<type> <description> [<field naming strategy>]"
  [ Text
"Storage \"This is storage description\""
  , Text
"Storage \"This is storage description\" stripFieldPrefix"
  ] do
    ReadP ()
skipSpaces
    Q Type
typeName <- Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT (Name -> Q Type) -> (String -> Name) -> String -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName (String -> Q Type) -> ReadP String -> ReadP (Q Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadP String
hsIdent
    ReadP ()
skipSpaces
    Q Exp
desc <- Lit -> Q Exp
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (Lit -> Q Exp) -> (String -> Lit) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lit
stringL (String -> Q Exp) -> ReadP String -> ReadP (Q Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadP String
hsString
    ReadP ()
skipSpaces
    Maybe (Q Exp)
fnstrategy <- ReadP (Q Exp) -> ReadP (Maybe (Q Exp))
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (ReadP (Q Exp) -> ReadP (Maybe (Q Exp)))
-> ReadP (Q Exp) -> ReadP (Maybe (Q Exp))
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> (String -> Name) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName (String -> Q Exp) -> ReadP String -> ReadP (Q Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadP String
hsIdent
    ReadP ()
skipSpaces
    ReadP ()
eof
    pure $ (Decs -> Decs -> Decs) -> Q Decs -> Q Decs -> Q Decs
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Decs -> Decs -> Decs
forall a. Semigroup a => a -> a -> a
(<>)
      [d|
      instance TypeHasDoc $typeName where
        typeDocMdDescription = $desc
      |]
      case Maybe (Q Exp)
fnstrategy of
        Maybe (Q Exp)
Nothing -> Q Decs
forall a. Monoid a => a
mempty
        Just Q Exp
strat' ->
          [d|
          instance TypeHasFieldNamingStrategy $typeName where
            typeFieldNamingStrategy = $strat'
          |]

--------------------------------------------------
-- Helper
--------------------------------------------------

failQQ :: MonadFail m => Text -> Text -> m a
failQQ :: forall (m :: * -> *) a. MonadFail m => Text -> Text -> m a
failQQ Text
qq Text
errTxt =
  String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m a) -> String -> m a
forall a b. (a -> b) -> a -> b
$ String
"Lorentz.Util.TH." String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. ToString a => a -> String
toString (Text
qq Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
errTxt)

failQQType :: MonadFail m => Text -> Text -> m a
failQQType :: forall (m :: * -> *) a. MonadFail m => Text -> Text -> m a
failQQType Text
qq Text
typeTxt = Text -> Text -> m a
forall (m :: * -> *) a. MonadFail m => Text -> Text -> m a
failQQ Text
qq (Text -> m a) -> Text -> m a
forall a b. (a -> b) -> a -> b
$ Text
"This QuasiQuoter cannot be used as a " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
typeTxt

mkParserQQ :: Text -> Text -> [Text] -> ReadP (Q [Dec]) -> QuasiQuoter
mkParserQQ :: Text -> Text -> [Text] -> ReadP (Q Decs) -> QuasiQuoter
mkParserQQ Text
qqName Text
format [Text]
examples ReadP (Q Decs)
parser = QuasiQuoter :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q Decs)
-> QuasiQuoter
QuasiQuoter
  { quoteExp :: String -> Q Exp
quoteExp  = Q Exp -> String -> Q Exp
forall a b. a -> b -> a
const (Q Exp -> String -> Q Exp) -> Q Exp -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Q Exp
forall (m :: * -> *) a. MonadFail m => Text -> Text -> m a
failQQType Text
qqName Text
"expression"
  , quotePat :: String -> Q Pat
quotePat  = Q Pat -> String -> Q Pat
forall a b. a -> b -> a
const (Q Pat -> String -> Q Pat) -> Q Pat -> String -> Q Pat
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Q Pat
forall (m :: * -> *) a. MonadFail m => Text -> Text -> m a
failQQType Text
qqName Text
"pattern"
  , quoteType :: String -> Q Type
quoteType = Q Type -> String -> Q Type
forall a b. a -> b -> a
const (Q Type -> String -> Q Type) -> Q Type -> String -> Q Type
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Q Type
forall (m :: * -> *) a. MonadFail m => Text -> Text -> m a
failQQType Text
qqName Text
"type"
  , quoteDec :: String -> Q Decs
quoteDec  = String -> Q Decs
go
  }
  where
    parse :: ReadS (Q Decs)
parse = ReadP (Q Decs) -> ReadS (Q Decs)
forall a. ReadP a -> ReadS a
readP_to_S ReadP (Q Decs)
parser
    mkSample :: Text -> Text
mkSample Text
text = Text
"        - [" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
qqName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"| " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
text Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" |]"
    go :: String -> Q Decs
go String
input = case ReadS (Q Decs)
parse String
input of
      [(Q Decs
res, String
"")] -> Q Decs
res
      [(Q Decs, String)]
_ -> Text -> Text -> Q Decs
forall (m :: * -> *) a. MonadFail m => Text -> Text -> m a
failQQ Text
qqName (Text -> Q Decs) -> Text -> Q Decs
forall a b. (a -> b) -> a -> b
$ Text
errTemplate Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a. ToText a => a -> Text
toText String
input
    errTemplate :: Text
errTemplate = [Text] -> Text
unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
        [ Text
"Invalid arguments."
        , Text
"      Expected arguments to be in the format of:"
        , Text
"        - [" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
qqName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"| " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
format Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" |]"
        , Text
"      Examples:"
        ] [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> (Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Text -> Text
mkSample [Text]
examples [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<>
        [ Text
"      But instead got: " ]

hsIdent :: ReadP String
hsIdent :: ReadP String
hsIdent = (Char -> Bool) -> ReadP String
munch1 (Bool -> Bool
forall a. Boolean a => a -> a
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSpace)

hsString :: ReadP String
hsString :: ReadP String
hsString = do
  String String
x <- ReadP Lexeme
lex
  String -> ReadP String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
x