gfse: experimental support for editing concrete syntax in text mode

src/compiler/GF/Grammar/Printer.hs

@@ -13,6 +13,7 @@ module GF.Grammar.Printer
            , ppGrammar
            , ppModule
            , ppJudgement
+           , ppParams
            , ppTerm
            , ppPatt
            , ppValue
@@ -20,6 +21,7 @@ module GF.Grammar.Printer
            , ppLocation
            , ppQIdent
            , ppMeta
+           , getAbs
            ) where
 
 import GF.Infra.Ident
@@ -107,7 +109,7 @@ ppJudgement q (id, AbsFun ptype _ pexp poper) =
 ppJudgement q (id, ResParam pparams _) = 
   text "param" <+> ppIdent id <+>
   (case pparams of
-     Just (L _ ps) -> equals <+> fsep (intersperse (char '|') (map (ppParam q) ps))
+     Just (L _ ps) -> equals <+> ppParams q ps
      _             -> empty) <+> semi
 ppJudgement q (id, ResValue pvalue) = empty
 ppJudgement q (id, ResOper  ptype pexp) =
@@ -304,6 +306,7 @@ ppBind (Implicit,v) = braces (ppIdent v)
 
 ppAltern q (x,y) = ppTerm q 0 x <+> char '/' <+> ppTerm q 0 y
 
+ppParams q ps = fsep (intersperse (char '|') (map (ppParam q) ps))
 ppParam q (id,cxt) = ppIdent id <+> hsep (map (ppDDecl q) cxt)
 
 ppLocation :: FilePath -> Location -> Doc

src/compiler/SimpleEditor/Convert.hs

@@ -5,17 +5,19 @@ import Control.Monad(unless,foldM,ap)
 import qualified Data.Map as Map
 import qualified Data.ByteString.Char8 as BS(pack)
 import Text.JSON(encode,makeObj)
+import Text.PrettyPrint(render)
 
 --import GF.Compile.GetGrammar (getSourceModule)
 --import GF.Infra.Option(noOptions)
 import GF.Infra.Ident(showIdent)
 --import GF.Infra.UseIO(appIOE)
 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 SimpleEditor.Syntax
+import SimpleEditor.Syntax as S
 import SimpleEditor.JSON
 
 
@@ -25,7 +27,7 @@ parseModule (path,source) =
      Left (Pn l c,msg) ->
          makeObj [prop "error" msg,
                   prop "location" (show l++":"++show c)]
-     Right mod -> case convAbstract mod of
+     Right mod -> case convModule mod of
                     Ok g -> makeObj [prop "converted" g]
                     Bad msg -> makeObj [prop "parsed" msg]
 
@@ -33,11 +35,19 @@ parseModule (path,source) =
 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)
-     (cats,funs) <- convJments (jments src)
+     (cats,funs) <- convAbsJments (jments src)
      let startcat = head (cats++["-"]) -- !!!
      return $ Grammar (convId modid) extends (Abstract startcat cats funs) []
 
@@ -45,9 +55,9 @@ convExtends = mapM convExtend
 convExtend (modid,MIAll) = return (convId modid)
 convExtend _ = fail "unsupported module extension"
 
-convJments jments = foldM convJment ([],[]) (Map.toList jments)
+convAbsJments jments = foldM convAbsJment ([],[]) (Map.toList jments)
 
-convJment (cats,funs) (name,jment) =
+convAbsJment (cats,funs) (name,jment) =
   case jment of
     AbsCat octx -> do unless (null (maybe [] unLoc octx)) $
                              fail "category with context"
@@ -69,3 +79,53 @@ convSimpleType (Vr id) = return (convId id)
 convSimpleType t = fail "unsupported type"
 
 convId = showIdent
