1
1
mirror of https://github.com/anoma/juvix.git synced 2024-12-15 10:03:22 +03:00

[minihaskell] improve pretty printer (parentheses and spacing)

This commit is contained in:
Jan Mas Rovira 2022-03-16 15:46:59 +01:00
parent e53b68502d
commit b0251bad93
2 changed files with 70 additions and 13 deletions

View File

@ -1,3 +1,4 @@
{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
module MiniJuvix.Syntax.MiniHaskell.Language (
module MiniJuvix.Syntax.MiniHaskell.Language,
module MiniJuvix.Syntax.Concrete.Scoped.Name.NameKind,
@ -7,6 +8,7 @@ module MiniJuvix.Syntax.MiniHaskell.Language (
import MiniJuvix.Prelude
import MiniJuvix.Syntax.Concrete.Scoped.Name.NameKind
import MiniJuvix.Syntax.Concrete.Scoped.Name (NameId(..))
import MiniJuvix.Syntax.Fixity
type FunctionName = Name
type VarName = Name
@ -121,3 +123,30 @@ instance Monoid ModuleBody where
_moduleInductives = mempty,
_moduleFunctions = mempty
}
instance HasAtomicity Application where
atomicity = const (Aggregate appFixity)
instance HasAtomicity Expression where
atomicity e = case e of
ExpressionIden {} -> Atom
ExpressionApplication a -> atomicity a
instance HasAtomicity Function where
atomicity = const (Aggregate funFixity)
instance HasAtomicity Type where
atomicity t = case t of
TypeIden {} -> Atom
TypeFunction f -> atomicity f
instance HasAtomicity ConstructorApp where
atomicity (ConstructorApp _ args)
| null args = Atom
| otherwise = Aggregate appFixity
instance HasAtomicity Pattern where
atomicity p = case p of
PatternConstructorApp a -> atomicity a
PatternVariable {} -> Atom
PatternWildcard {} -> Atom

View File

@ -4,6 +4,7 @@ module MiniJuvix.Syntax.MiniHaskell.Pretty.Base where
import MiniJuvix.Prelude
import Prettyprinter
import MiniJuvix.Syntax.Fixity
import MiniJuvix.Syntax.MiniHaskell.Pretty.Ann
import MiniJuvix.Syntax.MiniHaskell.Language
import qualified MiniJuvix.Internal.Strings as Str
@ -22,7 +23,6 @@ class PrettyCode c where
ppCode :: Member (Reader Options) r => c -> Sem r (Doc Ann)
instance PrettyCode Name where
ppCode :: Member (Reader Options) r => Name -> Sem r (Doc Ann)
ppCode n =
return $ annotate (AnnKind (n ^. nameKind))
$ pretty (n ^. nameText) <> "_" <> pretty (n ^. nameId)
@ -37,9 +37,9 @@ instance PrettyCode Iden where
-- TODO optimize parentheses.
instance PrettyCode Application where
ppCode a = do
l <- ppCode (a ^. appLeft)
r <- ppCode (a ^. appRight)
return $ l <+> parens r
l' <- ppLeftExpression appFixity (a ^. appLeft)
r' <- ppRightExpression appFixity (a ^. appRight)
return $ l' <+> r'
instance PrettyCode Expression where
ppCode e = case e of
@ -73,13 +73,11 @@ kwModule = keyword Str.module_
kwWildcard :: Doc Ann
kwWildcard = keyword Str.underscore
-- [a -> b -> c] -> d
-- TODO optimize parentheses.
instance PrettyCode Function where
ppCode f = do
funParameters' <- mapM ppCode (f ^. funParameters)
funReturn' <- ppCode (f ^. funReturn)
return $ concatWith (\a b -> parens a <+> kwArrow <+> parens b)
funReturn' <- ppCodeAtom (f ^. funReturn)
return $ concatWith (\a b -> a <+> kwArrow <+> b)
(toList funParameters' ++ [funReturn'])
instance PrettyCode Type where
@ -108,8 +106,8 @@ instance PrettyCode InductiveDef where
instance PrettyCode ConstructorApp where
ppCode c = do
constr' <- ppCode (c ^. constrAppConstructor)
params' <- mapM ppCode (c ^. constrAppParameters)
return $ parens (hsep $ constr' : params')
params' <- mapM ppCodeAtom (c ^. constrAppParameters)
return $ hsep $ constr' : params'
instance PrettyCode Pattern where
ppCode p = case p of
@ -126,7 +124,7 @@ instance PrettyCode FunctionDef where
<> vsep (toList clauses')
where
ppClause fun c = do
clausePatterns' <- mapM ppCode (c ^. clausePatterns)
clausePatterns' <- mapM ppCodeAtom (c ^. clausePatterns)
clauseBody' <- ppCode (c ^. clauseBody)
return $ fun <+> hsep clausePatterns' <+> kwEquals <+> clauseBody'
@ -134,10 +132,40 @@ instance PrettyCode ModuleBody where
ppCode m = do
types' <- mapM ppCode (toList (m ^. moduleInductives))
funs' <- mapM ppCode (toList (m ^. moduleFunctions))
return $ vsep types' <> line <> vsep funs'
return $ vsep2 types' <> line <> line <> vsep2 funs'
where
vsep2 = concatWith (\a b -> a <> line <> line <> b)
instance PrettyCode Module where
ppCode m = do
name' <- ppCode (m ^. moduleName)
body' <- ppCode (m ^. moduleBody)
return $ kwModule <+> name' <+> kwWhere <> line <> body'
return $ kwModule <+> name' <+> kwWhere
<> line <> line <> body' <> line
parensCond :: Bool -> Doc Ann -> Doc Ann
parensCond t d = if t then parens d else d
ppPostExpression ::(PrettyCode a, HasAtomicity a, Member (Reader Options) r) =>
Fixity -> a -> Sem r (Doc Ann)
ppPostExpression = ppLRExpression isPostfixAssoc
ppRightExpression :: (PrettyCode a, HasAtomicity a, Member (Reader Options) r) =>
Fixity -> a -> Sem r (Doc Ann)
ppRightExpression = ppLRExpression isRightAssoc
ppLeftExpression :: (PrettyCode a, HasAtomicity a, Member (Reader Options) r) =>
Fixity -> a -> Sem r (Doc Ann)
ppLeftExpression = ppLRExpression isLeftAssoc
ppLRExpression
:: (HasAtomicity a, PrettyCode a, Member (Reader Options) r) =>
(Fixity -> Bool) -> Fixity -> a -> Sem r (Doc Ann)
ppLRExpression associates fixlr e =
parensCond (atomParens associates (atomicity e) fixlr)
<$> ppCode e
ppCodeAtom :: (HasAtomicity c, PrettyCode c, Members '[Reader Options] r) => c -> Sem r (Doc Ann)
ppCodeAtom c = do
p' <- ppCode c
return $ if isAtomic c then p' else parens p'