Fix issue #10

hasql.cabal

@@ -144,6 +144,32 @@ test-suite tests
     base >= 4.5 && < 4.8
 
 
+test-suite postgres-tests
+  type:             
+    exitcode-stdio-1.0
+  hs-source-dirs:   
+    postgres-tests
+  main-is:          
+    Main.hs
+  ghc-options:
+    -threaded
+    "-with-rtsopts=-N"
+    -funbox-strict-fields
+  default-extensions:
+    Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, ImpredicativeTypes, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples
+  default-language:
+    Haskell2010
+  build-depends:
+    HTF == 0.12.*,
+    hasql-postgres == 0.7.*,
+    hasql == 0.2.*,
+    scientific == 0.3.*,
+    transformers >= 0.2 && < 0.5,
+    mtl-prelude < 3,
+    base-prelude == 0.1.*,
+    base >= 4.5 && < 4.8
+
+
 -- Well, it's not a benchmark actually, 
 -- but in Cabal there's no better way to specify an executable, 
 -- which is not intended for distribution.

library/Hasql/RowParser.hs

@@ -38,7 +38,17 @@ return $ flip map [2 .. 24] $ \arity ->
       where
         rowVarName = mkName "row"
         e =
-          THUtil.applicativeE (ConE (tupleDataName arity)) lookups
+          THUtil.purify $
+            [|
+              let actualLength = Vector.length $(varE rowVarName)
+                  expectedLength = $(litE (IntegerL $ fromIntegral arity))
+                  in if actualLength == expectedLength
+                    then $(pure $ THUtil.applicativeE (ConE (tupleDataName arity)) lookups)
+                    else Left $ fromString $ ($ "") $
+                           showString "Inappropriate row length: " . shows actualLength .
+                           showString ", expecting: " . shows expectedLength . 
+                           showString " instead"
+            |]
           where
             lookups = do
               i <- [0 .. pred arity]

postgres-tests/Main.hs

@@ -0,0 +1,34 @@
+{-# OPTIONS_GHC -F -pgmF htfpp #-}
+import BasePrelude
+import MTLPrelude
+import Test.Framework
+import qualified Hasql as H
+import qualified Hasql.Postgres as HP
+
+
+main = 
+  htfMain $ htf_thisModulesTests
+
+test_wrongRowParserArity =
+  flip assertThrowsIO (\case H.UnparsableRow _ -> True; _ -> False) $
+  session $ do
+    H.tx Nothing $ do
+      H.unit [H.q|DROP TABLE IF EXISTS data|]
+      H.unit [H.q|CREATE TABLE data (
+                      field1    DECIMAL NOT NULL,
+                      field2    BIGINT  NOT NULL,
+                      PRIMARY KEY (field1)
+                  )|]
+      H.unit [H.q|INSERT INTO data (field1, field2) VALUES (0, 0)|]
+    mrow :: Maybe (Double, Int64, String) <- 
+      H.tx Nothing $  
+        H.single $ [H.q|SELECT * FROM data|]
+    return ()
+
+
+session :: H.Session HP.Postgres IO r -> IO r
+session =
+  H.session backendSettings poolSettings
+  where
+    backendSettings = HP.Postgres "localhost" 5432 "postgres" "" "postgres"
+    poolSettings = fromJust $ H.sessionSettings 6 30