module Spark.Core.Internal.TypesGenerics where
import qualified Data.Vector as V
import Data.Text(Text, pack)
import Data.Proxy
import GHC.Generics
import Formatting
import Debug.Trace
import Spark.Core.Internal.TypesStructures
import Spark.Core.Internal.TypesFunctions
import Spark.Core.Internal.Utilities
import Spark.Core.StructuresInternal(FieldName(..), unsafeFieldName)
buildType :: (SQLTypeable a) => SQLType a
buildType = _buildType
class SQLTypeable a where
_genericTypeFromValue :: a -> GenericType
default _genericTypeFromValue :: (Generic a, GenSQLTypeable (Rep a)) => a -> GenericType
_genericTypeFromValue _ = genBuildType (Proxy :: Proxy a)
_buildType :: SQLType a
_buildType =
let !dt = _genericTypeFromValue (undefined :: a)
SQLType u = dt in SQLType u
data GenericRow
type GenericType = SQLType GenericRow
genBuildType :: forall a. (Generic a, GenSQLTypeable (Rep a)) => Proxy a -> GenericType
genBuildType _ = genTypeFromProxy (Proxy :: Proxy (Rep a))
instance SQLTypeable Int where
_genericTypeFromValue _ = SQLType (StrictType IntType)
instance SQLTypeable Text where
_genericTypeFromValue _ = SQLType (StrictType StringType)
instance SQLTypeable String where
_genericTypeFromValue _ = SQLType (StrictType StringType)
instance SQLTypeable a => SQLTypeable (Maybe a) where
_genericTypeFromValue _ = let SQLType dt = buildType :: (SQLType a) in
(SQLType . NullableType . iInnerStrictType) dt
instance SQLTypeable a => SQLTypeable [a] where
_genericTypeFromValue _ =
let SQLType dt = buildType :: (SQLType a) in
(SQLType . StrictType . ArrayType) dt
instance forall a1 a2. (
SQLTypeable a2,
SQLTypeable a1) => SQLTypeable (a1, a2) where
_genericTypeFromValue _ =
let
SQLType t1 = buildType :: SQLType a1
SQLType t2 = buildType :: SQLType a2
in _buildTupleStruct [t1, t2]
_buildTupleStruct :: [DataType] -> SQLType x
_buildTupleStruct dts =
let fnames = unsafeFieldName . pack. ("_" ++) . show <$> ([1..] :: [Int])
fs = uncurry StructField <$> zip fnames dts
in SQLType . StrictType . Struct . StructType $ V.fromList fs
class GenSQLTypeable a where
genTypeFromProxy :: Proxy a -> GenericType
instance GenSQLTypeable f => GenSQLTypeable (M1 D x f) where
genTypeFromProxy _ = genTypeFromProxy (Proxy :: Proxy f)
instance (GenSQLTypeable f, Constructor c) => GenSQLTypeable (M1 C c f) where
genTypeFromProxy _
| conIsRecord (undefined :: t c f a) =
let !dt = genTypeFromProxy (Proxy :: Proxy f) in
dt
| otherwise =
let !dt1 = genTypeFromProxy (Proxy :: Proxy f)
in case iSingleField (unSQLType dt1) of
Just dt -> SQLType dt
Nothing ->
failure $ sformat ("M1 C "%sh%" dt1="%sh) n dt1
where m = undefined :: t c f a
n = conName m
instance (GenSQLTypeable f, Selector c) => GenSQLTypeable (M1 S c f) where
genTypeFromProxy _ =
let !st = genTypeFromProxy (Proxy :: Proxy f)
m = undefined :: t c f a
n = selName m
SQLType innerdt = st
field = StructField { structFieldName = FieldName $ pack n, structFieldType = innerdt }
st2 = StructType (V.singleton field) in
SQLType (StrictType $ Struct st2)
instance (GenSQLTypeable (Rep f), SQLTypeable f) => GenSQLTypeable (K1 R f) where
genTypeFromProxy _ = _genericTypeFromValue (undefined :: f)
instance (GenSQLTypeable a, GenSQLTypeable b) => GenSQLTypeable (a :+: b) where
genTypeFromProxy _ =
let !y1 = genTypeFromProxy (Proxy :: Proxy a)
!y2 = genTypeFromProxy (Proxy :: Proxy b) in
trace ("SUM: y1=" ++ show y1 ++ " y2=" ++ show y2) y1
instance (GenSQLTypeable a, GenSQLTypeable b) => GenSQLTypeable (a :*: b) where
genTypeFromProxy _ =
let y1 = genTypeFromProxy (Proxy :: Proxy a)
y2 = genTypeFromProxy (Proxy :: Proxy b) in case (y1, y2) of
(SQLType (StrictType (Struct s1)), SQLType (StrictType (Struct s2))) ->
(SQLType . StrictType . Struct) s where
fs = structFields s1 V.++ structFields s2
s = StructType fs
_ -> failure $ sformat ("should not happen: left="%sh%" right="%sh) y1 y2
instance GenSQLTypeable U1 where
genTypeFromProxy _ = failure "U1"