content: ----------------------------------------------------------------------
  -- |
  -- Module      : GF.Grammar.Printer
  -- Maintainer  : Krasimir Angelov
  -- Stability   : (stable)
  -- Portability : (portable)
  --
  -----------------------------------------------------------------------------
  
  {-# LANGUAGE FlexibleContexts #-}
  module GF.Grammar.Printer
             ( -- ** Pretty printing
               TermPrintQual(..)
             , ppModule
             , ppJudgement
             , ppParams
             , ppTerm
             , ppPatt
             , ppValue
             , ppConstrs
             , ppQIdent
             , ppMeta
             , getAbs
             ) where
  import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
  
  import GF.Infra.Ident
  import GF.Infra.Option
  import GF.Grammar.Values
  import GF.Grammar.Grammar
  
  import PGF.Internal (ppMeta, ppLit, ppFId, ppFunId, ppSeqId, ppSeq)
  
  import GF.Text.Pretty
  import Data.Maybe (isNothing)
  import Data.List  (intersperse)
  import qualified Data.Map as Map
  --import qualified Data.IntMap as IntMap
  --import qualified Data.Set as Set
  import qualified Data.Array.IArray as Array
  
  data TermPrintQual
    = Terse | Unqualified | Qualified | Internal
    deriving Eq
  
  instance Pretty Grammar where
    pp = vcat . map (ppModule Qualified) . modules
  
  ppModule :: TermPrintQual -> SourceModule -> Doc
  ppModule q (mn, ModInfo mtype mstat opts exts with opens _ _ mseqs jments) =
      hdr $$
      nest 2 (ppOptions opts $$
              vcat (map (ppJudgement q) (Map.toList jments)) $$
              maybe empty (ppSequences q) mseqs) $$
      ftr
      where
        hdr = complModDoc <+> modTypeDoc <+> '=' <+>
              hsep (intersperse (pp "**") $
                    filter (not . isEmpty)  $ [ commaPunct ppExtends exts
                                              , maybe empty ppWith with
                                              , if null opens
                                                  then pp '{'
                                                  else "open" <+> commaPunct ppOpenSpec opens <+> "in" <+> '{'
                                              ])
  
        ftr = '}'
  
        complModDoc =
          case mstat of
            MSComplete   -> empty
            MSIncomplete -> pp "incomplete"
  
        modTypeDoc =
          case mtype of
            MTAbstract         -> "abstract"  <+> mn
            MTResource         -> "resource"  <+> mn
            MTConcrete abs     -> "concrete"  <+> mn <+> "of" <+> abs
            MTInterface        -> "interface" <+> mn
            MTInstance ie      -> "instance"  <+> mn <+> "of" <+> ppExtends ie
  
        ppExtends (id,MIAll        ) = pp id
        ppExtends (id,MIOnly   incs) = id         <+> brackets (commaPunct pp incs)
        ppExtends (id,MIExcept incs) = id <+> '-' <+> brackets (commaPunct pp incs)
  
        ppWith (id,ext,opens) = ppExtends (id,ext) <+> "with" <+> commaPunct ppInstSpec opens
  
  ppOptions opts =
    "flags" $$
    nest 2 (vcat [option <+> '=' <+> ppLit value <+> ';' | (option,value) <- optionsGFO opts])
  
  ppJudgement q (id, AbsCat pcont ) =
    "cat" <+> id <+>
    (case pcont of
       Just (L _ cont) -> hsep (map (ppDecl q) cont)
       Nothing         -> empty) <+> ';'
  ppJudgement q (id, AbsFun ptype _ pexp poper) =
    let kind | isNothing pexp      = "data"
             | poper == Just False = "oper"
             | otherwise           = "fun"
    in
    (case ptype of
       Just (L _ typ) -> kind <+> id <+> ':' <+> ppTerm q 0 typ <+> ';'
       Nothing        -> empty) $$
    (case pexp of
       Just []  -> empty
       Just eqs -> "def" <+> vcat [id <+> hsep (map (ppPatt q 2) ps) <+> '=' <+> ppTerm q 0 e <+> ';' | L _ (ps,e) <- eqs]
       Nothing  -> empty)
  ppJudgement q (id, ResParam pparams _) =
    "param" <+> id <+>
    (case pparams of
       Just (L _ ps) -> '=' <+> ppParams q ps
       _             -> empty) <+> ';'
  ppJudgement q (id, ResValue pvalue) =
    "-- param constructor" <+> id <+> ':' <+>
    (case pvalue of
       (L _ ty) -> ppTerm q 0 ty) <+> ';'
  ppJudgement q (id, ResOper  ptype pexp) =
    "oper" <+> id <+>
    (case ptype of {Just (L _ t) -> ':'  <+> ppTerm q 0 t; Nothing -> empty} $$
     case pexp  of {Just (L _ e) -> '=' <+> ppTerm q 0 e; Nothing -> empty}) <+> ';'
  ppJudgement q (id, ResOverload ids defs) =
    "oper" <+> id <+> '=' <+>
    ("overload" <+> '{' $$
     nest 2 (vcat [id <+> (':' <+> ppTerm q 0 ty $$ '=' <+> ppTerm q 0 e <+> ';') | (L _ ty,L _ e) <- defs]) $$
     '}') <+> ';'
  ppJudgement q (id, CncCat pcat pdef pref pprn mpmcfg) =
    (case pcat of
       Just (L _ typ) -> "lincat" <+> id <+> '=' <+> ppTerm q 0 typ <+> ';'
       Nothing        -> empty) $$
    (case pdef of
       Just (L _ exp) -> "lindef" <+> id <+> '=' <+> ppTerm q 0 exp <+> ';'
       Nothing        -> empty) $$
    (case pref of
       Just (L _ exp) -> "linref" <+> id <+> '=' <+> ppTerm q 0 exp <+> ';'
       Nothing        -> empty) $$
    (case pprn of
       Just (L _ prn) -> "printname" <+> id <+> '=' <+> ppTerm q 0 prn <+> ';'
       Nothing        -> empty) $$
    (case (mpmcfg,q) of
       (Just (PMCFG prods funs),Internal)
                      -> "pmcfg" <+> id <+> '=' <+> '{' $$
                         nest 2 (vcat (map ppProduction prods) $$
                                 ' ' $$
                                 vcat (map (\(funid,arr) -> ppFunId funid <+> ":=" <+>
                                                            parens (hcat (punctuate ',' (map ppSeqId (Array.elems arr)))))
                                           (Array.assocs funs))) $$
                         '}'
       _              -> empty)
  ppJudgement q (id, CncFun  ptype pdef pprn mpmcfg) =
    (case pdef of
       Just (L _ e) -> let (xs,e') = getAbs e
                       in "lin" <+> id <+> hsep (map ppBind xs) <+> '=' <+> ppTerm q 0 e' <+> ';'
       Nothing      -> empty) $$
    (case pprn of
       Just (L _ prn) -> "printname" <+> id <+> '=' <+> ppTerm q 0 prn <+> ';'
       Nothing        -> empty) $$
    (case (mpmcfg,q) of
       (Just (PMCFG prods funs),Internal)
                      -> "pmcfg" <+> id <+> '=' <+> '{' $$
                         nest 2 (vcat (map ppProduction prods) $$
                                 ' ' $$
                                 vcat (map (\(funid,arr) -> ppFunId funid <+> ":=" <+>
                                                            parens (hcat (punctuate ',' (map ppSeqId (Array.elems arr)))))
                                           (Array.assocs funs))) $$
                         '}'
       _              -> empty)
  ppJudgement q (id, AnyInd cann mid) =
    case q of
      Internal -> "ind" <+> id <+> '=' <+> (if cann then pp "canonical" else empty) <+> mid <+> ';'
      _        -> empty
  
  instance Pretty Term where pp = ppTerm Unqualified 0
  
  ppTerm q d (Abs b v e)   = let (xs,e') = getAbs (Abs b v e)
                             in prec d 0 ('\\' <> commaPunct ppBind xs <+> "->" <+> ppTerm q 0 e')
  ppTerm q d (T TRaw xs) = case getCTable (T TRaw xs) of
                             ([],_) -> "table" <+> '{' $$
                                         nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$
                                       '}'
                             (vs,e) -> prec d 0 ("\\\\" <> commaPunct pp vs <+> "=>" <+> ppTerm q 0 e)
  ppTerm q d (T (TTyped t) xs) = "table" <+> ppTerm q 0 t <+> '{' $$
                                   nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$
                                  '}'
  ppTerm q d (T (TComp  t) xs) = "table" <+> ppTerm q 0 t <+> '{' $$
                                   nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$
                                 '}'
  ppTerm q d (T (TWild  t) xs) = "table" <+> ppTerm q 0 t <+> '{' $$
                                   nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$
                                  '}'
  ppTerm q d (Prod bt x a b)= if x == identW && bt == Explicit
                                then prec d 0 (ppTerm q 4 a <+> "->" <+> ppTerm q 0 b)
                                else prec d 0 (parens (ppBind (bt,x) <+> ':' <+> ppTerm q 0 a) <+> "->" <+> ppTerm q 0 b)
  ppTerm q d (Table kt vt)=prec d 0 (ppTerm q 3 kt <+> "=>" <+> ppTerm q 0 vt)
  ppTerm q d (Let l e)    = let (ls,e') = getLet e
                            in prec d 0 ("let" <+> vcat (map (ppLocDef q) (l:ls)) $$ "in" <+> ppTerm q 0 e')
  ppTerm q d (Example e s)=prec d 0 ("in" <+> ppTerm q 5 e <+> str s)
  ppTerm q d (C e1 e2)    =prec d 1 (hang (ppTerm q 2 e1) 2 ("++" <+> ppTerm q 1 e2))
  ppTerm q d (Glue e1 e2) =prec d 2 (ppTerm q 3 e1 <+> '+'  <+> ppTerm q 2 e2)
  ppTerm q d (S x y)     = case x of
                             T annot xs -> let e = case annot of
                                                     TRaw     -> y
                                                     TTyped t -> Typed y t
                                                     TComp  t -> Typed y t
                                                     TWild  t -> Typed y t
                                           in "case" <+> ppTerm q 0 e <+>"of" <+> '{' $$
                                              nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$
                                             '}'
                             _          -> prec d 3 (hang (ppTerm q 3 x) 2 ("!" <+> ppTerm q 4 y))
  ppTerm q d (ExtR x y)  = prec d 3 (ppTerm q 3 x <+> "**" <+> ppTerm q 4 y)
  ppTerm q d (App x y)   = prec d 4 (ppTerm q 4 x <+> ppTerm q 5 y)
  ppTerm q d (V e es)    = hang "table" 2 (sep [ppTerm q 6 e,brackets (fsep (punctuate ';' (map (ppTerm q 0) es)))])
  ppTerm q d (FV es)     = prec d 4 ("variants" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es))))
  ppTerm q d (AdHocOverload es)     = "overload" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es)))
  ppTerm q d (Alts e xs) = prec d 4 ("pre" <+> braces (ppTerm q 0 e <> ';' <+> fsep (punctuate ';' (map (ppAltern q) xs))))
  ppTerm q d (Strs es)   = "strs" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es)))
  ppTerm q d (EPatt p)   = prec d 4 ('#' <+> ppPatt q 2 p)
  ppTerm q d (EPattType t)=prec d 4 ("pattern" <+> ppTerm q 0 t)
  ppTerm q d (P t l)     = prec d 5 (ppTerm q 5 t <> '.' <> l)
  ppTerm q d (Cn id)     = pp id
  ppTerm q d (Vr id)     = pp id
  ppTerm q d (Q  id)     = ppQIdent q id
  ppTerm q d (QC id)     = ppQIdent q id
  ppTerm q d (Sort id)   = pp id
  ppTerm q d (K s)       = str s
  ppTerm q d (EInt n)    = pp n
  ppTerm q d (EFloat f)  = pp f
  ppTerm q d (Meta i)    = ppMeta i
  ppTerm q d (Empty)     = pp "[]"
  ppTerm q d (R [])      = pp "<>" -- to distinguish from {} empty RecType
  ppTerm q d (R xs)      = braces (fsep (punctuate ';' [l <+>
                                                         fsep [case mb_t of {Just t -> ':' <+> ppTerm q 0 t; Nothing -> empty},
                                                               '=' <+> ppTerm q 0 e] | (l,(mb_t,e)) <- xs]))
  ppTerm q d (RecType xs)
    | q == Terse         = case [cat | (l,_) <- xs, let (p,cat) = splitAt 5 (showIdent (label2ident l)), p == "lock_"] of
                             [cat] -> pp cat
                             _     -> doc
    | otherwise          = doc
    where
      doc = braces (fsep (punctuate ';' [l <+> ':' <+> ppTerm q 0 t | (l,t) <- xs]))
  ppTerm q d (Typed e t) = '<' <> ppTerm q 0 e <+> ':' <+> ppTerm q 0 t <> '>'
  ppTerm q d (ImplArg e) = braces (ppTerm q 0 e)
  ppTerm q d (ELincat cat t) = prec d 4 ("lincat" <+> cat <+> ppTerm q 5 t)
  ppTerm q d (ELin cat t) = prec d 4 ("lin" <+> cat <+> ppTerm q 5 t)
  ppTerm q d (Error s)   = prec d 4 ("Predef.error" <+> str s)
  
  ppEquation q (ps,e) = hcat (map (ppPatt q 2) ps) <+> "->" <+> ppTerm q 0 e
  
  ppCase q (p,e) = ppPatt q 0 p <+> "=>" <+> ppTerm q 0 e
  
  instance Pretty Patt where pp = ppPatt Unqualified 0
  
  ppPatt q d (PAlt p1 p2) = prec d 0 (ppPatt q 0 p1 <+> '|' <+> ppPatt q 1 p2)
  ppPatt q d (PSeq p1 p2) = prec d 0 (ppPatt q 0 p1 <+> '+' <+> ppPatt q 1 p2)
  ppPatt q d (PMSeq (_,p1) (_,p2)) = prec d 0 (ppPatt q 0 p1 <+> '+' <+> ppPatt q 1 p2)
  ppPatt q d (PC f ps)    = if null ps
                              then pp f
                              else prec d 1 (f <+> hsep (map (ppPatt q 3) ps))
  ppPatt q d (PP f ps)    = if null ps
                              then ppQIdent q f
                              else prec d 1 (ppQIdent q f <+> hsep (map (ppPatt q 3) ps))
  ppPatt q d (PRep p)     = prec d 1 (ppPatt q 3 p <> '*')
  ppPatt q d (PAs f p)    = prec d 2 (f <> '@' <> ppPatt q 3 p)
  ppPatt q d (PNeg p)     = prec d 2 ('-' <> ppPatt q 3 p)
  ppPatt q d (PChar)      = pp '?'
  ppPatt q d (PChars s)   = brackets (str s)
  ppPatt q d (PMacro id)  = '#' <> id
  ppPatt q d (PM id)      = '#' <> ppQIdent q id
  ppPatt q d PW           = pp '_'
  ppPatt q d (PV id)      = pp id
  ppPatt q d (PInt n)     = pp n
  ppPatt q d (PFloat f)   = pp f
  ppPatt q d (PString s)  = str s
  ppPatt q d (PR xs)      = braces (hsep (punctuate ';' [l <+> '=' <+> ppPatt q 0 e | (l,e) <- xs]))
  ppPatt q d (PImplArg p) = braces (ppPatt q 0 p)
  ppPatt q d (PTilde t)   = prec d 2 ('~' <> ppTerm q 6 t)
  
  ppValue :: TermPrintQual -> Int -> Val -> Doc
  ppValue q d (VGen i x)    = x <> "{-" <> i <> "-}" ---- latter part for debugging
  ppValue q d (VApp u v)    = prec d 4 (ppValue q 4 u <+> ppValue q 5 v)
  ppValue q d (VCn (_,c))   = pp c
  ppValue q d (VClos env e) = case e of
                                Meta _ -> ppTerm q d e <> ppEnv env
                                _      -> ppTerm q d e ---- ++ prEnv env ---- for debugging
  ppValue q d (VRecType xs) = braces (hsep (punctuate ',' [l <> '=' <> ppValue q 0 v | (l,v) <- xs]))
  ppValue q d VType         = pp "Type"
  
  ppConstrs :: Constraints -> [Doc]
  ppConstrs = map (\(v,w) -> braces (ppValue Unqualified 0 v <+> "<>" <+> ppValue Unqualified 0 w))
  
  ppEnv :: Env -> Doc
  ppEnv e = hcat (map (\(x,t) -> braces (x <> ":=" <> ppValue Unqualified 0 t)) e)
  
  str s = doubleQuotes s
  
  ppDecl q (_,id,typ)
    | id == identW = ppTerm q 3 typ
    | otherwise    = parens (id <+> ':' <+> ppTerm q 0 typ)
  
  ppDDecl q (_,id,typ)
    | id == identW = ppTerm q 6 typ
    | otherwise    = parens (id <+> ':' <+> ppTerm q 0 typ)
  
  ppQIdent :: TermPrintQual -> QIdent -> Doc
  ppQIdent q (m,id) =
    case q of
      Terse       ->          pp id
      Unqualified ->          pp id
      Qualified   -> m <> '.' <> id
      Internal    -> m <> '.' <> id
  
  
  instance Pretty Label where pp = pp . label2ident
  
  ppOpenSpec (OSimple id)   = pp id
  ppOpenSpec (OQualif id n) = parens (id <+> '=' <+> n)
  
  ppInstSpec (id,n) = parens (id <+> '=' <+> n)
  
  ppLocDef q (id, (mbt, e)) =
    id <+>
    (case mbt of {Just t -> ':' <+> ppTerm q 0 t; Nothing -> empty} <+> '=' <+> ppTerm q 0 e) <+> ';'
  
  ppBind (Explicit,v) = pp v
  ppBind (Implicit,v) = braces v
  
  ppAltern q (x,y) = ppTerm q 0 x <+> '/' <+> ppTerm q 0 y
  
  ppParams q ps = fsep (intersperse (pp '|') (map (ppParam q) ps))
  ppParam q (id,cxt) = id <+> hsep (map (ppDDecl q) cxt)
  
  ppProduction (Production fid funid args) =
    ppFId fid <+> "->" <+> ppFunId funid <>
    brackets (hcat (punctuate "," (map (hsep . intersperse (pp '|') . map ppFId) args)))
  
  ppSequences q seqsArr
    | null seqs || q /= Internal = empty
    | otherwise                  = "sequences" <+> '{' $$
                                   nest 2 (vcat (map ppSeq seqs)) $$
                                   '}'
    where
      seqs = Array.assocs seqsArr
  
  commaPunct f ds = (hcat (punctuate "," (map f ds)))
  
  prec d1 d2 doc
    | d1 > d2   = parens doc
    | otherwise = doc
  
  getAbs :: Term -> ([(BindType,Ident)], Term)
  getAbs (Abs bt v e) = let (xs,e') = getAbs e
                        in ((bt,v):xs,e')
  getAbs e            = ([],e)
  
  getCTable :: Term -> ([Ident], Term)
  getCTable (T TRaw [(PV v,e)]) = let (vs,e') = getCTable e
                                  in (v:vs,e')
  getCTable (T TRaw [(PW,  e)]) = let (vs,e') = getCTable e
                                  in (identW:vs,e')
  getCTable e                   = ([],e)
  
  getLet :: Term -> ([LocalDef], Term)
  getLet (Let l e) = let (ls,e') = getLet e
                     in (l:ls,e')
  getLet e         = ([],e)
  