-- Test for everything that is supported by both the plugin and the preprocessor
import Control.Exception
import Data.Version
import Data.Proxy
import Data.Functor.Identity (Identity(..))
import qualified Data.Kind as T
main :: IO ()
main = test1 >> test2 >> test3 >> test4 >> test5 >> test6 >> test7 >> test8 >> test9 >> putStrLn "All worked"
(===) :: (Show a, Eq a) => a -> a -> IO ()
a === b = if a == b then pure () else fail $ "Mismatch, " ++ show a ++ " /= " ++ show b
fails :: a -> IO ()
fails val = do
res <- try $ evaluate val
case res of
Left e -> let _ = e :: SomeException in pure ()
Right _ -> fail "Expected an exception"
---------------------------------------------------------------------
-- CHECK THE BASICS WORK
data Foo a = Foo {foo1 :: !a, _foo2 :: Int} deriving (Show,Eq)
-- can you deal with multiple alternatives
data Animal = Human {name :: !String, job :: Prelude.String}
| Nonhuman {name :: String}
deriving (Show,Eq)
test1 :: IO ()
test1 = do
-- test expr.lbl
(Foo "test" 1).foo1 === "test"
let foo = Foo "test" 2
foo.foo1 === "test"
foo._foo2 === 2
(Foo (1,2) 3).foo1._1 === 1
let foo2 = Foo (1,2) 3
foo2.foo1._2 === 2
(foo2.foo1)._2 === 2
-- test expr{lbl = val}
foo{foo1 = "a"} === Foo "a" 2
foo{foo1 = "a", foo1 = "b"} === foo{foo1 = "b"}
null (foo{foo1 = []}.foo1) === True
foo{foo1 = "a"}.foo1 === "a"
let _foo2 = 8 in foo{_foo2} === Foo "test" 8
-- (.lbl)
map (.foo1) [foo, foo{foo1="q"}] === ["test", "q"]
( .foo1._foo2 ) (Foo foo 3) === 2
-- alternatives work
(Human "a" "b").name === "a" -- comment here
(Nonhuman "x").name === "x"
fails (Nonhuman "x").job
---------------------------------------------------------------------
-- DEAL WITH INFIX APPLICATIONS AND ASSOCIATIVITY
data Company = Company {name :: String, owner :: Person -- trailing comment
}
data Person = Person {name :: String, age :: Int}
test2 :: IO ()
test2 = do
let c = Company "A" $ Person "B" 3
let x = True
(===) "A" $ f c.name x
(===) "B" $ f c.owner.name x
(===) "A" $ gL $ 1 @+ c.name @+ True
(===) "B" $ gL $ 1 @+ c.owner.name @+ True
(===) "A" $ gL $ 1 @+ f c.name x @+ True
(===) "B" $ gL $ 1 @+ f c.owner.name x @+ True
(===) "A" $ gR $ 1 +@ c.name +@ True
(===) "B" $ gR $ 1 +@ c.owner.name +@ True
(===) "A" $ gR $ 1 +@ f c.name x +@ True
(===) "B" $ gR $ 1 +@ f c.owner.name x +@ True
f :: String -> Bool -> String
f x _ = x
infixl 9 @+
infixr 9 +@
(@+), (+@) :: _
(@+) = (,)
(+@) = (,)
gL :: ((Int, String), Bool) -> String
gL ((_,x),_) = x
gR :: (Int, (String, Bool)) -> String
gR (_,(x,_)) = x
---------------------------------------------------------------------
-- GADTS AND EXISTENTIALS
data GADT where
GADT :: {gadt :: Int} -> GADT
deriving (Show,Eq)
data V3 a = Num a => V3 { xx, yy, zz :: a }
deriving instance Show a => Show (V3 a)
deriving instance Eq a => Eq (V3 a)
test3 :: IO ()
test3 = do
let val = GADT 3
val.gadt === 3
val{gadt=5} === GADT 5
let v3 = V3 1 2 3
v3.xx === 1
v3{yy=1, zz=2} === V3 1 1 2
-- ---------------------------------------------------------------------
-- Another volley of tests combining constructions, updates and
-- applications adapted from the DAML test-suite
data AA = AA {xx :: Int} deriving (Eq, Show)
data BB = BB {yy :: AA, zz :: AA} deriving (Eq, Show)
data CC = CC {aa :: Int, bb :: Int} deriving (Eq, Show)
test4 :: IO ()
test4 = do
f1 CC{aa = 1, bb = 2} 3 4 === CC{aa = 3, bb = 4}
f2 CC{aa = 1, bb = 2} 1 2 === CC{aa = 3, bb = 2}
(f3 AA{xx = 1}).xx === 2
(f4 BB{yy = AA{xx = 1}, zz = AA{xx = 2}}).zz.xx === 4
let res = f4 BB{yy = AA{xx = 1}, zz = AA{xx = 2}} in res.zz.xx === 4
(f5 BB{yy = AA{xx = 1}, zz = AA{xx = 2}}).zz.xx === 4
(f6 BB{yy = AA{xx = 1}, zz = AA{xx = 2}}).yy.xx === 2
(f6 BB{yy = AA{xx = 1}, zz = AA{xx = 2}}).zz.xx === 4
f7 [AA 1, AA 2, AA 3] === [1, 2, 3]
f8 [BB (AA 1) (AA 2), BB (AA 2) (AA 3), BB (AA 3) (AA 4)] === [1, 2, 3]
where
f1 :: CC -> Int -> Int -> CC; f1 s t u = s{aa = t, bb = u}
f2 :: CC -> Int -> Int -> CC; f2 s t u = s{aa = t + u}
f3 :: AA -> AA; f3 s = s{xx = s.xx + 1}
f4 :: BB -> BB; f4 s = s{yy = s.yy, zz = s.zz{xx = 4}}
f5 :: BB -> BB; f5 s = s{yy = s.yy, zz = s.zz{xx = (\ x -> x * x) s.zz.xx}}
f6 :: BB -> BB; f6 s = s{yy = s.yy{xx = s.yy.xx + 1}, zz = s.zz{xx = (\ x -> x * x) s.zz{xx = s.zz.xx}.xx}}
f7 :: [AA] -> [Int]; f7 l = map (.xx) l
f8 :: [BB] -> [Int]; f8 l = map (.yy.xx) l
-- ---------------------------------------------------------------------
-- Test we can still non-instance fields
test5 :: IO ()
test5 = do
let v = makeVersion [1,2,3]
versionBranch v === [1,2,3]
-- the space before the { stops it from using record update
showVersion (v {versionBranch=[1]}) === "1"
-- ---------------------------------------------------------------------
-- Deal with type promotion
type Type = '[Int]
typeProxy :: Proxy Type
typeProxy = Proxy
test6 :: IO ()
test6 = do
_ <- evaluate typeProxy
return ()
-- ---------------------------------------------------------------------
-- Deal with kind signatures
data UserF (f :: T.Type -> T.Type) = UserF { userf_name :: String }
test7 :: IO ()
test7 = do
(UserF "test").userf_name === "test"
-- ---------------------------------------------------------------------
-- Deal with incomplete types with no warning
data Foo8 = Foo8 {
bar8 :: Int,
baz8 :: Float
} | Quux8 {
quux8 :: String
} deriving Show
test8 :: IO ()
test8 = do
let foo = Foo8 1 2
let quux = Quux8 "test"
(foo.bar8, foo.baz8) === (1, 2)
quux.quux8 === "test"
fails $ foo.quux8
fails $ length $ show $ quux{bar8=1}
-- ---------------------------------------------------------------------
-- Deal with HKD
-- Emulate simple HKD functionality
data Nullable (f :: T.Type -> T.Type) (a :: T.Type)
type family C (f :: T.Type -> T.Type) (a :: T.Type) :: T.Type where
C Identity a = a
C (Nullable c) a = C c (Maybe a)
C f a = f a
-- Existential typed field xc' need to be omitted from types, otherwise
-- compiler produce following error:
-- • Illegal instance declaration for
-- ‘GHC.Records.Extra.HasField "xc'" (Existential a) aplg’
-- The liberal coverage condition fails in class ‘GHC.Records.Extra.HasField’
-- for functional dependency: ‘x r -> a’
-- Reason: lhs types ‘"xc'"’, ‘Existential a’
-- do not jointly determine rhs type ‘aplg’
-- Un-determined variable: aplg
data Existential a = forall b. Bar { xa :: a, xb :: !a, xc' :: b }
data Foo9 f = Foo9 {
bar :: C f Int,
baz :: String
}
data Foo92 f = Foo92 {
bar2 :: C (Nullable f) Int,
baz2 :: String
}
tstObj :: Foo9 Identity
tstObj = Foo9 1 "test"
tstObj2 :: Foo92 Identity
tstObj2 = Foo92 (Just 1) "test"
test9 :: IO ()
test9 = do
tstObj.baz === "test"
tstObj.bar === 1
tstObj2.baz2 === "test"
tstObj2.bar2 === Just 1