summaryrefslogtreecommitdiff
path: root/src/compiler/GF/Grammar
diff options
context:
space:
mode:
Diffstat (limited to 'src/compiler/GF/Grammar')
-rw-r--r--src/compiler/GF/Grammar/Grammar.hs30
-rw-r--r--src/compiler/GF/Grammar/Lookup.hs20
-rw-r--r--src/compiler/GF/Grammar/Macros.hs24
-rw-r--r--src/compiler/GF/Grammar/PatternMatch.hs20
-rw-r--r--src/compiler/GF/Grammar/Printer.hs315
-rw-r--r--src/compiler/GF/Grammar/ShowTerm.hs14
6 files changed, 202 insertions, 221 deletions
diff --git a/src/compiler/GF/Grammar/Grammar.hs b/src/compiler/GF/Grammar/Grammar.hs
index df60c7c54..816a9f438 100644
--- a/src/compiler/GF/Grammar/Grammar.hs
+++ b/src/compiler/GF/Grammar/Grammar.hs
@@ -36,7 +36,7 @@ module GF.Grammar.Grammar (
PMCFG(..), Production(..), FId, FunId, SeqId, LIndex, Sequence,
Info(..),
- Location(..), L(..), unLoc, noLoc,
+ Location(..), L(..), unLoc, noLoc, ppLocation, ppL,
Type,
Cat,
Fun,
@@ -63,6 +63,7 @@ module GF.Grammar.Grammar (
import GF.Infra.Ident
import GF.Infra.Option ---
+import GF.Infra.Location
import GF.Data.Operations
@@ -74,7 +75,7 @@ import Data.Array.Unboxed
import qualified Data.Map as Map
--import qualified Data.Set as Set
--import qualified Data.IntMap as IntMap
-import Text.PrettyPrint
+import GF.Text.Pretty
--import System.FilePath
--import Control.Monad.Identity
@@ -98,6 +99,8 @@ data SourceModInfo = ModInfo {
jments :: Map.Map Ident Info
}
+instance HasSourcePath SourceModInfo where sourcePath = msrc
+
type SourceModule = (Ident, SourceModInfo)
-- | encoding the type of the module
@@ -200,12 +203,12 @@ abstractOfConcrete gr c = do
n <- lookupModule gr c
case mtype n of
MTConcrete a -> return a
- _ -> raise $ render (text "expected concrete" <+> ppIdent c)
+ _ -> raise $ render ("expected concrete" <+> c)
lookupModule :: ErrorMonad m => SourceGrammar -> Ident -> m SourceModInfo
lookupModule gr m = case Map.lookup m (moduleMap gr) of
Just i -> return i
- Nothing -> raise $ render (text "unknown module" <+> ppIdent m <+> text "among" <+> hsep (map (ppIdent . fst) (modules gr)))
+ Nothing -> raise $ render ("unknown module" <+> m <+> "among" <+> hsep (map fst (modules gr)))
isModAbs :: SourceModInfo -> Bool
isModAbs m =
@@ -263,7 +266,7 @@ allAbstracts :: SourceGrammar -> [Ident]
allAbstracts gr =
case topoTest [(i,extends m) | (i,m) <- modules gr, mtype m == MTAbstract] of
Left is -> is
- Right cycles -> error $ render (text "Cyclic abstract modules:" <+> vcat (map (hsep . map ppIdent) cycles))
+ Right cycles -> error $ render ("Cyclic abstract modules:" <+> vcat (map hsep cycles))
-- | the last abstract in dependency order (head of list)
greatestAbstract :: SourceGrammar -> Maybe Ident
@@ -332,23 +335,6 @@ data Info =
| AnyInd Bool Ident -- ^ (/INDIR/) the 'Bool' says if canonical
deriving Show
-data Location
- = NoLoc
- | Local Int Int
- | External FilePath Location
- deriving (Show,Eq,Ord)
-
-data L a = L Location a -- location information
- deriving Show
-
-instance Functor L where
- fmap f (L loc x) = L loc (f x)
-
-unLoc :: L a -> a
-unLoc (L _ x) = x
-
-noLoc = L NoLoc
-
type Type = Term
type Cat = QIdent
type Fun = QIdent
diff --git a/src/compiler/GF/Grammar/Lookup.hs b/src/compiler/GF/Grammar/Lookup.hs
index 6bdf87a5c..da75267de 100644
--- a/src/compiler/GF/Grammar/Lookup.hs
+++ b/src/compiler/GF/Grammar/Lookup.hs
@@ -42,7 +42,7 @@ import GF.Grammar.Lockfield
import Data.List (sortBy)
--import Data.Maybe (maybe)
--import Control.Monad
-import Text.PrettyPrint
+import GF.Text.Pretty
import qualified Data.Map as Map
-- whether lock fields are added in reuse
@@ -83,7 +83,7 @@ lookupResDefLoc gr (m,c)
AnyInd _ n -> look n c
ResParam _ _ -> return (noLoc (QC (m,c)))
ResValue _ -> return (noLoc (QC (m,c)))
- _ -> raise $ render (ppIdent c <+> text "is not defined in resource" <+> ppIdent m)
+ _ -> raise $ render (c <+> "is not defined in resource" <+> m)
lookupResType :: ErrorMonad m => SourceGrammar -> QIdent -> m Type
lookupResType gr (m,c) = do
@@ -99,7 +99,7 @@ lookupResType gr (m,c) = do
AnyInd _ n -> lookupResType gr (n,c)
ResParam _ _ -> return typePType
ResValue (L _ t) -> return t
- _ -> raise $ render (ppIdent c <+> text "has no type defined in resource" <+> ppIdent m)
+ _ -> raise $ render (c <+> "has no type defined in resource" <+> m)
lookupOverload :: ErrorMonad m => SourceGrammar -> QIdent -> m [([Type],(Type,Term))]
lookupOverload gr (m,c) = do
@@ -112,7 +112,7 @@ lookupOverload gr (m,c) = do
concat tss
AnyInd _ n -> lookupOverload gr (n,c)
- _ -> raise $ render (ppIdent c <+> text "is not an overloaded operation")
+ _ -> raise $ render (c <+> "is not an overloaded operation")
-- | returns the original 'Info' and the module where it was found
lookupOrigInfo :: ErrorMonad m => SourceGrammar -> QIdent -> m (Ident,Info)
@@ -132,7 +132,7 @@ lookupParamValues gr c = do
(_,info) <- lookupOrigInfo gr c
case info of
ResParam _ (Just pvs) -> return pvs
- _ -> raise $ render (ppQIdent Qualified c <+> text "has no parameter values defined")
+ _ -> raise $ render (ppQIdent Qualified c <+> "has no parameter values defined")
allParamValues :: ErrorMonad m => SourceGrammar -> Type -> m [Term]
allParamValues cnc ptyp =
@@ -148,13 +148,13 @@ allParamValues cnc ptyp =
pvs <- allParamValues cnc pt
vvs <- allParamValues cnc vt
return [V pt ts | ts <- combinations (replicate (length pvs) vvs)]
- _ -> raise (render (text "cannot find parameter values for" <+> ppTerm Unqualified 0 ptyp))
+ _ -> raise (render ("cannot find parameter values for" <+> ptyp))
where
-- to normalize records and record types
sortByFst = sortBy (\ x y -> compare (fst x) (fst y))
lookupAbsDef :: ErrorMonad m => SourceGrammar -> Ident -> Ident -> m (Maybe Int,Maybe [Equation])
-lookupAbsDef gr m c = errIn (render (text "looking up absdef of" <+> ppIdent c)) $ do
+lookupAbsDef gr m c = errIn (render ("looking up absdef of" <+> c)) $ do
info <- lookupQIdentInfo gr (m,c)
case info of
AbsFun _ a d _ -> return (a,fmap (map unLoc) d)
@@ -168,7 +168,7 @@ lookupLincat gr m c = do
case info of
CncCat (Just (L _ t)) _ _ _ _ -> return t
AnyInd _ n -> lookupLincat gr n c
- _ -> raise (render (ppIdent c <+> text "has no linearization type in" <+> ppIdent m))
+ _ -> raise (render (c <+> "has no linearization type in" <+> m))
-- | this is needed at compile time
lookupFunType :: ErrorMonad m => SourceGrammar -> Ident -> Ident -> m Type
@@ -177,7 +177,7 @@ lookupFunType gr m c = do
case info of
AbsFun (Just (L _ t)) _ _ _ -> return t
AnyInd _ n -> lookupFunType gr n c
- _ -> raise (render (text "cannot find type of" <+> ppIdent c))
+ _ -> raise (render ("cannot find type of" <+> c))
-- | this is needed at compile time
lookupCatContext :: ErrorMonad m => SourceGrammar -> Ident -> Ident -> m Context
@@ -186,7 +186,7 @@ lookupCatContext gr m c = do
case info of
AbsCat (Just (L _ co)) -> return co
AnyInd _ n -> lookupCatContext gr n c
- _ -> raise (render (text "unknown category" <+> ppIdent c))
+ _ -> raise (render ("unknown category" <+> c))
-- this gives all opers and param constructors, also overloaded opers and funs, and the types, and locations
diff --git a/src/compiler/GF/Grammar/Macros.hs b/src/compiler/GF/Grammar/Macros.hs
index e516f0e47..b623aaa2b 100644
--- a/src/compiler/GF/Grammar/Macros.hs
+++ b/src/compiler/GF/Grammar/Macros.hs
@@ -31,7 +31,7 @@ import qualified Data.Traversable as T(mapM)
import Control.Monad (liftM, liftM2, liftM3)
--import Data.Char (isDigit)
import Data.List (sortBy,nub)
-import Text.PrettyPrint
+import GF.Text.Pretty
typeForm :: Type -> (Context, Cat, [Term])
typeForm t =
@@ -45,7 +45,7 @@ typeForm t =
Q c -> ([],c,[])
QC c -> ([],c,[])
Sort c -> ([],(identW, c),[])
- _ -> error (render (text "no normal form of type" <+> ppTerm Unqualified 0 t))
+ _ -> error (render ("no normal form of type" <+> ppTerm Unqualified 0 t))
typeFormCnc :: Type -> (Context, Type)
typeFormCnc t =
@@ -170,7 +170,7 @@ projectRec :: Label -> [Assign] -> Term
projectRec l rs =
case lookup l rs of
Just (_,t) -> t
- Nothing -> error (render (text "no value for label" <+> ppLabel l))
+ Nothing -> error (render ("no value for label" <+> l))
zipAssign :: [Label] -> [Term] -> [Assign]
zipAssign ls ts = [assign l t | (l,t) <- zip ls ts]
@@ -194,7 +194,7 @@ mkRecType = mkRecTypeN 0
record2subst :: Term -> Err Substitution
record2subst t = case t of
R fs -> return [(identC x, t) | (LIdent x,(_,t)) <- fs]
- _ -> Bad (render (text "record expected, found" <+> ppTerm Unqualified 0 t))
+ _ -> Bad (render ("record expected, found" <+> ppTerm Unqualified 0 t))
typeType, typePType, typeStr, typeTok, typeStrs :: Term
@@ -273,8 +273,8 @@ plusRecType t1 t2 = case (t1, t2) of
(RecType r1, RecType r2) -> case
filter (`elem` (map fst r1)) (map fst r2) of
[] -> return (RecType (r1 ++ r2))
- ls -> raise $ render (text "clashing labels" <+> hsep (map ppLabel ls))
- _ -> raise $ render (text "cannot add record types" <+> ppTerm Unqualified 0 t1 <+> text "and" <+> ppTerm Unqualified 0 t2)
+ ls -> raise $ render ("clashing labels" <+> hsep ls)
+ _ -> raise $ render ("cannot add record types" <+> ppTerm Unqualified 0 t1 <+> "and" <+> ppTerm Unqualified 0 t2)
--plusRecord :: Term -> Term -> Err Term
plusRecord t1 t2 =
@@ -283,7 +283,7 @@ plusRecord t1 t2 =
(l,v) <- r1, not (elem l (map fst r2)) ] ++ r2))
(_, FV rs) -> mapM (plusRecord t1) rs >>= return . FV
(FV rs,_ ) -> mapM (`plusRecord` t2) rs >>= return . FV
- _ -> raise $ render (text "cannot add records" <+> ppTerm Unqualified 0 t1 <+> text "and" <+> ppTerm Unqualified 0 t2)
+ _ -> raise $ render ("cannot add records" <+> ppTerm Unqualified 0 t1 <+> "and" <+> ppTerm Unqualified 0 t2)
-- | default linearization type
defLinType :: Type
@@ -386,7 +386,7 @@ term2patt trm = case termForm trm of
Ok ([], Cn c, []) -> do
return (PMacro c)
- _ -> Bad $ render (text "no pattern corresponds to term" <+> ppTerm Unqualified 0 trm)
+ _ -> Bad $ render ("no pattern corresponds to term" <+> ppTerm Unqualified 0 trm)
patt2term :: Patt -> Term
patt2term pt = case pt of
@@ -450,7 +450,7 @@ strsFromTerm t = case t of
]
FV ts -> mapM strsFromTerm ts >>= return . concat
Strs ts -> mapM strsFromTerm ts >>= return . concat
- _ -> raise (render (text "cannot get Str from term" <+> ppTerm Unqualified 0 t))
+ _ -> raise (render ("cannot get Str from term" <+> ppTerm Unqualified 0 t))
-- | to print an Str-denoting term as a string; if the term is of wrong type, the error msg
stringFromTerm :: Term -> String
@@ -609,7 +609,7 @@ topoSortJments :: ErrorMonad m => SourceModule -> m [(Ident,Info)]
topoSortJments (m,mi) = do
is <- either
return
- (\cyc -> raise (render (text "circular definitions:" <+> fsep (map ppIdent (head cyc)))))
+ (\cyc -> raise (render ("circular definitions:" <+> fsep (head cyc))))
(topoTest (allDependencies (==m) (jments mi)))
return (reverse [(i,info) | i <- is, Ok info <- [lookupTree showIdent i (jments mi)]])
@@ -617,8 +617,8 @@ topoSortJments2 :: ErrorMonad m => SourceModule -> m [[(Ident,Info)]]
topoSortJments2 (m,mi) = do
iss <- either
return
- (\cyc -> raise (render (text "circular definitions:"
- <+> fsep (map ppIdent (head cyc)))))
+ (\cyc -> raise (render ("circular definitions:"
+ <+> fsep (head cyc))))
(topoTest2 (allDependencies (==m) (jments mi)))
return
[[(i,info) | i<-is,Ok info<-[lookupTree showIdent i (jments mi)]] | is<-iss]
diff --git a/src/compiler/GF/Grammar/PatternMatch.hs b/src/compiler/GF/Grammar/PatternMatch.hs
index 81541b2a3..48cb9bd3f 100644
--- a/src/compiler/GF/Grammar/PatternMatch.hs
+++ b/src/compiler/GF/Grammar/PatternMatch.hs
@@ -22,20 +22,20 @@ import GF.Data.Operations
import GF.Grammar.Grammar
import GF.Infra.Ident
import GF.Grammar.Macros
-import GF.Grammar.Printer
+--import GF.Grammar.Printer
--import Data.List
import Control.Monad
-import Text.PrettyPrint
+import GF.Text.Pretty
--import Debug.Trace
matchPattern :: ErrorMonad m => [(Patt,rhs)] -> Term -> m (rhs, Substitution)
matchPattern pts term =
if not (isInConstantForm term)
- then raise (render (text "variables occur in" <+> ppTerm Unqualified 0 term))
+ then raise (render ("variables occur in" <+> pp term))
else do
term' <- mkK term
- errIn (render (text "trying patterns" <+> hsep (punctuate comma (map (ppPatt Unqualified 0 . fst) pts)))) $
+ errIn (render ("trying patterns" <+> hsep (punctuate ',' (map fst pts)))) $
findMatch [([p],t) | (p,t) <- pts] [term']
where
-- to capture all Str with string pattern matching
@@ -49,7 +49,7 @@ matchPattern pts term =
K w -> return [w]
C v w -> liftM2 (++) (getS v) (getS w)
Empty -> return []
- _ -> raise (render (text "cannot get string from" <+> ppTerm Unqualified 0 s))
+ _ -> raise (render ("cannot get string from" <+> s))
testOvershadow :: ErrorMonad m => [Patt] -> [Term] -> m [Patt]
testOvershadow pts vs = do
@@ -60,10 +60,10 @@ testOvershadow pts vs = do
findMatch :: ErrorMonad m => [([Patt],rhs)] -> [Term] -> m (rhs, Substitution)
findMatch cases terms = case cases of
- [] -> raise (render (text "no applicable case for" <+> hsep (punctuate comma (map (ppTerm Unqualified 0) terms))))
+ [] -> raise (render ("no applicable case for" <+> hsep (punctuate ',' terms)))
(patts,_):_ | length patts /= length terms ->
- raise (render (text "wrong number of args for patterns :" <+> hsep (map (ppPatt Unqualified 0) patts) <+>
- text "cannot take" <+> hsep (map (ppTerm Unqualified 0) terms)))
+ raise (render ("wrong number of args for patterns :" <+> hsep patts <+>
+ "cannot take" <+> hsep terms))
(patts,val):cc -> case mapM tryMatch (zip patts terms) of
Ok substs -> return (val, concat substs)
_ -> findMatch cc terms
@@ -116,7 +116,7 @@ tryMatch (p,t) = do
(PNeg p',_) -> case tryMatch (p',t) of
Bad _ -> return []
- _ -> raise (render (text "no match with negative pattern" <+> ppPatt Unqualified 0 p))
+ _ -> raise (render ("no match with negative pattern" <+> p))
(PSeq p1 p2, ([],K s, [])) -> matchPSeq p1 p2 s
(PMSeq mp1 mp2, ([],K s, [])) -> matchPMSeq mp1 mp2 s
@@ -130,7 +130,7 @@ tryMatch (p,t) = do
(PChar, ([],K [_], [])) -> return []
(PChars cs, ([],K [c], [])) | elem c cs -> return []
- _ -> raise (render (text "no match in case expr for" <+> ppTerm Unqualified 0 t))
+ _ -> raise (render ("no match in case expr for" <+> t))
matchPMSeq (m1,p1) (m2,p2) s = matchPSeq' m1 p1 m2 p2 s
--matchPSeq p1 p2 s = matchPSeq' (0,maxBound::Int) p1 (0,maxBound::Int) p2 s
diff --git a/src/compiler/GF/Grammar/Printer.hs b/src/compiler/GF/Grammar/Printer.hs
index 6138f2ab9..da29e3ebd 100644
--- a/src/compiler/GF/Grammar/Printer.hs
+++ b/src/compiler/GF/Grammar/Printer.hs
@@ -9,8 +9,6 @@
module GF.Grammar.Printer
( TermPrintQual(..)
- , ppLabel
- , ppGrammar
, ppModule
, ppJudgement
, ppParams
@@ -18,7 +16,6 @@ module GF.Grammar.Printer
, ppPatt
, ppValue
, ppConstrs
- , ppLocation
, ppQIdent
, ppMeta
, getAbs
@@ -31,7 +28,7 @@ import GF.Grammar.Grammar
import PGF.Internal (ppMeta, ppLit, ppFId, ppFunId, ppSeqId, ppSeq)
-import Text.PrettyPrint
+import GF.Text.Pretty
import Data.Maybe (isNothing)
import Data.List (intersperse)
import qualified Data.Map as Map
@@ -43,8 +40,8 @@ data TermPrintQual
= Unqualified | Qualified | Internal
deriving Eq
-ppGrammar :: SourceGrammar -> Doc
-ppGrammar sgr = vcat $ map (ppModule Qualified) $ modules sgr
+instance Pretty SourceGrammar where
+ pp = vcat . map (ppModule Qualified) . modules
ppModule :: TermPrintQual -> SourceModule -> Doc
ppModule q (mn, ModInfo mtype mstat opts exts with opens _ _ mseqs jments) =
@@ -54,288 +51,286 @@ ppModule q (mn, ModInfo mtype mstat opts exts with opens _ _ mseqs jments) =
maybe empty (ppSequences q) mseqs) $$
ftr
where
- hdr = complModDoc <+> modTypeDoc <+> equals <+>
- hsep (intersperse (text "**") $
+ hdr = complModDoc <+> modTypeDoc <+> '=' <+>
+ hsep (intersperse (pp "**") $
filter (not . isEmpty) $ [ commaPunct ppExtends exts
, maybe empty ppWith with
, if null opens
- then lbrace
- else text "open" <+> commaPunct ppOpenSpec opens <+> text "in" <+> lbrace
+ then pp '{'
+ else "open" <+> commaPunct ppOpenSpec opens <+> "in" <+> '{'
])
- ftr = rbrace
+ ftr = '}'
complModDoc =
case mstat of
MSComplete -> empty
- MSIncomplete -> text "incomplete"
+ MSIncomplete -> pp "incomplete"
modTypeDoc =
case mtype of
- MTAbstract -> text "abstract" <+> ppIdent mn
- MTResource -> text "resource" <+> ppIdent mn
- MTConcrete abs -> text "concrete" <+> ppIdent mn <+> text "of" <+> ppIdent abs
- MTInterface -> text "interface" <+> ppIdent mn
- MTInstance ie -> text "instance" <+> ppIdent mn <+> text "of" <+> ppExtends ie
-
- ppExtends (id,MIAll ) = ppIdent id
- ppExtends (id,MIOnly incs) = ppIdent id <+> brackets (commaPunct ppIdent incs)
- ppExtends (id,MIExcept incs) = ppIdent id <+> char '-' <+> brackets (commaPunct ppIdent incs)
+ 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) <+> text "with" <+> commaPunct ppInstSpec opens
+ ppWith (id,ext,opens) = ppExtends (id,ext) <+> "with" <+> commaPunct ppInstSpec opens
ppOptions opts =
- text "flags" $$
- nest 2 (vcat [text option <+> equals <+> ppLit value <+> semi | (option,value) <- optionsGFO opts])
+ "flags" $$
+ nest 2 (vcat [option <+> '=' <+> ppLit value <+> ';' | (option,value) <- optionsGFO opts])
ppJudgement q (id, AbsCat pcont ) =
- text "cat" <+> ppIdent id <+>
+ "cat" <+> id <+>
(case pcont of
Just (L _ cont) -> hsep (map (ppDecl q) cont)
- Nothing -> empty) <+> semi
+ 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) -> text kind <+> ppIdent id <+> colon <+> ppTerm q 0 typ <+> semi
+ Just (L _ typ) -> kind <+> id <+> ':' <+> ppTerm q 0 typ <+> ';'
Nothing -> empty) $$
(case pexp of
Just [] -> empty
- Just eqs -> text "def" <+> vcat [ppIdent id <+> hsep (map (ppPatt q 2) ps) <+> equals <+> ppTerm q 0 e <+> semi | L _ (ps,e) <- eqs]
+ 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 _) =
- text "param" <+> ppIdent id <+>
+ "param" <+> id <+>
(case pparams of
- Just (L _ ps) -> equals <+> ppParams q ps
- _ -> empty) <+> semi
+ Just (L _ ps) -> '=' <+> ppParams q ps
+ _ -> empty) <+> ';'
ppJudgement q (id, ResValue pvalue) =
- text "-- param constructor" <+> ppIdent id <+> colon <+>
+ "-- param constructor" <+> id <+> ':' <+>
(case pvalue of
- (L _ ty) -> ppTerm q 0 ty) <+> semi
+ (L _ ty) -> ppTerm q 0 ty) <+> ';'
ppJudgement q (id, ResOper ptype pexp) =
- text "oper" <+> ppIdent id <+>
- (case ptype of {Just (L _ t) -> colon <+> ppTerm q 0 t; Nothing -> empty} $$
- case pexp of {Just (L _ e) -> equals <+> ppTerm q 0 e; Nothing -> empty}) <+> semi
+ "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) =
- text "oper" <+> ppIdent id <+> equals <+>
- (text "overload" <+> lbrace $$
- nest 2 (vcat [ppIdent id <+> (colon <+> ppTerm q 0 ty $$ equals <+> ppTerm q 0 e <+> semi) | (L _ ty,L _ e) <- defs]) $$
- rbrace) <+> semi
+ "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) -> text "lincat" <+> ppIdent id <+> equals <+> ppTerm q 0 typ <+> semi
+ Just (L _ typ) -> "lincat" <+> id <+> '=' <+> ppTerm q 0 typ <+> ';'
Nothing -> empty) $$
(case pdef of
- Just (L _ exp) -> text "lindef" <+> ppIdent id <+> equals <+> ppTerm q 0 exp <+> semi
+ Just (L _ exp) -> "lindef" <+> id <+> '=' <+> ppTerm q 0 exp <+> ';'
Nothing -> empty) $$
(case pref of
- Just (L _ exp) -> text "linref" <+> ppIdent id <+> equals <+> ppTerm q 0 exp <+> semi
+ Just (L _ exp) -> "linref" <+> id <+> '=' <+> ppTerm q 0 exp <+> ';'
Nothing -> empty) $$
(case pprn of
- Just (L _ prn) -> text "printname" <+> ppIdent id <+> equals <+> ppTerm q 0 prn <+> semi
+ Just (L _ prn) -> "printname" <+> id <+> '=' <+> ppTerm q 0 prn <+> ';'
Nothing -> empty) $$
(case (mpmcfg,q) of
(Just (PMCFG prods funs),Internal)
- -> text "pmcfg" <+> ppIdent id <+> equals <+> char '{' $$
+ -> "pmcfg" <+> id <+> '=' <+> '{' $$
nest 2 (vcat (map ppProduction prods) $$
- space $$
- vcat (map (\(funid,arr) -> ppFunId funid <+> text ":=" <+>
- parens (hcat (punctuate comma (map ppSeqId (Array.elems arr)))))
+ ' ' $$
+ vcat (map (\(funid,arr) -> ppFunId funid <+> ":=" <+>
+ parens (hcat (punctuate ',' (map ppSeqId (Array.elems arr)))))
(Array.assocs funs))) $$
- char '}'
+ '}'
_ -> empty)
ppJudgement q (id, CncFun ptype pdef pprn mpmcfg) =
(case pdef of
Just (L _ e) -> let (xs,e') = getAbs e
- in text "lin" <+> ppIdent id <+> hsep (map ppBind xs) <+> equals <+> ppTerm q 0 e' <+> semi
+ in "lin" <+> id <+> hsep (map ppBind xs) <+> '=' <+> ppTerm q 0 e' <+> ';'
Nothing -> empty) $$
(case pprn of
- Just (L _ prn) -> text "printname" <+> ppIdent id <+> equals <+> ppTerm q 0 prn <+> semi
+ Just (L _ prn) -> "printname" <+> id <+> '=' <+> ppTerm q 0 prn <+> ';'
Nothing -> empty) $$
(case (mpmcfg,q) of
(Just (PMCFG prods funs),Internal)
- -> text "pmcfg" <+> ppIdent id <+> equals <+> char '{' $$
+ -> "pmcfg" <+> id <+> '=' <+> '{' $$
nest 2 (vcat (map ppProduction prods) $$
- space $$
- vcat (map (\(funid,arr) -> ppFunId funid <+> text ":=" <+>
- parens (hcat (punctuate comma (map ppSeqId (Array.elems arr)))))
+ ' ' $$
+ vcat (map (\(funid,arr) -> ppFunId funid <+> ":=" <+>
+ parens (hcat (punctuate ',' (map ppSeqId (Array.elems arr)))))
(Array.assocs funs))) $$
- char '}'
+ '}'
_ -> empty)
ppJudgement q (id, AnyInd cann mid) =
case q of
- Internal -> text "ind" <+> ppIdent id <+> equals <+> (if cann then text "canonical" else empty) <+> ppIdent mid <+> semi
+ 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 (char '\\' <> commaPunct ppBind xs <+> text "->" <+> ppTerm q 0 e')
+ in prec d 0 ('\\' <> commaPunct ppBind xs <+> "->" <+> ppTerm q 0 e')
ppTerm q d (T TRaw xs) = case getCTable (T TRaw xs) of
- ([],_) -> text "table" <+> lbrace $$
- nest 2 (vcat (punctuate semi (map (ppCase q) xs))) $$
- rbrace
- (vs,e) -> prec d 0 (text "\\\\" <> commaPunct ppIdent vs <+> text "=>" <+> ppTerm q 0 e)
-ppTerm q d (T (TTyped t) xs) = text "table" <+> ppTerm q 0 t <+> lbrace $$
- nest 2 (vcat (punctuate semi (map (ppCase q) xs))) $$
- rbrace
-ppTerm q d (T (TComp t) xs) = text "table" <+> ppTerm q 0 t <+> lbrace $$
- nest 2 (vcat (punctuate semi (map (ppCase q) xs))) $$
- rbrace
-ppTerm q d (T (TWild t) xs) = text "table" <+> ppTerm q 0 t <+> lbrace $$
- nest 2 (vcat (punctuate semi (map (ppCase q) xs))) $$
- rbrace
+ ([],_) -> "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 <+> text "->" <+> ppTerm q 0 b)
- else prec d 0 (parens (ppBind (bt,x) <+> colon <+> ppTerm q 0 a) <+> text "->" <+> ppTerm q 0 b)
-ppTerm q d (Table kt vt)=prec d 0 (ppTerm q 3 kt <+> text "=>" <+> ppTerm q 0 vt)
+ 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 (text "let" <+> vcat (map (ppLocDef q) (l:ls)) $$ text "in" <+> ppTerm q 0 e')
-ppTerm q d (Example e s)=prec d 0 (text "in" <+> ppTerm q 5 e <+> str s)
-ppTerm q d (C e1 e2) =prec d 1 (hang (ppTerm q 2 e1) 2 (text "++" <+> ppTerm q 1 e2))
-ppTerm q d (Glue e1 e2) =prec d 2 (ppTerm q 3 e1 <+> char '+' <+> ppTerm q 2 e2)
+ 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 text "case" <+> ppTerm q 0 e <+> text "of" <+> lbrace $$
- nest 2 (vcat (punctuate semi (map (ppCase q) xs))) $$
- rbrace
- _ -> prec d 3 (hang (ppTerm q 3 x) 2 (text "!" <+> ppTerm q 4 y))
-ppTerm q d (ExtR x y) = prec d 3 (ppTerm q 3 x <+> text "**" <+> ppTerm q 4 y)
+ 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 (text "table") 2 (sep [ppTerm q 6 e,brackets (fsep (punctuate semi (map (ppTerm q 0) es)))])
-ppTerm q d (FV es) = text "variants" <+> braces (fsep (punctuate semi (map (ppTerm q 0) es)))
-ppTerm q d (AdHocOverload es) = text "overload" <+> braces (fsep (punctuate semi (map (ppTerm q 0) es)))
-ppTerm q d (Alts e xs) = prec d 4 (text "pre" <+> braces (ppTerm q 0 e <> semi <+> fsep (punctuate semi (map (ppAltern q) xs))))
-ppTerm q d (Strs es) = text "strs" <+> braces (fsep (punctuate semi (map (ppTerm q 0) es)))
-ppTerm q d (EPatt p) = prec d 4 (char '#' <+> ppPatt q 2 p)
-ppTerm q d (EPattType t)=prec d 4 (text "pattern" <+> ppTerm q 0 t)
-ppTerm q d (P t l) = prec d 5 (ppTerm q 5 t <> char '.' <> ppLabel l)
-ppTerm q d (Cn id) = ppIdent id
-ppTerm q d (Vr id) = ppIdent id
+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) = "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) = ppIdent id
+ppTerm q d (Sort id) = pp id
ppTerm q d (K s) = str s
-ppTerm q d (EInt n) = int n
-ppTerm q d (EFloat f) = double f
+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) = text "[]"
-ppTerm q d (R []) = text "<>" -- to distinguish from {} empty RecType
-ppTerm q d (R xs) = braces (fsep (punctuate semi [ppLabel l <+>
- fsep [case mb_t of {Just t -> colon <+> ppTerm q 0 t; Nothing -> empty},
- equals <+> ppTerm q 0 e] | (l,(mb_t,e)) <- xs]))
-ppTerm q d (RecType xs)= braces (fsep (punctuate semi [ppLabel l <+> colon <+> ppTerm q 0 t | (l,t) <- xs]))
-ppTerm q d (Typed e t) = char '<' <> ppTerm q 0 e <+> colon <+> ppTerm q 0 t <> char '>'
+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)= 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 (text "lincat" <+> ppIdent cat <+> ppTerm q 5 t)
-ppTerm q d (ELin cat t) = prec d 4 (text "lin" <+> ppIdent cat <+> ppTerm q 5 t)
-ppTerm q d (Error s) = prec d 4 (text "Predef.error" <+> str s)
+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
-ppEquation q (ps,e) = hcat (map (ppPatt q 2) ps) <+> text "->" <+> ppTerm q 0 e
+ppCase q (p,e) = ppPatt q 0 p <+> "=>" <+> ppTerm q 0 e
-ppCase q (p,e) = ppPatt q 0 p <+> text "=>" <+> 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 <+> char '|' <+> ppPatt q 1 p2)
-ppPatt q d (PSeq p1 p2) = prec d 0 (ppPatt q 0 p1 <+> char '+' <+> ppPatt q 1 p2)
-ppPatt q d (PMSeq (_,p1) (_,p2)) = prec d 0 (ppPatt q 0 p1 <+> char '+' <+> ppPatt q 1 p2)
+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 ppIdent f
- else prec d 1 (ppIdent f <+> hsep (map (ppPatt q 3) 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 <> char '*')
-ppPatt q d (PAs f p) = prec d 2 (ppIdent f <> char '@' <> ppPatt q 3 p)
-ppPatt q d (PNeg p) = prec d 2 (char '-' <> ppPatt q 3 p)
-ppPatt q d (PChar) = char '?'
+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) = char '#' <> ppIdent id
-ppPatt q d (PM id) = char '#' <> ppQIdent q id
-ppPatt q d PW = char '_'
-ppPatt q d (PV id) = ppIdent id
-ppPatt q d (PInt n) = int n
-ppPatt q d (PFloat f) = double f
+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 semi [ppLabel l <+> equals <+> ppPatt q 0 e | (l,e) <- xs]))
+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 (char '~' <> ppTerm q 6 t)
+ppPatt q d (PTilde t) = prec d 2 ('~' <> ppTerm q 6 t)
ppValue :: TermPrintQual -> Int -> Val -> Doc
-ppValue q d (VGen i x) = ppIdent x <> text "{-" <> int i <> text "-}" ---- latter part for debugging
+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)) = ppIdent c
+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 comma [ppLabel l <> char '=' <> ppValue q 0 v | (l,v) <- xs]))
-ppValue q d VType = text "Type"
+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 <+> text "<>" <+> ppValue Unqualified 0 w))
+ppConstrs = map (\(v,w) -> braces (ppValue Unqualified 0 v <+> "<>" <+> ppValue Unqualified 0 w))
ppEnv :: Env -> Doc
-ppEnv e = hcat (map (\(x,t) -> braces (ppIdent x <> text ":=" <> ppValue Unqualified 0 t)) e)
+ppEnv e = hcat (map (\(x,t) -> braces (x <> ":=" <> ppValue Unqualified 0 t)) e)
-str s = doubleQuotes (text s)
+str s = doubleQuotes s
ppDecl q (_,id,typ)
| id == identW = ppTerm q 3 typ
- | otherwise = parens (ppIdent id <+> colon <+> ppTerm q 0 typ)
+ | otherwise = parens (id <+> ':' <+> ppTerm q 0 typ)
ppDDecl q (_,id,typ)
| id == identW = ppTerm q 6 typ
- | otherwise = parens (ppIdent id <+> colon <+> ppTerm q 0 typ)
+ | otherwise = parens (id <+> ':' <+> ppTerm q 0 typ)
+ppQIdent :: TermPrintQual -> QIdent -> Doc
ppQIdent q (m,id) =
case q of
- Unqualified -> ppIdent id
- Qualified -> ppIdent m <> char '.' <> ppIdent id
- Internal -> ppIdent m <> char '.' <> ppIdent id
+ Unqualified -> pp id
+ Qualified -> m <> '.' <> id
+ Internal -> m <> '.' <> id
-ppLabel = ppIdent . label2ident
+instance Pretty Label where pp = pp . label2ident
-ppOpenSpec (OSimple id) = ppIdent id
-ppOpenSpec (OQualif id n) = parens (ppIdent id <+> equals <+> ppIdent n)
+ppOpenSpec (OSimple id) = pp id
+ppOpenSpec (OQualif id n) = parens (id <+> '=' <+> n)
-ppInstSpec (id,n) = parens (ppIdent id <+> equals <+> ppIdent n)
+ppInstSpec (id,n) = parens (id <+> '=' <+> n)
ppLocDef q (id, (mbt, e)) =
- ppIdent id <+>
- (case mbt of {Just t -> colon <+> ppTerm q 0 t; Nothing -> empty} <+> equals <+> ppTerm q 0 e) <+> semi
-
-ppBind (Explicit,v) = ppIdent v
-ppBind (Implicit,v) = braces (ppIdent v)
+ id <+>
+ (case mbt of {Just t -> ':' <+> ppTerm q 0 t; Nothing -> empty} <+> '=' <+> ppTerm q 0 e) <+> ';'
-ppAltern q (x,y) = ppTerm q 0 x <+> char '/' <+> ppTerm q 0 y
+ppBind (Explicit,v) = pp v
+ppBind (Implicit,v) = braces v
-ppParams q ps = fsep (intersperse (char '|') (map (ppParam q) ps))
-ppParam q (id,cxt) = ppIdent id <+> hsep (map (ppDDecl q) cxt)
+ppAltern q (x,y) = ppTerm q 0 x <+> '/' <+> ppTerm q 0 y
-ppLocation :: FilePath -> Location -> Doc
-ppLocation fpath NoLoc = text fpath
-ppLocation fpath (External p l) = ppLocation p l
-ppLocation fpath (Local b e)
- | b == e = text fpath <> colon <> int b
- | otherwise = text fpath <> colon <> int b <> text "-" <> int e
+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 <+> text "->" <+> ppFunId funid <>
- brackets (hcat (punctuate comma (map (hsep . intersperse (char '|') . map ppFId) args)))
+ ppFId fid <+> "->" <+> ppFunId funid <>
+ brackets (hcat (punctuate "," (map (hsep . intersperse (pp '|') . map ppFId) args)))
ppSequences q seqsArr
| null seqs || q /= Internal = empty
- | otherwise = text "sequences" <+> char '{' $$
+ | otherwise = "sequences" <+> '{' $$
nest 2 (vcat (map ppSeq seqs)) $$
- char '}'
+ '}'
where
seqs = Array.assocs seqsArr
-commaPunct f ds = (hcat (punctuate comma (map f ds)))
+commaPunct f ds = (hcat (punctuate "," (map f ds)))
prec d1 d2 doc
| d1 > d2 = parens doc
diff --git a/src/compiler/GF/Grammar/ShowTerm.hs b/src/compiler/GF/Grammar/ShowTerm.hs
index 8f64fbc5a..d97ad9fe3 100644
--- a/src/compiler/GF/Grammar/ShowTerm.hs
+++ b/src/compiler/GF/Grammar/ShowTerm.hs
@@ -5,7 +5,7 @@ import GF.Grammar.Printer
import GF.Grammar.Lookup
import GF.Data.Operations
-import Text.PrettyPrint
+import GF.Text.Pretty
import Data.List (intersperse)
showTerm :: SourceGrammar -> TermPrintStyle -> TermPrintQual -> Term -> String
@@ -13,7 +13,7 @@ showTerm gr sty q t = case sty of
TermPrintTable -> render $ vcat [p <+> s | (p,s) <- ppTermTabular gr q t]
TermPrintAll -> render $ vcat [ s | (p,s) <- ppTermTabular gr q t]
TermPrintList -> renderStyle (style{mode = OneLineMode}) $
- vcat (punctuate comma [s | (p,s) <- ppTermTabular gr q t])
+ vcat (punctuate ',' [s | (p,s) <- ppTermTabular gr q t])
TermPrintOne -> render $ vcat [ s | (p,s) <- take 1 (ppTermTabular gr q t)]
TermPrintDefault -> render $ ppTerm q 0 t
@@ -21,19 +21,19 @@ ppTermTabular :: SourceGrammar -> TermPrintQual -> Term -> [(Doc,Doc)]
ppTermTabular gr q = pr where
pr t = case t of
R rs ->
- [(ppLabel lab <+> char '.' <+> path, str) | (lab,(_,val)) <- rs, (path,str) <- pr val]
+ [(lab <+> '.' <+> path, str) | (lab,(_,val)) <- rs, (path,str) <- pr val]
T _ cs ->
- [(ppPatt q 0 patt <+> text "=>" <+> path, str) | (patt, val ) <- cs, (path,str) <- pr val]
+ [(ppPatt q 0 patt <+> "=>" <+> path, str) | (patt, val ) <- cs, (path,str) <- pr val]
V ty cs ->
let pvals = case allParamValues gr ty of
Ok pvals -> pvals
Bad _ -> map Meta [1..]
- in [(ppTerm q 0 pval <+> text "=>" <+> path, str) | (pval, val) <- zip pvals cs, (path,str) <- pr val]
+ in [(ppTerm q 0 pval <+> "=>" <+> path, str) | (pval, val) <- zip pvals cs, (path,str) <- pr val]
_ -> [(empty,ps t)]
ps t = case t of
- K s -> text s
+ K s -> pp s
C s u -> ps s <+> ps u
- FV ts -> hsep (intersperse (char '/') (map ps ts))
+ FV ts -> hsep (intersperse (pp '/') (map ps ts))
_ -> ppTerm q 0 t
data TermPrintStyle
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-30 14:37:51 +0000