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:
parent
e53b68502d
commit
b0251bad93
@ -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
|
||||
|
@ -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'
|
||||
|
Loading…
Reference in New Issue
Block a user