tracing a bug in gfcc generation

2 files changed, 32 insertions, 18 deletions

diff --git a/src/GF/Canon/CanonToGFCC.hs b/src/GF/Canon/CanonToGFCC.hs
index d5f8ac555..d187676d0 100644
--- a/src/GF/Canon/CanonToGFCC.hs
+++ b/src/GF/Canon/CanonToGFCC.hs
@@ -252,6 +252,7 @@ term2term cgr env@(labels,untyps,typs) tr = case tr of
      Ok (cat, lab) -> do
        k <- readSTM >>= return . length
        let tr' = LI $ identC $ show k
+
        let tyvs = case Map.lookup (cat,lab) labels of
              Just (ty,_) -> case Map.lookup ty typs of
                Just vs -> (ty,[t | 
@@ -260,6 +261,19 @@ term2term cgr env@(labels,untyps,typs) tr = case tr of
                _ -> error $ A.prt ty
              _ -> error $ A.prt tr
        updateSTM ((tyvs, (tr', tr)):) 
+
+{-
+       case Map.lookup (cat,lab) labels of
+         Just (ty,_) -> case Map.lookup ty typs of
+           Just vs -> do
+             let tyvs = (ty,[t | 
+                            (t,_) <- sortBy (\x y -> compare (snd x) (snd y)) 
+                                            (Map.assocs vs)])
+             updateSTM ((tyvs, (tr', tr)):) 
+           _ -> return ()
+         _ -> return ()
+-}
+
        return tr'
      _ -> composOp doVar tr
 
@@ -280,7 +294,8 @@ term2term cgr env@(labels,untyps,typs) tr = case tr of
     --- complexity could be lowered by sorting the records
     where
       tryPerm tr = case tr of
-        R rs -> case [v | Just v <- [Map.lookup (R rs') untyps | rs' <- permutations rs]] of
+        R rs -> case [v | Just v <- 
+                       [Map.lookup (R rs') untyps | rs' <- permutations rs]] of
 	  v:_ -> EInt v
           _ -> valNumFV $ tryVar tr
         _ -> valNumFV $ tryVar tr
@@ -299,13 +314,16 @@ term2term cgr env@(labels,untyps,typs) tr = case tr of
      EInt _  -> False
      R rs    -> any (isStr . trmAss) rs
      FV ts   -> any isStr ts
+     S t _   -> isStr t
+     E       -> True
+     T _ cs  -> any isStr [v | Cas _ v <- cs]
      P t r   -> case getLab tr of
        Ok (cat,labs) -> case 
           Map.lookup (cat,labs) labels of
             Just (ty,_) -> isStrType ty 
             _ -> True ---- TODO?
        _ -> True
-     _ -> True
+     _ -> True ----
    isStrType ty = case ty of
      TStr -> True
      RecType ts -> any isStrType [t | Lbg _ t <- ts]
diff --git a/src/GF/Canon/GFCC/DataGFCC.hs b/src/GF/Canon/GFCC/DataGFCC.hs
index e59bc46d9..c11587c6f 100644
--- a/src/GF/Canon/GFCC/DataGFCC.hs
+++ b/src/GF/Canon/GFCC/DataGFCC.hs
@@ -3,6 +3,7 @@ module GF.Canon.GFCC.DataGFCC where
 import GF.Canon.GFCC.AbsGFCC
 import Data.Map
 import Data.List
+import Debug.Trace ----
 
 data GFCC = GFCC {
   absname   :: CId ,
@@ -44,6 +45,8 @@ realize trm = case trm of
   K (KP s _) -> unwords s ---- prefix choice TODO
   W s t    -> s ++ realize t
   FV (t:_) -> realize t
+
+  RP _ r -> realize r
   _ -> "ERROR " ++ show trm ---- debug
 
 linExp :: GFCC -> CId -> Exp -> Term
@@ -76,31 +79,16 @@ compute mcfg lang args = compg [] where
   compg g trm = case trm of
     P r (FV ts) -> FV $ Prelude.map (comp . P r) ts
 
-    -- for the abstraction optimization
---    P (A x t) p -> compg ((x,comp p):g) t 
---    L x   -> maybe (error (show x)) id $ Prelude.lookup x g
-
     P r p -> case (comp r, comp p) of 
 
     -- for the suffix optimization
       (W s t, R (C i : _)) -> comp $ P (W s t) (C i)
-
       (W s t, C i) -> case comp t of
         R ss -> case comp $ idx ss (fromInteger i) of
           K (KS u) -> kks (s ++ u)      -- the only case where W occurs
- 
-    ----TODO: this is only needed because of some GFCC compilation bug
-    --  (R [C _ , R rs], C i) -> comp $ idx rs (fromInteger i)
-      (R rs, R (C i : _)) -> comp $ idx rs (fromInteger i)
 
-    -- parameter record
-      (RP _ (R rs), C i) -> comp $ idx rs (fromInteger i)
-      (R rs, RP t _) -> case comp t of 
-         C i -> comp $ idx rs (fromInteger i)
-	 RP (C i) _  -> comp $ idx rs (fromInteger i) ---- why?
+      (r', p') -> comp $ idx (getFields r') (getIndex (P r' p') p')
 
-      (R rs, C i) -> comp $ idx rs (fromInteger i)
-      (r',p') -> P r' p'
     RP i t -> RP (comp i) (comp t)
     W s t -> W s (comp t)
     R ts  -> R $ Prelude.map comp ts
@@ -117,7 +105,15 @@ compute mcfg lang args = compg [] where
       then K (KS ("ERROR" ++ show xs ++ " !! " ++ show i)) else
       xs !! i 
 
+    getIndex t0 t =  case t of
+      C i -> fromInteger i
+      RP p _ -> getIndex t0 $ p
+      ---- TODO: this is workaround for a compiler bug
+      R (u : _) -> trace (show t ++ " IN\n" ++ show t0) $ getIndex t0 u
 
+    getFields t = case t of
+      R rs -> rs
+      RP _ r -> getFields r
 
 
 {-