diff --git a/src/GF/Canon/CanonToGFCC.hs b/src/GF/Canon/CanonToGFCC.hs index 38bc6f112..3ed2bc9a8 100644 --- a/src/GF/Canon/CanonToGFCC.hs +++ b/src/GF/Canon/CanonToGFCC.hs @@ -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 diff --git a/src/GF/Canon/CanonToJS.hs b/src/GF/Canon/CanonToJS.hs index bcd64e282..7e88a5ef2 100644 --- a/src/GF/Canon/CanonToJS.hs +++ b/src/GF/Canon/CanonToJS.hs @@ -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" diff --git a/src/GF/Canon/GFCC/AbsGFCC.hs b/src/GF/Canon/GFCC/AbsGFCC.hs index af9f18088..ccb964689 100644 --- a/src/GF/Canon/GFCC/AbsGFCC.hs +++ b/src/GF/Canon/GFCC/AbsGFCC.hs @@ -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) - diff --git a/src/GF/Canon/GFCC/DataGFCC.hs b/src/GF/Canon/GFCC/DataGFCC.hs index 43ce04166..746175e29 100644 --- a/src/GF/Canon/GFCC/DataGFCC.hs +++ b/src/GF/Canon/GFCC/DataGFCC.hs @@ -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 diff --git a/src/GF/Canon/GFCC/GFCC.cf b/src/GF/Canon/GFCC/GFCC.cf index 65657a259..5c8020905 100644 --- a/src/GF/Canon/GFCC/GFCC.cf +++ b/src/GF/Canon/GFCC/GFCC.cf @@ -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] ; diff --git a/src/GF/Canon/GFCC/PrintGFCC.hs b/src/GF/Canon/GFCC/PrintGFCC.hs index b8a98532e..1ef7cfbe3 100644 --- a/src/GF/Canon/GFCC/PrintGFCC.hs +++ b/src/GF/Canon/GFCC/PrintGFCC.hs @@ -69,6 +69,10 @@ prPrec :: Int -> Int -> Doc -> Doc prPrec i j = if j 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