-- 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
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 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 [Dec]
quoteDec  = String -> Q [Dec]
go
  }
  where
    qqName :: Text
qqName = Text
"entrypointDoc"

    go :: String -> Q [Dec]
    go :: String -> Q [Dec]
go String
input =
      let
        mkEpdWithRoot :: Text -> Text -> TypeQ
        mkEpdWithRoot :: Text -> Text -> Q Type
mkEpdWithRoot Text
epd 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 String
"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 [Text]
a =
          case [Text]
a of
            [Text
x, Text
"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
$ String
"EpdPlain")
            [Text
x, Text
"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
$ String
"EpdDelegate")
            [Text
x, Text
"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
$ String
"EpdRecursive")
            [Text
x, Text
"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
$ String
"EpdNone")
            [Text
x, Text
"plain", 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 Text
"EpdPlain" Text
r)
            [Text
x, Text
"delegate", 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 Text
"EpdDelegate" Text
r)
            [Text
x, Text
"recursive", 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 Text
"EpdRecursive" Text
r)
            [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
              [ 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
"| Parameter <parameter-type> <optional-root-annotation> |]"
              , Text
"      Examples:"
              , Text
"        - [" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
qqName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"| Parameter plain |]"
              , Text
"        - [" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
qqName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"| Parameter recursive |]"
              , Text
"        - [" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
qqName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"| Parameter plain \"root\" |]"
              , Text
"      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 (Text
param, Q Type
paramValue) -> [d|
              instance ParameterHasEntrypoints $(conT $ mkName $ toString param) where
                type ParameterEntrypointsDerivation $(conT $ mkName $ toString param) = $(paramValue)
              |]
            Left 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 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 [Dec]
quoteDec  = String -> Q [Dec]
go
  }
  where
    qqName :: Text
qqName = Text
"errorDoc"

    errMsg :: [Text] -> Text
errMsg [Text]
i = [Text] -> Text
unlines
      [ 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
"| <error-name> <error-type> <error-description> |]"
      , Text
"      Examples:"
      , Text
"        - [" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
qqName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"| \"errorName\" exception \"Error description\" |]"
      , Text
"        - [" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
qqName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"| \"myError\" bad-argument \"An error happened\" |]"
      , Text
"      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 String
input =
      let
        extract :: [Text] -> Either Text (Text, ExpQ, Text)
        extract :: [Text] -> Either Text (Text, Q Exp, Text)
extract [Text]
i = case [Text]
i of
            Text
errorName:Text
errorClassString:[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 -> (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
                  )
                Maybe ErrorClass
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]
_ -> 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 (Text
errorName, Q Exp
errorClassVal, 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 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 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 [Dec]
quoteDec  = String -> Q [Dec]
go
  }
  where
    qqName :: Text
qqName = Text
"typeDoc"

    go :: String -> Q [Dec]
    go :: String -> Q [Dec]
go 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
        (Text
param:[Text]
value) ->
          [d|
          instance TypeHasDoc $(conT $ mkName $ toString $ param) where
            typeDocMdDescription = $(litE $ stringL $ toString $ stripQuote $ unwords value)
          |]
        [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
            [ 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
"| <type> <description> |]"
            , Text
"      Example:"
            , Text
"        - [" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
qqName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"| Storage \"This is storage description\" |]"
            , Text
"      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 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 :: 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

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