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
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
|
----------------------------------------------------------------------
-- |
-- Maintainer : PL
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/04/11 13:52:52 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.1 $
--
-- Converting GFC to SimpleGFC
--
-- the conversion might fail if the GFC grammar has dependent or higher-order types
-----------------------------------------------------------------------------
module GF.OldParsing.ConvertGFCtoSimple where
import qualified AbsGFC as A
import qualified Ident as I
import GF.OldParsing.SimpleGFC
import GFC
import MkGFC (grammar2canon)
import qualified Look (lookupLin, allParamValues, lookupLincat)
import qualified CMacros (defLinType)
import Operations (err, errVal)
import qualified Modules as M
import GF.System.Tracing
import GF.Printing.PrintParser
import GF.Printing.PrintSimplifiedTerm
----------------------------------------------------------------------
type Env = (CanonGrammar, I.Ident)
convertGrammar :: Env -> Grammar
convertGrammar gram = trace2 "language" (show (snd gram)) $
tracePrt "#simple-rules total" (show . length) $
[ convertAbsFun gram fun typing |
A.Mod (A.MTAbs modname) _ _ _ defs <- modules,
A.AbsDFun fun typing _ <- defs ]
where A.Gr modules = grammar2canon (fst gram)
convertAbsFun :: Env -> I.Ident -> A.Exp -> Rule
convertAbsFun gram fun aTyping
= -- trace2 "absFun" (show fun) $
Rule fun sTyping sTerm
where sTyping = convertTyping [] aTyping
sTerm = do lin <- lookupLin gram fun
return (convertTerm gram lin, convertCType gram cType)
cType = lookupCType gram sTyping
convertTyping :: [Decl] -> A.Exp -> Typing
-- convertTyping env tp | trace2 "typing" (prt env ++ " / " ++ prt tp) False = undefined
convertTyping env (A.EProd x a b)
= convertTyping ((x ::: convertType [] a) : env) b
convertTyping env a = (convertType [] a, reverse env)
convertType :: [Atom] -> A.Exp -> Type
-- convertType args tp | trace2 "type" (prt args ++ " / " ++ prt tp) False = undefined
convertType args (A.EApp a (A.EAtom at)) = convertType (convertAtom at : args) a
convertType args (A.EAtom at) = convertCat at :@ args
convertAtom :: A.Atom -> Atom
convertAtom (A.AC con) = ACon con
convertAtom (A.AV var) = AVar var
convertCat :: A.Atom -> Cat
convertCat (A.AC (A.CIQ _ cat)) = cat
convertCat at = error $ "convertCat: " ++ show at
convertCType :: Env -> A.CType -> CType
convertCType gram (A.RecType rec)
= RecT [ (lbl, convertCType gram ctype) | A.Lbg lbl ctype <- rec ]
convertCType gram (A.Table ptype vtype)
= TblT (convertCType gram ptype) (convertCType gram vtype)
convertCType gram ct@(A.Cn con) = ConT con $ map (convertTerm gram) $ groundTerms gram ct
convertCType gram (A.TStr) = StrT
convertCType gram (A.TInts n) = error "convertCType: cannot handle 'TInts' constructor"
convertTerm :: Env -> A.Term -> Term
convertTerm gram (A.Arg arg) = convertArgVar arg
convertTerm gram (A.Con con terms) = con :^ map (convertTerm gram) terms
convertTerm gram (A.LI var) = Var var
convertTerm gram (A.R rec) = Rec [ (lbl, convertTerm gram term) | A.Ass lbl term <- rec ]
convertTerm gram (A.P term lbl) = convertTerm gram term +. lbl
convertTerm gram (A.V ctype terms) = Tbl [ (convertTerm gram pat, convertTerm gram term) |
(pat, term) <- zip (groundTerms gram ctype) terms ]
convertTerm gram (A.T ctype tbl) = Tbl [ (convertPatt pat, convertTerm gram term) |
A.Cas pats term <- tbl, pat <- pats ]
convertTerm gram (A.S term sel) = convertTerm gram term +! convertTerm gram sel
convertTerm gram (A.C term1 term2) = convertTerm gram term1 ?++ convertTerm gram term2
convertTerm gram (A.FV terms) = Variants (map (convertTerm gram) terms)
convertTerm gram (A.K tok) = Token tok
convertTerm gram (A.E) = Empty
convertTerm gram (A.I con) = error "convertTerm: cannot handle 'I' constructor"
convertTerm gram (A.EInt int) = error "convertTerm: cannot handle 'EInt' constructor"
convertArgVar :: A.ArgVar -> Term
convertArgVar (A.A cat nr) = Arg (fromInteger nr) cat emptyPath
convertArgVar (A.AB cat bindings nr) = Arg (fromInteger nr) cat emptyPath
convertPatt (A.PC con pats) = con :^ map convertPatt pats
convertPatt (A.PV x) = Var x
convertPatt (A.PW) = Wildcard
convertPatt (A.PR rec) = Rec [ (lbl, convertPatt pat) | A.PAss lbl pat <- rec ]
convertPatt (A.PI n) = error "convertPatt: cannot handle 'PI' constructor"
----------------------------------------------------------------------
lookupLin gram fun = err fail Just $
Look.lookupLin (fst gram) (A.CIQ (snd gram) fun)
--lookupCType :: Env -> Typing -> CType
lookupCType env (cat :@ _, _) = errVal CMacros.defLinType $
Look.lookupLincat (fst env) (A.CIQ (snd env) cat)
groundTerms :: Env -> A.CType -> [A.Term]
groundTerms gram ctype = err error id $
Look.allParamValues (fst gram) ctype
|
