{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fplugin=Polytropos.Plugin #-}
module Main (main) where
import Data.Functor.Const (Const (..))
import Data.Functor.Identity (Identity (..))
import Data.Int (Int64)
import Data.Text (Text)
import qualified Data.Text as T
import Test.Tasty (TestTree, defaultMain, testGroup)
import Test.Tasty.HUnit (testCase, (@?=), assertBool)
import Unsafe.Coerce (unsafeCoerce)
import Rel8 (TableSchema (..), namesFromLabels, each, values, showQuery)
import Rel8.Internal.Schema.Name (Name (..))
import Polytropos
( Record
, Pair (..)
, Field (..)
, emptyRecord
, insertField
)
import Polytropos.Rel8
( PolyRow
, toRecord
, fromRecord
, rowToColumns
, columnsToRow
, litPolyRow
, litRecord
, hfield
, hfieldAt
, htabulate
, hmap
, htraverse
, hzipWith
)
{-------------------------------------------------------------------------------
Test Schemas and Records
-------------------------------------------------------------------------------}
type UserRow = '["id" ':= Int64, "name" ':= Text, "active" ':= Bool]
userSchema :: TableSchema (PolyRow UserRow Name)
userSchema = TableSchema
{ name = "users"
, columns = Rel8.namesFromLabels
}
userRecord :: Record UserRow
userRecord = REC { id = 42 :: Int64, name = "Alice" :: Text, active = True }
type SingleRow = '["value" ':= Int64]
singleSchema :: TableSchema (PolyRow SingleRow Name)
singleSchema = TableSchema
{ name = "singles"
, columns = Rel8.namesFromLabels
}
singleRecord :: Record SingleRow
singleRecord = REC { value = 100 :: Int64 }
{-------------------------------------------------------------------------------
Main Test Tree
-------------------------------------------------------------------------------}
main :: IO ()
main = defaultMain tests
tests :: TestTree
tests = testGroup "polytropos-rel8"
[ testGroup "Table Schema & Name Synthesis"
[ testCase "namesFromLabels synthesizes column names from Symbol labels" $ do
let TableSchema { columns = cols } = userSchema
Name idCol = hfield (Field @"id") cols
Name nameCol = hfield (Field @"name") cols
Name activeCol = hfield (Field @"active") cols
idCol @?= "id_1"
nameCol @?= "name_2"
activeCol @?= "active_3"
, testCase "each userSchema generates SELECT query with column projections" $ do
let q = T.pack (showQuery (each userSchema))
assertBool "contains table name 'users'" (T.isInfixOf "users" q)
assertBool "contains 'id_1'" (T.isInfixOf "id_1" q)
assertBool "contains 'name_2'" (T.isInfixOf "name_2" q)
assertBool "contains 'active_3'" (T.isInfixOf "active_3" q)
]
, testGroup "Lifting & Query Generation"
[ testCase "values with litRecord generates VALUES query" $ do
let q = T.pack (showQuery (values [litRecord userRecord]))
assertBool "contains 'VALUES'" (T.isInfixOf "VALUES" q)
assertBool "contains '42'" (T.isInfixOf "42" q)
assertBool "contains 'Alice'" (T.isInfixOf "Alice" q)
assertBool "contains 'TRUE'" (T.isInfixOf "TRUE" q)
, testCase "values with litPolyRow generates VALUES query" $ do
let q = T.pack (showQuery (values [litPolyRow (fromRecord userRecord)]))
assertBool "contains 'VALUES'" (T.isInfixOf "VALUES" q)
assertBool "contains 'Alice'" (T.isInfixOf "Alice" q)
]
, testGroup "Conversions & Roundtrips"
[ testCase "toRecord . fromRecord is identity" $ do
toRecord (fromRecord userRecord) @?= userRecord
, testCase "columnsToRow . rowToColumns is identity" $ do
columnsToRow (rowToColumns userRecord) @?= userRecord
]
, testGroup "Columnar Combinators"
[ testCase "hfield reads fields by type-level label" $ do
let polyRes = fromRecord userRecord
runIdentity (hfield (Field @"id") polyRes) @?= (42 :: Int64)
runIdentity (hfield (Field @"name") polyRes) @?= ("Alice" :: Text)
runIdentity (hfield (Field @"active") polyRes) @?= True
, testCase "hfieldAt reads raw slots by slot index" $ do
let polyRes = fromRecord userRecord
val0 = unsafeCoerce (hfieldAt 0 polyRes) :: Identity Int64
val1 = unsafeCoerce (hfieldAt 1 polyRes) :: Identity Text
val2 = unsafeCoerce (hfieldAt 2 polyRes) :: Identity Bool
runIdentity val0 @?= 42
runIdentity val1 @?= "Alice"
runIdentity val2 @?= True
, testCase "htabulate constructs row from column indices" $ do
let tab = htabulate @UserRow @(Const Int) (\i -> Const (i * 10))
fId = hfield (Field @"id") tab :: Const Int Int64
fName = hfield (Field @"name") tab :: Const Int Text
fActive = hfield (Field @"active") tab :: Const Int Bool
getConst fId @?= 0
getConst fName @?= 10
getConst fActive @?= 20
, testCase "hmap maps natural transformation across columns" $ do
let polyRes = fromRecord userRecord
mappedId = hmap id polyRes
toRecord mappedId @?= userRecord
let constRow = hmap (\(Identity _) -> Const (99 :: Int)) polyRes
fId = hfield (Field @"id") constRow :: Const Int Int64
getConst fId @?= 99
, testCase "htraverse traverses row with applicative" $ do
let polyRes = fromRecord userRecord
traversed = htraverse (\(Identity x) -> Identity (Identity x)) polyRes
runIdentity traversed @?= polyRes
, testCase "hzipWith combines columns slot-by-slot" $ do
let polyRes = fromRecord userRecord
zipped = hzipWith (\(Identity a) (Identity _) -> Identity a) polyRes polyRes
zipped @?= polyRes
]
, testGroup "Single-Column Row"
[ testCase "single-column table schema and queries" $ do
let TableSchema { columns = cols } = singleSchema
Name valCol = hfield (Field @"value") cols
valCol @?= "value_1"
let qEach = T.pack (showQuery (each singleSchema))
assertBool "contains 'singles'" (T.isInfixOf "singles" qEach)
let qVal = T.pack (showQuery (values [litRecord singleRecord]))
assertBool "contains '100'" (T.isInfixOf "100" qVal)
]
]