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
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
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
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 :: 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