Switch to higgledy

cabal.project.haskell-nix

@@ -2,3 +2,9 @@
 -- will interpret them as local packages, and try to build them when we cabal
 -- build. The only reason we have to specify these is for Haskell.nix to know to
 -- override these packages by fetching them rather than using Hackage.
+
+source-repository-package
+  type: git
+  location: git://github.com/jcpetruzza/barbies
+  tag: f99b05454874192e3511bd133555dfb6cc6a6ecb
+  --sha256: 0yy2i2jbllwavv5d2176rf8lmm4l1ws90lxkmdlfgvfzqxidx0gi

default.nix

@@ -5,7 +5,7 @@ let
 
   nixpkgsArgs = haskellNix.nixpkgsArgs;
 
-  compiler-nix-name = "ghc901";
+  compiler-nix-name = "ghc8104";
 
   pkgs = import nixpkgsSrc nixpkgsArgs;
 

rel8.cabal

@@ -17,6 +17,7 @@ library
     , casing
     , contravariant
     , hasql ^>= 1.4.5.1
+    , higgledy
     , opaleye ^>= 0.7.1.0
     , profunctors
     , scientific

src/Rel8/Aggregate.hs

@@ -15,7 +15,7 @@ module Rel8.Aggregate
   ( Aggregate(..), foldInputs, mapInputs
   , Aggregator(..), unsafeMakeAggregate
   , Aggregates
-  , Col( Aggregation )
+  , Col( Aggregation, unAggregation )
   )
 where
 
@@ -60,7 +60,7 @@ newtype Aggregate a = Aggregate (Opaleye.Aggregator () a)
 instance Interpretation Aggregate where
   data Col Aggregate _spec where
     Aggregation :: ()
