GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-09 04:59:31 -06:00
Code Issues Packages Projects Releases Wiki Activity

simplify GFCC syntax

Browse Source
This commit is contained in:
kr_angelov
2006-12-28 16:35:16 +00:00
parent 61ae1920b3
commit c70fa0831e
6 changed files with 66 additions and 78 deletions
Download Patch File Download Diff File Expand all files Collapse all files

61
src/GF/Canon/CanonToGFCC.hs
View File

@@ -82,7 +82,7 @@ mkType t = case GM.catSkeleton t of
mkCType :: CType -> C.Term
mkCType t = case t of
TInts i -> C.C i
TInts i -> C.C (fromInteger i)
-- record parameter alias - created in gfc preprocessing
RecType [Lbg (L (IC "_")) i, Lbg (L (IC "__")) t] -> C.RP (mkCType i) (mkCType t)
RecType rs -> C.R [mkCType t | Lbg _ t <- rs]
@@ -90,13 +90,13 @@ mkCType t = case t of
TStr -> C.S []
where
getI pt = case pt of
C.C i -> fromInteger i
C.C i -> i
C.RP i _ -> getI i
mkTerm :: Term -> C.Term
mkTerm tr = case tr of
Arg (A _ i) -> C.V i
EInt i -> C.C i
Arg (A _ i) -> C.V (fromInteger i)
EInt i -> C.C (fromInteger i)
-- record parameter alias - created in gfc preprocessing
R [Ass (L (IC "_")) i, Ass (L (IC "__")) t] -> C.RP (mkTerm i) (mkTerm t)
-- ordinary record
@@ -111,14 +111,14 @@ mkTerm tr = case tr of
S t p -> C.P (mkTerm t) (mkTerm p)
C s t -> C.S [mkTerm x | x <- [s,t]]
FV ts -> C.FV [mkTerm t | t <- ts]
K (KS s) -> C.K (C.KS s)
K (KP ss _) -> C.K (C.KP ss []) ---- TODO: prefix variants
K (KS s) -> C.KS s
K (KP ss _) -> C.KP ss [] ---- TODO: prefix variants
E -> C.S []
Par _ _ -> prtTrace tr $ C.C 66661 ---- for debugging
_ -> C.S [C.K (C.KS (A.prt tr +++ "66662"))] ---- for debugging
_ -> C.S [C.KS (A.prt tr +++ "66662")] ---- for debugging
where
mkLab (L (IC l)) = case l of
'_':ds -> (read ds) :: Integer
'_':ds -> (read ds) :: Int
_ -> prtTrace tr $ 66663
-- return just one module per language
@@ -406,24 +406,30 @@ optConcrete defs = subex
-- suffix sets can later be shared by subex elim
optTerm :: C.Term -> C.Term
optTerm tr = case tr of
C.R ts@(_:_:_) | all isK ts -> mkSuff $ optToks [s | C.K (C.KS s) <- ts]
C.R ts -> C.R $ map optTerm ts
C.P t v -> C.P (optTerm t) v
optTerm tr =
case tr of
C.R ts -> mkSuff ts
C.P t v -> C.P (optTerm t) v
C.L x t -> C.L x (optTerm t)
_ -> tr
where
optToks ss = prf : suffs where
prf = pref (head ss) (tail ss)
suffs = map (drop (length prf)) ss
pref cand ss = case ss of
s1:ss2 -> if isPrefixOf cand s1 then pref cand ss2 else pref (init cand) ss
_ -> cand
isK t = case t of
C.K (C.KS _) -> True
_ -> False
mkSuff ("":ws) = C.R (map (C.K . C.KS) ws)
mkSuff (p:ws) = C.W p (C.R (map (C.K . C.KS) ws))
tr -> tr
where
mkSuff ts@(C.KS s : ts1@(_:_)) =
case pref s ts1 of
Nothing -> C.R (map optTerm ts)
Just "" -> C.R ts
Just prf -> let len = length prf
in C.W prf [drop len s | C.KS s <- ts]
where
pref cand [] = Just cand
pref cand (t:ts) =
case t of
C.KS s -> pref (getPrefix cand s) ts
_ -> Nothing
where
getPrefix cand s
| isPrefixOf cand s = cand
| otherwise = getPrefix (init cand) s
mkSuff ts = C.R (map optTerm ts)
-- common subexpression elimination; see ./Subexpression.hs for the idea
@@ -448,7 +454,7 @@ addSubexpConsts tree lins =
_ -> case t of
C.R ts -> C.R $ map (recomp f) ts
C.S ts -> C.S $ map (recomp f) ts
C.W s t -> C.W s (recomp f t)
C.W s ss -> C.W s ss
C.P t p -> C.P (recomp f t) (recomp f p)
C.RP t p -> C.RP (recomp f t) (recomp f p)
C.L x t -> C.L x (recomp f t)
@@ -477,8 +483,7 @@ collectSubterms t = case t of
C.S ts -> do
mapM collectSubterms ts
add t
C.W s u -> do
collectSubterms u
C.W s ts -> do
add t
C.P p u -> do
collectSubterms p

