{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}

-- |
-- Copyright: © 2018-2020 IOHK
-- License: Apache-2.0
--
-- Extend the 'Data.Text' module with an extra abstraction to encode and decode
-- values safely to and from 'Text'. It's very similar to 'FromJSON' and
-- 'ToJSON' from 'Data.Aeson'.

module Data.Text.Class
    ( -- * Producing and consuming text from arbitrary types
      ToText (..)
    , FromText (..)
    , TextDecodingError(..)
    , fromTextMaybe

      -- * Producing and consuming text from bounded enumeration types
    , CaseStyle (..)
    , toTextFromBoundedEnum
    , fromTextToBoundedEnum

      -- * Helpers
    , showT
    ) where

import Prelude

import Control.Monad
    ( unless, (<=<) )
import Data.Bifunctor
    ( bimap, first )
import Data.List
    ( find )
import Data.List.Extra
    ( enumerate )
import Data.Maybe
    ( listToMaybe )
import Data.Text
    ( Text )
import Data.Text.Read
    ( decimal, signed )
import Data.Time.Clock
    ( NominalDiffTime )
import Data.Word
    ( Word32, Word64 )
import Data.Word.Odd
    ( Word31 )
import Formatting
    ( builder, sformat )
import Formatting.Buildable
    ( Buildable (..) )
import GHC.Generics
    ( Generic )
import Numeric.Natural
    ( Natural )
import Text.Read
    ( readEither )

import qualified Data.Char as C
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as B
import qualified Data.Text.Lazy.Builder.Int as B
import qualified Data.Text.Lazy.Builder.RealFloat as B
import qualified Text.Casing as Casing

{-------------------------------------------------------------------------------
                                     Types
-------------------------------------------------------------------------------}

-- | Defines a textual encoding for a type.
class ToText a where
    -- | Encode the specified value as text.
    toText :: a -> Text

    default toText :: Buildable a => a -> Text
    toText = Format Text (Builder -> Text) -> Builder -> Text
forall a. Format Text a -> a
sformat Format Text (Builder -> Text)
forall r. Format r (Builder -> r)
builder (Builder -> Text) -> (a -> Builder) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Builder
forall p. Buildable p => p -> Builder
build

-- | Defines a textual decoding for a type.
class FromText a where
    -- | Decode the specified text as a value.
    fromText :: Text -> Either TextDecodingError a

-- | Indicates an error that occurred while decoding from text.
newtype TextDecodingError = TextDecodingError
    { TextDecodingError -> String
getTextDecodingError :: String }
    deriving stock (TextDecodingError -> TextDecodingError -> Bool
(TextDecodingError -> TextDecodingError -> Bool)
-> (TextDecodingError -> TextDecodingError -> Bool)
-> Eq TextDecodingError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TextDecodingError -> TextDecodingError -> Bool
$c/= :: TextDecodingError -> TextDecodingError -> Bool
== :: TextDecodingError -> TextDecodingError -> Bool
$c== :: TextDecodingError -> TextDecodingError -> Bool
Eq, Int -> TextDecodingError -> ShowS
[TextDecodingError] -> ShowS
TextDecodingError -> String
(Int -> TextDecodingError -> ShowS)
-> (TextDecodingError -> String)
-> ([TextDecodingError] -> ShowS)
-> Show TextDecodingError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TextDecodingError] -> ShowS
$cshowList :: [TextDecodingError] -> ShowS
show :: TextDecodingError -> String
$cshow :: TextDecodingError -> String
showsPrec :: Int -> TextDecodingError -> ShowS
$cshowsPrec :: Int -> TextDecodingError -> ShowS
Show)
    deriving newtype TextDecodingError -> Builder
(TextDecodingError -> Builder) -> Buildable TextDecodingError
forall p. (p -> Builder) -> Buildable p
build :: TextDecodingError -> Builder
$cbuild :: TextDecodingError -> Builder
Buildable

