Discard special case for non-nested OpApp

2023-04-20 21:35:33 +00:00 · 2023-04-20 21:35:33 +00:00 · 99e5aacb5e
parent 52e4658314
commit 99e5aacb5e
5 changed files with 43 additions and 86 deletions
--- a/data/15-regressions.blt
+++ b/data/15-regressions.blt
@ -237,7 +237,8 @@ showPackageDetailedInfo pkginfo =
          , entry "Cached"        haveTarball  alwaysShow      dispYesNo
          , if not (hasLib pkginfo)
            then empty
-            else text "Modules:"
+            else
+              text "Modules:"
              $+$ nest 4 (vcat (map disp . sort . modules $ pkginfo))
          ]

@ -303,18 +304,18 @@ func _                   = 3
 #test listcomprehension-case-of
 parserCompactLocation =
  [ try
-      $ [ ParseRelAbs (Text.Read.read digits) _ _
-        | digits <- many1 digit
-        , rel1 :: Maybe (Either Int (Ratio Int)) <-
-          optionMaybe
-            [ case divPart of
-                Nothing -> Left $ Text.Read.read digits
-                Just ddigits ->
-                  Right $ Text.Read.read digits % Text.Read.read ddigits
-            | digits  <- many1 digit
-            , divPart <- optionMaybe (string "/" *> many1 digit)
-            ]
-        ]
+    $ [ ParseRelAbs (Text.Read.read digits) _ _
+      | digits <- many1 digit
+      , rel1 :: Maybe (Either Int (Ratio Int)) <-
+        optionMaybe
+          [ case divPart of
+              Nothing -> Left $ Text.Read.read digits
+              Just ddigits ->
+                Right $ Text.Read.read digits % Text.Read.read ddigits
+          | digits  <- many1 digit
+          , divPart <- optionMaybe (string "/" *> many1 digit)
+          ]
+      ]
  ]

 #test opapp-specialcasing-1
