Fix two parse issues related to newlines

lib/Language/Haskell/Stylish.hs

@@ -19,6 +19,7 @@ module Language.Haskell.Stylish
     , module Language.Haskell.Stylish.Verbose
     , version
     , format
+    , formatWith
     , ConfigSearchStrategy(..)
     , Lines
     , Step
@@ -106,6 +107,12 @@ runSteps exts mfp steps ls =
  foldM (runStep exts mfp) ls steps
 
 
+-- | Formats given contents using a 'Config' value directly.
+formatWith :: Config -> Maybe FilePath -> String -> Either String Lines
+formatWith conf maybeFilePath contents =
+  runSteps (configLanguageExtensions conf) maybeFilePath (configSteps conf) (lines contents)
+
+
 -- | Formats given contents.
 format ::
      ConfigSearchStrategy
@@ -116,7 +123,7 @@ format ::
   -> IO (Either String Lines)
 format configSearchStrategy maybeFilePath contents = do
   conf <- loadConfig (makeVerbose True) configSearchStrategy
-  pure $ runSteps (configLanguageExtensions conf) maybeFilePath (configSteps conf) $ lines contents
+  pure $ formatWith conf maybeFilePath contents
 
 
 --------------------------------------------------------------------------------

lib/Language/Haskell/Stylish/GHC.hs

@@ -27,7 +27,6 @@ import           Data.Generics                                       (Data,
                                                                       everything,
                                                                       mkQ)
 import           Data.List                                           (sortOn)
-import qualified GHC.Driver.Ppr                                      as GHC (showPpr)
 import           GHC.Driver.Session                                  (defaultDynFlags)
 import qualified GHC.Driver.Session                                  as GHC
 import qualified GHC.Hs                                              as GHC
@@ -77,7 +76,7 @@ getConDecls d@GHC.HsDataDefn {} = case GHC.dd_cons d of
   GHC.DataTypeCons _ cons -> cons
 
 showOutputable :: GHC.Outputable a => a -> String
-showOutputable = GHC.showPpr baseDynFlags
+showOutputable = GHC.showSDocOneLine GHC.defaultSDocContext . GHC.ppr
 
 epAnnComments :: GHC.EpAnn a -> [GHC.LEpaComment]
 epAnnComments GHC.EpAnn {..}   = priorAndFollowing comments

lib/Language/Haskell/Stylish/Printer.hs

@@ -98,11 +98,18 @@ runPrinter cfg (Printer printer) =
 runPrinter_ :: PrinterConfig -> Printer a -> Lines
 runPrinter_ cfg printer = snd (runPrinter cfg printer)
 
--- | Print text
+-- | Print text, handling embedded newlines by splitting across lines
 putText :: String -> P ()
-putText txt = do
-  l <- gets currentLine
-  modify \s -> s { currentLine = l <> txt }
+putText txt = go (break (== '\n') txt)
+  where
+    go (pre, rest) = do
+      l <- gets currentLine
+      modify \s -> s { currentLine = l <> pre }
+      case rest of
+        ('\n' : post) -> do
+          newline
+          go (break (== '\n') post)
+        _ -> pure ()
 
 -- | Check condition post action, and use fallback if false
 putCond :: (PrinterState -> Bool) -> P b -> P b -> P b

tests/Language/Haskell/Stylish/Regressions.hs

