content: {-# LANGUAGE GADTs, TypeSynonymInstances, FlexibleInstances #-}
  module PrintTTR where
  
  -- pretty-printer generated by the BNF converter
  
  import AbsTTR
  import Data.Char
  import Data.List (intersperse)
  
  -- the top-level printing method
  printTree :: Print a => a -> String
  printTree = render . prt 0
  
  type Doc = [ShowS] -> [ShowS]
  
  doc :: ShowS -> Doc
  doc = (:)
  
  render :: Doc -> String
  render d = rend 0 (map ($ "") $ d []) "" where
    rend i ss = case ss of
      "["      :ts -> showChar '[' . rend i ts
      "("      :ts -> showChar '(' . rend i ts
      "{"      :ts -> showChar '{' . new (i+1) . rend (i+1) ts
      "}" : ";":ts -> new (i-1) . space "}" . showChar ';' . new (i-1) . rend (i-1) ts
      "}"      :ts -> new (i-1) . showChar '}' . new (i-1) . rend (i-1) ts
      ";"      :ts -> showChar ';' . new i . rend i ts
      t  : "," :ts -> showString t . space "," . rend i ts
      t  : ")" :ts -> showString t . showChar ')' . rend i ts
      t  : "]" :ts -> showString t . showChar ']' . rend i ts
      t        :ts -> space t . rend i ts
      _            -> id
    new i   = showChar '\n' . replicateS (2*i) (showChar ' ') . dropWhile isSpace
    space t = showString t . (\s -> if null s then "" else (' ':s))
  
  parenth :: Doc -> Doc
  parenth ss = doc (showChar '(') . ss . doc (showChar ')')
  
  concatS :: [ShowS] -> ShowS
  concatS = foldr (.) id
  
  concatD :: [Doc] -> Doc
  concatD = foldr (.) id
  
  unwordsD :: [Doc] -> Doc
  unwordsD = concatD . intersperse (doc (showChar ' '))
  
  replicateS :: Int -> ShowS -> ShowS
  replicateS n f = concatS (replicate n f)
  
  -- the printer class does the job
  class Print a where
    prt :: Int -> a -> Doc
  
  instance Print Char where
    prt _ s = doc (showChar '\'' . mkEsc '\'' s . showChar '\'')
  
  instance Print String where
    prt _ s = doc (showChar '"' . concatS (map (mkEsc '"') s) . showChar '"')
  
  mkEsc :: Char -> Char -> ShowS
  mkEsc q s = case s of
    _ | s == q -> showChar '\\' . showChar s
    '\\'-> showString "\\\\"
    '\n' -> showString "\\n"
    '\t' -> showString "\\t"
    _ -> showChar s
  
  prPrec :: Int -> Int -> Doc -> Doc
  prPrec i j = if j<i then parenth else id
  
  
  instance Print Integer where
    prt _ x = doc (shows x)
  
  
  instance Print Double where
    prt _ x = doc (shows x)
  
  
  instance Print (Tree c) where
    prt _i e = case e of
      TJments jments -> prPrec _i 0 (concatD [prt 0 jments])
      JIn exp0 exp1 -> prPrec _i 0 (concatD [prt 0 exp0 , doc (showString ":") , prt 0 exp1])
      JEq exp0 exp1 -> prPrec _i 0 (concatD [prt 0 exp0 , doc (showString "=") , prt 0 exp1])
      JEqIn exp0 exp1 exp2 -> prPrec _i 0 (concatD [prt 0 exp0 , doc (showString "=") , prt 0 exp1 , doc (showString ":") , prt 0 exp2])
      JSub exp0 exp1 -> prPrec _i 0 (concatD [prt 0 exp0 , doc (showString "<") , prt 0 exp1])
      JSubIn exp0 exp1 exp2 -> prPrec _i 0 (concatD [prt 0 exp0 , doc (showString "<") , prt 0 exp1 , doc (showString ":") , prt 0 exp2])
      EId id -> prPrec _i 5 (concatD [prt 0 id])
      EStr str -> prPrec _i 5 (concatD [prt 0 str])
      EInt n -> prPrec _i 5 (concatD [prt 0 n])
      EFloat d -> prPrec _i 5 (concatD [prt 0 d])
      ERecTyp  -> prPrec _i 5 (concatD [doc (showString "RecType")])
      ERecord fields -> prPrec _i 5 (concatD [doc (showString "{") , prt 0 fields , doc (showString "}")])
      ESetTy exp -> prPrec _i 5 (concatD [doc (showString "{") , prt 0 exp , doc (showString "}")])
      EListTy exp -> prPrec _i 5 (concatD [doc (showString "[") , prt 0 exp , doc (showString "]")])
      EApps exp exps -> prPrec _i 5 (concatD [prt 5 exp , doc (showString "(") , prt 0 exps , doc (showString ")")])
      ELamApp lambdas exp exps -> prPrec _i 4 (concatD [doc (showString "<") , prt 0 lambdas , doc (showString ".") , prt 4 exp , doc (showString ",") , doc (showString "<") , prt 0 exps , doc (showString ">") , doc (showString ">")])
      EProj exp id -> prPrec _i 4 (concatD [prt 4 exp , doc (showString ".") , prt 0 id])
      ECompl exp -> prPrec _i 2 (concatD [doc (showString "~") , prt 2 exp])
      EJoin exp0 id1 exp2 -> prPrec _i 2 (concatD [doc (showString "JOIN") , doc (showString "[") , prt 0 exp0 , doc (showString "]") , doc (showString "(") , prt 0 id1 , doc (showString "->") , prt 0 exp2 , doc (showString ")")])
      EUnion exp0 exp1 -> prPrec _i 1 (concatD [prt 1 exp0 , doc (showString "||") , prt 2 exp1])
      EInters exp0 exp1 -> prPrec _i 1 (concatD [prt 1 exp0 , doc (showString "&&") , prt 2 exp1])
      EMerge exp0 exp1 -> prPrec _i 1 (concatD [prt 1 exp0 , doc (showString "&.&") , prt 2 exp1])
      EConcat exp0 exp1 -> prPrec _i 1 (concatD [prt 1 exp0 , doc (showString "^") , prt 2 exp1])
      ELambs lambdas exp -> prPrec _i 0 (concatD [prt 0 lambdas , doc (showString ".") , prt 1 exp])
      EProd id exp0 exp1 -> prPrec _i 0 (concatD [doc (showString "(") , prt 0 id , doc (showString ":") , prt 0 exp0 , doc (showString ")") , doc (showString "->") , prt 0 exp1])
      EFun exp0 exp1 -> prPrec _i 0 (concatD [prt 1 exp0 , doc (showString "->") , prt 0 exp1])
      ECFun exp0 exp1 -> prPrec _i 0 (concatD [prt 1 exp0 , doc (showString "->_c") , prt 0 exp1])
      ELet id exp0 exp1 exp2 -> prPrec _i 0 (concatD [doc (showString "let") , prt 0 id , doc (showString "=") , prt 0 exp0 , doc (showString ":") , prt 0 exp1 , doc (showString "in") , prt 0 exp2])
      EMul exp0 exp1 -> prPrec _i 4 (concatD [prt 4 exp0 , doc (showString "*") , prt 5 exp1])
      EDiv exp0 exp1 -> prPrec _i 4 (concatD [prt 4 exp0 , doc (showString "/") , prt 5 exp1])
      EAdd exp0 exp1 -> prPrec _i 3 (concatD [prt 3 exp0 , doc (showString "+") , prt 4 exp1])
      ESub exp0 exp1 -> prPrec _i 3 (concatD [prt 3 exp0 , doc (showString "-") , prt 4 exp1])
      ECat exp0 exp1 -> prPrec _i 3 (concatD [prt 3 exp0 , doc (showString "++") , prt 4 exp1])
      EAbs id exp0 exp1 -> prPrec _i 1 (concatD [doc (showString "\\") , prt 0 id , doc (showString ":") , prt 5 exp0 , doc (showString ".") , prt 1 exp1])
      EApp exp0 exp1 -> prPrec _i 4 (concatD [prt 5 exp0 , doc (showString "(") , prt 0 exp1 , doc (showString ")")])
      FIn id exp -> prPrec _i 0 (concatD [prt 0 id , doc (showString ":") , prt 0 exp])
      FEq id exp -> prPrec _i 0 (concatD [prt 0 id , doc (showString "=") , prt 0 exp])
      FEqIn id exp0 exp1 -> prPrec _i 0 (concatD [prt 0 id , doc (showString "=") , prt 0 exp0 , doc (showString ":") , prt 0 exp1])
      LAbs id exp -> prPrec _i 0 (concatD [doc (showString "\\") , prt 0 id , doc (showString ":") , prt 5 exp])
      Id str -> prPrec _i 0 (doc (showString str))
  
  instance Print [Jment] where
    prt _ es = case es of
     [] -> (concatD [])
     x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
  instance Print [Exp] where
    prt _ es = case es of
     [] -> (concatD [])
     [x] -> (concatD [prt 0 x])
     x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
  instance Print [Field] where
    prt _ es = case es of
     [] -> (concatD [])
     [x] -> (concatD [prt 0 x])
     x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
  instance Print [Lambda] where
    prt _ es = case es of
     [x] -> (concatD [prt 0 x])
     x:xs -> (concatD [prt 0 x , prt 0 xs])
  