{-# LANGUAGE GADTs, TypeFamilies, TypeOperators, PolyKinds #-}
{-# LANGUAGE FlexibleInstances, OverloadedStrings, ScopedTypeVariables #-}
{-# LANGUAGE DataKinds, UndecidableInstances, MultiParamTypeClasses #-}
-- | Columns and associated utility functions, specialized to 'SQL'.
module Database.Selda.Column
  ( Columns, Same
  , Row (..), Col (..), SomeCol (..), UntypedCol (..)
  , Exp (..), NulOp (..), UnOp (..), BinOp (..)
  , toTup, fromTup, liftC, liftC2, liftC3
  , allNamesIn
  , hideRenaming
  , literal
  ) where
import Database.Selda.Exp
import Database.Selda.SQL
import Database.Selda.SqlType
import Database.Selda.SqlRow
import Database.Selda.Types
import Data.Proxy
import Data.String
import Data.Text (Text)
import GHC.TypeLits as TL

-- | Any column tuple.
class Columns a where
  toTup :: [ColName] -> a
  fromTup :: a -> [UntypedCol SQL]

instance (SqlType a, Columns b) => Columns (Col s a :*: b) where
  toTup (x:xs) = One (Col x) :*: toTup xs
  toTup []     = error "too few elements to toTup"
  fromTup (One x :*: xs) = Untyped x : fromTup xs

instance (SqlRow a, Columns b) => Columns (Row s a :*: b) where
  toTup xs =
    case nestedCols (Proxy :: Proxy a) of
      n -> Many (map (Untyped . Col) (take n xs)) :*: toTup (drop n xs)
  fromTup (Many xs :*: xss) = xs ++ fromTup xss

instance Columns (Col s a) where
  toTup [x] = One (Col x)
  toTup []  = error "too few elements to toTup"
  toTup _   = error "too many elements to toTup"
  fromTup (One x) = [Untyped x]

instance Columns (Row s a) where
  toTup xs = Many (map (Untyped . Col) xs)
  fromTup (Many xs) = xs

-- | A database column. A column is often a literal column table, but can also
--   be an expression over such a column or a constant expression.
newtype Col s a = One (Exp SQL a)

-- | A database row. A row is a collection of one or more columns.
newtype Row s a = Many [UntypedCol SQL]

-- | A literal expression.
literal :: SqlType a => a -> Col s a
literal = One . Lit . mkLit

instance IsString (Col s Text) where
  fromString = literal . fromString

liftC3 :: (Exp SQL a -> Exp SQL b -> Exp SQL c -> Exp SQL d)
       -> Col s a
       -> Col s b
       -> Col s c
       -> Col s d
liftC3 f (One a) (One b) (One c) = One (f a b c)

-- | Denotes that scopes @s@ and @t@ are identical.
class s ~ t => Same s t where
  liftC2 :: (Exp SQL a -> Exp SQL b -> Exp SQL c) -> Col s a -> Col t b -> Col s c
  liftC2 f (One a) (One b) = One (f a b)

instance {-# OVERLAPPING #-} Same s s
instance {-# OVERLAPPABLE #-} (s ~ t, TypeError
  ('TL.Text "An identifier from an outer scope may not be used in an inner query."))
  => Same s t

liftC :: (Exp SQL a -> Exp SQL b) -> Col s a -> Col s b
liftC f (One x) = One (f x)

instance (SqlType a, Num a) => Num (Col s a) where
  fromInteger = literal . fromInteger
  (+) = liftC2 $ BinOp Add
  (-) = liftC2 $ BinOp Sub
  (*) = liftC2 $ BinOp Mul
  negate = liftC $ UnOp Neg
  abs = liftC $ UnOp Abs
  signum = liftC $ UnOp Sgn

instance Fractional (Col s Double) where
  fromRational = literal . fromRational
  (/) = liftC2 $ BinOp Div

instance Fractional (Col s Int) where
  fromRational = literal . (truncate :: Double -> Int) . fromRational
  (/) = liftC2 $ BinOp Div