[minihaskell] improve pretty printer (parentheses and spacing)

src/MiniJuvix/Syntax/MiniHaskell/Language.hs

@@ -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

src/MiniJuvix/Syntax/MiniHaskell/Pretty/Base.hs

@@ -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'