GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-05-13 05:02:50 -06:00
Code Issues Packages Projects Releases Wiki Activity

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

Browse Source
This commit is contained in:
bringert
2006-12-20 20:10:15 +00:00
parent c7df9f4167
commit f9621483a0
14 changed files with 541 additions and 308 deletions
Download Patch File Download Diff File Expand all files Collapse all files

90
src/GF/Speech/SISR.hs
View File

@@ -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
type SISRTag = [JS.Expr]
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)
prSISR :: SISRTag -> String
prSISR = JS.printTree
catSISR :: SRGNT -> [SISRExpr]
catSISR (c,slots) = [(EThis :. ("arg" ++ show s)) := (ERef c) | s <- slots]
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