"Committed_by_peb"

2 files changed, 180 insertions, 3 deletions

diff --git a/src/GF/Infra/Option.hs b/src/GF/Infra/Option.hs
index 401e02cab..41ed3c447 100644
--- a/src/GF/Infra/Option.hs
+++ b/src/GF/Infra/Option.hs
@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/03/18 10:17:10 $ 
+-- > CVS $Date: 2005/04/11 13:53:38 $ 
 -- > CVS $Author: peb $
--- > CVS $Revision: 1.23 $
+-- > CVS $Revision: 1.24 $
 --
 -- Options and flags used in GF shell commands and files.
 --
@@ -151,7 +151,7 @@ dontParse    = iOpt "read"
 showAbstr, showXML, showOld, showLatex, showFullForm,
   showEBNF, showCF, showWords, showOpts,
   isCompiled, isHaskell, noCompOpers, retainOpers,
-  newParser, noCF, checkCirc, noCheckCirc, lexerByNeed, useUTF8id :: Option
+  newParser, newerParser, noCF, checkCirc, noCheckCirc, lexerByNeed, useUTF8id :: Option
 defaultGrOpts :: [Option]
 
 showAbstr   = iOpt "abs"
@@ -170,6 +170,7 @@ noCompOpers = iOpt "nocomp"
 retainOpers = iOpt "retain"
 defaultGrOpts = []
 newParser   = iOpt "new"
+newerParser = iOpt "newer"
 noCF        = iOpt "nocf"
 checkCirc   = iOpt "nocirc"
 noCheckCirc = iOpt "nocheckcirc"
