{-# 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 (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
dropPrefix (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
dropQualifier,
      makeFieldType :: Text -> Maybe Text -> Text
makeFieldType = \Text
typeName -> Text -> (Text -> Text) -> Maybe Text -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"Command" (Text -> Text
T.toLower (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text -> Text
T.drop (Text -> Int
T.length Text
typeName) (Text -> Text) -> (Text -> Text) -> Text -> Text
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 <- [Con]
-> (Con -> Q [(Maybe Name, Type)]) -> Q [[(Maybe Name, Type)]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (Con
c Con -> [Con] -> [Con]
forall a. a -> [a] -> [a]
: [Con]
cs) Con -> Q [(Maybe Name, Type)]
fieldsOf
          [ExpQ] -> ExpQ
addToRegistry ([ExpQ] -> ExpQ) -> [ExpQ] -> ExpQ
forall a b. (a -> b) -> a -> b
$
            [ExpQ -> ExpQ
funOf (ExpQ -> ExpQ) -> ExpQ -> ExpQ
forall a b. (a -> b) -> a -> b
$ ParserConfiguration -> Name -> [Con] -> Help -> ExpQ
makeConstructorsParser ParserConfiguration
parserOptions Name
typeName (Con
c Con -> [Con] -> [Con]
forall a. a -> [a] -> [a]
: [Con]
cs) (Help -> ExpQ) -> Help -> ExpQ
forall a b. (a -> b) -> a -> b
$ [HelpUpdate] -> Help
makeHelp [HelpUpdate]
help]
              [ExpQ] -> [ExpQ] -> [ExpQ]
forall a. Semigroup a => a -> a -> a
<> ( if Bool
isCommand
                     then []
                     else
                       ((Maybe Name -> Type -> ExpQ) -> (Maybe Name, Type) -> ExpQ
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (ParserConfiguration -> Name -> Maybe Name -> Type -> ExpQ
makeFieldParser ParserConfiguration
parserOptions Name
typeName) ((Maybe Name, Type) -> ExpQ) -> [(Maybe Name, Type)] -> [ExpQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[(Maybe Name, Type)]] -> [(Maybe Name, Type)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Maybe Name, Type)]]
fs)
                         [ExpQ] -> [ExpQ] -> [ExpQ]
forall a. Semigroup a => a -> a -> a
<> ((Maybe Name -> Type -> ExpQ) -> (Maybe Name, Type) -> ExpQ
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (ParserConfiguration -> Name -> Maybe Name -> Type -> ExpQ
makeNoDefaultValues ParserConfiguration
parserOptions Name
typeName) ((Maybe Name, Type) -> ExpQ) -> [(Maybe Name, Type)] -> [ExpQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[(Maybe Name, Type)]] -> [(Maybe Name, Type)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Maybe Name, Type)]]
fs)
                 )
        [] -> do
          Bool -> String -> Q ()
forall (m :: * -> *). Quasi m => Bool -> String -> m ()
qReport Bool
True String
"can not make a Parser for a data type with no constructors"
          String -> ExpQ
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
      Bool -> String -> Q ()
forall (m :: * -> *). Quasi m => Bool -> String -> m ()
qReport Bool
True (String
"cannot create a parser for: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Info -> String
forall a b. (Show a, StringConv String b) => a -> b
show Info
other)
      String -> ExpQ
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 ([ExpQ] -> ExpQ) -> [ExpQ] -> ExpQ
forall a b. (a -> b) -> a -> b
$
    [ExpQ -> ExpQ
funOf (ExpQ -> ExpQ) -> ExpQ -> ExpQ
forall a b. (a -> b) -> a -> b
$ ParserConfiguration -> Bool -> Name -> Con -> Help -> ExpQ
makeConstructorParser ParserConfiguration
parserOptions Bool
isCommand Name
typeName Con
c (Help -> ExpQ) -> Help -> ExpQ
forall a b. (a -> b) -> a -> b
$ [HelpUpdate] -> Help
makeHelp [HelpUpdate]
help]
      [ExpQ] -> [ExpQ] -> [ExpQ]
forall a. Semigroup a => a -> a -> a
<> ( if Bool
isCommand
             then []
             else
               ((Maybe Name -> Type -> ExpQ) -> (Maybe Name, Type) -> ExpQ
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (ParserConfiguration -> Name -> Maybe Name -> Type -> ExpQ
makeFieldParser ParserConfiguration
parserOptions Name
cName) ((Maybe Name, Type) -> ExpQ) -> [(Maybe Name, Type)] -> [ExpQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Maybe Name, Type)]
fs)
                 [ExpQ] -> [ExpQ] -> [ExpQ]
forall a. Semigroup a => a -> a -> a
<> ((Maybe Name -> Type -> ExpQ) -> (Maybe Name, Type) -> ExpQ
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (ParserConfiguration -> Name -> Maybe Name -> Type -> ExpQ
makeNoDefaultValues ParserConfiguration
parserOptions Name
cName) ((Maybe Name, Type) -> ExpQ) -> [(Maybe Name, Type)] -> [ExpQ]
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 [] = String -> ExpQ
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 = ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> ExpQ
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
            Q Pat -> Q Type -> Q Pat
forall (m :: * -> *). Quote m => m Pat -> m Type -> m Pat
sigP (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"_p" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a b. (Show a, StringConv String b) => a -> b
show Int
n)) (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
"Parser" Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
fieldNameType Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
t)
        )
          (((Maybe Name, Type), Int) -> Q Pat)
