diff --git a/lib/cli/src/Cardano/CLI.hs b/lib/cli/src/Cardano/CLI.hs index bac98f6b013..9fade9245d0 100644 --- a/lib/cli/src/Cardano/CLI.hs +++ b/lib/cli/src/Cardano/CLI.hs @@ -6,6 +6,7 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DerivingVia #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -163,7 +164,7 @@ import Data.Text ( Text ) import Data.Text.Class ( FromText (..), TextDecodingError (..), ToText (..), showT, - toTextFromBoundedEnum, fromTextToBoundedEnum, CaseStyle (..) ) + BoundedEnum (..), CaseStyle (..) ) import Data.Text.Read ( decimal ) import Fmt @@ -334,12 +335,8 @@ cmdKey = command "key" $ info (helper <*> cmds) $ mempty data KeyType = Icarus | Trezor | Ledger | Byron deriving (Show, Eq, Generic, Bounded, Enum) + deriving (ToText, FromText) via (BoundedEnum 'KebabLowerCase KeyType) -instance ToText KeyType where - toText = toTextFromBoundedEnum KebabLowerCase - -instance FromText KeyType where - fromText = fromTextToBoundedEnum KebabLowerCase parseKeyType :: Parser (IO KeyType) parseKeyType = toIO . fromText <$> strOption diff --git a/lib/text-class/src/Data/Text/Class.hs b/lib/text-class/src/Data/Text/Class.hs index 8b6744fafb5..9b93184da19 100644 --- a/lib/text-class/src/Data/Text/Class.hs +++ b/lib/text-class/src/Data/Text/Class.hs @@ -2,6 +2,8 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -30,6 +32,7 @@ module Data.Text.Class -- * Helpers , showT , splitAtLastOccurrence + , BoundedEnum (..) ) where import Prelude @@ -42,6 +45,7 @@ import Data.List.Extra ( enumerate ) import Data.Maybe ( isNothing, listToMaybe ) +import Data.Proxy import Data.Text ( Text ) import Data.Text.Read @@ -191,6 +195,30 @@ fromTextToBoundedEnum cs t = filter ((== inputInPascalCase) . fst) $ (Just <$> allValuesInPascalCase) `zip` [0 :: Int ..] + +-- | Newtype wrapper to derive @ToText@ and @FromText@ using @DerivingVia@. +newtype BoundedEnum (s :: CaseStyle) a = BoundedEnum a + +-- Needed to get 'CaseStyle back to the value level +class KnownCaseStyle (s :: CaseStyle) where + caseStyleVal :: Proxy s -> CaseStyle +instance KnownCaseStyle 'CamelCase where caseStyleVal _ = CamelCase +instance KnownCaseStyle 'PascalCase where caseStyleVal _ = PascalCase +instance KnownCaseStyle 'KebabLowerCase where caseStyleVal _ = KebabLowerCase +instance KnownCaseStyle 'SnakeLowerCase where caseStyleVal _ = SnakeLowerCase +instance KnownCaseStyle 'SnakeUpperCase where caseStyleVal _ = SnakeUpperCase +instance KnownCaseStyle 'SpacedLowerCase where caseStyleVal _ = SpacedLowerCase + +instance (KnownCaseStyle s, Bounded a, Enum a, Show a) + => ToText (BoundedEnum s a) where + toText (BoundedEnum x) = + toTextFromBoundedEnum (caseStyleVal (Proxy :: Proxy s)) x + +instance (KnownCaseStyle s, Bounded a, Enum a, Show a) + => FromText (BoundedEnum s a) where + fromText = fmap BoundedEnum . + (fromTextToBoundedEnum (caseStyleVal (Proxy :: Proxy s))) + toCaseStyle :: CaseStyle -> Casing.Identifier String -> String toCaseStyle = \case CamelCase -> Casing.toCamel