+
+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 (convId modid) extends abs [conc]
+
+convOpens = mapM convOpen
+
+convOpen o =
+  case o of
+    OSimple id -> return (convId id)
+    _ -> fail "unsupported module open"
+
+
+data CncJment = Pa S.Param | LC Lincat | Op Oper | Li Lin
+
+convCncJments = mapM convCncJment . Map.toList
+
+convCncJment (name,jment) =
+  case jment of
+    ResParam ops _ ->
+      return $ Pa $ Param i (maybe "" (render . ppParams q . unLoc) ops)
+    CncCat (Just (L _ typ)) Nothing Nothing _ ->
+      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))
+    CncFun _ (Just ldef) Nothing _ ->
+      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"

src/www/gfse/editor.js

@@ -461,14 +461,21 @@ function draw_abstract(g) {
 			   extensible([kw_fun,
 				       indent_sortable(draw_funs(g),sort_funs)])])]);
     if(navigator.onLine) {
-	var mode_button=text_mode(g,file);
+	var mode_button=text_mode(g,file,0);
 	insertBefore(mode_button,file.firstChild)
     }
     return file;
 }
 
-function text_mode(g,file) {
+function module_name(g,ix) {
-    var path=g.basename+".gf"
+    return ix==0 ? g.basename : g.basename+g.concretes[ix-1].langcode
+}
+function show_module(g,ix) {
+    return ix==0 ? show_abstract(g) : show_concrete(g)(g.concretes[ix-1]);
+}
+
+function text_mode(g,file,ix) {
+    var path=module_name(g,ix)+".gf"
     function switch_to_guided_mode() {
 	clear(compiler_output);
 	edit_grammar(g); // !!
@@ -485,11 +492,24 @@ function text_mode(g,file) {
 	    dst.innerHTML=
 	      "Accepted by GF, but not by this editor ("+msg.parsed+")"
 	else if(msg.converted) {
-	    var gnew=msg.converted;
+	    if(ix==0) {
-	    g.abstract=gnew.abstract;
+		var gnew=msg.converted;
-	    g.extends=gnew.extends;
+		g.abstract=gnew.abstract;
-	    timestamp(g.abstract);
+		g.extends=gnew.extends;
-	    save_grammar(g);
+		timestamp(g.abstract);
+		save_grammar(g);
+	    }
+	    else {
+		var conc=g.concretes[ix-1];
+		var cnew=msg.converted.concretes[0];
+		conc.opens=cnew.opens;
+		conc.params=cnew.params;
+		conc.lincats=cnew.lincats;
+		conc.opers=cnew.opers;
+		conc.lins=cnew.lins;
+		timestamp(conc);
+		save_grammar(g);
+	    }
 	}
 	else replaceInnerHTML(dst,"unexpected parse result");
     }
@@ -507,7 +527,7 @@ function text_mode(g,file) {
     }
     function switch_to_text_mode() {
 	var ta=node("textarea",{class:"text_mode",rows:25,cols:80},
-		[text(show_abstract(g))])
+		    [text(show_module(g,ix))])
 	var timeout;
 	ta.onkeyup=function() {
 	    if(timeout) clearTimeout(timeout);
@@ -704,7 +724,7 @@ function draw_concrete(g,i) {
     kw_param.title="Parameter type definitions can be added here. [C.3.12]"
     var kw_oper=kw("oper")
     kw_oper.title="Operation definitions can be added here. [C.3.14]"
-    return div_id("file",
+    var file=div_id("file",
 		  [kw("concrete "),
 		   ident(g.basename),
 		   editable("span",ident(conc.langcode),g,
@@ -719,6 +739,11 @@ function draw_concrete(g,i) {
 		   indent([extensible([kw_oper,draw_opers(g,i)])]),
 		   exb_extra(g,i)
 		  ])
+    if(navigator.onLine) {
+	var mode_button=text_mode(g,file,i+1);
+	insertBefore(mode_button,file.firstChild)
+    }
+    return file;
 }
 
 var rgl_modules=["Paradigms","Syntax","Lexicon","Extra"];