{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE CPP #-}

-- | This module is designed to provide a @TemplateHaskell@ alternative to
-- "Options.Generic".
module Options.TH
  ( deriveParseRecord,
    module Options.Generic,
  )
where

import Data.Foldable (asum)
import Control.Applicative
import Data.List (foldl')
import Data.List.NonEmpty (NonEmpty (..))
import Data.List.NonEmpty qualified as NonEmpty
import Data.Text qualified as T
import Data.Traversable
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Options.Applicative qualified as Options
import Options.Generic

-- | This function derives 'ParseRecord' for you without incurring a 'Generic'
-- dependency.
--
-- The main barrier here to fully supporting the library is that the API for
-- 'ParseRecord' does not expose the function that provides modifiers by
-- default. So we can provide an instance of 'ParseRecord', but we can't provide
-- a replacement of 'parseRecordWithModifiers', because that function is defined
-- as a top-level that delegates directly to the generic.
--
-- @
-- parseRecordWithModifiers
--     :: (Generic a, GenericParseRecord (Rep a))
--     => Modifiers
--     -> Parser
-- parseRecordWithModifiers modifiers =
--     fmap GHC.Generics.to (genericParseRecord modifiers)
-- @
--
-- This means that we need to shift the options to the compile-time site,
-- instead of the runtime site.
--
-- Likewise, we cannot provide an instance of 'Unwrappable', because it's not
-- a class - it's a type alias for 'Generic' stuff. So we need to create
-- a separate top-level function that does the unwrap.
--
-- @since 0.1.0.0
deriveParseRecord :: Modifiers -> Name -> Q [Dec]
deriveParseRecord :: Modifiers -> Name -> Q [Dec]
deriveParseRecord Modifiers
modifiers Name
tyName = do
  Info
tyInfo <- Name -> Q Info
reify Name
tyName

  Datatype
datatype <-
    Name -> Info -> Q Datatype
getDatatypeForInfo Name
tyName Info
tyInfo


  forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 forall a. Semigroup a => a -> a -> a
(<>) (Modifiers -> Datatype -> Q [Dec]
datatypeToInstanceDec Modifiers
modifiers Datatype
datatype) (Name -> Datatype -> Q [Dec]
datatypeToUnwrapRecordDec Name
tyName Datatype
datatype)

datatypeToUnwrapRecordDec :: Name -> Datatype -> Q [Dec]
datatypeToUnwrapRecordDec :: Name -> Datatype -> Q [Dec]
datatypeToUnwrapRecordDec Name
typeName Datatype
datatype = do
  if Datatype -> Bool
datatypeIsWrapped Datatype
datatype
    then do
      let fnName :: Name
fnName =
            String -> Name
mkName (String
"unwrapRecord" forall a. Semigroup a => a -> a -> a
<> Name -> String
nameBase Name
typeName)
          fnType :: Q Type
fnType =
            [t|$(conT typeName) Wrapped -> $(conT typeName) Unwrapped|]
          fnExpr :: Q Exp
fnExpr = Datatype -> Q Exp
mkUnwrapRecordExpr Datatype
datatype
          fnSig :: Q Dec
fnSig = Name -> Type -> Dec
SigD Name
fnName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Type
fnType
      (:)
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Dec
fnSig
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [d|
          $(varP fnName) = $(fnExpr)
          |]
    else do
      forall (f :: * -> *) a. Applicative f => a -> f a
pure []

mkUnwrapRecordExpr :: Datatype -> Q Exp
mkUnwrapRecordExpr :: Datatype -> Q Exp
mkUnwrapRecordExpr Datatype
datatype = do
  let mkMatch :: Con -> Q Match
mkMatch Con
con =
        case Con
con of
          NormalC Name
name [BangType]
bangTyps -> do
            (Pat
pat, [(Name, Type)]
namesAndTypes) <- do
              [(Name, Type)]
namesAndTypes <-
                forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [BangType]
bangTyps \(Bang
_bang, Type
typ) -> do
                  Name
n <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
                  forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name
n, Type
typ)

              forall (f :: * -> *) a. Applicative f => a -> f a
pure
                ( Name -> [Pat] -> Pat
mkConP Name
name (forall a b. (a -> b) -> [a] -> [b]
map (\(Name
varName, Type
_fieldType) -> Name -> Pat
VarP Name
varName) [(Name, Type)]
namesAndTypes)
                , [(Name, Type)]
namesAndTypes
                )
            Body
body <- do
              let constr :: Exp
constr = Name -> Exp
ConE Name
name
              [Exp]
fields <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Name, Type) -> Q Exp
unwrapFields [(Name, Type)]
namesAndTypes
              forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Exp -> Body
