adapted GFCC2FCFG to other uses of GFCC, made it to default parser

3 files changed, 38 insertions, 22 deletions

diff --git a/src/GF/Canon/GFCC/AbsGFCC.hs b/src/GF/Canon/GFCC/AbsGFCC.hs
index ccb964689..aab74f7fb 100644
--- a/src/GF/Canon/GFCC/AbsGFCC.hs
+++ b/src/GF/Canon/GFCC/AbsGFCC.hs
@@ -47,19 +47,24 @@ data Term =
    R [Term]
  | P Term Term
  | S [Term]
- | KS String
- | KP [String] [Variant]
+ | K Tokn
  | V Int
  | C Int
  | F CId
  | FV [Term]
- | W String [String]
+ | W String Term
  | 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 746175e29..eabd8b3a3 100644
--- a/src/GF/Canon/GFCC/DataGFCC.hs
+++ b/src/GF/Canon/GFCC/DataGFCC.hs
@@ -46,9 +46,10 @@ realize :: Term -> String
 realize trm = case trm of
   R ts     -> realize (ts !! 0)
   S ss     -> unwords $ Prelude.map realize ss
-  KS s     -> s
-  KP s _   -> unwords s ---- prefix choice TODO
-  W s ss   -> s ++ (ss !! 0)
+  K t -> case t of
+    KS s -> s
+    KP s _ -> unwords s ---- prefix choice TODO
+  W s t    -> s ++ realize t
   FV ts    -> realize (ts !! 0)  ---- other variants TODO
   RP _ r   -> realize r
   TM       -> "?"
@@ -58,9 +59,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 [KS (show s)] -- quoted
-    AI i   -> R [KS (show i)]
-    AF d   -> R [KS (show d)]
+    AS s   -> R [kks (show s)] -- quoted
+    AI i   -> R [kks (show i)]
+    AF d   -> R [kks (show d)]
     AM     -> TM
  where
    lin  = linExp mcfg lang
@@ -71,17 +72,20 @@ exp0 :: Exp
 exp0 = Tr (AS "NO_PARSE") []
 
 term0 :: CId -> Term
-term0 (CId s) = R [KS ("#" ++ s ++ "#")]
+term0 (CId s) = R [kks ("#" ++ s ++ "#")]
+
+kks :: String -> Term
+kks = K . KS
 
 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 ss -> W s ss
+    W s t  -> W s (comp t)
     R ts   -> R $ Prelude.map comp ts
-    V i    -> idx args i                  -- already computed
-    F c    -> comp $ look c               -- not computed (if contains argvar)
+    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
     _ -> trm
@@ -90,9 +94,14 @@ 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 p of
-    FV ts -> FV $ Prelude.map (proj r) ts
-    _     -> comp $ getField r (getIndex p)
+  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"
 
   getIndex t =  case t of
     C i    -> i
@@ -102,7 +111,6 @@ compute mcfg lang args = comp where
 
   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/PrintGFCC.hs b/src/GF/Canon/GFCC/PrintGFCC.hs
index 1ef7cfbe3..05a9246cd 100644
--- a/src/GF/Canon/GFCC/PrintGFCC.hs
+++ b/src/GF/Canon/GFCC/PrintGFCC.hs
@@ -69,11 +69,10 @@ prPrec :: Int -> Int -> Doc -> Doc
 prPrec i j = if j<i then parenth else id
 
 
-instance Print Int where
+instance Print Integer where
   prt _ x = doc (shows x)
 
-
-instance Print Integer where
+instance Print Int where
   prt _ x = doc (shows x)
 
 
@@ -157,8 +156,7 @@ 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 ")")])
-   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 "]")])
+   K tokn -> prPrec i 0 (concatD [prt 0 tokn])
    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])
@@ -174,6 +172,11 @@ 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