Bump `base` version to 4.9.0.0 (closes #11026)
[ghc.git] / testsuite / tests / typecheck / should_fail / tcfail067.hs
1 {-# LANGUAGE DatatypeContexts #-}
2 module ShouldFail where
3
4 infixr 1 `rangeOf`
5
6 data Ord a => SubRange a = SubRange (a, a) a
7
8 type IntSubRange = SubRange Int
9
10
11 subRangeValue :: SubRange a -> a
12 subRangeValue (SubRange (lower, upper) value) = value
13
14 subRange :: SubRange a -> (a, a)
15 subRange (SubRange r value) = r
16
17 newRange :: (Ord a, Show a) => (a, a) -> a -> SubRange a
18 newRange r value = checkRange (SubRange r value)
19
20
21 checkRange :: (Ord a, Show a) => SubRange a -> SubRange a
22 checkRange (SubRange (lower, upper) value)
23 = if (value < lower) || (value > upper) then
24 error ("### sub range error. range = " ++ show lower ++
25 ".." ++ show upper ++ " value = " ++ show value ++ "\n")
26 else
27 SubRange (lower, upper) value
28
29
30 instance Eq a => Eq (SubRange a) where
31 (==) a b = subRangeValue a == subRangeValue b
32
33 instance (Ord a) => Ord (SubRange a) where
34 (<) = relOp (<)
35 (<=) = relOp (<=)
36 (>=) = relOp (>=)
37 (>) = relOp (>)
38
39 relOp :: Ord a => (a->a->Bool) -> SubRange a -> SubRange a -> Bool
40 relOp op a b = (subRangeValue a) `op` (subRangeValue b)
41
42 rangeOf :: (Ord a, Show a) => SubRange a -> SubRange a -> SubRange a
43 rangeOf a b = checkRange (SubRange (subRange b) (subRangeValue a))
44
45 showRange :: Show a => SubRange a -> String
46 showRange (SubRange (lower, upper) value)
47 = show value ++ " :" ++ show lower ++ ".." ++ show upper
48
49 showRangePair :: (Show a, Show b) => (SubRange a, SubRange b) -> String
50 showRangePair (a, b)
51 = "(" ++ showRange a ++ ", " ++ showRange b ++ ")"
52
53 showRangeTriple :: (Show a, Show b, Show c) =>
54 (SubRange a, SubRange b, SubRange c) -> String
55 showRangeTriple (a, b, c)
56 = "(" ++ showRange a ++ ", " ++ showRange b ++ ", " ++ showRange c ++ ")"
57
58
59
60 instance Num a => Num (SubRange a) where
61 negate = numSubRangeNegate
62 (+) = numSubRangeAdd
63 (-) = numSubRangeSubtract
64 (*) = numSubRangeMultiply
65 fromInteger a = SubRange (fromInteger a, fromInteger a) (fromInteger a)
66
67 numSubRangeNegate :: (Ord a, Show a, Num a) => SubRange a -> SubRange a
68 numSubRangeNegate (SubRange (lower, upper) value)
69 = checkRange (SubRange (lower, upper) (-value))
70
71 numSubRangeBinOp :: Num a => (a -> a -> a) ->
72 SubRange a -> SubRange a -> SubRange a
73 numSubRangeBinOp op a b
74 = SubRange (result, result) result
75 where
76 result = (subRangeValue a) `op` (subRangeValue b)
77
78 -- partain:
79 numSubRangeAdd, numSubRangeSubtract, numSubRangeMultiply :: Num a => SubRange a -> SubRange a -> SubRange a
80
81 numSubRangeAdd = numSubRangeBinOp (+)
82 numSubRangeSubtract = numSubRangeBinOp (-)
83 numSubRangeMultiply = numSubRangeBinOp (*)
84
85 unsignedBits :: Int -> (Int, Int)
86 unsignedBits n = (0, 2^n-1)
87
88 signedBits :: Int -> (Int, Int)
89 signedBits n = (-2^(n-1), 2^(n-1)-1)
90
91
92 si_n :: Int -> Int -> IntSubRange
93 si_n bits value = SubRange (signedBits bits) value
94
95 si8, si10, si16 :: Int -> IntSubRange
96 si8 = si_n 8
97 si10 = si_n 10
98 si16 = si_n 16