{-# OPTIONS_GHC -fno-warn-orphans #-}

-- | TemplateHaskell functions for creating commands
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

-- | Make a command parser for a given data type
--    - the data type name is used to get the command name to parse
--    - each alternative in the data type defines an alternative parser
--
--   Usage: @$(makeCommand ''MyDataType [shortDescription "copy a file"]) <: otherParsers@
--   The type of the resulting parser is @Parser "dataType" MyDataType@
makeCommand :: Name -> [HelpUpdate] -> ExpQ
makeCommand :: Name -> [HelpUpdate] -> ExpQ
makeCommand = ParserConfiguration -> Bool -> Name -> [HelpUpdate] -> ExpQ
makeParserWith ParserConfiguration
defaultParserConfiguration Bool
True

-- | Make a command parser with some specific parser options
makeCommandWith :: ParserConfiguration -> Name -> [HelpUpdate] -> ExpQ
makeCommandWith :: ParserConfiguration -> Name -> [HelpUpdate] -> ExpQ
makeCommandWith ParserConfiguration
parserOptions = ParserConfiguration -> Bool -> Name -> [HelpUpdate] -> ExpQ
makeParserWith ParserConfiguration
parserOptions Bool
True

-- | Make a Parser for a given data type, without using the data type as a command name
makeParser :: Name -> ExpQ
makeParser :: Name -> ExpQ
makeParser Name
n = ParserConfiguration -> Bool -> Name -> [HelpUpdate] -> ExpQ
makeParserWith ParserConfiguration
defaultParserConfiguration Bool
False Name
n []

-- | Options for creating a command parser
data ParserConfiguration = ParserConfiguration
  { -- | make the name a the command from a qualified data type name
    ParserConfiguration -> Text -> Text
makeCommandName :: Text -> Text,
    -- | make the type of a field from the command data type, and the qualified field type (if it exists)
    ParserConfiguration -> Text -> Maybe Text -> Text
makeFieldType :: Text -> Maybe Text -> Text
  }

-- | Default parser configuration
--   if the data type is @mypackage.DataType { dataTypeFieldName :: FieldType }@ then
--     - @makeCommandName -> "type"@
--     - @makeFieldType -> "fieldName"@
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)
    }

-- | Main TemplateHaskell function for creating a command parser
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
    -- newtype data constructor
    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
    -- regular data constructor with just one field
    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
    -- list of data constructors
    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"

-- | Make a parser for a single constructor, either a newtype with or without a field name
--   or a regular data constructor
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)
         )

-- | Add a list of parser functions to the registry
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

-- | Take an expression representing a function and apply @fun@ in front, in order
--   to add it to a registry
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"))

-- | Make a Parser for a single Constructor, where each field of the constructor is parsed separately
--   \(os: FieldConfiguration) (p0::Parser fieldName0 Text) (p1::Parser fieldName1 Bool) -> Constructor <$> coerce p0 <*> coerce p1
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)

-- | Make a Parser for a several Constructors, where each field of each the constructor is parsed separately
--   and an alternative is taken between all the parsers
--   \(os: FieldConfiguration) (p0::Parser fieldName1 Text) (p1::Parser fieldName1 Bool) (p2::Parser fieldName2 Bool) ->
--      (Constructor1 <$> coerce p0 <*> coerce p1) <|> (Constructor2 <$> coerce p1 <*> coerce p3)
makeConstructorsParser :: ParserConfiguration -> Name -> [Con] -> Help -> ExpQ
makeConstructorsParser :: ParserConfiguration -> Name -> [Con] -> Help -> ExpQ
makeConstructorsParser ParserConfiguration
parserOptions Name
typeName [Con]
cs Help
help = do
  -- take the fields of all the constructors
  -- and make a parameter list with the corresponding parsers
  [(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)

  -- the string type for the final parser is entirely derived from the data type name
  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)

-- | Apply a constructor to parsers for each of its fields
--   The resulting parser is a command parser @Parser "Command" DataType@ for a command
--   @ConstructorName <$> coerce p0 <*> coerce p1 ...@
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"
  -- a default subcommand might be optional, in that case it is ok if the command name is not parsed
  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)

-- | Get the types of all the fields of a constructor
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"

-- | Get the types of all the fields of a constructor
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"

-- | Return the name of a constructor
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"

-- | Given the list of all possible fields and their types, across all the alternatives of an ADT,
--   return the indices for a specific subset
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

-- | Make a Parser for a given field
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)
      )

-- | Add no default values for a given field name to the registry
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

-- | Return the singleton string type for a given field parser
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 an expression to a registry
append :: ExpQ -> ExpQ -> ExpQ
append :: ExpQ -> ExpQ -> ExpQ
append = Text -> ExpQ -> ExpQ -> ExpQ
appOf Text
"<+"

-- | Apply an operator (described as Text) to 2 expressions
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

-- | Display a type name
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

-- | Return the name of a type in the most frequent cases
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