{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE UndecidableInstances #-}

-- |
-- Module        : Data.Sum.Pure
-- Copyright     : Gautier DI FOLCO
-- License       : BSD2
--
-- Maintainer    : Gautier DI FOLCO <gautier.difolco@gmail.com>
-- Stability     : Unstable
-- Portability   : GHC
--
-- Derive fromText/toText-like for pure sum types.
module Data.Sum.Pure
  ( -- * Base type
    PureSumWith (..),
    PureSum,

    -- * from/to Text converters
    ToSumText (..),
    FromSumText (..),

    -- * Transformations
    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

-- * Base interface

-- | Wrapper for derivation.
-- @transformation@ is a @Transformation@ applied during derivations
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)

-- | Basic sum derivation
type PureSum = PureSumWith IdTransformation

class ToSumText a where
  toSumText :: a -> T.Text

class FromSumText a where
  fromSumText :: T.Text -> Maybe a

-- * Text Functions

-- | Convert a type into a @Text -> Text@ function
class Transformation a where
  transform :: Proxy a -> T.Text -> T.Text

-- | Apply no transformation (like @id@)
data IdTransformation

instance Transformation IdTransformation where
  transform :: Proxy IdTransformation -> Text -> Text
transform Proxy IdTransformation
_ = Text -> Text
forall a. a -> a
id

-- | Compose two transformations (e.g. @f << g@ is equivalent to @f (g x)@)
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)

-- | @DropPrefix prefix@ (e.g. @DropPrefix "A"@ on "ACase" gives "Case")
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

-- | Change case (e.g. "camelCasedPhrase")
data CamelCase

instance Transformation CamelCase where
  transform :: Proxy CamelCase -> Text -> Text
transform Proxy CamelCase
_ = Text -> Text
Manipulation.toCamel

-- | Change case (e.g. "PascalCasedPhrase")
data PascalCase

instance Transformation PascalCase where
  transform :: Proxy PascalCase -> Text -> Text
transform Proxy PascalCase
_ = Text -> Text
Manipulation.toPascal

-- | Change case (e.g. "snake_cased_phrase")
data SnakeCase

instance Transformation SnakeCase where
  transform :: Proxy SnakeCase -> Text -> Text
transform Proxy SnakeCase
_ = Text -> Text
Manipulation.toSnake

-- | Change case (e.g. "spinal-cased-phrase")
data SpinalCase

instance Transformation SpinalCase where
  transform :: Proxy SpinalCase -> Text -> Text
transform Proxy SpinalCase
_ = Text -> Text
Manipulation.toSpinal

-- | Change case (e.g. "Title Cased Phrase")
data TitleCase

instance Transformation TitleCase where
  transform :: Proxy TitleCase -> Text -> Text
transform Proxy TitleCase
_ = Text -> Text
Manipulation.toTitle

-- | Change case (e.g. "Train-Cased-Phrase")
data TrainCase

instance Transformation TrainCase where
  transform :: Proxy TrainCase -> Text -> Text
transform Proxy TrainCase
_ = Text -> Text
Manipulation.toTrain

-- * Generic derivation

-- * ToSumText

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 -- base type
  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 -- constructor
  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 -- sum type
  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"

-- * FromSumText

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) -- base type
  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) -- constructor
  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 -- sumtype
  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"

-- * Utils

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)")