3 files changed, 157 insertions, 0 deletions
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)