core/refactor: tying up the printers to allow for recursive printing by vicgeentor · Pull Request #54 · hattier-org/hattier

vicgeentor · 2026-04-09T14:59:29Z

Sorry for the big PR again but I didn't know how I would split this up in different PRs, since it refactors so much of the core of our printing logic that rely on each other. Splitting it up without a failing CI seemed impossible.

We currently use multiple different ways of dealing with things like adding indentation, recursing over a list of elements (like matches). This PR deals with tying all this seperated printer logic together.

Unfortunately, the Hattier.Printer.Expression module has become somewhat large. This is unavoidable due to otherwise cyclic dependencies.

vicgeentor · 2026-04-09T15:03:56Z

 printNames :: [LIdP GhcPs] -> Hattier
 printNames [] = pure ()
-printNames [(L _ name)] = append $ pprText name
+printNames [(L _ name)] = fallback name


see Utils.hs for the definition of fallback

vicgeentor · 2026-04-09T15:07:30Z

-  case style of
-    PrimaryAlignment -> do
-      let clausePatterns = [pats | L _ Match {m_pats = pats} <- matches]
-          maxWidths = map (maximum . map patWidth) (transpose clausePatterns)
-      -- splitting up these cases enables us to only put
-      -- newlines in between declarations and not after the
-      -- final one.
-      case matches of
-        [] -> pure ()
-        (x : xs) -> do
-          printClause fname maxWidths x
-          mapM_ (\clause -> newline >> printClause fname maxWidths clause) xs
-    NoAlignment -> do
-      -- See the comment at the above case expression
-      case matches of
-        [] -> pure ()
-        (x : xs) -> do
-          append $ pprText x
-          mapM_ (\match -> newline >> (append $ pprText match)) xs


This part contains two patterns we often use:

Checking the alignment style, and doing almost exactly the same with either choice except for some alignment.

Intercalating some monadic actions between a list of things to print (like mapM_ (\clause -> newline >> printClause fname maxWidths clause) xs).

The first pattern is abstracted with computeAlignment and computeColumnAlignments, see their definitions inside Utils.hs

The second pattern is abstracted with withSep, with its definition inside Combinators.hs

vicgeentor · 2026-04-09T15:08:21Z

-  append $ pprText pat
-  append $ T.replicate (maxWidth - patWidth pat) " "
-  printPatsWithPadding rest
+  printPats (zip pats maxWidths)


printPats is now also a function we all use instead of seperate implementations. It has moved to Pattern.hs

vicgeentor · 2026-04-09T15:11:05Z

 printExpr :: HsExpr GhcPs -> Hattier
 printExpr (HsCase _ scrut mg) = printCaseExpr scrut mg
-printExpr expr = append (pprText expr)
+printExpr (HsLet _ binds body) = printLetExpr binds body


printing let-expressions has moved to here.

vicgeentor · 2026-04-09T15:11:56Z

+  withSep newline $ map (printAlt (indToText indW) maxWidth) matches
+
+-- With NoAlignment, maxWidth should be 0
+printAlt :: Text -> Int -> LMatch GhcPs (LHsExpr GhcPs) -> Hattier


PrintAlt is basically the merged version of PrintAltAlign and PrintAltNoAlign. When not aligning, maxWidth is simply 0.

vicgeentor · 2026-04-09T15:13:59Z

+printLetExpr :: HsLocalBinds GhcPs -> LHsExpr GhcPs -> Hattier
+printLetExpr (HsValBinds _ (ValBinds _ binds _sigs)) body = do
+  style <- asks (letAlignment . cfg)
+  indW <- asks (fromIntegral . indentWidth . cfg)
+  let bindList = bagToList binds
+      bindInd = indToText (indW + 4)
+      alignCol = computeAlignment style (map nameLen bindList)
+  append "let "
+  printBinds bindInd alignCol bindList
+  newline >> append (indToText indW) >> append "in  " >> printExpr (unLoc body)
+printLetExpr localBinds body = do
+  -- TODO: HsIPBinds and EmptyLocalBinds cases
+  indW <- asks (fromIntegral . indentWidth . cfg)
+  fallback localBinds
+  newline >> append (indToText indW) >> append "in  " >> printExpr (unLoc body)
+
+-- | Print a list of bindings multi-line, using @alignCol@ for padding.
+-- Pass @alignCol = 0@ for no alignment.
+--
+--   let x        = 1   -- PrimaryAlignment (alignCol = 8)
+--       longName = 2
+--
+--   let x = 1          -- NoAlignment (alignCol = 0)
+--       longName = 2
+printBinds :: Text -> Int -> [LHsBind GhcPs] -> Hattier
+printBinds ind alignCol binds =
+  withSep (newline >> append ind) $ map (printBind ind alignCol) binds
+
+-- | Print a single binding, padding the name to @alignCol@ columns.
+-- When @alignCol = 0@ no padding is added.
+printBind :: Text -> Int -> LHsBind GhcPs -> Hattier
+printBind bindInd alignCol (L _ (FunBind _ lname mg)) = do
+  let name = pprText $ unLoc lname
+  append $ padTo alignCol name
+  case unLoc (mg_alts mg) of
+    [L _ Match {m_pats = pats, m_grhss = grhss}] -> do
+      printPats (zip pats (repeat 0))
+      printRHS bindInd grhss
+    -- Empty or multi-clause let bindings are not valid Haskell and
+    -- cannot be produced by GHC's parser, so these branches are unreachable.
+    -- still, we need to handle them to satisfy the type checker.
+    _ -> pure ()
+printBind _ _ bind =
+  -- TODO: PatBind and other binding forms
+  fallback (unLoc bind)


