From 61763b57848eaeb5e08ca0429dc5c0926606ad6c Mon Sep 17 00:00:00 2001
From: aarne <aarne@cs.chalmers.se>
Date: Tue, 4 Dec 2007 15:23:49 +0000
Subject: [PATCH] unifying judgement information - now easy

---
 src/GF/Devel/Grammar/MkJudgements.hs | 5 +++++
 src/GF/Devel/Grammar/SourceToGF.hs   | 7 +++++--
 2 files changed, 10 insertions(+), 2 deletions(-)

diff --git a/src/GF/Devel/Grammar/MkJudgements.hs b/src/GF/Devel/Grammar/MkJudgements.hs
index 833d2f695..011b83e62 100644
--- a/src/GF/Devel/Grammar/MkJudgements.hs
+++ b/src/GF/Devel/Grammar/MkJudgements.hs
@@ -64,6 +64,11 @@ paramConstructors p cs =
 
 -- unifying contents of judgements
 
+---- used in SourceToGF; make error-free and informative
+unifyJudgements (Left j) (Left k) = Left $ case unifyJudgement j k of
+  Ok l -> l
+  Bad s -> error s
+
 unifyJudgement :: Judgement -> Judgement -> Err Judgement
 unifyJudgement old new = do
   testErr (jform old == jform new) "different judment forms"
diff --git a/src/GF/Devel/Grammar/SourceToGF.hs b/src/GF/Devel/Grammar/SourceToGF.hs
index 0ad966648..d2690b4a7 100644
--- a/src/GF/Devel/Grammar/SourceToGF.hs
+++ b/src/GF/Devel/Grammar/SourceToGF.hs
@@ -79,6 +79,7 @@ transModDef x = case x of
       MAbstract id -> do
         id' <- transIdent id
         return (transAbsDef, MTAbstract, id')
+      MGrammar id -> mkModRes id MTGrammar body 
       MResource id -> mkModRes id MTGrammar body 
       MConcrete id open -> do
         id'   <- transIdent id
@@ -98,7 +99,8 @@ transModDef x = case x of
         extends' <- transExtend extends
         opens'   <- transOpens opens
         defs0    <- mapM trDef $ getTopDefs defs
-        let defs'  = Map.fromList [(i,Left d) | Left ds <- defs0, (i,d) <- ds]
+        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')
 
@@ -111,7 +113,8 @@ transModDef x = case x of
         insts'   <- mapM transOpen insts 
         opens'   <- transOpens opens
         defs0    <- mapM trDef $ getTopDefs defs
-        let defs'  = Map.fromList [(i,Left d) | Left ds <- defs0, (i,d) <- ds]
+        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')
        _ -> fail "deprecated module form"