1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
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) -> rc $ ResParam (Yes [(c,stripContext co) | (c,co)<- ps])
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
|
