restored the possibility to compile .cf files to gf

5 files changed, 165 insertions, 1 deletions

diff --git a/examples/tutorial/food/food.cf b/examples/tutorial/food/food.cf
new file mode 100644
index 000000000..ace818c2e
--- /dev/null
+++ b/examples/tutorial/food/food.cf
@@ -0,0 +1,14 @@
+  Is.        Phrase  ::= Item "is" Quality ;
+  That.      Item    ::= "that" Kind ;
+  This.      Item    ::= "this" Kind ;
+  QKind.     Kind    ::= Quality Kind ;
+  Cheese.    Kind    ::= "cheese" ;
+  Fish.      Kind    ::= "fish" ;
+  Wine.      Kind    ::= "wine" ;
+  Italian.   Quality ::= "Italian" ;
+  Boring.    Quality ::= "boring" ;
+  Delicious. Quality ::= "delicious" ;
+  Expensive. Quality ::= "expensive" ;
+  Fresh.     Quality ::= "fresh" ;
+  Very.      Quality ::= "very" Quality ;
+  Warm.      Quality ::= "warm" ;
diff --git a/src/GF/Command/Importing.hs b/src/GF/Command/Importing.hs
index 390eda5b0..bbf03ddbc 100644
--- a/src/GF/Command/Importing.hs
+++ b/src/GF/Command/Importing.hs
@@ -8,6 +8,7 @@ import GF.Grammar.Grammar (SourceGrammar) -- for cc command
 import GF.Infra.UseIO
 import GF.Infra.Option
 import GF.Data.ErrM
+import GF.Source.CF
 
 import Data.List (nubBy)
 import System.FilePath
@@ -17,6 +18,17 @@ importGrammar :: PGF -> Options -> [FilePath] -> IO PGF
 importGrammar pgf0 _ [] = return pgf0
 importGrammar pgf0 opts files =
   case takeExtensions (last files) of
+    ".cf" -> do
+       s  <- fmap unlines $ mapM readFile files 
+       let cnc = justModuleName (last files)
+       gf <- case getCF cnc s of
+               Ok g -> return g
+               Bad s -> error s ---- 
+       Ok gr <- appIOE $ compileSourceGrammar opts gf
+       epgf <- appIOE $ link opts (cnc ++ "Abs") gr
+       case epgf of
+         Ok pgf -> return pgf
+         Bad s -> error s ----
     s | elem s [".gf",".gfo"] -> do
       res <- appIOE $ compileToPGF opts files
       case res of
