GFCCtoJS in Devel

devel/koe/Koe.gf

@@ -1,6 +1,6 @@
 abstract Koe = {
 
-flags starcat = S ;
+flags startcat = S ;
 
 cat S ; NP ; VP ;
 

src/GF/Devel/GFC.hs

@@ -2,6 +2,7 @@ module Main where
 
 import GF.Devel.Compile
 import GF.Devel.GrammarToGFCC
+import GF.Devel.GFCCtoJS
 import GF.GFCC.OptimizeGFCC
 import GF.GFCC.CheckGFCC
 import GF.GFCC.DataGFCC
@@ -24,6 +25,12 @@ main = do
       let target = abs ++ ".gfcc"
       writeFile target (printGFCC gc)
       putStrLn $ "wrote file " ++ target
+      if oElem (iOpt "js") opts 
+        then do
+          let js = abs ++ ".js"
+          writeFile js (gfcc2js gc)
+          putStrLn $ "wrote file " ++ js
+        else return ()
     _ -> do
       mapM_ (batchCompile opts) (map return fs)
       putStrLn "Done."

src/GF/Devel/GFCCtoJS.hs

@@ -0,0 +1,79 @@
+module GF.Devel.GFCCtoJS (gfcc2js) where
+
+import qualified GF.GFCC.Macros as M
+import qualified GF.GFCC.DataGFCC as D
+import qualified GF.GFCC.AbsGFCC as C
+import qualified GF.JavaScript.AbsJS as JS
+import qualified GF.JavaScript.PrintJS as JS
+
+import GF.Text.UTF8
+import GF.Data.ErrM
+import GF.Infra.Option
+
+import Control.Monad (mplus)
+import Data.Maybe (fromMaybe)
+import qualified Data.Map as Map
+
+gfcc2js :: D.GFCC -> String
+gfcc2js gfcc =
+  encodeUTF8 $ JS.printTree $ JS.Program $ abstract2js start n as ++ 
+  concatMap (concrete2js n) cs
+ where
+   n  = D.absname gfcc
+   as = D.abstract gfcc
+   cs = Map.assocs (D.concretes gfcc)
+   start = M.lookAbsFlag gfcc (M.cid "startcat")
+
+abstract2js :: String -> C.CId -> D.Abstr -> [JS.Element]
+abstract2js start (C.CId n) ds = 
+    [JS.ElStmt $ JS.SDeclOrExpr $ JS.Decl [JS.DInit a (new "Abstract" [JS.EStr start])]] 
+    ++ concatMap (absdef2js a) (Map.assocs (D.funs ds))
+  where a = JS.Ident n
+
+absdef2js :: JS.Ident -> (C.CId,(C.Type,C.Exp)) -> [JS.Element]
+absdef2js a (C.CId f,(typ,_)) =
+  let (args,C.CId cat) = M.catSkeleton typ in 
+    [JS.ElStmt $ JS.SDeclOrExpr $ JS.DExpr $ JS.ECall (JS.EMember (JS.EVar a) (JS.Ident "addType")) 
+           [JS.EStr f, JS.EArray [JS.EStr x | C.CId x <- args], JS.EStr cat]]
+
+concrete2js :: C.CId -> (C.CId,D.Concr) -> [JS.Element]
+concrete2js (C.CId a) (C.CId c, cnc) =
+    [JS.ElStmt $ JS.SDeclOrExpr $ JS.Decl [JS.DInit l (new "Concrete" [JS.EVar (JS.Ident a)])]] 
+    ++ concatMap (cncdef2js l) ds
+  where 
+   l  = JS.Ident c
+   ds = Map.assocs $ D.lins cnc
+
+cncdef2js :: JS.Ident -> (C.CId,C.Term) -> [JS.Element]
+cncdef2js l (C.CId f, t) = 
+    [JS.ElStmt $ JS.SDeclOrExpr $ JS.DExpr $ JS.ECall (JS.EMember (JS.EVar l) (JS.Ident "addRule")) [JS.EStr f, JS.EFun [children] [JS.SReturn (term2js l t)]]]
+
+term2js :: JS.Ident -> C.Term -> JS.Expr
+term2js l t = f t
+  where 
+  f t = 
+    case t of
+      C.R xs           -> new "Arr" (map f xs)
+      C.P x y          -> JS.ECall (JS.EMember (f x) (JS.Ident "sel")) [f y]
+      C.S xs           -> new "Seq" (map f xs)
+      C.K t            -> tokn2js t
+      C.V i            -> JS.EIndex (JS.EVar children) (JS.EInt i)
+      C.C i            -> new "Int" [JS.EInt i]
+      C.F (C.CId f)    -> JS.ECall (JS.EMember (JS.EVar l) (JS.Ident "rule")) [JS.EStr f, JS.EVar children]
+      C.FV xs          -> new "Variants" (map f xs)
+      C.W str x        -> new "Suffix" [JS.EStr str, f x]
+      C.RP x y         -> new "Rp" [f x, f y]
+      C.TM             -> new "Meta" []
+
+tokn2js :: C.Tokn -> JS.Expr
+tokn2js (C.KS s) = new "Str" [JS.EStr s]
+tokn2js (C.KP ss vs) = new "Seq" (map JS.EStr ss) -- FIXME
+
+argIdent :: Integer -> JS.Ident
+argIdent n = JS.Ident ("x" ++ show n)
+
+children :: JS.Ident
+children = JS.Ident "cs"
+
+new :: String -> [JS.Expr] -> JS.Expr
+new f xs = JS.ENew (JS.Ident f) xs

src/GF/GFCC/Macros.hs

@@ -57,8 +57,11 @@ valCat :: Type -> CId
 valCat ty = case ty of
   DTyp _ val _ -> val
 
+cid :: String -> CId
+cid = CId
+
 wildCId :: CId
-wildCId = CId "_"
+wildCId = cid "_"
 
 exp0 :: Exp
 exp0 = tree (AM 0) []