diff --git a/duckdb-simple.cabal b/duckdb-simple.cabal --- a/duckdb-simple.cabal +++ b/duckdb-simple.cabal @@ -1,6 +1,6 @@ cabal-version: 3.4 name: duckdb-simple -version: 0.1.0.0 +version: 0.1.1.0 license: MPL-2.0 license-file: LICENSE author: Matthias Pall Gissurarson @@ -42,7 +42,7 @@ build-depends: base >=4.14 && <5 , bytestring >= 0.11 && <0.12 - , duckdb-ffi >= 0.1.4 && <0.1.5 + , duckdb-ffi >= 1.4 && <1.5 , text >= 2.0 && <2.1 , transformers >= 0.6 && <0.7 , time >= 1.12 && <1.13 diff --git a/src/Database/DuckDB/Simple/FromField.hs b/src/Database/DuckDB/Simple/FromField.hs --- a/src/Database/DuckDB/Simple/FromField.hs +++ b/src/Database/DuckDB/Simple/FromField.hs @@ -17,7 +17,7 @@ ResultError (..), FieldParser, FromField (..), - left + returnError ) where import Control.Exception (Exception, SomeException (..)) @@ -96,15 +96,18 @@ -- | Exception thrown if conversion from a SQL value to a Haskell -- value fails. data ResultError = Incompatible { errSQLType :: Text + , errSQLField :: Text , errHaskellType :: Text , errMessage :: Text } -- ^ The SQL and Haskell types are not compatible. | UnexpectedNull { errSQLType :: Text + , errSQLField :: Text , errHaskellType :: Text , errMessage :: Text } -- ^ A SQL @NULL@ was encountered when the Haskell -- type did not permit it. | ConversionFailed { errSQLType :: Text + , errSQLField :: Text , errHaskellType :: Text , errMessage :: Text } -- ^ The SQL value could not be parsed, or could not @@ -115,9 +118,6 @@ instance Exception ResultError --- From sqlite-simple: -left :: Exception a => a -> Ok b -left = Errors . (:[]) . SomeException -- | Parser used by 'FromField' instances and utilities such as @@ -135,102 +135,105 @@ fromField Field{fieldValue} = Ok fieldValue instance FromField Null where - fromField Field{fieldValue} = + fromField f@Field{fieldValue} = case fieldValue of FieldNull -> Ok Null - other -> left (Incompatible (fieldValueTypeName other) "Null" "expected NULL") + _ -> returnError Incompatible f "expected NULL" instance FromField Bool where - fromField Field{fieldValue} = + fromField f@Field{fieldValue} = case fieldValue of FieldBool b -> Ok b FieldInt i -> Ok (i /= 0) - other -> left (Incompatible (fieldValueTypeName other) "Bool" "invalid type for boolean") + FieldNull -> returnError UnexpectedNull f "" + _ -> returnError Incompatible f "" instance FromField Int8 where - fromField Field{fieldValue} = + fromField f@Field{fieldValue} = case fieldValue of FieldInt i -> Ok (fromIntegral i) - other -> left (Incompatible (fieldValueTypeName other) "Int8" "invalid type for Int8") + FieldNull -> returnError UnexpectedNull f "" + _ -> returnError Incompatible f "" instance FromField Int64 where - fromField Field{fieldValue} = + fromField f@Field{fieldValue} = case fieldValue of FieldInt i -> Ok (fromIntegral i) - other -> left (Incompatible (fieldValueTypeName other) "Int64" "invalid type for Int64") + FieldNull -> returnError UnexpectedNull f "" + _ -> returnError Incompatible f "" instance FromField Int32 where - fromField field@Field{fieldValue} = + fromField f@Field{fieldValue} = case fieldValue of - FieldInt i -> boundedIntegral field i - other -> left (Incompatible (fieldValueTypeName other) "Int32" "invalid type for integer") + FieldInt i -> boundedIntegral f i + FieldNull -> returnError UnexpectedNull f "" + _ -> returnError Incompatible f "" instance FromField Int16 where - fromField field@Field{fieldValue} = + fromField f@Field{fieldValue} = case fieldValue of - FieldInt i -> boundedIntegral field i - other -> left (Incompatible (fieldValueTypeName other) "Int16" "invalid type for integer") + FieldInt i -> boundedIntegral f i + FieldNull -> returnError UnexpectedNull f "" + _ -> returnError Incompatible f "" instance FromField Int where - fromField field@Field{fieldValue} = + fromField f@Field{fieldValue} = case fieldValue of - FieldInt i -> boundedIntegral field i - other -> left (Incompatible (fieldValueTypeName other) "Int" "invalid type for integer") + FieldInt i -> boundedIntegral f i + FieldNull -> returnError UnexpectedNull f "" + _ -> returnError Incompatible f "" instance FromField Word64 where - fromField Field{fieldValue} = + fromField f@Field{fieldValue} = case fieldValue of FieldInt i | i >= 0 -> Ok (fromIntegral i) | otherwise -> - left $ - ConversionFailed (fieldValueTypeName fieldValue) "Word64" $ - Text.pack "negative value cannot be converted to unsigned integer" + returnError ConversionFailed f "negative value cannot be converted to unsigned integer" FieldWord w -> Ok (fromIntegral w) - other -> left (Incompatible (fieldValueTypeName other) "Word64" "invalid type for Word64") + FieldNull -> returnError UnexpectedNull f "" + _ -> returnError Incompatible f "" instance FromField Word32 where - fromField field@Field{fieldValue} = + fromField f@Field{fieldValue} = case fieldValue of FieldInt i - | i >= 0 -> boundedIntegral field i + | i >= 0 -> boundedIntegral f i | otherwise -> - left $ - ConversionFailed (fieldValueTypeName fieldValue) "Word32" $ - Text.pack "negative value cannot be converted to unsigned integer" + returnError ConversionFailed f "negative value cannot be converted to unsigned integer" FieldWord w -> Ok (fromIntegral w) - other -> left (Incompatible (fieldValueTypeName other) "Word32" "invalid type for Word32") + FieldNull -> returnError UnexpectedNull f "" + _ -> returnError Incompatible f "" instance FromField Word16 where - fromField field@Field{fieldValue} = + fromField f@Field{fieldValue} = case fieldValue of FieldInt i - | i >= 0 -> boundedIntegral field i + | i >= 0 -> boundedIntegral f i | otherwise -> - left $ - ConversionFailed (fieldValueTypeName fieldValue) "Word16" $ - Text.pack "negative value cannot be converted to unsigned integer" + returnError ConversionFailed f "negative value cannot be converted to unsigned integer" FieldWord w -> Ok (fromIntegral w) - other -> left (Incompatible (fieldValueTypeName other) "Word16" "invalid type for Word16") + FieldNull -> returnError UnexpectedNull f "" + _ -> returnError Incompatible f "" instance FromField Word8 where - fromField field@Field{fieldValue} = + fromField f@Field{fieldValue} = case fieldValue of FieldInt i - | i >= 0 -> boundedIntegral field i + | i >= 0 -> boundedIntegral f i | otherwise -> - left $ - ConversionFailed (fieldValueTypeName fieldValue) "Word8" $ - Text.pack "negative value cannot be converted to unsigned integer" + returnError ConversionFailed f "negative value cannot be converted to unsigned integer" FieldWord w -> Ok (fromIntegral w) - other -> left (Incompatible (fieldValueTypeName other) "Word8" "invalid type for Word8") + FieldNull -> returnError UnexpectedNull f "" + _ -> returnError Incompatible f "" instance FromField Double where - fromField Field{fieldValue} = + fromField f@Field{fieldValue} = case fieldValue of FieldDouble d -> Ok d FieldInt i -> Ok (fromIntegral i) - other -> left (Incompatible (fieldValueTypeName other) "Double" "invalid type for double") + FieldNull -> returnError UnexpectedNull f "" + _ -> returnError Incompatible f "" instance FromField Float where fromField field = @@ -239,48 +242,49 @@ Ok d -> Ok (realToFrac d) instance FromField Text where - fromField Field{fieldValue} = + fromField f@Field{fieldValue} = case fieldValue of FieldText t -> Ok t FieldInt i -> Ok (Text.pack (show i)) FieldDouble d -> Ok (Text.pack (show d)) FieldBool b -> Ok (if b then Text.pack "1" else Text.pack "0") - FieldNull -> - left $ UnexpectedNull (fieldValueTypeName fieldValue) "Text" $ Text.pack "unexpected null value" - other -> left (Incompatible (fieldValueTypeName other) "Text" "invalid type for text") + FieldNull -> returnError UnexpectedNull f "" + _ -> returnError Incompatible f "" instance FromField String where fromField field = Text.unpack <$> fromField field instance FromField BS.ByteString where - fromField Field{fieldValue} = + fromField f@Field{fieldValue} = case fieldValue of FieldBlob bs -> Ok bs FieldText t -> Ok (TextEncoding.encodeUtf8 t) - FieldNull -> - left $ UnexpectedNull (fieldValueTypeName fieldValue) "ByteString" $ Text.pack "unexpected null value" - other -> left (Incompatible (fieldValueTypeName other) "ByteString" "invalid type for blob") + FieldNull -> returnError UnexpectedNull f "" + _ -> returnError Incompatible f "" instance FromField Day where - fromField Field{fieldValue} = + fromField f@Field{fieldValue} = case fieldValue of FieldDate day -> Ok day FieldTimestamp LocalTime{localDay} -> Ok localDay - other -> left (Incompatible (fieldValueTypeName other) "Day" "invalid type for date") + FieldNull -> returnError UnexpectedNull f "" + _ -> returnError Incompatible f "" instance FromField TimeOfDay where - fromField Field{fieldValue} = + fromField f@Field{fieldValue} = case fieldValue of FieldTime tod -> Ok tod FieldTimestamp LocalTime{localTimeOfDay} -> Ok localTimeOfDay - other -> left (Incompatible (fieldValueTypeName other) "TimeOfDay" "invalid type for time") + FieldNull -> returnError UnexpectedNull f "" + _ -> returnError Incompatible f "" instance FromField LocalTime where - fromField Field{ fieldValue} = + fromField f@Field{ fieldValue} = case fieldValue of FieldTimestamp ts -> Ok ts FieldDate day -> Ok (LocalTime day midnight) - other -> left (Incompatible (fieldValueTypeName other) "LocalTime" "invalid type for timestamp") + FieldNull -> returnError UnexpectedNull f "" + _ -> returnError Incompatible f "" where midnight = TimeOfDay 0 0 0 @@ -296,12 +300,22 @@ -- | Helper for bounded integral conversions. boundedIntegral :: forall a. (Integral a, Bounded a, Typeable a) => Field -> Int -> Ok a -boundedIntegral Field{fieldValue} i +boundedIntegral f@Field{} i | toInteger i < toInteger (minBound :: a) = - left $ ConversionFailed (fieldValueTypeName fieldValue) (Text.pack $ show (typeRep (Proxy :: Proxy a))) $ Text.pack "integer value out of bounds" + returnError ConversionFailed f "integer value out of bounds" | toInteger i > toInteger (maxBound :: a) = - left $ ConversionFailed (fieldValueTypeName fieldValue) (Text.pack $ show (typeRep (Proxy :: Proxy a))) $ Text.pack "integer value out of bounds" + returnError ConversionFailed f "integer value out of bounds" | otherwise = Ok (fromIntegral i) + +-- | Helper to construct a ResultError with field context. +-- based on postgresql-simple's implementation +returnError :: forall b. (Typeable b) => (Text -> Text -> Text -> Text -> ResultError) -> Field -> Text -> Ok b +returnError mkError Field{fieldValue, fieldName} msg = + Errors [SomeException $ mkError (fieldValueTypeName fieldValue) + fieldName + (Text.pack $ show (typeRep (Proxy :: Proxy b))) + msg] + fieldValueTypeName :: FieldValue -> Text fieldValueTypeName = \case diff --git a/src/Database/DuckDB/Simple/FromRow.hs b/src/Database/DuckDB/Simple/FromRow.hs --- a/src/Database/DuckDB/Simple/FromRow.hs +++ b/src/Database/DuckDB/Simple/FromRow.hs @@ -30,7 +30,7 @@ ) where import Control.Applicative (Alternative (..)) -import Control.Exception (Exception, SomeException, fromException, toException) +import Control.Exception (Exception, SomeException (SomeException), fromException, toException) import Control.Monad (MonadPlus, replicateM) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT) @@ -121,7 +121,7 @@ in case runStateT (runReaderT (runRowParser parser) context) initialState of Ok (value, (columnCount, _)) | columnCount == length fields -> Ok value - | otherwise -> left (ColumnOutOfBounds (columnCount + 1)) + | otherwise -> Errors [SomeException $ ColumnOutOfBounds (columnCount + 1)] Errors errs -> Errors errs instance FromRow () where @@ -256,8 +256,7 @@ renderError = \case Incompatible{errSQLType, errHaskellType} -> Text.concat - [ "duckdb-simple: column " - , " has type " + [ "duckdb-simple: column has type " , errSQLType , " but expected " , errHaskellType @@ -265,7 +264,7 @@ UnexpectedNull{errSQLType} -> Text.concat [ "duckdb-simple: column " - , " is NULL but expected " + , "is NULL but expected " , errSQLType ] ConversionFailed{errMessage} -> diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -21,7 +21,7 @@ import Data.Time.Clock (UTCTime) import Data.Time.LocalTime (LocalTime (..), TimeOfDay (..), localTimeToUTC, utc) import Database.DuckDB.Simple -import Database.DuckDB.Simple.FromField (Field (..), left) +import Database.DuckDB.Simple.FromField (Field (..), returnError) import GHC.Generics (Generic) import Test.Tasty (TestTree, defaultMain, testGroup) import Test.Tasty.HUnit @@ -60,11 +60,7 @@ let normalized = Text.toLower txt in if normalized == expected then Ok () - else left $ - ConversionFailed - (Text.pack "TEXT") - (Text.pack "YesNo") - "failed to match exact string" + else returnError ConversionFailed fld "failed to match exact string" newtype NonEmptyText = NonEmptyText Text.Text deriving (Eq, Show) @@ -75,11 +71,7 @@ Errors err -> Errors err Ok txt | Text.null txt -> - left $ - ConversionFailed - (Text.pack "TEXT") - (Text.pack "NonEmptyText") - (Text.pack "NonEmptyText requires a non-empty string") + returnError ConversionFailed f "NonEmptyText requires a non-empty string" | otherwise -> Ok (NonEmptyText txt) instance FromField NonEmptyText where