vinyl-0.14.3: tests/XRecSpec.hs

{-# LANGUAGE DataKinds, FlexibleContexts, OverloadedLabels,
             TypeApplications, TypeOperators, ViewPatterns #-}
module XRecSpec (spec) where
import Data.Vinyl
import Data.Vinyl.FromTuple (namedArgs, ruple, xrec, fieldRec, withDefaults)
import Data.Vinyl.Functor ((:.))
import Data.Vinyl.XRec (rgetX)
import Test.Hspec (SpecWith, describe, it, shouldBe)

-- | A function that takes named parameters.
foo :: FieldRec '["name" ::: String, "age" ::: Int] -> Int
foo (ruple -> (name, age)) = length name + age

-- | Like 'foo', but has default values for each parameter.
foo' :: (RMap ss, ss ⊆ '["name" ::: String, "age" ::: Int])
     => Rec ElField ss -> Int
foo' = foo . withDefaults defs
  where defs = fieldRec (#name =: "roberta", #age =: (48 :: Int))

spec :: SpecWith ()
spec = do
  describe "Named Arguments" $ do
    it "Can re-order arguments" $
      foo (namedArgs (#age =: (23 :: Int), #name =: "Joe")) `shouldBe` 26
    it "Can pass too many arguments" $
      foo (namedArgs ( #age =: (23 :: Int)
                     , #isAwesome =: True
                     , #name =: "Cheryl"))
      `shouldBe` 29

  describe "Default arguments" $ do
    it "Can take zero arguments" $
      foo' (fieldRec ()) `shouldBe` 55
    it "Can take a subset of named arguments (1)" $
      foo' (#age =:= (39::Int)) `shouldBe` 46
    it "Can take a subset of named arguments (2)" $
      foo' (#name =:= "Jerome") `shouldBe` 54
    it "Can take all arguments" $
      foo' (fieldRec (#age =: (36::Int), #name =: "Jerome")) `shouldBe` 42

  describe "Can get fields through HKD" $ do
    let myRec :: Rec (Maybe :. ElField) ["name" ::: String, "age" ::: Int]
        myRec = xrec (Just "joe", Just 23)
    it "Can eliminate Compose newtype wrappers" $ do
      rgetX @("age" ::: Int) myRec `shouldBe` Just 23