diff options
author | David Terei <davidterei@gmail.com> | 2011-07-20 11:09:03 -0700 |
---|---|---|
committer | David Terei <davidterei@gmail.com> | 2011-07-20 11:26:35 -0700 |
commit | 16514f272fb42af6e9c7674a9bd6c9dce369231f (patch) | |
tree | e4f332b45fe65e2a7a2451be5674f887b42bf199 /testsuite/tests/typecheck/should_fail/tcfail067.hs | |
parent | ebd422aed41048476aa61dd4c520d43becd78682 (diff) | |
download | haskell-16514f272fb42af6e9c7674a9bd6c9dce369231f.tar.gz |
Move tests from tests/ghc-regress/* to just tests/*
Diffstat (limited to 'testsuite/tests/typecheck/should_fail/tcfail067.hs')
-rw-r--r-- | testsuite/tests/typecheck/should_fail/tcfail067.hs | 98 |
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 |