module GF.Grammar.ShowTerm where

import GF.Grammar.Grammar
import GF.Grammar.Printer
import GF.Grammar.Lookup
import GF.Data.Operations

import GF.Text.Pretty
import Data.List  (intersperse)

showTerm :: SourceGrammar -> TermPrintStyle -> TermPrintQual -> Term -> String
showTerm :: SourceGrammar -> TermPrintStyle -> TermPrintQual -> Term -> String
showTerm SourceGrammar
gr TermPrintStyle
sty TermPrintQual
q Term
t = case TermPrintStyle
sty of
    TermPrintStyle
TermPrintTable -> Doc -> String
forall a. Pretty a => a -> String
render (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
forall a. Pretty a => [a] -> Doc
vcat [Doc
p Doc -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+> Doc
s | (Doc
p,Doc
s) <- SourceGrammar -> TermPrintQual -> Term -> [(Doc, Doc)]
ppTermTabular SourceGrammar
gr TermPrintQual
q Term
t]
    TermPrintStyle
TermPrintAll   -> Doc -> String
forall a. Pretty a => a -> String
render (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
forall a. Pretty a => [a] -> Doc
vcat [      Doc
s | (Doc
p,Doc
s) <- SourceGrammar -> TermPrintQual -> Term -> [(Doc, Doc)]
ppTermTabular SourceGrammar
gr TermPrintQual
q Term
t]
    TermPrintStyle
TermPrintList  -> Style -> Doc -> String
forall a. Pretty a => Style -> a -> String
renderStyle (Style
style{mode :: Mode
mode = Mode
OneLineMode}) (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ 
      [Doc] -> Doc
forall a. Pretty a => [a] -> Doc
vcat (Char -> [Doc] -> [Doc]
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> [a2] -> [Doc]
punctuate Char
',' [Doc
s | (Doc
p,Doc
s) <- SourceGrammar -> TermPrintQual -> Term -> [(Doc, Doc)]
ppTermTabular SourceGrammar
gr TermPrintQual
q Term
t])
    TermPrintStyle
TermPrintOne   -> Doc -> String
forall a. Pretty a => a -> String
render (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
forall a. Pretty a => [a] -> Doc
vcat [      Doc
s | (Doc
p,Doc
s) <- Int -> [(Doc, Doc)] -> [(Doc, Doc)]
forall a. Int -> [a] -> [a]
take Int
1 (SourceGrammar -> TermPrintQual -> Term -> [(Doc, Doc)]
ppTermTabular SourceGrammar
gr TermPrintQual
q Term
t)]
    TermPrintStyle
TermPrintDefault -> Doc -> String
forall a. Pretty a => a -> String
render (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ TermPrintQual -> Integer -> Term -> Doc
forall t. (Ord t, Num t) => TermPrintQual -> t -> Term -> Doc
ppTerm TermPrintQual
q Integer
0 Term
t

ppTermTabular :: SourceGrammar -> TermPrintQual -> Term -> [(Doc,Doc)]
ppTermTabular :: SourceGrammar -> TermPrintQual -> Term -> [(Doc, Doc)]
ppTermTabular SourceGrammar
gr TermPrintQual
q = Term -> [(Doc, Doc)]
pr where
  pr :: Term -> [(Doc, Doc)]
pr Term
t = case Term
t of
    R [Assign]
rs   -> 
      [(Label
lab       Label -> Char -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+> Char
'.' Doc -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+> Doc
path, Doc
str) | (Label
lab,(Maybe Term
_,Term
val)) <- [Assign]
rs, (Doc
path,Doc
str) <- Term -> [(Doc, Doc)]
pr Term
val]
    T TInfo
_ [Case]
cs -> 
      [(TermPrintQual -> Integer -> Patt -> Doc
forall a. (Num a, Ord a) => TermPrintQual -> a -> Patt -> Doc
ppPatt TermPrintQual
q Integer
0 Patt
patt     Doc -> String -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+> String
"=>" Doc -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+> Doc
path, Doc
str) | (Patt
patt,  Term
val ) <- [Case]
cs, (Doc
path,Doc
str) <- Term -> [(Doc, Doc)]
pr Term
val]
    V Term
ty [Term]
cs -> 
      let pvals :: [Term]
pvals = case SourceGrammar -> Term -> Err [Term]
forall (m :: * -> *).
ErrorMonad m =>
SourceGrammar -> Term -> m [Term]
allParamValues SourceGrammar
gr Term
ty of
                    Ok [Term]
pvals -> [Term]
pvals
                    Bad String
_    -> (Int -> Term) -> [Int] -> [Term]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Term
Meta [Int
1..]
      in [(TermPrintQual -> Integer -> Term -> Doc
forall t. (Ord t, Num t) => TermPrintQual -> t -> Term -> Doc
ppTerm TermPrintQual
q Integer
0 Term
pval Doc -> String -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+> String
"=>" Doc -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+> Doc
path, Doc
str) | (Term
pval, Term
val) <- [Term] -> [Term] -> [(Term, Term)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Term]
pvals [Term]
cs, (Doc
path,Doc
str) <- Term -> [(Doc, Doc)]
pr Term
val]
    Term
_      -> [(Doc
empty,Term -> Doc
ps Term
t)]
  ps :: Term -> Doc
ps Term
t = case Term
t of
    K String
s   -> String -> Doc
forall a. Pretty a => a -> Doc
pp String
s
    C Term
s Term
u -> Term -> Doc
ps Term
s Doc -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+> Term -> Doc
ps Term
u
    FV [Term]
ts -> [Doc] -> Doc
forall a. Pretty a => [a] -> Doc
hsep (Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
intersperse (Char -> Doc
forall a. Pretty a => a -> Doc
pp Char
'/') ((Term -> Doc) -> [Term] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Term -> Doc
ps [Term]
ts))
    Term
_     -> TermPrintQual -> Integer -> Term -> Doc
forall t. (Ord t, Num t) => TermPrintQual -> t -> Term -> Doc
ppTerm TermPrintQual
q Integer
0 Term
t

data TermPrintStyle
  = TermPrintTable
  | TermPrintAll
  | TermPrintList
  | TermPrintOne
  | TermPrintDefault