{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
module Main (main) where
import Composite
import Composite.Fcf
import Composite.TH
import Data.Functor.Contravariant
import Data.Functor.Identity
import Data.Vinyl
import Test.Tasty
import Test.Tasty.HUnit
withLensesAndProxies
[d|
type A = "a" :-> String
type B = "b" :-> Int
type C = "c" :-> ()
type D = "d" :-> (String, Int)
|]
type RecA = Record '[A, B, C]
type RecB = Record '[B, C, D]
type RecDiffAB = Record '[A]
type RecDiffBA = Record '[D]
type RecUnionAB = Record '[A, B, C, D]
type RecIntersectionAB = Record '[B, C]
recA :: RecA
recA = "foo" :*: 5 :*: () :*: RNil
recB :: RecB
recB = 5 :*: () :*: ("bar", 4) :*: RNil
recDiffAB :: RecDiffAB
recDiffAB = "foo" :*: RNil
recDiffBA :: RecDiffBA
recDiffBA = ("bar", 4) :*: RNil
recUnionAB :: RecUnionAB
recUnionAB = "foo" :*: 5 :*: () :*: ("bar", 4) :*: RNil
recIntersectionAB :: RecIntersectionAB
recIntersectionAB = 5 :*: () :*: RNil
tests :: TestTree
tests =
testGroup
"Casting operations"
[ testCase "difference" $ do
let x = difference recA recB
assertEqual "" recDiffAB x
let x = difference recB recA
assertEqual "" recDiffBA x,
testCase "union" $ do
let x = recA `union` recB
assertEqual "" recUnionAB (rcast x)
let x = recB `union` recA
assertEqual "" recUnionAB x,
testCase "intersection" $ do
let x = intersection recA recB
assertEqual "" recIntersectionAB x
let x = intersection recB recA
assertEqual "" recIntersectionAB x
]
main :: IO ()
main = defaultMain tests