started modifying GFtoGFCC for new internal GF format

2 files changed, 564 insertions, 0 deletions

diff --git a/src/GF/Devel/Compile/GFtoGFCC.hs b/src/GF/Devel/Compile/GFtoGFCC.hs
new file mode 100644
index 000000000..dc6a86a7a
--- /dev/null
+++ b/src/GF/Devel/Compile/GFtoGFCC.hs
@@ -0,0 +1,517 @@
+module GF.Devel.GFtoGFCC (prGrammar2gfcc,mkCanon2gfcc) where
+
+import GF.Devel.Compile.Factorize (unshareModule)
+
+import GF.Devel.Grammar.Grammar
+import GF.Devel.Grammar.Construct
+import qualified GF.Devel.Grammar.Lookup as Look
+
+import qualified GF.Devel.Grammar.Grammar as A ----
+import qualified GF.Devel.Grammar.Grammar as M ----
+import qualified GF.Devel.Grammar.Macros as GM
+--import qualified GF.Grammar.Compute as Compute
+
+import GF.Devel.Grammar.PrGF
+--import GF.Devel.ModDeps
+import GF.Infra.Ident
+
+import qualified GF.GFCC.Macros as CM
+import qualified GF.GFCC.AbsGFCC as C
+import qualified GF.GFCC.DataGFCC as D
+
+import GF.Infra.Option ----
+import GF.Data.Operations
+import GF.Text.UTF8
+
+import Data.List
+import Data.Char (isDigit,isSpace)
+import qualified Data.Map as Map
+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
+  (abs,gc) = mkCanon2gfcc opts cnc gr 
+
+mkCanon2gfcc :: Options -> String -> GF -> (String,D.GFCC)
+mkCanon2gfcc opts cnc gr = 
+  (prIdent abs, (canon2gfcc opts pars . reorder abs . canon2canon abs) gr)
+  where
+    abs = err error id $ Look.abstractOfConcrete gr (identC cnc)
+    pars = mkParamLincat gr
+
+-- Generate GFCC from GFCM.
+-- this assumes a grammar translated by canon2canon
+
+canon2gfcc :: Options -> (Ident -> Ident -> C.Term) -> GF -> D.GFCC
+canon2gfcc opts pars cgr =  
+  (if (oElem (iOpt "show_canon") opts) then trace (prt cgr) else id) $
+     D.GFCC an cns gflags abs cncs 
+ where
+  -- recognize abstract and concretes
+  [[(a,abm)],cms] = 
+    partition ((== MTAbstract) . mtype . snd) (Map.toList gfmodules cgr)
+
+  -- abstract
+  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)]] 
+                                          where fg = "firstlang"
+  aflags = Map.fromList [(C.CId f,x) | Opt (f,[x]) <- M.mflags abm]
+  mkDef pty = case pty of
+    Meta _ -> CM.primNotion
+    t -> mkExp t
+
+  funs = Map.fromAscList lfuns
+  cats = Map.fromAscList lcats
+
+  lfuns = [(i2i f, (mkType (jtype ju), mkDef (jdef ju))) | 
+                      (f,ju) <- listJudgements abm, jform ju == JFun]
+  lcats = [(i2i c, mkContext (GM.contextOfType (jtype ju))) |
+                      (c,ju) <- listJudgements abm, jform ju == JCat]
+  catfuns = Map.fromList 
+    [(cat,[f | (f, (C.DTyp _ c _,_)) <- lfuns, c==cat]) | (cat,_) <- lcats]
+
+  -- concretes
+  cncs  = Map.fromList [mkConcr lang (i2i lang) mo | (lang,mo) <- cms]
+  mkConcr lang0 lang mo = 
+      (lang,D.Concr flags lins opers lincats lindefs printnames params)
+    where
+      js = listJudgements mo
+      flags   = Map.fromList [(C.CId f,x) | Opt (f,[x]) <- M.mflags mo]
+      opers   = Map.fromAscList [] -- opers will be created as optimization
+      utf     = if elem (Opt ("coding",["utf8"])) (M.mflags mo) 
+                  then D.convertStringsInTerm decodeUTF8 else id
+      lins    = Map.fromAscList 
+        [(i2i f, utf (mkTerm (jdef ju))) | (f,ju) <- js, jform ju == JLin]
+      lincats = Map.fromAscList 
+        [(i2i c, utf (mkTerm (jtype ju))) | (c,ju) <- js, jform ju == JLincat]
+      lindefs = Map.fromAscList 
+        [(i2i c, utf (mkTerm (jdef ju))) | (c,ju) <- js, jform ju == JLincat]
+      printnames = Map.fromAscList 
+        [(i2i c, utf (mkTerm (jprintname ju))) | 
+                     (c,ju) <- js, elem (jform ju) [JLincat,JLin]]
+      params = Map.fromAscList 
+        [(i2i c, pars lang0 (jtype ju)) | (c,ju) <- js, jform ju == JLincat]
+
+i2i :: Ident -> C.CId
+i2i = C.CId . prIdent
+
+mkType :: A.Type -> C.Type
+mkType t = case GM.typeForm t of
+  (hyps,(Q _ cat),args) -> C.DTyp (mkContext hyps) (i2i cat) (map mkExp args)
+
+mkExp :: A.Term -> C.Exp
+mkExp t = case t of
+  A.Eqs eqs -> C.EEq [C.Equ (map mkPatt ps) (mkExp e) | (ps,e) <- eqs]
+  _ -> case GM.termForm t of
+    Ok (xx,c,args) -> C.DTr [i2i x | x <- xx] (mkAt c) (map mkExp args) 
+ where
+  mkAt c = case c of 
+    Q _ c  -> C.AC $ i2i c
+    QC _ c -> C.AC $ i2i c
+    Vr x   -> C.AV $ i2i x
+    EInt i -> C.AI i
+    EFloat f -> C.AF f
+    K s    -> C.AS s
+    Meta i -> C.AM $ toInteger i
+    _ -> C.AM 0
+  mkPatt p = uncurry CM.tree $ case p of
+    A.PP _ c ps -> (C.AC (i2i c), map mkPatt ps)
+    A.PV x      -> (C.AV (i2i x), [])
+    A.PW        -> (C.AV CM.wildCId, [])
+    A.PInt i    -> (C.AI i, [])
+
+mkContext :: A.Context -> [C.Hypo]
+mkContext hyps = [C.Hyp (i2i x) (mkType ty) | (x,ty) <- hyps]
+
+mkTerm :: Term -> C.Term
+mkTerm tr = case tr of
+  Vr (IA (_,i)) -> C.V i
+  Vr (IC s) | isDigit (last s) -> 
+    C.V (read (reverse (takeWhile (/='_') (reverse s)))) 
+    ---- from gf parser of gfc
+  EInt i      -> C.C $ fromInteger i
+  R rs     -> C.R [mkTerm t | (_, (_,t)) <- rs]
+  P t l    -> C.P (mkTerm t) (C.C (mkLab l))
+  T _ cs   -> C.R [mkTerm t | (_,t) <- cs] ------
+  V _ cs   -> C.R [mkTerm t | t <- cs]
+  S t p    -> C.P (mkTerm t) (mkTerm p)
+  C s t    -> C.S $ concatMap flats [mkTerm x | x <- [s,t]]
+  FV ts    -> C.FV [mkTerm t | t <- ts]
+  K s      -> C.K (C.KS s)
+-----  K (KP ss _) -> C.K (C.KP ss []) ---- TODO: prefix variants
+  Empty    -> C.S []
+  App _ _  -> prtTrace tr $ C.C 66661          ---- for debugging
+  Abs _ t  -> mkTerm t ---- only on toplevel
+  Alts (td,tvs) -> 
+    C.K (C.KP (strings td) [C.Var (strings u) (strings v) | (u,v) <- tvs])
+  _ -> prtTrace tr $ C.S [C.K (C.KS (prt tr +++ "66662"))] ---- for debugging
+ where
+   mkLab (LIdent l) = case l of
+     '_':ds -> (read ds) :: Int
+     _ -> prtTrace tr $ 66663
+   strings t = case t of
+     K s -> [s]
+     C u v -> strings u ++ strings v
+     FV ss -> concatMap strings ss
+     _ -> prtTrace tr $ ["66660"]
+   flats t = case t of
+     C.S ts -> concatMap flats ts
+     _ -> [t]
+
+-- encoding GFCC-internal lincats as terms
+mkCType :: Type -> C.Term
+mkCType t = case t of
+  EInt i      -> C.C $ fromInteger i
+  RecType rs  -> C.R [mkCType t | (_, t) <- rs]
+  Table pt vt -> case pt of
+    EInt i -> C.R $ replicate (1 + fromInteger i) $ mkCType vt
+    RecType rs -> mkCType $ foldr Table vt (map snd rs) 
+  Sort "Str"        -> C.S [] --- Str only
+  App (Q (IC "Predef") (IC "Ints")) (EInt i) -> C.C $ fromInteger i
+  _ -> error  $ "mkCType " ++ show t
+
+-- encoding showable lincats (as in source gf) as terms
+mkParamLincat :: GF -> Ident -> Ident -> C.Term
+mkParamLincat sgr lang cat = errVal (C.R [C.S []]) $ do 
+  typ <- Look.lookupLincat sgr lang cat
+  mkPType typ
+ where
+  mkPType typ = case typ of
+    RecType lts -> do
+      ts <- mapM (mkPType . snd) lts
+      return $ C.R [ C.P (kks $ prt_ l) t | ((l,_),t) <- zip lts ts]
+    Table (RecType lts) v -> do
+      ps <- mapM (mkPType . snd) lts
+      v' <- mkPType v
+      return $ foldr (\p v -> C.S [p,v]) v' ps
+    Table p v -> do
+      p' <- mkPType p
+      v' <- mkPType v
+      return $ C.S [p',v']
+    Sort "Str" -> return $ C.S []
+    _ -> return $ 
+      C.FV $ map (kks . filter showable . prt_) $ 
+             errVal [] $ Look.allParamValues sgr typ
+  showable c = not (isSpace c) ---- || (c == ' ')  -- to eliminate \n in records
+  kks = C.K . C.KS
+
+-- return just one module per language
+
+reorder :: Ident -> GF -> GF
+reorder abs cg = emptyGF {
+  gfabsname = abs,
+  gfcncnames = Map.fromList (map fst cncs),
+  gfmodules = Map.fromList ((abs,absm) : map mkCnc cncs)
+  } 
+ where
+    absm = emptyModule {
+      mtype = MTAbstract,
+      mflags = aflags,
+      mjments = adefs
+      }
+    mkCnc (c,cnc) = (c,emptyModule {
+      mtype = MTConcrete abs,
+      mflags = fst cnc,
+      mjments = snd cnc
+      })
+       
+    mos = gfmodules cg
+       
+    adefs = Map.fromAscList $ sortIds $
+                 predefADefs ++ Look.allOrigJudgements cg abs
+    predefADefs = 
+         [(IC c, absCat []) | c <- ["Float","Int","String"]]
+    aflags = nubByFst $ 
+         concat [M.mflags mo | (_,mo) <- mos, mtype mo == MTAbstract] ----too many
+
+    cncs = sortIds [(lang, concr lang) | lang <- Look.allConcretes cg abs]
+    concr la = (nubByFst flags, sortIds (predefCDefs ++ jments)) where 
+      jments = Look.allOrigJudgements cg la
+      flags  = Look.lookupFlags cg la
+                  ----concat [M.mflags mo | 
+                  ----  (i,mo) <- mos, M.isModCnc mo, 
+                  ----  Just r <- [lookup i (M.allExtendSpecs cg la)]]
+
+    predefCDefs = [(IC c, cncCat GM.defLinType) | 
+                       ---- lindef,printname 
+                         c <- ["Float","Int","String"]]
+
+    sortIds = sortBy (\ (f,_) (g,_) -> compare f g) 
+    
+nubByFst = nubBy (\ (f,_) (g,_) -> f == g)
+
+
+-- one grammar per language - needed for symtab generation
+repartition :: Ident -> GF -> [GF]
+repartition abs cg = [Look.partOfGrammar cg (lang,mo) | 
+  let mos = gfmodules cg,
+  lang   <- Look.allConcretes cg abs,
+  let mo = errVal 
+       (error ("no module found for " ++ prt lang)) $ Look.lookupModule cg lang
+  ]
+ 
+
+-- translate tables and records to arrays, parameters and labels to indices
+
+canon2canon :: Ident -> GF -> GF
+canon2canon abs = 
+   recollect . map cl2cl . repartition abs . purgeGrammar abs 
+ where
+  recollect gfs = emptyGF {gfmodules = nubModules gfs}
+  nubModules = Map.toList . nubByFst . concatMap (Map.fromList. gfmodules)
+
+  cl2cl = M.MGrammar . js2js . map (c2c p2p) . M.modules
+    
+  js2js ms = map (c2c (j2j (M.MGrammar ms))) ms
+
+  c2c f2 (c,m) = case m of
+      M.ModMod mo@(M.Module _ _ _ _ _ js) ->
+        (c, M.ModMod $ M.replaceJudgements mo $ mapTree f2 js)
+      _ -> (c,m)    
+  j2j cg (f,j) = case j of
+      CncFun x (Yes tr) z -> (f,CncFun x (Yes (t2t tr)) z)
+      CncCat (Yes ty) (Yes x) y -> (f,CncCat (Yes (ty2ty ty)) (Yes (t2t x)) y)
+      _ -> (f,j)
+   where
+      t2t = term2term cg pv
+      ty2ty = type2type cg pv
+      pv@(labels,untyps,typs) = paramValues cg ---trs $ paramValues cg
+
+    -- flatten record arguments of param constructors
+  p2p (f,j) = case j of
+      ResParam (Yes (ps,v)) -> 
+        (f,ResParam (Yes ([(c,concatMap unRec cont) | (c,cont) <- ps],Nothing)))
+      _ -> (f,j)
+  unRec (x,ty) = case ty of
+      RecType fs -> [ity | (_,typ) <- fs, ity <- unRec (identW,typ)] 
+      _ -> [(x,ty)]
+
+----
+  trs v = trace (tr v) v
+
+  tr (labels,untyps,typs) =
+     ("labels:" ++++
+       unlines [A.prt c ++ "." ++ unwords (map A.prt l) +++ "=" +++ show i  | 
+       ((c,l),i) <- Map.toList labels]) ++
+     ("untyps:" ++++ unlines [A.prt t +++ "=" +++ show i  | 
+       (t,i) <- Map.toList untyps]) ++
+     ("typs:" ++++ unlines [A.prt t | 
+       (t,_) <- Map.toList typs])
+----
+
+purgeGrammar :: Ident -> GF -> GF
+purgeGrammar abstr gr = 
+  (M.MGrammar . map unopt . filter complete . purge . M.modules) gr 
+ where
+  purge = nubBy (\x y -> fst x == fst y) . filter (flip elem needed . fst)
+  needed = nub $ concatMap (requiredCanModules isSingle gr) acncs
+  acncs = abstr : M.allConcretes gr abstr
+  isSingle = True
+  complete (i,M.ModMod m) = M.isCompleteModule m --- not . isIncompleteCanon
+  unopt = unshareModule gr -- subexp elim undone when compiled
+
+type ParamEnv =
+  (Map.Map (Ident,[Label]) (Type,Integer), -- numbered labels
+   Map.Map Term Integer,                   -- untyped terms to values
+   Map.Map Type (Map.Map Term Integer))    -- types to their terms to values
+
+--- gathers those param types that are actually used in lincats and lin terms
+paramValues :: GF -> ParamEnv
+paramValues cgr = (labels,untyps,typs) where
+  partyps = nub $ [ty | 
+              (_,(_,CncCat (Yes (RecType ls)) _ _)) <- jments,
+              ty0 <- [ty | (_, ty) <- unlockTyp ls],
+              ty  <- typsFrom ty0
+            ] ++ [
+             Q m ty | 
+              (m,(ty,ResParam _)) <- jments
+            ] ++ [ty | 
+              (_,(_,CncFun _ (Yes tr) _)) <- jments,
+              ty  <- err (const []) snd $ appSTM (typsFromTrm tr) []
+            ]
+  params = [(ty, errVal [] $ Look.allParamValues cgr ty) | ty <- partyps]
+  typsFrom ty = case ty of
+    Table p t  -> typsFrom p ++ typsFrom t
+    RecType ls -> RecType (sort (unlockTyp ls)) : concat [typsFrom t | (_, t) <- ls]
+    _ -> [ty]
+ 
+  typsFromTrm :: Term -> STM [Type] Term
+  typsFromTrm tr = case tr of
+    R fs -> mapM_ (typsFromField . snd) fs >> return tr 
+      where
+        typsFromField (mty, t) = case mty of
+          Just x -> updateSTM (x:) >> typsFromTrm t
+          _ -> typsFromTrm t
+    V ty ts -> updateSTM (ty:) >> mapM_ typsFromTrm ts >> return tr
+    T (TTyped ty) cs -> 
+      updateSTM (ty:) >> mapM_ typsFromTrm [t | (_, t) <- cs] >> return tr
+    T (TComp ty) cs -> 
+      updateSTM (ty:) >> mapM_ typsFromTrm [t | (_, t) <- cs] >> return tr
+    _ -> GM.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,[(LIdent "s",GM.typeStr)]) | cat <- ["Int", "Float", "String"]] ++
+    reverse ---- TODO: really those lincats that are reached
+            ---- reverse is enough to expel overshadowed ones... 
+      [(cat,(unlockTyp ls)) | (_,(cat,CncCat (Yes (RecType ls)) _ _)) <- jments]
+  labels = Map.fromList $ concat 
+    [((cat,[lab]),(typ,i)): 
+      [((cat,[lab,lab2]),(ty,j)) | 
+        rs <- getRec typ, ((lab2, ty),j) <- zip rs [0..]] 
+      | 
+        (cat,ls) <- lincats, ((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 :: GF -> ParamEnv -> Type -> Type
+type2type cgr env@(labels,untyps,typs) ty = case ty of
+  RecType rs ->
+    RecType [(mkLab i, t2t t) | (i,(l, t)) <- zip [0..] (unlockTyp rs)]
+  Table pt vt -> Table (t2t pt) (t2t vt)
+  QC _ _ -> look ty
+  _ -> ty
+ where
+   t2t = type2type cgr env
+   look ty = EInt $ (+ (-1)) $ toInteger $ case Map.lookup ty typs of
+     Just vs -> length $ Map.assocs vs
+     _ -> trace ("unknown partype " ++ show ty) 66669
+
+term2term :: GF -> ParamEnv -> Term -> Term
+term2term cgr env@(labels,untyps,typs) tr = case tr of
+  App _ _ -> mkValCase (unrec tr)
+  QC  _ _ -> mkValCase tr 
+  R rs    -> R [(mkLab i, (Nothing, t2t t)) | 
+                 (i,(l,(_,t))) <- zip [0..] (sort (unlock rs))]
+  P  t l   -> r2r tr
+  PI t l i -> EInt $ toInteger i
+  T (TComp  ty) cs  -> t2t $ V ty $ map snd cs ---- should be elim'ed in tc
+  T (TTyped ty) cs  -> t2t $ V ty $ map snd cs ---- should be elim'ed in tc
+  V ty ts  -> mkCurry $ V ty [t2t t | t <- ts]
+  S t p    -> mkCurrySel (t2t t) (t2t p)
+  _ -> GM.composSafeOp t2t tr
+ where
+   t2t = term2term cgr env
+
+   unrec t = case t of
+     App f (R fs) -> GM.mkApp (unrec f) [unrec u | (_,(_,u)) <- fs]
+     _ -> GM.composSafeOp unrec t
+
+   mkValCase tr = case appSTM (doVar tr) [] of
+     Ok (tr', st@(_:_)) -> t2t $ comp $ foldr mkCase tr' st
+     _ -> valNum $ comp tr
+
+   --- this is mainly needed for parameter record projections
+   ---- was: errVal t $ Compute.computeConcreteRec cgr t
+   comp t = case t of
+     T (TComp typ) ts  -> comp $ V typ (map (comp . snd) ts)  ---- should...
+     T (TTyped typ) ts -> comp $ V typ (map (comp . snd) ts)  ---- should
+     V typ ts -> V typ (map comp ts)
+     S (V typ ts) v0 -> err error id $ do
+       let v = comp v0 
+       return $ maybe t (comp . (ts !!) . fromInteger) $ Map.lookup v untyps
+     R r -> R [(l,(ty,comp t)) | (l,(ty,t)) <- r]
+     P (R r) l -> maybe t (comp . snd) $ lookup l r
+     _ -> GM.composSafeOp comp t
+
+   doVar :: Term -> STM [((Type,[Term]),(Term,Term))] Term
+   doVar tr = case getLab tr of
+     Ok (cat, lab) -> do
+       k <- readSTM >>= return . length
+       let tr' = Vr $ 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'
+     _ -> GM.composOp doVar tr
+
+   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 ((A.prt tr +++ prtTrace tr "66665"))
+
+   -- this goes recursively into tables (ignored) and records (accumulated)
+   getLab tr = case tr of
+     Vr (IA (cat, _)) -> return (identC cat,[])
+     Vr (IC s) -> return (identC cat,[]) where
+       cat = init (reverse (dropWhile (/='_') (reverse s))) ---- from gf parser
+----     Vr _ -> error $ "getLab " ++ show tr
+     P p lab2 -> do
+       (cat,labs) <- getLab p
+       return (cat,labs++[lab2]) 
+     S p _ -> getLab p
+     _ -> Bad "getLab"
+
+
+   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
+     _ -> GM.composSafeOp (mkBranch x t) tr     
+
+   valNum tr = maybe (valNumFV $ tryFV tr) EInt $ Map.lookup tr untyps
+    where
+      tryFV tr = case GM.appForm tr of
+        (c@(QC _ _), ts) -> [GM.mkApp c ts' | ts' <- combinations (map tryFV ts)]
+        (FV ts,_) -> ts
+        _ -> [tr]
+      valNumFV ts = case ts of
+        [tr] -> trace (unwords (map prt (Map.keys typs))) $ 
+                  prtTrace tr $ K "66667"
+        _ -> FV $ map valNum ts
+
+   mkCurry trm = case trm of
+     V (RecType [(_,ty)]) ts -> V ty ts 
+     V (RecType ((_,ty):ltys)) ts -> 
+       V ty [mkCurry (V (RecType ltys) cs) | 
+         cs <- chop (product (map (lengthtyp . snd) ltys)) ts] 
+     _ -> trm
+   lengthtyp ty = case Map.lookup ty typs of
+     Just m -> length (Map.assocs m)
+     _ -> error $ "length of type " ++ show ty
+   chop i xs = case splitAt i xs of 
+     (xs1,[])  -> [xs1]
+     (xs1,xs2) -> xs1:chop i xs2
+
+
+   mkCurrySel t p = S t p -- done properly in CheckGFCC
+
+
+mkLab k = LIdent (("_" ++ show k))
+
+-- remove lock fields; in fact, any empty records and record types
+unlock = filter notlock where
+  notlock (l,(_, t)) = case t of --- need not look at l
+     R [] -> False
+     _ -> True
+unlockTyp = filter notlock where
+  notlock (l, t) = case t of --- need not look at l
+     RecType [] -> False
+     _ -> True
+
+prtTrace tr n = 
+  trace ("-- INTERNAL COMPILER ERROR" +++ A.prt tr ++++ show n) n
+prTrace  tr n = trace ("-- OBSERVE" +++ A.prt tr +++ show n +++ show tr) n
+
diff --git a/src/GF/Devel/Grammar/Lookup.hs b/src/GF/Devel/Grammar/Lookup.hs
index ac55aec62..94021cb7d 100644
--- a/src/GF/Devel/Grammar/Lookup.hs
+++ b/src/GF/Devel/Grammar/Lookup.hs
@@ -80,6 +80,11 @@ lookupParamValues gf m c = do
      vs <- liftM combinations $ mapM (\ (_,ty) -> allParamValues gf ty) co
      return $ lmap (mkApp (QC m f)) vs
 
+lookupFlags :: GF -> Ident -> [(Ident,String)]
+lookupFlags gf m = errVal [] $ do
+  mo <- lookupModule gf m
+  return $ toList $ mflags mo
+
 allParamValues :: GF -> Type -> Err [Term]
 allParamValues cnc ptyp = case ptyp of
      App (Q (IC "Predef") (IC "Ints")) (EInt n) -> 
@@ -96,6 +101,47 @@ allParamValues cnc ptyp = case ptyp of
     -- to normalize records and record types
     sortByFst = sortBy (\ x y -> compare (fst x) (fst y))
 
+abstractOfConcrete :: GF -> Ident -> Err Ident
+abstractOfConcrete gf m = do
+  mo <- lookupModule gf m
+  case mtype mo of
+    MTConcrete a -> return a
+    MTInstance a -> return a
+    MTGrammar -> return m
+    _ -> prtBad "not concrete module" m
+
+allOrigJudgements :: GF -> Ident -> [(Ident,Judgement)]
+allOrigJudgements gf m = errVal [] $ do
+  mo <- lookupModule gf m
+  return [ju | ju@(_,j) <- listJudgements mo, jform j /= JLink]
+
+allConcretes :: GF -> Ident -> [Ident]
+allConcretes gf m = 
+  [c | (c,mo) <- toList (gfmodules gf), mtype mo == MTConcrete m]
+
+-- | select just those modules that a given one depends on, including itself
+partOfGrammar :: GF -> (Ident,Module) -> GF
+partOfGrammar gr (i,mo) = gr {
+  gfmodules = fromList [m | m@(j,_) <- mos, elem j modsFor]
+  } 
+  where
+    mos = toList $ gfmodules gr
+    modsFor = i : allDepsModule gr mo
+
+allDepsModule :: GF -> Module -> [Ident]
+allDepsModule gr m = iterFix add os0 where
+  os0 = depPathModule m
+  add os = [m | o <- os, Just n <- [llookup o mods], m <- depPathModule n]
+  mods = toList $ gfmodules gr
+
+-- | initial dependency list
+depPathModule :: Module -> [Ident]
+depPathModule mo = fors ++ lmap fst (mextends mo) ++ lmap snd (mopens mo) where
+  fors = case mtype mo of
+    MTConcrete i   -> [i]
+    MTInstance i   -> [i]
+    _              -> []
+
 -- infrastructure for lookup
     
 lookupModule :: GF -> Ident -> Err Module
@@ -121,4 +167,5 @@ mlookup = Data.Map.lookup
 raiseIdent msg i = raise (msg +++ prIdent i)
 
 lmap = Prelude.map
+llookup = Prelude.lookup