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