diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/GF/Devel/GFC.hs | 7 | ||||
| -rw-r--r-- | src/GF/Devel/GFCCtoJS.hs | 79 | ||||
| -rw-r--r-- | src/GF/GFCC/Macros.hs | 5 |
3 files changed, 90 insertions, 1 deletions
diff --git a/src/GF/Devel/GFC.hs b/src/GF/Devel/GFC.hs index 0d8df98a1..206d54206 100644 --- a/src/GF/Devel/GFC.hs +++ b/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." diff --git a/src/GF/Devel/GFCCtoJS.hs b/src/GF/Devel/GFCCtoJS.hs new file mode 100644 index 000000000..bed71e10a --- /dev/null +++ b/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 diff --git a/src/GF/GFCC/Macros.hs b/src/GF/GFCC/Macros.hs index a44250e98..f75941f53 100644 --- a/src/GF/GFCC/Macros.hs +++ b/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) [] |