-> [((Maybe Name, Type), Int)] -> [Q Pat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Maybe Name, Type)] -> [Int] -> [((Maybe Name, Type), Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Maybe Name, Type)]
fs [(Int
0 :: Int) ..]
  let parserType :: Q Type
parserType = Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
"Parser" Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` ParserConfiguration -> Name -> Maybe Name -> Q Type
fieldNameTypeT ParserConfiguration
parserOptions Name
cName Maybe Name
forall a. Maybe a
Nothing 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
typeName
  let commandName :: Text
commandName = ParserConfiguration -> Text -> Text
makeCommandName ParserConfiguration
parserOptions (Name -> Text
forall a b. (Show a, StringConv String b) => a -> b
show Name
cName)
  let parserWithHelp :: ExpQ
parserWithHelp =
        Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
"addParserHelp"
          ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` ExpQ -> ExpQ
forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ [|help {helpCommandName = Just commandName}|]
          ExpQ -> ExpQ -> ExpQ
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 .. ([(Maybe Name, Type)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Maybe Name, Type)]
fs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)]
  [Q Pat] -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [Q Pat]
parserParameters (ExpQ -> Q Type -> ExpQ
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 <- [[(Maybe Name, Type)]] -> [(Maybe Name, Type)]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join ([[(Maybe Name, Type)]] -> [(Maybe Name, Type)])
-> Q [[(Maybe Name, Type)]] -> Q [(Maybe Name, Type)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Con]
-> (Con -> Q [(Maybe Name, Type)]) -> Q [[(Maybe Name, Type)]]
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
            Q Pat -> Q Type -> Q Pat
forall (m :: * -> *). Quote m => m Pat -> m Type -> m Pat
sigP (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"_p" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a b. (Show a, StringConv String b) => a -> b
show Int
n)) (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
"Parser" Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
fieldNameType Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
t)
        )
          (((Maybe Name, Type), Int) -> Q Pat)
-> [((Maybe Name, Type), Int)] -> [Q Pat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Maybe Name, Type)] -> [Int] -> [((Maybe Name, Type), Int)]
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
        )
          (Con -> ExpQ) -> [Con] -> [ExpQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Con]
cs

  let commandName :: Text
commandName = ParserConfiguration -> Text -> Text
makeCommandName ParserConfiguration
parserOptions (Name -> Text
forall a b. (Show a, StringConv String b) => a -> b
show Name
typeName)
  let commandNameParser :: ExpQ
commandNameParser = Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
"commandNameParser" ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` String -> ExpQ
forall (m :: * -> *). Quote m => String -> m Exp
stringE (Text -> String
forall a b. ConvertText a b => a -> b
toS Text
commandName)
  let parserAlternatives :: ExpQ
parserAlternatives =
        Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
"*>"
          ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` ExpQ
commandNameParser
          ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` (Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
"addParserHelp" ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` ExpQ -> ExpQ
forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ [|help {helpCommandName = Just commandName}|] ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` (ExpQ -> ExpQ -> ExpQ) -> [ExpQ] -> ExpQ
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\ExpQ
p ExpQ
r -> Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
"<|>" ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` ExpQ
p ExpQ -> ExpQ -> ExpQ
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 Maybe Name
forall a. Maybe a
Nothing
  let parserType :: Q Type