This code is basically unchanged. It simply uses the new abstractions, making it more compact. It also uses the same logic for printing patterns as the rest of the code

LVries

First look, will look more once I am home

LVries · 2026-04-09T15:05:42Z

-    -- funcAlignment drives which code path handles the function body.
-    -- PrimaryAlignment uses printClause, which calls printExpr on the body.
-    -- printExpr does not handle HsLet, so it falls through to pprText, placing
-    -- 'in' at column 0 - invalid Haskell. NoAlignment uses pprText for the whole
-    -- match clause, which always produces valid output.
-    -- letAlignment does not affect this routing, so only funcAlignment matters.
-    [ testCase "#37: funcAlignment=PrimaryAlignment (default) - 'in' incorrectly at col 0" letInFunctionBodyPrimary,
-      testCase "#37: funcAlignment=NoAlignment - valid output via pprText fallback" letInFunctionBodyNoAlign


Fair enough

LVries · 2026-04-09T15:06:26Z

            "greet 1 = \" INFOAFP\"",
-            "greet _",
-            "  = let",
-            "      hello = greet 0",
+            "greet _ =",
+            "  let hello  = greet 0",
            "      course = greet 1",
-            "    in hello ++ course"


Is this change in expected outcome desired?

Yes! Since only funcAlignment is disabled here. Not letAlignment

LVries · 2026-04-09T15:08:12Z

+printModule :: Hattier
+printModule = do
+  printModHeader
+  printModImports
+  printModDecls
+


LVries · 2026-04-09T15:09:57Z

+computeAlignment :: Alignment -> [Int] -> Int
+computeAlignment PrimaryAlignment xs = maximum xs
+computeAlignment NoAlignment _ = 0
+
+computeColumnAlignments :: Alignment -> [[Int]] -> [Int]
+computeColumnAlignments PrimaryAlignment cols = map maximum cols
+computeColumnAlignments NoAlignment cols = map (const 0) cols


vicgeentor · 2026-04-09T15:15:00Z

+printBind :: Text -> Int -> LHsBind GhcPs -> Hattier
+printBind bindInd alignCol (L _ (FunBind _ lname mg)) = do
+  let name = pprText $ unLoc lname
+  append $ padTo alignCol name


padTo is a new abstraction in Utils.hs. Take a look at its definition to understand it. If it doesn't feel logical, please tell me so we'll think of a better abstraction.

Am I correct in assuming padTo 5 "y" ->yxxxx (where is a space for clarity) so it adds (y is length 1) 5-1 spaces?

That's exactly correct. This lets you do stuff like append $ padTo maxWidth patTxt so that your next patTxt will start on the right column.

Also, running your example in ghci gives exactly what you assumed:

ghci> padTo 5 "y" "y "

vicgeentor · 2026-04-09T15:16:45Z

-    nameLen _ = 0
-
-- | Print the body of a @let@ expression, recursing into nested @let@s.
-printLetBody :: HsExpr GhcPs -> Hattier


This is now the same as printExpr now that printLetExpr has moved into that. This function is thus entirely removed.

vicgeentor · 2026-04-09T15:17:58Z

+  indW <- asks (fromIntegral . indentWidth . cfg)
+  let bindList = bagToList binds
+      bindInd = indToText (indW + 4)
+      alignCol = computeAlignment style (map nameLen bindList)


Like I said earlier, the style seperation between NoAlignment and PrimaryAlignment has moved to computeAlignment. Makes for more simple implementations

vicgeentor · 2026-04-09T15:19:00Z

+    GRHSs _ [L _ (GRHS _ [] body)] _ ->
+      printExpr (unLoc body)
+    GRHSs _ xs _ ->
+      printGRHS ind xs


Printing a guarded RHS has moved to printGRHS at the bottom of this file. I actually wanted to abstract this entire case expression to printRHS (also at the bottom of this file) but haven't figured that out yet.

printRHS also calls printGRHS for a guarded expression. Outside of that, this is currently the only place that calls printGRHS. We should figure out how to defer this to printRHS for maintainability.

vicgeentor · 2026-04-09T15:26:11Z

+printBinds :: Text -> Int -> [LHsBind GhcPs] -> Hattier
+printBinds ind alignCol binds =
+  withSep (newline >> append ind) $ map (printBind ind alignCol) binds


Logic unchanged, but again uses the new withSep abstraction.

vicgeentor · 2026-04-09T15:26:37Z

+  -- TODO: PatBind and other binding forms
+  fallback (unLoc bind)
+
+-- * RHS


New section purely dedicated to printing RHS's

vicgeentor · 2026-04-09T15:27:55Z

+printPats :: [(LPat GhcPs, Int)] -> Hattier
+printPats = mapM_ $ \(pat, maxWidth) -> do
+  let patTxt = pprText pat
+  append " " >> append (padTo maxWidth patTxt)


this used to be printPatsWithPadding. With NoAlignment all the second tuple elements should be 0.

vicgeentor · 2026-04-09T15:28:37Z

+patWidth :: LPat GhcPs -> Int
+patWidth (L _ pat) =
+  case pat of
+    -- In most cases where a specific integer is added to the width, the
+    -- comment after the case shows what that integer represents
+    WildPat _ -> 1
+    VarPat _ (L _ name) -> T.length (pprText name)
+    LazyPat _ pat' -> 1 + patWidth pat' -- "~"
+    AsPat _ (L _ name) pat' -> T.length (pprText name) + 1 + patWidth pat' -- "@"
+    ParPat _ pat' -> 2 + patWidth pat' -- "(" + ")"
+    BangPat _ pat' -> 1 + patWidth pat' -- "!"
+    ListPat _ pats -> 2 + sum (map patWidth pats) + max 0 (length pats - 1) * 2 -- "[" + "]" + commas: ", "
+    TuplePat _ pats Boxed ->
+      2 + sum (map patWidth pats) + max 0 (length pats - 1) * 2 -- "(" + ")" + commas: ", "
+    TuplePat _ pats Unboxed ->
+      4 + sum (map patWidth pats) + max 0 (length pats - 1) * 2 -- "(#" + "#)" + commas: ", "
+    ConPat _ (L _ name) (InfixCon l r) ->
+      patWidth l + 1 + T.length (pprText name) + 1 + patWidth r -- " con "
+    ConPat _ (L _ name) (PrefixCon _ args) ->
+      T.length (pprText name) + sum (map (\a -> 1 + patWidth a) args)
+    ConPat _ (L _ name) (RecCon _) -> T.length $ pprText name -- TODO: records
+    LitPat _ lit -> T.length $ pprText lit
+    NPat _ (L _ lit) (Just _) _ -> 1 + (T.length $ pprText lit) -- "-"
+    NPat _ (L _ lit) Nothing _ -> T.length $ pprText lit
+    SigPat _ pat' sig -> 2 + patWidth pat' + 4 + (T.length $ pprText sig) -- "(" + " :: " + ")"
+    -- TODO: the following require certain language extensions
+    SumPat _ _ _ _ -> undefined -- UnboxedSums extension
+    ViewPat _ _ _ -> undefined -- ViewPatterns extension
+    SplicePat _ _ -> undefined -- TemplateHaskell extension
+    NPlusKPat _ _ _ _ _ _ -> undefined -- NPlusKPatterns extension
+    EmbTyPat _ _ -> undefined -- ExplicitNamespaces and RequiredTypeArguments extensions
+    InvisPat _ _ -> undefined -- TypeAbstractions extension
+
+matchWidth :: LMatch GhcPs (LHsExpr GhcPs) -> Int
+matchWidth (L _ Match {m_pats = [pat]}) = patWidth pat
+matchWidth _ = 0


Unchanged code that moved

vicgeentor · 2026-04-09T15:29:02Z

+pprText :: (Outputable a) => a -> Text
+pprText = T.pack . showSDocUnsafe . ppr


Unchanged code that moved

vicgeentor · 2026-04-09T15:29:29Z

+nameLen :: LHsBind GhcPs -> Int
+nameLen (L _ (FunBind _ lname _)) = T.length (pprText $ unLoc lname)
+nameLen _ = 0


New function currently only used inside printLetExpr

vicgeentor · 2026-04-09T15:30:48Z

            "greet 1 = \" INFOAFP\"",
-            "greet _",
-            "  = let",
-            "      hello = greet 0",
+            "greet _ =",
+            "  let hello  = greet 0",
            "      course = greet 1",
-            "    in hello ++ course"


Yes! Since only funcAlignment is disabled here. Not letAlignment

vicgeentor · 2026-04-09T15:31:12Z

@@ -0,0 +1,150 @@
+-- Some disabled warnings to delete after recursive printing with indentation is implemented


See this comment

Am I correct in seeing this test as a check for recursive indentation printing?

That's right. It is basically a test for nested let AND case expressions, that's why I called it an integration test

vicgeentor · 2026-04-09T15:32:00Z

 nestedNoAlignmentTest = expected @=? runLetPrinter NoAlignment nestedLetSrc
  where
-    expected = "let x = 1\n      longName = 2\n  in let result = x\n  in result"
+    expected = "let x = 1\n      longName = 2\n  in  let result = x\n  in  result"


Even when not aligning equals signs, I think the in should still always have an extra space. If you don't agree, I'll remove it

nomadalgia

I mostly did a proper check that the changes are sound for Expression.hs, since I was most familiar with it.
For the rest, it seems like it is mostly moving code around.
Very good! Highly needed change.
It merge new functionality with refactoring, but that's fine since

they are both correct so its not blocking
we need this merge now now now now
Once merged, I will adapt my case-cons-align branch appropriately as mentioned there.

Core: add import printing

vicgeentor added 2 commits April 9, 2026 16:34

core/refactor: tying up the printers to allow for recursive printing

43fe713

test: add integration test with deep nesting, currently a disabled test

d49bb17

vicgeentor linked an issue Apr 9, 2026 that may be closed by this pull request

Ticket (core/refactor): tying up the printers to allow for recursive printing #53

Closed

vicgeentor commented Apr 9, 2026

View reviewed changes

LVries reviewed Apr 9, 2026

View reviewed changes

vicgeentor commented Apr 9, 2026

View reviewed changes

vicgeentor added 2 commits April 9, 2026 19:27

test: add tests for printing module imports

2038edd

core: add import printer

5204dd0

LVries approved these changes Apr 9, 2026

View reviewed changes

nomadalgia approved these changes Apr 9, 2026

View reviewed changes

Merge pull request #55 from hattier-org/add-import-printing

b2ab6a7

Core: add import printing

vicgeentor merged commit ac9b90f into main Apr 9, 2026
2 checks passed

vicgeentor deleted the make-printing-recursive branch April 9, 2026 20:25

		pprText :: (Outputable a) => a -> Text
		pprText = T.pack . showSDocUnsafe . ppr

		@@ -0,0 +1,150 @@
		-- Some disabled warnings to delete after recursive printing with indentation is implemented

Conversation

vicgeentor commented Apr 9, 2026

Uh oh!

Choose a reason for hiding this comment

Uh oh!

Choose a reason for hiding this comment

Uh oh!

vicgeentor Apr 9, 2026 • edited Loading Uh oh! There was an error while loading. Please reload this page.

Uh oh!

Choose a reason for hiding this comment

Uh oh!

Choose a reason for hiding this comment

Uh oh!

Choose a reason for hiding this comment

Uh oh!

Choose a reason for hiding this comment

Uh oh!

LVries left a comment

Choose a reason for hiding this comment

Uh oh!

Choose a reason for hiding this comment

Uh oh!

Choose a reason for hiding this comment

Uh oh!

Choose a reason for hiding this comment

Uh oh!

Choose a reason for hiding this comment

Uh oh!

Choose a reason for hiding this comment

Uh oh!

Choose a reason for hiding this comment

Uh oh!

Choose a reason for hiding this comment

Uh oh!

Choose a reason for hiding this comment

Uh oh!

Choose a reason for hiding this comment

Uh oh!

Choose a reason for hiding this comment

Uh oh!

vicgeentor Apr 9, 2026 • edited Loading Uh oh! There was an error while loading. Please reload this page.

Uh oh!

Choose a reason for hiding this comment

Uh oh!

Choose a reason for hiding this comment

Uh oh!

Choose a reason for hiding this comment

Uh oh!

Choose a reason for hiding this comment

Uh oh!

Choose a reason for hiding this comment

Uh oh!

Choose a reason for hiding this comment

Uh oh!

Choose a reason for hiding this comment

Uh oh!

Choose a reason for hiding this comment

Uh oh!

Choose a reason for hiding this comment

Uh oh!

Choose a reason for hiding this comment

Uh oh!

Choose a reason for hiding this comment

Uh oh!

Choose a reason for hiding this comment

Uh oh!

nomadalgia left a comment

Choose a reason for hiding this comment

Uh oh!

Uh oh!

Reviewers

Assignees

Labels

Projects

Milestone

Development

Uh oh!

3 participants

vicgeentor Apr 9, 2026 •

edited

Loading

vicgeentor Apr 9, 2026 •

edited

Loading