MODULE {PrettyFlat} {ppFag} {}

PRAGMA genlinepragmas

INCLUDE "FlatAst.ag"

imports
{
import Common
import UU.Scanner.Position
import Type
import UU.Pretty
import Flat
import Data.Char
}


WRAPPER Fag

{
ppFag :: Fag -> PP_Doc
ppFag vag = pp_Syn_Fag syn
  where
    inh = Inh_Fag {}
    sem = sem_Fag vag
    syn = wrap_Fag sem inh
}


ATTR Fag Data Con FieldSig InhSig SynSig Itf Ctx MaybeTail Tail MaybeBlock Block Code Clause Def Pat [ | | pp : PP_Doc ]

SEM Fag
  | Ag  lhs.pp = "-- data types"
                 >-< vlist_sep "" @datas.pps
                 >-< ""
                 >-< "-- interfaces"
                 >-< vlist_sep "" @itfs.pps
                 >-< ""
                 >-< vlist_sep "" @blocks.pps

SEM Data
  | Data  lhs.pp = "data" >#< @name >#< hlist_sp @vars
                   >-< indent 2 (vlist @cons.pps)

SEM Con
  | Con   lhs.pp = "|" >#< @name >#< (vlist @sigs.pps)

SEM FieldSig InhSig SynSig
  | Sig   lhs.pp = @name >#< "::" >#< @tp

SEM Itf
  | Itf   lhs.pp = "itf" >#< @name >#< hlist_sp @vars
                   >-< ( if null @inhs.pps
                         then empty
                         else indent 2 ("inh" >#< vlist @inhs.pps) )
                   >-< ( if null @ctxs.pps
                         then empty
                         else indent 2 (vlist @ctxs.pps) )

SEM Ctx
  | Ctx   lhs.pp = "ctx" >#< @name >#< (   ( if null @syns.pps
                                             then empty
                                             else "syn" >#< vlist @syns.pps )
                                       >-< @mbTail.pp
                                       )

SEM MaybeTail
  | Just     lhs.pp = @just.pp
  | Nothing  lhs.pp = empty

SEM Tail
  | Tail     lhs.pp = "tail" >#< case @mbNm of
                                   Nothing -> pp @tp
                                   Just nm -> nm >#< "::" >#< @tp

SEM Block
  | Code  lhs.pp = if isInline @kind
                   then vlist @items.pps
                   else "-- code block" >#< @kind
                        >-< vlist @items.pps

SEM MaybeBlock
  | Nothing  lhs.pp = pp "-- empty"

SEM Code
  | Plain  lhs.pp = if all isSpace @txt
                    then empty
                    else ".." >#< trim @txt
  | Attr   lhs.pp = @name >|< "." >|< @field
  | Sem    lhs.pp = ppPos @pos
                    >-< "sem" >#< @tp
                    >-< indent 2 (vlist @clauses.pps)

{
trim :: String -> String
trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace
}

SEM Clause
  | Clause  lhs.pp = "clause" >#< @name >#< case @mbCtx of
                                              Nothing  -> empty
                                              Just ctx -> ":" >#< ctx
                     >-< indent 2 (vlist @defs.pps)

SEM Def
  | Child   lhs.pp  = "child" >#< @name >#< "::" >#< @tp >#< "=" >#< @def.pp
  | Visit   lhs.pp  = "visit" >#< @child >|< maybe empty (\tl -> "." >|< tl) @mbTail >|< maybe empty (\ctx -> " :" >#< ctx) @mbCtx >#< "=" >#< @mbDef.pp
  | Bind    lhs.pp  = @kind >#< @pat.pp >#< "=" >#< @def.pp
  | Tail    lhs.pp  = "tail" >#< @def.pp

SEM Pat
  | Attr        lhs.pp = @child >|< "." >|< @field
  | Con         lhs.pp = "(" >#< @name >#< hlist_sp @pats.pps >#< ")"
  | ConAttr     lhs.pp = @child >|< "@" >|< @tp >|< "." >|< @con
  | Tup         lhs.pp = "(" >#< hlist_sep ", " @pats.pps >#< ")"
  | Underscore  lhs.pp = pp "_"


--
-- List-like cases
--

ATTR Datas Cons FieldSigs InhSigs SynSigs Itfs Ctxs Blocks Codes Clauses Defs Pats [ | | pps : {[PP_Doc]} ]

SEM Datas
  | Cons  lhs.pps = @hd.pp : @tl.pps
  | Nil   lhs.pps = []

SEM Cons
  | Cons  lhs.pps = @hd.pp : @tl.pps
  | Nil   lhs.pps = []

SEM FieldSigs
  | Cons  lhs.pps = @hd.pp : @tl.pps
  | Nil   lhs.pps = []

SEM InhSigs
  | Cons  lhs.pps = @hd.pp : @tl.pps
  | Nil   lhs.pps = []

SEM SynSigs
  | Cons  lhs.pps = @hd.pp : @tl.pps
  | Nil   lhs.pps = []

SEM Itfs
  | Cons  lhs.pps = @hd.pp : @tl.pps
  | Nil   lhs.pps = []

SEM Ctxs
  | Cons  lhs.pps = @hd.pp : @tl.pps
  | Nil   lhs.pps = []

SEM Blocks
  | Cons  lhs.pps = @hd.pp : @tl.pps
  | Nil   lhs.pps = []

SEM Codes
  | Cons  lhs.pps = @hd.pp : @tl.pps
  | Nil   lhs.pps = []

SEM Clauses
  | Cons  lhs.pps = @hd.pp : @tl.pps
  | Nil   lhs.pps = []

SEM Defs
  | Cons  lhs.pps = @hd.pp : @tl.pps
  | Nil   lhs.pps = []

SEM Pats
  | Cons  lhs.pps = @hd.pp : @tl.pps
  | Nil   lhs.pps = []