diff --git a/src/compiler/GF/Command/Interpreter.hs b/src/compiler/GF/Command/Interpreter.hs index 001c18554..3b0f77ace 100644 --- a/src/compiler/GF/Command/Interpreter.hs +++ b/src/compiler/GF/Command/Interpreter.hs @@ -16,7 +16,7 @@ import PGF.Internal --import PGF.Morphology import GF.Infra.SIO -import Text.PrettyPrint +import GF.Text.Pretty import Control.Monad(when) --import Control.Monad.Error() import qualified Data.Map as Map diff --git a/src/compiler/GF/Compile/Compute/Abstract.hs b/src/compiler/GF/Compile/Compute/Abstract.hs index ef7974314..c374a80b4 100644 --- a/src/compiler/GF/Compile/Compute/Abstract.hs +++ b/src/compiler/GF/Compile/Compute/Abstract.hs @@ -29,7 +29,7 @@ import GF.Grammar.Lookup import Debug.Trace import Data.List(intersperse) import Control.Monad (liftM, liftM2) -import Text.PrettyPrint +import GF.Text.Pretty -- for debugging tracd m t = t diff --git a/src/compiler/GF/Compile/Compute/AppPredefined.hs b/src/compiler/GF/Compile/Compute/AppPredefined.hs index 2a1998283..0869cedee 100644 --- a/src/compiler/GF/Compile/Compute/AppPredefined.hs +++ b/src/compiler/GF/Compile/Compute/AppPredefined.hs @@ -23,7 +23,7 @@ import GF.Grammar import GF.Grammar.Predef import qualified Data.Map as Map -import Text.PrettyPrint +import GF.Text.Pretty import Data.Char (isUpper,toUpper,toLower) -- predefined function type signatures and definitions. AR 12/3/2003. @@ -140,4 +140,4 @@ mapStr ty f t = case (ty,t) of mapField (mty,te) = case mty of Just ty -> (mty,mapStr ty f te) _ -> (mty,te) --} \ No newline at end of file +-} diff --git a/src/compiler/GF/Compile/Compute/ConcreteLazy.hs b/src/compiler/GF/Compile/Compute/ConcreteLazy.hs index abfa93578..929e30ce1 100644 --- a/src/compiler/GF/Compile/Compute/ConcreteLazy.hs +++ b/src/compiler/GF/Compile/Compute/ConcreteLazy.hs @@ -33,7 +33,7 @@ import GF.Compile.Compute.AppPredefined import Data.List (nub) --intersperse --import Control.Monad (liftM2, liftM) import Control.Monad.Identity -import Text.PrettyPrint +import GF.Text.Pretty ----import Debug.Trace diff --git a/src/compiler/GF/Compile/Compute/ConcreteNew1.hs b/src/compiler/GF/Compile/Compute/ConcreteNew1.hs index 354f8249e..eba1db57b 100644 --- a/src/compiler/GF/Compile/Compute/ConcreteNew1.hs +++ b/src/compiler/GF/Compile/Compute/ConcreteNew1.hs @@ -8,7 +8,7 @@ import GF.Grammar.Lookup import GF.Grammar.Predef import GF.Data.Operations import Data.List (intersect) -import Text.PrettyPrint +import GF.Text.Pretty normalForm :: SourceGrammar -> Term -> Term normalForm gr t = value2term gr [] (eval gr [] t) @@ -65,7 +65,7 @@ eval gr env (ImplArg t) = VImplArg (eval gr env t) eval gr env (Table p res) = VTblType (eval gr env p) (eval gr env res) eval gr env (RecType rs) = VRecType [(l,eval gr env ty) | (l,ty) <- rs] eval gr env t@(ExtR t1 t2) = - let error = VError (show (text "The term" <+> ppTerm Unqualified 0 t <+> text "is not reducible")) + let error = VError (show ("The term" <+> ppTerm Unqualified 0 t <+> "is not reducible")) in case (eval gr env t1, eval gr env t2) of (VRecType rs1, VRecType rs2) -> case intersect (map fst rs1) (map fst rs2) of [] -> VRecType (rs1 ++ rs2) diff --git a/src/compiler/GF/Compile/Compute/ConcreteStrict.hs b/src/compiler/GF/Compile/Compute/ConcreteStrict.hs index 3f417bae2..df343adec 100644 --- a/src/compiler/GF/Compile/Compute/ConcreteStrict.hs +++ b/src/compiler/GF/Compile/Compute/ConcreteStrict.hs @@ -33,7 +33,7 @@ import GF.Compile.Compute.AppPredefined import Data.List (nub,intersperse) import Control.Monad (liftM2, liftM) -import Text.PrettyPrint +import GF.Text.Pretty ----import Debug.Trace diff --git a/src/compiler/GF/Compile/Compute/Predef.hs b/src/compiler/GF/Compile/Compute/Predef.hs index 8c5e5c5f7..b9bb01ce8 100644 --- a/src/compiler/GF/Compile/Compute/Predef.hs +++ b/src/compiler/GF/Compile/Compute/Predef.hs @@ -2,7 +2,7 @@ {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} module GF.Compile.Compute.Predef(predef,predefName,delta) where -import Text.PrettyPrint(render,hang,text) +import GF.Text.Pretty(render,hang) import qualified Data.Map as Map import Data.Array(array,(!)) import Data.List (isInfixOf) @@ -154,6 +154,6 @@ string s = case words s of swap (x,y) = (y,x) -bug msg = ppbug (text msg) +bug msg = ppbug msg ppbug doc = error $ render $ - hang (text "Internal error in Compute.Predef:") 4 doc + hang "Internal error in Compute.Predef:" 4 doc diff --git a/src/compiler/GF/Compile/Export.hs b/src/compiler/GF/Compile/Export.hs index ff7d5790a..432d98db9 100644 --- a/src/compiler/GF/Compile/Export.hs +++ b/src/compiler/GF/Compile/Export.hs @@ -21,7 +21,7 @@ import GF.Speech.PrRegExp import Data.Maybe import System.FilePath -import Text.PrettyPrint +import GF.Text.Pretty -- top-level access to code generation diff --git a/src/compiler/GF/Compile/GrammarToPGF.hs b/src/compiler/GF/Compile/GrammarToPGF.hs index b72bbb347..feccea46a 100644 --- a/src/compiler/GF/Compile/GrammarToPGF.hs +++ b/src/compiler/GF/Compile/GrammarToPGF.hs @@ -30,7 +30,7 @@ import qualified Data.Set as Set import qualified Data.Map as Map import qualified Data.IntMap as IntMap import Data.Array.IArray ---import Text.PrettyPrint +--import GF.Text.Pretty --import Control.Monad.Identity mkCanon2pgf :: Options -> SourceGrammar -> Ident -> IOE D.PGF diff --git a/src/compiler/GF/Compile/PGFtoLProlog.hs b/src/compiler/GF/Compile/PGFtoLProlog.hs index b0825b26c..9f990d4f9 100644 --- a/src/compiler/GF/Compile/PGFtoLProlog.hs +++ b/src/compiler/GF/Compile/PGFtoLProlog.hs @@ -5,46 +5,46 @@ import PGF.Internal hiding (ppExpr,ppType,ppHypo,ppCat,ppFun) --import PGF.Macros import Data.List import Data.Maybe -import Text.PrettyPrint +import GF.Text.Pretty import qualified Data.Map as Map --import Debug.Trace grammar2lambdaprolog_mod pgf = render $ - text "module" <+> ppCId (absname pgf) <> char '.' $$ - space $$ + "module" <+> ppCId (absname pgf) <> '.' $$ + ' ' $$ vcat [ppClauses cat fns | (cat,(_,fs,_,_)) <- Map.toList (cats (abstract pgf)), let fns = [(f,fromJust (Map.lookup f (funs (abstract pgf)))) | (_,f) <- fs]] where ppClauses cat fns = - text "/*" <+> ppCId cat <+> text "*/" $$ + "/*" <+> ppCId cat <+> "*/" $$ vcat [snd (ppClause (abstract pgf) 0 1 [] f ty) <> dot | (f,(ty,_,Nothing,_,_)) <- fns] $$ - space $$ + ' ' $$ vcat [vcat (map (\eq -> equation2clause (abstract pgf) f eq <> dot) eqs) | (f,(_,_,Just eqs,_,_)) <- fns] $$ - space + ' ' grammar2lambdaprolog_sig pgf = render $ - text "sig" <+> ppCId (absname pgf) <> char '.' $$ - space $$ + "sig" <+> ppCId (absname pgf) <> '.' $$ + ' ' $$ vcat [ppCat c hyps <> dot | (c,(hyps,_,_,_)) <- Map.toList (cats (abstract pgf))] $$ - space $$ + ' ' $$ vcat [ppFun f ty <> dot | (f,(ty,_,Nothing,_,_)) <- Map.toList (funs (abstract pgf))] $$ - space $$ + ' ' $$ vcat [ppExport c hyps <> dot | (c,(hyps,_,_,_)) <- Map.toList (cats (abstract pgf))] $$ vcat [ppFunPred f (hyps ++ [(Explicit,wildCId,DTyp [] c es)]) <> dot | (f,(DTyp hyps c es,_,Just _,_,_)) <- Map.toList (funs (abstract pgf))] ppCat :: CId -> [Hypo] -> Doc -ppCat c hyps = text "kind" <+> ppKind c <+> text "type" +ppCat c hyps = "kind" <+> ppKind c <+> "type" ppFun :: CId -> Type -> Doc -ppFun f ty = text "type" <+> ppCId f <+> ppType 0 ty +ppFun f ty = "type" <+> ppCId f <+> ppType 0 ty ppExport :: CId -> [Hypo] -> Doc -ppExport c hyps = text "exportdef" <+> ppPred c <+> foldr (\hyp doc -> ppHypo 1 hyp <+> text "->" <+> doc) (text "o") (hyp:hyps) +ppExport c hyps = "exportdef" <+> ppPred c <+> foldr (\hyp doc -> ppHypo 1 hyp <+> "->" <+> doc) (pp "o") (hyp:hyps) where hyp = (Explicit,wildCId,DTyp [] c []) ppFunPred :: CId -> [Hypo] -> Doc -ppFunPred c hyps = text "exportdef" <+> ppCId c <+> foldr (\hyp doc -> ppHypo 1 hyp <+> text "->" <+> doc) (text "o") hyps +ppFunPred c hyps = "exportdef" <+> ppCId c <+> foldr (\hyp doc -> ppHypo 1 hyp <+> "->" <+> doc) (pp "o") hyps ppClause :: Abstr -> Int -> Int -> [CId] -> CId -> Type -> (Int,Doc) ppClause abstr d i scope f ty@(DTyp hyps cat args) @@ -52,20 +52,20 @@ ppClause abstr d i scope f ty@(DTyp hyps cat args) (goals,i',head) = ppRes i scope cat (res : args) in (i',(if null goals then empty - else hsep (punctuate comma (map (ppExpr 0 i' scope) goals)) <> comma) + else hsep (punctuate ',' (map (ppExpr 0 i' scope) goals)) <> ',') <+> head) | otherwise = let (i',vars,scope',hdocs) = ppHypos i [] scope hyps (depType [] ty) res = foldl EApp (EFun f) (map EFun (reverse vars)) quants = if d > 0 - then hsep (map (\v -> text "pi" <+> ppCId v <+> char '\\') vars) + then hsep (map (\v -> "pi" <+> ppCId v <+> '\\') vars) else empty (goals,i'',head) = ppRes i' scope' cat (res : args) docs = map (ppExpr 0 i'' scope') goals ++ hdocs in (i'',ppParens (d > 0) (quants <+> head <+> (if null docs then empty - else text ":-" <+> hsep (punctuate comma docs)))) + else ":-" <+> hsep (punctuate ',' docs)))) where ppRes i scope cat es = let ((goals,i'),es') = mapAccumL (\(goals,i) e -> let (goals',i',e') = expr2goal abstr scope goals i e [] @@ -89,20 +89,20 @@ ppClause abstr d i scope f ty@(DTyp hyps cat args) mkVar i = mkCId ("X_"++show i) ppPred :: CId -> Doc -ppPred cat = text "p_" <> ppCId cat +ppPred cat = "p_" <> ppCId cat ppKind :: CId -> Doc -ppKind cat = text "k_" <> ppCId cat +ppKind cat = "k_" <> ppCId cat ppType :: Int -> Type -> Doc ppType d (DTyp hyps cat args) | null hyps = ppKind cat - | otherwise = ppParens (d > 0) (foldr (\hyp doc -> ppHypo 1 hyp <+> text "->" <+> doc) (ppKind cat) hyps) + | otherwise = ppParens (d > 0) (foldr (\hyp doc -> ppHypo 1 hyp <+> "->" <+> doc) (ppKind cat) hyps) ppHypo d (_,_,typ) = ppType d typ ppExpr d i scope (EAbs b x e) = let v = mkVar i - in ppParens (d > 1) (ppCId v <+> char '\\' <+> ppExpr 1 (i+1) (v:scope) e) + in ppParens (d > 1) (ppCId v <+> '\\' <+> ppExpr 1 (i+1) (v:scope) e) ppExpr d i scope (EApp e1 e2) = ppParens (d > 3) ((ppExpr 3 i scope e1) <+> (ppExpr 4 i scope e2)) ppExpr d i scope (ELit l) = ppLit l ppExpr d i scope (EMeta n) = ppMeta n @@ -111,7 +111,7 @@ ppExpr d i scope (EVar j) = ppCId (scope !! j) ppExpr d i scope (ETyped e ty)= ppExpr d i scope e ppExpr d i scope (EImplArg e) = ppExpr 0 i scope e -dot = char '.' +dot = '.' depType counts (DTyp hyps cat es) = foldl' depExpr (foldl' depHypo counts hyps) es @@ -142,7 +142,7 @@ equation2clause abstr f (Equ ps e) = in ppCId f <+> hsep (map (ppExpr 4 n scope) (es++[goal])) <+> if null goals then empty - else text ":-" <+> hsep (punctuate comma (map (ppExpr 0 n scope) (reverse goals))) + else ":-" <+> hsep (punctuate ',' (map (ppExpr 0 n scope) (reverse goals))) patt2expr scope (PApp f ps) = foldl EApp (EFun f) (map (patt2expr scope) ps) diff --git a/src/compiler/GF/Compile/ReadFiles.hs b/src/compiler/GF/Compile/ReadFiles.hs index 02bc4452d..9bc36f0b5 100644 --- a/src/compiler/GF/Compile/ReadFiles.hs +++ b/src/compiler/GF/Compile/ReadFiles.hs @@ -46,7 +46,7 @@ import qualified Data.Map as Map import Data.Time(UTCTime) import GF.System.Directory import System.FilePath -import Text.PrettyPrint +import GF.Text.Pretty type ModName = String type ModEnv = Map.Map ModName (UTCTime,[ModName]) @@ -105,8 +105,8 @@ getAllFiles opts ps env file = do case mb_gfoFile of Just gfoFile -> do gfoTime <- modtime gfoFile return (gfoFile, Nothing, Just gfoTime) - Nothing -> raise (render (text "File" <+> text (gfFile name) <+> text "does not exist." $$ - text "searched in:" <+> vcat (map text ps))) + Nothing -> raise (render ("File" <+> gfFile name <+> "does not exist." $$ + "searched in:" <+> vcat ps)) let mb_envmod = Map.lookup name env diff --git a/src/compiler/GF/Compile/Tags.hs b/src/compiler/GF/Compile/Tags.hs index 10be24f16..dab4ee343 100644 --- a/src/compiler/GF/Compile/Tags.hs +++ b/src/compiler/GF/Compile/Tags.hs @@ -12,7 +12,7 @@ import GF.Grammar import qualified Data.Map as Map import qualified Data.Set as Set --import Control.Monad -import Text.PrettyPrint +import GF.Text.Pretty import System.FilePath writeTags opts gr file mo = do diff --git a/src/compiler/GF/Compile/TypeCheck/Abstract.hs b/src/compiler/GF/Compile/TypeCheck/Abstract.hs index 1fa4c01c6..aa52b5724 100644 --- a/src/compiler/GF/Compile/TypeCheck/Abstract.hs +++ b/src/compiler/GF/Compile/TypeCheck/Abstract.hs @@ -29,7 +29,7 @@ import GF.Grammar.Unify --import GF.Compile.Compute.Abstract import GF.Compile.TypeCheck.TC -import Text.PrettyPrint +import GF.Text.Pretty --import Control.Monad (foldM, liftM, liftM2) -- | invariant way of creating TCEnv from context @@ -70,10 +70,10 @@ checkContext :: SourceGrammar -> Context -> [Message] checkContext st = checkTyp st . cont2exp checkTyp :: SourceGrammar -> Type -> [Message] -checkTyp gr typ = err (\x -> [text x]) ppConstrs $ justTypeCheck gr typ vType +checkTyp gr typ = err (\x -> [pp x]) ppConstrs $ justTypeCheck gr typ vType checkDef :: SourceGrammar -> Fun -> Type -> Equation -> [Message] -checkDef gr (m,fun) typ eq = err (\x -> [text x]) ppConstrs $ do +checkDef gr (m,fun) typ eq = err (\x -> [pp x]) ppConstrs $ do (b,cs) <- checkBranch (grammar2theory gr) (initTCEnv []) eq (type2val typ) (constrs,_) <- unifyVal cs return $ filter notJustMeta constrs diff --git a/src/compiler/GF/Compile/TypeCheck/Concrete.hs b/src/compiler/GF/Compile/TypeCheck/Concrete.hs index 7b24ab65a..89aaeb1fb 100644 --- a/src/compiler/GF/Compile/TypeCheck/Concrete.hs +++ b/src/compiler/GF/Compile/TypeCheck/Concrete.hs @@ -13,7 +13,7 @@ import GF.Compile.TypeCheck.Primitives import Data.List import Control.Monad -import Text.PrettyPrint +import GF.Text.Pretty computeLType :: SourceGrammar -> Context -> Type -> Check Type computeLType gr g0 t = comp (reverse [(b,x, Vr x) | (b,x,_) <- g0] ++ g0) t @@ -714,4 +714,4 @@ checkLookup x g = case [ty | (b,y,ty) <- g, x == y] of [] -> checkError (text "unknown variable" <+> ppIdent x) (ty:_) -> return ty --} \ No newline at end of file +-} diff --git a/src/compiler/GF/CompilerAPI.hs b/src/compiler/GF/CompilerAPI.hs index 60ce74ce0..c65b566c3 100644 --- a/src/compiler/GF/CompilerAPI.hs +++ b/src/compiler/GF/CompilerAPI.hs @@ -41,7 +41,7 @@ import Data.List(nub) import Data.Maybe (isNothing) import Data.Binary import qualified Data.ByteString.Char8 as BS -import Text.PrettyPrint +import GF.Text.Pretty import PGF.CId import PGF.Data diff --git a/src/compiler/GF/Grammar/MMacros.hs b/src/compiler/GF/Grammar/MMacros.hs index 1b9060003..9f4587967 100644 --- a/src/compiler/GF/Grammar/MMacros.hs +++ b/src/compiler/GF/Grammar/MMacros.hs @@ -26,7 +26,7 @@ import GF.Grammar.Values import GF.Grammar.Macros import Control.Monad -import Text.PrettyPrint +import GF.Text.Pretty {- nodeTree :: Tree -> TrNode @@ -178,13 +178,13 @@ val2expP :: Bool -> Val -> Err Exp val2expP safe v = case v of VClos g@(_:_) e@(Meta _) -> if safe - then Bad (render (text "unsafe value substitution" <+> ppValue Unqualified 0 v)) + then Bad (render ("unsafe value substitution" <+> ppValue Unqualified 0 v)) else substVal g e VClos g e -> substVal g e VApp f c -> liftM2 App (val2expP safe f) (val2expP safe c) VCn c -> return $ Q c VGen i x -> if safe - then Bad (render (text "unsafe val2exp" <+> ppValue Unqualified 0 v)) + then Bad (render ("unsafe val2exp" <+> ppValue Unqualified 0 v)) else return $ Vr $ x --- in editing, no alpha conversions presentv VRecType xs->do xs <- mapM (\(l,v) -> val2expP safe v >>= \e -> return (l,e)) xs return (RecType xs) diff --git a/src/compiler/GF/Grammar/Unify.hs b/src/compiler/GF/Grammar/Unify.hs index d08de96c7..9ec6e5078 100644 --- a/src/compiler/GF/Grammar/Unify.hs +++ b/src/compiler/GF/Grammar/Unify.hs @@ -20,7 +20,7 @@ module GF.Grammar.Unify (unifyVal) where import GF.Grammar import GF.Data.Operations -import Text.PrettyPrint +import GF.Text.Pretty import Data.List (partition) unifyVal :: Constraints -> Err (Constraints,MetaSubst) @@ -64,13 +64,13 @@ unify e1 e2 g = unify b c' g (App c a, App d b) -> case unify c d g of Ok g1 -> unify a b g1 - _ -> Bad (render (text "fail unify" <+> ppTerm Unqualified 0 e1)) + _ -> Bad (render ("fail unify" <+> ppTerm Unqualified 0 e1)) (RecType xs,RecType ys) | xs == ys -> return g - _ -> Bad (render (text "fail unify" <+> ppTerm Unqualified 0 e1)) + _ -> Bad (render ("fail unify" <+> ppTerm Unqualified 0 e1)) extend :: Unifier -> MetaId -> Term -> Err Unifier extend g s t | (t == Meta s) = return g - | occCheck s t = Bad (render (text "occurs check" <+> ppTerm Unqualified 0 t)) + | occCheck s t = Bad (render ("occurs check" <+> ppTerm Unqualified 0 t)) | True = return ((s, t) : g) subst_all :: Unifier -> Term -> Err Term diff --git a/src/compiler/GF/Speech/GSL.hs b/src/compiler/GF/Speech/GSL.hs index 3eb4c20a7..ca49afb61 100644 --- a/src/compiler/GF/Speech/GSL.hs +++ b/src/compiler/GF/Speech/GSL.hs @@ -18,7 +18,7 @@ import PGF import Data.Char (toUpper,toLower) import Data.List (partition) -import Text.PrettyPrint.HughesPJ +import GF.Text.Pretty width :: Int width = 75 @@ -30,10 +30,10 @@ gslPrinter opts pgf cnc = renderStyle st $ prGSL $ makeNonLeftRecursiveSRG opts prGSL :: SRG -> Doc prGSL srg = header $++$ mainCat $++$ foldr ($++$) empty (map prRule (srgRules srg)) where - header = text ";GSL2.0" $$ + header = ";GSL2.0" $$ comment ("Nuance speech recognition grammar for " ++ srgName srg) $$ comment ("Generated by GF") - mainCat = text ".MAIN" <+> prCat (srgStartCat srg) + mainCat = ".MAIN" <+> prCat (srgStartCat srg) prRule (SRGRule cat rhs) = prCat cat <+> union (map prAlt rhs) -- FIXME: use the probability prAlt (SRGAlt mp _ rhs) = prItem rhs @@ -42,23 +42,23 @@ prGSL srg = header $++$ mainCat $++$ foldr ($++$) empty (map prRule (srgRules sr prItem :: SRGItem -> Doc prItem = f where - f (REUnion xs) = (if null es then empty else text "?") <> union (map f nes) + f (REUnion xs) = (if null es then empty else pp "?") <> union (map f nes) where (es,nes) = partition isEpsilon xs f (REConcat [x]) = f x - f (REConcat xs) = text "(" <> fsep (map f xs) <> text ")" - f (RERepeat x) = text "*" <> f x + f (REConcat xs) = "(" <> fsep (map f xs) <> ")" + f (RERepeat x) = "*" <> f x f (RESymbol s) = prSymbol s union :: [Doc] -> Doc union [x] = x -union xs = text "[" <> fsep xs <> text "]" +union xs = "[" <> fsep xs <> "]" prSymbol :: Symbol SRGNT Token -> Doc prSymbol = symbol (prCat . fst) (doubleQuotes . showToken) -- GSL requires an upper case letter in category names prCat :: Cat -> Doc -prCat = text . firstToUpper +prCat = pp . firstToUpper firstToUpper :: String -> String @@ -76,19 +76,19 @@ keepSymbol _ = True -- Nuance does not like upper case characters in tokens showToken :: Token -> Doc -showToken = text . map toLower +showToken = pp . map toLower isPunct :: Char -> Bool isPunct c = c `elem` "-_.:;.,?!()[]{}" comment :: String -> Doc -comment s = text ";" <+> text s +comment s = ";" <+> s -- Pretty-printing utilities emptyLine :: Doc -emptyLine = text "" +emptyLine = pp "" ($++$) :: Doc -> Doc -> Doc x $++$ y = x $$ emptyLine $$ y diff --git a/src/compiler/GF/Speech/JSGF.hs b/src/compiler/GF/Speech/JSGF.hs index 2f4b4d96d..25168dbc8 100644 --- a/src/compiler/GF/Speech/JSGF.hs +++ b/src/compiler/GF/Speech/JSGF.hs @@ -23,7 +23,7 @@ import PGF import Data.Char import Data.List --import Data.Maybe -import Text.PrettyPrint.HughesPJ +import GF.Text.Pretty --import Debug.Trace width :: Int @@ -40,46 +40,46 @@ prJSGF :: Maybe SISRFormat -> SRG -> Doc prJSGF sisr srg = header $++$ mainCat $++$ foldr ($++$) empty (map prRule (srgRules srg)) where - header = text "#JSGF" <+> text "V1.0" <+> text "UTF-8" <+> lang <> char ';' $$ + header = "#JSGF" <+> "V1.0" <+> "UTF-8" <+> lang <> ';' $$ comment ("JSGF speech recognition grammar for " ++ srgName srg) $$ comment "Generated by GF" $$ - text ("grammar " ++ srgName srg ++ ";") - lang = maybe empty text (srgLanguage srg) + ("grammar " ++ srgName srg ++ ";") + lang = maybe empty pp (srgLanguage srg) mainCat = rule True "MAIN" [prCat (srgStartCat srg)] prRule (SRGRule cat rhs) = rule (isExternalCat srg cat) cat (map prAlt rhs) prAlt (SRGAlt mp n rhs) = sep [initTag, p (prItem sisr n rhs), finalTag] where initTag | isEmpty t = empty - | otherwise = text "" <+> t + | otherwise = "" <+> t where t = tag sisr (profileInitSISR n) finalTag = tag sisr (profileFinalSISR n) p = if isEmpty initTag && isEmpty finalTag then id else parens prCat :: Cat -> Doc -prCat c = char '<' <> text c <> char '>' +prCat c = '<' <> c <> '>' prItem :: Maybe SISRFormat -> CFTerm -> SRGItem -> Doc prItem sisr t = f 0 where - f _ (REUnion []) = text "" + f _ (REUnion []) = pp "" f p (REUnion xs) | not (null es) = brackets (f 0 (REUnion nes)) | otherwise = (if p >= 1 then parens else id) (alts (map (f 1) xs)) where (es,nes) = partition isEpsilon xs - f _ (REConcat []) = text "" + f _ (REConcat []) = pp "" f p (REConcat xs) = (if p >= 3 then parens else id) (fsep (map (f 2) xs)) - f p (RERepeat x) = f 3 x <> char '*' + f p (RERepeat x) = f 3 x <> '*' f _ (RESymbol s) = prSymbol sisr t s prSymbol :: Maybe SISRFormat -> CFTerm -> SRGSymbol -> Doc prSymbol sisr cn (NonTerminal n@(c,_)) = prCat c <+> tag sisr (catSISR cn n) prSymbol _ cn (Terminal t) | all isPunct t = empty -- removes punctuation - | otherwise = text t -- FIXME: quote if there is whitespace or odd chars + | otherwise = pp t -- FIXME: quote if there is whitespace or odd chars tag :: Maybe SISRFormat -> (SISRFormat -> SISRTag) -> Doc tag Nothing _ = empty tag (Just fmt) t = case t fmt of [] -> empty - ts -> char '{' <+> (text (e $ prSISR ts)) <+> char '}' + ts -> '{' <+> (e $ prSISR ts) <+> '}' where e [] = [] e ('}':xs) = '\\':'}':e xs e ('\n':xs) = ' ' : e (dropWhile isSpace xs) @@ -89,21 +89,21 @@ isPunct :: Char -> Bool isPunct c = c `elem` "-_.;.,?!" comment :: String -> Doc -comment s = text "//" <+> text s +comment s = "//" <+> s alts :: [Doc] -> Doc -alts = fsep . prepunctuate (text "| ") +alts = fsep . prepunctuate ("| ") rule :: Bool -> Cat -> [Doc] -> Doc -rule pub c xs = p <+> prCat c <+> char '=' <+> nest 2 (alts xs) <+> char ';' - where p = if pub then text "public" else empty +rule pub c xs = p <+> prCat c <+> '=' <+> nest 2 (alts xs) <+> ';' + where p = if pub then pp "public" else empty -- Pretty-printing utilities emptyLine :: Doc -emptyLine = text "" +emptyLine = pp "" -prepunctuate :: Doc -> [Doc] -> [Doc] +--prepunctuate :: Doc -> [Doc] -> [Doc] prepunctuate _ [] = [] prepunctuate p (x:xs) = x : map (p <>) xs diff --git a/src/compiler/GF/Speech/SRGS_ABNF.hs b/src/compiler/GF/Speech/SRGS_ABNF.hs index a359b2c38..f5e163951 100644 --- a/src/compiler/GF/Speech/SRGS_ABNF.hs +++ b/src/compiler/GF/Speech/SRGS_ABNF.hs @@ -30,7 +30,7 @@ import PGF (PGF, CId) --import Data.Char import Data.List import Data.Maybe -import Text.PrettyPrint.HughesPJ +import GF.Text.Pretty --import Debug.Trace width :: Int @@ -50,14 +50,14 @@ prABNF :: Maybe SISRFormat -> SRG -> Doc prABNF sisr srg = header $++$ foldr ($++$) empty (map prRule (srgRules srg)) where - header = text "#ABNF 1.0 UTF-8;" $$ + header = "#ABNF 1.0 UTF-8;" $$ meta "description" ("Speech recognition grammar for " ++ srgName srg) $$ meta "generator" "Grammatical Framework" $$ language $$ tagFormat $$ mainCat - language = maybe empty (\l -> text "language" <+> text l <> char ';') (srgLanguage srg) - tagFormat | isJust sisr = text "tag-format" <+> text "" <> char ';' + language = maybe empty (\l -> "language" <+> l <> ';') (srgLanguage srg) + tagFormat | isJust sisr = "tag-format" <+> "" <> ';' | otherwise = empty - mainCat = text "root" <+> prCat (srgStartCat srg) <> char ';' + mainCat = "root" <+> prCat (srgStartCat srg) <> ';' prRule (SRGRule cat alts) = rule (isExternalCat srg cat) cat (map prAlt alts) prAlt (SRGAlt mp n rhs) = sep [initTag, p (prItem sisr n rhs), finalTag] where initTag = tag sisr (profileInitSISR n) @@ -65,19 +65,19 @@ prABNF sisr srg p = if isEmpty initTag && isEmpty finalTag then id else parens prCat :: Cat -> Doc -prCat c = char '$' <> text c +prCat c = '$' <> c prItem :: Maybe SISRFormat -> CFTerm -> SRGItem -> Doc prItem sisr t = f 0 where - f _ (REUnion []) = text "$VOID" + f _ (REUnion []) = pp "$VOID" f p (REUnion xs) | not (null es) = brackets (f 0 (REUnion nes)) | otherwise = (if p >= 1 then parens else id) (alts (map (f 1) xs)) where (es,nes) = partition isEpsilon xs - f _ (REConcat []) = text "$NULL" + f _ (REConcat []) = pp "$NULL" f p (REConcat xs) = (if p >= 3 then parens else id) (fsep (map (f 2) xs)) - f p (RERepeat x) = f 3 x <> text "<0->" + f p (RERepeat x) = f 3 x <> "<0->" f _ (RESymbol s) = prSymbol sisr t s @@ -85,7 +85,7 @@ prSymbol :: Maybe SISRFormat -> CFTerm -> SRGSymbol -> Doc prSymbol sisr cn (NonTerminal n@(c,_)) = prCat c <+> tag sisr (catSISR cn n) prSymbol _ cn (Terminal t) | all isPunct t = empty -- removes punctuation - | otherwise = text t -- FIXME: quote if there is whitespace or odd chars + | otherwise = pp t -- FIXME: quote if there is whitespace or odd chars tag :: Maybe SISRFormat -> (SISRFormat -> SISRTag) -> Doc tag Nothing _ = empty @@ -93,32 +93,32 @@ tag (Just fmt) t = case t fmt of [] -> empty -- grr, silly SRGS ABNF does not have an escaping mechanism - ts | '{' `elem` x || '}' `elem` x -> text "{!{" <+> text x <+> text "}!}" - | otherwise -> text "{" <+> text x <+> text "}" + ts | '{' `elem` x || '}' `elem` x -> "{!{" <+> x <+> "}!}" + | otherwise -> "{" <+> x <+> "}" where x = prSISR ts isPunct :: Char -> Bool isPunct c = c `elem` "-_.;.,?!" comment :: String -> Doc -comment s = text "//" <+> text s +comment s = "//" <+> s alts :: [Doc] -> Doc -alts = fsep . prepunctuate (text "| ") +alts = fsep . prepunctuate ("| ") rule :: Bool -> Cat -> [Doc] -> Doc -rule pub c xs = p <+> prCat c <+> char '=' <+> nest 2 (alts xs) <+> char ';' - where p = if pub then text "public" else empty +rule pub c xs = p <+> prCat c <+> '=' <+> nest 2 (alts xs) <+> ';' + where p = if pub then pp "public" else empty meta :: String -> String -> Doc -meta n v = text "meta" <+> text (show n) <+> text "is" <+> text (show v) <> char ';' +meta n v = "meta" <+> show n <+> "is" <+> show v <> ';' -- Pretty-printing utilities emptyLine :: Doc -emptyLine = text "" +emptyLine = pp "" -prepunctuate :: Doc -> [Doc] -> [Doc] +--prepunctuate :: Doc -> [Doc] -> [Doc] prepunctuate _ [] = [] prepunctuate p (x:xs) = x : map (p <>) xs