diff --git a/src/compiler/GFServer.hs b/src/compiler/GFServer.hs index 3fcec3f4d..cb66137b2 100644 --- a/src/compiler/GFServer.hs +++ b/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] \ No newline at end of file +mapFst f xys = [(f x,y)|(x,y)<-xys] + +prop n v = (n,showJSON v) diff --git a/src/compiler/SimpleEditor/Convert.hs b/src/compiler/SimpleEditor/Convert.hs new file mode 100644 index 000000000..93844ea18 --- /dev/null +++ b/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 diff --git a/src/compiler/SimpleEditor/JSON.hs b/src/compiler/SimpleEditor/JSON.hs new file mode 100644 index 000000000..3c15e731b --- /dev/null +++ b/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) diff --git a/src/compiler/SimpleEditor/Syntax.hs b/src/compiler/SimpleEditor/Syntax.hs new file mode 100644 index 000000000..4a5eb6da8 --- /dev/null +++ b/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) diff --git a/src/www/gfse/cloud2.js b/src/www/gfse/cloud2.js index 8d33315bd..02af9d91a 100644 --- a/src/www/gfse/cloud2.js +++ b/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) { diff --git a/src/www/gfse/editor.js b/src/www/gfse/editor.js index b630f69ab..60abf2142 100644 --- a/src/www/gfse/editor.js +++ b/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) {