module Spark.Core.Internal.TypesGenerics where
import qualified Data.Vector as V
import qualified Data.Text as T
import GHC.Generics
import Formatting
import Spark.Core.Internal.TypesStructures
import Spark.Core.Internal.TypesFunctions
import Spark.Core.Internal.Utilities
import Spark.Core.StructuresInternal(FieldName(..), unsafeFieldName)
import Spark.Core.Internal.TypesStructuresRepr(DataTypeRepr, DataTypeElementRepr)
buildType :: (HasCallStack, SQLTypeable a) => SQLType a
buildType = _buildType
class SQLTypeable a where
_genericTypeFromValue :: (HasCallStack) => a -> GenericType
default _genericTypeFromValue :: (HasCallStack, Generic a, GenSQLTypeable (Rep a)) => a -> GenericType
_genericTypeFromValue x = genTypeFromProxy (from x)
class GenSQLTypeable f where
genTypeFromProxy :: (HasCallStack) => f a -> GenericType
_buildType :: forall a. (HasCallStack, SQLTypeable a) => SQLType a
_buildType =
let dt = _genericTypeFromValue (undefined :: a)
in SQLType dt
type GenericType = DataType
instance SQLTypeable Int where
_genericTypeFromValue _ = StrictType IntType
instance SQLTypeable Double where
_genericTypeFromValue _ = StrictType DoubleType
instance SQLTypeable T.Text where
_genericTypeFromValue _ = StrictType StringType
instance SQLTypeable Bool where
_genericTypeFromValue _ = StrictType BoolType
instance SQLTypeable DataTypeRepr
instance SQLTypeable DataTypeElementRepr
instance SQLTypeable DataType where
_genericTypeFromValue _ = _genericTypeFromValue (undefined :: DataTypeRepr)
instance SQLTypeable a => SQLTypeable (Maybe a) where
_genericTypeFromValue _ = let SQLType dt = buildType :: (SQLType a) in
(NullableType . iInnerStrictType) dt
instance SQLTypeable a => SQLTypeable [a] where
_genericTypeFromValue _ =
let SQLType dt = buildType :: (SQLType a) in
(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 :: [GenericType] -> GenericType
_buildTupleStruct dts =
let fnames = unsafeFieldName . T.pack. ("_" ++) . show <$> ([1..] :: [Int])
fs = uncurry StructField <$> zip fnames dts
in StrictType . Struct . StructType $ V.fromList fs
instance (GenSQLTypeable f) => GenSQLTypeable (M1 D c f) where
genTypeFromProxy m = genTypeFromProxy (unM1 m)
instance (GenSQLTypeable f, Constructor c) => GenSQLTypeable (M1 C c f) where
genTypeFromProxy m
| conIsRecord m =
let x = unM1 m
dt = genTypeFromProxy x in
dt
| otherwise =
let !dt1 = genTypeFromProxy (unM1 m)
in case iSingleField dt1 of
Just dt -> dt
Nothing ->
failure $ sformat ("M1 C "%sh%" dt1="%sh) n dt1
where n = conName m
instance (GenSQLTypeable f, Selector c) => GenSQLTypeable (M1 S c f) where
genTypeFromProxy m =
let st = genTypeFromProxy (unM1 m)
n = selName m
field = StructField { structFieldName = FieldName $ T.pack n, structFieldType = st }
st2 = StructType (V.singleton field) in
StrictType $ Struct st2
instance (SQLTypeable a) => GenSQLTypeable (K1 R a) where
genTypeFromProxy m = _genericTypeFromValue (unK1 m)
instance (GenSQLTypeable a, GenSQLTypeable b) => GenSQLTypeable (a :+: b) where
genTypeFromProxy (L1 x) = genTypeFromProxy x
genTypeFromProxy (R1 x) = genTypeFromProxy x
instance (GenSQLTypeable a, GenSQLTypeable b) => GenSQLTypeable (a :*: b) where
genTypeFromProxy z =
let (x1 :*: x2) = z
y1 = genTypeFromProxy x1
y2 = genTypeFromProxy x2 in case (y1, y2) of
(StrictType (Struct s1), StrictType (Struct s2)) ->
(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"