parserType = Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
"Parser" Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
parserTypeName 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
typeName
  [Q Pat] -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [Q Pat]
parserParameters (ExpQ -> Q Type -> ExpQ
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 (Name -> Text
forall a b. (Show a, StringConv String b) => a -> b
show Name
cName)
  let commandNameParser :: ExpQ
commandNameParser = if Bool
isCommand then Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
"commandNameParser" ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` String -> ExpQ
forall (m :: * -> *). Quote m => String -> m Exp
stringE (Text -> String
forall a b. ConvertText a b => a -> b
toS Text
commandName) else Name -> ExpQ
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 = Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
"*>" ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` (if Bool
isOptionalCommand then Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
"<|>" ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` ExpQ
commandNameParser ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
"unitParser" else ExpQ
commandNameParser)
  let cons :: ExpQ
cons = ExpQ
commandParser ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` (Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
"pure" ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
cName)
  case [Int]
ns of
    [] -> ExpQ
cons
    (Int
n : [Int]
rest) ->
      (Int -> ExpQ -> ExpQ) -> ExpQ -> [Int] -> ExpQ
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Int
i ExpQ
r -> Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
"<*>" ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` ExpQ
r ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Int -> ExpQ
forall {m :: * -> *} {a}. (Quote m, Show a) => a -> m Exp
parseAt Int
i) (Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
"<*>" ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` ExpQ
cons ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Int -> ExpQ
forall {m :: * -> *} {a}. (Quote m, Show a) => a -> m Exp
parseAt Int
n) ([Int] -> [Int]
forall a. [a] -> [a]
reverse [Int]
rest)
      where
        parseAt :: a -> m Exp
parseAt a
i = Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
"coerceParser" m Exp -> m Exp -> m Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"_p" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
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) = Cxt -> Q Cxt
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BangType -> Type
forall a b. (a, b) -> b
snd (BangType -> Type) -> [BangType] -> Cxt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [BangType]
types)
typesOf (RecC Name
_ [VarBangType]
types) = Cxt -> Q Cxt
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Cxt -> Q Cxt) -> Cxt -> Q Cxt
forall a b. (a -> b) -> a -> b
$ (\(Name
_, Bang
_, Type
t) -> Type
t) (VarBangType -> Type) -> [VarBangType] -> Cxt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [VarBangType]
types
typesOf Con
other = do
  Bool -> String -> Q ()
forall (m :: * -> *). Quasi m => Bool -> String -> m ()
qReport Bool
True (String
"we can only create a parser for normal constructors and records, got: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Con -> String
forall a b. (Show a, StringConv String b) => a -> b
show Con
other)
  String -> Q Cxt
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) = [(Maybe Name, Type)] -> Q [(Maybe Name, Type)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Maybe Name, Type)] -> Q [(Maybe Name, Type)])
-> [(Maybe Name, Type)] -> Q [(Maybe Name, Type)]
forall a b. (a -> b) -> a -> b
$ (\(Bang
_, Type
t) -> (Maybe Name
forall a. Maybe a
Nothing, Type
t)) (BangType -> (Maybe Name, Type))
-> [BangType] -> [(Maybe Name, Type)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [BangType]
types
fieldsOf (RecC Name
_ [VarBangType]
types) = [(Maybe Name, Type)] -> Q [(Maybe Name, Type)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Maybe Name, Type)] -> Q [(Maybe Name, Type)])
-> [(Maybe Name, Type)] -> Q [(Maybe Name, Type)]
forall a b. (a -> b) -> a -> b
$ (\(Name
n, Bang
_, Type
t) -> (Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n, Type
t)) (VarBangType -> (Maybe Name, Type))
-> [VarBangType] -> [(Maybe Name, Type)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [VarBangType]
types
fieldsOf Con
other = do
  Bool -> String -> Q ()
forall (m :: * -> *). Quasi m => Bool -> String -> m ()
qReport Bool
True (String
"we can only create a parser for normal constructors and records, got: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Con -> String
forall a b. (Show a, StringConv String b) => a -> b
show Con
other)
  String -> Q [(Maybe Name, Type)]
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]
_) = Name -> Q Name
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
n
nameOf (RecC Name
n [VarBangType]
_) = Name -> Q Name
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
n
nameOf Con
other = do
  Bool -> String -> Q ()
