diff --git a/lib/Language/Haskell/Stylish.hs b/lib/Language/Haskell/Stylish.hs index 0c403984..7ba7a274 100644 --- a/lib/Language/Haskell/Stylish.hs +++ b/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 -------------------------------------------------------------------------------- diff --git a/lib/Language/Haskell/Stylish/GHC.hs b/lib/Language/Haskell/Stylish/GHC.hs index 1413fd3e..0714e124 100644 --- a/lib/Language/Haskell/Stylish/GHC.hs +++ b/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 diff --git a/lib/Language/Haskell/Stylish/Printer.hs b/lib/Language/Haskell/Stylish/Printer.hs index db05c407..49d59df6 100644 --- a/lib/Language/Haskell/Stylish/Printer.hs +++ b/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 diff --git a/tests/Language/Haskell/Stylish/Regressions.hs b/tests/Language/Haskell/Stylish/Regressions.hs index ddf2837d..bb0c4e16 100644 --- a/tests/Language/Haskell/Stylish/Regressions.hs +++ 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 \\ 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)" + ]