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
|
module CMacros where
import AbsGFC
import GFC
import qualified Ident as A ---- no need to qualif? 21/9
import qualified Values as V
import qualified MMacros as M
import PrGrammar
import Str
import Operations
import Char
import Monad
-- macros for concrete syntax in GFC that do not need lookup in a grammar
-- how to mark subtrees, dep. on node, position, whether focus
type Marker = V.TrNode -> [Int] -> Bool -> (String, String)
markSubtree :: Marker -> V.TrNode -> [Int] -> Bool -> Term -> Term
markSubtree mk n is = markSubterm . mk n is
-- if no marking is wanted, use the following
noMark :: Marker
noMark _ _ _ = ("","")
-- for vanilla brackets, focus, and position, use
markBracket :: Marker
markBracket n p b = if b then ("[*" ++ show p,"*]") else ("[" ++ show p,"]")
-- for focus only
markFocus :: Marker
markFocus n p b = if b then ("[*","*]") else ("","")
-- for XML, use
markXML :: Marker
markXML n i b =
if b
then ("<focus" +++ p +++ c ++ ">", "</focus>")
else ("<subtree" +++ p +++ c ++ ">", "</subtree>")
where
c = "type=" ++ prt (M.valNode n)
p = "position=" ++ (show $ reverse i)
-- for XML in JGF 1, use
markXMLjgf :: Marker
markXMLjgf n p b =
if b
then ("<focus" +++ c ++ ">", "</focus>")
else ("","")
where
c = "type=" ++ prt (M.valNode n)
-- the marking engine
markSubterm :: (String,String) -> Term -> Term
markSubterm (beg, end) t = case t of
R rs -> R $ map markField rs
T ty cs -> T ty [Cas p (mark v) | Cas p v <- cs]
FV ts -> FV $ map mark ts
_ -> foldr1 C (tk beg ++ [t] ++ tk end) -- t : Str guaranteed?
where
mark = markSubterm (beg, end)
markField lt@(Ass l t) = if isLinLabel l then (Ass l (mark t)) else lt
tk s = if null s then [] else [tK s]
tK :: String -> Term
tK = K . KS
term2patt :: Term -> Err Patt
term2patt trm = case trm of
Con c aa -> do
aa' <- mapM term2patt aa
return (PC c aa')
R r -> do
let (ll,aa) = unzip [(l,a) | Ass l a <- r]
aa' <- mapM term2patt aa
return (PR (map (uncurry PAss) (zip ll aa')))
LI x -> return $ PV x
_ -> prtBad "no pattern corresponds to term" trm
patt2term :: Patt -> Term
patt2term p = case p of
PC x ps -> Con x (map patt2term ps)
PV x -> LI x
PW -> anyTerm ----
PR pas -> R [ Ass lbl (patt2term q) | PAss lbl q <- pas ]
anyTerm :: Term
anyTerm = LI (A.identC "_") --- should not happen
matchPatt cs0 (FV ts) = liftM FV $ mapM (matchPatt cs0) ts
matchPatt cs0 trm = term2patt trm >>= match cs0 where
match cs t =
case cs of
Cas ps b :_ | elem t ps -> return b
_:cs' -> match cs' t
[] -> Bad $ "pattern not found for" +++ prt t
+++ "among" ++++ unlines (map prt cs0) ---- debug
defLinType :: CType
defLinType = RecType [Lbg (L (A.identC "s")) TStr]
defLindef :: Term
defLindef = R [Ass (L (A.identC "s")) (Arg (A (A.identC "str") 0))]
strsFromTerm :: Term -> Err [Str]
strsFromTerm t = case t of
K (KS s) -> return [str s]
K (KP d vs) -> return $ [Str [TN d [(s,v) | Var s v <- vs]]]
C s t -> do
s' <- strsFromTerm s
t' <- strsFromTerm t
return [plusStr x y | x <- s', y <- t']
FV ts -> liftM concat $ mapM strsFromTerm ts
E -> return [str []]
_ -> return [str ("BUG[" ++ prt t ++ "]")] ---- debug
---- _ -> prtBad "cannot get Str from term " t
-- recursively collect all branches in a table
allInTable :: Term -> [Term]
allInTable t = case t of
T _ ts -> concatMap (\ (Cas _ v) -> allInTable v) ts --- expand ?
_ -> [t]
-- to gather s-fields; assumes term in normal form, preserves label
allLinFields :: Term -> Err [[(Label,Term)]]
allLinFields trm = case trm of
---- R rs -> return [[(l,t) | (l,(Just ty,t)) <- rs, isStrType ty]] -- good
R rs -> return [[(l,t) | Ass l t <- rs, isLinLabel l]] ---- bad
FV ts -> do
lts <- mapM allLinFields ts
return $ concat lts
_ -> prtBad "fields can only be sought in a record not in" trm
---- deprecated
isLinLabel l = case l of
L (A.IC ('s':cs)) | all isDigit cs -> True
-- peb (28/4-04), for MCFG grammars to work:
L (A.IC cs) | null cs || head cs `elem` ".!" -> True
_ -> False
-- to gather ultimate cases in a table; preserves pattern list
allCaseValues :: Term -> [([Patt],Term)]
allCaseValues trm = case trm of
T _ cs -> [(p:ps, t) | Cas pp t0 <- cs, p <- pp, (ps,t) <- allCaseValues t0]
_ -> [([],trm)]
-- to gather all linearizations; assumes normal form, preserves label and args
allLinValues :: Term -> Err [[(Label,[([Patt],Term)])]]
allLinValues trm = do
lts <- allLinFields trm
mapM (mapPairsM (return . allCaseValues)) lts
redirectIdent n f@(CIQ _ c) = CIQ n c
ciq n f = CIQ n f
wordsInTerm :: Term -> [String]
wordsInTerm trm = filter (not . null) $ case trm of
K (KS s) -> [s]
S c _ -> wo c
R rs -> concat [wo t | Ass _ t <- rs]
T _ cs -> concat [wo t | Cas _ t <- cs]
C s t -> wo s ++ wo t
FV ts -> concatMap wo ts
K (KP ss vs) -> ss ++ concat [s | Var s _ <- vs]
P t _ -> wo t --- not needed ?
_ -> []
where wo = wordsInTerm
|
