----------------------------------------------------------------------
-- |
-- 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 PGF2(Literal(..))
import PGF2.Transactions(SeqId)
import GF.Infra.Ident
import GF.Infra.Option
import GF.Grammar.Values
import GF.Grammar.Predef
import GF.Grammar.Grammar

import GF.Text.Pretty
import Data.Maybe (isNothing)
import Data.List  (intersperse)
import Data.Foldable (toList)
import qualified Data.Map as Map
import qualified Data.Sequence as Seq
import qualified GHC.Show

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 idx) =
  "-- param constructor" <+> id <+> ':' <+>
  (case pvalue of
     (L _ ty) -> ppTerm q 0 ty) <+> ';' <+> parens (pp "index = " <> pp idx)
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 mtyp pdef pref pprn mpmcfg) =
  (case mtyp 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 (mtyp,mpmcfg,q) of
     (Just (L _ typ),Just (lindefs,linrefs),Internal)
                    -> "pmcfg" <+> '{' $$
                       nest 2 (vcat (map (ppPmcfgRule (identS "lindef") [cString] id) lindefs)  $$
                               vcat (map (ppPmcfgRule (identS "linref") [id] cString) linrefs)) $$
                       '}'
     _              -> empty)
ppJudgement q (id, CncFun mtyp 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 (mtyp,mpmcfg,q) of
     (Just (args,res,_,_),Just rules,Internal)
                    -> "pmcfg" <+> '{' $$
                       nest 2 (vcat (map (ppPmcfgRule id args res) rules)) $$
                       '}'
     _              -> empty)
ppJudgement q (id, AnyInd cann mid) =
  case q of
    Internal -> "ind" <+> id <+> '=' <+> (if cann then pp "canonical" else empty) <+> mid <+> ';'
    _        -> empty

ppPmcfgRule id arg_cats res_cat (Production vars args res seqids) =
  pp id <+> (':' <+>
             (if null vars
                then empty
                else "∀{" <> hsep (punctuate ',' [ppLVar v <> '<' <> m | (v,m) <- vars]) <> '}'  <+> '.') <+>
             ppPmcfgCat res_cat res <+> "->" <+>
             brackets (hcat (intersperse (pp ',') (zipWith ppPArg arg_cats args))) <+> '=' <+> 
             brackets (hcat (intersperse (pp ',') (map ppSeqId seqids))))

ppPArg cat (PArg _ p) = ppPmcfgCat cat p

ppPmcfgCat :: Ident -> LParam -> Doc
ppPmcfgCat cat p = pp cat <> parens (ppLParam p)

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 (TSymCat i r rs) = pp '<' <> pp i <> pp ',' <> ppLinFun (pp.fst) r rs <> pp '>'
ppTerm q d (TSymVar i r) = pp '<' <> pp i <> pp ',' <> pp '$' <> pp r <> pp '>'

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 (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 (pp (foldr showLitChar "" s))
  where
    showLitChar c
      | c == '"'    = showString "\\\""
      | c > '\DEL'  = showChar c
      | otherwise   = GHC.Show.showLitChar c

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)

ppSeqId :: SeqId -> Doc
ppSeqId seqid = 'S' <> pp seqid

ppSequences q seqs
  | Seq.null seqs || q /= Internal = empty
  | otherwise                      = "sequences" <+> '{' $$
                                     nest 2 (vcat (zipWith ppSeq [0..] (toList seqs))) $$
                                    '}'
  where
    ppSeq seqid seq =
      ppSeqId seqid <+> ":=" <+> hsep (map ppSymbol seq)

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)

ppMeta :: Int -> Doc
ppMeta n
  | n == 0    = pp '?'
  | otherwise = pp '?' <> pp n

ppLit (LStr s) = pp (show s)
ppLit (LInt n) = pp n
ppLit (LFlt d) = pp d

ppSymbol (SymCat d r)= pp '<' <> pp d <> pp ',' <> ppLParam r <> pp '>'
ppSymbol (SymLit d r)= pp '{' <> pp d <> pp ',' <> ppLParam r <> pp '}'
ppSymbol (SymVar d r)   = pp '<' <> pp d <> pp ',' <> pp '$' <> pp r <> pp '>'
ppSymbol (SymKS t)      = doubleQuotes (pp t)
ppSymbol SymNE          = pp "nonExist"
ppSymbol SymBIND        = pp "BIND"
ppSymbol SymSOFT_BIND   = pp "SOFT_BIND"
ppSymbol SymSOFT_SPACE  = pp "SOFT_SPACE"
ppSymbol SymCAPIT       = pp "CAPIT"
ppSymbol SymALL_CAPIT   = pp "ALL_CAPIT"
ppSymbol (SymKP syms alts) = pp "pre" <+> braces (hsep (punctuate (pp ';') (hsep (map ppSymbol syms) : map ppAlt alts)))

ppLParam (LParam r rs) = ppLinFun ppLVar r rs

ppLinFun ppParam r rs
  | r == 0 && not (null rs) = hcat (intersperse (pp '+') (       map ppTerm rs))
  | otherwise               = hcat (intersperse (pp '+') (pp r : map ppTerm rs))
  where
    ppTerm (i,p)
      | i == 1    = ppParam p
      | otherwise = pp i <> pp '*' <> ppParam p

ppLVar p
  | i == 0    = pp (chars !! j)
  | otherwise = pp (chars !! j : show i)
  where
    chars = "ijklmnopqr"
    (i,j) = p `divMod` (length chars)

ppAlt (syms,ps) = hsep (map ppSymbol syms) <+> pp '/' <+> hsep (map (doubleQuotes . pp) ps)