move gf.cabal and all compiler dependent files into src/compiler

src/compiler/GF/Server/SimpleEditor/Convert.hs

@@ -0,0 +1,161 @@
+{-# LANGUAGE NoMonomorphismRestriction #-}
+module GF.Server.SimpleEditor.Convert where
+
+import Control.Monad(unless,foldM,ap,mplus)
+import Data.List(sortBy)
+import Data.Function(on)
+import qualified Data.Map as Map
+import Text.JSON(makeObj) --encode
+import GF.Text.Pretty(render,(<+>))
+
+import qualified Data.ByteString.UTF8 as UTF8(fromString)
+
+import GF.Infra.Option(optionsGFO)
+import GF.Infra.Ident(showIdent,ModuleName(..))
+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 PGF2(Literal(LStr))
+
+import GF.Server.SimpleEditor.Syntax as S
+import GF.Server.SimpleEditor.JSON
+
+
+parseModule (path,source) =
+   (path.=) $
+   case runP pModDef (UTF8.fromString source) of
+     Left (Pn l c,msg) ->
+         makeObj ["error".=msg, "location".= show l++":"++show c]
+     Right mod -> case convModule mod of
+                    Ok g -> makeObj ["converted".=g]
+                    Bad msg -> makeObj ["parsed".=msg]
+
+{-
+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)
+     (cats0,funs0) <- convAbsJments (jments src)
+     let cats = reverse cats0
+         funs = reverse funs0
+         flags = optionsGFO (mflags src)
+         startcat =
+           case lookup "startcat" flags of
+             Just (LStr cat) -> cat
+             _               -> "-"
+     return $ Grammar (convModId modid) extends (Abstract startcat cats funs) []
+
+convExtends = mapM convExtend
+convExtend (modid,MIAll) = return (convModId modid)
+convExtend _ = fail "unsupported module extension"
+
+convAbsJments jments = foldM convAbsJment ([],[]) (jmentList jments)
+
+convAbsJment (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
+convModId (MN m) = convId m
+
+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 (convModId modid) extends abs [conc]
+
+convOpens = mapM convOpen
+
+convOpen o =
+  case o of
+    OSimple id -> return (convModId id)
+    _ -> fail "unsupported module open"
+
+
+data CncJment = Pa S.Param | LC Lincat | Op Oper | Li Lin | Ignored
+
+convCncJments = mapM convCncJment . jmentList
+
+convCncJment (name,jment) =
+  case jment of
+    ResParam ops _ ->
+      return $ Pa $ Param i (maybe "" (render . ppParams q . unLoc) ops)
+    ResValue _ _ -> return Ignored
+    CncCat (Just (L _ typ)) Nothing Nothing pprn _ -> -- ignores printname !!
+      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))
+    ResOverload [] defs -> return $ Op $ Oper lhs rhs
+      where
+        lhs = i
+        rhs = render $ " = overload"<+>ppTerm q 0 r
+        r =  R [(lab,(Just ty,fu)) | (L _ ty,L _ fu) <-defs]
+        lab = ident2label name
+    CncFun _ (Just ldef) pprn _ -> -- ignores printname !!
+      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"
+
+jmentList = sortBy (compare `on` (jmentLocation.snd)) . Map.toList
+
+jmentLocation jment =
+  case jment of
+    AbsCat ctxt      -> fmap loc ctxt
+    AbsFun ty _ _ _  -> fmap loc ty
+    ResParam ops _   -> fmap loc ops
+    CncCat ty _ _ _ _ ->fmap loc ty
+    ResOper ty rhs   -> fmap loc rhs `mplus` fmap loc ty
+    CncFun _ rhs _ _ -> fmap loc rhs
+    _ -> Nothing
+
+
+loc (L l _) = l

src/compiler/GF/Server/SimpleEditor/JSON.hs

@@ -0,0 +1,50 @@
+module GF.Server.SimpleEditor.JSON where
+
+import Text.JSON
+
+import GF.Server.SimpleEditor.Syntax
+
+
+instance JSON Grammar where
+  showJSON (Grammar name extends abstract concretes) =
+    makeObj ["basename".=name, "extends".=extends,
+             "abstract".=abstract, "concretes".=concretes]
+  readJSON = error "Grammar.readJSON intentionally not defined"
+
+instance JSON Abstract where
+  showJSON (Abstract startcat cats funs) =
+    makeObj ["startcat".=startcat, "cats".=cats, "funs".=funs]
+  readJSON = error "Abstract.readJSON intentionally not defined"
+
+instance JSON Fun where 
+  showJSON (Fun   name typ) = signature  name typ
+  readJSON = error "Fun.readJSON intentionally not defined"
+
+instance JSON Param where 
+  showJSON (Param name rhs) = definition name rhs
+  readJSON = error "Param.readJSON intentionally not defined"
+
+instance JSON Oper where 
+  showJSON (Oper  name rhs) = definition name rhs
+  readJSON = error "Oper.readJSON intentionally not defined"
+
+signature  name typ = makeObj ["name".=name,"type".=typ]
+definition name rhs = makeObj ["name".=name,"rhs".=rhs]
+
+instance JSON Concrete where
+  showJSON (Concrete langcode opens params lincats opers lins) =
+    makeObj ["langcode".=langcode, "opens".=opens,
+              "params".=params, "opers".=opers,
+             "lincats".=lincats, "lins".=lins]
+  readJSON = error "Concrete.readJSON intentionally not defined"
+
+instance JSON Lincat where
+  showJSON (Lincat cat lintype) = makeObj ["cat".=cat, "type".=lintype]
+  readJSON = error "Lincat.readJSON intentionally not defined"
+
+instance JSON Lin where
+  showJSON (Lin fun args lin) = makeObj ["fun".=fun, "args".=args, "lin".=lin]
+  readJSON = error "Lin.readJSON intentionally not defined"
+
+infix 1 .=
+name .= v = (name,showJSON v)

src/compiler/GF/Server/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 GF.Server.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)