Skip to content

Instantly share code, notes, and snippets.

@kosmikus
Created April 2, 2022 12:55
Show Gist options
  • Save kosmikus/58a374cf8594600e583c088d005ee330 to your computer and use it in GitHub Desktop.
Save kosmikus/58a374cf8594600e583c088d005ee330 to your computer and use it in GitHub Desktop.
CLI parser using generics-sop
{-# 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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment