--- /dev/null
+implementation module genLibTest\r
+\r
+/*\r
+ GAST: A Generic Automatic Software Test-system\r
+ \r
+ genLibtest: library for generic testing: showing and comparing values\r
+\r
+ Pieter Koopman, 2004\r
+ Radboud Universty, Nijmegen\r
+ The Netherlands\r
+ pieter@cs.ru.nl\r
+*/\r
+\r
+import StdEnv, StdGeneric, GenEq\r
+\r
+instance + String where (+) s t = s +++ t\r
+\r
+(@)infixl 2 :: (a->b) a -> b\r
+(@) f x = f x\r
+\r
+(@!)infixl 2 :: (a->b) !a -> b\r
+(@!) f x = f x\r
+\r
+//--- show ---//\r
+generic genShow a :: String Bool a [String] -> [String]\r
+\r
+genShow{|Int|} sep p x rest = [toString x: rest]\r
+genShow{|Char|} sep p x rest = ["'",showChar x,"'": rest]\r
+genShow{|Bool|} sep p x rest = [toString x: rest]\r
+genShow{|Real|} sep p x rest = [toString x: rest]\r
+genShow{|String|} sep p s rest = ["\"",s,"\"":rest] \r
+genShow{|UNIT|} sep p _ rest = rest\r
+genShow{|PAIR|} fx fy sep p (PAIR x y) rest\r
+// | p\r
+// = ["(":fx sep p x [sep: fy sep p y [")":rest]]]\r
+ = fx sep p x [sep: fy sep p y rest]\r
+//genShow{|PAIR|} fx fy sep p (PAIR x y) rest = fx sep True x [sep: fy sep True y rest]\r
+genShow{|EITHER|} fl fr sep p (LEFT x) rest = fl sep p x rest\r
+genShow{|EITHER|} fl fr sep p (RIGHT x) rest = fr sep p x rest\r
+genShow{|OBJECT|} f sep p (OBJECT x) rest = f sep p x rest\r
+genShow{|(->)|} fa fr sep p f rest = ["<function>": rest]\r
+genShow{|{}|} fx sep p xs rest = ["{" :showList fx [x\\x<-:xs] ["}":rest]]\r
+genShow{|{!}|} fx sep p xs rest = ["{!":showList fx [x\\x<-:xs] ["}":rest]]\r
+//genShow{|{#}|} fx sep p xs rest = ["{#":showList fx [x\\x<-:xs] ["}":rest]]\r
+genShow{|[]|} f sep p xs rest = ["[" :showList f xs ["]":rest]]\r
+genShow{|(,)|} f1 f2 sep p (x1,x2) rest = ["(":f1 sep False x1 [",":f2 sep False x2 [")":rest]]]\r
+genShow{|(,,)|} f1 f2 f3 sep p (x1,x2,x3) rest = ["(":f1 sep False x1 [",":f2 sep False x2 [",":f3 sep False x3 [")":rest]]]]\r
+genShow{|(,,,)|} f1 f2 f3 f4 sep p (x1,x2,x3,x4) rest\r
+ = ["(":f1 sep False x1 [",":f2 sep False x2 [",":f3 sep False x3 [",":f4 sep False x4 [")":rest]]]]]\r
+genShow{|(,,,,)|} f1 f2 f3 f4 f5 sep p (x1,x2,x3,x4,x5) rest\r
+ = ["(":f1 sep False x1 [",":f2 sep False x2 [",":f3 sep False x3 [",":f4 sep False x4 [",":f5 sep False x5 [")":rest]]]]]]\r
+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]]]]]]]\r
+genShow{|(,,,,,,)|}f1 f2 f3 f4 f5 f6 f7 sep p (x1,x2,x3,x4,x5,x6,x7) rest\r
+ = ["(":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]]]]]]]]\r
+genShow{|(,,,,,,,)|}f1 f2 f3 f4 f5 f6 f7 f8 sep p (x1,x2,x3,x4,x5,x6,x7,x8) rest\r
+ = ["(":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]]]]]]]]]\r
+genShow{|(,,,,,,,,)|}f1 f2 f3 f4 f5 f6 f7 f8 f9 sep p (x1,x2,x3,x4,x5,x6,x7,x8,x9) rest\r
+ = ["(":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]]]]]]]]]]\r
+genShow{|(,,,,,,,,,)|}f1 f2 f3 f4 f5 f6 f7 f8 f9 f0 sep p (x1,x2,x3,x4,x5,x6,x7,x8,x9,x0) rest\r
+ = ["(":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]]]]]]]]]]]\r
+genShow{|CONS of {gcd_name, gcd_arity, gcd_fields}|} fx sep p (CONS x) rest\r
+ | gcd_arity == 0\r
+ = [gcd_name: rest]\r
+ | isEmpty gcd_fields // ordinary constructor\r
+ | p // parentheses needed\r
+// = ["(",gcd_name," ":fx " " False x [")":rest]]\r
+// = [gcd_name," ":fx " " False x rest]\r
+ = ["(",gcd_name," ":fx " " True x [")":rest]]\r
+ = [gcd_name," ":fx " " True x rest]\r
+ | otherwise // record\r
+ = ["{",{gcd_name.[i]\\i<-[1..size gcd_name-1]},"|":fx "," False x ["}":rest]]\r
+genShow{|FIELD of {gfd_name}|} fx sep p (FIELD x) rest\r
+ = [gfd_name,"=":fx sep False x rest]\r
+\r
+showChar :: Char -> String\r
+showChar c\r
+ = case c of\r
+ '\n' = "\\n"\r
+ '\t' = "\\t"\r
+ '\r' = "\\r"\r
+ '\b' = "\\b"\r
+ '\'' = "\\'"\r
+ c = toString c\r
+\r
+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]\r
+showList f [] rest = rest\r
+showList f [x] rest = f "" False x rest\r
+showList f [x:xs] rest = f "" False x [",":showList f xs rest]\r
+\r
+show :: !a -> [String] | genShow{|*|} a\r
+show x = genShow{|*|} "" False x []\r
+\r
+show1 :: !a -> String | genShow{|*|} a\r
+show1 x = glue (genShow{|*|} "" True x [])\r
+where\r
+ glue :: [String] -> String\r
+ glue [] = ""\r
+ glue [x:xs]\r
+ = case xs of\r
+ [] = x\r
+ = x+glue xs\r
+\r
+//--- comparision ---//\r
+/*\r
+instance < Bool\r
+where\r
+ (<) True b = not b\r
+ (<) False _ = False\r
+*/\r
+generic gLess a :: a a -> Bool\r
+\r
+gLess{|UNIT|} _ _ = False\r
+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\r
+gLess{|EITHER|} fl fr (LEFT x) (LEFT y) = fl x y\r
+gLess{|EITHER|} fl fr (RIGHT x) (RIGHT y) = fr x y\r
+gLess{|EITHER|} fl fr (LEFT x) (RIGHT y) = True\r
+gLess{|EITHER|} fl fr (RIGHT x) (LEFT y) = False\r
+gLess{|CONS|} f (CONS x) (CONS y) = f x y\r
+gLess{|OBJECT|} f (OBJECT x) (OBJECT y) = f x y\r
+gLess{|FIELD|} f (FIELD x) (FIELD y) = f x y\r
+gLess{|Int|} x y = x < y\r
+gLess{|Char|} x y = x < y\r
+gLess{|Bool|} False y = y\r
+gLess{|Bool|} x y = False\r
+gLess{|Real|} x y = x < y\r
+gLess{|String|} x y = x < y\r
+\r
+derive gLess [], (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,), (,,,,,,,,), (,,,,,,,,,)\r
+\r
+(-<-) infix 4 :: !a !a -> Bool | gLess{|*|} a\r
+(-<-) x y = gLess{|*|} x y\r
+\r
+(->-) infix 4 :: !a !a -> Bool | gLess{|*|} a\r
+(->-) x y = gLess{|*|} y x\r
+\r
+(-<=) infix 4 :: !a !a -> Bool | gLess{|*|} a\r
+(-<=) x y = not (gLess{|*|} y x)\r
+\r
+(=>-) infix 4 :: !a !a -> Bool | gLess{|*|} a\r
+(=>-) x y = not (gLess{|*|} x y)\r
+\r
repositories / tt2015.git / blobdiff