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
|
{-# LANGUAGE NoMonomorphismRestriction #-}
module SimpleEditor.Convert where
import Control.Monad(unless,foldM,ap,mplus)
import Data.List(sortBy)
import Data.Function(on)
import qualified Data.Map as Map
import Text.JSON(makeObj) --encode
import GF.Text.Pretty(render,(<+>))
import qualified Data.ByteString.UTF8 as UTF8(fromString)
import GF.Infra.Option(optionsGFO)
import GF.Infra.Ident(showIdent,ModuleName(..))
import GF.Grammar.Grammar
import GF.Grammar.Printer(ppParams,ppTerm,getAbs,TermPrintQual(..))
import GF.Grammar.Parser(runP,pModDef)
import GF.Grammar.Lexer(Posn(..))
import GF.Data.ErrM
import PGF.Internal(Literal(LStr))
import SimpleEditor.Syntax as S
import SimpleEditor.JSON
parseModule (path,source) =
(path.=) $
case runP pModDef (UTF8.fromString source) of
Left (Pn l c,msg) ->
makeObj ["error".=msg, "location".= show l++":"++show c]
Right mod -> case convModule mod of
Ok g -> makeObj ["converted".=g]
Bad msg -> makeObj ["parsed".=msg]
{-
convAbstractFile path =
appIOE (fmap encode . convAbstract =<< getSourceModule noOptions path)
-}
convModule m@(modid,src) =
if isModAbs src
then convAbstract m
else if isModCnc src
then convConcrete m
else fail "An abstract or concrete syntax module was expected"
convAbstract (modid,src) =
do unless (isModAbs src) $ fail "Abstract syntax expected"
unless (isCompleteModule src) $ fail "A complete abstract syntax expected"
extends <- convExtends (mextend src)
(cats0,funs0) <- convAbsJments (jments src)
let cats = reverse cats0
funs = reverse funs0
flags = optionsGFO (mflags src)
startcat =
case lookup "startcat" flags of
Just (LStr cat) -> cat
_ -> "-"
return $ Grammar (convModId modid) extends (Abstract startcat cats funs) []
convExtends = mapM convExtend
convExtend (modid,MIAll) = return (convModId modid)
convExtend _ = fail "unsupported module extension"
convAbsJments jments = foldM convAbsJment ([],[]) (jmentList jments)
convAbsJment (cats,funs) (name,jment) =
case jment of
AbsCat octx -> do unless (null (maybe [] unLoc octx)) $
fail "category with context"
let cat = convId name
return (cat:cats,funs)
AbsFun (Just lt) _ oeqns _ -> do unless (null (maybe [] id oeqns)) $
fail "function with equations"
let f = convId name
typ <- convType (unLoc lt)
let fun = Fun f typ
return (cats,fun:funs)
_ -> fail $ "unsupported judgement form: "++show jment
convType (Prod _ _ t1 t2) = (:) `fmap` convSimpleType t1 `ap` convType t2
convType t = (:[]) `fmap` convSimpleType t
convSimpleType (Vr id) = return (convId id)
convSimpleType t = fail "unsupported type"
convId = showIdent
convModId (MN m) = convId m
convConcrete (modid,src) =
do unless (isModCnc src) $ fail "Concrete syntax expected"
unless (isCompleteModule src) $ fail "A complete concrete syntax expected"
extends <- convExtends (mextend src)
opens <- convOpens (mopens src)
js <- convCncJments (jments src)
let ps = [p | Pa p <-js]
lcs = [lc | LC lc<-js]
os = [o | Op o <-js]
ls = [l | Li l <-js]
langcode = "" -- !!!
conc = Concrete langcode opens ps lcs os ls
abs = Abstract "-" [] [] -- dummy
return $ Grammar (convModId modid) extends abs [conc]
convOpens = mapM convOpen
convOpen o =
case o of
OSimple id -> return (convModId id)
_ -> fail "unsupported module open"
data CncJment = Pa S.Param | LC Lincat | Op Oper | Li Lin | Ignored
convCncJments = mapM convCncJment . jmentList
convCncJment (name,jment) =
case jment of
ResParam ops _ ->
return $ Pa $ Param i (maybe "" (render . ppParams q . unLoc) ops)
ResValue _ -> return Ignored
CncCat (Just (L _ typ)) Nothing Nothing pprn _ -> -- ignores printname !!
return $ LC $ Lincat i (render $ ppTerm q 0 typ)
ResOper oltyp (Just lterm) -> return $ Op $ Oper lhs rhs
where
lhs = i++maybe "" ((" : "++) . render . ppTerm q 0 . unLoc) oltyp
rhs = render (" ="<+>ppTerm q 0 (unLoc lterm))
ResOverload [] defs -> return $ Op $ Oper lhs rhs
where
lhs = i
rhs = render $ " = overload"<+>ppTerm q 0 r
r = R [(lab,(Just ty,fu)) | (L _ ty,L _ fu) <-defs]
lab = ident2label name
CncFun _ (Just ldef) pprn _ -> -- ignores printname !!
do let (xs,e') = getAbs (unLoc ldef)
lin = render $ ppTerm q 0 e'
args <- mapM convBind xs
return $ Li $ Lin i args lin
_ -> fail $ "unsupported judgement form: "++show jment
where
i = convId name
q = Unqualified
convBind (Explicit,v) = return $ convId v
convBind (Implicit,v) = fail "implicit binding not supported"
jmentList = sortBy (compare `on` (jmentLocation.snd)) . Map.toList
jmentLocation jment =
case jment of
AbsCat ctxt -> fmap loc ctxt
AbsFun ty _ _ _ -> fmap loc ty
ResParam ops _ -> fmap loc ops
CncCat ty _ _ _ _ ->fmap loc ty
ResOper ty rhs -> fmap loc rhs `mplus` fmap loc ty
CncFun _ rhs _ _ -> fmap loc rhs
_ -> Nothing
loc (L l _) = l
|
