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.

1 files changed, 71 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