-      => Aggregate (Expr a)
+      => { unAggregation :: Aggregate (Expr a) }
       -> Col Aggregate ('Spec labels necessity a)
 
 

src/Rel8/Schema/Context.hs

@@ -4,7 +4,7 @@
 {-# language TypeFamilies #-}
 
 module Rel8.Schema.Context
-  ( Interpretation(..), Col( Result )
+  ( Interpretation(..), Col( Result, unResult )
   )
 where
 
@@ -25,4 +25,4 @@ class Interpretation context where
 
 instance Interpretation Identity where
   data Col Identity _spec where
-    Result :: a -> Col Identity ('Spec labels necessity a)
+    Result :: { unResult :: a } -> Col Identity ('Spec labels necessity a)

src/Rel8/Schema/Field.hs

@@ -4,6 +4,7 @@
 {-# language GADTs #-}
 {-# language LambdaCase #-}
 {-# language MultiParamTypeClasses #-}
+{-# language RankNTypes #-}
 {-# language ScopedTypeVariables #-}
 {-# language StandaloneKindSignatures #-}
 {-# language TypeApplications #-}
@@ -22,13 +23,18 @@ module Rel8.Schema.Field
 where
 
 -- base
+import Control.Applicative ( Const( Const ), getConst )
 import Data.Bifunctor ( Bifunctor, bimap )
-import Data.Functor.Identity ( Identity )
+import Data.Functor.Compose ( Compose( Compose ), getCompose )
+import Data.Functor.Identity ( Identity, runIdentity )
 import Data.Kind ( Constraint, Type )
 import Data.List.NonEmpty ( NonEmpty )
 import GHC.Generics
 import Prelude
 
+-- higgledy
+import Data.Generic.HKD ( Construct, HKD( HKD ), GHKD_, construct, deconstruct, runHKD )
+
 -- rel8
 import Rel8.Aggregate ( Aggregate, Col(..) )
 import Rel8.Expr ( Expr, Col(..) )
@@ -137,12 +143,12 @@ type family HThese context where
 type Lift :: K.Context -> Type -> Type
 type family Lift context a where
   Lift (Reify context) a = ALift context a
-  Lift Aggregate a = GHKD (Rep a) (Col Aggregate)
-  Lift Expr a = GHKD (Rep a) (Col Expr)
+  Lift Aggregate a = HKD a (Compose Aggregate Expr)
+  Lift Expr a = HKD a Expr
   Lift Identity a = a
-  Lift Insert a = GHKD (Rep a) (Col Insert)
-  Lift Name a = GHKD (Rep a) (Col Name)
-  Lift f a = GHKD (Rep a) (Col f)
+  Lift Insert a = HKD a Expr
+  Lift Name a = HKD a (Const String)
+  Lift f a = HKD a f
 
 
 type AField :: K.Context -> Necessity -> Type -> Type
@@ -318,10 +324,10 @@ instance
 
 
 type ALift :: K.Context -> Type -> Type
-newtype ALift context a = ALift (Lift context a)
+newtype ALift context a = ALift { runALift :: Lift context a }
 
 
-instance (Reifiable context, HTable (GHKD (Rep a)), Generic a, GHKDC (Rep a))
+instance (Reifiable context, HTable (GHKD (Rep a)), Generic a, GHKDC (Rep a), Construct Identity a)
   => Table (Reify context) (ALift context a)
  where
   type Context (ALift context a) = Reify context
@@ -345,6 +351,7 @@ instance
   , GHKD (Rep a) ~ GHKD (Rep a')
   , Generic a, Generic a'
   , GHKDC (Rep a), GHKDC (Rep a')
+  , Construct Identity a, Construct Identity a'
   ) =>
   Recontextualize
     (Reify context)
@@ -769,50 +776,57 @@ stoColumnsThese = \case
     (\(AHThese a) -> a)
 
 
-sfromColumnsLift :: (HTable (GHKD (Rep a)), Generic a, GHKDC (Rep a))
+sfromColumnsLift :: forall a context. (HTable (GHKD (Rep a)), Generic a, GHKDC (Rep a), Construct Identity a)
   => SContext context
   -> GHKD (Rep a) (Col (Reify context))
   -> ALift context a
 sfromColumnsLift = \case
-  SAggregate -> ALift . hunreify
-  SExpr -> ALift . hunreify
-  SInsert -> ALift . hunreify
-  SName -> ALift . hunreify
+  SAggregate -> ALift . HKD . fromGHKD (Compose . unAggregation) . hunreify
+  SExpr -> ALift . HKD . fromGHKD unDB . hunreify
+  SInsert -> ALift . HKD . fromGHKD (\(RequiredInsert expr) -> expr) . hunreify
+  SName -> ALift . HKD . fromGHKD (Const . unNameCol) . hunreify
   SReify context -> ALift . sfromColumnsLift context . hunreify 
-  SIdentity -> ALift . to . fromGHKD . hunreify
+  SIdentity -> ALift . runIdentity . construct . HKD  . fromGHKD (pure . unResult) . hunreify
 
 
-stoColumnsLift :: (HTable (GHKD (Rep a)), GHKDC (Rep a), Generic a)
+stoColumnsLift :: (HTable (GHKD (Rep a)), GHKDC (Rep a), Generic a, Construct Identity a)
   => SContext context
   -> ALift context a
   -> GHKD (Rep a) (Col (Reify context))
 stoColumnsLift = \case
-  SAggregate -> \(ALift x) -> hreify x
-  SExpr -> \(ALift x) -> hreify x
-  SName -> \(ALift x) -> hreify x
-  SInsert -> \(ALift x) -> hreify x
-  SIdentity -> \(ALift x) -> hreify $ toGHKD $ from x
+  SAggregate -> hreify . toGHKD (Aggregation . getCompose) . runHKD . runALift
+  SExpr -> hreify . toGHKD DB . runHKD . runALift
+  SName -> hreify . toGHKD (NameCol . getConst) . runHKD . runALift
+  SInsert -> hreify . toGHKD RequiredInsert . runHKD . runALift
+  SIdentity -> hreify . toGHKD (Result . runIdentity) . runHKD . deconstruct . runALift
   SReify context -> \(ALift x) -> hreify $ stoColumnsLift context x
 
 
 class GHKDC rep where
-  fromGHKD :: GHKD rep (Col Identity) -> rep x
-  toGHKD :: rep x -> GHKD rep (Col Identity)
+  fromGHKD :: ()
+    => (forall name a. Col context ('Spec name 'Required a) -> context' a) 
+    -> GHKD rep (Col context) 
+    -> GHKD_ context' rep x
+
+  toGHKD :: ()
+    => (forall name a. context' a -> Col context ('Spec name 'Required a))
+    -> GHKD_ context' rep x 
+    -> GHKD rep (Col context)
 
 
 instance (GHKD (M1 i c f) ~ GHKD f, GHKDC f) => GHKDC (M1 i c f) where
-  fromGHKD = M1 . fromGHKD @f
-  toGHKD (M1 x) = toGHKD x
+  fromGHKD f = M1 . fromGHKD @f f
+  toGHKD f (M1 x) = toGHKD f x
 
 
 instance {-# overlaps #-} GHKDC (M1 S ('MetaSel ('Just name) x y z) (K1 i a)) where
-  fromGHKD (HIdentity (Result x)) = M1 $ K1 x
-  toGHKD (M1 (K1 x)) = HIdentity (Result x)
+  fromGHKD f (HIdentity x) = M1 $ K1 $ f x
+  toGHKD f (M1 (K1 x)) = HIdentity (f x)
 
 
 instance (GHKDC f, GHKDC g) => GHKDC (f :*: g) where
-  fromGHKD (HPair x y) = fromGHKD x :*: fromGHKD y
-  toGHKD (x :*: y) = HPair (toGHKD x) (toGHKD y)
+  fromGHKD f (HPair x y) = fromGHKD f x :*: fromGHKD f y
+  toGHKD f (x :*: y) = HPair (toGHKD f x) (toGHKD f y)
 
 
 hreify :: HTable t => t (Col context) -> t (Col (Reify context))

src/Rel8/Schema/Name.hs

@@ -12,7 +12,7 @@
 
 module Rel8.Schema.Name
   ( Name(..)
-  , Col( NameCol )
+  , Col( NameCol, unNameCol )
   , Selects
   )
 where
@@ -69,7 +69,7 @@ instance Sql DBType a => Recontextualize Name Name (Name a) (Name a)
 
 
 instance Interpretation Name where
-  newtype Col Name _spec = NameCol String
+  newtype Col Name _spec = NameCol { unNameCol :: String }
 
 
 instance Labelable Name where