gfse: edit abstract syntax in text mode with instant syntax error reporting

This is an experimental feature. It requires server support for parsing and is
thus not available while offline, unlike most other editing functionality.

src/compiler/GFServer.hs

@@ -21,10 +21,9 @@ import Network.URI(URI(..),parseURI)
 import Network.Shed.Httpd(initServer,Request(..),Response(..),queryToArguments,
                           noCache)
 --import qualified Network.FastCGI as FCGI -- from hackage direct-fastcgi
---import qualified Data.ByteString.Char8 as BS(pack,unpack,length)
 import Network.CGI(handleErrors,liftIO)
 import FastCGIUtils(outputJSONP,handleCGIErrors,stderrToFile)
-import Text.JSON(encode,showJSON,toJSObject)
+import Text.JSON(encode,showJSON,makeObj)
 import System.IO.Silently(hCapture)
 import System.Process(readProcessWithExitCode)
 import System.Exit(ExitCode(..))
@@ -35,6 +34,7 @@ import qualified ExampleService as ES
 import Data.Version(showVersion)
 import Paths_gf(getDataDir,version)
 import GF.Infra.BuildInfo (buildInfo)
+import SimpleEditor.Convert(parseModule)
 import RunHTTP(cgiHandler)
 
 --logFile :: FilePath
@@ -105,6 +105,7 @@ handle state0 cache execute1
 --         "/stop" ->
 --         "/start" ->
            "/gfshell" -> inDir qs $ look "command" . command
+           "/parse" -> parse qs
            "/cloud" -> inDir qs $ look "command" . cloud
            '/':rpath ->
              case (takeDirectory path,takeFileName path,takeExtension path) of
@@ -157,6 +158,8 @@ handle state0 cache execute1
          let state' = maybe state (flip (M.insert dir) state) st'
          return (state',ok200 output)
 
+    parse qs = return (state,json200 (makeObj (map parseModule qs)))
+
     cloud dir cmd qs =
       case cmd of
         "make" -> make dir qs
@@ -226,14 +229,12 @@ handle state0 cache execute1
 -- * Dynamic content
 
 jsonresult cwd dir cmd (ecode,stdout,stderr) files =
-  toJSObject [
-    field "errorcode" (if ecode==ExitSuccess then "OK" else "Error"),
-    field "command" cmd,
-    field "output" (unlines [rel stderr,rel stdout]),
-    field "minibar_url" ("/minibar/minibar.html?"++dir++pgf)]
+  makeObj [
+    prop "errorcode" (if ecode==ExitSuccess then "OK" else "Error"),
+    prop "command" cmd,
+    prop "output" (unlines [rel stderr,rel stdout]),
+    prop "minibar_url" ("/minibar/minibar.html?"++dir++pgf)]
   where
-    field n v = (n,showJSON v)
-
     pgf = case files of
             (abstract,_):_ -> "%20"++dropExtension abstract++".pgf"
             _ -> ""
@@ -390,4 +391,6 @@ inputs = queryToArguments . fixplus
     decode '+' = "%20" -- httpd-shed bug workaround
     decode c   = [c]
 
-mapFst f xys = [(f x,y)|(x,y)<-xys]
+mapFst f xys = [(f x,y)|(x,y)<-xys]
+
+prop n v = (n,showJSON v)

src/compiler/SimpleEditor/Convert.hs

@@ -0,0 +1,71 @@
+{-# LANGUAGE NoMonomorphismRestriction #-}
+module SimpleEditor.Convert where
+
+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 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.Parser(runP,pModDef)
+import GF.Grammar.Lexer(Posn(..))
+import GF.Data.ErrM
+
+import SimpleEditor.Syntax
+import SimpleEditor.JSON
+
+
+parseModule (path,source) =
+   prop path $ 
+   case runP pModDef (BS.pack source) of
+     Left (Pn l c,msg) ->
+         makeObj [prop "error" msg,
+                  prop "location" (show l++":"++show c)]
+     Right mod -> case convAbstract mod of
+                    Ok g -> makeObj [prop "converted" g]
+                    Bad msg -> makeObj [prop "parsed" msg]
+
+{-
+convAbstractFile path =
+    appIOE (fmap encode . convAbstract =<< getSourceModule noOptions path)
+-}
+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)
+     let startcat = head (cats++["-"]) -- !!!
+     return $ Grammar (convId modid) extends (Abstract startcat cats funs) []
+
+convExtends = mapM convExtend
+convExtend (modid,MIAll) = return (convId modid)
+convExtend _ = fail "unsupported module extension"
+
+convJments jments = foldM convJment ([],[]) (Map.toList jments)
+
+convJment (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

src/compiler/SimpleEditor/JSON.hs

@@ -0,0 +1,47 @@
+module SimpleEditor.JSON where
+
+import Text.JSON
+
+import SimpleEditor.Syntax
+
+
+instance JSON Grammar where
+  showJSON (Grammar name extends abstract concretes) =
+    makeObj [prop "basename" name,
+             prop "extends" extends,
+             prop "abstract" abstract,
+             prop "concretes" concretes]
+
+instance JSON Abstract where
+  showJSON (Abstract startcat cats funs) =
+    makeObj [prop "startcat" startcat,
+             prop "cats" cats,
+             prop "funs" funs]
+
+instance JSON Fun   where showJSON (Fun   name typ) = signature  name typ
+instance JSON Param where showJSON (Param name rhs) = definition name rhs
+instance JSON Oper  where showJSON (Oper  name rhs) = definition name rhs
+
+signature  name typ = makeObj [prop "name" name,prop "type" typ]
+definition name rhs = makeObj [prop "name" name,prop "rhs" rhs]
+
+instance JSON Concrete where
+  showJSON (Concrete langcode opens params lincats opers lins) =
+    makeObj [prop "langcode" langcode,
+             prop "opens" opens,
+             prop "params" params,
+             prop "lincats" lincats,
+             prop "opers" opers,
+             prop "lins" lins]
+
+instance JSON Lincat where
+  showJSON (Lincat cat lintype) =
+    makeObj [prop "cat" cat,prop "type" lintype]
+
+instance JSON Lin where
+  showJSON (Lin fun args lin) =
+    makeObj [prop "fun" fun,
+             prop "args" args,
+             prop "lin" lin]
+
+prop name v = (name,showJSON v)

src/compiler/SimpleEditor/Syntax.hs

@@ -0,0 +1,39 @@
+{-
+Abstract syntax for the small subset of GF grammars supported
+in gfse, the JavaScript-based simple grammar editor.
+-}
+module SimpleEditor.Syntax where
+
+type Id    = String -- all sorts of identifiers
+type ModId = Id -- module name
+type Cat   = Id -- category name
+type FunId = Id -- function name
+type Type  = [Cat] -- [Cat_1,...,Cat_n] means Cat_1 -> ... -> Cat_n
+
+data Grammar  = Grammar { basename :: ModId,
+                          extends  :: [ModId],
+                          abstract :: Abstract,
+                          concretes:: [Concrete] }
+                deriving Show
+
+data Abstract = Abstract { startcat:: Cat, cats:: [Cat], funs:: [Fun] }
+                deriving Show
+data Fun      = Fun      { fname:: FunId, ftype:: Type }
+                deriving Show
+
+data Concrete = Concrete { langcode:: Id,
+                           opens:: [ModId],
+		           params:: [Param],
+		           lincats:: [Lincat],
+		           opers:: [Oper],
+		           lins:: [Lin] }
+                deriving Show
+
+data Param  = Param  {pname:: Id, prhs:: String}              deriving Show
+data Lincat = Lincat {cat  :: Cat, lintype:: Term}            deriving Show
+data Oper   = Oper   {oname:: Lhs, orhs:: Term}               deriving Show
+data Lin    = Lin    {fun  :: FunId, args:: [Id], lin:: Term} deriving Show
+
+type Lhs = String -- name and type of oper,
+                  -- e.g "regN : Str -> { s:Str,g:Gender} ="
+type Term = String -- arbitrary GF term (not parsed by the editor)

src/www/gfse/cloud2.js

@@ -193,6 +193,12 @@ function gfshell(cmd,cont) {
     })
 }
 
