From 5ec43f2f75e8b62bcb650f75099b83f282878901 Mon Sep 17 00:00:00 2001
From: krasimir <krasimir@chalmers.se>
Date: Tue, 7 Mar 2017 08:24:00 +0000
Subject: [PATCH] GF.Grammar.Printer now has a Terse mode which prints record
 types with lock fields with their corresponding abstract categories

---
 src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs |  4 ++--
 src/compiler/GF/Compile/TypeCheck/RConcrete.hs   |  2 +-
 src/compiler/GF/Grammar/Printer.hs               | 11 +++++++++--
 3 files changed, 12 insertions(+), 5 deletions(-)

diff --git a/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs b/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs
index f1c6aab80..badf8bd30 100644
--- a/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs
+++ b/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs
@@ -288,8 +288,8 @@ tcApp ge scope t =
 
 tcOverloadFailed t ttys =
   tcError ("Overload resolution failed" $$
-           "term " <+> pp t $$
-           "types" <+> vcat [pp ty | (_,ty) <- ttys])
+           "of term   " <+> pp t $$
+           "with types" <+> vcat [ppTerm Terse 0 ty | (_,ty) <- ttys])
 
 
 tcPatt ge scope PW        ty0 =
diff --git a/src/compiler/GF/Compile/TypeCheck/RConcrete.hs b/src/compiler/GF/Compile/TypeCheck/RConcrete.hs
index 8913f7c5d..2fe08b256 100644
--- a/src/compiler/GF/Compile/TypeCheck/RConcrete.hs
+++ b/src/compiler/GF/Compile/TypeCheck/RConcrete.hs
@@ -425,7 +425,7 @@ checkLType gr g trm typ0 = do
                        then checkLType gr ((bt,x,a):g) c b
                        else do b' <- checkIn (pp "abs") $ substituteLType [(bt',z,Vr x)] b
                                checkLType gr ((bt,x,a):g) c b'
-          return $ (Abs bt x c', Prod bt' x a b')
+          return $ (Abs bt x c', Prod bt' z a b')
         _ -> checkError $ "function type expected instead of" <+> ppType typ
 
     App f a -> do
diff --git a/src/compiler/GF/Grammar/Printer.hs b/src/compiler/GF/Grammar/Printer.hs
index 341ff3863..dcd419c42 100644
--- a/src/compiler/GF/Grammar/Printer.hs
+++ b/src/compiler/GF/Grammar/Printer.hs
@@ -39,7 +39,7 @@ import qualified Data.Map as Map
 import qualified Data.Array.IArray as Array
 
 data TermPrintQual 
-  = Unqualified | Qualified | Internal
+  = Terse | Unqualified | Qualified | Internal
   deriving Eq                 
 
 instance Pretty Grammar where
@@ -229,7 +229,13 @@ ppTerm q d (R [])      = pp "<>" -- to distinguish from {} empty RecType
 ppTerm q d (R xs)      = braces (fsep (punctuate ';' [l <+> 
                                                        fsep [case mb_t of {Just t -> ':' <+> ppTerm q 0 t; Nothing -> empty},
                                                              '=' <+> ppTerm q 0 e] | (l,(mb_t,e)) <- xs]))
-ppTerm q d (RecType xs)= braces (fsep (punctuate ';' [l <+> ':' <+> ppTerm q 0 t | (l,t) <- xs]))
+ppTerm q d (RecType xs)
+  | q == Terse         = case [cat | (l,_) <- xs, let (p,cat) = splitAt 5 (showIdent (label2ident l)), p == "lock_"] of
+                           [cat] -> pp cat
+                           _     -> doc
+  | otherwise          = doc
+  where
+    doc = braces (fsep (punctuate ';' [l <+> ':' <+> ppTerm q 0 t | (l,t) <- xs]))
 ppTerm q d (Typed e t) = '<' <> ppTerm q 0 e <+> ':' <+> ppTerm q 0 t <> '>'
 ppTerm q d (ImplArg e) = braces (ppTerm q 0 e)
 ppTerm q d (ELincat cat t) = prec d 4 ("lincat" <+> cat <+> ppTerm q 5 t)
@@ -296,6 +302,7 @@ ppDDecl q (_,id,typ)
 ppQIdent :: TermPrintQual -> QIdent -> Doc
 ppQIdent q (m,id) =
   case q of
+    Terse       ->          pp id
     Unqualified ->          pp id
     Qualified   -> m <> '.' <> id
     Internal    -> m <> '.' <> id