new GFCC format in GF/GFCC

src/GF/Devel/GFC.hs

@@ -3,16 +3,13 @@ module Main where
 import GF.Devel.Compile
 import GF.Devel.GrammarToGFCC
 import GF.Devel.OptimizeGFCC
-import GF.Canon.GFCC.CheckGFCC
+import GF.GFCC.CheckGFCC
-import GF.Canon.GFCC.PrintGFCC
+import GF.GFCC.DataGFCC
-import GF.Canon.GFCC.DataGFCC
 import GF.Devel.UseIO
 import GF.Infra.Option
----import GF.Devel.PrGrammar ---
 
 import System
 
-
 main = do
   xx <- getArgs
   let (opts,fs) = getOptions "-" xx
@@ -31,8 +28,7 @@ main = do
       mapM_ (batchCompile opts) (map return fs)
       putStrLn "Done."
 
-check gc0 = do
+check gfcc = do
-  let gfcc = mkGFCC gc0
   (gc,b) <- checkGFCC gfcc
   putStrLn $ if b then "OK" else "Corrupted GFCC"
   return gc

src/GF/Devel/GrammarToGFCC.hs

@@ -3,8 +3,8 @@ module GF.Devel.GrammarToGFCC (prGrammar2gfcc,mkCanon2gfcc) where
 import GF.Grammar.Grammar
 import qualified GF.Grammar.Lookup as Look
 
-import qualified GF.Canon.GFCC.AbsGFCC as C
+import qualified GF.GFCC.AbsGFCC as C
-import qualified GF.Canon.GFCC.PrintGFCC as Pr
+import qualified GF.GFCC.DataGFCC as D
 import qualified GF.Grammar.Abstract as A
 import qualified GF.Grammar.Macros as GM
 import qualified GF.Grammar.Compute as Compute
@@ -26,10 +26,10 @@ import Debug.Trace ----
 -- the main function: generate GFCC from GF.
 
 prGrammar2gfcc :: Options -> String -> SourceGrammar -> (String,String)
-prGrammar2gfcc opts cnc gr = (abs, Pr.printTree gc) where
+prGrammar2gfcc opts cnc gr = (abs, D.printGFCC gc) where
   (abs,gc) = mkCanon2gfcc opts cnc gr 
 
-mkCanon2gfcc :: Options -> String -> SourceGrammar -> (String,C.Grammar)
+mkCanon2gfcc :: Options -> String -> SourceGrammar -> (String,D.GFCC)
 mkCanon2gfcc opts cnc gr = 
   (prIdent abs, (canon2gfcc opts . reorder abs . utf8Conv . canon2canon abs) gr)
   where
@@ -38,27 +38,39 @@ mkCanon2gfcc opts cnc gr =
 -- Generate GFCC from GFCM.
 -- this assumes a grammar translated by canon2canon
 
-canon2gfcc :: Options -> SourceGrammar -> C.Grammar
+canon2gfcc :: Options -> SourceGrammar -> D.GFCC
 canon2gfcc opts cgr@(M.MGrammar ((a,M.ModMod abm):cms)) = 
   (if (oElem (iOpt "show_canon") opts) then trace (prGrammar cgr) else id) $
-     C.Grm (C.Hdr (i2i a) cs) (C.Abs adefs) cncs 
+     D.GFCC an cns abs cncs 
  where