9
src/GF/Canon/CanonToJS.hs
View File

@@ -53,22 +53,19 @@ term2js l t = f t
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.KS s -> new "Str" [JS.EStr s]
C.KP ss vs -> new "Seq" (map JS.EStr ss) -- FIXME
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.W str ss -> new "Suffix" (JS.EStr str : map JS.EStr ss)
C.RP x y -> new "Rp" [f x, f y]
C.TM -> new "Meta" []
argIdent :: Integer -> JS.Ident
argIdent n = JS.Ident ("x" ++ show n)
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
children :: JS.Ident
children = JS.Ident "cs"

15
src/GF/Canon/GFCC/AbsGFCC.hs
View File

@@ -47,24 +47,19 @@ data Term =
R [Term]
| P Term Term
| S [Term]
| K Tokn
| V Integer
| C Integer
| KS String
| KP [String] [Variant]
| V Int
| C Int
| F CId
| FV [Term]
| W String Term
| W String [String]
| RP Term Term
| TM
| L CId Term
| BV CId
deriving (Eq,Ord,Show)
data Tokn =
KS String
| KP [String] [Variant]
deriving (Eq,Ord,Show)
data Variant =
Var [String] [String]
deriving (Eq,Ord,Show)

36
src/GF/Canon/GFCC/DataGFCC.hs
View File

@@ -46,10 +46,9 @@ realize :: Term -> String
realize trm = case trm of
R ts -> realize (ts !! 0)
S ss -> unwords $ Prelude.map realize ss
K t -> case t of
KS s -> s
KP s _ -> unwords s ---- prefix choice TODO
W s t -> s ++ realize t
KS s -> s
KP s _ -> unwords s ---- prefix choice TODO
W s ss -> s ++ (ss !! 0)
FV ts -> realize (ts !! 0) ---- other variants TODO
RP _ r -> realize r
TM -> "?"
@@ -59,9 +58,9 @@ linExp :: GFCC -> CId -> Exp -> Term
linExp mcfg lang tree@(Tr at trees) =
case at of
AC fun -> comp (Prelude.map lin trees) $ look fun
AS s -> R [kks (show s)] -- quoted
AI i -> R [kks (show i)]
AF d -> R [kks (show d)]
AS s -> R [KS (show s)] -- quoted
AI i -> R [KS (show i)]
AF d -> R [KS (show d)]
AM -> TM
where
lin = linExp mcfg lang
@@ -72,19 +71,16 @@ exp0 :: Exp
exp0 = Tr (AS "NO_PARSE") []
term0 :: CId -> Term
term0 (CId s) = R [kks ("#" ++ s ++ "#")]
kks :: String -> Term
kks = K . KS
term0 (CId s) = R [KS ("#" ++ s ++ "#")]
compute :: GFCC -> CId -> [Term] -> Term -> Term
compute mcfg lang args = comp where
comp trm = case trm of
P r p -> proj (comp r) (comp p)
RP i t -> RP (comp i) (comp t)
W s t -> W s (comp t)
W s ss -> W s ss
R ts -> R $ Prelude.map comp ts
V i -> idx args (fromInteger i) -- already computed
V i -> idx args i -- already computed
F c -> comp $ look c -- not computed (if contains argvar)
FV ts -> FV $ Prelude.map comp ts
S ts -> S $ Prelude.filter (/= S []) $ Prelude.map comp ts
@@ -94,23 +90,19 @@ compute mcfg lang args = comp where
idx xs i = if i > length xs - 1 then trace "overrun !!\n" (last xs) else xs !! i
proj r p = case (r,p) of
(_, FV ts) -> FV $ Prelude.map (proj r) ts
(W s t, _) -> kks (s ++ getString (proj t p))
_ -> comp $ getField r (getIndex p)
getString t = case t of
K (KS s) -> s
_ -> trace ("ERROR in grammar compiler: string from "++ show t) "ERR"
proj r p = case p of
FV ts -> FV $ Prelude.map (proj r) ts
_ -> comp $ getField r (getIndex p)
getIndex t = case t of
C i -> fromInteger i
C i -> i
RP p _ -> getIndex p
TM -> 0 -- default value for parameter
_ -> trace ("ERROR in grammar compiler: index from " ++ show t) 0
getField t i = case t of
R rs -> idx rs i
W s ss -> KS (s ++ idx ss i)
RP _ r -> getField r i
TM -> TM
_ -> trace ("ERROR in grammar compiler: field from " ++ show t) t

