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
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
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT (Name -> Q Type) -> Name -> Q Type
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"EpdWithRoot") (Q TyLit -> Q Type
forall (m :: * -> *). Quote m => m TyLit -> m Type
litT (Q TyLit -> Q Type) -> Q TyLit -> Q Type
forall a b. (a -> b) -> a -> b
$ String -> Q TyLit
forall (m :: * -> *). Quote m => String -> m TyLit
strTyLit (String -> Q TyLit) -> String -> Q TyLit
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
forall (m :: * -> *). Quote m => Name -> m 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
forall (m :: * -> *). Quote m => Name -> m 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
forall (m :: * -> *). Quote m => Name -> m 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
forall (m :: * -> *). Quote m => Name -> m 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
forall (m :: * -> *). Quote m => Name -> m 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
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 = QuasiQuoter -> String -> Q [Dec]
quoteDec QuasiQuoter
errorDocArg (String -> Q [Dec]) -> (String -> String) -> String -> Q [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" ()")
}
where
qqName :: Text
qqName = Text
"errorDoc"
{-# DEPRECATED errorDoc "errorDoc is deprecated, use errorDocArg with () argument instead" #-}
errorDocArg :: QuasiQuoter
errorDocArg :: QuasiQuoter
errorDocArg = 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
"errorDocArg"
errMsg :: String -> Text
errMsg String
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> [<error-argument>] |]"
, 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
<> String -> Text
forall a. IsString a => String -> a
fromString String
i
]
go :: String -> Q [Dec]
go :: String -> Q [Dec]
go String
input =
let
parser :: ReadP (String, ErrorClass, String)
parser = do
ReadP ()
skipSpaces
String String
errorName <- ReadP Lexeme
lex
ReadP ()
skipSpaces
ErrorClass
errorClass <- [ReadP ErrorClass] -> ReadP ErrorClass
forall a. [ReadP a] -> ReadP a
choice
[ String -> ReadP String
string String
"exception" ReadP String -> ErrorClass -> ReadP ErrorClass
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ErrorClass
ErrClassActionException
, String -> ReadP String
string String
"bad-argument" ReadP String -> ErrorClass -> ReadP ErrorClass
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ErrorClass
ErrClassBadArgument
, String -> ReadP String
string String
"contract-internal" ReadP String -> ErrorClass -> ReadP ErrorClass
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ErrorClass
ErrClassContractInternal
, String -> ReadP String
string String
"unknown" ReadP String -> ErrorClass -> ReadP ErrorClass
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ErrorClass
ErrClassUnknown
]
ReadP ()
skipSpaces
String String
errorDesc <- ReadP Lexeme
lex
ReadP ()
skipSpaces
pure (String
errorName, ErrorClass
errorClass, String
errorDesc)
extract :: String -> Either Text ((String, ErrorClass, String), String)
extract :: String -> Either Text ((String, ErrorClass, String), String)
extract String
i = ReadP (String, ErrorClass, String)
-> ReadS (String, ErrorClass, String)
forall a. ReadP a -> ReadS a
readP_to_S ReadP (String, ErrorClass, String)
parser String
i [((String, ErrorClass, String), String)]
-> ([((String, ErrorClass, String), String)]
-> Either Text ((String, ErrorClass, String), String))
-> Either Text ((String, ErrorClass, String), String)
forall a b. a -> (a -> b) -> b
& \case
[((String, ErrorClass, String)
res, String
type_)] -> ((String, ErrorClass, String), String)
-> Either Text ((String, ErrorClass, String), String)
forall a b. b -> Either a b
Right ((String, ErrorClass, String)
res, Text -> String
forall a. ToString a => a -> String
toString (Text -> String) -> (Text -> Text) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
strip (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ String -> Text
forall a. IsString a => String -> a
fromString String
type_)
[((String, ErrorClass, String), String)]
_ -> Text -> Either Text ((String, ErrorClass, String), String)
forall a b. a -> Either a b
Left (Text -> Either Text ((String, ErrorClass, String), String))
-> Text -> Either Text ((String, ErrorClass, String), String)
forall a b. (a -> b) -> a -> b
$ String -> Text
errMsg String
i
in case String -> Either Text ((String, ErrorClass, String), String)
extract String
input of
Right ((String
errorName, ErrorClass
errorClassVal, String
errorDesc), String
errorArg) -> do
let errorArgType :: Q Type
errorArgType = case String
errorArg of
[] -> [t|NoErrorArg|]
String
_ -> Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT (Name -> Q Type) -> Name -> Q Type
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
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 Text
err -> Text -> Text -> Q [Dec]
forall (m :: * -> *) a. MonadFail m => Text -> Text -> m a
failQQ Text
qqName Text
err
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
]
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
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