content: {-# OPTIONS_GHC -fglasgow-exts #-}
  module GFCC.Print where
  
  -- pretty-printer generated by the BNF converter
  
  import GFCC.Abs
  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
      Grm header abstract concretes -> prPrec _i 0 (concatD [prt 0 header , doc (showString ";") , prt 0 abstract , doc (showString ";") , prt 0 concretes])
      Hdr cid cids -> prPrec _i 0 (concatD [doc (showString "grammar") , prt 0 cid , doc (showString "(") , prt 0 cids , doc (showString ")")])
      Abs absdefs -> prPrec _i 0 (concatD [doc (showString "abstract") , doc (showString "{") , prt 0 absdefs , doc (showString "}")])
      Cnc cid cncdefs -> prPrec _i 0 (concatD [doc (showString "concrete") , prt 0 cid , doc (showString "{") , prt 0 cncdefs , doc (showString "}")])
      Fun cid type' exp -> prPrec _i 0 (concatD [prt 0 cid , doc (showString ":") , prt 0 type' , doc (showString "=") , prt 0 exp])
      Lin cid term -> prPrec _i 0 (concatD [prt 0 cid , doc (showString "=") , prt 0 term])
      Typ cids cid -> prPrec _i 0 (concatD [prt 0 cids , doc (showString "->") , prt 0 cid])
      Tr atom exps -> prPrec _i 0 (concatD [doc (showString "(") , prt 0 atom , prt 0 exps , doc (showString ")")])
      AC cid -> prPrec _i 0 (concatD [prt 0 cid])
      AS str -> prPrec _i 0 (concatD [prt 0 str])
      AI n -> prPrec _i 0 (concatD [prt 0 n])
      AF d -> prPrec _i 0 (concatD [prt 0 d])
      AM  -> prPrec _i 0 (concatD [doc (showString "?")])
      R terms -> prPrec _i 0 (concatD [doc (showString "[") , prt 0 terms , doc (showString "]")])
      P term0 term1 -> prPrec _i 0 (concatD [doc (showString "(") , prt 0 term0 , doc (showString "!") , prt 0 term1 , doc (showString ")")])
      S terms -> prPrec _i 0 (concatD [doc (showString "(") , prt 0 terms , doc (showString ")")])
      K tokn -> prPrec _i 0 (concatD [prt 0 tokn])
      V n -> prPrec _i 0 (concatD [doc (showString "$") , prt 0 n])
      C n -> prPrec _i 0 (concatD [prt 0 n])
      F cid -> prPrec _i 0 (concatD [prt 0 cid])
      FV terms -> prPrec _i 0 (concatD [doc (showString "[|") , prt 0 terms , doc (showString "|]")])
      W str term -> prPrec _i 0 (concatD [doc (showString "(") , prt 0 str , doc (showString "+") , prt 0 term , doc (showString ")")])
      RP term0 term1 -> prPrec _i 0 (concatD [doc (showString "(") , prt 0 term0 , doc (showString "@") , prt 0 term1 , doc (showString ")")])
      TM  -> prPrec _i 0 (concatD [doc (showString "?")])
      L cid term -> prPrec _i 0 (concatD [doc (showString "(") , prt 0 cid , doc (showString "->") , prt 0 term , doc (showString ")")])
      BV cid -> prPrec _i 0 (concatD [doc (showString "#") , prt 0 cid])
      KS str -> prPrec _i 0 (concatD [prt 0 str])
      KP strs variants -> prPrec _i 0 (concatD [doc (showString "[") , doc (showString "pre") , prt 0 strs , doc (showString "[") , prt 0 variants , doc (showString "]") , doc (showString "]")])
      Var strs0 strs1 -> prPrec _i 0 (concatD [prt 0 strs0 , doc (showString "/") , prt 0 strs1])
      CId str -> prPrec _i 0 (doc (showString str))
  
  instance Print [Concrete] where
    prt _ es = case es of
     [] -> (concatD [])
     x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
  instance Print [AbsDef] where
    prt _ es = case es of
     [] -> (concatD [])
     x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
  instance Print [CncDef] where
    prt _ es = case es of
     [] -> (concatD [])
     x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
  instance Print [CId] 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 [Term] 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 [Exp] where
    prt _ es = case es of
     [] -> (concatD [])
     x:xs -> (concatD [prt 0 x , prt 0 xs])
  instance Print [String] where
    prt _ es = case es of
     [] -> (concatD [])
     x:xs -> (concatD [prt 0 x , prt 0 xs])
  instance Print [Variant] where
    prt _ es = case es of
     [] -> (concatD [])
     [x] -> (concatD [prt 0 x])
     x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
  