1 files changed, 98 insertions, 0 deletions
diff --git a/testsuite/tests/typecheck/should_fail/tcfail067.hs b/testsuite/tests/typecheck/should_fail/tcfail067.hs
new file mode 100644
index 0000000000..bcdb0c75ed
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/tcfail067.hs
@@ -0,0 +1,98 @@
+{-# LANGUAGE DatatypeContexts #-}
+module ShouldFail where
+
+infixr 1 `rangeOf`
+
+data Ord a => SubRange a = SubRange (a, a) a
+
+type IntSubRange = SubRange Int 
+
+
+subRangeValue :: SubRange a -> a
+subRangeValue (SubRange (lower, upper) value) = value
+
+subRange :: SubRange a -> (a, a)
+subRange (SubRange r value) = r
+
+newRange :: (Ord a, Show a) => (a, a) -> a -> SubRange a
+newRange r value = checkRange (SubRange r value)
+
+
+checkRange :: (Ord a, Show a) => SubRange a -> SubRange a
+checkRange (SubRange (lower, upper) value)
+  = if (value < lower) || (value > upper) then
+      error ("### sub range error. range = " ++ show lower ++ 
+              ".." ++ show upper ++ " value = " ++ show value ++ "\n")
+    else
+      SubRange (lower, upper) value
+
+
+instance Eq a => Eq (SubRange a) where
+  (==) a b = subRangeValue a == subRangeValue  b
+
+instance (Ord a) => Ord (SubRange a) where
+  (<)  = relOp (<)
+  (<=) = relOp (<=)
+  (>=) = relOp (>=)
+  (>)  = relOp (>)
+
+relOp :: Ord a => (a->a->Bool) -> SubRange a -> SubRange a -> Bool
+relOp op a b = (subRangeValue a) `op` (subRangeValue b)
+
+rangeOf :: (Ord a, Show a) => SubRange a -> SubRange a -> SubRange a
+rangeOf a b = checkRange (SubRange (subRange b) (subRangeValue a))
+
+showRange :: Show a => SubRange a -> String
+showRange (SubRange (lower, upper) value)
+  = show value ++ " :" ++ show lower ++ ".." ++ show upper
+
+showRangePair :: (Show a, Show b) => (SubRange a, SubRange b) -> String
+showRangePair (a, b)
+  = "(" ++ showRange a ++ ", " ++ showRange b ++ ")"
+
+showRangeTriple :: (Show a, Show b, Show c) =>
+                   (SubRange a, SubRange b, SubRange c) -> String
+showRangeTriple (a, b, c) 
+  = "(" ++ showRange a ++ ", " ++ showRange b ++ ", " ++ showRange c ++ ")"
+
+
+
+instance Num a => Num (SubRange a) where
+  negate = numSubRangeNegate
+  (+) = numSubRangeAdd
+  (-) = numSubRangeSubtract
+  (*) = numSubRangeMultiply
+  fromInteger a = SubRange (fromInteger a, fromInteger a) (fromInteger a)
+
+numSubRangeNegate :: (Ord a, Num a) => SubRange a -> SubRange a
+numSubRangeNegate (SubRange (lower, upper) value)
+  = checkRange (SubRange (lower, upper) (-value))
+
+numSubRangeBinOp :: Num a => (a -> a -> a) -> 
+                    SubRange a -> SubRange a -> SubRange a
+numSubRangeBinOp op a b
+  = SubRange (result, result) result
+    where
+    result = (subRangeValue a) `op` (subRangeValue b)
+
+-- partain:
+numSubRangeAdd, numSubRangeSubtract, numSubRangeMultiply :: Num a => SubRange a -> SubRange a -> SubRange a
+
+numSubRangeAdd = numSubRangeBinOp (+)
+numSubRangeSubtract = numSubRangeBinOp (-)
+numSubRangeMultiply = numSubRangeBinOp (*)
+
+unsignedBits :: Int -> (Int, Int)
+unsignedBits n = (0, 2^n-1)
+
+signedBits :: Int -> (Int, Int)
+signedBits n = (-2^(n-1), 2^(n-1)-1)   
+
+
+si_n :: Int -> Int -> IntSubRange
+si_n bits value = SubRange (signedBits bits) value
+
+si8, si10, si16 :: Int -> IntSubRange
+si8  = si_n 8
+si10 = si_n 10
+si16 = si_n 16