+// Check the syntax of a source module
+function check_module(path,source,cont) {
+    var enc=encodeURIComponent;
+    http_get_json("/parse?"+enc(path)+"="+enc(source),cont)
+}
+
 // Check the syntax of an expression
 function check_exp(s,cont) {
     function check(gf_message) {

src/www/gfse/editor.js

@@ -453,7 +453,7 @@ function draw_abstract(g) {
 	timestamp(g.abstract);
 	save_grammar(g);
     }
-    return div_id("file",
+    var file=div_id("file",
 		  [kw("abstract "),ident(g.basename),sep(" = "),
 		   draw_timestamp(g.abstract),
 		   draw_extends(g),
@@ -462,6 +462,65 @@ function draw_abstract(g) {
 				       indent(draw_cats(g))]),
 			   extensible([kw_fun,
 				       indent_sortable(draw_funs(g),sort_funs)])])]);
+    if(navigator.onLine) {
+	var mode_button=text_mode(g,file);
+	insertBefore(mode_button,file.firstChild)
+    }
+    return file;
+}
+
+function text_mode(g,file) {
+    var path=g.basename+".gf"
+    function switch_to_guided_mode() {
+	edit_grammar(g); // !!
+    }
+    function store_parsed(parse_results) {
+	var dst=compiler_output;
+	var msg=parse_results[path];
+	if(dst) dst.innerHTML=""
+	console.log(msg)
+	if(dst && msg.error)
+	    dst.appendChild(span_class("error_message",
+				       text(msg.location+": "+msg.error)))
+	else if(dst && msg.parsed)
+	    dst.innerHTML=
+	      "Accepted by GF, but not by this editor ("+msg.parsed+")"
+	else if(msg.converted) {
+	    var gnew=msg.converted;
+	    g.abstract=gnew.abstract;
+	    g.extends=gnew.extends;
+	    timestamp(g.abstract);
+	    save_grammar(g);
+	}
+	else if(dst) dst.innerHTML="unexpected parse result";
+    }
+    var last_source=show_abstract(g);
+    function parse(source) {
+	if(source!=last_source) {
+	    if(navigator.onLine) {
+		//compiler_output.innerHTML="";
+		last_source=source;
+		check_module(path,source,store_parsed)
+	    }
+	    else if(compiler_output)
+		compiler_output.innerHTML="Offline, edits will not be saved"
+	}
+    }
+    function switch_to_text_mode() {
+	var ta=node("textarea",{class:"text_mode",rows:25,cols:80},
+		[text(show_abstract(g))])
+	var timeout;
+	ta.onkeyup=function() {
+	    if(timeout) clearTimeout(timeout);
+	    timeout=setTimeout(function(){parse(ta.value)},400)
+	}
+	var mode_button=div_class("right",[button("Guided mode",switch_to_guided_mode)])
+	file.innerHTML="";
+	appendChildren(file,[mode_button,ta])
+	ta.focus();
+    }
+    var mode_button=div_class("right",[button("Text mode",switch_to_text_mode)])
+    return mode_button;
 }
 
 function add_cat(g,el) {