path: root/src/GF/Source/PrintGF.hs

module PrintGF where

-- pretty-printer generated by the BNF converter, except --H

import AbsGF
import Ident --H
import Char

-- the top-level printing method

printTree :: Print a => a -> String
printTree = render . prt 0

-- you may want to change render and parenth

render :: [String] -> String
render = rend 0 where
  rend i ss = case ss of

    --H these four are hand-written
    "{0"     :ts -> cons "{"  $ rend (i+1) ts
    t :"}0"  :ts -> cons t    $ space "}"  $ rend (i-1) ts
    t : "."  :ts -> cons t    $ cons "."  $ rend i ts
    "\\"     :ts -> cons "\\"  $ rend i ts

    "["      :ts -> cons "["  $ rend i ts
    "("      :ts -> cons "("  $ rend i ts
    "{"      :ts -> cons "{"  $ new (i+1) $ rend (i+1) ts
    "}" : ";":ts -> new (i-1) $ space "}" $ cons ";" $ new (i-1) $ rend (i-1) ts
    "}"      :ts -> new (i-1) $ cons "}" $ new (i-1) $ rend (i-1) ts
    ";"      :ts -> cons ";"  $ new i $ rend i ts
    t  : "," :ts -> cons t    $ space "," $ rend i ts
    t  : ")" :ts -> cons t    $ cons ")"  $ rend i ts
    t  : "]" :ts -> cons t    $ cons "]"  $ rend i ts
    t        :ts -> space t   $ rend i ts
    _            -> ""
  cons s t  = s ++ t
  new i s   = '\n' : replicate (2*i) ' ' ++ dropWhile isSpace s
  space t s = if null s then t else t ++ " " ++ s

parenth :: [String] -> [String]
parenth ss = ["("] ++ ss ++ [")"]

-- the printer class does the job
class Print a where
  prt :: Int -> a -> [String]
  prtList :: [a] -> [String]
  prtList = concat . map (prt 0)

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

instance Print Integer where
  prt _ = (:[]) . show

instance Print Double where
  prt _ = (:[]) . show

instance Print Char where
  prt _ s = ["'" ++ mkEsc s ++ "'"]
  prtList s = ["\"" ++ concatMap mkEsc s ++ "\""]

mkEsc s = case s of
  _ | elem s "\\\"" -> '\\':[s]
  '\n' -> "\\n"
  '\t' -> "\\t"
  _ -> [s]

prPrec :: Int -> Int -> [String] -> [String]
prPrec i j = if j<i then parenth else id


instance Print Ident where
  prt _ i = [prIdent i] --H
  prtList es = case es of
   [x] -> (concat [prt 0 x])
   x:xs -> (concat [prt 0 x , [","] , prt 0 xs])


instance Print LString where
  prt _ (LString i) = [i]



instance Print Grammar where
  prt i e = case e of
   Gr moddefs -> prPrec i 0 (concat [prt 0 moddefs])


instance Print ModDef where
  prt i e = case e of
   MMain id0 id concspecs -> prPrec i 0 (concat [["grammar"] , prt 0 id0 , ["="] , ["{"] , ["abstract"] , ["="] , prt 0 id , [";"] , prt 0 concspecs , ["}"]])
   MModule complmod modtype modbody -> prPrec i 0 (concat [prt 0 complmod , prt 0 modtype , ["="] , prt 0 modbody])

  prtList es = case es of
   [] -> (concat [])
   x:xs -> (concat [prt 0 x , prt 0 xs])

instance Print ConcSpec where
  prt i e = case e of
   ConcSpec id concexp -> prPrec i 0 (concat [prt 0 id , ["="] , prt 0 concexp])

  prtList es = case es of
   [] -> (concat [])
   [x] -> (concat [prt 0 x])
   x:xs -> (concat [prt 0 x , [";"] , prt 0 xs])

instance Print ConcExp where
  prt i e = case e of
   ConcExp id transfers -> prPrec i 0 (concat [prt 0 id , prt 0 transfers])


