summaryrefslogtreecommitdiff
path: root/src/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'src/compiler')
-rw-r--r--src/compiler/GFServer.hs23
-rw-r--r--src/compiler/SimpleEditor/Convert.hs71
-rw-r--r--src/compiler/SimpleEditor/JSON.hs47
-rw-r--r--src/compiler/SimpleEditor/Syntax.hs39
4 files changed, 170 insertions, 10 deletions
diff --git a/src/compiler/GFServer.hs b/src/compiler/GFServer.hs
index 3fcec3f4d..cb66137b2 100644
--- a/src/compiler/GFServer.hs
+++ b/src/compiler/GFServer.hs
@@ -21,10 +21,9 @@ import Network.URI(URI(..),parseURI)
import Network.Shed.Httpd(initServer,Request(..),Response(..),queryToArguments,
noCache)
--import qualified Network.FastCGI as FCGI -- from hackage direct-fastcgi
---import qualified Data.ByteString.Char8 as BS(pack,unpack,length)
import Network.CGI(handleErrors,liftIO)
import FastCGIUtils(outputJSONP,handleCGIErrors,stderrToFile)
-import Text.JSON(encode,showJSON,toJSObject)
+import Text.JSON(encode,showJSON,makeObj)
import System.IO.Silently(hCapture)
import System.Process(readProcessWithExitCode)
import System.Exit(ExitCode(..))
@@ -35,6 +34,7 @@ import qualified ExampleService as ES
import Data.Version(showVersion)
import Paths_gf(getDataDir,version)
import GF.Infra.BuildInfo (buildInfo)
+import SimpleEditor.Convert(parseModule)
import RunHTTP(cgiHandler)
--logFile :: FilePath
@@ -105,6 +105,7 @@ handle state0 cache execute1
-- "/stop" ->
-- "/start" ->
"/gfshell" -> inDir qs $ look "command" . command
+ "/parse" -> parse qs
"/cloud" -> inDir qs $ look "command" . cloud
'/':rpath ->
case (takeDirectory path,takeFileName path,takeExtension path) of
@@ -157,6 +158,8 @@ handle state0 cache execute1
let state' = maybe state (flip (M.insert dir) state) st'
return (state',ok200 output)
+ parse qs = return (state,json200 (makeObj (map parseModule qs)))
+
cloud dir cmd qs =
case cmd of
"make" -> make dir qs
@@ -226,14 +229,12 @@ handle state0 cache execute1
-- * Dynamic content
jsonresult cwd dir cmd (ecode,stdout,stderr) files =
- toJSObject [
- field "errorcode" (if ecode==ExitSuccess then "OK" else "Error"),
- field "command" cmd,
- field "output" (unlines [rel stderr,rel stdout]),
- field "minibar_url" ("/minibar/minibar.html?"++dir++pgf)]
+ makeObj [
+ prop "errorcode" (if ecode==ExitSuccess then "OK" else "Error"),
+ prop "command" cmd,
+ prop "output" (unlines [rel stderr,rel stdout]),
+ prop "minibar_url" ("/minibar/minibar.html?"++dir++pgf)]
where
- field n v = (n,showJSON v)
-
pgf = case files of
(abstract,_):_ -> "%20"++dropExtension abstract++".pgf"
_ -> ""
@@ -390,4 +391,6 @@ inputs = queryToArguments . fixplus
decode '+' = "%20" -- httpd-shed bug workaround
decode c = [c]
-mapFst f xys = [(f x,y)|(x,y)<-xys] \ No newline at end of file
+mapFst f xys = [(f x,y)|(x,y)<-xys]
+
+prop n v = (n,showJSON v)
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)
generated by cgit v1.2.3 (git 2.39.1) at 2026-07-19 09:25:12 +0000