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"