NormalB forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Exp -> Exp -> Exp
AppE Exp
constr [Exp]
fields
            let decs :: [a]
decs =
                  []
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
              Pat -> Body -> [Dec] -> Match
Match Pat
pat Body
body forall a. [a]
decs
          RecC Name
name [VarBangType]
varBangTypes -> do
            (Pat
pat, [(Name, Type)]
varNames) <- do
              [(Name, Type)]
varNames <-
                forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [VarBangType]
varBangTypes \(Name
_fieldName, Bang
_bang, Type
typ) -> do
                  Name
n <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
                  forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name
n, Type
typ)

              forall (f :: * -> *) a. Applicative f => a -> f a
pure
                ( Name -> [Pat] -> Pat
mkConP Name
name (forall a b. (a -> b) -> [a] -> [b]
map (\(Name
varName, Type
_fieldType) -> Name -> Pat
VarP Name
varName) [(Name, Type)]
varNames)
                , [(Name, Type)]
varNames
                )
            Body
body <- do
              let constr :: Exp
constr = Name -> Exp
ConE Name
name
              [Exp]
fields <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Name, Type) -> Q Exp
unwrapFields [(Name, Type)]
varNames
              forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Exp -> Body
NormalB forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Exp -> Exp -> Exp
AppE Exp
constr [Exp]
fields
            let decs :: [a]
decs =
                  []
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
              Pat -> Body -> [Dec] -> Match
Match Pat
pat Body
body forall a. [a]
decs
          Con
_ ->
            forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$
              [String] -> String
unlines
                [ String
"Unexpected constructor in mkUnwrapRecordExpr: "
                , String
"  " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Con
con
                ]

  NonEmpty Match
matches <-
    forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Con -> Q Match
mkMatch (Datatype -> NonEmpty Con
datatypeConstructors Datatype
datatype)

  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Match] -> Exp
LamCaseE (forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty Match
matches)

-- | Test the type of the field. If it is unwrappable, unwrap it until it isn't.
unwrapFields :: (Name, Type) -> Q Exp
unwrapFields :: (Name, Type) -> Q Exp
unwrapFields (Name
varName, Type
varTyp) =
  case Type
varTyp of
    AppT
      ( AppT
          (ConT ((forall a. Eq a => a -> a -> Bool
== ''(Options.Generic.:::)) -> Bool
True))
          (VarT Name
_)
        )
      Type
rest -> do
        Name -> Type -> Q Exp
tryUnwrapping Name
varName Type
rest
    Type
_ ->
      forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
varName

-- | The goal of this function is to test to see if the constructor is
-- unwrappable: that is, one of <?>, <!>, or <#>.
--
-- If it is unwrappable, then we call the relevant function. Note that we have
-- to try multiple times, since you can put a wrapper in any order.
tryUnwrapping :: Name -> Type -> Q Exp
tryUnwrapping :: Name -> Type -> Q Exp
tryUnwrapping Name
varName = [Exp] -> Type -> Q Exp
go []
  where
    go :: [Exp] -> Type -> Q Exp
go [Exp]
fns Type
varTyp = do
      case Type
varTyp of
        ( AppT
            (ConT ((forall a. Eq a => a -> a -> Bool
== ''(Options.Generic.<?>)) -> Bool
True))
            Type
rest
          )
          `AppT` Type
_helpText ->
            do
              [Exp] -> Type -> Q Exp
go (Name -> Exp
VarE 'unHelpful forall a. a -> [a] -> [a]
: [Exp]
fns) Type
rest
        AppT
          ( AppT
              (ConT ((forall a. Eq a => a -> a -> Bool
== ''(Options.Generic.<!>)) -> Bool
True))
              Type
rest
            )
          Type
_defVal ->
            do
              [Exp] -> Type -> Q Exp