forall (m :: * -> *). Quasi m => Bool -> String -> m ()
qReport Bool
True (String
"we can only create a parser for normal constructors and records, got: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Con -> String
forall a b. (Show a, StringConv String b) => a -> b
show Con
other)
  String -> Q Name
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 =
  [(Maybe Name, Type)] -> ((Maybe Name, Type) -> Q Int) -> Q [Int]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [(Maybe Name, Type)]
constructorFields (((Maybe Name, Type) -> Q Int) -> Q [Int])
-> ((Maybe Name, Type) -> Q Int) -> Q [Int]
forall a b. (a -> b) -> a -> b
$ \(Maybe Name, Type)
f ->
    case (Maybe Name, Type) -> [(Maybe Name, Type)] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
elemIndex (Maybe Name, Type)
f [(Maybe Name, Type)]
allFields of
      Just Int
n -> Int -> Q Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
n
      Maybe Int
Nothing -> String -> Q Int
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Int) -> String -> Q Int
forall a b. (a -> b) -> a -> b
$ String
"the field " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (Maybe Name, Type) -> String
forall a b. (Show a, StringConv String b) => a -> b
show (Maybe Name, Type)
f String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" cannot be found in the list of all the fields " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [(Maybe Name, Type)] -> String
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 = ExpQ -> (Name -> ExpQ) -> Maybe Name -> ExpQ
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
"Positional") (ExpQ -> Name -> ExpQ
forall a b. a -> b -> a
const (ExpQ -> Name -> ExpQ) -> ExpQ -> Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
"NonPositional") Maybe Name
mFieldName
  Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
"fun"
    ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` [Q Pat] -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE
      [Q Pat -> Q Type -> Q Pat
forall (m :: * -> *). Quote m => m Pat -> m Type -> m Pat
sigP (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
"ps") (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
"FieldConfiguration")]
      ( (Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
"parseField" ExpQ -> Q Type -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Type -> m Exp
`appTypeE` Q Type
fieldNameType ExpQ -> Q Type -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Type -> m Exp
`appTypeE` Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
fieldType)
          ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
"ps"
          ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` ExpQ
fieldName
          ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` String -> ExpQ
forall (m :: * -> *). Quote m => String -> m Exp
stringE (Text -> String
forall a b. ConvertText a b => a -> b
toS (Text -> String) -> Text -> String
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 =
  Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
"setNoDefaultValues" ExpQ -> Q Type -> ExpQ
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 ExpQ -> Q Type -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Type -> m Exp
`appTypeE` Type -> Q Type
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 =
  Q TyLit -> Q Type
forall (m :: * -> *). Quote m => m TyLit -> m Type
litT (Q TyLit -> Q Type) -> (Text -> Q TyLit) -> Text -> 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 TyLit) -> (Text -> String) -> Text -> Q TyLit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
forall a b. ConvertText a b => a -> b
toS (Text -> Q Type) -> Text -> Q Type
forall a b. (a -> b) -> a -> b
$ ParserConfiguration -> Text -> Maybe Text -> Text
makeFieldType ParserConfiguration
parserOptions (Text -> Text
dropQualifier (Text -> Text) -> (Name -> Text) -> Name -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Text
forall a b. (Show a, StringConv String b) => a -> b
show (Name -> Text) -> Name -> Text
forall a b. (a -> b) -> a -> b
$ Name
constructorName) (Name -> Text
forall a b. (Show a, StringConv String b) => a -> b
show (Name -> Text) -> Maybe Name -> Maybe Text
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 = Maybe ExpQ -> ExpQ -> Maybe ExpQ -> ExpQ
forall (m :: * -> *).
Quote m =>
Maybe (m Exp) -> m Exp -> Maybe (m Exp) -> m Exp
infixE (ExpQ -> Maybe ExpQ
forall a. a -> Maybe a
Just ExpQ
e1) (Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Text -> String
forall a b. ConvertText a b => a -> b
toS Text
operator)) (ExpQ -> Maybe ExpQ
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 = Name -> Text
forall a b. (Show a, StringConv String b) => a -> b
show (Name -> Text) -> (Type -> Name) -> Type -> Text
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 (Name -> String
forall a b. (Show a, StringConv String b) => a -> b
show (Type -> Name
getTypeName Type
t1) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Name -> String
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 = Text -> Name
forall a. HasCallStack => Text -> a
panic (Text -> Name) -> Text -> Name
forall a b. (a -> b) -> a -> b
$ Text
"getTypeName: Unknown type: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Type -> Text
forall a b. (Show a, StringConv String b) => a -> b
show Type
t