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

src-3.0/GF/Compile/PrOld.hs

@@ -0,0 +1,84 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : PrOld
+-- Maintainer  : GF
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/21 16:21:44 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.8 $
+--
+-- a hack to print gf2 into gf1 readable files
+-- Works only for canonical grammars, printed into GFC. Otherwise we would have
+-- problems with qualified names.
+-- --- printnames are not preserved, nor are lindefs
+-----------------------------------------------------------------------------
+
+module GF.Compile.PrOld (printGrammarOld, stripTerm) where
+
+import GF.Grammar.PrGrammar
+import GF.Canon.CanonToGrammar
+import qualified GF.Canon.GFC as GFC
+import GF.Grammar.Grammar
+import GF.Infra.Ident
+import GF.Grammar.Macros
+import GF.Infra.Modules
+import qualified GF.Source.PrintGF as P
+import GF.Source.GrammarToSource
+
+import Data.List
+import GF.Data.Operations
+import GF.Infra.UseIO
+
+printGrammarOld :: GFC.CanonGrammar -> String
+printGrammarOld gr = err id id $ do
+  as0 <- mapM canon2sourceModule [im | im@(_,ModMod m) <- modules gr, isModAbs m]
+  cs0 <- mapM canon2sourceModule 
+           [im | im@(_,ModMod m) <- modules gr, isModCnc m || isModRes m]
+  as1 <- return $ concatMap stripInfo $ concatMap (tree2list . js . snd) as0
+  cs1 <- return $ concatMap stripInfo $ concatMap (tree2list . js . snd) cs0
+  return $ unlines $ map prj $ srt as1 ++ srt cs1
+ where
+   js (ModMod m) = jments m
+   srt = sortBy (\ (i,_) (j,_) -> compare i j)
+   prj ii = P.printTree $ trAnyDef ii
+
+stripInfo :: (Ident,Info) -> [(Ident,Info)]
+stripInfo (c,i) = case i of
+  AbsCat   (Yes co) (Yes fs) -> rc $ AbsCat (Yes (stripContext co)) nope
+  AbsFun   (Yes ty) (Yes tr) -> rc $ AbsFun (Yes (stripTerm ty)) (Yes(stripTerm tr))
+  AbsFun   (Yes ty) _ -> rc $ AbsFun (Yes (stripTerm ty)) nope
+  ResParam (Yes (ps,m))       -> rc $ ResParam (Yes ([(c,stripContext co) | (c,co)<- ps],Nothing))
+  CncCat   (Yes ty) _ _ -> rc $
+    CncCat (Yes (stripTerm ty)) nope nope
+  CncFun   _ (Yes tr) _ -> rc $ CncFun Nothing (Yes (stripTerm tr)) nope
+  _ -> []
+ where
+   rc j = [(c,j)]
+
+stripContext co = [(x, stripTerm t) | (x,t) <- co]
+
+stripTerm :: Term -> Term
+stripTerm t = case t of
+  Q _ c -> Vr c
+  QC _ c -> Vr c
+  T ti cs -> T ti' [(stripPattern p, stripTerm c) | (p,c) <- cs] where
+               ti' = case ti of
+                  TTyped ty -> TTyped $ stripTerm ty
+                  TComp ty -> TComp $ stripTerm ty
+                  TWild ty -> TWild $ stripTerm ty
+                  _ -> ti
+----  R [] -> EInt 8      --- GF 1.2 parser doesn't accept empty records 
+----  RecType [] -> Cn (zIdent "Int") ---
+  _ -> composSafeOp stripTerm t
+
+stripPattern p = case p of
+  PC c [] -> PV c
+  PP _ c [] -> PV c
+  PC c ps -> PC c (map stripPattern ps)
+  PP _ c ps -> PC c (map stripPattern ps)
+  PR lps -> PR [(l, stripPattern p) | (l,p) <- lps]
+  PT t p -> PT (stripTerm t) (stripPattern p)
+  _ -> p
+