home *** CD-ROM | disk | FTP | other *** search
/ PSION CD 2 / PsionCDVol2.iso / Programs / 876 / hugs.sis / GenericPrint.hs < prev    next >
Encoding:
Text File  |  2000-09-21  |  10.7 KB  |  383 lines
  1. ----------------------------------------------------------------
  2. -- A "generic" (or "polymorphic") print function in Haskell
  3. -- This is very heavily based on the code in printer.c
  4. -- (Together with the decompiler and error catching primitives,
  5. -- this might make a good base on which to build a debugger?)
  6. --
  7. -- NB This library is an _experimental_ feature which may be
  8. --    removed in future versions of Hugs.
  9. --    It can only be used if Hugs was configured with the
  10. --    "--enable-internal--prims" flag.
  11. ----------------------------------------------------------------
  12.  
  13. module GenericPrint(
  14.         printError, 
  15.         outputString, 
  16.         print
  17.         ) where
  18.  
  19. import Prelude hiding (print)
  20.  
  21. import HugsInternals(
  22.         Name, nameInfo, nameString,
  23.         Cell, getCell,
  24.         CellKind(..), classifyCell,
  25.         )
  26.  
  27. import IOExts( unsafePerformIO )
  28. import Array
  29.  
  30. ----------------------------------------------------------------
  31. -- The top-level print routine 
  32. ----------------------------------------------------------------
  33.  
  34. printError   :: Cell -> IO ()
  35. outputString :: String -> IO ()
  36. print        :: a -> IO ()
  37.  
  38. printError err = do
  39.   putStr "\nProgram error: " 
  40.   printDBadRedex err 
  41.   putStr "\n"
  42.  
  43. outputString s = outputStr (getCell s)
  44.  
  45. print x        = print' True (getCell x)
  46.  
  47. ----------------------------------------------------------------
  48.  
  49. printBadRedex err = do
  50.   putChar '{' 
  51.   print' False err 
  52.   putChar '}'
  53.  
  54. printDBadRedex err = do
  55.   kind <- classifyCell False err
  56.   case kind of
  57.   Apply fun args -> do
  58.       funkind <- classifyCell False fun
  59.       case (funkind, args) of
  60.       (Fun nm, [msg]) | nm == nameError ->
  61.         outputStr msg
  62.       _ -> printBadRedex err
  63.   _ -> printBadRedex err
  64.  
  65. outputStr :: Cell -> IO ()
  66. outputStr xs = do
  67.   kind <- hugsClassifyCell True xs
  68.   case kind of
  69.   Apply fun args ->
  70.       hugsClassifyCell True fun >>= \ funkind ->
  71.       case (funkind, args) of
  72.       (Con nm, [y,ys]) | nm == nameCons ->
  73.         hugsClassifyCell True y >>= \ ykind ->
  74.         case ykind of
  75.         Char c ->
  76.           putChar c >>
  77.           outputStr ys
  78.         Error err ->
  79.           printBadRedex err >>
  80.           outputStr ys
  81.         _ ->
  82.           printBadRedex y >>
  83.           outputStr ys
  84.       (Error err, _) ->
  85.         printBadRedex err
  86.       _ ->
  87.         printBadRedex xs
  88.   Con nm | nm == nameNil ->
  89.         return ()
  90.   Error err ->
  91.         printBadRedex err
  92.   _ ->
  93.         printBadRedex xs
  94.  
  95. print' :: Bool -> Cell -> IO ()
  96. print' strict x = printCell strict min_prec x
  97.  
  98. --ToDo: combine with sprint (if possible)
  99. lprint :: Bool -> Cell -> Cell -> IO ()
  100. lprint strict x xs =
  101.   printCell strict min_prec x >>
  102.   hugsClassifyCell strict xs >>= \ kind ->
  103.   case kind of
  104.   Apply fun args ->
  105.       hugsClassifyCell strict fun >>= \ funkind ->
  106.         case (funkind, args) of
  107.         (Con nm, [y,ys]) | nm == nameCons ->
  108.           putStr ", " >>
  109.           lprint strict y ys
  110.         (Error err, _) ->
  111.           printBadRedex err
  112.         _ ->
  113.           putStr "] ++ " >>
  114.           printBadRedex xs
  115.   Con nm | nm == nameNil ->
  116.           putChar ']'
  117.   Error err ->
  118.           printBadRedex err
  119.   _ ->
  120.           putStr "] ++ " >>
  121.           printBadRedex xs
  122.  
  123. sprint :: Bool -> Char -> Cell -> IO ()
  124. sprint strict c xs =
  125.   putStr (showLitChar c "") >>
  126.   hugsClassifyCell strict xs >>= \ kind ->
  127.   case kind of
  128.   Apply fun args ->
  129.       hugsClassifyCell strict fun >>= \ funkind ->
  130.         case (funkind, args) of
  131.         (Con nm, [y,ys]) | nm == nameCons ->
  132.           hugsClassifyCell strict y >>= \ ykind ->
  133.           case ykind of
  134.           Char c -> sprint strict c ys
  135.           _      -> lprint False y ys
  136.         _ ->
  137.           putStr "\" ++ " >>
  138.           printBadRedex xs
  139.   Con nm | nm == nameNil ->
  140.           putChar '"'
  141.   _ ->
  142.           putStr "\" ++ " >>
  143.           printBadRedex xs
  144.  
  145. printCell :: Bool -> Int -> Cell -> IO ()
  146. printCell strict d x =
  147.   hugsClassifyCell strict x >>= \ kind ->
  148.   case kind of
  149.   Apply fun args ->
  150.       hugsClassifyCell strict fun >>= \ funkind ->
  151.       case funkind of
  152.       Con nm ->
  153.         case args of
  154.           [x,xs] | nm == nameCons
  155.             -> hugsClassifyCell strict x >>= \ xkind ->
  156.                case xkind of
  157.                Char c -> putChar '"' >> sprint strict c xs
  158.                _      -> putChar '[' >> lprint strict x xs
  159.  
  160.           [x] | assoc /= 'A'
  161.             -> printParen True (
  162.                  printCell strict (fun_prec-1) x >>
  163.                  putChar ' ' >>
  164.                  putStr (asOp nameStr)
  165.                )
  166.  
  167.           (x1:x2:xs) | assoc /= 'A'
  168.             -> printParen (not (null xs) && d >= fun_prec) (
  169.                  printParen (d <= p) (do
  170.                    printCell strict lp x1
  171.                    putChar ' '           
  172.                    putStr (asOp nameStr) 
  173.                    putChar ' '           
  174.                    printCell strict rp x2
  175.                    ) >>
  176.                  mapM_ (\ arg ->
  177.                    putChar ' ' >>
  178.                    printCell strict p arg
  179.                  ) xs
  180.                  )
  181.  
  182.           xs
  183.             -> printParen (not (null xs) && d >= fun_prec) (
  184.                  -- test that xs is nonNull should be redundant but
  185.                  -- no harm being robust
  186.                  putStr (asVar nameStr)       >>
  187.                  mapM_ (\arg ->
  188.                    putChar ' ' >>
  189.                    printCell strict fun_prec arg
  190.                  ) xs
  191.                  )
  192.          where
  193.           (arity, p, assoc) = nameInfo nm
  194.           nameStr = nameString nm
  195.  
  196.           -- from Appendix E2 of Haskell 1.2 report
  197.           lp = if assoc == 'L' then p else p+1
  198.           rp = if assoc == 'R' then p else p+1
  199.         
  200.       Fun nm ->
  201.         printParen (d >= fun_prec) (
  202.           putStr (asVar nameStr)       >>
  203.           mapM_ (\arg ->
  204.             putChar ' ' >>
  205.             -- switch to lazy printing!
  206.             printCell False fun_prec arg
  207.           ) args
  208.           )
  209.        where
  210.         nameStr = nameString nm
  211.       
  212.       Tuple arity ->
  213.         printParen (not (null extra) && d >= fun_prec) (
  214.           printParen True (
  215.             for__ fields (\ field ->
  216.               printCell strict min_prec field
  217.             ) (putChar ',') >>
  218.             -- Haskell's syntax makes it impossible to construct an
  219.             -- incomplete tuple - but let's play safe!
  220.             mapM_ (\_ ->
  221.               putChar ','
  222.             ) [numArgs+1..arity]
  223.           ) >>
  224.           -- Haskell's type system makes extra arguments impossible
  225.           -- - but let's play safe!
  226.           mapM_ (\ arg ->
  227.             putChar ' ' >>
  228.             printCell strict fun_prec arg
  229.           ) extra
  230.         )
  231.        where
  232.         (fields, extra) = splitAt arity args
  233.  
  234.       Error err ->
  235.           printBadRedex err
  236.  
  237.       _
  238.         -> printParen (not (null args) && d >= fun_prec) (
  239.              printCell strict fun_prec fun   >>
  240.              mapM_ (\arg ->
  241.                putChar ' ' >>
  242.                printCell strict fun_prec arg
  243.              ) args
  244.              )
  245.      where
  246.         numArgs = length args
  247.  
  248.   Fun nm ->
  249.     putStr (asVar (nameString nm))
  250.  
  251.   Con nm ->
  252.     putStr (asVar (nameString nm))
  253.  
  254.   Tuple arity ->
  255.     putStr ('(' : replicate arity ',' ++ ")")
  256.  
  257.   Int x ->
  258.     putStr (show x)
  259.  
  260.   Integer x ->
  261.     putStr (show x)
  262.  
  263.   Float x ->
  264.     putStr (show x)
  265.  
  266.   Char x ->
  267.     putStr ('\'' : showLitChar x "\'")
  268.  
  269.   Prim prim ->
  270.     putStr prim
  271.  
  272.   Error err ->
  273.     printBadRedex err
  274.  
  275. ----------------------------------------------------------------
  276. -- Cell/Name utilities
  277. ----------------------------------------------------------------
  278.  
  279. nameCons    =  cellName (:)
  280. nameNil     =  cellName []
  281. nameError   =  cellName error
  282.  
  283. -- Here's something VERY subtle.
  284. -- We use classifyCell instead of hugsClassifyCell because
  285. -- otherwise, this gets put in the same dependency class as everything
  286. -- else and the lack of polymorphic recursion bites us.
  287. -- (Using classifyCell is equally good here because it wont fail.)
  288. cellName :: a -> Name
  289. cellName x = unsafePerformIO (
  290.   classifyCell True (getCell x) >>= \ kind ->
  291.   case kind of
  292.   Fun nm -> return nm
  293.   Con nm -> return nm
  294.   )
  295.  
  296. -- This implements the error-handling policy:
  297. hugsClassifyCell :: Bool -> Cell -> IO CellKind
  298. hugsClassifyCell strict obj =
  299.   classifyCell strict obj >>= \ kind ->
  300.   case kind of
  301.   Error err ->
  302.     if failOnError then
  303.       exitWith (printError err)
  304.     else
  305.       return kind
  306.   _ ->
  307.     return kind
  308.  
  309. ----------------------------------------------------------------
  310. -- Utilities
  311. ----------------------------------------------------------------
  312.  
  313. intersperse :: a -> [a] -> [a]
  314. intersperse x (y:ys@(_:_)) = y : x : intersperse x ys
  315. intersperse x ys = ys
  316.  
  317. for__ :: Monad m => [a] -> (a -> m ()) -> m () -> m ()
  318. for__ xs f inc = sequence $ intersperse inc $ map f xs
  319.  
  320. min_prec, max_prec, fun_prec :: Int
  321. min_prec = 0
  322. max_prec = 9
  323. fun_prec = max_prec+2
  324.  
  325. asOp str
  326.  | isOp str  = str
  327.  | otherwise = '`' : str ++ "`"
  328.  
  329. asVar str
  330.  | isOp str  = '(' : str ++ ")"
  331.  | otherwise = str
  332.  
  333. isOp (c:_) = not (isAlpha c || c == '[')
  334. isOp _     = False
  335.  
  336. printParen :: Bool -> IO () -> IO ()
  337. printParen True m  = putChar '(' >> m >> putChar ')'
  338. printParen False m = m
  339.  
  340. ----------------------------------------------------------------
  341. -- Missing primitives
  342. ----------------------------------------------------------------
  343.  
  344. -- In Hugs0, this accessed the value of the :set -f" flag
  345. failOnError :: Bool
  346. failOnError = True
  347.  
  348. -- In Hugs0, this executed the action and terminated the current evaluation
  349. exitWith :: IO () -> IO a
  350. exitWith m = m >> error "{exitWith}"
  351.  
  352. ----------------------------------------------------------------
  353. -- from Prelude.hs
  354. ----------------------------------------------------------------
  355. {-
  356. showLitChar               :: Char -> ShowS
  357. showLitChar c | c > '\DEL' = showChar '\\' . protectEsc isDigit (shows (fromEnum c))
  358. showLitChar '\DEL'         = showString "\\DEL"
  359. showLitChar '\\'           = showString "\\\\"
  360. showLitChar c | c >= ' '   = showChar c
  361. showLitChar '\a'           = showString "\\a"
  362. showLitChar '\b'           = showString "\\b"
  363. showLitChar '\f'           = showString "\\f"
  364. showLitChar '\n'           = showString "\\n"
  365. showLitChar '\r'           = showString "\\r"
  366. showLitChar '\t'           = showString "\\t"
  367. showLitChar '\v'           = showString "\\v"
  368. showLitChar '\SO'          = protectEsc ('H'==) (showString "\\SO")
  369. showLitChar c              = showString ('\\' : asciiTab!c)
  370.  
  371. asciiTab = listArray ('\NUL', ' ')
  372.            ["NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL",
  373.             "BS",  "HT",  "LF",  "VT",  "FF",  "CR",  "SO",  "SI",
  374.             "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB",
  375.             "CAN", "EM",  "SUB", "ESC", "FS",  "GS",  "RS",  "US",
  376.             "SP"]
  377.  
  378. protectEsc p f             = f . cont
  379.  where cont s@(c:_) | p c  = "\\&" ++ s
  380.        cont s              = s
  381. -}
  382. ----------------------------------------------------------------
  383.