{-# LANGUAGE GADTs, MultiParamTypeClasses, FunctionalDependencies, UndecidableInstances, FlexibleContexts, FlexibleInstances, ScopedTypeVariables, RankNTypes, TypeFamilies, NoMonomorphismRestriction, TypeSynonymInstances, PatternSignatures, PatternGuards #-}
module Database.Squiggle.Types where

import qualified Prelude
import Prelude hiding ( (==), (/=), (<), (<=), (>), (>=), (&&), (||), not, sum, minimum, maximum )
import Control.Arrow ( (***), (&&&) )
import Control.Monad.Identity hiding (join)
import Control.Monad.State hiding (join)
import Control.Monad.Writer hiding (join)
import Data.Accessor
import Data.List hiding (sortBy, nub, union, groupBy, minimum, maximum, sum)
import qualified Data.List as List
import Data.Map (Map)
import qualified Data.Map as Map
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import Data.Maybe hiding (isJust, isNothing, fromJust )
import qualified Data.Maybe as DM
import Data.Set (Set)
import qualified Data.Set as Set
import Data.String
import qualified Data.Traversable as T
import qualified Safe
import Text.PrettyPrint.HughesPJ

import Database.HSQL
import Database.HSQL.Types

import Unsafe.Coerce

import Debug.Trace

newtype Date = Date (Int, Int, Int) -- TODO change this?
  deriving (Eq, Ord, Show)

infixr 3 &&
infixr 2 ||

class IsBool b where
   fromBool :: Bool -> b
   (&&) :: b -> b -> b
   (||) :: b -> b -> b
   not :: b -> b

true, false :: IsBool b => b
true = fromBool True
false = fromBool False

instance IsBool Bool where
   fromBool = id
   (&&) = (Prelude.&&)
   (||) = (Prelude.||)
   not = Prelude.not

infix 4 ==
infix 4 /=

class IsBool b => AEq a b where
  (==) :: a -> a -> b
  (/=) :: a -> a -> b
  a /= b = not (a == b)

class Cond b s where
  (?) :: b -> (s, s) -> s

instance Cond Bool a where
  c ? (t, e) = if c then t else e

-- TODO should do some kind of flattening
instance SqlPrimType a => Cond (SqlExpr Bool) (SqlExpr a) where 
  c ? (t, e) = SEPrim SPIfThenElse `SEApp` c `SEApp` t `SEApp` e

instance Eq a => AEq a Bool where
  (==) = (Prelude.==)

class AEq a b => AOrd a b where
  (<) :: a -> a -> b
  (<=) :: a -> a -> b
  (>) :: a -> a -> b
  (>=) :: a -> a -> b

instance Ord a => AOrd a Bool where
  (<) = (Prelude.<)
  (>) = (Prelude.>)
  (<=) = (Prelude.<=)
  (>=) = (Prelude.>=)

class HasMaybe (c :: * -> *) a where
   nothing :: Apply c (Maybe a)
   just :: Apply c a -> Apply c (Maybe a)
   isJust :: Apply c (Maybe a) -> Apply c Bool
   isNothing :: Apply c (Maybe a) -> Apply c Bool
   fromJust :: Apply c (Maybe a) -> Apply c a

instance HasMaybe Id a where
   nothing = Nothing
   just = Just
   isJust = DM.isJust
   isNothing = DM.isNothing
   fromJust = DM.fromJust

data FieldName = FieldId { unFieldId :: !Int } | FieldName { unFieldName :: String }
  deriving (Show, Eq, Ord)

maybeUnFieldId (FieldId i) = Just i
maybeUnFieldId _ = Nothing

type DBName = String
type TableName = String

data Prod a b = Prod a b
  deriving (Eq, Ord, Show)

-- TODO still don't know if Nil/() makes sense to have
data Nil = Nil
  deriving (Eq, Ord, Show)

sum (Aggr e) = SEApp (SEPrim SPSum) (SEAggr e)
minimum (Aggr e) = SEApp (SEPrim SPMin) (SEAggr e)
maximum (Aggr e) = SEApp (SEPrim SPMax) (SEAggr e)
the :: (HasProdEnc sea, IsSqlExpr (ProdEnc sea), SqlBE (UnSqlExpr (ProdEnc sea))) => Aggr sea -> sea
the = decodeSqlExpr . applyThe . encodeSqlExpr
count (Aggr e) = SEApp (SEPrim SPCount) (SEAggr e)

class IsDate a where
   date :: (Int, Int, Int) -> a

instance IsDate Date where
   date = Date

instance IsDate (SqlExpr Date) where
   date (y, m, d) = SEPrim (SPLit (SLDate (Date (y, m, d))))


fromFields' :: FromFields a => [FieldName] -> ((SqlFields a, FMap a), [FieldName])
fromFields' fs = case fromFields'' fs of
                   (flds, fs') -> ((flds, buildFMap flds), fs')

buildFMap :: FromFields a => SqlFields a -> FMap a
buildFMap fs = buildFMap' fs id fm_empty

class FromFields a where
  fromFields'' :: [FieldName] -> (SqlFields a, [FieldName])
  reproject :: ProdSel f => FMap b -> SqlFields a -> f b -> f a
  -- just for PrimTypes, TODO move it..
  reproject' :: ProdSel f => FMap b -> SqlFields a -> Maybe (f b -> f a)
  buildFMap' :: SqlFields a -> (forall f . ProdSel f => f b -> f a) -> FMap b -> FMap b

{-
  nullableMap :: SqlExpr a -> NMap
  toNullableSE :: NMap -> SqlExpr a -> Wrapped SqlExpr
  fromNullableSE :: NMap -> SqlExpr a -> Wrapped SqlExpr
-}

rebuildFunc :: (SqlBE a, SqlBE b) => (SqlExpr' q a -> SqlExpr' q b) -> SqlExpr' q a -> SqlExpr' q b
rebuildFunc = runIdentity . rebuildFuncM . (Identity .)

rebuildFuncM :: (Monad m, SqlBE a, SqlBE b) => (SqlExpr' q a -> m (SqlExpr' q b)) -> m (SqlExpr' q a -> SqlExpr' q b)
rebuildFuncM f = do ((a', fm), fs) <- argsForM' f
                    b' <- f (fieldsToExpr a')
                    return $ rebuildE fs fm b'


rebuildE :: [FieldName] -> FMap a -> SqlExpr' q b -> SqlExpr' q a -> SqlExpr' q b
rebuildE fs fm (SEField tn fn) | Just f <- reproject' fm (SFField tn fn) = f
                               | otherwise = const (SEField tn fn)
rebuildE fs fm (SEApp f a) = let f' = rebuildE fs fm f
	                         a' = rebuildE fs fm a
                             in \v -> SEApp (f' v) (a' v)
rebuildE fs fm (SEPrim p) = const (SEPrim p)
rebuildE fs fm SENil = const SENil
rebuildE fs fm (SEProd x y) = let x' = rebuildE fs fm x
                                  y' = rebuildE fs fm y
                              in \v -> SEProd (x' v) (y' v)
rebuildE fs fm (SEAggr x) = let x' = rebuildE fs fm x in \v -> SEAggr (x' v)
rebuildE fs fm (SEIntQuery q) = let q' = rebuildIQ fs fm q in \v -> SEIntQuery (q' v)
rebuildE fs fm (SEPrimQuery q) = let q' = rebuildPQ fs fm q in \v -> SEPrimQuery (q' v)

