Add SqlType and FieldDefinition modules

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

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)

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"