removed gfcc via gfc everywhere; workaround for russian in present

5 files changed, 48 insertions, 533 deletions

diff --git a/src/GF/Canon/CanonToGFCC.hs b/src/GF/Canon/CanonToGFCC.hs
deleted file mode 100644
index 9beb1a2b7..000000000
--- a/src/GF/Canon/CanonToGFCC.hs
+++ /dev/null
@@ -1,422 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module      : CanonToGFCC
--- Maintainer  : AR
--- Stability   : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/06/17 14:15:17 $ 
--- > CVS $Author: aarne $
--- > CVS $Revision: 1.15 $
---
--- GFC to GFCC compiler. AR Aug-Oct 2006
------------------------------------------------------------------------------
-
-module GF.Canon.CanonToGFCC (
-  prCanon2gfcc, mkCanon2gfcc, mkCanon2gfccNoUTF8) where
-
-import GF.Canon.AbsGFC
-import qualified GF.Canon.GFC as GFC
-import qualified GF.Canon.Look as Look
-import qualified GF.Canon.Subexpressions as Sub
-
-import qualified GF.GFCC.Macros as CM
-import GF.GFCC.Raw.AbsGFCCRaw (CId (..))
-import qualified GF.GFCC.DataGFCC as C
-import qualified GF.GFCC.DataGFCC as D
-import GF.Devel.PrintGFCC
-import GF.GFCC.OptimizeGFCC
-
-import GF.Canon.GFC
-import GF.Canon.Share
-import qualified GF.Grammar.Abstract as A
-import qualified GF.Grammar.Macros as GM
-import GF.Canon.MkGFC
-import GF.Canon.CMacros
-import qualified GF.Infra.Modules as M
-import qualified GF.Infra.Option as O
-import GF.UseGrammar.Linear (expandLinTables, unoptimizeCanon)
-
-import GF.Infra.Ident
-import GF.Data.Operations
-import GF.Text.UTF8
-
-import Data.List
-import qualified Data.Map as Map
-import Debug.Trace ----
-
--- the main function: generate GFCC from GFCM.
-
-prCanon2gfcc :: CanonGrammar -> String
-prCanon2gfcc = printGFCC . mkCanon2gfcc
-
--- this variant makes utf8 conversion; used in back ends
-mkCanon2gfcc :: CanonGrammar -> D.GFCC
-mkCanon2gfcc = 
--- canon2gfcc . reorder abs . utf8Conv . canon2canon abs
-  optGFCC . canon2gfcc . reorder . utf8Conv . canon2canon . normalize
-
--- this variant makes no utf8 conversion; used in ShellState
-mkCanon2gfccNoUTF8 :: CanonGrammar -> D.GFCC
-mkCanon2gfccNoUTF8 = optGFCC . canon2gfcc . reorder . canon2canon . normalize
-
--- This is needed to reorganize the grammar. 
--- GFCC has its own back-end optimization.
--- But we need to have the canonical order in tables, created by valOpt
-normalize :: CanonGrammar -> CanonGrammar
-normalize = share . unoptimizeCanon . Sub.unSubelimCanon where
-  share = M.MGrammar . map (shareModule valOpt) . M.modules --- allOpt
-
--- Generate GFCC from GFCM.
--- this assumes a grammar normalized and transformed by canon2canon
-
-canon2gfcc :: CanonGrammar -> D.GFCC
-canon2gfcc cgr@(M.MGrammar ((a,M.ModMod abm):cms)) = 
-     D.GFCC an cns Map.empty abs cncs 
- where
-  an  = (i2i a)
-  cns = map (i2i . fst) cms
-  abs = D.Abstr aflags funs cats catfuns
-  aflags = Map.fromAscList [] ---- flags
-  lfuns = [(f', (mkType ty,CM.primNotion)) | ---- defs 
-             (f,GFC.AbsFun ty _) <- tree2list (M.jments abm), let f' = i2i f]
-  funs = Map.fromAscList lfuns
-  lcats = [(i2i c,[]) | ---- context
-            (c,GFC.AbsCat _ _) <- tree2list (M.jments abm)]
-  cats = Map.fromAscList lcats
-  catfuns = Map.fromAscList 
-    [(cat,[f | (f, (C.DTyp _ c _,_)) <- lfuns, c==cat]) | (cat,_) <- lcats]
-
-  cncs  = Map.fromList [mkConcr (i2i lang) mo | (lang,M.ModMod mo) <- cms]
-  mkConcr lang mo = (lang,D.Concr flags lins opers lincats lindefs printnames params)
-    where
-      flags   = Map.fromAscList [] ---- flags
-      opers   = Map.fromAscList [] -- opers will be created as optimization
-      lins    = Map.fromAscList 
-        [(i2i f, mkTerm tr) | (f,GFC.CncFun _ _ tr _) <- tree2list (M.jments mo)]
-      lincats = Map.fromAscList 
-        [(i2i c, mkCType ty) | (c,GFC.CncCat ty _ _) <- tree2list (M.jments mo)]
-      lindefs = Map.fromAscList 
-        [(i2i c, mkTerm tr) | (c,GFC.CncCat _ tr _) <- tree2list (M.jments mo)]
-      printnames = Map.fromAscList [] ---- printnames
-      params = Map.fromAscList [] ---- params
-
-i2i :: Ident -> CId
-i2i (IC c) = CId c
-
-mkType :: A.Type -> C.Type
-mkType t = case GM.catSkeleton t of
-  Ok (cs,c) -> CM.cftype (map (i2i . snd) cs) (i2i $ snd c)
-
-mkCType :: CType -> C.Term
-mkCType t = case t of
-  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]
-  Table pt vt -> C.R $ replicate (getI (mkCType pt)) $ mkCType vt
-  TStr     -> C.S []
- where
-  getI pt = case pt of
-    C.C i -> i + 1
-    C.RP i _ -> getI i
-
-mkTerm :: Term -> C.Term
-mkTerm tr = case tr of
-  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
-  R rs     -> C.R [mkTerm t | Ass _ t <- rs]
-  P t l    -> C.P (mkTerm t) (C.C (mkLab l))
-
-  T _ cs   -> error $ "improper optimization for gfcc in" +++ A.prt tr
-  V _ cs   -> C.R [mkTerm t | t <- cs]
-  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
-  E        -> C.S []
-  Par _ _  -> prtTrace tr $ C.C 66661          ---- for debugging
-  _ -> C.S [C.K (C.KS (A.prt tr +++ "66662"))] ---- for debugging
- where
-   mkLab (L (IC l)) = case l of
-     '_':ds -> (read ds) :: Int
-     _ -> prtTrace tr $ 66663
-
--- return just one module per language
-
-reorder :: CanonGrammar -> CanonGrammar
-reorder cg = M.MGrammar $ 
-    (abs, M.ModMod $ 
-          M.Module M.MTAbstract M.MSComplete [] [] [] adefs):
-      [(c, M.ModMod $ 
-          M.Module (M.MTConcrete abs) M.MSComplete [] [] [] (sorted2tree js)) 
-            | (c,js) <- cncs] 
-     where
-       abs = maybe (error "no abstract") id $ M.greatestAbstract cg
-       mos = M.allModMod cg
-       adefs = 
-         sorted2tree $ sortBy (\ (f,_) (g,_) -> compare f g) 
-            [finfo | 
-              (i,mo) <- M.allModMod cg, M.isModAbs mo, 
-              finfo <- tree2list (M.jments mo)]
-       cncs = sortBy (\ (x,_) (y,_) -> compare x y)
-            [(lang, concr lang) | lang <- M.allConcretes cg abs]
-       concr la = sortBy (\ (f,_) (g,_) -> compare f g) 
-            [finfo | 
-              (i,mo) <- mos, M.isModCnc mo, elem i (M.allExtends cg la),
-              finfo <- tree2list (M.jments mo)]
-
--- one grammar per language - needed for symtab generation
-repartition :: CanonGrammar -> [CanonGrammar]
-repartition cg = [M.partOfGrammar cg (lang,mo) | 
-  let abs = maybe (error "no abstract") id $ M.greatestAbstract cg,
-  let mos = M.allModMod cg,
-  lang <- M.allConcretes cg abs,
-  let mo = errVal 
-       (error ("no module found for " ++ A.prt lang)) $ M.lookupModule cg lang
-  ]
-
--- convert to UTF8 if not yet converted
-utf8Conv :: CanonGrammar -> CanonGrammar
-utf8Conv = M.MGrammar . map toUTF8 . M.modules where
-  toUTF8 mo = case mo of
-    (i, M.ModMod m) 
-      | hasFlagCanon (flagCanon "coding" "utf8") mo -> mo
-      | otherwise -> (i, M.ModMod $
-          m{ M.jments = 
-              mapTree (onSnd (mapInfoTerms (onTokens encodeUTF8))) (M.jments m),
-	     M.flags = setFlag "coding" "utf8" (M.flags m) }
-          )
-    _ -> mo
- 
-
--- translate tables and records to arrays, parameters and labels to indices
-
-canon2canon :: CanonGrammar -> CanonGrammar
-canon2canon = recollect . map cl2cl . repartition where
-  recollect = 
-    M.MGrammar . nubBy (\ (i,_) (j,_) -> i==j) . concatMap M.modules
-  cl2cl cg = {-tr $-} M.MGrammar $ map c2c $ M.modules cg where
-    c2c (c,m) = case m of
-      M.ModMod mo@(M.Module _ _ _ _ _ js) ->
-        (c, M.ModMod $ M.replaceJudgements mo $ mapTree j2j js)
-      _ -> (c,m)
-    j2j (f,j) = case j of
-      GFC.CncFun x y tr z -> (f,GFC.CncFun x y (t2t tr) z)
-      GFC.CncCat ty x y   -> (f,GFC.CncCat (ty2ty ty) (t2t x) y)
-      _ -> (f,j)
-    t2t = term2term cg pv
-    ty2ty = type2type cg pv
-    pv@(labels,untyps,typs) = paramValues cg
-    tr = trace $
-     (unlines [A.prt c ++ "." ++ unwords (map A.prt l) +++ "=" +++ show i  | 
-       ((c,l),i) <- Map.toList labels]) ++
-     (unlines [A.prt t +++ "=" +++ show i  | 
-       (t,i) <- Map.toList untyps]) ++
-     (unlines [A.prt t | 
-       (t,_) <- Map.toList typs])
-
-type ParamEnv =
-  (Map.Map (Ident,[Label]) (CType,Integer), -- numbered labels
-   Map.Map Term Integer,                    -- untyped terms to values
-   Map.Map CType (Map.Map Term Integer))    -- types to their terms to values
-
---- gathers those param types that are actually used in lincats and in lin terms
-paramValues :: CanonGrammar -> ParamEnv
-paramValues cgr = (labels,untyps,typs) where
-  params = [(ty, errVal [] $ Look.allParamValues cgr ty) | ty <- partyps]
-  partyps = nub $ [ty | 
-              (_,(_,CncCat (RecType ls) _ _)) <- jments,
-              ty0 <- [ty | Lbg _ ty <- unlockTyp ls],
-              ty  <- typsFrom ty0
-            ] ++ [
-             Cn (CIQ m ty) | 
-              (m,(ty,ResPar _)) <- jments
-            ] ++ [ty | 
-              (_,(_,CncFun _ _ tr _)) <- jments,
-              ty  <- err (const []) snd $ appSTM (typsFromTrm tr) []
-            ]
-  typsFrom ty = case ty of
-    Table p t  -> typsFrom p ++ typsFrom t
-    RecType ls -> RecType (unlockTyp ls) : concat [typsFrom t | Lbg _ t <- ls]
-    _ -> [ty]
- 
-  typsFromTrm :: Term -> STM [CType] Term
-  typsFromTrm tr = case tr of
-    V ty ts -> updateSTM (ty:) >> mapM_ typsFromTrm ts >> return tr
-    T ty cs -> updateSTM (ty:) >> mapM_ typsFromTrm [t | Cas _ t <- cs] >> return tr
-    _ -> composOp typsFromTrm tr
-
-
-  jments = [(m,j) | (m,mo) <- M.allModMod cgr, j <- tree2list $ M.jments mo]
-  typs = Map.fromList [(ci,Map.fromList (zip vs [0..])) | (ci,vs) <- params]
-  untyps = Map.fromList $ concatMap Map.toList [typ | (_,typ) <- Map.toList typs]
-  lincats = 
-    [(IC cat,[Lbg (L (IC "s")) TStr]) | cat <- ["Int", "Float", "String"]] ++
-    [(cat,(unlockTyp ls)) | (_,(cat,CncCat (RecType ls) _ _)) <- jments]
-  labels = Map.fromList $ concat 
-    [((cat,[lab]),(typ,i)): 
-      [((cat,[lab,lab2]),(ty,j)) | 
-        rs <- getRec typ, (Lbg lab2 ty,j) <- zip rs [0..]] 
-      | 
-        (cat,ls) <- lincats, (Lbg lab typ,i) <- zip ls [0..]]
-    -- go to tables recursively
-    ---- TODO: even go to deeper records
-   where
-     getRec typ = case typ of
-       RecType rs -> [rs]
-       Table _ t  -> getRec t
-       _ -> []
-
-type2type :: CanonGrammar -> ParamEnv -> CType -> CType
-type2type cgr env@(labels,untyps,typs) ty = case ty of
-  RecType rs ->
-    let
-      rs' = [Lbg (mkLab i) (t2t t) | 
-               (i,Lbg l t) <- zip [0..] (unlockTyp rs)]
-    in if (any isStrType [t | Lbg _ t <- rs])
-      then RecType rs'
-      else RecType [Lbg (L (IC "_")) (look ty), Lbg (L (IC "__")) (RecType rs')]
-
-  Table pt vt -> Table (t2t pt) (t2t vt)
-  Cn _ -> look ty
-  _ -> ty
- where
-   t2t = type2type cgr env
-   look ty = TInts $ (+ (-1)) $ toInteger $ case Map.lookup ty typs of
-     Just vs -> length $ Map.assocs vs
-     _ -> trace ("unknown partype " ++ show ty) 1 ---- 66669
-
-term2term :: CanonGrammar -> ParamEnv -> Term -> Term
-term2term cgr env@(labels,untyps,typs) tr = case tr of
-  Par _ _ -> mkValCase tr 
-  R rs ->
-    let
-      rs' = [Ass (mkLab i) (t2t t) | 
-               (i,Ass l t) <- zip [0..] (unlock rs)]
-    in if (any (isStr . trmAss) rs)
-      then R rs'
-      else R [Ass (L (IC "_")) (mkValCase tr), Ass (L (IC "__")) (R rs')]
-  P t l    -> r2r tr
-
-  T ti [Cas ps@[PV _] t] -> T ti [Cas ps (t2t t)]
-
-  T _ cs0  -> case expandLinTables cgr tr of  -- normalize order of cases
-    Ok (T ty cs) -> checkCases cs $ V ty [t2t t | Cas _ t <- cs]
-    _ -> K (KS (A.prt tr +++ prtTrace tr "66668"))
-  V ty ts  -> V ty [t2t t | t <- ts]
-  S t p    -> S (t2t t) (t2t p)
-  _ -> composSafeOp t2t tr
- where
-   t2t = term2term cgr env
-
-   checkCases cs a = 
-     if null [() | Cas (_:_:_) _ <- cs] -- no share option active
-       then a
-       else error $ "Share optimization illegal for gfcc in" +++ A.prt tr ++++
-         "Recompile with -optimize=(values | none | subs | all_subs)."
-
-   r2r tr@(P (S (V ty ts) v) l) = t2t $ S (V ty [comp (P t l) | t <- ts]) v
-
-   r2r tr@(P p _) = case getLab tr of
-     Ok (cat,labs) -> P (t2t p) . mkLab $ maybe (prtTrace tr $ 66664) snd $ 
-          Map.lookup (cat,labs) labels
-     _ -> K (KS (A.prt tr +++ prtTrace tr "66665"))
-
-   -- this goes recursively into tables (ignored) and records (accumulated)
-   getLab tr = case tr of
-     Arg (A cat _) -> return (cat,[])
-     P p lab2 -> do
-       (cat,labs) <- getLab p
-       return (cat,labs++[lab2]) 
-     S p _ -> getLab p
-     _ -> Bad "getLab"
-
-   doVar :: Term -> STM [((CType,[Term]),(Term,Term))] Term
-   doVar tr = case getLab 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 | 
-                            (t,_) <- sortBy (\x y -> compare (snd x) (snd y)) 
-                                            (Map.assocs vs)])
-               _ -> error $ A.prt ty
-             _ -> error $ A.prt tr
-       updateSTM ((tyvs, (tr', tr)):) 
-       return tr'
-     _ -> composOp doVar tr
-
-   mkValCase tr = case appSTM (doVar tr) [] of
-     Ok (tr', st@(_:_)) -> t2t $ comp $ foldr mkCase tr' st
-     _ -> valNum tr
-
-   mkCase ((ty,vs),(x,p)) tr = 
-     S (V ty [mkBranch x v tr | v <- vs]) p
-   mkBranch x t tr = case tr of
-     _ | tr == x -> t
-     _ -> composSafeOp (mkBranch x t) tr     
-
-   valNum tr = maybe (tryPerm tr) EInt $ Map.lookup tr untyps
-    where
-      tryPerm tr = case tr of
-        R rs -> case Map.lookup (R rs) untyps of
-	  Just v -> EInt v
-          _ -> valNumFV $ tryVar tr
-        _ -> valNumFV $ tryVar tr
-      tryVar tr = case tr of
-        Par c ts -> [Par c ts' | ts' <- combinations (map tryVar ts)]
-        FV ts -> ts
-        _ -> [tr]
-      valNumFV ts = case ts of
-        [tr] -> EInt 66667 ----K (KS (A.prt tr +++ prtTrace tr "66667"))
-        _ -> FV $ map valNum ts
-   isStr tr = case tr of
-     Par _ _ -> False
-     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]
-     V _ ts  -> any isStr ts
-     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 ----
-   trmAss (Ass _ t) = t
-
-   --- this is mainly needed for parameter record projections
-   comp t = errVal t $ Look.ccompute cgr [] t
-
-isStrType ty = case ty of
-     TStr -> True
-     RecType ts -> any isStrType [t | Lbg _ t <- ts]
-     Table _ t -> isStrType t
-     _ -> False
-
-mkLab k = L (IC ("_" ++ show k))
-
--- remove lock fields; in fact, any empty records and record types
-unlock = filter notlock where
-  notlock (Ass l t) = case t of --- need not look at l
-     R [] -> False
-     _ -> True
-unlockTyp = filter notlock where
-  notlock (Lbg l t) = case t of --- need not look at l
-     RecType [] -> False
-     _ -> True
-
-
-prtTrace tr n = n ----trace ("-- ERROR" +++ A.prt tr +++ show n +++ show tr) n
-prTrace  tr n = trace ("-- OBSERVE" +++ A.prt tr +++ show n +++ show tr) n
-
diff --git a/src/GF/Canon/CanonToJS.hs b/src/GF/Canon/CanonToJS.hs
deleted file mode 100644
index a88a2f46a..000000000
--- a/src/GF/Canon/CanonToJS.hs
+++ /dev/null
@@ -1,95 +0,0 @@
-module GF.Canon.CanonToJS (prCanon2js) where
-
-import GF.Canon.GFC
-import GF.Canon.CanonToGFCC
-import GF.Canon.Look
-import GF.Data.ErrM
-import GF.Infra.Option
-import qualified GF.GFCC.Macros as M
-import qualified GF.GFCC.DataGFCC as D
-import qualified GF.GFCC.DataGFCC as C
-import GF.GFCC.Raw.AbsGFCCRaw (CId(CId))
-import qualified GF.JavaScript.AbsJS as JS
-import qualified GF.JavaScript.PrintJS as JS
-
-
-import Control.Monad (mplus)
-import Data.Maybe (fromMaybe)
-import qualified Data.Map as Map
-
-prCanon2js :: Options -> CanonGrammar -> String
-prCanon2js opts gr = gfcc2js start $ mkCanon2gfcc gr
-  where 
-    start = fromMaybe "S" (getOptVal opts gStartCat 
-                           `mplus` getOptVal grOpts gStartCat)
-    grOpts = errVal noOptions $ lookupOptionsCan gr
-
-gfcc2js :: String -> D.GFCC -> String
-gfcc2js start gfcc =
-  JS.printTree $ JS.Program $ abstract2js start n as ++ 
-  concatMap (concrete2js n) cs
- where
-   n  = D.absname gfcc
-   as = D.abstract gfcc
-   cs = Map.assocs (D.concretes gfcc)
-
-abstract2js :: String -> CId -> D.Abstr -> [JS.Element]
-abstract2js start (CId n) ds = 
-    [JS.ElStmt $ JS.SDeclOrExpr $ JS.Decl [JS.DInit a (new "Abstract" [JS.EStr start])]] 
-    ++ concatMap (absdef2js a) (Map.assocs (D.funs ds))
-  where a = JS.Ident n
-
-absdef2js :: JS.Ident -> (CId,(C.Type,C.Exp)) -> [JS.Element]
-absdef2js a (CId f,(typ,_)) =
-  let (args,CId cat) = M.catSkeleton typ in 
-    [JS.ElStmt $ JS.SDeclOrExpr $ JS.DExpr $ JS.ECall (JS.EMember (JS.EVar a) (JS.Ident "addType")) 
-           [JS.EStr f, JS.EArray [JS.EStr x | CId x <- args], JS.EStr cat]]
-
-concrete2js :: CId -> (CId,D.Concr) -> [JS.Element]
-concrete2js (CId a) (CId c, cnc) =
-    [JS.ElStmt $ JS.SDeclOrExpr $ JS.Decl [JS.DInit l (new "Concrete" [JS.EVar (JS.Ident a)])]] 
-    ++ concatMap (cncdef2js l) ds
-  where 
-   l  = JS.Ident c
-   ds = concatMap Map.assocs [D.lins cnc, D.opers cnc, D.lindefs cnc]
-
-cncdef2js :: JS.Ident -> (CId,C.Term) -> [JS.Element]
-cncdef2js l (CId f, t) = 
-    [JS.ElStmt $ JS.SDeclOrExpr $ JS.DExpr $ JS.ECall (JS.EMember (JS.EVar l) (JS.Ident "addRule")) [JS.EStr f, JS.EFun [children] [JS.SReturn (term2js l t)]]]
-
-term2js :: JS.Ident -> C.Term -> JS.Expr
-term2js l t = f t
-  where 
-  f t = 
-    case t of
-      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           -> mkSeq (map f xs)
-      C.K t            -> tokn2js t
-      C.V i            -> JS.EIndex (JS.EVar children) (JS.EInt i)
-      C.C i            -> new "Int" [JS.EInt i]
-      C.F (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.RP x y         -> new "Rp" [f x, f y]
-      C.TM             -> new "Meta" []
-
-tokn2js :: C.Tokn -> JS.Expr
-tokn2js (C.KS s) = mkStr s
-tokn2js (C.KP ss vs) = mkSeq (map mkStr ss) -- FIXME
-
-mkStr :: String -> JS.Expr
-mkStr s = new "Str" [JS.EStr s]
-
-mkSeq :: [JS.Expr] -> JS.Expr
-mkSeq [x] = x
-mkSeq xs = new "Seq" xs
-
-argIdent :: Integer -> JS.Ident
-argIdent n = JS.Ident ("x" ++ show n)
-
-children :: JS.Ident
-children = JS.Ident "cs"
-
-new :: String -> [JS.Expr] -> JS.Expr
-new f xs = JS.ENew (JS.Ident f) xs
diff --git a/src/GF/Devel/Compile/GFtoGFCC.hs b/src/GF/Devel/Compile/GFtoGFCC.hs
index aaa55c895..3fc3331de 100644
--- a/src/GF/Devel/Compile/GFtoGFCC.hs
+++ b/src/GF/Devel/Compile/GFtoGFCC.hs
@@ -15,10 +15,11 @@ import GF.Devel.Grammar.PrGF
 --import GF.Devel.ModDeps
 import GF.Infra.Ident
 
+import GF.Devel.PrintGFCC
 import qualified GF.GFCC.Macros as CM
-import qualified GF.GFCC.AbsGFCC as C
+import qualified GF.GFCC.DataGFCC as C
 import qualified GF.GFCC.DataGFCC as D
-
+import GF.GFCC.Raw.AbsGFCCRaw (CId (..))
 import GF.Infra.Option ----
 import GF.Data.Operations
 import GF.Text.UTF8
@@ -31,7 +32,7 @@ import Debug.Trace ----
 -- the main function: generate GFCC from GF.
 
 prGrammar2gfcc :: Options -> String -> GF -> (String,String)
-prGrammar2gfcc opts cnc gr = (abs, D.printGFCC gc) where
+prGrammar2gfcc opts cnc gr = (abs, printGFCC gc) where
   (abs,gc) = mkCanon2gfcc opts cnc gr 
 
 mkCanon2gfcc :: Options -> String -> GF -> (String,D.GFCC)
@@ -57,9 +58,9 @@ canon2gfcc opts pars cgr =
   an  = (i2i a)
   cns = map (i2i . fst) cms
   abs = D.Abstr aflags funs cats catfuns
-  gflags = Map.fromList [(C.CId fg,x) | Just x <- [getOptVal opts (aOpt fg)]] 
+  gflags = Map.fromList [(CId fg,x) | Just x <- [getOptVal opts (aOpt fg)]] 
                                           where fg = "firstlang"
-  aflags = Map.fromList [(C.CId f,x) | (IC f,x) <- Map.toList (M.mflags abm)]
+  aflags = Map.fromList [(CId f,x) | (IC f,x) <- Map.toList (M.mflags abm)]
   mkDef pty = case pty of
     Meta _ -> CM.primNotion
     t -> mkExp t
@@ -80,7 +81,7 @@ canon2gfcc opts pars cgr =
       (lang,D.Concr flags lins opers lincats lindefs printnames params)
     where
       js = listJudgements mo
-      flags = Map.fromList [(C.CId f,x) | (IC f,x) <- Map.toList (M.mflags mo)]
+      flags = Map.fromList [(CId f,x) | (IC f,x) <- Map.toList (M.mflags mo)]
       opers = Map.fromAscList [] -- opers will be created as optimization
       utf   = if elem (IC "coding","utf8") (Map.assocs (M.mflags mo)) ---- 
                   then D.convertStringsInTerm decodeUTF8 else id
@@ -96,8 +97,8 @@ canon2gfcc opts pars cgr =
       params = Map.fromAscList 
         [(i2i c, pars lang0 c) | (c,ju) <- js, jform ju == JLincat] ---- c ??
 
-i2i :: Ident -> C.CId
-i2i = C.CId . prIdent
+i2i :: Ident -> CId
+i2i = CId . prIdent
 
 mkType :: A.Type -> C.Type
 mkType t = case GM.typeForm t of
diff --git a/src/GF/GFCC/CheckGFCC.hs b/src/GF/GFCC/CheckGFCC.hs
index f3098d02c..065e2cb54 100644
--- a/src/GF/GFCC/CheckGFCC.hs
+++ b/src/GF/GFCC/CheckGFCC.hs
@@ -1,4 +1,4 @@
-module GF.GFCC.CheckGFCC (checkGFCC, checkGFCCio) where
+module GF.GFCC.CheckGFCC (checkGFCC, checkGFCCio, checkGFCCmaybe) where
 
 import GF.GFCC.Raw.AbsGFCCRaw (CId (..))
 import GF.GFCC.Macros
@@ -18,6 +18,12 @@ checkGFCCio gfcc = case checkGFCC gfcc of
     putStrLn s
     error "building GFCC failed"
 
+---- needed in old Custom
+checkGFCCmaybe :: GFCC -> Maybe GFCC
+checkGFCCmaybe gfcc = case checkGFCC gfcc of
+  Ok (gc,b) -> return gc 
+  Bad s -> Nothing
+
 checkGFCC :: GFCC -> Err (GFCC,Bool)
 checkGFCC gfcc = do
   (cs,bs) <- mapM (checkConcrete gfcc) 
diff --git a/src/GF/UseGrammar/Custom.hs b/src/GF/UseGrammar/Custom.hs
index 5b98936ca..45421951f 100644
--- a/src/GF/UseGrammar/Custom.hs
+++ b/src/GF/UseGrammar/Custom.hs
@@ -34,10 +34,19 @@ import GF.Grammar.Values
 import qualified GF.Grammar.Grammar as G
 import qualified GF.Canon.AbsGFC as A
 import qualified GF.Canon.GFC as C
-import qualified GF.Canon.CanonToGFCC as GFCC
+
+import qualified GF.Devel.GrammarToGFCC as GFCC
 import qualified GF.Devel.GFCCtoHaskell as CCH
-import qualified GF.GFCC.DataGFCC as DataGFCC
-import qualified GF.Canon.CanonToJS as JS (prCanon2js)
+import GF.Devel.PrintGFCC
+import qualified GF.Devel.GFCCtoJS as JS
+import GF.GFCC.CheckGFCC (checkGFCCmaybe)
+import GF.GFCC.OptimizeGFCC
+
+--import qualified GF.Canon.CanonToGFCC as GFCC
+--import qualified GF.Devel.GFCCtoHaskell as CCH
+--import qualified GF.GFCC.DataGFCC as DataGFCC
+--import qualified GF.Canon.CanonToJS as JS (prCanon2js)
+
 import qualified GF.Source.AbsGF as GF
 import qualified GF.Grammar.MMacros as MM
 import GF.Grammar.AbsCompute
@@ -106,6 +115,7 @@ import GF.Visualization.VisualizeGrammar (visualizeCanonGrammar, visualizeSource
 
 import GF.API.MyParser
 
+import qualified GF.Infra.Modules as M
 import GF.Infra.UseIO
 
 import Control.Monad
@@ -274,8 +284,8 @@ customGrammarPrinter =
   ,(strCI "bnf",     \_ -> prBNF False)
   ,(strCI "absbnf",  \_ -> abstract2bnf . stateGrammarST)
   ,(strCI "haskell", \_ -> grammar2haskell . stateGrammarST)
-  ,(strCI "gfcc_haskell", \_ -> CCH.grammar2haskell . 
-                                GFCC.mkCanon2gfcc . stateGrammarST)
+  ,(strCI "gfcc_haskell", \opts -> CCH.grammar2haskell . 
+                                canon2gfcc opts . stateGrammarST)
   ,(strCI "haskell_gadt", \_ -> grammar2haskellGADT . stateGrammarST)
   ,(strCI "transfer", \_ -> grammar2transfer . stateGrammarST)
   ,(strCI "morpho",  \_ -> prMorpho . stateMorpho)
@@ -328,8 +338,8 @@ customMultiGrammarPrinter =
   customData "Printers for multiple grammars, selected by option -printer=x" $
   [
    (strCI "gfcm", const MC.prCanon)
-  ,(strCI "gfcc", const GFCC.prCanon2gfcc)
-  ,(strCI "js", JS.prCanon2js)
+  ,(strCI "gfcc", canon2gfccPr)
+  ,(strCI "js", \opts -> JS.gfcc2js . canon2gfcc opts)
   ,(strCI "header", const (MC.prCanonMGr . unoptimizeCanon))
   ,(strCI "cfgm", prCanonAsCFGM)
   ,(strCI "graph", visualizeCanonGrammar)
@@ -341,6 +351,21 @@ customMultiGrammarPrinter =
   ,(strCI "cfg-prolog", CnvProlog.prtCMulti)
   ]
 
+---Options -> CanonGrammar -> String
+canon2gfccPr opts = printGFCC . canon2gfcc opts
+canon2gfcc opts = source2gfcc opts . canon2source ----
+canon2source = err error id . canon2sourceGrammar . unSubelimCanon
+
+source2gfcc opts gf = 
+  let 
+    (abs,gfcc) = GFCC.mkCanon2gfcc opts (gfcabs gf) gf
+    gfcc1 = maybe undefined id $ checkGFCCmaybe gfcc
+  in if oElem (iOpt "noopt") opts then gfcc1 else optGFCC gfcc1
+
+gfcabs gfc = 
+  prt $ head $ M.allConcretes gfc $ maybe (error "no abstract") id $ 
+   M.greatestAbstract gfc
+
 
 customSyntaxPrinter = 
   customData "Syntax printers, selected by option -printer=x" $