fixed a Compute bug due to failure to match typed record values with untyped record patterns

3 files changed, 17 insertions, 8 deletions

diff --git a/examples/bronzeage/Makefile b/examples/bronzeage/Makefile
index 5d4fd7acc..b0efea29f 100644
--- a/examples/bronzeage/Makefile
+++ b/examples/bronzeage/Makefile
@@ -5,10 +5,10 @@ all: magnet
 magnet:
 #	gfc --make -src --parser=off --name=fre BronzeageFre.gf +RTS -K100M
 #	gfc --make -src --erasing=on --name=bul BronzeageBul.gf
-	gfc --make -src --parser=off --name=fin BronzeageFin.gf +RTS -K100M
+	gfc --make -src --erasing=on --name=fin BronzeageFin.gf +RTS -K100M
 	gfc --make -src --erasing=on --name=eng BronzeageEng.gf
 	gfc --make -src --erasing=on --name=ger BronzeageGer.gf 
 	gfc --make -src --erasing=on --name=scand BronzeageNor.gf BronzeageSwe.gf 
-	gfc --make -src --name=rom BronzeageIta.gf BronzeageSpa.gf
-	gfc --make --name=bronze eng.pgf fin.pgf ger.pgf rom.pgf scand.pgf 
+	gfc --make -src --name=rom BronzeageIta.gf BronzeageSpa.gf BronzeageFre.gf
+	gfc --make --name=bronze eng.pgf fin.pgf ger.pgf rom.pgf scand.pgf
 
diff --git a/src/GF/Compile/Compute.hs b/src/GF/Compile/Compute.hs
index f35e7c6a9..3c7c061fc 100644
--- a/src/GF/Compile/Compute.hs
+++ b/src/GF/Compile/Compute.hs
@@ -33,6 +33,8 @@ import GF.Grammar.AppPredefined
 import Data.List (nub,intersperse)
 import Control.Monad (liftM2, liftM)
 
+----import Debug.Trace ----
+
 -- | computation of concrete syntax terms into normal form
 -- used mainly for partial evaluation
 computeConcrete :: SourceGrammar -> Term -> Err Term
@@ -309,7 +311,7 @@ computeTermOpt rec gr = comput True where
          -- course-of-values table: look up by index, no pattern matching needed
          V ptyp ts -> do
            vs <- allParamValues gr ptyp
-           case lookup v' (zip vs [0 .. length vs - 1]) of
+           case lookupR v' (zip vs [0 .. length vs - 1]) of
              Just i -> comp g $ ts !! i
              _ -> return $ S t' v' -- if v' is not canonical
          T _ cc -> case matchPattern cc v' of
@@ -321,6 +323,13 @@ computeTermOpt rec gr = comput True where
          S (V i cs) e -> prawitzV g i (flip S v') cs e
          _    -> returnC $ S t' v'
 
+     --- needed to match records with and without type information
+     ---- todo: eliminate linear search in a list of records!
+     lookupR v vs = case v of
+       R rs -> lookup ([(x,y) | (x,(_,y)) <- rs]) 
+                                [([(x,y) | (x,(_,y)) <- rs],v) | (R rs,v) <- vs]
+       _ -> lookup v vs
+
      -- case-expand tables
      -- if already expanded, don't expand again
      compTable g t = case t of
diff --git a/src/GF/Compile/GrammarToGFCC.hs b/src/GF/Compile/GrammarToGFCC.hs
index bb99d9d6c..539e5834c 100644
--- a/src/GF/Compile/GrammarToGFCC.hs
+++ b/src/GF/Compile/GrammarToGFCC.hs
@@ -38,7 +38,7 @@ traceD s t = t
 -- the main function: generate PGF from GF.
 mkCanon2gfcc :: Options -> String -> SourceGrammar -> (String,D.PGF)
 mkCanon2gfcc opts cnc gr = 
-  (prIdent abs, (canon2gfcc opts pars . reorder abs . canon2canon abs) gr)
+  (prIdent abs, (canon2gfcc opts pars . reorder abs . canon2canon opts abs) gr)
   where
     abs = err (const c) id $ M.abstractOfConcrete gr c where c = identC (BS.pack cnc)
     pars = mkParamLincat gr
@@ -267,8 +267,8 @@ repartition abs cg =
 
 -- translate tables and records to arrays, parameters and labels to indices
 
-canon2canon :: Ident -> SourceGrammar -> SourceGrammar
-canon2canon abs cg0 = 
+canon2canon :: Options -> Ident -> SourceGrammar -> SourceGrammar
+canon2canon opts abs cg0 = 
    (recollect . map cl2cl . repartition abs . purgeGrammar abs) cg0 
  where
   recollect = M.MGrammar . nubBy (\ (i,_) (j,_) -> i==j) . concatMap M.modules
@@ -281,7 +281,7 @@ canon2canon abs cg0 =
         (c, M.ModMod $ M.replaceJudgements mo $ mapTree f2 (M.jments mo))
       _ -> (c,m)    
   j2j cg (f,j) = 
-    let debug = traceD ("+ " ++ prt f) in
+    let debug = if verbAtLeast opts Verbose then trace ("+ " ++ prt f) else id in
     case j of
       CncFun x (Yes tr) z -> CncFun x (Yes (debug (t2t tr))) z
       CncCat (Yes ty) (Yes x) y -> CncCat (Yes (ty2ty ty)) (Yes (t2t x)) y