Restore litTable (sort of)

rel8.cabal

@@ -33,9 +33,11 @@ library
     Rel8.EqTable
     Rel8.Expr
     Rel8.FromRow
+    Rel8.Lit
     Rel8.MaybeTable
     Rel8.Optimize
     Rel8.Query
+    Rel8.Recontextualise
     Rel8.SimpleConstraints
     Rel8.TableSchema
     Rel8.Unconstrained

src/Rel8.hs

@@ -98,6 +98,7 @@ import Rel8.DBEq
 import Rel8.EqTable
 import Rel8.Expr
 import Rel8.FromRow
+import Rel8.Lit
 import Rel8.MaybeTable
 import Rel8.Query
 import Rel8.Table

src/Rel8/Expr.hs

@@ -41,7 +41,6 @@ module Rel8.Expr
   , isNull
   , liftNull
   , traversePrimExpr
-  , litTable
   , ifThenElse_
   ) where
 
@@ -72,14 +71,6 @@ instance ( IsString a, DBType a ) => IsString ( Expr a ) where
     lit . fromString
 
 
--- TODO I should be more general
-litTable
-  :: (HigherKindedTable t, HConstrainTable t Expr DBType)
-  => t Identity -> t Expr
-litTable =
-  mapTableC @DBType (mapCC @DBType lit)
-
-
 -- | The SQL @AND@ operator.
 (&&.) :: Expr Bool -> Expr Bool -> Expr Bool
 (&&.) ( Expr a ) ( Expr b ) =
@@ -165,10 +156,6 @@ nullaryFunction_forAll name =
   const ( Expr ( Opaleye.FunExpr name [] ) ) ( lit @a undefined )
 
 
-newtype HIdentity a f = HIdentity { unHIdentity :: Column f a }
-  deriving ( Generic, HigherKindedTable )
-
-
 -- | Any 'Expr' can be seen as a 'Table' with only one column.
 instance Table (Expr a) where
   type Context (Expr a) = Expr

src/Rel8/Lit.hs

@@ -0,0 +1,26 @@
+{-# language FlexibleContexts #-}
+{-# language TypeApplications #-}
+{-# language TypeFamilies #-}
+{-# language UndecidableSuperClasses #-}
+
+module Rel8.Lit
+  ( litTable
+  ) where
+
+import Data.Functor.Identity
+import Data.Proxy
+import Rel8.Column
+import Rel8.DBType
+import Rel8.Expr
+import Rel8.Recontextualise
+import Rel8.Table
+
+
+litTable
+  :: ( HConstrainTable (Structure b) (Context b) DBType
+     , Context a ~ Identity
+     , Context b ~ Expr
+     , Recontextualise Lit a b
+     )
+  => a -> b
+litTable = runIdentity . mapContext (Proxy @Lit) (Proxy @DBType) (Identity . mapCC @DBType lit)

src/Rel8/Recontextualise.hs

@@ -0,0 +1,71 @@
+{-# language ConstraintKinds #-}
+{-# language EmptyDataDecls #-}
+{-# language FlexibleInstances #-}
+{-# language FunctionalDependencies #-}
+{-# language KindSignatures #-}
+{-# language MultiParamTypeClasses #-}
+{-# language RankNTypes #-}
+{-# language TypeFamilies #-}
+{-# language UndecidableInstances #-}
+
+module Rel8.Recontextualise
+  ( Apply
+  , Lit
+  , Recontextualise (MapContext, mapContext)
+  )
+where
+
+import Data.Functor.Identity ( Identity( Identity ) )
+import Data.Kind ( Type )
+import Rel8.Column ( C( MkC ) )
+import Rel8.Expr ( Expr )
+import Rel8.Table
+
+
+type family Apply (g :: (Type -> Type) -> Type -> Type) (f :: Type -> Type) :: Type -> Type where
+  Apply Lit Identity = Expr
+  Apply g f = g f
+
+
+data Lit (f :: Type -> Type) a
+
+
+class
+  ( Table a
+  , Table b
+  , MapContext g a ~ b
+  , Structure a ~ Structure b
+  , Apply g (Context a) ~ Context b
+  ) =>
+    Recontextualise g a b
+  where
+
+  type MapContext (g :: (Type -> Type) -> Type -> Type) a :: Type
+
+  mapContext :: (Applicative m, HConstrainTable (Structure a) (Context b) c)
+    => proxy g
+    -> proxy' c
+    -> (forall x. c x => C (Context a) x -> m (C (Context b) x))
+    -> a
+    -> m b
+
+
+instance (HigherKindedTable t, f' ~ Apply g f) => Recontextualise g (t f) (t f') where
+  type MapContext g (t f) = t (Apply g f)
+
+  mapContext _ c f as = htabulate c (\field -> f (hfield as field))
+
+
+instance (Recontextualise g a a', Recontextualise g b b', Context a ~ Context b) => Recontextualise g (a, b) (a', b') where
+  type MapContext g (a, b) = (MapContext g a, MapContext g b)
+
+  mapContext g c f (a, b) = (,) <$> mapContext g c f a <*> mapContext g c f b
+
+
+-- | FIXME: This isn't quite right
+instance Recontextualise Lit (Identity a) (Expr a) where
+  type MapContext Lit (Identity a) = Expr a
+
+  mapContext _ _ f (Identity a) = unC <$> f (MkC a)
+    where
+      unC (MkC x) = x

src/Rel8/Table.hs

@@ -10,7 +10,6 @@
 {-# language FunctionalDependencies #-}
 {-# language GADTs #-}
 {-# language LambdaCase #-}
-{-# language QuantifiedConstraints #-}
 {-# language RankNTypes #-}
 {-# language ScopedTypeVariables #-}
 {-# language StandaloneDeriving #-}
@@ -33,7 +32,6 @@ module Rel8.Table where
 import Data.Functor.Identity
 import Data.Kind
 import Data.Proxy
-import GHC.Exts ( Constraint )
 import GHC.Generics hiding ( C )
 import Rel8.Column
 import Rel8.Unconstrained
@@ -352,3 +350,15 @@ instance (Context a ~ f, Table a, Structure a ~ Structure a') => DispatchK1 'Fal
 
   k1tabulate proxy f =
     fromStructure <$> htabulate proxy (f . K1False)
+
+
+newtype HIdentity a f = HIdentity { unHIdentity :: Column f a }
+  deriving ( Generic, HigherKindedTable )
+
+
+-- | Any 'Expr' can be seen as a 'Table' with only one column.
+instance Table (Identity a) where
+  type Context (Identity a) = Identity
+  type Structure (Identity a) = HIdentity a
+  toStructure = HIdentity . runIdentity
+  fromStructure = Identity . unHIdentity