11
src/GF/Canon/GFCC/GFCC.cf
View File

@@ -21,20 +21,19 @@ define trA a = Tr a [] ;
R. Term ::= "[" [Term] "]" ; -- record/table
P. Term ::= "(" Term "!" Term ")" ; -- projection/selection
S. Term ::= "(" [Term] ")" ; -- sequence with ++
K. Term ::= Tokn ; -- token
V. Term ::= "$" Integer ; -- argument
C. Term ::= Integer ; -- parameter value/label
KS. Term ::= String ; -- token
KP. Term ::= "[" "pre" [String] "[" [Variant] "]" "]" ;
V. Term ::= "$" Int ; -- argument
C. Term ::= Int ; -- parameter value/label
F. Term ::= CId ; -- global constant
FV. Term ::= "[|" [Term] "|]" ; -- free variation
W. Term ::= "(" String "+" Term ")" ; -- prefix + suffix table
W. Term ::= "(" String "+" [String] ")" ; -- prefix + suffix table
RP. Term ::= "(" Term "@" Term ")"; -- record parameter alias
TM. Term ::= "?" ; -- lin of metavariable
L. Term ::= "(" CId "->" Term ")" ; -- lambda abstracted table
BV. Term ::= "#" CId ; -- lambda-bound variable
KS. Tokn ::= String ;
KP. Tokn ::= "[" "pre" [String] "[" [Variant] "]" "]" ;
Var. Variant ::= [String] "/" [String] ;

12
src/GF/Canon/GFCC/PrintGFCC.hs
View File

@@ -69,6 +69,10 @@ prPrec :: Int -> Int -> Doc -> Doc
prPrec i j = if j<i then parenth else id
instance Print Int where
prt _ x = doc (shows x)
instance Print Integer where
prt _ x = doc (shows x)
@@ -153,7 +157,8 @@ instance Print Term where
R terms -> prPrec i 0 (concatD [doc (showString "[") , prt 0 terms , doc (showString "]")])
P term0 term -> prPrec i 0 (concatD [doc (showString "(") , prt 0 term0 , doc (showString "!") , prt 0 term , doc (showString ")")])
S terms -> prPrec i 0 (concatD [doc (showString "(") , prt 0 terms , doc (showString ")")])
K tokn -> prPrec i 0 (concatD [prt 0 tokn])
KS str -> prPrec i 0 (concatD [prt 0 str])
KP strs variants -> prPrec i 0 (concatD [doc (showString "[") , doc (showString "pre") , prt 0 strs , doc (showString "[") , prt 0 variants , doc (showString "]") , doc (showString "]")])
V n -> prPrec i 0 (concatD [doc (showString "$") , prt 0 n])
C n -> prPrec i 0 (concatD [prt 0 n])
F cid -> prPrec i 0 (concatD [prt 0 cid])
@@ -169,11 +174,6 @@ instance Print Term where
[x] -> (concatD [prt 0 x])
x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
instance Print Tokn where
prt i e = case e of
KS str -> prPrec i 0 (concatD [prt 0 str])
KP strs variants -> prPrec i 0 (concatD [doc (showString "[") , doc (showString "pre") , prt 0 strs , doc (showString "[") , prt 0 variants , doc (showString "]") , doc (showString "]")])
instance Print Variant where
prt i e = case e of