go (Name -> Exp
VarE 'unDefValue forall a. a -> [a] -> [a]
: [Exp]
fns) Type
rest
        AppT
          ( AppT
              (ConT ((forall a. Eq a => a -> a -> Bool
== ''(Options.Generic.<#>)) -> Bool
True))
              Type
rest
            )
          Type
_shortLabel ->
            [Exp] -> Type -> Q Exp
go (Name -> Exp
VarE 'unShortName forall a. a -> [a] -> [a]
: [Exp]
fns) Type
rest
        Type
_ -> do
          forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Exp
fn Q Exp
acc -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
fn forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
acc) (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
varName) [Exp]
fns

getDatatypeForInfo :: Name -> Info -> Q Datatype
getDatatypeForInfo :: Name -> Info -> Q Datatype
getDatatypeForInfo Name
tyName Info
tyInfo =
  case Info
tyInfo of
    TyConI Dec
dec ->
      case Dec
dec of
        DataD Cxt
_xct Name
name [TyVarBndr ()]
bndrs Maybe Type
_mkind [Con]
constructors [DerivClause]
_derivs -> do
          case [Con]
constructors of
            [] ->
              forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$
                [String] -> String
unlines
                  [ String
"A `ParseRecord` instance can't be generated for the following type:"
                  , String
"  " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Name
tyName
                  , String
"... because it has no constructors."
                  ]
            (Con
c : [Con]
cs) -> do
              forall (f :: * -> *) a. Applicative f => a -> f a
pure
                Datatype
                  { datatypeName :: Name
datatypeName =
                      Name
name
                  , datatypeConstructors :: NonEmpty Con
datatypeConstructors =
                      Con
c forall a. a -> [a] -> NonEmpty a
:| [Con]
cs
                  , datatypeIsWrapped :: Bool
datatypeIsWrapped =
                      Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVarBndr ()]
bndrs)
                  }
        NewtypeD Cxt
_cxt Name
name [TyVarBndr ()]
bndrs Maybe Type
_mkind Con
constructor [DerivClause]
_derivs -> do
          forall (f :: * -> *) a. Applicative f => a -> f a
pure
            Datatype
              { datatypeName :: Name
datatypeName =
                  Name
name
              , datatypeConstructors :: NonEmpty Con
datatypeConstructors =
                  forall (f :: * -> *) a. Applicative f => a -> f a
pure Con
constructor
              , datatypeIsWrapped :: Bool
datatypeIsWrapped =
                  Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVarBndr ()]
bndrs)
              }
        Dec
_ ->
          forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$
            [String] -> String
unlines
              [ String
"Internal error: Options.TH.getDatatypeForInfo."
              , String
""
              , String
"This is not your fault. Open a bug report and include the following error for the context in the report: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Dec
dec
              , String
"The GHC API provided a `TyConI` wrapping a declaration that was not a `data` or `newtype` declaration, which should never happen."
              ]
    Info
_ -> do
      forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$
        forall a. Monoid a => [a] -> a
mconcat
          [ String
"Expected a type constructor in 'deriveParseRecord', got: "
          , String
"\n\t"
          , forall a. Show a => a -> String
show Info
tyInfo
          ]

data Datatype = Datatype
  { Datatype -> Name
datatypeName :: Name
  , Datatype -> Bool
datatypeIsWrapped :: Bool
  , Datatype -> NonEmpty Con
datatypeConstructors :: NonEmpty Con
  }

datatypeToInstanceDec :: Modifiers -> Datatype -> Q [Dec]
datatypeToInstanceDec :: Modifiers -> Datatype -> Q [Dec]
datatypeToInstanceDec Modifiers
mods Datatype {Bool
NonEmpty Con
Name
datatypeConstructors :: NonEmpty Con
datatypeIsWrapped :: Bool
datatypeName :: Name
datatypeName :: Datatype -> Name
datatypeConstructors :: Datatype -> NonEmpty Con
datatypeIsWrapped :: Datatype -> Bool
..} = do
  let saturatedType :: Type
saturatedType =
        if Bool
datatypeIsWrapped
          then Name -> Type
ConT Name
datatypeName Type -> Type -> Type
`AppT` Name -> Type
ConT ''Wrapped
          else Name -> Type
ConT Name
datatypeName

  Exp
parseRecordExpr <-
    case NonEmpty Con
datatypeConstructors of
      Con
singleConstructor :| [] -> do
        Modifiers -> Con -> Q Exp
makeSingleCommand Modifiers
mods Con
singleConstructor
      NonEmpty Con
subcommands -> do
        [|asum|] forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE (forall a. NonEmpty a -> [a]
NonEmpty.toList (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Modifiers -> Con -> Q Exp
makeSubcommand Modifiers
mods) NonEmpty Con
subcommands))

  [d|
    instance ParseRecord $(pure saturatedType) where
      parseRecord =
        Options.helper <*> $(pure parseRecordExpr)
    |]

-- | This function should be called on a single constructor. No subcommand
-- should be created.
makeSingleCommand :: Modifiers -> Con -> Q Exp
makeSingleCommand :: Modifiers -> Con -> Q Exp
makeSingleCommand Modifiers {String -> String
String -> Maybe Char
fieldNameModifier :: Modifiers -> String -> String
constructorNameModifier :: Modifiers -> String -> String
shortNameModifier :: Modifiers -> String -> Maybe Char
shortNameModifier :: String -> Maybe Char
constructorNameModifier :: String -> String
fieldNameModifier :: String -> String
..} Con
con = do
  case Con
con of
    NormalC Name