@@ -1,19 +1,30 @@
+{-# LANGUAGE LambdaCase        #-}
 {-# LANGUAGE OverloadedLists   #-}
 {-# LANGUAGE OverloadedStrings #-}
 module Language.Haskell.Stylish.Regressions
   ( tests
   ) where
 
+import qualified System.IO                           as IO (Newline (..))
+
+import           Language.Haskell.Stylish            (formatWith)
+import           Language.Haskell.Stylish.Config     (Config (..),
+                                                      ExitCodeBehavior (..))
+import qualified Language.Haskell.Stylish.Step.Data  as Data
 import           Language.Haskell.Stylish.Step.Imports
+import qualified Language.Haskell.Stylish.Step.SimpleAlign as SimpleAlign
+import qualified Language.Haskell.Stylish.Step.TrailingWhitespace as TrailingWhitespace
 import           Language.Haskell.Stylish.Tests.Util (assertSnippet)
 import           Test.Framework                      (Test, testGroup)
 import           Test.Framework.Providers.HUnit      (testCase)
-import           Test.HUnit                          (Assertion)
+import           Test.HUnit                          (Assertion, (@?=))
 
 
 tests :: Test
 tests = testGroup "Language.Haskell.Stylish.Regressions"
     [ testCase "case 00 (issue #198)" case00
+    , testCase "case 01 (embedded newlines in Printer)" case01
+    , testCase "case 02 (deriving via with gap strings)" case02
     ]
 
 -- | Error parsing '(,) #198
@@ -32,3 +43,148 @@ case00 = assertSnippet (step (Just 80) $ importStepConfig Global) input input
 
 importStepConfig :: ImportAlign -> Options
 importStepConfig align = defaultOptions { importAlign = align }
+
+
+--------------------------------------------------------------------------------
+regressionConf :: Config
+regressionConf = Config
+    { configSteps =
+        [ Data.step Data.Config
+            { Data.cEquals                  = Data.Indent 2
+            , Data.cFirstField              = Data.Indent 2
+            , Data.cFieldComment            = 2
+            , Data.cDeriving                = 2
+            , Data.cBreakEnums              = False
+            , Data.cBreakSingleConstructors = True
+            , Data.cVia                     = Data.Indent 2
+            , Data.cCurriedContext          = False
+            , Data.cSortDeriving            = True
+            , Data.cMaxColumns              = Data.MaxColumns 80
+            }
+        , SimpleAlign.step (Just 80) SimpleAlign.Config
+            { SimpleAlign.cCases            = SimpleAlign.Always
+            , SimpleAlign.cTopLevelPatterns = SimpleAlign.Always
+            , SimpleAlign.cRecords          = SimpleAlign.Always
+            , SimpleAlign.cMultiWayIf       = SimpleAlign.Always
+            }
+        , TrailingWhitespace.step
+        ]
+    , configColumns            = Just 80
+    , configLanguageExtensions =
+        ["BangPatterns", "DerivingVia", "DataKinds", "TypeOperators", "OverloadedStrings"]
+    , configNewline            = IO.LF
+    , configCabal              = False
+    , configExitCode           = NormalExitBehavior
+    }
+
+
+-- | When the Data step produces lines with embedded newlines (from
+-- showOutputable wrapping long types), subsequent steps like simple_align
+-- would miscount lines and corrupt identifiers.
+case01 :: Assertion
+case01 = actual @?= Right expected
+  where
+    actual = formatWith regressionConf Nothing (unlines input)
+    input =
+        [ "module Foo where"
+        , ""
+        , "data FooRec"
+        , "  = FooRec"
+        , "      { fooBarMap       :: !(M.Map Name Xid)"
+        , "      , bazQuxLookupMap :: !(M.Map (Name, SomeLongKeyType, AnotherVeryLongKeyName) SomeVeryLongResultType)"
+        , "      , fooItems        :: ![Xs]"
+        , "      , fooBatches      :: ![Ys]"
+        , "      }"
+        , ""
+        , "data BarResult"
+        , "  = BarNothing"
+        , "      { brNeErrors :: NonEmpty AppError"
+        , "      }"
+        , "  | BarJust"
+        , "      { brResult   :: ([Dp], [(Gcn, [Cn])])"
+        , "      , brErrors   :: [AppError]"
+        , "      , brWarnings :: [AppWarning]"
+        , "      , brXs :: [Xs]"
+        , "      , brYs  :: [Ys]"
+        , "      }"
+        ]
+    expected =
+        [ "module Foo where"
+        , ""
+        , "data FooRec"
+        , "  = FooRec"
+        , "      { fooBarMap :: !(M.Map Name Xid)"
+        , "      , bazQuxLookupMap :: !(M.Map (Name, SomeLongKeyType, AnotherVeryLongKeyName) SomeVeryLongResultType)"
+        , "      , fooItems :: ![Xs]"
+        , "      , fooBatches :: ![Ys]"
+        , "      }"
+        , ""
+        , "data BarResult"
+        , "  = BarNothing"
+        , "      { brNeErrors :: NonEmpty AppError"
+        , "      }"
+        , "  | BarJust"
+        , "      { brResult   :: ([Dp], [(Gcn, [Cn])])"
+        , "      , brErrors   :: [AppError]"
+        , "      , brWarnings :: [AppWarning]"
+        , "      , brXs       :: [Xs]"
+        , "      , brYs       :: [Ys]"
+        , "      }"
+        ]
+
+
+-- | When the Data step processes a deriving via clause containing a gap string
+-- (multi-line string literal using \<newline><spaces>\ syntax), the embedded
+-- newlines should be properly split across Lines entries so subsequent steps
+-- don't miscount lines and corrupt identifiers.
+case02 :: Assertion
+case02 = actual @?= Right expected
+  where
+    actual = formatWith regressionConf Nothing (unlines input)
+    input =
+        [ "module Foo where"
+        , ""
+        , "data MyRecord"
+        , "  = MyRecord"
+        , "      { mrName  :: !Name"
+        , "      , mrItems :: !(NonEmpty MyItem)"
+        , "      }"
+        , "  deriving (Eq, Show, Ord, Generic)"
+        , "  deriving (ToJSON, FromJSON, ToSchema) via CustomEncoding (Wrapper MyRecord"
+        , "    '[ \"mrName\" `With` WithLabel \"label\""
+        , "     , \"mrItems\" `With` WithLabel"
+        , "         \"Some long text.\\"
+        , "         \\ Split across multiple \\"
+        , "         \\ lines\""
+        , "     ])"
+        , ""
+        , "data MyItem"
+        , "  = MyItem"
+        , "      { miEntries      :: !(NonEmpty Rf)"
+        , "      , miEnabled      :: !Bool"
+        , "      , miLookupResult :: !(Maybe (Abc Def))"
+        , "      }"
+        , "  deriving (Eq, Show, Ord, Generic)"
+        ]
+    expected =
+        [ "module Foo where"
+        , ""
+        , "data MyRecord"
+        , "  = MyRecord"
+        , "      { mrName  :: !Name"
+        , "      , mrItems :: !(NonEmpty MyItem)"
+        , "      }"
+        , "  deriving (Eq, Generic, Ord, Show)"
+        , "  deriving (FromJSON, ToJSON, ToSchema)"
+        , "    via CustomEncoding (Wrapper MyRecord '[\"mrName\" `With` WithLabel \"label\", \"mrItems\" `With` WithLabel \"Some long text.\\"
+        , "         \\ Split across multiple \\"
+        , "         \\ lines\"])"
+        , ""
+        , "data MyItem"
+        , "  = MyItem"
+        , "      { miEntries      :: !(NonEmpty Rf)"
+        , "      , miEnabled      :: !Bool"
+        , "      , miLookupResult :: !(Maybe (Abc Def))"
+        , "      }"
+        , "  deriving (Eq, Generic, Ord, Show)"
+        ]