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