-  cs  = map (i2i . fst) cms
+  an  = (i2i a)
-  adefs = [C.Fun f' (mkType ty) (C.Tr (C.AC f') []) | 
+  cns = map (i2i . fst) cms
-            (f,AbsFun (Yes ty) _) <- tree2list (M.jments abm), let f' = i2i f]
+  abs = D.Abstr aflags funs cats catfuns
-  cncs  = [C.Cnc (i2i lang) (concr m) | (lang,M.ModMod m) <- cms]
+  aflags = Map.fromAscList [] ---- flags
-  concr mo = cats mo ++ lindefs mo ++ 
+  lfuns = [(f', (mkType ty,C.Tr (C.AC f') [])) | ---- defs 
-                 [C.Lin (i2i f) (mkTerm tr) | 
+             (f,AbsFun (Yes ty) _) <- tree2list (M.jments abm), let f' = i2i f]
-                   (f,CncFun _ (Yes tr) _) <- tree2list (M.jments mo)]
+  funs = Map.fromAscList lfuns
-  cats mo = [C.Lin (i2ic c) (mkCType ty) | 
+  lcats = [(i2i c,[]) | ---- context
-                   (c,CncCat (Yes ty) _ _) <- tree2list (M.jments mo)]
+            (c,AbsCat _ _) <- tree2list (M.jments abm)]
-  lindefs mo = [C.Lin (i2id c) (mkTerm tr) | 
+  cats = Map.fromAscList lcats
-                   (c,CncCat _ (Yes tr) _) <- tree2list (M.jments mo)]
+  catfuns = Map.fromAscList 
+    [(cat,[f | (f, (C.Typ _ 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)
+    where
+      flags   = Map.fromAscList [] ---- flags
+      opers   = Map.fromAscList [] -- opers will be created as optimization
+      lins    = Map.fromAscList 
+        [(i2i f, mkTerm tr) | (f,CncFun _ (Yes tr) _) <- tree2list (M.jments mo)]
+      lincats = Map.fromAscList 
+        [(i2i c, mkCType ty) | (c,CncCat (Yes ty) _ _) <- tree2list (M.jments mo)]
+      lindefs = Map.fromAscList 
+        [(i2i c, mkTerm tr) | (c,CncCat _ (Yes tr) _) <- tree2list (M.jments mo)]
+      printnames = Map.fromAscList [] ---- printnames
 
 i2i :: Ident -> C.CId
 i2i (IC c) = C.CId c
-i2ic (IC c) = C.CId ("__" ++ c) -- for lincat of category symbols
-i2id (IC c) = C.CId ("_d" ++ c) -- for lindef of category symbols
 
 mkType :: A.Type -> C.Type
 mkType t = case GM.catSkeleton t of

src/GF/Devel/OptimizeGFCC.hs

@@ -1,41 +1,36 @@
 module GF.Devel.OptimizeGFCC where
 
-import qualified GF.Canon.GFCC.AbsGFCC as C
+import GF.GFCC.AbsGFCC
-import qualified GF.Canon.GFCC.DataGFCC as D
+import GF.GFCC.DataGFCC
-import qualified GF.Canon.GFCC.PrintGFCC as Pr
 
-import qualified GF.Infra.Option as O
-
-import GF.Infra.Option
 import GF.Data.Operations
 
 import Data.List
-import Data.Char (isDigit)
 import qualified Data.Map as Map
-import Debug.Trace ----
 
 
 -- back-end optimization: 
 -- suffix analysis followed by common subexpression elimination
 
-optGFCC :: D.GFCC -> D.GFCC
+optGFCC :: GFCC -> GFCC
 optGFCC gfcc = gfcc {
-  D.concretes = 
+  concretes = Map.map opt (concretes gfcc)
-    Map.fromAscList
-    [(lang, (opt cnc)) | (lang,cnc) <- Map.assocs (D.concretes gfcc)]
   }
  where 
-  opt cnc = Map.fromAscList $ subex [(f,optTerm t) | (f,t) <- Map.assocs cnc]
+  opt cnc = subex $ cnc {
+    lins = Map.map optTerm (lins cnc),
+    lindefs = Map.map optTerm (lindefs cnc),
+    printnames = Map.map optTerm (printnames cnc)
+  }
 
 -- analyse word form lists into prefix + suffixes
 -- suffix sets can later be shared by subex elim
 
-optTerm :: C.Term -> C.Term  
+optTerm :: Term -> Term  
 optTerm tr = case tr of
-    C.R ts@(_:_:_) | all isK ts -> mkSuff $ optToks [s | C.K (C.KS s) <- ts]
+    R ts@(_:_:_) | all isK ts -> mkSuff $ optToks [s | K (KS s) <- ts]
-    C.R ts  -> C.R $ map optTerm ts
+    R ts  -> R $ map optTerm ts
-    C.P t v -> C.P (optTerm t) v
+    P t v -> P (optTerm t) v
-    C.L x t -> C.L x (optTerm t)
     _ -> tr
  where
   optToks ss = prf : suffs where
@@ -45,67 +40,67 @@ optTerm tr = case tr 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
+    K (KS _) -> True
     _ -> False
-  mkSuff ("":ws) = C.R (map (C.K . C.KS) ws)
+  mkSuff ("":ws) = R (map (K . KS) ws)
-  mkSuff (p:ws) = C.W p (C.R (map (C.K . C.KS) ws))
+  mkSuff (p:ws) = W p (R (map (K . KS) ws))
 
 
--- common subexpression elimination; see ./Subexpression.hs for the idea
+-- common subexpression elimination
 
-subex :: [(C.CId,C.Term)] -> [(C.CId,C.Term)]
+---subex :: [(CId,Term)] -> [(CId,Term)]
-subex js = errVal js $ do
+subex :: Concr -> Concr
-  (tree,_) <- appSTM (getSubtermsMod js) (Map.empty,0)
+subex cnc = errVal cnc $ do
-  return $ addSubexpConsts tree js
+  (tree,_) <- appSTM (getSubtermsMod cnc) (Map.empty,0)
+  return $ addSubexpConsts tree cnc
 
-type TermList = Map.Map C.Term (Int,Int) -- number of occs, id
+type TermList = Map.Map Term (Int,Int) -- number of occs, id
 type TermM a = STM (TermList,Int) a
 
-addSubexpConsts :: TermList -> [(C.CId,C.Term)] -> [(C.CId,C.Term)]
+addSubexpConsts :: TermList -> Concr -> Concr
-addSubexpConsts tree lins =
+addSubexpConsts tree cnc = cnc {
-  let opers = sortBy (\ (f,_) (g,_) -> compare f g)
+  opers = Map.fromList [(f,recomp f trm) | (f,trm) <- ops],
-                [(fid id, trm) | (trm,(_,id)) <- list]
+  lins  = rec lins,
-  in map mkOne $ opers ++ lins
+  lindefs = rec lindefs,
+  printnames = rec printnames
+  }
  where
+   ops = [(fid id, trm) | (trm,(_,id)) <- Map.assocs tree]
    mkOne (f,trm) = (f, recomp f trm)
    recomp f t = case Map.lookup t tree of
-     Just (_,id) | fid id /= f -> C.F $ fid id -- not to replace oper itself
+     Just (_,id) | fid id /= f -> F $ fid id -- not to replace oper itself
      _ -> case t of
-       C.R ts   -> C.R $ map (recomp f) ts
+       R ts   -> R $ map (recomp f) ts
-       C.S ts   -> C.S $ map (recomp f) ts
+       S ts   -> S $ map (recomp f) ts
-       C.W s t  -> C.W s (recomp f t)
+       W s t  -> W s (recomp f t)
-       C.P t p  -> C.P (recomp f t) (recomp f p)
+       P t p  -> 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)
        _ -> t
-   fid n = C.CId $ "_" ++ show n
+   fid n = CId $ "_" ++ show n
-   list = Map.toList tree
+   rec field = Map.fromAscList [(f,recomp f trm) | (f,trm) <- Map.assocs (field cnc)]
 
-getSubtermsMod :: [(C.CId,C.Term)] -> TermM TermList
+
-getSubtermsMod js = do
+getSubtermsMod :: Concr -> TermM TermList
-  mapM (getInfo collectSubterms) js
+getSubtermsMod cnc = do
+  mapM getSubterms (Map.assocs (lins cnc))
+  mapM getSubterms (Map.assocs (lindefs cnc))
+  mapM getSubterms (Map.assocs (printnames cnc))
   (tree0,_) <- readSTM
   return $ Map.filter (\ (nu,_) -> nu > 1) tree0
  where
-   getInfo get (f,trm) = do
+   getSubterms (f,trm) = collectSubterms trm >> return ()
-     get trm
-     return ()
 
-collectSubterms :: C.Term -> TermM ()
+collectSubterms :: Term -> TermM ()
 collectSubterms t = case t of
-  C.R ts -> do
+  R ts -> do
     mapM collectSubterms ts
     add t
-  C.RP u v -> do
+  S ts -> do
-    collectSubterms v
-    add t
-  C.S ts -> do
     mapM collectSubterms ts
     add t
-  C.W s u -> do
+  W s u -> do
     collectSubterms u
     add t
-  C.P p u -> do
+  P p u -> do
     collectSubterms p
     collectSubterms u
     add t

src/GF/Devel/Shell.hs

@@ -0,0 +1,67 @@
+module Main where
+
+import GF.GFCC.API
+import System.Random (newStdGen)
+import System (getArgs)
+import Data.Char (isDigit)
+
+-- Simple translation application built on GFCC. AR 7/9/2006 -- 19/9/2007
+
+main :: IO ()
+main = do
+  file:_  <- getArgs
+  grammar <- file2grammar file
+  printHelp grammar
+  loop grammar
+
+loop :: MultiGrammar -> IO ()
+loop grammar = do
+  s <- getLine
+  if s == "q" then return () else do
+    treat grammar s
+    loop grammar
+
+printHelp grammar = do
+  putStrLn $ "languages:  " ++ unwords (languages grammar)
+  putStrLn $ "categories: " ++ unwords (categories grammar)
+  putStrLn commands
+
+
+commands = unlines [
+  "Commands:",
+  "  (gt | gtt | gr | grt) Cat Num - generate all or random",
+  "  p Lang Cat String             - parse (unquoted) string",
+  "  l Tree                        - linearize in all languages",
+  "  h                             - help",
+  "  q                             - quit"
+  ]
+
+treat :: MultiGrammar -> String -> IO ()
+treat mgr s = case words s of
+  "gt" :cat:n:_ -> mapM_ prlinonly $ take (read1 n) $ generateAll mgr cat
+  "gtt":cat:n:_ -> mapM_ prlin $ take (read1 n) $ generateAll mgr cat
+  "gr" :cat:n:_ -> generateRandom mgr cat >>= mapM_ prlinonly . take (read1 n) 
+  "grt":cat:n:_ -> generateRandom mgr cat >>= mapM_ prlin . take (read1 n) 
+  "p":lang:cat:ws -> do
+    let ts = parse mgr lang cat $ unwords ws
+    mapM_ (putStrLn . showTree) ts 
+  "h":_ -> printHelp mgr
+  _ -> lins $ readTree mgr s
+ where
+  grammar = gfcc mgr
+  langs = languages mgr
+  lins t = mapM_ (lint t) $ langs 
+  lint t lang = do
+----    putStrLn $ showTree $ linExp grammar lang t 
+    lin t lang
+  lin t lang = do
+    putStrLn $ linearize mgr lang t
+  prlins t = do
+    putStrLn $ showTree t
+    lins t
+  prlin t = do
+    putStrLn $ showTree t
+    prlinonly t
+  prlinonly t = mapM_ (lin t) $ langs
+  read1 s = if all isDigit s then read s else 1
+

src/GF/GFCC/API.hs

@@ -0,0 +1,129 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : GFCCAPI
+-- Maintainer  : Aarne Ranta
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 
+-- > CVS $Author: 
+-- > CVS $Revision: 
+--
+-- Reduced Application Programmer's Interface to GF, meant for
+-- embedded GF systems. AR 19/9/2007
+-----------------------------------------------------------------------------
+
+module  GF.GFCC.API where
+
+import GF.GFCC.DataGFCC
+import GF.GFCC.AbsGFCC
+import GF.GFCC.ParGFCC
+import GF.GFCC.PrintGFCC
+import GF.GFCC.ErrM
+import GF.GFCC.Generate
+----import GF.Parsing.FCFG
+----import GF.Conversion.SimpleToFCFG (convertGrammar,FCat(..))
+
+--import GF.Data.Operations
+--import GF.Infra.UseIO
+import qualified Data.Map as Map
+import System.Random (newStdGen)
+import System.Directory (doesFileExist)
+
+
+-- This API is meant to be used when embedding GF grammars in Haskell 
+-- programs. The embedded system is supposed to use the
+-- .gfcm grammar format, which is first produced by the gf program.
+
+---------------------------------------------------
+-- Interface
+---------------------------------------------------
+
+----data MultiGrammar = MultiGrammar {gfcc :: GFCC, parsers :: [(Language,FCFPInfo)]}
+data MultiGrammar = MultiGrammar {gfcc :: GFCC, parsers :: [(Language,())]}
+type Language     = String
+type Category     = String
+type Tree         = Exp
+
+file2grammar :: FilePath -> IO MultiGrammar
+
+linearize    :: MultiGrammar -> Language -> Tree -> String
+parse        :: MultiGrammar -> Language -> Category -> String -> [Tree]
+
+linearizeAll     :: MultiGrammar -> Tree -> [String]
+linearizeAllLang :: MultiGrammar -> Tree -> [(Language,String)]
+
+parseAll     :: MultiGrammar -> Category -> String -> [[Tree]]
+parseAllLang :: MultiGrammar -> Category -> String -> [(Language,[Tree])]
+
+generateAll    :: MultiGrammar -> Category -> [Tree]
+generateRandom :: MultiGrammar -> Category -> IO [Tree]
+
+readTree   :: MultiGrammar -> String -> Tree
+showTree   ::                 Tree -> String
+
+languages  :: MultiGrammar -> [Language]
+categories :: MultiGrammar -> [Category]
+
+startCat   :: MultiGrammar -> Category
+
+---------------------------------------------------
+-- Implementation
+---------------------------------------------------
+
+file2grammar f = do
+  gfcc <- file2gfcc f
+----  let fcfgs = convertGrammar gfcc
+----  return (MultiGrammar gfcc [(lang, buildFCFPInfo fcfg) | (CId lang,fcfg) <- fcfgs])
+  return (MultiGrammar gfcc [])
+
+file2gfcc f =
+  readFileIf f >>= err (error) (return . mkGFCC) . pGrammar . myLexer
+
+linearize mgr lang = GF.GFCC.DataGFCC.linearize (gfcc mgr) (CId lang)
+
+parse mgr lang cat s = error "no parser"
+----parse mgr lang cat s = 
+----  case lookup lang (parsers mgr) of
+----    Nothing    -> error "no parser"
+----    Just pinfo -> case parseFCF "bottomup" pinfo (CId cat) (words s) of
+----                    Ok x -> x
+----                    Bad s -> error s
+
+linearizeAll mgr = map snd . linearizeAllLang mgr
+linearizeAllLang mgr t = 
+  [(lang,linearThis mgr lang t) | lang <- languages mgr]
+
+parseAll mgr cat = map snd . parseAllLang mgr cat
+
+parseAllLang mgr cat s = 
+  [(lang,ts) | lang <- languages mgr, let ts = parse mgr lang cat s, not (null ts)]
+
+generateRandom mgr cat = do
+  gen <- newStdGen
+  return $ genRandom gen (gfcc mgr) (CId cat)
+
+generateAll mgr cat = generate (gfcc mgr) (CId cat)
+
+readTree _ = err (const exp0) id . (pExp . myLexer)
+
+showTree t = printTree t
+
+languages mgr = [l | CId l <- cncnames (gfcc mgr)]
+
+categories mgr = [c | CId c <- Map.keys (cats (abstract (gfcc mgr)))]
+
+startCat mgr = "S" ----
+
+------------ for internal use only
+
+linearThis = GF.GFCC.API.linearize
+
+err f g ex = case ex of
+  Ok x -> g x
+  Bad s -> f s
+
+readFileIf f = do
+  b <- doesFileExist f
+  if b then readFile f 
+       else putStrLn ("file " ++ f ++ " not found") >> return ""

src/GF/GFCC/AbsGFCC.hs

@@ -0,0 +1,83 @@
+module GF.GFCC.AbsGFCC where
+
+-- Haskell module generated by the BNF converter
+
+newtype CId = CId String deriving (Eq,Ord,Show)
+data Grammar =
+   Grm CId [CId] Abstract [Concrete]
+  deriving (Eq,Ord,Show)
+
+data Abstract =
+   Abs [Flag] [FunDef] [CatDef]
+  deriving (Eq,Ord,Show)
+
+data Concrete =
+   Cnc CId [Flag] [LinDef] [LinDef] [LinDef] [LinDef] [LinDef]
+  deriving (Eq,Ord,Show)
+
+data Flag =
+   Flg CId String
+  deriving (Eq,Ord,Show)
+
+data CatDef =
+   Cat CId [Hypo]
+  deriving (Eq,Ord,Show)
+
+data FunDef =
+   Fun CId Type Exp
+  deriving (Eq,Ord,Show)
+
+data LinDef =
+   Lin CId Term
+  deriving (Eq,Ord,Show)
+
+data Type =
+   Typ [CId] CId
+ | DTyp [Hypo] CId [Exp]
+  deriving (Eq,Ord,Show)
+
+data Exp =
+   Tr Atom [Exp]
+ | DTr [CId] Atom [Exp]
+ | EEq [Equation]
+  deriving (Eq,Ord,Show)
+
+data Atom =
+   AC CId
+ | AS String
+ | AI Integer
+ | AF Double
+ | AM Integer
+ | AV CId
+  deriving (Eq,Ord,Show)
+
+data Term =
+   R [Term]
+ | P Term Term
+ | S [Term]
+ | K Tokn
+ | V Int --H
+ | C Int --H
+ | F CId
+ | FV [Term]
+ | W String Term
+ | TM
+  deriving (Eq,Ord,Show)
+
+data Tokn =
+   KS String
+ | KP [String] [Variant]
+  deriving (Eq,Ord,Show)
+
+data Variant =
+   Var [String] [String]
+  deriving (Eq,Ord,Show)
+
+data Hypo =
+   Hyp CId Type
+  deriving (Eq,Ord,Show)
+
+data Equation =
+   Equ [Exp] Exp
+  deriving (Eq,Ord,Show)
+

src/GF/GFCC/CheckGFCC.hs

@@ -0,0 +1,162 @@
+module GF.GFCC.CheckGFCC where
+
+import GF.GFCC.DataGFCC
+import GF.GFCC.AbsGFCC
+import GF.GFCC.PrintGFCC
+import GF.GFCC.ErrM
+
+import qualified Data.Map as Map
+import Control.Monad
+
+andMapM :: Monad m => (a -> m Bool) -> [a] -> m Bool
+andMapM f xs = mapM f xs >>= return . and
+
+labelBoolIO :: String -> IO (x,Bool) -> IO (x,Bool)
+labelBoolIO msg iob = do
+  (x,b) <- iob
+  if b then return (x,b) else (putStrLn msg >> return (x,b))
+
+checkGFCC :: GFCC -> IO (GFCC,Bool)
+checkGFCC gfcc = do
+  (cs,bs) <- mapM (checkConcrete gfcc) 
+               (Map.assocs (concretes gfcc)) >>= return . unzip
+  return (gfcc {concretes = Map.fromAscList cs}, and bs)
+
+checkConcrete :: GFCC -> (CId,Concr) -> IO ((CId,Concr),Bool)
+checkConcrete gfcc (lang,cnc) = 
+  labelBoolIO ("happened in language " ++ printTree lang) $ do
+    (rs,bs) <- mapM checkl (Map.assocs (lins cnc)) >>= return . unzip
+    return ((lang,cnc{lins = Map.fromAscList rs}),and bs)
+ where
+   checkl = checkLin gfcc lang
+
+checkLin :: GFCC -> CId -> (CId,Term) -> IO ((CId,Term),Bool)
+checkLin gfcc lang (f,t) = 
+  labelBoolIO ("happened in function " ++ printTree f) $ do
+    (t',b) <- checkTerm (lintype gfcc lang f) t --- $ inline gfcc lang t
+    return ((f,t'),b)
+
+inferTerm :: [Tpe] -> Term -> Err (Term,Tpe)
+inferTerm args trm = case trm of
+  K _ -> returnt str
+  C i -> returnt $ ints i
+  V i -> do
+    testErr (i < length args) ("too large index " ++ show i) 
+    returnt $ args !! i
+  S ts -> do
+    (ts',tys) <- mapM infer ts >>= return . unzip
+    let tys' = filter (/=str) tys
+    testErr (null tys')
+      ("expected Str in " ++ prt trm ++ " not " ++ unwords (map prt tys')) 
+    return (S ts',str)
+  R ts -> do
+    (ts',tys) <- mapM infer ts >>= return . unzip
+    return $ (R ts',tuple tys)
+  P t u -> do
+    (t',tt) <- infer t
+    (u',tu) <- infer u
+    case tt of
+      R tys -> case tu of
+        R vs -> infer $ foldl P t' [P u' (C i) | i <- [0 .. length vs - 1]]
+        --- R [v] -> infer $ P t v
+        --- R (v:vs) -> infer $ P (head tys) (R vs)
+        
+        C i -> do
+          testErr (i < length tys) 
+            ("required more than " ++ show i ++ " fields in " ++ prt (R tys)) 
+          return (P t' u', tys !! i) -- record: index must be known
+        _ -> do
+          let typ = head tys
+          testErr (all (==typ) tys) ("different types in table " ++ prt trm) 
+          return (P t' u', typ)      -- table: types must be same
+      _ -> Bad $ "projection from " ++ prt t ++ " : " ++ prt tt
+  FV [] -> returnt str ----
+  FV (t:ts) -> do
+    (t',ty) <- infer t
+    (ts',tys) <- mapM infer ts >>= return . unzip
+    testErr (all (==ty) tys) ("different types in variants " ++ prt trm)
+    return (FV (t':ts'),ty)
+  W s r -> infer r
+  _ -> Bad ("no type inference for " ++ prt trm)
+ where
+   returnt ty = return (trm,ty)
+   infer = inferTerm args
+   prt = printTree
+
+checkTerm :: LinType -> Term -> IO (Term,Bool)
+checkTerm (args,val) trm = case inferTerm args trm of
+  Ok (t,ty) -> if eqType ty val 
+             then return (t,True) 
+             else do
+    putStrLn $ "term: " ++ printTree trm ++ 
+               "\nexpected type: " ++ printTree val ++
+               "\ninferred type: " ++ printTree ty
+    return (t,False)
+  Bad s -> do
+    putStrLn s
+    return (trm,False)
+
+eqType :: Tpe -> Tpe -> Bool
+eqType inf exp = case (inf,exp) of
+  (C k, C n)  -> k <= n -- only run-time corr.
+  (R rs,R ts) -> length rs == length ts && and [eqType r t | (r,t) <- zip rs ts]
+  _ -> inf == exp
+
+-- should be in a generic module, but not in the run-time DataGFCC
+
+type Tpe = Term
+type LinType = ([Tpe],Tpe)
+
+tuple :: [Tpe] -> Tpe
+tuple = R
+
+ints :: Int -> Tpe
+ints = C
+
+str :: Tpe
+str = S []
+
+lintype :: GFCC -> CId -> CId -> LinType
+lintype gfcc lang fun = case lookType gfcc fun of
+  Typ cs c -> (map linc cs, linc c)
+ where 
+   linc = lookLincat gfcc lang
+
+inline :: GFCC -> CId -> Term -> Term
+inline gfcc lang t = case t of
+  F c -> inl $ look c
+  _ -> composSafeOp inl t
+ where
+  inl  = inline gfcc lang
+  look = lookLin gfcc lang
+
+composOp :: Monad m => (Term -> m Term) -> Term -> m Term
+composOp f trm = case trm of
+  R  ts -> liftM R $ mapM f ts
+  S  ts -> liftM S $ mapM f ts
+  FV ts -> liftM FV $ mapM f ts
+  P t u -> liftM2 P (f t) (f u)
+  W s t -> liftM (W s) $ f t
+  _ -> return trm
+
+composSafeOp :: (Term -> Term) -> Term -> Term
+composSafeOp f = maybe undefined id . composOp (return . f)
+
+-- from GF.Data.Oper
+
+maybeErr :: String -> Maybe a -> Err a
+maybeErr s = maybe (Bad s) Ok
+
+testErr :: Bool -> String -> Err ()
+testErr cond msg = if cond then return () else Bad msg
+
+errVal :: a -> Err a -> a
+errVal a = err (const a) id
+
+errIn :: String -> Err a -> Err a
+errIn msg = err (\s -> Bad (s ++ "\nOCCURRED IN\n" ++ msg)) return
+
+err :: (String -> b) -> (a -> b) -> Err a -> b 
+err d f e = case e of
+  Ok a -> f a
+  Bad s -> d s

src/GF/GFCC/ComposOp.hs

@@ -0,0 +1,30 @@
+{-# OPTIONS_GHC -fglasgow-exts #-}
+module GF.GFCC.ComposOp (Compos(..),composOp,composOpM,composOpM_,composOpMonoid,
+                 composOpMPlus,composOpFold) where
+
+import Control.Monad.Identity
+import Data.Monoid
+
+class Compos t where
+  compos :: (forall a. a -> m a) -> (forall a b. m (a -> b) -> m a -> m b)
+         -> (forall a. t a -> m (t a)) -> t c -> m (t c)
+
+composOp :: Compos t => (forall a. t a -> t a) -> t c -> t c
+composOp f = runIdentity . composOpM (Identity . f)
+
+composOpM :: (Compos t, Monad m) => (forall a. t a -> m (t a)) -> t c -> m (t c)
+composOpM = compos return ap
+
+composOpM_ :: (Compos t, Monad m) => (forall a. t a -> m ()) -> t c -> m ()
+composOpM_ = composOpFold (return ()) (>>)
+
+composOpMonoid :: (Compos t, Monoid m) => (forall a. t a -> m) -> t c -> m
+composOpMonoid = composOpFold mempty mappend
+
+composOpMPlus :: (Compos t, MonadPlus m) => (forall a. t a -> m b) -> t c -> m b
+composOpMPlus = composOpFold mzero mplus
+
+composOpFold :: Compos t => b -> (b -> b -> b) -> (forall a. t a -> b) -> t c -> b
+composOpFold z c f = unC . compos (\_ -> C z) (\(C x) (C y) -> C (c x y)) (C . f)
+
+newtype C b a = C { unC :: b }

src/GF/GFCC/DataGFCC.hs

@@ -0,0 +1,195 @@
+module GF.GFCC.DataGFCC where
+
+import GF.GFCC.AbsGFCC
+import GF.GFCC.PrintGFCC
+import Data.Map
+import Data.List
+
+-- internal datatypes for GFCC
+
+data GFCC = GFCC {
+  absname   :: CId ,
+  cncnames  :: [CId] ,
+  abstract  :: Abstr ,
+  concretes :: Map CId Concr
+  }
+
+data Abstr = Abstr {
+  aflags  :: Map CId String,     -- value of a flag
+  funs    :: Map CId (Type,Exp), -- type and def of a fun
+  cats    :: Map CId [Hypo],     -- context of a cat
+  catfuns :: Map CId [CId]       -- funs yielding a cat (redundant, for fast lookup)
+  }
+
+data Concr = Concr {
+  flags   :: Map CId String, -- value of a flag
+  lins    :: Map CId Term,   -- lin of a fun
+  opers   :: Map CId Term,   -- oper generated by subex elim
+  lincats :: Map CId Term,   -- lin type of a cat
+  lindefs :: Map CId Term,   -- lin default of a cat
+  printnames :: Map CId Term -- printname of a cat or a fun
+  }
+
+statGFCC :: GFCC -> String
+statGFCC gfcc = unlines [
+  "Abstract\t" ++ pr (absname gfcc), 
+  "Concretes\t" ++ unwords (lmap pr (cncnames gfcc)), 
+  "Categories\t" ++ unwords (lmap pr (keys (cats (abstract gfcc)))) 
+  ]
+ where pr (CId s) = s
+
+lookLin :: GFCC -> CId -> CId -> Term
+lookLin gfcc lang fun = 
+  lookMap TM fun $ lins $ lookMap (error "no lang") lang $ concretes gfcc
+
+lookOper :: GFCC -> CId -> CId -> Term
+lookOper gfcc lang fun = 
+  lookMap TM fun $ opers $ lookMap (error "no lang") lang $ concretes gfcc
+
+lookLincat :: GFCC -> CId -> CId -> Term
+lookLincat gfcc lang fun = 
+  lookMap TM fun $ lincats $ lookMap (error "no lang") lang $ concretes gfcc
+
+-- | Look up the type of a function.
+lookType :: GFCC -> CId -> Type
+lookType gfcc f = 
+  fst $ lookMap (error $ "lookType " ++ show f) f (funs (abstract gfcc))
+
+linearize :: GFCC -> CId -> Exp -> String
+linearize mcfg lang = realize . linExp mcfg lang
+
+realize :: Term -> String
+realize trm = case trm of
+  R ts     -> realize (ts !! 0)
+  S ss     -> unwords $ lmap realize ss
+  K t -> case t of
+    KS s -> s
+    KP s _ -> unwords s ---- prefix choice TODO
+  W s t    -> s ++ realize t
+  FV ts    -> realize (ts !! 0)  ---- other variants TODO
+  TM       -> "?"
+  _ -> "ERROR " ++ show trm ---- debug
+
+linExp :: GFCC -> CId -> Exp -> Term
+linExp mcfg lang tree@(Tr at trees) = 
+  case at of
+    AC fun -> comp (lmap lin trees) $ look fun
+    AS s   -> R [kks (show s)] -- quoted
+    AI i   -> R [kks (show i)]
+    AF d   -> R [kks (show d)]
+    AM _   -> TM
+ where
+   lin  = linExp mcfg lang
+   comp = compute mcfg lang
+   look = lookLin mcfg lang
+
+exp0 :: Exp
+exp0 = Tr (AM 0) []
+
+term0 :: CId -> Term
+term0 _ = TM
+
+kks :: String -> Term
+kks = K . KS
+
+compute :: GFCC -> CId -> [Term] -> Term -> Term
+compute mcfg lang args = comp where
+  comp trm = case trm of
+    P r p  -> proj (comp r) (comp p) 
+    W s t  -> W s (comp t)
+    R ts   -> R $ lmap comp ts
+    V i    -> idx args i          -- already computed
+    F c    -> comp $ look c       -- not computed (if contains argvar)
+    FV ts  -> FV $ lmap comp ts
+    S ts   -> S $ lfilter (/= S []) $ lmap comp ts
+    _ -> trm
+
+  look = lookOper mcfg lang
+
+  idx xs i = if i > length xs - 1 
+    then error 
+         ("too large " ++ show i ++ " for\n" ++ unlines (lmap prt xs) ++ "\n") TM 
+    else xs !! i 
+
+  proj r p = case (r,p) of
+    (_,     FV ts) -> FV $ lmap (proj r) ts
+    (FV ts, _    ) -> FV $ lmap (\t -> proj t r) ts
+    (W s t, _)     -> kks (s ++ getString (proj t p))
+    _              -> comp $ getField r (getIndex p)
+
+  getString t = case t of
+    K (KS s) -> s
+    _ -> error ("ERROR in grammar compiler: string from "++ show t) "ERR"
+
+  getIndex t =  case t of
+    C i    -> i
+    TM     -> 0  -- default value for parameter
+    _ -> error ("ERROR in grammar compiler: index from " ++ show t) 0
+
+  getField t i = case t of
+    R rs   -> idx rs i
+    TM     -> TM
+    _ -> error ("ERROR in grammar compiler: field from " ++ show t) t
+
+  prt = printTree
+
+
+-- convert parsed grammar to internal GFCC
+
+mkGFCC :: Grammar -> GFCC
+mkGFCC (Grm a cs ab@(Abs afls fs cts) ccs) = GFCC {
+  absname = a,
+  cncnames = cs,
+  abstract = 
+    let
+      aflags  = fromAscList [(f,v) | Flg f v <- afls]
+      lfuns   = [(fun,(typ,def)) | Fun fun typ def <- fs]
+      funs    = fromAscList lfuns
+      lcats   = [(c,hyps) | Cat c hyps <- cts]
+      cats    = fromAscList lcats
+      catfuns = fromAscList 
+                  [(cat,[f | (f, (Typ _ c,_)) <- lfuns, c==cat]) | (cat,_) <- lcats]
+    in Abstr aflags funs cats catfuns,
+  concretes = fromAscList (lmap mkCnc ccs)
+  }
+ where
+   mkCnc (Cnc lang fls ls ops lincs linds prns) = 
+       (lang, Concr flags lins opers lincats lindefs printnames) where
+     flags      = fromAscList [(f,v) | Flg f v <- fls]  
+     lins       = fromAscList [(f,v) | Lin f v <- ls]  
+     opers      = fromAscList [(f,v) | Lin f v <- ops]  
+     lincats    = fromAscList [(f,v) | Lin f v <- lincs]  
+     lindefs    = fromAscList [(f,v) | Lin f v <- linds]  
+     printnames = fromAscList [(f,v) | Lin f v <- prns]  
+
+
+-- convert internal GFCC and pretty-print it
+
+printGFCC :: GFCC -> String
+printGFCC gfcc = printTree $ Grm
+  (absname gfcc) 
+  (cncnames gfcc)
+  (Abs
+    [Flg f v     | (f,v) <- assocs (aflags (abstract gfcc))]
+    [Fun f ty df | (f,(ty,df)) <- assocs (funs (abstract gfcc))]
+    [Cat f v     | (f,v) <- assocs (cats (abstract gfcc))]
+    )
+  [fromCnc lang cnc | (lang,cnc) <- assocs (concretes gfcc)]
+ where
+   fromCnc lang cnc = Cnc lang 
+     [Flg f v | (f,v) <- assocs (flags cnc)]
+     [Lin f v | (f,v) <- assocs (lins cnc)]
+     [Lin f v | (f,v) <- assocs (opers cnc)]
+     [Lin f v | (f,v) <- assocs (lincats cnc)]
+     [Lin f v | (f,v) <- assocs (lindefs cnc)]
+     [Lin f v | (f,v) <- assocs (printnames cnc)]
+
+-- lookup with default value
+lookMap :: (Show i, Ord i) => a -> i -> Map i a -> a 
+lookMap d c m = maybe d id $ Data.Map.lookup c m
+
+-- default map and filter are for Map here
+lmap = Prelude.map
+lfilter = Prelude.filter
+
+

src/GF/GFCC/ErrM.hs

@@ -0,0 +1,26 @@
+-- BNF Converter: Error Monad
+-- Copyright (C) 2004  Author:  Aarne Ranta
+
+-- This file comes with NO WARRANTY and may be used FOR ANY PURPOSE.
+module GF.GFCC.ErrM where
+
+-- the Error monad: like Maybe type with error msgs
+
+import Control.Monad (MonadPlus(..), liftM)
+
+data Err a = Ok a | Bad String
+  deriving (Read, Show, Eq, Ord)
+
+instance Monad Err where
+  return      = Ok
+  fail        = Bad
+  Ok a  >>= f = f a
+  Bad s >>= f = Bad s
+
+instance Functor Err where
+  fmap = liftM
+
+instance MonadPlus Err where
+  mzero = Bad "Err.mzero"
+  mplus (Bad _) y = y
+  mplus x       _ = x

src/GF/GFCC/GFCC.cf

@@ -1,50 +1,43 @@
-Grm. Grammar  ::= Header ";" Abstract ";" [Concrete] ;
+Grm. Grammar  ::= 
-Hdr. Header   ::= "grammar" CId "(" [CId] ")" ;
+  "grammar" CId "(" [CId] ")" ";" 
+  Abstract ";" 
+  [Concrete] ;
 
 Abs. Abstract ::= 
   "abstract" "{" 
      "flags" [Flag] 
-     "cat"   [CatDef] 
      "fun"   [FunDef] 
+     "cat"   [CatDef] 
   "}" ;
 
 Cnc. Concrete ::= 
   "concrete" CId "{" 
      "flags"  [Flag] 
+     "lin"    [LinDef] 
      "oper"   [LinDef] 
      "lincat" [LinDef] 
      "lindef" [LinDef] 
-     "lin"    [LinDef] 
+     "printname" [LinDef]
   "}" ;
 
 Flg. Flag     ::= CId "=" String ;
-
+Cat. CatDef   ::= CId "[" [Hypo] "]" ;
-Cat. CatDef   ::= CId [Hypo] ;
 
 Fun. FunDef   ::= CId ":" Type "=" Exp ;
-
 Lin. LinDef   ::= CId "=" Term ;
 
-Hyp. Hypo     ::= "(" CId ":" Type ")" ;
+Typ. Type     ::= [CId] "->" CId ;          -- context-free type
-
+Tr.  Exp      ::= "(" Atom [Exp] ")" ;      -- context-free term
-FTyp. Type    ::= [CId] "->" CId ;            -- simple type
-DTyp. Type    ::= "[" [Hypo] "->" Type "]" ;  -- dep. product type
-BTyp. Type    ::= "(" CId [Exp] ")" ;         -- dep. basic type
-
-Tr.   Exp     ::= "(" Atom [Exp] ")" ;               -- ordinary term
-DTr.  Exp     ::= "[" "(" [CId] ")" Atom [Exp] "]" ; -- term with bindings
 
 AC.  Atom     ::= CId ;
 AS.  Atom     ::= String ;
 AI.  Atom     ::= Integer ;
 AF.  Atom     ::= Double ;
-AM.  Atom     ::= "?" ;
+AM.  Atom     ::= "?" Integer ;
-trA. Exp      ::= Atom ;
-define trA a = Tr a [] ;
 
 R.   Term     ::= "[" [Term] "]" ;          -- record/table
 P.   Term     ::= "(" Term "!" Term ")" ;   -- projection/selection
-S.   Term     ::= "(" [Term] ")" ;          -- sequence with ++
+S.   Term     ::= "(" [Term] ")" ;          -- concatenated sequence
 K.   Term     ::= Tokn ;                    -- token
 V.   Term     ::= "$" Integer ;             -- argument
 C.   Term     ::= Integer ;                 -- parameter value/label
@@ -63,7 +56,6 @@ terminator Flag ";" ;
 terminator CatDef ";" ;
 terminator FunDef ";" ;
 terminator LinDef ";" ;
-terminator Hypo "" ;
 separator  CId "," ;
 separator  Term "," ;
 terminator Exp "" ;
@@ -71,3 +63,17 @@ terminator String "" ;
 separator  Variant "," ;
 
 token CId (('_' | letter) (letter | digit | '\'' | '_')*) ;
+
+-- the following are needed if dependent types or HOAS or defs are present
+
+Hyp.  Hypo    ::= CId ":" Type ;
+DTyp. Type    ::= "[" [Hypo] "]" CId [Exp] ;         -- dependent type
+DTr.  Exp     ::= "[" "(" [CId] ")" Atom [Exp] "]" ; -- term with bindings
+AV.   Atom    ::= "$" CId ;
+
+EEq.  Exp      ::= "{" [Equation] "}" ;  -- list of pattern eqs; primitive notion: []
+Equ.  Equation ::= [Exp] "->" Exp ;      -- patterns are encoded as exps
+
+terminator Hypo ";" ;
+terminator Equation ";" ;
+

src/GF/GFCC/Generate.hs

@@ -0,0 +1,79 @@
+module GF.GFCC.Generate where
+
+import GF.GFCC.DataGFCC
+import GF.GFCC.AbsGFCC
+
+import qualified Data.Map as M
+import System.Random
+
+-- generate an infinite list of trees exhaustively
+generate :: GFCC -> CId -> [Exp]
+generate gfcc cat = concatMap (\i -> gener i cat) [0..]
+ where
+  gener 0 c = [Tr (AC f) [] | (f, Typ [] _) <- fns c]
+  gener i c = [
+    tr | 
+      (f, Typ cs _) <- fns c,
+      let alts = map (gener (i-1)) cs,
+      ts <- combinations alts,
+      let tr = Tr (AC f) ts,
+      depth tr >= i
+    ]
+  fns cat = 
+    let fs = lookMap [] cat $ catfuns $ abstract gfcc
+    in [(f,ty) | f <- fs, Just (ty,_) <- [M.lookup f $ funs $ abstract gfcc]]
+  depth tr = case tr of
+    Tr _ [] -> 1
+    Tr _ ts -> maximum (map depth ts) + 1
+
+--- from Operations
+combinations :: [[a]] -> [[a]]
+combinations t = case t of 
+  []    -> [[]]
+  aa:uu -> [a:u | a <- aa, u <- combinations uu]
+
+-- generate an infinite list of trees randomly
+genRandom :: StdGen -> GFCC -> CId -> [Exp]
+genRandom gen gfcc cat = genTrees (randomRs (0.0, 1.0) gen) cat where
+
+  timeout = 47 -- give up
+
+  genTrees ds0 cat = 
+    let (ds,ds2) = splitAt (timeout+1) ds0  -- for time out, else ds
+        (t,k) = genTree ds cat      
+    in (if k>timeout then id else (t:))
+                (genTrees ds2 cat)          -- else (drop k ds)
+
+  genTree rs = gett rs where
+    gett ds (CId "String") = (Tr (AS "foo") [], 1)
+    gett ds (CId "Int")    = (Tr (AI 12345) [], 1)
+    gett [] _ = (Tr (AS "TIMEOUT") [], 1) ----
+    gett ds cat = case fns cat of
+      [] -> (Tr (AM 0) [],1)
+      fs -> let 
+          d:ds2    = ds
+          (f,args) = getf d fs
+          (ts,k)   = getts ds2 args
+        in (Tr (AC f) ts, k+1)
+    getf d fs = let lg = (length fs) in
+      fs !! (floor (d * fromIntegral lg))
+    getts ds cats = case cats of
+      c:cs -> let 
+          (t, k)  = gett ds c
+          (ts,ks) = getts (drop k ds) cs 
+        in (t:ts, k + ks)
+      _ -> ([],0)
+
+    fns cat = 
+      let fs = maybe [] id $ M.lookup cat $ catfuns $ abstract gfcc
+      in [(f,cs) | f <- fs, 
+            Just (Typ cs _,_) <- [M.lookup f $ funs $ abstract gfcc]]
+
+-- brute-force parsing method; only returns the first result
+-- note: you cannot throw away rules with unknown words from the grammar
+-- because it is not known which field in each rule may match the input
+
+searchParse :: Int -> GFCC -> CId -> [String] -> [Exp]
+searchParse i gfcc cat ws = [t | t <- gen, s <- lins t, words s == ws] where 
+  gen    = take i $ generate gfcc cat
+  lins t = [linearize gfcc lang t | lang <- cncnames gfcc]

src/GF/GFCC/PrintGFCC.hs

@@ -0,0 +1,217 @@
+{-# OPTIONS -fno-warn-incomplete-patterns #-}
+module GF.GFCC.PrintGFCC where
+
+-- pretty-printer generated by the BNF converter
+
+import GF.GFCC.AbsGFCC
+import Char
+
+-- the top-level printing method
+printTree :: Print a => a -> String
+printTree = render . prt 0
+
+type Doc = [ShowS] -> [ShowS]
+
+doc :: ShowS -> Doc
+doc = (:)
+
+render :: Doc -> String
+render d = rend 0 (map ($ "") $ d []) "" where
+  rend i ss = case ss of
+    "["      :ts -> showChar '[' . rend i ts
+    "("      :ts -> showChar '(' . rend i ts
+    "{"      :ts -> showChar '{' . new (i+1) . rend (i+1) ts
+    "}" : ";":ts -> new (i-1) . space "}" . showChar ';' . new (i-1) . rend (i-1) ts
+    "}"      :ts -> new (i-1) . showChar '}' . new (i-1) . rend (i-1) ts
+    ";"      :ts -> showChar ';' . new i . rend i ts
+    t  : "," :ts -> showString t . space "," . rend i ts
+    t  : ")" :ts -> showString t . showChar ')' . rend i ts
+    t  : "]" :ts -> showString t . showChar ']' . rend i ts
+    t        :ts -> space t . rend i ts
+    _            -> id
+  new i   = showChar '\n' . replicateS (2*i) (showChar ' ') . dropWhile isSpace
+  space t = showString t . (\s -> if null s then "" else (' ':s))
+
+parenth :: Doc -> Doc
+parenth ss = doc (showChar '(') . ss . doc (showChar ')')
+
+concatS :: [ShowS] -> ShowS
+concatS = foldr (.) id
+
+concatD :: [Doc] -> Doc
+concatD = foldr (.) id
+
+replicateS :: Int -> ShowS -> ShowS
+replicateS n f = concatS (replicate n f)
+
+-- the printer class does the job
+class Print a where
+  prt :: Int -> a -> Doc
+  prtList :: [a] -> Doc
+  prtList = concatD . map (prt 0)
+
+instance Print a => Print [a] where
+  prt _ = prtList
+
+instance Print Char where
+  prt _ s = doc (showChar '\'' . mkEsc '\'' s . showChar '\'')
+  prtList s = doc (showChar '"' . concatS (map (mkEsc '"') s) . showChar '"')
+
+mkEsc :: Char -> Char -> ShowS
+mkEsc q s = case s of
+  _ | s == q -> showChar '\\' . showChar s
+  '\\'-> showString "\\\\"
+  '\n' -> showString "\\n"
+  '\t' -> showString "\\t"
+  _ -> showChar s
+
+prPrec :: Int -> Int -> Doc -> Doc
+prPrec i j = if j<i then parenth else id
+
+
+instance Print Integer where
+  prt _ x = doc (shows x)
+
+instance Print Int where  --H
+  prt _ x = doc (shows x) --H
+
+instance Print Double where
+  prt _ x = doc (shows x)
+
+
+
+instance Print CId where
+  prt _ (CId i) = doc (showString i)
+  prtList es = case es of
+   [] -> (concatD [])
+   [x] -> (concatD [prt 0 x])
+   x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
+
+
+
+instance Print Grammar where
+  prt i e = case e of
+   Grm cid cids abstract concretes -> prPrec i 0 (concatD [doc (showString "grammar") , prt 0 cid , doc (showString "(") , prt 0 cids , doc (showString ")") , doc (showString ";") , prt 0 abstract , doc (showString ";") , prt 0 concretes])
+
+
+instance Print Abstract where
+  prt i e = case e of
+   Abs flags fundefs catdefs -> prPrec i 0 (concatD [doc (showString "abstract") , doc (showString "{") , doc (showString "flags") , prt 0 flags , doc (showString "fun") , prt 0 fundefs , doc (showString "cat") , prt 0 catdefs , doc (showString "}")])
+
+
+instance Print Concrete where
+  prt i e = case e of
+   Cnc cid flags lindefs0 lindefs1 lindefs2 lindefs3 lindefs -> prPrec i 0 (concatD [doc (showString "concrete") , prt 0 cid , doc (showString "{") , doc (showString "flags") , prt 0 flags , doc (showString "lin") , prt 0 lindefs0 , doc (showString "oper") , prt 0 lindefs1 , doc (showString "lincat") , prt 0 lindefs2 , doc (showString "lindef") , prt 0 lindefs3 , doc (showString "printname") , prt 0 lindefs , doc (showString "}")])
+
+  prtList es = case es of
+   [] -> (concatD [])
+   x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
+
+instance Print Flag where
+  prt i e = case e of
+   Flg cid str -> prPrec i 0 (concatD [prt 0 cid , doc (showString "=") , prt 0 str])
+
+  prtList es = case es of
+   [] -> (concatD [])
+   x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
+
+instance Print CatDef where
+  prt i e = case e of
+   Cat cid hypos -> prPrec i 0 (concatD [prt 0 cid , doc (showString "[") , prt 0 hypos , doc (showString "]")])
+
+  prtList es = case es of
+   [] -> (concatD [])
+   x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
+
+instance Print FunDef where
+  prt i e = case e of
+   Fun cid type' exp -> prPrec i 0 (concatD [prt 0 cid , doc (showString ":") , prt 0 type' , doc (showString "=") , prt 0 exp])
+
+  prtList es = case es of
+   [] -> (concatD [])
+   x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
+
+instance Print LinDef where
+  prt i e = case e of
+   Lin cid term -> prPrec i 0 (concatD [prt 0 cid , doc (showString "=") , prt 0 term])
+
+  prtList es = case es of
+   [] -> (concatD [])
+   x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
+
+instance Print Type where
+  prt i e = case e of
+   Typ cids cid -> prPrec i 0 (concatD [prt 0 cids , doc (showString "->") , prt 0 cid])
+   DTyp hypos cid exps -> prPrec i 0 (concatD [doc (showString "[") , prt 0 hypos , doc (showString "]") , prt 0 cid , prt 0 exps])
+
+
+instance Print Exp where
+  prt i e = case e of
+   Tr atom exps -> prPrec i 0 (concatD [doc (showString "(") , prt 0 atom , prt 0 exps , doc (showString ")")])
+   DTr cids atom exps -> prPrec i 0 (concatD [doc (showString "[") , doc (showString "(") , prt 0 cids , doc (showString ")") , prt 0 atom , prt 0 exps , doc (showString "]")])
+   EEq equations -> prPrec i 0 (concatD [doc (showString "{") , prt 0 equations , doc (showString "}")])
+
+  prtList es = case es of
+   [] -> (concatD [])
+   x:xs -> (concatD [prt 0 x , prt 0 xs])
+
+instance Print Atom where
+  prt i e = case e of
+   AC cid -> prPrec i 0 (concatD [prt 0 cid])
+   AS str -> prPrec i 0 (concatD [prt 0 str])
+   AI n -> prPrec i 0 (concatD [prt 0 n])
+   AF d -> prPrec i 0 (concatD [prt 0 d])
+   AM n -> prPrec i 0 (concatD [doc (showString "?") , prt 0 n])
+   AV cid -> prPrec i 0 (concatD [doc (showString "$") , prt 0 cid])
+
+
+instance Print Term where
+  prt i e = case e of
+   R terms -> prPrec i 0 (concatD [doc (showString "[") , prt 0 terms , doc (showString "]")])
+   P term0 term -> prPrec i 0 (concatD [doc (showString "(") , prt 0 term0 , doc (showString "!") , prt 0 term , doc (showString ")")])
+   S terms -> prPrec i 0 (concatD [doc (showString "(") , prt 0 terms , doc (showString ")")])
+   K tokn -> prPrec i 0 (concatD [prt 0 tokn])
+   V n -> prPrec i 0 (concatD [doc (showString "$") , prt 0 n])
+   C n -> prPrec i 0 (concatD [prt 0 n])
+   F cid -> prPrec i 0 (concatD [prt 0 cid])
+   FV terms -> prPrec i 0 (concatD [doc (showString "[|") , prt 0 terms , doc (showString "|]")])
+   W str term -> prPrec i 0 (concatD [doc (showString "(") , prt 0 str , doc (showString "+") , prt 0 term , doc (showString ")")])
+   TM  -> prPrec i 0 (concatD [doc (showString "?")])
+
+  prtList es = case es of
+   [] -> (concatD [])
+   [x] -> (concatD [prt 0 x])
+   x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
+
+instance Print Tokn where
+  prt i e = case e of
+   KS str -> prPrec i 0 (concatD [prt 0 str])
+   KP strs variants -> prPrec i 0 (concatD [doc (showString "[") , doc (showString "pre") , prt 0 strs , doc (showString "[") , prt 0 variants , doc (showString "]") , doc (showString "]")])
+
+
+instance Print Variant where
+  prt i e = case e of
+   Var strs0 strs -> prPrec i 0 (concatD [prt 0 strs0 , doc (showString "/") , prt 0 strs])
+
+  prtList es = case es of
+   [] -> (concatD [])
+   [x] -> (concatD [prt 0 x])
+   x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
+
+instance Print Hypo where
+  prt i e = case e of
+   Hyp cid type' -> prPrec i 0 (concatD [prt 0 cid , doc (showString ":") , prt 0 type'])
+
+  prtList es = case es of
+   [] -> (concatD [])
+   x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
+
+instance Print Equation where
+  prt i e = case e of
+   Equ exps exp -> prPrec i 0 (concatD [prt 0 exps , doc (showString "->") , prt 0 exp])
+
+  prtList es = case es of
+   [] -> (concatD [])
+   x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
+
+

src/GF/GFCC/SkelGFCC.hs

@@ -0,0 +1,110 @@
+module GF.GFCC.SkelGFCC where
+
+-- Haskell module generated by the BNF converter
+
+import GF.GFCC.AbsGFCC
+import GF.GFCC.ErrM
+type Result = Err String
+
+failure :: Show a => a -> Result
+failure x = Bad $ "Undefined case: " ++ show x
+
+transCId :: CId -> Result
+transCId x = case x of
+  CId str  -> failure x
+
+
+transGrammar :: Grammar -> Result
+transGrammar x = case x of
+  Grm cid cids abstract concretes  -> failure x
+
+
+transAbstract :: Abstract -> Result
+transAbstract x = case x of
+  Abs flags fundefs catdefs  -> failure x
+
+
+transConcrete :: Concrete -> Result
+transConcrete x = case x of
+  Cnc cid flags lindefs0 lindefs1 lindefs2 lindefs3 lindefs  -> failure x
+
+
+transFlag :: Flag -> Result
+transFlag x = case x of
+  Flg cid str  -> failure x
+
+
+transCatDef :: CatDef -> Result
+transCatDef x = case x of
+  Cat cid hypos  -> failure x
+
+
+transFunDef :: FunDef -> Result
+transFunDef x = case x of
+  Fun cid type' exp  -> failure x
+
+
+transLinDef :: LinDef -> Result
+transLinDef x = case x of
+  Lin cid term  -> failure x
+
+
+transType :: Type -> Result
+transType x = case x of
+  Typ cids cid  -> failure x
+  DTyp hypos cid exps  -> failure x
+
+
+transExp :: Exp -> Result
+transExp x = case x of
+  Tr atom exps  -> failure x
+  DTr cids atom exps  -> failure x
+  EEq equations  -> failure x
+
+
+transAtom :: Atom -> Result
+transAtom x = case x of
+  AC cid  -> failure x
+  AS str  -> failure x
+  AI n  -> failure x
+  AF d  -> failure x
+  AM n  -> failure x
+  AV cid  -> failure x
+
+
+transTerm :: Term -> Result
+transTerm x = case x of
+  R terms  -> failure x
+  P term0 term  -> failure x
+  S terms  -> failure x
+  K tokn  -> failure x
+  V n  -> failure x
+  C n  -> failure x
+  F cid  -> failure x
+  FV terms  -> failure x
+  W str term  -> failure x
+  TM  -> failure x
+
+
+transTokn :: Tokn -> Result
+transTokn x = case x of
+  KS str  -> failure x
+  KP strs variants  -> failure x
+
+
+transVariant :: Variant -> Result
+transVariant x = case x of
+  Var strs0 strs  -> failure x
+
+
+transHypo :: Hypo -> Result
+transHypo x = case x of
+  Hyp cid type'  -> failure x
+
+
+transEquation :: Equation -> Result
+transEquation x = case x of
+  Equ exps exp  -> failure x
+
+
+

src/GF/GFCC/TestGFCC.hs

@@ -0,0 +1,58 @@
+-- automatically generated by BNF Converter
+module Main where
+
+
+import IO ( stdin, hGetContents )
+import System ( getArgs, getProgName )
+
+import GF.GFCC.LexGFCC
+import GF.GFCC.ParGFCC
+import GF.GFCC.SkelGFCC
+import GF.GFCC.PrintGFCC
+import GF.GFCC.AbsGFCC
+
+
+
+
+import GF.GFCC.ErrM
+
+type ParseFun a = [Token] -> Err a
+
+myLLexer = myLexer
+
+type Verbosity = Int
+
+putStrV :: Verbosity -> String -> IO ()
+putStrV v s = if v > 1 then putStrLn s else return ()
+
+runFile :: (Print a, Show a) => Verbosity -> ParseFun a -> FilePath -> IO ()
+runFile v p f = putStrLn f >> readFile f >>= run v p
+
+run :: (Print a, Show a) => Verbosity -> ParseFun a -> String -> IO ()
+run v p s = let ts = myLLexer s in case p ts of
+           Bad s    -> do putStrLn "\nParse              Failed...\n"
+                          putStrV v "Tokens:"
+                          putStrV v $ show ts
+                          putStrLn s
+           Ok  tree -> do putStrLn "\nParse Successful!"
+                          showTree v tree
+
+
+
+showTree :: (Show a, Print a) => Int -> a -> IO ()
+showTree v tree
+ = do
+      putStrV v $ "\n[Abstract Syntax]\n\n" ++ show tree
+      putStrV v $ "\n[Linearized tree]\n\n" ++ printTree tree
+
+main :: IO ()
+main = do args <- getArgs
+          case args of
+            [] -> hGetContents stdin >>= run 2 pGrammar
+            "-s":fs -> mapM_ (runFile 0 pGrammar) fs
+            fs -> mapM_ (runFile 2 pGrammar) fs
+
+
+
+
+

src/Makefile

@@ -199,7 +199,8 @@ gfc:
 	mv gfc ../bin/
 
 gfcc:
-	$(GHMAKE) $(GHCOPTFLAGS) -o gfcc GF/Canon/GFCC/Shell.hs
+#	$(GHMAKE) $(GHCOPTFLAGS) -o gfcc GF/Canon/GFCC/Shell.hs
+	$(GHMAKE) $(GHCOPTFLAGS) -o gfcc GF/Devel/Shell.hs
 	strip gfcc
 	mv gfcc ../bin/