-- Copyright (c) 2019-2025 Rudy Matela.
-- Distributed under the 3-Clause BSD licence (see the file LICENSE).
{-# LANGUAGE TemplateHaskell #-}
-- uncomment to debug derivation:
-- {-# OPTIONS_GHC -ddump-splices #-}
import Test hiding ((-:), (->:))
-- -: and ->: should be generated by deriveConjurable
-- replication of Haskell's built-in data types
-- in the order of the Haskell98 standard
-- https://www.haskell.org/onlinereport/basic.html
data Choice = Yes | No deriving (Show, Eq)
data Peano = Zero | Succ Peano deriving (Show, Eq)
data Lst a = Nil | a :- Lst a deriving (Show, Eq)
data Unit = Unit deriving (Show, Eq)
data Perhaps a = Naught | Precisely a deriving (Show, Eq)
data Alternatively a b = Sinister a | Dexter b deriving (Show, Eq)
data Relation = Smaller | Same | Bigger deriving (Show, Eq)
deriveConjurable ''Choice
deriveConjurable ''Peano
deriveConjurable ''Lst
deriveConjurable ''Unit
deriveConjurable ''Perhaps
deriveConjurable ''Alternatively
deriveConjurable ''Relation
-- tree types
data Bush a = Bush a :-: Bush a | Leaf a deriving (Show, Eq)
data Tree a = Node (Tree a) a (Tree a) | Null deriving (Show, Eq)
deriveConjurable ''Bush
deriveConjurable ''Tree
-- inner/outer
data Inner = I deriving (Eq, Ord, Show)
data Outer = O Inner deriving (Eq, Ord, Show)
deriveConjurableCascading ''Outer
-- Nested datatype cascade
data Nested = Nested N0 (N1 Int) (N2 Int Int) deriving (Eq, Show)
data N0 = R0 Int deriving (Eq, Show)
data N1 a = R1 a deriving (Eq, Show)
data N2 a b = R2 a b deriving (Eq, Show)
deriveConjurableCascading ''Nested
-- Recursive nested datatype cascade
data RN = RN RN0 (RN1 Int) (RN2 Int RN0) deriving (Eq, Show)
data RN0 = Nest0 Int | Recurse0 RN deriving (Eq, Show)
data RN1 a = Nest1 a | Recurse1 RN deriving (Eq, Show)
data RN2 a b = Nest2 a b | Recurse2 RN deriving (Eq, Show)
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)
data CoMutual = CoMutual0 | CoMutual Mutual deriving (Eq, Show)
deriveConjurableCascading ''Mutual
main :: IO ()
main = mainTest tests 5040
tests :: Int -> [Bool]
tests n =
[ True
-- re-test standard types
, conjurableOK (undefined :: Bool)
, conjurableOK (undefined :: Int)
, conjurableOK (undefined :: [A])
, conjurableOK (undefined :: [Int])
, conjurableOK (undefined :: [Bool])
, conjurableOK (undefined :: ())
, conjurableOK (undefined :: Maybe A)
, conjurableOK (undefined :: Either A B)
, conjurableOK (undefined :: Ordering)
-- replication of Haskell's built-in types
, conjurableOK (undefined :: Choice)
, conjurableOK (undefined :: Peano)
, conjurableOK (undefined :: Lst A)
, conjurableOK (undefined :: Lst Peano)
, conjurableOK (undefined :: Lst Choice)
, conjurableOK (undefined :: Unit)
, conjurableOK (undefined :: Perhaps A)
, conjurableOK (undefined :: Alternatively A B)
, conjurableOK (undefined :: Relation)
-- tree types
, conjurableOK (undefined :: Bush Int)
, conjurableOK (undefined :: Tree Int)
, conjurableOK (undefined :: Inner)
, conjurableOK (undefined :: Outer)
, conjurableOK (undefined :: RN)
, conjurableOK (undefined :: Mutual)
, conjurableOK (undefined :: CoMutual)
, conjureSize Yes == 1
, conjureSize No == 1
, conjureSize Zero == 1
, conjureSize (Succ Zero) == 2
, conjureSize (Succ (Succ Zero)) == 3
, conjureSize (Succ (Succ (Succ Zero))) == 4
, conjureSize (Nil :: Lst Int) == 1
, conjureSize (10 :- (20 :- Nil) :: Lst Int) == 33
, conjureSize Unit == 1
, conjureCases choice
== [ val Yes
, val No
]
, conjureCases peano
== [ val Zero
, value "Succ" Succ :$ hole (undefined :: Peano)
]
, conjureCases (lst int)
== [ val (Nil :: Lst Int)
, value ":-" ((:-) ->>: lst int) :$ hole int :$ hole (lst int)
]
, conjureCases relation
== [ val Smaller
, val Same
, val Bigger
]
, conjureCases (bush int)
== [ value ":-:" ((:-:) ->>: bush int) :$ hole (bush int) :$ hole (bush int)
, value "Leaf" (Leaf ->: bush int) :$ hole int
]
, conjureCases (tree int)
== [ value "Node" (Node ->>>: tree int) :$ hole (tree int) :$ hole int :$ hole (tree int)
, val (Null :: Tree Int)
]
, conjureCases nested
== [ value "Nested" Nested :$ hole n0 :$ hole (n1 int) :$ hole (n2 int int)
]
, conjureHoles (undefined :: Choice) == [ hole (undefined :: Choice)
, hole (undefined :: Bool)
]
, conjureHoles (undefined :: Peano) == [ hole (undefined :: Peano)
, hole (undefined :: Bool)
]
, conjureHoles (undefined :: Lst Int) == [ hole (undefined :: Int)
, hole (undefined :: Lst Int)
, hole (undefined :: Bool)
]
, conjureHoles (undefined :: Lst Peano) == [ hole (undefined :: Peano)
, hole (undefined :: Lst Peano)
, hole (undefined :: Bool)
]
, conjureHoles (undefined :: Nested) == [ hole (undefined :: N0)
, hole (undefined :: N1 Int)
, hole (undefined :: Int)
, hole (undefined :: N2 Int Int)
, hole (undefined :: Nested)
, hole (undefined :: Bool)
]
, conjureHoles (undefined :: RN) == [ hole (undefined :: RN1 Int)
, hole (undefined :: Int)
, hole (undefined :: RN0)
, hole (undefined :: RN2 Int RN0)
, hole (undefined :: RN)
, hole (undefined :: Bool)
]
, conjureHoles (undefined :: Mutual) == [ hole (undefined :: CoMutual)
, hole (undefined :: Mutual)
, hole (undefined :: Bool)
]
, conjureHoles (undefined :: CoMutual) == [ hole (undefined :: Mutual)
, hole (undefined :: CoMutual)
, hole (undefined :: Bool)
]
]
-- proxies --
choice :: Choice
choice = undefined
peano :: Peano
peano = undefined
lst :: a -> Lst a
lst _ = undefined
relation :: Relation
relation = undefined
bush :: a -> Bush a
bush _ = undefined
tree :: a -> Tree a
tree _ = undefined
nested :: Nested
nested = undefined
n0 :: N0
n0 = undefined
n1 :: a -> N1 a
n1 _ = undefined
n2 :: a -> b -> N2 a b
n2 _ _ = undefined