-- | Decode the specified text with a 'Maybe' result type.
fromTextMaybe :: FromText a => Text -> Maybe a
fromTextMaybe :: Text -> Maybe a
fromTextMaybe = (TextDecodingError -> Maybe a)
-> (a -> Maybe a) -> Either TextDecodingError a -> Maybe a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe a -> TextDecodingError -> Maybe a
forall a b. a -> b -> a
const Maybe a
forall a. Maybe a
Nothing) a -> Maybe a
forall a. a -> Maybe a
Just (Either TextDecodingError a -> Maybe a)
-> (Text -> Either TextDecodingError a) -> Text -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either TextDecodingError a
forall a. FromText a => Text -> Either TextDecodingError a
fromText

{-------------------------------------------------------------------------------
                                   Instances
-------------------------------------------------------------------------------}

instance FromText String where
    fromText :: Text -> Either TextDecodingError String
fromText = String -> Either TextDecodingError String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Either TextDecodingError String)
-> (Text -> String) -> Text -> Either TextDecodingError String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack

instance ToText String where
    toText :: String -> Text
toText = String -> Text
T.pack

instance FromText Text where
    fromText :: Text -> Either TextDecodingError Text
fromText = Text -> Either TextDecodingError Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure

instance ToText Text where
    toText :: Text -> Text
toText = Text -> Text
forall a. a -> a
id

instance FromText Int where
    fromText :: Text -> Either TextDecodingError Int
fromText Text
t = do
        (Int
parsedValue, Text
unconsumedInput) <- (String -> TextDecodingError)
-> Either String (Int, Text)
-> Either TextDecodingError (Int, Text)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (TextDecodingError -> String -> TextDecodingError
forall a b. a -> b -> a
const TextDecodingError
err) (Either String (Int, Text) -> Either TextDecodingError (Int, Text))
-> Either String (Int, Text)
-> Either TextDecodingError (Int, Text)
forall a b. (a -> b) -> a -> b
$ Reader Int -> Reader Int
forall a. Num a => Reader a -> Reader a
signed Reader Int
forall a. Integral a => Reader a
decimal Text
t
        Bool -> Either TextDecodingError () -> Either TextDecodingError ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text -> Bool
T.null Text
unconsumedInput) (Either TextDecodingError () -> Either TextDecodingError ())
-> Either TextDecodingError () -> Either TextDecodingError ()
forall a b. (a -> b) -> a -> b
$ TextDecodingError -> Either TextDecodingError ()
forall a b. a -> Either a b
Left TextDecodingError
err
        Int -> Either TextDecodingError Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
parsedValue
      where
        err :: TextDecodingError
err = String -> TextDecodingError
TextDecodingError (String -> TextDecodingError) -> String -> TextDecodingError
forall a b. (a -> b) -> a -> b
$
            String
"Int is an integer number between "
                String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (Bounded Int => Int
forall a. Bounded a => a
minBound @Int)
                String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" and "
                String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (Bounded Int => Int
forall a. Bounded a => a
maxBound @Int)
                String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"."

instance ToText Int where
    toText :: Int -> Text
toText = Int -> Text
forall a. Integral a => a -> Text
intToText

instance FromText Natural where
    fromText :: Text -> Either TextDecodingError Natural
fromText Text
t = do
        (Natural
parsedValue, Text
unconsumedInput) <- (String -> TextDecodingError)
-> Either String (Natural, Text)
-> Either TextDecodingError (Natural, Text)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (TextDecodingError -> String -> TextDecodingError
forall a b. a -> b -> a
const TextDecodingError
err) (Either String (Natural, Text)
 -> Either TextDecodingError (Natural, Text))
-> Either String (Natural, Text)
-> Either TextDecodingError (Natural, Text)
forall a b. (a -> b) -> a -> b
$ Reader Natural
forall a. Integral a => Reader a
decimal Text
t
        Bool -> Either TextDecodingError () -> Either TextDecodingError ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text -> Bool
T.null Text
unconsumedInput) (Either TextDecodingError () -> Either TextDecodingError ())
-> Either TextDecodingError () -> Either TextDecodingError ()
forall a b. (a -> b) -> a -> b
$ TextDecodingError -> Either TextDecodingError ()
forall a b. a -> Either a b
Left TextDecodingError
err
        Natural -> Either TextDecodingError Natural
forall (f :: * -> *) a. Applicative f => a -> f a
pure Natural
parsedValue
      where
        err :: TextDecodingError
err = String -> TextDecodingError
TextDecodingError String
"Expecting natural number"

instance ToText Natural where
    toText :: Natural -> Text
