-- Copyright (c) 2019-2021 Rudy Matela.
-- Distributed under the 3-Clause BSD licence (see the file LICENSE).
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveDataTypeable #-}
import Test hiding ((-:), (->:))
-- -: and ->: should be generated by deriveConjurable
data Choice = Ae | Bee | Cee deriving (Show, Eq, Typeable)
data Peano = Zero | Succ Peano deriving (Show, Eq, Typeable)
data List a = a :- List a | Nil deriving (Show, Eq, Typeable)
data Bush a = Bush a :-: Bush a | Leaf a deriving (Show, Eq, Typeable)
data Tree a = Node (Tree a) a (Tree a) | Null deriving (Show, Eq, Typeable)
deriveConjurable ''Choice
deriveConjurable ''Peano
deriveConjurable ''List
deriveConjurable ''Bush
deriveConjurable ''Tree
-- Nested datatype cascade
data Nested = Nested N0 (N1 Int) (N2 Int Int) deriving (Eq, Show, Typeable)
data N0 = R0 Int deriving (Eq, Show, Typeable)
data N1 a = R1 a deriving (Eq, Show, Typeable)
data N2 a b = R2 a b deriving (Eq, Show, Typeable)
deriveConjurableCascading ''Nested
-- Recursive nested datatype cascade
data RN = RN RN0 (RN1 Int) (RN2 Int RN) deriving (Eq, Show, Typeable)
data RN0 = Nest0 Int | Recurse0 RN deriving (Eq, Show, Typeable)
data RN1 a = Nest1 a | Recurse1 RN deriving (Eq, Show, Typeable)
data RN2 a b = Nest2 a b | Recurse2 RN deriving (Eq, Show, Typeable)
-- beware: values of the above type are always infinite!
-- derivation works but full evaluation does not terminate
deriveConjurableCascading ''RN
-- Those should have no effect (instance already exists):
{- uncommenting those should generate warnings
deriveConjurable ''Bool
deriveConjurable ''Maybe
deriveConjurable ''Either
-}
-- Those should not generate warnings
deriveConjurableIfNeeded ''Bool
deriveConjurableIfNeeded ''Maybe
deriveConjurableIfNeeded ''Either
data Mutual = Mutual0 | Mutual CoMutual deriving (Eq, Show, Typeable)
data CoMutual = CoMutual0 | CoMutual Mutual deriving (Eq, Show, Typeable)
deriveConjurableCascading ''Mutual
main :: IO ()
main = mainTest tests 5040
tests :: Int -> [Bool]
tests n =
[ True
, conjurableOK (undefined :: Bool)
, conjurableOK (undefined :: Int)
, conjurableOK (undefined :: Char)
, conjurableOK (undefined :: [Bool])
, conjurableOK (undefined :: [Int])
, conjurableOK (undefined :: String)
, conjurableOK (undefined :: Choice)
, conjurableOK (undefined :: Peano)
, conjurableOK (undefined :: List Int)
, conjurableOK (undefined :: Bush Int)
, conjurableOK (undefined :: Tree Int)
--, conjurableOK (undefined :: RN) -- TODO: FIX: infinite loop somewhere...
]
-- checks if the functions conjureEquality, conjureExpress and conjureTiers
-- were correctly generated.
conjurableOK :: (Eq a, Show a, Express a, Listable a, Conjurable a) => a -> Bool
conjurableOK x = and
[ holds 60 $ (-==-) ==== (==)
, holds 60 $ expr' === expr
, tiers =| 6 |= (tiers -: [[x]])
]
where
(-==-) = evl (fromJust $ conjureEquality x) -:> x
tiers' = mapT evl (fromJust $ conjureTiers x) -: [[x]]
expr' = (conjureExpress x . val) -:> x