{-# 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 :: forall (p :: k).
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 = forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall a b. (a -> b) -> a -> b
$ forall {k} (t :: (* -> *) -> *) (m :: * -> *) (a :: k -> *)
       (lensType :: * -> *) (p :: k).
GTableLenses t m a lensType =>
Proxy a -> Lens' (t m) (a p) -> lensType ()
gTableLenses (forall {k} (t :: k). Proxy t
Proxy :: Proxy a) (\a p -> f (a p)
f -> Lens' (t m) (M1 s d a p)
lensToHere (\(M1 a p
x) -> forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 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 :: forall (p :: k).
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 forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: bLens ()
rightLenses
        where leftLenses :: aLens ()
leftLenses = forall {k} (t :: (* -> *) -> *) (m :: * -> *) (a :: k -> *)
       (lensType :: * -> *) (p :: k).
GTableLenses t m a lensType =>
Proxy a -> Lens' (t m) (a p) -> lensType ()
gTableLenses (forall {k} (t :: k). Proxy t
Proxy :: Proxy a) (\a p -> f (a p)
f -> Lens' (t m) ((:*:) a b p)
lensToHere (\(a p
a :*: b p
b) -> (forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: b p
b) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a p -> f (a p)
f a p
a))
              rightLenses :: bLens ()
rightLenses = forall {k} (t :: (* -> *) -> *) (m :: * -> *) (a :: k -> *)
       (lensType :: * -> *) (p :: k).
GTableLenses t m a lensType =>
Proxy a -> Lens' (t m) (a p) -> lensType ()
gTableLenses (forall {k} (t :: k). Proxy t
Proxy :: Proxy b) (\b p -> f (b p)
f -> Lens' (t m) ((:*:) a b p)
lensToHere (\(a p
a :*: b p
b) -> (a p
a forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g 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 :: forall (p :: k).
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 = forall k i c (p :: k). c -> K1 i c p
K1 (forall t x. Generic t => Lens' t x -> LensFor t x
LensFor (\x -> f x
f -> Lens' (t m) (K1 R x p)
lensToHere (\(K1 x
x) -> forall k i c (p :: k). c -> K1 i c p
K1 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 :: forall (p :: k).
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 = forall k i c (p :: k). c -> K1 i c p
K1 (forall a x. Generic a => Rep a x -> a
to (forall {k} (t :: (* -> *) -> *) (m :: * -> *) (a :: k -> *)
       (lensType :: * -> *) (p :: k).
GTableLenses t m a lensType =>
Proxy a -> Lens' (t m) (a p) -> lensType ()
gTableLenses (forall {k} (t :: k). Proxy t
Proxy :: Proxy (Rep (sub m))) (\Rep (sub m) Any -> f (Rep (sub m) Any)
f -> Lens' (t m) (K1 R (sub m) p)
lensToHere (\(K1 sub m
x) -> forall k i c (p :: k). c -> K1 i c p
K1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a x. Generic a => Rep a x -> a
to forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Rep (sub m) Any -> f (Rep (sub m) Any)
f (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 :: forall (p :: k).
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 = forall k i c (p :: k). c -> K1 i c p
K1 (forall a x. Generic a => Rep a x -> a
to (forall {k} (t :: (* -> *) -> *) (m :: * -> *) (a :: k -> *)
       (lensType :: * -> *) (p :: k).
GTableLenses t m a lensType =>
Proxy a -> Lens' (t m) (a p) -> lensType ()
gTableLenses (forall {k} (t :: k). Proxy t
Proxy :: Proxy (Rep (sub (Nullable m)))) (\Rep (sub (Nullable m)) Any -> f (Rep (sub (Nullable m)) Any)
f -> Lens' (t m) (K1 R (sub (Nullable m)) p)
lensToHere (\(K1 sub (Nullable m)
x) -> forall k i c (p :: k). c -> K1 i c p
K1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a x. Generic a => Rep a x -> a
to forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Rep (sub (Nullable m)) Any -> f (Rep (sub (Nullable m)) Any)
f (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' :: 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' (Proxy t
Proxy :: Proxy t) (Proxy f
Proxy :: Proxy f) =
    forall a x. Generic a => Rep a x -> a
to (forall {k} (t :: (* -> *) -> *) (m :: * -> *) (a :: k -> *)
       (lensType :: * -> *) (p :: k).
GTableLenses t m a lensType =>
Proxy a -> Lens' (t m) (a p) -> lensType ()
gTableLenses (forall {k} (t :: k). Proxy t
Proxy :: Proxy (Rep (t f))) ((\Rep (t f) () -> f (Rep (t f) ())
f t f
x -> forall a x. Generic a => Rep a x -> a
to forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Rep (t f) () -> f (Rep (t f) ())
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 :: forall (lensType :: * -> *) (t :: (* -> *) -> *) (f :: * -> *).
(lensType ~ Lenses t f, Generic (t lensType), Generic (t f),
 GTableLenses t f (Rep (t f)) (Rep (t lensType))) =>
t (Lenses t f)
tableLenses = let res :: t (Lenses t f)
res = 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' (forall (t :: (* -> *) -> *) (f :: * -> *).
t (Lenses t f) -> Proxy t
tProxy t (Lenses t f)
res) (forall (t :: (* -> *) -> *) (f :: * -> *).
t (Lenses t f) -> Proxy f
fProxy t (Lenses t f)
res)

                  tProxy :: t (Lenses t f) -> Proxy t
                  tProxy :: forall (t :: (* -> *) -> *) (f :: * -> *).
t (Lenses t f) -> Proxy t
tProxy t (Lenses t f)
_ = forall {k} (t :: k). Proxy t
Proxy
                  fProxy :: t (Lenses t f) -> Proxy f
                  fProxy :: forall (t :: (* -> *) -> *) (f :: * -> *).
t (Lenses t f) -> Proxy f
fProxy t (Lenses t 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 :: forall (p :: k). Lens' db (M1 s d a p) -> M1 s d al ()
gDatabaseLenses Lens' db (M1 s d a p)
lensToHere = forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall a b. (a -> b) -> a -> b
$ forall {k} outer (structure :: k -> *) (lensType :: * -> *)
       (p :: k).
GDatabaseLenses outer structure lensType =>
Lens' outer (structure p) -> lensType ()
gDatabaseLenses (\a p -> f (a p)
f -> Lens' db (M1 s d a p)
lensToHere (\(M1 a p
x) -> forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 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 :: forall (p :: k). Lens' db ((:*:) a b p) -> (:*:) al bl ()
gDatabaseLenses Lens' db ((:*:) a b p)
lensToHere = al ()
leftLenses forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: bl ()
rightLenses
        where leftLenses :: al ()
leftLenses = forall {k} outer (structure :: k -> *) (lensType :: * -> *)
       (p :: k).
GDatabaseLenses outer structure lensType =>
Lens' outer (structure p) -> lensType ()
gDatabaseLenses (\a p -> f (a p)
f -> Lens' db ((:*:) a b p)
lensToHere (\(a p
a :*: b p
b) -> (forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: b p
b) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a p -> f (a p)
f a p
a))
              rightLenses :: bl ()
rightLenses = forall {k} outer (structure :: k -> *) (lensType :: * -> *)
       (p :: k).
GDatabaseLenses outer structure lensType =>
Lens' outer (structure p) -> lensType ()
gDatabaseLenses (\b p -> f (b p)
f -> Lens' db ((:*:) a b p)
lensToHere (\(a p
a :*: b p
b) -> (a p
a forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g 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 :: forall (p :: k).
Lens' (db f) (K1 R (f x) p) -> K1 R (TableLens f db x) ()
gDatabaseLenses Lens' (db f) (K1 R (f x) p)
lensToHere = forall k i c (p :: k). c -> K1 i c p
K1 (forall k (f :: k -> *) (db :: (k -> *) -> *) (x :: k).
Lens' (db f) (f x) -> TableLens f db x
TableLens (\f x -> f (f x)
f -> Lens' (db f) (K1 R (f x) p)
lensToHere (\(K1 f x
x) -> forall k i c (p :: k). c -> K1 i c p
K1 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 :: forall {k} (db :: (k -> *) -> *) (f :: k -> *).
(Generic (db (TableLens f db)), Generic (db f),
 GDatabaseLenses (db f) (Rep (db f)) (Rep (db (TableLens f db)))) =>
db (TableLens f db)
dbLenses = forall a. (a -> a) -> a
fix forall a b. (a -> b) -> a -> b
$ \(db (TableLens f db)
_ :: db (TableLens f db)) ->
           forall a x. Generic a => Rep a x -> a
to (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 (db f
x :: db f) -> forall a x. Generic a => Rep a x -> a
to forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Rep (db f) Any -> f (Rep (db f) Any)
f (forall a x. Generic a => a -> Rep a x
from db f
x)) :: Rep (db (TableLens f db)) ())