simplify GFCC syntax

6 files changed, 66 insertions, 78 deletions

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<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