-- 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 Prelude hiding (lift)
import Data.Text (stripPrefix, stripSuffix)
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Language.Haskell.TH.Quote

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
entrypointDoc = QuasiQuoter :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> 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 "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 "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 "type"
  , quoteDec :: String -> Q [Dec]
quoteDec  = String -> Q [Dec]
go
  }
  where
    qqName :: Text
qqName = "entrypointDoc"

    go :: String -> Q [Dec]
    go :: String -> Q [Dec]
go input :: String
input =
      let
        mkEpdWithRoot :: Text -> Text -> TypeQ
        mkEpdWithRoot :: Text -> Text -> Q Type
mkEpdWithRoot epd :: Text
epd r :: Text
r =
          Q Type -> Q Type -> Q Type
appT (Q Type -> Q Type -> Q Type
appT (Name -> Q Type
conT (Name -> Q Type) -> Name -> Q Type
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName "EpdWithRoot") (TyLitQ -> Q Type
litT (TyLitQ -> Q Type) -> TyLitQ -> Q Type
forall a b. (a -> b) -> a -> b
$ String -> TyLitQ
strTyLit (String -> TyLitQ) -> String -> TyLitQ
forall a b. (a -> b) -> a -> b
$ Text -> String
forall a. ToString a => a -> String
toString (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text -> Text
stripQuote Text
r))
               (Name -> Q Type
conT (Name -> Q Type) -> Name -> Q Type
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName (Text -> String
forall a. ToString a => a -> String
toString Text
epd))
        extract :: [Text] -> Either Text (Text, TypeQ)
        extract :: [Text] -> Either Text (Text, Q Type)
extract a :: [Text]
a =
          case [Text]
a of
            [x :: Text
x, "plain"] -> (Text, Q Type) -> Either Text (Text, Q Type)
forall a b. b -> Either a b
Right (Text
x, Name -> Q Type
conT (Name -> Q Type) -> Name -> Q Type
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ "EpdPlain")
            [x :: Text
x, "delegate"] -> (Text, Q Type) -> Either Text (Text, Q Type)
forall a b. b -> Either a b
Right (Text
x, Name -> Q Type
conT (Name -> Q Type) -> Name -> Q Type
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ "EpdDelegate")
            [x :: Text
x, "recursive"] -> (Text, Q Type) -> Either Text (Text, Q Type)
forall a b. b -> Either a b
Right (Text
x, Name -> Q Type
conT (Name -> Q Type) -> Name -> Q Type
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ "EpdRecursive")
            [x :: Text
x, "none"] -> (Text, Q Type) -> Either Text (Text, Q Type)
forall a b. b -> Either a b
Right (Text
x, Name -> Q Type
conT (Name -> Q Type) -> Name -> Q Type
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ "EpdNone")
            [x :: Text
x, "plain", r :: Text
r] -> (Text, Q Type) -> Either Text (Text, Q Type)
forall a b. b -> Either a b
Right (Text
x, Text -> Text -> Q Type
mkEpdWithRoot "EpdPlain" Text
r)
            [x :: Text
x, "delegate", r :: Text
r] -> (Text, Q Type) -> Either Text (Text, Q Type)
forall a b. b -> Either a b
Right (Text
x, Text -> Text -> Q Type
mkEpdWithRoot "EpdDelegate" Text
r)
            [x :: Text
x, "recursive", r :: Text
r] -> (Text, Q Type) -> Either Text (Text, Q Type)
forall a b. b -> Either a b
Right (Text
x, Text -> Text -> Q Type
mkEpdWithRoot "EpdRecursive" Text
r)
            i :: [Text]
i -> Text -> Either Text (Text, Q Type)
forall a b. a -> Either a b
Left (Text -> Either Text (Text, Q Type))
-> Text -> Either Text (Text, Q Type)
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
unlines
              [ "Invalid arguments."
              , "      Expected arguments to be in the format of:"
              , "        - [" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
qqName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "| Parameter <parameter-type> <optional-root-annotation> |]"
              , "      Examples:"
              , "        - [" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
qqName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "| Parameter plain |]"
              , "        - [" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
qqName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "| Parameter recursive |]"
              , "        - [" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
qqName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "| Parameter plain \"root\" |]"
              , "      But instead got: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
unwords [Text]
i
              ]
      in case  [Text] -> Either Text (Text, Q Type)
extract ([Text] -> Either Text (Text, Q Type))
-> [Text] -> Either Text (Text, Q Type)
forall a b. (a -> b) -> a -> b
$ Text -> [Text]
words (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ String -> Text
forall a. ToText a => a -> Text
toText String
input of
            Right (param :: Text
param, paramValue :: Q Type
paramValue) -> [d|
              instance ParameterHasEntrypoints $(conT $ mkName $ toString param) where
                type ParameterEntrypointsDerivation $(conT $ mkName $ toString param) = $(paramValue)
              |]
            Left err :: Text
err -> Text -> Text -> Q [Dec]
forall (m :: * -> *) a. MonadFail m => Text -> Text -> m a
failQQ Text
qqName Text
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
errorDoc = QuasiQuoter :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> 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 "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 "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 "type"
  , quoteDec :: String -> Q [Dec]
quoteDec  = String -> Q [Dec]
go
  }
  where
    qqName :: Text
qqName = "errorDoc"

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

    go :: String -> Q [Dec]
    go :: String -> Q [Dec]
go input :: String
input =
      let
        extract :: [Text] -> Either Text (Text, ExpQ, Text)
        extract :: [Text] -> Either Text (Text, Q Exp, Text)
extract i :: [Text]
i = case [Text]
i of
            errorName :: Text
errorName:errorClassString :: Text
errorClassString:errorDesc :: [Text]
errorDesc ->
              case String -> Maybe ErrorClass
forall a. Read a => String -> Maybe a
readMaybe @ErrorClass (Text -> String
forall a. ToString a => a -> String
toString Text
errorClassString) of
                Just errorClass :: ErrorClass
errorClass -> (Text, Q Exp, Text) -> Either Text (Text, Q Exp, Text)
forall a b. b -> Either a b
Right
                  ( Text -> Text
stripQuote (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text
errorName
                  , ErrorClass -> Q Exp
forall t. Lift t => t -> Q Exp
lift ErrorClass
errorClass
                  , Text -> Text
stripQuote (Text -> Text) -> ([Text] -> Text) -> [Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
unwords ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ [Text]
errorDesc
                  )
                Nothing -> Text -> Either Text (Text, Q Exp, Text)
forall a b. a -> Either a b
Left (Text -> Either Text (Text, Q Exp, Text))
-> ([Text] -> Text) -> [Text] -> Either Text (Text, Q Exp, Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
errMsg ([Text] -> Either Text (Text, Q Exp, Text))
-> [Text] -> Either Text (Text, Q Exp, Text)
forall a b. (a -> b) -> a -> b
$ [Text]
i
            _ -> Text -> Either Text (Text, Q Exp, Text)
forall a b. a -> Either a b
Left (Text -> Either Text (Text, Q Exp, Text))
-> ([Text] -> Text) -> [Text] -> Either Text (Text, Q Exp, Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
errMsg ([Text] -> Either Text (Text, Q Exp, Text))
-> [Text] -> Either Text (Text, Q Exp, Text)
forall a b. (a -> b) -> a -> b
$ [Text]
i
      in case  [Text] -> Either Text (Text, Q Exp, Text)
extract ([Text] -> Either Text (Text, Q Exp, Text))
-> [Text] -> Either Text (Text, Q Exp, Text)
forall a b. (a -> b) -> a -> b
$ Text -> [Text]
words (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ String -> Text
forall a. ToText a => a -> Text
toText String
input of
            Right (errorName :: Text
errorName, errorClassVal :: Q Exp
errorClassVal, errorDesc :: Text
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 :: Text
err -> Text -> Text -> Q [Dec]
forall (m :: * -> *) a. MonadFail m => Text -> Text -> m a
failQQ Text
qqName Text
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
typeDoc = QuasiQuoter :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> 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 "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 "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 "type"
  , quoteDec :: String -> Q [Dec]
quoteDec  = String -> Q [Dec]
go
  }
  where
    qqName :: Text
qqName = "typeDoc"

    go :: String -> Q [Dec]
    go :: String -> Q [Dec]
go input :: String
input =
      case Text -> [Text]
words (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ String -> Text
forall a. ToText a => a -> Text
toText (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
input of
        (param :: Text
param:value :: [Text]
value) ->
          [d|
          instance TypeHasDoc $(conT $ mkName $ toString $ param) where
            typeDocMdDescription = $(litE $ stringL $ toString $ stripQuote $ unwords value)
          |]
        i :: [Text]
i ->
          Text -> Text -> Q [Dec]
forall (m :: * -> *) a. MonadFail m => Text -> Text -> m a
failQQ Text
qqName (Text -> Q [Dec]) -> Text -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
unlines
            [ "Invalid arguments."
            , "      Expected arguments to be in the format of:"
            , "        - [" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
qqName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "| <type> <description> |]"
            , "      Example:"
            , "        - [" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
qqName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "| Storage \"This is storage description\" |]"
            , "      But instead got: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
unwords [Text]
i
            ]

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

failQQ :: MonadFail m => Text -> Text -> m a
failQQ :: Text -> Text -> m a
failQQ qq :: Text
qq errTxt :: 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
$ "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
forall a. Semigroup a => a -> a -> a
<> Text
errTxt)

failQQType :: MonadFail m => Text -> Text -> m a
failQQType :: Text -> Text -> m a
failQQType qq :: Text
qq typeTxt :: 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
$ "This QuasiQuoter cannot be used as a " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
typeTxt

stripQuote :: Text -> Text
stripQuote :: Text -> Text
stripQuote txt :: Text
txt =
  let
    h :: Text
h = Text -> Text -> Maybe Text
stripPrefix "\"" Text
txt Maybe Text -> Text -> Text
forall a. Maybe a -> a -> a
?: Text
txt
    g :: Text
g = Text -> Text -> Maybe Text
stripSuffix "\"" Text
h Maybe Text -> Text -> Text
forall a. Maybe a -> a -> a
?: Text
h
  in Text
g