Use LCLR algorithm for eliminating left-recursion, with lambda terms in SISR for getting trees right.

1 files changed, 59 insertions, 37 deletions

diff --git a/src/GF/Speech/SISR.hs b/src/GF/Speech/SISR.hs
index 4f37b6b82..6e035afb4 100644
--- a/src/GF/Speech/SISR.hs
+++ b/src/GF/Speech/SISR.hs
@@ -10,8 +10,8 @@
 --
 -----------------------------------------------------------------------------
 
-module GF.Speech.SISR (SISRFormat(..), SISRExpr(..), prSISR, 
-                       profileInitSISR, catSISR) where
+module GF.Speech.SISR (SISRFormat(..), SISRTag, prSISR, 
+                       topCatSISR, profileInitSISR, catSISR, profileFinalSISR) where
 
 import Data.List
 
@@ -20,11 +20,11 @@ import GF.Data.Utilities
 import GF.Formalism.CFG
 import GF.Formalism.Utilities (Symbol(..), NameProfile(..), Profile(..), forestName)
 import GF.Infra.Ident
+import GF.Speech.TransformCFG
 import GF.Speech.SRG
 
-
-infixl 8 :.
-infixr 1 :=
+import qualified GF.JavaScript.AbsJS   as JS
+import qualified GF.JavaScript.PrintJS as JS
 
 data SISRFormat = 
     -- SISR Working draft 1 April 2003
@@ -32,35 +32,57 @@ data SISRFormat =
     SISROld
  deriving Show
 
-data SISRExpr = SISRExpr := SISRExpr
-              | EThis 
-              | SISRExpr :. String 
-              | ERef String
-              | EStr String
-              | EApp SISRExpr [SISRExpr]
-              | ENew String [SISRExpr]
-  deriving Show
-
-prSISR :: SISRFormat -> [SISRExpr] -> String
-prSISR fmt = join "; " . map f
-  where
-   f e = 
-    case e of
-      x := y -> f x ++ "=" ++ f y
-      EThis -> "$" 
-      x :. y -> f x ++ "." ++ y
-      ERef y -> "$" ++ y
-      EStr s -> show s
-      EApp x ys -> f x ++ "(" ++ concat (intersperse "," (map f ys)) ++ ")"
-      ENew n ys -> "new " ++ n ++ "(" ++ concat (intersperse "," (map f ys)) ++ ")"
-
-profileInitSISR :: Name -> [SISRExpr]
-profileInitSISR (Name f prs) =
-    [(EThis :. "name") := (EStr (prIdent f))] ++
-    [(EThis :. ("arg" ++ show n)) := (EStr (argInit (prs!!n))) 
-                  | n <- [0..length prs-1]]
-  where argInit (Unify _) = "?"
-        argInit (Constant f) = maybe "?" prIdent (forestName f)
-
-catSISR :: SRGNT -> [SISRExpr]
-catSISR (c,slots) = [(EThis :. ("arg" ++ show s)) := (ERef c) | s <- slots]
+type SISRTag = [JS.Expr]
+
+
+prSISR :: SISRTag -> String
+prSISR = JS.printTree
+
+topCatSISR :: String -> String -> SISRFormat -> SISRTag
+topCatSISR i c fmt = [field (fmtOut fmt) i `ass` fmtRef fmt c]
+
+profileInitSISR :: CFTerm -> SISRFormat -> SISRTag
+profileInitSISR t fmt 
+    | null (usedChildren t) = []
+    | otherwise = [children `ass` JS.ENew (JS.Ident "Array") []]
+
+usedChildren :: CFTerm -> [Int]
+usedChildren (CFObj _ ts) = foldr union [] (map usedChildren ts)
+usedChildren (CFAbs _ x) = usedChildren x
+usedChildren (CFApp x y) = usedChildren x `union` usedChildren y
+usedChildren (CFRes i) = [i]
+usedChildren _ = []
+
+catSISR :: CFTerm -> SRGNT -> SISRFormat -> SISRTag
+catSISR t (c,i) fmt
+        | i `elem` usedChildren t = 
+            [JS.EIndex children (JS.EInt (fromIntegral i)) `ass` fmtRef fmt c]
+        | otherwise = []
+
+profileFinalSISR :: CFTerm -> SISRFormat -> SISRTag
+profileFinalSISR term fmt = [fmtOut fmt `ass` f term]
+  where f (CFObj n ts) = 
+            JS.ESeq $ [ret `ass` JS.ENew (JS.Ident "Object") [], 
+                           field ret "name" `ass` JS.EStr (prIdent n)] 
+                  ++ [field ret ("arg"++show i) `ass` f t 
+                          | (i,t) <- zip [0..] ts ]
+                  ++ [ret]
+          where ret = JS.EVar (JS.Ident "ret")
+        f (CFAbs v x) = JS.EFun [var v] [JS.SReturn (f x)]
+        f (CFApp x y) = JS.ECall (f x) [f y]
+        f (CFRes i) = JS.EIndex children (JS.EInt (fromIntegral i))
+        f (CFVar v) = JS.EVar (var v)
+        f (CFConst s) = JS.EStr s
+
+
+fmtOut SISROld = JS.EVar (JS.Ident "$")
+
+fmtRef SISROld c = JS.EVar (JS.Ident ("$" ++ c))
+
+children = JS.EVar (JS.Ident "c")
+
+var v = JS.Ident ("x" ++ show v)
+
+field x y = JS.EMember x (JS.Ident y)
+
+ass = JS.EAssign
\ No newline at end of file