toText = Natural -> Text
forall a. Integral a => a -> Text
intToText

instance FromText Word32 where
    fromText :: Text -> Either TextDecodingError Word32
fromText =
        Word32 -> Either TextDecodingError Word32
validate (Word32 -> Either TextDecodingError Word32)
-> (Text -> Either TextDecodingError Word32)
-> Text
-> Either TextDecodingError Word32
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< ((Natural -> Word32)
-> Either TextDecodingError Natural
-> Either TextDecodingError Word32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Natural -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Either TextDecodingError Natural
 -> Either TextDecodingError Word32)
-> (Text -> Either TextDecodingError Natural)
-> Text
-> Either TextDecodingError Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FromText Natural => Text -> Either TextDecodingError Natural
forall a. FromText a => Text -> Either TextDecodingError a
fromText @Natural)
      where
        validate :: Word32 -> Either TextDecodingError Word32
validate Word32
x
            | (Word32
x Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
>= (Bounded Word32 => Word32
forall a. Bounded a => a
minBound @Word32)) Bool -> Bool -> Bool
&& (Word32
x Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
<= (Bounded Word32 => Word32
forall a. Bounded a => a
maxBound @Word32))  =
                Word32 -> Either TextDecodingError Word32
forall (m :: * -> *) a. Monad m => a -> m a
return Word32
x
            | Bool
otherwise =
                TextDecodingError -> Either TextDecodingError Word32
forall a b. a -> Either a b
Left (TextDecodingError -> Either TextDecodingError Word32)
-> TextDecodingError -> Either TextDecodingError Word32
forall a b. (a -> b) -> a -> b
$ String -> TextDecodingError
TextDecodingError String
"Word32 is out of bounds"

instance FromText Integer where
    fromText :: Text -> Either TextDecodingError Integer
fromText Text
t = do
        (Integer
parsedValue, Text
unconsumedInput) <- (String -> TextDecodingError)
-> Either String (Integer, Text)
-> Either TextDecodingError (Integer, Text)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (TextDecodingError -> String -> TextDecodingError
forall a b. a -> b -> a
const TextDecodingError
err) (Either String (Integer, Text)
 -> Either TextDecodingError (Integer, Text))
-> Either String (Integer, Text)
-> Either TextDecodingError (Integer, Text)
forall a b. (a -> b) -> a -> b
$ Reader Integer -> Reader Integer
forall a. Num a => Reader a -> Reader a
signed Reader Integer
forall a. Integral a => Reader a
decimal Text
t
        Bool -> Either TextDecodingError () -> Either TextDecodingError ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text -> Bool
T.null Text
unconsumedInput) (Either TextDecodingError () -> Either TextDecodingError ())
-> Either TextDecodingError () -> Either TextDecodingError ()
forall a b. (a -> b) -> a -> b
$ TextDecodingError -> Either TextDecodingError ()
forall a b. a -> Either a b
Left TextDecodingError
err
        Integer -> Either TextDecodingError Integer
forall (f :: * -> *) a. Applicative f => a -> f a
pure Integer
parsedValue
      where
        err :: TextDecodingError
err = String -> TextDecodingError
TextDecodingError String
"Expecting integer"

instance ToText Integer where
    toText :: Integer -> Text
toText = Integer -> Text
forall a. Integral a => a -> Text
intToText

instance FromText Double where
    fromText :: Text -> Either TextDecodingError Double
fromText = (String -> TextDecodingError)
-> Either String Double -> Either TextDecodingError Double
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (TextDecodingError -> String -> TextDecodingError
forall a b. a -> b -> a
const TextDecodingError
err) (Either String Double -> Either TextDecodingError Double)
-> (Text -> Either String Double)
-> Text
-> Either TextDecodingError Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String Double
forall a. Read a => String -> Either String a
readEither (String -> Either String Double)
-> (Text -> String) -> Text -> Either String Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack
      where
        err :: TextDecodingError
err = String -> TextDecodingError
TextDecodingError String
"Expecting floating number"

instance ToText Double where
    toText :: Double -> Text
toText = Double -> Text
forall a. RealFloat a => a -> Text
realFloatToText

instance ToText Word64 where
    toText :: Word64 -> Text
