From 9ebc42300419b8844b324bc429284bbfdee36048 Mon Sep 17 00:00:00 2001
From: hallgren <hallgren@chalmers.se>
Date: Wed, 22 Feb 2012 16:30:42 +0000
Subject: gfse: experimental support for editing concrete syntax in text mode

---
 src/compiler/SimpleEditor/Convert.hs | 70 +++++++++++++++++++++++++++++++++---
 1 file changed, 65 insertions(+), 5 deletions(-)

(limited to 'src/compiler/SimpleEditor/Convert.hs')

diff --git a/src/compiler/SimpleEditor/Convert.hs b/src/compiler/SimpleEditor/Convert.hs
index 93844ea18..037b04986 100644
--- a/src/compiler/SimpleEditor/Convert.hs
+++ b/src/compiler/SimpleEditor/Convert.hs
@@ -5,17 +5,19 @@ 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 Text.PrettyPrint(render)
 
 --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.Printer(ppParams,ppTerm,getAbs,TermPrintQual(..))
 import GF.Grammar.Parser(runP,pModDef)
 import GF.Grammar.Lexer(Posn(..))
 import GF.Data.ErrM
 
-import SimpleEditor.Syntax
+import SimpleEditor.Syntax as S
 import SimpleEditor.JSON
 
 
@@ -25,7 +27,7 @@ parseModule (path,source) =
      Left (Pn l c,msg) ->
          makeObj [prop "error" msg,
                   prop "location" (show l++":"++show c)]
-     Right mod -> case convAbstract mod of
+     Right mod -> case convModule mod of
                     Ok g -> makeObj [prop "converted" g]
                     Bad msg -> makeObj [prop "parsed" msg]
 
@@ -33,11 +35,19 @@ parseModule (path,source) =
 convAbstractFile path =
     appIOE (fmap encode . convAbstract =<< getSourceModule noOptions path)
 -}
+
+convModule m@(modid,src) =
+  if isModAbs src
+  then convAbstract m
+  else if isModCnc src
+       then convConcrete m
+       else fail "An abstract or concrete syntax module was expected"
+
 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)
+     (cats,funs) <- convAbsJments (jments src)
      let startcat = head (cats++["-"]) -- !!!
      return $ Grammar (convId modid) extends (Abstract startcat cats funs) []
 
@@ -45,9 +55,9 @@ convExtends = mapM convExtend
 convExtend (modid,MIAll) = return (convId modid)
 convExtend _ = fail "unsupported module extension"
 
-convJments jments = foldM convJment ([],[]) (Map.toList jments)
+convAbsJments jments = foldM convAbsJment ([],[]) (Map.toList jments)
 
-convJment (cats,funs) (name,jment) =
+convAbsJment (cats,funs) (name,jment) =
   case jment of
     AbsCat octx -> do unless (null (maybe [] unLoc octx)) $
                              fail "category with context"
@@ -69,3 +79,53 @@ convSimpleType (Vr id) = return (convId id)
 convSimpleType t = fail "unsupported type"
 
 convId = showIdent
+
+convConcrete (modid,src) =
+  do unless (isModCnc src) $ fail "Concrete syntax expected"
+     unless (isCompleteModule src) $ fail "A complete concrete syntax expected"
+     extends <- convExtends (mextend src)
+     opens <- convOpens (mopens src)
+     js <- convCncJments (jments src)
+     let ps  = [p  | Pa p <-js]
+         lcs = [lc | LC lc<-js]
+         os  = [o  | Op o <-js]
+         ls  = [l  | Li l <-js]
+         langcode = "" -- !!!
+         conc = Concrete langcode opens ps lcs os ls
+         abs = Abstract "-" [] [] -- dummy
+     return $ Grammar (convId modid) extends abs [conc]
+
+convOpens = mapM convOpen
+
+convOpen o =
+  case o of
+    OSimple id -> return (convId id)
+    _ -> fail "unsupported module open"
+
+
+data CncJment = Pa S.Param | LC Lincat | Op Oper | Li Lin
+
+convCncJments = mapM convCncJment . Map.toList
+
+convCncJment (name,jment) =
+  case jment of
+    ResParam ops _ ->
+      return $ Pa $ Param i (maybe "" (render . ppParams q . unLoc) ops)
+    CncCat (Just (L _ typ)) Nothing Nothing _ ->
+      return $ LC $ Lincat i (render $ ppTerm q 0 typ)
+    ResOper oltyp (Just lterm) -> return $ Op $ Oper lhs rhs
+      where
+        lhs = i++maybe "" ((" : "++) . render . ppTerm q 0 . unLoc) oltyp
+        rhs = " = "++render (ppTerm q 0 (unLoc lterm))
+    CncFun _ (Just ldef) Nothing _ ->
+      do let (xs,e') = getAbs (unLoc ldef)
+             lin = render $ ppTerm q 0 e'
+         args <- mapM convBind xs
+         return $ Li $ Lin i args lin
+    _ -> fail $ "unsupported judgement form: "++show jment
+  where
+    i = convId name
+    q = Unqualified
+
+convBind (Explicit,v) = return $ convId v
+convBind (Implicit,v) = fail "implicit binding not supported"
-- 
cgit v1.2.3