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
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
|
module Linear where
import GFC
import AbsGFC
import qualified Abstract as A
import MkGFC (rtQIdent) ----
import Ident
import PrGrammar
import CMacros
import Look
import LookAbs
import MMacros
import TypeCheck (annotate) ----
import Str
import Unlex
----import TypeCheck -- to annotate
import Operations
import Zipper
import Monad
-- Linearization for canonical GF. AR 7/6/2003
-- The worker function: linearize a Tree, return
-- a record. Possibly mark subtrees.
-- NB. Constants in trees are annotated by the name of the abstract module.
-- A concrete module name must be given to find (and choose) linearization rules.
-- If no marking is wanted, noMark :: Marker.
-- For xml marking, use markXML :: Marker
linearizeToRecord :: CanonGrammar -> Marker -> Ident -> A.Tree -> Err Term
linearizeToRecord gr mk m = lin [] where
lin ts t@(Tr (n,xs)) = errIn ("linearization of" +++ prt t) $ do
let binds = A.bindsNode n
at = A.atomNode n
fmk = markSubtree mk n ts (A.isFocusNode n)
c <- A.val2cat $ A.valNode n
xs' <- mapM (\ (i,x) -> lin (i:ts) x) $ zip [0..] xs
r <- case at of
A.AtC f -> look f >>= comp xs'
A.AtL s -> return $ recS $ tK $ prt at
A.AtI i -> return $ recS $ tK $ prt at
A.AtV x -> lookCat c >>= comp [tK (prt at)]
A.AtM m -> lookCat c >>= comp [tK (prt at)]
return $ fmk $ mkBinds binds r
look = lookupLin gr . redirectIdent m . rtQIdent
comp = ccompute gr
mkBinds bs bdy = case bdy of
R fs -> R $ [Ass (LV i) (tK (prt t)) | (i,(t,_)) <- zip [0..] bs] ++ fs
recS t = R [Ass (L (identC "s")) t] ----
lookCat = return . errVal defLindef . look
---- should always be given in the module
-- thus the special case:
linearizeNoMark :: CanonGrammar -> Ident -> A.Tree -> Err Term
linearizeNoMark gr = linearizeToRecord gr noMark
-- expand tables in linearized term to full, normal-order tables
-- NB expand from inside-out so that values are not looked up in copies of branches
expandLinTables :: CanonGrammar -> Term -> Err Term
expandLinTables gr t = case t of
R rs -> liftM (R . map (uncurry Ass)) $ mapPairsM exp [(l,r) | Ass l r <- rs]
T ty rs -> do
rs' <- mapPairsM exp [(l,r) | Cas l r <- rs] -- expand from inside-out
let t' = T ty $ map (uncurry Cas) rs'
vs <- alls ty
ps <- mapM term2patt vs
ts' <- mapM (comp . S t') $ vs
return $ T ty [Cas [p] t | (p,t) <- zip ps ts']
FV ts -> liftM FV $ mapM exp ts
_ -> return t
where
alls = allParamValues gr
exp = expandLinTables gr
comp = ccompute gr []
-- from records, one can get to records of tables of strings
rec2strTables :: Term -> Err [[(Label,[([Patt],[Str])])]]
rec2strTables r = do
vs <- allLinValues r
mapM (mapPairsM (mapPairsM strsFromTerm)) vs
-- from these tables, one may want to extract the ones for the "s" label
strTables2sTables :: [[(Label,[([Patt],[Str])])]] -> [[([Patt],[Str])]]
strTables2sTables ts = [t | r <- ts, (l,t) <- r, l == linLab0]
linLab0 :: Label
linLab0 = L (identC "s")
-- to get lists of token lists is easy
sTables2strs :: [[([Patt],[Str])]] -> [[Str]]
sTables2strs = map snd . concat
-- from this, to get a list of strings --- customize unlexer
strs2strings :: [[Str]] -> [String]
strs2strings = map unlex
-- finally, a top-level function to get a string from an expression
linTree2string :: Marker -> CanonGrammar -> Ident -> A.Tree -> String
linTree2string mk gr m e = err id id $ do
t <- linearizeToRecord gr mk m e
r <- expandLinTables gr t
ts <- rec2strTables r
let ss = strs2strings $ sTables2strs $ strTables2sTables ts
ifNull (prtBad "empty linearization of" e) (return . head) ss
-- argument is a Tree, value is a list of strs; needed in Parsing
allLinsOfTree :: CanonGrammar -> Ident -> A.Tree -> [Str]
allLinsOfTree gr a e = err (singleton . str) id $ do
e' <- return e ---- annotateExp gr e
r <- linearizeNoMark gr a e'
r' <- expandLinTables gr r
ts <- rec2strTables r'
return $ concat $ sTables2strs $ strTables2sTables ts
{-
-- the value is a list of strs
allLinStrings :: CanonGrammar -> Tree -> [Str]
allLinStrings gr ft = case allLinsAsStrs gr ft of
Ok ts -> map snd $ concat $ map snd $ concat ts
Bad s -> [str s]
-- the value is a list of strs, not forgetting their arguments
allLinsAsStrs :: CanonGrammar -> Tree -> Err [[(Label,[([Patt],Str)])]]
allLinsAsStrs gr ft = do
lpts <- allLinearizations gr ft
return $ concat $ mapM (mapPairsM (mapPairsM strsFromTerm)) lpts
-- the value is a list of terms of type Str, not forgetting their arguments
allLinearizations :: CanonGrammar -> Tree -> Err [[(Label,[([Patt],Term)])]]
allLinearizations gr ft = linearizeTree gr ft >>= allLinValues
-- to a list of strings
linearizeToStrings :: CanonGrammar -> ([Int] ->Term -> Term) -> Tree -> Err [String]
linearizeToStrings gr mk = liftM (map unlex) . linearizeToStrss gr mk
-- to a list of token lists
linearizeToStrss :: CanonGrammar -> ([Int] -> Term -> Term) -> Tree -> Err [[Str]]
linearizeToStrss gr mk e = do
R rs <- linearizeToRecord gr mk e ----
t <- lookupErr linLab0 [(r,s) | Ass r s <- rs]
return $ map strsFromTerm $ allInTable t
-- the value is a list of strings, not forgetting their arguments
allLinsOfFun :: CanonGrammar -> CIdent -> Err [[(Label,[([Patt],Term)])]]
allLinsOfFun gr f = do
t <- lookupLin gr f
allLinValues t
-}
-- returns printname if one exists; otherwise linearizes with metas
printOrLinearize :: CanonGrammar -> Ident -> A.Fun -> String
printOrLinearize gr c f@(m, d) = errVal (prt fq) $
case lookupPrintname gr (CIQ c d) of
Ok t -> do
ss <- strsFromTerm t
let s = strs2strings [ss]
return $ ifNull (prt fq) head s
_ -> do
ty <- lookupFunType gr m d
f' <- ref2exp [] ty (A.QC m d)
tr <- annotate gr f'
return $ linTree2string noMark gr c tr
where
fq = CIQ m d
|
