{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
module PrintM where

-- pretty-printer generated by the BNF converter

import AbsM
import Data.Char


-- 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

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
  prtList :: Int -> [a] -> Doc
  prtList i = concatD . map (prt i)

instance Print a => Print [a] where
  prt = prtList

instance Print Char where
  prt _ s = doc (showChar '\'' . mkEsc '\'' s . showChar '\'')
  prtList _ 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 CID where
  prt _ (CID (_,i)) = doc (showString ( i))


instance Print BVAL where
  prt _ (BVAL i) = doc (showString ( i))


instance Print PIdent where
  prt _ (PIdent (_,i)) = doc (showString ( i))
  prtList _ [x] = (concatD [prt 0 x])
  prtList _ (x:xs) = (concatD [prt 0 x, doc (showString ","), prt 0 xs])


instance Print Prog where
  prt i e = case e of
    M block -> prPrec i 0 (concatD [prt 0 block])

instance Print Block where
  prt i e = case e of
    Program declarations programbody -> prPrec i 0 (concatD [prt 0 declarations, prt 0 programbody])

instance Print Declaration where
  prt i e = case e of
    Dec_Var vardeclaration -> prPrec i 0 (concatD [prt 0 vardeclaration])
    Dec_Fun fundeclaration -> prPrec i 0 (concatD [prt 0 fundeclaration])
    Dec_Data datadeclaration -> prPrec i 0 (concatD [prt 0 datadeclaration])
  prtList _ [] = (concatD [])
  prtList _ (x:xs) = (concatD [prt 0 x, doc (showString ";"), prt 0 xs])
instance Print VarDeclaration where
  prt i e = case e of
    D_Variable varspecs type_ -> prPrec i 0 (concatD [doc (showString "var"), prt 0 varspecs, doc (showString ":"), prt 0 type_])

instance Print VarSpec where
  prt i e = case e of
    V_Spec pident arraydimensions -> prPrec i 0 (concatD [prt 0 pident, prt 0 arraydimensions])
  prtList _ [] = (concatD [])
  prtList _ [x] = (concatD [prt 0 x])
  prtList _ (x:xs) = (concatD [prt 0 x, doc (showString ","), prt 0 xs])
instance Print ArrayDimension where
  prt i e = case e of
    ArrDim expr -> prPrec i 0 (concatD [doc (showString "["), prt 0 expr, doc (showString "]")])
  prtList _ [] = (concatD [])
  prtList _ (x:xs) = (concatD [prt 0 x, prt 0 xs])
instance Print Type where
  prt i e = case e of
    T_Int -> prPrec i 0 (concatD [doc (showString "int")])
    T_Real -> prPrec i 0 (concatD [doc (showString "real")])
    T_Bool -> prPrec i 0 (concatD [doc (showString "bool")])
    T_Char -> prPrec i 0 (concatD [doc (showString "char")])
    T_User pident -> prPrec i 0 (concatD [prt 0 pident])
  prtList _ [x] = (concatD [prt 0 x])
  prtList _ (x:xs) = (concatD [prt 0 x, doc (showString "*"), prt 0 xs])
instance Print FunDeclaration where
  prt i e = case e of
    D_Function pident paramlist type_ funblock -> prPrec i 0 (concatD [doc (showString "fun"), prt 0 pident, prt 0 paramlist, doc (showString ":"), prt 0 type_, doc (showString "{"), prt 0 funblock, doc (showString "}")])

instance Print FunBlock where
  prt i e = case e of
    FunctionBlock declarations funbody -> prPrec i 0 (concatD [prt 0 declarations, prt 0 funbody])

instance Print ParamList where
  prt i e = case e of
    ParameterList basicdeclarations -> prPrec i 0 (concatD [doc (showString "("), prt 0 basicdeclarations, doc (showString ")")])

instance Print BasicDeclaration where
  prt i e = case e of
    BasicDec pident basicarraydimensions type_ -> prPrec i 0 (concatD [prt 0 pident, prt 0 basicarraydimensions, doc (showString ":"), prt 0 type_])
  prtList _ [] = (concatD [])
  prtList _ [x] = (concatD [prt 0 x])
  prtList _ (x:xs) = (concatD [prt 0 x, doc (showString ","), prt 0 xs])
instance Print BasicArrayDimension where
  prt i e = case e of
    B_ArrDim -> prPrec i 0 (concatD [doc (showString "["), doc (showString "]")])
  prtList _ [] = (concatD [])
  prtList _ (x:xs) = (concatD [prt 0 x, prt 0 xs])
instance Print DataDeclaration where
  prt i e = case e of
    D_Data pident consdecls -> prPrec i 0 (concatD [doc (showString "data"), prt 0 pident, doc (showString "="), prt 0 consdecls])

instance Print ConsDecl where
  prt i e = case e of
    TypeComposition cid types -> prPrec i 0 (concatD [prt 0 cid, doc (showString "of"), prt 0 types])
    TypeConstructor cid -> prPrec i 0 (concatD [prt 0 cid])
  prtList _ [x] = (concatD [prt 0 x])
  prtList _ (x:xs) = (concatD [prt 0 x, doc (showString "|"), prt 0 xs])
instance Print ProgramBody where
  prt i e = case e of
    P_Body progstmts -> prPrec i 0 (concatD [doc (showString "begin"), prt 0 progstmts, doc (showString "end")])

instance Print FunBody where
  prt i e = case e of
    F_Body progstmts expr -> prPrec i 0 (concatD [doc (showString "begin"), prt 0 progstmts, doc (showString "return"), prt 0 expr, doc (showString ";"), doc (showString "end")])

instance Print ProgStmt where
  prt i e = case e of
    P_If expr progstmt1 progstmt2 -> prPrec i 0 (concatD [doc (showString "if"), prt 0 expr, doc (showString "then"), prt 0 progstmt1, doc (showString "else"), prt 0 progstmt2])
    P_While expr progstmt -> prPrec i 0 (concatD [doc (showString "while"), prt 0 expr, doc (showString "do"), prt 0 progstmt])
    P_Read location -> prPrec i 0 (concatD [doc (showString "read"), prt 0 location])
    P_Assign location expr -> prPrec i 0 (concatD [prt 0 location, doc (showString ":="), prt 0 expr])
    P_Print expr -> prPrec i 0 (concatD [doc (showString "print"), prt 0 expr])
    P_Block block -> prPrec i 0 (concatD [doc (showString "{"), prt 0 block, doc (showString "}")])
    P_Case expr cases -> prPrec i 0 (concatD [doc (showString "case"), prt 0 expr, doc (showString "of"), doc (showString "{"), prt 0 cases, doc (showString "}")])
  prtList _ [] = (concatD [])
  prtList _ (x:xs) = (concatD [prt 0 x, doc (showString ";"), prt 0 xs])
instance Print Location where
  prt i e = case e of
    L_Location pident arraydimensions -> prPrec i 0 (concatD [prt 0 pident, prt 0 arraydimensions])

instance Print Case where
  prt i e = case e of
    C_Case cid varlist progstmt -> prPrec i 0 (concatD [prt 0 cid, prt 0 varlist, doc (showString "=>"), prt 0 progstmt])
  prtList _ [x] = (concatD [prt 0 x])
  prtList _ (x:xs) = (concatD [prt 0 x, doc (showString "|"), prt 0 xs])
instance Print VarList where
  prt i e = case e of
    VL_List pidents -> prPrec i 0 (concatD [doc (showString "("), prt 0 pidents, doc (showString ")")])
    VL_End -> prPrec i 0 (concatD [])

instance Print Expr where
  prt i e = case e of
    B_Or expr bintterm -> prPrec i 0 (concatD [prt 0 expr, doc (showString "||"), prt 0 bintterm])
    B_Term bintterm -> prPrec i 0 (concatD [prt 0 bintterm])
  prtList _ [] = (concatD [])
  prtList _ [x] = (concatD [prt 0 x])
  prtList _ (x:xs) = (concatD [prt 0 x, doc (showString ","), prt 0 xs])
instance Print BintTerm where
  prt i e = case e of
    B_And bintterm bintfactor -> prPrec i 0 (concatD [prt 0 bintterm, doc (showString "&&"), prt 0 bintfactor])
    B_Factor bintfactor -> prPrec i 0 (concatD [prt 0 bintfactor])

instance Print BintFactor where
  prt i e = case e of
    B_Not bintfactor -> prPrec i 0 (concatD [doc (showString "not"), prt 0 bintfactor])
    B_Compare intexpr1 compareop intexpr2 -> prPrec i 0 (concatD [prt 0 intexpr1, prt 0 compareop, prt 0 intexpr2])
    B_Expr intexpr -> prPrec i 0 (concatD [prt 0 intexpr])

instance Print CompareOp where
  prt i e = case e of
    B_EQ -> prPrec i 0 (concatD [doc (showString "=")])
    B_LT -> prPrec i 0 (concatD [doc (showString "<")])
    B_GT -> prPrec i 0 (concatD [doc (showString ">")])
    B_LE -> prPrec i 0 (concatD [doc (showString "=<")])
    B_GE -> prPrec i 0 (concatD [doc (showString ">=")])

instance Print IntExpr where
  prt i e = case e of
    Int_Add intexpr addop intterm -> prPrec i 0 (concatD [prt 0 intexpr, prt 0 addop, prt 0 intterm])
    Int_Term intterm -> prPrec i 0 (concatD [prt 0 intterm])

instance Print Addop where
  prt i e = case e of
    Op_Add -> prPrec i 0 (concatD [doc (showString "+")])
    Op_Sub -> prPrec i 0 (concatD [doc (showString "-")])

instance Print IntTerm where
  prt i e = case e of
    Int_Mul intterm mulop intfactor -> prPrec i 0 (concatD [prt 0 intterm, prt 0 mulop, prt 0 intfactor])
    Int_Factor intfactor -> prPrec i 0 (concatD [prt 0 intfactor])

instance Print Mulop where
  prt i e = case e of
    Op_Mult -> prPrec i 0 (concatD [doc (showString "*")])
    Op_Divide -> prPrec i 0 (concatD [doc (showString "/")])

instance Print IntFactor where
  prt i e = case e of
    IF_Expression expr -> prPrec i 0 (concatD [doc (showString "("), prt 0 expr, doc (showString ")")])
    IF_Size pident basicarraydimensions -> prPrec i 0 (concatD [doc (showString "size"), doc (showString "("), prt 0 pident, prt 0 basicarraydimensions, doc (showString ")")])
    IF_Float expr -> prPrec i 0 (concatD [doc (showString "float"), doc (showString "("), prt 0 expr, doc (showString ")")])
    IF_Floor expr -> prPrec i 0 (concatD [doc (showString "floor"), doc (showString "("), prt 0 expr, doc (showString ")")])
    IF_Ceil expr -> prPrec i 0 (concatD [doc (showString "ceil"), doc (showString "("), prt 0 expr, doc (showString ")")])
    IF_ID pident modifierlist -> prPrec i 0 (concatD [prt 0 pident, prt 0 modifierlist])
    IF_Data cid consargumentlist -> prPrec i 0 (concatD [prt 0 cid, prt 0 consargumentlist])
    IF_Integer n -> prPrec i 0 (concatD [prt 0 n])
    IF_Real d -> prPrec i 0 (concatD [prt 0 d])
    IF_Boolean bval -> prPrec i 0 (concatD [prt 0 bval])
    IF_Character c -> prPrec i 0 (concatD [prt 0 c])
    IF_Negate intfactor -> prPrec i 0 (concatD [doc (showString "-"), prt 0 intfactor])

instance Print ModifierList where
  prt i e = case e of
    Mod_CallParams funargumentlist -> prPrec i 0 (concatD [prt 0 funargumentlist])
    Mod_Array arraydimensions -> prPrec i 0 (concatD [prt 0 arraydimensions])

instance Print FunArgumentList where
  prt i e = case e of
    F_Args exprs -> prPrec i 0 (concatD [doc (showString "("), prt 0 exprs, doc (showString ")")])

instance Print ConsArgumentList where
  prt i e = case e of
    CAL_Arguments funargumentlist -> prPrec i 0 (concatD [prt 0 funargumentlist])
    CAL_NoArgs -> prPrec i 0 (concatD [])