rebuildPQ :: [FieldName] -> FMap a -> PrimQuery b -> SqlExprP a -> PrimQuery b
rebuildPQ fs fm (PrimUnit e f) = let e' = rebuildE fs fm e in \v -> PrimUnit (e' v) f
rebuildPQ fs fm (PrimSelect d p f r ms t) = let ((c', fm'), fs') = fromFields' fs
                                                ce = fieldsToExpr c'
                                                fm'' = fm_prod fm fm'
                                                p' = rebuildE fs' fm'' (fromFunc p ce)
                                                r' = rebuildE fs' fm'' (r ce)
                                                ms' = flip fmap ms $ \s -> rebuildE fs' fm'' (s ce)
                                                withProd v g = \v' -> g (SEProd v v')
                                                t' = rebuildPT fs fm t
                                            in \v -> PrimSelect d
                                                                (EmbedFunc $ withProd v p')
                                                                f
                                                                (withProd v r')
                                                                (fmap (withProd v) ms')
                                                                (t' v)
rebuildPQ fs fm (PrimGroup d sel deaggr f r ms t) 
                                          = let ((c', fm'), fs') = fromFields' fs
                                                ce = fieldsToExpr c'
                                                fm'' = fm_prod fm fm'
                                                sel' = rebuildE fs' fm'' (sel ce)
                                                deaggr' = rebuildE fs' fm'' (deaggr (exprToAggr ce))
                                                r' = rebuildE fs' fm'' (r ce)
                                                ms' = flip fmap ms $ \s -> rebuildE fs' fm'' (s ce)
                                                withProd v g = \v' -> g (SEProd v v')
                                                t' = rebuildPT fs fm t
                                            in \v -> PrimGroup d
                                                               (withProd v sel')
                                                               (withProd v deaggr' . aggrToExpr)
                                                               f
                                                               (withProd v r')
                                                               (fmap (withProd v) ms')
                                                               (t' v)
rebuildPQ fs fm (PrimUnion d q1 q2) = let q1' = rebuildPQ fs fm q1
                                          q2' = rebuildPQ fs fm q2
                                      in \v -> PrimUnion d (q1' v) (q2' v)
rebuildPQ fs fm (PrimIntersection q1 q2) = let q1' = rebuildPQ fs fm q1
                                               q2' = rebuildPQ fs fm q2
                                           in \v -> PrimIntersection (q1' v) (q2' v)

rebuildPT :: [FieldName] -> FMap a -> PrimTables b -> SqlExprP a -> PrimTables b
rebuildPT fs fm (PrimTable mdb tn mtn f) = \v -> PrimTable mdb tn mtn f
rebuildPT fs fm (PrimQuickJoin t1 t2) = let t1' = rebuildPT fs fm t1
                                            t2' = rebuildPT fs fm t2
                                        in \v -> PrimQuickJoin (t1' v) (t2' v)
rebuildPT fs fm (PrimJoin f t1 t2) = let ((c', fm'), fs') = fromFields' fs
                                         ce = fieldsToExpr c'
                                         fm'' = fm_prod fm fm'
                                         f' = rebuildE fs' fm'' (uncurrySEProd f ce)
                                         withProd v g = \v' -> g (SEProd v v')
                                         t1' = rebuildPT fs fm t1
                                         t2' = rebuildPT fs fm t2
                                     in \v -> PrimJoin (currySEProd $ withProd v f')
                                                       (t1' v)
                                                       (t2' v)
rebuildPT fs fm (PrimLeftJoin f t1 t2) = let ((c', fm'), fs') = fromFields' fs
                                             ce = fieldsToExpr c'
                                             fm'' = fm_prod fm fm'
                                             f' = rebuildE fs' fm'' (uncurrySEProd f ce)
                                             withProd v g = \v' -> g (SEProd v v')
                                             t1' = rebuildPT fs fm t1
                                             t2' = rebuildPT fs fm t2
                                         in \v -> PrimLeftJoin (currySEProd $ withProd v f')
                                                               (t1' v)
                                                               (t2' v)
rebuildPT fs fm (PrimSubQuery tn q) = let q' = rebuildPQ fs fm q in \v -> PrimSubQuery tn (q' v)

rebuildIQTop :: IntQuery a -> IntQuery a
rebuildIQTop q = rebuildIQ (map FieldId [0..]) fm_empty q SENil

rebuildIQ :: [FieldName] -> FMap a -> IntQuery b -> SqlExpr a -> IntQuery b
rebuildIQ fs fm (IntKnown es) = let es' = map (rebuildE fs fm) es in \v -> IntKnown (map ($ v) es')
rebuildIQ fs fm (IntTable tn f) = \v -> IntTable tn f
rebuildIQ fs fm (IntNub q) = let q' = rebuildIQ fs fm q in \v -> IntNub (q' v)
rebuildIQ fs fm (IntProject f q) = let ((c', fm'), fs') = fromFields' fs
                                       d' = f (fieldsToExpr c')
                                       fm'' = fm_prod fm fm'
                                       f' = rebuildE fs' fm'' d'
                                       withProd v g = \v' -> g (SEProd v v')
                                       q' = rebuildIQ fs fm q
                                   in \v -> IntProject (withProd v f') (q' v)
rebuildIQ fs fm (IntRestrict r q) = let ((c', fm'), fs') = fromFields' fs
                                        d' = r (fieldsToExpr c')
                                        fm'' = fm_prod fm fm'
                                        r' = rebuildE fs' fm'' d'
                                        withProd v g = \v' -> g (SEProd v v')
                                        q' = rebuildIQ fs fm q
                                    in \v -> IntRestrict (withProd v r') (q' v)
rebuildIQ fs fm (IntJoin r q1 q2) = let ((c', fm'), fs') = fromFields' fs
                                        d' = uncurrySEProd r (fieldsToExpr c')
                                        fm'' = fm_prod fm fm'
                                        r' = rebuildE fs' fm'' d'
                                        withProd v g = \v' -> g (SEProd v v')
                                        q1' = rebuildIQ fs fm q1
                                        q2' = rebuildIQ fs fm q2
                                    in \v -> IntJoin (currySEProd $ withProd v r')
                                                     (q1' v)
                                                     (q2' v)
rebuildIQ fs fm (IntLeftJoin r q1 q2) = let ((c', fm'), fs') = fromFields' fs
                                            d' = uncurrySEProd r (fieldsToExpr c')
                                            fm'' = fm_prod fm fm'
                                            r' = rebuildE fs' fm'' d'
                                            withProd v g = \v' -> g (SEProd v v')
                                            q1' = rebuildIQ fs fm q1
                                            q2' = rebuildIQ fs fm q2
                                        in \v -> IntLeftJoin (currySEProd $ withProd v r')
                                                             (q1' v)
                                                             (q2' v)
rebuildIQ fs fm (IntSortBy s q) = let ((c', fm'), fs') = fromFields' fs
                                      d' = s (fieldsToExpr c')
                                      fm'' = fm_prod fm fm'
                                      s' = rebuildE fs' fm'' d'
                                      withProd v g = \v' -> g (SEProd v v')
                                      q' = rebuildIQ fs fm q
                                  in \v -> IntSortBy (withProd v s') (q' v)
rebuildIQ fs fm (IntGroupBy sel deaggr q) = let ((c', fm'), fs') = fromFields' fs
                                                d' = sel (fieldsToExpr c')
                                                e' = deaggr (exprToAggr . fieldsToExpr $ c')
                                                fm'' = fm_prod fm fm'
                                                sel' = rebuildE fs' fm'' d'
                                                deaggr' = rebuildE fs' fm'' e'
                                                withProd v g = \v' -> g (SEProd v v')
                                                q' = rebuildIQ fs fm q
                                            in \v -> IntGroupBy (withProd v sel')
                                                                (withProd v deaggr' . aggrToExpr)
                                                                (q' v)
rebuildIQ fs fm (IntUnion q1 q2) = let q1' = rebuildIQ fs fm q1
                                       q2' = rebuildIQ fs fm q2
                                   in \v -> IntUnion (q1' v) (q2' v)
rebuildIQ fs fm (IntIntersection q1 q2) = let q1' = rebuildIQ fs fm q1
                                              q2' = rebuildIQ fs fm q2
                                          in \v -> IntIntersection (q1' v) (q2' v)


newtype PSMap a t = PSMap { unPSMap :: forall f . ProdSel f => IntMap (f a -> f t) }

data FMap a = FMap { fm_bools :: PSMap a Bool
                   , fm_mbools :: PSMap a (Maybe Bool)
                   , fm_ints  :: PSMap a Int
                   , fm_mints  :: PSMap a (Maybe Int)
                   , fm_chars  :: PSMap a Char
                   , fm_mchars  :: PSMap a (Maybe Char)
                   , fm_doubles  :: PSMap a Double
                   , fm_mdoubles  :: PSMap a (Maybe Double)
                   , fm_dates  :: PSMap a Date
                   , fm_mdates  :: PSMap a (Maybe Date)
                   , fm_strings  :: PSMap a String
                   , fm_mstrings  :: PSMap a (Maybe String)
                   }

fm_boolsA = Accessor fm_bools (\x fm -> fm { fm_bools = x })
fm_mboolsA = Accessor fm_mbools (\x fm -> fm { fm_mbools = x })
fm_intsA = Accessor fm_ints (\x fm -> fm { fm_ints = x })
fm_mintsA = Accessor fm_mints (\x fm -> fm { fm_mints = x })
fm_charsA = Accessor fm_chars (\x fm -> fm { fm_chars = x })
fm_mcharsA = Accessor fm_mchars (\x fm -> fm { fm_mchars = x })
fm_stringsA = Accessor fm_strings (\x fm -> fm { fm_strings = x })
fm_mstringsA = Accessor fm_mstrings (\x fm -> fm { fm_mstrings = x })
fm_datesA = Accessor fm_dates (\x fm -> fm { fm_dates = x })
fm_mdatesA = Accessor fm_mdates (\x fm -> fm { fm_mdates = x })
fm_doublesA = Accessor fm_doubles (\x fm -> fm { fm_doubles = x })
fm_mdoublesA = Accessor fm_mdoubles (\x fm -> fm { fm_mdoubles = x })

type NMap = Map FieldName Bool -- True => a -> Maybe a, False => Maybe a -> Maybe a

class ProdSel f where
   sel1 :: f (Prod x y) -> f x
   sel2 :: f (Prod x y) -> f y
   nil :: f Nil
   prod :: f x -> f y -> f (Prod x y)
   deaggr :: f (Aggr x) -> f x

-- TODO is this useful?
instance ProdSel Id where
   sel1 (Id (Prod x y)) = Id x
   sel2 (Id (Prod x y)) = Id y
   nil = Id Nil
   prod (Id x) (Id y) = Id (Prod x y)
   deaggr (Id x) = Id (unAggr x)

instance ProdSel (SqlExpr' q) where
   sel1 (SEProd x y) = x
   sel2 (SEProd x y) = y
   nil = SENil
   prod = SEProd
   deaggr (SEAggr x) = x

instance ProdSel SqlFields where
   sel1 (SFProd x y) = x
   sel2 (SFProd x y) = y
   nil = SFNil
   prod = SFProd
   deaggr (SFAggr x) = x


psm_union (PSMap a) (PSMap b) = PSMap (IntMap.union a b)
psm_empty = PSMap IntMap.empty
psm_map :: (forall f . ProdSel f => (f a -> f t) -> (f b -> f t)) -> PSMap a t -> PSMap b t
psm_map f (PSMap a) = PSMap (IntMap.map f a)
psm_insert :: FieldName -> (forall f . ProdSel f => f a -> f t) -> PSMap a t -> PSMap a t
psm_insert (FieldId k) v (PSMap a) = PSMap (IntMap.insert k v a)
psm_insert (FieldName n) v (PSMap a) = error $ "psm_insert: Can't handle fieldname " ++ n
psm_lookup (FieldId k) (PSMap a) = IntMap.lookup k a
psm_lookup (FieldName n) (PSMap a) = Nothing -- error $ "psm_lookup: Can't handle fieldname " ++ n

fm_union :: FMap a -> FMap a -> FMap a
fm_union x y = FMap { fm_bools = psm_union (fm_bools x) (fm_bools y)
                    , fm_mbools = psm_union (fm_mbools x) (fm_mbools y)
                    , fm_ints  = psm_union (fm_ints x) (fm_ints y)
                    , fm_mints  = psm_union (fm_mints x) (fm_mints y)
                    , fm_chars  = psm_union (fm_chars x) (fm_chars y)
                    , fm_mchars  = psm_union (fm_mchars x) (fm_mchars y)
                    , fm_doubles  = psm_union (fm_doubles x) (fm_doubles y)
                    , fm_mdoubles  = psm_union (fm_mdoubles x) (fm_mdoubles y)
                    , fm_strings  = psm_union (fm_strings x) (fm_strings y)
                    , fm_mstrings  = psm_union (fm_mstrings x) (fm_mstrings y)
                    , fm_dates  = psm_union (fm_dates x) (fm_dates y)
                    , fm_mdates  = psm_union (fm_mdates x) (fm_mdates y)
                    }

fm_empty :: FMap a
fm_empty = FMap { fm_bools = psm_empty
                , fm_mbools = psm_empty
                , fm_ints = psm_empty
                , fm_mints = psm_empty
                , fm_chars = psm_empty
                , fm_mchars = psm_empty
                , fm_strings = psm_empty
                , fm_mstrings = psm_empty
                , fm_doubles = psm_empty
                , fm_mdoubles = psm_empty
                , fm_dates = psm_empty
                , fm_mdates = psm_empty
                }

fm_addfunc :: (forall f . ProdSel f => f b -> f a) -> FMap a -> FMap b
fm_addfunc f x = FMap { fm_bools = psm_map (. f) (fm_bools x)
                      , fm_mbools = psm_map (. f) (fm_mbools x)
                      , fm_ints = psm_map (. f) (fm_ints x)
                      , fm_mints = psm_map (. f) (fm_mints x)
                      , fm_chars = psm_map (. f) (fm_chars x)
                      , fm_mchars = psm_map (. f) (fm_mchars x)
                      , fm_doubles = psm_map (. f) (fm_doubles x)
                      , fm_mdoubles = psm_map (. f) (fm_mdoubles x)
                      , fm_dates = psm_map (. f) (fm_dates x)
                      , fm_mdates = psm_map (. f) (fm_mdates x)
                      , fm_strings = psm_map (. f) (fm_strings x)
                      , fm_mstrings = psm_map (. f) (fm_mstrings x)
                      }

instance FromFields a => FromFields (Aggr a) where
  fromFields'' fs = case fromFields'' fs of
                       (sf, fs') -> (SFAggr sf, fs')
  buildFMap' (SFAggr sf) func fm = buildFMap' sf (deaggr . func) fm

instance FromFields Nil where
  fromFields'' fs = (SFNil, fs)
  reproject _ SFNil _ = nil
  buildFMap' SFNil func fm = fm
{-
  nullableMap SENil = Map.empty
  toNullableSE _ SENil = Wrapped SENil
  fromNullableSE _ SENil = Wrapped SENil
-}

fm_prod :: FMap a -> FMap b -> FMap (Prod a b)
fm_prod fm1 fm2 = fm_union (fm_addfunc sel1 fm1) (fm_addfunc sel2 fm2)

fromFieldsProd'' :: (FromFields x, FromFields y) => [FieldName] -> (SqlFields (Prod x y), [FieldName])
fromFieldsProd'' fs = case fromFields'' fs of
                      (a, fs') -> case fromFields'' fs' of
                        (b, fs'') -> (SFProd a b, fs'')

instance (FromFields a, FromFields b) => FromFields (Prod a b) where
  fromFields'' = fromFieldsProd''
  reproject fm (SFProd a b) v = prod (reproject fm a v) (reproject fm b v)
  buildFMap' (SFProd a b) func fm = buildFMap' b (sel2 . func) (buildFMap' a (sel1 . func) fm)
{-
  nullableMap (SEProd a b) = Map.union (nullableMap a) (nullableMap b)
  toNullableSE nm (SEProd a b) = onWrapped2 (\a b -> Wrapped (SEProd a b)) (toNullableSE nm a) (toNullableSE nm b)
  fromNullableSE nm (SEProd a b) = onWrapped2 (\a b -> Wrapped (SEProd a b)) (fromNullableSE nm a) (fromNullableSE nm b)
-}


modVal :: Accessor s a -> (a -> a) -> s -> s
modVal acc f r = setVal acc (f (getVal acc r)) r

fromFieldsPrim'' :: SqlPrimType t => [FieldName] -> (SqlFields t, [FieldName])
fromFieldsPrim'' (f:fs) = (SFField (False, Nothing) f, fs)

instance FromFields Bool where
  fromFields'' = fromFieldsPrim''
  reproject fm (SFField _ fn) v = (Safe.fromJustNote ("missing field " ++ show fn) $ psm_lookup fn $ fm_bools fm) v
  reproject' fm (SFField _ fn) = psm_lookup fn (fm_bools fm)
  buildFMap' (SFField _ fn) func fm = fm { fm_bools = psm_insert fn func (fm_bools fm) }
{-
  nullableMap (SEField _ fn) = Map.singleton fn True
  toNullableSE nm f@(SEField mtn fn) | Just _ <- Map.lookup fn nm = Wrapped (SEField mtn fn :: SqlExpr (Maybe Bool))
                                     | otherwise = Wrapped f
  fromNullableSE nm f@(SEField mtn fn) | Just _ <- Map.lookup fn nm = error $ "fromNullableSE: non-Maybe field " ++ fn
                                       | otherwise = Wrapped f
-}

instance FromFields (Maybe Bool) where
  fromFields'' = fromFieldsPrim''
  reproject fm (SFField _ fn) v = (Safe.fromJustNote ("missing field " ++ show fn) $ psm_lookup fn $ fm_mbools fm) v
  reproject' fm (SFField _ fn) = psm_lookup fn (fm_mbools fm)
  buildFMap' (SFField _ fn) func fm = fm { fm_mbools = psm_insert fn func (fm_mbools fm) }
{-
  nullableMap (SEField _ fn) = Map.singleton fn False
  toNullableSE nm f@(SEField mtn fn) = Wrapped f
  fromNullableSE nm f@(SEField mtn fn) | Just True <- Map.lookup fn nm = Wrapped (SEField mtn fn :: SqlExpr Bool)
                                       | otherwise = Wrapped f
-}

instance FromFields Int where
  fromFields'' = fromFieldsPrim''
  reproject fm (SFField _ fn) v = (Safe.fromJustNote ("missing field " ++ show fn) $ psm_lookup fn $ fm_ints fm) v
  reproject' fm (SFField _ fn) = psm_lookup fn (fm_ints fm)
  buildFMap' (SFField _ fn) func fm = fm { fm_ints = psm_insert fn func (fm_ints fm) }

instance FromFields (Maybe Int) where
  fromFields'' = fromFieldsPrim''
  reproject fm (SFField _ fn) v = (Safe.fromJustNote ("missing field " ++ show fn) $ psm_lookup fn $ fm_mints fm) v
  reproject' fm (SFField _ fn) = psm_lookup fn (fm_mints fm)
  buildFMap' (SFField _ fn) func fm = fm { fm_mints = psm_insert fn func (fm_mints fm) }

instance FromFields String where
  fromFields'' = fromFieldsPrim''
  reproject fm (SFField _ fn) v = (Safe.fromJustNote ("missing field " ++ show fn) $ psm_lookup fn $ fm_strings fm) v
  reproject' fm (SFField _ fn) = psm_lookup fn (fm_strings fm)
  buildFMap' (SFField _ fn) func fm = fm { fm_strings = psm_insert fn func (fm_strings fm) }

instance FromFields (Maybe String) where
  fromFields'' = fromFieldsPrim''
  reproject fm (SFField _ fn) v = (Safe.fromJustNote ("missing field " ++ show fn) $ psm_lookup fn $ fm_mstrings fm) v
  reproject' fm (SFField _ fn) = psm_lookup fn (fm_mstrings fm)
  buildFMap' (SFField _ fn) func fm = fm { fm_mstrings = psm_insert fn func (fm_mstrings fm) }

instance FromFields Char where
  fromFields'' = fromFieldsPrim''
  reproject fm (SFField _ fn) v = (Safe.fromJustNote ("missing field " ++ show fn) $ psm_lookup fn $ fm_chars fm) v
  reproject' fm (SFField _ fn) = psm_lookup fn (fm_chars fm)
  buildFMap' (SFField _ fn) func fm = fm { fm_chars = psm_insert fn func (fm_chars fm) }

instance FromFields (Maybe Char) where
  fromFields'' = fromFieldsPrim''
  reproject fm (SFField _ fn) v = (Safe.fromJustNote ("missing field " ++ show fn) $ psm_lookup fn $ fm_mchars fm) v
  reproject' fm (SFField _ fn) = psm_lookup fn (fm_mchars fm)
  buildFMap' (SFField _ fn) func fm = fm { fm_mchars = psm_insert fn func (fm_mchars fm) }

instance FromFields Date where
  fromFields'' = fromFieldsPrim''
  reproject fm (SFField _ fn) v = (Safe.fromJustNote ("missing field " ++ show fn) $ psm_lookup fn $ fm_dates fm) v
  reproject' fm (SFField _ fn) = psm_lookup fn (fm_dates fm)
  buildFMap' (SFField _ fn) func fm = fm { fm_dates = psm_insert fn func (fm_dates fm) }

instance FromFields (Maybe Date) where
  fromFields'' = fromFieldsPrim''
  reproject fm (SFField _ fn) v = (Safe.fromJustNote ("missing field " ++ show fn) $ psm_lookup fn $ fm_mdates fm) v
  reproject' fm (SFField _ fn) = psm_lookup fn (fm_mdates fm)
  buildFMap' (SFField _ fn) func fm = fm { fm_mdates = psm_insert fn func (fm_mdates fm) }

instance FromFields Double where
  fromFields'' = fromFieldsPrim''
  reproject fm (SFField _ fn) v = (Safe.fromJustNote ("missing field " ++ show fn) $ psm_lookup fn $ fm_doubles fm) v
  reproject' fm (SFField _ fn) = psm_lookup fn (fm_doubles fm)
  buildFMap' (SFField _ fn) func fm = fm { fm_doubles = psm_insert fn func (fm_doubles fm) }

instance FromFields (Maybe Double) where
  fromFields'' = fromFieldsPrim''
  reproject fm (SFField _ fn) v = (Safe.fromJustNote ("missing field " ++ show fn) $ psm_lookup fn $ fm_mdoubles fm) v
  reproject' fm (SFField _ fn) = psm_lookup fn (fm_mdoubles fm)
  buildFMap' (SFField _ fn) func fm = fm { fm_mdoubles = psm_insert fn func (fm_mdoubles fm) }

fromFieldsE = fieldsToExpr . fst . fst . fromFields'
fromFieldsA = exprToAggr . fieldsToExpr . fst . fst . fromFields'
fromFields = fst . fst .fromFields'

data SqlFields a where
  SFField :: SqlPrimType a => (Bool, Maybe TableName) -> FieldName -> SqlFields a
  SFNil :: SqlFields Nil
  SFProd :: SqlFields a -> SqlFields b -> SqlFields (Prod a b)
  SFAggr :: SqlFields a -> SqlFields (Aggr a)

instance Eq (SqlFields a) where
  SFNil == SFNil = True
  SFProd a b == SFProd a' b' = a == a' && b == b'
  SFField tn x == SFField tn' x' = tn == tn' && x == x'

instance Same SqlFields where
   sameT SFNil SFNil = Just EqId
   sameT (SFProd a b) (SFProd a' b') = mkSameProd (sameT a a') (sameT b b')
   sameT (SFField (False, _) x :: SqlFields a) (SFField (False, _) x' :: SqlFields a') | x == x' = sameT (dummyVal :: SqlExpr a) (dummyVal :: SqlExpr a')
   sameT _ _ = Nothing

exprIsFields :: SqlExpr' q a1 -> SqlFields a2 -> Bool
exprIsFields SENil SFNil = True
exprIsFields (SEProd a b) (SFProd a' b') = exprIsFields a a' && exprIsFields b b'
exprIsFields (SEField (False, _) x) (SFField (False, _) x') | x == x' = True
exprIsFields _ _ = False

newtype Aggr a = Aggr { unAggr :: a }

-- TODO consider whether all combinations make sense
data SqlExpr' q a where
  SEField :: SqlPrimType a => (Bool, Maybe TableName) -> FieldName -> SqlExpr' q a
  SEApp :: SqlExpr' q (a -> b) -> SqlExpr' q a -> SqlExpr' q b
  SEPrim :: SqlPrim a -> SqlExpr' q a
  SEAggr :: SqlExpr' q a -> SqlExpr' q (Aggr a)
  SEProd :: SqlExpr' q a -> SqlExpr' q b -> SqlExpr' q (Prod a b)
  SENil :: SqlExpr' q Nil
  -- these constructors are a compromise between full parametrisation and none at all
  -- they provide type safety, but also let us add special-casing into general functions
  -- like optSE
  SEIntQuery :: SqlBE a => IntQuery a -> SqlExpr' IntQuery [a]
  SEPrimQuery :: SqlBE a => PrimQuery a -> SqlExpr' PrimQuery [a]

type SqlExpr = SqlExpr' IntQuery

translateSqlExpr :: (forall a . SqlExpr' q1 a -> SqlExpr' q2 a) -> SqlExpr' q1 a -> SqlExpr' q2 a
translateSqlExpr tr (SEField tn fn) = SEField tn fn
translateSqlExpr tr (SEApp f a) = SEApp (tr f) (tr a)
translateSqlExpr tr (SEPrim p) = SEPrim p
translateSqlExpr tr (SEAggr a) = SEAggr (tr a)
translateSqlExpr tr (SEProd e1 e2) = SEProd (tr e1) (tr e2)
translateSqlExpr tr SENil = SENil

exists :: HasSqlExpr a sea => Query a -> SqlExpr Bool
exists = SEApp (SEPrim SPExists) . SEIntQuery . translateQ

data SqlPrim a where
  SPLit  :: SqlLit a -> SqlPrim a
  SPPlus :: (SqlPrimType a, Num a) => SqlPrim (a -> a -> a)
  SPMinus :: (SqlPrimType a, Num a) => SqlPrim (a -> a -> a)
  SPTimes :: (SqlPrimType a, Num a) => SqlPrim (a -> a -> a)
  SPAbs :: (SqlPrimType a, Num a) => SqlPrim (a -> a)
  SPSign :: (SqlPrimType a, Num a) => SqlPrim (a -> a)
  SPNegate :: (SqlPrimType a, Num a) => SqlPrim (a -> a)
  SPDivide :: (SqlPrimType a, Fractional a) => SqlPrim (a -> a -> a)
  SPEq   :: (SqlPrimType a, Eq a)  => SqlPrim (a -> a -> Bool)
  SPNe   :: (SqlPrimType a, Eq a)  => SqlPrim (a -> a -> Bool)
  SPLt   :: (SqlPrimType a, Ord a)  => SqlPrim (a -> a -> Bool)
  SPGt   :: (SqlPrimType a, Ord a)  => SqlPrim (a -> a -> Bool)
  SPLe   :: (SqlPrimType a, Ord a)  => SqlPrim (a -> a -> Bool)
  SPGe   :: (SqlPrimType a, Ord a)  => SqlPrim (a -> a -> Bool)
  SPAnd  :: SqlPrim (Bool -> Bool -> Bool)
  SPOr  :: SqlPrim (Bool -> Bool -> Bool)
  SPNot  :: SqlPrim (Bool -> Bool)
  SPNull :: (SqlPrimType a, SqlPrimType (Maybe a)) => SqlPrim (Maybe a)
  SPIsNull :: (SqlPrimType a, SqlPrimType (Maybe a)) => SqlPrim (Maybe a -> Bool)
  SPJust :: (SqlPrimType a, SqlPrimType (Maybe a)) => SqlPrim (a -> Maybe a)
  SPFromJust :: (SqlPrimType a, SqlPrimType (Maybe a)) => SqlPrim (Maybe a -> a)
  SPDoubleToInt :: SqlPrim (Double -> Int)
  SPIfThenElse :: (SqlPrimType a) => SqlPrim (Bool -> a -> a -> a)
  SPConcat :: SqlPrim (String -> String -> String)
  SPExists :: SqlPrim ([a] -> Bool)
  SPSum :: (SqlPrimType a, Num a) => SqlPrim (Aggr a -> a)
  SPMin :: (SqlPrimType a, Num a) => SqlPrim (Aggr a -> a)
  SPMax :: (SqlPrimType a, Num a) => SqlPrim (Aggr a -> a)
  SPCount :: SqlPrim (Aggr a -> Int)
  -- SPConcat using some kind of AllStrings class?
  SPThe :: SqlPrimType a => SqlPrim (Aggr a -> a)


data SqlLit a where
  -- we need to enumerate the prim types so we can get GADT type refinement when we use one
  SLBool :: Bool -> SqlLit Bool
  SLChar :: Char -> SqlLit Char
  SLInt :: Int -> SqlLit Int
  SLString :: String -> SqlLit String
  SLDouble :: Double -> SqlLit Double
  SLDate :: Date -> SqlLit Date

  SLProd :: SqlLit a -> SqlLit b -> SqlLit (Prod a b)
  SLNil :: SqlLit Nil

  SLAggr :: [SqlLit a] -> SqlLit (Aggr a)

instance Show (SqlLit a) where
  show (SLBool a) = show a
  show (SLChar a) = show a
  show (SLInt a) = show a
  show (SLString a) = show a
  show (SLDouble a) = show a
  show (SLDate a) = show a
  show (SLProd a b) = show (a, b)
  show SLNil = show ()

instance (SqlPrimType a, Num a) => Num (SqlLit a) where
  SLInt a + SLInt b = SLInt (a + b)
  SLDouble a + SLDouble b = SLDouble (a + b)
  SLInt a * SLInt b = SLInt (a * b)
  SLDouble a * SLDouble b = SLDouble (a * b)
  abs (SLInt a) = SLInt (abs a)
  abs (SLDouble a) = SLDouble (abs a)
  signum (SLInt a) = SLInt (signum a)
  signum (SLDouble a) = SLDouble (signum a)
  fromInteger = DM.fromJust . toLit . toSqlE . fromInteger

toLit :: SqlExpr a -> Maybe (SqlLit a)
toLit (SEPrim (SPLit v)) = return v
toLit SENil = return SLNil
toLit (SEProd a b) = return SLProd `ap` toLit a `ap` toLit b
toLit _ = Nothing

fromLit :: SqlLit a -> SqlExpr a
fromLit (SLProd a b) = SEProd (fromLit a) (fromLit b) -- TODO would be nice if the rest of the code could handle SEPrim (SPLit (SLProd ...))
fromLit SLNil = SENil
fromLit v = SEPrim (SPLit v)

checkLit :: SqlExpr a -> Maybe (SqlExpr a)
checkLit = fmap fromLit . toLit

class Showable1 (q :: * -> *) a where
  data Showable1Witness q a

class Show1 q where
  showsPrec1 :: Showable1 q a => Int -> q a -> ShowS
  show1 :: Showable1 q a => q a -> String
  showList1 :: Showable1 q a => [q a] -> ShowS

instance Showable1 IntQuery a where
  data Showable1Witness IntQuery a = Showable1IntQuery ()

instance Show1 IntQuery where
  showsPrec1 = showsPrec
  show1 = show
  showList1 = showList

instance Showable1 PrimQuery a where
  data Showable1Witness PrimQuery a = Showable1PrimQuery ()

instance Show1 PrimQuery where
  showsPrec1 = showsPrec
  show1 = show
  showList1 = showList

instance Show1 q => Show (SqlExpr' q a) where
  show (SEField (True, Just tn) (FieldName fn)) = tn ++ "." ++ fn
  show (SEField _ (FieldName fn)) = fn
  show (SEApp f a) = "(" ++ show f ++ " " ++ show a ++ ")"
  show (SEPrim p) = show p
  show (SEProd a b) = show (a, b)
  show SENil = "()"
  show (SEAggr e) = "aggr(" ++ show e ++ ")"
  show (SEIntQuery q) = "(" ++ show1 q ++ ")"
  show (SEPrimQuery q) = "(" ++ show1 q ++ ")"

instance Show (SqlFields a) where
  show (SFField (True, Just tn) (FieldName fn)) = tn ++ "." ++ fn
  show (SFField _ (FieldName fn)) = fn
  show (SFProd a b) = show (a, b)
  show SFNil = "()"

instance Show (SqlPrim a) where
  show (SPLit x) = show x
  show SPPlus = "(+)"
  show SPMinus = "(-)"
  show SPTimes = "(*)"
  show SPDivide = "(/)"
  show SPEq = "(==)"
  show SPNe = "(/=)"
  show SPLt = "(<)"
  show SPGt = "(>)"
  show SPLe = "(<=)"
  show SPGe = "(>=)"
  show SPAnd = "(&&)"
  show SPOr = "(||)"
  show SPNot = "not"
  show SPNegate = "negate"
  show SPAbs = "abs"
  show SPSign = "signum"
  show SPIsNull = "isnull"
  show SPDoubleToInt = "doubletoint"
  show SPFromJust = "fromjust"
  show SPIfThenElse = "ifthenelse"
  show SPJust = "just"
  show SPNull = "null"
  show SPConcat = "(++)"
  show SPExists = "exists"
  show SPSum = "sum"
  show SPMax = "max"
  show SPMin = "min"
  show SPThe = "the"  
  show SPCount = "count"  

data EqTypes a a' where
  EqId :: EqTypes a a
  EqFailed :: EqTypes a a'
  EqFun :: (EqTypes a a' -> EqTypes b b') -> EqTypes (a -> b) (a' -> b')
  EqProd :: EqTypes a a' -> EqTypes b b' -> EqTypes (Prod a b) (Prod a' b')

class Same s where
  sameT :: s a -> s a' -> Maybe (EqTypes a a')


same :: Same s => s a -> s a' -> Bool
same a a' = DM.isJust (sameT a a')

mkSameBase :: Bool -> Maybe (EqTypes a a)
mkSameBase False = Nothing
mkSameBase True = Just EqId

mkSameProd :: Maybe (EqTypes a a') -> Maybe (EqTypes b b') -> Maybe (EqTypes (Prod a b) (Prod a' b'))
mkSameProd (Just EqId) (Just EqId) = Just EqId
mkSameProd (Just eq) (Just eq') = Just (EqProd eq eq')
mkSameProd _ _ = Nothing

mkSameApp :: Maybe (EqTypes (a -> b) (a' -> b')) -> Maybe (EqTypes a a') -> Maybe (EqTypes b b')
mkSameApp (Just (EqFun f)) (Just eq) = Just (f eq)
mkSameApp (Just _) (Just _) = Just EqFailed
mkSameApp _ _ = Nothing

mkSameConstr :: Maybe (EqTypes a a') -> Maybe (EqTypes (s a) (s a'))
mkSameConstr (Just EqId) = Just EqId
mkSameConstr (Just _) = Just EqFailed
mkSameConstr Nothing = Nothing

mkUnConstr :: EqTypes (s a -> a) (s a' -> a')
mkUnConstr = EqFun (\eq1 -> case eq1 of EqId -> EqId ; _ -> EqFailed)

mkLamAAA :: EqTypes (a -> a -> a) (a' -> a' -> a')
mkLamAAA = EqFun (\eq1 -> EqFun (\eq2 -> case eq1 of EqId -> eq1 ; _ -> eq2))

mkSameAnd :: Maybe (EqTypes a a') -> Maybe (EqTypes a a') -> Maybe (EqTypes a a')
mkSameAnd (Just EqId) (Just _) = Just EqId
mkSameAnd (Just _) (Just EqId) = Just EqId
mkSameAnd (Just _) (Just _) = Just EqFailed
mkSameAnd _ _ = Nothing

instance Same SqlLit where
  SLBool a `sameT` SLBool b = mkSameBase $ a Prelude.== b
  SLInt a `sameT` SLInt b = mkSameBase $ a Prelude.== b
  SLChar a `sameT` SLChar b = mkSameBase $ a Prelude.== b
  SLString a `sameT` SLString b = mkSameBase $ a Prelude.== b
  SLDouble a `sameT` SLDouble b = mkSameBase $ a Prelude.== b
  SLDate a `sameT` SLDate b = mkSameBase $ a Prelude.== b
  SLProd a b `sameT` SLProd c d = mkSameProd (a `sameT` c) (b `sameT` d)
  SLNil `sameT` SLNil = Just EqId
  _ `sameT` _ = Nothing

instance Same (SqlExpr' q) where
  (SEField tn fn :: SqlExpr' q a) `sameT` (SEField tn' fn' :: SqlExpr' q a')
      | tn Prelude.== tn' && fn Prelude.== fn' = (dummyVal :: SqlExpr a) `sameT` (dummyVal :: SqlExpr a')
  SEPrim p `sameT` SEPrim p' = p `sameT` p'
  SEApp f a `sameT` SEApp f' a' = mkSameApp (f `sameT` f') (a `sameT` a')
  SEProd a b `sameT` SEProd a' b' = mkSameProd (a `sameT` a') (b `sameT` b')
  SENil `sameT` SENil = Just EqId
  SEAggr e `sameT` SEAggr e' = mkSameConstr (e `sameT` e')
  SEIntQuery q `sameT` SEIntQuery q' = mkSameConstr (q `sameT` q')
  SEPrimQuery q `sameT` SEPrimQuery q' = mkSameConstr (q `sameT` q')
  _ `sameT` _ = Nothing


sameF :: SqlBE a => ([FieldName] -> t a) -> (s b -> s b' -> res) -> (t a -> s b) -> (t a -> s b') -> res
sameF fromF sameU f f' = let a = fromF (map FieldId [20..]) in f a `sameU` f' a

sameFE = sameF fromFieldsE
sameFA = sameF fromFieldsA

sameM :: (a -> a' -> Bool) -> Maybe a -> Maybe a' -> Bool
sameM _ Nothing Nothing = True
sameM sameU (Just x) (Just x') = x `sameU` x'
sameM _ _ _ = False

instance Same IntQuery where
  (IntKnown as :: IntQuery a) `sameT` (IntKnown as' :: IntQuery a') = foldr mkSameAnd (sameT (dummyVal :: SqlExpr a) (dummyVal :: SqlExpr a')) $ zipWith sameT as as'
  IntTable tn fs `sameT` IntTable tn' fs' | tn == tn' = fs `sameT` fs'
  IntProject f q `sameT` IntProject f' q' | Just EqId <- sameT q q' = sameFE sameT f f'
  IntRestrict r q `sameT` IntRestrict r' q' | Just EqId <- sameT q q' = mkSameBase $ sameFE same r r'
  IntJoin r q1 q2 `sameT` IntJoin r' q1' q2' | Just EqId <- mkSameProd (q1 `sameT` q1') (q2 `sameT` q2') = mkSameBase $ (sameFE same `on` uncurrySEProd) r r'
  IntLeftJoin r q1 q2 `sameT` IntLeftJoin r' q1' q2' | Just EqId <- mkSameProd (q1 `sameT` q1') (q2 `sameT` q2') = mkSameBase $ (sameFE same `on` uncurrySEProd) r r'
  IntUnion q1 q2 `sameT` IntUnion q1' q2' = mkSameAnd (q1 `sameT` q1') (q2 `sameT` q2')
  IntIntersection q1 q2 `sameT` IntIntersection q1' q2' = mkSameAnd (q1 `sameT` q1') (q2 `sameT` q2')
  IntSortBy s q `sameT` IntSortBy s' q' | Just EqId <- sameT q q' = mkSameBase $ sameFE same s s'
  IntGroupBy sel deaggr q `sameT` IntGroupBy sel' deaggr' q' | Just EqId <- sameT q q' = if sameFE same sel sel' then sameFA sameT deaggr deaggr' else Nothing
  _ `sameT` _ = Nothing  

instance Same PrimQuery where
  PrimUnit e f `sameT` PrimUnit e' f' = mkSameAnd (e `sameT` e') (f `sameT` f')
  PrimUnion d q1 q2 `sameT` PrimUnion d' q1' q2' | d == d' = mkSameAnd (q1 `sameT` q1') (q2 `sameT` q2')
  PrimIntersection q1 q2 `sameT` PrimIntersection q1' q2' = mkSameAnd (q1 `sameT` q1') (q2 `sameT` q2')
  PrimSelect distinct proj f restr msort ts `sameT` PrimSelect distinct' proj' f' restr' msort' ts'
    | distinct == distinct', Just EqId <- sameT ts ts', f `same` f', sameFE same restr restr', sameM (sameFE same) msort msort'
     = sameFE sameT (fromFunc proj) (fromFunc proj')
  PrimGroup distinct sel deaggr f restr msort ts `sameT` PrimGroup distinct' sel' deaggr' f' restr' msort' ts'
    | distinct == distinct', Just EqId <- sameT ts ts', f `same` f', sameFE same sel sel', sameFE same restr restr', sameM (sameFE same) msort msort'
     = sameFE sameT deaggr deaggr'
  _ `sameT` _ = Nothing

instance Same PrimTables where
  PrimTable db tn mtn f `sameT` PrimTable db' tn' mtn' f' | db == db', tn == tn', mtn == mtn' = f `sameT` f'
  PrimQuickJoin t1 t2 `sameT` PrimQuickJoin t1' t2' = mkSameProd (t1 `sameT` t1') (t2 `sameT` t2')
  PrimJoin f t1 t2 `sameT` PrimJoin f' t1' t2' | Just EqId <- mkSameProd (t1 `sameT` t1') (t2 `sameT` t2') = mkSameBase $ (sameFE same `on` uncurrySEProd) f f'
  PrimLeftJoin f t1 t2 `sameT` PrimLeftJoin f' t1' t2' | Just EqId <- mkSameProd (t1 `sameT` t1') (t2 `sameT` t2') = mkSameBase $ (sameFE same `on` uncurrySEProd) f f'
  PrimSubQuery tn q `sameT` PrimSubQuery tn' q' | tn == tn' = q `sameT` q'
  _ `sameT` _ = Nothing

instance Same SqlPrim where
  SPLit a `sameT` SPLit a' = a `sameT` a'
  SPPlus `sameT` SPPlus = Just mkLamAAA
  SPMinus `sameT` SPMinus = Just mkLamAAA
  SPTimes `sameT` SPTimes = Just mkLamAAA
  SPAbs `sameT` SPAbs = Just (EqFun id)
  SPSign `sameT` SPSign = Just (EqFun id)
  SPNegate `sameT` SPNegate = Just (EqFun id)
  SPDivide `sameT` SPDivide = Just mkLamAAA
  SPEq `sameT` SPEq = Just (EqFun (const (EqFun (const EqId))))
  SPNe `sameT` SPNe = Just (EqFun (const (EqFun (const EqId))))
  SPLt `sameT` SPLt = Just (EqFun (const (EqFun (const EqId))))
  SPGt `sameT` SPGt = Just (EqFun (const (EqFun (const EqId))))
  SPLe `sameT` SPLe = Just (EqFun (const (EqFun (const EqId))))
  SPGe `sameT` SPGe = Just (EqFun (const (EqFun (const EqId))))
  SPAnd `sameT` SPAnd = Just (EqFun (const (EqFun (const EqId))))
  SPOr `sameT` SPOr = Just (EqFun (const (EqFun (const EqId))))
  SPNot `sameT` SPNot = Just (EqFun (const EqId))
  SPNull `sameT` SPNull = Just EqFailed
  SPIsNull `sameT` SPIsNull = Just (EqFun (const EqId))
  SPJust `sameT` SPJust = Just (EqFun f)
     where f :: EqTypes b b' -> EqTypes (Maybe b) (Maybe b')
           f EqId = EqId
           f _ = EqFailed
  SPFromJust `sameT` SPFromJust = Just (EqFun f)
     where f :: EqTypes (Maybe b) (Maybe b') -> EqTypes b b'
           f EqId = EqId
           f _ = EqFailed
  SPDoubleToInt `sameT` SPDoubleToInt = Just (EqFun (const EqId))
  SPIfThenElse `sameT` SPIfThenElse = Just (EqFun (const mkLamAAA))
  SPConcat `sameT` SPConcat = Just (EqFun (const (EqFun (const EqId))))
  SPExists `sameT` SPExists = Just (EqFun (const EqId))
  SPSum `sameT` SPSum = Just mkUnConstr
  SPMin `sameT` SPMin = Just mkUnConstr
  SPMax `sameT` SPMax = Just mkUnConstr
  SPCount `sameT` SPCount = Just (EqFun (const EqId))
  SPThe `sameT` SPThe = Just mkUnConstr
  _ `sameT` _ = Nothing

instance Eq (SqlLit a) where
  (==) = same

instance Eq (SqlExpr a) where
  a == b = error "Can't compare SqlExprs for normal Boolean equality"

-- Perhaps better to enumerate the SqlPrimTypes in the constructors, so we know statically there is no ambiguity with pairs?

class Eq a => SqlEq a where
  eq :: SqlExpr a -> SqlExpr a -> SqlExpr Bool

instance SqlEq Int where
  x `eq` y = SEPrim SPEq `SEApp` x `SEApp` y

instance SqlEq (Maybe Int) where
  x `eq` y = SEPrim SPEq `SEApp` x `SEApp` y

instance SqlEq Bool where
  x `eq` y = SEPrim SPEq `SEApp` x `SEApp` y

instance SqlEq (Maybe Bool) where
  x `eq` y = SEPrim SPEq `SEApp` x `SEApp` y

instance SqlEq String where
  x `eq` y = SEPrim SPEq `SEApp` x `SEApp` y

instance SqlEq (Maybe String) where
  x `eq` y = SEPrim SPEq `SEApp` x `SEApp` y

instance SqlEq Char where
  x `eq` y = SEPrim SPEq `SEApp` x `SEApp` y

instance SqlEq (Maybe Char) where
  x `eq` y = SEPrim SPEq `SEApp` x `SEApp` y

instance SqlEq Date where
  x `eq` y = SEPrim SPEq `SEApp` x `SEApp` y

instance SqlEq (Maybe Date) where
  x `eq` y = SEPrim SPEq `SEApp` x `SEApp` y

instance SqlEq Double where
  x `eq` y = SEPrim SPEq `SEApp` x `SEApp` y

instance SqlEq (Maybe Double) where
  x `eq` y = SEPrim SPEq `SEApp` x `SEApp` y


sqlAnd x y = SEPrim SPAnd `SEApp` x `SEApp` y
sqlOr x y = SEPrim SPOr `SEApp` x `SEApp` y

instance SqlEq Nil where
  x `eq` y = true

instance (SqlEq a, SqlEq b) => SqlEq (Prod a b) where
  SEProd a b `eq` SEProd c d = sqlAnd (a `eq` c) (b `eq` d)

class (SqlEq a, Ord a) => SqlOrd a where
  lt :: SqlExpr a -> SqlExpr a -> SqlExpr Bool
  gt :: SqlExpr a -> SqlExpr a -> SqlExpr Bool
  le :: SqlExpr a -> SqlExpr a -> SqlExpr Bool
  ge :: SqlExpr a -> SqlExpr a -> SqlExpr Bool

instance SqlOrd Int where
  x `lt` y = SEPrim SPLt `SEApp` x `SEApp` y
  x `gt` y = SEPrim SPGt `SEApp` x `SEApp` y
  x `le` y = SEPrim SPLe `SEApp` x `SEApp` y
  x `ge` y = SEPrim SPGe `SEApp` x `SEApp` y

instance SqlOrd Bool where
  x `lt` y = SEPrim SPLt `SEApp` x `SEApp` y
  x `gt` y = SEPrim SPGt `SEApp` x `SEApp` y
  x `le` y = SEPrim SPLe `SEApp` x `SEApp` y
  x `ge` y = SEPrim SPGe `SEApp` x `SEApp` y

instance SqlOrd String where
  x `lt` y = SEPrim SPLt `SEApp` x `SEApp` y
  x `gt` y = SEPrim SPGt `SEApp` x `SEApp` y
  x `le` y = SEPrim SPLe `SEApp` x `SEApp` y
  x `ge` y = SEPrim SPGe `SEApp` x `SEApp` y

instance SqlOrd Char where
  x `lt` y = SEPrim SPLt `SEApp` x `SEApp` y
  x `gt` y = SEPrim SPGt `SEApp` x `SEApp` y
  x `le` y = SEPrim SPLe `SEApp` x `SEApp` y
  x `ge` y = SEPrim SPGe `SEApp` x `SEApp` y

instance SqlOrd Date where
  x `lt` y = SEPrim SPLt `SEApp` x `SEApp` y
  x `gt` y = SEPrim SPGt `SEApp` x `SEApp` y
  x `le` y = SEPrim SPLe `SEApp` x `SEApp` y
  x `ge` y = SEPrim SPGe `SEApp` x `SEApp` y

instance SqlOrd Double where
  x `lt` y = SEPrim SPLt `SEApp` x `SEApp` y
  x `gt` y = SEPrim SPGt `SEApp` x `SEApp` y
  x `le` y = SEPrim SPLe `SEApp` x `SEApp` y
  x `ge` y = SEPrim SPGe `SEApp` x `SEApp` y

instance SqlOrd Nil where
  x `lt` y = false
  x `gt` y = false
  x `le` y = true
  x `ge` y = true

instance (SqlOrd a, SqlOrd b) => SqlOrd (Prod a b) where
  SEProd a b `lt` SEProd c d = (a `lt` c) `sqlOr` ((a `eq` c) `sqlAnd` (b `lt` d))
  SEProd a b `le` SEProd c d = (a `lt` c) `sqlOr` ((a `eq` c) `sqlAnd` (b `le` d))
  SEProd a b `gt` SEProd c d = (a `gt` c) `sqlOr` ((a `eq` c) `sqlAnd` (b `gt` d))
  SEProd a b `ge` SEProd c d = (a `gt` c) `sqlOr` ((a `eq` c) `sqlAnd` (b `ge` d))


-- If we want the comparison operator to be consistent with the behaviour of
-- ORDER BY and GROUP BY then we can only implement it by projection. So we use
-- this restricted type class to enforce that.
-- TODO reverse comparison (Desc constructor?)
class HasSqlCmp sa where
  type SqlCmp sa
  comparisonFields :: sa -> SqlCmp sa

(f `on` g) a b = f (g a) (g b)

instance (HasSqlCmp sea, HasSqlExpr a sea,
          HasProdEnc (SqlCmp sea),
          IsSqlExpr (ProdEnc (SqlCmp sea)),
          SqlEq (UnSqlExpr (ProdEnc (SqlCmp sea))))
       => AEq sea (SqlExpr Bool) where
  (==) = eq `on` (encodeSqlExpr . comparisonFields)

instance (HasSqlCmp sea,
          HasSqlExpr a sea,
          HasProdEnc (SqlCmp sea),
          IsSqlExpr (ProdEnc (SqlCmp sea)),
          SqlOrd (UnSqlExpr (ProdEnc (SqlCmp sea))))
       => AOrd sea (SqlExpr Bool) where
  (<) = lt `on` (encodeSqlExpr . comparisonFields)
  (<=) = le `on` (encodeSqlExpr . comparisonFields)
  (>) = gt `on` (encodeSqlExpr . comparisonFields)
  (>=) = ge `on` (encodeSqlExpr . comparisonFields)

instance HasSqlCmp (SqlExpr ()) where
  type SqlCmp (SqlExpr ()) = SqlExpr ()
  comparisonFields = id

instance HasSqlCmp (SqlExpr Int) where
  type SqlCmp (SqlExpr Int) = SqlExpr Int
  comparisonFields = id

instance HasSqlCmp (SqlExpr Bool) where
  type SqlCmp (SqlExpr Bool) = SqlExpr Bool
  comparisonFields = id

instance HasSqlCmp (SqlExpr String) where
  type SqlCmp (SqlExpr String) = SqlExpr String
  comparisonFields = id

instance HasSqlCmp (SqlExpr Char) where
  type SqlCmp (SqlExpr Char) = SqlExpr Char
  comparisonFields = id

instance HasSqlCmp (SqlExpr Date) where
  type SqlCmp (SqlExpr Date) = SqlExpr Date
  comparisonFields = id

instance HasSqlCmp (SqlExpr Double) where
  type SqlCmp (SqlExpr Double) = SqlExpr Double
  comparisonFields = id

instance (HasSqlCmp a, HasSqlCmp b) => HasSqlCmp (a, b) where
  type SqlCmp (a, b) = (SqlCmp a, SqlCmp b)
  comparisonFields (a, b) = (comparisonFields a, comparisonFields b)

instance IsBool (SqlLit Bool) where
   fromBool = SLBool . fromBool
   SLBool a && SLBool b = SLBool (a && b)
   SLBool a || SLBool b = SLBool (a || b)
   not (SLBool a) = SLBool (not a)

instance IsBool (SqlExpr' q Bool) where
   fromBool = SEPrim . SPLit . SLBool
   a && b = SEPrim SPAnd `SEApp` a `SEApp` b
   a || b = SEPrim SPOr `SEApp` a `SEApp` b
   not a = SEPrim SPNot `SEApp` a

instance IsString (SqlExpr String) where
   fromString = SEPrim . SPLit . SLString

instance SqlPrimType a => IsString (SqlFields a) where
   fromString = SFField (False, Nothing) . FieldName

instance (SqlPrimType a, SqlPrimType (Maybe a)) => HasMaybe SqlExpr a where
   nothing = SEPrim SPNull
   just x = SEApp (SEPrim SPJust) x
   isNothing y = SEApp (SEPrim SPIsNull) y
   isJust y = SEApp (SEPrim SPNot) (SEApp (SEPrim SPIsNull) y)
   fromJust y = SEApp (SEPrim SPFromJust) y

instance Num (SqlLit Int) where
   fromInteger = SLInt . fromInteger
   SLInt a + SLInt b = SLInt (a + b)
   SLInt a - SLInt b = SLInt (a - b)
   SLInt a * SLInt b = SLInt (a * b)
   negate (SLInt a) = SLInt (negate a)
   abs (SLInt a) = SLInt (abs a)
   signum (SLInt a) = SLInt (signum a)

instance Num (SqlExpr Int) where
   fromInteger = SEPrim . SPLit . SLInt . fromInteger
   a + b = SEPrim SPPlus `SEApp` a `SEApp` b
   a - b = SEPrim SPMinus `SEApp` a `SEApp` b
   a * b = SEPrim SPTimes `SEApp` a `SEApp` b
   negate a = SEPrim SPNegate `SEApp` a
   abs a = SEPrim SPAbs `SEApp` a
   signum a = SEPrim SPSign `SEApp` a

instance Num (SqlLit Double) where
   fromInteger = SLDouble . fromInteger
   SLDouble a + SLDouble b = SLDouble (a + b)
   SLDouble a - SLDouble b = SLDouble (a - b)
   SLDouble a * SLDouble b = SLDouble (a * b)
   negate (SLDouble a) = SLDouble (negate a)
   abs (SLDouble a) = SLDouble (abs a)
   signum (SLDouble a) = SLDouble (signum a)

instance Num (SqlExpr Double) where
   fromInteger = SEPrim . SPLit . SLDouble . fromInteger
   a + b = SEPrim SPPlus `SEApp` a `SEApp` b
   a - b = SEPrim SPMinus `SEApp` a `SEApp` b
   a * b = SEPrim SPTimes `SEApp` a `SEApp` b
   negate a = SEPrim SPNegate `SEApp` a
   abs a = SEPrim SPAbs `SEApp` a
   signum a = SEPrim SPSign `SEApp` a

isNull = SEApp (SEPrim SPIsNull)

class DoubleToInt s where
   doubleToInt :: Apply s Double -> Apply s Int

instance DoubleToInt Id where
   doubleToInt = round

instance DoubleToInt SqlExpr where
   doubleToInt = SEApp (SEPrim SPDoubleToInt)

data SqlPrimTypeDict a where
   SqlPrimTypeDict :: SqlPrimType a => SqlPrimTypeDict a

class (Show a, Eq a, SqlEq a, SqlBind a, SqlBE a) => SqlPrimType a where
  sqlPrimTypeNullableDict :: a -> SqlPrimTypeDict (Nullable a)
  showPrimSql :: a -> String
  -- TODO should be called toSqlExpr
  toSqlE :: a -> SqlExpr a


instance SqlBind Char where
  fromSqlValue typ field = fmap head (fromSqlValue typ field)

instance SqlBind Date where
  fromSqlValue typ field = fmap mkDate (fromSqlValue typ field)
   where
      mkDate str = Date (read (take 4 str),
                         read (take 2 (drop 5 str)),
                         read (take 2 (drop 8 str)))

instance (SqlEq (Maybe a), SqlBE (Maybe a), SqlPrimType a, Nullable a ~ Maybe a) => SqlPrimType (Maybe a) where
  sqlPrimTypeNullableDict _ = SqlPrimTypeDict
  showPrimSql Nothing = "NULL"
  showPrimSql (Just a) = showPrimSql a
  toSqlE (Just a) = SEApp (SEPrim SPJust) (toSqlE a)
  toSqlE Nothing = SEPrim SPNull

instance SqlPrimType Int where
  sqlPrimTypeNullableDict _ = SqlPrimTypeDict
  showPrimSql = show
  toSqlE = SEPrim . SPLit . SLInt

instance SqlPrimType Bool where
  sqlPrimTypeNullableDict _ = SqlPrimTypeDict
  showPrimSql True = "true"
  showPrimSql False = "false"
  toSqlE = SEPrim . SPLit . SLBool

instance SqlPrimType String where
  sqlPrimTypeNullableDict _ = SqlPrimTypeDict
  showPrimSql = show
  toSqlE = SEPrim . SPLit . SLString

instance SqlPrimType Char where
  sqlPrimTypeNullableDict _ = SqlPrimTypeDict
  showPrimSql = show
  toSqlE = SEPrim . SPLit . SLChar

instance SqlPrimType Date where
  sqlPrimTypeNullableDict _ = SqlPrimTypeDict
  showPrimSql (Date (yyyy, mm, dd)) = show (show yyyy ++ "-" ++ show mm ++ "-" ++ show dd)
  toSqlE = SEPrim . SPLit . SLDate

instance SqlPrimType Double where
  sqlPrimTypeNullableDict _ = SqlPrimTypeDict
  showPrimSql = show
  toSqlE = SEPrim . SPLit . SLDouble

newtype Id a = Id { unId :: a }
newtype Comp f g x = Comp { unComp :: f (g x) }

type family Apply (f :: * -> *) a

type instance Apply Id a = a
type instance Apply (Comp f g) a = Apply f (Apply g a)
type instance Apply SqlExpr a = SqlExpr a
type instance Apply SqlFields a = SqlFields a
type instance Apply Maybe Int = Maybe Int
type instance Apply Maybe Double = Maybe Double
type instance Apply Maybe Date = Maybe Int
type instance Apply Maybe Bool = Maybe Bool
type instance Apply Maybe Char = Maybe Char
type instance Apply Maybe String = Maybe String
type instance Apply Maybe (Maybe a) = Apply Maybe a

class HasProdEnc a where
   type ProdEnc a
   encode :: a -> ProdEnc a
   decode :: ProdEnc a -> a

instance HasProdEnc Bool where
   type ProdEnc Bool = Bool
   encode = id
   decode = id

instance HasProdEnc (Id Bool) where
   type ProdEnc (Id Bool) = Id Bool
   encode = id
   decode = id

instance HasProdEnc (Maybe Bool) where
   type ProdEnc (Maybe Bool) = Maybe Bool
   encode = id
   decode = id

instance HasProdEnc (SqlExpr Bool) where
   type ProdEnc (SqlExpr Bool) = SqlExpr Bool
   encode = id
   decode = id

instance HasProdEnc (SqlFields Bool) where
   type ProdEnc (SqlFields Bool) = SqlFields Bool
   encode = id
   decode = id

instance HasProdEnc (SqlExpr (Maybe Bool)) where
   type ProdEnc (SqlExpr (Maybe Bool)) = SqlExpr (Maybe Bool)
   encode = id
   decode = id

instance HasProdEnc (Comp SqlExpr Maybe Bool) where
   type ProdEnc (Comp SqlExpr Maybe Bool) = SqlExpr (Maybe Bool)
   encode = unComp
   decode = Comp

instance HasProdEnc (SqlFields (Maybe Bool)) where
   type ProdEnc (SqlFields (Maybe Bool)) = SqlFields (Maybe Bool)
   encode = id
   decode = id


instance HasProdEnc (Comp SqlFields Maybe Bool) where
   type ProdEnc (Comp SqlFields Maybe Bool) = SqlFields (Maybe Bool)
   encode = unComp
   decode = Comp

instance HasProdEnc Int where
   type ProdEnc Int = Int
   encode = id
   decode = id

instance HasProdEnc (Id Int) where
   type ProdEnc (Id Int) = Id Int
   encode = id
   decode = id

instance HasProdEnc (Maybe Int) where
   type ProdEnc (Maybe Int) = Maybe Int
   encode = id
   decode = id

instance HasProdEnc (Maybe (Maybe Int)) where
   type ProdEnc (Maybe (Maybe Int)) = Maybe Int
   encode (Just (Just x)) = Just x
   encode _ = Nothing
   decode (Just x) = Just (Just x)
   decode Nothing = Nothing

instance HasProdEnc (Id (Maybe Int)) where
   type ProdEnc (Id (Maybe Int)) = Maybe Int
   encode = unId
   decode = Id

instance HasProdEnc (SqlExpr Int) where
   type ProdEnc (SqlExpr Int) = SqlExpr Int
   encode = id
   decode = id

instance HasProdEnc (SqlExpr (Maybe Int)) where
   type ProdEnc (SqlExpr (Maybe Int)) = SqlExpr (Maybe Int)
   encode = id
   decode = id

instance HasProdEnc (Comp SqlExpr Maybe Int) where
   type ProdEnc (Comp SqlExpr Maybe Int) = SqlExpr (Maybe Int)
   encode = unComp
   decode = Comp

instance HasProdEnc (SqlFields Int) where
   type ProdEnc (SqlFields Int) = SqlFields Int
   encode = id
   decode = id

instance HasProdEnc (SqlFields (Maybe Int)) where
   type ProdEnc (SqlFields (Maybe Int)) = SqlFields (Maybe Int)
   encode = id
   decode = id

instance HasProdEnc (Comp SqlFields Maybe Int) where
   type ProdEnc (Comp SqlFields Maybe Int) = SqlFields (Maybe Int)
   encode = unComp
   decode = Comp



instance HasProdEnc String where
   type ProdEnc String = String
   encode = id
   decode = id

instance HasProdEnc (Id String) where
   type ProdEnc (Id String) = Id String
   encode = id
   decode = id

instance HasProdEnc (Maybe String) where
   type ProdEnc (Maybe String) = Maybe String
   encode = id
   decode = id

instance HasProdEnc (SqlExpr String) where
   type ProdEnc (SqlExpr String) = SqlExpr String
   encode = id
   decode = id

instance HasProdEnc (SqlExpr (Maybe String)) where
   type ProdEnc (SqlExpr (Maybe String)) = SqlExpr (Maybe String)
   encode = id
   decode = id

instance HasProdEnc (Comp SqlExpr Maybe String) where
   type ProdEnc (Comp SqlExpr Maybe String) = SqlExpr (Maybe String)
   encode = unComp
   decode = Comp

instance HasProdEnc (SqlFields String) where
   type ProdEnc (SqlFields String) = SqlFields String
   encode = id
   decode = id

instance HasProdEnc (SqlFields (Maybe String)) where
   type ProdEnc (SqlFields (Maybe String)) = SqlFields (Maybe String)
   encode = id
   decode = id

instance HasProdEnc (Comp SqlFields Maybe String) where
   type ProdEnc (Comp SqlFields Maybe String) = SqlFields (Maybe String)
   encode = unComp
   decode = Comp


instance HasProdEnc Char where
   type ProdEnc Char = Char
   encode = id
   decode = id

instance HasProdEnc (Id Char) where
   type ProdEnc (Id Char) = Id Char
   encode = id
   decode = id

instance HasProdEnc (Maybe Char) where
   type ProdEnc (Maybe Char) = Maybe Char
   encode = id
   decode = id

instance HasProdEnc (SqlExpr Char) where
   type ProdEnc (SqlExpr Char) = SqlExpr Char
   encode = id
   decode = id

instance HasProdEnc (SqlExpr (Maybe Char)) where
   type ProdEnc (SqlExpr (Maybe Char)) = SqlExpr (Maybe Char)
   encode = id
   decode = id

instance HasProdEnc (Comp SqlExpr Maybe Char) where
   type ProdEnc (Comp SqlExpr Maybe Char) = SqlExpr (Maybe Char)
   encode = unComp
   decode = Comp

instance HasProdEnc (SqlFields Char) where
   type ProdEnc (SqlFields Char) = SqlFields Char
   encode = id
   decode = id

instance HasProdEnc (SqlFields (Maybe Char)) where
   type ProdEnc (SqlFields (Maybe Char)) = SqlFields (Maybe Char)
   encode = id
   decode = id

instance HasProdEnc (Comp SqlFields Maybe Char) where
   type ProdEnc (Comp SqlFields Maybe Char) = SqlFields (Maybe Char)
   encode = unComp
   decode = Comp



instance HasProdEnc Date where
   type ProdEnc Date = Date
   encode = id
   decode = id

instance HasProdEnc (Id Date) where
   type ProdEnc (Id Date) = Id Date
   encode = id
   decode = id

instance HasProdEnc (Maybe Date) where
   type ProdEnc (Maybe Date) = Maybe Date
   encode = id
   decode = id

instance HasProdEnc (SqlExpr Date) where
   type ProdEnc (SqlExpr Date) = SqlExpr Date
   encode = id
   decode = id

instance HasProdEnc (SqlExpr (Maybe Date)) where
   type ProdEnc (SqlExpr (Maybe Date)) = SqlExpr (Maybe Date)
   encode = id
   decode = id

instance HasProdEnc (Comp SqlExpr Maybe Date) where
   type ProdEnc (Comp SqlExpr Maybe Date) = SqlExpr (Maybe Date)
   encode = unComp
   decode = Comp

instance HasProdEnc (SqlFields Date) where
   type ProdEnc (SqlFields Date) = SqlFields Date
   encode = id
   decode = id

instance HasProdEnc (SqlFields (Maybe Date)) where
   type ProdEnc (SqlFields (Maybe Date)) = SqlFields (Maybe Date)
   encode = id
   decode = id

instance HasProdEnc (Comp SqlFields Maybe Date) where
   type ProdEnc (Comp SqlFields Maybe Date) = SqlFields (Maybe Date)
   encode = unComp
   decode = Comp


instance HasProdEnc Double where
   type ProdEnc Double = Double
   encode = id
   decode = id

instance HasProdEnc (Id Double) where
   type ProdEnc (Id Double) = Id Double
   encode = id
   decode = id

instance HasProdEnc (Maybe Double) where
   type ProdEnc (Maybe Double) = Maybe Double
   encode = id
   decode = id

instance HasProdEnc (SqlExpr Double) where
   type ProdEnc (SqlExpr Double) = SqlExpr Double
   encode = id
   decode = id

instance HasProdEnc (SqlExpr (Maybe Double)) where
   type ProdEnc (SqlExpr (Maybe Double)) = SqlExpr (Maybe Double)
   encode = id
   decode = id

instance HasProdEnc (Comp SqlExpr Maybe Double) where
   type ProdEnc (Comp SqlExpr Maybe Double) = SqlExpr (Maybe Double)
   encode = unComp
   decode = Comp

instance HasProdEnc (SqlFields Double) where
   type ProdEnc (SqlFields Double) = SqlFields Double
   encode = id
   decode = id

instance HasProdEnc (SqlFields (Maybe Double)) where
   type ProdEnc (SqlFields (Maybe Double)) = SqlFields (Maybe Double)
   encode = id
   decode = id

instance HasProdEnc (Comp SqlFields Maybe Double) where
   type ProdEnc (Comp SqlFields Maybe Double) = SqlFields (Maybe Double)
   encode = unComp
   decode = Comp

class (Show t, HasProdEnc t) => HasProdEncS t
instance (Show t, HasProdEnc t) => HasProdEncS t

class (HasProdEncS (Apply s Int),
       HasProdEncS (Apply s Bool),
       HasProdEncS (Apply s String),
       HasProdEncS (Apply s Char),
       HasProdEncS (Apply s Date),
       HasProdEncS (Apply s Double),
       HasProdEncS (Apply s (Maybe Int)),
       HasProdEncS (Apply s (Maybe Bool)),
       HasProdEncS (Apply s (Maybe String)),
       HasProdEncS (Apply s (Maybe Char)),
       HasProdEncS (Apply s (Maybe Date)),
       HasProdEncS (Apply s (Maybe Double))
      ) => SqlConstr s

instance SqlConstr Id
instance SqlConstr SqlExpr
instance SqlConstr SqlFields
instance SqlConstr Maybe
instance SqlConstr s => SqlConstr (Comp s Maybe)

class (IsString (Apply s String), HasMaybe s String, HasMaybe s Int, HasMaybe s Double, DoubleToInt s) => SqlConstr2 s 
instance SqlConstr2 Id
instance SqlConstr2 SqlExpr

instance HasProdEnc () where
   type ProdEnc () = Nil
   encode () = Nil
   decode Nil = ()

instance HasProdEnc a => HasProdEnc (Aggr a) where
   type ProdEnc (Aggr a) = Aggr (ProdEnc a)
   encode (Aggr a) = Aggr (encode a)
   decode (Aggr a) = Aggr (decode a)

instance HasProdEnc (SqlExpr a) => HasProdEnc (SqlExpr (Aggr a)) where
   type ProdEnc (SqlExpr (Aggr a)) = Aggr (ProdEnc (SqlExpr a))
   encode (SEAggr a) = Aggr (encode a)
   decode (Aggr a) = SEAggr (decode a)

instance (HasProdEnc a, HasProdEnc b) => HasProdEnc (a, b) where
   type ProdEnc (a, b) = Prod (ProdEnc a) (ProdEnc b)
   encode (a, b) = Prod (encode a) (encode b)
   decode (Prod a b) = (decode a, decode b)

instance (HasProdEnc a, HasProdEnc b, HasProdEnc c) => HasProdEnc (a, b, c) where
   type ProdEnc (a, b, c) = Prod (ProdEnc a) (Prod (ProdEnc b) (ProdEnc c))
   encode (a, b, c) = Prod (encode a) (Prod (encode b) (encode c))
   decode (Prod a (Prod b c)) = (decode a, decode b, decode c)

encodeSqlExpr :: (HasProdEnc sea, IsSqlExpr (ProdEnc sea)) => sea -> SqlExpr (UnSqlExpr (ProdEnc sea))
encodeSqlExpr sql = toSqlExpr (encode sql)

decodeSqlExpr :: (HasProdEnc sea, IsSqlExpr (ProdEnc sea)) => SqlExpr (UnSqlExpr (ProdEnc sea)) -> sea
decodeSqlExpr exp = decode (fromSqlExpr exp)

encodeSqlFields :: (HasProdEnc saa, IsSqlFields (ProdEnc saa)) => saa -> SqlFields (UnSqlFields (ProdEnc saa))
encodeSqlFields sql = toSqlFields (encode sql)

decodeSqlFields :: (HasProdEnc saa, IsSqlFields (ProdEnc saa)) => SqlFields (UnSqlFields (ProdEnc saa)) -> saa
decodeSqlFields exp = decode (fromSqlFields exp)

class IsSqlExpr a where
   type UnSqlExpr a -- This is actually a two-way mapping, but perhaps we don't need that..
   toSqlExpr :: a -> SqlExpr (UnSqlExpr a)
   fromSqlExpr :: SqlExpr (UnSqlExpr a) -> a

class IsSqlFields a where
   type UnSqlFields a
   toSqlFields :: a -> SqlFields (UnSqlFields a)
   fromSqlFields :: SqlFields (UnSqlFields a) -> a

instance IsSqlExpr (SqlExpr Bool) where
   type UnSqlExpr (SqlExpr Bool) = Bool
   toSqlExpr = id
   fromSqlExpr = id

instance IsSqlFields (SqlFields Bool) where
   type UnSqlFields (SqlFields Bool) = Bool
   toSqlFields = id
   fromSqlFields = id


instance IsSqlExpr (SqlExpr Int) where
   type UnSqlExpr (SqlExpr Int) = Int
   toSqlExpr = id
   fromSqlExpr = id


instance IsSqlFields (SqlFields Int) where
   type UnSqlFields (SqlFields Int) = Int
   toSqlFields = id
   fromSqlFields = id



instance IsSqlExpr (SqlExpr String) where
   type UnSqlExpr (SqlExpr String) = String
   toSqlExpr = id
   fromSqlExpr = id



instance IsSqlExpr (SqlExpr Char) where
   type UnSqlExpr (SqlExpr Char) = Char
   toSqlExpr = id
   fromSqlExpr = id


instance IsSqlExpr (SqlExpr Date) where
   type UnSqlExpr (SqlExpr Date) = Date
   toSqlExpr = id
   fromSqlExpr = id


instance IsSqlExpr (SqlExpr Double) where
   type UnSqlExpr (SqlExpr Double) = Double
   toSqlExpr = id
   fromSqlExpr = id


instance IsSqlFields (SqlFields String) where
   type UnSqlFields (SqlFields String) = String
   toSqlFields = id
   fromSqlFields = id

instance IsSqlFields (SqlFields Char) where
   type UnSqlFields (SqlFields Char) = Char
   toSqlFields = id
   fromSqlFields = id

instance IsSqlFields (SqlFields Date) where
   type UnSqlFields (SqlFields Date) = Date
   toSqlFields = id
   fromSqlFields = id

instance IsSqlFields (SqlFields Double) where
   type UnSqlFields (SqlFields Double) = Double
   toSqlFields = id
   fromSqlFields = id


instance (a ~ UnSqlExpr (SqlExpr a), IsSqlExpr (SqlExpr a)) => IsSqlExpr (SqlExpr (Maybe a)) where
   type UnSqlExpr (SqlExpr (Maybe a)) = Maybe a
   toSqlExpr = id
   fromSqlExpr = id

instance IsSqlExpr Nil where
   type UnSqlExpr Nil = Nil
   toSqlExpr Nil = SENil
   fromSqlExpr SENil = Nil

instance (a ~ UnSqlFields (SqlFields a), IsSqlFields (SqlFields a)) => IsSqlFields (SqlFields (Maybe a)) where
   type UnSqlFields (SqlFields (Maybe a)) = Maybe a
   toSqlFields = id
   fromSqlFields = id

instance IsSqlFields Nil where
   type UnSqlFields Nil = Nil
   toSqlFields Nil = SFNil
   fromSqlFields SFNil = Nil


instance IsSqlExpr a => IsSqlExpr (Aggr a) where
   type UnSqlExpr (Aggr a) = Aggr (UnSqlExpr a)
   toSqlExpr (Aggr a) = SEAggr (toSqlExpr a)
   fromSqlExpr (SEAggr a) = Aggr (fromSqlExpr a)

instance IsSqlExpr (SqlExpr a) => IsSqlExpr (SqlExpr (Aggr a)) where
   type UnSqlExpr (SqlExpr (Aggr a)) = Aggr (UnSqlExpr (SqlExpr a))
   toSqlExpr (SEAggr a) = SEAggr (toSqlExpr a)
   fromSqlExpr (SEAggr a) = SEAggr (fromSqlExpr a)

instance (IsSqlExpr a, IsSqlExpr b) => IsSqlExpr (Prod a b) where
   type UnSqlExpr (Prod a b) = Prod (UnSqlExpr a) (UnSqlExpr b)
   toSqlExpr (Prod a b) = SEProd (toSqlExpr a) (toSqlExpr b)
   fromSqlExpr (SEProd a b) = Prod (fromSqlExpr a) (fromSqlExpr b)


instance (IsSqlFields a, IsSqlFields b) => IsSqlFields (Prod a b) where
   type UnSqlFields (Prod a b) = Prod (UnSqlFields a) (UnSqlFields b)
   toSqlFields (Prod a b) = SFProd (toSqlFields a) (toSqlFields b)
   fromSqlFields (SFProd a b) = Prod (fromSqlFields a) (fromSqlFields b)

exprToAggr :: SqlExpr' q e -> SqlAggr' q e
exprToAggr = SEAggr
aggrToExpr :: SqlAggr' q e -> SqlExpr' q e
aggrToExpr (SEAggr e) = e

onAggr :: (a -> b) -> Aggr a -> Aggr b
onAggr f (Aggr a) = Aggr (f a)

f **** g = (f . onAggr fst) &&& (g . onAggr snd)

class SqlConv a where
   fieldsToExpr :: SqlFields a -> SqlExpr' q a
   applyThe :: SqlAggr a -> SqlExpr a

instance SqlConv Bool where
   fieldsToExpr (SFField mtn x) = SEField mtn x
   applyThe = SEApp (SEPrim SPThe)

instance SqlConv (Maybe Bool) where
   fieldsToExpr (SFField mtn x) = SEField mtn x
   applyThe = SEApp (SEPrim SPThe)

instance SqlConv Int where
   fieldsToExpr (SFField mtn x) = SEField mtn x
   applyThe = SEApp (SEPrim SPThe)

instance SqlConv (Maybe Int) where
   fieldsToExpr (SFField mtn x) = SEField mtn x
   applyThe = SEApp (SEPrim SPThe)

instance SqlConv Char where
   fieldsToExpr (SFField mtn x) = SEField mtn x
   applyThe = SEApp (SEPrim SPThe)

instance SqlConv (Maybe Char) where
   fieldsToExpr (SFField mtn x) = SEField mtn x
   applyThe = SEApp (SEPrim SPThe)

instance SqlConv Double where
   fieldsToExpr (SFField mtn x) = SEField mtn x
   applyThe = SEApp (SEPrim SPThe)

instance SqlConv (Maybe Double) where
   fieldsToExpr (SFField mtn x) = SEField mtn x
   applyThe = SEApp (SEPrim SPThe)

instance SqlConv Date where
   fieldsToExpr (SFField mtn x) = SEField mtn x
   applyThe = SEApp (SEPrim SPThe)

instance SqlConv (Maybe Date) where
   fieldsToExpr (SFField mtn x) = SEField mtn x
   applyThe = SEApp (SEPrim SPThe)

instance SqlConv String where
   fieldsToExpr (SFField mtn x) = SEField mtn x
   applyThe = SEApp (SEPrim SPThe)

instance SqlConv (Maybe String) where
   fieldsToExpr (SFField mtn x) = SEField mtn x
   applyThe = SEApp (SEPrim SPThe)

instance SqlConv Nil where
   fieldsToExpr SFNil = SENil
   applyThe (SEAggr SENil) = SENil

instance (SqlConv a, SqlConv b) => SqlConv (Prod a b) where
   fieldsToExpr (SFProd a b) = SEProd (fieldsToExpr a) (fieldsToExpr b)
   applyThe (SEAggr (SEProd a b)) = SEProd (applyThe (SEAggr a)) (applyThe (SEAggr b))

instance SqlConv a => SqlConv (Aggr a) where
   fieldsToExpr (SFAggr a) = SEAggr (fieldsToExpr a)
   applyThe (SEAggr a) = SEAggr (applyThe a)

data SqlBEDict a where
   SqlBEDict :: SqlBE a => SqlBEDict a

-- A type that can exist in the backend, i.e. IntQuery and PrimQuery
class (SqlConv a, FromFields a) => SqlBE a where
   sqlBENullableDict :: a -> SqlBEDict (Nullable a)
   dummyVal :: SqlExpr a

instance SqlBE Nil where
  sqlBENullableDict _ = SqlBEDict
  dummyVal = SENil

instance (SqlBE a, SqlBE b) => SqlBE (Prod a b) where
  sqlBENullableDict _ = case (sqlBENullableDict (undefined :: a), sqlBENullableDict (undefined :: b)) of
                         (SqlBEDict, SqlBEDict) -> SqlBEDict
  dummyVal = SEProd dummyVal dummyVal

instance SqlBE a => SqlBE (Aggr a) where
  sqlBENullableDict _ = error "TODO: sqlBENullablDict (Aggr...)"
  dummyVal = SEAggr dummyVal

instance SqlBE Bool where
  sqlBENullableDict _ = SqlBEDict
  dummyVal = SEPrim (SPLit (SLBool False))

instance SqlBE Int where
  sqlBENullableDict _ = SqlBEDict
  dummyVal = SEPrim (SPLit (SLInt 0))

instance SqlBE Char where
  sqlBENullableDict _ = SqlBEDict
  dummyVal = SEPrim (SPLit (SLChar '0'))

instance SqlBE String where
  sqlBENullableDict _ = SqlBEDict
  dummyVal = SEPrim (SPLit (SLString ""))

instance SqlBE Date where
  sqlBENullableDict _ = SqlBEDict
  dummyVal = SEPrim (SPLit (SLDate (Date (0,0,0))))

instance SqlBE Double where
  sqlBENullableDict _ = SqlBEDict
  dummyVal = SEPrim (SPLit (SLDouble 0))

instance SqlBE (Maybe Bool) where
  sqlBENullableDict _ = SqlBEDict
  dummyVal = SEPrim SPNull

instance SqlBE (Maybe Int) where
  sqlBENullableDict _ = SqlBEDict
  dummyVal = SEPrim SPNull

instance SqlBE (Maybe Char) where
  sqlBENullableDict _ = SqlBEDict
  dummyVal = SEPrim SPNull

instance SqlBE (Maybe String) where
  sqlBENullableDict _ = SqlBEDict
  dummyVal = SEPrim SPNull

instance SqlBE (Maybe Date) where
  sqlBENullableDict _ = SqlBEDict
  dummyVal = SEPrim SPNull

instance SqlBE (Maybe Double) where
  sqlBENullableDict _ = SqlBEDict
  dummyVal = SEPrim SPNull

type family Nullable a

type instance Nullable (Maybe a) = Maybe a
type instance Nullable Int = Maybe Int
type instance Nullable Bool = Maybe Bool
type instance Nullable String = Maybe String
type instance Nullable Date = Maybe Date
type instance Nullable Char = Maybe Char
type instance Nullable Double = Maybe Double
type instance Nullable () = ()
type instance Nullable (a, b) = (Nullable a, Nullable b)
type instance Nullable (a, b, c) = (Nullable a, Nullable b, Nullable c)

type instance Nullable Nil = Nil
type instance Nullable (Prod a b) = Prod (Nullable a) (Nullable b)


class HasAggr e a | e -> a, a -> e

instance HasAggr Bool (Aggr Bool)
instance HasAggr Int (Aggr Int)
instance HasAggr Char (Aggr Char)
instance HasAggr String (Aggr String)
instance HasAggr Date (Aggr Date)
instance HasAggr Double (Aggr Double)
instance HasAggr (Maybe Bool) (Aggr (Maybe Bool))
instance HasAggr (Maybe Int) (Aggr (Maybe Int))
instance HasAggr (Maybe Char) (Aggr (Maybe Char))
instance HasAggr (Maybe String) (Aggr (Maybe String))
instance HasAggr (Maybe Date) (Aggr (Maybe Date))
instance HasAggr (Maybe Double) (Aggr (Maybe Double))
instance HasAggr Nil Nil
instance (HasAggr e1 a1, HasAggr e2 a2) => HasAggr (Prod e1 e2) (Prod a1 a2)

class HasSql s a sa | s a -> sa
instance HasSql s Bool (s Bool)
instance HasSql s (Maybe Bool) (s (Maybe Bool))
instance HasSql s Int (s Int)
instance HasSql s (Maybe Int) (s (Maybe Int))
instance HasSql s String (s String)
instance HasSql s (Maybe String) (s (Maybe String))
instance HasSql s Char (s Char)
instance HasSql s (Maybe Char) (s (Maybe Char))
instance HasSql s Date (s Date)
instance HasSql s (Maybe Date) (s (Maybe Date))
instance HasSql s Double (s Double)
instance HasSql s (Maybe Double) (s (Maybe Double))
instance HasSql s () ()
instance (HasSql s a sa, HasSql s b sb) => HasSql s (a, b) (sa, sb)
instance (HasSql s a sa, HasSql s b sb, HasSql s c sc) => HasSql s (a, b, c) (sa, sb, sc)

class (HasSql SqlFields a sfa, HasProdEnc sfa, IsSqlFields (ProdEnc sfa), SqlBE (UnSqlFields (ProdEnc sfa)))
    => HasSqlFields a sfa | a -> sfa, sfa -> a

instance HasSqlFields Bool (SqlFields Bool)
instance HasSqlFields (Maybe Bool) (SqlFields (Maybe Bool))
instance HasSqlFields Int (SqlFields Int)
instance HasSqlFields (Maybe Int) (SqlFields (Maybe Int))
instance HasSqlFields String (SqlFields String)
instance HasSqlFields (Maybe String) (SqlFields (Maybe String))
instance HasSqlFields Char (SqlFields Char)
instance HasSqlFields (Maybe Char) (SqlFields (Maybe Char))
instance HasSqlFields Date (SqlFields Date)
instance HasSqlFields (Maybe Date) (SqlFields (Maybe Date))
instance HasSqlFields Double (SqlFields Double)
instance HasSqlFields (Maybe Double) (SqlFields (Maybe Double))
instance HasSqlFields () ()
instance (HasSqlFields a sea, HasSqlFields b seb) => HasSqlFields (a, b) (sea, seb)
instance (HasSqlFields a sea, HasSqlFields b seb, HasSqlFields c sec) => HasSqlFields (a, b, c) (sea, seb, sec)

class (HasSql SqlExpr a sea, HasProdEnc sea, IsSqlExpr (ProdEnc sea), SqlBE (UnSqlExpr (ProdEnc sea))
--       HasProdEnc a, ProdEnc a ~ UnSqlExpr (ProdEnc sea) -- TODO would like this too
      )
    => HasSqlExpr a sea | a -> sea, sea -> a

instance HasSqlExpr Bool (SqlExpr Bool)
instance HasSqlExpr (Maybe Bool) (SqlExpr (Maybe Bool))
instance HasSqlExpr Int (SqlExpr Int)
instance HasSqlExpr (Maybe Int) (SqlExpr (Maybe Int))
instance HasSqlExpr String (SqlExpr String)
instance HasSqlExpr (Maybe String) (SqlExpr (Maybe String))
instance HasSqlExpr Char (SqlExpr Char)
instance HasSqlExpr (Maybe Char) (SqlExpr (Maybe Char))
instance HasSqlExpr Date (SqlExpr Date)
instance HasSqlExpr (Maybe Date) (SqlExpr (Maybe Date))
instance HasSqlExpr Double (SqlExpr Double)
instance HasSqlExpr (Maybe Double) (SqlExpr (Maybe Double))
instance HasSqlExpr () ()
instance (HasSqlExpr a sea, HasSqlExpr b seb) => HasSqlExpr (a, b) (sea, seb)
instance (HasSqlExpr a sea, HasSqlExpr b seb, HasSqlExpr c sec) => HasSqlExpr (a, b, c) (sea, seb, sec)

type SqlAggr' q e = SqlExpr' q (Aggr e)
type SqlAggr e = SqlExpr (Aggr e)

class (HasProdEnc saa, IsSqlExpr (ProdEnc saa), HasProdEnc a, {- HasAggr (ProdEnc a) (UnSqlExpr (ProdEnc saa)), -} SqlBE (ProdEnc a))
    => HasSqlAggr a saa | a -> saa, saa -> a

instance HasSqlAggr Bool (SqlAggr Bool)
instance HasSqlAggr (Maybe Bool) (SqlAggr (Maybe Bool))
instance HasSqlAggr Int (SqlAggr Int)
instance HasSqlAggr (Maybe Int) (SqlAggr (Maybe Int))
instance HasSqlAggr String (SqlAggr String)
instance HasSqlAggr (Maybe String) (SqlAggr (Maybe String))
instance HasSqlAggr Char (SqlAggr Char)
instance HasSqlAggr (Maybe Char) (SqlAggr (Maybe Char))
instance HasSqlAggr Date (SqlAggr Date)
instance HasSqlAggr (Maybe Date) (SqlAggr (Maybe Date))
instance HasSqlAggr Double (SqlAggr Double)
instance HasSqlAggr (Maybe Double) (SqlAggr (Maybe Double))
instance HasSqlAggr () ()
instance (HasSqlAggr a sea, HasSqlAggr b seb) => HasSqlAggr (a, b) (sea, seb)
instance (HasSqlAggr a sea, HasSqlAggr b seb, HasSqlAggr c sec) => HasSqlAggr (a, b, c) (sea, seb, sec)

class HasSql SqlLit a sla => HasSqlLit a sla | a -> sla, sla -> a where
   toSqlLit :: a -> sla
   fromSqlLit :: sla -> a

instance HasSqlLit Bool (SqlLit Bool) where
   toSqlLit = SLBool
   fromSqlLit (SLBool a) = a

instance HasSqlLit Int (SqlLit Int) where
   toSqlLit = SLInt
   fromSqlLit (SLInt a) = a

instance HasSqlLit String (SqlLit String) where
   toSqlLit = SLString
   fromSqlLit (SLString a) = a

instance HasSqlLit Char (SqlLit Char) where
   toSqlLit = SLChar
   fromSqlLit (SLChar a) = a

instance HasSqlLit Date (SqlLit Date) where
   toSqlLit = SLDate
   fromSqlLit (SLDate a) = a

instance HasSqlLit Double (SqlLit Double) where
   toSqlLit = SLDouble
   fromSqlLit (SLDouble a) = a

instance HasSqlLit () () where
   toSqlLit () = ()
   fromSqlLit () = ()

instance (HasSqlLit a sla, HasSqlLit b slb) => HasSqlLit (a, b) (sla, slb) where
   toSqlLit (a, b) = (toSqlLit a, toSqlLit b)
   fromSqlLit (a, b) = (fromSqlLit a, fromSqlLit b)

instance (HasSqlLit a sla, HasSqlLit b slb, HasSqlLit c slc) => HasSqlLit (a, b, c) (sla, slb, slc) where
   toSqlLit (a, b, c) = (toSqlLit a, toSqlLit b, toSqlLit c)
   fromSqlLit (a, b, c) = (fromSqlLit a, fromSqlLit b, fromSqlLit c)

{-
TODO this doesn't work yet in GHC
class (HasProdEnc sea, IsSqlExpr (ProdEnc sea), SqlBE (UnSqlExpr (ProdEnc sea)),
       HasProdEnc (ExprToFields sea),
       IsSqlFields (ProdEnc (ExprToFields sea)), SqlBE (UnSqlFields (ProdEnc (ExprToFields sea))),
       UnSqlExpr (ProdEnc sea) ~ UnSqlFields (ProdEnc (ExprToFields sea))
      ) => SqlExprM sea where
  type ExprToFields sea
-}

class (HasProdEnc sea, IsSqlExpr (ProdEnc sea), SqlBE (UnSqlExpr (ProdEnc sea))) => SqlExprM sea
class (HasProdEnc sfa, IsSqlFields (ProdEnc sfa), SqlBE (UnSqlFields (ProdEnc sfa))) => SqlFieldsM sfa

instance SqlExprM () where
instance SqlFieldsM () where

instance SqlExprM (SqlExpr Int) where
instance SqlFieldsM (SqlFields Int) where

instance (SqlExprM sea, SqlExprM seb) => SqlExprM (sea, seb) where
instance (SqlFieldsM sfa, SqlFieldsM sfb) => SqlFieldsM (sfa, sfb) where

data QueryM a where
  UnitM :: (SqlExprM sea, SqlFieldsM sfa, UnSqlExpr (ProdEnc sea) ~ UnSqlFields (ProdEnc sfa))
        => sfa -> sea -> QueryM sea
  TableM :: (SqlExprM sea, SqlFieldsM sfa, UnSqlExpr (ProdEnc sea) ~ UnSqlFields (ProdEnc sfa))
         => (Maybe DBName, TableName) -> sfa -> QueryM sea
  ProjectM :: (SqlExprM sea, SqlFieldsM sfa, UnSqlExpr (ProdEnc sea) ~ UnSqlFields (ProdEnc sfa),
               SqlExprM seb, SqlFieldsM sfb, UnSqlExpr (ProdEnc seb) ~ UnSqlFields (ProdEnc sfb))
           => (sfa, sfb) -> (sea -> seb) -> QueryM sea -> QueryM seb
  RestrictM :: (SqlExprM sea, SqlFieldsM sfa, UnSqlExpr (ProdEnc sea) ~ UnSqlFields (ProdEnc sfa))
            => sfa -> (sea -> SqlExpr Bool) -> QueryM sea -> QueryM sea
  JoinM :: (SqlExprM sea, SqlFieldsM sfa, UnSqlExpr (ProdEnc sea) ~ UnSqlFields (ProdEnc sfa)
           ,SqlExprM seb, SqlFieldsM sfb, UnSqlExpr (ProdEnc seb) ~ UnSqlFields (ProdEnc sfb)
--           ,SqlExprM (sea, seb), SqlFieldsM (sfa, sfb)
--           ,UnSqlExpr (ProdEnc (sea, seb)) ~ UnSqlFields (ProdEnc (sfa, sfb))
           )
        => (sfa, sfb) -> (sea -> seb -> SqlExpr Bool) -> QueryM sea -> QueryM seb -> QueryM (sea, seb)
  ReturnM :: a -> QueryM a
  BindM :: QueryM a -> (a -> QueryM b) -> QueryM b

translateQM :: (SqlExprM sea, SqlFieldsM sfa, UnSqlExpr (ProdEnc sea) ~ UnSqlFields (ProdEnc sfa))
            => sfa -> QueryM sea -> IntQuery (UnSqlExpr (ProdEnc sea))
translateQM _ (UnitM _ e) = IntKnown [encodeSqlExpr e]
translateQM _ (TableM tn f) = IntTable tn (encodeSqlFields f)
translateQM _ (ProjectM (_ :: (sfa, sfb)) (func :: sea -> seb) q)
   = IntProject (encodeSqlExpr . func . decodeSqlExpr) (translateQM (undefined :: sfa) (q :: QueryM sea))
translateQM _ (RestrictM (_ :: sfa) r q) = IntRestrict (r . decodeSqlExpr) (translateQM (undefined :: sfa) q)
translateQM _ (JoinM (_ :: (sfa, sfb)) r q1 q2) = IntJoin (\a b -> r (decodeSqlExpr a) (decodeSqlExpr b))
                                                          (translateQM (undefined :: sfa) q1)
                                                          (translateQM (undefined :: sfb) q2)
translateQM _ (ReturnM e) = IntKnown [encodeSqlExpr e]
translateQM x (BindM (ReturnM e) f) = translateQM x (f e)
translateQM x (BindM (BindM m f) g) = translateQM x (BindM m (\x -> BindM (f x) g))

instance Monad QueryM where
  return v = ReturnM v
  m >>= f = BindM m f

data Query a where
  Zero :: (HasSqlExpr a sea, HasProdEnc a, ProdEnc a ~ UnSqlExpr (ProdEnc sea)) => Query a
  Unit :: (HasSqlExpr a sea, HasProdEnc a, ProdEnc a ~ UnSqlExpr (ProdEnc sea))
       => sea -> Query a  -- TODO should be SqlLit?
  Table :: (HasSqlExpr a sea, HasSqlFields a sfa, UnSqlExpr (ProdEnc sea) ~ UnSqlFields (ProdEnc sfa),
            HasProdEnc a, ProdEnc a ~ UnSqlExpr (ProdEnc sea))
        => (Maybe DBName, TableName) -> sfa -> Query a
  Nub :: (HasSqlExpr a sea, HasProdEnc a, ProdEnc a ~ UnSqlExpr (ProdEnc sea)) => sea -> Query a -> Query a
  Project :: (HasSqlExpr a sea, HasSqlExpr b seb, HasProdEnc b, ProdEnc b ~ UnSqlExpr (ProdEnc seb))
          => (sea -> seb) -> Query a -> Query b
  Restrict :: (HasSqlExpr a sea, HasProdEnc a, ProdEnc a ~ UnSqlExpr (ProdEnc sea))
           => (sea -> SqlExpr Bool) -> Query a -> Query a
  Union :: (HasSqlExpr a sea, HasProdEnc a, ProdEnc a ~ UnSqlExpr (ProdEnc sea))
         => sea -> Query a -> Query a -> Query a
  Intersection :: (HasSqlExpr a sea, HasProdEnc a, ProdEnc a ~ UnSqlExpr (ProdEnc sea))
               => sea -> Query a -> Query a -> Query a
  Join :: (HasSqlExpr a sea, HasProdEnc a, ProdEnc a ~ UnSqlExpr (ProdEnc sea),
           HasSqlExpr b seb, HasProdEnc b, ProdEnc b ~ UnSqlExpr (ProdEnc seb))
       => (sea -> seb -> SqlExpr Bool) -> Query a -> Query b -> Query (a, b)
  LeftJoin :: (HasSqlExpr a sea, HasProdEnc a, ProdEnc a ~ UnSqlExpr (ProdEnc sea),
               HasSqlExpr b seb, HasProdEnc (Nullable b), ProdEnc (Nullable b) ~ UnSqlExpr (ProdEnc senb),
               HasSqlExpr (Nullable b) senb,
               UnSqlExpr (ProdEnc senb) ~ Nullable (UnSqlExpr (ProdEnc seb)),
               SqlBE (Nullable (UnSqlExpr (ProdEnc seb))) -- TODO isn't this implied by the above?
              )
           => senb -- dummy parameter so we can introduce senb as a scoped type variable in translateQ
           -> (sea -> seb -> SqlExpr Bool) -> Query a -> Query b -> Query (a, Nullable b)
  SortBy :: (HasSqlExpr a sea, HasProdEnc a, ProdEnc a ~ UnSqlExpr (ProdEnc sea),
             HasSqlExpr b seb)
         => (sea -> seb) -> Query a -> Query a
  GroupBy :: (HasSqlExpr a sea, HasSqlExpr b seb, {- HasSqlExpr a saa, -} HasSqlExpr g seg,
              HasProdEnc b, ProdEnc b ~ UnSqlExpr (ProdEnc seb)
--              Aggr (UnSqlExpr (ProdEnc sea)) ~ UnSqlExpr (ProdEnc saa)
             )
	  => (sea -> seg) -> (Aggr sea -> seb) -> Query a -> Query b
  Nested :: (HasSqlExpr a sea, HasSqlExpr b seb, HasSqlExpr c sec,
             HasProdEnc b, ProdEnc b ~ UnSqlExpr (ProdEnc seb),
             Ord c, HasProdEnc c, ProdEnc c ~ UnSqlExpr (ProdEnc sec),
             HasSqlCmp sec, HasProdEnc (SqlCmp sec), IsSqlExpr (ProdEnc (SqlCmp sec)),
             SqlEq (UnSqlExpr (ProdEnc (SqlCmp sec)))
            )
         => (a -> c, sea -> sec) -> (b -> c, seb -> sec) -> Query a -> Query b -> Query (a, [b])

handleNested :: Monad m
             => (forall b seb . (HasSqlExpr b seb, HasProdEnc b, UnSqlExpr (ProdEnc seb) ~ ProdEnc b) => Query b -> m [b])
             -> Query a
             -> m [a]
handleNested f (Nested (geta, sgeta) (getb, sgetb) qa qb)
 = do resa <- handleNested f qa
      resb <- handleNested f $ project snd $ sortBy fst $ join (\c b -> c == sgetb b) (nub $ project sgeta qa) qb
      let bmp = Map.fromListWith (++) [(getb b, [b]) | b <- resb]
      return [(a, Map.findWithDefault [] (geta a) bmp) | a <- resa]
handleNested f q@(Unit _) = f q
handleNested f q@(Table _ _) = f q
handleNested f q@(Nub _ _) = f q
handleNested f q@(Project _ _) = f q
handleNested f q@(Restrict _ _) = f q
handleNested f q@(Union _ _ _) = f q
handleNested f q@(Intersection _ _ _) = f q
handleNested f q@(Join _ _ _) = f q
handleNested f q@(LeftJoin _ _ _ _) = f q
handleNested f q@(SortBy {}) = f q
handleNested f q@(GroupBy {}) = f q

collectNestedM :: Monad m
               => (forall b seb . (HasSqlExpr b seb, HasProdEnc b, UnSqlExpr (ProdEnc seb) ~ ProdEnc b) => Query b -> m c)
               -> Query a
               -> m [c]
collectNestedM f = liftM snd . runWriterT . handleNested (\q' -> lift (f q') >>= (tell . (:[])) >> return [])

collectNested :: (forall b seb . (HasSqlExpr b seb, HasProdEnc b, UnSqlExpr (ProdEnc seb) ~ ProdEnc b) => Query b -> c)
              -> Query a
              -> [c]
collectNested f = runIdentity . collectNestedM (return . f)

restrict' :: NestedCond a -> Query a -> Query a
restrict' (NestedBase (f :: sea -> SqlExpr Bool)) q@(Unit a) = Restrict (\x -> f (unsafeCoerce x :: sea)) q
restrict' (NestedFst f) (Nested s1 s2 q1 q2) = Nested s1 s2 (restrict' f q1) q2
restrict' (NestedSnd (NestedList f)) (Nested s1 s2 q1 q2) = Nested s1 s2 q1 (restrict' f q2)

data NestedCond a where
   NestedBase :: HasSqlExpr a sea => (sea -> SqlExpr Bool) -> NestedCond a
   NestedUnary :: (SqlExpr Bool -> SqlExpr Bool) -> NestedCond a -> NestedCond a
   NestedBinary :: (SqlExpr Bool -> SqlExpr Bool -> SqlExpr Bool) -> NestedCond a -> NestedCond a -> NestedCond a
   NestedFst :: NestedCond a -> NestedCond (a, b)
   NestedSnd :: NestedCond b -> NestedCond (a, b)
   NestedList :: NestedCond b -> NestedCond [b]

data RelInfo a where
   Singleton :: RelInfo a
   Unique :: (HasSqlFields a sfa, HasSqlFields b sfb) => sfb -> RelInfo a


data IntQuery a where
   IntKnown :: SqlBE a => [SqlExpr a] -> IntQuery a
   IntTable :: SqlBE a => (Maybe DBName, TableName) -> SqlFields a -> IntQuery a
   IntNub :: SqlBE a => IntQuery a -> IntQuery a
   IntProject :: (SqlBE a, SqlBE b) => (SqlExpr a -> SqlExpr b) -> IntQuery a -> IntQuery b
   IntRestrict :: SqlBE a => (SqlExpr a -> SqlExpr Bool) -> IntQuery a -> IntQuery a
   IntUnion :: SqlBE a => IntQuery a -> IntQuery a -> IntQuery a
   IntIntersection :: SqlBE a => IntQuery a -> IntQuery a -> IntQuery a
   IntJoin :: (SqlBE a, SqlBE b) => (SqlExpr a -> SqlExpr b -> SqlExpr Bool) -> IntQuery a -> IntQuery b -> IntQuery (Prod a b)
   IntLeftJoin :: (SqlBE a, SqlBE b, SqlBE (Nullable b))
               => (SqlExpr a -> SqlExpr b -> SqlExpr Bool) -> IntQuery a -> IntQuery b -> IntQuery (Prod a (Nullable b))
   IntSortBy :: (SqlBE a, SqlBE b) => (SqlExpr a -> SqlExpr b) -> IntQuery a -> IntQuery a
   IntGroupBy :: (SqlBE a, SqlBE b, SqlBE g) => (SqlExpr a -> SqlExpr g) -> (SqlAggr a -> SqlExpr b) -> IntQuery a -> IntQuery b

instance Show (IntQuery a) where
   show (IntKnown as) = "(IntKnown " ++ show as ++ ")"
   show (IntTable tn f) = "(IntTable " ++ show tn ++ " " ++ show f ++ ")"
   show (IntNub q) = "(IntNub " ++ show q ++ ")"
   show (IntProject f q) = "(IntProject " ++ show f ++ " " ++ show q ++ ")"
   show (IntRestrict r q) = "(IntRestrict " ++ show r ++ " " ++ show q ++ ")"
   show (IntUnion q1 q2) = "(IntUnion " ++ show q1 ++ " " ++ show q2 ++ ")"
   show (IntIntersection q1 q2) = "(IntIntersection " ++ show q1 ++ " " ++ show q2 ++ ")"
   show (IntJoin f q1 q2) = "(IntJoin " ++ show f ++ " " ++ show q1 ++ " " ++ show q2 ++ ")"
   show (IntLeftJoin f q1 q2) = "(IntLeftJoin " ++ show f ++ " " ++ show q1 ++ " " ++ show q2 ++ ")"
   show (IntSortBy s q) = "(IntSortBy " ++ show s ++ " " ++ show q ++ ")"
   show (IntGroupBy sel deaggr q) = "(IntGroupBy " ++ show sel ++ " " ++ show deaggr ++ " " ++ show q ++ ")"

type CoerceIQ a b = IntQuery a -> IntQuery b

coerceIQ :: {- (HasSqlExpr a sea1, HasSqlExpr a sea2) => -} IntQuery sea1 -> IntQuery sea2
coerceIQ = unsafeCoerce

translateQ :: forall a sea . HasSqlExpr a sea => Query a -> IntQuery (UnSqlExpr (ProdEnc sea))
translateQ Zero = IntKnown []
translateQ (Unit (a :: sea1))
    = (coerceIQ :: CoerceIQ (UnSqlExpr (ProdEnc sea1)) (UnSqlExpr (ProdEnc sea))) $
      IntKnown [encodeSqlExpr a]
translateQ (Table tn (fields :: sfa))
    = (coerceIQ :: CoerceIQ (UnSqlFields (ProdEnc sfa)) (UnSqlExpr (ProdEnc sea))) $
      IntTable tn (encodeSqlFields fields)
translateQ (Nub (_ :: sea1) q)
    = (coerceIQ :: CoerceIQ (UnSqlExpr (ProdEnc sea1)) (UnSqlExpr (ProdEnc sea))) $
      IntNub (translateQ q)
translateQ (Project (f :: seb -> sea1) q)
    = (coerceIQ :: CoerceIQ (UnSqlExpr (ProdEnc sea1)) (UnSqlExpr (ProdEnc sea))) $
      IntProject (encodeSqlExpr . f . decodeSqlExpr) (translateQ q)
translateQ (Restrict (f :: sea1 -> SqlExpr Bool) q)
    = (coerceIQ :: CoerceIQ (UnSqlExpr (ProdEnc sea1)) (UnSqlExpr (ProdEnc sea))) $
      IntRestrict (f . decodeSqlExpr) (translateQ q)
translateQ (Union (_ :: sea1) q1 q2)
    = (coerceIQ :: CoerceIQ (UnSqlExpr (ProdEnc sea1)) (UnSqlExpr (ProdEnc sea))) $
      IntUnion (translateQ q1) (translateQ q2)
translateQ (Intersection (_ :: sea1) q1 q2)
    = (coerceIQ :: CoerceIQ (UnSqlExpr (ProdEnc sea1)) (UnSqlExpr (ProdEnc sea))) $
      IntIntersection (translateQ q1) (translateQ q2)
translateQ (Join (cond :: sea1 -> seb1 -> SqlExpr Bool) q1 q2)
    = (coerceIQ :: CoerceIQ (UnSqlExpr (ProdEnc (sea1, seb1))) (UnSqlExpr (ProdEnc sea))) $
      IntJoin (\x y -> encodeSqlExpr (cond (decodeSqlExpr x) (decodeSqlExpr y))) (translateQ q1) (translateQ q2)
translateQ (LeftJoin (_ :: senb1) (cond :: sea1 -> seb1 -> SqlExpr Bool) q1 q2)
    = (coerceIQ :: CoerceIQ (UnSqlExpr (ProdEnc (sea1, senb1))) (UnSqlExpr (ProdEnc sea))) $
      IntLeftJoin (\x y -> encodeSqlExpr (cond (decodeSqlExpr x) (decodeSqlExpr y))) (translateQ q1) (translateQ q2)
translateQ (SortBy (f :: sea1 -> seb1) q) 
    = (coerceIQ :: CoerceIQ (UnSqlExpr (ProdEnc sea1)) (UnSqlExpr (ProdEnc sea))) $
      IntSortBy (encodeSqlExpr . f . decodeSqlExpr) (translateQ q)
translateQ (GroupBy sel (deaggr :: Aggr sea3 -> sea2) q)
    = (coerceIQ :: CoerceIQ (UnSqlExpr (ProdEnc sea2)) (UnSqlExpr (ProdEnc sea))) $
      IntGroupBy (encodeSqlExpr . sel . decodeSqlExpr) (encodeSqlExpr . deaggr . decodeSqlExpr) (translateQ q)

uncurrySEProd :: (SqlExpr' q a -> SqlExpr' q b -> c) -> SqlExpr' q (Prod a b) -> c
uncurrySEProd f (SEProd a b) = f a b
currySEProd :: (SqlExpr' q (Prod a b) -> c) -> SqlExpr' q a -> SqlExpr' q b -> c
currySEProd f a b = f (SEProd a b)

translateSqlExprIQPQ :: SqlExpr a -> SqlExprP a
translateSqlExprIQPQ (SEIntQuery q) = SEPrimQuery (translateIQ q)
translateSqlExprIQPQ q = translateSqlExpr translateSqlExprIQPQ q

translateSqlExprPQIQ :: SqlExprP a -> SqlExpr a
translateSqlExprPQIQ (SEPrimQuery q) = error "query found in function arguments"
translateSqlExprPQIQ q = translateSqlExpr translateSqlExprPQIQ q

translateIQF f = translateSqlExprIQPQ . f . translateSqlExprPQIQ

translateIQ :: IntQuery a -> PrimQuery a
translateIQ (IntKnown []) = translateIQ (IntRestrict (const false) $ IntKnown [dummyVal])
translateIQ (IntKnown vs) = foldr1 (PrimUnion False) . map (\v -> PrimUnit (translateSqlExprIQPQ v) (fromFields namesupply)) $ vs
translateIQ (IntTable (dn, tn) fields) = idSelect $ PrimTable dn tn Nothing fields
translateIQ (IntNub q) = addNub $ translateIQ q
translateIQ (IntProject f q) = compProj (translateIQF f) $ translateIQ q
translateIQ (IntRestrict r q) = conjRestr (translateIQF r) $ translateIQ q
translateIQ (IntUnion q1 q2) = PrimUnion False (translateIQ q1) (translateIQ q2)
translateIQ (IntIntersection q1 q2) = PrimIntersection (translateIQ q1) (translateIQ q2)
translateIQ (IntJoin cond q1 q2) = conjRestr (translateIQF . uncurrySEProd $ cond) $ idSelect $
                                   PrimQuickJoin (primSubQuery (translateIQ q1)) (primSubQuery (translateIQ q2))
translateIQ (IntLeftJoin cond q1 q2) = idSelect (PrimLeftJoin (currySEProd . translateIQF . uncurrySEProd $ cond)
                                                              (primSubQuery (translateIQ q1))
                                                              (primSubQuery (translateIQ q2)))
translateIQ (IntSortBy f q) = addSort (translateIQF f) $ translateIQ q
translateIQ (IntGroupBy sel deaggr q) = addGroup (translateIQF sel) (translateIQF deaggr) $ translateIQ q

optPT :: PrimTables a -> PrimTables a
optPT (PrimQuickJoin q1 q2) | PrimSubQuery n1 (PrimSelect False p1 f1 r1 Nothing ts1) <- optPT q1,
                              PrimSubQuery n2 (PrimSelect False p2 f2 r2 Nothing ts2) <- optPT q2
  = optPT $ 
    PrimSubQuery n1
                 (PrimSelect False
                             (PairFunc p1 p2)
                             (SFProd f1 f2)
                             (\(SEProd fs1 fs2) -> r1 fs1 && r2 fs2)
                             (Nothing :: Maybe (SqlExprP x -> SqlExprP x))
                             (PrimQuickJoin ts1 ts2))
optPT (PrimSubQuery _ (PrimSelect False p _ restr Nothing ts)) | IdFunc <- optFunc p, isAlwaysTrue restr = optPT ts
optPT (PrimSubQuery n q) = PrimSubQuery n (optPQ q)
optPT (PrimLeftJoin f q1 q2) = PrimLeftJoin f (optPT q1) (optPT q2)
optPT (PrimQuickJoin q1 q2) = PrimQuickJoin (optPT q1) (optPT q2)
optPT (PrimJoin f q1 q2) = PrimJoin f (optPT q1) (optPT q2)
optPT (PrimTable dn tn mtn fs) = PrimTable dn tn mtn fs

optFunc :: SqlFunc' q a b -> SqlFunc' q a b
optFunc IdFunc = IdFunc
optFunc (EmbedFunc f) = EmbedFunc (optSE . f)
optFunc (CompFunc f g) = case (optFunc f, optFunc g) of
                               (IdFunc, g') -> g'
                               (f', IdFunc) -> f'
                               (EmbedFunc a, EmbedFunc b) -> EmbedFunc (a . b)
                               (f', g') -> CompFunc f' g'
optFunc (PairFunc f g) = case (optFunc f, optFunc g) of
                                (IdFunc, IdFunc) -> IdFunc
                                (f', g') -> PairFunc f' g'

getFreeNo :: (SqlBE a) => (SqlExpr' q a -> SqlExpr' q b) -> Int
getFreeNo = runIdentity . getFreeNoM . (Identity .)

getFreeNoM :: (Monad m, SqlBE a) => (SqlExpr' q a -> m (SqlExpr' q b)) -> m Int
getFreeNoM f = liftM (List.maximum . (0:) . map (1+) . catMaybes . map maybeUnFieldId . Map.keys . flip findUsedSE Map.empty) $ f $ fromFieldsE (repeat (FieldName ""))

argsForE :: SqlBE a => (SqlExpr' q a -> SqlExpr' q b) -> SqlExpr' q a
argsForE f = fromFieldsE (map FieldId [getFreeNo f..])

argsFor' :: SqlBE a => (SqlExpr' q a -> SqlExpr' q b) -> ((SqlFields a, FMap a), [FieldName])
argsFor' = runIdentity . argsForM' . (Identity .)

argsForM' :: (Monad m, SqlBE a) => (SqlExpr' q a -> m (SqlExpr' q b)) -> m ((SqlFields a, FMap a), [FieldName])
argsForM' f = do i <- getFreeNoM f
                 return $ fromFields' (map FieldId [i..])


isAlwaysTrue :: SqlBE a => (SqlExpr' q a -> SqlExpr' q Bool) -> Bool
isAlwaysTrue f = case f (argsForE f) of
                   SEPrim (SPLit (SLBool True)) -> True
                   _ -> False

isAlwaysFalse :: SqlBE a => (SqlExpr' q a -> SqlExpr' q Bool) -> Bool
isAlwaysFalse f = case f (argsForE f) of
                   SEPrim (SPLit (SLBool False)) -> True
                   _ -> False

isId :: (SqlBE a, SqlBE b) => (SqlExpr' q a -> SqlExpr' q b) -> Bool
isId f = let v = argsForE f in f v `same` v

isProj :: (SqlBE a, SqlBE b) => (SqlExpr' q a -> SqlExpr' q b) -> Maybe (SqlAggr' q a -> SqlAggr' q b)
isProj f = fmap ((\g -> exprToAggr . g . aggrToExpr) . reproject tr) (allFields res)
         where res = f (fieldsToExpr v)
               ((v, tr), _) = argsFor' f
               allFields :: SqlExpr' q a -> Maybe (SqlFields a)
               allFields (SEField mtn fn) = return (SFField mtn fn)
               allFields SENil = return SFNil
               allFields (SEProd a b) = liftM2 SFProd (allFields a) (allFields b)
               allFields _ = Nothing

onlyFst :: (SqlBE a, SqlBE b, SqlBE c) => (SqlExpr (Prod a b) -> SqlExpr c) -> Maybe (SqlExpr a -> SqlExpr c)
onlyFst f = let freeno = getFreeNo f
                ((fldsa, tr), fields') = fromFields' (map FieldId [freeno..])
                ((fldsb, tr'), _) = fromFields' fields'
                freeno' = unFieldId . head $ fields' :: Int
                usedno' fn | Just n <- maybeUnFieldId fn, n >= freeno' = True
                           | otherwise = False
                res = f (SEProd (fieldsToExpr fldsa) (fieldsToExpr fldsb))
            in case toUsedFields usedno' res of
                  Wrapped SFNil -> Just (rebuildFunc f . reproject tr (SFProd fldsa fldsb))
                  _ -> Nothing

optPQ :: PrimQuery a -> PrimQuery a
optPQ (PrimSelect False p f restr Nothing t) | IdFunc <- optFunc p, isAlwaysTrue restr, PrimSubQuery _ q <- optPT t = q
optPQ (PrimSelect False p f r Nothing t) | PrimSubQuery _ (PrimSelect False ps fs rs Nothing ts) <- optPT t
 = optPQ $
   PrimSelect False
              (p `CompFunc` ps)
              f
              (\fs -> rs fs && r (fromFunc ps fs))
              (Nothing :: Maybe (SqlExprP x -> SqlExprP x))
              ts
optPQ (PrimSelect False p f r Nothing t) | PrimSubQuery _ (PrimGroup False sel deaggr fs rs Nothing ts) <- optPT t, isAlwaysTrue r
 = optPQ $
   PrimGroup False
             sel
             (fromFunc p . deaggr)
             f
             rs
             (Nothing :: Maybe (SqlExprP x -> SqlExprP x))
             ts

optPQ (PrimGroup False sel deaggr f r Nothing t) | PrimSubQuery _ (PrimSelect False ps fs rs Nothing ts) <- optPT t,
                                             Just aggrProj <- isProj (fromFunc ps)
 = optPQ $
   PrimGroup False
             (sel . fromFunc ps)
             (deaggr . aggrProj)
             f
             (\fs -> rs fs && r (fromFunc ps fs))
             (Nothing :: Maybe (SqlExprP x -> SqlExprP x))
             ts

optPQ (PrimSelect True p f r Nothing (PrimSubQuery _ (PrimUnion True q1 q2)))
 = optPQ (PrimUnion True (PrimSelect True p f r (Nothing :: Maybe (SqlExprP x -> SqlExprP x)) (PrimSubQuery "sub" q1))
                         (PrimSelect True p f r (Nothing :: Maybe (SqlExprP x -> SqlExprP x)) (PrimSubQuery "sub" q2)))
optPQ (PrimUnit v f) = PrimUnit (optSE v) f
optPQ (PrimSelect b p f r s t) = PrimSelect b (optFunc p) f (\x -> optSE (r x)) s (optPT t)
optPQ (PrimUnion b q1 q2) = PrimUnion b (optPQ q1) (optPQ q2)
optPQ (PrimIntersection q1 q2) = PrimIntersection (optPQ q1) (optPQ q2)
optPQ (PrimGroup b sel deaggr f restr msort t) = PrimGroup b sel (\x -> optSE (deaggr x)) f (\x -> optSE (restr x)) msort (optPT t)


data Fact q where
   Fact :: SqlExpr' q a -> SqlExpr' q a -> Fact q

instance Eq (Fact q) where
   Fact lhs rhs == Fact lhs' rhs' = same lhs rhs && same lhs' rhs'

instance Show1 q => Show (Fact q) where
   show (Fact lhs rhs) = show lhs ++ " == " ++ show rhs

listIntersection xs = filter (`elem` xs)

getFacts :: Bool -> SqlExpr' q Bool -> [Fact q]
getFacts True (SEApp (SEApp (SEPrim SPAnd) e1) e2) = getFacts True e1 `List.union` getFacts True e2
getFacts False (SEApp (SEApp (SEPrim SPAnd) e1) e2) = getFacts False e1 `listIntersection` getFacts False e2
getFacts True (SEApp (SEApp (SEPrim SPOr) e1) e2) = getFacts True e1 `listIntersection` getFacts True e2
getFacts False (SEApp (SEApp (SEPrim SPOr) e1) e2) = getFacts False e1 `List.union` getFacts False e2
getFacts b (SEApp (SEPrim SPNot) e) = getFacts (not b) e
-- TODO handle SPEq/SPNe (need to be careful about orientation)
getFacts b f = [Fact f (SEPrim (SPLit (SLBool b)))]

applyFact :: Fact q -> SqlExpr' q a -> Writer Any (SqlExpr' q a)
applyFact (Fact lhs rhs) e
  = case sameT lhs e of
      Just EqId -> do tell (Any True) ; return rhs
      Nothing -> return e

applyFacts :: [Fact q] -> SqlExpr' q a -> Writer Any (SqlExpr' q a)
applyFacts facts e = foldM (flip applyFact) e facts

unIfThenElse :: SqlExpr' q a -> Maybe (SqlExpr' q Bool, SqlExpr' q a, SqlExpr' q a)
unIfThenElse (SEApp (SEApp (SEApp (SEPrim SPIfThenElse) cnd) th) el) = Just (optSE cnd, optSE th, optSE el)
unIfThenElse _ = Nothing

optSE :: SqlExpr' q a -> SqlExpr' q a
optSE = optSE' []

optSE' :: forall q a . [Fact q] -> SqlExpr' q a -> SqlExpr' q a

-- optSE' facts e | trace ("optSE': " ++ show facts ++ ": " ++ show e ++ "\n") False = undefined

optSE' facts@(_:_) e | changed = optSE' facts e'
 where (e', Any changed) = runWriter (applyFacts facts e)

optSE' facts (SEApp (SEApp (SEPrim SPAnd) e1) e2)
  | SEPrim (SPLit (SLBool True)) <- e1' = e2'
  | SEPrim (SPLit (SLBool True)) <- e2' = e1'
  | SEPrim (SPLit (SLBool False)) <- e1' = SEPrim (SPLit (SLBool False))
  | SEPrim (SPLit (SLBool False)) <- e2' = SEPrim (SPLit (SLBool False))
  | same e1' e2' = e1' -- TODO could do better with full substitution of conjuncts for False inside other conjuncts
 where e1' = optSE' facts e1
       e2' = optSE' facts e2
optSE' facts (SEApp (SEPrim SPIsNull) e)
  | SEPrim SPNull <- e' = SEPrim (SPLit (SLBool True))
  | SEApp (SEPrim SPJust) _ <- e' = SEPrim (SPLit (SLBool False))
  | Just (cnd, th, el) <- unIfThenElse e'
       = optSE' facts (SEApp (SEApp (SEApp (SEPrim SPIfThenElse) cnd) (SEApp (SEPrim SPIsNull) th)) (SEApp (SEPrim SPIsNull) el))
 where e' = optSE' facts e
optSE' facts (SEApp (SEPrim SPNot) e)
  | SEPrim (SPLit (SLBool b)) <- e' = SEPrim (SPLit (SLBool (not b)))
  | SEApp (SEPrim SPNot) ne <- e' = ne
 where e' = optSE' facts e

optSE' facts (SEApp (SEApp (SEPrim SPLt) e1) e2)
  | SEPrim (SPLit (SLInt n1)) <- e1', SEPrim (SPLit (SLInt n2)) <- e2' = SEPrim (SPLit (SLBool (n1 < n2)))
 where e1' = optSE' facts e1
       e2' = optSE' facts e2

optSE' facts (SEApp (SEApp (SEPrim SPGt) e1) e2)
  | SEPrim (SPLit (SLInt n1)) <- e1', SEPrim (SPLit (SLInt n2)) <- e2' = SEPrim (SPLit (SLBool (n1 > n2)))
 where e1' = optSE' facts e1
       e2' = optSE' facts e2

optSE' facts (SEApp (SEApp (SEPrim SPPlus) e1) e2)
  | SEPrim (SPLit (SLInt n1)) <- e1', SEPrim (SPLit (SLInt n2)) <- e2' = SEPrim (SPLit (SLInt (n1 + n2)))
 where e1' = optSE' facts e1
       e2' = optSE' facts e2

optSE' facts (SEApp (SEApp (SEPrim SPMinus) e1) e2)
  | SEPrim (SPLit (SLInt n1)) <- e1', SEPrim (SPLit (SLInt n2)) <- e2' = SEPrim (SPLit (SLInt (n1 - n2)))
 where e1' = optSE' facts e1
       e2' = optSE' facts e2

optSE' facts (SEApp (SEPrim SPSum) e)
  | SEPrim (SPLit (SLAggr ls)) <- e' = SEPrim (SPLit (List.sum ls))
 where e' = optSE' facts e

optSE' facts (SEApp (SEPrim SPThe) e)
  | SEPrim (SPLit (SLAggr (l:_))) <- e' = SEPrim (SPLit l)
 where e' = optSE' facts e

optSE' facts (SEApp (SEApp (SEApp (SEPrim SPIfThenElse) c) t) e)
  | SEPrim (SPLit (SLBool True)) <- c' = t'
  | SEPrim (SPLit (SLBool False)) <- c' = e'
  | SEPrim (SPLit (SLBool True)) <- t', SEPrim (SPLit (SLBool False)) <- e' = c'
  | SEPrim (SPLit (SLBool False)) <- t', SEPrim (SPLit (SLBool True)) <- e' = optSE' facts (SEApp (SEPrim SPNot) c')
  | same t' e' = t'
 where t',e' :: SqlExpr' q a
       t' = optSE' (facts `List.union` getFacts True c') t
       e' = optSE' (facts `List.union` getFacts False c') e
       c' :: SqlExpr' q Bool
       c' = optSE' facts c
optSE' facts (SEApp (SEPrim SPExists) e)
  | SEIntQuery (IntKnown vs) <- e' = SEPrim (SPLit (SLBool (not $ null vs)))
  | SEIntQuery q <- e' = SEApp (SEPrim SPExists) . SEIntQuery $ optForExists q
 where e' = optSE' facts e

optSE' facts (SEApp f a) = SEApp (optSE' facts f) (optSE' facts a)
optSE' facts (SEProd a b) = SEProd (optSE' facts a) (optSE' facts b)
optSE' facts (SEIntQuery q) = SEIntQuery (optIQ q)
optSE' facts (SEPrimQuery q) = SEPrimQuery (optPQ q)
optSE' _ e = e

optForExists :: SqlBE a => IntQuery a -> IntQuery Nil
optForExists = removeDead . optIQ . onWrapped (removeDead' (const nil)) . dropStuff
   where dropStuff :: SqlBE b => IntQuery b -> Wrapped IntQuery
         dropStuff (IntProject _ q) = dropStuff q
         dropStuff (IntGroupBy _ _ q) = dropStuff q
         dropStuff q = Wrapped q

removeDead :: SqlBE a => IntQuery a -> IntQuery a
removeDead = removeDead' id

removeDead' :: (SqlBE a, SqlBE b) => (forall f . ProdSel f => f a -> f b) -> IntQuery a -> IntQuery b
removeDead' f (IntKnown es) = IntKnown (map f es)
removeDead' f q@(IntTable _ _) = IntProject f q
removeDead' f (IntNub q) = IntNub (removeDead' f q)
removeDead' f (IntProject g q)
  = case funcSplit (f . g) of
      FuncSplit f' g' -> IntProject g' (removeDead' f' q)
removeDead' f (IntRestrict r q) -- f :: a -> b, q :: a, r :: a -> Bool, fr :: a -> Prod b Bool, f' :: a -> c, 
  = case funcSplit (\a -> prod (f a) (r a)) of
      FuncSplit f' fr' -> IntProject (sel1 . fr') $ IntRestrict (sel2 . fr') (removeDead' f' q)
removeDead' f (IntUnion q1 q2) = IntUnion (removeDead' f q1) (removeDead' f q2)
removeDead' f (IntIntersection q1 q2) = IntIntersection (removeDead' f q1) (removeDead' f q2)
removeDead' f (IntJoin g (q1 :: IntQuery x) (q2 :: IntQuery y))
  = let buildRes :: SqlBE b => ProdFuncSplit SqlExpr (Prod x y) (Prod b Bool) -> IntQuery b
        buildRes (ProdFuncSplit f1' f2' fg') = IntProject (sel1 . fg') $
                                               IntJoin (\c d -> sel2 (fg' (prod c d)))
                                                       (removeDead' f1' q1)
                                                       (removeDead' f2' q2)
    in buildRes (prodFuncSplit (\ab -> prod (f ab) (g (sel1 ab) (sel2 ab))))
removeDead' f (IntLeftJoin g q1 q2) = IntProject f (IntLeftJoin g q1 q2) -- give up :-(
{-
removeDead' f (IntLeftJoin g (q1 :: IntQuery x) (q2 :: IntQuery y))
  = let buildRes :: SqlBE b => ProdFuncSplit SqlExpr (Prod x y) (Prod b Bool) -> IntQuery b
        buildRes (ProdFuncSplit f1' (f2' :: forall f . ProdSel f => f y -> f d) fg')
            = case sqlBENullableDict (undefined :: d) of
                SqlBEDict -> IntProject (sel1 . fg' . (\cd -> prod (sel1 cd) (fromNullable (fromFieldsE (repeat "")) (sel2 cd)))) $
                             IntLeftJoin (\c d -> sel2 (fg' (prod c d)))
                                         (removeDead' f1' q1)
                                         (removeDead' f2' q2)
       thefunc (SEProd a b) = let nm = nullableMap b
                                  
                              in prod (f a (toNullable b)) (g a b)
    in buildRes (prodFuncSplit thefunc)
-}
removeDead' f (IntSortBy s q)
  = case funcSplit (\a -> prod (f a) (s a)) of
      FuncSplit f' fs' -> IntProject (sel1 . fs') $ IntSortBy (sel2 . fs') (removeDead' f' q)
removeDead' f (IntGroupBy sel deaggr q)
  = case funcSplit (\a -> prod (sel a) (f (deaggr (exprToAggr a)))) of
      FuncSplit f' seldeaggr' -> IntGroupBy (sel1 . seldeaggr') (sel2 . seldeaggr' . aggrToExpr) (removeDead' f' q)



toNullable :: forall a . SqlExpr a -> SqlExpr (Nullable a)
toNullable SENil = SENil
toNullable (SEProd a b) = SEProd (toNullable a) (toNullable b)
toNullable (SEField mtn fn) = case sqlPrimTypeNullableDict (undefined :: a) of
                                SqlPrimTypeDict -> SEField mtn fn

fromNullable :: forall a . SqlExpr a -> SqlExpr (Nullable a) -> SqlExpr a
fromNullable SENil SENil = SENil
fromNullable (SEProd x y) (SEProd a b) = SEProd (fromNullable x a) (fromNullable y b)
fromNullable (SEField _ _) (SEField mtn fn) = SEField mtn fn

data FuncSplit g a c where
   FuncSplit :: (SqlBE a, SqlBE b, SqlBE c) => (forall f . ProdSel f => f a -> f b) -> (g b -> g c) -> FuncSplit g a c

data ProdFuncSplit g a c where
   ProdFuncSplit :: (SqlBE a, SqlBE b, SqlBE c, SqlBE d, SqlBE e)
                 => (forall f . ProdSel f => f a -> f c)
                 -> (forall f . ProdSel f => f b -> f d)
                 -> (g (Prod c d) -> g e)
                 -> ProdFuncSplit g (Prod a b) e

maybeRead :: Read a => String -> Maybe a
maybeRead str = case reads str of
                  [(a, "")] -> Just a
                  _ -> Nothing

funcSplit :: (SqlBE a, SqlBE c) => (SqlExpr a -> SqlExpr c) -> FuncSplit SqlExpr a c
funcSplit f = let freeno = getFreeNo f
                  ((fldsa, fmapa), _) = fromFields' (map FieldId [freeno..])
                  usedno fn | Just n <- maybeUnFieldId fn, n >= freeno = True
                            | otherwise = False
                  expa = fieldsToExpr fldsa
              in case toUsedFields usedno (f expa) of
                   Wrapped fldsb -> FuncSplit (reproject fmapa fldsb)
                                              (rebuildFunc f . reproject (buildFMap fldsb) fldsa)

prodFuncSplit :: forall a b e . (SqlBE a, SqlBE b, SqlBE e) => (SqlExpr (Prod a b) -> SqlExpr e) -> ProdFuncSplit SqlExpr (Prod a b) e
prodFuncSplit f = let
                      freeno = getFreeNo f
                      ((fldsa, fmapa), names') = fromFields' (map FieldId [freeno..])
                      ((fldsb, fmapb), _     ) = fromFields' names'
                      usedno fn | Just n <- maybeUnFieldId fn, n >= freeno = True
                                | otherwise = False
                      expa = fieldsToExpr fldsa
                      expb = fieldsToExpr fldsb
                      dummyexpa = fromFieldsE (repeat (FieldName ""))
                      dummyexpb = fromFieldsE (repeat (FieldName ""))
                  in case (toUsedFields usedno (f (SEProd expa dummyexpb)), toUsedFields usedno (f (SEProd dummyexpa expb))) of
                     (Wrapped fldsc, Wrapped fldsd)
                         -> ProdFuncSplit (reproject fmapa fldsc)
                                          (reproject fmapb fldsd)
                                          ((\(SEProd c d)
                                                    -> rebuildFunc f
                                                         (SEProd (reproject (buildFMap fldsc) fldsa c)
                                                                 (reproject (buildFMap fldsd) fldsb d))))

data Wrapped s where
   Wrapped :: SqlBE a => s a -> Wrapped s

onWrapped :: (forall a . SqlBE a => s a -> c) -> Wrapped s -> c
onWrapped f (Wrapped a) = f a

mapWrapped :: (forall a . SqlBE a => s a -> t a) -> Wrapped s -> Wrapped t
mapWrapped f (Wrapped a) = Wrapped (f a)

onWrapped2 :: (forall a b . (SqlBE a, SqlBE b) => s a -> s b -> c) -> Wrapped s -> Wrapped s -> c
onWrapped2 f (Wrapped a) (Wrapped b) = f a b

findUsedSE :: forall q a . SqlExpr' q a -> Map FieldName (Wrapped SqlFields) -> Map FieldName (Wrapped SqlFields)
findUsedSE (SEField _ (FieldName "")) = id -- bit of a hack so we can ignore some stuff
findUsedSE f@(SEField mtn fn) = Map.insert fn (Wrapped (SFField mtn fn :: SqlFields a))
findUsedSE (SEProd e1 e2) = findUsedSE e1 . findUsedSE e2
findUsedSE SENil = id
findUsedSE (SEAggr e) = findUsedSE e
findUsedSE (SEApp f a) = findUsedSE f . findUsedSE a
findUsedSE (SEPrim _) = id
findUsedSE (SEIntQuery q) = findUsedIQ q
findUsedSE (SEPrimQuery q) = findUsedPQ q

emptyFields = repeat (FieldName "")

findUsedPQ :: PrimQuery a -> Map FieldName (Wrapped SqlFields) -> Map FieldName (Wrapped SqlFields)
findUsedPQ (PrimUnit e _) = findUsedSE e
findUsedPQ (PrimSelect _ proj _ restr msort ts) = findUsedSE (fromFunc proj (fromFieldsE emptyFields)) . findUsedSE (restr (fromFieldsE emptyFields)) . maybe id (findUsedSE . ($ (fromFieldsE emptyFields))) msort . findUsedPT ts
findUsedPQ (PrimIntersection q1 q2) = findUsedPQ q1 . findUsedPQ q2
findUsedPQ (PrimUnion _ q1 q2) = findUsedPQ q1 . findUsedPQ q2
findUsedPQ (PrimGroup _ sel deaggr _ restr msort ts) = findUsedSE (sel (fromFieldsE emptyFields)) . findUsedSE (deaggr (fromFieldsE emptyFields)) . findUsedSE (restr (fromFieldsE emptyFields)) . maybe id (findUsedSE . ($ (fromFieldsE emptyFields))) msort . findUsedPT ts

findUsedPT :: PrimTables a -> Map FieldName (Wrapped SqlFields) -> Map FieldName (Wrapped SqlFields)
findUsedPT (PrimTable _ _ _ _) = id
findUsedPT (PrimQuickJoin t1 t2) = findUsedPT t1 . findUsedPT t2
findUsedPT (PrimJoin f t1 t2) = findUsedSE (uncurrySEProd f (fromFieldsE emptyFields)) . findUsedPT t1 . findUsedPT t2
findUsedPT (PrimLeftJoin f t1 t2) = findUsedSE (uncurrySEProd f (fromFieldsE emptyFields)) . findUsedPT t1 . findUsedPT t2
findUsedPT (PrimSubQuery _ q) = findUsedPQ q

findUsedIQ :: IntQuery a -> Map FieldName (Wrapped SqlFields) -> Map FieldName (Wrapped SqlFields)
findUsedIQ (IntKnown es) = flip (foldr findUsedSE) es
findUsedIQ (IntTable _ _) = id
findUsedIQ (IntNub q) = findUsedIQ q
findUsedIQ (IntProject f q) = findUsedSE (f (fromFieldsE (repeat (FieldName "")))) . findUsedIQ q
findUsedIQ (IntRestrict r q) = findUsedSE (r (fromFieldsE (repeat (FieldName "")))) . findUsedIQ q
findUsedIQ (IntUnion q1 q2) = findUsedIQ q1 . findUsedIQ q2
findUsedIQ (IntIntersection q1 q2) = findUsedIQ q1 . findUsedIQ q2
findUsedIQ (IntJoin f q1 q2) = findUsedSE (f (fromFieldsE (repeat (FieldName ""))) (fromFieldsE (repeat (FieldName "")))) . findUsedIQ q1 . findUsedIQ q2
findUsedIQ (IntLeftJoin f q1 q2) = findUsedSE (f (fromFieldsE (repeat (FieldName ""))) (fromFieldsE (repeat (FieldName "")))) . findUsedIQ q1 . findUsedIQ q2
findUsedIQ (IntSortBy s q) = findUsedSE (s (fromFieldsE (repeat (FieldName "")))) . findUsedIQ q
findUsedIQ (IntGroupBy sel deaggr q) = findUsedSE (sel (fromFieldsE (repeat (FieldName "")))) . findUsedSE (deaggr (fromFieldsA (repeat (FieldName "")))) . findUsedIQ q

toUsedFields :: (FieldName -> Bool) -> SqlExpr a -> Wrapped SqlFields
toUsedFields f e = foldr (onWrapped2 (\a b -> Wrapped (SFProd a b))) (Wrapped SFNil) $ Map.elems $ Map.filterWithKey (\a _ -> f a) $ findUsedSE e Map.empty

onlyThe :: SqlExpr a -> Bool
onlyThe (SEApp (SEPrim SPThe) (SEAggr e)) = True
onlyThe (SEApp f a) = onlyThe f && onlyThe a
onlyThe SENil = True
onlyThe (SEPrim p) = True
onlyThe (SEProd a b) = onlyThe a && onlyThe b
onlyThe (SEIntQuery q) = True
onlyThe (SEField tn fn) = False
onlyThe (SEAggr e) = False

removeThe :: SqlExpr a -> SqlExpr a
removeThe (SEApp (SEPrim SPThe) (SEAggr e)) = e
removeThe (SEApp f a) = SEApp (removeThe f) (removeThe a)
removeThe SENil = SENil
removeThe (SEPrim p) = SEPrim p
removeThe (SEProd a b) = SEProd (removeThe a) (removeThe b)
removeThe (SEIntQuery q) = SEIntQuery q
removeThe (SEField tn fn) = error "removeThe SEField"
removeThe (SEAggr e) = error "removeThe SEAggr"

optIQ :: IntQuery a -> IntQuery a

-- optIQ q | trace ("optIQ: " ++ show q ++ "\n") False = undefined

optIQ (IntProject f q)
  | IntKnown vs <- q' = optIQ (IntKnown (map f vs))
  | IntProject g q'' <- q' = optIQ (IntProject (f' . g) q'')
  | IntUnion q1 q2 <- q' = optIQ (IntUnion (IntProject f' q1) (IntProject f' q2))
  | IntIntersection q1 q2 <- q' = optIQ (IntIntersection (IntProject f' q1) (IntProject f' q2))
  | otherwise = IntProject f' q'
   where f' = rebuildFunc (optSE . f)
         q' = optIQ q

optIQ (IntRestrict r q)
  | isAlwaysFalse r' = IntKnown []
  | IntKnown [] <- q' = IntKnown []
  | IntProject f q'' <- q' = optIQ (IntProject (rebuildFunc $ \x -> optSE' (getFacts True (r' (f x))) (f x)) (IntRestrict (r' . f) q''))
  | IntRestrict r'' q'' <- q' = optIQ (IntRestrict (\x -> r' x && r'' x) q'')
  | IntUnion q1 q2 <- q' = optIQ (IntUnion (IntRestrict r' q1) (IntRestrict r' q2))
  | IntIntersection q1 q2 <- q' = optIQ (IntIntersection (IntRestrict r' q1) (IntRestrict r' q2))
  | IntSortBy s q'' <- q' = optIQ (IntSortBy s (IntRestrict r' q''))
  | IntGroupBy sel deaggr q'' <- q', onlyThe (r' (deaggr (fromFieldsA emptyFields)))
          = optIQ (IntGroupBy sel deaggr (IntRestrict (removeThe . r' . deaggr. exprToAggr) q''))
  | otherwise = IntRestrict r' q'
   where r' = rebuildFunc (optSE . r)
         q' = optIQ q

optIQ (IntNub q)
  | IntKnown vs <- q', length vs < 2 = q'
  | IntNub q'' <- q' = q'
  | IntProject f (IntJoin r q1 q2) <- q, Just f' <- onlyFst f
         = optIQ (IntNub (IntProject f' (IntRestrict (\a -> SEApp (SEPrim SPExists) (SEIntQuery (IntRestrict (\b -> r a b) q2))) q1)))
  | IntProject f q'' <- q' = IntNub (optIQ (IntProject f (IntNub q'')))
  | IntRestrict r q'' <- q' = optIQ (IntRestrict r (IntNub q''))
  | IntJoin f q1 q2 <- q' = optIQ (IntJoin f (IntNub q1) (IntNub q2))
  | IntUnion q1 q2 <- q' = IntNub (optIQ (IntUnion (IntNub q1) (IntNub q2)))
  | IntIntersection q1 q2 <- q' = optIQ (IntIntersection (IntNub q1) (IntNub q2))
  | IntSortBy s q'' <- q' = optIQ (IntSortBy s (IntNub q''))
  | IntGroupBy sel deaggr q'' <- q', onlyThe (deaggr (fromFieldsA emptyFields))
          = optIQ (IntGroupBy sel deaggr (IntNub q''))
  | otherwise = IntNub q'
   where q' = optIQ q

optIQ (IntSortBy s q)
  | IntKnown vs <- q', length vs < 2 = q'
  | otherwise = IntSortBy s' q'
   where s' = rebuildFunc (optSE . s)
         q' = optIQ q

optIQ (IntGroupBy sel deaggr q)
  | IntKnown es <- q',
    Just svs <- mapM (\e -> do s <- toLit (optSE (sel e)) ; v <- toLit e ; return (s, v)) es,
    vss <- List.map (List.map snd) . List.groupBy ((==) `on` fst) $ svs,
    Just es' <- mapM (checkLit . optSE . deaggr . SEPrim . SPLit . SLAggr) vss
      = IntKnown es'
  | otherwise = IntGroupBy sel' deaggr' q'
   where sel' = rebuildFunc (optSE . sel)
         deaggr' = rebuildFunc (optSE . deaggr)
         q' = optIQ q

optIQ (IntIntersection q1 q2)
  | IntKnown [] <- q1' = IntKnown []
  | IntKnown [] <- q2' = IntKnown []
  | otherwise = IntIntersection q1' q2'
   where q1' = optIQ q1
         q2' = optIQ q2

optIQ (IntUnion q1 q2)
  | IntKnown [] <- q1' = q2'
  | IntKnown [] <- q2' = q1'
  | IntKnown vs1 <- q1', IntKnown vs2 <- q2' = IntKnown (vs1 ++ vs2)
  | otherwise = IntUnion q1' q2'
   where q1' = optIQ q1
         q2' = optIQ q2

optIQ (IntKnown vs) = IntKnown (map optSE vs)
optIQ (IntTable fn t) = IntTable fn t
optIQ (IntJoin f q1 q2) = IntJoin (currySEProd . rebuildFunc . (optSE .) . uncurrySEProd $ f) (optIQ q1) (optIQ q2)
optIQ (IntLeftJoin f q1 q2) = IntLeftJoin (currySEProd . rebuildFunc . (optSE .) . uncurrySEProd $ f) (optIQ q1) (optIQ q2)

namesupply = map ((FieldName) . (:"field")) ['a'..'z']


idSelect :: SqlBE a => PrimTables a -> PrimQuery a
idSelect = PrimSelect False IdFunc (fromFields namesupply) (const true) (Nothing :: Maybe (SqlExprP a -> SqlExprP a))

primSubQuery :: SqlBE a => PrimQuery a -> PrimTables a
primSubQuery = PrimSubQuery "sub"

addSort :: (SqlBE a, SqlBE b) => (SqlExprP a -> SqlExprP b) -> PrimQuery a -> PrimQuery a
addSort s (PrimSelect b p f r Nothing t) = PrimSelect b p f r (Just $ s . fromFunc p) t
addSort s' (PrimSelect b p f r (Just s) t) = PrimSelect b p f r (Just $ \x -> SEProd (s' (fromFunc p x)) (s x)) t
addSort f ps = addSort f $ idSelect (primSubQuery ps)

addGroup :: (SqlBE a, SqlBE b, SqlBE g) => (SqlExprP a -> SqlExprP g) -> (SqlAggrP a -> SqlExprP b) -> PrimQuery a -> PrimQuery b
addGroup sel deaggr ps
   = PrimGroup False sel deaggr (fromFields namesupply) (const true) (Nothing :: Maybe (SqlExprP x -> SqlExprP x)) (primSubQuery ps)

conjRestr :: SqlBE a => (SqlExprP a -> SqlExprP Bool) -> PrimQuery a -> PrimQuery a
conjRestr r' (PrimSelect b p f r s t) = PrimSelect b p f (\x -> r x && r' (fromFunc p x)) s t
conjRestr r' ps = conjRestr r' $ idSelect (primSubQuery ps)

compProj :: (SqlBE a, SqlBE b) => (SqlExprP a -> SqlExprP b) -> PrimQuery a -> PrimQuery b
compProj p' (PrimSelect b p _ r s t) = PrimSelect b (EmbedFunc p' `CompFunc` p) (fromFields namesupply) r s t
compProj p ps = compProj p $ idSelect (primSubQuery ps)

addNub :: SqlBE a => PrimQuery a -> PrimQuery a
addNub (PrimSelect b p f r s t) = PrimSelect True p f r s t
addNub (PrimGroup b sel deaggr f r s t) = PrimGroup True sel deaggr f r s t
addNub (PrimUnion b q1 q2) = PrimUnion True q1 q2
addNub ps = addNub $ idSelect (primSubQuery ps)

data PrimTables a where
   PrimTable :: (SqlBE a) => Maybe DBName -> TableName -> Maybe TableName -> SqlFields a -> PrimTables a
   PrimQuickJoin :: (SqlBE a, SqlBE b) => PrimTables a -> PrimTables b -> PrimTables (Prod a b)
   PrimJoin :: (SqlBE a, SqlBE b) => (SqlExprP a -> SqlExprP b -> SqlExprP Bool) -> PrimTables a -> PrimTables b -> PrimTables (Prod a b)
   PrimLeftJoin :: (SqlBE a, SqlBE b, SqlBE (Nullable b))
                => (SqlExprP a -> SqlExprP b -> SqlExprP Bool) -> PrimTables a -> PrimTables b -> PrimTables (Prod a (Nullable b))
   PrimSubQuery :: (SqlBE a) => TableName -> PrimQuery a -> PrimTables a

instance Show (PrimTables a) where
   show (PrimTable dn tn mtn exp) = "PrimTable " ++ show dn ++ " " ++ show tn ++ " " ++ show mtn ++ " (" ++ show exp ++ ")"
   show (PrimQuickJoin pt1 pt2) = "PrimQuickJoin (" ++ show pt1 ++ ") (" ++ show pt2 ++ ")"
   show (PrimJoin f pt1 pt2) = "PrimJoin (" ++ show f ++ ") (" ++ show pt1 ++ ") (" ++ show pt2 ++ ")"
   show (PrimLeftJoin f pt1 pt2) = "PrimLeftJoin (" ++ show f ++  ") (" ++ show pt1 ++ ") (" ++ show pt2 ++ ")"
   show (PrimSubQuery tn pq) = "PrimSubQuery " ++ show tn ++ " (" ++ show pq ++ ")"

-- TODO is this actually useful?
data SqlFunc' q a b where
   IdFunc :: SqlBE a => SqlFunc' q a a
   EmbedFunc :: (SqlBE a, SqlBE b) => (SqlExpr' q a -> SqlExpr' q b) -> SqlFunc' q a b
   CompFunc :: (SqlBE a, SqlBE b, SqlBE c) => SqlFunc' q b c -> SqlFunc' q a b -> SqlFunc' q a c
   PairFunc :: (SqlBE a, SqlBE b, SqlBE c, SqlBE d) => SqlFunc' q a b -> SqlFunc' q c d -> SqlFunc' q (Prod a c) (Prod b d)

type SqlFunc = SqlFunc' IntQuery

fromFunc :: SqlFunc' q a b -> (SqlExpr' q a -> SqlExpr' q b)
fromFunc IdFunc = id
fromFunc (EmbedFunc f) = f
fromFunc (CompFunc f g) = fromFunc f . fromFunc g
fromFunc (PairFunc f g) = pair (fromFunc f) (fromFunc g)
  where pair ::(SqlExpr' q a -> SqlExpr' q b) -> (SqlExpr' q c -> SqlExpr' q d) -> (SqlExpr' q (Prod a c) -> SqlExpr' q (Prod b d))
        pair f1 f2 (SEProd fs1 fs2) = SEProd (f1 fs1) (f2 fs2)

instance (Show1 q, SqlBE a) => Show (SqlExpr' q a -> SqlExpr' q b) where
    show f = let args :: SqlExpr' q a
                 args = fromFieldsE $ map (FieldName . (:[])) $ ['a'..'z']
             in "\\" ++ show args ++ " -> " ++ show (f args)

instance (Show1 q, SqlBE a, SqlBE b, SqlBE c) => Show (SqlExpr' q a -> SqlExpr' q b -> SqlExpr' q c) where
    show f = case (fromFieldsE $ map (FieldName . (:[])) $ ['a'..'z'] :: SqlExpr' q (Prod a b)) of
                SEProd args1 args2  -> "\\" ++ show args1 ++ " " ++ show args2 ++ " -> " ++ show (f args1 args2)

instance Show1 q => Show (SqlFunc' q a b) where
   show (EmbedFunc (f :: SqlExpr' q a -> SqlExpr' q b)) = "embed(" ++ show f ++ ")"
--   show f@(CompFunc _ _) = show (EmbedFunc (fromFunc f))
   show IdFunc = "id"
   show (CompFunc f g) = show f ++ " . " ++ show g
   show (PairFunc f g) = "(" ++ show f ++ " *** " ++ show g ++ ")"

type SqlFuncP = SqlFunc' PrimQuery
type SqlExprP = SqlExpr' PrimQuery
type SqlAggrP a = SqlExprP (Aggr a)

data PrimQuery a where
   PrimUnit :: SqlBE a => SqlExprP a -> SqlFields a -> PrimQuery a
   PrimSelect :: (SqlBE a, SqlBE p, SqlBE s)
              => Bool -- True = DISTINCT, False = ALL
              -> SqlFuncP a p
              -> SqlFields p
              -> (SqlExprP a -> SqlExprP Bool)
              -> Maybe (SqlExprP a -> SqlExprP s)
              -> PrimTables a
              -> PrimQuery p
   PrimUnion :: SqlBE a => Bool -> PrimQuery a -> PrimQuery a -> PrimQuery a
   PrimIntersection :: SqlBE a => PrimQuery a -> PrimQuery a -> PrimQuery a
   PrimGroup :: (SqlBE a, SqlBE g, SqlBE p, SqlBE s)
             => Bool -- True = DISTINCT, False = ALL
             -> (SqlExprP a -> SqlExprP g)
             -> (SqlAggrP a -> SqlExprP p)
             -> SqlFields p
             -> (SqlExprP a -> SqlExprP Bool)
             -> Maybe (SqlExprP a -> SqlExprP s)
             -> PrimTables a
             -> PrimQuery p

instance Show (PrimQuery a) where
   show (PrimUnit exp f) = "PrimUnit (" ++ show exp ++ ") (" ++ show f ++ ")"
   show (PrimSelect b p f r s t) = "PrimSelect " ++ show b ++ " (" ++ show p ++ ") (" ++ show f ++ ") (" ++ show r ++ ") (" ++ show s ++ ") " ++ show t
   show (PrimGroup b sel deaggr f r s t) = "PrimGroup " ++ show b ++ " (" ++ show sel ++ ") (" ++ show deaggr ++ ") (" ++ show f ++ ") (" ++ show r ++ ") (" ++ show s ++ ") " ++ show t
   show (PrimUnion b q1 q2) = "PrimUnion " ++ show b ++ " (" ++ show q1 ++ ") (" ++ show q2 ++ ")"
   show (PrimIntersection q1 q2) = "PrimIntersection (" ++ show q1 ++ ") (" ++ show q2 ++ ")"

zero = Zero

unit = Unit

table = Table

field = SFField (False, Nothing) . FieldName

nub = Nub undefined

project = Project

restrict = Restrict

join = Join

leftJoin = LeftJoin undefined

union = Union undefined
intersection = Intersection undefined

sort :: (HasSqlCmp sea, HasSqlExpr a sea, HasProdEnc a, ProdEnc a ~ UnSqlExpr (ProdEnc sea),
         HasSqlExpr b (SqlCmp sea)) => Query a -> Query a
sort = SortBy comparisonFields

sortBy :: (HasSqlExpr a sea, HasProdEnc a, ProdEnc a ~ UnSqlExpr (ProdEnc sea),
           HasSqlExpr b seb)
       => (sea -> seb) -> Query a -> Query a
sortBy = SortBy

groupBy :: (HasSqlExpr a sea, HasSqlExpr g seg, HasSqlExpr b seb,
            HasProdEnc b, ProdEnc b ~ UnSqlExpr (ProdEnc seb)
           )
        => (sea -> seg) -> (Aggr sea -> seb) -> Query a -> Query b
groupBy sel deaggr = GroupBy sel deaggr

-- TODO review whether we can have a default aggr; add group

data WrapSqlExpr a where
  WrapSqlExpr :: HasSqlExpr a sea => sea -> WrapSqlExpr a

unWrapSqlExpr :: WrapSqlExpr a -> (forall sea . HasSqlExpr a sea => sea -> b) -> b
unWrapSqlExpr (WrapSqlExpr e) f = f e

{-
fields :: Tables a -> WrapSqlExpr a
fields (OneTable _ f) = WrapSqlExpr f
fields (ProdTables t1 t2) = unWrapSqlExpr (fields t1) $ \f1 ->
                            unWrapSqlExpr (fields t2) $ \f2 ->
                            WrapSqlExpr (f1, f2)

tablenames :: Tables a -> [String]
tablenames (OneTable n _) = [n]
tablenames (ProdTables t1 t2) = tablenames t1 ++ tablenames t2
-}

-- ICK!!!! (but note the two-way fundep)
convSqlExpr :: (HasSqlExpr a sea1, HasSqlExpr a sea2) => sea1 -> sea2
convSqlExpr a = unsafeCoerce a

convSqlFields :: (HasSqlFields a sfa1, HasSqlFields a sfa2) => sfa1 -> sfa2
convSqlFields a = unsafeCoerce a

{-
renderE :: (HasProdEnc sea, IsSqlExpr (ProdEnc sea)) => sea -> Doc
renderE = renderSqlExpr 0 . encodeSqlExpr
-}

renderSqlExpr n e = renderSqlExpr' n e Nothing

renderAs :: SqlPrimType a => Maybe (SqlFields a) -> Doc
renderAs Nothing = empty
renderAs (Just (SFField _ fn)) = text "AS" <+> text (unFieldName fn)

parens' :: Int -> Int -> Doc -> Doc
parens' n m = if n >= m then parens else id

renderInfix :: Int -> Int -> String -> SqlExprP a -> SqlExprP b -> Doc
renderInfix n m op a b = parens' n m (renderSqlExpr m a <+> text op <+> renderSqlExpr m b)

castSqlField :: (SqlPrimType a, SqlPrimType b) => SqlFields a -> SqlFields b
castSqlField (SFField tn fn) = SFField tn fn

renderSqlExpr' :: Int -> SqlExprP a -> Maybe (SqlFields a) -> Doc
renderSqlExpr' n (SEPrim (SPLit (SLBool l))) as = text (showPrimSql l) <+> renderAs as
renderSqlExpr' n (SEPrim (SPLit (SLInt l))) as = text (showPrimSql l) <+> renderAs as
renderSqlExpr' n (SEPrim (SPLit (SLChar l))) as = text (showPrimSql l) <+> renderAs as
renderSqlExpr' n (SEPrim (SPLit (SLString l))) as = text (showPrimSql l) <+> renderAs as
renderSqlExpr' n (SEPrim (SPLit (SLDouble l))) as = text (showPrimSql l) <+> renderAs as
renderSqlExpr' n (SEPrim (SPLit (SLDate l))) as = text (showPrimSql l) <+> renderAs as
renderSqlExpr' n (SEField (True, Just tn) fn) as = text (tn ++ "." ++ unFieldName fn) <+> renderAs as
renderSqlExpr' n (SEField (True, Nothing) fn) as = error $ "field " ++ unFieldName fn ++ " needs table name but has none"
renderSqlExpr' n (SEField _ fn) (Just (SFField _ fn')) | fn == fn' = text (unFieldName fn)
renderSqlExpr' n (SEField _ fn) as = text (unFieldName fn) <+> renderAs as
renderSqlExpr' n (SEApp (SEApp (SEPrim SPEq) a) b) as = renderInfix n 2 "=" a b <+> renderAs as
renderSqlExpr' n (SEApp (SEApp (SEPrim SPNe) a) b) as = renderInfix n 2 "<>" a b <+> renderAs as
renderSqlExpr' n (SEApp (SEApp (SEPrim SPLt) a) b) as = renderInfix n 2 "<" a b <+> renderAs as
renderSqlExpr' n (SEApp (SEApp (SEPrim SPGt) a) b) as = renderInfix n 2 ">" a b <+> renderAs as
renderSqlExpr' n (SEApp (SEApp (SEPrim SPLe) a) b) as = renderInfix n 2 "<=" a b <+> renderAs as
renderSqlExpr' n (SEApp (SEApp (SEPrim SPGe) a) b) as = renderInfix n 2 ">=" a b <+> renderAs as
renderSqlExpr' n (SEApp (SEApp (SEPrim SPAnd) a) b) as = renderInfix n 1 "&&" a b <+> renderAs as
renderSqlExpr' n (SEApp (SEApp (SEPrim SPOr) a) b) as = renderInfix n 1 "||" a b <+> renderAs as
renderSqlExpr' n (SEApp (SEPrim SPNot) a) as = text "not" <> parens (renderSqlExpr 0 a) <+> renderAs as
renderSqlExpr' n (SEApp (SEApp (SEPrim SPPlus) a) b) as = renderInfix n 3 "+" a b <+> renderAs as
renderSqlExpr' n (SEApp (SEApp (SEPrim SPMinus) a) b) as = renderInfix n 3 "-" a b <+> renderAs as
renderSqlExpr' n (SEApp (SEApp (SEPrim SPTimes) a) b) as = renderInfix n 4 "*" a b <+> renderAs as
renderSqlExpr' n (SEApp (SEPrim SPNegate) a) as = text "-" <> parens (renderSqlExpr 0 a) <+> renderAs as
renderSqlExpr' n (SEApp (SEPrim SPIsNull) a) as = parens' n 5 (renderSqlExpr 5 a) <+> text "IS NULL" <+> renderAs as
renderSqlExpr' n (SEPrim SPNull) as = text "NULL" <+> renderAs as
renderSqlExpr' n (SEApp (SEApp (SEPrim SPConcat) a) b) as = text "concat" <> parens (renderSqlExpr 0 a <> comma <> renderSqlExpr 0 b) <+> renderAs as
renderSqlExpr' n (SEApp (SEPrim SPJust) a) as = renderSqlExpr' n a (fmap castSqlField as)
renderSqlExpr' n (SEApp (SEPrim SPFromJust) a) as = renderSqlExpr' n a (fmap castSqlField as)
renderSqlExpr' n (SEApp (SEApp (SEApp (SEPrim SPIfThenElse) c) t) e) as
   = text "if" <> parens (renderSqlExpr 0 c <> comma <> renderSqlExpr 0 t <> comma <> renderSqlExpr 0 e) <+> renderAs as
renderSqlExpr' n (SEApp (SEPrim SPDoubleToInt) a) as = renderSqlExpr' n a (fmap castSqlField as)
renderSqlExpr' n (SEApp (SEPrim SPExists) (SEPrimQuery q)) as = text "exists" <> (parens . fst . renderPrimQuery $ q) <+> renderAs as
renderSqlExpr' n (SEApp (SEPrim SPThe) e) as = renderSqlExpr' n e (fmap SFAggr as)
renderSqlExpr' n (SEApp (SEPrim SPSum) e) as = text "sum" <> parens (renderSqlExpr 0 e) <+> renderAs as
renderSqlExpr' n (SEApp (SEPrim SPMax) e) as = text "max" <> parens (renderSqlExpr 0 e) <+> renderAs as
renderSqlExpr' n (SEApp (SEPrim SPMin) e) as = text "min" <> parens (renderSqlExpr 0 e) <+> renderAs as
renderSqlExpr' n (SEApp (SEPrim SPCount) e) as = text "count" <> parens (renderSqlExpr 0 e) <+> renderAs as
renderSqlExpr' n (SEProd a b) as | isNil a = renderSqlExpr' n b (fmap sel2 as)
                                 | isNil b = renderSqlExpr' n a (fmap sel1 as)
                                 | otherwise = renderSqlExpr' 0 a (fmap sel1 as) <> comma <> renderSqlExpr' 0 b (fmap sel2 as)
   where isNil :: SqlExpr' q a -> Bool
         isNil SENil = True
         isNil (SEProd a b) = isNil a && isNil b
         isNil _ = False
renderSqlExpr' n SENil as = text "0" -- don't know how to select nothing
renderSqlExpr' n (SEAggr e) as = renderSqlExpr' n e (fmap deaggr as)
renderSqlExpr' n e _ = error $ "renderSqlExpr: " ++ show e

renderPrimQuery :: PrimQuery a -> (Doc, SqlFields a)
renderPrimQuery (PrimUnit v fields)
 = (text "SELECT" <+> renderSqlExpr' 0 v (Just fields), fields)
renderPrimQuery (PrimSelect distinct proj fields restr msort tables)
 = case renderPrimTables tables of
     (tablestr, subfields) -> (sep [text "SELECT" <+> (if distinct then text "DISTINCT" else empty) <+>
                                        if exprIsFields (addScopedNames (fromFunc proj) (fieldsToExpr subfields)) subfields &&
                                           same fields subfields
                                          then text "*"
                                          else renderSqlExpr' 0 (addScopedNames (fromFunc proj) (fieldsToExpr subfields)) (Just fields),
                                    text "FROM" <+> tablestr,
                                    case addScopedNames restr (fieldsToExpr subfields) of
                                        SEPrim (SPLit (SLBool True)) -> empty
                                        x -> text "WHERE" <+> renderSqlExpr 0 x,
                                    maybe empty (\sort -> text "ORDER BY" <+>
                                                     renderSqlExpr 0 (sort (fieldsToExpr subfields))) msort],
                               fields)
renderPrimQuery (PrimGroup distinct sel deaggr fields restr msort tables)
 = case renderPrimTables tables of
     (tablestr, subfields) -> (sep [text "SELECT" <+> (if distinct then text "DISTINCT" else empty) <+>
                                        renderSqlExpr' 0 (deaggr (exprToAggr (fieldsToExpr subfields))) (Just fields),
                                    text "FROM" <+> tablestr,
                                    case addScopedNames restr (fieldsToExpr subfields) of
                                        SEPrim (SPLit (SLBool True)) -> empty
                                        x -> text "WHERE" <+> renderSqlExpr 0 x,
                                    maybe empty (\sort -> text "ORDER BY" <+>
                                                      renderSqlExpr 0 (sort (fieldsToExpr subfields))) msort,
                                    case sel (fieldsToExpr subfields) of
                                        SENil -> empty
                                        x -> text "GROUP BY" <+> renderSqlExpr 0 x],
                              fields)
-- TODO need to sort out field naming
renderPrimQuery (PrimUnion b q1 q2)
 = case (renderPrimQueryIU q1, renderPrimQueryIU q2) of
     ((tablestr1, fields1), (tablestr2, fields2)) ->
         (sep [tablestr1, if b then text "UNION" else text "UNION" <+> text "ALL", tablestr2], fields1)
renderPrimQuery (PrimIntersection q1 q2)
 = case (renderPrimQuery q1, renderPrimQuery q2) of
     ((tablestr1, fields1), (tablestr2, fields2)) ->
         (sep [parens tablestr1, text "INTERSECTION", parens tablestr2], fields1)

renderPrimQueryIU (PrimUnion b q1 q2)
 = case (renderPrimQueryIU q1, renderPrimQueryIU q2) of
     ((tablestr1, fields1), (tablestr2, fields2)) ->
         (sep [tablestr1, if b then text "UNION" else text "UNION" <+> text "ALL", tablestr2], fields1)
renderPrimQueryIU q = (id *** id) $ renderPrimQuery q

renderPrimTables :: PrimTables a -> (Doc, SqlFields a)
renderPrimTables (PrimTable dn tn Nothing fields) = (text (maybe id (\a b -> a ++ "." ++ b) dn tn), fields)
renderPrimTables (PrimTable dn tn (Just tn') fields) = (text (maybe id (\a b -> a ++ "." ++ b) dn tn) <+> text "AS" <+> text tn', fields)
renderPrimTables (PrimQuickJoin t1 t2) = let (t1str, t1fields) = renderPrimTables t1
                                             (t2str, t2fields) = renderPrimTables t2
                                         in (cat [t1str <> comma, t2str], SFProd t1fields t2fields)
renderPrimTables (PrimLeftJoin f t1 t2) = let (t1str, t1fields) = renderPrimTables t1
                                              (t2str, t2fields) = renderPrimTables t2
                                          in (t1str <+> text "LEFT JOIN" <+> t2str <+> text "ON" <+>
                                              renderSqlExpr 0 (f (fieldsToExpr t1fields) (fieldsToExpr t2fields)),
                                              SFProd t1fields (unsafeCoerce t2fields))
renderPrimTables (PrimSubQuery sn q) = let (str, fields) = renderPrimQuery q
                                        in (parens str <+> text "AS" <+> text sn, fields)

getFieldNamesPQ :: PrimQuery a -> [FieldName] -> [FieldName]
getFieldNamesPQ (PrimUnit _ f) = getFieldNamesSF f
getFieldNamesPQ (PrimSelect _ _ f _ _ t) = getFieldNamesSF f
getFieldNamesPQ (PrimUnion b q1 q2) = getFieldNamesPQ q1 -- . getFieldNamesPQ q2
getFieldNamesPQ (PrimIntersection q1 q2) = getFieldNamesPQ q1 -- . getFieldNamesPQ q2
getFieldNamesPQ (PrimGroup _ _ _ f _ _ t) = getFieldNamesSF f

getFieldNamesPT :: PrimTables a -> [FieldName] -> [FieldName]
getFieldNamesPT (PrimTable _ _ _ fields) = getFieldNamesSF fields
getFieldNamesPT (PrimQuickJoin t1 t2) = getFieldNamesPT t1 . getFieldNamesPT t2
getFieldNamesPT (PrimLeftJoin _ t1 t2) = getFieldNamesPT t1 . getFieldNamesPT t2
getFieldNamesPT (PrimJoin _ t1 t2) = getFieldNamesPT t1 . getFieldNamesPT t2
getFieldNamesPT (PrimSubQuery _ q) = getFieldNamesPQ q

getFieldNamesSF :: SqlFields a -> [FieldName] -> [FieldName]
getFieldNamesSF (SFField _ fn) = (fn:)
getFieldNamesSF (SFProd e1 e2) = getFieldNamesSF e1 . getFieldNamesSF e2
getFieldNamesSF SFNil = id

getFieldNamesSE :: SqlExpr' q a -> [FieldName] -> [FieldName]
getFieldNamesSE (SEField _ fn) = (fn:)
getFieldNamesSE (SEProd e1 e2) = getFieldNamesSE e1 . getFieldNamesSE e2
getFieldNamesSE (SEApp f a) = getFieldNamesSE f . getFieldNamesSE a
getFieldNamesSE (SEPrim _) = id
getFieldNamesSE SENil = id
getFieldNamesSE (SEAggr e) = getFieldNamesSE e
-- getFieldNamesSE e = error $ "getFieldNamesSE " ++ show e

addTableNamesPQ :: ((Maybe String, FieldName) -> Bool) -> PrimQuery a -> PrimQuery a
addTableNamesPQ fs (PrimUnit v f) = PrimUnit v (addTableNamesSF fs f)
addTableNamesPQ fs (PrimSelect b p f r s t) = PrimSelect b p (addTableNamesSF fs f) r s t
addTableNamesPQ fs (PrimUnion b q1 q2) = PrimUnion b (addTableNamesPQ fs q1) (addTableNamesPQ fs q2)
addTableNamesPQ fs (PrimIntersection q1 q2) = PrimIntersection (addTableNamesPQ fs q1) (addTableNamesPQ fs q2)
addTableNamesPQ fs (PrimGroup b sel deaggr f restr msort t) = PrimGroup b sel deaggr (addTableNamesSF fs f) restr msort t

addTableNamesPT :: ((Maybe String, FieldName) -> Bool) -> PrimTables a -> PrimTables a
addTableNamesPT fs (PrimTable dn tn mtn fields) = PrimTable dn tn mtn (addTableNamesSF fs fields)
addTableNamesPT fs (PrimQuickJoin t1 t2) = PrimQuickJoin (addTableNamesPT fs t1) (addTableNamesPT fs t2)
addTableNamesPT fs (PrimLeftJoin r t1 t2) = PrimLeftJoin r (addTableNamesPT fs t1) (addTableNamesPT fs t2)
addTableNamesPT fs (PrimJoin r t1 t2) = PrimJoin r (addTableNamesPT fs t1) (addTableNamesPT fs t2)
addTableNamesPT fs (PrimSubQuery tn q) = PrimSubQuery tn (addTableNamesPQ fs q)

addTableNamesSF :: ((Maybe String, FieldName) -> Bool) -> SqlFields a -> SqlFields a
addTableNamesSF fs (SFField (c, mtn) f) | fs (mtn, f) = SFField (True, mtn) f
                                        | otherwise = SFField (c, mtn) f
addTableNamesSF fs (SFProd e1 e2) = SFProd (addTableNamesSF fs e1) (addTableNamesSF fs e2)
addTableNamesSF fs SFNil = SFNil

addTableNamesSE :: ((Maybe String, FieldName) -> Bool) -> SqlExprP a -> SqlExprP a
addTableNamesSE fs (SEField (c, mtn) f) | fs (mtn, f) = SEField (True, mtn) f
                                        | otherwise = SEField (c, mtn) f
addTableNamesSE fs (SEProd e1 e2) = SEProd (addTableNamesSE fs e1) (addTableNamesSE fs e2)
addTableNamesSE fs SENil = SENil
addTableNamesSE fs (SEAggr e) = SEAggr (addTableNamesSE fs e)
addTableNamesSE fs (SEApp f a) = SEApp (addTableNamesSE fs f) (addTableNamesSE fs a)
addTableNamesSE fs (SEPrim p) = SEPrim p
addTableNamesSE fs (SEPrimQuery q) = SEPrimQuery (addTableNamesPQ fs q)

type FieldSel = (Maybe String, FieldName) -> Bool

-- TODO scopedname handling for deaggr
compScoped :: (FieldSel -> SqlExprP b -> SqlExprP b) -> FieldSel -> (SqlExprP a -> SqlExprP b) -> (SqlExprP a -> SqlExprP b)
compScoped addTN fs f a = addTN (\v -> fs v && not (isLocal v)) (f a)
   where gatherLocals :: SqlExprP c -> Map FieldName (Maybe String)
         gatherLocals (SEProd a b) = gatherLocals a `Map.union` gatherLocals b
         gatherLocals SENil = Map.empty
         gatherLocals (SEAggr e) = gatherLocals e
         gatherLocals (SEField (_, mtn) fn) = Map.singleton fn mtn
         locals = gatherLocals a
         isLocal (mtn, fn) = Map.lookup fn locals == Just mtn

addScopedNames :: (SqlExprP a -> SqlExprP b) -> SqlExprP a -> SqlExprP b
addScopedNames f a = addTableNamesSE (not . isLocal) (f a)
   where gatherLocals :: SqlExprP c -> Map FieldName (Maybe String)
         gatherLocals (SEProd a b) = gatherLocals a `Map.union` gatherLocals b
         gatherLocals SENil = Map.empty
         gatherLocals (SEAggr e) = gatherLocals e
         gatherLocals (SEField (_, mtn) fn) = Map.singleton fn mtn
         locals = gatherLocals a
         isLocal (mtn, fn) = Map.lookup fn locals == Just mtn

renameSubQueriesSE :: SqlExprP a -> State Int (SqlExprP a)
renameSubQueriesSE se@(SEField {}) = return se
renameSubQueriesSE (SEProd a b) = liftM2 SEProd (renameSubQueriesSE a) (renameSubQueriesSE b)
renameSubQueriesSE se@SENil = return se
renameSubQueriesSE (SEApp f a) = liftM2 SEApp (renameSubQueriesSE f) (renameSubQueriesSE a)
renameSubQueriesSE se@(SEPrim p) = return se
renameSubQueriesSE (SEAggr e) = liftM SEAggr $ renameSubQueriesSE e
renameSubQueriesSE (SEPrimQuery q) = liftM SEPrimQuery $ renameSubQueriesPQ q

renameSubQueriesSEF :: (SqlBE a, SqlBE b) => (SqlExprP a -> SqlExprP b) -> State Int (SqlExprP a -> SqlExprP b)
renameSubQueriesSEF f = rebuildFuncM (renameSubQueriesSE . f)

renameSubQueriesPQ :: PrimQuery a -> State Int (PrimQuery a)
renameSubQueriesPQ (PrimUnit v f) = return PrimUnit `ap` renameSubQueriesSE v `ap` return f
renameSubQueriesPQ (PrimSelect b p f r s t) = return (PrimSelect b) `ap` liftM EmbedFunc (renameSubQueriesSEF (fromFunc p)) `ap` return f
                                                                    `ap` renameSubQueriesSEF r `ap` T.mapM renameSubQueriesSEF s `ap` renameSubQueriesPT t
renameSubQueriesPQ (PrimUnion b q1 q2) = return (PrimUnion b) `ap` renameSubQueriesPQ q1 `ap` renameSubQueriesPQ q2
renameSubQueriesPQ (PrimIntersection q1 q2) = return PrimIntersection `ap` renameSubQueriesPQ q1 `ap` renameSubQueriesPQ q2
renameSubQueriesPQ (PrimGroup b sel deaggr f restr msort t) = return (PrimGroup b) `ap` renameSubQueriesSEF sel `ap` renameSubQueriesSEF deaggr
                                                                                   `ap` return f `ap` renameSubQueriesSEF restr
                                                                                   `ap` T.mapM renameSubQueriesSEF msort `ap` renameSubQueriesPT t

renameSubQueriesPT :: PrimTables a -> State Int (PrimTables a)
renameSubQueriesPT (PrimTable dn tn _ fields) = do n <- get
                                                   put (n+1)
                                                   return (PrimTable dn tn (Just (tn ++ show n)) fields)
renameSubQueriesPT (PrimQuickJoin t1 t2) = return PrimQuickJoin `ap` renameSubQueriesPT t1 `ap` renameSubQueriesPT t2
renameSubQueriesPT (PrimJoin r t1 t2) = return PrimJoin `ap` liftM currySEProd (renameSubQueriesSEF (uncurrySEProd r))
                                                        `ap` renameSubQueriesPT t1 `ap` renameSubQueriesPT t2
renameSubQueriesPT (PrimLeftJoin r t1 t2) = return PrimLeftJoin `ap` liftM currySEProd (renameSubQueriesSEF (uncurrySEProd r))
                                                                `ap` renameSubQueriesPT t1 `ap` renameSubQueriesPT t2
renameSubQueriesPT (PrimSubQuery tn q) = do n <- get
                                            put (n+1)
                                            liftM (PrimSubQuery (tn ++ show n)) $ renameSubQueriesPQ q

renamePQ, renamePQ' :: PrimQuery a -> PrimQuery a
renamePQ' = fixupNamesPQ . improveFieldNamesPQ . annotateTableNamesPQ Nothing 
renamePQ = renamePQ' . (\q -> evalState (renameSubQueriesPQ q) 0)

annotateTableNamesPQ :: Maybe TableName -> PrimQuery a -> PrimQuery a
annotateTableNamesPQ mtn (PrimUnit v f) = PrimUnit v (annotateTableNamesSF mtn f)
annotateTableNamesPQ mtn (PrimSelect b p f r s t) = PrimSelect b (EmbedFunc (annotateTableNamesSE . fromFunc p)) (annotateTableNamesSF mtn f)
                                                                 (annotateTableNamesSE . r) (fmap (annotateTableNamesSE . ) s) (annotateTableNamesPT t)
annotateTableNamesPQ mtn (PrimGroup b sel deaggr f r s t) = PrimGroup b (annotateTableNamesSE . sel) (annotateTableNamesSE . deaggr) (annotateTableNamesSF mtn f)
                                                                        (annotateTableNamesSE . r) (fmap (annotateTableNamesSE .) s) (annotateTableNamesPT t)
annotateTableNamesPQ mtn (PrimUnion b q1 q2) = PrimUnion b (annotateTableNamesPQ mtn q1) (annotateTableNamesPQ mtn q2)
annotateTableNamesPQ mtn (PrimIntersection q1 q2) = PrimIntersection (annotateTableNamesPQ mtn q1) (annotateTableNamesPQ mtn q2)

annotateTableNamesSF :: Maybe TableName -> SqlFields a -> SqlFields a
annotateTableNamesSF mtn (SFField (c, _) f) = SFField (c, mtn) f
annotateTableNamesSF mtn SFNil = SFNil
annotateTableNamesSF mtn (SFProd f1 f2) = SFProd (annotateTableNamesSF mtn f1) (annotateTableNamesSF mtn f2)

annotateTableNamesSE :: SqlExprP a -> SqlExprP a
annotateTableNamesSE e@(SEField _ _) = e
annotateTableNamesSE e@SENil = SENil
annotateTableNamesSE (SEProd e1 e2) = SEProd (annotateTableNamesSE e1) (annotateTableNamesSE e2)
annotateTableNamesSE e@(SEPrim _) = e
annotateTableNamesSE (SEApp f a) = SEApp (annotateTableNamesSE f) (annotateTableNamesSE a)
annotateTableNamesSE (SEAggr e) = SEAggr (annotateTableNamesSE e)
annotateTableNamesSE (SEPrimQuery q) = SEPrimQuery (annotateTableNamesPQ Nothing q)

annotateTableNamesPT :: PrimTables a -> PrimTables a
annotateTableNamesPT (PrimTable dn tn mtn f) = PrimTable dn tn mtn (annotateTableNamesSF (mtn `mplus` Just tn) f)
annotateTableNamesPT (PrimSubQuery tn q) = PrimSubQuery tn (annotateTableNamesPQ (Just tn) q)
annotateTableNamesPT (PrimQuickJoin t1 t2) = PrimQuickJoin (annotateTableNamesPT t1) (annotateTableNamesPT t2)
annotateTableNamesPT (PrimJoin f t1 t2) = PrimJoin (currySEProd (annotateTableNamesSE . uncurrySEProd f)) (annotateTableNamesPT t1) (annotateTableNamesPT t2)
annotateTableNamesPT (PrimLeftJoin f t1 t2) = PrimLeftJoin (currySEProd (annotateTableNamesSE . uncurrySEProd f)) (annotateTableNamesPT t1) (annotateTableNamesPT t2)

fixupNamesSE :: SqlExprP a -> SqlExprP a
fixupNamesSE e@(SEField _ _) = e
fixupNamesSE e@(SEPrim _) = e
fixupNamesSE (SEApp f a) = SEApp (fixupNamesSE f) (fixupNamesSE a)
fixupNamesSE e@SENil = SENil
fixupNamesSE (SEProd a b) = SEProd (fixupNamesSE a) (fixupNamesSE b)
fixupNamesSE (SEAggr e) = SEAggr (fixupNamesSE e)
fixupNamesSE (SEPrimQuery q) = SEPrimQuery (fixupNamesPQ q)

fixupNamesPQ :: PrimQuery a -> PrimQuery a
fixupNamesPQ (PrimUnit v f) = PrimUnit v f
fixupNamesPQ (PrimSelect b p f r s t) = PrimSelect b (EmbedFunc (fixupNamesSE . fromFunc p)) f (fixupNamesSE . r) (fmap (fixupNamesSE .) s) (fixupNamesPT t)
fixupNamesPQ (PrimGroup b sel deaggr f r s t) = PrimGroup b (fixupNamesSE . sel) (fixupNamesSE . deaggr) f (fixupNamesSE . r) (fmap (fixupNamesSE .) s) (fixupNamesPT t)
fixupNamesPQ (PrimUnion b q1 q2) = PrimUnion b (fixupNamesPQ q1) (fixupNamesPQ q2)
fixupNamesPQ (PrimIntersection q1 q2) = PrimIntersection (fixupNamesPQ q1) (fixupNamesPQ q2)

fixupNamesPT :: PrimTables a -> PrimTables a
fixupNamesPT pt = fixupNamesPT' $ addTableNamesPT (\(_, fn) -> fn `elem` dups (getFieldNamesPT pt [])) pt

dups = map head . filter ((Prelude.> 1) . length) . group . Data.List.sort

fixupNamesPT' :: PrimTables a -> PrimTables a
fixupNamesPT' (PrimSubQuery tn q) = PrimSubQuery tn (fixupNamesPQ q)
fixupNamesPT' (PrimTable dn tn mtn fields) = PrimTable dn tn mtn fields
fixupNamesPT' (PrimJoin r t1 t2) = PrimJoin (currySEProd (fixupNamesSE . uncurrySEProd r)) (fixupNamesPT' t1) (fixupNamesPT' t2)
fixupNamesPT' (PrimLeftJoin r t1 t2) = PrimLeftJoin (currySEProd (fixupNamesSE . uncurrySEProd r)) (fixupNamesPT' t1) (fixupNamesPT' t2)
fixupNamesPT' (PrimQuickJoin t1 t2) = PrimQuickJoin (fixupNamesPT' t1) (fixupNamesPT' t2)

goodFieldNames :: [FieldName] -> SqlExprP a -> SqlFields a -> SqlFields a
goodFieldNames _ SENil _ = SFNil
goodFieldNames bad (SEField _ f) (SFField mtn _) | f `notElem` bad = SFField mtn f
goodFieldNames bad (SEProd e1 e2) (SFProd f1 f2) = SFProd (goodFieldNames bad e1 f1) (goodFieldNames bad e2 f2)
goodFieldNames bad e (SFField mtn _) | [f'] <- getFieldNamesSE e [], f' `notElem` bad = SFField mtn f'
goodFieldNames _ _ f = f

-- TODO should make this recurse into SEPrimQuery
improveFieldNames :: SqlExprP a -> SqlFields a -> SqlFields a
improveFieldNames e f = improve Set.empty
   where improve bad = let f' = goodFieldNames (Set.elems bad) e f
                           bad' = Set.union bad $ Set.fromList $ dups $ getFieldNamesSF f' []
                       in if bad == bad' then f' else improve bad'

improveFieldNamesPQ :: PrimQuery a -> PrimQuery a
improveFieldNamesPQ (PrimUnit v f) = PrimUnit v f
improveFieldNamesPQ (PrimSelect b p f r s t)
    = let t' = improveFieldNamesPT t
          e = fromFunc p (fieldsToExpr (snd (renderPrimTables t')))
      in PrimSelect b p (improveFieldNames e f) r s t'
improveFieldNamesPQ (PrimGroup b sel deaggr f r s t)
    = let t' = improveFieldNamesPT t
          e = deaggr (exprToAggr (fieldsToExpr (snd (renderPrimTables t'))))
      in PrimGroup b sel deaggr (improveFieldNames e f) r s t'
improveFieldNamesPQ (PrimUnion b q1 q2) = PrimUnion b (improveFieldNamesPQ q1) (improveFieldNamesPQ q2)
improveFieldNamesPQ (PrimIntersection q1 q2) = PrimIntersection (improveFieldNamesPQ q1) (improveFieldNamesPQ q2)

improveFieldNamesPT :: PrimTables a -> PrimTables a
improveFieldNamesPT (PrimTable dn tn mtn f) = PrimTable dn tn mtn f
improveFieldNamesPT (PrimSubQuery tn q) = PrimSubQuery tn (improveFieldNamesPQ q)
improveFieldNamesPT (PrimQuickJoin t1 t2) = PrimQuickJoin (improveFieldNamesPT t1) (improveFieldNamesPT t2)
improveFieldNamesPT (PrimLeftJoin f t1 t2) = PrimLeftJoin f (improveFieldNamesPT t1) (improveFieldNamesPT t2)
improveFieldNamesPT (PrimJoin f t1 t2) = PrimJoin f (improveFieldNamesPT t1) (improveFieldNamesPT t2)

compileQ = renamePQ . optPQ . translateIQ . removeDead . optIQ . removeDead . translateQ
unoptCompileQ = renamePQ . translateIQ . translateQ

renderQ = vcat . collectNested (fst . renderPrimQuery . compileQ)
unoptRenderQ = vcat . collectNested (fst . renderPrimQuery . unoptCompileQ)