Embrace -XTypeInType, add -XStarIsType
[ghc.git] / testsuite / tests / simplCore / should_run / T13429.hs
1 {-# LANGUAGE FlexibleContexts #-}
2 {-# LANGUAGE FlexibleInstances #-}
3 {-# LANGUAGE MultiParamTypeClasses #-}
4 {-# OPTIONS_GHC -fno-warn-orphans #-}
5 module Main (main) where
6
7 import T13429a
8
9 import Data.Foldable (Foldable(..))
10 import Data.Monoid (Monoid(..))
11
12 main :: IO ()
13 main = print $ prop_mappend z z
14 where
15 z :: Seq Integer
16 z = deep (Four 1 2 3 4) Empty (Four 1 2 3 4)
17
18 infix 4 ~=
19
20 (~=) :: Eq a => Maybe a -> a -> Bool
21 (~=) = maybe (const False) (==)
22
23 -- Partial conversion of an output sequence to a list.
24 toList' :: (Eq a, Measured [a] a, Valid a) => Seq a -> Maybe [a]
25 toList' xs
26 | valid xs = Just (toList xs)
27 | otherwise = Nothing
28
29 prop_mappend :: Seq Integer -> Seq Integer -> Bool
30 prop_mappend xs ys =
31 toList' (mappend xs ys) ~= toList xs ++ toList ys
32
33 ------------------------------------------------------------------------
34 -- Valid trees
35 ------------------------------------------------------------------------
36
37 class Valid a where
38 valid :: a -> Bool
39
40 instance (Measured v a, Eq v, Valid a) => Valid (FingerTree v a) where
41 valid Empty = True
42 valid (Single x) = valid x
43 valid (Deep s pr m sf) =
44 s == measure pr `mappend` measure m `mappend` measure sf &&
45 valid pr && valid m && valid sf
46
47 instance (Measured v a, Eq v, Valid a) => Valid (Node v a) where
48 valid node = measure node == foldMap measure node && all valid node
49
50 instance Valid a => Valid (Digit a) where
51 valid = all valid
52
53 instance Valid Integer where
54 valid = const True
55
56 ------------------------------------------------------------------------
57 -- Use list of elements as the measure
58 ------------------------------------------------------------------------
59
60 type Seq a = FingerTree [a] a
61
62 instance Measured [Integer] Integer where
63 measure x = [x]