GF/src is now for 2.9, and the new sources are in src-3.0 - keep it this way until the release of GF 3

1 files changed, 127 insertions, 0 deletions

diff --git a/src-3.0/GF/Printing/PrintSimplifiedTerm.hs b/src-3.0/GF/Printing/PrintSimplifiedTerm.hs
new file mode 100644
index 000000000..ccd107558
--- /dev/null
+++ b/src-3.0/GF/Printing/PrintSimplifiedTerm.hs
@@ -0,0 +1,127 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : PrintSimplifiedTerm
+-- Maintainer  : PL
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/06/17 14:15:19 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.4 $
+--
+-- Instances for printing terms in a simplified format
+-----------------------------------------------------------------------------
+
+
+module GF.Printing.PrintSimplifiedTerm () where
+
+import GF.Canon.AbsGFC
+import GF.CF.CF
+import GF.CF.CFIdent
+import GF.Printing.PrintParser
+import qualified GF.Canon.PrintGFC as P
+
+instance Print Term where
+    prt (Arg arg)         = prt arg
+    prt (con `Par` [])    = prt con
+    prt (con `Par` 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 (term `S` sel)    = prt term ++ "!" ++ prt sel
+    prt (FV terms)        = "variants{" ++ prtSep "|" terms ++ "}"
+    prt (term `C` term')  = prt term ++ "  " ++ prt term'
+    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 (AS s) = show s
+    prt (AI n) = show n
+    prt (AT s) = show s
+
+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 tok = show tok
+
+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
+
+
+sizeCT :: CType -> Int
+sizeCT (RecType rt) = 1 + sum [ sizeCT t | _ `Lbg` t <- rt ]
+sizeCT (Table pt vt) = 1 + sizeCT pt + sizeCT vt
+sizeCT (Cn cn) = 1
+sizeCT (TStr) = 1
+
+sizeT :: Term -> Int
+sizeT (_ `Par` ts) = 2 + sum (map sizeT ts)
+sizeT (R rec) = 1 + sum [ sizeT t | _ `Ass` t <- rec ]
+sizeT (t `P` _) = 1 + sizeT t
+sizeT (T _ tbl) = 1 + sum [ sum (map sizeP ps) + sizeT t | ps `Cas` t <- tbl ]
+sizeT (t `S` s) = 1 + sizeT t + sizeT s
+sizeT (t `C` t') = 1 + sizeT t + sizeT t'
+sizeT (FV ts) = 1 + sum (map sizeT ts)
+sizeT _ = 1
+
+sizeP :: Patt -> Int
+sizeP (con `PC` pats) = 2 + sum (map sizeP pats)
+sizeP (PR record)     = 1 + sum [ sizeP p | _ `PAss` p <- record ]
+sizeP _ = 1