CLI parser using generics-sop

Example.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE UndecidableInstances #-}
module Example where

import Data.Kind
import Generics.SOP
import Generics.SOP.NP
import Generics.SOP.NS
import qualified GHC.Generics as GHC
import Options.Applicative

data AllParams = FirstThing FirstParams | SecondThing SecondParams
  deriving stock (GHC.Generic, Show)
  deriving anyclass (Generic, HasDatatypeInfo)

data FirstParams = MkFirstParams {fooOne :: String}
  deriving stock (GHC.Generic, Show)
  deriving anyclass (Generic, HasDatatypeInfo)

data SecondParams = MkSecondParams {fooTwo :: Bool, fooThree :: ()}
  deriving stock (GHC.Generic, Show)
  deriving anyclass (Generic, HasDatatypeInfo)

full :: ParserInfo (AllParams, FilePath)
full =
  info
    (optP <**> helper)
    (fullDesc
      <> progDesc "Example CLI"
      <> header "Example CLI"
    )
  where
    optP = liftA2 (,) commandsP outputPathP
    commandsP = gCommands
    outputPathP =
      strOption
        (short 'o'
          <> metavar "FilePath"
          <> help "Output Path"
        )

ixs_NP :: All Top xs => NP (K Int) xs
ixs_NP =
  ana_NP (\ (K i) -> (K i, K (i + 1))) (K 0)

fieldNames :: (IsProductType a xs, HasDatatypeInfo a) => Proxy a -> NP FieldInfo xs
fieldNames p =
  case constructorInfo (datatypeInfo p) of
    Record _ fi :* Nil -> fi
    _ :* Nil -> map_NP (FieldInfo . show . unK) ixs_NP

typeName :: forall a . HasDatatypeInfo a => K String a
typeName = K (datatypeName (datatypeInfo (Proxy @a)))

constructorNames :: (Generic a, HasDatatypeInfo a) => Proxy a -> NP (K String) (Code a)
constructorNames p =
  map_NP (K . constructorName) (constructorInfo (datatypeInfo p))

gParams ::
  forall a xs .
  (IsProductType a xs, HasDatatypeInfo a, All HasDatatypeInfo xs, All StrOrAuto xs)
  => Parser a
gParams =
  productTypeTo <$>
  sequence_NP
    (czipWith_NP
      (Proxy @StrOrAuto)
      (\ (FieldInfo fn) (K tn) -> option strOrAuto (long fn <> metavar tn))
      (fieldNames (Proxy @a))
      (cpure_NP (Proxy @HasDatatypeInfo) typeName)
    )

class IsCommandCode (xs :: [Type]) where
  gCommand :: Generic a => Injection (NP Parser) (Code a) xs -> Parser a

instance (IsProductType a xs, HasDatatypeInfo a, All HasDatatypeInfo xs, All StrOrAuto xs) => IsCommandCode '[a] where
  gCommand (Fn inj) = to <$> sequence_SOP (SOP (unK (inj (gParams @a :* Nil))))

gCommands ::
  forall a xs .
  (Generic a, HasDatatypeInfo a, All IsCommandCode (Code a))
  => Parser a
gCommands =
  hsubparser
    (mconcat
      (collapse_NP
        (czipWith_NP
          (Proxy @IsCommandCode)
          (\ con (K n) -> K (command n (info (gCommand con) (fullDesc <> progDesc (desc n)))))
          (injections @_ @(NP Parser))
          (constructorNames (Proxy @a))
        )
      )
    )
  where
    desc x = "Using " <> x <> " with given parameters"

class StrOrAuto a where
  strOrAuto :: ReadM a

instance {-# OVERLAPS #-} StrOrAuto String where
  strOrAuto = str

instance Read a => StrOrAuto a where
  strOrAuto = auto