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