diff --git a/src/GF/Infra/Print.hs b/src/GF/Infra/Print.hs
new file mode 100644
index 000000000..8feeae3a0
--- /dev/null
+++ b/src/GF/Infra/Print.hs
@@ -0,0 +1,176 @@
+----------------------------------------------------------------------
+-- |
+-- Maintainer  : PL
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/11 13:52:50 $ 
+-- > CVS $Author: peb $
+-- > CVS $Revision: 1.1 $
+--
+-- Pretty-printing
+-----------------------------------------------------------------------------
+
+module GF.Infra.Print 
+    (Print(..),
+     prtBefore, prtAfter, prtSep, 
+     prtBeforeAfter,
+     prIO
+    ) where
+
+-- haskell modules:
+import List (intersperse)
+import Char (toUpper)
+-- gf modules:
+import Operations (Err(..))
+import Ident (Ident(..))
+import AbsGFC
+import CF
+import CFIdent
+import qualified PrintGFC as P
+
+------------------------------------------------------------
+
+prtBefore :: Print a => String -> [a] -> String
+prtBefore before = prtBeforeAfter before ""
+
+prtAfter :: Print a => String -> [a] -> String
+prtAfter after = prtBeforeAfter "" after
+
+prtSep :: Print a => String -> [a] -> String
+prtSep sep = concat . intersperse sep . map prt
+
+prtBeforeAfter :: Print a => String -> String -> [a] -> String
+prtBeforeAfter before after as = concat [ before ++ prt a ++ after | a <- as ]
+
+prIO :: Print a => a -> IO ()
+prIO = putStr . prt
+
+class Print a where
+    prt :: a -> String
+    prtList :: [a] -> String
+    prtList as = "[" ++ prtSep "," as ++ "]"
+
+instance Print a => Print [a] where
+    prt = prtList
+
+instance (Print a, Print b) => Print (a, b) where
+    prt (a, b) = "(" ++ prt a ++ "," ++ prt b ++ ")"
+
+instance (Print a, Print b, Print c) => Print (a, b, c) where
+    prt (a, b, c) = "(" ++ prt a ++ "," ++ prt b ++ "," ++ prt c ++ ")"
+
+instance (Print a, Print b, Print c, Print d) => Print (a, b, c, d) where
+    prt (a, b, c, d) = "(" ++ prt a ++ "," ++ prt b ++ "," ++ prt c ++ "," ++ prt d ++ ")"
+
+instance Print Char where
+    prt = return
+    prtList = id
+
+instance Print Int where
+    prt = show
+
+instance Print Integer where
+    prt = show
+
+instance Print a => Print (Maybe a) where
+    prt (Just a) = prt a
+    prt Nothing  = "Nothing"
+
+instance Print a => Print (Err a) where
+    prt (Ok a) = prt a
+    prt (Bad str) = str
+
+----------------------------------------------------------------------
+
+instance Print Ident where
+    prt = P.printTree 
+
+instance Print Term where
+    prt (Arg arg)         = prt arg
+    prt (con `Con` [])    = prt con
+    prt (con `Con` terms) = prt con ++ "(" ++ prtSep ", " terms ++ ")"
+    prt (LI ident)        = "$" ++ prt ident
+    prt (R record)        = "{" ++ prtSep "; " record ++ "}"
+    prt (term `P` lbl)    = prt term ++ "." ++ prt lbl
+    prt (T _ table)       = "table{" ++ prtSep "; " table ++ "}"
+    prt (V _ terms)       = "values{" ++ prtSep "; " terms ++ "}"
+    prt (term `S` sel)    = "(" ++ prt term ++ " ! " ++ prt sel ++ ")"
+    prt (FV terms)        = "variants{" ++ prtSep " | " terms ++ "}"
+    prt (term `C` term')  = prt term ++ "  " ++ prt term'
+    prt (EInt n)          = prt n
+    prt (K tokn)          = show (prt tokn)
+    prt (E)               = show ""
+
+instance Print Patt where
+    prt (con `PC` [])     = prt con
+    prt (con `PC` pats)   = prt con ++ "(" ++ prtSep "," pats ++ ")"
+    prt (PV ident)        = "$" ++ prt ident
+    prt (PW)              = "_"
+    prt (PR record)       = "{" ++ prtSep ";" record ++ "}"
+
+instance Print Label where
+    prt (L ident)          = prt ident
+    prt (LV nr)            = "$" ++ show nr
+
+instance Print Tokn where
+    prt (KS str)          = str
+    prt tokn@(KP _ _)     = show tokn
+
+instance Print ArgVar where
+    prt (A cat argNr)     = prt cat ++ "#" ++ show argNr
+
+instance Print CIdent where
+    prt (CIQ _ ident)     = prt ident
+
+instance Print Case where
+    prt (pats `Cas` term) = prtSep "|" pats ++ "=>" ++ prt term
+
+instance Print Assign where
+    prt (lbl `Ass` term)  = prt lbl ++ "=" ++ prt term
+
+instance Print PattAssign where
+    prt (lbl `PAss` pat)  = prt lbl ++ "=" ++ prt pat
+
+instance Print Atom where
+    prt (AC c) = prt c
+    prt (AD c) = "<" ++ prt c ++ ">"
+    prt (AV i) = "$" ++ prt i
+    prt (AM n) = "?" ++ show n
+    prt atom   = show atom
+
+instance Print CType where
+    prt (RecType rtype) = "{" ++ prtSep "; " rtype ++ "}"
+    prt (Table ptype vtype) = "(" ++ prt ptype ++ " => " ++ prt vtype ++ ")"
+    prt (Cn cn) = prt cn
+    prt (TStr) = "Str"
+
+instance Print Labelling where
+    prt (lbl `Lbg` ctype) = prt lbl ++ ":" ++ prt ctype
+
+instance Print CFItem where
+    prt (CFTerm regexp) = prt regexp
+    prt (CFNonterm cat) = prt cat
+
+instance Print RegExp where
+    prt (RegAlts words) = "("++prtSep "|" words ++ ")"
+    prt (RegSpec tok) = prt tok
+
+instance Print CFTok where
+    prt (TS str) = str
+    prt (TC (c:str)) = '(' : toUpper c : ')' : str
+    prt (TL str) = show str
+    prt (TI n) = "#" ++ show n
+    prt (TV x) = "$" ++ prt x
+    prt (TM n s) = "?" ++ show n ++ s
+
+instance Print CFCat where
+    prt (CFCat (cid,lbl)) = prt cid ++ "-" ++ prt lbl
+
+instance Print CFFun where 
+    prt (CFFun fun) = prt (fst fun)
+
+instance Print Exp where
+    prt = P.printTree
+
+