From 65bafe2a3bbdecc95f716f3c2f9c1388f4a3cc67 Mon Sep 17 00:00:00 2001 From: aarne Date: Wed, 15 Oct 2008 15:08:38 +0000 Subject: [PATCH] restored the possibility to compile .cf files to gf --- examples/tutorial/food/food.cf | 14 ++++ src/GF/Command/Importing.hs | 12 ++++ src/GF/Source/CF.hs | 123 +++++++++++++++++++++++++++++++++ src/GFC.hs | 15 ++++ src/PGF/TypeCheck.hs | 2 +- 5 files changed, 165 insertions(+), 1 deletion(-) create mode 100644 examples/tutorial/food/food.cf create mode 100644 src/GF/Source/CF.hs 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)])