module Prairie.Class where
import Control.Lens (Lens', set, view, Identity(..), Const(..))
import Data.Aeson (ToJSON(..), FromJSON(..), withText)
import Data.Constraint (Dict(..))
import Data.Kind (Constraint, Type)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Typeable ((:~:)(..), Typeable, eqT)
import GHC.OverloadedLabels (IsLabel(..))
import GHC.TypeLits (Symbol)
class Record rec where
data Field rec :: Type -> Type
recordFieldLens :: Field rec ty -> Lens' rec ty
tabulateRecordA :: Applicative m => (forall ty. Field rec ty -> m ty) -> m rec
recordFieldLabel :: Field rec ty -> Text
default recordFieldLabel :: Show (Field rec ty) => Field rec ty -> Text
recordFieldLabel = String -> Text
Text.pack (String -> Text)
-> (Field rec ty -> String) -> Field rec ty -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Field rec ty -> String
forall a. Show a => a -> String
show
allFields :: Record rec => [SomeField rec]
allFields :: forall rec. Record rec => [SomeField rec]
allFields = Const [SomeField rec] rec -> [SomeField rec]
forall {k} a (b :: k). Const a b -> a
getConst (Const [SomeField rec] rec -> [SomeField rec])
-> Const [SomeField rec] rec -> [SomeField rec]
forall a b. (a -> b) -> a -> b
$ (forall ty. Field rec ty -> Const [SomeField rec] ty)
-> Const [SomeField rec] rec
forall rec (m :: Type -> Type).
(Record rec, Applicative m) =>
(forall ty. Field rec ty -> m ty) -> m rec
forall (m :: Type -> Type).
Applicative m =>
(forall ty. Field rec ty -> m ty) -> m rec
tabulateRecordA ((forall ty. Field rec ty -> Const [SomeField rec] ty)
-> Const [SomeField rec] rec)
-> (forall ty. Field rec ty -> Const [SomeField rec] ty)
-> Const [SomeField rec] rec
forall a b. (a -> b) -> a -> b
$ \Field rec ty
field ->
[SomeField rec] -> Const [SomeField rec] ty
forall {k} a (b :: k). a -> Const a b
Const [Field rec ty -> SomeField rec
forall rec a. Field rec a -> SomeField rec
SomeField Field rec ty
field]
tabulateRecord :: Record rec => (forall ty. Field rec ty -> ty) -> rec
tabulateRecord :: forall rec. Record rec => (forall ty. Field rec ty -> ty) -> rec
tabulateRecord forall ty. Field rec ty -> ty
k = Identity rec -> rec
forall a. Identity a -> a
runIdentity ((forall ty. Field rec ty -> Identity ty) -> Identity rec
forall rec (m :: Type -> Type).
(Record rec, Applicative m) =>
(forall ty. Field rec ty -> m ty) -> m rec
forall (m :: Type -> Type).
Applicative m =>
(forall ty. Field rec ty -> m ty) -> m rec
tabulateRecordA (ty -> Identity ty
forall a. a -> Identity a
Identity (ty -> Identity ty)
-> (Field rec ty -> ty) -> Field rec ty -> Identity ty
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Field rec ty -> ty
forall ty. Field rec ty -> ty
k))
fieldMap :: Record rec => Map Text (SomeField rec)
fieldMap :: forall rec. Record rec => Map Text (SomeField rec)
fieldMap =
(SomeField rec -> Map Text (SomeField rec))
-> [SomeField rec] -> Map Text (SomeField rec)
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: Type -> Type) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
(\sf :: SomeField rec
sf@(SomeField Field rec a
f) -> Text -> SomeField rec -> Map Text (SomeField rec)
forall k a. k -> a -> Map k a
Map.singleton (Field rec a -> Text
forall rec ty. Record rec => Field rec ty -> Text
forall ty. Field rec ty -> Text
recordFieldLabel Field rec a
f) SomeField rec
sf)
[SomeField rec]
forall rec. Record rec => [SomeField rec]
allFields
getRecordField :: Record rec => Field rec ty -> rec -> ty
getRecordField :: forall rec ty. Record rec => Field rec ty -> rec -> ty
getRecordField Field rec ty
f = Getting ty rec ty -> rec -> ty
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
view (Field rec ty -> Lens' rec ty
forall rec ty. Record rec => Field rec ty -> Lens' rec ty
forall ty. Field rec ty -> Lens' rec ty
recordFieldLens Field rec ty
f)
setRecordField :: Record rec => Field rec ty -> ty -> rec -> rec
setRecordField :: forall rec ty. Record rec => Field rec ty -> ty -> rec -> rec
setRecordField Field rec ty
f = ASetter rec rec ty ty -> ty -> rec -> rec
forall s t a b. ASetter s t a b -> b -> s -> t
set (Field rec ty -> Lens' rec ty
forall rec ty. Record rec => Field rec ty -> Lens' rec ty
forall ty. Field rec ty -> Lens' rec ty
recordFieldLens Field rec ty
f)
data SomeField rec where
SomeField :: Field rec a -> SomeField rec
deriving stock instance (forall a. Show (Field rec a)) => Show (SomeField rec)
instance
( forall a. Eq (Field rec a)
, FieldDict Typeable rec
)
=>
Eq (SomeField rec)
where
SomeField (Field rec a
f0 :: Field rec a) == :: SomeField rec -> SomeField rec -> Bool
== SomeField (Field rec a
f1 :: Field rec b) =
forall (c :: Type -> Constraint) rec a r.
FieldDict c rec =>
Field rec a -> (c a => r) -> r
withFieldDict @Typeable Field rec a
f0 ((Typeable a => Bool) -> Bool) -> (Typeable a => Bool) -> Bool
forall a b. (a -> b) -> a -> b
$
forall (c :: Type -> Constraint) rec a r.
FieldDict c rec =>
Field rec a -> (c a => r) -> r
withFieldDict @Typeable Field rec a
f1 ((Typeable a => Bool) -> Bool) -> (Typeable a => Bool) -> Bool
forall a b. (a -> b) -> a -> b
$
case forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
forall a b. (Typeable a, Typeable b) => Maybe (a :~: b)
eqT @a @b of
Just a :~: a
Refl ->
Field rec a
f0 Field rec a -> Field rec a -> Bool
forall a. Eq a => a -> a -> Bool
== Field rec a
Field rec a
f1
Maybe (a :~: a)
Nothing ->
Bool
False
instance (forall a. ToJSON (Field rec a)) => ToJSON (SomeField rec) where
toJSON :: SomeField rec -> Value
toJSON (SomeField Field rec a
f) = Field rec a -> Value
forall a. ToJSON a => a -> Value
toJSON Field rec a
f
instance (Record rec) => FromJSON (SomeField rec) where
parseJSON :: Value -> Parser (SomeField rec)
parseJSON = String
-> (Text -> Parser (SomeField rec))
-> Value
-> Parser (SomeField rec)
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"Field" ((Text -> Parser (SomeField rec))
-> Value -> Parser (SomeField rec))
-> (Text -> Parser (SomeField rec))
-> Value
-> Parser (SomeField rec)
forall a b. (a -> b) -> a -> b
$ \Text
txt ->
case Text -> Map Text (SomeField rec) -> Maybe (SomeField rec)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
txt (forall rec. Record rec => Map Text (SomeField rec)
fieldMap @rec) of
Just SomeField rec
field ->
SomeField rec -> Parser (SomeField rec)
forall a. a -> Parser a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure SomeField rec
field
Maybe (SomeField rec)
Nothing ->
String -> Parser (SomeField rec)
forall a. String -> Parser a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
"Field not"
instance Record rec => ToJSON (Field rec a) where
toJSON :: Field rec a -> Value
toJSON = Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Text -> Value) -> (Field rec a -> Text) -> Field rec a -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Field rec a -> Text
forall rec ty. Record rec => Field rec ty -> Text
forall ty. Field rec ty -> Text
recordFieldLabel
instance (Record rec, FieldDict Typeable rec, Typeable a) => FromJSON (Field rec a) where
parseJSON :: Value -> Parser (Field rec a)
parseJSON = String
-> (Text -> Parser (Field rec a)) -> Value -> Parser (Field rec a)
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"Field" ((Text -> Parser (Field rec a)) -> Value -> Parser (Field rec a))
-> (Text -> Parser (Field rec a)) -> Value -> Parser (Field rec a)
forall a b. (a -> b) -> a -> b
$ \Text
txt ->
case Text -> Map Text (SomeField rec) -> Maybe (SomeField rec)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
txt (forall rec. Record rec => Map Text (SomeField rec)
fieldMap @rec) of
Just (SomeField (Field rec a
a :: Field rec b)) ->
forall (c :: Type -> Constraint) rec a r.
FieldDict c rec =>
Field rec a -> (c a => r) -> r
withFieldDict @Typeable Field rec a
a ((Typeable a => Parser (Field rec a)) -> Parser (Field rec a))
-> (Typeable a => Parser (Field rec a)) -> Parser (Field rec a)
forall a b. (a -> b) -> a -> b
$
case forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
forall a b. (Typeable a, Typeable b) => Maybe (a :~: b)
eqT @a @b of
Just a :~: a
Refl ->
Field rec a -> Parser (Field rec a)
forall a. a -> Parser a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Field rec a
Field rec a
a
Maybe (a :~: a)
Nothing ->
String -> Parser (Field rec a)
forall a. String -> Parser a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
"types not same???"
Maybe (SomeField rec)
Nothing ->
String -> Parser (Field rec a)
forall a. String -> Parser a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
"Field not"
class (Record r) => FieldDict (c :: Type -> Constraint) (r :: Type) where
getFieldDict :: Field r a -> Dict (c a)
withFieldDict
:: forall c rec a r
. FieldDict c rec
=> Field rec a
-> (c a => r)
-> r
withFieldDict :: forall (c :: Type -> Constraint) rec a r.
FieldDict c rec =>
Field rec a -> (c a => r) -> r
withFieldDict Field rec a
l c a => r
k =
case forall (c :: Type -> Constraint) r a.
FieldDict c r =>
Field r a -> Dict (c a)
getFieldDict @c Field rec a
l of
Dict (c a)
Dict -> r
c a => r
k
class Record rec => SymbolToField (sym :: Symbol) (rec :: Type) (a :: Type) | rec sym -> a where
symbolToField :: Field rec a
instance (SymbolToField sym rec a) => IsLabel sym (Field rec a) where
fromLabel :: Field rec a
fromLabel = forall (sym :: Symbol) rec a.
SymbolToField sym rec a =>
Field rec a
symbolToField @sym