From 769121788a01bc4a21cd69299a788876244e3d31 Mon Sep 17 00:00:00 2001
From: aarne <aarne@chalmers.se>
Date: Sun, 28 Aug 2011 10:35:55 +0000
Subject: [PATCH] import command now gives priority to new abstract syntax, and
 discards the old concretes if they are for the old abstract; the new priority
 is implemented in PGF.Data.unionPGF

---
 src/compiler/GF/Command/Commands.hs  |  6 +++++-
 src/compiler/GF/Command/Importing.hs |  9 +++++++--
 src/runtime/haskell/PGF/Data.hs      | 22 +++++++++++++++++-----
 3 files changed, 29 insertions(+), 8 deletions(-)

diff --git a/src/compiler/GF/Command/Commands.hs b/src/compiler/GF/Command/Commands.hs
index 543c05cb2..4197e0c31 100644
--- a/src/compiler/GF/Command/Commands.hs
+++ b/src/compiler/GF/Command/Commands.hs
@@ -436,7 +436,8 @@ allCommands env@(pgf, mos) = Map.fromList [
      synopsis = "import a grammar from source code or compiled .pgf file",
      explanation = unlines [
        "Reads a grammar from File and compiles it into a GF runtime grammar.",
-       "If a grammar with the same concrete name is already in the state",
+       "If its abstract is different from current state, old modules are discarded.",
+       "If its abstract is the same and a concrete with the same name is already in the state",
        "it is overwritten - but only if compilation succeeds.",
        "The grammar parser depends on the file name suffix:",
        "  .cf    context-free (labelled BNF) source",
@@ -588,6 +589,7 @@ allCommands env@(pgf, mos) = Map.fromList [
        ("cats",   "show just the names of abstract syntax categories"),
        ("fullform", "print the fullform lexicon"),
        ("funs",   "show just the names and types of abstract syntax functions"),
+       ("langs",  "show just the names of top concrete syntax modules"),
        ("lexc", "print the lexicon in Xerox LEXC format"),
        ("missing","show just the names of functions that have no linearization"),
        ("opt",    "optimize the generated pgf"),
@@ -1169,6 +1171,8 @@ allCommands env@(pgf, mos) = Map.fromList [
      | isOpt "cats"     opts = return $ fromString $ unwords $ map showCId $ categories pgf
      | isOpt "funs"     opts = return $ fromString $ unlines $ map showFun $ funsigs pgf
      | isOpt "fullform" opts = return $ fromString $ concatMap (morpho "" prFullFormLexicon) $ optLangs opts
+     | isOpt "langs"    opts = return $ fromString $ unwords $ map showCId $ languages pgf
+  
      | isOpt "lexc"     opts = return $ fromString $ concatMap (morpho "" prLexcLexicon) $ optLangs opts
      | isOpt "missing"  opts = return $ fromString $ unlines $ [unwords (showCId la:":": map showCId cs) | 
                                                                   la <- optLangs opts, let cs = missingLins pgf la]
diff --git a/src/compiler/GF/Command/Importing.hs b/src/compiler/GF/Command/Importing.hs
index 3d05868b1..cbbb7a30e 100644
--- a/src/compiler/GF/Command/Importing.hs
+++ b/src/compiler/GF/Command/Importing.hs
@@ -30,14 +30,19 @@ importGrammar pgf0 opts files =
     s | elem s [".gf",".gfo"] -> do
       res <- appIOE $ compileToPGF opts files
       case res of
-        Ok pgf2 -> do return $ unionPGF pgf0 pgf2
+        Ok pgf2 -> ioUnionPGF pgf0 pgf2
         Bad msg -> do putStrLn ('\n':'\n':msg)
                       return pgf0
     ".pgf" -> do
       pgf2 <- mapM readPGF files >>= return . foldl1 unionPGF
-      return $ unionPGF pgf0 pgf2
+      ioUnionPGF pgf0 pgf2
     ext -> die $ "Unknown filename extension: " ++ show ext
 
+ioUnionPGF :: PGF -> PGF -> IO PGF
+ioUnionPGF one two = case msgUnionPGF one two of
+  (pgf, Just msg) -> putStrLn msg >> return pgf
+  (pgf,_)         -> return pgf
+
 importSource :: SourceGrammar -> Options -> [FilePath] -> IO SourceGrammar
 importSource src0 opts files = do
   src <- appIOE $ batchCompile opts files
diff --git a/src/runtime/haskell/PGF/Data.hs b/src/runtime/haskell/PGF/Data.hs
index 3e26cbd98..e97b8701e 100644
--- a/src/runtime/haskell/PGF/Data.hs
+++ b/src/runtime/haskell/PGF/Data.hs
@@ -79,12 +79,16 @@ data Alternative =
 -- merge two PGFs; fails is differens absnames; priority to second arg
 
 unionPGF :: PGF -> PGF -> PGF
-unionPGF one two = case absname one of
-  n | n == wildCId     -> two    -- extending empty grammar
-    | n == absname two -> one {  -- extending grammar with same abstract
+unionPGF one two = fst $ msgUnionPGF one two
+
+msgUnionPGF :: PGF -> PGF -> (PGF, Maybe String)
+msgUnionPGF one two = case absname one of
+  n | n == wildCId     -> (two, Nothing)    -- extending empty grammar
+    | n == absname two && haveSameFunsPGF one two -> (one { -- extending grammar with same abstract
       concretes = Map.union (concretes two) (concretes one)
-    }
-  _ -> one   -- abstracts don't match ---- print error msg
+    }, Nothing)
+  _ -> (two, -- abstracts don't match, discard the old one  -- error msg in Importing.ioUnionPGF
+        Just "Abstract changed, previous concretes discarded.")
 
 emptyPGF :: PGF
 emptyPGF = PGF {
@@ -94,6 +98,14 @@ emptyPGF = PGF {
   concretes = Map.empty
   }
 
+-- sameness of function type signatures, checked when importing a new concrete in env
+haveSameFunsPGF :: PGF -> PGF -> Bool
+haveSameFunsPGF one two = 
+  let 
+    fsone = [(f,t) | (f,(t,_,_,_)) <- Map.toList (funs (abstract one))]
+    fstwo = [(f,t) | (f,(t,_,_,_)) <- Map.toList (funs (abstract two))]
+  in fsone == fstwo
+
 -- | This is just a 'CId' with the language name.
 -- A language name is the identifier that you write in the 
 -- top concrete or abstract module in GF after the