{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE TypeFamilies, TypeOperators, FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances, MultiParamTypeClasses, OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts, ScopedTypeVariables, ConstraintKinds #-}
{-# LANGUAGE GADTs, CPP, DataKinds #-}
-- | Generics utilities.
module Database.Selda.Generic
  ( Relational, Generic
  , tblCols, params, def, gNew, gRow
  ) where
import Control.Monad.State
    ( liftM2, MonadState(put, get), evalState, State )
import Data.Dynamic ( Typeable )
import Data.Text as Text (Text, pack)

import Data.Typeable ( Proxy(..), typeRep, typeRepTyCon )

import GHC.Generics
    ( Generic(from, Rep), Selector(selName), K1(K1), M1(M1), S )
import qualified GHC.Generics as G
    ( (:*:)(..), Selector, (:+:)(..) )
import qualified GHC.TypeLits as TL
import qualified Database.Selda.Column as C (Col)
import Control.Exception (Exception (..), try, throw)
import System.IO.Unsafe ( unsafePerformIO )
import Database.Selda.Types ( ColName, modColName, mkColName )
import Database.Selda.SqlType
    ( Lit, SqlType(sqlType, defaultValue, mkLit) )
import Database.Selda.SqlRow (SqlRow)
import Database.Selda.Table.Type
    ( ColAttr(Required, Optional), ColInfo(..) )
import Database.Selda.SQL (Param (..))
import Database.Selda.Exp (Exp (Col, Lit), UntypedCol (..))




-- | Any type which has a corresponding relation.
--   To make a @Relational@ instance for some type, simply derive 'Generic'.
--
--   Note that only types which have a single data constructor, and where all
--   fields are instances of 'SqlValue' can be used with this module.
--   Attempting to use functions in this module with any type which doesn't
--   obey those constraints will result in a very confusing type error.
type Relational a =
  ( Generic a
  , SqlRow a
  , GRelation (Rep a)
  )

-- | Extract all insert parameters from a generic value.
params :: Relational a => a -> [Either Param Param]
params :: forall a. Relational a => a -> [Either Param Param]
params = forall a. IO a -> a
unsafePerformIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a.
GRelation f =>
f a -> IO [Either Param Param]
gParams forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a x. Generic a => a -> Rep a x
from

-- | Extract all column names from the given type.
--   If the type is not a record, the columns will be named @col_1@,
--   @col_2@, etc.
tblCols :: forall a. Relational a => Proxy a -> (Text -> Text) -> [ColInfo]
tblCols :: forall a. Relational a => Proxy a -> (Text -> Text) -> [ColInfo]
tblCols Proxy a
_ Text -> Text
fieldMod =
    forall s a. State s a -> s -> a
evalState (forall (f :: * -> *).
GRelation f =>
Proxy f
-> Maybe ColName
-> (Int -> Maybe ColName -> ColName)
-> State Int [ColInfo]
gTblCols (forall {k} (t :: k). Proxy t
Proxy :: Proxy (Rep a)) forall a. Maybe a
Nothing Int -> Maybe ColName -> ColName
rename) Int
0
  where
    rename :: Int -> Maybe ColName -> ColName
rename Int
n Maybe ColName
Nothing     = Text -> ColName
mkColName forall a b. (a -> b) -> a -> b
$ Text -> Text
fieldMod (Text
"col_" forall a. Semigroup a => a -> a -> a
<> String -> Text
pack (forall a. Show a => a -> String
show Int
n))
    rename Int
_ (Just ColName
name) = ColName -> (Text -> Text) -> ColName
modColName ColName
name Text -> Text
fieldMod

-- | Exception indicating the use of a default value.
--   If any values throwing this during evaluation of @param xs@ will be
--   replaced by their default value.
data DefaultValueException = DefaultValueException
  deriving Int -> DefaultValueException -> ShowS
[DefaultValueException] -> ShowS
DefaultValueException -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DefaultValueException] -> ShowS
$cshowList :: [DefaultValueException] -> ShowS
show :: DefaultValueException -> String
$cshow :: DefaultValueException -> String
showsPrec :: Int -> DefaultValueException -> ShowS
$cshowsPrec :: Int -> DefaultValueException -> ShowS
Show
instance Exception DefaultValueException

-- | The default value for a column during insertion.
--   For an auto-incrementing primary key, the default value is the next key.
--
--   Using @def@ in any other context than insertion results in a runtime error.
def :: SqlType a => a
def :: forall a. SqlType a => a
def = forall a e. Exception e => e -> a
throw DefaultValueException
DefaultValueException

class GRelation f where
  -- | Generic worker for 'params'.
  gParams :: f a -> IO [Either Param Param]

  -- | Compute all columns needed to represent the given type.
  gTblCols :: Proxy f
           -> Maybe ColName
           -> (Int -> Maybe ColName -> ColName)
           -> State Int [ColInfo]

  -- | Create a new value with all default fields.
  gNew :: Proxy f -> [UntypedCol sql]

  -- | Create a new row from the given value.
  gRow :: f a -> [UntypedCol sql]

instance {-# OVERLAPPABLE #-} GRelation a => GRelation (M1 t c a) where
  gParams :: forall a. M1 t c a a -> IO [Either Param Param]
gParams (M1 a a
x) = forall (f :: * -> *) a.
GRelation f =>
f a -> IO [Either Param Param]
gParams a a
x
  gTblCols :: Proxy (M1 t c a)
-> Maybe ColName
-> (Int -> Maybe ColName -> ColName)
-> State Int [ColInfo]
gTblCols Proxy (M1 t c a)
_ = forall (f :: * -> *).
GRelation f =>
Proxy f
-> Maybe ColName
-> (Int -> Maybe ColName -> ColName)
-> State Int [ColInfo]
gTblCols (forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
  gNew :: forall sql. Proxy (M1 t c a) -> [UntypedCol sql]
gNew Proxy (M1 t c a)
_ = forall (f :: * -> *) sql.
GRelation f =>
Proxy f -> [UntypedCol sql]
gNew (forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
  gRow :: forall a sql. M1 t c a a -> [UntypedCol sql]
gRow (M1 a a
x) = forall (f :: * -> *) a sql. GRelation f => f a -> [UntypedCol sql]
gRow a a
x

instance {-# OVERLAPPING #-} (G.Selector c, GRelation a) =>
         GRelation (M1 S c a) where
  gParams :: forall a. M1 S c a a -> IO [Either Param Param]
gParams (M1 a a
x) = forall (f :: * -> *) a.
GRelation f =>
f a -> IO [Either Param Param]
gParams a a
x
  gTblCols :: Proxy (M1 S c a)
-> Maybe ColName
-> (Int -> Maybe ColName -> ColName)
-> State Int [ColInfo]
gTblCols Proxy (M1 S c a)
_ Maybe ColName
_ = forall (f :: * -> *).
GRelation f =>
Proxy f
-> Maybe ColName
-> (Int -> Maybe ColName -> ColName)
-> State Int [ColInfo]
gTblCols (forall {k} (t :: k). Proxy t
Proxy :: Proxy a) Maybe ColName
name
    where
      name :: Maybe ColName
name =
        case forall {k} (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
selName ((forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall a. HasCallStack => a
undefined) :: M1 S c a b) of
          String
"" -> forall a. Maybe a
Nothing
          String
s  -> forall a. a -> Maybe a
Just (Text -> ColName
mkColName forall a b. (a -> b) -> a -> b
$ String -> Text
pack String
s)
  gNew :: forall sql. Proxy (M1 S c a) -> [UntypedCol sql]
gNew Proxy (M1 S c a)
_ = forall (f :: * -> *) sql.
GRelation f =>
Proxy f -> [UntypedCol sql]
gNew (forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
  gRow :: forall a sql. M1 S c a a -> [UntypedCol sql]
gRow (M1 a a
x) = forall (f :: * -> *) a sql. GRelation f => f a -> [UntypedCol sql]
gRow a a
x

instance (Typeable a, SqlType a) => GRelation (K1 i a) where
  gParams :: forall a. K1 i a a -> IO [Either Param Param]
gParams (K1 a
x) = do
    Either DefaultValueException a
res <- forall e a. Exception e => IO a -> IO (Either e a)
try forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! a
x
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Either DefaultValueException a
res of
      Right a
x'                   -> [forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. Lit a -> Param
Param (forall a. SqlType a => a -> Lit a
mkLit a
x')]
      Left DefaultValueException
DefaultValueException -> [forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a. Lit a -> Param
Param (forall a. SqlType a => Lit a
defaultValue :: Lit a)]

  gTblCols :: Proxy (K1 i a)
-> Maybe ColName
-> (Int -> Maybe ColName -> ColName)
-> State Int [ColInfo]
gTblCols Proxy (K1 i a)
_ Maybe ColName
name Int -> Maybe ColName -> ColName
rename = do
    Int
n <- forall s (m :: * -> *). MonadState s m => m s
get
    forall s (m :: * -> *). MonadState s m => s -> m ()
put (Int
nforall a. Num a => a -> a -> a
+Int
1)
    let name' :: ColName
name' = Int -> Maybe ColName -> ColName
rename Int
n Maybe ColName
name
    forall (m :: * -> *) a. Monad m => a -> m a
return
      [ ColInfo
        { colName :: ColName
colName = ColName
name'
        , colType :: SqlTypeRep
colType = forall a. SqlType a => Proxy a -> SqlTypeRep
sqlType (forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
        , colAttrs :: [ColAttr]
colAttrs = [ColAttr]
optReq
        , colFKs :: [(Table (), ColName)]
colFKs = []
        , colExpr :: UntypedCol SQL
colExpr = forall sql a. Exp sql a -> UntypedCol sql
Untyped (forall sql a. ColName -> Exp sql a
Col ColName
name')
        }
      ]
    where
      -- workaround for GHC 8.2 not resolving overlapping instances properly
      maybeTyCon :: TyCon
maybeTyCon = TypeRep -> TyCon
typeRepTyCon (forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall {k} (t :: k). Proxy t
Proxy :: Proxy (Maybe ())))
      optReq :: [ColAttr]
optReq
        | TypeRep -> TyCon
typeRepTyCon (forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall {k} (t :: k). Proxy t
Proxy :: Proxy a)) forall a. Eq a => a -> a -> Bool
== TyCon
maybeTyCon = [ColAttr
Optional]
        | Bool
otherwise                                               = [ColAttr
Required]

  gNew :: forall sql. Proxy (K1 i a) -> [UntypedCol sql]
gNew Proxy (K1 i a)
_ = [forall sql a. Exp sql a -> UntypedCol sql
Untyped (forall a sql. Lit a -> Exp sql a
Lit (forall a. SqlType a => Lit a
defaultValue :: Lit a))]
  gRow :: forall a sql. K1 i a a -> [UntypedCol sql]
gRow (K1 a
x) = [forall sql a. Exp sql a -> UntypedCol sql
Untyped (forall a sql. Lit a -> Exp sql a
Lit (forall a. SqlType a => a -> Lit a
mkLit a
x))]

instance (GRelation a, GRelation b) => GRelation (a G.:*: b) where
  gParams :: forall a. (:*:) a b a -> IO [Either Param Param]
gParams (a a
a G.:*: b a
b) = forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 forall a. [a] -> [a] -> [a]
(++) (forall (f :: * -> *) a.
GRelation f =>
f a -> IO [Either Param Param]
gParams a a
a) (forall (f :: * -> *) a.
GRelation f =>
f a -> IO [Either Param Param]
gParams b a
b)
  gTblCols :: Proxy (a :*: b)
-> Maybe ColName
-> (Int -> Maybe ColName -> ColName)
-> State Int [ColInfo]
gTblCols Proxy (a :*: b)
_ Maybe ColName
_ Int -> Maybe ColName -> ColName
rename = do
      [ColInfo]
as <- forall (f :: * -> *).
GRelation f =>
Proxy f
-> Maybe ColName
-> (Int -> Maybe ColName -> ColName)
-> State Int [ColInfo]
gTblCols Proxy a
a forall a. Maybe a
Nothing Int -> Maybe ColName -> ColName
rename
      [ColInfo]
bs <- forall (f :: * -> *).
GRelation f =>
Proxy f
-> Maybe ColName
-> (Int -> Maybe ColName -> ColName)
-> State Int [ColInfo]
gTblCols Proxy b
b forall a. Maybe a
Nothing Int -> Maybe ColName -> ColName
rename
      forall (m :: * -> *) a. Monad m => a -> m a
return ([ColInfo]
as forall a. [a] -> [a] -> [a]
++ [ColInfo]
bs)
    where
      a :: Proxy a
a = forall {k} (t :: k). Proxy t
Proxy :: Proxy a
      b :: Proxy b
b = forall {k} (t :: k). Proxy t
Proxy :: Proxy b
  gNew :: forall sql. Proxy (a :*: b) -> [UntypedCol sql]
gNew Proxy (a :*: b)
_ = forall (f :: * -> *) sql.
GRelation f =>
Proxy f -> [UntypedCol sql]
gNew (forall {k} (t :: k). Proxy t
Proxy :: Proxy a) forall a. [a] -> [a] -> [a]
++ forall (f :: * -> *) sql.
GRelation f =>
Proxy f -> [UntypedCol sql]
gNew (forall {k} (t :: k). Proxy t
Proxy :: Proxy b)
  gRow :: forall a sql. (:*:) a b a -> [UntypedCol sql]
gRow (a a
a G.:*: b a
b) = forall (f :: * -> *) a sql. GRelation f => f a -> [UntypedCol sql]
gRow a a
a forall a. [a] -> [a] -> [a]
++ forall (f :: * -> *) a sql. GRelation f => f a -> [UntypedCol sql]
gRow b a
b

instance
  (TL.TypeError
    ( 'TL.Text "Selda currently does not support creating tables from sum types."
      'TL.:$$:
      'TL.Text "Restrict your table type to a single data constructor."
    )) => GRelation (a G.:+: b) where
  gParams :: forall a. (:+:) a b a -> IO [Either Param Param]
gParams = forall a. HasCallStack => String -> a
error String
"unreachable"
  gTblCols :: Proxy (a :+: b)
-> Maybe ColName
-> (Int -> Maybe ColName -> ColName)
-> State Int [ColInfo]
gTblCols = forall a. HasCallStack => String -> a
error String
"unreachable"
  gNew :: forall sql. Proxy (a :+: b) -> [UntypedCol sql]
gNew = forall a. HasCallStack => String -> a
error String
"unreachable"
  gRow :: forall a sql. (:+:) a b a -> [UntypedCol sql]
gRow = forall a. HasCallStack => String -> a
error String
"unreachable"

instance {-# OVERLAPS #-}
  (TL.TypeError
    ( 'TL.Text "Columns are now allowed to nest other columns."
      'TL.:$$:
      'TL.Text "Remove any fields of type 'Col s a' from your table type."
    )) => GRelation (K1 i (C.Col s a)) where
  gParams :: forall a. K1 i (Col s a) a -> IO [Either Param Param]
gParams = forall a. HasCallStack => String -> a
error String
"unreachable"
  gTblCols :: Proxy (K1 i (Col s a))
-> Maybe ColName
-> (Int -> Maybe ColName -> ColName)
-> State Int [ColInfo]
gTblCols = forall a. HasCallStack => String -> a
error String
"unreachable"
  gNew :: forall sql. Proxy (K1 i (Col s a)) -> [UntypedCol sql]
gNew = forall a. HasCallStack => String -> a
error String
"unreachable"
  gRow :: forall a sql. K1 i (Col s a) a -> [UntypedCol sql]
gRow = forall a. HasCallStack => String -> a
error String
"unreachable"