{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Sum.Pure
(
PureSumWith (..),
PureSum,
ToSumText (..),
FromSumText (..),
Transformation (..),
type (<<<),
DropPrefix,
CamelCase,
PascalCase,
SnakeCase,
SpinalCase,
TitleCase,
TrainCase,
)
where
import Control.Applicative ((<|>))
import Control.Monad (guard)
import Data.Kind
import Data.Maybe (fromMaybe)
import Data.Proxy
import qualified Data.Text as T
import qualified Data.Text.Manipulate as Manipulation
import GHC.Generics
import GHC.TypeError
import GHC.TypeLits
newtype PureSumWith transformation a = PureSumWith {forall transformation a. PureSumWith transformation a -> a
unPureSumWith :: a}
deriving stock (PureSumWith transformation a
-> PureSumWith transformation a -> Bool
(PureSumWith transformation a
-> PureSumWith transformation a -> Bool)
-> (PureSumWith transformation a
-> PureSumWith transformation a -> Bool)
-> Eq (PureSumWith transformation a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall transformation a.
Eq a =>
PureSumWith transformation a
-> PureSumWith transformation a -> Bool
$c== :: forall transformation a.
Eq a =>
PureSumWith transformation a
-> PureSumWith transformation a -> Bool
== :: PureSumWith transformation a
-> PureSumWith transformation a -> Bool
$c/= :: forall transformation a.
Eq a =>
PureSumWith transformation a
-> PureSumWith transformation a -> Bool
/= :: PureSumWith transformation a
-> PureSumWith transformation a -> Bool
Eq, Eq (PureSumWith transformation a)
Eq (PureSumWith transformation a) =>
(PureSumWith transformation a
-> PureSumWith transformation a -> Ordering)
-> (PureSumWith transformation a
-> PureSumWith transformation a -> Bool)
-> (PureSumWith transformation a
-> PureSumWith transformation a -> Bool)
-> (PureSumWith transformation a
-> PureSumWith transformation a -> Bool)
-> (PureSumWith transformation a
-> PureSumWith transformation a -> Bool)
-> (PureSumWith transformation a
-> PureSumWith transformation a -> PureSumWith transformation a)
-> (PureSumWith transformation a
-> PureSumWith transformation a -> PureSumWith transformation a)
-> Ord (PureSumWith transformation a)
PureSumWith transformation a
-> PureSumWith transformation a -> Bool
PureSumWith transformation a
-> PureSumWith transformation a -> Ordering
PureSumWith transformation a
-> PureSumWith transformation a -> PureSumWith transformation a
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall transformation a. Ord a => Eq (PureSumWith transformation a)
forall transformation a.
Ord a =>
PureSumWith transformation a
-> PureSumWith transformation a -> Bool
forall transformation a.
Ord a =>
PureSumWith transformation a
-> PureSumWith transformation a -> Ordering
forall transformation a.
Ord a =>
PureSumWith transformation a
-> PureSumWith transformation a -> PureSumWith transformation a
$ccompare :: forall transformation a.
Ord a =>
PureSumWith transformation a
-> PureSumWith transformation a -> Ordering
compare :: PureSumWith transformation a
-> PureSumWith transformation a -> Ordering
$c< :: forall transformation a.
Ord a =>
PureSumWith transformation a
-> PureSumWith transformation a -> Bool
< :: PureSumWith transformation a
-> PureSumWith transformation a -> Bool
$c<= :: forall transformation a.
Ord a =>
PureSumWith transformation a
-> PureSumWith transformation a -> Bool
<= :: PureSumWith transformation a
-> PureSumWith transformation a -> Bool
$c> :: forall transformation a.
Ord a =>
PureSumWith transformation a
-> PureSumWith transformation a -> Bool
> :: PureSumWith transformation a
-> PureSumWith transformation a -> Bool
$c>= :: forall transformation a.
Ord a =>
PureSumWith transformation a
-> PureSumWith transformation a -> Bool
>= :: PureSumWith transformation a
-> PureSumWith transformation a -> Bool
$cmax :: forall transformation a.
Ord a =>
PureSumWith transformation a
-> PureSumWith transformation a -> PureSumWith transformation a
max :: PureSumWith transformation a
-> PureSumWith transformation a -> PureSumWith transformation a
$cmin :: forall transformation a.
Ord a =>
PureSumWith transformation a
-> PureSumWith transformation a -> PureSumWith transformation a
min :: PureSumWith transformation a
-> PureSumWith transformation a -> PureSumWith transformation a
Ord, Int -> PureSumWith transformation a -> ShowS
[PureSumWith transformation a] -> ShowS
PureSumWith transformation a -> String
(Int -> PureSumWith transformation a -> ShowS)
-> (PureSumWith transformation a -> String)
-> ([PureSumWith transformation a] -> ShowS)
-> Show (PureSumWith transformation a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall transformation a.
Show a =>
Int -> PureSumWith transformation a -> ShowS
forall transformation a.
Show a =>
[PureSumWith transformation a] -> ShowS
forall transformation a.
Show a =>
PureSumWith transformation a -> String
$cshowsPrec :: forall transformation a.
Show a =>
Int -> PureSumWith transformation a -> ShowS
showsPrec :: Int -> PureSumWith transformation a -> ShowS
$cshow :: forall transformation a.
Show a =>
PureSumWith transformation a -> String
show :: PureSumWith transformation a -> String
$cshowList :: forall transformation a.
Show a =>
[PureSumWith transformation a] -> ShowS
showList :: [PureSumWith transformation a] -> ShowS
Show)
type PureSum = PureSumWith IdTransformation
class ToSumText a where
toSumText :: a -> T.Text
class FromSumText a where
fromSumText :: T.Text -> Maybe a
class Transformation a where
transform :: Proxy a -> T.Text -> T.Text
data IdTransformation
instance Transformation IdTransformation where
transform :: Proxy IdTransformation -> Text -> Text
transform Proxy IdTransformation
_ = Text -> Text
forall a. a -> a
id
data f <<< g
instance (Transformation f, Transformation g) => Transformation (f <<< g) where
transform :: Proxy (f <<< g) -> Text -> Text
transform Proxy (f <<< g)
_ = Proxy f -> Text -> Text
forall a. Transformation a => Proxy a -> Text -> Text
transform (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @f) (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy g -> Text -> Text
forall a. Transformation a => Proxy a -> Text -> Text
transform (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @g)
data DropPrefix (s :: Symbol)
instance (KnownSymbol s) => Transformation (DropPrefix s) where
transform :: Proxy (DropPrefix s) -> Text -> Text
transform Proxy (DropPrefix s)
_ Text
x = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
x (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Maybe Text
T.stripPrefix (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal @s Proxy s
forall {k} (t :: k). Proxy t
Proxy) Text
x
data CamelCase
instance Transformation CamelCase where
transform :: Proxy CamelCase -> Text -> Text
transform Proxy CamelCase
_ = Text -> Text
Manipulation.toCamel
data PascalCase
instance Transformation PascalCase where
transform :: Proxy PascalCase -> Text -> Text
transform Proxy PascalCase
_ = Text -> Text
Manipulation.toPascal
data SnakeCase
instance Transformation SnakeCase where
transform :: Proxy SnakeCase -> Text -> Text
transform Proxy SnakeCase
_ = Text -> Text
Manipulation.toSnake
data SpinalCase
instance Transformation SpinalCase where
transform :: Proxy SpinalCase -> Text -> Text
transform Proxy SpinalCase
_ = Text -> Text
Manipulation.toSpinal
data TitleCase
instance Transformation TitleCase where
transform :: Proxy TitleCase -> Text -> Text
transform Proxy TitleCase
_ = Text -> Text
Manipulation.toTitle
data TrainCase
instance Transformation TrainCase where
transform :: Proxy TrainCase -> Text -> Text
transform Proxy TrainCase
_ = Text -> Text
Manipulation.toTrain
instance
(Transformation transformation, Generic a, GToSumText (Rep a)) =>
ToSumText (PureSumWith transformation a)
where
toSumText :: PureSumWith transformation a -> Text
toSumText = (Text -> Text) -> Rep a Any -> Text
forall a. (Text -> Text) -> Rep a a -> Text
forall (f :: * -> *) a.
GToSumText f =>
(Text -> Text) -> f a -> Text
gToSumText (Proxy transformation -> Text -> Text
forall a. Transformation a => Proxy a -> Text -> Text
transform (Proxy transformation -> Text -> Text)
-> Proxy transformation -> Text -> Text
forall a b. (a -> b) -> a -> b
$ forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @transformation) (Rep a Any -> Text)
-> (PureSumWith transformation a -> Rep a Any)
-> PureSumWith transformation a
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Rep a Any
forall x. a -> Rep a x
forall a x. Generic a => a -> Rep a x
from (a -> Rep a Any)
-> (PureSumWith transformation a -> a)
-> PureSumWith transformation a
-> Rep a Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PureSumWith transformation a -> a
forall transformation a. PureSumWith transformation a -> a
unPureSumWith
class GToSumText f where
gToSumText :: (T.Text -> T.Text) -> f a -> T.Text
instance (GToSumText a) => GToSumText (M1 D meta a) where
gToSumText :: forall a. (Text -> Text) -> M1 D meta a a -> Text
gToSumText Text -> Text
transformation (M1 a a
x) = (Text -> Text) -> a a -> Text
forall a. (Text -> Text) -> a a -> Text
forall (f :: * -> *) a.
GToSumText f =>
(Text -> Text) -> f a -> Text
gToSumText Text -> Text
transformation a a
x
instance (KnownSymbol cntr, EnsureEmpty a) => GToSumText (M1 C ('MetaCons cntr p b) a) where
gToSumText :: forall a. (Text -> Text) -> M1 C ('MetaCons cntr p b) a a -> Text
gToSumText Text -> Text
transformation (M1 a a
_) = Text -> Text
transformation (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Proxy cntr -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy cntr -> String) -> Proxy cntr -> String
forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @cntr
instance (GToSumText a, GToSumText b) => GToSumText (a :+: b) where
gToSumText :: forall a. (Text -> Text) -> (:+:) a b a -> Text
gToSumText Text -> Text
transformation (R1 b a
x) = (Text -> Text) -> b a -> Text
forall a. (Text -> Text) -> b a -> Text
forall (f :: * -> *) a.
GToSumText f =>
(Text -> Text) -> f a -> Text
gToSumText Text -> Text
transformation b a
x
gToSumText Text -> Text
transformation (L1 a a
x) = (Text -> Text) -> a a -> Text
forall a. (Text -> Text) -> a a -> Text
forall (f :: * -> *) a.
GToSumText f =>
(Text -> Text) -> f a -> Text
gToSumText Text -> Text
transformation a a
x
instance (NonSumTypeError) => GToSumText V1 where
gToSumText :: forall a. (Text -> Text) -> V1 a -> Text
gToSumText Text -> Text
_ V1 a
_ = String -> Text
forall a. HasCallStack => String -> a
error String
"impossible"
instance
(Transformation transformation, Generic a, GFromSumText (Rep a)) =>
FromSumText (PureSumWith transformation a)
where
fromSumText :: Text -> Maybe (PureSumWith transformation a)
fromSumText Text
x = a -> PureSumWith transformation a
forall transformation a. a -> PureSumWith transformation a
PureSumWith (a -> PureSumWith transformation a)
-> (Rep a Any -> a) -> Rep a Any -> PureSumWith transformation a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rep a Any -> a
forall a x. Generic a => Rep a x -> a
forall x. Rep a x -> a
to (Rep a Any -> PureSumWith transformation a)
-> Maybe (Rep a Any) -> Maybe (PureSumWith transformation a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> Text) -> Text -> Maybe (Rep a Any)
forall a. (Text -> Text) -> Text -> Maybe (Rep a a)
forall (f :: * -> *) a.
GFromSumText f =>
(Text -> Text) -> Text -> Maybe (f a)
gFromSumText (Proxy transformation -> Text -> Text
forall a. Transformation a => Proxy a -> Text -> Text
transform (Proxy transformation -> Text -> Text)
-> Proxy transformation -> Text -> Text
forall a b. (a -> b) -> a -> b
$ forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @transformation) Text
x
class GFromSumText f where
gFromSumText :: (T.Text -> T.Text) -> T.Text -> Maybe (f a)
instance
(GFromSumText a) =>
GFromSumText (M1 D ('MetaData typeName c i b) a)
where
gFromSumText :: forall a.
(Text -> Text)
-> Text -> Maybe (M1 D ('MetaData typeName c i b) a a)
gFromSumText Text -> Text
transformation Text
x = a a -> M1 D ('MetaData typeName c i b) a a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (a a -> M1 D ('MetaData typeName c i b) a a)
-> Maybe (a a) -> Maybe (M1 D ('MetaData typeName c i b) a a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> Text) -> Text -> Maybe (a a)
forall a. (Text -> Text) -> Text -> Maybe (a a)
forall (f :: * -> *) a.
GFromSumText f =>
(Text -> Text) -> Text -> Maybe (f a)
gFromSumText Text -> Text
transformation Text
x
instance
(GFromSumText a, KnownSymbol cntr) =>
GFromSumText (M1 C ('MetaCons cntr p b) a)
where
gFromSumText :: forall a.
(Text -> Text) -> Text -> Maybe (M1 C ('MetaCons cntr p b) a a)
gFromSumText Text -> Text
transformation Text
v =
a a -> M1 C ('MetaCons cntr p b) a a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (a a -> M1 C ('MetaCons cntr p b) a a)
-> Maybe (a a) -> Maybe (M1 C ('MetaCons cntr p b) a a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
let cntrName :: Text
cntrName = Text -> Text
transformation (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Proxy cntr -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @cntr)
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Text
v Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
cntrName
(Text -> Text) -> Text -> Maybe (a a)
forall a. (Text -> Text) -> Text -> Maybe (a a)
forall (f :: * -> *) a.
GFromSumText f =>
(Text -> Text) -> Text -> Maybe (f a)
gFromSumText Text -> Text
transformation Text
v
instance (GFromSumText a, GFromSumText b) => GFromSumText (a :+: b) where
gFromSumText :: forall a. (Text -> Text) -> Text -> Maybe ((:+:) a b a)
gFromSumText Text -> Text
transformation Text
v =
(a a -> (:+:) a b a
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (a a -> (:+:) a b a) -> Maybe (a a) -> Maybe ((:+:) a b a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> Text) -> Text -> Maybe (a a)
forall a. (Text -> Text) -> Text -> Maybe (a a)
forall (f :: * -> *) a.
GFromSumText f =>
(Text -> Text) -> Text -> Maybe (f a)
gFromSumText Text -> Text
transformation Text
v)
Maybe ((:+:) a b a) -> Maybe ((:+:) a b a) -> Maybe ((:+:) a b a)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (b a -> (:+:) a b a
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (b a -> (:+:) a b a) -> Maybe (b a) -> Maybe ((:+:) a b a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> Text) -> Text -> Maybe (b a)
forall a. (Text -> Text) -> Text -> Maybe (b a)
forall (f :: * -> *) a.
GFromSumText f =>
(Text -> Text) -> Text -> Maybe (f a)
gFromSumText Text -> Text
transformation Text
v)
instance GFromSumText U1 where
gFromSumText :: forall a. (Text -> Text) -> Text -> Maybe (U1 a)
gFromSumText Text -> Text
_ Text
_ = U1 a -> Maybe (U1 a)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return U1 a
forall k (p :: k). U1 p
U1
instance (NonSumTypeError) => GFromSumText V1 where
gFromSumText :: forall a. (Text -> Text) -> Text -> Maybe (V1 a)
gFromSumText Text -> Text
_ Text
_ = String -> Maybe (V1 a)
forall a. HasCallStack => String -> a
error String
"impossible"
instance (NonSumTypeError) => GFromSumText (M1 S meta a) where
gFromSumText :: forall a. (Text -> Text) -> Text -> Maybe (M1 S meta a a)
gFromSumText Text -> Text
_ Text
_ = String -> Maybe (M1 S meta a a)
forall a. HasCallStack => String -> a
error String
"impossible"
type family EnsureEmpty a :: Constraint where
EnsureEmpty U1 = ()
EnsureEmpty a = NonSumTypeError
type NonSumTypeError :: Constraint
type NonSumTypeError = TypeError (Text "Only pure sum types are supported (constructor(s) without values)")