Merge pull request #178 from well-typed/optional-rdp

Make record-dot-preprocessor functionality optional (manual flag)

Author: edsko

.github/workflows/haskell-ci.yml

@@ -238,6 +238,8 @@ jobs:
           if [ $((HCNUMVER >= 90000 && HCNUMVER < 91000)) -ne 0 ] ; then echo "package beam-large-records" >> cabal.project ; fi
           if [ $((HCNUMVER >= 90000 && HCNUMVER < 91000)) -ne 0 ] ; then echo "    ghc-options: -Werror=incomplete-patterns -Werror=incomplete-uni-patterns" >> cabal.project ; fi
           cat >> cabal.project <<EOF
+          constraints: large-records -rdp
+
           package typelet
             ghc-options: -Werror
 

beam-large-records/beam-large-records.cabal

@@ -81,7 +81,6 @@ test-suite test-beam-large-records
     , beam-large-records
     , beam-sqlite
     , large-records
-    , microlens
     , record-hasfield
     , sqlite-simple
     , tasty

beam-large-records/test/Test/Record/Beam/SimpleSQL.hs

@@ -14,8 +14,9 @@
 {-# LANGUAGE TypeFamilies              #-}
 {-# LANGUAGE TypeOperators             #-}
 {-# LANGUAGE UndecidableInstances      #-}
+{-# LANGUAGE OverloadedLabels          #-}
 
-{-# OPTIONS_GHC -fplugin=Data.Record.Plugin.WithRDP #-}
+{-# OPTIONS_GHC -fplugin=Data.Record.Plugin #-}
 
 -- | Simple but complete example that does an SQL INSERT and SELECT
 module Test.Record.Beam.SimpleSQL (
@@ -29,6 +30,7 @@ import Data.Int
 import Data.Kind
 import Data.Text (Text)
 import Database.Beam
+import Optics.Core ((^.))
 
 import qualified Database.SQLite.Simple as SQLite
 import qualified GHC.Generics           as GHC
@@ -61,7 +63,7 @@ instance Table LargeTable where
     deriving stock (GHC.Generic)
     deriving anyclass (Beamable)
 
-  primaryKey tbl = LargeTableKey tbl.largeTableId
+  primaryKey tbl = LargeTableKey (tbl ^. #largeTableId)
 
 {-------------------------------------------------------------------------------
   The full database
@@ -93,12 +95,12 @@ test_insert_select = runInMemory $ \conn -> do
       "CREATE TABLE db_large_table (table_id INT PRIMARY KEY NOT NULL, table_field VARCHAR NOT NULL);"
 
     runInsert $
-      insert exampleDb.exampleDbLargeTable $ insertValues [
+      insert (exampleDb ^. #exampleDbLargeTable) $ insertValues [
           large1
         , large2
         ]
 
     allLarge <- runSelectReturningList $ select $
-      orderBy_ (\x -> asc_ (x.largeTableId)) $ all_ exampleDb.exampleDbLargeTable
+      orderBy_ (\x -> asc_ (x ^. #largeTableId)) $ all_ (exampleDb ^. #exampleDbLargeTable)
     liftIO $ assertEqual "allLarge" allLarge [large1, large2]
 

beam-large-records/test/Test/Record/Beam/Tutorial1.hs

@@ -15,8 +15,9 @@
 {-# LANGUAGE TypeFamilies              #-}
 {-# LANGUAGE TypeOperators             #-}
 {-# LANGUAGE UndecidableInstances      #-}
+{-# LANGUAGE OverloadedLabels          #-}
 
-{-# OPTIONS_GHC -fplugin=Data.Record.Plugin.WithRDP #-}
+{-# OPTIONS_GHC -fplugin=Data.Record.Plugin #-}
 
 module Test.Record.Beam.Tutorial1 (
     tests
@@ -35,6 +36,7 @@ import Data.Record.Beam ()
 import Data.Text (Text)
 import Database.Beam hiding (Generic, countAll_)
 import Database.Beam.Schema.Tables
+import Optics.Core ((^.))
 
 import qualified Data.List.NonEmpty     as NE
 import qualified Database.SQLite.Simple as SQLite
@@ -79,11 +81,11 @@ sam2   = User "[email protected]"  "Sam"   "Sophitz" "332532dcfaa1cbf61e2a266bd723
 sam3   = User "[email protected]"     "Sam"   "Jely"    "332532dcfaa1cbf61e2a266bd723612c"
 
 instance Table UserT where
-   data PrimaryKey UserT f = UserId (Columnar f Text)
+   newtype PrimaryKey UserT f = UserId (Columnar f Text)
      deriving stock (GHC.Generic)
      deriving anyclass (Beamable)
 
-   primaryKey tbl = UserId tbl.userEmail
+   primaryKey tbl = UserId (tbl ^. #userEmail)
 
 deriving instance Show (Columnar f Text) => Show (PrimaryKey UserT f)
 deriving instance Eq   (Columnar f Text) => Eq   (PrimaryKey UserT f)
@@ -153,51 +155,51 @@ test_tutorial1_insertSelect = runInMemory $ \conn -> do
     liftIO $ SQLite.execute_ conn $
       "CREATE TABLE cart_users (email VARCHAR NOT NULL, first_name VARCHAR NOT NULL, last_name VARCHAR NOT NULL, password VARCHAR NOT NULL, PRIMARY KEY( email ));"
 
-    runInsert $ insert shoppingCartDb.shoppingCartUsers $ insertValues [
+    runInsert $ insert (shoppingCartDb ^. #shoppingCartUsers) $ insertValues [
          james
        , betty
        , sam
        ]
 
-    let allUsers = all_ (shoppingCartDb.shoppingCartUsers)
+    let allUsers = all_ (shoppingCartDb ^. #shoppingCartUsers)
     users <- runSelectReturningList $ select allUsers
     liftIO $ assertEqual "users" [james, betty, sam] users
 
-    let sortUsersByFirstName = orderBy_ (\u -> (asc_ u.userFirstName, desc_ u.userLastName)) (all_ shoppingCartDb.shoppingCartUsers)
+    let sortUsersByFirstName = orderBy_ (\u -> (asc_ $ u ^. #userFirstName, desc_ $ u ^. #userLastName)) (all_ $ shoppingCartDb ^. #shoppingCartUsers)
     sorted <- runSelectReturningList $ select sortUsersByFirstName
     liftIO $ assertEqual "sorted" [betty, james, sam] sorted
 
     let boundedQuery = limit_ 1 $ offset_ 1 $
-                       orderBy_ (\u -> asc_ u.userFirstName) $
-                       all_ shoppingCartDb.shoppingCartUsers
+                       orderBy_ (\u -> asc_ (u ^. #userFirstName)) $
+                       all_ (shoppingCartDb ^. #shoppingCartUsers)
 
     bounded <- runSelectReturningList (select boundedQuery)
     liftIO $ assertEqual "bounded" [james] bounded
 
     -- Tutorial has Int32 here, but that doesn't typecheck
     -- Don't think that is related to beam-large-records though..?
     -- (Maybe due to beam version mismatch between tutorial and our beam branch.)
-    let userCount = aggregate_ (\_u -> as_ @Int32 countAll_) (all_ shoppingCartDb.shoppingCartUsers)
+    let userCount = aggregate_ (\_u -> as_ @Int32 countAll_) (all_ (shoppingCartDb ^. #shoppingCartUsers))
     Just c <- runSelectReturningOne $ select userCount
     liftIO $ assertEqual "userCount" 3 c
 
-    runInsert $ insert shoppingCartDb.shoppingCartUsers $ insertValues [
+    runInsert $ insert (shoppingCartDb ^. #shoppingCartUsers) $ insertValues [
         james2
       , betty2
       , james3
       , sam2
       , sam3
       ]
-    let numberOfUsersByName = aggregate_ (\u -> (group_ u.userFirstName, as_ @Int32 countAll_)) $
-                              all_ shoppingCartDb.shoppingCartUsers
+    let numberOfUsersByName = aggregate_ (\u -> (group_ (u ^. #userFirstName), as_ @Int32 countAll_)) $
+                              all_ (shoppingCartDb ^. #shoppingCartUsers)
     countedByName <- runSelectReturningList $ select numberOfUsersByName
     liftIO $ assertEqual "countedByName" [("Betty",2), ("James",3), ("Sam",3)] countedByName
 
 -- Just a sanity check that RDS is working
 -- (NOTE: RDS gets confused by nested multiline comments.)
 test_tutorial1_recordDotSyntax :: Assertion
 test_tutorial1_recordDotSyntax =
-    assertEqual "" "[email protected]" u.userEmail
+    assertEqual "" "[email protected]" (u ^. #userEmail)
   where
     u :: User
     u = User {