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
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
|
----------------------------------------------------------------------
-- |
-- Module : PGFtoProlog
-- Maintainer : Peter Ljunglöf
--
-- exports a GF grammar into a Prolog module
-----------------------------------------------------------------------------
module GF.Compile.PGFtoProlog (grammar2prolog) where
import PGF(mkCId,wildCId,showCId)
import PGF.Internal
--import PGF.Macros
import GF.Data.Operations
import qualified Data.Array.IArray as Array
import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified Data.IntMap as IntMap
import Data.Char (isAlphaNum, isAscii, isAsciiLower, isAsciiUpper, ord)
import Data.List (isPrefixOf, mapAccumL)
grammar2prolog :: PGF -> String
grammar2prolog pgf
= ("%% This file was automatically generated by GF" +++++
":- style_check(-singleton)." +++++
plFacts wildCId "abstract" 1 "(?AbstractName)"
[[plp name]] ++++
plFacts wildCId "concrete" 2 "(?AbstractName, ?ConcreteName)"
[[plp name, plp cncname] |
cncname <- Map.keys (concretes pgf)] ++++
plFacts wildCId "flag" 2 "(?Flag, ?Value): global flags"
[[plp f, plp v] |
(f, v) <- Map.assocs (gflags pgf)] ++++
plAbstract name (abstract pgf) ++++
unlines (map plConcrete (Map.assocs (concretes pgf)))
)
where name = absname pgf
----------------------------------------------------------------------
-- abstract syntax
plAbstract :: CId -> Abstr -> String
plAbstract name abs
= (plHeader "Abstract syntax" ++++
plFacts name "flag" 2 "(?Flag, ?Value): flags for abstract syntax"
[[plp f, plp v] |
(f, v) <- Map.assocs (aflags abs)] ++++
plFacts name "cat" 2 "(?Type, ?[X:Type,...])"
[[plType cat args, plHypos hypos'] |
(cat, (hypos,_,_)) <- Map.assocs (cats abs),
let ((_, subst), hypos') = mapAccumL alphaConvertHypo emptyEnv hypos,
let args = reverse [EFun x | (_,x) <- subst]] ++++
plFacts name "fun" 3 "(?Fun, ?Type, ?[X:Type,...])"
[[plp fun, plType cat args, plHypos hypos] |
(fun, (typ, _, _, _)) <- Map.assocs (funs abs),
let (_, DTyp hypos cat args) = alphaConvert emptyEnv typ] ++++
plFacts name "def" 2 "(?Fun, ?Expr)"
[[plp fun, plp expr] |
(fun, (_, _, Just (eqs,_), _)) <- Map.assocs (funs abs),
let (_, expr) = alphaConvert emptyEnv eqs]
)
where plType cat args = plTerm (plp cat) (map plp args)
plHypos hypos = plList [plOper ":" (plp x) (plp ty) | (_, x, ty) <- hypos]
----------------------------------------------------------------------
-- concrete syntax
plConcrete :: (CId, Concr) -> String
plConcrete (name, cnc)
= (plHeader ("Concrete syntax: " ++ plp name) ++++
plFacts name "flag" 2 "(?Flag, ?Value): flags for concrete syntax"
[[plp f, plp v] |
(f, v) <- Map.assocs (cflags cnc)] ++++
plFacts name "printname" 2 "(?AbsFun/AbsCat, ?Atom)"
[[plp f, plp n] |
(f, n) <- Map.assocs (printnames cnc)] ++++
plFacts name "lindef" 2 "(?CncCat, ?CncFun)"
[[plCat cat, plFun fun] |
(cat, funs) <- IntMap.assocs (lindefs cnc),
fun <- funs] ++++
plFacts name "prod" 3 "(?CncCat, ?CncFun, ?[CncCat])"
[[plCat cat, fun, plTerm "c" (map plCat args)] |
(cat, set) <- IntMap.toList (productions cnc),
(fun, args) <- map plProduction (Set.toList set)] ++++
plFacts name "cncfun" 3 "(?CncFun, ?[Seq,...], ?AbsFun)"
[[plFun fun, plTerm "s" (map plSeq (Array.elems lins)), plp absfun] |
(fun, CncFun absfun lins) <- Array.assocs (cncfuns cnc)] ++++
plFacts name "seq" 2 "(?Seq, ?[Term])"
[[plSeq seq, plp (Array.elems symbols)] |
(seq, symbols) <- Array.assocs (sequences cnc)] ++++
plFacts name "cnccat" 2 "(?AbsCat, ?[CnCCat])"
[[plp cat, plList (map plCat [start..end])] |
(cat, CncCat start end _) <- Map.assocs (cnccats cnc)]
)
where plProduction (PCoerce arg) = ("-", [arg])
plProduction (PApply funid args) = (plFun funid, [fid | PArg hypos fid <- args])
----------------------------------------------------------------------
-- prolog-printing pgf datatypes
instance PLPrint Type where
plp (DTyp hypos cat args)
| null hypos = result
| otherwise = plOper " -> " plHypos result
where result = plTerm (plp cat) (map plp args)
plHypos = plList [plOper ":" (plp x) (plp ty) | (_,x,ty) <- hypos]
instance PLPrint Expr where
plp (EFun x) = plp x
plp (EAbs _ x e)= plOper "^" (plp x) (plp e)
plp (EApp e e') = plOper " * " (plp e) (plp e')
plp (ELit lit) = plp lit
plp (EMeta n) = "Meta_" ++ show n
instance PLPrint Patt where
plp (PVar x) = plp x
plp (PApp f ps) = plOper " * " (plp f) (plp ps)
plp (PLit lit) = plp lit
instance PLPrint Equation where
plp (Equ patterns result) = plOper ":" (plp patterns) (plp result)
instance PLPrint CId where
plp cid | isLogicalVariable str || cid == wildCId = plVar str
| otherwise = plAtom str
where str = showCId cid
instance PLPrint Literal where
plp (LStr s) = plp s
plp (LInt n) = plp (show n)
plp (LFlt f) = plp (show f)
instance PLPrint Symbol where
plp (SymCat n l) = plOper ":" (show n) (show l)
plp (SymLit n l) = plTerm "lit" [show n, show l]
plp (SymVar n l) = plTerm "var" [show n, show l]
plp (SymKS t) = plAtom t
plp (SymKP ts alts) = plTerm "pre" [plList (map plp ts), plList (map plAlt alts)]
where plAlt (ps,ts) = plOper "/" (plList (map plp ps)) (plList (map plAtom ts))
class PLPrint a where
plp :: a -> String
plps :: [a] -> String
plps = plList . map plp
instance PLPrint Char where
plp c = plAtom [c]
plps s = plAtom s
instance PLPrint a => PLPrint [a] where
plp = plps
----------------------------------------------------------------------
-- other prolog-printing functions
plCat :: Int -> String
plCat n = plAtom ('c' : show n)
plFun :: Int -> String
plFun n = plAtom ('f' : show n)
plSeq :: Int -> String
plSeq n = plAtom ('s' : show n)
plHeader :: String -> String
plHeader hdr = "%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%\n%% " ++ hdr ++ "\n"
plFacts :: CId -> String -> Int -> String -> [[String]] -> String
plFacts mod pred arity comment facts = "%% " ++ pred ++ comment ++++ clauses
where clauses = (if facts == [] then ":- dynamic " ++ pred ++ "/" ++ show arity ++ ".\n"
else unlines [mod' ++ plTerm pred args ++ "." | args <- facts])
mod' = if mod == wildCId then "" else plp mod ++ ": "
plTerm :: String -> [String] -> String
plTerm fun args = plAtom fun ++ prParenth (prTList ", " args)
plList :: [String] -> String
plList xs = prBracket (prTList "," xs)
plOper :: String -> String -> String -> String
plOper op a b = prParenth (a ++ op ++ b)
plVar :: String -> String
plVar = varPrefix . concatMap changeNonAlphaNum
where varPrefix var@(c:_) | isAsciiUpper c || c=='_' = var
| otherwise = "_" ++ var
changeNonAlphaNum c | isAlphaNumUnderscore c = [c]
| otherwise = "_" ++ show (ord c) ++ "_"
plAtom :: String -> String
plAtom "" = "''"
plAtom atom@(c:cs) | isAsciiLower c && all isAlphaNumUnderscore cs
|| c == '\'' && cs /= "" && last cs == '\'' = atom
| otherwise = "'" ++ changeQuote atom ++ "'"
where changeQuote ('\'':cs) = '\\' : '\'' : changeQuote cs
changeQuote ('\\':cs) = '\\' : '\\' : changeQuote cs
changeQuote (c:cs) = c : changeQuote cs
changeQuote "" = ""
isAlphaNumUnderscore :: Char -> Bool
isAlphaNumUnderscore c = (isAscii c && isAlphaNum c) || c == '_'
----------------------------------------------------------------------
-- prolog variables
createLogicalVariable :: Int -> CId
createLogicalVariable n = mkCId (logicalVariablePrefix ++ show n)
isLogicalVariable :: String -> Bool
isLogicalVariable = isPrefixOf logicalVariablePrefix
logicalVariablePrefix :: String
logicalVariablePrefix = "X"
----------------------------------------------------------------------
-- alpha convert variables to (unique) logical variables
-- * this is needed if we want to translate variables to Prolog variables
-- * used for abstract syntax, not concrete
-- * not (yet?) used for variables bound in pattern equations
type ConvertEnv = (Int, [(CId,CId)])
emptyEnv :: ConvertEnv
emptyEnv = (0, [])
class AlphaConvert a where
alphaConvert :: ConvertEnv -> a -> (ConvertEnv, a)
instance AlphaConvert a => AlphaConvert [a] where
alphaConvert env [] = (env, [])
alphaConvert env (a:as) = (env'', a':as')
where (env', a') = alphaConvert env a
(env'', as') = alphaConvert env' as
instance AlphaConvert Type where
alphaConvert env@(_,subst) (DTyp hypos cat args)
= ((ctr,subst), DTyp hypos' cat args')
where (env', hypos') = mapAccumL alphaConvertHypo env hypos
((ctr,_), args') = alphaConvert env' args
alphaConvertHypo env (b,x,typ) = ((ctr+1,(x,x'):subst), (b,x',typ'))
where ((ctr,subst), typ') = alphaConvert env typ
x' = createLogicalVariable ctr
instance AlphaConvert Expr where
alphaConvert (ctr,subst) (EAbs b x e) = ((ctr',subst), EAbs b x' e')
where ((ctr',_), e') = alphaConvert (ctr+1,(x,x'):subst) e
x' = createLogicalVariable ctr
alphaConvert env (EApp e1 e2) = (env'', EApp e1' e2')
where (env', e1') = alphaConvert env e1
(env'', e2') = alphaConvert env' e2
alphaConvert env expr@(EFun i) = (env, maybe expr EFun (lookup i (snd env)))
alphaConvert env expr = (env, expr)
-- pattern variables are not alpha converted
-- (but they probably should be...)
instance AlphaConvert Equation where
alphaConvert env@(_,subst) (Equ patterns result)
= ((ctr,subst), Equ patterns result')
where ((ctr,_), result') = alphaConvert env result
|
