a3/code/Gast/genLibTest.icl

   1 implementation module genLibTest
   2
   3 /*
   4         GAST: A Generic Automatic Software Test-system
   5
   6         genLibtest: library for generic testing: showing and comparing values
   7
   8         Pieter Koopman, 2004
   9         Radboud Universty, Nijmegen
  10         The Netherlands
  11         pieter@cs.ru.nl
  12 */
  13
  14 import StdEnv, StdGeneric, GenEq
  15
  16 instance + String where (+) s t = s +++ t
  17
  18 (@)infixl 2 :: (a->b) a -> b
  19 (@) f x = f x
  20
  21 (@!)infixl 2 :: (a->b) !a -> b
  22 (@!) f x = f x
  23
  24 //--- show ---//
  25 generic genShow a :: String Bool a [String] -> [String]
  26
  27 genShow{|Int|}                          sep p x                         rest = [toString x: rest]
  28 genShow{|Char|}                         sep p x                         rest = ["'",showChar x,"'": rest]
  29 genShow{|Bool|}                         sep p x                         rest = [toString x: rest]
  30 genShow{|Real|}                         sep p x                         rest = [toString x: rest]
  31 genShow{|String|}                       sep p s                         rest = ["\"",s,"\"":rest]
  32 genShow{|UNIT|}                         sep p _                         rest = rest
  33 genShow{|PAIR|}         fx fy   sep p (PAIR x y)        rest
  34 //      | p
  35 //              = ["(":fx sep p x [sep: fy sep p y [")":rest]]]
  36                 = fx sep p x [sep: fy sep p y rest]
  37 //genShow{|PAIR|}       fx fy   sep p (PAIR x y)        rest = fx sep True x [sep: fy sep True y rest]
  38 genShow{|EITHER|}       fl fr   sep p (LEFT x)          rest = fl sep p x rest
  39 genShow{|EITHER|}       fl fr   sep p (RIGHT x)         rest = fr sep p x rest
  40 genShow{|OBJECT|}       f       sep p (OBJECT x)        rest = f sep p x rest
  41 genShow{|(->)|}         fa fr   sep p f                         rest = ["<function>": rest]
  42 genShow{|{}|}           fx              sep p xs                        rest = ["{" :showList fx [x\\x<-:xs] ["}":rest]]
  43 genShow{|{!}|}          fx              sep p xs                        rest = ["{!":showList fx [x\\x<-:xs] ["}":rest]]
  44 //genShow{|{#}|}                fx              sep p xs                        rest = ["{#":showList fx [x\\x<-:xs] ["}":rest]]
  45 genShow{|[]|}           f               sep p xs                        rest = ["[" :showList f xs ["]":rest]]
  46 genShow{|(,)|}          f1 f2   sep p (x1,x2)           rest = ["(":f1 sep False x1 [",":f2 sep False x2 [")":rest]]]
  47 genShow{|(,,)|}         f1 f2 f3 sep p (x1,x2,x3)       rest = ["(":f1 sep False x1 [",":f2 sep False x2 [",":f3 sep False x3 [")":rest]]]]
  48 genShow{|(,,,)|}        f1 f2 f3 f4 sep p (x1,x2,x3,x4) rest
  49  = ["(":f1 sep False x1 [",":f2 sep False x2 [",":f3 sep False x3 [",":f4 sep False x4 [")":rest]]]]]
  50 genShow{|(,,,,)|}       f1 f2 f3 f4 f5 sep p (x1,x2,x3,x4,x5) rest
  51  = ["(":f1 sep False x1 [",":f2 sep False x2 [",":f3 sep False x3 [",":f4 sep False x4 [",":f5 sep False x5 [")":rest]]]]]]
  52 genShow{|(,,,,,)|}      f1 f2 f3 f4 f5 f6 sep p (x1,x2,x3,x4,x5, x6) rest = ["(":f1 sep False x1 [",":f2 sep False x2 [",":f3 sep False x3 [",":f4 sep False x4 [",":f5 sep False x5 [",":f6 sep False x6 [")":rest]]]]]]]
  53 genShow{|(,,,,,,)|}f1 f2 f3 f4 f5 f6 f7 sep p (x1,x2,x3,x4,x5,x6,x7) rest
  54  = ["(":f1 sep False x1 [",":f2 sep False x2 [",":f3 sep False x3 [",":f4 sep False x4 [",":f5 sep False x5 [",":f6 sep False x6 [",":f7 sep False x7 [")":rest]]]]]]]]
  55 genShow{|(,,,,,,,)|}f1 f2 f3 f4 f5 f6 f7 f8 sep p (x1,x2,x3,x4,x5,x6,x7,x8) rest
  56  = ["(":f1 sep False x1 [",":f2 sep False x2 [",":f3 sep False x3 [",":f4 sep False x4 [",":f5 sep False x5 [",":f6 sep False x6 [",":f7 sep False x7 [",":f8 sep False x8 [")":rest]]]]]]]]]
  57 genShow{|(,,,,,,,,)|}f1 f2 f3 f4 f5 f6 f7 f8 f9 sep p (x1,x2,x3,x4,x5,x6,x7,x8,x9) rest
  58  = ["(":f1 sep False x1 [",":f2 sep False x2 [",":f3 sep False x3 [",":f4 sep False x4 [",":f5 sep False x5 [",":f6 sep False x6 [",":f7 sep False x7 [",":f8 sep False x8 [",":f9 sep False x9 [")":rest]]]]]]]]]]
  59 genShow{|(,,,,,,,,,)|}f1 f2 f3 f4 f5 f6 f7 f8 f9 f0 sep p (x1,x2,x3,x4,x5,x6,x7,x8,x9,x0) rest
  60  = ["(":f1 sep False x1 [",":f2 sep False x2 [",":f3 sep False x3 [",":f4 sep False x4 [",":f5 sep False x5 [",":f6 sep False x6 [",":f7 sep False x7 [",":f8 sep False x8 [",":f9 sep False x9 [",":f0 sep False x0 [")":rest]]]]]]]]]]]
  61 genShow{|CONS of {gcd_name, gcd_arity, gcd_fields}|} fx sep p (CONS x) rest
  62         | gcd_arity == 0
  63                 = [gcd_name: rest]
  64         | isEmpty gcd_fields // ordinary constructor
  65                 | p // parentheses needed
  66 //                      = ["(",gcd_name," ":fx " " False x [")":rest]]
  67 //                      = [gcd_name," ":fx " " False x rest]
  68                         = ["(",gcd_name," ":fx " " True x [")":rest]]
  69                         = [gcd_name," ":fx " " True x rest]
  70         | otherwise // record
  71                 = ["{",{gcd_name.[i]\\i<-[1..size gcd_name-1]},"|":fx "," False x ["}":rest]]
  72 genShow{|FIELD of {gfd_name}|} fx sep p (FIELD x) rest
  73         = [gfd_name,"=":fx sep False x rest]
  74
  75 showChar :: Char -> String
  76 showChar c
  77  = case c of
  78         '\n' = "\\n"
  79         '\t' = "\\t"
  80         '\r' = "\\r"
  81         '\b' = "\\b"
  82         '\'' = "\\'"
  83         c = toString c
  84
  85 showList :: (.String -> .(.Bool -> .(.a -> .(u:[v:String] -> w:[x:String])))) ![.a] z:[u0:String] -> w0:[x0:String], [w0 <= u,x0 <= v,z w <= w0,u0 x <= x0]
  86 showList f []           rest = rest
  87 showList f [x]          rest = f "" False x rest
  88 showList f [x:xs]       rest = f "" False x [",":showList f xs rest]
  89
  90 show :: !a -> [String] | genShow{|*|} a
  91 show x = genShow{|*|} "" False x []
  92
  93 show1 :: !a -> String | genShow{|*|} a
  94 show1 x = glue (genShow{|*|} "" True x [])
  95 where
  96         glue :: [String] -> String
  97         glue [] = ""
  98         glue [x:xs]
  99                 = case xs of
 100                         [] = x
 101                            = x+glue xs
 102
 103 //--- comparision ---//
 104 /*
 105 instance < Bool
 106 where
 107         (<) True  b = not b
 108         (<) False _ = False
 109 */
 110 generic gLess a  :: a a -> Bool
 111
 112 gLess{|UNIT|} _ _                                                               = False
 113 gLess{|PAIR|} fx fy (PAIR x1 y1) (PAIR x2 y2)   = fx x1 x2 || (not (fx x2 x1) && fy y1 y2) // x1<x2 || (x1==x2) && y1<y2
 114 gLess{|EITHER|} fl fr (LEFT x)   (LEFT y)               = fl x y
 115 gLess{|EITHER|} fl fr (RIGHT x)  (RIGHT y)              = fr x y
 116 gLess{|EITHER|} fl fr (LEFT x)   (RIGHT y)              = True
 117 gLess{|EITHER|} fl fr (RIGHT x)  (LEFT y)               = False
 118 gLess{|CONS|}   f     (CONS x)   (CONS y)               = f x y
 119 gLess{|OBJECT|} f     (OBJECT x) (OBJECT y)     = f x y
 120 gLess{|FIELD|}  f     (FIELD x)  (FIELD y)              = f x y
 121 gLess{|Int|}    x y                                                     = x < y
 122 gLess{|Char|} x y                                                               = x < y
 123 gLess{|Bool|} False y                                                   = y
 124 gLess{|Bool|} x y                                                               = False
 125 gLess{|Real|} x y                                                               = x < y
 126 gLess{|String|} x y                                                     = x < y
 127
 128 derive gLess [], (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,), (,,,,,,,,), (,,,,,,,,,)
 129
 130 (-<-) infix 4 :: !a !a -> Bool | gLess{|*|} a
 131 (-<-) x y = gLess{|*|} x y
 132
 133 (->-) infix 4 :: !a !a -> Bool | gLess{|*|} a
 134 (->-) x y = gLess{|*|} y x
 135
 136 (-<=) infix 4 :: !a !a -> Bool | gLess{|*|} a
 137 (-<=) x y = not (gLess{|*|} y x)
 138
 139 (=>-) infix 4 :: !a !a -> Bool | gLess{|*|} a
 140 (=>-) x y = not (gLess{|*|} x y)
 141