an attempt to solve record extension overloading bug, commented out for the moment

2 files changed, 23 insertions, 15 deletions

diff --git a/src/compiler/GF/Compile/TypeCheck/RConcrete.hs b/src/compiler/GF/Compile/TypeCheck/RConcrete.hs
index 75b789a76..aa13d5406 100644
--- a/src/compiler/GF/Compile/TypeCheck/RConcrete.hs
+++ b/src/compiler/GF/Compile/TypeCheck/RConcrete.hs
@@ -224,8 +224,14 @@ inferLType gr g trm = case trm of
      return (RecType (zip ls ts'), typeType)
 
    ExtR r s -> do
-     (r',rT) <- inferLType gr g r 
+   
+---     over <- getOverload gr g Nothing r
+---     let r1 = maybe r fst over
+     let r1 = r --- 
+
+     (r',rT) <- inferLType gr g r1
      rT'     <- computeLType gr g rT
+     
      (s',sT) <- inferLType gr g s
      sT'     <- computeLType gr g sT
 
@@ -332,8 +338,6 @@ getOverload gr g mt ot = case appForm ot of
        return $ Just v
      _ -> return Nothing
      
--- checkIfEqLType :: SourceGrammar -> Context -> Type -> Type -> Term -> Check (Bool,Type,Type,String)
--- checkEqLType   :: SourceGrammar -> Context -> Type -> Type -> Term -> Check Type
  where
    collectOverloads tr@(Q c) = case lookupOverload gr c of 
      Ok typs -> typs
@@ -514,8 +518,13 @@ checkLType gr g trm typ0 = do
                RecType ss -> return $ map fst ss
                _ ->  checkError ("cannot get labels from" $$ nest 2 (ppTerm Unqualified 0 typ2))
          let ll1 = [l | (l,_) <- rr, notElem l ll2]
-         (r',_) <- checkLType gr g r (RecType [field | field@(l,_) <- rr, elem l ll1])
-         (s',_) <- checkLType gr g s (RecType [field | field@(l,_) <- rr, elem l ll2])
+
+---         over <- getOverload gr g Nothing r --- this would solve #66 but fail ParadigmsAra. AR 6/7/2020
+---         let r1 = maybe r fst over
+         let r1 = r ---
+         
+         (r',_) <- checkLType gr g r1 (RecType [field | field@(l,_) <- rr, elem l ll1])
+         (s',_) <- checkLType gr g s  (RecType [field | field@(l,_) <- rr, elem l ll2])
 
          let rec = R ([(l,(Nothing,P r' l)) | l <- ll1] ++ [(l,(Nothing,P s' l)) | l <- ll2])
          return (rec, typ)
diff --git a/src/runtime/haskell/PGF/VisualizeTree.hs b/src/runtime/haskell/PGF/VisualizeTree.hs
index bab40d0ae..32709bac0 100644
--- a/src/runtime/haskell/PGF/VisualizeTree.hs
+++ b/src/runtime/haskell/PGF/VisualizeTree.hs
@@ -239,20 +239,19 @@ graphvizDependencyTree format debug mlab mclab pgf lang t =
 
 -- auxiliaries for UD conversion  PK 15/12/2018 
 rmcomments :: String -> String
-rmcomments [] = []
-rmcomments ('-':'-':xs) = []
-rmcomments ('-':x  :xs) = '-':rmcomments (x:xs)
-rmcomments ('#':xs) = case splitAt 3 xs of -- for compatibility with gf-ud annotations
-  ("cat",rest) -> rmcomments rest
-  ("fun",rest) -> rmcomments rest
-  _ -> [] --- gf-ud keywords not used in gf-core
-rmcomments (x:xs)       = x:rmcomments xs
+rmcomments s = case s of
+  '-':'-':_ -> []
+  '#':'f':'u':'n':rest -> rmcomments rest -- the new gf-ud format
+  '#':'c':'a':'t':rest -> rmcomments rest
+  x:xs -> x : rmcomments xs
+  _ -> []
+  
 
 -- | Prepare lines obtained from a configuration file for labels for
 -- use with 'graphvizDependencyTree'. Format per line /fun/ /label/@*@.
+--- ignore other gf-ud annotatations than #fun and #cat at this point 
 getDepLabels :: String -> Labels
--- getDepLabels s = Map.fromList [(mkCId f,ls) | f:ls <- map words (lines s)]
-getDepLabels s = Map.fromList [(mkCId f,ls) | f:ls <- map (words . rmcomments) (lines s)]
+getDepLabels s = Map.fromList [(mkCId f,ls) | f:ls <- map (words . rmcomments) (lines s), not (head f == '#')]
 
 -- the old function, without dependencies
 graphvizParseTree :: PGF -> Language -> GraphvizOptions -> Tree -> String