Basic CLI generics-sop

GCLI.hs

{-# LANGUAGE AllowAmbiguousTypes     #-}
{-# LANGUAGE DerivingStrategies      #-}
{-# LANGUAGE DeriveAnyClass          #-}
{-# LANGUAGE DeriveGeneric           #-}
{-# LANGUAGE DataKinds               #-}
{-# LANGUAGE PolyKinds               #-}
{-# LANGUAGE FlexibleContexts        #-}
{-# LANGUAGE FlexibleInstances       #-}
{-# LANGUAGE MultiParamTypeClasses   #-}
{-# LANGUAGE ScopedTypeVariables     #-}
{-# LANGUAGE TypeApplications        #-}
{-# LANGUAGE TypeFamilyDependencies  #-}
{-# LANGUAGE TypeOperators           #-}
{-# LANGUAGE UndecidableInstances    #-}
{-# LANGUAGE UndecidableSuperClasses #-}

module GCLI (paramP) where

import Data.Functor

import Options.Applicative
import Generics.SOP
import qualified GHC.Generics as GHC
import Generics.SOP.NP
import Data.Kind (Constraint, Type)
import Data.String (IsString)
import GHC.TypeLits ( Nat, type (+) )
import Generics.SOP.Constraint
import Data.Typeable

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)

-- | For constraining type level lists to be singletons.
class Singleton a

instance Singleton '[x]

{- | Used in 'gsubparsers' 'trans_NP' to reveal enough information and types to be able to build each parser.

A full collection of example instances for 'AllParams' is:

instance AllParams '[FirstParams] FirstParams
  type FieldsOf FirstParams = '[String]

instance AllParams '[SecondParams] SecondParams
  type FieldsOf SecondParams = '[Bool, ()]

In essence, the wildcard instance below should set up all such instances for each `a`.

The very first param, `a` is the overarching CLI result. The second one is the HList representation of the fields
in one of its constructors. All constructors must have exactly one field. The final parameter is the type of that field.
Obviously, the third parameter is trivially deducible from the second param.

Inside, 'FieldsOf' should be the HList representation of the fields within the third param. It's important to notice
that the third param must designate a type with a single constructor, with 0 or more fields.
-}
class
  ( Generic a
  , All Singleton (Code a)
  , HasDatatypeInfo y
  , x ~ '[y]
  , IsProductType y (FieldsOf y)
  , All (And Typeable Read) (FieldsOf y)
  , NSFrom y (Code a)
  ) =>
  Processible a x y
  where
  type FieldsOf y :: [Type]

instance
  ( Generic a
  , All Singleton (Code a)
  , HasDatatypeInfo y
  , Member x (Code a)
  , x ~ '[y]
  , NSFrom y (Code a)
  , Code y ~ '[Head (Code y)]
  , All (And Typeable Read) (FieldsOf y)
  , All Top (FieldsOf y)
  ) =>
  Processible a x y
  where
  type FieldsOf y = Head (Code y)

type family Member e l where
  Member _ '[] = True ~ False
  Member e (e : z) = ()
  Member e (_ : z) = Member e z

-- | [0..n] but for NP and the `n` is derived from `xs`.
rangeNP :: All Top xs => NP (K Int) xs
rangeNP = ana_NP f (K 0)
  where
    f :: K Int (y : ys) -> (K Int y, K Int ys)
    f (K i) = (K i, K $ i + 1)

typeNameOf :: forall x. Typeable x => String
typeNameOf = show . typeRep $ Proxy @x

{- | Parser for each command. This is derived for each of the field types in each of the constructors in `AllParams`.

This is like:

@
MkFirstParams
  <$> strOption
    ( long "fooOne"
      <> metavar "String"
    )
@

from the handwritten parser.
-}
gcommand :: forall a flds. (HasDatatypeInfo a, IsProductType a flds, All (And Typeable Read) flds) => Parser a
gcommand = case hd . constructorInfo . datatypeInfo $ Proxy @a of
  Record _ np ->
    let
      -- Build a `Mod OptionFields` from the field name (--fooOne String). Then pack it into 'Parser'.
      f :: forall x. (Typeable x, Read x) => FieldInfo x -> Parser x
      f (FieldInfo fldName) = option auto $ long fldName <> metavar (typeNameOf @x)
    in
      -- It's always a single constructor data type, pack it into 'Z'.
      fmap (to . SOP . Z)
      -- NP I (Parser flds)
      . hsequence
      -- NP Parser flds
      . hcmap (Proxy @(And Typeable Read)) f
      $ np
  {- This branch uses stuff like `--0`, `--1` and so on for argument names.

  Usually this machinery will only be used with Records though - see above for that.
  -}
  _ ->
    let
      f :: forall x. (Typeable x, Read x) => K Int x -> Parser x
      f (K i) = option auto $ long (show i) <> metavar (typeNameOf @x)
    in fmap (to . SOP . Z)
      . hsequence
      . hcmap (Proxy @(And Typeable Read)) f
      $ rangeNP @flds

type family MapFst xs = r | r -> xs where
  MapFst '[] = '[]
  MapFst ('[x] ': xs) = x ': MapFst xs

-- | Build parsers for each command using `gcommand`, and combine it all into a full `AllParams` parser.
gsubparsers :: forall a. (HasDatatypeInfo a, AllZip (Processible a) (Code a) (MapFst (Code a))) => Mod CommandFields a
gsubparsers =
  mconcat
    -- [Mod CommandFields a]
    . hcollapse @_ @_ @_ @(MapFst (Code a))
    -- NP (K (Mod CommandFields a)) (MapFst (Code a))
    . htrans (Proxy @(Processible a)) f
    -- NP ConstructorInfo (Code a)
    . constructorInfo
    . datatypeInfo
    $ Proxy @a
  where
    {- Creates a 'Mod CommandFields a' (for the command subparser) given constructor info.

    The 'y' hardly matters value wise. But it's used for moral constraints via 'Processible'.
    -}
    f ::
      forall x y.
      Processible a x y =>
      ConstructorInfo x ->
      K (Mod CommandFields a) y
    f x =
      let s = constructorName x
       in K . command s
            -- This is like `firstCommand <&> FirstThing` from the handwritten parser.
            . info (gcommand @y @(FieldsOf y) <&> to . SOP . nsFrom @_ @(Code a))
            $ fullDesc <> progDesc ("Using " ++ s ++ " with given parameters")

{- | This entire machinery is purely to be able to build a 'NS' of any given target,
given an argument that is valid for one of the constructors.

FIXME: A constraint to ensure target does not have multiple constructors with same field type.
-}
class NSFrom y target where
  nsFrom :: y -> NS (NP I) target

instance {-# OVERLAPPING #-} NSFrom x ('[x] : z) where
  nsFrom x = Z $ I x :* Nil

instance NSFrom x z => NSFrom x (_1 : z) where
  nsFrom x = S $ nsFrom @x @z x

-- | The final result.
paramP :: ParserInfo (AllParams, FilePath)
paramP =
  info
    (optP <**> helper)
    ( fullDesc
        <> progDesc "Example CLI"
        <> header "Example CLI"
    )
  where
    optP = liftA2 (,) commandsP outputPathP
    commandsP =
      hsubparser gsubparsers
    outputPathP =
      strOption
        ( short 'o'
            <> metavar "Path"
            <> help "Output path"
        )