restored work on Extend and Rename

6 files changed, 67 insertions, 16 deletions

diff --git a/src/GF/Devel/Grammar/Lookup.hs b/src/GF/Devel/Grammar/Lookup.hs
index 1bd36184d..cb45b5406 100644
--- a/src/GF/Devel/Grammar/Lookup.hs
+++ b/src/GF/Devel/Grammar/Lookup.hs
@@ -61,12 +61,12 @@ lookupParamValues gf m c = do
     
 lookupModule :: GF -> Ident -> Err Module
 lookupModule gf m = do
-  maybe (raise "module not found") return $ mlookup m (gfmodules gf)
+  maybe (raiseIdent "module not found:" m) return $ mlookup m (gfmodules gf)
 
 lookupIdent :: GF -> Ident -> Ident -> Err JEntry
 lookupIdent gf m c = do
   mo <- lookupModule gf m
-  maybe (Bad "constant not found") return $ mlookup c (mjments mo)
+  maybe (raiseIdent "constant not found" c) return $ mlookup c (mjments mo)
 
 lookupJudgement :: GF -> Ident -> Ident -> Err Judgement
 lookupJudgement gf m c = do
@@ -75,3 +75,6 @@ lookupJudgement gf m c = do
 
 mlookup = Data.Map.lookup
 
+raiseIdent msg i = raise (msg +++ prIdent i)
+
+
diff --git a/src/GF/Devel/Grammar/Macros.hs b/src/GF/Devel/Grammar/Macros.hs
index 9af5e7ec9..785b69902 100644
--- a/src/GF/Devel/Grammar/Macros.hs
+++ b/src/GF/Devel/Grammar/Macros.hs
@@ -64,6 +64,9 @@ assignT l a t = (l,(Just a,t))
 mkDecl :: Term -> Decl
 mkDecl typ = (wildIdent, typ)
 
+mkLet :: [LocalDef] -> Term -> Term
+mkLet defs t = foldr Let t defs
+
 typeType :: Type
 typeType = Sort "Type"
 
@@ -73,6 +76,9 @@ meta0 = Meta 0
 ident2label :: Ident -> Label
 ident2label c = LIdent (prIdent c)
 
+label2ident :: Label -> Ident
+label2ident (LIdent c) = identC c
+
 ----label2ident :: Label -> Ident
 ----label2ident = identC . prLabel
 
diff --git a/src/GF/Devel/Grammar/MkJudgements.hs b/src/GF/Devel/Grammar/MkJudgements.hs
index 011b83e62..01b5f97d7 100644
--- a/src/GF/Devel/Grammar/MkJudgements.hs
+++ b/src/GF/Devel/Grammar/MkJudgements.hs
@@ -3,6 +3,7 @@ module GF.Devel.Grammar.MkJudgements where
 import GF.Devel.Grammar.Macros
 import GF.Devel.Grammar.Judgements
 import GF.Devel.Grammar.Terms
+import GF.Devel.Grammar.PrGF
 import GF.Infra.Ident
 
 import GF.Data.Operations
@@ -10,6 +11,8 @@ import GF.Data.Operations
 import Control.Monad
 import Data.Map
 
+import Debug.Trace (trace) ----
+
 -- constructing judgements from parse tree
 
 emptyJudgement :: JudgementForm -> Judgement
@@ -79,5 +82,12 @@ unifyJudgement old new = do
    unifyTerm oterm nterm = case (oterm,nterm) of
      (Meta _,t) -> return t
      (t,Meta _) -> return t
-     _ -> testErr (nterm == oterm) "incompatible fields" >> return nterm
+     _ -> do
+       if (nterm /= oterm) 
+          then (trace (unwords ["illegal update of",prt oterm,"to",prt nterm]) 
+                (return ()))
+          else return () ---- to recover from spurious qualification conflicts
+----       testErr (nterm == oterm) 
+----               (unwords ["illegal update of",prt oterm,"to",prt nterm])
+       return nterm
 
