From 2b1d5a4d513970308f47c735212cbc253ec40961 Mon Sep 17 00:00:00 2001
From: aarne <aarne@cs.chalmers.se>
Date: Tue, 6 Nov 2007 14:44:17 +0000
Subject: [PATCH] Devel/GF3: experimentally putting together all
 functionalities for the first time

---
 src/GF/Command/Importing.hs | 34 ++++++++++++++++++++++++++++
 src/GF/Devel/GF3.hs         | 44 +++++++++++++++++++++++++++++++++++++
 src/GF/GFCC/API.hs          |  9 +++++---
 src/GF/GFCC/DataGFCC.hs     | 20 ++++++++++++-----
 src/Makefile                |  5 +++++
 5 files changed, 104 insertions(+), 8 deletions(-)
 create mode 100644 src/GF/Command/Importing.hs
 create mode 100644 src/GF/Devel/GF3.hs

diff --git a/src/GF/Command/Importing.hs b/src/GF/Command/Importing.hs
new file mode 100644
index 000000000..dc8255ad2
--- /dev/null
+++ b/src/GF/Command/Importing.hs
@@ -0,0 +1,34 @@
+module GF.Command.Importing (importGrammar) where
+
+import GF.Devel.Compile
+import GF.Devel.GrammarToGFCC
+import GF.GFCC.OptimizeGFCC
+import GF.GFCC.CheckGFCC
+import GF.GFCC.DataGFCC
+import GF.GFCC.ParGFCC
+import GF.GFCC.API
+import qualified GF.Command.AbsGFShell as C
+
+import GF.Devel.UseIO
+import GF.Infra.Option
+
+import Data.List (nubBy)
+
+-- import a grammar in an environment where it extends an existing grammar
+importGrammar :: MultiGrammar -> Options -> [FilePath] -> IO MultiGrammar
+importGrammar mgr0 opts files = do
+  gfcc2 <- case fileSuffix (last files) of
+    s | elem s ["gf","gfo"] -> do
+      gr <- batchCompile opts files
+      let name = justModuleName (last files)
+      let (abs,gfcc0) = mkCanon2gfcc opts name gr
+      (gfcc1,b) <- checkGFCC gfcc0
+      if b then return () else do
+        putStrLn "Corrupted GFCC"
+      return $ if oElem (iOpt "noopt") opts then gfcc1 else optGFCC gfcc1
+    "gfcc" -> 
+      mapM file2gfcc files >>= return . foldl1 unionGFCC
+  let gfcc3 = unionGFCC (gfcc mgr0) gfcc2
+  return $ MultiGrammar gfcc3 
+     (nubBy (\ (x,_) (y,_) -> x == y) (gfcc2parsers gfcc3 ++ parsers mgr0)) 
+     -- later coming parsers override
diff --git a/src/GF/Devel/GF3.hs b/src/GF/Devel/GF3.hs
new file mode 100644
index 000000000..742feb09a
--- /dev/null
+++ b/src/GF/Devel/GF3.hs
@@ -0,0 +1,44 @@
+module Main where
+
+import GF.Command.Interpreter
+import GF.Command.Importing
+import GF.Command.Commands
+import GF.GFCC.API
+
+import GF.Infra.Option ---- Haskell's option lib
+
+import System (getArgs)
+
+main :: IO ()
+main = do
+  putStrLn welcome
+  xx <- getArgs
+  env <- importInEnv emptyMultiGrammar xx
+  loop env
+  return ()
+
+loop :: CommandEnv -> IO CommandEnv
+loop env = do
+  s <- getLine
+  case words s of
+    "q":_ -> return env
+    "i":args -> do
+      env1 <- importInEnv (multigrammar env) args
+      loop env1
+    _ -> do
+      interpretCommandLine env s
+      loop env
+
+importInEnv mgr0 xx = do
+  let (opts,files) = getOptions "-" xx
+  mgr1 <- case files of
+    [] -> return mgr0
+    _  -> importGrammar mgr0 opts files
+  let env = CommandEnv mgr1 (allCommands mgr1)
+  putStrLn $ unwords $ "\nLanguages:" : languages mgr1
+  return env
+
+welcome = unlines [
+  "This is GF version 3.0 alpha.",
+  "Some things may work."
+  ]
diff --git a/src/GF/GFCC/API.hs b/src/GF/GFCC/API.hs
index a35faacb5..2abd0e09b 100644
--- a/src/GF/GFCC/API.hs
+++ b/src/GF/GFCC/API.hs
@@ -76,9 +76,10 @@ startCat   :: MultiGrammar -> Category
 
 file2grammar f = do
   gfcc <- file2gfcc f
-  let fcfgs = convertGrammar gfcc
-  return (MultiGrammar gfcc 
-            [(lang, buildFCFPInfo fcfg) | (CId lang,fcfg) <- fcfgs])
+  return (MultiGrammar gfcc (gfcc2parsers gfcc))
+
+gfcc2parsers gfcc =
+  [(lang, buildFCFPInfo fcfg) | (CId lang,fcfg) <- convertGrammar gfcc]
 
 file2gfcc f =
   readFileIf f >>= err (error) (return . mkGFCC) . pGrammar . myLexer
@@ -117,6 +118,8 @@ categories mgr = [c | CId c <- Map.keys (cats (abstract (gfcc mgr)))]
 
 startCat mgr = "S" ----
 
+emptyMultiGrammar = MultiGrammar emptyGFCC []
+
 ------------ for internal use only
 
 linearThis = GF.GFCC.API.linearize
diff --git a/src/GF/GFCC/DataGFCC.hs b/src/GF/GFCC/DataGFCC.hs
index ab2710e4c..47a891083 100644
--- a/src/GF/GFCC/DataGFCC.hs
+++ b/src/GF/GFCC/DataGFCC.hs
@@ -96,12 +96,22 @@ printGFCC gfcc0 = compactPrintGFCC $ printTree $ Grm
 -- merge two GFCCs; fails is differens absnames; priority to second arg
 
 unionGFCC :: GFCC -> GFCC -> GFCC
-unionGFCC one two = 
-  if absname one == absname two
-    then one {
+unionGFCC one two = case absname one of
+  CId "" -> two                  -- extending empty grammar
+  n | n == absname two -> one {  -- extending grammar with same abstract
       concretes = Data.Map.union (concretes two) (concretes one),
-      cncnames  = Data.List.union (cncnames two) (cncnames one)}
-    else one
+      cncnames  = Data.List.union (cncnames two) (cncnames one)
+    }
+  _ -> one   -- abstracts don't match ---- print error msg
+
+emptyGFCC :: GFCC
+emptyGFCC = GFCC {
+  absname   = CId "",
+  cncnames  = [] ,
+  abstract  = error "empty grammar, no abstract",
+  concretes = empty
+  }
+
 
 -- default map and filter are for Map here
 lmap = Prelude.map
diff --git a/src/Makefile b/src/Makefile
index 690b66cee..6cda7d458 100644
--- a/src/Makefile
+++ b/src/Makefile
@@ -203,6 +203,11 @@ gfcc:
 	strip gfcc
 	mv gfcc ../bin/
 
+gf3:
+	$(GHMAKE) $(GHCOPTFLAGS) -o gf3 GF/Devel/GF3.hs
+	strip gf3
+	mv gf3 ../bin/
+
 gfcc2c:
 	$(MAKE) -C tools/c
 	$(MAKE) -C ../lib/c