From 64ccd8295864c494c02e2af179cf67007f74bd48 Mon Sep 17 00:00:00 2001 From: krangelov Date: Wed, 20 Oct 2021 19:57:42 +0200 Subject: [PATCH] make record extension more compact after typechecking --- src/compiler/GF/Compile/TypeCheck/Concrete.hs | 9 ++++++++- src/compiler/GF/Grammar/Printer.hs | 6 +++++- 2 files changed, 13 insertions(+), 2 deletions(-) diff --git a/src/compiler/GF/Compile/TypeCheck/Concrete.hs b/src/compiler/GF/Compile/TypeCheck/Concrete.hs index 670bf299c..a3821edc2 100644 --- a/src/compiler/GF/Compile/TypeCheck/Concrete.hs +++ b/src/compiler/GF/Compile/TypeCheck/Concrete.hs @@ -554,7 +554,14 @@ checkLType gr g trm typ0 = do (r',_) <- checkLType gr g r (RecType fields1) (s',_) <- checkLType gr g s (RecType fields2) - let rec = R ([(l,(Nothing,P r' l)) | (l,_) <- fields1] ++ [(l,(Nothing,P s' l)) | (l,_) <- fields2]) + let project t l = + case t of + R rs -> case lookup l rs of + Just (_,t) -> t + Nothing -> error (render ("no value for label" <+> l)) + t -> P t l + + rec = R ([(l,(Nothing,project r' l)) | (l,_) <- fields1] ++ [(l,(Nothing,project s' l)) | (l,_) <- fields2]) return (rec, typ) ExtR ty ex -> do diff --git a/src/compiler/GF/Grammar/Printer.hs b/src/compiler/GF/Grammar/Printer.hs index 13a06b826..9c91b9b1c 100644 --- a/src/compiler/GF/Grammar/Printer.hs +++ b/src/compiler/GF/Grammar/Printer.hs @@ -160,7 +160,11 @@ ppJudgement q (id, AnyInd cann mid) = _ -> empty ppPmcfgRule id arg_cats res_cat (PMCFGRule res args lins) = - pp id <+> (':' <+> hsep (intersperse (pp '*') (zipWith ppPmcfgCat arg_cats args)) <+> "->" <+> ppPmcfgCat res_cat res $$ + pp id <+> (':' <+> + (if null args + then empty + else hsep (intersperse (pp '*') (zipWith ppPmcfgCat arg_cats args)) <+> "->") <+> + ppPmcfgCat res_cat res $$ '=' <+> brackets (vcat (map (hsep . map ppSymbol) lins))) ppPmcfgCat :: Ident -> PMCFGCat -> Doc