instance Print Transfer where
  prt i e = case e of
   TransferIn open -> prPrec i 0 (concat [["("] , ["transfer"] , ["in"] , prt 0 open , [")"]])
   TransferOut open -> prPrec i 0 (concat [["("] , ["transfer"] , ["out"] , prt 0 open , [")"]])

  prtList es = case es of
   [] -> (concat [])
   x:xs -> (concat [prt 0 x , prt 0 xs])

instance Print ModType where
  prt i e = case e of
   MTAbstract id -> prPrec i 0 (concat [["abstract"] , prt 0 id])
   MTResource id -> prPrec i 0 (concat [["resource"] , prt 0 id])
   MTInterface id -> prPrec i 0 (concat [["interface"] , prt 0 id])
   MTConcrete id0 id -> prPrec i 0 (concat [["concrete"] , prt 0 id0 , ["of"] , prt 0 id])
   MTInstance id0 id -> prPrec i 0 (concat [["instance"] , prt 0 id0 , ["of"] , prt 0 id])
   MTTransfer id open0 open -> prPrec i 0 (concat [["transfer"] , prt 0 id , [":"] , prt 0 open0 , ["->"] , prt 0 open])


instance Print ModBody where
  prt i e = case e of
   MBody extend opens topdefs -> prPrec i 0 (concat [prt 0 extend , prt 0 opens , ["{"] , prt 0 topdefs , ["}"]])
   MWith id opens -> prPrec i 0 (concat [prt 0 id , ["with"] , prt 0 opens])
   MReuse id -> prPrec i 0 (concat [["reuse"] , prt 0 id])
   MUnion includeds -> prPrec i 0 (concat [["union"] , prt 0 includeds])

instance Print Extend where
  prt i e = case e of
   Ext id -> prPrec i 0 (concat [prt 0 id , ["**"]])
   NoExt  -> prPrec i 0 (concat [])


instance Print Opens where
  prt i e = case e of
   NoOpens  -> prPrec i 0 (concat [])
   Opens opens -> prPrec i 0 (concat [["open"] , prt 0 opens , ["in"]])


instance Print Open where
  prt i e = case e of
   OName id -> prPrec i 0 (concat [prt 0 id])
   OQualQO qualopen id -> prPrec i 0 (concat [["("] , prt 0 qualopen , prt 0 id , [")"]])
   OQual qualopen id0 id -> prPrec i 0 (concat [["("] , prt 0 qualopen , prt 0 id0 , ["="] , prt 0 id , [")"]])

  prtList es = case es of
   [] -> (concat [])
   [x] -> (concat [prt 0 x])
   x:xs -> (concat [prt 0 x , [","] , prt 0 xs])

instance Print ComplMod where
  prt i e = case e of
   CMCompl  -> prPrec i 0 (concat [])
   CMIncompl  -> prPrec i 0 (concat [["incomplete"]])


instance Print QualOpen where
  prt i e = case e of
   QOCompl  -> prPrec i 0 (concat [])
   QOIncompl  -> prPrec i 0 (concat [["incomplete"]])
   QOInterface  -> prPrec i 0 (concat [["interface"]])

instance Print Included where
  prt i e = case e of
   IAll id -> prPrec i 0 (concat [prt 0 id])
   ISome id ids -> prPrec i 0 (concat [prt 0 id , ["["] , prt 0 ids , ["]"]])

  prtList es = case es of
   [] -> (concat [])
   [x] -> (concat [prt 0 x])
   x:xs -> (concat [prt 0 x , [","] , prt 0 xs])

instance Print Def where
  prt i e = case e of
   DDecl ids exp -> prPrec i 0 (concat [prt 0 ids , [":"] , prt 0 exp])
   DDef ids exp -> prPrec i 0 (concat [prt 0 ids , ["="] , prt 0 exp])
   DPatt id patts exp -> prPrec i 0 (concat [prt 0 id , prt 0 patts , ["="] , prt 0 exp])
   DFull ids exp0 exp -> prPrec i 0 (concat [prt 0 ids , [":"] , prt 0 exp0 , ["="] , prt 0 exp])

  prtList es = case es of
   [x] -> (concat [prt 0 x , [";"]])
   x:xs -> (concat [prt 0 x , [";"] , prt 0 xs])

