Laziness.hs

-- {-# LANGUAGE ConstraintKinds           #-}
-- {-# LANGUAGE DataKinds                 #-}
-- {-# LANGUAGE ExistentialQuantification #-}
-- {-# LANGUAGE FlexibleContexts          #-}
-- {-# LANGUAGE FlexibleInstances         #-}
-- {-# LANGUAGE MultiParamTypeClasses     #-}
{-# LANGUAGE ScopedTypeVariables       #-}
-- {-# LANGUAGE TemplateHaskell           #-}
{-# LANGUAGE TypeApplications          #-}
-- {-# LANGUAGE TypeFamilies              #-}
{-# LANGUAGE TypeOperators             #-}
-- {-# LANGUAGE UndecidableInstances      #-}


-- | Check that the functions on 'Rep' can be called on 'undefined'
module Test.Record.Generic.Sanity.Laziness (tests) where

import Control.Exception
import Data.List (isInfixOf)
import Data.IORef
import Test.Tasty
import Test.Tasty.HUnit

import Data.Record.Generic

import qualified Data.Record.Generic.Rep          as Rep
import qualified Data.Record.Generic.Rep.Internal as Rep

import Test.Record.Generic.Infra.Examples
import Test.Record.Generic.Infra.Util (expectException)

{-------------------------------------------------------------------------------
  Tests proper
-------------------------------------------------------------------------------}

tests :: TestTree
tests = testGroup "Test.Record.Generic.Sanity.Laziness" [
      testCase "mapWithIndex" test_mapWithIndex
    , testCase "ap"           test_ap
    , testCase "map"          test_map
    , testCase "map'"         test_map'
    , testCase "mapM"         test_mapM
    , testCase "cmap"         test_cmap
    , testCase "cmapM"        test_cmapM
    , testCase "zipWithM"     test_zipWithM
    , testCase "czipWithM"    test_czipWithM
    ]

test_mapWithIndex :: Assertion
test_mapWithIndex =
    assertEqual "" expected actual
  where
    expected, actual :: Rep (K Int) SimpleRecord
    expected = Rep.unsafeFromList [0, 1]
    actual   = Rep.mapWithIndex (\ix _ -> K $ Rep.indexToInt ix) undefined

test_ap :: Assertion
test_ap =
    assertEqual "" expected actual
  where
    fns :: Rep (f -.-> I) SimpleRecord
    fns = Rep.map' (\x -> Fn $ \_ -> x) (from exampleSimpleRecord)

    expected, actual :: SimpleRecord
    expected = exampleSimpleRecord
    actual   = to $ Rep.ap fns undefined

test_map :: Assertion
test_map =
    assertEqual "" expected actual
  where
    expected, actual :: Rep (K Int) SimpleRecord
    expected = Rep.unsafeFromList [0, 0]
    actual   = Rep.map (\_ -> K 0) undefined

-- Just to be sure: if we use map' instead of map, we get bottom
test_map' :: Assertion
test_map' = expectException isExpectedException $ do
    assertEqual "" expected actual
  where
    isExpectedException :: SomeException -> Bool
    isExpectedException e = "undefined" `isInfixOf` show e

    expected, actual :: Rep (K Int) SimpleRecord
    expected = Rep.unsafeFromList [0, 0]
    actual   = Rep.map' (\_ -> K 0) undefined

test_mapM :: Assertion
test_mapM = do
    r <- newIORef 1

    let next :: f x -> IO (K Int x)
        next _ = atomicModifyIORef r $ \i -> (i + 1, K i)

    actual :: Rep (K Int) SimpleRecord <- Rep.mapM next undefined
    assertEqual "" expected actual
  where
    expected :: Rep (K Int) SimpleRecord
    expected = Rep.unsafeFromList [1, 2]

test_cmap :: Assertion
test_cmap =
    assertEqual "" expected actual
  where
    expected, actual :: SimpleRecord
    expected = MkSimpleRecord {
                   simpleRecordField1 = 0
                 , simpleRecordField2 = False
                 }
    actual   = to $ Rep.cmap (Proxy @Bounded) (\_ -> I minBound) undefined

test_cmapM :: Assertion
test_cmapM = do
    r <- newIORef False

    let next :: Bounded x => f x -> IO (I x)
        next _ = do
            b <- atomicModifyIORef r $ \b -> (not b, b)
            return . I $ if b then maxBound else minBound

    actual :: SimpleRecord <- to <$> Rep.cmapM (Proxy @Bounded) next undefined
    assertEqual "" expected actual
  where
    expected :: SimpleRecord
    expected = MkSimpleRecord {
                   simpleRecordField1 = 0
                 , simpleRecordField2 = True
                 }

test_zipWithM :: Assertion
test_zipWithM =
    assertEqual "" expected actual
  where
    expected, actual :: Maybe (Rep (K Int) SimpleRecord)
    expected = Just $ Rep.unsafeFromList [0, 0]
    actual   = Rep.zipWithM (\_ _ -> Just $ K 0) undefined undefined

test_czipWithM :: Assertion
test_czipWithM =
    assertEqual "" expected actual
  where
    expected, actual :: Maybe SimpleRecord
    expected = Just $ MkSimpleRecord {
                   simpleRecordField1 = 0
                 , simpleRecordField2 = False
                 }
    actual   = to <$> Rep.czipWithM
                        (Proxy @Bounded)
                        (\_ _ -> Just $ I minBound)
                        undefined
                        undefined