{-# OPTIONS_GHC -fno-warn-orphans #-}
module Data.Registry.Options.TH where
import Control.Monad.Fail
import Data.List (elemIndex, foldr1)
import Data.Registry.Options.Help
import Data.Registry.Options.OptionDescription (OptionDescription)
import Data.Registry.Options.Text
import Data.String
import Data.Text qualified as T
import Language.Haskell.TH
import Language.Haskell.TH.Lift
import Language.Haskell.TH.Syntax
import Protolude hiding (Type)
deriveLift ''OptionDescription
deriveLift ''Help
makeCommand :: Name -> [HelpUpdate] -> ExpQ
makeCommand :: Name -> [HelpUpdate] -> ExpQ
makeCommand = ParserConfiguration -> Bool -> Name -> [HelpUpdate] -> ExpQ
makeParserWith ParserConfiguration
defaultParserConfiguration Bool
True
makeCommandWith :: ParserConfiguration -> Name -> [HelpUpdate] -> ExpQ
makeCommandWith :: ParserConfiguration -> Name -> [HelpUpdate] -> ExpQ
makeCommandWith ParserConfiguration
parserOptions = ParserConfiguration -> Bool -> Name -> [HelpUpdate] -> ExpQ
makeParserWith ParserConfiguration
parserOptions Bool
True
makeParser :: Name -> ExpQ
makeParser :: Name -> ExpQ
makeParser Name
n = ParserConfiguration -> Bool -> Name -> [HelpUpdate] -> ExpQ
makeParserWith ParserConfiguration
defaultParserConfiguration Bool
False Name
n []
data ParserConfiguration = ParserConfiguration
{
ParserConfiguration -> Text -> Text
makeCommandName :: Text -> Text,
ParserConfiguration -> Text -> Maybe Text -> Text
makeFieldType :: Text -> Maybe Text -> Text
}
defaultParserConfiguration :: ParserConfiguration
defaultParserConfiguration :: ParserConfiguration
defaultParserConfiguration =
ParserConfiguration
{ makeCommandName :: Text -> Text
makeCommandName = Text -> Text
T.toLower forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
dropPrefix forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
dropQualifier,
makeFieldType :: Text -> Maybe Text -> Text
makeFieldType = \Text
typeName -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"Command" (Text -> Text
T.toLower forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text -> Text
T.drop (Text -> Int
T.length Text
typeName) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
dropQualifier)
}
makeParserWith :: ParserConfiguration -> Bool -> Name -> [HelpUpdate] -> ExpQ
makeParserWith :: ParserConfiguration -> Bool -> Name -> [HelpUpdate] -> ExpQ
makeParserWith ParserConfiguration
parserOptions Bool
isCommand Name
typeName [HelpUpdate]
help = do
Info
info <- Name -> Q Info
reify Name
typeName
case Info
info of
TyConI (NewtypeD Cxt
_context Name
_name [TyVarBndr ()]
_typeVars Maybe Type
_kind c :: Con
c@(NormalC Name
_ [(Bang
_, Type
_)]) [DerivClause]
_deriving) ->
ParserConfiguration -> Bool -> Name -> [HelpUpdate] -> Con -> ExpQ
makeSingleConstructor ParserConfiguration
parserOptions Bool
isCommand Name
typeName [HelpUpdate]
help Con
c
TyConI (NewtypeD Cxt
_context Name
_name [TyVarBndr ()]
_typeVars Maybe Type
_kind c :: Con
c@(RecC Name
_ [(Name
_, Bang
_, Type
_)]) [DerivClause]
_deriving) ->
ParserConfiguration -> Bool -> Name -> [HelpUpdate] -> Con -> ExpQ
makeSingleConstructor ParserConfiguration
parserOptions Bool
isCommand Name
typeName [HelpUpdate]
help Con
c
TyConI (DataD Cxt
_context Name
_name [TyVarBndr ()]
_typeVars Maybe Type
_kind [Con]
constructors [DerivClause]
_deriving) -> do
case [Con]
constructors of
[Con
c] ->
ParserConfiguration -> Bool -> Name -> [HelpUpdate] -> Con -> ExpQ
makeSingleConstructor ParserConfiguration
parserOptions Bool
isCommand Name
typeName [HelpUpdate]
help Con
c
Con
c : [Con]
cs -> do
[[(Maybe Name, Type)]]
fs <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (Con
c forall a. a -> [a] -> [a]
: [Con]
cs) Con -> Q [(Maybe Name, Type)]
fieldsOf
[ExpQ] -> ExpQ
addToRegistry forall a b. (a -> b) -> a -> b
$
[ExpQ -> ExpQ
funOf forall a b. (a -> b) -> a -> b
$ ParserConfiguration -> Name -> [Con] -> Help -> ExpQ
makeConstructorsParser ParserConfiguration
parserOptions Name
typeName (Con
c forall a. a -> [a] -> [a]
: [Con]
cs) forall a b. (a -> b) -> a -> b
$ [HelpUpdate] -> Help
makeHelp [HelpUpdate]
help]
forall a. Semigroup a => a -> a -> a
<> ( if Bool
isCommand
then []
else
(forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (ParserConfiguration -> Name -> Maybe Name -> Type -> ExpQ
makeFieldParser ParserConfiguration
parserOptions Name
typeName) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Maybe Name, Type)]]
fs)
forall a. Semigroup a => a -> a -> a
<> (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (ParserConfiguration -> Name -> Maybe Name -> Type -> ExpQ
makeNoDefaultValues ParserConfiguration
parserOptions Name
typeName) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Maybe Name, Type)]]
fs)
)
[] -> do
forall (m :: * -> *). Quasi m => Bool -> String -> m ()
qReport Bool
True String
"can not make a Parser for a data type with no constructors"
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"parser creation failed: cannot create a parser for a data type with no constructors"
Info
other -> do
forall (m :: * -> *). Quasi m => Bool -> String -> m ()
qReport Bool
True (String
"cannot create a parser for: " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show Info
other)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"parser creation failed"
makeSingleConstructor :: ParserConfiguration -> Bool -> Name -> [HelpUpdate] -> Con -> ExpQ
makeSingleConstructor :: ParserConfiguration -> Bool -> Name -> [HelpUpdate] -> Con -> ExpQ
makeSingleConstructor ParserConfiguration
parserOptions Bool
isCommand Name
typeName [HelpUpdate]
help Con
c = do
[(Maybe Name, Type)]
fs <- Con -> Q [(Maybe Name, Type)]
fieldsOf Con
c
Name
cName <- Con -> Q Name
nameOf Con
c
[ExpQ] -> ExpQ
addToRegistry forall a b. (a -> b) -> a -> b
$
[ExpQ -> ExpQ
funOf forall a b. (a -> b) -> a -> b
$ ParserConfiguration -> Bool -> Name -> Con -> Help -> ExpQ
makeConstructorParser ParserConfiguration
parserOptions Bool
isCommand Name
typeName Con
c forall a b. (a -> b) -> a -> b
$ [HelpUpdate] -> Help
makeHelp [HelpUpdate]
help]
forall a. Semigroup a => a -> a -> a
<> ( if Bool
isCommand
then []
else
(forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (ParserConfiguration -> Name -> Maybe Name -> Type -> ExpQ
makeFieldParser ParserConfiguration
parserOptions Name
cName) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Maybe Name, Type)]
fs)
forall a. Semigroup a => a -> a -> a
<> (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (ParserConfiguration -> Name -> Maybe Name -> Type -> ExpQ
makeNoDefaultValues ParserConfiguration
parserOptions Name
cName) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Maybe Name, Type)]
fs)
)
addToRegistry :: [ExpQ] -> ExpQ
addToRegistry :: [ExpQ] -> ExpQ
addToRegistry [] = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"parsers creation failed"
addToRegistry [ExpQ
g] = ExpQ
g
addToRegistry (ExpQ
g : [ExpQ]
gs) = ExpQ
g ExpQ -> ExpQ -> ExpQ
`append` [ExpQ] -> ExpQ
addToRegistry [ExpQ]
gs
funOf :: ExpQ -> ExpQ
funOf :: ExpQ -> ExpQ
funOf = forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName String
"fun"))
makeConstructorParser :: ParserConfiguration -> Bool -> Name -> Con -> Help -> ExpQ
makeConstructorParser :: ParserConfiguration -> Bool -> Name -> Con -> Help -> ExpQ
makeConstructorParser ParserConfiguration
parserOptions Bool
isCommand Name
typeName Con
c Help
help = do
let isOptionalCommand :: Bool
isOptionalCommand = Help -> Bool
helpDefaultSubcommand Help
help
[(Maybe Name, Type)]
fs <- Con -> Q [(Maybe Name, Type)]
fieldsOf Con
c
Name
cName <- Con -> Q Name
nameOf Con
c
let parserParameters :: [Q Pat]
parserParameters =
( \((Maybe Name
mFieldName, Type
t), Int
n) -> do
let fieldNameType :: Q Type
fieldNameType = ParserConfiguration -> Name -> Maybe Name -> Q Type
fieldNameTypeT ParserConfiguration
parserOptions Name
cName Maybe Name
mFieldName
forall (m :: * -> *). Quote m => m Pat -> m Type -> m Pat
sigP (forall (m :: * -> *). Quote m => Name -> m Pat
varP (String -> Name
mkName forall a b. (a -> b) -> a -> b
$ String
"_p" forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show Int
n)) (forall (m :: * -> *). Quote m => Name -> m Type
conT Name
"Parser" forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
fieldNameType forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
t)
)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. [a] -> [b] -> [(a, b)]
zip [(Maybe Name, Type)]
fs [(Int
0 :: Int) ..]
let parserType :: Q Type
parserType = forall (m :: * -> *). Quote m => Name -> m Type
conT Name
"Parser" forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` ParserConfiguration -> Name -> Maybe Name -> Q Type
fieldNameTypeT ParserConfiguration
parserOptions Name
cName forall a. Maybe a
Nothing forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` forall (m :: * -> *). Quote m => Name -> m Type
conT Name
typeName
let commandName :: Text
commandName = ParserConfiguration -> Text -> Text
makeCommandName ParserConfiguration
parserOptions (forall a b. (Show a, StringConv String b) => a -> b
show Name
cName)
let parserWithHelp :: ExpQ
parserWithHelp =
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
"addParserHelp"
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ [|help {helpCommandName = Just commandName}|]
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` ParserConfiguration -> Bool -> Bool -> Name -> [Int] -> ExpQ
applyParser ParserConfiguration
parserOptions Bool
isCommand Bool
isOptionalCommand Name
cName [Int
0 .. (forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Maybe Name, Type)]
fs forall a. Num a => a -> a -> a
- Int
1)]
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [Q Pat]
parserParameters (forall (m :: * -> *). Quote m => m Exp -> m Type -> m Exp
sigE ExpQ
parserWithHelp Q Type
parserType)
makeConstructorsParser :: ParserConfiguration -> Name -> [Con] -> Help -> ExpQ
makeConstructorsParser :: ParserConfiguration -> Name -> [Con] -> Help -> ExpQ
makeConstructorsParser ParserConfiguration
parserOptions Name
typeName [Con]
cs Help
help = do
[(Maybe Name, Type)]
fs <- forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Con]
cs Con -> Q [(Maybe Name, Type)]
fieldsOf
let parserParameters :: [Q Pat]
parserParameters =
( \((Maybe Name
mFieldName, Type
t), Int
n) -> do
let fieldNameType :: Q Type
fieldNameType = ParserConfiguration -> Name -> Maybe Name -> Q Type
fieldNameTypeT ParserConfiguration
parserOptions Name
typeName Maybe Name
mFieldName
forall (m :: * -> *). Quote m => m Pat -> m Type -> m Pat
sigP (forall (m :: * -> *). Quote m => Name -> m Pat
varP (String -> Name
mkName forall a b. (a -> b) -> a -> b
$ String
"_p" forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show Int
n)) (forall (m :: * -> *). Quote m => Name -> m Type
conT Name
"Parser" forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
fieldNameType forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
t)
)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. [a] -> [b] -> [(a, b)]
zip [(Maybe Name, Type)]
fs [(Int
0 :: Int) ..]
let appliedParsers :: [ExpQ]
appliedParsers =
( \Con
c -> do
Name
cName <- Con -> Q Name
nameOf Con
c
[(Maybe Name, Type)]
cFields <- Con -> Q [(Maybe Name, Type)]
fieldsOf Con
c
[Int]
constructorTypes <- [(Maybe Name, Type)] -> [(Maybe Name, Type)] -> Q [Int]
indexConstructorTypes [(Maybe Name, Type)]
fs [(Maybe Name, Type)]
cFields
ParserConfiguration -> Bool -> Bool -> Name -> [Int] -> ExpQ
applyParser ParserConfiguration
parserOptions Bool
False Bool
False Name
cName [Int]
constructorTypes
)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Con]
cs
let commandName :: Text
commandName = ParserConfiguration -> Text -> Text
makeCommandName ParserConfiguration
parserOptions (forall a b. (Show a, StringConv String b) => a -> b
show Name
typeName)
let commandNameParser :: ExpQ
commandNameParser = forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
"commandNameParser" forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => String -> m Exp
stringE (forall a b. ConvertText a b => a -> b
toS Text
commandName)
let parserAlternatives :: ExpQ
parserAlternatives =
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
"*>"
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` ExpQ
commandNameParser
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
"addParserHelp" forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ [|help {helpCommandName = Just commandName}|] forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\ExpQ
p ExpQ
r -> forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
"<|>" forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` ExpQ
p forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` ExpQ
r) [ExpQ]
appliedParsers)
let parserTypeName :: Q Type
parserTypeName = ParserConfiguration -> Name -> Maybe Name -> Q Type
fieldNameTypeT ParserConfiguration
parserOptions Name
typeName forall a. Maybe a
Nothing
let parserType :: Q Type
parserType = forall (m :: * -> *). Quote m => Name -> m Type
conT Name
"Parser" forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
parserTypeName forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` forall (m :: * -> *). Quote m => Name -> m Type
conT Name
typeName
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [Q Pat]
parserParameters (forall (m :: * -> *). Quote m => m Exp -> m Type -> m Exp
sigE ExpQ
parserAlternatives Q Type
parserType)
applyParser :: ParserConfiguration -> Bool -> Bool -> Name -> [Int] -> ExpQ
applyParser :: ParserConfiguration -> Bool -> Bool -> Name -> [Int] -> ExpQ
applyParser ParserConfiguration
parserOptions Bool
isCommand Bool
isOptionalCommand Name
cName [Int]
ns = do
let commandName :: Text
commandName = ParserConfiguration -> Text -> Text
makeCommandName ParserConfiguration
parserOptions (forall a b. (Show a, StringConv String b) => a -> b
show Name
cName)
let commandNameParser :: ExpQ
commandNameParser = if Bool
isCommand then forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
"commandNameParser" forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => String -> m Exp
stringE (forall a b. ConvertText a b => a -> b
toS Text
commandName) else forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
"unitParser"
let commandParser :: ExpQ
commandParser = forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
"*>" forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` (if Bool
isOptionalCommand then forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
"<|>" forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` ExpQ
commandNameParser forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
"unitParser" else ExpQ
commandNameParser)
let cons :: ExpQ
cons = ExpQ
commandParser forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
"pure" forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
cName)
case [Int]
ns of
[] -> ExpQ
cons
(Int
n : [Int]
rest) ->
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Int
i ExpQ
r -> forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
"<*>" forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` ExpQ
r forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall {m :: * -> *} {a}. (Quote m, Show a) => a -> m Exp
parseAt Int
i) (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
"<*>" forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` ExpQ
cons forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall {m :: * -> *} {a}. (Quote m, Show a) => a -> m Exp
parseAt Int
n) (forall a. [a] -> [a]
reverse [Int]
rest)
where
parseAt :: a -> m Exp
parseAt a
i = forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
"coerceParser" forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName forall a b. (a -> b) -> a -> b
$ String
"_p" forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show a
i)
typesOf :: Con -> Q [Type]
typesOf :: Con -> Q Cxt
typesOf (NormalC Name
_ [BangType]
types) = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [BangType]
types)
typesOf (RecC Name
_ [VarBangType]
types) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ (\(Name
_, Bang
_, Type
t) -> Type
t) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [VarBangType]
types
typesOf Con
other = do
forall (m :: * -> *). Quasi m => Bool -> String -> m ()
qReport Bool
True (String
"we can only create a parser for normal constructors and records, got: " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show Con
other)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"parser creation failed"
fieldsOf :: Con -> Q [(Maybe Name, Type)]
fieldsOf :: Con -> Q [(Maybe Name, Type)]
fieldsOf (NormalC Name
_ [BangType]
types) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ (\(Bang
_, Type
t) -> (forall a. Maybe a
Nothing, Type
t)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [BangType]
types
fieldsOf (RecC Name
_ [VarBangType]
types) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ (\(Name
n, Bang
_, Type
t) -> (forall a. a -> Maybe a
Just Name
n, Type
t)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [VarBangType]
types
fieldsOf Con
other = do
forall (m :: * -> *). Quasi m => Bool -> String -> m ()
qReport Bool
True (String
"we can only create a parser for normal constructors and records, got: " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show Con
other)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"parser creation failed"
nameOf :: Con -> Q Name
nameOf :: Con -> Q Name
nameOf (NormalC Name
n [BangType]
_) = forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
n
nameOf (RecC Name
n [VarBangType]
_) = forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
n
nameOf Con
other = do
forall (m :: * -> *). Quasi m => Bool -> String -> m ()
qReport Bool
True (String
"we can only create a parser for normal constructors and records, got: " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show Con
other)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"parser creation failed"
indexConstructorTypes :: [(Maybe Name, Type)] -> [(Maybe Name, Type)] -> Q [Int]
indexConstructorTypes :: [(Maybe Name, Type)] -> [(Maybe Name, Type)] -> Q [Int]
indexConstructorTypes [(Maybe Name, Type)]
allFields [(Maybe Name, Type)]
constructorFields =
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [(Maybe Name, Type)]
constructorFields forall a b. (a -> b) -> a -> b
$ \(Maybe Name, Type)
f ->
case forall a. Eq a => a -> [a] -> Maybe Int
elemIndex (Maybe Name, Type)
f [(Maybe Name, Type)]
allFields of
Just Int
n -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
n
Maybe Int
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"the field " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show (Maybe Name, Type)
f forall a. Semigroup a => a -> a -> a
<> String
" cannot be found in the list of all the fields " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show [(Maybe Name, Type)]
allFields
makeFieldParser :: ParserConfiguration -> Name -> Maybe Name -> Type -> ExpQ
makeFieldParser :: ParserConfiguration -> Name -> Maybe Name -> Type -> ExpQ
makeFieldParser ParserConfiguration
parserOptions Name
constructorName Maybe Name
mFieldName Type
fieldType = do
let fieldNameType :: Q Type
fieldNameType = ParserConfiguration -> Name -> Maybe Name -> Q Type
fieldNameTypeT ParserConfiguration
parserOptions Name
constructorName Maybe Name
mFieldName
let fieldName :: ExpQ
fieldName = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
"Positional") (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
"NonPositional") Maybe Name
mFieldName
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
"fun"
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE
[forall (m :: * -> *). Quote m => m Pat -> m Type -> m Pat
sigP (forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
"ps") (forall (m :: * -> *). Quote m => Name -> m Type
conT Name
"FieldConfiguration")]
( (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
"parseField" forall (m :: * -> *). Quote m => m Exp -> m Type -> m Exp
`appTypeE` Q Type
fieldNameType forall (m :: * -> *). Quote m => m Exp -> m Type -> m Exp
`appTypeE` forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
fieldType)
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
"ps"
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` ExpQ
fieldName
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => String -> m Exp
stringE (forall a b. ConvertText a b => a -> b
toS forall a b. (a -> b) -> a -> b
$ Type -> Text
displayType Type
fieldType)
)
makeNoDefaultValues :: ParserConfiguration -> Name -> Maybe Name -> Type -> ExpQ
makeNoDefaultValues :: ParserConfiguration -> Name -> Maybe Name -> Type -> ExpQ
makeNoDefaultValues ParserConfiguration
parserOptions Name
constructorName Maybe Name
mFieldName Type
fieldType =
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
"setNoDefaultValues" forall (m :: * -> *). Quote m => m Exp -> m Type -> m Exp
`appTypeE` ParserConfiguration -> Name -> Maybe Name -> Q Type
fieldNameTypeT ParserConfiguration
parserOptions Name
constructorName Maybe Name
mFieldName forall (m :: * -> *). Quote m => m Exp -> m Type -> m Exp
`appTypeE` forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
fieldType
fieldNameTypeT :: ParserConfiguration -> Name -> Maybe Name -> Q Type
fieldNameTypeT :: ParserConfiguration -> Name -> Maybe Name -> Q Type
fieldNameTypeT ParserConfiguration
parserOptions Name
constructorName Maybe Name
mFieldName =
forall (m :: * -> *). Quote m => m TyLit -> m Type
litT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Quote m => String -> m TyLit
strTyLit forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. ConvertText a b => a -> b
toS forall a b. (a -> b) -> a -> b
$ ParserConfiguration -> Text -> Maybe Text -> Text
makeFieldType ParserConfiguration
parserOptions (Text -> Text
dropQualifier forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Show a, StringConv String b) => a -> b
show forall a b. (a -> b) -> a -> b
$ Name
constructorName) (forall a b. (Show a, StringConv String b) => a -> b
show forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Name
mFieldName)
append :: ExpQ -> ExpQ -> ExpQ
append :: ExpQ -> ExpQ -> ExpQ
append = Text -> ExpQ -> ExpQ -> ExpQ
appOf Text
"<+"
appOf :: Text -> ExpQ -> ExpQ -> ExpQ
appOf :: Text -> ExpQ -> ExpQ -> ExpQ
appOf Text
operator ExpQ
e1 ExpQ
e2 = forall (m :: * -> *).
Quote m =>
Maybe (m Exp) -> m Exp -> Maybe (m Exp) -> m Exp
infixE (forall a. a -> Maybe a
Just ExpQ
e1) (forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName forall a b. (a -> b) -> a -> b
$ forall a b. ConvertText a b => a -> b
toS Text
operator)) (forall a. a -> Maybe a
Just ExpQ
e2)
instance IsString Name where
fromString :: String -> Name
fromString = String -> Name
mkName
displayType :: Type -> Text
displayType :: Type -> Text
displayType = forall a b. (Show a, StringConv String b) => a -> b
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Name
getTypeName
getTypeName :: Type -> Name
getTypeName :: Type -> Name
getTypeName (ForallT [TyVarBndr Specificity]
_ Cxt
_ Type
ty) = Type -> Name
getTypeName Type
ty
getTypeName (VarT Name
name) = Name
name
getTypeName (ConT Name
name) = Name
name
getTypeName (TupleT Int
n) = Int -> Name
tupleTypeName Int
n
getTypeName Type
ArrowT = ''(->)
getTypeName Type
ListT = ''[]
getTypeName (AppT Type
t1 Type
t2) = String -> Name
mkName (forall a b. (Show a, StringConv String b) => a -> b
show (Type -> Name
getTypeName Type
t1) forall a. Semigroup a => a -> a -> a
<> String
" " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show (Type -> Name
getTypeName Type
t2))
getTypeName (SigT Type
t Type
_) = Type -> Name
getTypeName Type
t
getTypeName (UnboxedTupleT Int
n) = Int -> Name
unboxedTupleTypeName Int
n
getTypeName Type
t = forall a. HasCallStack => Text -> a
panic forall a b. (a -> b) -> a -> b
$ Text
"getTypeName: Unknown type: " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show Type
t