instance Print TopDef where
  prt i e = case e of
   DefCat catdefs -> prPrec i 0 (concat [["cat"] , prt 0 catdefs])
   DefFun fundefs -> prPrec i 0 (concat [["fun"] , prt 0 fundefs])
   DefDef defs -> prPrec i 0 (concat [["def"] , prt 0 defs])
   DefData datadefs -> prPrec i 0 (concat [["data"] , prt 0 datadefs])
   DefTrans defs -> prPrec i 0 (concat [["transfer"] , prt 0 defs])
   DefPar pardefs -> prPrec i 0 (concat [["param"] , prt 0 pardefs])
   DefOper defs -> prPrec i 0 (concat [["oper"] , prt 0 defs])
   DefLincat printdefs -> prPrec i 0 (concat [["lincat"] , prt 0 printdefs])
   DefLindef defs -> prPrec i 0 (concat [["lindef"] , prt 0 defs])
   DefLin defs -> prPrec i 0 (concat [["lin"] , prt 0 defs])
   DefPrintCat printdefs -> prPrec i 0 (concat [["printname"] , ["cat"] , prt 0 printdefs])
   DefPrintFun printdefs -> prPrec i 0 (concat [["printname"] , ["fun"] , prt 0 printdefs])
   DefFlag flagdefs -> prPrec i 0 (concat [["flags"] , prt 0 flagdefs])
   DefPrintOld printdefs -> prPrec i 0 (concat [["printname"] , prt 0 printdefs])
   DefLintype defs -> prPrec i 0 (concat [["lintype"] , prt 0 defs])
   DefPattern defs -> prPrec i 0 (concat [["pattern"] , prt 0 defs])

  prtList es = case es of
   [] -> (concat [])
   x:xs -> (concat [prt 0 x , prt 0 xs])

instance Print CatDef where
  prt i e = case e of
   CatDef id ddecls -> prPrec i 0 (concat [prt 0 id , prt 0 ddecls])

  prtList es = case es of
   [x] -> (concat [prt 0 x , [";"]])
   x:xs -> (concat [prt 0 x , [";"] , prt 0 xs])

instance Print FunDef where
  prt i e = case e of
   FunDef ids exp -> prPrec i 0 (concat [prt 0 ids , [":"] , prt 0 exp])

  prtList es = case es of
   [x] -> (concat [prt 0 x , [";"]])
   x:xs -> (concat [prt 0 x , [";"] , prt 0 xs])

instance Print DataDef where
  prt i e = case e of
   DataDef id dataconstrs -> prPrec i 0 (concat [prt 0 id , ["="] , prt 0 dataconstrs])

  prtList es = case es of
   [x] -> (concat [prt 0 x , [";"]])
   x:xs -> (concat [prt 0 x , [";"] , prt 0 xs])

instance Print DataConstr where
  prt i e = case e of
   DataId id -> prPrec i 0 (concat [prt 0 id])
   DataQId id0 id -> prPrec i 0 (concat [prt 0 id0 , ["."] , prt 0 id])

  prtList es = case es of
   [] -> (concat [])
   [x] -> (concat [prt 0 x])
   x:xs -> (concat [prt 0 x , ["|"] , prt 0 xs])

instance Print ParDef where
  prt i e = case e of
   ParDef id parconstrs -> prPrec i 0 (concat [prt 0 id , ["="] , prt 0 parconstrs])
   ParDefIndir id0 id -> prPrec i 0 (concat [prt 0 id0 , ["="] , ["("] , ["in"] , prt 0 id , [")"]])
   ParDefAbs id -> prPrec i 0 (concat [prt 0 id])

  prtList es = case es of
   [x] -> (concat [prt 0 x , [";"]])
   x:xs -> (concat [prt 0 x , [";"] , prt 0 xs])

instance Print ParConstr where
  prt i e = case e of
   ParConstr id ddecls -> prPrec i 0 (concat [prt 0 id , prt 0 ddecls])

  prtList es = case es of
   [] -> (concat [])
   [x] -> (concat [prt 0 x])
   x:xs -> (concat [prt 0 x , ["|"] , prt 0 xs])

