Format linked lists with colon as line terminator

This adds support for a formatting style described here:

<https://wiki.haskell.org/List_notation>

CHANGELOG.md

@@ -13,6 +13,9 @@
 * Fixed a bug related to trailing space in multiline comments in certain
   cases. [Issue 603](https://github.com/tweag/ormolu/issues/602).
 
+* Added support for formatting linked lists with `(:)` as line terminator.
+  [Issue 478](https://github.com/tweag/ormolu/issues/478).
+
 ## Ormolu 0.1.0.0
 
 * Fixed rendering of type signatures concerning several identifiers. [Issue

data/examples/declaration/value/function/infix/dollar-chains-out.hs

@@ -13,9 +13,9 @@ foo =
     throwIO (OrmoluCppEnabled path)
 
 foo =
-  bar
-    $ baz
-    $ quux
+  bar $
+    baz $
+      quux
 
 x =
   case l of { A -> B } $

data/examples/declaration/value/function/infix/hanging-out.hs

@@ -17,6 +17,7 @@ update =
     `catch` \case
       a -> a
 
-foo = bar
-  ++ case foo of
-    a -> a
+foo =
+  bar
+    ++ case foo of
+      a -> a

data/examples/declaration/value/function/infix/lenses-out.hs

@@ -1,11 +1,12 @@
 lenses =
-  Just $ M.fromList $
-    "type" .= ("user.connection" :: Text)
-      # "connection" .= uc
-      # "user" .= case name of
-        Just n -> Just $ object ["name" .= n]
-        Nothing -> Nothing
-      # []
+  Just $
+    M.fromList $
+      "type" .= ("user.connection" :: Text)
+        # "connection" .= uc
+        # "user" .= case name of
+          Just n -> Just $ object ["name" .= n]
+          Nothing -> Nothing
+        # []
 
 foo =
   a

data/examples/declaration/value/function/list-notation-0-out.hs

@@ -0,0 +1,5 @@
+foo =
+  testCase "Foo" testFoo :
+  testCase "Bar" testBar :
+  testCase "Baz" testBaz :
+  []

data/examples/declaration/value/function/list-notation-0.hs

@@ -0,0 +1,5 @@
+foo =
+  testCase "Foo" testFoo :
+  testCase "Bar" testBar :
+  testCase "Baz" testBaz :
+  []

data/examples/declaration/value/function/list-notation-1-out.hs

@@ -0,0 +1,8 @@
+instance A.ToJSON UpdateTable where
+  toJSON a =
+    A.object $
+      "TableName" .= updateTableName a :
+      "ProvisionedThroughput" .= updateProvisionedThroughput a :
+      case updateGlobalSecondaryIndexUpdates a of
+        [] -> []
+        l -> ["GlobalSecondaryIndexUpdates" .= l]

data/examples/declaration/value/function/list-notation-1.hs

@@ -0,0 +1,7 @@
+instance A.ToJSON UpdateTable where
+    toJSON a = A.object
+        $ "TableName" .= updateTableName a
+        : "ProvisionedThroughput" .= updateProvisionedThroughput a
+        : case updateGlobalSecondaryIndexUpdates a of
+            [] -> []
+            l -> [ "GlobalSecondaryIndexUpdates" .= l ]

data/examples/declaration/value/function/list-notation-2-out.hs

@@ -0,0 +1,6 @@
+-- A list of the element and all its parents up to the root node.
+getPath tree t =
+  t :
+  case Map.lookup (getId t) tree of
+    Nothing -> []
+    Just parent -> getPath tree parent

data/examples/declaration/value/function/list-notation-2.hs

@@ -0,0 +1,5 @@
+-- A list of the element and all its parents up to the root node.
+getPath tree t = t :
+    case Map.lookup (getId t) tree of
+        Nothing     -> []
+        Just parent -> getPath tree parent

data/examples/declaration/value/function/list-notation-3-out.hs

@@ -0,0 +1,12 @@
+foo =
+  reportSDoc "tc.cc" 30 $
+    sep $ do
+      (prettyTCM q <+> " before compilation") : do
+        map (prettyTCM . map unArg . clPats) cls
+
+foo =
+  reportSDoc "tc.cc" 30 $
+    sep $ do
+      (prettyTCM q <+> " before compilation") :
+        do
+          map (prettyTCM . map unArg . clPats) cls

data/examples/declaration/value/function/list-notation-3.hs

@@ -0,0 +1,10 @@
+foo =
+  reportSDoc "tc.cc" 30 $ sep $ do
+    (prettyTCM q <+> " before compilation") : do
+      map (prettyTCM . map unArg . clPats) cls
+
+foo =
+  reportSDoc "tc.cc" 30 $ sep $ do
+    (prettyTCM q <+> " before compilation") :
+      do
+        map (prettyTCM . map unArg . clPats) cls

expected-failures/Agda.txt

@@ -5,7 +5,7 @@ Formatting is not idempotent:
 Please, consider reporting the bug.
 
 Formatting is not idempotent:
-  src/full/Agda/Syntax/Translation/InternalToAbstract.hs<rendered>:745:4
+  src/full/Agda/Syntax/Translation/InternalToAbstract.hs<rendered>:750:4
   before: " nes\n\n              "
   after:  " nes\n\n    -- Andreas"
 Please, consider reporting the bug.

expected-failures/intero.txt

@@ -1,5 +1,5 @@
 Formatting is not idempotent:
-  src/InteractiveUI.hs<rendered>:3688:33
+  src/InteractiveUI.hs<rendered>:3708:33
   before: "text \"Try\" <+> doWha"
   after:  "text \"Try\"\n         "
 Please, consider reporting the bug.

expected-failures/leksah.txt

@@ -1,5 +1,5 @@
 Formatting is not idempotent:
-  src/IDE/Pane/Modules.hs<rendered>:1188:7
+  src/IDE/Pane/Modules.hs<rendered>:1187:7
   before: "cr\n          -- show"
   after:  "cr\n       in -- show"
 Please, consider reporting the bug.

src/Ormolu/Printer/Meat/Common.hs

@@ -131,7 +131,7 @@ p_infixDefHelper isInfix indentArgs name args =
       parens' $ do
         p0
         breakpoint
-        inci $ sitcc $ do
+        inci . sitcc $ do
           name
           space
           p1

src/Ormolu/Printer/Meat/Declaration.hs

@@ -54,12 +54,13 @@ p_hsDeclsRespectGrouping :: FamilyStyle -> [LHsDecl GhcPs] -> R ()
 p_hsDeclsRespectGrouping = p_hsDecls' Respect
 
 p_hsDecls' :: UserGrouping -> FamilyStyle -> [LHsDecl GhcPs] -> R ()
-p_hsDecls' grouping style decls = sepSemi id $
-  -- Return a list of rendered declarations, adding a newline to separate
-  -- groups.
-  case groupDecls decls of
-    [] -> []
-    (x : xs) -> renderGroup x ++ concat (zipWith renderGroupWithPrev (x : xs) xs)
+p_hsDecls' grouping style decls =
+  sepSemi id $
+    -- Return a list of rendered declarations, adding a newline to separate
+    -- groups.
+    case groupDecls decls of
+      [] -> []
+      (x : xs) -> renderGroup x ++ concat (zipWith renderGroupWithPrev (x : xs) xs)
   where
     renderGroup = NE.toList . fmap (located' $ dontUseBraces . p_hsDecl style)
     renderGroupWithPrev prev curr =
@@ -288,9 +289,10 @@ patSigRdrNames (SigD NoExtField (PatSynSig NoExtField ns _)) = Just $ map unLoc
 patSigRdrNames _ = Nothing
 
 warnSigRdrNames :: HsDecl GhcPs -> Maybe [RdrName]
-warnSigRdrNames (WarningD NoExtField (Warnings NoExtField _ ws)) = Just $ flip concatMap ws $ \case
-  L _ (Warning NoExtField ns _) -> map unLoc ns
-  L _ (XWarnDecl x) -> noExtCon x
+warnSigRdrNames (WarningD NoExtField (Warnings NoExtField _ ws)) = Just $
+  flip concatMap ws $ \case
+    L _ (Warning NoExtField ns _) -> map unLoc ns
+    L _ (XWarnDecl x) -> noExtCon x
 warnSigRdrNames _ = Nothing
 
 patBindNames :: Pat GhcPs -> [RdrName]

src/Ormolu/Printer/Meat/Declaration/Data.hs

@@ -60,28 +60,26 @@ p_dataDecl style name tpats fixity HsDataDefn {..} = do
           txt "where"
         breakpoint
         sepSemi (located' (p_conDecl False)) dd_cons
-      else switchLayout (getLoc name : (getLoc <$> dd_cons))
-        $ inci
-        $ do
-          let singleConstRec = isSingleConstRec dd_cons
-          if singleConstRec
-            then space
-            else
-              if hasHaddocks dd_cons
-                then newline
-                else breakpoint
-          equals
-          space
-          layout <- getLayout
-          let s =
-                if layout == MultiLine || hasHaddocks dd_cons
-                  then newline >> txt "|" >> space
-                  else space >> txt "|" >> space
-              sitcc' =
-                if singleConstRec
-                  then id
-                  else sitcc
-          sep s (sitcc' . located' (p_conDecl singleConstRec)) dd_cons
+      else switchLayout (getLoc name : (getLoc <$> dd_cons)) . inci $ do
+        let singleConstRec = isSingleConstRec dd_cons
+        if singleConstRec
+          then space
+          else
+            if hasHaddocks dd_cons
+              then newline
+              else breakpoint
+        equals
+        space
+        layout <- getLayout
+        let s =
+              if layout == MultiLine || hasHaddocks dd_cons
+                then newline >> txt "|" >> space
+                else space >> txt "|" >> space
+            sitcc' =
+              if singleConstRec
+                then id
+                else sitcc
+        sep s (sitcc' . located' (p_conDecl singleConstRec)) dd_cons
   unless (null $ unLoc dd_derivs) breakpoint
   inci . located dd_derivs $ \xs ->
     sep newline (located' p_hsDerivingClause) xs

src/Ormolu/Printer/Meat/Declaration/Instance.hs

@@ -88,12 +88,10 @@ p_clsInstDecl = \case
             unless (null allDecls) $ do
               breakpoint
               txt "where"
-        unless (null allDecls)
-          $ inci
-          $ do
-            -- Ensure whitespace is added after where clause.
-            breakpoint
-            dontUseBraces $ p_hsDeclsRespectGrouping Associated allDecls
+        unless (null allDecls) . inci $ do
+          -- Ensure whitespace is added after where clause.
+          breakpoint
+          dontUseBraces $ p_hsDeclsRespectGrouping Associated allDecls
       XHsImplicitBndrs x -> noExtCon x
   XClsInstDecl x -> noExtCon x
 

src/Ormolu/Printer/Meat/Declaration/Value.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiWayIf #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE TypeApplications #-}
@@ -26,7 +27,7 @@ import qualified Data.List.NonEmpty as NE
 import Data.Text (Text)
 import qualified Data.Text as Text
 import GHC
-import OccName (mkVarOcc)
+import OccName (occNameString)
 import Ormolu.Printer.Combinators
 import Ormolu.Printer.Internal
 import Ormolu.Printer.Meat.Common
@@ -60,7 +61,7 @@ data Placement
     -- should use it and avoid bumping one level
     -- of indentation
     Hanging
-  deriving (Eq)
+  deriving (Eq, Show)
 
 p_valDecl :: HsBindLR GhcPs GhcPs -> R ()
 p_valDecl = \case
@@ -180,9 +181,10 @@ p_match' placer render style isInfix strictness m_pats GRHSs {..} = do
     SrcStrict -> txt "!"
     SrcLazy -> txt "~"
   indentBody <- case NE.nonEmpty m_pats of
-    Nothing -> False <$ case style of
-      Function name -> p_rdrName name
-      _ -> return ()
+    Nothing ->
+      False <$ case style of
+        Function name -> p_rdrName name
+        _ -> return ()
     Just ne_pats -> do
       let combinedSpans =
             combineSrcSpans' $
@@ -592,9 +594,10 @@ p_hsExpr' s = \case
                 L _ (HsAppType NoExtField _ _) -> True
                 L _ (HsMultiIf NoExtField _) -> True
                 L spn _ -> isOneLineSpan spn
-        ub <- getLayout <&> \case
-          SingleLine -> useBraces
-          MultiLine -> id
+        ub <-
+          getLayout <&> \case
+            SingleLine -> useBraces
+            MultiLine -> id
         ub $ do
           located func (p_hsExpr' s)
           breakpoint
@@ -617,7 +620,7 @@ p_hsExpr' s = \case
       located (hswc_body a) p_hsType
   OpApp NoExtField x op y -> do
     let opTree = OpBranch (exprOpTree x) op (exprOpTree y)
-    p_exprOpTree True s (reassociateOpTree getOpName opTree)
+    p_exprOpTree s (reassociateOpTree getOpName opTree)
   NegApp NoExtField e _ -> do
     txt "-"
     space
@@ -671,7 +674,7 @@ p_hsExpr' s = \case
             sepSemi
               (ub . withSpacing (p_stmt' exprPlacement (p_hsExpr' S)))
               (unLoc es)
-        compBody = brackets N $ located es $ \xs -> do
+        compBody = brackets N . located es $ \xs -> do
           let p_parBody =
                 sep
                   (breakpoint >> txt "|" >> space)
@@ -1222,11 +1225,10 @@ exprPlacement = \case
   HsCase NoExtField _ _ -> Hanging
   HsDo NoExtField DoExpr _ -> Hanging
   HsDo NoExtField MDoExpr _ -> Hanging
-  -- If the rightmost expression in an operator chain is hanging, make the
-  -- whole block hanging; so that we can use the common @f = foo $ do@
-  -- style.
-  OpApp NoExtField _ _ y -> exprPlacement (unLoc y)
-  -- Same thing for function applications (usually with -XBlockArguments)
+  OpApp NoExtField _ op y ->
+    case (fmap getOpNameStr . getOpName . unLoc) op of
+      Just "$" -> exprPlacement (unLoc y)
+      _ -> Normal
   HsApp NoExtField _ y -> exprPlacement (unLoc y)
   HsProc NoExtField p _ ->
     -- Indentation breaks if pattern is longer than one line and left
@@ -1252,15 +1254,16 @@ getOpName = \case
   HsVar NoExtField (L _ a) -> Just a
   _ -> Nothing
 
+getOpNameStr :: RdrName -> String
+getOpNameStr = occNameString . rdrNameOcc
+
 p_exprOpTree ::
-  -- | Can use special handling of dollar?
-  Bool ->
   -- | Bracket style to use
   BracketStyle ->
   OpTree (LHsExpr GhcPs) (LHsExpr GhcPs) ->
   R ()
-p_exprOpTree _ s (OpNode x) = located x (p_hsExpr' s)
-p_exprOpTree isDollarSpecial s (OpBranch x op y) = do
+p_exprOpTree s (OpNode x) = located x (p_hsExpr' s)
+p_exprOpTree s (OpBranch x op y) = do
   -- If the beginning of the first argument and the second argument are on
   -- the same line, and the second argument has a hanging form, use hanging
   -- placement.
@@ -1282,44 +1285,54 @@ p_exprOpTree isDollarSpecial s (OpBranch x op y) = do
         MultiLine -> case placement of
           Hanging -> useBraces
           Normal -> dontUseBraces
-      gotDollar = case getOpName (unLoc op) of
-        Just rname -> mkVarOcc "$" == rdrNameOcc rname
-        _ -> False
+      opNameStr = (fmap getOpNameStr . getOpName . unLoc) op
+      gotDollar = opNameStr == Just "$"
+      gotColon = opNameStr == Just ":"
+      gotRecordDot = isRecordDot (unLoc op) (opTreeLoc y)
       lhs =
         switchLayout [opTreeLoc x] $
-          p_exprOpTree (not gotDollar) s x
-  let p_op = located op (opWrapper . p_hsExpr)
-      p_y = switchLayout [opTreeLoc y] (p_exprOpTree True N y)
+          p_exprOpTree s x
+      p_op = located op (opWrapper . p_hsExpr)
+      p_y = switchLayout [opTreeLoc y] (p_exprOpTree N y)
       isSection = case (opTreeLoc x, getLoc op) of
         (RealSrcSpan treeSpan, RealSrcSpan opSpan) ->
           srcSpanEndCol treeSpan /= srcSpanStartCol opSpan
         _ -> False
+      isDoBlock = \case
+        OpNode (L _ HsDo {}) -> True
+        _ -> False
   useRecordDot' <- useRecordDot
-  let isRecordDot' = isRecordDot (unLoc op) (opTreeLoc y)
-  if useRecordDot' && isRecordDot'
-    then do
-      lhs
-      when isSection space
-      p_op
-      p_y
-    else
-      if isDollarSpecial
-        && gotDollar
-        && placement
-        == Normal
-        && isOneLineSpan (opTreeLoc x)
-        then do
-          useBraces lhs
-          space
-          p_op
-          breakpoint
-          inci p_y
-        else do
-          ub lhs
-          placeHanging placement $ do
-            p_op
+  if
+      | gotColon -> do
+        lhs
+        space
+        p_op
+        case placement of
+          Hanging -> do
             space
             p_y
+          Normal -> do
+            breakpoint
+            inciIf (isDoBlock y) p_y
+      | gotDollar
+          && isOneLineSpan (opTreeLoc x)
+          && placement == Normal -> do
+        useBraces lhs
+        space
+        p_op
+        breakpoint
+        inci p_y
+      | useRecordDot' && gotRecordDot -> do
+        lhs
+        when isSection space
+        p_op
+        p_y
+      | otherwise -> do
+        ub lhs
+        placeHanging placement $ do
+          p_op
+          space
+          p_y
 
 -- | Return 'True' if given expression is a record-dot operator expression.
 isRecordDot ::
@@ -1330,14 +1343,10 @@ isRecordDot ::
   Bool
 isRecordDot op (RealSrcSpan ySpan) = case op of
   HsVar NoExtField (L (RealSrcSpan opSpan) opName) ->
-    isDot opName && (srcSpanEndCol opSpan == srcSpanStartCol ySpan)
+    (getOpNameStr opName == ".") && (srcSpanEndCol opSpan == srcSpanStartCol ySpan)
   _ -> False
 isRecordDot _ _ = False
 
--- | Check whether a given 'RdrName' is the dot operator.
-isDot :: RdrName -> Bool
-isDot name = rdrNameOcc name == mkVarOcc "."
-
 -- | Get annotations for the enclosing element.
 getEnclosingAnns :: R [AnnKeywordId]
 getEnclosingAnns = do

src/Ormolu/Printer/Meat/Declaration/Warning.hs

@@ -32,9 +32,8 @@ p_moduleWarning wtxt = do
 p_topLevelWarning :: [Located RdrName] -> WarningTxt -> R ()
 p_topLevelWarning fnames wtxt = do
   let (pragmaText, lits) = warningText wtxt
-  switchLayout (fmap getLoc fnames ++ fmap getLoc lits)
-    $ pragma pragmaText . inci
-    $ do
+  switchLayout (fmap getLoc fnames ++ fmap getLoc lits) $
+    pragma pragmaText . inci $ do
       sep commaDel p_rdrName fnames
       breakpoint
       p_lits lits

src/Ormolu/Printer/Meat/ImportExport.hs

@@ -93,9 +93,8 @@ p_lie encLayout relativePos = \case
     inci $ do
       let names :: [R ()]
           names = located' p_ieWrappedName <$> xs
-      parens N
-        $ sep commaDel sitcc
-        $ case w of
+      parens N . sep commaDel sitcc $
+        case w of
           NoIEWildcard -> names
           IEWildcard n ->
             let (before, after) = splitAt n names

src/Ormolu/Printer/Meat/Type.hs

@@ -67,7 +67,7 @@ p_hsType' multilineArgs docStyle = \case
             L _ (HsAppTy _ l r) -> gatherArgs l (r : knownArgs)
             _ -> (f', knownArgs)
         (func, args) = gatherArgs f [x]
-    switchLayout (getLoc f : fmap getLoc args) $ sitcc $ do
+    switchLayout (getLoc f : fmap getLoc args) . sitcc $ do
       located func p_hsType
       breakpoint
       inci $
@@ -270,6 +270,6 @@ tyVarToType = \case
     -- <https://gitlab.haskell.org/ghc/ghc/issues/17404>. This is fine as
     -- long as 'tyVarToType' does not get applied to right-hand sides of
     -- declarations.
-    HsParTy NoExtField $ noLoc $
+    HsParTy NoExtField . noLoc $
       HsKindSig NoExtField (noLoc (HsTyVar NoExtField NotPromoted tvar)) kind
   XTyVarBndr x -> noExtCon x

src/Ormolu/Printer/Operators.hs

@@ -16,7 +16,7 @@ import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
 import Data.Maybe (fromMaybe, mapMaybe)
 import GHC
-import OccName (mkVarOcc)
+import OccName (occNameString)
 import Ormolu.Utils (unSrcSpan)
 
 -- | Intermediate representation of operator trees. It has two type
@@ -57,7 +57,7 @@ reassociateOpTree getOpName opTree =
 reassociateOpTreeWith ::
   forall ty op.
   -- | Fixity map for operators
-  Map RdrName Fixity ->
+  Map String Fixity ->
   -- | How to get the name of an operator
   (op -> Maybe RdrName) ->
   -- | Original 'OpTree'
@@ -68,8 +68,8 @@ reassociateOpTreeWith fixityMap getOpName = go
   where
     fixityOf :: op -> Fixity
     fixityOf op = fromMaybe defaultFixity $ do
-      opName <- getOpName op
-      M.lookup opName fixityMap
+      s <- occNameString . rdrNameOcc <$> getOpName op
+      M.lookup s fixityMap
     -- Here, left branch is already associated and the root alongside with
     -- the right branch is right-associated. This function picks up one item
     -- from the right and inserts it correctly to the left.
@@ -112,26 +112,26 @@ buildFixityMap ::
   -- | Operator tree
   OpTree (Located ty) (Located op) ->
   -- | Fixity map
-  Map RdrName Fixity
+  Map String Fixity
 buildFixityMap getOpName opTree =
   addOverrides
     . M.fromList
     . concatMap (\(i, ns) -> map (\(n, _) -> (n, fixity i InfixL)) ns)
-    . zip [1 ..]
+    . zip [2 ..]
     . L.groupBy ((==) `on` snd)
     . selectScores
     $ score opTree
   where
-    addOverrides :: Map RdrName Fixity -> Map RdrName Fixity
+    addOverrides :: Map String Fixity -> Map String Fixity
     addOverrides m =
-      let mk k v = (mkRdrUnqual (mkVarOcc k), fixity v InfixL)
-       in M.fromList
-            [ mk "$" 0,
-              mk "." 9
-            ]
-            `M.union` m
+      M.fromList
+        [ ("$", fixity 0 InfixR),
+          (":", fixity 1 InfixR),
+          (".", fixity 100 InfixL)
+        ]
+        `M.union` m
     fixity = Fixity NoSourceText
-    score :: OpTree (Located ty) (Located op) -> [(RdrName, Score)]
+    score :: OpTree (Located ty) (Located op) -> [(String, Score)]
     score (OpNode _) = []
     score (OpBranch l o r) = fromMaybe (score r) $ do
       -- If we fail to get any of these, 'defaultFixity' will be used by
@@ -141,13 +141,13 @@ buildFixityMap getOpName opTree =
       oe <- srcSpanEndLine <$> unSrcSpan (getLoc o) -- operator end
       rb <- srcSpanStartLine <$> unSrcSpan (opTreeLoc r) -- right begin
       oc <- srcSpanStartCol <$> unSrcSpan (getLoc o) -- operator column
-      opName <- getOpName (unLoc o)
+      opName <- occNameString . rdrNameOcc <$> getOpName (unLoc o)
       let s
             | le < ob = AtBeginning oc
             | oe < rb = AtEnd
             | otherwise = InBetween
       return $ (opName, s) : score r
-    selectScores :: [(RdrName, Score)] -> [(RdrName, Score)]
+    selectScores :: [(String, Score)] -> [(String, Score)]
     selectScores =
       L.sortOn snd
         . mapMaybe