new GFCC format in GF/GFCC

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

@@ -0,0 +1,79 @@
+Grm. Grammar  ::= 
+  "grammar" CId "(" [CId] ")" ";" 
+  Abstract ";" 
+  [Concrete] ;
+
+Abs. Abstract ::= 
+  "abstract" "{" 
+     "flags" [Flag] 
+     "fun"   [FunDef] 
+     "cat"   [CatDef] 
+  "}" ;
+
+Cnc. Concrete ::= 
+  "concrete" CId "{" 
+     "flags"  [Flag] 
+     "lin"    [LinDef] 
+     "oper"   [LinDef] 
+     "lincat" [LinDef] 
+     "lindef" [LinDef] 
+     "printname" [LinDef]
+  "}" ;
+
+Flg. Flag     ::= CId "=" String ;
+Cat. CatDef   ::= CId "[" [Hypo] "]" ;
+
+Fun. FunDef   ::= CId ":" Type "=" Exp ;
+Lin. LinDef   ::= CId "=" Term ;
+
+Typ. Type     ::= [CId] "->" CId ;          -- context-free type
+Tr.  Exp      ::= "(" Atom [Exp] ")" ;      -- context-free term
+
+AC.  Atom     ::= CId ;
+AS.  Atom     ::= String ;
+AI.  Atom     ::= Integer ;
+AF.  Atom     ::= Double ;
+AM.  Atom     ::= "?" Integer ;
+
+R.   Term     ::= "[" [Term] "]" ;          -- record/table
+P.   Term     ::= "(" Term "!" Term ")" ;   -- projection/selection
+S.   Term     ::= "(" [Term] ")" ;          -- concatenated sequence
+K.   Term     ::= Tokn ;                    -- token
+V.   Term     ::= "$" Integer ;             -- argument
+C.   Term     ::= Integer ;                 -- parameter value/label
+F.   Term     ::= CId ;                     -- global constant
+FV.  Term     ::= "[|" [Term] "|]" ;        -- free variation
+W.   Term     ::= "(" String "+" Term ")" ; -- prefix + suffix table
+TM.  Term     ::= "?" ;                     -- lin of metavariable
+
+KS.  Tokn     ::= String ;
+KP.  Tokn     ::= "[" "pre" [String] "[" [Variant] "]" "]" ;
+Var. Variant  ::= [String] "/" [String] ;
+
+
+terminator Concrete ";" ;
+terminator Flag ";" ;
+terminator CatDef ";" ;
+terminator FunDef ";" ;
+terminator LinDef ";" ;
+separator  CId "," ;
+separator  Term "," ;
+terminator Exp "" ;
+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
+
+
+
+
+