conName [BangType]
bangTypes -> do
      -- In this case, we want to create a parser that parses the arguments as
      -- positional arguments.
      Exp
baseCase <- [e|pure $(conE conName)|]

      let apps :: m Exp -> (a, b) -> m Exp
apps m Exp
expr (a
_bang, b
_type) = do
            let label :: Maybe Text
label = forall a. Maybe a
Nothing @Text
                shortName :: Maybe Char
shortName = forall a. Maybe a
Nothing @Char
            forall (m :: * -> *).
Quote m =>
Maybe (m Exp) -> m Exp -> Maybe (m Exp) -> m Exp
infixE (forall a. a -> Maybe a
Just m Exp
expr) (forall (m :: * -> *). Quote m => Name -> m Exp
varE '(<*>)) (forall a. a -> Maybe a
Just [e|parseFields Nothing $(lift label) $(lift shortName) Nothing|])

      forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall {m :: * -> *} {a} {b}. Quote m => m Exp -> (a, b) -> m Exp
apps (forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
baseCase) [BangType]
bangTypes
    RecC Name
conName [VarBangType]
varBangTypes -> do
      -- In this case, we want to create a parser that will use the field names.
      Exp
baseCase <- [e|pure $(conE conName)|]
      let apps :: Q Exp -> VarBangType -> Q Exp
apps Q Exp
expr (Name
fieldName, Bang
_bang, Type
_type) = do
            let fieldNameString :: String
fieldNameString =
                  Name -> String
nameBase Name
fieldName
                label :: Maybe Text
label =
                  forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
fieldNameModifier forall a b. (a -> b) -> a -> b
$ String
fieldNameString
                shortName :: Maybe Char
shortName =
                  String -> Maybe Char
shortNameModifier String
fieldNameString
            forall (m :: * -> *).
Quote m =>
Maybe (m Exp) -> m Exp -> Maybe (m Exp) -> m Exp
infixE (forall a. a -> Maybe a
Just Q Exp
expr) (forall (m :: * -> *). Quote m => Name -> m Exp
varE '(<*>)) (forall a. a -> Maybe a
Just [e|parseFields Nothing $(lift label) $(lift shortName) Nothing|])

      forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Q Exp -> VarBangType -> Q Exp
apps (forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
baseCase) [VarBangType]
varBangTypes
    Con
_ ->
      forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$
        [String] -> String
unlines
          [ String
"Expected either a normal or record constructor, got: "
          , String
"\t" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Con
con
          , String
"Other constructors are not supported yet."
          ]

getConName :: Con -> Q Name
getConName :: Con -> Q Name
getConName = \case
  NormalC Name
n [BangType]
_ ->
    forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
n
  RecC Name
n [VarBangType]
_ ->
    forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
n
  Con
other ->
    forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$
      [String] -> String
unlines
        [ String
"Expected a normal or record constructor, got unsupported constructor: "
        , String
"\t" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Con
other
        ]

-- | This function should be called with a datatype consisting of multiple
-- constructors. The constructor will be converted into a subcommand name.
makeSubcommand :: Modifiers -> Con -> Q Exp
makeSubcommand :: Modifiers -> Con -> Q Exp
makeSubcommand modifiers :: Modifiers
modifiers@Modifiers {String -> String
String -> Maybe Char
shortNameModifier :: String -> Maybe Char
constructorNameModifier :: String -> String
fieldNameModifier :: String -> String
fieldNameModifier :: Modifiers -> String -> String
constructorNameModifier :: Modifiers -> String -> String
shortNameModifier :: Modifiers -> String -> Maybe Char
..} Con
con = do
  Name
conName <- Con -> Q Name
getConName Con
con
  Exp
singleCommandParserExpr <- Modifiers -> Con -> Q Exp
makeSingleCommand Modifiers
modifiers Con
con
  let conNameString :: String
conNameString =
        Name -> String
nameBase Name
conName
      name :: String
name =
        String -> String
constructorNameModifier String
conNameString

  Exp
subparserFieldsExpr <-
    [e|
      Options.command
        $(lift name)
        ( Options.info (Options.helper <*> $(pure singleCommandParserExpr)) mempty
        )
        <> Options.metavar $(lift name)
      |]

  [e|Options.subparser $(pure subparserFieldsExpr)|]

#if MIN_VERSION_template_haskell(2,18,0)
mkConP :: Name -> [Pat] -> Pat
mkConP :: Name -> [Pat] -> Pat
mkConP Name
name [Pat]
pats = Name -> Cxt -> [Pat] -> Pat
ConP Name
name [] [Pat]
pats
#else
mkConP :: Name -> [Pat] -> Pat
mkConP name pats = ConP name pats
#endif