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/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)