Merge pull request #28 from bitemyapp/fix-group-by-composite-key

Fixing composite key support for group by

.editorconfig

@@ -0,0 +1,20 @@
+# http://editorconfig.org
+root = true
+
+[Makefile]
+indent_style = tabs
+indent_size = 8
+end_of_line = lf
+charset = utf-8
+trim_trailing_whitespace = true
+insert_final_newline = true
+
+[*.{hs,md,php}]
+indent_style = space
+indent_size = 2
+tab_width = 2
+end_of_line = lf
+charset = utf-8
+trim_trailing_whitespace = true
+insert_final_newline = true
+max_line_length = 80

Makefile

@@ -5,3 +5,12 @@ build-7.10:
 
 build-8.0:
 	STACK_YAML="stack-8.0.yaml" stack build
+
+ghci:
+	stack ghci
+
+test:
+	stack test
+
+test-ghci:
+	stack ghci esqueleto:test:test

src/Database/Esqueleto/Internal/Sql.hs

@@ -76,7 +76,6 @@ import qualified Data.Text.Lazy.Builder as TLB
 
 import Database.Esqueleto.Internal.Language
 
-
 -- | SQL backend for @esqueleto@ using 'SqlPersistT'.
 newtype SqlQuery a =
   Q { unQ :: W.WriterT SideData (S.State IdentState) a }
@@ -1099,13 +1098,19 @@ makeGroupBy :: IdentInfo -> GroupByClause -> (TLB.Builder, [PersistValue])
 makeGroupBy _ (GroupBy []) = (mempty, [])
 makeGroupBy info (GroupBy fields) = first ("\nGROUP BY " <>) build
   where
-    build = uncommas' $ map (\(SomeValue (ERaw _ f)) -> f info) fields
+    build :: (TLB.Builder, [PersistValue])
+    build = uncommas' $ map match fields
+
+    match :: SomeValue SqlExpr -> (TLB.Builder, [PersistValue])
+    match (SomeValue (ERaw _ f)) = f info
+    match (SomeValue (ECompositeKey f)) = (mconcat $ f info, mempty)
 
 makeHaving :: IdentInfo -> WhereClause -> (TLB.Builder, [PersistValue])
 makeHaving _    NoWhere                    = mempty
 makeHaving info (Where (ERaw _ f))         = first ("\nHAVING " <>) (f info)
-makeHaving _    (Where (ECompositeKey _ )) = unexpectedCompositeKeyError "makeHaving"
+makeHaving _    (Where (ECompositeKey _)) = unexpectedCompositeKeyError "makeHaving"
 
+-- makeHaving, makeWhere and makeOrderBy
 makeOrderBy :: IdentInfo -> [OrderByClause] -> (TLB.Builder, [PersistValue])
 makeOrderBy _    [] = mempty
 makeOrderBy info os = first ("\nORDER BY " <>) . uncommas' $ concatMap mk os

stack-8.0.yaml

@@ -1,6 +1,6 @@
 # resolver: nightly-2017-01-10
-resolver: lts-7.16
-compiler: ghc-8.0.2
+resolver: lts-8.8
+# compiler: ghc-8.0.2
 
 packages:
 - '.'

stack.yaml

@@ -1 +1 @@
-stack-7.10.yaml
+stack-8.0.yaml

test/Test.hs

@@ -69,6 +69,19 @@ share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase|
     title String
     authorId PersonId
     deriving Eq Show
+
+  Lord
+    county String
+    dogs Int Maybe
+    Primary county
+    deriving Show
+
+  Deed
+    contract String
+    ownerId LordId
+    Primary contract
+    deriving Show
+
   Follow
     follower PersonId
     followed PersonId
@@ -129,6 +142,10 @@ main = do
       p3 = Person "Mike"   (Just 17) Nothing   3
       p4 = Person "Livia"  (Just 17) (Just 18) 4
       p5 = Person "Mitch"  Nothing   Nothing   5
+      l1 = Lord "Cornwall" (Just 36)
+      l2 = Lord "Dorset" Nothing
+      l3 = Lord "Chester" (Just 17)
+      
   hspec $ do
     describe "select" $ do
       it "works for a single value" $
@@ -1069,6 +1086,23 @@ main = do
                                   , (Entity p1k p1, Value 3)
                                   , (Entity p3k p3, Value 7) ]
 
+      it "GROUP BY works with COUNT and InnerJoin" $
+        run $ do
+          l1k <- insert l1
+          l2k <- insert l2
+          l3k <- insert l3
+          mapM_ (\k -> insert $ Deed k l1k) (map show [1..3])
+
+          mapM_ (\k -> insert $ Deed k l3k) (map show [4..10])
+
+          (ret :: [(Value (Key Lord), Value Int)]) <- select $ from $
+            \ ( lord `InnerJoin` deed ) -> do
+            on $ lord ^. LordId ==. deed ^. DeedOwnerId
+            groupBy (lord ^. LordId)
+            return (lord ^. LordId, count $ deed ^. DeedId)
+          liftIO $ ret `shouldBe` [ (Value l3k, Value 7)
+                                  , (Value l1k, Value 3) ]
+
       it "GROUP BY works with HAVING" $
         run $ do
           p1k <- insert p1