msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

GF.Grammar.Printer now has a Terse mode which prints record types with lock fields with their corresponding abstract categories

Browse Source
This commit is contained in:
krasimir
2017-03-07 08:24:00 +00:00
parent 5a61ab5fcc
commit 5ec43f2f75
3 changed files with 12 additions and 5 deletions
Download Patch File Download Diff File Expand all files Collapse all files

4
src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs
View File

@@ -288,8 +288,8 @@ tcApp ge scope t =
tcOverloadFailed t ttys = tcOverloadFailed t ttys =
tcError ("Overload resolution failed" $$ tcError ("Overload resolution failed" $$
"term " <+> pp t $$ "of term " <+> pp t $$
"types" <+> vcat [pp ty | (_,ty) <- ttys]) "with types" <+> vcat [ppTerm Terse 0 ty | (_,ty) <- ttys])
tcPatt ge scope PW ty0 = tcPatt ge scope PW ty0 =

2
src/compiler/GF/Compile/TypeCheck/RConcrete.hs
View File

@@ -425,7 +425,7 @@ checkLType gr g trm typ0 = do
then checkLType gr ((bt,x,a):g) c b then checkLType gr ((bt,x,a):g) c b
else do b' <- checkIn (pp "abs") $ substituteLType [(bt',z,Vr x)] b else do b' <- checkIn (pp "abs") $ substituteLType [(bt',z,Vr x)] b
checkLType gr ((bt,x,a):g) c 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 _ -> checkError $ "function type expected instead of" <+> ppType typ
App f a -> do App f a -> do

11
src/compiler/GF/Grammar/Printer.hs
View File

@@ -39,7 +39,7 @@ import qualified Data.Map as Map
import qualified Data.Array.IArray as Array import qualified Data.Array.IArray as Array
data TermPrintQual data TermPrintQual
= Unqualified | Qualified | Internal = Terse | Unqualified | Qualified | Internal
deriving Eq deriving Eq
instance Pretty Grammar where 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 <+> ppTerm q d (R xs) = braces (fsep (punctuate ';' [l <+>
fsep [case mb_t of {Just t -> ':' <+> ppTerm q 0 t; Nothing -> empty}, fsep [case mb_t of {Just t -> ':' <+> ppTerm q 0 t; Nothing -> empty},
'=' <+> ppTerm q 0 e] | (l,(mb_t,e)) <- xs])) '=' <+> 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 (Typed e t) = '<' <> ppTerm q 0 e <+> ':' <+> ppTerm q 0 t <> '>'
ppTerm q d (ImplArg e) = braces (ppTerm q 0 e) 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) 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 :: TermPrintQual -> QIdent -> Doc
ppQIdent q (m,id) = ppQIdent q (m,id) =
case q of case q of
Terse -> pp id
Unqualified -> pp id Unqualified -> pp id
Qualified -> m <> '.' <> id Qualified -> m <> '.' <> id
Internal -> m <> '.' <> id Internal -> m <> '.' <> id