toText = Word64 -> Text
forall a. Integral a => a -> Text
intToText

instance ToText Word32 where
    toText :: Word32 -> Text
toText = Word32 -> Text
forall a. Integral a => a -> Text
intToText

instance ToText Word31 where
    toText :: Word31 -> Text
toText = Word31 -> Text
forall a. Integral a => a -> Text
intToText

instance ToText NominalDiffTime where
    toText :: NominalDiffTime -> Text
toText = String -> Text
T.pack (String -> Text)
-> (NominalDiffTime -> String) -> NominalDiffTime -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NominalDiffTime -> String
forall a. Show a => a -> String
show

-- Note: This parser doesn't allow fractional or negative durations.
instance FromText NominalDiffTime where
    fromText :: Text -> Either TextDecodingError NominalDiffTime
fromText Text
t = case Text -> Text -> [Text]
T.splitOn Text
"s" Text
t of
        [Text
v,Text
""] -> (TextDecodingError -> TextDecodingError)
-> (Natural -> NominalDiffTime)
-> Either TextDecodingError Natural
-> Either TextDecodingError NominalDiffTime
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (TextDecodingError -> TextDecodingError -> TextDecodingError
forall a b. a -> b -> a
const TextDecodingError
err) (forall b. (Integral Natural, Num b) => Natural -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral @Natural) (Text -> Either TextDecodingError Natural
forall a. FromText a => Text -> Either TextDecodingError a
fromText Text
v)
        [Text]
_ -> TextDecodingError -> Either TextDecodingError NominalDiffTime
forall a b. a -> Either a b
Left TextDecodingError
err
      where
        err :: TextDecodingError
err = String -> TextDecodingError
TextDecodingError (String -> TextDecodingError) -> String -> TextDecodingError
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords
            [ String
"Cannot parse given time duration."
            , String
"Values must be given as whole positive seconds, and must"
            , String
"finish with \"s\". For example: \"3s\", \"3600s\", \"42s\"."
            ]

realFloatToText :: RealFloat a => a -> T.Text
realFloatToText :: a -> Text
realFloatToText = Text -> Text
TL.toStrict (Text -> Text) -> (a -> Text) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Text
B.toLazyText (Builder -> Text) -> (a -> Builder) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Builder
forall a. RealFloat a => a -> Builder
B.realFloat

intToText :: Integral a => a -> T.Text
intToText :: a -> Text
intToText = Text -> Text
TL.toStrict (Text -> Text) -> (a -> Text) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Text
B.toLazyText (Builder -> Text) -> (a -> Builder) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Builder
forall a. Integral a => a -> Builder
B.decimal

{-------------------------------------------------------------------------------
                            Formatting enums as text
-------------------------------------------------------------------------------}

