diff --git a/orville-sqlite.cabal b/orville-sqlite.cabal index 05dd766..75bb81e 100644 --- a/orville-sqlite.cabal +++ b/orville-sqlite.cabal @@ -15,8 +15,10 @@ build-type: Simple library exposed-modules: + Orville.SQLite.FieldDefinition Orville.SQLite.Monad Orville.SQLite.RawSql + Orville.SQLite.SqlType hs-source-dirs: src build-depends: base >=4.17 && <5 diff --git a/src/Orville/SQLite/FieldDefinition.hs b/src/Orville/SQLite/FieldDefinition.hs new file mode 100644 index 0000000..b9d5ec1 --- /dev/null +++ b/src/Orville/SQLite/FieldDefinition.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} + +module Orville.SQLite.FieldDefinition + ( Nullability (..) + , FieldDefinition (..) + , integerField + , textField + , realField + , blobField + , nullableField + , convertField + , fieldToSqlValue + , fieldFromSqlValue + , fieldColumnName + , fieldSqlTypeName + , fieldIsNullable + ) where + +import Data.Kind (Type) +import qualified Data.ByteString as BS +import Data.Int (Int64) +import qualified Data.Text as T +import qualified Database.SQLite3 as SQLite3 +import Orville.SQLite.SqlType + ( SqlType + , convertSqlType + , integerType + , realType + , blobType + , sqlTypeFromSql + , sqlTypeName + , sqlTypeToSql + , textType + ) + +data Nullability = NotNull | Nullable + +data FieldDefinition (nullability :: Nullability) :: Type -> Type where + NotNullField :: + { notNullFieldName :: String + , notNullFieldSqlType :: SqlType a + } -> FieldDefinition 'NotNull a + NullableField :: + { nullableFieldName :: String + , nullableFieldSqlType :: SqlType a + } -> FieldDefinition 'Nullable a + +fieldColumnName :: FieldDefinition null a -> String +fieldColumnName = \case + NotNullField n _ -> n + NullableField n _ -> n + +fieldSqlTypeName :: FieldDefinition null a -> String +fieldSqlTypeName = \case + NotNullField _ st -> sqlTypeName st + NullableField _ st -> sqlTypeName st + +fieldIsNullable :: FieldDefinition null a -> Bool +fieldIsNullable = \case + NotNullField _ _ -> False + NullableField _ _ -> True + +fieldToSqlValue :: a -> FieldDefinition null a -> SQLite3.SQLData +fieldToSqlValue val = \case + NotNullField _ st -> sqlTypeToSql st val + NullableField _ st -> sqlTypeToSql st val + +fieldFromSqlValue :: SQLite3.SQLData -> FieldDefinition null a -> Either String a +fieldFromSqlValue sqlVal = \case + NotNullField _ st -> sqlTypeFromSql st sqlVal + NullableField _ st -> sqlTypeFromSql st sqlVal + +integerField :: String -> FieldDefinition 'NotNull Int64 +integerField name = NotNullField name integerType + +textField :: String -> FieldDefinition 'NotNull T.Text +textField name = NotNullField name textType + +realField :: String -> FieldDefinition 'NotNull Double +realField name = NotNullField name realType + +blobField :: String -> FieldDefinition 'NotNull BS.ByteString +blobField name = NotNullField name blobType + +nullableField :: FieldDefinition 'NotNull a -> FieldDefinition 'Nullable a +nullableField = \case + NotNullField n st -> NullableField n st + +convertField :: + (a -> b) -> + (b -> a) -> + FieldDefinition null a -> + FieldDefinition null b +convertField to from = \case + NotNullField n st -> NotNullField n (convertSqlType to from st) + NullableField n st -> NullableField n (convertSqlType to from st) diff --git a/src/Orville/SQLite/SqlType.hs b/src/Orville/SQLite/SqlType.hs new file mode 100644 index 0000000..3d68f64 --- /dev/null +++ b/src/Orville/SQLite/SqlType.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE LambdaCase #-} + +module Orville.SQLite.SqlType + ( SqlType (..) + , integerType + , textType + , realType + , blobType + , convertSqlType + ) where + +import qualified Data.ByteString as BS +import Data.Int (Int64) +import qualified Data.Text as T +import qualified Database.SQLite3 as SQLite3 + +data SqlType a = SqlType + { sqlTypeName :: String + , sqlTypeToSql :: a -> SQLite3.SQLData + , sqlTypeFromSql :: SQLite3.SQLData -> Either String a + } + +integerType :: SqlType Int64 +integerType = + SqlType + { sqlTypeName = "INTEGER" + , sqlTypeToSql = SQLite3.SQLInteger + , sqlTypeFromSql = \case + SQLite3.SQLInteger i -> Right i + SQLite3.SQLNull -> Right 0 + other -> Left $ "Expected INTEGER, got " <> show (sqlDataKind other) + } + +textType :: SqlType T.Text +textType = + SqlType + { sqlTypeName = "TEXT" + , sqlTypeToSql = SQLite3.SQLText + , sqlTypeFromSql = \case + SQLite3.SQLText t -> Right t + SQLite3.SQLNull -> Right T.empty + SQLite3.SQLInteger i -> Right (T.pack (show i)) + SQLite3.SQLFloat d -> Right (T.pack (show d)) + other -> Left $ "Expected TEXT, got " <> show (sqlDataKind other) + } + +realType :: SqlType Double +realType = + SqlType + { sqlTypeName = "REAL" + , sqlTypeToSql = SQLite3.SQLFloat + , sqlTypeFromSql = \case + SQLite3.SQLFloat d -> Right d + SQLite3.SQLInteger i -> Right (fromIntegral i) + SQLite3.SQLNull -> Right 0.0 + other -> Left $ "Expected REAL, got " <> show (sqlDataKind other) + } + +blobType :: SqlType BS.ByteString +blobType = + SqlType + { sqlTypeName = "BLOB" + , sqlTypeToSql = SQLite3.SQLBlob + , sqlTypeFromSql = \case + SQLite3.SQLBlob b -> Right b + SQLite3.SQLNull -> Right BS.empty + other -> Left $ "Expected BLOB, got " <> show (sqlDataKind other) + } + +convertSqlType :: (a -> b) -> (b -> a) -> SqlType a -> SqlType b +convertSqlType to from sqlType = + SqlType + { sqlTypeName = sqlTypeName sqlType + , sqlTypeToSql = sqlTypeToSql sqlType . from + , sqlTypeFromSql = fmap to . sqlTypeFromSql sqlType + } + +sqlDataKind :: SQLite3.SQLData -> String +sqlDataKind = \case + SQLite3.SQLInteger _ -> "SQLInteger" + SQLite3.SQLFloat _ -> "SQLFloat" + SQLite3.SQLText _ -> "SQLText" + SQLite3.SQLBlob _ -> "SQLBlob" + SQLite3.SQLNull -> "SQLNull"