ghc/compiler/tests/typecheck/should_fail/tcfail067.hs

   1 module SubRange where
   2
   3 infixr 1 `rangeOf`
   4
   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, Text a) => (a, a) -> a -> SubRange a
  18 newRange r value = checkRange (SubRange r value)
  19
  20
  21 checkRange :: (Ord a, Text 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, Text a) => SubRange a -> SubRange a -> SubRange a
  43 rangeOf a b = checkRange (SubRange (subRange b) (subRangeValue a))
  44
  45 showRange :: Text a => SubRange a -> String
  46 showRange (SubRange (lower, upper) value)
  47   = show value ++ " :" ++ show lower ++ ".." ++ show upper
  48
  49 showRangePair :: (Text a, Text b) => (SubRange a, SubRange b) -> String
  50 showRangePair (a, b)
  51   = "(" ++ showRange a ++ ", " ++ showRange b ++ ")"
  52
  53 showRangeTriple :: (Text a, Text b, Text 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, 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