instance Print PrintDef where
  prt i e = case e of
   PrintDef ids exp -> prPrec i 0 (concat [prt 0 ids , ["="] , prt 0 exp])

  prtList es = case es of
   [x] -> (concat [prt 0 x , [";"]])
   x:xs -> (concat [prt 0 x , [";"] , prt 0 xs])

instance Print FlagDef where
  prt i e = case e of
   FlagDef id0 id -> prPrec i 0 (concat [prt 0 id0 , ["="] , prt 0 id])

  prtList es = case es of
   [x] -> (concat [prt 0 x , [";"]])
   x:xs -> (concat [prt 0 x , [";"] , prt 0 xs])

instance Print LocDef where
  prt i e = case e of
   LDDecl ids exp -> prPrec i 0 (concat [prt 0 ids , [":"] , prt 0 exp])
   LDDef ids exp -> prPrec i 0 (concat [prt 0 ids , ["="] , prt 0 exp])
   LDFull ids exp0 exp -> prPrec i 0 (concat [prt 0 ids , [":"] , prt 0 exp0 , ["="] , prt 0 exp])

  prtList es = case es of
   [] -> (concat [])
   [x] -> (concat [prt 0 x])
   x:xs -> (concat [prt 0 x , [";"] , prt 0 xs])

instance Print Exp where
  prt i e = case e of
   EIdent id -> prPrec i 4 (concat [prt 0 id])
   EConstr id -> prPrec i 4 (concat [["{0"] , prt 0 id , ["}0"]]) --H
   ECons id -> prPrec i 4 (concat [["["] , prt 0 id , ["]"]])
   ESort sort -> prPrec i 4 (concat [prt 0 sort])
   EString str -> prPrec i 4 (concat [prt 0 str])
   EInt n -> prPrec i 4 (concat [prt 0 n])
   EMeta  -> prPrec i 4 (concat [["?"]])
   EEmpty  -> prPrec i 4 (concat [["["] , ["]"]])
   EStrings str -> prPrec i 4 (concat [["["] , prt 0 str , ["]"]])
   ERecord locdefs -> prPrec i 4 (concat [["{"] , prt 0 locdefs , ["}"]])
   ETuple tuplecomps -> prPrec i 4 (concat [["<"] , prt 0 tuplecomps , [">"]])
   EIndir id -> prPrec i 4 (concat [["("] , ["in"] , prt 0 id , [")"]])
   ETyped exp0 exp -> prPrec i 4 (concat [["<"] , prt 0 exp0 , [":"] , prt 0 exp , [">"]])
   EProj exp label -> prPrec i 3 (concat [prt 3 exp , ["."] , prt 0 label])
   EQConstr id0 id -> prPrec i 3 (concat [["{0"] , prt 0 id0 , ["."] , prt 0 id , ["}0"]]) --H
   EQCons id0 id -> prPrec i 3 (concat [["["] , prt 0 id0 , ["."] , prt 0 id , ["]"]])
   EApp exp0 exp -> prPrec i 2 (concat [prt 2 exp0 , prt 3 exp])
   ETable cases -> prPrec i 2 (concat [["table"] , ["{"] , prt 0 cases , ["}"]])
   ETTable exp cases -> prPrec i 2 (concat [["table"] , prt 4 exp , ["{"] , prt 0 cases , ["}"]])
   ECase exp cases -> prPrec i 2 (concat [["case"] , prt 0 exp , ["of"] , ["{"] , prt 0 cases , ["}"]])
   EVariants exps -> prPrec i 2 (concat [["variants"] , ["{"] , prt 0 exps , ["}"]])
   EPre exp alterns -> prPrec i 2 (concat [["pre"] , ["{"] , prt 0 exp , [";"] , prt 0 alterns , ["}"]])
   EStrs exps -> prPrec i 2 (concat [["strs"] , ["{"] , prt 0 exps , ["}"]])
   EConAt id exp -> prPrec i 2 (concat [prt 0 id , ["@"] , prt 4 exp])
   ESelect exp0 exp -> prPrec i 1 (concat [prt 1 exp0 , ["!"] , prt 2 exp])
   ETupTyp exp0 exp -> prPrec i 1 (concat [prt 1 exp0 , ["*"] , prt 2 exp])
   EExtend exp0 exp -> prPrec i 1 (concat [prt 1 exp0 , ["**"] , prt 2 exp])
   EAbstr binds exp -> prPrec i 0 (concat [["\\"] , prt 0 binds , ["->"] , prt 0 exp])
   ECTable binds exp -> prPrec i 0 (concat [["\\"] , ["\\"] , prt 0 binds , ["=>"] , prt 0 exp])
   EProd decl exp -> prPrec i 0 (concat [prt 0 decl , ["->"] , prt 0 exp])
   ETType exp0 exp -> prPrec i 0 (concat [prt 1 exp0 , ["=>"] , prt 0 exp])
   EConcat exp0 exp -> prPrec i 0 (concat [prt 1 exp0 , ["++"] , prt 0 exp])
   EGlue exp0 exp -> prPrec i 0 (concat [prt 1 exp0 , ["+"] , prt 0 exp])
   ELet locdefs exp -> prPrec i 0 (concat [["let"] , ["{"] , prt 0 locdefs , ["}"] , ["in"] , prt 0 exp])
   ELetb locdefs exp -> prPrec i 0 (concat [["let"] , prt 0 locdefs , ["in"] , prt 0 exp])
   EWhere exp locdefs -> prPrec i 0 (concat [prt 1 exp , ["where"] , ["{"] , prt 0 locdefs , ["}"]])
   EEqs equations -> prPrec i 0 (concat [["fn"] , ["{"] , prt 0 equations , ["}"]])
   ELString lstring -> prPrec i 4 (concat [prt 0 lstring])
   ELin id -> prPrec i 2 (concat [["Lin"] , prt 0 id])

  prtList es = case es of
   [] -> (concat [])
   [x] -> (concat [prt 0 x])
   x:xs -> (concat [prt 0 x , [";"] , prt 0 xs])

