1   module Print where
    2 
    3 
    4   import LambdaLift
    5   import Utilities
    6 
    7 
    8 
    9   pprint :: (binder -> Iseq) -> Expr binder -> [Char]
   10   pprint pb e = i_mkstr (ppr pb e)
   11 
   12 
   13 
   14   pprintExpr = pprint i_str
   15 
   16 
   17 
   18   pprintLevel :: (Expr ([Char], Integer)) -> [Char]
   19  
   20   pprintLevel = pprint (\(name,level) -> i_concat [ i_str name, i_str "{",
   21                                                     i_num level, i_str "}" ])
   22 
   23 
   24 
   25   pprintSCs scs = i_mkstr (i_concat (map ppsc scs))
   26   ppsc (name, args, rhs) = 
   27         i_concat [ i_newline, i_str name, i_str " ",
   28                    i_interleave (i_str " ") (map i_str args),
   29                    i_str " = ",
   30                    i_indent 6 (ppr i_str rhs) ]
   31 
   32 
   33 
   34   ppr pb (EAp e1 e2) = i_concat [ppr pb e1, i_space, ppr_atomic pb e2]
   35   ppr pb (ELet isrec defs e) =
   36     i_concat [  i_str keyword, i_newline,
   37                 i_indent 4 (i_interleave (i_str ";\n") (map (ppr_def pb) defs)),
   38                 i_str "\nin ", 
   39                 ppr pb e
   40     ]
   41     where
   42     keyword | isrec     = "letrec"
   43             | not isrec = "let"
   44   ppr pb (ELam args body) =
   45     i_concat [ i_str "\\[", 
   46                i_interleave (i_str ",") (map pb args),
   47                i_str "] ", ppr pb body ]
   48  
   49   ppr pb e = ppr_atomic pb e
   50  
   51   ppr_atomic pb (EConst (CNum n))       = i_num n
   52   ppr_atomic pb (EConst (CFun name))    = i_str name
   53   ppr_atomic pb (EConst (CBool b))      = i_str (show b)
   54   ppr_atomic pb (EVar v)                = i_str v
   55   ppr_atomic pb e = i_concat [i_str "(", ppr pb e, i_str ")"]
   56 
   57 
   58 
   59 
   60   ppr_def pb (binder, (ELam args body)) =
   61     i_concat [  pb binder, i_space,
   62                 i_interleave i_space (map pb args),
   63                 i_str " = ",
   64                 ppr pb body
   65     ]
   66   ppr_def pb (binder, rhs) = i_concat [pb binder, i_str " = ", ppr pb rhs]
   67  
   68 
   69 
   70 
   71 
   72 
   73 
   74 
   75 
   76 
   77 
   78 
   79 
   80 
   81 
   82 
   83 
   84 
   85 
   86 
   87 
   88 
   89 
   90 
   91 
   92 
   93 
   94 
   95 
   96 
   97 
   98 
   99 
  100 
  101   type Iseq = Oseq -> Oseq
  102 
  103 
  104 
  105 
  106 
  107   i_concat :: [Iseq] -> Iseq
  108   i_concat = foldr i_append i_nil
  109 
  110 
  111 
  112 
  113   i_interleave :: Iseq -> [Iseq] -> Iseq
  114   i_interleave is []  = i_nil
  115   i_interleave is iss = foldr1 glue iss
  116                         where glue is1 is2 = is1 `i_append` (is `i_append` is2)
  117                               foldr1 f [x] = x
  118                               foldr1 f (x:xs) = f x (foldr1 f xs)
  119 
  120 
  121 
  122   i_num :: Num a => a -> Iseq
  123   i_num = i_str . show
  124 
  125   i_newline     = i_str "\n"
  126   i_space       = i_str " "
  127 
  128 
  129 
  130 
  131 
  132 
  133 
  134   type Oseq = Int -> Bool -> [Char]
  135 
  136 
  137 
  138   o_empty :: Oseq              -- An empty oseq
  139   o_empty indent npend = []
  140  
  141   o_mkstr :: Oseq -> [Char]
  142   o_mkstr oseq = oseq 0 False
  143 
  144 
  145 
  146 
  147 
  148 
  149 
  150   i_nil x = x
  151   i_append = (.)
  152   i_str = foldr (i_append . i_char) i_nil
  153   i_mkstr iseq = o_mkstr (iseq o_empty)
  154 
  155 
  156 
  157 
  158 
  159 
  160 
  161 
  162   i_char :: Char -> Iseq
  163   i_char '\n' rest indent npend = '\n' : rest indent True
  164   i_char c    rest indent False = c    : rest indent False
  165   i_char c    rest indent True  = pspaces indent (c : rest indent False)
  166 
  167 
  168 
  169 
  170   i_indent n iseq oseq indent npend =
  171     iseq oseq' (indent+n) npend
  172     where 
  173     oseq' indent' npend' = oseq indent npend'
  174     -- Ignore the indent passed along to oseq; 
  175     -- use the original indent instead.
  176 
  177 
  178 
  179   pspaces 0 cs = cs
  180   pspaces n cs = ' ' : pspaces (n-1) cs
  181 
  182 
  183 
  184 
  185 
  186 
  187 
  188