Simplify ToFromT (#225)

* Simplify ToFromT. Converted most closed type families to be associated type families with the exception of IsLateral, Nullable and the two new FromOnClause and FromCrossJoin type families that handle the overlaps instead of ToFromT

changelog.md

@@ -3,6 +3,10 @@
 - @arthurxavierx
   - [#221](https://github.com/bitemyapp/esqueleto/pull/221)
     - Deprecate `ToAliasT` and `ToAliasReferenceT`
+- @belevy
+  - [#225](https://github.com/bitemyapp/esqueleto/pull/225)
+    - Simplify `ToFromT` extracting the overlapping and type error instances
+    - Make `ToFromT` and associated type family of `ToFrom`
 
 3.4.0.0
 =======

src/Database/Esqueleto/Experimental.hs

@@ -52,11 +52,11 @@ module Database.Esqueleto.Experimental
 
       -- * Internals
     , ToFrom(..)
-    , ToFromT
     , ToMaybe(..)
-    , ToMaybeT
     , ToAlias(..)
+    , ToAliasT
     , ToAliasReference(..)
+    , ToAliasReferenceT
     -- * The Normal Stuff
 
     , where_
@@ -609,34 +609,27 @@ intersect_ :: a -> b -> Intersect a b
 intersect_ = Intersect
 
 class SetOperationT a ~ b => ToSetOperation a b | a -> b where
+    type SetOperationT a
     toSetOperation :: a -> SqlSetOperation b
-
 instance ToSetOperation (SqlSetOperation a) a where
+    type SetOperationT (SqlSetOperation a) = a
     toSetOperation = id
-
 instance ToSetOperation (SqlQuery a) a where
+    type SetOperationT (SqlQuery a) = a
     toSetOperation = SelectQueryP Never
-
 instance (ToSetOperation a c, ToSetOperation b c) => ToSetOperation (Union a b) c where
+    type SetOperationT (Union a b) = SetOperationT a
     toSetOperation (Union a b) = SqlSetUnion (toSetOperation a) (toSetOperation b)
-
 instance (ToSetOperation a c, ToSetOperation b c) => ToSetOperation (UnionAll a b) c where
+    type SetOperationT (UnionAll a b) = SetOperationT a
     toSetOperation (UnionAll a b) = SqlSetUnionAll (toSetOperation a) (toSetOperation b)
-
 instance (ToSetOperation a c, ToSetOperation b c) => ToSetOperation (Except a b) c where
+    type SetOperationT (Except a b) = SetOperationT a
     toSetOperation (Except a b) = SqlSetExcept (toSetOperation a) (toSetOperation b)
-
 instance (ToSetOperation a c, ToSetOperation b c) => ToSetOperation (Intersect a b) c where
+    type SetOperationT (Intersect a b) = SetOperationT a
     toSetOperation (Intersect a b) = SqlSetIntersect (toSetOperation a) (toSetOperation b)
 
-type family SetOperationT a where
-    SetOperationT (Union a b) = SetOperationT a
-    SetOperationT (UnionAll a b) = SetOperationT a
-    SetOperationT (Except a b) = SetOperationT a
-    SetOperationT (Intersect a b) = SetOperationT a
-    SetOperationT (SqlQuery a) = a
-    SetOperationT (SqlSetOperation a) = a
-
 {-# DEPRECATED SelectQuery "/Since: 3.4.0.0/ - It is no longer necessary to tag 'SqlQuery' values with @SelectQuery@" #-}
 pattern SelectQuery :: SqlQuery a -> SqlSetOperation a
 pattern SelectQuery q = SelectQueryP Never q
@@ -744,28 +737,6 @@ on :: ValidOnClauseValue a => a -> (b -> SqlExpr (Value Bool)) -> (a, b -> SqlEx
 on = (,)
 infix 9 `on`
 
-type JoinErrorMsg jk = 'Text "Missing on statement for " ':<>: 'Text jk
-
-type family ToFromT a where
-    ToFromT (From a) = a
-    ToFromT (SqlQuery a) = a
-    ToFromT (Union a b) = SetOperationT a
-    ToFromT (UnionAll a b) = SetOperationT a
-    ToFromT (Except a b) = SetOperationT a
-    ToFromT (Intersect a b) = SetOperationT a
-    ToFromT (SqlSetOperation a) = a
-    ToFromT (InnerJoin a (b, c -> SqlExpr (Value Bool))) = c
-    ToFromT (LeftOuterJoin a (b, c -> SqlExpr (Value Bool))) = c
-    ToFromT (RightOuterJoin a (b, c -> SqlExpr (Value Bool))) = c
-    ToFromT (FullOuterJoin a (b, c -> SqlExpr (Value Bool))) = c
-    ToFromT (CrossJoin a (c -> SqlQuery b)) = ToFromT a :& b
-    ToFromT (CrossJoin a b) = ToFromT a :& ToFromT b
-    ToFromT (InnerJoin a b) = TypeError (JoinErrorMsg "InnerJoin")
-    ToFromT (LeftOuterJoin a b) = TypeError (JoinErrorMsg "LeftOuterJoin")
-    ToFromT (RightOuterJoin a b) = TypeError (JoinErrorMsg "RightOuterJoin")
-    ToFromT (FullOuterJoin a b) = TypeError (JoinErrorMsg "FullOuterJoin")
-
-
 data Lateral
 data NotLateral
 
@@ -779,46 +750,100 @@ type family ErrorOnLateral a :: Constraint where
 
 {-- Type class magic to allow the use of the `InnerJoin` family of data constructors in from --}
 class ToFrom a where
+    type ToFromT a
     toFrom :: a -> From (ToFromT a)
 
-instance ToFrom (From a) where
+-- @since 3.4.0.1
-    toFrom = id
+type family FromOnClause a where
+    FromOnClause (a, b -> SqlExpr (Value Bool)) = b
+    FromOnClause a = TypeError ('Text "Missing ON clause")
 
 instance {-# OVERLAPPABLE #-} ToFrom (InnerJoin a b) where
+    type ToFromT (InnerJoin a b) = FromOnClause b
     toFrom = undefined
 instance {-# OVERLAPPABLE #-} ToFrom (LeftOuterJoin a b) where
-    toFrom = undefined
+    type ToFromT (LeftOuterJoin a b) = FromOnClause b
-instance {-# OVERLAPPABLE #-} ToFrom (RightOuterJoin a b) where
     toFrom = undefined
 instance {-# OVERLAPPABLE #-} ToFrom (FullOuterJoin a b) where
-
+    type ToFromT (FullOuterJoin a b) = FromOnClause b
+    toFrom = undefined
+instance {-# OVERLAPPABLE #-} ToFrom (RightOuterJoin a b) where
+    type ToFromT (RightOuterJoin a b) = FromOnClause b
     toFrom = undefined
 
-instance ( ToAlias a
+instance ToFrom (From a) where
+    type ToFromT (From a) = a
+    toFrom = id
+
+instance
+    ( ToAlias a
     , ToAliasReference a
     , SqlSelect a r
-         ) => ToFrom (SqlQuery a) where
+    )
+  =>
+    ToFrom (SqlQuery a)
+  where
+    type ToFromT (SqlQuery a) = a
     toFrom = SubQuery
 
-instance ( SqlSelect c r
+instance
+    ( SqlSelect c r
     , ToAlias c
     , ToAliasReference c
     , ToSetOperation a c
     , ToSetOperation b c
     , c ~ SetOperationT a
-         )  => ToFrom (Union a b) where
+    )
+  =>
+    ToFrom (Union a b)
+  where
+    type ToFromT (Union a b) = SetOperationT a
     toFrom u = SqlSetOperation $ toSetOperation u
 
-instance ( SqlSelect c r
+instance
+    ( SqlSelect c r
     , ToAlias c
     , ToAliasReference c
     , ToSetOperation a c
     , ToSetOperation b c
     , c ~ SetOperationT a
-         )  => ToFrom (UnionAll a b) where
+    )
+  =>
+    ToFrom (UnionAll a b)
+  where
+    type ToFromT (UnionAll a b) = SetOperationT a
+    toFrom u = SqlSetOperation $ toSetOperation u
+
+instance
+    ( SqlSelect c r
+    , ToAlias c
+    , ToAliasReference c
+    , ToSetOperation a c
+    , ToSetOperation b c
+    , c ~ SetOperationT a
+    )
+  =>
+    ToFrom (Intersect a b)
+  where
+    type ToFromT (Intersect a b) = SetOperationT a
+    toFrom u = SqlSetOperation $ toSetOperation u
+
+instance
+    ( SqlSelect c r
+    , ToAlias c
+    , ToAliasReference c
+    , ToSetOperation a c
+    , ToSetOperation b c
+    , c ~ SetOperationT a
+    )
+  =>
+    ToFrom (Except a b)
+  where
+    type ToFromT (Except a b) = SetOperationT a
     toFrom u = SqlSetOperation $ toSetOperation u
 
 instance (SqlSelect a r, ToAlias a, ToAliasReference a) => ToFrom (SqlSetOperation a) where
+    type ToFromT (SqlSetOperation a) = a
     -- If someone uses just a plain SelectQuery it should behave like a normal subquery
     toFrom (SelectQueryP _ q) = SubQuery q
     -- Otherwise use the SqlSetOperation
@@ -839,39 +864,33 @@ instance (ToFrom a, ToFromT a ~ a', ToFrom b, ToFromT b ~ b')
   => ToInnerJoin NotLateral a b (a' :& b') where
       toInnerJoin _ lhs rhs on' = InnerJoinFrom (toFrom lhs) (toFrom rhs, on')
 
-instance
+instance (ToInnerJoin (IsLateral b) a b b') => ToFrom (InnerJoin a (b, b' -> SqlExpr (Value Bool))) where
-    ( ToFrom a
+    type ToFromT (InnerJoin a (b, b' -> SqlExpr (Value Bool))) = FromOnClause (b, b' -> SqlExpr(Value Bool))
-    , ToFromT a ~ a'
+    toFrom (InnerJoin lhs (rhs, on')) = toInnerJoin (toProxy rhs) lhs rhs on'
-    , ToInnerJoin (IsLateral b) a b b'
-    )
-  =>
-    ToFrom (InnerJoin a (b, b' -> SqlExpr (Value Bool)))
         where
-    toFrom (InnerJoin lhs (rhs, on')) =
+            toProxy :: b -> Proxy (IsLateral b)
-        let toProxy :: b -> Proxy (IsLateral b)
             toProxy _ = Proxy
-        in
-            toInnerJoin (toProxy rhs) lhs rhs on'
 
-instance
+-- @since 3.4.0.1
-    ( ToFrom a
+type family FromCrossJoin a b where
+    FromCrossJoin a (b -> SqlQuery c) = ToFromT a :& c
+    FromCrossJoin a b = ToFromT a :& ToFromT b
+
+instance ( ToFrom a
          , ToFrom b
          , ToFromT (CrossJoin a b) ~ (ToFromT a :& ToFromT b)
-    )
+         ) => ToFrom (CrossJoin a b) where
-  =>
+    type ToFromT (CrossJoin a b) = FromCrossJoin a b
-    ToFrom (CrossJoin a b)
-  where
     toFrom (CrossJoin lhs rhs) = CrossJoinFrom (toFrom lhs) (toFrom rhs)
 
 instance {-# OVERLAPPING #-}
-
          ( ToFrom a
          , ToFromT a ~ a'
          , SqlSelect b r
          , ToAlias b
          , ToAliasReference b
-         )
+         ) => ToFrom (CrossJoin a (a' -> SqlQuery b)) where
-       => ToFrom (CrossJoin a (a' -> SqlQuery b)) where
+    type ToFromT (CrossJoin a (a' -> SqlQuery b)) = FromCrossJoin a (a' -> SqlQuery b)
     toFrom (CrossJoin lhs q) = CrossJoinFromLateral (toFrom lhs) q
 
 class ToLeftJoin lateral lhs rhs res where
@@ -896,20 +915,16 @@ instance ( ToFrom a
          ) => ToLeftJoin NotLateral a b (a' :& mb) where
             toLeftJoin _ lhs rhs on' = LeftJoinFrom (toFrom lhs) (toFrom rhs, on')
 
-instance
+instance ( ToLeftJoin (IsLateral b) a b b'
-    ( ToLeftJoin (IsLateral b) a b b'
+         ) => ToFrom (LeftOuterJoin a (b, b' -> SqlExpr (Value Bool))) where
-    )
+            type ToFromT (LeftOuterJoin a (b, b' -> SqlExpr (Value Bool))) = FromOnClause (b, b' -> SqlExpr(Value Bool))
-  =>
-    ToFrom (LeftOuterJoin a (b, b' -> SqlExpr (Value Bool)))
-  where
             toFrom (LeftOuterJoin lhs (rhs, on')) =
-        let toProxy :: b -> Proxy (IsLateral b)
-            toProxy _ = Proxy
-        in
                 toLeftJoin (toProxy rhs) lhs rhs on'
+              where
+                toProxy :: b -> Proxy (IsLateral b)
+                toProxy _ = Proxy
 
-instance
+instance ( ToFrom a
-    ( ToFrom a
          , ToFromT a ~ a'
          , ToFrom b
          , ToFromT b ~ b'
@@ -918,125 +933,83 @@ instance
          , ToMaybe b'
          , mb ~ ToMaybeT b'
          , ErrorOnLateral b
-    )
+         ) => ToFrom (FullOuterJoin a (b, (ma :& mb) -> SqlExpr (Value Bool))) where
-  =>
+            type ToFromT (FullOuterJoin a (b, (ma :& mb) -> SqlExpr (Value Bool))) = FromOnClause (b, (ma :& mb) -> SqlExpr(Value Bool))
-    ToFrom (FullOuterJoin a (b, (ma :& mb) -> SqlExpr (Value Bool)))
+            toFrom (FullOuterJoin lhs (rhs, on')) = FullJoinFrom (toFrom lhs) (toFrom rhs, on')
-  where
-    toFrom (FullOuterJoin lhs (rhs, on')) =
-        FullJoinFrom (toFrom lhs) (toFrom rhs, on')
 
-instance
+instance ( ToFrom a
-    ( ToFrom a
          , ToFromT a ~ a'
          , ToMaybe a'
          , ma ~ ToMaybeT a'
          , ToFrom b
          , ToFromT b ~ b'
          , ErrorOnLateral b
-    )
+         ) => ToFrom (RightOuterJoin a (b, (ma :& b') -> SqlExpr (Value Bool))) where
-  =>
+            type ToFromT (RightOuterJoin a (b, (ma :& b') -> SqlExpr (Value Bool))) = FromOnClause (b, (ma :& b') -> SqlExpr(Value Bool))
-    ToFrom (RightOuterJoin a (b, (ma :& b') -> SqlExpr (Value Bool)))
+            toFrom (RightOuterJoin lhs (rhs, on')) = RightJoinFrom (toFrom lhs) (toFrom rhs,  on')
-  where
-    toFrom (RightOuterJoin lhs (rhs, on')) =
-        RightJoinFrom (toFrom lhs) (toFrom rhs,  on')
 
 type family Nullable a where
     Nullable (Maybe a) = a
     Nullable a =  a
 
-type family ToMaybeT a where
-    ToMaybeT (SqlExpr (Maybe a)) = SqlExpr (Maybe a)
-    ToMaybeT (SqlExpr (Entity a)) = SqlExpr (Maybe (Entity a))
-    ToMaybeT (SqlExpr (Value a)) = SqlExpr (Value (Maybe (Nullable a)))
-    ToMaybeT (a :& b) = (ToMaybeT a :& ToMaybeT b)
-    ToMaybeT (a, b) = (ToMaybeT a, ToMaybeT b)
-    ToMaybeT (a, b, c) = (ToMaybeT a, ToMaybeT b, ToMaybeT c)
-    ToMaybeT (a, b, c, d) = (ToMaybeT a, ToMaybeT b, ToMaybeT c, ToMaybeT d)
-    ToMaybeT (a, b, c, d, e) = (ToMaybeT a, ToMaybeT b, ToMaybeT c, ToMaybeT d, ToMaybeT e)
-    ToMaybeT (a, b, c, d, e, f) = (ToMaybeT a, ToMaybeT b, ToMaybeT c, ToMaybeT d, ToMaybeT e, ToMaybeT f)
-    ToMaybeT (a, b, c, d, e, f, g) = (ToMaybeT a, ToMaybeT b, ToMaybeT c, ToMaybeT d, ToMaybeT e, ToMaybeT f, ToMaybeT g)
-    ToMaybeT (a, b, c, d, e, f, g, h) = (ToMaybeT a, ToMaybeT b, ToMaybeT c, ToMaybeT d, ToMaybeT e, ToMaybeT f, ToMaybeT g, ToMaybeT h)
-
 class ToMaybe a where
+    type ToMaybeT a
     toMaybe :: a -> ToMaybeT a
 
 instance ToMaybe (SqlExpr (Maybe a)) where
+    type ToMaybeT (SqlExpr (Maybe a)) = SqlExpr (Maybe a)
     toMaybe = id
 
 instance ToMaybe (SqlExpr (Entity a)) where
+    type ToMaybeT (SqlExpr (Entity a)) = SqlExpr (Maybe (Entity a))
     toMaybe = EMaybe
 
 instance ToMaybe (SqlExpr (Value a)) where
+    type ToMaybeT (SqlExpr (Value a)) = SqlExpr (Value (Maybe (Nullable a)))
     toMaybe = veryUnsafeCoerceSqlExprValue
 
 instance (ToMaybe a, ToMaybe b) => ToMaybe (a :& b) where
+    type ToMaybeT (a :& b) = (ToMaybeT a :& ToMaybeT b)
     toMaybe (a :& b) = (toMaybe a :& toMaybe b)
 
 instance (ToMaybe a, ToMaybe b) => ToMaybe (a,b) where
+    type ToMaybeT (a, b) = (ToMaybeT a, ToMaybeT b)
     toMaybe (a, b) = (toMaybe a, toMaybe b)
 
-instance
+instance ( ToMaybe a , ToMaybe b , ToMaybe c) => ToMaybe (a,b,c) where
-    ( ToMaybe a
+    type ToMaybeT (a, b, c) = (ToMaybeT a, ToMaybeT b, ToMaybeT c)
-    , ToMaybe b
-    , ToMaybe c
-    )
-  =>
-    ToMaybe (a,b,c)
-  where
     toMaybe = to3 . toMaybe . from3
 
-instance
+instance ( ToMaybe a , ToMaybe b , ToMaybe c , ToMaybe d) => ToMaybe (a,b,c,d) where
-    ( ToMaybe a
+    type ToMaybeT (a, b, c, d) = (ToMaybeT a, ToMaybeT b, ToMaybeT c, ToMaybeT d)
-    , ToMaybe b
-    , ToMaybe c
-    , ToMaybe d
-    )
-  =>
-    ToMaybe (a,b,c,d)
-  where
     toMaybe = to4 . toMaybe . from4
 
-instance
+instance ( ToMaybe a , ToMaybe b , ToMaybe c , ToMaybe d , ToMaybe e) => ToMaybe (a,b,c,d,e) where
-    ( ToMaybe a
+    type ToMaybeT (a, b, c, d, e) = (ToMaybeT a, ToMaybeT b, ToMaybeT c, ToMaybeT d, ToMaybeT e)
-    , ToMaybe b
-    , ToMaybe c
-    , ToMaybe d
-    , ToMaybe e
-    )
-  =>
-    ToMaybe (a,b,c,d,e)
-  where
     toMaybe = to5 . toMaybe . from5
 
-instance
+instance ( ToMaybe a
-    ( ToMaybe a
          , ToMaybe b
          , ToMaybe c
          , ToMaybe d
          , ToMaybe e
          , ToMaybe f
-    )
+         ) => ToMaybe (a,b,c,d,e,f) where
-  =>
+    type ToMaybeT (a, b, c, d, e, f) = (ToMaybeT a, ToMaybeT b, ToMaybeT c, ToMaybeT d, ToMaybeT e, ToMaybeT f)
-    ToMaybe (a,b,c,d,e,f)
-  where
     toMaybe = to6 . toMaybe . from6
 
-instance
+instance ( ToMaybe a
-    ( ToMaybe a
          , ToMaybe b
          , ToMaybe c
          , ToMaybe d
          , ToMaybe e
          , ToMaybe f
          , ToMaybe g
-    )
+         ) => ToMaybe (a,b,c,d,e,f,g) where
-  =>
+    type ToMaybeT (a, b, c, d, e, f, g) = (ToMaybeT a, ToMaybeT b, ToMaybeT c, ToMaybeT d, ToMaybeT e, ToMaybeT f, ToMaybeT g)
-    ToMaybe (a,b,c,d,e,f,g)
-  where
     toMaybe = to7 . toMaybe . from7
 
-instance
+instance ( ToMaybe a
-    ( ToMaybe a
          , ToMaybe b
          , ToMaybe c
          , ToMaybe d
@@ -1044,10 +1017,8 @@ instance
          , ToMaybe f
          , ToMaybe g
          , ToMaybe h
-    )
+         ) => ToMaybe (a,b,c,d,e,f,g,h) where
-  =>
+     type ToMaybeT (a, b, c, d, e, f, g, h) = (ToMaybeT a, ToMaybeT b, ToMaybeT c, ToMaybeT d, ToMaybeT e, ToMaybeT f, ToMaybeT g, ToMaybeT h)
-    ToMaybe (a,b,c,d,e,f,g,h)
-  where
      toMaybe = to8 . toMaybe . from8
 
 -- | 'FROM' clause, used to bring entities into scope.
@@ -1072,7 +1043,7 @@ from parts = do
         let entity = EEntity ident
         pure $ (entity, FromStart ident ed)
           where
-            getVal :: PersistEntity ent => From (SqlExpr (Entity ent)) -> Proxy ent
+            getVal :: From (SqlExpr (Entity ent)) -> Proxy ent
             getVal = const Proxy
     runFrom (SubQuery subquery) =
         fromSubQuery NormalSubQuery subquery
@@ -1443,7 +1414,6 @@ instance ( ToAliasReference a
          ) => ToAliasReference (a,b,c,d,e,f,g,h) where
     toAliasReference ident x = to8 <$> (toAliasReference ident $ from8 x)
 
-
 class RecursiveCteUnion a where
     unionKeyword :: a -> TLB.Builder