{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE UndecidableInstances #-}
module Database.Beam.Schema.Lenses
    ( tableLenses
    , TableLens(..)

    , dbLenses ) where

import Database.Beam.Schema.Tables

import Control.Monad.Identity

import Data.Kind (Type)
import Data.Proxy

import GHC.Generics

import Lens.Micro hiding (to)

class GTableLenses t (m :: Type -> Type) a (lensType :: Type -> Type) where
    gTableLenses :: Proxy a -> Lens' (t m) (a p) -> lensType ()
instance GTableLenses t m a al => GTableLenses t m (M1 s d a) (M1 s d al) where
    gTableLenses :: Proxy (M1 s d a) -> Lens' (t m) (M1 s d a p) -> M1 s d al ()
gTableLenses (Proxy (M1 s d a)
Proxy :: Proxy (M1 s d a)) Lens' (t m) (M1 s d a p)
lensToHere = al () -> M1 s d al ()
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (al () -> M1 s d al ()) -> al () -> M1 s d al ()
forall a b. (a -> b) -> a -> b
$ Proxy a -> Lens' (t m) (a p) -> al ()
forall k (t :: (* -> *) -> *) (m :: * -> *) (a :: k -> *)
       (lensType :: * -> *) (p :: k).
GTableLenses t m a lensType =>
Proxy a -> Lens' (t m) (a p) -> lensType ()
gTableLenses (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a) (\a p -> f (a p)
f -> (M1 s d a p -> f (M1 s d a p)) -> t m -> f (t m)
Lens' (t m) (M1 s d a p)
lensToHere (\(M1 a p
x) -> a p -> M1 s d a p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (a p -> M1 s d a p) -> f (a p) -> f (M1 s d a p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a p -> f (a p)
f a p
x))
instance (GTableLenses t m a aLens, GTableLenses t m b bLens) => GTableLenses t m (a :*: b) (aLens :*: bLens) where
    gTableLenses :: Proxy (a :*: b)
-> Lens' (t m) ((:*:) a b p) -> (:*:) aLens bLens ()
gTableLenses (Proxy (a :*: b)
Proxy :: Proxy (a :*: b)) Lens' (t m) ((:*:) a b p)
lensToHere = aLens ()
leftLenses aLens () -> bLens () -> (:*:) aLens bLens ()
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: bLens ()
rightLenses
        where leftLenses :: aLens ()
leftLenses = Proxy a -> Lens' (t m) (a p) -> aLens ()
forall k (t :: (* -> *) -> *) (m :: * -> *) (a :: k -> *)
       (lensType :: * -> *) (p :: k).
GTableLenses t m a lensType =>
Proxy a -> Lens' (t m) (a p) -> lensType ()
gTableLenses (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a) (\a p -> f (a p)
f -> ((:*:) a b p -> f ((:*:) a b p)) -> t m -> f (t m)
Lens' (t m) ((:*:) a b p)
lensToHere (\(a p
a :*: b p
b) -> (a p -> b p -> (:*:) a b p
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: b p
b) (a p -> (:*:) a b p) -> f (a p) -> f ((:*:) a b p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a p -> f (a p)
f a p
a))
              rightLenses :: bLens ()
rightLenses = Proxy b -> Lens' (t m) (b p) -> bLens ()
forall k (t :: (* -> *) -> *) (m :: * -> *) (a :: k -> *)
       (lensType :: * -> *) (p :: k).
GTableLenses t m a lensType =>
Proxy a -> Lens' (t m) (a p) -> lensType ()
gTableLenses (Proxy b
forall k (t :: k). Proxy t
Proxy :: Proxy b) (\b p -> f (b p)
f -> ((:*:) a b p -> f ((:*:) a b p)) -> t m -> f (t m)
Lens' (t m) ((:*:) a b p)
lensToHere (\(a p
a :*: b p
b) -> (a p
a a p -> b p -> (:*:) a b p
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*:) (b p -> (:*:) a b p) -> f (b p) -> f ((:*:) a b p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> b p -> f (b p)
f b p
b))
instance Generic (t m) => GTableLenses t m (K1 R x) (K1 R (LensFor (t m) x)) where
    gTableLenses :: Proxy (K1 R x)
-> Lens' (t m) (K1 R x p) -> K1 R (LensFor (t m) x) ()
gTableLenses Proxy (K1 R x)
_ Lens' (t m) (K1 R x p)
lensToHere = LensFor (t m) x -> K1 R (LensFor (t m) x) ()
forall k i c (p :: k). c -> K1 i c p
K1 (Lens' (t m) x -> LensFor (t m) x
forall t x. Generic t => Lens' t x -> LensFor t x
LensFor (\x -> f x
f -> (K1 R x p -> f (K1 R x p)) -> t m -> f (t m)
Lens' (t m) (K1 R x p)
lensToHere (\(K1 x
x) -> x -> K1 R x p
forall k i c (p :: k). c -> K1 i c p
K1 (x -> K1 R x p) -> f x -> f (K1 R x p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> x -> f x
f x
x)))

instance ( Generic (sub m)
         , Generic (sub (Lenses t m))
         , GTableLenses t m (Rep (sub m)) (Rep (sub (Lenses t m))) ) =>
         GTableLenses t m (K1 R (sub m)) (K1 R (sub (Lenses t m))) where
    gTableLenses :: Proxy (K1 R (sub m))
-> Lens' (t m) (K1 R (sub m) p) -> K1 R (sub (Lenses t m)) ()
gTableLenses Proxy (K1 R (sub m))
_ Lens' (t m) (K1 R (sub m) p)
lensToHere = sub (Lenses t m) -> K1 R (sub (Lenses t m)) ()
forall k i c (p :: k). c -> K1 i c p
K1 (Rep (sub (Lenses t m)) () -> sub (Lenses t m)
forall a x. Generic a => Rep a x -> a
to (Proxy (Rep (sub m))
-> Lens' (t m) (Rep (sub m) Any) -> Rep (sub (Lenses t m)) ()
forall k (t :: (* -> *) -> *) (m :: * -> *) (a :: k -> *)
       (lensType :: * -> *) (p :: k).
GTableLenses t m a lensType =>
Proxy a -> Lens' (t m) (a p) -> lensType ()
gTableLenses (Proxy (Rep (sub m))
forall k (t :: k). Proxy t
Proxy :: Proxy (Rep (sub m))) (\Rep (sub m) Any -> f (Rep (sub m) Any)
f -> (K1 R (sub m) p -> f (K1 R (sub m) p)) -> t m -> f (t m)
Lens' (t m) (K1 R (sub m) p)
lensToHere (\(K1 sub m
x) -> sub m -> K1 R (sub m) p
forall k i c (p :: k). c -> K1 i c p
K1 (sub m -> K1 R (sub m) p)
-> (Rep (sub m) Any -> sub m) -> Rep (sub m) Any -> K1 R (sub m) p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rep (sub m) Any -> sub m
forall a x. Generic a => Rep a x -> a
to (Rep (sub m) Any -> K1 R (sub m) p)
-> f (Rep (sub m) Any) -> f (K1 R (sub m) p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Rep (sub m) Any -> f (Rep (sub m) Any)
f (sub m -> Rep (sub m) Any
forall a x. Generic a => a -> Rep a x
from sub m
x)))))

instance ( Generic (sub (Nullable m))
         , Generic (sub (Nullable (Lenses t m)))
         , GTableLenses t m (Rep (sub (Nullable m))) (Rep (sub (Nullable (Lenses t m))))) =>
         GTableLenses t m (K1 R (sub (Nullable m))) (K1 R (sub (Nullable (Lenses t m)))) where
    gTableLenses :: Proxy (K1 R (sub (Nullable m)))
-> Lens' (t m) (K1 R (sub (Nullable m)) p)
-> K1 R (sub (Nullable (Lenses t m))) ()
gTableLenses Proxy (K1 R (sub (Nullable m)))
_ Lens' (t m) (K1 R (sub (Nullable m)) p)
lensToHere = sub (Nullable (Lenses t m))
-> K1 R (sub (Nullable (Lenses t m))) ()
forall k i c (p :: k). c -> K1 i c p
K1 (Rep (sub (Nullable (Lenses t m))) () -> sub (Nullable (Lenses t m))
forall a x. Generic a => Rep a x -> a
to (Proxy (Rep (sub (Nullable m)))
-> Lens' (t m) (Rep (sub (Nullable m)) Any)
-> Rep (sub (Nullable (Lenses t m))) ()
forall k (t :: (* -> *) -> *) (m :: * -> *) (a :: k -> *)
       (lensType :: * -> *) (p :: k).
GTableLenses t m a lensType =>
Proxy a -> Lens' (t m) (a p) -> lensType ()
gTableLenses (Proxy (Rep (sub (Nullable m)))
forall k (t :: k). Proxy t
Proxy :: Proxy (Rep (sub (Nullable m)))) (\Rep (sub (Nullable m)) Any -> f (Rep (sub (Nullable m)) Any)
f -> (K1 R (sub (Nullable m)) p -> f (K1 R (sub (Nullable m)) p))
-> t m -> f (t m)
Lens' (t m) (K1 R (sub (Nullable m)) p)
lensToHere (\(K1 sub (Nullable m)
x) -> sub (Nullable m) -> K1 R (sub (Nullable m)) p
forall k i c (p :: k). c -> K1 i c p
K1 (sub (Nullable m) -> K1 R (sub (Nullable m)) p)
-> (Rep (sub (Nullable m)) Any -> sub (Nullable m))
-> Rep (sub (Nullable m)) Any
-> K1 R (sub (Nullable m)) p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rep (sub (Nullable m)) Any -> sub (Nullable m)
forall a x. Generic a => Rep a x -> a
to (Rep (sub (Nullable m)) Any -> K1 R (sub (Nullable m)) p)
-> f (Rep (sub (Nullable m)) Any) -> f (K1 R (sub (Nullable m)) p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Rep (sub (Nullable m)) Any -> f (Rep (sub (Nullable m)) Any)
f (sub (Nullable m) -> Rep (sub (Nullable m)) Any
forall a x. Generic a => a -> Rep a x
from sub (Nullable m)
x)))))

tableLenses' :: ( lensType ~ Lenses t f
                , Generic (t lensType)
                , Generic (t f)
                , GTableLenses t f (Rep (t f)) (Rep (t lensType)) ) =>
                 Proxy t -> Proxy f -> t lensType
tableLenses' :: Proxy t -> Proxy f -> t lensType
tableLenses' (Proxy t
Proxy :: Proxy t) (Proxy f
Proxy :: Proxy f) =
    Rep (t lensType) () -> t lensType
forall a x. Generic a => Rep a x -> a
to (Proxy (Rep (t f))
-> Lens' (t f) (Rep (t f) ()) -> Rep (t (Lenses t f)) ()
forall k (t :: (* -> *) -> *) (m :: * -> *) (a :: k -> *)
       (lensType :: * -> *) (p :: k).
GTableLenses t m a lensType =>
Proxy a -> Lens' (t m) (a p) -> lensType ()
gTableLenses (Proxy (Rep (t f))
forall k (t :: k). Proxy t
Proxy :: Proxy (Rep (t f))) ((\Rep (t f) () -> f (Rep (t f) ())
f t f
x -> Rep (t f) () -> t f
forall a x. Generic a => Rep a x -> a
to (Rep (t f) () -> t f) -> f (Rep (t f) ()) -> f (t f)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Rep (t f) () -> f (Rep (t f) ())
f (t f -> Rep (t f) ()
forall a x. Generic a => a -> Rep a x
from t f
x)) :: Lens' (t f) (Rep (t f) ())))

-- | Automatically deduce lenses for a table over any column tag. lenses at
--   global level by doing a top-level pattern match on 'tableLenses', replacing
--   every column in the pattern with `LensFor <nameOfLensForField>'. The lenses
--   are generated per-column, not per field in the record. Thus if you have
--   nested 'Beamable' types, lenses are generated for each nested field.
--
--   For example,
--
-- > data AuthorT f = AuthorT
-- >                { _authorEmail     :: Columnar f Text
-- >                , _authorFirstName :: Columnar f Text
-- >                , _authorLastName  :: Columnar f Text }
-- >                  deriving Generic
-- >
-- > data BlogPostT f = BlogPost
-- >                  { _blogPostSlug    :: Columnar f Text
-- >                  , _blogPostBody    :: Columnar f Text
-- >                  , _blogPostDate    :: Columnar f UTCTime
-- >                  , _blogPostAuthor  :: PrimaryKey AuthorT f
-- >                  , _blogPostTagline :: Columnar f (Maybe Text) }
-- >                    deriving Generic
-- > instance Table BlogPostT where
-- >    data PrimaryKey BlogPostT f = BlogPostId (Columnar f Text)
-- >    primaryKey = BlogPostId . _blogPostSlug
-- > instance Table AuthorT where
-- >    data PrimaryKey AuthorT f = AuthorId (Columnar f Text)
-- >    primaryKey = AuthorId . _authorEmail
--
-- > BlogPost (LensFor blogPostSlug
-- >          (LensFor blogPostBody)
-- >          (LensFor blogPostDate)
-- >          (AuthorId (LensFor blogPostAuthorEmail))
-- >          (LensFor blogPostTagLine) = tableLenses
--
--   Note: In order to have GHC deduce the right type, you will need to turn off
--   the monomorphism restriction. This is a part of the Haskell standard that
--   specifies that top-level definitions must be inferred to have a monomorphic
--   type. However, lenses need a polymorphic type to work properly. You can
--   turn off the monomorphism restriction by enabling the
--   'NoMonomorphismRestriction' extension. You can do this per-file by using
--   the {-# LANGUAGE NoMonomorphismRestriction #-} pragma at the top of the
--   file. You can also pass the @-XNoMonomorphismRestriction@ command line flag
--   to GHC during compilation.
tableLenses :: ( lensType ~ Lenses t f
                , Generic (t lensType)
                , Generic (t f)
                , GTableLenses t f (Rep (t f)) (Rep (t lensType)) ) =>
               t (Lenses t f)
tableLenses :: t (Lenses t f)
tableLenses = let res :: t (Lenses t f)
res = Proxy t -> Proxy f -> t (Lenses t f)
forall (lensType :: * -> *) (t :: (* -> *) -> *) (f :: * -> *).
(lensType ~ Lenses t f, Generic (t lensType), Generic (t f),
 GTableLenses t f (Rep (t f)) (Rep (t lensType))) =>
Proxy t -> Proxy f -> t lensType
tableLenses' (t (Lenses t f) -> Proxy t
forall (t :: (* -> *) -> *) (f :: * -> *).
t (Lenses t f) -> Proxy t
tProxy t (Lenses t f)
res) (t (Lenses t f) -> Proxy f
forall (t :: (* -> *) -> *) (f :: * -> *).
t (Lenses t f) -> Proxy f
fProxy t (Lenses t f)
res)

                  tProxy :: t (Lenses t f) -> Proxy t
                  tProxy :: t (Lenses t f) -> Proxy t
tProxy t (Lenses t f)
_ = Proxy t
forall k (t :: k). Proxy t
Proxy
                  fProxy :: t (Lenses t f) -> Proxy f
                  fProxy :: t (Lenses t f) -> Proxy f
fProxy t (Lenses t f)
_ = Proxy f
forall k (t :: k). Proxy t
Proxy
              in t (Lenses t f)
res

newtype TableLens f db (x :: k) = TableLens (Lens' (db f) (f x))

class GDatabaseLenses outer structure lensType where
    gDatabaseLenses :: Lens' outer (structure p) -> lensType ()
instance GDatabaseLenses db a al => GDatabaseLenses db (M1 s d a) (M1 s d al) where
    gDatabaseLenses :: Lens' db (M1 s d a p) -> M1 s d al ()
gDatabaseLenses Lens' db (M1 s d a p)
lensToHere = al () -> M1 s d al ()
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (al () -> M1 s d al ()) -> al () -> M1 s d al ()
forall a b. (a -> b) -> a -> b
$ Lens' db (a p) -> al ()
forall k outer (structure :: k -> *) (lensType :: * -> *) (p :: k).
GDatabaseLenses outer structure lensType =>
Lens' outer (structure p) -> lensType ()
gDatabaseLenses (\a p -> f (a p)
f -> (M1 s d a p -> f (M1 s d a p)) -> db -> f db
Lens' db (M1 s d a p)
lensToHere (\(M1 a p
x) -> a p -> M1 s d a p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (a p -> M1 s d a p) -> f (a p) -> f (M1 s d a p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a p -> f (a p)
f a p
x))
instance (GDatabaseLenses db a al, GDatabaseLenses db b bl) => GDatabaseLenses db (a :*: b) (al :*: bl) where
    gDatabaseLenses :: Lens' db ((:*:) a b p) -> (:*:) al bl ()
gDatabaseLenses Lens' db ((:*:) a b p)
lensToHere = al ()
leftLenses al () -> bl () -> (:*:) al bl ()
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: bl ()
rightLenses
        where leftLenses :: al ()
leftLenses = Lens' db (a p) -> al ()
forall k outer (structure :: k -> *) (lensType :: * -> *) (p :: k).
GDatabaseLenses outer structure lensType =>
Lens' outer (structure p) -> lensType ()
gDatabaseLenses (\a p -> f (a p)
f -> ((:*:) a b p -> f ((:*:) a b p)) -> db -> f db
Lens' db ((:*:) a b p)
lensToHere (\(a p
a :*: b p
b) -> (a p -> b p -> (:*:) a b p
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: b p
b) (a p -> (:*:) a b p) -> f (a p) -> f ((:*:) a b p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a p -> f (a p)
f a p
a))
              rightLenses :: bl ()
rightLenses = Lens' db (b p) -> bl ()
forall k outer (structure :: k -> *) (lensType :: * -> *) (p :: k).
GDatabaseLenses outer structure lensType =>
Lens' outer (structure p) -> lensType ()
gDatabaseLenses (\b p -> f (b p)
f -> ((:*:) a b p -> f ((:*:) a b p)) -> db -> f db
Lens' db ((:*:) a b p)
lensToHere (\(a p
a :*: b p
b) -> (a p
a a p -> b p -> (:*:) a b p
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*:) (b p -> (:*:) a b p) -> f (b p) -> f ((:*:) a b p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> b p -> f (b p)
f b p
b))
instance GDatabaseLenses (db f) (K1 R (f x))
                                (K1 R (TableLens f db x)) where
    gDatabaseLenses :: Lens' (db f) (K1 R (f x) p) -> K1 R (TableLens f db x) ()
gDatabaseLenses Lens' (db f) (K1 R (f x) p)
lensToHere = TableLens f db x -> K1 R (TableLens f db x) ()
forall k i c (p :: k). c -> K1 i c p
K1 (Lens' (db f) (f x) -> TableLens f db x
forall k (f :: k -> *) (db :: (k -> *) -> *) (x :: k).
Lens' (db f) (f x) -> TableLens f db x
TableLens (\f x -> f (f x)
f -> (K1 R (f x) p -> f (K1 R (f x) p)) -> db f -> f (db f)
Lens' (db f) (K1 R (f x) p)
lensToHere (\(K1 f x
x) -> f x -> K1 R (f x) p
forall k i c (p :: k). c -> K1 i c p
K1 (f x -> K1 R (f x) p) -> f (f x) -> f (K1 R (f x) p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f x -> f (f x)
f f x
x)))

-- | Like 'tableLenses' but for types that are instances of 'Database'. Instead
--   of pattern matching on 'LensFor', pattern match on 'TableLens'.
dbLenses :: ( Generic (db (TableLens f db))
            , Generic (db f)
            , GDatabaseLenses (db f) (Rep (db f)) (Rep (db (TableLens f db))) )
           => db (TableLens f db)
dbLenses :: db (TableLens f db)
dbLenses = (db (TableLens f db) -> db (TableLens f db)) -> db (TableLens f db)
forall a. (a -> a) -> a
fix ((db (TableLens f db) -> db (TableLens f db))
 -> db (TableLens f db))
-> (db (TableLens f db) -> db (TableLens f db))
-> db (TableLens f db)
forall a b. (a -> b) -> a -> b
$ \(db (TableLens f db)
_ :: db (TableLens f db)) ->
           Rep (db (TableLens f db)) () -> db (TableLens f db)
forall a x. Generic a => Rep a x -> a
to (Lens' (db f) (Rep (db f) Any) -> Rep (db (TableLens f db)) ()
forall k outer (structure :: k -> *) (lensType :: * -> *) (p :: k).
GDatabaseLenses outer structure lensType =>
Lens' outer (structure p) -> lensType ()
gDatabaseLenses (\Rep (db f) Any -> f (Rep (db f) Any)
f (x :: db f) -> Rep (db f) Any -> db f
forall a x. Generic a => Rep a x -> a
to (Rep (db f) Any -> db f) -> f (Rep (db f) Any) -> f (db f)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Rep (db f) Any -> f (Rep (db f) Any)
f (db f -> Rep (db f) Any
forall a x. Generic a => a -> Rep a x
from db f
x)) :: Rep (db (TableLens f db)) ())