instance Print Patt where
  prt i e = case e of
   PW  -> prPrec i 1 (concat [["_"]])
   PV id -> prPrec i 1 (concat [prt 0 id])
   PCon id -> prPrec i 1 (concat [["{0"] , prt 0 id , ["}0"]]) --H
   PQ id0 id -> prPrec i 1 (concat [prt 0 id0 , ["."] , prt 0 id])
   PInt n -> prPrec i 1 (concat [prt 0 n])
   PStr str -> prPrec i 1 (concat [prt 0 str])
   PR pattasss -> prPrec i 1 (concat [["{"] , prt 0 pattasss , ["}"]])
   PTup patttuplecomps -> prPrec i 1 (concat [["<"] , prt 0 patttuplecomps , [">"]])
   PC id patts -> prPrec i 0 (concat [prt 0 id , prt 0 patts])
   PQC id0 id patts -> prPrec i 0 (concat [prt 0 id0 , ["."] , prt 0 id , prt 0 patts])

  prtList es = case es of
   [x] -> (concat [prt 1 x])
   x:xs -> (concat [prt 1 x , prt 0 xs])

instance Print PattAss where
  prt i e = case e of
   PA ids patt -> prPrec i 0 (concat [prt 0 ids , ["="] , prt 0 patt])

  prtList es = case es of
   [] -> (concat [])
   [x] -> (concat [prt 0 x])
   x:xs -> (concat [prt 0 x , [";"] , prt 0 xs])

instance Print Label where
  prt i e = case e of
   LIdent id -> prPrec i 0 (concat [prt 0 id])
   LVar n -> prPrec i 0 (concat [["$"] , prt 0 n])


instance Print Sort where
  prt i e = case e of
   Sort_Type  -> prPrec i 0 (concat [["Type"]])
   Sort_PType  -> prPrec i 0 (concat [["PType"]])
   Sort_Tok  -> prPrec i 0 (concat [["Tok"]])
   Sort_Str  -> prPrec i 0 (concat [["Str"]])
   Sort_Strs  -> prPrec i 0 (concat [["Strs"]])


