a3/code/Generics/GenLexOrd.icl

   1 implementation module GenLexOrd
   2
   3 import StdEnv
   4 import StdGeneric, GenEq
   5
   6 :: LexOrd = LT |EQ | GT
   7 derive gEq LexOrd
   8
   9 generic gLexOrd a b :: a b -> LexOrd
  10 gLexOrd{|Int|} x y
  11         | x == y = EQ
  12         | x < y  = LT
  13                          = GT
  14 gLexOrd{|Bool|} True True = EQ
  15 gLexOrd{|Bool|} False True = LT
  16 gLexOrd{|Bool|} True False = GT
  17 gLexOrd{|Bool|} False False = EQ
  18 gLexOrd{|Real|} x y
  19         | x == y = EQ
  20         | x < y  = LT
  21                          = GT
  22 gLexOrd{|Char|} x y
  23         | x == y = EQ
  24         | x < y  = LT
  25                          = GT
  26 gLexOrd{|String|} x y
  27         | x == y = EQ
  28         | x < y  = LT
  29                          = GT
  30 gLexOrd{|UNIT|} UNIT UNIT = EQ
  31 gLexOrd{|PAIR|} fx fy (PAIR x1 y1) (PAIR x2 y2) = case fx x1 x2 of
  32                 EQ -> fy y1 y2
  33                 LT -> LT
  34                 GT -> GT
  35
  36 gLexOrd{|EITHER|} fl fr (LEFT x) (LEFT y) = fl x y
  37 gLexOrd{|EITHER|} fl fr (LEFT x) (RIGHT y) = LT
  38 gLexOrd{|EITHER|} fl fr (RIGHT x) (LEFT y) = GT
  39 gLexOrd{|EITHER|} fl fr (RIGHT x) (RIGHT y) = fr x y
  40 gLexOrd{|CONS|} f (CONS x) (CONS y) = f x y
  41 gLexOrd{|FIELD|} f (FIELD x) (FIELD y) = f x y
  42 gLexOrd{|OBJECT|} f (OBJECT x) (OBJECT y) = f x y
  43
  44 // Instance on standard lists is needed because
  45 // standard lists have unnatural internal ordering of constructors: Cons < Nil,
  46 // i.e Cons is LEFT and Nil is RIGHT in the generic representation.
  47 // We want ordering Nil < Cons
  48 gLexOrd{|[]|} f [] [] = EQ
  49 gLexOrd{|[]|} f [] _  = LT
  50 gLexOrd{|[]|} f _ []  = GT
  51 gLexOrd{|[]|} f [x:xs] [y:ys] = gLexOrd{|*->*->*|} f (gLexOrd{|*->*|} f) (PAIR x xs) (PAIR y ys)
  52
  53 gLexOrd{|{}|} f xs ys   = lexOrdArray f xs ys
  54 gLexOrd{|{!}|} f xs ys  = lexOrdArray f xs ys
  55
  56
  57 // standard types
  58 derive gLexOrd (,), (,,),  (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)
  59
  60
  61 (=?=) infix 4 :: a a -> LexOrd | gLexOrd{|*|} a
  62 (=?=) x y = gLexOrd{|*|} x y
  63
  64
  65 lexOrdArray f xs ys
  66         #! size_xs = size xs
  67         #! size_ys = size ys
  68         | size_xs < size_ys     = LT
  69         | size_xs > size_ys = GT
  70         | otherwise                     = lexord 0 size_xs xs ys
  71 where
  72         lexord i n xs ys
  73                 | i == n                = EQ
  74                 | otherwise     = case f xs.[i] ys.[i] of
  75                                 LT -> LT
  76                                 GT -> GT
  77                                 EQ -> lexord (inc i) n xs ys