{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
module Typson.Optics
(
fieldLens
, fieldPrism
) where
import Data.Functor.Identity (Identity(..))
import Data.Profunctor (Profunctor(dimap))
import Data.Profunctor.Choice (Choice(..))
import Data.Kind (Type)
import Data.Monoid (First(..))
import Data.Proxy (Proxy(..))
import Data.Type.Equality ((:~:)(..))
import GHC.TypeLits (KnownSymbol, Symbol, sameSymbol)
import Unsafe.Coerce (unsafeCoerce)
import Typson.JsonTree (Aggregator(..), Edge(..), FieldSYM(..), Multiplicity(..), ObjectSYM(..), Tree(..), UnionSYM(..), runAp, runAp_)
import Typson.Pathing (TypeAtPath)
fieldLens :: ( KnownSymbol key
, tree ~ 'Node 'Product edges
, TypeAtPath obj tree key ~ ty
)
=> proxy key
-> Optic key ty tree obj
-> Lens' obj ty
fieldLens :: proxy key -> Optic key ty tree obj -> Lens' obj ty
fieldLens _ (Lens l :: Lens' obj ty
l) = (ty -> f ty) -> obj -> f obj
Lens' obj ty
l
fieldPrism :: ( KnownSymbol key
, tree ~ 'Node 'Sum edges
, TypeAtPath obj tree key ~ Maybe ty
)
=> proxy key
-> Optic key ty tree obj
-> Prism' obj ty
fieldPrism :: proxy key -> Optic key ty tree obj -> Prism' obj ty
fieldPrism _ (Prism p :: Prism' obj ty
p) = p ty (f ty) -> p obj (f obj)
Prism' obj ty
p
type Lens' s a = forall f. Functor f => (a -> f a) -> s -> f s
type Prism' s a = forall p f. (Choice p, Applicative f) => p a (f a) -> p s (f s)
data Optic (key :: Symbol) (val :: Type) (t :: Tree) (o :: Type) where
Lens :: t ~ 'Node 'Product es => Lens' o val -> Optic key val t o
Prism :: t ~ 'Node 'Sum es => Prism' o val -> Optic key val t o
AbsurdLeaf :: t ~ 'Leaf => Optic key val t o
AbsurdIndexed :: t ~ 'IndexedNode k st => Optic key val t o
instance KnownSymbol queryKey
=> ObjectSYM (Optic queryKey queryType) where
object :: String
-> TreeBuilder (Field (Optic queryKey queryType) o) tree o
-> Optic queryKey queryType tree o
object _ fields :: TreeBuilder (Field (Optic queryKey queryType) o) tree o
fields = Lens' o queryType -> Optic queryKey queryType tree o
forall (t :: Tree) (es :: [Edge]) o val (key :: Symbol).
(t ~ 'Node 'Product es) =>
Lens' o val -> Optic key val t o
Lens (Lens' o queryType -> Optic queryKey queryType tree o)
-> Lens' o queryType -> Optic queryKey queryType tree o
forall a b. (a -> b) -> a -> b
$ \afa :: queryType -> f queryType
afa obj :: o
obj ->
case First (o -> queryType) -> Maybe (o -> queryType)
forall a. First a -> Maybe a
getFirst (First (o -> queryType) -> Maybe (o -> queryType))
-> First (o -> queryType) -> Maybe (o -> queryType)
forall a b. (a -> b) -> a -> b
$ (forall a' (t' :: Tree).
Field (Optic queryKey queryType) o t' a' -> First (o -> queryType))
-> TreeBuilder (Field (Optic queryKey queryType) o) tree o
-> First (o -> queryType)
forall m (f :: Tree -> * -> *) (t :: Tree) a.
Monoid m =>
(forall a' (t' :: Tree). f t' a' -> m) -> TreeBuilder f t a -> m
runAp_ forall a' (t' :: Tree).
Field (Optic queryKey queryType) o t' a' -> First (o -> queryType)
forall (queryKey :: Symbol) queryType obj (tree :: Tree) fieldType.
Field (Optic queryKey queryType) obj tree fieldType
-> First (obj -> queryType)
fGetter TreeBuilder (Field (Optic queryKey queryType) o) tree o
fields of
Nothing -> String -> f o
forall a. HasCallStack => String -> a
error "impossible"
Just getter :: o -> queryType
getter ->
let val :: queryType
val = o -> queryType
getter o
obj
setter :: o -> queryType -> o
setter o :: o
o a :: queryType
a =
Identity o -> o
forall a. Identity a -> a
runIdentity (Identity o -> o) -> Identity o -> o
forall a b. (a -> b) -> a -> b
$ (forall a' (t' :: Tree).
Field (Optic queryKey queryType) o t' a' -> Identity a')
-> TreeBuilder (Field (Optic queryKey queryType) o) tree o
-> Identity o
forall (g :: * -> *) (f :: Tree -> * -> *) (t :: Tree) a.
Applicative g =>
(forall a' (t' :: Tree). f t' a' -> g a')
-> TreeBuilder f t a -> g a
runAp (\s :: Field (Optic queryKey queryType) o t' a'
s -> a' -> Identity a'
forall a. a -> Identity a
Identity (a' -> Identity a') -> a' -> Identity a'
forall a b. (a -> b) -> a -> b
$ Field (Optic queryKey queryType) o t' a' -> queryType -> o -> a'
forall (queryKey :: Symbol) queryType obj (tree :: Tree) fieldType.
Field (Optic queryKey queryType) obj tree fieldType
-> queryType -> obj -> fieldType
fSetter Field (Optic queryKey queryType) o t' a'
s queryType
a o
o) TreeBuilder (Field (Optic queryKey queryType) o) tree o
fields
in o -> queryType -> o
setter o
obj (queryType -> o) -> f queryType -> f o
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> queryType -> f queryType
afa queryType
val
list :: Optic queryKey queryType tree o
-> Optic queryKey queryType ('IndexedNode Nat tree) [o]
list _ = Optic queryKey queryType ('IndexedNode Nat tree) [o]
forall (t :: Tree) k (st :: Tree) (key :: Symbol) val o.
(t ~ 'IndexedNode k st) =>
Optic key val t o
AbsurdIndexed
textMap :: Optic queryKey queryType tree o
-> Optic queryKey queryType ('IndexedNode Symbol tree) (Map k o)
textMap _ = Optic queryKey queryType ('IndexedNode Symbol tree) (Map k o)
forall (t :: Tree) k (st :: Tree) (key :: Symbol) val o.
(t ~ 'IndexedNode k st) =>
Optic key val t o
AbsurdIndexed
set :: Optic queryKey queryType tree o
-> Optic queryKey queryType ('IndexedNode Nat tree) (Set o)
set _ = Optic queryKey queryType ('IndexedNode Nat tree) (Set o)
forall (t :: Tree) k (st :: Tree) (key :: Symbol) val o.
(t ~ 'IndexedNode k st) =>
Optic key val t o
AbsurdIndexed
vector :: Optic queryKey queryType tree o
-> Optic queryKey queryType ('IndexedNode Nat tree) (Vector o)
vector _ = Optic queryKey queryType ('IndexedNode Nat tree) (Vector o)
forall (t :: Tree) k (st :: Tree) (key :: Symbol) val o.
(t ~ 'IndexedNode k st) =>
Optic key val t o
AbsurdIndexed
prim :: Optic queryKey queryType 'Leaf v
prim = Optic queryKey queryType 'Leaf v
forall (t :: Tree) (key :: Symbol) val o.
(t ~ 'Leaf) =>
Optic key val t o
AbsurdLeaf
instance KnownSymbol queryKey
=> FieldSYM (Optic queryKey queryType) where
data Field (Optic queryKey queryType) obj tree fieldType =
Focus { Field (Optic queryKey queryType) obj tree fieldType
-> First (obj -> queryType)
fGetter :: First (obj -> queryType)
, Field (Optic queryKey queryType) obj tree fieldType
-> queryType -> obj -> fieldType
fSetter :: queryType
-> obj
-> fieldType
}
field :: forall field key subTree tree obj repr proxy edge.
( KnownSymbol key
, edge ~ 'Edge key 'Singleton field subTree
, tree ~ 'Node 'Product '[edge]
)
=> proxy key
-> (obj -> field)
-> repr subTree field
-> Field (Optic queryKey queryType) obj tree field
field :: proxy key
-> (obj -> field)
-> repr subTree field
-> Field (Optic queryKey queryType) obj tree field
field _ getter :: obj -> field
getter _ =
case Proxy '(queryKey, queryType)
-> Proxy '(key, field)
-> Maybe ('(queryKey, queryType) :~: '(key, field))
forall (fieldA :: Symbol) (fieldB :: Symbol) typeA typeB.
(KnownSymbol fieldA, KnownSymbol fieldB) =>
Proxy '(fieldA, typeA)
-> Proxy '(fieldB, typeB)
-> Maybe ('(fieldA, typeA) :~: '(fieldB, typeB))
sameField (Proxy '(queryKey, queryType)
forall k (t :: k). Proxy t
Proxy @'(queryKey, queryType)) (Proxy '(key, field)
forall k (t :: k). Proxy t
Proxy @'(key, field)) of
Nothing ->
$WFocus :: forall (queryKey :: Symbol) queryType obj (tree :: Tree) fieldType.
First (obj -> queryType)
-> (queryType -> obj -> fieldType)
-> Field (Optic queryKey queryType) obj tree fieldType
Focus
{ fGetter :: First (obj -> queryType)
fGetter = Maybe (obj -> queryType) -> First (obj -> queryType)
forall a. Maybe a -> First a
First Maybe (obj -> queryType)
forall a. Maybe a
Nothing
, fSetter :: queryType -> obj -> field
fSetter = \_ obj :: obj
obj -> obj -> field
getter obj
obj
}
Just Refl ->
$WFocus :: forall (queryKey :: Symbol) queryType obj (tree :: Tree) fieldType.
First (obj -> queryType)
-> (queryType -> obj -> fieldType)
-> Field (Optic queryKey queryType) obj tree fieldType
Focus
{ fGetter :: First (obj -> queryType)
fGetter = Maybe (obj -> field) -> First (obj -> queryType)
forall a. Maybe a -> First a
First (Maybe (obj -> field) -> First (obj -> queryType))
-> Maybe (obj -> field) -> First (obj -> queryType)
forall a b. (a -> b) -> a -> b
$ (obj -> field) -> Maybe (obj -> field)
forall a. a -> Maybe a
Just obj -> field
getter
, fSetter :: queryType -> obj -> field
fSetter = queryType -> obj -> field
forall a b. a -> b -> a
const
}
optField :: forall field key subTree tree obj repr proxy edge.
( KnownSymbol key
, edge ~ 'Edge key 'Nullable field subTree
, tree ~ 'Node 'Product '[edge]
)
=> proxy key
-> (obj -> Maybe field)
-> repr subTree field
-> Field (Optic queryKey queryType) obj tree (Maybe field)
optField :: proxy key
-> (obj -> Maybe field)
-> repr subTree field
-> Field (Optic queryKey queryType) obj tree (Maybe field)
optField _ getter :: obj -> Maybe field
getter _ =
case Proxy '(queryKey, queryType)
-> Proxy '(key, Maybe field)
-> Maybe ('(queryKey, queryType) :~: '(key, Maybe field))
forall (fieldA :: Symbol) (fieldB :: Symbol) typeA typeB.
(KnownSymbol fieldA, KnownSymbol fieldB) =>
Proxy '(fieldA, typeA)
-> Proxy '(fieldB, typeB)
-> Maybe ('(fieldA, typeA) :~: '(fieldB, typeB))
sameField (Proxy '(queryKey, queryType)
forall k (t :: k). Proxy t
Proxy @'(queryKey, queryType)) (Proxy '(key, Maybe field)
forall k (t :: k). Proxy t
Proxy @'(key, Maybe field)) of
Nothing ->
$WFocus :: forall (queryKey :: Symbol) queryType obj (tree :: Tree) fieldType.
First (obj -> queryType)
-> (queryType -> obj -> fieldType)
-> Field (Optic queryKey queryType) obj tree fieldType
Focus
{ fGetter :: First (obj -> queryType)
fGetter = Maybe (obj -> queryType) -> First (obj -> queryType)
forall a. Maybe a -> First a
First Maybe (obj -> queryType)
forall a. Maybe a
Nothing
, fSetter :: queryType -> obj -> Maybe field
fSetter = \_ obj :: obj
obj -> obj -> Maybe field
getter obj
obj
}
Just Refl ->
$WFocus :: forall (queryKey :: Symbol) queryType obj (tree :: Tree) fieldType.
First (obj -> queryType)
-> (queryType -> obj -> fieldType)
-> Field (Optic queryKey queryType) obj tree fieldType
Focus
{ fGetter :: First (obj -> queryType)
fGetter = Maybe (obj -> Maybe field) -> First (obj -> queryType)
forall a. Maybe a -> First a
First (Maybe (obj -> Maybe field) -> First (obj -> queryType))
-> Maybe (obj -> Maybe field) -> First (obj -> queryType)
forall a b. (a -> b) -> a -> b
$ (obj -> Maybe field) -> Maybe (obj -> Maybe field)
forall a. a -> Maybe a
Just obj -> Maybe field
getter
, fSetter :: queryType -> obj -> Maybe field
fSetter = queryType -> obj -> Maybe field
forall a b. a -> b -> a
const
}
instance KnownSymbol queryKey => UnionSYM (Optic queryKey queryType) where
type Result (Optic queryKey queryType) union = Maybe queryType
data Tag (Optic queryKey queryType) union tree vToRes =
Facet
{ :: vToRes
, Tag (Optic queryKey queryType) union tree vToRes
-> First (queryType -> union)
fEmbed :: First (queryType -> union)
}
union :: String
-> TreeBuilder
(Tag (Optic queryKey queryType) union)
tree
(union -> Result (Optic queryKey queryType) union)
-> Optic queryKey queryType tree union
union _ tags :: TreeBuilder
(Tag (Optic queryKey queryType) union)
tree
(union -> Result (Optic queryKey queryType) union)
tags = Prism' union queryType -> Optic queryKey queryType tree union
forall (t :: Tree) (es :: [Edge]) o val (key :: Symbol).
(t ~ 'Node 'Sum es) =>
Prism' o val -> Optic key val t o
Prism (Prism' union queryType -> Optic queryKey queryType tree union)
-> Prism' union queryType -> Optic queryKey queryType tree union
forall a b. (a -> b) -> a -> b
$ \pafa :: p queryType (f queryType)
pafa ->
case First (queryType -> union) -> Maybe (queryType -> union)
forall a. First a -> Maybe a
getFirst (First (queryType -> union) -> Maybe (queryType -> union))
-> First (queryType -> union) -> Maybe (queryType -> union)
forall a b. (a -> b) -> a -> b
$ (forall a' (t' :: Tree).
Tag (Optic queryKey queryType) union t' a'
-> First (queryType -> union))
-> TreeBuilder
(Tag (Optic queryKey queryType) union)
tree
(union -> Maybe queryType)
-> First (queryType -> union)
forall m (f :: Tree -> * -> *) (t :: Tree) a.
Monoid m =>
(forall a' (t' :: Tree). f t' a' -> m) -> TreeBuilder f t a -> m
runAp_ forall a' (t' :: Tree).
Tag (Optic queryKey queryType) union t' a'
-> First (queryType -> union)
forall (queryKey :: Symbol) queryType union (tree :: Tree) vToRes.
Tag (Optic queryKey queryType) union tree vToRes
-> First (queryType -> union)
fEmbed TreeBuilder
(Tag (Optic queryKey queryType) union)
tree
(union -> Maybe queryType)
TreeBuilder
(Tag (Optic queryKey queryType) union)
tree
(union -> Result (Optic queryKey queryType) union)
tags of
Nothing -> String -> p union (f union)
forall a. HasCallStack => String -> a
error "impossible"
Just embed :: queryType -> union
embed ->
(union -> Either union queryType)
-> (Either union (f queryType) -> f union)
-> p (Either union queryType) (Either union (f queryType))
-> p union (f union)
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap union -> Either union queryType
f Either union (f queryType) -> f union
g (p (Either union queryType) (Either union (f queryType))
-> p union (f union))
-> p (Either union queryType) (Either union (f queryType))
-> p union (f union)
forall a b. (a -> b) -> a -> b
$ p queryType (f queryType)
-> p (Either union queryType) (Either union (f queryType))
forall (p :: * -> * -> *) a b c.
Choice p =>
p a b -> p (Either c a) (Either c b)
right' p queryType (f queryType)
pafa
where
f :: union -> Either union queryType
f u :: union
u = Either union queryType
-> (queryType -> Either union queryType)
-> Maybe queryType
-> Either union queryType
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (union -> Either union queryType
forall a b. a -> Either a b
Left union
u) queryType -> Either union queryType
forall a b. b -> Either a b
Right
(Maybe queryType -> Either union queryType)
-> Maybe queryType -> Either union queryType
forall a b. (a -> b) -> a -> b
$ Identity (union -> Maybe queryType) -> union -> Maybe queryType
forall a. Identity a -> a
runIdentity ((forall a' (t' :: Tree).
Tag (Optic queryKey queryType) union t' a' -> Identity a')
-> TreeBuilder
(Tag (Optic queryKey queryType) union)
tree
(union -> Maybe queryType)
-> Identity (union -> Maybe queryType)
forall (g :: * -> *) (f :: Tree -> * -> *) (t :: Tree) a.
Applicative g =>
(forall a' (t' :: Tree). f t' a' -> g a')
-> TreeBuilder f t a -> g a
runAp (a' -> Identity a'
forall a. a -> Identity a
Identity (a' -> Identity a')
-> (Tag (Optic queryKey queryType) union t' a' -> a')
-> Tag (Optic queryKey queryType) union t' a'
-> Identity a'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tag (Optic queryKey queryType) union t' a' -> a'
forall (queryKey :: Symbol) queryType union (tree :: Tree) vToRes.
Tag (Optic queryKey queryType) union tree vToRes -> vToRes
fExtract) TreeBuilder
(Tag (Optic queryKey queryType) union)
tree
(union -> Maybe queryType)
TreeBuilder
(Tag (Optic queryKey queryType) union)
tree
(union -> Result (Optic queryKey queryType) union)
tags) union
u
g :: Either union (f queryType) -> f union
g = (union -> f union)
-> (f queryType -> f union)
-> Either union (f queryType)
-> f union
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either union -> f union
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((queryType -> union) -> f queryType -> f union
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap queryType -> union
embed)
tag :: forall name union v subTree tree proxy edge.
( KnownSymbol name
, edge ~ 'Edge name 'Nullable v subTree
, tree ~ 'Node 'Sum '[edge]
)
=> proxy name
-> (v -> union)
-> Optic queryKey queryType subTree v
-> Tag (Optic queryKey queryType) union tree (v -> Maybe queryType)
tag :: proxy name
-> (v -> union)
-> Optic queryKey queryType subTree v
-> Tag (Optic queryKey queryType) union tree (v -> Maybe queryType)
tag _ embed :: v -> union
embed _ =
case Proxy '(queryKey, queryType)
-> Proxy '(name, v)
-> Maybe ('(queryKey, queryType) :~: '(name, v))
forall (fieldA :: Symbol) (fieldB :: Symbol) typeA typeB.
(KnownSymbol fieldA, KnownSymbol fieldB) =>
Proxy '(fieldA, typeA)
-> Proxy '(fieldB, typeB)
-> Maybe ('(fieldA, typeA) :~: '(fieldB, typeB))
sameField (Proxy '(queryKey, queryType)
forall k (t :: k). Proxy t
Proxy @'(queryKey, queryType)) (Proxy '(name, v)
forall k (t :: k). Proxy t
Proxy @'(name, v)) of
Nothing ->
$WFacet :: forall (queryKey :: Symbol) queryType union (tree :: Tree) vToRes.
vToRes
-> First (queryType -> union)
-> Tag (Optic queryKey queryType) union tree vToRes
Facet
{ fExtract :: v -> Maybe queryType
fExtract = Maybe queryType -> v -> Maybe queryType
forall a b. a -> b -> a
const Maybe queryType
forall a. Maybe a
Nothing
, fEmbed :: First (queryType -> union)
fEmbed = Maybe (queryType -> union) -> First (queryType -> union)
forall a. Maybe a -> First a
First Maybe (queryType -> union)
forall a. Maybe a
Nothing
}
Just Refl ->
$WFacet :: forall (queryKey :: Symbol) queryType union (tree :: Tree) vToRes.
vToRes
-> First (queryType -> union)
-> Tag (Optic queryKey queryType) union tree vToRes
Facet
{ fExtract :: v -> Maybe queryType
fExtract = v -> Maybe queryType
forall a. a -> Maybe a
Just
, fEmbed :: First (queryType -> union)
fEmbed = Maybe (v -> union) -> First (queryType -> union)
forall a. Maybe a -> First a
First (Maybe (v -> union) -> First (queryType -> union))
-> Maybe (v -> union) -> First (queryType -> union)
forall a b. (a -> b) -> a -> b
$ (v -> union) -> Maybe (v -> union)
forall a. a -> Maybe a
Just v -> union
embed
}
sameField :: forall fieldA fieldB typeA typeB.
(KnownSymbol fieldA, KnownSymbol fieldB)
=> Proxy '(fieldA ,typeA)
-> Proxy '(fieldB, typeB)
-> Maybe ('(fieldA, typeA) :~: '(fieldB, typeB))
sameField :: Proxy '(fieldA, typeA)
-> Proxy '(fieldB, typeB)
-> Maybe ('(fieldA, typeA) :~: '(fieldB, typeB))
sameField _ _ =
(fieldA :~: fieldB) -> '(fieldA, typeA) :~: '(fieldB, typeB)
forall a b. a -> b
unsafeCoerce ((fieldA :~: fieldB) -> '(fieldA, typeA) :~: '(fieldB, typeB))
-> Maybe (fieldA :~: fieldB)
-> Maybe ('(fieldA, typeA) :~: '(fieldB, typeB))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy fieldA -> Proxy fieldB -> Maybe (fieldA :~: fieldB)
forall (a :: Symbol) (b :: Symbol).
(KnownSymbol a, KnownSymbol b) =>
Proxy a -> Proxy b -> Maybe (a :~: b)
sameSymbol (Proxy fieldA
forall k (t :: k). Proxy t
Proxy @fieldA) (Proxy fieldB
forall k (t :: k). Proxy t
Proxy @fieldB)