Gabriella439/optparse-generic
1
1
Fork 0
mirror of https://github.com/Gabriella439/optparse-generic.git synced 2024-11-22 21:48:54 +03:00
Code Issues Projects Releases Wiki Activity

Add ability to set ShortName at Type (#84)

Browse Source
This commit is contained in:
Daniel Winograd-Cort 2021-08-30 12:29:21 -04:00 committed by GitHub
parent b571738af4
commit a8f66ee199
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
1 changed files with 27 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
src/Options/Generic.hs
View File

@ -310,6 +310,7 @@ module Options.Generic (
-- * Help -- * Help
, type (<?>)(..) , type (<?>)(..)
, type (<!>)(..) , type (<!>)(..)
, type (<#>)(..)
, type (:::) , type (:::)
, Wrapped , Wrapped
, Unwrapped , Unwrapped
@ -330,6 +331,7 @@ import Control.Applicative
import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.IO.Class (MonadIO(..))
import Data.Char (isUpper, toLower, toUpper) import Data.Char (isUpper, toLower, toUpper)
import Data.Int (Int8, Int16, Int32, Int64) import Data.Int (Int8, Int16, Int32, Int64)
import Data.Maybe (listToMaybe)
import Data.Monoid import Data.Monoid
import Data.List.NonEmpty (NonEmpty((:|))) import Data.List.NonEmpty (NonEmpty((:|)))
import Data.Proxy import Data.Proxy
@ -683,6 +685,26 @@ instance (ParseFields a, KnownSymbol d) => ParseFields (a <!> d) where
parseFields h m c _ = DefValue <$> parseFields h m c (Just (symbolVal (Proxy :: Proxy d))) parseFields h m c _ = DefValue <$> parseFields h m c (Just (symbolVal (Proxy :: Proxy d)))
instance (ParseFields a, KnownSymbol h) => ParseRecord (a <!> h) instance (ParseFields a, KnownSymbol h) => ParseRecord (a <!> h)
{-| Use this to annotate a field with a type-level char (i.e. a `Symbol`)
representing the short name of the field (only the first character of the
symbol is used):
> data Example = Example
> { foo :: Int <#> "f"
> , bar :: Double <#> "b"
> } deriving (Generic, Show)
-}
newtype (<#>) (field :: *) (value :: Symbol) = ShortName { unShortName :: field } deriving (Generic, Show)
instance (ParseField a, KnownSymbol c) => ParseField (a <#> c) where
parseField h m _ d = ShortName <$> parseField h m (listToMaybe (symbolVal (Proxy :: Proxy c))) d
readField = ShortName <$> readField
metavar _ = metavar (Proxy :: Proxy a)
instance (ParseFields a, KnownSymbol c) => ParseFields (a <#> c) where
parseFields h m _ d = ShortName <$> parseFields h m (listToMaybe (symbolVal (Proxy :: Proxy c))) d
instance (ParseFields a, KnownSymbol h) => ParseRecord (a <#> h)
{-| A 1-tuple, used solely to translate `ParseFields` instances into {-| A 1-tuple, used solely to translate `ParseFields` instances into
`ParseRecord` instances `ParseRecord` instances
-} -}
@ -1172,6 +1194,7 @@ type instance Unwrapped ::: wrapped = Unwrap wrapped
type family Unwrap ty where type family Unwrap ty where
Unwrap (ty <?> helper) = Unwrap ty Unwrap (ty <?> helper) = Unwrap ty
Unwrap (ty <!> defVal) = Unwrap ty Unwrap (ty <!> defVal) = Unwrap ty
Unwrap (ty <#> shrtNm) = Unwrap ty
Unwrap ty = ty Unwrap ty = ty
infixr 0 ::: infixr 0 :::
@ -1212,6 +1235,10 @@ instance GenericUnwrappable (K1 i field) (K1 i c)
=> GenericUnwrappable (K1 i (field <!> defVal)) (K1 i c) where => GenericUnwrappable (K1 i (field <!> defVal)) (K1 i c) where
genericUnwrap (K1 c) = (genericUnwrap :: K1 i field p -> K1 i c p) (K1 (unDefValue c)) genericUnwrap (K1 c) = (genericUnwrap :: K1 i field p -> K1 i c p) (K1 (unDefValue c))
instance GenericUnwrappable (K1 i field) (K1 i c)
=> GenericUnwrappable (K1 i (field <#> defVal)) (K1 i c) where
genericUnwrap (K1 c) = (genericUnwrap :: K1 i field p -> K1 i c p) (K1 (unShortName c))
-- | Unwrap the fields of a constructor -- | Unwrap the fields of a constructor
unwrap :: forall f . Unwrappable f => f Wrapped -> f Unwrapped unwrap :: forall f . Unwrappable f => f Wrapped -> f Unwrapped
unwrap = to . genericUnwrap . from unwrap = to . genericUnwrap . from