From 42b45a1c20fe609e1cdf488969285e61f27b95c8 Mon Sep 17 00:00:00 2001 From: James Brechtel Date: Sat, 30 May 2026 07:04:00 -0400 Subject: [PATCH] Add comprehensive test suite: FieldDefinition, SqlMarshaller, EntityOperations, AutoMigration (53 tests) --- orville-sqlite.cabal | 8 +++ test/Main.hs | 91 +++-------------------- test/Test/AutoMigration.hs | 94 ++++++++++++++++++++++++ test/Test/EntityOperations.hs | 132 ++++++++++++++++++++++++++++++++++ test/Test/FieldDefinition.hs | 95 ++++++++++++++++++++++++ test/Test/Setup.hs | 106 +++++++++++++++++++++++++++ test/Test/SqlMarshaller.hs | 109 ++++++++++++++++++++++++++++ 7 files changed, 552 insertions(+), 83 deletions(-) create mode 100644 test/Test/AutoMigration.hs create mode 100644 test/Test/EntityOperations.hs create mode 100644 test/Test/FieldDefinition.hs create mode 100644 test/Test/Setup.hs create mode 100644 test/Test/SqlMarshaller.hs diff --git a/orville-sqlite.cabal b/orville-sqlite.cabal index f396140..f77047b 100644 --- a/orville-sqlite.cabal +++ b/orville-sqlite.cabal @@ -37,9 +37,17 @@ library test-suite spec type: exitcode-stdio-1.0 main-is: Main.hs + other-modules: + Test.Setup + Test.AutoMigration + Test.EntityOperations + Test.FieldDefinition + Test.SqlMarshaller hs-source-dirs: test build-depends: base >=4.17 && <5 + , bytestring + , direct-sqlite , mtl , orville-sqlite , hspec diff --git a/test/Main.hs b/test/Main.hs index 029b79f..8115f16 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -1,92 +1,17 @@ -{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} module Main where -import Control.Monad.IO.Class (liftIO) -import Data.Int (Int64) -import Data.Text (Text) -import Orville.SQLite import Test.Hspec -data Person = Person - { personId :: Int64 - , firstName :: Text - , lastName :: Text - , age :: Int64 - } - deriving (Show, Eq) - -personIdField :: FieldDefinition 'NotNull Int64 -personIdField = integerField "id" - -firstNameField :: FieldDefinition 'NotNull Text -firstNameField = textField "first_name" - -lastNameField :: FieldDefinition 'NotNull Text -lastNameField = textField "last_name" - -ageField :: FieldDefinition 'NotNull Int64 -ageField = integerField "age" - -personMarshaller :: SqlMarshaller Person Person -personMarshaller = - Person - <$> marshallReadOnlyField personIdField - <*> marshallField firstName firstNameField - <*> marshallField lastName lastNameField - <*> marshallField age ageField - -personTable :: TableDefinition Int64 Person Person -personTable = - mkTableDefinition "person" (primaryKey personId personIdField) personMarshaller +import qualified Test.AutoMigration as AutoMigration +import qualified Test.EntityOperations as EntityOperations +import qualified Test.FieldDefinition as FieldDefinition +import qualified Test.SqlMarshaller as SqlMarshaller main :: IO () main = hspec $ do - describe "Orville.SQLite" $ do - it "creates a table and inserts a row" $ do - db <- openConnection ":memory:" - withConnection db $ do - autoMigrateSchema defaultOptions [schemaTable personTable []] - insertEntity personTable (Person 0 "Alice" "Smith" 30) - mAlice <- findEntity personTable 1 - liftIO $ mAlice `shouldBe` Just (Person 1 "Alice" "Smith" 30) - closeConnection db - - it "finds all rows" $ do - db <- openConnection ":memory:" - withConnection db $ do - autoMigrateSchema defaultOptions [schemaTable personTable []] - insertEntity personTable (Person 0 "Alice" "Smith" 30) - insertEntity personTable (Person 0 "Bob" "Jones" 25) - results <- findAll personTable - liftIO $ length results `shouldBe` 2 - closeConnection db - - it "updates a row" $ do - db <- openConnection ":memory:" - withConnection db $ do - autoMigrateSchema defaultOptions [schemaTable personTable []] - insertEntity personTable (Person 0 "Alice" "Smith" 30) - updateEntity personTable (Person 1 "Alice" "Jones" 31) - mAlice <- findEntity personTable 1 - liftIO $ mAlice `shouldBe` Just (Person 1 "Alice" "Jones" 31) - closeConnection db - - it "deletes a row" $ do - db <- openConnection ":memory:" - withConnection db $ do - autoMigrateSchema defaultOptions [schemaTable personTable []] - insertEntity personTable (Person 0 "Alice" "Smith" 30) - deleteEntity personTable 1 - mAlice <- findEntity personTable 1 - liftIO $ mAlice `shouldBe` Nothing - closeConnection db - - it "returns Nothing for missing row" $ do - db <- openConnection ":memory:" - withConnection db $ do - autoMigrateSchema defaultOptions [schemaTable personTable []] - mAlice <- findEntity personTable 999 - liftIO $ mAlice `shouldBe` Nothing - closeConnection db + describe "FieldDefinition" FieldDefinition.fieldDefinitionTests + describe "SqlMarshaller" SqlMarshaller.sqlMarshallerTests + describe "EntityOperations" EntityOperations.entityOperationsTests + describe "AutoMigration" AutoMigration.autoMigrationTests diff --git a/test/Test/AutoMigration.hs b/test/Test/AutoMigration.hs new file mode 100644 index 0000000..07728e5 --- /dev/null +++ b/test/Test/AutoMigration.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Test.AutoMigration where + +import Control.Exception (SomeException, try) +import Control.Monad.IO.Class (liftIO) +import Data.Int (Int64) +import Test.Hspec + +import Orville.SQLite +import Test.Setup + +autoMigrationTests :: Spec +autoMigrationTests = do + describe "autoMigrateSchema" $ do + it "creates a table that does not exist" $ do + db <- openConnection ":memory:" + withConnection db $ do + autoMigrateSchema defaultOptions [schemaTable personTable []] + pure () + closeConnection db + + it "is idempotent — running twice does not error" $ do + db <- openConnection ":memory:" + withConnection db $ do + autoMigrateSchema defaultOptions [schemaTable personTable []] + autoMigrateSchema defaultOptions [schemaTable personTable []] + pure () + closeConnection db + + it "creates multiple tables at once" $ do + db <- openConnection ":memory:" + withConnection db $ do + autoMigrateSchema + defaultOptions + [ schemaTable personTable [] + , schemaTable widgetTable [] + ] + pure () + closeConnection db + + it "adds a new nullable column via ALTER TABLE" $ do + db <- openConnection ":memory:" + withConnection db $ do + autoMigrateSchema defaultOptions [existingTableSchema] + insertEntity widgetTable (Widget 1 "Test") + autoMigrateSchema defaultOptions [schemaTable widgetTable []] + mWidget <- findEntity widgetTable 1 + liftIO $ mWidget `shouldBe` Just (Widget 1 "Test") + closeConnection db + + it "attempting to use old marshaller after column drop fails" $ do + db <- openConnection ":memory:" + result <- liftIO $ try $ withConnection db $ do + autoMigrateSchema defaultOptions [schemaTable personTable []] + insertEntity personTable (Person 0 "Alice" "Smith" 30) + autoMigrateSchema defaultOptions [schemaTable personTable ["age"]] + -- This will fail because the marshaller still references the age column + findEntity personTable 1 + closeConnection db + liftIO $ + result `shouldSatisfy` \case + Left (_ :: SomeException) -> True + Right _ -> False + + it "dry run does not create tables" $ do + db <- openConnection ":memory:" + withConnection db $ do + autoMigrateSchema + defaultOptions{runSchemaChanges = False} + [schemaTable personTable []] + -- Migration is skipped; table should not exist + result <- + liftIO $ + try $ + withConnection db $ + insertEntity personTable (Person 0 "Alice" "Smith" 30) + liftIO $ + result `shouldSatisfy` \case + Left (_ :: SomeException) -> True + Right _ -> False + closeConnection db + +-- | Schema that only has widget_id (no label), representing an older version. +existingTableSchema :: SchemaItem +existingTableSchema = + let + marshaller = Widget <$> marshallField widgetId widgetIdField <*> marshallReadOnlyField widgetLabelField + tableDef = mkTableDefinition "widget" (primaryKey widgetId widgetIdField) marshaller + in + schemaTable tableDef [] diff --git a/test/Test/EntityOperations.hs b/test/Test/EntityOperations.hs new file mode 100644 index 0000000..e127bfe --- /dev/null +++ b/test/Test/EntityOperations.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} + +module Test.EntityOperations where + +import Control.Monad.IO.Class (liftIO) +import Data.Int (Int64) +import Data.Text (Text) +import Test.Hspec + +import Orville.SQLite +import Test.Setup + +entityOperationsTests :: Spec +entityOperationsTests = do + describe "insertEntity" $ do + it "inserts a row and returns via findEntity" $ do + let p = Person 0 "Alice" "Smith" 30 + mAlice <- withFreshDb personTable $ do + insertEntity personTable p + findEntity personTable 1 + liftIO $ mAlice `shouldBe` Just (Person 1 "Alice" "Smith" 30) + + it "assigns auto-increment ids sequentially" $ do + results <- withFreshDb personTable $ do + insertEntity personTable (Person 0 "A" "One" 20) + insertEntity personTable (Person 0 "B" "Two" 25) + insertEntity personTable (Person 0 "C" "Three" 30) + findAll personTable + liftIO $ map personId results `shouldBe` [1, 2, 3] + + it "inserts an entity with explicit PK (non-auto-increment)" $ do + let w = Widget 42 "TestWidget" + mWidget <- withFreshDb widgetTable $ do + insertEntity widgetTable w + findEntity widgetTable 42 + liftIO $ mWidget `shouldBe` Just w + + it "inserts an entity with a nullable field set to Just" $ do + let t = Task 0 "Buy groceries" (Just 15) + mTask <- withFreshDb taskTable $ do + insertEntity taskTable t + findEntity taskTable 1 + liftIO $ mTask `shouldBe` Just (Task 1 "Buy groceries" (Just 15)) + + it "inserts an entity with a nullable field set to Nothing" $ do + let t = Task 0 "No due date" Nothing + mTask <- withFreshDb taskTable $ do + insertEntity taskTable t + findEntity taskTable 1 + liftIO $ mTask `shouldBe` Just (Task 1 "No due date" Nothing) + + describe "findEntity" $ do + it "returns Nothing for a non-existent key" $ do + result <- + withFreshDb personTable $ + findEntity personTable 999 + liftIO $ result `shouldBe` Nothing + + it "returns Nothing on an empty table" $ do + result <- + withFreshDb personTable $ + findEntity personTable 1 + liftIO $ result `shouldBe` Nothing + + describe "findAll" $ do + it "returns all inserted rows" $ do + results <- withFreshDb personTable $ do + insertEntity personTable (Person 0 "Alice" "Smith" 30) + insertEntity personTable (Person 0 "Bob" "Jones" 25) + findAll personTable + liftIO $ length results `shouldBe` 2 + + it "returns empty list on empty table" $ do + results <- + withFreshDb personTable $ + findAll personTable + liftIO $ results `shouldBe` [] + + it "returns rows in insertion order" $ do + results <- withFreshDb personTable $ do + insertEntity personTable (Person 0 "First" "One" 10) + insertEntity personTable (Person 0 "Second" "Two" 20) + insertEntity personTable (Person 0 "Third" "Three" 30) + findAll personTable + liftIO $ map firstName results `shouldBe` ["First", "Second", "Third"] + + describe "updateEntity" $ do + it "updates a row and returns via findEntity" $ do + result <- withFreshDb personTable $ do + insertEntity personTable (Person 0 "Alice" "Smith" 30) + updateEntity personTable (Person 1 "Alice" "Jones" 31) + findEntity personTable 1 + liftIO $ result `shouldBe` Just (Person 1 "Alice" "Jones" 31) + + it "updates a widget with explicit PK" $ do + result <- withFreshDb widgetTable $ do + insertEntity widgetTable (Widget 10 "OldLabel") + updateEntity widgetTable (Widget 10 "NewLabel") + findEntity widgetTable 10 + liftIO $ result `shouldBe` Just (Widget 10 "NewLabel") + + it "does not affect other rows" $ do + results <- withFreshDb personTable $ do + insertEntity personTable (Person 0 "Alice" "Smith" 30) + insertEntity personTable (Person 0 "Bob" "Jones" 25) + updateEntity personTable (Person 1 "Alice" "Updated" 99) + findAll personTable + liftIO $ map firstName results `shouldBe` ["Alice", "Bob"] + + describe "deleteEntity" $ do + it "deletes a row" $ do + result <- withFreshDb personTable $ do + insertEntity personTable (Person 0 "Alice" "Smith" 30) + deleteEntity personTable 1 + findEntity personTable 1 + liftIO $ result `shouldBe` Nothing + + it "does not delete other rows" $ do + results <- withFreshDb personTable $ do + insertEntity personTable (Person 0 "Alice" "Smith" 30) + insertEntity personTable (Person 0 "Bob" "Jones" 25) + deleteEntity personTable 1 + findAll personTable + liftIO $ map firstName results `shouldBe` ["Bob"] + + it "deleting non-existent key does nothing" $ do + results <- withFreshDb personTable $ do + insertEntity personTable (Person 0 "Alice" "Smith" 30) + deleteEntity personTable 999 + findAll personTable + liftIO $ length results `shouldBe` 1 diff --git a/test/Test/FieldDefinition.hs b/test/Test/FieldDefinition.hs new file mode 100644 index 0000000..2a301b0 --- /dev/null +++ b/test/Test/FieldDefinition.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Test.FieldDefinition where + +import qualified Data.ByteString as BS +import Data.Int (Int64) +import qualified Data.Text as T +import Test.Hspec + +import qualified Database.SQLite3 as SQLite3 +import Orville.SQLite + +fieldDefinitionTests :: Spec +fieldDefinitionTests = do + describe "integerField" $ do + it "roundtrips encode/decode" $ do + let fd = integerField "count" + let val = 42 :: Int64 + fieldFromSqlValue (fieldToSqlValue val fd) fd `shouldBe` Right val + + it "encodes to SQLInteger" $ do + let fd = integerField "count" + fieldToSqlValue 99 fd `shouldBe` SQLite3.SQLInteger 99 + + it "decodes from SQLInteger" $ do + let fd = integerField "count" + fieldFromSqlValue (SQLite3.SQLInteger 99) fd `shouldBe` Right 99 + + describe "textField" $ do + it "roundtrips encode/decode" $ do + let fd = textField "name" + let val = "Hello" :: T.Text + fieldFromSqlValue (fieldToSqlValue val fd) fd `shouldBe` Right val + + it "encodes to SQLText" $ do + let fd = textField "name" + fieldToSqlValue "test" fd `shouldBe` SQLite3.SQLText "test" + + it "decodes from SQLText" $ do + let fd = textField "name" + fieldFromSqlValue (SQLite3.SQLText "decoded") fd `shouldBe` Right ("decoded" :: T.Text) + + describe "realField" $ do + it "roundtrips encode/decode" $ do + let fd = realField "price" + let val = 3.14 :: Double + fieldFromSqlValue (fieldToSqlValue val fd) fd `shouldBe` Right val + + it "encodes to SQLFloat" $ do + let fd = realField "price" + fieldToSqlValue 2.718 fd `shouldBe` SQLite3.SQLFloat 2.718 + + describe "blobField" $ do + it "roundtrips encode/decode" $ do + let fd = blobField "data" + let val = "binary\0stuff" :: BS.ByteString + fieldFromSqlValue (fieldToSqlValue val fd) fd `shouldBe` Right val + + describe "nullableField" $ do + it "is marked as nullable" $ do + let fd = nullableField (integerField "opt") + fieldIsNullable fd `shouldBe` True + + it "retains the column name" $ do + let fd = nullableField (textField "notes") + fieldColumnName fd `shouldBe` "notes" + + describe "convertField" $ do + it "converts between types" $ do + let fd = integerField "count" + let converted = convertField show (read @Int64) fd :: FieldDefinition 'NotNull String + fieldFromSqlValue (SQLite3.SQLInteger 123) converted `shouldBe` Right "123" + + describe "fieldColumnName" $ do + it "returns the column name for non-null field" $ do + fieldColumnName (integerField "my_col") `shouldBe` "my_col" + + it "returns the column name for nullable field" $ do + fieldColumnName (nullableField (textField "opt_col")) `shouldBe` "opt_col" + + describe "fieldSqlTypeName" $ do + it "returns INTEGER for integerField" $ do + fieldSqlTypeName (integerField "x") `shouldBe` "INTEGER" + + it "returns TEXT for textField" $ do + fieldSqlTypeName (textField "x") `shouldBe` "TEXT" + + it "returns REAL for realField" $ do + fieldSqlTypeName (realField "x") `shouldBe` "REAL" + + it "returns BLOB for blobField" $ do + fieldSqlTypeName (blobField "x") `shouldBe` "BLOB" diff --git a/test/Test/Setup.hs b/test/Test/Setup.hs new file mode 100644 index 0000000..0c91f2a --- /dev/null +++ b/test/Test/Setup.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE DataKinds #-} + +module Test.Setup where + +import Data.Int (Int64) +import Data.Text (Text) + +import Orville.SQLite + +{- | A simple entity for testing, with an auto-increment primary key. +The PK (personId) is read-only — SQLite populates it via INTEGER PRIMARY KEY. +-} +data Person = Person + { personId :: Int64 + , firstName :: Text + , lastName :: Text + , age :: Int64 + } + deriving (Show, Eq) + +personIdField :: FieldDefinition 'NotNull Int64 +personIdField = integerField "id" + +firstNameField :: FieldDefinition 'NotNull Text +firstNameField = textField "first_name" + +lastNameField :: FieldDefinition 'NotNull Text +lastNameField = textField "last_name" + +ageField :: FieldDefinition 'NotNull Int64 +ageField = integerField "age" + +personMarshaller :: SqlMarshaller Person Person +personMarshaller = + Person + <$> marshallReadOnlyField personIdField + <*> marshallField firstName firstNameField + <*> marshallField lastName lastNameField + <*> marshallField age ageField + +personTable :: TableDefinition Int64 Person Person +personTable = + mkTableDefinition "person" (primaryKey personId personIdField) personMarshaller + +-- | An entity where the PK is part of the write entity (not auto-increment). +data Widget = Widget + { widgetId :: Int64 + , widgetLabel :: Text + } + deriving (Show, Eq) + +widgetIdField :: FieldDefinition 'NotNull Int64 +widgetIdField = integerField "widget_id" + +widgetLabelField :: FieldDefinition 'NotNull Text +widgetLabelField = textField "label" + +widgetMarshaller :: SqlMarshaller Widget Widget +widgetMarshaller = + Widget + <$> marshallField widgetId widgetIdField + <*> marshallField widgetLabel widgetLabelField + +widgetTable :: TableDefinition Int64 Widget Widget +widgetTable = + mkTableDefinition "widget" (primaryKey widgetId widgetIdField) widgetMarshaller + +-- | An entity with a nullable field. +data Task = Task + { taskId :: Int64 + , taskDescription :: Text + , taskDueDay :: Maybe Int64 + } + deriving (Show, Eq) + +taskIdField :: FieldDefinition 'NotNull Int64 +taskIdField = integerField "task_id" + +taskDescriptionField :: FieldDefinition 'NotNull Text +taskDescriptionField = textField "description" + +taskDueDayField :: FieldDefinition 'Nullable Int64 +taskDueDayField = nullableField (integerField "due_day") + +taskMarshaller :: SqlMarshaller Task Task +taskMarshaller = + Task + <$> marshallReadOnlyField taskIdField + <*> marshallField taskDescription taskDescriptionField + <*> marshallMaybe taskDueDay taskDueDayField + +taskTable :: TableDefinition Int64 Task Task +taskTable = + mkTableDefinition "task" (primaryKey taskId taskIdField) taskMarshaller + +{- | Run an OrvilleM action against a fresh in-memory database, +with the given table created via auto-migration. +-} +withFreshDb :: TableDefinition key w r -> OrvilleM a -> IO a +withFreshDb tableDef action = do + db <- openConnection ":memory:" + result <- withConnection db $ do + autoMigrateSchema defaultOptions [schemaTable tableDef []] + action + closeConnection db + pure result diff --git a/test/Test/SqlMarshaller.hs b/test/Test/SqlMarshaller.hs new file mode 100644 index 0000000..2bf356e --- /dev/null +++ b/test/Test/SqlMarshaller.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module Test.SqlMarshaller where + +import Data.Int (Int64) +import qualified Data.Text as T +import Test.Hspec + +import qualified Database.SQLite3 as SQLite3 +import Orville.SQLite +import Test.Setup + +sqlMarshallerTests :: Spec +sqlMarshallerTests = do + describe "marshallerFieldInfo" $ do + it "enumerates all fields including read-only" $ do + let info = marshallerFieldInfo personMarshaller + map fieldInfoName info `shouldBe` ["age", "last_name", "first_name", "id"] + + it "reports correct types" $ do + let info = marshallerFieldInfo personMarshaller + let types = [(fieldInfoName i, fieldInfoType i) | i <- info] + lookup "id" types `shouldBe` Just "INTEGER" + lookup "first_name" types `shouldBe` Just "TEXT" + lookup "last_name" types `shouldBe` Just "TEXT" + lookup "age" types `shouldBe` Just "INTEGER" + + describe "marshallerDerivedColumns" $ do + it "lists all column names" $ do + let cols = marshallerDerivedColumns personMarshaller + length cols `shouldBe` 4 + + describe "marshallerEncodeWrite" $ do + it "excludes read-only fields" $ do + let p = Person 0 "Alice" "Smith" 30 + let pairs = marshallerEncodeWrite personMarshaller p + let names = map fst pairs + names `shouldNotContain` ["id"] + + it "includes all write fields" $ do + let p = Person 0 "Alice" "Smith" 30 + let pairs = marshallerEncodeWrite personMarshaller p + let names = map fst pairs + names `shouldBe` ["age", "last_name", "first_name"] + + it "encodes correct values" $ do + let p = Person 0 "Alice" "Smith" 30 + let pairs = marshallerEncodeWrite personMarshaller p + lookup "first_name" pairs `shouldBe` Just (SQLite3.SQLText "Alice") + lookup "last_name" pairs `shouldBe` Just (SQLite3.SQLText "Smith") + lookup "age" pairs `shouldBe` Just (SQLite3.SQLInteger 30) + + it "encodes nullable field as SQLNull when Nothing" $ do + let t = Task 0 "No due" Nothing + let pairs = marshallerEncodeWrite taskMarshaller t + lookup "due_day" pairs `shouldBe` Just SQLite3.SQLNull + + it "encodes nullable field as SQLInteger when Just" $ do + let t = Task 0 "Has due" (Just 10) + let pairs = marshallerEncodeWrite taskMarshaller t + lookup "due_day" pairs `shouldBe` Just (SQLite3.SQLInteger 10) + + describe "marshallerDecodeRow" $ do + it "decodes a complete row" $ do + let row = + [ ("id", SQLite3.SQLInteger 1) + , ("first_name", SQLite3.SQLText "Alice") + , ("last_name", SQLite3.SQLText "Smith") + , ("age", SQLite3.SQLInteger 30) + ] + marshallerDecodeRow personMarshaller row `shouldBe` Right (Person 1 "Alice" "Smith" 30) + + it "reports missing column" $ do + let row = + [ ("first_name", SQLite3.SQLText "Alice") + , ("last_name", SQLite3.SQLText "Smith") + , ("age", SQLite3.SQLInteger 30) + ] + marshallerDecodeRow personMarshaller row `shouldSatisfy` \case + Left e -> "id" `T.isInfixOf` T.pack e + Right _ -> False + + describe "marshallReadOnlyField" $ do + it "is included in decode but excluded from encode" $ do + let p = Person 0 "Alice" "Smith" 30 + let pairs = marshallerEncodeWrite personMarshaller p + let colNames = marshallerDerivedColumns personMarshaller + colNames `shouldContain` ["id"] -- id appears in SELECT + map fst pairs `shouldNotContain` ["id"] -- id not in INSERT values + describe "marshallMaybe" $ do + it "decodes SQLNull as Nothing" $ do + let row = + [ ("task_id", SQLite3.SQLInteger 1) + , ("description", SQLite3.SQLText "Test") + , ("due_day", SQLite3.SQLNull) + ] + marshallerDecodeRow taskMarshaller row + `shouldBe` Right (Task 1 "Test" Nothing) + + it "decodes SQLInteger as Just" $ do + let row = + [ ("task_id", SQLite3.SQLInteger 1) + , ("description", SQLite3.SQLText "Test") + , ("due_day", SQLite3.SQLInteger 25) + ] + marshallerDecodeRow taskMarshaller row + `shouldBe` Right (Task 1 "Test" (Just 25))