oper overloading: first implemenatation using records

2 files changed, 11 insertions, 1 deletions

diff --git a/src/GF/Source/GrammarToSource.hs b/src/GF/Source/GrammarToSource.hs
index a20eb7830..055c79d15 100644
--- a/src/GF/Source/GrammarToSource.hs
+++ b/src/GF/Source/GrammarToSource.hs
@@ -94,6 +94,10 @@ trAnyDef (i,info) = let i' = tri i in case info of
     May b  -> P.ParDefIndir i' $ tri b
     _      -> P.ParDefAbs i']]
 
+  ResOverload tysts -> 
+    [P.DefOper [P.DDef [mkName i'] (
+      P.ERecord [P.LDFull [i'] (trt ty) (trt fu) | (ty,fu) <- tysts])]]
+
   CncCat (Yes ty) Nope _ -> 
     [P.DefLincat [P.PrintDef [mkName i'] (trt ty)]] 
   CncCat pty ptr ppr -> 
diff --git a/src/GF/Source/SourceToGrammar.hs b/src/GF/Source/SourceToGrammar.hs
index dadf8c3af..49023bf09 100644
--- a/src/GF/Source/SourceToGrammar.hs
+++ b/src/GF/Source/SourceToGrammar.hs
@@ -299,7 +299,7 @@ transResDef x = case x of
                      (p,pars) <- pardefs', (f,co) <- pars]
   DefOper defs -> do
     defs' <- liftM concat $ mapM getDefs defs
-    returnl [(f, G.ResOper pt pe) | (f,(pt,pe)) <- defs']
+    returnl [mkOverload (f, G.ResOper pt pe) | (f,(pt,pe)) <- defs']
 
   DefLintype defs -> do
     defs' <- liftM concat $ mapM getDefs defs
@@ -307,6 +307,12 @@ transResDef x = case x of
 
   DefFlag defs -> liftM Right $ mapM transFlagDef defs
   _ -> Bad $ "illegal definition form in resource" +++ printTree x
+ where
+   mkOverload (c,j) = case j of
+     G.ResOper Nope (Yes (G.R fs@(_:_:_))) | isOverloading c fs -> 
+       (c,G.ResOverload [(ty,fu) | (_,(Just ty,fu)) <- fs])
+     _ -> (c,j)
+   isOverloading c fs = all (== GP.prt c) (map (GP.prt . fst) fs)
 
 transParDef :: ParDef -> Err (Ident, [G.Param])
 transParDef x = case x of