----------------------------------------------------------------------
-- |
-- 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(LIndex,LParam,Symbol(..))
import GF.Infra.Ident
import GF.Infra.Option
import GF.Grammar.Values
import GF.Grammar.Grammar

import GF.Text.Pretty
import Data.Maybe (isNothing)
import Data.List  (intersperse)
import qualified Data.Map as Map
import qualified Data.Array.IArray as Array
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 _ _ jments) =
    hdr $$
    nest 2 (ppOptions opts $$
            vcat (map (ppJudgement q) (Map.toList jments))) $$
    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 rules,Internal)
                    -> "pmcfg" <+> '{' $$
                       nest 2 (vcat (map (ppPmcfgRule id [] id) rules)) $$
                       '}'
     _              -> 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 (PMCFGRule res args lins) =
  pp id <+> (':' <+> hsep (intersperse (pp '*') (zipWith ppPmcfgCat arg_cats args)) <+> "->" <+> ppPmcfgCat res_cat res $$
             '=' <+> brackets (vcat (map (hsep . map ppSymbol) lins)))

ppPmcfgCat :: Ident -> PMCFGCat -> Doc
ppPmcfgCat cat (PMCFGCat r rs) = pp cat <> parens (ppLinFun ppLParam r rs)

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 r rs <> 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)

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 rs)= pp '<' <> pp d <> pp ',' <> ppLinFun ppLParam r rs <> pp '>'
ppSymbol (SymLit d r)   = pp '{' <> pp d <> pp ',' <> pp 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)))

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

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