diff --git a/src/GF/Source/CF.hs b/src/GF/Source/CF.hs
new file mode 100644
index 000000000..b268a8ecd
--- /dev/null
+++ b/src/GF/Source/CF.hs
@@ -0,0 +1,123 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : CF
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/11/15 17:56:13 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.13 $
+--
+-- parsing CF grammars and conversing them to GF
+-----------------------------------------------------------------------------
+
+module GF.Source.CF (getCF) where
+
+import GF.Grammar.Grammar
+import GF.Grammar.Macros
+import GF.Infra.Ident
+import GF.Infra.Modules
+
+import GF.Data.Operations
+
+import Data.Char
+import Data.List
+import qualified Data.ByteString.Char8 as BS
+
+getCF :: String -> String -> Err SourceGrammar
+getCF name = fmap (cf2gf name) . pCF
+
+---------------------
+-- the parser -------
+---------------------
+
+pCF :: String -> Err CF
+pCF s = do
+  rules <- mapM getCFRule $ filter isRule $ lines s
+  return $ concat rules
+ where
+   isRule line = case dropWhile isSpace line of
+     '-':'-':_ -> False
+     _ -> not $ all isSpace line
+
+-- rules have an amazingly easy parser, if we use the format
+-- fun. C -> item1 item2 ... where unquoted items are treated as cats
+-- Actually would be nice to add profiles to this.
+
+getCFRule :: String -> Err [CFRule]
+getCFRule s = getcf (wrds s) where
+  getcf ws = case ws of
+    fun : cat : a : its | isArrow a -> 
+      Ok [(init fun, (cat, map mkIt its))]
+    cat : a : its | isArrow a -> 
+      Ok [(mkFun cat it, (cat, map mkIt it)) | it <- chunk its]
+    _ -> Bad (" invalid rule:" +++ s)
+  isArrow a = elem a ["->", "::="] 
+  mkIt w = case w of
+    ('"':w@(_:_)) -> Right (init w)
+    _             -> Left w
+  chunk its = case its of
+    [] -> [[]]
+    _ -> chunks "|" its
+  mkFun cat its = case its of
+    [] -> cat ++ "_"
+    _ -> concat $ intersperse "_" (cat : map clean its) -- CLE style
+  clean = filter isAlphaNum -- to form valid identifiers
+  wrds = takeWhile (/= ";") . words -- to permit semicolon in the end
+
+type CF = [CFRule]
+
+type CFRule = (CFFun, (CFCat, [CFItem]))
+
+type CFItem = Either CFCat String
+
+type CFCat = String
+type CFFun = String
+
+--------------------------
+-- the compiler ----------
+--------------------------
+
+cf2gf :: String -> CF -> SourceGrammar
+cf2gf name cf = MGrammar [
+  (aname, ModMod (emptyModule {mtype = MTAbstract,       jments = abs})),
+  (cname, ModMod (emptyModule {mtype = MTConcrete aname, jments = cnc}))
+  ]
+ where
+   (abs,cnc) = cf2grammar cf
+   aname = identS $ name ++ "Abs"
+   cname = identS name
+
+
+cf2grammar :: CF -> (BinTree Ident Info, BinTree Ident Info)
+cf2grammar rules = (buildTree abs, buildTree conc) where
+  abs   = cats ++ funs
+  conc  = lincats ++ lins
+  cats  = [(cat, AbsCat (yes []) (yes [])) | 
+             cat <- nub (concat (map cf2cat rules))] ----notPredef cat
+  lincats = [(cat, CncCat (yes defLinType) nope nope) | (cat,AbsCat _ _) <- cats]
+  (funs,lins) = unzip (map cf2rule rules)
+
+cf2cat :: CFRule -> [Ident]
+cf2cat (_,(cat, items)) = map identS $ cat : [c | Left c <- items]
+
+cf2rule :: CFRule -> ((Ident,Info),(Ident,Info))
+cf2rule (fun, (cat, items)) = (def,ldef) where
+  f     = identS fun
+  def   = (f, AbsFun (yes (mkProd (args', Cn (identS cat), []))) nope)
+  args0 = zip (map (identS . ("x" ++) . show) [0..]) items
+  args  = [(v, Cn (identS c)) | (v, Left c) <- args0]
+  args' = [(identS "_", Cn (identS c)) | (_, Left c) <- args0]
+  ldef  = (f, CncFun 
+               Nothing 
+               (yes (mkAbs (map fst args) 
+                      (mkRecord (const theLinLabel) [foldconcat (map mkIt args0)])))
+               nope)
+  mkIt (v, Left _) = P (Vr v) theLinLabel
+  mkIt (_, Right a) = K a
+  foldconcat [] = K ""
+  foldconcat tt = foldr1 C tt
+
+identS = identC . BS.pack
+
diff --git a/src/GFC.hs b/src/GFC.hs
index 4e06641f9..62a57ba0c 100644
--- a/src/GFC.hs
+++ b/src/GFC.hs
@@ -8,6 +8,9 @@ import PGF.Raw.Parse
 import PGF.Raw.Convert
 import GF.Compile
 import GF.Compile.Export
+
+import GF.Source.CF ---- should this be on a deeper level? AR 15/10/2008
+
 import GF.Infra.UseIO
 import GF.Infra.Option
 import GF.Data.ErrM
@@ -20,6 +23,7 @@ mainGFC :: Options -> [FilePath] -> IOE ()
 mainGFC opts fs = 
     case () of
       _ | null fs -> fail $ "No input files."
+      _ | all (extensionIs ".cf")  fs -> compileCFFiles opts fs
       _ | all (extensionIs ".gf")  fs -> compileSourceFiles opts fs
       _ | all (extensionIs ".pgf") fs -> unionPGFFiles opts fs
       _ -> fail $ "Don't know what to do with these input files: " ++ show fs
@@ -34,6 +38,17 @@ compileSourceFiles opts fs =
          else do pgf <- link opts cnc gr
                  writeOutputs opts pgf
 
+compileCFFiles :: Options -> [FilePath] -> IOE ()
+compileCFFiles opts fs = 
+    do s  <- ioeIO $ fmap unlines $ mapM readFile fs 
+       let cnc = justModuleName (last fs)
+       gf <- ioeErr $ getCF cnc s
+       gr <- compileSourceGrammar opts gf
+       if flag optStopAfterPhase opts == Compile 
+         then return ()
+         else do pgf <- link opts cnc gr
+                 writeOutputs opts pgf
+
 unionPGFFiles :: Options -> [FilePath] -> IOE ()
 unionPGFFiles opts fs = 
     do pgfs <- ioeIO $ mapM readPGF fs
diff --git a/src/PGF/TypeCheck.hs b/src/PGF/TypeCheck.hs
index fb5130d56..1c0d04fd4 100644
--- a/src/PGF/TypeCheck.hs
+++ b/src/PGF/TypeCheck.hs
@@ -36,7 +36,7 @@ inferExpr :: PGF -> Expr -> Err Expr
 inferExpr pgf e = case infer pgf emptyTCEnv e of
   Ok (e,_,cs) -> let (ms,cs2) = splitConstraints cs in case cs2 of
     [] -> Ok (metaSubst ms e)
-    _  -> Bad ("Error: " ++ prConstraints cs2)
+    _  -> Bad ("Error in tree " ++ showExpr e ++ " :\n  " ++ prConstraints cs2)
   Bad s -> Bad s
 
 infer :: PGF -> TCEnv -> Expr -> Err (Expr, Value, [(Value,Value)])