simplify GFCC syntax

1 files changed, 33 insertions, 28 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