instance Print PattAlt where
  prt i e = case e of
   AltP patt -> prPrec i 0 (concat [prt 0 patt])

  prtList es = case es of
   [x] -> (concat [prt 0 x])
   x:xs -> (concat [prt 0 x , ["|"] , prt 0 xs])

instance Print Bind where
  prt i e = case e of
   BIdent id -> prPrec i 0 (concat [prt 0 id])
   BWild  -> prPrec i 0 (concat [["_"]])

  prtList es = case es of
   [] -> (concat [])
   [x] -> (concat [prt 0 x])
   x:xs -> (concat [prt 0 x , [","] , prt 0 xs])

instance Print Decl where
  prt i e = case e of
   DDec binds exp -> prPrec i 0 (concat [["("] , prt 0 binds , [":"] , prt 0 exp , [")"]])
   DExp exp -> prPrec i 0 (concat [prt 2 exp])


instance Print TupleComp where
  prt i e = case e of
   TComp exp -> prPrec i 0 (concat [prt 0 exp])

  prtList es = case es of
   [] -> (concat [])
   [x] -> (concat [prt 0 x])
   x:xs -> (concat [prt 0 x , [","] , prt 0 xs])

instance Print PattTupleComp where
  prt i e = case e of
   PTComp patt -> prPrec i 0 (concat [prt 0 patt])

  prtList es = case es of
   [] -> (concat [])
   [x] -> (concat [prt 0 x])
   x:xs -> (concat [prt 0 x , [","] , prt 0 xs])

instance Print Case where
  prt i e = case e of
   Case pattalts exp -> prPrec i 0 (concat [prt 0 pattalts , ["=>"] , prt 0 exp])

  prtList es = case es of
   [x] -> (concat [prt 0 x])
   x:xs -> (concat [prt 0 x , [";"] , prt 0 xs])

instance Print Equation where
  prt i e = case e of
   Equ patts exp -> prPrec i 0 (concat [prt 0 patts , ["->"] , prt 0 exp])

  prtList es = case es of
   [] -> (concat [])
   [x] -> (concat [prt 0 x])
   x:xs -> (concat [prt 0 x , [";"] , prt 0 xs])

instance Print Altern where
  prt i e = case e of
   Alt exp0 exp -> prPrec i 0 (concat [prt 0 exp0 , ["/"] , prt 0 exp])

  prtList es = case es of
   [] -> (concat [])
   [x] -> (concat [prt 0 x])
   x:xs -> (concat [prt 0 x , [";"] , prt 0 xs])

instance Print DDecl where
  prt i e = case e of
   DDDec binds exp -> prPrec i 0 (concat [["("] , prt 0 binds , [":"] , prt 0 exp , [")"]])
   DDExp exp -> prPrec i 0 (concat [prt 4 exp])

  prtList es = case es of
   [] -> (concat [])
   x:xs -> (concat [prt 0 x , prt 0 xs])

instance Print OldGrammar where
  prt i e = case e of
   OldGr include topdefs -> prPrec i 0 (concat [prt 0 include , prt 0 topdefs])


instance Print Include where
  prt i e = case e of
   NoIncl  -> prPrec i 0 (concat [])
   Incl filenames -> prPrec i 0 (concat [["include"] , prt 0 filenames])


instance Print FileName where
  prt i e = case e of
   FString str -> prPrec i 0 (concat [prt 0 str])
   FIdent id -> prPrec i 0 (concat [prt 0 id])
   FSlash filename -> prPrec i 0 (concat [["/"] , prt 0 filename])
   FDot filename -> prPrec i 0 (concat [["."] , prt 0 filename])
   FMinus filename -> prPrec i 0 (concat [["-"] , prt 0 filename])
   FAddId id filename -> prPrec i 0 (concat [prt 0 id , prt 0 filename])

  prtList es = case es of
   [x] -> (concat [prt 0 x , [";"]])
   x:xs -> (concat [prt 0 x , [";"] , prt 0 xs])