-- | Represents a case style for multi-word strings.
data CaseStyle
    = CamelCase
      -- ^ A string in the style of "doNotRepeatYourself"
    | PascalCase
      -- ^ A string in the style of "DoNotRepeatYourself"
    | KebabLowerCase
      -- ^ A string in the style of "do-not-repeat-yourself"
    | SnakeLowerCase
      -- ^ A string in the style of "do_not_repeat_yourself"
    | SnakeUpperCase
      -- ^ A string in the style of "DO_NOT_REPEAT_YOURSELF"
    | SpacedLowerCase
      -- ^ A string in the style of "do not repeat yourself"
    deriving (CaseStyle
CaseStyle -> CaseStyle -> Bounded CaseStyle
forall a. a -> a -> Bounded a
maxBound :: CaseStyle
$cmaxBound :: CaseStyle
minBound :: CaseStyle
$cminBound :: CaseStyle
Bounded, Int -> CaseStyle
CaseStyle -> Int
CaseStyle -> [CaseStyle]
CaseStyle -> CaseStyle
CaseStyle -> CaseStyle -> [CaseStyle]
CaseStyle -> CaseStyle -> CaseStyle -> [CaseStyle]
(CaseStyle -> CaseStyle)
-> (CaseStyle -> CaseStyle)
-> (Int -> CaseStyle)
-> (CaseStyle -> Int)
-> (CaseStyle -> [CaseStyle])
-> (CaseStyle -> CaseStyle -> [CaseStyle])
-> (CaseStyle -> CaseStyle -> [CaseStyle])
-> (CaseStyle -> CaseStyle -> CaseStyle -> [CaseStyle])
-> Enum CaseStyle
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: CaseStyle -> CaseStyle -> CaseStyle -> [CaseStyle]
$cenumFromThenTo :: CaseStyle -> CaseStyle -> CaseStyle -> [CaseStyle]
enumFromTo :: CaseStyle -> CaseStyle -> [CaseStyle]
$cenumFromTo :: CaseStyle -> CaseStyle -> [CaseStyle]
enumFromThen :: CaseStyle -> CaseStyle -> [CaseStyle]
$cenumFromThen :: CaseStyle -> CaseStyle -> [CaseStyle]
enumFrom :: CaseStyle -> [CaseStyle]
$cenumFrom :: CaseStyle -> [CaseStyle]
fromEnum :: CaseStyle -> Int
$cfromEnum :: CaseStyle -> Int
toEnum :: Int -> CaseStyle
$ctoEnum :: Int -> CaseStyle
pred :: CaseStyle -> CaseStyle
$cpred :: CaseStyle -> CaseStyle
succ :: CaseStyle -> CaseStyle
$csucc :: CaseStyle -> CaseStyle
Enum, CaseStyle -> CaseStyle -> Bool
(CaseStyle -> CaseStyle -> Bool)
-> (CaseStyle -> CaseStyle -> Bool) -> Eq CaseStyle
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CaseStyle -> CaseStyle -> Bool
$c/= :: CaseStyle -> CaseStyle -> Bool
== :: CaseStyle -> CaseStyle -> Bool
$c== :: CaseStyle -> CaseStyle -> Bool
Eq, (forall x. CaseStyle -> Rep CaseStyle x)
-> (forall x. Rep CaseStyle x -> CaseStyle) -> Generic CaseStyle
forall x. Rep CaseStyle x -> CaseStyle
forall x. CaseStyle -> Rep CaseStyle x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep CaseStyle x -> CaseStyle
$cfrom :: forall x. CaseStyle -> Rep CaseStyle x
Generic, Int -> CaseStyle -> ShowS
[CaseStyle] -> ShowS
CaseStyle -> String
(Int -> CaseStyle -> ShowS)
-> (CaseStyle -> String)
-> ([CaseStyle] -> ShowS)
-> Show CaseStyle
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CaseStyle] -> ShowS
$cshowList :: [CaseStyle] -> ShowS
show :: CaseStyle -> String
$cshow :: CaseStyle -> String
showsPrec :: Int -> CaseStyle -> ShowS
$cshowsPrec :: Int -> CaseStyle -> ShowS
Show)

-- | Converts the given value to text, according to the specified 'CaseStyle'.
--
-- This function guarantees to satisfy the following property:
--
-- > fromTextToBoundedEnum s (toTextFromBoundedEnum s a) == Right a
--
toTextFromBoundedEnum
    :: forall a . (Bounded a, Enum a, Show a)
    => CaseStyle -> a -> Text
toTextFromBoundedEnum :: CaseStyle -> a -> Text
toTextFromBoundedEnum CaseStyle
cs = String -> Text
T.pack (String -> Text) -> (a -> String) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CaseStyle -> Identifier String -> String
toCaseStyle CaseStyle
cs (Identifier String -> String)
-> (a -> Identifier String) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Identifier String
Casing.fromHumps (String -> Identifier String)
-> (a -> String) -> a -> Identifier String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show

-- | Parses the given text to a value, according to the specified 'CaseStyle'.
--
-- This function guarantees to satisfy the following property:
--
-- > fromTextToBoundedEnum s (toTextFromBoundedEnum s a) == Right a
--
fromTextToBoundedEnum
    :: forall a . (Bounded a, Enum a, Show a)
    => CaseStyle -> Text -> Either TextDecodingError a
fromTextToBoundedEnum :: CaseStyle -> Text -> Either TextDecodingError a
fromTextToBoundedEnum CaseStyle
cs Text
t =
    case Maybe a
matchingValue of
        Just a
mv -> a -> Either TextDecodingError a
forall a b. b -> Either a b
Right a
mv
        Maybe a
