Lenses.hs

module Database.Beam.Schema.Lenses
    ( tableConfigLenses ) where

import Database.Beam.Internal
import Database.Beam.Schema.Tables
import Database.Beam.Schema.Fields

import Control.Applicative
import Control.Monad.Identity

import Data.Functor
import Data.Proxy

import GHC.Generics

import Lens.Micro hiding (to)

class GTableLenses t (m :: * -> *) a (lensType :: * -> *) 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 :: Proxy (M1 s d a)) lensToHere = M1 $ gTableLenses (Proxy :: Proxy a) (\f -> lensToHere (\(M1 x) -> M1 <$> f x))
instance (GTableLenses t m a aLens, GTableLenses t m b bLens) => GTableLenses t m (a :*: b) (aLens :*: bLens) where
    gTableLenses (Proxy :: Proxy (a :*: b)) lensToHere = leftLenses :*: rightLenses
        where leftLenses = gTableLenses (Proxy :: Proxy a) (\f -> lensToHere (\(a :*: b) -> (:*: b) <$> f a))
              rightLenses = gTableLenses (Proxy :: Proxy b) (\f -> lensToHere (\(a :*: b) -> (a :*:) <$> f b))
instance Generic (t m) => GTableLenses t m (K1 R x) (K1 R (LensFor (t m) x)) where
    gTableLenses _ lensToHere = K1 (LensFor (\f -> lensToHere (\(K1 x) -> K1 <$> f x)))
instance ( Generic (PrimaryKey rel m)
         , Generic (PrimaryKey rel (Lenses t m))
         , GTableLenses t m (Rep (PrimaryKey rel m)) (Rep (PrimaryKey rel (Lenses t m))) ) =>
         GTableLenses t m (K1 R (PrimaryKey rel m)) (K1 R (PrimaryKey rel (Lenses t m))) where
    gTableLenses _ lensToHere = K1 (to (gTableLenses (Proxy :: Proxy (Rep (PrimaryKey rel m))) (\f -> lensToHere (\(K1 x) -> K1 . to <$> f (from 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 :: Proxy t) (Proxy :: Proxy f) =
    to (gTableLenses (Proxy :: Proxy (Rep (t f))) ((\f x -> to <$> f (from x)) :: Lens' (t f) (Rep (t f) ())))

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 = let res = tableLenses' (tProxy res) (fProxy res)

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

simpleTableLenses :: ( lensType ~ Lenses t Identity
                     , Generic (t lensType)
                     , Generic (t Identity)
                     , GTableLenses t Identity (Rep (t Identity)) (Rep (t lensType)) ) =>
                     t (Lenses t Identity)
simpleTableLenses = tableLenses

-- | Automatically deduce lenses for 'TableSettings table'. You can expose the lenses at global level by doing a
--   top-level pattern match on 'tableConfigLenses', replacing every column in the pattern with `LensFor <nameOfLensForField>'.
--
--   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  :: ForeignKey AuthorT f
-- >                  , _blogPostTagline :: Columnar f (Maybe Text) }
-- >                    deriving Generic
-- > instance Table BlogPostT where
-- >    type PrimaryKey BlogPostT f = PK f Text
-- >    primaryKey = PK . _blogPostSlug
-- > instance Table AuthorT where
-- >    type PrimaryKey AuthorT f = PK f Text
-- >    primaryKey = PK . _authorEmail
--
-- > BlogPost (LensFor blogPostSlug
-- >          (LensFor blogPostBody)
-- >          (LensFor blogPostDate)
-- >          (ForeignKey (PK (LensFor blogPostAuthorEmail)))
-- >          (LensFor blogPostTagLine) = tableConfigLenses
tableConfigLenses :: ( lensType ~ Lenses t (TableField t)
                     , Generic (t lensType)
                     , Generic (t (TableField t))
                     , GTableLenses t (TableField t) (Rep (t (TableField t))) (Rep (t lensType)) ) =>
                     t (Lenses t (TableField t))
tableConfigLenses = tableLenses

-- dbLenses :: ( Generic (db (LensForT db))
--             , Generic (db f)

--             , GTableLenses db f (Rep (db f)) (Rep (db (LensFor db))) ) =>
--             db (LensFor db)

-- dbLenses :: ( Generic (db (LensFor db))
--             , Generic (db f)

--             , GTableLenses db f (Rep (db f)) (Rep (db (LensFor db))) ) =>
--             db (LensFor db)
-- dbLenses = let res = dbLenses' (dbProxy res) (fProxy res)

--                   dbProxy :: t (Lenses t f) -> Proxy t
--                   dbProxy _ = Proxy
--                   fProxy :: t (Lenses t f) -> Proxy f
--                   fProxy _ = Proxy
--               in res