diff --git a/src/GF/Devel/Grammar/Modules.hs b/src/GF/Devel/Grammar/Modules.hs
index 23dfdae72..43458ce90 100644
--- a/src/GF/Devel/Grammar/Modules.hs
+++ b/src/GF/Devel/Grammar/Modules.hs
@@ -30,6 +30,7 @@ addModule c m gf = gf {gfmodules = insert c m (gfmodules gf)}
 
 data Module = Module {
   mtype       :: ModuleType,
+  miscomplete :: Bool,
   minterfaces :: [(Ident,Ident)],           -- non-empty for functors 
   minstances  :: [((Ident,MInclude),[(Ident,Ident)])], -- non-empty for instant'ions
   mextends    :: [(Ident,MInclude)],
@@ -39,12 +40,24 @@ data Module = Module {
   }
 
 emptyModule :: Ident -> Module
-emptyModule m = Module MTGrammar [] [] [] [] empty empty
+emptyModule m = Module MTGrammar True [] [] [] [] empty empty
 
 type MapJudgement = Map Ident JEntry -- def or indirection
 
 isCompleteModule :: Module -> Bool
-isCompleteModule = Prelude.null . minterfaces 
+isCompleteModule = miscomplete ---- Prelude.null . minterfaces 
+
+isInterface :: Module -> Bool
+isInterface m = case mtype m of
+  MTInterface -> True
+  MTAbstract -> True
+  _ -> False
+
+interfaceName :: Module -> Maybe Ident
+interfaceName mo = case mtype mo of
+  MTInstance i -> return i
+  MTConcrete i -> return i
+  _ -> Nothing
 
 listJudgements :: Module -> [(Ident,JEntry)]
 listJudgements = assocs . mjments
diff --git a/src/GF/Devel/Grammar/PrGF.hs b/src/GF/Devel/Grammar/PrGF.hs
index 0a8134a6c..589f5e9b4 100644
--- a/src/GF/Devel/Grammar/PrGF.hs
+++ b/src/GF/Devel/Grammar/PrGF.hs
@@ -24,11 +24,13 @@ module GF.Devel.Grammar.PrGF where
 import qualified GF.Devel.Grammar.PrintGF as P
 import GF.Devel.Grammar.GFtoSource
 import GF.Devel.Grammar.Modules
+import GF.Devel.Grammar.Judgements
 import GF.Devel.Grammar.Terms
 ----import GF.Grammar.Values
 
 ----import GF.Infra.Option
 import GF.Infra.Ident
+import GF.Infra.CompactPrint
 ----import GF.Data.Str
 
 import GF.Data.Operations
@@ -53,22 +55,32 @@ class Print a where
 --- in writing grammars to a file. For some constructs, e.g. prMarkedTree,
 --- only the former is ever needed.
 
+cprintTree :: P.Print a => a -> String
+cprintTree = compactPrint . P.printTree
+
 -- | to show terms etc in error messages
 prtBad :: Print a => String -> a -> Err b
 prtBad s a = Bad (s +++ prt a)
 
 prGF :: GF -> String
-prGF = P.printTree . trGrammar
+prGF = cprintTree . trGrammar
 
 prModule :: SourceModule -> String
-prModule = P.printTree . trModule
+prModule = cprintTree . trModule
+
+prJEntry :: JEntry -> String
+prJEntry = either prt show 
+
+instance Print Judgement where
+  prt j = cprintTree $ trAnyDef (wildIdent, j)
+----  prt_ = prExp
 
 instance Print Term where
-  prt = P.printTree . trt
+  prt = cprintTree . trt
 ----  prt_ = prExp
 
 instance Print Ident where
-  prt = P.printTree . tri
+  prt = cprintTree . tri
 
 {- ----
 instance Print Patt where
diff --git a/src/GF/Devel/Grammar/SourceToGF.hs b/src/GF/Devel/Grammar/SourceToGF.hs
index fecb5b4ea..e09b9964c 100644
--- a/src/GF/Devel/Grammar/SourceToGF.hs
+++ b/src/GF/Devel/Grammar/SourceToGF.hs
@@ -43,6 +43,8 @@ import Data.Char
 import qualified Data.Map as Map
 import Data.List (genericReplicate)
 
+import Debug.Trace (trace) ----
+
 -- based on the skeleton Haskell module generated by the BNF converter
 
 type Result = Err String
@@ -73,7 +75,7 @@ transModDef :: ModDef -> Err (Ident,Module)
 transModDef x = case x of
   MModule compl mtyp body -> do
 
-    --- let mstat' = transComplMod compl
+    let isCompl = transComplMod compl
 
     (trDef, mtyp', id') <- case mtyp of
       MAbstract id -> do
@@ -90,9 +92,9 @@ transModDef x = case x of
         open' <- transIdent open
         mkModRes id (MTInstance open') body
 
-    mkBody (trDef, mtyp', id') body
+    mkBody (isCompl, trDef, mtyp', id') body
   where
-      mkBody xx@(trDef, mtyp', id') bod = case bod of 
+      mkBody xx@(isc, trDef, mtyp', id') bod = case bod of 
        MNoBody incls -> do
         mkBody xx $ MBody (Ext incls) NoOpens []
        MBody extends opens defs -> do
@@ -102,7 +104,7 @@ transModDef x = case x of
         let defs' = Map.fromListWith unifyJudgements 
                        [(i,Left d) | Left ds <- defs0, (i,d) <- ds]
         let flags' = Map.fromList [f | Right fs <- defs0, f <- fs]
-        return (id', Module mtyp' [] [] extends' opens' flags' defs')
+        return (id', Module mtyp' isc [] [] extends' opens' flags' defs')
 
        MWith m insts -> mkBody xx $ MWithEBody [] m insts NoOpens []
        MWithBody m insts opens defs -> mkBody xx $ MWithEBody [] m insts opens defs
@@ -116,7 +118,7 @@ transModDef x = case x of
         let defs'  = Map.fromListWith unifyJudgements 
                        [(i,Left d) | Left ds <- defs0, (i,d) <- ds]
         let flags' = Map.fromList [f | Right fs <- defs0, f <- fs]
-        return (id', Module mtyp' [] [(m',insts')] extends' opens' flags' defs')
+        return (id', Module mtyp' isc [] [(m',insts')] extends' opens' flags' defs')
        _ -> fail "deprecated module form"
 
 
@@ -128,6 +130,11 @@ transModDef x = case x of
 getTopDefs :: [TopDef] -> [TopDef]
 getTopDefs x = x
 
+transComplMod :: ComplMod -> Bool
+transComplMod x = case x of
+  CMCompl   -> True
+  CMIncompl -> False
+
 transExtend :: Extend -> Err [(Ident,MInclude)]
 transExtend x = case x of
   Ext ids  -> mapM transIncludedExt ids
@@ -279,7 +286,7 @@ transResDef x = case x of
      _ -> [(c,j)]
    isOverloading (G.Vr keyw) c fs = 
      prIdent keyw == "overload" &&       -- overload is a "soft keyword"
-     False ---- all (== GP.prt c) (map (GP.prt . fst) fs)
+     True ---- all (== GP.prt c) (map (GP.prt . fst) fs)
 
 transParDef :: ParDef -> Err (Ident, [(Ident,G.Context)])
 transParDef x = case x of
@@ -426,7 +433,7 @@ transExp x = case x of
     exp'  <- transExp exp
     defs0 <- mapM locdef2fields defs
     defs' <- mapM tryLoc $ concat defs0
-    return $ exp' ---- M.mkLet defs' exp'
+    return $ M.mkLet defs' exp'
    where
      tryLoc (c,(mty,Just e)) = return (c,(mty,e))
      tryLoc (c,_) = Bad $ "local definition of" +++ prIdent c +++ "without value"