@ -445,8 +446,8 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs = do
       ]
    ++ -- two-line solution + where in next line(s)
       [ docLines
-         $  [ docForceSingleline
-              $ docSeq (patPartInline ++ [guardPart, return binderDoc])
+         $  [ docForceSingleline $ docSeq
+              (patPartInline ++ [guardPart, return binderDoc])
            , docEnsureIndent BrIndentRegular
            $ docForceSingleline
            $ return body
@ -872,6 +873,7 @@ instance HasDependencies SomeDataModel where
    = (SomeOtherDataModelId, SomeOtherOtherDataModelId)

 #test stupid-do-operator-combination
+#pending

 func =
  do
--- a/data/30-tests-context-free.blt
+++ b/data/30-tests-context-free.blt
@ -1176,7 +1176,8 @@ showPackageDetailedInfo pkginfo =
          , entry "Cached" haveTarball alwaysShow dispYesNo
          , if not (hasLib pkginfo)
            then empty
-            else text "Modules:"
+            else
+              text "Modules:"
              $+$ nest 4 (vcat (map disp . sort . modules $ pkginfo))
          ]

@ -1249,18 +1250,18 @@ func _ = 3
 #test listcomprehension-case-of
 parserCompactLocation =
  [ try
-      $ [ ParseRelAbs (Text.Read.read digits) _ _
-        | digits <- many1 digit
-        , rel1 :: Maybe (Either Int (Ratio Int)) <-
-          optionMaybe
-            [ case divPart of
-                Nothing -> Left $ Text.Read.read digits
-                Just ddigits ->
-                  Right $ Text.Read.read digits % Text.Read.read ddigits
-            | digits <- many1 digit
-            , divPart <- optionMaybe (string "/" *> many1 digit)
-            ]
-        ]
+    $ [ ParseRelAbs (Text.Read.read digits) _ _
+      | digits <- many1 digit
+      , rel1 :: Maybe (Either Int (Ratio Int)) <-
+        optionMaybe
+          [ case divPart of
+              Nothing -> Left $ Text.Read.read digits
+              Just ddigits ->
+                Right $ Text.Read.read digits % Text.Read.read ddigits
+          | digits <- many1 digit
+          , divPart <- optionMaybe (string "/" *> many1 digit)
+          ]
+      ]
  ]

 #test opapp-specialcasing-1
@ -1370,8 +1371,8 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs = do
       ]
    ++ -- two-line solution + where in next line(s)
       [ docLines
-         $ [ docForceSingleline
-             $ docSeq (patPartInline ++ [guardPart, return binderDoc])
+         $ [ docForceSingleline $ docSeq
+             (patPartInline ++ [guardPart, return binderDoc])
           , docEnsureIndent BrIndentRegular
           $ docForceSingleline
           $ return body
--- a/source/library/Language/Haskell/Brittany/Internal/Components/OpTree.hs
+++ b/source/library/Language/Haskell/Brittany/Internal/Components/OpTree.hs
@ -223,7 +223,9 @@ hardcodedFixity allowUnqualify = \case
  "!"         -> Just $ Fixity NoSourceText 9 InfixL
  "//"        -> Just $ Fixity NoSourceText 9 InfixL
  "<>"        -> Just $ Fixity NoSourceText 6 InfixR
+  "<+>"       -> Just $ Fixity NoSourceText 5 InfixR
  "<$"        -> Just $ Fixity NoSourceText 4 InfixL
+  "$>"        -> Just $ Fixity NoSourceText 4 InfixL
  "<$>"       -> Just $ Fixity NoSourceText 4 InfixL
  "<&>"       -> Just $ Fixity NoSourceText 1 InfixL
  "&"         -> Just $ Fixity NoSourceText 1 InfixL
@ -245,6 +247,7 @@ hardcodedFixity allowUnqualify = \case
  "`shiftR`"  -> Just $ Fixity NoSourceText 8 InfixL
  "`rotateL`" -> Just $ Fixity NoSourceText 8 InfixL
  "`rotateR`" -> Just $ Fixity NoSourceText 8 InfixL
+  "+#"        -> Just $ Fixity NoSourceText 6 InfixL
  ".^."       -> Just $ Fixity NoSourceText 6 InfixL
  ".>>."      -> Just $ Fixity NoSourceText 8 InfixL
  ".<<."      -> Just $ Fixity NoSourceText 8 InfixL
@ -265,6 +268,8 @@ hardcodedFixity allowUnqualify = \case
  ".>"        -> Just $ Fixity NoSourceText 9 InfixL
  ":?"        -> Just $ Fixity NoSourceText 7 InfixN
  ":-"        -> Just $ Fixity NoSourceText 9 InfixR
+  ".:"        -> Just $ Fixity NoSourceText 9 InfixR
+  ".="        -> Just $ Fixity NoSourceText 8 InfixR

  str         -> case (Safe.headMay str, Safe.lastMay str) of
    (Just '\'', _) -> hardcodedFixity False (drop 1 str)
--- a/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Expr.hs
+++ b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Expr.hs
@ -220,7 +220,7 @@ layoutExpr lexpr@(L _ expr) = do
          ]
        , docPar e (docSeq [docLit $ Text.pack "@", t])
        ]
-    OpApp _topEpAnn _expLeft@(L _ OpApp{}) _expOp _expRight -> do
+    OpApp _topEpAnn _expLeft _expOp _expRight -> do
      -- let
      --   allowPar = case (expOp, expRight) of
      --     (L _ (HsVar _ (L _ (Unqual occname))), _)
@ -235,60 +235,6 @@ layoutExpr lexpr@(L _ expr) = do
      treeAndHasComms <-
        layout_gatherOpTreeE layouters False False id Nothing Nothing [] lexpr
      layout_opTree layouters treeAndHasComms
-    OpApp epAnn expLeft expOp expRight -> docHandleComms epAnn $ do
-      expDocLeft  <- shareDoc $ layoutExpr expLeft
-      expDocOp    <- shareDoc $ layoutExpr expOp
-      expDocRight <- shareDoc $ layoutExpr expRight
-      let
-        allowPar = case (expOp, expRight) of
-          (L _ (HsVar _ (L _ (Unqual occname))), _)
-            | occNameString occname == "$" -> True
-          (_, L _ (HsApp _ _ (L _ HsVar{}))) -> False
-          _ -> True
-      let leftIsDoBlock = case expLeft of
-            L _ HsDo{} -> True
-            _          -> False
-      runFilteredAlternative $ do
-        -- one-line
-        addAlternative $ docSeq
-          [ appSep $ docForceSingleline expDocLeft
-          , appSep $ docForceSingleline expDocOp
-          , docForceSingleline expDocRight
-          ]
-        -- -- line + freely indented block for right expression
-        -- addAlternative
-        --   $ docSeq
-        --   [ appSep $ docForceSingleline expDocLeft
-        --   , appSep $ docForceSingleline expDocOp
-        --   , docSetBaseY $ docAddBaseY BrIndentRegular expDocRight
-        --   ]
-        -- two-line
-        addAlternative $ do
-          let expDocOpAndRight = docForceSingleline $ docCols
-                ColOpPrefix
-                [appSep $ expDocOp, docSetBaseY expDocRight]
-          if leftIsDoBlock
-            then docLines [expDocLeft, expDocOpAndRight]
-            else docAddBaseY BrIndentRegular
-              $ docPar expDocLeft expDocOpAndRight
-              -- TODO: in both cases, we don't force expDocLeft to be
-              -- single-line, which has certain.. interesting consequences.
-              -- At least, the "two-line" label is not entirely
-              -- accurate.
-        -- one-line + par
-        addAlternativeCond allowPar $ docSeq
-          [ appSep $ docForceSingleline expDocLeft
-          , appSep $ docForceSingleline expDocOp
-          , docForceParSpacing expDocRight
-          ]
-        -- more lines
-        addAlternative $ do
-          let expDocOpAndRight =
-                docCols ColOpPrefix [appSep expDocOp, docSetBaseY expDocRight]
-          if leftIsDoBlock
-            then docLines [expDocLeft, expDocOpAndRight]
-            else docAddBaseY BrIndentRegular
-              $ docPar expDocLeft expDocOpAndRight
    NegApp _ op _ -> do
      opDoc <- shareDoc $ layoutExpr op
      docSeq [docLit $ Text.pack "-", opDoc]
--- a/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/OpTree.hs
+++ b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/OpTree.hs
@ -258,7 +258,10 @@ layoutOpTree allowSinglelinePar = \case
        -- or
        -- > one + two + case x of
        -- >   _ -> three
-        addAlternativeCond allowSinglelinePar $ wrapParenIfSl hasParen $ docSeq
+        addAlternativeCond allowSinglelinePar
+          $ wrapParenIfSl hasParen
+          $ docSetParSpacing
+          $ docSeq
          ([docForceSingleline docL] ++ case splitFirstLast sharedOps of
            FirstLastEmpty -> []
            FirstLastSingleton (od, ed) ->