beam-large-records-0.1.1: test/Test/Record/Beam/Andres.hs
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fplugin=Data.Record.Plugin #-}
-- Lots of fields defined here are never used directly
{-# OPTIONS_GHC -Wno-unused-top-binds #-}
-- | Test cases in Andres' original sketch for this library
module Test.Record.Beam.Andres (tests) where
import Control.Applicative
import Data.Functor.Identity
import Data.Kind
import Data.Proxy
import Database.Beam
import Database.Beam.Schema.Tables
import GHC.Records.Compat
import qualified Data.List.NonEmpty as NE
import qualified GHC.Generics as GHC
import Test.Tasty
import Test.Tasty.HUnit
import Data.Record.Beam ()
import Test.Record.Beam.Util.Orphans ()
{-------------------------------------------------------------------------------
Table A
-------------------------------------------------------------------------------}
{-# ANN type LRTableA largeRecord #-}
data LRTableA (f :: Type -> Type) = MkLRTableA {
fldA1 :: Columnar f Int
, fldA2 :: Columnar f Int
}
deriving stock (Eq, Show)
deriving anyclass (Beamable)
instance Table LRTableA where
newtype PrimaryKey LRTableA f = LRTableAKey (Columnar f Int)
deriving stock (GHC.Generic)
deriving anyclass (Beamable)
primaryKey = LRTableAKey . getField @"fldA1"
deriving instance Show (Columnar f Int) => Show (PrimaryKey LRTableA f)
deriving instance Eq (Columnar f Int) => Eq (PrimaryKey LRTableA f)
{-------------------------------------------------------------------------------
Table B: has mixin (reference to table A), as well as nullable fields
-------------------------------------------------------------------------------}
{-# ANN type LRTableB largeRecord #-}
data LRTableB (f :: Type -> Type) = MkLRTableB {
fldB1 :: Columnar f Int
, fldB2 :: Columnar f Int
, fldB3 :: Columnar f Bool
, fldB4 :: Columnar (Nullable f) Char
, fldB5 :: Columnar f Int
, fldB6 :: Columnar f String
, fldB7 :: LRTableA f
, fldB8 :: PrimaryKey LRTableA f
, fldB9 :: PrimaryKey LRTableA (Nullable f)
}
deriving stock (Eq, Show)
deriving anyclass (Beamable)
instance Table LRTableB where
data PrimaryKey LRTableB f = LRTableBKey (Columnar f Int)
deriving stock (GHC.Generic)
deriving anyclass (Beamable)
primaryKey = LRTableBKey . getField @"fldB1"
{-------------------------------------------------------------------------------
The database definition
-------------------------------------------------------------------------------}
-- | Example of a domain type
--
-- <https://haskell-beam.github.io/beam/user-guide/databases/#domain-types>
newtype EvenInt = EvenInt Int
{-# ANN type LRDB largeRecord #-}
data LRDB (f :: Type -> Type) = MkLRDB {
tblA :: f (TableEntity LRTableA)
, tblB :: f (TableEntity LRTableB)
, viewA :: f (ViewEntity LRTableA)
, domTyp :: f (DomainTypeEntity EvenInt)
}
deriving (Show, Eq)
instance Database be LRDB
exDbSettings :: DatabaseSettings be LRDB
exDbSettings = defaultDbSettings
{-------------------------------------------------------------------------------
Tests proper
-------------------------------------------------------------------------------}
tests :: TestTree
tests = testGroup "Test.Record.Beam.Andres" [
testCase "zipBeamFields" test_zipBeamFields
, testCase "tblSkeleton" test_tblSkeleton
, testCase "zipTables" test_zipTables
, testCase "autoDbSettings" test_autoDbSettings
, testCase "withConstraints" test_withConstraints
]
test_zipBeamFields :: Assertion
test_zipBeamFields =
assertEqual "" (runIdentity (zipBeamFieldsM alt ex1 ex2)) exRes
where
alt :: forall a.
Columnar' Maybe a
-> Columnar' Maybe a
-> Identity (Columnar' Maybe a)
alt (Columnar' x) (Columnar' y) = Identity (Columnar' (x <|> y))
ex1 :: LRTableB Maybe
ex1 = MkLRTableB {
fldB1 = Just 2
, fldB2 = Just 2
, fldB3 = Nothing
, fldB4 = Just (Just 'x')
, fldB5 = Just 4
, fldB6 = Nothing
, fldB7 = MkLRTableA {
fldA1 = Just 8
, fldA2 = Nothing
}
, fldB8 = LRTableAKey (Just 11)
, fldB9 = LRTableAKey Nothing
}
ex2 :: LRTableB Maybe
ex2 = MkLRTableB {
fldB1 = Nothing
, fldB2 = Just 3
, fldB3 = Nothing
, fldB4 = Nothing
, fldB5 = Nothing
, fldB6 = Just "foo"
, fldB7 = MkLRTableA {
fldA1 = Nothing
, fldA2 = Just 9
}
, fldB8 = LRTableAKey (Just 22)
, fldB9 = LRTableAKey (Just Nothing)
}
exRes :: LRTableB Maybe
exRes = MkLRTableB {
fldB1 = Just 2
, fldB2 = Just 2
, fldB3 = Nothing
, fldB4 = Just (Just 'x')
, fldB5 = Just 4
, fldB6 = Just "foo"
, fldB7 = MkLRTableA {
fldA1 = Just 8
, fldA2 = Just 9
}
, fldB8 = LRTableAKey (Just 11)
-- Outermost Maybe is our choice of @f@, innermost due to 'Nullable'
, fldB9 = LRTableAKey (Just Nothing)
}
test_tblSkeleton :: Assertion
test_tblSkeleton = do
assertEqual "" tblSkeleton ex
where
ex :: TableSkeleton LRTableB
ex = MkLRTableB {
fldB1 = Ignored
, fldB2 = Ignored
, fldB3 = Ignored
, fldB4 = Ignored
, fldB5 = Ignored
, fldB6 = Ignored
, fldB7 = MkLRTableA {
fldA1 = Ignored
, fldA2 = Ignored
}
, fldB8 = LRTableAKey Ignored
, fldB9 = LRTableAKey Ignored
}
test_zipTables :: Assertion
test_zipTables = do
assertEqual "" (runIdentity (zipTables (Proxy @()) f dbX dbY)) dbRes
where
f :: Const Int tbl -> Const Int tbl -> Identity (Const Bool tbl)
f (Const x) (Const y) = Identity $ Const (x > y)
dbX :: LRDB (Const Int)
dbX = MkLRDB {
tblA = Const 10
, tblB = Const 20
, viewA = Const 10
, domTyp = Const 20
}
dbY :: LRDB (Const Int)
dbY = MkLRDB {
tblA = Const 12
, tblB = Const 18
, viewA = Const 12
, domTyp = Const 18
}
dbRes :: LRDB (Const Bool)
dbRes = MkLRDB {
tblA = Const False
, tblB = Const True
, viewA = Const False
, domTyp = Const True
}
test_autoDbSettings :: Assertion
test_autoDbSettings =
assertEqual "" exDbSettings settings
where
settings :: LRDB (DatabaseEntity be db)
settings = MkLRDB {
tblA = DatabaseEntity $
DatabaseTable {
dbTableSchema = Nothing
, dbTableOrigName = "tblA"
, dbTableCurrentName = "a"
, dbTableSettings = MkLRTableA {
fldA1 = TableField {_fieldPath = NE.fromList ["fldA1"], _fieldName = "a1"}
, fldA2 = TableField {_fieldPath = NE.fromList ["fldA2"], _fieldName = "a2"}
}
}
, tblB = DatabaseEntity $
DatabaseTable {
dbTableSchema = Nothing
, dbTableOrigName = "tblB"
, dbTableCurrentName = "b"
, dbTableSettings = MkLRTableB {
fldB1 = TableField {_fieldPath = NE.fromList ["fldB1"], _fieldName = "b1"}
, fldB2 = TableField {_fieldPath = NE.fromList ["fldB2"], _fieldName = "b2"}
, fldB3 = TableField {_fieldPath = NE.fromList ["fldB3"], _fieldName = "b3"}
, fldB4 = TableField {_fieldPath = NE.fromList ["fldB4"], _fieldName = "b4"}
, fldB5 = TableField {_fieldPath = NE.fromList ["fldB5"], _fieldName = "b5"}
, fldB6 = TableField {_fieldPath = NE.fromList ["fldB6"], _fieldName = "b6"}
, fldB7 = MkLRTableA {
fldA1 = TableField {_fieldPath = NE.fromList ["fldB7", "fldA1"], _fieldName = "b7__a1"}
, fldA2 = TableField {_fieldPath = NE.fromList ["fldB7", "fldA2"], _fieldName = "b7__a2"}
}
, fldB8 = LRTableAKey (TableField {_fieldPath = NE.fromList ["fldB8", "fldA1"], _fieldName = "b8__a1"})
, fldB9 = LRTableAKey (TableField {_fieldPath = NE.fromList ["fldB9", "fldA1"], _fieldName = "b9__a1"})
}
}
, viewA = DatabaseEntity $
DatabaseView {
dbViewSchema = Nothing
, dbViewOrigName = "viewA"
, dbViewCurrentName = "a"
, dbViewSettings = MkLRTableA {
fldA1 = TableField {_fieldPath = NE.fromList ["fldA1"], _fieldName = "a1"}
, fldA2 = TableField {_fieldPath = NE.fromList ["fldA2"], _fieldName = "a2"}
}
}
, domTyp = DatabaseEntity $
DatabaseDomainType Nothing "domTyp"
}
test_withConstraints :: Assertion
test_withConstraints =
assertEqual "" (showTable canShowB) res
where
canShowB :: LRTableB (WithConstraint Show)
canShowB = withConstrainedFields ex
ex :: LRTableB Identity
ex = MkLRTableB {
fldB1 = 1
, fldB2 = 2
, fldB3 = False
, fldB4 = Just 'a'
, fldB5 = 4
, fldB6 = "b"
, fldB7 = MkLRTableA {
fldA1 = 5
, fldA2 = 6
}
, fldB8 = LRTableAKey 7
, fldB9 = LRTableAKey (Just 8)
}
-- Note the use of undefined here! Beam does similar things internally;
-- large-records has been modified so that this works.
showTable :: Beamable tbl => tbl (WithConstraint Show) -> tbl (Const String)
showTable tbl = runIdentity $
zipBeamFieldsM aux tbl undefined
where
aux ::
Columnar' (WithConstraint Show) a
-> Columnar' whatever a
-> Identity (Columnar' (Const String) a)
aux (Columnar' (WithConstraint x)) _ = Identity $
Columnar' (Const (show x))
res :: LRTableB (Const String)
res = MkLRTableB {
fldB1 = Const "1"
, fldB2 = Const "2"
, fldB3 = Const "False"
, fldB4 = Const "Just 'a'"
, fldB5 = Const "4"
, fldB6 = Const "\"b\""
, fldB7 = MkLRTableA {fldA1 = Const "5", fldA2 = Const "6"}
, fldB8 = LRTableAKey (Const "7")
, fldB9 = LRTableAKey (Const "Just 8")
}