Nothing -> TextDecodingError -> Either TextDecodingError a
forall a b. a -> Either a b
Left (TextDecodingError -> Either TextDecodingError a)
-> TextDecodingError -> Either TextDecodingError a
forall a b. (a -> b) -> a -> b
$ String -> TextDecodingError
TextDecodingError (String -> TextDecodingError) -> String -> TextDecodingError
forall a b. (a -> b) -> a -> b
$ String
forall a. Monoid a => a
mempty
            String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"Unable to decode the given text value. "
            String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"Please specify one of the following values: "
            String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack (Text -> [Text] -> Text
T.intercalate Text
", " [Text]
allValuesInRequiredCase)
            String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"."
  where
    allValuesInPascalCase :: [Text]
allValuesInPascalCase = CaseStyle -> a -> Text
forall a. (Bounded a, Enum a, Show a) => CaseStyle -> a -> Text
toTextFromBoundedEnum CaseStyle
PascalCase (a -> Text) -> [a] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Enum a, Bounded a) => [a]
forall a. (Enum a, Bounded a) => [a]
enumerate @a
    allValuesInRequiredCase :: [Text]
allValuesInRequiredCase = CaseStyle -> a -> Text
forall a. (Bounded a, Enum a, Show a) => CaseStyle -> a -> Text
toTextFromBoundedEnum CaseStyle
cs (a -> Text) -> [a] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Enum a, Bounded a) => [a]
forall a. (Enum a, Bounded a) => [a]
enumerate @a
    inputInPascalCase :: Maybe Text
inputInPascalCase =
        String -> Text
T.pack (String -> Text)
-> (Identifier String -> String) -> Identifier String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identifier String -> String
Casing.toPascal (Identifier String -> Text)
-> Maybe (Identifier String) -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CaseStyle -> String -> Maybe (Identifier String)
fromCaseStyle CaseStyle
cs (Text -> String
T.unpack Text
t)
    matchingValue :: Maybe a
matchingValue = ((Maybe Text, Int) -> a) -> Maybe (Maybe Text, Int) -> Maybe a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> a
forall a. Enum a => Int -> a
toEnum (Int -> a) -> ((Maybe Text, Int) -> Int) -> (Maybe Text, Int) -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Text, Int) -> Int
forall a b. (a, b) -> b
snd) (Maybe (Maybe Text, Int) -> Maybe a)
-> Maybe (Maybe Text, Int) -> Maybe a
forall a b. (a -> b) -> a -> b
$
        ((Maybe Text, Int) -> Bool)
