ghc/interpreter/test/unused/testDebug.hs

   1
   2 simpleLazyPrint :: a -> IO ()
   3 simpleLazyPrint x = print (primGetHugsObject x)
   4  where
   5   -- Extra level of indirection introduced to overcome lack of
   6   -- polymorphic recursion!
   7   print :: HugsObject -> IO ()
   8   print x =
   9     primClassifyObject False x >>= \ kind ->
  10     case kind of
  11     HugsApply fun args ->
  12       putChar '('    >>
  13       print fun      >>
  14       for_ args (\arg ->
  15         putChar ' ' >>
  16         print arg
  17       ) >>
  18       putChar ')'
  19
  20     HugsFun nm ->
  21       putStr (primNameString nm)
  22
  23     HugsCon nm ->
  24       putStr (primNameString nm)
  25
  26     HugsTuple arity ->
  27       putStr ('(' : replicate arity ',' ++ ")")
  28
  29     HugsInt x ->
  30       putStr (show x)
  31
  32     HugsInteger x ->
  33       putStr (show x)
  34
  35     HugsFloat x ->
  36       putStr (show x)
  37
  38     HugsChar x ->
  39       putStr ('\'' : showLitChar x "\'")
  40
  41     HugsPrim prim ->
  42       putStr prim
  43
  44     HugsError err ->
  45       print err
  46
  47 simpleStrictPrint :: a -> IO ()
  48 simpleStrictPrint x = print (primGetHugsObject x)
  49  where
  50   -- Extra level of indirection introduced to overcome lack of
  51   -- polymorphic recursion!
  52   print :: HugsObject -> IO ()
  53   print x =
  54     primClassifyObject True x >>= \ kind ->
  55     case kind of
  56     HugsApply fun args ->
  57       putChar '('    >>
  58       print fun      >>
  59       for_ args (\arg ->
  60         putChar ' ' >>
  61         print arg
  62       ) >>
  63       putChar ')'
  64
  65     HugsFun nm ->
  66       putStr (primNameString nm)
  67
  68     HugsCon nm ->
  69       putStr (primNameString nm)
  70
  71     HugsTuple arity ->
  72       putStr ('(' : replicate arity ',' ++ ")")
  73
  74     HugsInt x ->
  75       putStr (show x)
  76
  77     HugsInteger x ->
  78       putStr (show x)
  79
  80     HugsFloat x ->
  81       putStr (show x)
  82
  83     HugsChar x ->
  84       putStr ('\'' : showLitChar x "\'")
  85
  86     HugsPrim prim ->
  87       putStr prim
  88
  89     HugsError err ->
  90       -- could call lazy print (if object printer was exposed)
  91       putStr "{error}"
  92
  93 s1 = simpleStrictPrint (error "foo")
  94 s2 = simpleStrictPrint (1 + error "foo")
  95
  96
  97 -- test
  98
  99 lazyPrint   x = hugsPrinter False (primGetHugsObject x)
 100 strictPrint x = hugsPrinter True (primGetHugsObject x)
 101
 102 t1 = lazyPrint (True &&)
 103 t2 = lazyPrint (1:)
 104 t3 = lazyPrint ('a':)
 105 t4 = lazyPrint (1 `elem`)
 106 t5 = lazyPrint "abcd"
 107 t6 = strict lazyPrint (1 `elem`)
 108
 109 t11 = strictPrint (True &&)
 110 t12 = strictPrint (1:)
 111 t13 = strictPrint ('a':)
 112 t14 = strictPrint (1 `elem`)
 113 t15 = strictPrint "abcd"
 114 t16 = strictPrint (take 10 [1..])
 115 t17 = strictPrint [1..]
 116 t18 = strictPrint (pi::Float)  -- used to fail because pi is a CAF.
 117 t19 = strictPrint '\DEL'
 118
 119 {-
 120 Known Bugs:
 121
 122 * Prints "(||) True False" (in lazy mode) instead of "True || False".
 123
 124   This is a deliberate change from the original Hugs version (in builtin.c)
 125   which would print: '{dict} !! "abcd"' for ("abcd" !!) instead of
 126   '(!!) {dict} "abcd"' or '("abcd" `(||) {dict}`)'.
 127
 128   (This is a feature not a bug!)
 129
 130 * Should print errors to stderr.
 131
 132 -}