-> [(Maybe Text, Int)] -> Maybe (Maybe Text, Int)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Text
inputInPascalCase) (Maybe Text -> Bool)
-> ((Maybe Text, Int) -> Maybe Text) -> (Maybe Text, Int) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Text, Int) -> Maybe Text
forall a b. (a, b) -> a
fst) ([(Maybe Text, Int)] -> Maybe (Maybe Text, Int))
-> [(Maybe Text, Int)] -> Maybe (Maybe Text, Int)
forall a b. (a -> b) -> a -> b
$
            (Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> [Text] -> [Maybe Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
allValuesInPascalCase) [Maybe Text] -> [Int] -> [(Maybe Text, Int)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Int
0 :: Int ..]

toCaseStyle :: CaseStyle -> Casing.Identifier String -> String
toCaseStyle :: CaseStyle -> Identifier String -> String
toCaseStyle = \case
    CaseStyle
CamelCase       -> Identifier String -> String
Casing.toCamel
    CaseStyle
PascalCase      -> Identifier String -> String
Casing.toPascal
    CaseStyle
KebabLowerCase  -> Identifier String -> String
Casing.toKebab
    CaseStyle
SnakeLowerCase  -> Identifier String -> String
Casing.toQuietSnake
    CaseStyle
SnakeUpperCase  -> Identifier String -> String
Casing.toScreamingSnake
    CaseStyle
SpacedLowerCase -> (Char -> Char) -> ShowS
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Char -> Char
C.toLower ShowS
-> (Identifier String -> String) -> Identifier String -> String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Identifier String -> String
Casing.toWords

fromCaseStyle :: CaseStyle -> String -> Maybe (Casing.Identifier String)
fromCaseStyle :: CaseStyle -> String -> Maybe (Identifier String)
fromCaseStyle = \case
    CaseStyle
CamelCase       -> (String -> Identifier String)
-> Maybe String -> Maybe (Identifier String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Identifier String
Casing.fromHumps (Maybe String -> Maybe (Identifier String))
-> (String -> Maybe String) -> String -> Maybe (Identifier String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe String
ensureFirstCharLowerCase
    CaseStyle
PascalCase      -> (String -> Identifier String)
-> Maybe String -> Maybe (Identifier String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Identifier String
Casing.fromHumps (Maybe String -> Maybe (Identifier String))
-> (String -> Maybe String) -> String -> Maybe (Identifier String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe String
ensureFirstCharUpperCase
    CaseStyle
KebabLowerCase  -> (String -> Identifier String)
-> Maybe String -> Maybe (Identifier String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Identifier String
Casing.fromKebab (Maybe String -> Maybe (Identifier String))
-> (String -> Maybe String) -> String -> Maybe (Identifier String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe String
forall (t :: * -> *). Foldable t => t Char -> Maybe (t Char)
ensureAllLowerCase
    CaseStyle
SnakeLowerCase  -> (String -> Identifier String)
-> Maybe String -> Maybe (Identifier String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Identifier String
Casing.fromSnake (Maybe String -> Maybe (Identifier String))
-> (String -> Maybe String) -> String -> Maybe (Identifier String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe String
forall (t :: * -> *). Foldable t => t Char -> Maybe (t Char)
ensureAllLowerCase
    CaseStyle
SnakeUpperCase  -> (String -> Identifier String)
-> Maybe String -> Maybe (Identifier String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Identifier String
Casing.fromSnake (Maybe String -> Maybe (Identifier String))
-> (String -> Maybe String) -> String -> Maybe (Identifier String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe String
forall (t :: * -> *). Foldable t => t Char -> Maybe (t Char)
ensureAllUpperCase
    CaseStyle
SpacedLowerCase -> (String -> Identifier String)
-> Maybe String -> Maybe (Identifier String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Identifier String
Casing.fromWords (Maybe String -> Maybe (Identifier String))
-> (String -> Maybe String) -> String -> Maybe (Identifier String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe String
forall (t :: * -> *). Foldable t => t Char -> Maybe (t Char)
ensureAllLowerCase
  where
    ensureAllLowerCase :: t Char -> Maybe (t Char)
ensureAllLowerCase t Char
s =
        if (Char -> Bool) -> t Char -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Char -> Bool
C.isUpper t Char
s then Maybe (t Char)
forall a. Maybe a
Nothing else t Char -> Maybe (t Char)
forall a. a -> Maybe a
Just t Char
s
    ensureAllUpperCase :: t Char -> Maybe (t Char)
ensureAllUpperCase t Char
s =
        if (Char -> Bool) -> t Char -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Char -> Bool
C.isLower t Char
s then Maybe (t Char)
forall a. Maybe a
Nothing else t Char -> Maybe (t Char)
forall a. a -> Maybe a
Just t Char
s
    ensureFirstCharLowerCase :: String -> Maybe String
ensureFirstCharLowerCase String
s =
        (\Char
c -> if Char -> Bool
C.isUpper Char
c then Maybe String
forall a. Maybe a
Nothing else String -> Maybe String
forall a. a -> Maybe a
Just String
s) (Char -> Maybe String) -> Maybe Char -> Maybe String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> Maybe Char
forall a. [a] -> Maybe a
listToMaybe String
s
    ensureFirstCharUpperCase :: String -> Maybe String
ensureFirstCharUpperCase String
s =
        (\Char
c -> if Char -> Bool
C.isLower Char
c then Maybe String
forall a. Maybe a
Nothing else String -> Maybe String
forall a. a -> Maybe a
Just String
s) (Char -> Maybe String) -> Maybe Char -> Maybe String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> Maybe Char
forall a. [a] -> Maybe a
listToMaybe String
s

{-------------------------------------------------------------------------------
                                    Helpers
-------------------------------------------------------------------------------}

-- | Show a data-type through its 'ToText' instance
showT :: ToText a => a -> String
showT :: a -> String
showT = Text -> String
T.unpack (Text -> String) -> (a -> Text) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Text
forall a. ToText a => a -> Text
toText