From 3946b64f7d684154a828344b862ba7552146f469 Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Mon, 13 Jul 2020 18:36:56 +0200 Subject: [PATCH 001/135] Add initial parsing logic for using ghc-lib-parser instead of haskell-src-exts --- lib/Language/Haskell/Stylish.hs | 7 +- lib/Language/Haskell/Stylish/Config.hs | 21 ++ lib/Language/Haskell/Stylish/Module.hs | 89 +++++++++ lib/Language/Haskell/Stylish/Parse.hs | 184 ++++++++++++------ lib/Language/Haskell/Stylish/Printer.hs | 111 +++++++++++ lib/Language/Haskell/Stylish/Printer/Decl.hs | 14 ++ .../Haskell/Stylish/Printer/Imports.hs | 170 ++++++++++++++++ .../Haskell/Stylish/Printer/Module.hs | 19 ++ .../Haskell/Stylish/Printer/ModuleHeader.hs | 87 +++++++++ lib/Language/Haskell/Stylish/Step/Imports.hs | 1 - src/Main.hs | 2 +- stack.yaml | 1 + stack.yaml.lock | 7 + stylish-haskell.cabal | 17 ++ tests/Language/Haskell/Stylish/Parse/Tests.hs | 48 ++--- .../Haskell/Stylish/Printer/Imports/Tests.hs | 139 +++++++++++++ .../Stylish/Printer/ModuleHeader/Tests.hs | 89 +++++++++ tests/Language/Haskell/Stylish/Tests/Util.hs | 11 +- tests/TestSuite.hs | 4 + 19 files changed, 929 insertions(+), 92 deletions(-) create mode 100644 lib/Language/Haskell/Stylish/Module.hs create mode 100644 lib/Language/Haskell/Stylish/Printer.hs create mode 100644 lib/Language/Haskell/Stylish/Printer/Decl.hs create mode 100644 lib/Language/Haskell/Stylish/Printer/Imports.hs create mode 100644 lib/Language/Haskell/Stylish/Printer/Module.hs create mode 100644 lib/Language/Haskell/Stylish/Printer/ModuleHeader.hs create mode 100644 tests/Language/Haskell/Stylish/Printer/Imports/Tests.hs create mode 100644 tests/Language/Haskell/Stylish/Printer/ModuleHeader/Tests.hs diff --git a/lib/Language/Haskell/Stylish.hs b/lib/Language/Haskell/Stylish.hs index c50db4d0..a2510822 100644 --- a/lib/Language/Haskell/Stylish.hs +++ b/lib/Language/Haskell/Stylish.hs @@ -27,6 +27,7 @@ module Language.Haskell.Stylish -------------------------------------------------------------------------------- import Control.Monad (foldM) +import Data.Function ((&)) import System.Directory (doesDirectoryExist, doesFileExist, listDirectory) @@ -36,6 +37,7 @@ import System.FilePath (takeExtension -------------------------------------------------------------------------------- import Language.Haskell.Stylish.Config import Language.Haskell.Stylish.Parse +import Language.Haskell.Stylish.Printer.Module import Language.Haskell.Stylish.Step import qualified Language.Haskell.Stylish.Step.Imports as Imports import qualified Language.Haskell.Stylish.Step.LanguagePragmas as LanguagePragmas @@ -91,8 +93,9 @@ unicodeSyntax = UnicodeSyntax.step -------------------------------------------------------------------------------- runStep :: Extensions -> Maybe FilePath -> Lines -> Step -> Either String Lines -runStep exts mfp ls step = - stepFilter step ls <$> parseModule exts mfp (unlines ls) +runStep exts mfp ls _step + = parseModule exts mfp (unlines ls) + & fmap (printModule defaultConfig') -------------------------------------------------------------------------------- diff --git a/lib/Language/Haskell/Stylish/Config.hs b/lib/Language/Haskell/Stylish/Config.hs index 475a5e36..28021535 100644 --- a/lib/Language/Haskell/Stylish/Config.hs +++ b/lib/Language/Haskell/Stylish/Config.hs @@ -4,6 +4,10 @@ module Language.Haskell.Stylish.Config ( Extensions , Config (..) + , Config' (..) + , defaultConfig' + , DeclPrinter (..) + , ImportsPrinter (..) , defaultConfigBytes , configFilePath , loadConfig @@ -62,6 +66,23 @@ data Config = Config , configCabal :: Bool } +-------------------------------------------------------------------------------- +data Config' = Config' + { configDeclPrinter :: DeclPrinter + , configImportsPrinter :: ImportsPrinter + } + +data DeclPrinter + = DeclMinimizeDiffs + +data ImportsPrinter + = DeclMinimizeDiffsPostQualified + +defaultConfig' :: Config' +defaultConfig' = Config' + { configDeclPrinter = DeclMinimizeDiffs + , configImportsPrinter = DeclMinimizeDiffsPostQualified + } -------------------------------------------------------------------------------- instance FromJSON Config where diff --git a/lib/Language/Haskell/Stylish/Module.hs b/lib/Language/Haskell/Stylish/Module.hs new file mode 100644 index 00000000..c24066fc --- /dev/null +++ b/lib/Language/Haskell/Stylish/Module.hs @@ -0,0 +1,89 @@ +module Language.Haskell.Stylish.Module + ( Module + , ModuleHeader + , Imports + , Decls + , Comments + , Lines + , moduleHeader + , moduleImports + , makeModule + , moduleDecls + , moduleComments + + -- * Internal API getters + , rawComments + , rawImports + , rawModuleName + , rawModuleExports + , rawModuleHaddocks + ) where + +-------------------------------------------------------------------------------- +import qualified GHC.Hs as GHC +import GHC.Hs.Extension (GhcPs) +import GHC.Hs.Decls (LHsDecl) +import GHC.Hs.ImpExp (LImportDecl) +import qualified SrcLoc as GHC +import qualified Module as GHC + +-------------------------------------------------------------------------------- +type Lines = [String] + + +-------------------------------------------------------------------------------- +-- | Concrete module type +newtype Module = Module { unModule :: GHC.Located (GHC.HsModule GhcPs) } + +newtype Decls = Decls [LHsDecl GhcPs] + +data Imports = Imports [LImportDecl GhcPs] + +data Comments = Comments [GHC.Located String] + +data ModuleHeader = ModuleHeader + { name :: Maybe (GHC.Located GHC.ModuleName) + , exports :: Maybe (GHC.Located [GHC.LIE GhcPs]) + , haddocks :: Maybe GHC.LHsDocString + } + +makeModule :: GHC.Located (GHC.HsModule GHC.GhcPs) -> Module +makeModule = Module + +moduleDecls :: Module -> Decls +moduleDecls = Decls . GHC.hsmodDecls . unLocated . unModule + +moduleComments :: Module -> Comments +moduleComments = undefined + +moduleImports :: Module -> Imports +moduleImports = Imports . GHC.hsmodImports . unLocated . unModule + +moduleHeader :: Module -> ModuleHeader +moduleHeader (Module (GHC.L _ m)) = ModuleHeader + { name = GHC.hsmodName m + , exports = GHC.hsmodExports m + , haddocks = GHC.hsmodHaddockModHeader m + } + +unLocated :: GHC.Located a -> a +unLocated (GHC.L _ a) = a + +-------------------------------------------------------------------------------- +-- | Getter for internal components in imports newtype +-- +-- /Note:/ this function might be +rawImports :: Imports -> [LImportDecl GhcPs] +rawImports (Imports xs) = xs + +rawModuleName :: ModuleHeader -> Maybe (GHC.Located GHC.ModuleName) +rawModuleName = name + +rawModuleExports :: ModuleHeader -> Maybe (GHC.Located [GHC.LIE GhcPs]) +rawModuleExports = exports + +rawModuleHaddocks :: ModuleHeader -> Maybe GHC.LHsDocString +rawModuleHaddocks = haddocks + +rawComments :: Comments -> [GHC.Located String] +rawComments (Comments xs) = xs diff --git a/lib/Language/Haskell/Stylish/Parse.hs b/lib/Language/Haskell/Stylish/Parse.hs index 01def632..f998b0f4 100644 --- a/lib/Language/Haskell/Stylish/Parse.hs +++ b/lib/Language/Haskell/Stylish/Parse.hs @@ -1,34 +1,44 @@ +{-# LANGUAGE LambdaCase #-} +{-# OPTIONS_GHC -Wno-missing-fields #-} -------------------------------------------------------------------------------- module Language.Haskell.Stylish.Parse - ( parseModule - ) where + ( parseModule + , baseDynFlags -- FIXME should be moved + ) where -------------------------------------------------------------------------------- -import Data.List (isPrefixOf, nub) +import Bag (bagToList) +import Data.Function ((&)) import Data.Maybe (fromMaybe, listToMaybe) -import qualified Language.Haskell.Exts as H - +import DynFlags (Settings(..), defaultDynFlags) +import qualified DynFlags as GHC +import FastString (mkFastString) +import FileSettings (FileSettings(..)) +import GHC.Fingerprint (fingerprint0) +import qualified GHC.Hs as GHC +import qualified GHC.LanguageExtensions as GHC +import GHC.Platform +import GHC.Version (cProjectVersion) +import GhcNameVersion (GhcNameVersion(..)) +import qualified HeaderInfo as GHC +import qualified HscTypes as GHC +import Lexer (ParseResult(..)) +import Lexer (mkPState, unP) +import qualified Lexer as GHC +import qualified Panic as GHC +import qualified Parser as GHC +import PlatformConstants (PlatformConstants(..)) +import SrcLoc (mkRealSrcLoc) +import qualified SrcLoc as GHC +import StringBuffer (stringToStringBuffer) +import qualified StringBuffer as GHC +import System.IO.Unsafe (unsafePerformIO) +import ToolSettings (ToolSettings(..)) -------------------------------------------------------------------------------- import Language.Haskell.Stylish.Config -import Language.Haskell.Stylish.Step - - --------------------------------------------------------------------------------- --- | Syntax-related language extensions are always enabled for parsing. Since we --- can't authoritatively know which extensions are enabled at compile-time, we --- should try not to throw errors when parsing any GHC-accepted code. -defaultExtensions :: [H.Extension] -defaultExtensions = map H.EnableExtension - [ H.GADTs - , H.HereDocuments - , H.KindSignatures - , H.NewQualifiedOperators - , H.PatternGuards - , H.StandaloneDeriving - , H.UnicodeSyntax - ] +import Language.Haskell.Stylish.Module -------------------------------------------------------------------------------- @@ -42,15 +52,6 @@ unCpp = unlines . go False . lines nextMultiline = isCpp && not (null x) && last x == '\\' in (if isCpp then "" else x) : go nextMultiline xs - --------------------------------------------------------------------------------- --- | Remove shebang lines -unShebang :: String -> String -unShebang str = - let (shebangs, other) = break (not . ("#!" `isPrefixOf`)) (lines str) in - unlines $ map (const "") shebangs ++ other - - -------------------------------------------------------------------------------- -- | If the given string is prefixed with an UTF-8 Byte Order Mark, drop it -- because haskell-src-exts can't handle it. @@ -60,32 +61,97 @@ dropBom str = str -------------------------------------------------------------------------------- --- | Abstraction over HSE's parsing +-- | Abstraction over GHC lib's parsing parseModule :: Extensions -> Maybe FilePath -> String -> Either String Module -parseModule extraExts mfp string = do - -- Determine the extensions: those specified in the file and the extra ones - let noPrefixes = unShebang . dropBom $ string - extraExts' = map H.classifyExtension extraExts - (lang, fileExts) = fromMaybe (Nothing, []) $ H.readExtensions noPrefixes - exts = nub $ fileExts ++ extraExts' ++ defaultExtensions - - -- Parsing options... - fp = fromMaybe "" mfp - mode = H.defaultParseMode - { H.extensions = exts - , H.fixities = Nothing - , H.baseLanguage = case lang of - Nothing -> H.baseLanguage H.defaultParseMode - Just l -> l - } - - -- Preprocessing - processed = if H.EnableExtension H.CPP `elem` exts - then unCpp noPrefixes - else noPrefixes - - case H.parseModuleWithComments mode processed of - H.ParseOk md -> return md - err -> Left $ - "Language.Haskell.Stylish.Parse.parseModule: could not parse " ++ - fp ++ ": " ++ show err +parseModule exts fp string = + parsePragmasIntoDynFlags baseDynFlags userExtensions filePath string >>= \dynFlags -> + dropBom string + & removeCpp dynFlags + & runParser dynFlags + & toModule dynFlags + where + toModule :: GHC.DynFlags -> GHC.ParseResult (GHC.Located (GHC.HsModule GHC.GhcPs)) -> Either String Module + toModule dynFlags res = case res of + POk _ m -> + Right (makeModule m) + PFailed failureState -> + Left . unlines . getParserStateErrors dynFlags $ failureState + + removeCpp dynFlags s = + if GHC.xopt GHC.Cpp dynFlags then unCpp s + else s + + userExtensions = + fmap toLocatedExtensionFlag exts + + toLocatedExtensionFlag flag + = "-X" <> flag + & GHC.L GHC.noSrcSpan + + getParserStateErrors dynFlags state + = GHC.getErrorMessages state dynFlags + & bagToList + & fmap show + + filePath = + fromMaybe "" fp + + runParser :: GHC.DynFlags -> String -> GHC.ParseResult (GHC.Located (GHC.HsModule GHC.GhcPs)) + runParser flags str = + let + filename = mkFastString filePath + parseState = mkPState flags (stringToStringBuffer str) (mkRealSrcLoc filename 1 1) + in + unP GHC.parseModule parseState + +baseDynFlags :: GHC.DynFlags +baseDynFlags = defaultDynFlags fakeSettings llvmConfig + where + fakeSettings = GHC.Settings + { sGhcNameVersion = GhcNameVersion "stylish-haskell" cProjectVersion + , sFileSettings = FileSettings {} + , sToolSettings = ToolSettings + { toolSettings_opt_P_fingerprint = fingerprint0, + toolSettings_pgm_F = "" + } + , sPlatformConstants = PlatformConstants + { pc_DYNAMIC_BY_DEFAULT = False + , pc_WORD_SIZE = 8 + } + , sTargetPlatform = Platform + { platformMini = PlatformMini + { platformMini_arch = ArchUnknown + , platformMini_os = OSUnknown + } + , platformWordSize = PW8 + , platformUnregisterised = True + , platformHasIdentDirective = False + , platformHasSubsectionsViaSymbols = False + , platformIsCrossCompiling = False + } + , sPlatformMisc = PlatformMisc {} + , sRawSettings = [] + } + + llvmConfig = GHC.LlvmConfig [] [] + +-- | Parse 'DynFlags' from the extra options +-- +-- /Note:/ this function would be IO, but we're not using any of the internal +-- features that constitute side effectful computation. So I think it's fine +-- if we run this to avoid changing the interface too much. +parsePragmasIntoDynFlags :: + GHC.DynFlags + -> [GHC.Located String] + -> FilePath + -> String + -> Either String GHC.DynFlags +{-# NOINLINE parsePragmasIntoDynFlags #-} +parsePragmasIntoDynFlags originalFlags extraOpts filepath str = unsafePerformIO $ catchErrors $ do + let opts = GHC.getOptions originalFlags (GHC.stringToStringBuffer str) filepath + (parsedFlags, _invalidFlags, _warnings) <- GHC.parseDynamicFilePragma originalFlags (opts <> extraOpts) + -- FIXME: have a look at 'leftovers' since it should be empty + return $ Right $ parsedFlags `GHC.gopt_set` GHC.Opt_KeepRawTokenStream + where + catchErrors act = GHC.handleGhcException reportErr (GHC.handleSourceError reportErr act) + reportErr e = return $ Left (show e) diff --git a/lib/Language/Haskell/Stylish/Printer.hs b/lib/Language/Haskell/Stylish/Printer.hs new file mode 100644 index 00000000..d0320262 --- /dev/null +++ b/lib/Language/Haskell/Stylish/Printer.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE BangPatterns #-} +module Language.Haskell.Stylish.Printer + ( Printer(..) + , PrinterState(..) + + -- * Alias + , P + + -- * Functions to use the printer + , runPrinter + + -- ** Combinators + , comma + , dot + , newline + , parenthesize + , prefix + , putText + , sep + , space + , suffix + , indent + , indented + -- ** Outputable helpers + , showOutputable + , compareOutputable + ) where + +-------------------------------------------------------------------------------- +import Language.Haskell.Stylish.Config (Config') +import Language.Haskell.Stylish.Parse (baseDynFlags) + +-------------------------------------------------------------------------------- +import Control.Monad (forM_, replicateM) +import Control.Monad.Reader (MonadReader, ReaderT(..)) +import Control.Monad.State (MonadState, State) +import Control.Monad.State (execState, gets, modify) +import GHC.Generics (Generic) +import qualified Outputable as GHC +import Prelude hiding (lines) + +-------------------------------------------------------------------------------- + +type P = Printer +type Lines = [String] + +newtype Printer a = Printer (ReaderT Config' (State PrinterState) a) + deriving (Applicative, Functor, Monad, MonadReader Config', MonadState PrinterState) + +data PrinterState = PrinterState + { lines :: Lines + , linePos :: !Int + , currentLine :: String + } + deriving stock (Generic) + +runPrinter :: Config' -> Printer a -> Lines +runPrinter cfg (Printer printer) = + let + PrinterState parsedLines _ startedLine = runReaderT printer cfg `execState` PrinterState [] 0 "" + in + parsedLines <> if startedLine == [] then [] else [startedLine] + +putText :: String -> P () +putText txt = do + l <- gets currentLine + modify (\s -> s { currentLine = l <> txt }) + +newline :: P () +newline = do + l <- gets currentLine + modify (\s -> s { currentLine = "", linePos = 0, lines = lines s <> [l] }) + +space :: P () +space = putText " " + +dot :: P () +dot = putText "." + +comma :: P () +comma = putText "," + +parenthesize :: P a -> P a +parenthesize action = putText "(" *> action <* putText ")" + +sep :: P a -> [P a] -> P () +sep _ [] = pure () +sep s (first : rest) = do + first >> forM_ rest ((>>) s) + +prefix :: P a -> P b -> P b +prefix pa pb = pa >> pb + +suffix :: P a -> P b -> P a +suffix pa pb = pb >> pa + +indented :: Int -> [P a] -> [P a] +indented i = fmap \x -> replicateM i space >> x + +indent :: Int -> P a -> P a +indent i = (>>) (replicateM i space) + +showOutputable :: GHC.Outputable a => a -> String +showOutputable = GHC.showPpr baseDynFlags + +compareOutputable :: GHC.Outputable a => a -> a -> Ordering +compareOutputable i0 i1 = compare (showOutputable i0) (showOutputable i1) diff --git a/lib/Language/Haskell/Stylish/Printer/Decl.hs b/lib/Language/Haskell/Stylish/Printer/Decl.hs new file mode 100644 index 00000000..9e490a01 --- /dev/null +++ b/lib/Language/Haskell/Stylish/Printer/Decl.hs @@ -0,0 +1,14 @@ +module Language.Haskell.Stylish.Printer.Decl + ( printDecls + ) where + +-------------------------------------------------------------------------------- +import Language.Haskell.Stylish.Module +import Language.Haskell.Stylish.Config (Config'(..)) +--import GHC.Hs.Decls +--import SrcLoc (Located, GenLocated(..)) +--import GHC.Hs (GhcPs) + +-------------------------------------------------------------------------------- +printDecls :: Config' -> Comments -> Decls -> Lines +printDecls _ _ _ = ["printDecl: not implemented"] diff --git a/lib/Language/Haskell/Stylish/Printer/Imports.hs b/lib/Language/Haskell/Stylish/Printer/Imports.hs new file mode 100644 index 00000000..ec2726f8 --- /dev/null +++ b/lib/Language/Haskell/Stylish/Printer/Imports.hs @@ -0,0 +1,170 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE LambdaCase #-} +module Language.Haskell.Stylish.Printer.Imports + ( printImports + ) where + +-------------------------------------------------------------------------------- +import Control.Monad (forM_, when) +import Data.Function ((&)) +import Data.List (sortBy) +import GHC.Hs.Extension (GhcPs) +import qualified GHC.Hs.Extension as GHC +import GHC.Hs.ImpExp +import Module (ModuleName, moduleNameString) +import RdrName +import qualified SrcLoc as GHC + +-------------------------------------------------------------------------------- +import Language.Haskell.Stylish.Config (Config'(..), ImportsPrinter(..)) +import Language.Haskell.Stylish.Module (Comments, Lines, Imports, rawImports) +import Language.Haskell.Stylish.Printer + +-------------------------------------------------------------------------------- +printImports :: Config' -> Comments -> Imports -> Lines +printImports cfg@(Config' {configImportsPrinter = printer}) _comments imports = + runPrinter cfg importPrinter + where + importList = rawImports imports + + sortImports = + sortBy \a0 a1 -> + compareOutputable a0 a1 <> + if isQualified a0 then GT else LT + + importPrinter = case printer of + DeclMinimizeDiffsPostQualified -> + forM_ (sortImports importList) \imp -> printPostQualified imp >> newline + +-------------------------------------------------------------------------------- +printPostQualified :: LImportDecl GhcPs -> P () +printPostQualified decl = do + let + decl' = unLocated decl + + putText "import" >> space + + when (ideclSource decl') (putText "{-# SOURCE #-}" >> space) + + when (ideclSafe decl') (putText "safe" >> space) + + putText (moduleName decl) + + when (isQualified decl) (space >> putText "qualified") + + forM_ (ideclAs decl') \(GHC.L _ name) -> + space >> putText "as" >> space >> putText (moduleNameString name) + + when (isHiding decl') (space >> putText "hiding" >> space) + + forM_ (snd <$> ideclHiding decl') \(GHC.L _ imports) -> + let + printedImports = + fmap (printImport . unLocated) (sortedImportList imports) + + separated = + sep (comma >> space) + in + space >> parenthesize (separated printedImports) + +-------------------------------------------------------------------------------- +printImport :: IE GhcPs -> P () +printImport = \case + IEVar _ name -> + printIeWrappedName name + IEThingAbs _ name -> + printIeWrappedName name + IEThingAll _ name -> do + printIeWrappedName name + space + putText "(..)" + IEModuleContents _ (GHC.L _ m) -> + putText (moduleNameString m) + IEThingWith _ name _wildcard imps _ -> + let + sortedImps = flip sortBy imps \(GHC.L _ a0) (GHC.L _ a1) -> compareOutputable a0 a1 + in do + printIeWrappedName name + space + parenthesize $ sep (comma >> space) (fmap printIeWrappedName sortedImps) + IEGroup _ _ _ -> + error "Language.Haskell.Stylish.Printer.Imports.printImportExport: unhandled case 'IEGroup'" + IEDoc _ _ -> + error "Language.Haskell.Stylish.Printer.Imports.printImportExport: unhandled case 'IEDoc'" + IEDocNamed _ _ -> + error "Language.Haskell.Stylish.Printer.Imports.printImportExport: unhandled case 'IEDocNamed'" + XIE ext -> + GHC.noExtCon ext + +-------------------------------------------------------------------------------- +printIeWrappedName :: LIEWrappedName RdrName -> P () +printIeWrappedName lie = unLocated lie & \case + IEName n -> printRdrName n + IEPattern n -> putText "pattern" >> space >> printRdrName n + IEType n -> putText "type" >> space >> printRdrName n + +printRdrName :: GHC.Located RdrName -> P () +printRdrName (GHC.L _ n) = case n of + Unqual name -> + putText (showOutputable name) + Qual modulePrefix name -> + printModulePrefix modulePrefix >> dot >> putText (showOutputable name) + Orig _ name -> + putText (showOutputable name) + Exact name -> + putText (showOutputable name) + +printModulePrefix :: ModuleName -> P () +printModulePrefix = putText . moduleNameString + +moduleName :: LImportDecl GhcPs -> String +moduleName + = moduleNameString + . unLocated + . ideclName + . unLocated + +isQualified :: LImportDecl GhcPs -> Bool +isQualified + = (/=) NotQualified + . ideclQualified + . unLocated + +isHiding :: ImportDecl GhcPs -> Bool +isHiding + = maybe False fst + . ideclHiding + +unLocated :: GHC.Located a -> a +unLocated (GHC.L _ a) = a + +sortedImportList :: [LIE GhcPs] -> [LIE GhcPs] +sortedImportList = + let + unLocated' f (GHC.L _ i0) (GHC.L _ i1) = f (i0, i1) + in + sortBy $ unLocated' \case + (IEVar _ n0, IEVar _ n1) -> compareOutputable n0 n1 + + (IEThingAbs _ n0, IEThingAbs _ n1) -> compareOutputable n0 n1 + (IEThingAbs _ n0, IEThingAll _ n1) -> compareOutputable n0 n1 + (IEThingAbs _ n0, IEThingWith _ n1 _ _ _) -> compareOutputable n0 n1 + + (IEThingAll _ n0, IEThingAll _ n1) -> compareOutputable n0 n1 + (IEThingAll _ n0, IEThingAbs _ n1) -> compareOutputable n0 n1 + (IEThingAll _ n0, IEThingWith _ n1 _ _ _) -> compareOutputable n0 n1 + + (IEThingWith _ n0 _ _ _, IEThingWith _ n1 _ _ _) -> compareOutputable n0 n1 + (IEThingWith _ n0 _ _ _, IEThingAll _ n1) -> compareOutputable n0 n1 + (IEThingWith _ n0 _ _ _, IEThingAbs _ n1) -> compareOutputable n0 n1 + + (IEVar _ _, _) -> GT + (_, IEVar _ _) -> LT + (IEThingAbs _ _, _) -> GT + (_, IEThingAbs _ _) -> LT + (IEThingAll _ _, _) -> GT + (_, IEThingAll _ _) -> LT + (IEThingWith _ _ _ _ _, _) -> GT + (_, IEThingWith _ _ _ _ _) -> LT + + _ -> EQ diff --git a/lib/Language/Haskell/Stylish/Printer/Module.hs b/lib/Language/Haskell/Stylish/Printer/Module.hs new file mode 100644 index 00000000..a09a367a --- /dev/null +++ b/lib/Language/Haskell/Stylish/Printer/Module.hs @@ -0,0 +1,19 @@ +module Language.Haskell.Stylish.Printer.Module + ( printModule + ) where + +import Language.Haskell.Stylish.Module +import Language.Haskell.Stylish.Config (Config'(..)) +import Language.Haskell.Stylish.Printer.Decl (printDecls) +import Language.Haskell.Stylish.Printer.ModuleHeader (printModuleHeader) +import Language.Haskell.Stylish.Printer.Imports (printImports) + +printModule :: Config' -> Module -> Lines +printModule c m = + let + comments = moduleComments m + in + printModuleHeader c comments (moduleHeader m) <> + printImports c comments (moduleImports m) <> + printDecls c comments (moduleDecls m) <> + [] diff --git a/lib/Language/Haskell/Stylish/Printer/ModuleHeader.hs b/lib/Language/Haskell/Stylish/Printer/ModuleHeader.hs new file mode 100644 index 00000000..11e92d15 --- /dev/null +++ b/lib/Language/Haskell/Stylish/Printer/ModuleHeader.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE BlockArguments #-} +module Language.Haskell.Stylish.Printer.ModuleHeader + ( printModuleHeader + ) where + + +-------------------------------------------------------------------------------- +import Control.Monad (forM_, when) +import Data.Maybe (isJust) +import qualified GHC.Hs.Doc as GHC +import GHC.Hs.Extension (GhcPs) +import qualified GHC.Hs.Extension as GHC +import GHC.Hs.ImpExp (IE(..)) +import qualified GHC.Hs.ImpExp as GHC +import qualified Module as GHC +import SrcLoc (Located, GenLocated(..)) +import Util (notNull) + +-------------------------------------------------------------------------------- +import Language.Haskell.Stylish.Module +import Language.Haskell.Stylish.Config (Config'(..)) +import Language.Haskell.Stylish.Printer + +printModuleHeader :: Config' -> Comments -> ModuleHeader -> Lines +printModuleHeader cfg _ header = + let + name = rawModuleName header + haddocks = rawModuleHaddocks header + exports = rawModuleExports header + in + runPrinter cfg (printHeader name exports haddocks) + +printHeader :: + Maybe (Located GHC.ModuleName) + -> Maybe (Located [GHC.LIE GhcPs]) + -> Maybe GHC.LHsDocString + -> P () +printHeader mname mexps _ = do + forM_ mname \(L _ name) -> do + putText "module" + space + putText (showOutputable name) + + maybe + (when (isJust mname) do newline >> space >> space >> putText "where") + printExportList + mexps + +printExportList :: Located [GHC.LIE GhcPs] -> P () +printExportList (L _ exports) = do + newline + indent 2 (putText "(") >> when (notNull exports) space + + sep (newline >> space >> space >> comma >> space) (fmap printExports exports) + + newline >> indent 2 (putText ")" >> space >> putText "where") + where + putOutputable = putText . showOutputable + + printExports :: GHC.LIE GhcPs -> P () + printExports (L _ export) = case export of + IEVar _ name -> putOutputable name + IEThingAbs _ name -> putOutputable name + IEThingAll _ name -> do + undefined + --printIeWrappedName name + --space + --putText "(..)" + IEModuleContents _ (L _ m) -> + undefined + --putText (moduleNameString m) + IEThingWith _ name _wildcard imps _ -> + undefined + --let + -- sortedImps = flip sortBy imps \(GHC.L _ a0) (GHC.L _ a1) -> compareOutputable a0 a1 + --in do + -- printIeWrappedName name + -- space + -- parenthesize $ sep (comma >> space) (fmap printIeWrappedName sortedImps) + IEGroup _ _ _ -> + error "Language.Haskell.Stylish.Printer.Imports.printImportExport: unhandled case 'IEGroup'" + IEDoc _ _ -> + error "Language.Haskell.Stylish.Printer.Imports.printImportExport: unhandled case 'IEDoc'" + IEDocNamed _ _ -> + error "Language.Haskell.Stylish.Printer.Imports.printImportExport: unhandled case 'IEDocNamed'" + XIE ext -> + GHC.noExtCon ext diff --git a/lib/Language/Haskell/Stylish/Step/Imports.hs b/lib/Language/Haskell/Stylish/Step/Imports.hs index 7cb78d4c..05268ba7 100644 --- a/lib/Language/Haskell/Stylish/Step/Imports.hs +++ b/lib/Language/Haskell/Stylish/Step/Imports.hs @@ -24,7 +24,6 @@ import qualified Data.Map as M import Data.Maybe (isJust, maybeToList) import Data.Ord (comparing) import qualified Data.Set as S -import Data.Semigroup (Semigroup ((<>))) import qualified Language.Haskell.Exts as H diff --git a/src/Main.hs b/src/Main.hs index b1ca2d5c..a39c735f 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -7,7 +7,7 @@ module Main -------------------------------------------------------------------------------- import Control.Monad (forM_, unless) import qualified Data.ByteString.Char8 as BC8 -import Data.Monoid ((<>)) +--import Data.Monoid ((<>)) import Data.Version (showVersion) import qualified Options.Applicative as OA import System.Exit (exitFailure) diff --git a/stack.yaml b/stack.yaml index 723d5d8f..7294b68d 100644 --- a/stack.yaml +++ b/stack.yaml @@ -4,3 +4,4 @@ packages: extra-deps: - 'haskell-src-exts-1.23.0' +- 'ghc-lib-parser-8.10.1.20200324' diff --git a/stack.yaml.lock b/stack.yaml.lock index 450a155f..e03470ec 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -11,6 +11,13 @@ packages: sha256: 8e5bc885533431db9bf75e9609f6b80b56ab0c289a903d701f8628e78322afd0 original: hackage: haskell-src-exts-1.23.0 +- completed: + hackage: ghc-lib-parser-8.10.1.20200324@sha256:581cfcd1ccc74ca5e6078ca99ee0ba0fba6cd3c20c55faab84f02a8de541629b,8751 + pantry-tree: + size: 19497 + sha256: dbd89e03bc6b7279916a6a172d7190e79f0d1688333836d6bb0e878a2a231765 + original: + hackage: ghc-lib-parser-8.10.1.20200324 snapshots: - completed: size: 491387 diff --git a/stylish-haskell.cabal b/stylish-haskell.cabal index 8e9dffda..2112f7b1 100644 --- a/stylish-haskell.cabal +++ b/stylish-haskell.cabal @@ -29,6 +29,12 @@ Library Exposed-modules: Language.Haskell.Stylish + Language.Haskell.Stylish.Module + Language.Haskell.Stylish.Printer + Language.Haskell.Stylish.Printer.Decl + Language.Haskell.Stylish.Printer.Module + Language.Haskell.Stylish.Printer.ModuleHeader + Language.Haskell.Stylish.Printer.Imports Language.Haskell.Stylish.Step.Data Language.Haskell.Stylish.Step.Imports Language.Haskell.Stylish.Step.LanguagePragmas @@ -61,6 +67,7 @@ Library filepath >= 1.1 && < 1.5, file-embed >= 0.0.10 && < 0.1, haskell-src-exts >= 1.18 && < 1.24, + ghc-lib-parser >= 8.10 && < 8.12, mtl >= 2.0 && < 2.3, semigroups >= 0.18 && < 0.20, syb >= 0.3 && < 0.8, @@ -87,6 +94,7 @@ Executable stylish-haskell filepath >= 1.1 && < 1.5, file-embed >= 0.0.10 && < 0.1, haskell-src-exts >= 1.18 && < 1.24, + ghc-lib-parser >= 8.10 && < 8.12, mtl >= 2.0 && < 2.3, syb >= 0.3 && < 0.8, HsYAML-aeson >=0.2.0 && < 0.3, @@ -107,8 +115,16 @@ Test-suite stylish-haskell-tests Language.Haskell.Stylish.Config.Internal Language.Haskell.Stylish.Config.Tests Language.Haskell.Stylish.Editor + Language.Haskell.Stylish.Module Language.Haskell.Stylish.Parse Language.Haskell.Stylish.Parse.Tests + Language.Haskell.Stylish.Printer + Language.Haskell.Stylish.Printer.Decl + Language.Haskell.Stylish.Printer.Module + Language.Haskell.Stylish.Printer.ModuleHeader + Language.Haskell.Stylish.Printer.Imports + Language.Haskell.Stylish.Printer.Imports.Tests + Language.Haskell.Stylish.Printer.ModuleHeader.Tests Language.Haskell.Stylish.Step Language.Haskell.Stylish.Step.Imports Language.Haskell.Stylish.Step.Imports.Tests @@ -147,6 +163,7 @@ Test-suite stylish-haskell-tests filepath >= 1.1 && < 1.5, file-embed >= 0.0.10 && < 0.1, haskell-src-exts >= 1.18 && < 1.24, + ghc-lib-parser >= 8.10 && < 8.12, mtl >= 2.0 && < 2.3, syb >= 0.3 && < 0.8, text >= 1.2 && < 1.3, diff --git a/tests/Language/Haskell/Stylish/Parse/Tests.hs b/tests/Language/Haskell/Stylish/Parse/Tests.hs index a8ebf39c..d46f4a52 100644 --- a/tests/Language/Haskell/Stylish/Parse/Tests.hs +++ b/tests/Language/Haskell/Stylish/Parse/Tests.hs @@ -6,7 +6,8 @@ module Language.Haskell.Stylish.Parse.Tests -------------------------------------------------------------------------------- import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit (Assertion, assert) +import Test.HUnit (Assertion, assertFailure) +import GHC.Stack (HasCallStack, withFrozenCallStack) -------------------------------------------------------------------------------- @@ -33,18 +34,18 @@ tests = testGroup "Language.Haskell.Stylish.Parse" -------------------------------------------------------------------------------- testShebangExt :: Assertion -testShebangExt = assert $ isRight $ parseModule [] Nothing input - where - input = unlines - [ "#!env runghc" - , "{-# LANGUAGE CPP #-}" - , "#define foo bar \\" - , " qux" - ] +testShebangExt = returnsRight $ parseModule [] Nothing input + where + input = unlines + [ "#!env runghc" + , "{-# LANGUAGE CPP #-}" + , "#define foo bar \\" + , " qux" + ] -------------------------------------------------------------------------------- testBom :: Assertion -testBom = assert $ isRight $ parseModule [] Nothing input +testBom = returnsRight $ parseModule [] Nothing input where input = unlines [ '\xfeff' : "foo :: Int" @@ -54,13 +55,13 @@ testBom = assert $ isRight $ parseModule [] Nothing input -------------------------------------------------------------------------------- testExtraExtensions :: Assertion -testExtraExtensions = assert $ isRight $ +testExtraExtensions = returnsRight $ parseModule ["TemplateHaskell"] Nothing "$(foo)" -------------------------------------------------------------------------------- testMultilineCpp :: Assertion -testMultilineCpp = assert $ isRight $ parseModule [] Nothing $ unlines +testMultilineCpp = returnsRight $ parseModule [] Nothing $ unlines [ "{-# LANGUAGE CPP #-}" , "#define foo bar \\" , " qux" @@ -69,7 +70,7 @@ testMultilineCpp = assert $ isRight $ parseModule [] Nothing $ unlines -------------------------------------------------------------------------------- testHaskell2010 :: Assertion -testHaskell2010 = assert $ isRight $ parseModule [] Nothing $ unlines +testHaskell2010 = returnsRight $ parseModule [] Nothing $ unlines [ "{-# LANGUAGE Haskell2010 #-}" , "module X where" , "foo x | Just y <- x = y" @@ -78,7 +79,7 @@ testHaskell2010 = assert $ isRight $ parseModule [] Nothing $ unlines -------------------------------------------------------------------------------- testShebang :: Assertion -testShebang = assert $ isRight $ parseModule [] Nothing $ unlines +testShebang = returnsRight $ parseModule [] Nothing $ unlines [ "#!runhaskell" , "module Main where" , "main = return ()" @@ -87,7 +88,7 @@ testShebang = assert $ isRight $ parseModule [] Nothing $ unlines -------------------------------------------------------------------------------- testShebangDouble :: Assertion -testShebangDouble = assert $ isRight $ parseModule [] Nothing $ unlines +testShebangDouble = returnsRight $ parseModule [] Nothing $ unlines [ "#!nix-shell" , "#!nix-shell -i runhaskell -p haskellPackages.ghc" , "module Main where" @@ -100,7 +101,7 @@ testShebangDouble = assert $ isRight $ parseModule [] Nothing $ unlines -- enabled for parsing, even when the pragma is absent. testGADTs :: Assertion -testGADTs = assert $ isRight $ parseModule [] Nothing $ unlines +testGADTs = returnsRight $ parseModule [] Nothing $ unlines [ "module Main where" , "data SafeList a b where" , " Nil :: SafeList a Empty" @@ -108,36 +109,35 @@ testGADTs = assert $ isRight $ parseModule [] Nothing $ unlines ] testKindSignatures :: Assertion -testKindSignatures = assert $ isRight $ parseModule [] Nothing $ unlines +testKindSignatures = returnsRight $ parseModule [] Nothing $ unlines [ "module Main where" , "data D :: * -> * -> * where" , " D :: a -> b -> D a b" ] testStandaloneDeriving :: Assertion -testStandaloneDeriving = assert $ isRight $ parseModule [] Nothing $ unlines +testStandaloneDeriving = returnsRight $ parseModule [] Nothing $ unlines [ "module Main where" , "deriving instance Show MyType" ] testUnicodeSyntax :: Assertion -testUnicodeSyntax = assert $ isRight $ parseModule [] Nothing $ unlines +testUnicodeSyntax = returnsRight $ parseModule [] Nothing $ unlines [ "module Main where" , "monadic ∷ (Monad m) ⇒ m a → m a" , "monadic = id" ] testXmlSyntaxRegression :: Assertion -testXmlSyntaxRegression = assert $ isRight $ parseModule [] Nothing $ unlines +testXmlSyntaxRegression = returnsRight $ parseModule [] Nothing $ unlines [ "smaller a b = a Bool -isRight (Right _) = True -isRight _ = False +returnsRight :: HasCallStack => Show a => Either a b -> Assertion +returnsRight action = withFrozenCallStack $ either (assertFailure . show) mempty action diff --git a/tests/Language/Haskell/Stylish/Printer/Imports/Tests.hs b/tests/Language/Haskell/Stylish/Printer/Imports/Tests.hs new file mode 100644 index 00000000..9d55ee86 --- /dev/null +++ b/tests/Language/Haskell/Stylish/Printer/Imports/Tests.hs @@ -0,0 +1,139 @@ +module Language.Haskell.Stylish.Printer.Imports.Tests + ( tests + ) where + +-------------------------------------------------------------------------------- +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit (Assertion, (@=?)) +import GHC.Stack (HasCallStack, withFrozenCallStack) +import Prelude hiding (lines) + + +-------------------------------------------------------------------------------- +import Language.Haskell.Stylish.Module +import Language.Haskell.Stylish.Config (defaultConfig') +import Language.Haskell.Stylish.Parse (parseModule) +import Language.Haskell.Stylish.Printer.Imports (printImports) + + + +-------------------------------------------------------------------------------- +tests :: Test +tests = testGroup "Language.Haskell.Stylish.Printer.Imports" + [ testCase "Hello world" ex0 + , testCase "Sorted simple" ex1 + , testCase "Sorted import lists" ex2 + , testCase "Sorted import lists and import decls" ex3 + , testCase "Import constructor all" ex4 + , testCase "Import constructor specific" ex5 + , testCase "Import constructor specific sorted" ex6 + ] + +-------------------------------------------------------------------------------- +ex0 :: Assertion +ex0 = input `assertFormatted` output + where + input = + [ "import B" + , "import A" + ] + output = + [ "import A" + , "import B" + ] + +ex1 :: Assertion +ex1 = input `assertFormatted` output + where + input = + [ "import B" + , "import A" + , "import C" + , "import A qualified" + , "import B qualified as X" + ] + output = + [ "import A" + , "import A qualified" + , "import B" + , "import B qualified as X" + , "import C" + ] + +ex2 :: Assertion +ex2 = input `assertFormatted` output + where + input = + [ "import B" + , "import A (X)" + , "import C" + , "import A qualified as Y (Y)" + ] + output = + [ "import A (X)" + , "import A qualified as Y (Y)" + , "import B" + , "import C" + ] + +ex3 :: Assertion +ex3 = input `assertFormatted` output + where + input = + [ "import B" + , "import A (X, Z, Y)" + , "import C" + , "import qualified A as A0 (b, Y, a)" + , "import D qualified as D0 (Y, b, a)" + , "import E qualified as E0 (b, a, Y)" + ] + output = + [ "import A (X, Y, Z)" + , "import A qualified as A0 (Y, a, b)" + , "import B" + , "import C" + , "import D qualified as D0 (Y, a, b)" + , "import E qualified as E0 (Y, a, b)" + ] + +ex4 :: Assertion +ex4 = input `assertFormatted` output + where + input = + [ "import A (X, Z(..), Y)" + ] + output = + [ "import A (X, Y, Z (..))" + ] + +ex5 :: Assertion +ex5 = input `assertFormatted` output + where + input = + [ "import A (X, Z(Z), Y)" + ] + output = + [ "import A (X, Y, Z (Z))" + ] + +ex6 :: Assertion +ex6 = input `assertFormatted` output + where + input = + [ "import A (X, Z(X, Z, Y), Y)" + ] + output = + [ "import A (X, Y, Z (X, Y, Z))" + ] + +-------------------------------------------------------------------------------- +assertFormatted :: HasCallStack => Lines -> Lines -> Assertion +assertFormatted input expected = withFrozenCallStack $ expected @=? parseAndFormat input + where + parseAndFormat lines = + case parseModule [] Nothing (unlines lines) of + Right parsedModule -> + printImports defaultConfig' (moduleComments parsedModule) (moduleImports parsedModule) + Left err -> + error $ "parseAndFormat: Should've been able to parse input - " <> err diff --git a/tests/Language/Haskell/Stylish/Printer/ModuleHeader/Tests.hs b/tests/Language/Haskell/Stylish/Printer/ModuleHeader/Tests.hs new file mode 100644 index 00000000..e8c6b48a --- /dev/null +++ b/tests/Language/Haskell/Stylish/Printer/ModuleHeader/Tests.hs @@ -0,0 +1,89 @@ +module Language.Haskell.Stylish.Printer.ModuleHeader.Tests + ( tests + ) where + +-------------------------------------------------------------------------------- +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit (Assertion, (@=?)) +import GHC.Stack (HasCallStack, withFrozenCallStack) +import Prelude hiding (lines) + + +-------------------------------------------------------------------------------- +import Language.Haskell.Stylish.Module +import Language.Haskell.Stylish.Config (defaultConfig') +import Language.Haskell.Stylish.Parse (parseModule) +import Language.Haskell.Stylish.Printer.ModuleHeader (printModuleHeader) + + + +-------------------------------------------------------------------------------- +tests :: Test +tests = testGroup "Language.Haskell.Stylish.Printer.ModuleHeader" + [ testCase "Hello world" ex0 + , testCase "Empty exports list" ex1 + , testCase "Single exported variable" ex2 + , testCase "Multiple exported variables" ex3 + ] + +-------------------------------------------------------------------------------- +ex0 :: Assertion +ex0 = input `assertFormatted` output + where + input = + [ "module Foo where" + ] + output = + [ "module Foo" + , " where" + ] + +ex1 :: Assertion +ex1 = input `assertFormatted` output + where + input = + [ "module Foo () where" + ] + output = + [ "module Foo" + , " (" + , " ) where" + ] + +ex2 :: Assertion +ex2 = input `assertFormatted` output + where + input = + [ "module Foo (tests) where" + ] + output = + [ "module Foo" + , " ( tests" + , " ) where" + ] + +ex3 :: Assertion +ex3 = input `assertFormatted` output + where + input = + [ "module Foo (t1, t2, t3) where" + ] + output = + [ "module Foo" + , " ( t1" + , " , t2" + , " , t3" + , " ) where" + ] + +-------------------------------------------------------------------------------- +assertFormatted :: HasCallStack => Lines -> Lines -> Assertion +assertFormatted input expected = withFrozenCallStack $ expected @=? parseAndFormat input + where + parseAndFormat lines = + case parseModule [] Nothing (unlines lines) of + Right parsedModule -> + printModuleHeader defaultConfig' (moduleComments parsedModule) (moduleHeader parsedModule) + Left err -> + error $ "parseAndFormat: Should've been able to parse input - " <> err diff --git a/tests/Language/Haskell/Stylish/Tests/Util.hs b/tests/Language/Haskell/Stylish/Tests/Util.hs index f43b6b56..214220b2 100644 --- a/tests/Language/Haskell/Stylish/Tests/Util.hs +++ b/tests/Language/Haskell/Stylish/Tests/Util.hs @@ -23,11 +23,12 @@ import Language.Haskell.Stylish.Step -------------------------------------------------------------------------------- testStep :: Step -> String -> String -testStep step str = case parseModule [] Nothing str of - Left err -> error err - Right module' -> unlines $ stepFilter step ls module' - where - ls = lines str +testStep = undefined +--testStep step str = case parseModule [] Nothing str of +-- Left err -> error err +-- Right module' -> unlines $ stepFilter step ls module' +-- where +-- ls = lines str -------------------------------------------------------------------------------- diff --git a/tests/TestSuite.hs b/tests/TestSuite.hs index d2023ed7..84aeb34b 100644 --- a/tests/TestSuite.hs +++ b/tests/TestSuite.hs @@ -20,6 +20,8 @@ import qualified Language.Haskell.Stylish.Step.Tabs.Tests import qualified Language.Haskell.Stylish.Step.TrailingWhitespace.Tests import qualified Language.Haskell.Stylish.Step.UnicodeSyntax.Tests import qualified Language.Haskell.Stylish.Tests +import qualified Language.Haskell.Stylish.Printer.Imports.Tests +import qualified Language.Haskell.Stylish.Printer.ModuleHeader.Tests -------------------------------------------------------------------------------- @@ -36,4 +38,6 @@ main = defaultMain , Language.Haskell.Stylish.Step.TrailingWhitespace.Tests.tests , Language.Haskell.Stylish.Step.UnicodeSyntax.Tests.tests , Language.Haskell.Stylish.Tests.tests + , Language.Haskell.Stylish.Printer.Imports.Tests.tests + , Language.Haskell.Stylish.Printer.ModuleHeader.Tests.tests ] From e9f63dc695f2ed15fde7e38110246514afdbe28a Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Tue, 14 Jul 2020 17:07:48 +0200 Subject: [PATCH 002/135] Add comments parsing capability --- lib/Language/Haskell/Stylish.hs | 2 +- lib/Language/Haskell/Stylish/Module.hs | 34 +++++++++++++++++++------- lib/Language/Haskell/Stylish/Parse.hs | 4 +-- 3 files changed, 28 insertions(+), 12 deletions(-) diff --git a/lib/Language/Haskell/Stylish.hs b/lib/Language/Haskell/Stylish.hs index a2510822..7a304b37 100644 --- a/lib/Language/Haskell/Stylish.hs +++ b/lib/Language/Haskell/Stylish.hs @@ -95,7 +95,7 @@ unicodeSyntax = UnicodeSyntax.step runStep :: Extensions -> Maybe FilePath -> Lines -> Step -> Either String Lines runStep exts mfp ls _step = parseModule exts mfp (unlines ls) - & fmap (printModule defaultConfig') + & fmap (printModule defaultConfig' ls) -------------------------------------------------------------------------------- diff --git a/lib/Language/Haskell/Stylish/Module.hs b/lib/Language/Haskell/Stylish/Module.hs index c24066fc..6d43dcf7 100644 --- a/lib/Language/Haskell/Stylish/Module.hs +++ b/lib/Language/Haskell/Stylish/Module.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE LambdaCase #-} module Language.Haskell.Stylish.Module ( Module , ModuleHeader @@ -20,6 +22,9 @@ module Language.Haskell.Stylish.Module ) where -------------------------------------------------------------------------------- +import qualified ApiAnnotation as GHC +import Data.Maybe (mapMaybe) +import qualified Lexer as GHC import qualified GHC.Hs as GHC import GHC.Hs.Extension (GhcPs) import GHC.Hs.Decls (LHsDecl) @@ -33,13 +38,16 @@ type Lines = [String] -------------------------------------------------------------------------------- -- | Concrete module type -newtype Module = Module { unModule :: GHC.Located (GHC.HsModule GhcPs) } +data Module = Module + { parsedComments :: [GHC.RealLocated GHC.AnnotationComment] + , parsedModule :: GHC.Located (GHC.HsModule GhcPs) + } newtype Decls = Decls [LHsDecl GhcPs] data Imports = Imports [LImportDecl GhcPs] -data Comments = Comments [GHC.Located String] +data Comments = Comments [GHC.RealLocated GHC.AnnotationComment] data ModuleHeader = ModuleHeader { name :: Maybe (GHC.Located GHC.ModuleName) @@ -47,20 +55,28 @@ data ModuleHeader = ModuleHeader , haddocks :: Maybe GHC.LHsDocString } -makeModule :: GHC.Located (GHC.HsModule GHC.GhcPs) -> Module -makeModule = Module +makeModule :: GHC.PState -> GHC.Located (GHC.HsModule GHC.GhcPs) -> Module +makeModule pstate = Module comments + where + comments + = filterRealLocated + $ GHC.comment_q pstate ++ (GHC.annotations_comments pstate >>= snd) + + filterRealLocated = mapMaybe \case + GHC.L (GHC.RealSrcSpan s) e -> Just (GHC.L s e) + GHC.L (GHC.UnhelpfulSpan _) _ -> Nothing moduleDecls :: Module -> Decls -moduleDecls = Decls . GHC.hsmodDecls . unLocated . unModule +moduleDecls = Decls . GHC.hsmodDecls . unLocated . parsedModule moduleComments :: Module -> Comments -moduleComments = undefined +moduleComments = Comments . parsedComments moduleImports :: Module -> Imports -moduleImports = Imports . GHC.hsmodImports . unLocated . unModule +moduleImports = Imports . GHC.hsmodImports . unLocated . parsedModule moduleHeader :: Module -> ModuleHeader -moduleHeader (Module (GHC.L _ m)) = ModuleHeader +moduleHeader (Module _ (GHC.L _ m)) = ModuleHeader { name = GHC.hsmodName m , exports = GHC.hsmodExports m , haddocks = GHC.hsmodHaddockModHeader m @@ -85,5 +101,5 @@ rawModuleExports = exports rawModuleHaddocks :: ModuleHeader -> Maybe GHC.LHsDocString rawModuleHaddocks = haddocks -rawComments :: Comments -> [GHC.Located String] +rawComments :: Comments -> [GHC.RealLocated GHC.AnnotationComment] rawComments (Comments xs) = xs diff --git a/lib/Language/Haskell/Stylish/Parse.hs b/lib/Language/Haskell/Stylish/Parse.hs index f998b0f4..60f91cb6 100644 --- a/lib/Language/Haskell/Stylish/Parse.hs +++ b/lib/Language/Haskell/Stylish/Parse.hs @@ -72,8 +72,8 @@ parseModule exts fp string = where toModule :: GHC.DynFlags -> GHC.ParseResult (GHC.Located (GHC.HsModule GHC.GhcPs)) -> Either String Module toModule dynFlags res = case res of - POk _ m -> - Right (makeModule m) + POk ps m -> + Right (makeModule ps m) PFailed failureState -> Left . unlines . getParserStateErrors dynFlags $ failureState From 4278c119a248e6a25d7fd52dc1d62db306322520 Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Tue, 14 Jul 2020 17:12:35 +0200 Subject: [PATCH 003/135] Restructure interface to be a bit more similar to old stylish --- lib/Language/Haskell/Stylish/Printer/Decl.hs | 4 +- .../Haskell/Stylish/Printer/Imports.hs | 90 +++++++++---------- .../Haskell/Stylish/Printer/Module.hs | 10 +-- .../Haskell/Stylish/Printer/ModuleHeader.hs | 63 +++++++++++-- .../Haskell/Stylish/Printer/Imports/Tests.hs | 2 +- .../Stylish/Printer/ModuleHeader/Tests.hs | 76 +++++++++++++++- 6 files changed, 181 insertions(+), 64 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Printer/Decl.hs b/lib/Language/Haskell/Stylish/Printer/Decl.hs index 9e490a01..e0555e3c 100644 --- a/lib/Language/Haskell/Stylish/Printer/Decl.hs +++ b/lib/Language/Haskell/Stylish/Printer/Decl.hs @@ -10,5 +10,5 @@ import Language.Haskell.Stylish.Config (Config'(..)) --import GHC.Hs (GhcPs) -------------------------------------------------------------------------------- -printDecls :: Config' -> Comments -> Decls -> Lines -printDecls _ _ _ = ["printDecl: not implemented"] +printDecls :: Config' -> Lines -> Comments -> Decls -> Lines +printDecls _ ls _ _ = ls diff --git a/lib/Language/Haskell/Stylish/Printer/Imports.hs b/lib/Language/Haskell/Stylish/Printer/Imports.hs index ec2726f8..a63ed0df 100644 --- a/lib/Language/Haskell/Stylish/Printer/Imports.hs +++ b/lib/Language/Haskell/Stylish/Printer/Imports.hs @@ -21,20 +21,16 @@ import Language.Haskell.Stylish.Module (Comments, Lines, Imports, rawI import Language.Haskell.Stylish.Printer -------------------------------------------------------------------------------- -printImports :: Config' -> Comments -> Imports -> Lines -printImports cfg@(Config' {configImportsPrinter = printer}) _comments imports = +printImports :: Config' -> Lines -> Comments -> Imports -> Lines +printImports cfg@(Config' {configImportsPrinter = printer}) ls _comments imports = + if True then ls else runPrinter cfg importPrinter where importList = rawImports imports - sortImports = - sortBy \a0 a1 -> - compareOutputable a0 a1 <> - if isQualified a0 then GT else LT - importPrinter = case printer of DeclMinimizeDiffsPostQualified -> - forM_ (sortImports importList) \imp -> printPostQualified imp >> newline + forM_ (sortImportDecls importList) \imp -> printPostQualified imp >> newline -------------------------------------------------------------------------------- printPostQualified :: LImportDecl GhcPs -> P () @@ -60,7 +56,7 @@ printPostQualified decl = do forM_ (snd <$> ideclHiding decl') \(GHC.L _ imports) -> let printedImports = - fmap (printImport . unLocated) (sortedImportList imports) + fmap (printImport . unLocated) (sortImportList imports) separated = sep (comma >> space) @@ -80,13 +76,11 @@ printImport = \case putText "(..)" IEModuleContents _ (GHC.L _ m) -> putText (moduleNameString m) - IEThingWith _ name _wildcard imps _ -> - let - sortedImps = flip sortBy imps \(GHC.L _ a0) (GHC.L _ a1) -> compareOutputable a0 a1 - in do - printIeWrappedName name - space - parenthesize $ sep (comma >> space) (fmap printIeWrappedName sortedImps) + IEThingWith _ name _wildcard imps _ -> do + printIeWrappedName name + space + parenthesize $ + sep (comma >> space) (printIeWrappedName <$> sortBy compareOutputable imps) IEGroup _ _ _ -> error "Language.Haskell.Stylish.Printer.Imports.printImportExport: unhandled case 'IEGroup'" IEDoc _ _ -> @@ -138,33 +132,37 @@ isHiding unLocated :: GHC.Located a -> a unLocated (GHC.L _ a) = a -sortedImportList :: [LIE GhcPs] -> [LIE GhcPs] -sortedImportList = - let - unLocated' f (GHC.L _ i0) (GHC.L _ i1) = f (i0, i1) - in - sortBy $ unLocated' \case - (IEVar _ n0, IEVar _ n1) -> compareOutputable n0 n1 - - (IEThingAbs _ n0, IEThingAbs _ n1) -> compareOutputable n0 n1 - (IEThingAbs _ n0, IEThingAll _ n1) -> compareOutputable n0 n1 - (IEThingAbs _ n0, IEThingWith _ n1 _ _ _) -> compareOutputable n0 n1 - - (IEThingAll _ n0, IEThingAll _ n1) -> compareOutputable n0 n1 - (IEThingAll _ n0, IEThingAbs _ n1) -> compareOutputable n0 n1 - (IEThingAll _ n0, IEThingWith _ n1 _ _ _) -> compareOutputable n0 n1 - - (IEThingWith _ n0 _ _ _, IEThingWith _ n1 _ _ _) -> compareOutputable n0 n1 - (IEThingWith _ n0 _ _ _, IEThingAll _ n1) -> compareOutputable n0 n1 - (IEThingWith _ n0 _ _ _, IEThingAbs _ n1) -> compareOutputable n0 n1 - - (IEVar _ _, _) -> GT - (_, IEVar _ _) -> LT - (IEThingAbs _ _, _) -> GT - (_, IEThingAbs _ _) -> LT - (IEThingAll _ _, _) -> GT - (_, IEThingAll _ _) -> LT - (IEThingWith _ _ _ _ _, _) -> GT - (_, IEThingWith _ _ _ _ _) -> LT - - _ -> EQ +sortImportList :: [LIE GhcPs] -> [LIE GhcPs] +sortImportList = sortBy $ currycated \case + (IEVar _ n0, IEVar _ n1) -> compareOutputable n0 n1 + + (IEThingAbs _ n0, IEThingAbs _ n1) -> compareOutputable n0 n1 + (IEThingAbs _ n0, IEThingAll _ n1) -> compareOutputable n0 n1 + (IEThingAbs _ n0, IEThingWith _ n1 _ _ _) -> compareOutputable n0 n1 <> LT + + (IEThingAll _ n0, IEThingAll _ n1) -> compareOutputable n0 n1 + (IEThingAll _ n0, IEThingAbs _ n1) -> compareOutputable n0 n1 + (IEThingAll _ n0, IEThingWith _ n1 _ _ _) -> compareOutputable n0 n1 <> LT + + (IEThingWith _ n0 _ _ _, IEThingWith _ n1 _ _ _) -> compareOutputable n0 n1 + (IEThingWith _ n0 _ _ _, IEThingAll _ n1) -> compareOutputable n0 n1 <> GT + (IEThingWith _ n0 _ _ _, IEThingAbs _ n1) -> compareOutputable n0 n1 <> GT + + (IEVar _ _, _) -> GT + (_, IEVar _ _) -> LT + (IEThingAbs _ _, _) -> GT + (_, IEThingAbs _ _) -> LT + (IEThingAll _ _, _) -> GT + (_, IEThingAll _ _) -> LT + (IEThingWith _ _ _ _ _, _) -> GT + (_, IEThingWith _ _ _ _ _) -> LT + + _ -> EQ + +sortImportDecls :: [LImportDecl GhcPs] -> [LImportDecl GhcPs] +sortImportDecls = sortBy $ currycated \(a0, a1) -> + compareOutputable (ideclName a0) (ideclName a1) <> + compareOutputable a0 a1 + +currycated :: ((a, b) -> c) -> (GHC.Located a -> GHC.Located b -> c) +currycated f = \(GHC.L _ a) (GHC.L _ b) -> f (a, b) diff --git a/lib/Language/Haskell/Stylish/Printer/Module.hs b/lib/Language/Haskell/Stylish/Printer/Module.hs index a09a367a..677ba353 100644 --- a/lib/Language/Haskell/Stylish/Printer/Module.hs +++ b/lib/Language/Haskell/Stylish/Printer/Module.hs @@ -8,12 +8,12 @@ import Language.Haskell.Stylish.Printer.Decl (printDecls) import Language.Haskell.Stylish.Printer.ModuleHeader (printModuleHeader) import Language.Haskell.Stylish.Printer.Imports (printImports) -printModule :: Config' -> Module -> Lines -printModule c m = +printModule :: Config' -> Lines -> Module -> Lines +printModule c ls m = let comments = moduleComments m in - printModuleHeader c comments (moduleHeader m) <> - printImports c comments (moduleImports m) <> - printDecls c comments (moduleDecls m) <> + printModuleHeader c ls comments (moduleHeader m) <> + printImports c ls comments (moduleImports m) <> + printDecls c ls comments (moduleDecls m) <> [] diff --git a/lib/Language/Haskell/Stylish/Printer/ModuleHeader.hs b/lib/Language/Haskell/Stylish/Printer/ModuleHeader.hs index 11e92d15..2e2ab6de 100644 --- a/lib/Language/Haskell/Stylish/Printer/ModuleHeader.hs +++ b/lib/Language/Haskell/Stylish/Printer/ModuleHeader.hs @@ -1,11 +1,14 @@ {-# LANGUAGE BlockArguments #-} +{-# LANGUAGE LambdaCase #-} module Language.Haskell.Stylish.Printer.ModuleHeader ( printModuleHeader ) where -------------------------------------------------------------------------------- -import Control.Monad (forM_, when) +import Control.Monad (forM_, join, when) +import Data.Foldable (toList) +import Data.List (sortBy) import Data.Maybe (isJust) import qualified GHC.Hs.Doc as GHC import GHC.Hs.Extension (GhcPs) @@ -13,22 +16,64 @@ import qualified GHC.Hs.Extension as GHC import GHC.Hs.ImpExp (IE(..)) import qualified GHC.Hs.ImpExp as GHC import qualified Module as GHC -import SrcLoc (Located, GenLocated(..)) +import SrcLoc (Located, GenLocated(..), SrcSpan(..)) +import SrcLoc (srcSpanStartLine, srcSpanEndLine) import Util (notNull) -------------------------------------------------------------------------------- import Language.Haskell.Stylish.Module import Language.Haskell.Stylish.Config (Config'(..)) import Language.Haskell.Stylish.Printer +import Language.Haskell.Stylish.Editor +import Language.Haskell.Stylish.Block -printModuleHeader :: Config' -> Comments -> ModuleHeader -> Lines -printModuleHeader cfg _ header = +printModuleHeader :: Config' -> Lines -> Comments -> ModuleHeader -> Lines +printModuleHeader cfg ls _ header = let name = rawModuleName header haddocks = rawModuleHaddocks header exports = rawModuleExports header + + printedModuleHeader = runPrinter cfg (printHeader name exports haddocks) + + unsafeGetStart = \case + (L (RealSrcSpan s) _) -> srcSpanStartLine s + _ -> error "could not get start line of block" + + unsafeGetEnd = \case + (L (RealSrcSpan s) _) -> srcSpanEndLine s + _ -> error "could not get end line of block" + + getBlock loc = + Block <$> fmap unsafeGetStart loc <*> fmap unsafeGetEnd loc + + adjustOffsetFrom :: Block a -> Block a -> Maybe (Block a) + adjustOffsetFrom (Block s0 _) b2@(Block s1 e1) + | s0 >= s1 && s0 >= e1 = Nothing + | s0 >= s1 = Just (Block (s0 + 1) e1) + | otherwise = Just b2 + + nameBlock = + getBlock name + + exportsBlock = + join $ adjustOffsetFrom <$> nameBlock <*> getBlock exports + + mergeAdjacent (a : b : rest) | a `adjacent` b = merge a b : mergeAdjacent rest + mergeAdjacent (a : rest) = a : mergeAdjacent rest + mergeAdjacent [] = [] + + deletes = + fmap delete $ mergeAdjacent $ toList nameBlock <> toList exportsBlock + + startLine = + maybe 1 blockStart nameBlock + + additions = [insert startLine printedModuleHeader] + + changes = deletes <> additions in - runPrinter cfg (printHeader name exports haddocks) + applyChanges changes ls printHeader :: Maybe (Located GHC.ModuleName) @@ -51,7 +96,7 @@ printExportList (L _ exports) = do newline indent 2 (putText "(") >> when (notNull exports) space - sep (newline >> space >> space >> comma >> space) (fmap printExports exports) + sep (newline >> space >> space >> comma >> space) (fmap printExports (sortBy compareOutputable exports)) newline >> indent 2 (putText ")" >> space >> putText "where") where @@ -61,15 +106,15 @@ printExportList (L _ exports) = do printExports (L _ export) = case export of IEVar _ name -> putOutputable name IEThingAbs _ name -> putOutputable name - IEThingAll _ name -> do + IEThingAll _ _name -> do undefined --printIeWrappedName name --space --putText "(..)" - IEModuleContents _ (L _ m) -> + IEModuleContents _ (L _ _m) -> undefined --putText (moduleNameString m) - IEThingWith _ name _wildcard imps _ -> + IEThingWith _ _name _wildcard _imps _ -> undefined --let -- sortedImps = flip sortBy imps \(GHC.L _ a0) (GHC.L _ a1) -> compareOutputable a0 a1 diff --git a/tests/Language/Haskell/Stylish/Printer/Imports/Tests.hs b/tests/Language/Haskell/Stylish/Printer/Imports/Tests.hs index 9d55ee86..b3465712 100644 --- a/tests/Language/Haskell/Stylish/Printer/Imports/Tests.hs +++ b/tests/Language/Haskell/Stylish/Printer/Imports/Tests.hs @@ -134,6 +134,6 @@ assertFormatted input expected = withFrozenCallStack $ expected @=? parseAndForm parseAndFormat lines = case parseModule [] Nothing (unlines lines) of Right parsedModule -> - printImports defaultConfig' (moduleComments parsedModule) (moduleImports parsedModule) + printImports defaultConfig' lines (moduleComments parsedModule) (moduleImports parsedModule) Left err -> error $ "parseAndFormat: Should've been able to parse input - " <> err diff --git a/tests/Language/Haskell/Stylish/Printer/ModuleHeader/Tests.hs b/tests/Language/Haskell/Stylish/Printer/ModuleHeader/Tests.hs index e8c6b48a..99cbac15 100644 --- a/tests/Language/Haskell/Stylish/Printer/ModuleHeader/Tests.hs +++ b/tests/Language/Haskell/Stylish/Printer/ModuleHeader/Tests.hs @@ -25,6 +25,9 @@ tests = testGroup "Language.Haskell.Stylish.Printer.ModuleHeader" , testCase "Empty exports list" ex1 , testCase "Single exported variable" ex2 , testCase "Multiple exported variables" ex3 + , testCase "Only reformats module header" ex4 + , testCase "Leaving pragmas in place" ex5 + , testCase "Leaving pragmas in place variant" ex6 ] -------------------------------------------------------------------------------- @@ -77,6 +80,77 @@ ex3 = input `assertFormatted` output , " ) where" ] +ex4 :: Assertion +ex4 = input `assertFormatted` output + where + input = + [ "module Foo (" + , " t1," + , " t3," + , " t2" + , ") where" + , "" + , "" + , "-- | Docstring" + , "foo :: Int" + , "foo = 1" + ] + output = + [ "module Foo" + , " ( t1" + , " , t2" + , " , t3" + , " ) where" + , "" + , "" + , "-- | Docstring" + , "foo :: Int" + , "foo = 1" + ] + +ex5 :: Assertion +ex5 = input `assertFormatted` output + where + input = + [ "{-# LANGUAGE DerivingVia #-}" + , "-- | This module docs" + , "module Foo (" + , " t1," + , " t3," + , " t2" + , ") where" + ] + output = + [ "{-# LANGUAGE DerivingVia #-}" + , "-- | This module docs" + , "module Foo" + , " ( t1" + , " , t2" + , " , t3" + , " ) where" + ] +ex6 :: Assertion +ex6 = input `assertFormatted` output + where + input = + [ "-- | This module docs" + , "{-# LANGUAGE DerivingVia #-}" + , "module Foo (" + , " t1," + , " t3," + , " t2" + , ") where" + ] + output = + [ "-- | This module docs" + , "{-# LANGUAGE DerivingVia #-}" + , "module Foo" + , " ( t1" + , " , t2" + , " , t3" + , " ) where" + ] + -------------------------------------------------------------------------------- assertFormatted :: HasCallStack => Lines -> Lines -> Assertion assertFormatted input expected = withFrozenCallStack $ expected @=? parseAndFormat input @@ -84,6 +158,6 @@ assertFormatted input expected = withFrozenCallStack $ expected @=? parseAndForm parseAndFormat lines = case parseModule [] Nothing (unlines lines) of Right parsedModule -> - printModuleHeader defaultConfig' (moduleComments parsedModule) (moduleHeader parsedModule) + printModuleHeader defaultConfig' lines (moduleComments parsedModule) (moduleHeader parsedModule) Left err -> error $ "parseAndFormat: Should've been able to parse input - " <> err From 0005bba2350c9ab4c429fd20576fb281b5e94767 Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Tue, 14 Jul 2020 17:21:15 +0200 Subject: [PATCH 004/135] Only do module header in stylish step --- lib/Language/Haskell/Stylish.hs | 4 ++-- .../Haskell/Stylish/Printer/Module.hs | 19 ------------------- .../Haskell/Stylish/Printer/ModuleHeader.hs | 5 +++-- stylish-haskell.cabal | 2 -- .../Stylish/Printer/ModuleHeader/Tests.hs | 2 +- 5 files changed, 6 insertions(+), 26 deletions(-) delete mode 100644 lib/Language/Haskell/Stylish/Printer/Module.hs diff --git a/lib/Language/Haskell/Stylish.hs b/lib/Language/Haskell/Stylish.hs index 7a304b37..696d3005 100644 --- a/lib/Language/Haskell/Stylish.hs +++ b/lib/Language/Haskell/Stylish.hs @@ -37,7 +37,7 @@ import System.FilePath (takeExtension -------------------------------------------------------------------------------- import Language.Haskell.Stylish.Config import Language.Haskell.Stylish.Parse -import Language.Haskell.Stylish.Printer.Module +import Language.Haskell.Stylish.Printer.ModuleHeader (printModuleHeader) import Language.Haskell.Stylish.Step import qualified Language.Haskell.Stylish.Step.Imports as Imports import qualified Language.Haskell.Stylish.Step.LanguagePragmas as LanguagePragmas @@ -95,7 +95,7 @@ unicodeSyntax = UnicodeSyntax.step runStep :: Extensions -> Maybe FilePath -> Lines -> Step -> Either String Lines runStep exts mfp ls _step = parseModule exts mfp (unlines ls) - & fmap (printModule defaultConfig' ls) + & fmap (printModuleHeader defaultConfig' ls) -------------------------------------------------------------------------------- diff --git a/lib/Language/Haskell/Stylish/Printer/Module.hs b/lib/Language/Haskell/Stylish/Printer/Module.hs deleted file mode 100644 index 677ba353..00000000 --- a/lib/Language/Haskell/Stylish/Printer/Module.hs +++ /dev/null @@ -1,19 +0,0 @@ -module Language.Haskell.Stylish.Printer.Module - ( printModule - ) where - -import Language.Haskell.Stylish.Module -import Language.Haskell.Stylish.Config (Config'(..)) -import Language.Haskell.Stylish.Printer.Decl (printDecls) -import Language.Haskell.Stylish.Printer.ModuleHeader (printModuleHeader) -import Language.Haskell.Stylish.Printer.Imports (printImports) - -printModule :: Config' -> Lines -> Module -> Lines -printModule c ls m = - let - comments = moduleComments m - in - printModuleHeader c ls comments (moduleHeader m) <> - printImports c ls comments (moduleImports m) <> - printDecls c ls comments (moduleDecls m) <> - [] diff --git a/lib/Language/Haskell/Stylish/Printer/ModuleHeader.hs b/lib/Language/Haskell/Stylish/Printer/ModuleHeader.hs index 2e2ab6de..38e121a2 100644 --- a/lib/Language/Haskell/Stylish/Printer/ModuleHeader.hs +++ b/lib/Language/Haskell/Stylish/Printer/ModuleHeader.hs @@ -27,9 +27,10 @@ import Language.Haskell.Stylish.Printer import Language.Haskell.Stylish.Editor import Language.Haskell.Stylish.Block -printModuleHeader :: Config' -> Lines -> Comments -> ModuleHeader -> Lines -printModuleHeader cfg ls _ header = +printModuleHeader :: Config' -> Lines -> Module -> Lines +printModuleHeader cfg ls m = let + header = moduleHeader m name = rawModuleName header haddocks = rawModuleHaddocks header exports = rawModuleExports header diff --git a/stylish-haskell.cabal b/stylish-haskell.cabal index 2112f7b1..8aecd9c8 100644 --- a/stylish-haskell.cabal +++ b/stylish-haskell.cabal @@ -32,7 +32,6 @@ Library Language.Haskell.Stylish.Module Language.Haskell.Stylish.Printer Language.Haskell.Stylish.Printer.Decl - Language.Haskell.Stylish.Printer.Module Language.Haskell.Stylish.Printer.ModuleHeader Language.Haskell.Stylish.Printer.Imports Language.Haskell.Stylish.Step.Data @@ -120,7 +119,6 @@ Test-suite stylish-haskell-tests Language.Haskell.Stylish.Parse.Tests Language.Haskell.Stylish.Printer Language.Haskell.Stylish.Printer.Decl - Language.Haskell.Stylish.Printer.Module Language.Haskell.Stylish.Printer.ModuleHeader Language.Haskell.Stylish.Printer.Imports Language.Haskell.Stylish.Printer.Imports.Tests diff --git a/tests/Language/Haskell/Stylish/Printer/ModuleHeader/Tests.hs b/tests/Language/Haskell/Stylish/Printer/ModuleHeader/Tests.hs index 99cbac15..5664eec0 100644 --- a/tests/Language/Haskell/Stylish/Printer/ModuleHeader/Tests.hs +++ b/tests/Language/Haskell/Stylish/Printer/ModuleHeader/Tests.hs @@ -158,6 +158,6 @@ assertFormatted input expected = withFrozenCallStack $ expected @=? parseAndForm parseAndFormat lines = case parseModule [] Nothing (unlines lines) of Right parsedModule -> - printModuleHeader defaultConfig' lines (moduleComments parsedModule) (moduleHeader parsedModule) + printModuleHeader defaultConfig' lines parsedModule Left err -> error $ "parseAndFormat: Should've been able to parse input - " <> err From 97a9c57686cfee27a98be18d98fc0b7c95deaec5 Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Tue, 14 Jul 2020 17:29:44 +0200 Subject: [PATCH 005/135] Print both imports and module header in stylish regular path --- lib/Language/Haskell/Stylish.hs | 6 +++++- lib/Language/Haskell/Stylish/Printer/Imports.hs | 7 ++++--- 2 files changed, 9 insertions(+), 4 deletions(-) diff --git a/lib/Language/Haskell/Stylish.hs b/lib/Language/Haskell/Stylish.hs index 696d3005..0cac1b1e 100644 --- a/lib/Language/Haskell/Stylish.hs +++ b/lib/Language/Haskell/Stylish.hs @@ -38,6 +38,7 @@ import System.FilePath (takeExtension import Language.Haskell.Stylish.Config import Language.Haskell.Stylish.Parse import Language.Haskell.Stylish.Printer.ModuleHeader (printModuleHeader) +import Language.Haskell.Stylish.Printer.Imports (printImports) import Language.Haskell.Stylish.Step import qualified Language.Haskell.Stylish.Step.Imports as Imports import qualified Language.Haskell.Stylish.Step.LanguagePragmas as LanguagePragmas @@ -95,7 +96,10 @@ unicodeSyntax = UnicodeSyntax.step runStep :: Extensions -> Maybe FilePath -> Lines -> Step -> Either String Lines runStep exts mfp ls _step = parseModule exts mfp (unlines ls) - & fmap (printModuleHeader defaultConfig' ls) + & fmap printSteps + where + printSteps m = + printImports defaultConfig' (printModuleHeader defaultConfig' ls m) m -------------------------------------------------------------------------------- diff --git a/lib/Language/Haskell/Stylish/Printer/Imports.hs b/lib/Language/Haskell/Stylish/Printer/Imports.hs index a63ed0df..f779f519 100644 --- a/lib/Language/Haskell/Stylish/Printer/Imports.hs +++ b/lib/Language/Haskell/Stylish/Printer/Imports.hs @@ -17,15 +17,16 @@ import qualified SrcLoc as GHC -------------------------------------------------------------------------------- import Language.Haskell.Stylish.Config (Config'(..), ImportsPrinter(..)) -import Language.Haskell.Stylish.Module (Comments, Lines, Imports, rawImports) +import Language.Haskell.Stylish.Module import Language.Haskell.Stylish.Printer -------------------------------------------------------------------------------- -printImports :: Config' -> Lines -> Comments -> Imports -> Lines -printImports cfg@(Config' {configImportsPrinter = printer}) ls _comments imports = +printImports :: Config' -> Lines -> Module -> Lines +printImports cfg@(Config' {configImportsPrinter = printer}) ls m = if True then ls else runPrinter cfg importPrinter where + imports = moduleImports m importList = rawImports imports importPrinter = case printer of From dc92f92a66bcc5b18ae3835ad1b679d62f163c3e Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Wed, 15 Jul 2020 09:24:28 +0200 Subject: [PATCH 006/135] Hook up old stylish to new one --- lib/Language/Haskell/Stylish.hs | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/lib/Language/Haskell/Stylish.hs b/lib/Language/Haskell/Stylish.hs index 0cac1b1e..972092b7 100644 --- a/lib/Language/Haskell/Stylish.hs +++ b/lib/Language/Haskell/Stylish.hs @@ -96,6 +96,7 @@ unicodeSyntax = UnicodeSyntax.step runStep :: Extensions -> Maybe FilePath -> Lines -> Step -> Either String Lines runStep exts mfp ls _step = parseModule exts mfp (unlines ls) + --stepFilter step ls <$> parseModule exts mfp (unlines ls) & fmap printSteps where printSteps m = @@ -105,7 +106,14 @@ runStep exts mfp ls _step -------------------------------------------------------------------------------- runSteps :: Extensions -> Maybe FilePath -> [Step] -> Lines -> Either String Lines -runSteps exts mfp steps ls = foldM (runStep exts mfp) ls steps +runSteps exts mfp steps ls = + if False then foldM (runStep exts mfp) ls steps + else + parseModule exts mfp (unlines ls) + & fmap printSteps + where + printSteps m = + printImports defaultConfig' (printModuleHeader defaultConfig' ls m) m newtype ConfigPath = ConfigPath { unConfigPath :: FilePath } From 03e3e39f16f1fe124b0c778a7f4886fa5bd45d2d Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Wed, 15 Jul 2020 13:23:39 +0200 Subject: [PATCH 007/135] Finish implemntation of module header --- lib/Language/Haskell/Stylish/Module.hs | 4 +- lib/Language/Haskell/Stylish/Printer.hs | 76 ++++++++++--- .../Haskell/Stylish/Printer/Imports.hs | 3 +- .../Haskell/Stylish/Printer/ModuleHeader.hs | 106 ++++++++++++++---- .../Haskell/Stylish/Printer/Imports/Tests.hs | 2 +- .../Stylish/Printer/ModuleHeader/Tests.hs | 94 ++++++++++++++++ 6 files changed, 246 insertions(+), 39 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Module.hs b/lib/Language/Haskell/Stylish/Module.hs index 6d43dcf7..2c3bb62c 100644 --- a/lib/Language/Haskell/Stylish/Module.hs +++ b/lib/Language/Haskell/Stylish/Module.hs @@ -24,6 +24,7 @@ module Language.Haskell.Stylish.Module -------------------------------------------------------------------------------- import qualified ApiAnnotation as GHC import Data.Maybe (mapMaybe) +import Data.List (sort) import qualified Lexer as GHC import qualified GHC.Hs as GHC import GHC.Hs.Extension (GhcPs) @@ -59,7 +60,8 @@ makeModule :: GHC.PState -> GHC.Located (GHC.HsModule GHC.GhcPs) -> Module makeModule pstate = Module comments where comments - = filterRealLocated + = sort + . filterRealLocated $ GHC.comment_q pstate ++ (GHC.annotations_comments pstate >>= snd) filterRealLocated = mapMaybe \case diff --git a/lib/Language/Haskell/Stylish/Printer.hs b/lib/Language/Haskell/Stylish/Printer.hs index d0320262..9c61daa0 100644 --- a/lib/Language/Haskell/Stylish/Printer.hs +++ b/lib/Language/Haskell/Stylish/Printer.hs @@ -1,8 +1,9 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} module Language.Haskell.Stylish.Printer ( Printer(..) , PrinterState(..) @@ -19,12 +20,15 @@ module Language.Haskell.Stylish.Printer , newline , parenthesize , prefix + , putComment , putText , sep , space + , spaces , suffix , indent - , indented + , removeLineComment + , removeCommentTo -- ** Outputable helpers , showOutputable , compareOutputable @@ -35,10 +39,15 @@ import Language.Haskell.Stylish.Config (Config') import Language.Haskell.Stylish.Parse (baseDynFlags) -------------------------------------------------------------------------------- -import Control.Monad (forM_, replicateM) +import ApiAnnotation (AnnotationComment(..)) +import SrcLoc (GenLocated(..), RealLocated) +import SrcLoc (srcSpanStartLine) +import Control.Monad (forM_, replicateM, replicateM_) import Control.Monad.Reader (MonadReader, ReaderT(..)) import Control.Monad.State (MonadState, State) import Control.Monad.State (execState, gets, modify) +import Data.Foldable (find) +import Data.List (delete) import GHC.Generics (Generic) import qualified Outputable as GHC import Prelude hiding (lines) @@ -55,29 +64,43 @@ data PrinterState = PrinterState { lines :: Lines , linePos :: !Int , currentLine :: String + , pendingComments :: [RealLocated AnnotationComment] } deriving stock (Generic) -runPrinter :: Config' -> Printer a -> Lines -runPrinter cfg (Printer printer) = +runPrinter :: Config' -> [RealLocated AnnotationComment] -> Printer a -> Lines +runPrinter cfg comments (Printer printer) = let - PrinterState parsedLines _ startedLine = runReaderT printer cfg `execState` PrinterState [] 0 "" + PrinterState parsedLines _ startedLine _ = runReaderT printer cfg `execState` PrinterState [] 0 "" comments in parsedLines <> if startedLine == [] then [] else [startedLine] putText :: String -> P () putText txt = do l <- gets currentLine - modify (\s -> s { currentLine = l <> txt }) + modify \s -> s { currentLine = l <> txt } + +putComment :: AnnotationComment -> P () +putComment = \case + AnnLineComment s -> putText s + AnnDocCommentNext s -> putText s + AnnDocCommentPrev s -> putText s + AnnDocCommentNamed s -> putText s + AnnDocSection _ s -> putText s + AnnDocOptions s -> putText s + AnnBlockComment s -> putText s newline :: P () newline = do l <- gets currentLine - modify (\s -> s { currentLine = "", linePos = 0, lines = lines s <> [l] }) + modify \s -> s { currentLine = "", linePos = 0, lines = lines s <> [l] } space :: P () space = putText " " +spaces :: Int -> P () +spaces i = replicateM_ i space + dot :: P () dot = putText "." @@ -89,8 +112,7 @@ parenthesize action = putText "(" *> action <* putText ")" sep :: P a -> [P a] -> P () sep _ [] = pure () -sep s (first : rest) = do - first >> forM_ rest ((>>) s) +sep s (first : rest) = first >> forM_ rest ((>>) s) prefix :: P a -> P b -> P b prefix pa pb = pa >> pb @@ -98,9 +120,6 @@ prefix pa pb = pa >> pb suffix :: P a -> P b -> P a suffix pa pb = pb >> pa -indented :: Int -> [P a] -> [P a] -indented i = fmap \x -> replicateM i space >> x - indent :: Int -> P a -> P a indent i = (>>) (replicateM i space) @@ -109,3 +128,32 @@ showOutputable = GHC.showPpr baseDynFlags compareOutputable :: GHC.Outputable a => a -> a -> Ordering compareOutputable i0 i1 = compare (showOutputable i0) (showOutputable i1) + +-- | Gets comment on supplied 'line' and removes it from the state +removeLineComment :: Int -> P (Maybe AnnotationComment) +removeLineComment line = + removeComment (\(L rloc _) -> srcSpanStartLine rloc == line) + +-- | Removes comments from the state up to 'line' and returns the ones that were removed +removeCommentTo :: Int -> P [AnnotationComment] +removeCommentTo line = + removeComment (\(L rloc _) -> srcSpanStartLine rloc < line) >>= \case + Nothing -> pure [] + Just c -> do + rest <- removeCommentTo line + pure (c : rest) + +-- | Remove a comment from the state given predicate 'p' +removeComment :: (RealLocated AnnotationComment -> Bool) -> P (Maybe AnnotationComment) +removeComment p = do + comments <- gets pendingComments + + let + foundComment = + find p comments + + newPendingComments = + maybe comments (`delete` comments) foundComment + + modify \s -> s { pendingComments = newPendingComments } + pure $ fmap (\(L _ c) -> c) foundComment diff --git a/lib/Language/Haskell/Stylish/Printer/Imports.hs b/lib/Language/Haskell/Stylish/Printer/Imports.hs index f779f519..04b5e0f0 100644 --- a/lib/Language/Haskell/Stylish/Printer/Imports.hs +++ b/lib/Language/Haskell/Stylish/Printer/Imports.hs @@ -24,7 +24,8 @@ import Language.Haskell.Stylish.Printer printImports :: Config' -> Lines -> Module -> Lines printImports cfg@(Config' {configImportsPrinter = printer}) ls m = if True then ls else - runPrinter cfg importPrinter + -- FIXME add comments here + runPrinter cfg [] importPrinter where imports = moduleImports m importList = rawImports imports diff --git a/lib/Language/Haskell/Stylish/Printer/ModuleHeader.hs b/lib/Language/Haskell/Stylish/Printer/ModuleHeader.hs index 38e121a2..2aa0c48b 100644 --- a/lib/Language/Haskell/Stylish/Printer/ModuleHeader.hs +++ b/lib/Language/Haskell/Stylish/Printer/ModuleHeader.hs @@ -6,8 +6,11 @@ module Language.Haskell.Stylish.Printer.ModuleHeader -------------------------------------------------------------------------------- +import ApiAnnotation (AnnotationComment(..)) import Control.Monad (forM_, join, when) import Data.Foldable (toList) +import Data.Function ((&), on) +import Data.Functor ((<&>)) import Data.List (sortBy) import Data.Maybe (isJust) import qualified GHC.Hs.Doc as GHC @@ -17,6 +20,7 @@ import GHC.Hs.ImpExp (IE(..)) import qualified GHC.Hs.ImpExp as GHC import qualified Module as GHC import SrcLoc (Located, GenLocated(..), SrcSpan(..)) +import SrcLoc (RealLocated) import SrcLoc (srcSpanStartLine, srcSpanEndLine) import Util (notNull) @@ -35,7 +39,25 @@ printModuleHeader cfg ls m = haddocks = rawModuleHaddocks header exports = rawModuleExports header - printedModuleHeader = runPrinter cfg (printHeader name exports haddocks) + relevantComments :: [RealLocated AnnotationComment] + relevantComments + = moduleComments m + & rawComments + & dropAfter exports + & dropBefore name + + dropAfter loc xs = case loc of + Just (L (RealSrcSpan rloc) _) -> + filter (\(L x _) -> srcSpanEndLine rloc >= srcSpanStartLine x) xs + _ -> xs + + dropBefore loc xs = case loc of + Just (L (RealSrcSpan rloc) _) -> + filter (\(L x _) -> srcSpanStartLine rloc <= srcSpanEndLine x) xs + _ -> xs + + printedModuleHeader = + runPrinter cfg relevantComments (printHeader name exports haddocks) unsafeGetStart = \case (L (RealSrcSpan s) _) -> srcSpanStartLine s @@ -82,47 +104,80 @@ printHeader :: -> Maybe GHC.LHsDocString -> P () printHeader mname mexps _ = do - forM_ mname \(L _ name) -> do + forM_ mname \(L loc name) -> do putText "module" space putText (showOutputable name) + attachEolComment loc maybe (when (isJust mname) do newline >> space >> space >> putText "where") printExportList mexps +attachEolComment :: SrcSpan -> P () +attachEolComment = \case + UnhelpfulSpan _ -> pure () + RealSrcSpan rspan -> + removeLineComment (srcSpanStartLine rspan) >>= mapM_ \c -> space >> putComment c + +attachEolCommentEnd :: SrcSpan -> P () +attachEolCommentEnd = \case + UnhelpfulSpan _ -> pure () + RealSrcSpan rspan -> + removeLineComment (srcSpanEndLine rspan) >>= mapM_ \c -> space >> putComment c + printExportList :: Located [GHC.LIE GhcPs] -> P () -printExportList (L _ exports) = do +printExportList (L srcLoc exports) = do newline indent 2 (putText "(") >> when (notNull exports) space - sep (newline >> space >> space >> comma >> space) (fmap printExports (sortBy compareOutputable exports)) + exportsWithComments <- + attachComments exports <&> sortBy (compareOutputable `on` snd) + + printExports exportsWithComments - newline >> indent 2 (putText ")" >> space >> putText "where") + putText ")" >> space >> putText "where" >> attachEolCommentEnd srcLoc where putOutputable = putText . showOutputable - printExports :: GHC.LIE GhcPs -> P () - printExports (L _ export) = case export of + printExports :: [([AnnotationComment], GHC.LIE GhcPs)] -> P () + printExports (([], export) : rest) = do + printExport export + newline + spaces 2 + printExportsTail rest + printExports ((firstComment : comments, export) : rest) = do + putComment firstComment >> newline >> spaces 2 + forM_ comments \c -> spaces 2 >> putComment c >> newline >> spaces 2 + spaces 2 + printExport export + newline + spaces 2 + printExportsTail rest + printExports [] = + newline >> spaces 2 + + printExportsTail :: [([AnnotationComment], GHC.LIE GhcPs)] -> P () + printExportsTail = mapM_ \(comments, export) -> do + forM_ comments \c -> spaces 2 >> putComment c >> newline >> spaces 2 + comma >> space >> printExport export + newline >> spaces 2 + + printExport :: GHC.LIE GhcPs -> P () + printExport (L _ export) = case export of IEVar _ name -> putOutputable name IEThingAbs _ name -> putOutputable name - IEThingAll _ _name -> do - undefined - --printIeWrappedName name - --space - --putText "(..)" - IEModuleContents _ (L _ _m) -> - undefined - --putText (moduleNameString m) + IEThingAll _ name -> do + putOutputable name + space + putText "(..)" + IEModuleContents _ (L _ m) -> do + putText "module" + space + putText (showOutputable m) IEThingWith _ _name _wildcard _imps _ -> - undefined - --let - -- sortedImps = flip sortBy imps \(GHC.L _ a0) (GHC.L _ a1) -> compareOutputable a0 a1 - --in do - -- printIeWrappedName name - -- space - -- parenthesize $ sep (comma >> space) (fmap printIeWrappedName sortedImps) + error "Language.Haskell.Stylish.Printer.Imports.printImportExport: unhandled case 'IEThingWith'" IEGroup _ _ _ -> error "Language.Haskell.Stylish.Printer.Imports.printImportExport: unhandled case 'IEGroup'" IEDoc _ _ -> @@ -131,3 +186,10 @@ printExportList (L _ exports) = do error "Language.Haskell.Stylish.Printer.Imports.printImportExport: unhandled case 'IEDocNamed'" XIE ext -> GHC.noExtCon ext + +attachComments :: [GHC.LIE GhcPs] -> P [([AnnotationComment], GHC.LIE GhcPs)] +attachComments (L (RealSrcSpan rloc) x : xs) = do + comments <- removeCommentTo (srcSpanStartLine rloc) + rest <- attachComments xs + pure $ (comments, L (RealSrcSpan rloc) x) : rest +attachComments _ = pure [] diff --git a/tests/Language/Haskell/Stylish/Printer/Imports/Tests.hs b/tests/Language/Haskell/Stylish/Printer/Imports/Tests.hs index b3465712..97e45113 100644 --- a/tests/Language/Haskell/Stylish/Printer/Imports/Tests.hs +++ b/tests/Language/Haskell/Stylish/Printer/Imports/Tests.hs @@ -134,6 +134,6 @@ assertFormatted input expected = withFrozenCallStack $ expected @=? parseAndForm parseAndFormat lines = case parseModule [] Nothing (unlines lines) of Right parsedModule -> - printImports defaultConfig' lines (moduleComments parsedModule) (moduleImports parsedModule) + printImports defaultConfig' lines parsedModule Left err -> error $ "parseAndFormat: Should've been able to parse input - " <> err diff --git a/tests/Language/Haskell/Stylish/Printer/ModuleHeader/Tests.hs b/tests/Language/Haskell/Stylish/Printer/ModuleHeader/Tests.hs index 5664eec0..f90d6630 100644 --- a/tests/Language/Haskell/Stylish/Printer/ModuleHeader/Tests.hs +++ b/tests/Language/Haskell/Stylish/Printer/ModuleHeader/Tests.hs @@ -28,6 +28,10 @@ tests = testGroup "Language.Haskell.Stylish.Printer.ModuleHeader" , testCase "Only reformats module header" ex4 , testCase "Leaving pragmas in place" ex5 , testCase "Leaving pragmas in place variant" ex6 + , testCase "Leaving comments in place" ex7 + , testCase "Exports all" ex8 + , testCase "Exports module" ex9 + , testCase "Exports symbol" ex10 ] -------------------------------------------------------------------------------- @@ -151,6 +155,96 @@ ex6 = input `assertFormatted` output , " ) where" ] +ex7 :: Assertion +ex7 = input `assertFormatted` output + where + input = + [ "module Foo -- Foo" + , "(" + , " -- * t1 something" + , " t1," + , " t3," + , " -- * t2 something" + , " t2" + , ") where -- x" + , "-- y" + ] + output = + [ "module Foo -- Foo" + , " ( -- * t1 something" + , " t1" + , " -- * t2 something" + , " , t2" + , " , t3" + , " ) where -- x" + , "-- y" + ] + + +ex8 :: Assertion +ex8 = input `assertFormatted` output + where + input = + [ "module Foo (" + , " -- * t1 something" + , " A(..)," + , " t3," + , " -- * t2 something" + , " t2" + , ") where -- x" + , "-- y" + ] + output = + [ "module Foo" + , " ( -- * t1 something" + , " A (..)" + , " -- * t2 something" + , " , t2" + , " , t3" + , " ) where -- x" + , "-- y" + ] + +ex9 :: Assertion +ex9 = input `assertFormatted` output + where + input = + [ "module Foo (" + , " -- * t1 something" + , " module A," + , " t3," + , " -- * t2 something" + , " t2" + , ") where -- x" + , "-- y" + ] + output = + [ "module Foo" + , " ( -- * t1 something" + , " module A" + , " -- * t2 something" + , " , t2" + , " , t3" + , " ) where -- x" + , "-- y" + ] + +ex10 :: Assertion +ex10 = input `assertFormatted` output + where + input = + [ "module Foo (" + , " (<&>)" + , ") where -- x" + , "-- y" + ] + output = + [ "module Foo" + , " ( (<&>)" + , " ) where -- x" + , "-- y" + ] + -------------------------------------------------------------------------------- assertFormatted :: HasCallStack => Lines -> Lines -> Assertion assertFormatted input expected = withFrozenCallStack $ expected @=? parseAndFormat input From bf38e53671d1930ceee0bfd1e24f305b5f845d08 Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Wed, 15 Jul 2020 16:27:28 +0200 Subject: [PATCH 008/135] Print more helpful error message when encountering a parser error --- lib/Language/Haskell/Stylish/Parse.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/lib/Language/Haskell/Stylish/Parse.hs b/lib/Language/Haskell/Stylish/Parse.hs index 60f91cb6..ff24fd96 100644 --- a/lib/Language/Haskell/Stylish/Parse.hs +++ b/lib/Language/Haskell/Stylish/Parse.hs @@ -75,7 +75,10 @@ parseModule exts fp string = POk ps m -> Right (makeModule ps m) PFailed failureState -> - Left . unlines . getParserStateErrors dynFlags $ failureState + let + withFileName x = maybe "" (<> ": ") fp <> x + in + Left . withFileName . unlines . getParserStateErrors dynFlags $ failureState removeCpp dynFlags s = if GHC.xopt GHC.Cpp dynFlags then unCpp s From 196f44576b22fa6b00b335b8dcd8f62bd9bcf778 Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Wed, 15 Jul 2020 16:27:40 +0200 Subject: [PATCH 009/135] Implement missing printer for IEThingWith --- .../Haskell/Stylish/Printer/ModuleHeader.hs | 17 ++++++++++++----- 1 file changed, 12 insertions(+), 5 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Printer/ModuleHeader.hs b/lib/Language/Haskell/Stylish/Printer/ModuleHeader.hs index 2aa0c48b..b04c4272 100644 --- a/lib/Language/Haskell/Stylish/Printer/ModuleHeader.hs +++ b/lib/Language/Haskell/Stylish/Printer/ModuleHeader.hs @@ -176,14 +176,21 @@ printExportList (L srcLoc exports) = do putText "module" space putText (showOutputable m) - IEThingWith _ _name _wildcard _imps _ -> - error "Language.Haskell.Stylish.Printer.Imports.printImportExport: unhandled case 'IEThingWith'" + IEThingWith _ name _wildcard imps _ -> do + putOutputable name + space + putText "(" + sep (comma >> space) (fmap putOutputable (sortBy compareOutputable imps)) + putText ")" IEGroup _ _ _ -> - error "Language.Haskell.Stylish.Printer.Imports.printImportExport: unhandled case 'IEGroup'" + error $ + "Language.Haskell.Stylish.Printer.Imports.printImportExport: unhandled case 'IEGroup'" <> showOutputable export IEDoc _ _ -> - error "Language.Haskell.Stylish.Printer.Imports.printImportExport: unhandled case 'IEDoc'" + error $ + "Language.Haskell.Stylish.Printer.Imports.printImportExport: unhandled case 'IEDoc'" <> showOutputable export IEDocNamed _ _ -> - error "Language.Haskell.Stylish.Printer.Imports.printImportExport: unhandled case 'IEDocNamed'" + error $ + "Language.Haskell.Stylish.Printer.Imports.printImportExport: unhandled case 'IEDocNamed'" <> showOutputable export XIE ext -> GHC.noExtCon ext From f2a0cd6c1e7513b73bee926d9195897dca26701b Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Wed, 15 Jul 2020 17:21:22 +0200 Subject: [PATCH 010/135] Make sure that imports respect grouping --- lib/Language/Haskell/Stylish/Printer.hs | 10 ++++- .../Haskell/Stylish/Printer/ModuleHeader.hs | 42 ++++++++++++------- .../Stylish/Printer/ModuleHeader/Tests.hs | 39 ++++++++++++++--- 3 files changed, 70 insertions(+), 21 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Printer.hs b/lib/Language/Haskell/Stylish/Printer.hs index 9c61daa0..96f4c903 100644 --- a/lib/Language/Haskell/Stylish/Printer.hs +++ b/lib/Language/Haskell/Stylish/Printer.hs @@ -27,6 +27,7 @@ module Language.Haskell.Stylish.Printer , spaces , suffix , indent + , peekNextCommentPos , removeLineComment , removeCommentTo -- ** Outputable helpers @@ -41,12 +42,13 @@ import Language.Haskell.Stylish.Parse (baseDynFlags) -------------------------------------------------------------------------------- import ApiAnnotation (AnnotationComment(..)) import SrcLoc (GenLocated(..), RealLocated) -import SrcLoc (srcSpanStartLine) +import SrcLoc (SrcSpan(..), srcSpanStartLine) import Control.Monad (forM_, replicateM, replicateM_) import Control.Monad.Reader (MonadReader, ReaderT(..)) import Control.Monad.State (MonadState, State) import Control.Monad.State (execState, gets, modify) import Data.Foldable (find) +import Data.Functor ((<&>)) import Data.List (delete) import GHC.Generics (Generic) import qualified Outputable as GHC @@ -157,3 +159,9 @@ removeComment p = do modify \s -> s { pendingComments = newPendingComments } pure $ fmap (\(L _ c) -> c) foundComment + +peekNextCommentPos :: P (Maybe SrcSpan) +peekNextCommentPos = do + gets pendingComments <&> \case + (L next _ : _) -> Just (RealSrcSpan next) + [] -> Nothing diff --git a/lib/Language/Haskell/Stylish/Printer/ModuleHeader.hs b/lib/Language/Haskell/Stylish/Printer/ModuleHeader.hs index b04c4272..b45b4755 100644 --- a/lib/Language/Haskell/Stylish/Printer/ModuleHeader.hs +++ b/lib/Language/Haskell/Stylish/Printer/ModuleHeader.hs @@ -9,7 +9,7 @@ module Language.Haskell.Stylish.Printer.ModuleHeader import ApiAnnotation (AnnotationComment(..)) import Control.Monad (forM_, join, when) import Data.Foldable (toList) -import Data.Function ((&), on) +import Data.Function ((&)) import Data.Functor ((<&>)) import Data.List (sortBy) import Data.Maybe (isJust) @@ -133,7 +133,7 @@ printExportList (L srcLoc exports) = do indent 2 (putText "(") >> when (notNull exports) space exportsWithComments <- - attachComments exports <&> sortBy (compareOutputable `on` snd) + attachComments exports <&> fmap (fmap (sortBy compareOutputable)) printExports exportsWithComments @@ -141,28 +141,33 @@ printExportList (L srcLoc exports) = do where putOutputable = putText . showOutputable - printExports :: [([AnnotationComment], GHC.LIE GhcPs)] -> P () - printExports (([], export) : rest) = do - printExport export + printExports :: [([AnnotationComment], [GHC.LIE GhcPs])] -> P () + printExports (([], firstInGroup : groupRest) : rest) = do + printExport firstInGroup newline spaces 2 + printExportsTail [([], groupRest)] printExportsTail rest - printExports ((firstComment : comments, export) : rest) = do + printExports ((_, []) : _rest) = + error "Expected all groups to contain at least one export, had comments, no export" + printExports ((firstComment : comments, firstExport : groupRest) : rest) = do putComment firstComment >> newline >> spaces 2 forM_ comments \c -> spaces 2 >> putComment c >> newline >> spaces 2 spaces 2 - printExport export + printExport firstExport newline spaces 2 + printExportsTail [([], groupRest)] printExportsTail rest printExports [] = newline >> spaces 2 - printExportsTail :: [([AnnotationComment], GHC.LIE GhcPs)] -> P () - printExportsTail = mapM_ \(comments, export) -> do + printExportsTail :: [([AnnotationComment], [GHC.LIE GhcPs])] -> P () + printExportsTail = mapM_ \(comments, exported) -> do forM_ comments \c -> spaces 2 >> putComment c >> newline >> spaces 2 - comma >> space >> printExport export - newline >> spaces 2 + forM_ exported \export -> do + comma >> space >> printExport export + newline >> spaces 2 printExport :: GHC.LIE GhcPs -> P () printExport (L _ export) = case export of @@ -194,9 +199,18 @@ printExportList (L srcLoc exports) = do XIE ext -> GHC.noExtCon ext -attachComments :: [GHC.LIE GhcPs] -> P [([AnnotationComment], GHC.LIE GhcPs)] +attachComments :: [GHC.LIE GhcPs] -> P [([AnnotationComment], [GHC.LIE GhcPs])] attachComments (L (RealSrcSpan rloc) x : xs) = do comments <- removeCommentTo (srcSpanStartLine rloc) - rest <- attachComments xs - pure $ (comments, L (RealSrcSpan rloc) x) : rest + nextGroupStartM <- peekNextCommentPos + + let + sameGroupOf = maybe xs \nextGroupStart -> + takeWhile (\(L p _)-> p < nextGroupStart) xs + + restOf = maybe [] \nextGroupStart -> + dropWhile (\(L p _) -> p <= nextGroupStart) xs + + restGroups <- attachComments (restOf nextGroupStartM) + pure $ (comments, L (RealSrcSpan rloc) x : sameGroupOf nextGroupStartM) : restGroups attachComments _ = pure [] diff --git a/tests/Language/Haskell/Stylish/Printer/ModuleHeader/Tests.hs b/tests/Language/Haskell/Stylish/Printer/ModuleHeader/Tests.hs index f90d6630..8a04d71b 100644 --- a/tests/Language/Haskell/Stylish/Printer/ModuleHeader/Tests.hs +++ b/tests/Language/Haskell/Stylish/Printer/ModuleHeader/Tests.hs @@ -32,6 +32,7 @@ tests = testGroup "Language.Haskell.Stylish.Printer.ModuleHeader" , testCase "Exports all" ex8 , testCase "Exports module" ex9 , testCase "Exports symbol" ex10 + , testCase "Respects groups" ex11 ] -------------------------------------------------------------------------------- @@ -162,8 +163,8 @@ ex7 = input `assertFormatted` output [ "module Foo -- Foo" , "(" , " -- * t1 something" - , " t1," , " t3," + , " t1," , " -- * t2 something" , " t2" , ") where -- x" @@ -173,9 +174,9 @@ ex7 = input `assertFormatted` output [ "module Foo -- Foo" , " ( -- * t1 something" , " t1" + , " , t3" , " -- * t2 something" , " , t2" - , " , t3" , " ) where -- x" , "-- y" ] @@ -187,10 +188,11 @@ ex8 = input `assertFormatted` output input = [ "module Foo (" , " -- * t1 something" - , " A(..)," , " t3," + , " A(..)," , " -- * t2 something" - , " t2" + , " t2," + , " t1" , ") where -- x" , "-- y" ] @@ -198,9 +200,10 @@ ex8 = input `assertFormatted` output [ "module Foo" , " ( -- * t1 something" , " A (..)" + , " , t3" , " -- * t2 something" + , " , t1" , " , t2" - , " , t3" , " ) where -- x" , "-- y" ] @@ -222,9 +225,9 @@ ex9 = input `assertFormatted` output [ "module Foo" , " ( -- * t1 something" , " module A" + , " , t3" , " -- * t2 something" , " , t2" - , " , t3" , " ) where -- x" , "-- y" ] @@ -245,6 +248,30 @@ ex10 = input `assertFormatted` output , "-- y" ] +ex11 :: Assertion +ex11 = input `assertFormatted` output + where + input = + [ "module Foo (" + , " -- group 1" + , " g1_1," + , " g1_0," + , " -- group 2" + , " g0_1," + , " g0_0" + , ") where" + ] + output = + [ "module Foo" + , " ( -- group 1" + , " g1_0" + , " , g1_1" + , " -- group 2" + , " , g0_0" + , " , g0_1" + , " ) where" + ] + -------------------------------------------------------------------------------- assertFormatted :: HasCallStack => Lines -> Lines -> Assertion assertFormatted input expected = withFrozenCallStack $ expected @=? parseAndFormat input From 58424cd69e1862d29bf34c63230432de62ae1508 Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Fri, 17 Jul 2020 00:10:58 +0200 Subject: [PATCH 011/135] Fix issue where 'where' might be repeated due to not being a part of AST --- lib/Language/Haskell/Stylish/Module.hs | 13 +++++-- .../Haskell/Stylish/Printer/ModuleHeader.hs | 36 ++++++++++++++++--- .../Stylish/Printer/ModuleHeader/Tests.hs | 15 ++++++++ 3 files changed, 56 insertions(+), 8 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Module.hs b/lib/Language/Haskell/Stylish/Module.hs index 2c3bb62c..e070ec1a 100644 --- a/lib/Language/Haskell/Stylish/Module.hs +++ b/lib/Language/Haskell/Stylish/Module.hs @@ -16,9 +16,10 @@ module Language.Haskell.Stylish.Module -- * Internal API getters , rawComments , rawImports - , rawModuleName + , rawModuleAnnotations , rawModuleExports , rawModuleHaddocks + , rawModuleName ) where -------------------------------------------------------------------------------- @@ -41,6 +42,7 @@ type Lines = [String] -- | Concrete module type data Module = Module { parsedComments :: [GHC.RealLocated GHC.AnnotationComment] + , parsedAnnotations :: [(GHC.ApiAnnKey, [GHC.SrcSpan])] , parsedModule :: GHC.Located (GHC.HsModule GhcPs) } @@ -57,7 +59,7 @@ data ModuleHeader = ModuleHeader } makeModule :: GHC.PState -> GHC.Located (GHC.HsModule GHC.GhcPs) -> Module -makeModule pstate = Module comments +makeModule pstate = Module comments annotations where comments = sort @@ -68,6 +70,8 @@ makeModule pstate = Module comments GHC.L (GHC.RealSrcSpan s) e -> Just (GHC.L s e) GHC.L (GHC.UnhelpfulSpan _) _ -> Nothing + annotations = GHC.annotations pstate + moduleDecls :: Module -> Decls moduleDecls = Decls . GHC.hsmodDecls . unLocated . parsedModule @@ -78,7 +82,7 @@ moduleImports :: Module -> Imports moduleImports = Imports . GHC.hsmodImports . unLocated . parsedModule moduleHeader :: Module -> ModuleHeader -moduleHeader (Module _ (GHC.L _ m)) = ModuleHeader +moduleHeader (Module _ _ (GHC.L _ m)) = ModuleHeader { name = GHC.hsmodName m , exports = GHC.hsmodExports m , haddocks = GHC.hsmodHaddockModHeader m @@ -105,3 +109,6 @@ rawModuleHaddocks = haddocks rawComments :: Comments -> [GHC.RealLocated GHC.AnnotationComment] rawComments (Comments xs) = xs + +rawModuleAnnotations :: Module -> [(GHC.ApiAnnKey, [GHC.SrcSpan])] +rawModuleAnnotations = parsedAnnotations diff --git a/lib/Language/Haskell/Stylish/Printer/ModuleHeader.hs b/lib/Language/Haskell/Stylish/Printer/ModuleHeader.hs index b45b4755..0ddf3b3f 100644 --- a/lib/Language/Haskell/Stylish/Printer/ModuleHeader.hs +++ b/lib/Language/Haskell/Stylish/Printer/ModuleHeader.hs @@ -6,13 +6,13 @@ module Language.Haskell.Stylish.Printer.ModuleHeader -------------------------------------------------------------------------------- -import ApiAnnotation (AnnotationComment(..)) +import ApiAnnotation (AnnotationComment(..), AnnKeywordId(..)) import Control.Monad (forM_, join, when) -import Data.Foldable (toList) +import Data.Foldable (find, toList) import Data.Function ((&)) import Data.Functor ((<&>)) -import Data.List (sortBy) -import Data.Maybe (isJust) +import Data.List (sort, sortBy) +import Data.Maybe (listToMaybe, isJust) import qualified GHC.Hs.Doc as GHC import GHC.Hs.Extension (GhcPs) import qualified GHC.Hs.Extension as GHC @@ -38,6 +38,7 @@ printModuleHeader cfg ls m = name = rawModuleName header haddocks = rawModuleHaddocks header exports = rawModuleExports header + annotations = rawModuleAnnotations m relevantComments :: [RealLocated AnnotationComment] relevantComments @@ -82,12 +83,37 @@ printModuleHeader cfg ls m = exportsBlock = join $ adjustOffsetFrom <$> nameBlock <*> getBlock exports + whereM :: Maybe SrcSpan + whereM + = annotations + & filter (\(((_, w), _)) -> w == AnnWhere) + & fmap (head . snd) -- get position of annot + & sort + & listToMaybe + + isModuleHeaderWhere :: Block a -> Bool + isModuleHeaderWhere w + = not + . overlapping + $ [w] <> toList nameBlock <> toList exportsBlock + + toLineBlock :: SrcSpan -> Block a + toLineBlock (RealSrcSpan s) = Block (srcSpanStartLine s) (srcSpanEndLine s) + toLineBlock s + = error + $ "'where' block was not a RealSrcSpan" <> show s + + whereBlock + = whereM + & fmap toLineBlock + & find isModuleHeaderWhere + mergeAdjacent (a : b : rest) | a `adjacent` b = merge a b : mergeAdjacent rest mergeAdjacent (a : rest) = a : mergeAdjacent rest mergeAdjacent [] = [] deletes = - fmap delete $ mergeAdjacent $ toList nameBlock <> toList exportsBlock + fmap delete $ mergeAdjacent $ toList nameBlock <> toList exportsBlock <> toList whereBlock startLine = maybe 1 blockStart nameBlock diff --git a/tests/Language/Haskell/Stylish/Printer/ModuleHeader/Tests.hs b/tests/Language/Haskell/Stylish/Printer/ModuleHeader/Tests.hs index 8a04d71b..e955e245 100644 --- a/tests/Language/Haskell/Stylish/Printer/ModuleHeader/Tests.hs +++ b/tests/Language/Haskell/Stylish/Printer/ModuleHeader/Tests.hs @@ -33,6 +33,7 @@ tests = testGroup "Language.Haskell.Stylish.Printer.ModuleHeader" , testCase "Exports module" ex9 , testCase "Exports symbol" ex10 , testCase "Respects groups" ex11 + , testCase "'where' not repeated in case it isn't part of exports" ex12 ] -------------------------------------------------------------------------------- @@ -272,6 +273,20 @@ ex11 = input `assertFormatted` output , " ) where" ] +ex12 :: Assertion +ex12 = input `assertFormatted` output + where + input = + [ "module Foo" + , " where" + , "-- hmm" + ] + output = + [ "module Foo" + , " where" + , "-- hmm" + ] + -------------------------------------------------------------------------------- assertFormatted :: HasCallStack => Lines -> Lines -> Assertion assertFormatted input expected = withFrozenCallStack $ expected @=? parseAndFormat input From 0c7072f6bac3af6a70d17504824a7533bb58d7dd Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Fri, 17 Jul 2020 15:21:51 +0200 Subject: [PATCH 012/135] Start moving printers into steps --- lib/Language/Haskell/Stylish.hs | 29 ++++-------- lib/Language/Haskell/Stylish/Config.hs | 44 +++++++++---------- lib/Language/Haskell/Stylish/Parse.hs | 3 +- lib/Language/Haskell/Stylish/Printer.hs | 10 +++-- lib/Language/Haskell/Stylish/Printer/Decl.hs | 6 +-- .../Haskell/Stylish/Printer/Imports.hs | 12 ++--- lib/Language/Haskell/Stylish/Step.hs | 23 +++++----- lib/Language/Haskell/Stylish/Step/Data.hs | 4 +- lib/Language/Haskell/Stylish/Step/Imports'.hs | 13 ++++++ lib/Language/Haskell/Stylish/Step/Imports.hs | 4 +- .../Haskell/Stylish/Step/LanguagePragmas.hs | 4 +- .../Stylish/{Printer => Step}/ModuleHeader.hs | 24 ++++++---- .../Haskell/Stylish/Step/SimpleAlign.hs | 2 +- lib/Language/Haskell/Stylish/Step/Squash.hs | 2 +- .../Haskell/Stylish/Step/UnicodeSyntax.hs | 4 +- stylish-haskell.cabal | 8 ++-- .../Haskell/Stylish/Printer/Imports/Tests.hs | 3 +- .../{Printer => Step}/ModuleHeader/Tests.hs | 28 +++++------- tests/Language/Haskell/Stylish/Tests/Util.hs | 19 +++++--- tests/TestSuite.hs | 4 +- 20 files changed, 124 insertions(+), 122 deletions(-) create mode 100644 lib/Language/Haskell/Stylish/Step/Imports'.hs rename lib/Language/Haskell/Stylish/{Printer => Step}/ModuleHeader.hs (95%) rename tests/Language/Haskell/Stylish/{Printer => Step}/ModuleHeader/Tests.hs (87%) diff --git a/lib/Language/Haskell/Stylish.hs b/lib/Language/Haskell/Stylish.hs index 972092b7..2610f38c 100644 --- a/lib/Language/Haskell/Stylish.hs +++ b/lib/Language/Haskell/Stylish.hs @@ -27,7 +27,6 @@ module Language.Haskell.Stylish -------------------------------------------------------------------------------- import Control.Monad (foldM) -import Data.Function ((&)) import System.Directory (doesDirectoryExist, doesFileExist, listDirectory) @@ -37,8 +36,6 @@ import System.FilePath (takeExtension -------------------------------------------------------------------------------- import Language.Haskell.Stylish.Config import Language.Haskell.Stylish.Parse -import Language.Haskell.Stylish.Printer.ModuleHeader (printModuleHeader) -import Language.Haskell.Stylish.Printer.Imports (printImports) import Language.Haskell.Stylish.Step import qualified Language.Haskell.Stylish.Step.Imports as Imports import qualified Language.Haskell.Stylish.Step.LanguagePragmas as LanguagePragmas @@ -94,26 +91,18 @@ unicodeSyntax = UnicodeSyntax.step -------------------------------------------------------------------------------- runStep :: Extensions -> Maybe FilePath -> Lines -> Step -> Either String Lines -runStep exts mfp ls _step - = parseModule exts mfp (unlines ls) - --stepFilter step ls <$> parseModule exts mfp (unlines ls) - & fmap printSteps - where - printSteps m = - printImports defaultConfig' (printModuleHeader defaultConfig' ls m) m - +runStep exts mfp ls step = + stepFilter step ls <$> parseModule exts mfp (unlines ls) -------------------------------------------------------------------------------- -runSteps :: Extensions -> Maybe FilePath -> [Step] -> Lines - -> Either String Lines +runSteps :: + Extensions + -> Maybe FilePath + -> [Step] + -> Lines + -> Either String Lines runSteps exts mfp steps ls = - if False then foldM (runStep exts mfp) ls steps - else - parseModule exts mfp (unlines ls) - & fmap printSteps - where - printSteps m = - printImports defaultConfig' (printModuleHeader defaultConfig' ls m) m + foldM (runStep exts mfp) ls steps newtype ConfigPath = ConfigPath { unConfigPath :: FilePath } diff --git a/lib/Language/Haskell/Stylish/Config.hs b/lib/Language/Haskell/Stylish/Config.hs index 28021535..9c6f795e 100644 --- a/lib/Language/Haskell/Stylish/Config.hs +++ b/lib/Language/Haskell/Stylish/Config.hs @@ -4,10 +4,6 @@ module Language.Haskell.Stylish.Config ( Extensions , Config (..) - , Config' (..) - , defaultConfig' - , DeclPrinter (..) - , ImportsPrinter (..) , defaultConfigBytes , configFilePath , loadConfig @@ -44,6 +40,8 @@ import Language.Haskell.Stylish.Config.Internal import Language.Haskell.Stylish.Step import qualified Language.Haskell.Stylish.Step.Data as Data import qualified Language.Haskell.Stylish.Step.Imports as Imports +import qualified Language.Haskell.Stylish.Step.Imports' as Imports' +import qualified Language.Haskell.Stylish.Step.ModuleHeader as ModuleHeader import qualified Language.Haskell.Stylish.Step.LanguagePragmas as LanguagePragmas import qualified Language.Haskell.Stylish.Step.SimpleAlign as SimpleAlign import qualified Language.Haskell.Stylish.Step.Squash as Squash @@ -66,24 +64,6 @@ data Config = Config , configCabal :: Bool } --------------------------------------------------------------------------------- -data Config' = Config' - { configDeclPrinter :: DeclPrinter - , configImportsPrinter :: ImportsPrinter - } - -data DeclPrinter - = DeclMinimizeDiffs - -data ImportsPrinter - = DeclMinimizeDiffsPostQualified - -defaultConfig' :: Config' -defaultConfig' = Config' - { configDeclPrinter = DeclMinimizeDiffs - , configImportsPrinter = DeclMinimizeDiffsPostQualified - } - -------------------------------------------------------------------------------- instance FromJSON Config where parseJSON = parseConfig @@ -163,7 +143,8 @@ parseConfig _ = mzero -------------------------------------------------------------------------------- catalog :: Map String (Config -> A.Object -> A.Parser Step) -catalog = M.fromList +catalog = M.fromList $ + if False then [ ("imports", parseImports) , ("records", parseRecords) , ("language_pragmas", parseLanguagePragmas) @@ -173,6 +154,10 @@ catalog = M.fromList , ("trailing_whitespace", parseTrailingWhitespace) , ("unicode_syntax", parseUnicodeSyntax) ] + else + [ ("module_header", parseModuleHeader) + , ("imports", parseImports') + ] -------------------------------------------------------------------------------- @@ -193,6 +178,12 @@ parseEnum strs _ (Just k) = case lookup k strs of Nothing -> fail $ "Unknown option: " ++ k ++ ", should be one of: " ++ intercalate ", " (map fst strs) +-------------------------------------------------------------------------------- +parseModuleHeader :: Config -> A.Object -> A.Parser Step +parseModuleHeader _ _ + = pure + . ModuleHeader.step + $ ModuleHeader.Config -------------------------------------------------------------------------------- parseSimpleAlign :: Config -> A.Object -> A.Parser Step @@ -278,6 +269,13 @@ parseImports config o = Imports.step , ("right_after", Imports.RightAfter) ] +-------------------------------------------------------------------------------- +parseImports' :: Config -> A.Object -> A.Parser Step +parseImports' _ _ + = pure + . Imports'.step + $ Imports'.Config + -------------------------------------------------------------------------------- parseLanguagePragmas :: Config -> A.Object -> A.Parser Step parseLanguagePragmas config o = LanguagePragmas.step diff --git a/lib/Language/Haskell/Stylish/Parse.hs b/lib/Language/Haskell/Stylish/Parse.hs index ff24fd96..236fd435 100644 --- a/lib/Language/Haskell/Stylish/Parse.hs +++ b/lib/Language/Haskell/Stylish/Parse.hs @@ -37,9 +37,10 @@ import System.IO.Unsafe (unsafePerformIO) import ToolSettings (ToolSettings(..)) -------------------------------------------------------------------------------- -import Language.Haskell.Stylish.Config +--import Language.Haskell.Stylish.Config import Language.Haskell.Stylish.Module +type Extensions = [String] -------------------------------------------------------------------------------- -- | Filter out lines which use CPP macros diff --git a/lib/Language/Haskell/Stylish/Printer.hs b/lib/Language/Haskell/Stylish/Printer.hs index 96f4c903..a33a2c43 100644 --- a/lib/Language/Haskell/Stylish/Printer.hs +++ b/lib/Language/Haskell/Stylish/Printer.hs @@ -6,6 +6,7 @@ {-# LANGUAGE LambdaCase #-} module Language.Haskell.Stylish.Printer ( Printer(..) + , PrinterConfig(..) , PrinterState(..) -- * Alias @@ -36,7 +37,6 @@ module Language.Haskell.Stylish.Printer ) where -------------------------------------------------------------------------------- -import Language.Haskell.Stylish.Config (Config') import Language.Haskell.Stylish.Parse (baseDynFlags) -------------------------------------------------------------------------------- @@ -59,8 +59,10 @@ import Prelude hiding (lines) type P = Printer type Lines = [String] -newtype Printer a = Printer (ReaderT Config' (State PrinterState) a) - deriving (Applicative, Functor, Monad, MonadReader Config', MonadState PrinterState) +newtype Printer a = Printer (ReaderT PrinterConfig (State PrinterState) a) + deriving (Applicative, Functor, Monad, MonadReader PrinterConfig, MonadState PrinterState) + +data PrinterConfig = PrinterConfig data PrinterState = PrinterState { lines :: Lines @@ -70,7 +72,7 @@ data PrinterState = PrinterState } deriving stock (Generic) -runPrinter :: Config' -> [RealLocated AnnotationComment] -> Printer a -> Lines +runPrinter :: PrinterConfig -> [RealLocated AnnotationComment] -> Printer a -> Lines runPrinter cfg comments (Printer printer) = let PrinterState parsedLines _ startedLine _ = runReaderT printer cfg `execState` PrinterState [] 0 "" comments diff --git a/lib/Language/Haskell/Stylish/Printer/Decl.hs b/lib/Language/Haskell/Stylish/Printer/Decl.hs index e0555e3c..4454ed70 100644 --- a/lib/Language/Haskell/Stylish/Printer/Decl.hs +++ b/lib/Language/Haskell/Stylish/Printer/Decl.hs @@ -4,11 +4,11 @@ module Language.Haskell.Stylish.Printer.Decl -------------------------------------------------------------------------------- import Language.Haskell.Stylish.Module -import Language.Haskell.Stylish.Config (Config'(..)) +import Language.Haskell.Stylish.Config (Config(..)) --import GHC.Hs.Decls --import SrcLoc (Located, GenLocated(..)) --import GHC.Hs (GhcPs) -------------------------------------------------------------------------------- -printDecls :: Config' -> Lines -> Comments -> Decls -> Lines -printDecls _ ls _ _ = ls +printDecls :: Config -> Lines -> Module -> Lines +printDecls _ ls _ = ls diff --git a/lib/Language/Haskell/Stylish/Printer/Imports.hs b/lib/Language/Haskell/Stylish/Printer/Imports.hs index 04b5e0f0..1dc40112 100644 --- a/lib/Language/Haskell/Stylish/Printer/Imports.hs +++ b/lib/Language/Haskell/Stylish/Printer/Imports.hs @@ -16,24 +16,20 @@ import RdrName import qualified SrcLoc as GHC -------------------------------------------------------------------------------- -import Language.Haskell.Stylish.Config (Config'(..), ImportsPrinter(..)) import Language.Haskell.Stylish.Module import Language.Haskell.Stylish.Printer -------------------------------------------------------------------------------- -printImports :: Config' -> Lines -> Module -> Lines -printImports cfg@(Config' {configImportsPrinter = printer}) ls m = +printImports :: cfg -> Lines -> Module -> Lines +printImports _ ls m = if True then ls else -- FIXME add comments here - runPrinter cfg [] importPrinter + runPrinter PrinterConfig [] do + forM_ (sortImportDecls importList) \imp -> printPostQualified imp >> newline where imports = moduleImports m importList = rawImports imports - importPrinter = case printer of - DeclMinimizeDiffsPostQualified -> - forM_ (sortImportDecls importList) \imp -> printPostQualified imp >> newline - -------------------------------------------------------------------------------- printPostQualified :: LImportDecl GhcPs -> P () printPostQualified decl = do diff --git a/lib/Language/Haskell/Stylish/Step.hs b/lib/Language/Haskell/Stylish/Step.hs index e5f3424d..27250af9 100644 --- a/lib/Language/Haskell/Stylish/Step.hs +++ b/lib/Language/Haskell/Stylish/Step.hs @@ -1,32 +1,29 @@ -------------------------------------------------------------------------------- module Language.Haskell.Stylish.Step ( Lines - , Module + , OldModule , Step (..) , makeStep + , oldMakeStep ) where -------------------------------------------------------------------------------- import qualified Language.Haskell.Exts as H - +import Language.Haskell.Stylish.Module -------------------------------------------------------------------------------- -type Lines = [String] - - --------------------------------------------------------------------------------- --- | Concrete module type -type Module = (H.Module H.SrcSpanInfo, [H.Comment]) - +type OldModule = (H.Module H.SrcSpanInfo, [H.Comment]) -------------------------------------------------------------------------------- data Step = Step - { stepName :: String - , stepFilter :: Lines -> Module -> Lines - } - + { stepName :: String + , stepFilter :: Lines -> Module -> Lines + } -------------------------------------------------------------------------------- makeStep :: String -> (Lines -> Module -> Lines) -> Step makeStep = Step + +oldMakeStep :: String -> (Lines -> OldModule -> Lines) -> Step +oldMakeStep = undefined diff --git a/lib/Language/Haskell/Stylish/Step/Data.hs b/lib/Language/Haskell/Stylish/Step/Data.hs index 1f7732be..f2c9a188 100644 --- a/lib/Language/Haskell/Stylish/Step/Data.hs +++ b/lib/Language/Haskell/Stylish/Step/Data.hs @@ -35,9 +35,9 @@ datas _ = [] type ChangeLine = Change String step :: Config -> Step -step cfg = makeStep "Data" (step' cfg) +step cfg = oldMakeStep "Data" (step' cfg) -step' :: Config -> Lines -> Module -> Lines +step' :: Config -> Lines -> OldModule -> Lines step' cfg ls (module', allComments) = applyChanges changes ls where datas' = datas $ fmap linesFromSrcSpan module' diff --git a/lib/Language/Haskell/Stylish/Step/Imports'.hs b/lib/Language/Haskell/Stylish/Step/Imports'.hs new file mode 100644 index 00000000..1c678203 --- /dev/null +++ b/lib/Language/Haskell/Stylish/Step/Imports'.hs @@ -0,0 +1,13 @@ +module Language.Haskell.Stylish.Step.Imports' + ( Config (..) + , step + ) where + +-------------------------------------------------------------------------------- +import Language.Haskell.Stylish.Step +import Language.Haskell.Stylish.Printer.Imports (printImports) + +data Config = Config + +step :: Config -> Step +step = makeStep "Imports" . printImports diff --git a/lib/Language/Haskell/Stylish/Step/Imports.hs b/lib/Language/Haskell/Stylish/Step/Imports.hs index 05268ba7..014035a9 100644 --- a/lib/Language/Haskell/Stylish/Step/Imports.hs +++ b/lib/Language/Haskell/Stylish/Step/Imports.hs @@ -420,11 +420,11 @@ prettyImportGroup columns align fileAlign longest imps = -------------------------------------------------------------------------------- step :: Maybe Int -> Options -> Step -step columns = makeStep "Imports" . step' columns +step columns = oldMakeStep "Imports" . step' columns -------------------------------------------------------------------------------- -step' :: Maybe Int -> Options -> Lines -> Module -> Lines +step' :: Maybe Int -> Options -> Lines -> OldModule -> Lines step' columns align ls (module', _) = applyChanges [ change block $ const $ prettyImportGroup columns align fileAlign longest importGroup diff --git a/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs b/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs index c9d461f6..64f94e2a 100644 --- a/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs +++ b/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs @@ -106,11 +106,11 @@ filterRedundant isRedundant' = snd . foldr filterRedundant' (S.empty, []) -------------------------------------------------------------------------------- step :: Maybe Int -> Style -> Bool -> Bool -> String -> Step -step = ((((makeStep "LanguagePragmas" .) .) .) .) . step' +step = ((((oldMakeStep "LanguagePragmas" .) .) .) .) . step' -------------------------------------------------------------------------------- -step' :: Maybe Int -> Style -> Bool -> Bool -> String -> Lines -> Module -> Lines +step' :: Maybe Int -> Style -> Bool -> Bool -> String -> Lines -> OldModule -> Lines step' columns style align removeRedundant lngPrefix ls (module', _) | null pragmas' = ls | otherwise = applyChanges changes ls diff --git a/lib/Language/Haskell/Stylish/Printer/ModuleHeader.hs b/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs similarity index 95% rename from lib/Language/Haskell/Stylish/Printer/ModuleHeader.hs rename to lib/Language/Haskell/Stylish/Step/ModuleHeader.hs index 0ddf3b3f..75e5d512 100644 --- a/lib/Language/Haskell/Stylish/Printer/ModuleHeader.hs +++ b/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs @@ -1,10 +1,10 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE LambdaCase #-} -module Language.Haskell.Stylish.Printer.ModuleHeader - ( printModuleHeader +module Language.Haskell.Stylish.Step.ModuleHeader + ( Config (..) + , step ) where - -------------------------------------------------------------------------------- import ApiAnnotation (AnnotationComment(..), AnnKeywordId(..)) import Control.Monad (forM_, join, when) @@ -25,14 +25,20 @@ import SrcLoc (srcSpanStartLine, srcSpanEndLi import Util (notNull) -------------------------------------------------------------------------------- +import Language.Haskell.Stylish.Block +import Language.Haskell.Stylish.Editor import Language.Haskell.Stylish.Module -import Language.Haskell.Stylish.Config (Config'(..)) import Language.Haskell.Stylish.Printer -import Language.Haskell.Stylish.Editor -import Language.Haskell.Stylish.Block +import Language.Haskell.Stylish.Step + + +data Config = Config + +step :: Config -> Step +step = makeStep "Module header" . printModuleHeader -printModuleHeader :: Config' -> Lines -> Module -> Lines -printModuleHeader cfg ls m = +printModuleHeader :: Config -> Lines -> Module -> Lines +printModuleHeader _ ls m = let header = moduleHeader m name = rawModuleName header @@ -58,7 +64,7 @@ printModuleHeader cfg ls m = _ -> xs printedModuleHeader = - runPrinter cfg relevantComments (printHeader name exports haddocks) + runPrinter PrinterConfig relevantComments (printHeader name exports haddocks) unsafeGetStart = \case (L (RealSrcSpan s) _) -> srcSpanStartLine s diff --git a/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs b/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs index 5e611232..b9de329f 100644 --- a/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs +++ b/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs @@ -109,7 +109,7 @@ fieldDeclToAlignable (H.FieldDecl ann names ty) = Just $ Alignable -------------------------------------------------------------------------------- step :: Maybe Int -> Config -> Step -step maxColumns config = makeStep "Cases" $ \ls (module', _) -> +step maxColumns config = oldMakeStep "Cases" $ \ls (module', _) -> let module'' = fmap H.srcInfoSpan module' changes search toAlign = [ change_ diff --git a/lib/Language/Haskell/Stylish/Step/Squash.hs b/lib/Language/Haskell/Stylish/Step/Squash.hs index 0eb4895a..cf3f9ef0 100644 --- a/lib/Language/Haskell/Stylish/Step/Squash.hs +++ b/lib/Language/Haskell/Stylish/Step/Squash.hs @@ -52,7 +52,7 @@ squashAlt (H.Alt _ pat rhs _) = squash pat rhs -------------------------------------------------------------------------------- step :: Step -step = makeStep "Squash" $ \ls (module', _) -> +step = oldMakeStep "Squash" $ \ls (module', _) -> let module'' = fmap H.srcInfoSpan module' changes = concat [ mapMaybe squashAlt (everything module'') diff --git a/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs b/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs index 266e8e59..0c5a7fdb 100644 --- a/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs +++ b/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs @@ -105,11 +105,11 @@ between (startRow, startCol) (endRow, endCol) needle = -------------------------------------------------------------------------------- step :: Bool -> String -> Step -step = (makeStep "UnicodeSyntax" .) . step' +step = (oldMakeStep "UnicodeSyntax" .) . step' -------------------------------------------------------------------------------- -step' :: Bool -> String -> Lines -> Module -> Lines +step' :: Bool -> String -> Lines -> OldModule -> Lines step' alp lg ls (module', _) = applyChanges changes ls where changes = (if alp then addLanguagePragma lg "UnicodeSyntax" module' else []) ++ diff --git a/stylish-haskell.cabal b/stylish-haskell.cabal index 8aecd9c8..3e25dd23 100644 --- a/stylish-haskell.cabal +++ b/stylish-haskell.cabal @@ -32,10 +32,11 @@ Library Language.Haskell.Stylish.Module Language.Haskell.Stylish.Printer Language.Haskell.Stylish.Printer.Decl - Language.Haskell.Stylish.Printer.ModuleHeader Language.Haskell.Stylish.Printer.Imports Language.Haskell.Stylish.Step.Data Language.Haskell.Stylish.Step.Imports + Language.Haskell.Stylish.Step.Imports' + Language.Haskell.Stylish.Step.ModuleHeader Language.Haskell.Stylish.Step.LanguagePragmas Language.Haskell.Stylish.Step.SimpleAlign Language.Haskell.Stylish.Step.Squash @@ -119,15 +120,16 @@ Test-suite stylish-haskell-tests Language.Haskell.Stylish.Parse.Tests Language.Haskell.Stylish.Printer Language.Haskell.Stylish.Printer.Decl - Language.Haskell.Stylish.Printer.ModuleHeader Language.Haskell.Stylish.Printer.Imports Language.Haskell.Stylish.Printer.Imports.Tests - Language.Haskell.Stylish.Printer.ModuleHeader.Tests Language.Haskell.Stylish.Step Language.Haskell.Stylish.Step.Imports + Language.Haskell.Stylish.Step.Imports' Language.Haskell.Stylish.Step.Imports.Tests Language.Haskell.Stylish.Step.Data Language.Haskell.Stylish.Step.Data.Tests + Language.Haskell.Stylish.Step.ModuleHeader + Language.Haskell.Stylish.Step.ModuleHeader.Tests Language.Haskell.Stylish.Step.LanguagePragmas Language.Haskell.Stylish.Step.LanguagePragmas.Tests Language.Haskell.Stylish.Step.SimpleAlign diff --git a/tests/Language/Haskell/Stylish/Printer/Imports/Tests.hs b/tests/Language/Haskell/Stylish/Printer/Imports/Tests.hs index 97e45113..a53f2644 100644 --- a/tests/Language/Haskell/Stylish/Printer/Imports/Tests.hs +++ b/tests/Language/Haskell/Stylish/Printer/Imports/Tests.hs @@ -12,7 +12,6 @@ import Prelude hiding (lines) -------------------------------------------------------------------------------- import Language.Haskell.Stylish.Module -import Language.Haskell.Stylish.Config (defaultConfig') import Language.Haskell.Stylish.Parse (parseModule) import Language.Haskell.Stylish.Printer.Imports (printImports) @@ -134,6 +133,6 @@ assertFormatted input expected = withFrozenCallStack $ expected @=? parseAndForm parseAndFormat lines = case parseModule [] Nothing (unlines lines) of Right parsedModule -> - printImports defaultConfig' lines parsedModule + printImports True lines parsedModule Left err -> error $ "parseAndFormat: Should've been able to parse input - " <> err diff --git a/tests/Language/Haskell/Stylish/Printer/ModuleHeader/Tests.hs b/tests/Language/Haskell/Stylish/Step/ModuleHeader/Tests.hs similarity index 87% rename from tests/Language/Haskell/Stylish/Printer/ModuleHeader/Tests.hs rename to tests/Language/Haskell/Stylish/Step/ModuleHeader/Tests.hs index e955e245..90e71c5c 100644 --- a/tests/Language/Haskell/Stylish/Printer/ModuleHeader/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/ModuleHeader/Tests.hs @@ -1,20 +1,19 @@ -module Language.Haskell.Stylish.Printer.ModuleHeader.Tests +module Language.Haskell.Stylish.Step.ModuleHeader.Tests ( tests ) where -------------------------------------------------------------------------------- -import Test.Framework (Test, testGroup) -import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit (Assertion, (@=?)) -import GHC.Stack (HasCallStack, withFrozenCallStack) -import Prelude hiding (lines) - +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit (Assertion, (@=?)) +import GHC.Stack (HasCallStack, withFrozenCallStack) +import Prelude hiding (lines) -------------------------------------------------------------------------------- import Language.Haskell.Stylish.Module -import Language.Haskell.Stylish.Config (defaultConfig') -import Language.Haskell.Stylish.Parse (parseModule) -import Language.Haskell.Stylish.Printer.ModuleHeader (printModuleHeader) +import Language.Haskell.Stylish.Tests.Util (testStep') +import Language.Haskell.Stylish.Step.ModuleHeader (step) +import qualified Language.Haskell.Stylish.Step.ModuleHeader as ModuleHeader @@ -289,11 +288,4 @@ ex12 = input `assertFormatted` output -------------------------------------------------------------------------------- assertFormatted :: HasCallStack => Lines -> Lines -> Assertion -assertFormatted input expected = withFrozenCallStack $ expected @=? parseAndFormat input - where - parseAndFormat lines = - case parseModule [] Nothing (unlines lines) of - Right parsedModule -> - printModuleHeader defaultConfig' lines parsedModule - Left err -> - error $ "parseAndFormat: Should've been able to parse input - " <> err +assertFormatted input expected = withFrozenCallStack $ expected @=? testStep' (step ModuleHeader.Config) input diff --git a/tests/Language/Haskell/Stylish/Tests/Util.hs b/tests/Language/Haskell/Stylish/Tests/Util.hs index 214220b2..aee52c64 100644 --- a/tests/Language/Haskell/Stylish/Tests/Util.hs +++ b/tests/Language/Haskell/Stylish/Tests/Util.hs @@ -1,5 +1,6 @@ module Language.Haskell.Stylish.Tests.Util ( testStep + , testStep' , withTestDirTree ) where @@ -23,12 +24,18 @@ import Language.Haskell.Stylish.Step -------------------------------------------------------------------------------- testStep :: Step -> String -> String -testStep = undefined ---testStep step str = case parseModule [] Nothing str of --- Left err -> error err --- Right module' -> unlines $ stepFilter step ls module' --- where --- ls = lines str +testStep step str = case parseModule [] Nothing str of + Left err -> error err + Right module' -> unlines $ stepFilter step ls module' + where + ls = lines str + +testStep' :: Step -> Lines -> Lines +testStep' step ls = case parseModule [] Nothing (unlines ls) of + Left err -> + error $ "parseAndFormat: Should've been able to parse input - " <> err + Right parsedModule -> + stepFilter step ls parsedModule -------------------------------------------------------------------------------- diff --git a/tests/TestSuite.hs b/tests/TestSuite.hs index 84aeb34b..fb465b85 100644 --- a/tests/TestSuite.hs +++ b/tests/TestSuite.hs @@ -13,6 +13,7 @@ import qualified Language.Haskell.Stylish.Config.Tests import qualified Language.Haskell.Stylish.Parse.Tests import qualified Language.Haskell.Stylish.Step.Data.Tests import qualified Language.Haskell.Stylish.Step.Imports.Tests +import qualified Language.Haskell.Stylish.Step.ModuleHeader.Tests import qualified Language.Haskell.Stylish.Step.LanguagePragmas.Tests import qualified Language.Haskell.Stylish.Step.SimpleAlign.Tests import qualified Language.Haskell.Stylish.Step.Squash.Tests @@ -21,7 +22,6 @@ import qualified Language.Haskell.Stylish.Step.TrailingWhitespace.Tests import qualified Language.Haskell.Stylish.Step.UnicodeSyntax.Tests import qualified Language.Haskell.Stylish.Tests import qualified Language.Haskell.Stylish.Printer.Imports.Tests -import qualified Language.Haskell.Stylish.Printer.ModuleHeader.Tests -------------------------------------------------------------------------------- @@ -31,6 +31,7 @@ main = defaultMain , Language.Haskell.Stylish.Config.Tests.tests , Language.Haskell.Stylish.Step.Data.Tests.tests , Language.Haskell.Stylish.Step.Imports.Tests.tests + , Language.Haskell.Stylish.Step.ModuleHeader.Tests.tests , Language.Haskell.Stylish.Step.LanguagePragmas.Tests.tests , Language.Haskell.Stylish.Step.SimpleAlign.Tests.tests , Language.Haskell.Stylish.Step.Squash.Tests.tests @@ -39,5 +40,4 @@ main = defaultMain , Language.Haskell.Stylish.Step.UnicodeSyntax.Tests.tests , Language.Haskell.Stylish.Tests.tests , Language.Haskell.Stylish.Printer.Imports.Tests.tests - , Language.Haskell.Stylish.Printer.ModuleHeader.Tests.tests ] From 627448aca6faa75713edd8a5813593d9705ed7a8 Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Fri, 17 Jul 2020 15:24:45 +0200 Subject: [PATCH 013/135] Remove unused decl printer --- lib/Language/Haskell/Stylish/Printer/Decl.hs | 14 -------------- stylish-haskell.cabal | 2 -- 2 files changed, 16 deletions(-) delete mode 100644 lib/Language/Haskell/Stylish/Printer/Decl.hs diff --git a/lib/Language/Haskell/Stylish/Printer/Decl.hs b/lib/Language/Haskell/Stylish/Printer/Decl.hs deleted file mode 100644 index 4454ed70..00000000 --- a/lib/Language/Haskell/Stylish/Printer/Decl.hs +++ /dev/null @@ -1,14 +0,0 @@ -module Language.Haskell.Stylish.Printer.Decl - ( printDecls - ) where - --------------------------------------------------------------------------------- -import Language.Haskell.Stylish.Module -import Language.Haskell.Stylish.Config (Config(..)) ---import GHC.Hs.Decls ---import SrcLoc (Located, GenLocated(..)) ---import GHC.Hs (GhcPs) - --------------------------------------------------------------------------------- -printDecls :: Config -> Lines -> Module -> Lines -printDecls _ ls _ = ls diff --git a/stylish-haskell.cabal b/stylish-haskell.cabal index 3e25dd23..5eded1b8 100644 --- a/stylish-haskell.cabal +++ b/stylish-haskell.cabal @@ -31,7 +31,6 @@ Library Language.Haskell.Stylish Language.Haskell.Stylish.Module Language.Haskell.Stylish.Printer - Language.Haskell.Stylish.Printer.Decl Language.Haskell.Stylish.Printer.Imports Language.Haskell.Stylish.Step.Data Language.Haskell.Stylish.Step.Imports @@ -119,7 +118,6 @@ Test-suite stylish-haskell-tests Language.Haskell.Stylish.Parse Language.Haskell.Stylish.Parse.Tests Language.Haskell.Stylish.Printer - Language.Haskell.Stylish.Printer.Decl Language.Haskell.Stylish.Printer.Imports Language.Haskell.Stylish.Printer.Imports.Tests Language.Haskell.Stylish.Step From bb8e157e6862efa59348013289f90b192d9363df Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Fri, 17 Jul 2020 15:31:41 +0200 Subject: [PATCH 014/135] Move imports printer to step --- .../Haskell/Stylish/Printer/Imports.hs | 166 ------------------ lib/Language/Haskell/Stylish/Step/Imports'.hs | 162 ++++++++++++++++- stylish-haskell.cabal | 4 +- .../Imports => Step/Imports'}/Tests.hs | 28 ++- .../Stylish/Step/ModuleHeader/Tests.hs | 16 +- tests/TestSuite.hs | 6 +- 6 files changed, 184 insertions(+), 198 deletions(-) delete mode 100644 lib/Language/Haskell/Stylish/Printer/Imports.hs rename tests/Language/Haskell/Stylish/{Printer/Imports => Step/Imports'}/Tests.hs (78%) diff --git a/lib/Language/Haskell/Stylish/Printer/Imports.hs b/lib/Language/Haskell/Stylish/Printer/Imports.hs deleted file mode 100644 index 1dc40112..00000000 --- a/lib/Language/Haskell/Stylish/Printer/Imports.hs +++ /dev/null @@ -1,166 +0,0 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE LambdaCase #-} -module Language.Haskell.Stylish.Printer.Imports - ( printImports - ) where - --------------------------------------------------------------------------------- -import Control.Monad (forM_, when) -import Data.Function ((&)) -import Data.List (sortBy) -import GHC.Hs.Extension (GhcPs) -import qualified GHC.Hs.Extension as GHC -import GHC.Hs.ImpExp -import Module (ModuleName, moduleNameString) -import RdrName -import qualified SrcLoc as GHC - --------------------------------------------------------------------------------- -import Language.Haskell.Stylish.Module -import Language.Haskell.Stylish.Printer - --------------------------------------------------------------------------------- -printImports :: cfg -> Lines -> Module -> Lines -printImports _ ls m = - if True then ls else - -- FIXME add comments here - runPrinter PrinterConfig [] do - forM_ (sortImportDecls importList) \imp -> printPostQualified imp >> newline - where - imports = moduleImports m - importList = rawImports imports - --------------------------------------------------------------------------------- -printPostQualified :: LImportDecl GhcPs -> P () -printPostQualified decl = do - let - decl' = unLocated decl - - putText "import" >> space - - when (ideclSource decl') (putText "{-# SOURCE #-}" >> space) - - when (ideclSafe decl') (putText "safe" >> space) - - putText (moduleName decl) - - when (isQualified decl) (space >> putText "qualified") - - forM_ (ideclAs decl') \(GHC.L _ name) -> - space >> putText "as" >> space >> putText (moduleNameString name) - - when (isHiding decl') (space >> putText "hiding" >> space) - - forM_ (snd <$> ideclHiding decl') \(GHC.L _ imports) -> - let - printedImports = - fmap (printImport . unLocated) (sortImportList imports) - - separated = - sep (comma >> space) - in - space >> parenthesize (separated printedImports) - --------------------------------------------------------------------------------- -printImport :: IE GhcPs -> P () -printImport = \case - IEVar _ name -> - printIeWrappedName name - IEThingAbs _ name -> - printIeWrappedName name - IEThingAll _ name -> do - printIeWrappedName name - space - putText "(..)" - IEModuleContents _ (GHC.L _ m) -> - putText (moduleNameString m) - IEThingWith _ name _wildcard imps _ -> do - printIeWrappedName name - space - parenthesize $ - sep (comma >> space) (printIeWrappedName <$> sortBy compareOutputable imps) - IEGroup _ _ _ -> - error "Language.Haskell.Stylish.Printer.Imports.printImportExport: unhandled case 'IEGroup'" - IEDoc _ _ -> - error "Language.Haskell.Stylish.Printer.Imports.printImportExport: unhandled case 'IEDoc'" - IEDocNamed _ _ -> - error "Language.Haskell.Stylish.Printer.Imports.printImportExport: unhandled case 'IEDocNamed'" - XIE ext -> - GHC.noExtCon ext - --------------------------------------------------------------------------------- -printIeWrappedName :: LIEWrappedName RdrName -> P () -printIeWrappedName lie = unLocated lie & \case - IEName n -> printRdrName n - IEPattern n -> putText "pattern" >> space >> printRdrName n - IEType n -> putText "type" >> space >> printRdrName n - -printRdrName :: GHC.Located RdrName -> P () -printRdrName (GHC.L _ n) = case n of - Unqual name -> - putText (showOutputable name) - Qual modulePrefix name -> - printModulePrefix modulePrefix >> dot >> putText (showOutputable name) - Orig _ name -> - putText (showOutputable name) - Exact name -> - putText (showOutputable name) - -printModulePrefix :: ModuleName -> P () -printModulePrefix = putText . moduleNameString - -moduleName :: LImportDecl GhcPs -> String -moduleName - = moduleNameString - . unLocated - . ideclName - . unLocated - -isQualified :: LImportDecl GhcPs -> Bool -isQualified - = (/=) NotQualified - . ideclQualified - . unLocated - -isHiding :: ImportDecl GhcPs -> Bool -isHiding - = maybe False fst - . ideclHiding - -unLocated :: GHC.Located a -> a -unLocated (GHC.L _ a) = a - -sortImportList :: [LIE GhcPs] -> [LIE GhcPs] -sortImportList = sortBy $ currycated \case - (IEVar _ n0, IEVar _ n1) -> compareOutputable n0 n1 - - (IEThingAbs _ n0, IEThingAbs _ n1) -> compareOutputable n0 n1 - (IEThingAbs _ n0, IEThingAll _ n1) -> compareOutputable n0 n1 - (IEThingAbs _ n0, IEThingWith _ n1 _ _ _) -> compareOutputable n0 n1 <> LT - - (IEThingAll _ n0, IEThingAll _ n1) -> compareOutputable n0 n1 - (IEThingAll _ n0, IEThingAbs _ n1) -> compareOutputable n0 n1 - (IEThingAll _ n0, IEThingWith _ n1 _ _ _) -> compareOutputable n0 n1 <> LT - - (IEThingWith _ n0 _ _ _, IEThingWith _ n1 _ _ _) -> compareOutputable n0 n1 - (IEThingWith _ n0 _ _ _, IEThingAll _ n1) -> compareOutputable n0 n1 <> GT - (IEThingWith _ n0 _ _ _, IEThingAbs _ n1) -> compareOutputable n0 n1 <> GT - - (IEVar _ _, _) -> GT - (_, IEVar _ _) -> LT - (IEThingAbs _ _, _) -> GT - (_, IEThingAbs _ _) -> LT - (IEThingAll _ _, _) -> GT - (_, IEThingAll _ _) -> LT - (IEThingWith _ _ _ _ _, _) -> GT - (_, IEThingWith _ _ _ _ _) -> LT - - _ -> EQ - -sortImportDecls :: [LImportDecl GhcPs] -> [LImportDecl GhcPs] -sortImportDecls = sortBy $ currycated \(a0, a1) -> - compareOutputable (ideclName a0) (ideclName a1) <> - compareOutputable a0 a1 - -currycated :: ((a, b) -> c) -> (GHC.Located a -> GHC.Located b -> c) -currycated f = \(GHC.L _ a) (GHC.L _ b) -> f (a, b) diff --git a/lib/Language/Haskell/Stylish/Step/Imports'.hs b/lib/Language/Haskell/Stylish/Step/Imports'.hs index 1c678203..b51d210c 100644 --- a/lib/Language/Haskell/Stylish/Step/Imports'.hs +++ b/lib/Language/Haskell/Stylish/Step/Imports'.hs @@ -1,13 +1,173 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE LambdaCase #-} module Language.Haskell.Stylish.Step.Imports' ( Config (..) , step ) where -------------------------------------------------------------------------------- +import Control.Monad (forM_, when) +import Data.Function ((&)) +import Data.List (sortBy) +import GHC.Hs.Extension (GhcPs) +import qualified GHC.Hs.Extension as GHC +import GHC.Hs.ImpExp +import Module (ModuleName, moduleNameString) +import RdrName +import qualified SrcLoc as GHC + +-------------------------------------------------------------------------------- +import Language.Haskell.Stylish.Module +import Language.Haskell.Stylish.Printer import Language.Haskell.Stylish.Step -import Language.Haskell.Stylish.Printer.Imports (printImports) data Config = Config step :: Config -> Step step = makeStep "Imports" . printImports + +-------------------------------------------------------------------------------- +printImports :: cfg -> Lines -> Module -> Lines +printImports _ ls m = + if True then ls else + -- FIXME add comments here + runPrinter PrinterConfig [] do + forM_ (sortImportDecls importList) \imp -> printPostQualified imp >> newline + where + imports = moduleImports m + importList = rawImports imports + +-------------------------------------------------------------------------------- +printPostQualified :: LImportDecl GhcPs -> P () +printPostQualified decl = do + let + decl' = unLocated decl + + putText "import" >> space + + when (ideclSource decl') (putText "{-# SOURCE #-}" >> space) + + when (ideclSafe decl') (putText "safe" >> space) + + putText (moduleName decl) + + when (isQualified decl) (space >> putText "qualified") + + forM_ (ideclAs decl') \(GHC.L _ name) -> + space >> putText "as" >> space >> putText (moduleNameString name) + + when (isHiding decl') (space >> putText "hiding" >> space) + + forM_ (snd <$> ideclHiding decl') \(GHC.L _ imports) -> + let + printedImports = + fmap (printImport . unLocated) (sortImportList imports) + + separated = + sep (comma >> space) + in + space >> parenthesize (separated printedImports) + +-------------------------------------------------------------------------------- +printImport :: IE GhcPs -> P () +printImport = \case + IEVar _ name -> + printIeWrappedName name + IEThingAbs _ name -> + printIeWrappedName name + IEThingAll _ name -> do + printIeWrappedName name + space + putText "(..)" + IEModuleContents _ (GHC.L _ m) -> + putText (moduleNameString m) + IEThingWith _ name _wildcard imps _ -> do + printIeWrappedName name + space + parenthesize $ + sep (comma >> space) (printIeWrappedName <$> sortBy compareOutputable imps) + IEGroup _ _ _ -> + error "Language.Haskell.Stylish.Printer.Imports.printImportExport: unhandled case 'IEGroup'" + IEDoc _ _ -> + error "Language.Haskell.Stylish.Printer.Imports.printImportExport: unhandled case 'IEDoc'" + IEDocNamed _ _ -> + error "Language.Haskell.Stylish.Printer.Imports.printImportExport: unhandled case 'IEDocNamed'" + XIE ext -> + GHC.noExtCon ext + +-------------------------------------------------------------------------------- +printIeWrappedName :: LIEWrappedName RdrName -> P () +printIeWrappedName lie = unLocated lie & \case + IEName n -> printRdrName n + IEPattern n -> putText "pattern" >> space >> printRdrName n + IEType n -> putText "type" >> space >> printRdrName n + +printRdrName :: GHC.Located RdrName -> P () +printRdrName (GHC.L _ n) = case n of + Unqual name -> + putText (showOutputable name) + Qual modulePrefix name -> + printModulePrefix modulePrefix >> dot >> putText (showOutputable name) + Orig _ name -> + putText (showOutputable name) + Exact name -> + putText (showOutputable name) + +printModulePrefix :: ModuleName -> P () +printModulePrefix = putText . moduleNameString + +moduleName :: LImportDecl GhcPs -> String +moduleName + = moduleNameString + . unLocated + . ideclName + . unLocated + +isQualified :: LImportDecl GhcPs -> Bool +isQualified + = (/=) NotQualified + . ideclQualified + . unLocated + +isHiding :: ImportDecl GhcPs -> Bool +isHiding + = maybe False fst + . ideclHiding + +unLocated :: GHC.Located a -> a +unLocated (GHC.L _ a) = a + +sortImportList :: [LIE GhcPs] -> [LIE GhcPs] +sortImportList = sortBy $ currycated \case + (IEVar _ n0, IEVar _ n1) -> compareOutputable n0 n1 + + (IEThingAbs _ n0, IEThingAbs _ n1) -> compareOutputable n0 n1 + (IEThingAbs _ n0, IEThingAll _ n1) -> compareOutputable n0 n1 + (IEThingAbs _ n0, IEThingWith _ n1 _ _ _) -> compareOutputable n0 n1 <> LT + + (IEThingAll _ n0, IEThingAll _ n1) -> compareOutputable n0 n1 + (IEThingAll _ n0, IEThingAbs _ n1) -> compareOutputable n0 n1 + (IEThingAll _ n0, IEThingWith _ n1 _ _ _) -> compareOutputable n0 n1 <> LT + + (IEThingWith _ n0 _ _ _, IEThingWith _ n1 _ _ _) -> compareOutputable n0 n1 + (IEThingWith _ n0 _ _ _, IEThingAll _ n1) -> compareOutputable n0 n1 <> GT + (IEThingWith _ n0 _ _ _, IEThingAbs _ n1) -> compareOutputable n0 n1 <> GT + + (IEVar _ _, _) -> GT + (_, IEVar _ _) -> LT + (IEThingAbs _ _, _) -> GT + (_, IEThingAbs _ _) -> LT + (IEThingAll _ _, _) -> GT + (_, IEThingAll _ _) -> LT + (IEThingWith _ _ _ _ _, _) -> GT + (_, IEThingWith _ _ _ _ _) -> LT + + _ -> EQ + +sortImportDecls :: [LImportDecl GhcPs] -> [LImportDecl GhcPs] +sortImportDecls = sortBy $ currycated \(a0, a1) -> + compareOutputable (ideclName a0) (ideclName a1) <> + compareOutputable a0 a1 + +currycated :: ((a, b) -> c) -> (GHC.Located a -> GHC.Located b -> c) +currycated f = \(GHC.L _ a) (GHC.L _ b) -> f (a, b) diff --git a/stylish-haskell.cabal b/stylish-haskell.cabal index 5eded1b8..5b44986a 100644 --- a/stylish-haskell.cabal +++ b/stylish-haskell.cabal @@ -31,7 +31,6 @@ Library Language.Haskell.Stylish Language.Haskell.Stylish.Module Language.Haskell.Stylish.Printer - Language.Haskell.Stylish.Printer.Imports Language.Haskell.Stylish.Step.Data Language.Haskell.Stylish.Step.Imports Language.Haskell.Stylish.Step.Imports' @@ -118,12 +117,11 @@ Test-suite stylish-haskell-tests Language.Haskell.Stylish.Parse Language.Haskell.Stylish.Parse.Tests Language.Haskell.Stylish.Printer - Language.Haskell.Stylish.Printer.Imports - Language.Haskell.Stylish.Printer.Imports.Tests Language.Haskell.Stylish.Step Language.Haskell.Stylish.Step.Imports Language.Haskell.Stylish.Step.Imports' Language.Haskell.Stylish.Step.Imports.Tests + Language.Haskell.Stylish.Step.Imports'.Tests Language.Haskell.Stylish.Step.Data Language.Haskell.Stylish.Step.Data.Tests Language.Haskell.Stylish.Step.ModuleHeader diff --git a/tests/Language/Haskell/Stylish/Printer/Imports/Tests.hs b/tests/Language/Haskell/Stylish/Step/Imports'/Tests.hs similarity index 78% rename from tests/Language/Haskell/Stylish/Printer/Imports/Tests.hs rename to tests/Language/Haskell/Stylish/Step/Imports'/Tests.hs index a53f2644..3bc447a7 100644 --- a/tests/Language/Haskell/Stylish/Printer/Imports/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Imports'/Tests.hs @@ -1,19 +1,20 @@ -module Language.Haskell.Stylish.Printer.Imports.Tests +module Language.Haskell.Stylish.Step.Imports'.Tests ( tests ) where -------------------------------------------------------------------------------- -import Test.Framework (Test, testGroup) -import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit (Assertion, (@=?)) -import GHC.Stack (HasCallStack, withFrozenCallStack) -import Prelude hiding (lines) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit (Assertion, (@=?)) +import GHC.Stack (HasCallStack, withFrozenCallStack) +import Prelude hiding (lines) -------------------------------------------------------------------------------- -import Language.Haskell.Stylish.Module -import Language.Haskell.Stylish.Parse (parseModule) -import Language.Haskell.Stylish.Printer.Imports (printImports) +import Language.Haskell.Stylish.Module +import Language.Haskell.Stylish.Step.Imports' (step) +import Language.Haskell.Stylish.Tests.Util (testStep') +import qualified Language.Haskell.Stylish.Step.Imports' as Imports @@ -128,11 +129,4 @@ ex6 = input `assertFormatted` output -------------------------------------------------------------------------------- assertFormatted :: HasCallStack => Lines -> Lines -> Assertion -assertFormatted input expected = withFrozenCallStack $ expected @=? parseAndFormat input - where - parseAndFormat lines = - case parseModule [] Nothing (unlines lines) of - Right parsedModule -> - printImports True lines parsedModule - Left err -> - error $ "parseAndFormat: Should've been able to parse input - " <> err +assertFormatted input expected = withFrozenCallStack $ expected @=? testStep' (step Imports.Config) input diff --git a/tests/Language/Haskell/Stylish/Step/ModuleHeader/Tests.hs b/tests/Language/Haskell/Stylish/Step/ModuleHeader/Tests.hs index 90e71c5c..63aca024 100644 --- a/tests/Language/Haskell/Stylish/Step/ModuleHeader/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/ModuleHeader/Tests.hs @@ -3,16 +3,16 @@ module Language.Haskell.Stylish.Step.ModuleHeader.Tests ) where -------------------------------------------------------------------------------- -import Test.Framework (Test, testGroup) -import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit (Assertion, (@=?)) -import GHC.Stack (HasCallStack, withFrozenCallStack) -import Prelude hiding (lines) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit (Assertion, (@=?)) +import GHC.Stack (HasCallStack, withFrozenCallStack) +import Prelude hiding (lines) -------------------------------------------------------------------------------- -import Language.Haskell.Stylish.Module -import Language.Haskell.Stylish.Tests.Util (testStep') -import Language.Haskell.Stylish.Step.ModuleHeader (step) +import Language.Haskell.Stylish.Module +import Language.Haskell.Stylish.Tests.Util (testStep') +import Language.Haskell.Stylish.Step.ModuleHeader (step) import qualified Language.Haskell.Stylish.Step.ModuleHeader as ModuleHeader diff --git a/tests/TestSuite.hs b/tests/TestSuite.hs index fb465b85..d318cddf 100644 --- a/tests/TestSuite.hs +++ b/tests/TestSuite.hs @@ -21,7 +21,7 @@ import qualified Language.Haskell.Stylish.Step.Tabs.Tests import qualified Language.Haskell.Stylish.Step.TrailingWhitespace.Tests import qualified Language.Haskell.Stylish.Step.UnicodeSyntax.Tests import qualified Language.Haskell.Stylish.Tests -import qualified Language.Haskell.Stylish.Printer.Imports.Tests +import qualified Language.Haskell.Stylish.Step.Imports'.Tests -------------------------------------------------------------------------------- @@ -30,14 +30,14 @@ main = defaultMain [ Language.Haskell.Stylish.Parse.Tests.tests , Language.Haskell.Stylish.Config.Tests.tests , Language.Haskell.Stylish.Step.Data.Tests.tests + , Language.Haskell.Stylish.Step.Imports'.Tests.tests , Language.Haskell.Stylish.Step.Imports.Tests.tests - , Language.Haskell.Stylish.Step.ModuleHeader.Tests.tests , Language.Haskell.Stylish.Step.LanguagePragmas.Tests.tests + , Language.Haskell.Stylish.Step.ModuleHeader.Tests.tests , Language.Haskell.Stylish.Step.SimpleAlign.Tests.tests , Language.Haskell.Stylish.Step.Squash.Tests.tests , Language.Haskell.Stylish.Step.Tabs.Tests.tests , Language.Haskell.Stylish.Step.TrailingWhitespace.Tests.tests , Language.Haskell.Stylish.Step.UnicodeSyntax.Tests.tests , Language.Haskell.Stylish.Tests.tests - , Language.Haskell.Stylish.Printer.Imports.Tests.tests ] From 5ea2bbe354247a9fc3232100ef5c2cf5e53e1fe4 Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Fri, 17 Jul 2020 15:38:27 +0200 Subject: [PATCH 015/135] Enable more of the old steps and list which one need to be fixed --- lib/Language/Haskell/Stylish/Config.hs | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Config.hs b/lib/Language/Haskell/Stylish/Config.hs index 9c6f795e..a65b7035 100644 --- a/lib/Language/Haskell/Stylish/Config.hs +++ b/lib/Language/Haskell/Stylish/Config.hs @@ -155,9 +155,18 @@ catalog = M.fromList $ , ("unicode_syntax", parseUnicodeSyntax) ] else - [ ("module_header", parseModuleHeader) - , ("imports", parseImports') + -- Done: + [ ("imports", parseImports') + , ("module_header", parseModuleHeader) + , ("tabs", parseTabs) + , ("trailing_whitespace", parseTrailingWhitespace) ] + -- To be ported: + -- * data (records) + -- * language_pragmas + -- * simple_align + -- * squash + -- * unicode_syntax -------------------------------------------------------------------------------- From f66b9f2fc9a127c97bbfdd7f42ff36b7de79ab62 Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Fri, 17 Jul 2020 16:03:47 +0200 Subject: [PATCH 016/135] Make sure that module imports don't bother rest of file --- lib/Language/Haskell/Stylish/Block.hs | 7 +++ lib/Language/Haskell/Stylish/Step/Imports'.hs | 62 +++++++++++++------ .../Haskell/Stylish/Step/ModuleHeader.hs | 15 +---- lib/Language/Haskell/Stylish/Util.hs | 17 +++++ .../Haskell/Stylish/Step/Imports'/Tests.hs | 29 +++++++++ 5 files changed, 99 insertions(+), 31 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Block.hs b/lib/Language/Haskell/Stylish/Block.hs index 46111eed..1210d6eb 100644 --- a/lib/Language/Haskell/Stylish/Block.hs +++ b/lib/Language/Haskell/Stylish/Block.hs @@ -9,6 +9,7 @@ module Language.Haskell.Stylish.Block , moveBlock , adjacent , merge + , mergeAdjacent , overlapping , groupAdjacent ) where @@ -94,3 +95,9 @@ groupAdjacent = foldr go [] go (b1, x) gs = case break (adjacent b1 . fst) gs of (_, []) -> (b1, [x]) : gs (ys, ((b2, xs) : zs)) -> (merge b1 b2, x : xs) : (ys ++ zs) + +mergeAdjacent :: [Block a] -> [Block a] +mergeAdjacent (a : b : rest) | a `adjacent` b = merge a b : mergeAdjacent rest +mergeAdjacent (a : rest) = a : mergeAdjacent rest +mergeAdjacent [] = [] + diff --git a/lib/Language/Haskell/Stylish/Step/Imports'.hs b/lib/Language/Haskell/Stylish/Step/Imports'.hs index b51d210c..d3cba8f6 100644 --- a/lib/Language/Haskell/Stylish/Step/Imports'.hs +++ b/lib/Language/Haskell/Stylish/Step/Imports'.hs @@ -8,18 +8,24 @@ module Language.Haskell.Stylish.Step.Imports' -------------------------------------------------------------------------------- import Control.Monad (forM_, when) import Data.Function ((&)) +import Data.Foldable (toList) +import Data.Maybe (listToMaybe) import Data.List (sortBy) import GHC.Hs.Extension (GhcPs) import qualified GHC.Hs.Extension as GHC import GHC.Hs.ImpExp import Module (ModuleName, moduleNameString) import RdrName -import qualified SrcLoc as GHC +import Util (lastMaybe) +import SrcLoc (Located, GenLocated(..)) -------------------------------------------------------------------------------- +import Language.Haskell.Stylish.Block import Language.Haskell.Stylish.Module import Language.Haskell.Stylish.Printer import Language.Haskell.Stylish.Step +import Language.Haskell.Stylish.Editor +import Language.Haskell.Stylish.Util (getStartLineUnsafe, getEndLineUnsafe) data Config = Config @@ -27,15 +33,35 @@ step :: Config -> Step step = makeStep "Imports" . printImports -------------------------------------------------------------------------------- -printImports :: cfg -> Lines -> Module -> Lines +printImports :: Config -> Lines -> Module -> Lines printImports _ ls m = - if True then ls else - -- FIXME add comments here - runPrinter PrinterConfig [] do - forM_ (sortImportDecls importList) \imp -> printPostQualified imp >> newline - where - imports = moduleImports m - importList = rawImports imports + let + imports = + rawImports (moduleImports m) + + importsBlock = Block + <$> importStart + <*> importEnd + + importStart + = listToMaybe imports + & fmap getStartLineUnsafe + + importEnd + = lastMaybe imports + & fmap getEndLineUnsafe + + printedImports = runPrinter PrinterConfig [] do + forM_ (sortImportDecls imports) \imp -> printPostQualified imp >> newline + in + case importStart of + Just start -> + let + deletes = fmap delete $ toList importsBlock + additions = [insert start printedImports] + in + applyChanges (deletes <> additions) ls + Nothing -> ls -------------------------------------------------------------------------------- printPostQualified :: LImportDecl GhcPs -> P () @@ -53,12 +79,12 @@ printPostQualified decl = do when (isQualified decl) (space >> putText "qualified") - forM_ (ideclAs decl') \(GHC.L _ name) -> + forM_ (ideclAs decl') \(L _ name) -> space >> putText "as" >> space >> putText (moduleNameString name) when (isHiding decl') (space >> putText "hiding" >> space) - forM_ (snd <$> ideclHiding decl') \(GHC.L _ imports) -> + forM_ (snd <$> ideclHiding decl') \(L _ imports) -> let printedImports = fmap (printImport . unLocated) (sortImportList imports) @@ -79,7 +105,7 @@ printImport = \case printIeWrappedName name space putText "(..)" - IEModuleContents _ (GHC.L _ m) -> + IEModuleContents _ (L _ m) -> putText (moduleNameString m) IEThingWith _ name _wildcard imps _ -> do printIeWrappedName name @@ -102,8 +128,8 @@ printIeWrappedName lie = unLocated lie & \case IEPattern n -> putText "pattern" >> space >> printRdrName n IEType n -> putText "type" >> space >> printRdrName n -printRdrName :: GHC.Located RdrName -> P () -printRdrName (GHC.L _ n) = case n of +printRdrName :: Located RdrName -> P () +printRdrName (L _ n) = case n of Unqual name -> putText (showOutputable name) Qual modulePrefix name -> @@ -134,8 +160,8 @@ isHiding = maybe False fst . ideclHiding -unLocated :: GHC.Located a -> a -unLocated (GHC.L _ a) = a +unLocated :: Located a -> a +unLocated (L _ a) = a sortImportList :: [LIE GhcPs] -> [LIE GhcPs] sortImportList = sortBy $ currycated \case @@ -169,5 +195,5 @@ sortImportDecls = sortBy $ currycated \(a0, a1) -> compareOutputable (ideclName a0) (ideclName a1) <> compareOutputable a0 a1 -currycated :: ((a, b) -> c) -> (GHC.Located a -> GHC.Located b -> c) -currycated f = \(GHC.L _ a) (GHC.L _ b) -> f (a, b) +currycated :: ((a, b) -> c) -> (Located a -> Located b -> c) +currycated f = \(L _ a) (L _ b) -> f (a, b) diff --git a/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs b/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs index 75e5d512..95d9c572 100644 --- a/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs +++ b/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs @@ -30,6 +30,7 @@ import Language.Haskell.Stylish.Editor import Language.Haskell.Stylish.Module import Language.Haskell.Stylish.Printer import Language.Haskell.Stylish.Step +import Language.Haskell.Stylish.Util (getStartLineUnsafe, getEndLineUnsafe) data Config = Config @@ -66,16 +67,8 @@ printModuleHeader _ ls m = printedModuleHeader = runPrinter PrinterConfig relevantComments (printHeader name exports haddocks) - unsafeGetStart = \case - (L (RealSrcSpan s) _) -> srcSpanStartLine s - _ -> error "could not get start line of block" - - unsafeGetEnd = \case - (L (RealSrcSpan s) _) -> srcSpanEndLine s - _ -> error "could not get end line of block" - getBlock loc = - Block <$> fmap unsafeGetStart loc <*> fmap unsafeGetEnd loc + Block <$> fmap getStartLineUnsafe loc <*> fmap getEndLineUnsafe loc adjustOffsetFrom :: Block a -> Block a -> Maybe (Block a) adjustOffsetFrom (Block s0 _) b2@(Block s1 e1) @@ -114,10 +107,6 @@ printModuleHeader _ ls m = & fmap toLineBlock & find isModuleHeaderWhere - mergeAdjacent (a : b : rest) | a `adjacent` b = merge a b : mergeAdjacent rest - mergeAdjacent (a : rest) = a : mergeAdjacent rest - mergeAdjacent [] = [] - deletes = fmap delete $ mergeAdjacent $ toList nameBlock <> toList exportsBlock <> toList whereBlock diff --git a/lib/Language/Haskell/Stylish/Util.hs b/lib/Language/Haskell/Stylish/Util.hs index 9883f4b5..04408cc2 100644 --- a/lib/Language/Haskell/Stylish/Util.hs +++ b/lib/Language/Haskell/Stylish/Util.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} -------------------------------------------------------------------------------- module Language.Haskell.Stylish.Util ( nameToString @@ -13,6 +14,9 @@ module Language.Haskell.Stylish.Util , wrapMaybe , wrapRestMaybe + , getStartLineUnsafe + , getEndLineUnsafe + , withHead , withInit , withTail @@ -29,6 +33,8 @@ import Data.Maybe (fromMaybe, listToMaybe, maybeToList) import Data.Typeable (cast) import qualified Language.Haskell.Exts as H +import SrcLoc (GenLocated(..), Located, SrcSpan(..)) +import SrcLoc (srcSpanStartLine, srcSpanEndLine) -------------------------------------------------------------------------------- @@ -185,3 +191,14 @@ withInit f (x : xs) = f x : withInit f xs withTail :: (a -> a) -> [a] -> [a] withTail _ [] = [] withTail f (x : xs) = x : map f xs + +getStartLineUnsafe :: Located a -> Int +getStartLineUnsafe = \case + (L (RealSrcSpan s) _) -> srcSpanStartLine s + _ -> error "could not get start line of block" + +getEndLineUnsafe :: Located a -> Int +getEndLineUnsafe = \case + (L (RealSrcSpan s) _) -> srcSpanEndLine s + _ -> error "could not get end line of block" + diff --git a/tests/Language/Haskell/Stylish/Step/Imports'/Tests.hs b/tests/Language/Haskell/Stylish/Step/Imports'/Tests.hs index 3bc447a7..2cfbf393 100644 --- a/tests/Language/Haskell/Stylish/Step/Imports'/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Imports'/Tests.hs @@ -28,6 +28,7 @@ tests = testGroup "Language.Haskell.Stylish.Printer.Imports" , testCase "Import constructor all" ex4 , testCase "Import constructor specific" ex5 , testCase "Import constructor specific sorted" ex6 + , testCase "Imports step does not change rest of file" ex7 ] -------------------------------------------------------------------------------- @@ -127,6 +128,34 @@ ex6 = input `assertFormatted` output [ "import A (X, Y, Z (X, Y, Z))" ] +ex7 :: Assertion +ex7 = input `assertFormatted` output + where + input = + [ "module Foo (tests) where" + , "import B" + , "import A (X, Z, Y)" + , "import C" + , "import qualified A as A0 (b, Y, a)" + , "import D qualified as D0 (Y, b, a)" + , "import E qualified as E0 (b, a, Y)" + , "-- hello" + , "foo :: Int" + , "foo = 1" + ] + output = + [ "module Foo (tests) where" + , "import A (X, Y, Z)" + , "import A qualified as A0 (Y, a, b)" + , "import B" + , "import C" + , "import D qualified as D0 (Y, a, b)" + , "import E qualified as E0 (Y, a, b)" + , "-- hello" + , "foo :: Int" + , "foo = 1" + ] + -------------------------------------------------------------------------------- assertFormatted :: HasCallStack => Lines -> Lines -> Assertion assertFormatted input expected = withFrozenCallStack $ expected @=? testStep' (step Imports.Config) input From d36cced4df6138a7056e87cda0e21fd2c26fc345 Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Fri, 17 Jul 2020 20:26:27 +0200 Subject: [PATCH 017/135] Factor out function to associate comments with groups of expressions --- lib/Language/Haskell/Stylish/Printer.hs | 28 ++++++++++++- .../Haskell/Stylish/Step/ModuleHeader.hs | 39 ++++++------------- 2 files changed, 39 insertions(+), 28 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Printer.hs b/lib/Language/Haskell/Stylish/Printer.hs index a33a2c43..9423300b 100644 --- a/lib/Language/Haskell/Stylish/Printer.hs +++ b/lib/Language/Haskell/Stylish/Printer.hs @@ -31,17 +31,19 @@ module Language.Haskell.Stylish.Printer , peekNextCommentPos , removeLineComment , removeCommentTo + , sortedAttachedComments -- ** Outputable helpers , showOutputable , compareOutputable ) where -------------------------------------------------------------------------------- -import Language.Haskell.Stylish.Parse (baseDynFlags) +import Language.Haskell.Stylish.Parse (baseDynFlags) -------------------------------------------------------------------------------- import ApiAnnotation (AnnotationComment(..)) import SrcLoc (GenLocated(..), RealLocated) +import SrcLoc (Located) import SrcLoc (SrcSpan(..), srcSpanStartLine) import Control.Monad (forM_, replicateM, replicateM_) import Control.Monad.Reader (MonadReader, ReaderT(..)) @@ -50,7 +52,10 @@ import Control.Monad.State (execState, gets, modify) import Data.Foldable (find) import Data.Functor ((<&>)) import Data.List (delete) +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NonEmpty import GHC.Generics (Generic) +import Outputable (Outputable) import qualified Outputable as GHC import Prelude hiding (lines) @@ -167,3 +172,24 @@ peekNextCommentPos = do gets pendingComments <&> \case (L next _ : _) -> Just (RealSrcSpan next) [] -> Nothing + +sortedAttachedComments :: Outputable a => [Located a] -> P [([AnnotationComment], NonEmpty (Located a))] +sortedAttachedComments origs = go origs <&> fmap sortGroup + where + sortGroup = fmap (NonEmpty.sortBy compareOutputable) + + go :: [Located a] -> P [([AnnotationComment], NonEmpty (Located a))] + go (L (RealSrcSpan rloc) x : xs) = do + comments <- removeCommentTo (srcSpanStartLine rloc) + nextGroupStartM <- peekNextCommentPos + + let + sameGroupOf = maybe xs \nextGroupStart -> + takeWhile (\(L p _)-> p < nextGroupStart) xs + + restOf = maybe [] \nextGroupStart -> + dropWhile (\(L p _) -> p <= nextGroupStart) xs + + restGroups <- go (restOf nextGroupStartM) + pure $ (comments, L (RealSrcSpan rloc) x :| sameGroupOf nextGroupStartM) : restGroups + go _ = pure [] diff --git a/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs b/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs index 95d9c572..6b575f0d 100644 --- a/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs +++ b/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs @@ -10,8 +10,8 @@ import ApiAnnotation (AnnotationComment(..), AnnKeyw import Control.Monad (forM_, join, when) import Data.Foldable (find, toList) import Data.Function ((&)) -import Data.Functor ((<&>)) import Data.List (sort, sortBy) +import Data.List.NonEmpty (NonEmpty(..)) import Data.Maybe (listToMaybe, isJust) import qualified GHC.Hs.Doc as GHC import GHC.Hs.Extension (GhcPs) @@ -153,8 +153,7 @@ printExportList (L srcLoc exports) = do newline indent 2 (putText "(") >> when (notNull exports) space - exportsWithComments <- - attachComments exports <&> fmap (fmap (sortBy compareOutputable)) + exportsWithComments <- sortedAttachedComments exports printExports exportsWithComments @@ -162,34 +161,36 @@ printExportList (L srcLoc exports) = do where putOutputable = putText . showOutputable - printExports :: [([AnnotationComment], [GHC.LIE GhcPs])] -> P () - printExports (([], firstInGroup : groupRest) : rest) = do + printExports :: [([AnnotationComment], NonEmpty (GHC.LIE GhcPs))] -> P () + printExports (([], firstInGroup :| groupRest) : rest) = do printExport firstInGroup newline spaces 2 - printExportsTail [([], groupRest)] + printExportsGroupTail groupRest printExportsTail rest - printExports ((_, []) : _rest) = - error "Expected all groups to contain at least one export, had comments, no export" - printExports ((firstComment : comments, firstExport : groupRest) : rest) = do + printExports ((firstComment : comments, firstExport :| groupRest) : rest) = do putComment firstComment >> newline >> spaces 2 forM_ comments \c -> spaces 2 >> putComment c >> newline >> spaces 2 spaces 2 printExport firstExport newline spaces 2 - printExportsTail [([], groupRest)] + printExportsGroupTail groupRest printExportsTail rest printExports [] = newline >> spaces 2 - printExportsTail :: [([AnnotationComment], [GHC.LIE GhcPs])] -> P () + printExportsTail :: [([AnnotationComment], NonEmpty (GHC.LIE GhcPs))] -> P () printExportsTail = mapM_ \(comments, exported) -> do forM_ comments \c -> spaces 2 >> putComment c >> newline >> spaces 2 forM_ exported \export -> do comma >> space >> printExport export newline >> spaces 2 + printExportsGroupTail :: [GHC.LIE GhcPs] -> P () + printExportsGroupTail (x : xs) = printExportsTail [([], x :| xs)] + printExportsGroupTail [] = pure () + printExport :: GHC.LIE GhcPs -> P () printExport (L _ export) = case export of IEVar _ name -> putOutputable name @@ -219,19 +220,3 @@ printExportList (L srcLoc exports) = do "Language.Haskell.Stylish.Printer.Imports.printImportExport: unhandled case 'IEDocNamed'" <> showOutputable export XIE ext -> GHC.noExtCon ext - -attachComments :: [GHC.LIE GhcPs] -> P [([AnnotationComment], [GHC.LIE GhcPs])] -attachComments (L (RealSrcSpan rloc) x : xs) = do - comments <- removeCommentTo (srcSpanStartLine rloc) - nextGroupStartM <- peekNextCommentPos - - let - sameGroupOf = maybe xs \nextGroupStart -> - takeWhile (\(L p _)-> p < nextGroupStart) xs - - restOf = maybe [] \nextGroupStart -> - dropWhile (\(L p _) -> p <= nextGroupStart) xs - - restGroups <- attachComments (restOf nextGroupStartM) - pure $ (comments, L (RealSrcSpan rloc) x : sameGroupOf nextGroupStartM) : restGroups -attachComments _ = pure [] From b9890660c7b4ffb0fc3d0d58a8db559c56220208 Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Fri, 17 Jul 2020 22:43:25 +0200 Subject: [PATCH 018/135] Make sure imports respect groups and preserve comments --- lib/Language/Haskell/Stylish/Printer.hs | 24 ++++++++++++++++--- lib/Language/Haskell/Stylish/Step/Imports'.hs | 19 +++++++++++---- .../Haskell/Stylish/Step/ModuleHeader.hs | 14 ++--------- .../Haskell/Stylish/Step/Imports'/Tests.hs | 19 +++++++++++++++ 4 files changed, 57 insertions(+), 19 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Printer.hs b/lib/Language/Haskell/Stylish/Printer.hs index 9423300b..aee577cc 100644 --- a/lib/Language/Haskell/Stylish/Printer.hs +++ b/lib/Language/Haskell/Stylish/Printer.hs @@ -32,6 +32,11 @@ module Language.Haskell.Stylish.Printer , removeLineComment , removeCommentTo , sortedAttachedComments + + -- ** Helpers + , dropAfterLocated + , dropBeforeLocated + -- ** Outputable helpers , showOutputable , compareOutputable @@ -43,8 +48,8 @@ import Language.Haskell.Stylish.Parse (baseDynFlags) -------------------------------------------------------------------------------- import ApiAnnotation (AnnotationComment(..)) import SrcLoc (GenLocated(..), RealLocated) -import SrcLoc (Located) -import SrcLoc (SrcSpan(..), srcSpanStartLine) +import SrcLoc (Located, SrcSpan(..)) +import SrcLoc (srcSpanStartLine, srcSpanEndLine) import Control.Monad (forM_, replicateM, replicateM_) import Control.Monad.Reader (MonadReader, ReaderT(..)) import Control.Monad.State (MonadState, State) @@ -192,4 +197,17 @@ sortedAttachedComments origs = go origs <&> fmap sortGroup restGroups <- go (restOf nextGroupStartM) pure $ (comments, L (RealSrcSpan rloc) x :| sameGroupOf nextGroupStartM) : restGroups - go _ = pure [] + + go _ = pure [] + +dropAfterLocated :: Maybe (Located a) -> [RealLocated b] -> [RealLocated b] +dropAfterLocated loc xs = case loc of + Just (L (RealSrcSpan rloc) _) -> + filter (\(L x _) -> srcSpanEndLine rloc >= srcSpanStartLine x) xs + _ -> xs + +dropBeforeLocated :: Maybe (Located a) -> [RealLocated b] -> [RealLocated b] +dropBeforeLocated loc xs = case loc of + Just (L (RealSrcSpan rloc) _) -> + filter (\(L x _) -> srcSpanStartLine rloc <= srcSpanEndLine x) xs + _ -> xs diff --git a/lib/Language/Haskell/Stylish/Step/Imports'.hs b/lib/Language/Haskell/Stylish/Step/Imports'.hs index d3cba8f6..587d11e0 100644 --- a/lib/Language/Haskell/Stylish/Step/Imports'.hs +++ b/lib/Language/Haskell/Stylish/Step/Imports'.hs @@ -11,6 +11,8 @@ import Data.Function ((&)) import Data.Foldable (toList) import Data.Maybe (listToMaybe) import Data.List (sortBy) +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NonEmpty import GHC.Hs.Extension (GhcPs) import qualified GHC.Hs.Extension as GHC import GHC.Hs.ImpExp @@ -39,6 +41,12 @@ printImports _ ls m = imports = rawImports (moduleImports m) + relevantComments + = moduleComments m + & rawComments + & dropAfterLocated (lastMaybe imports) + & dropBeforeLocated (listToMaybe imports) + importsBlock = Block <$> importStart <*> importEnd @@ -51,8 +59,11 @@ printImports _ ls m = = lastMaybe imports & fmap getEndLineUnsafe - printedImports = runPrinter PrinterConfig [] do - forM_ (sortImportDecls imports) \imp -> printPostQualified imp >> newline + printedImports = runPrinter PrinterConfig relevantComments do + importsWithComments <- sortedAttachedComments imports + forM_ (fmap (fmap sortImportDecls) importsWithComments) \(comments, importGroup) -> do + forM_ comments \c -> putComment c >> newline + forM_ importGroup \imp -> printPostQualified imp >> newline in case importStart of Just start -> @@ -190,8 +201,8 @@ sortImportList = sortBy $ currycated \case _ -> EQ -sortImportDecls :: [LImportDecl GhcPs] -> [LImportDecl GhcPs] -sortImportDecls = sortBy $ currycated \(a0, a1) -> +sortImportDecls :: NonEmpty (LImportDecl GhcPs) -> NonEmpty (LImportDecl GhcPs) +sortImportDecls = NonEmpty.sortBy $ currycated \(a0, a1) -> compareOutputable (ideclName a0) (ideclName a1) <> compareOutputable a0 a1 diff --git a/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs b/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs index 6b575f0d..d68b7dd9 100644 --- a/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs +++ b/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs @@ -51,18 +51,8 @@ printModuleHeader _ ls m = relevantComments = moduleComments m & rawComments - & dropAfter exports - & dropBefore name - - dropAfter loc xs = case loc of - Just (L (RealSrcSpan rloc) _) -> - filter (\(L x _) -> srcSpanEndLine rloc >= srcSpanStartLine x) xs - _ -> xs - - dropBefore loc xs = case loc of - Just (L (RealSrcSpan rloc) _) -> - filter (\(L x _) -> srcSpanStartLine rloc <= srcSpanEndLine x) xs - _ -> xs + & dropAfterLocated exports + & dropBeforeLocated name printedModuleHeader = runPrinter PrinterConfig relevantComments (printHeader name exports haddocks) diff --git a/tests/Language/Haskell/Stylish/Step/Imports'/Tests.hs b/tests/Language/Haskell/Stylish/Step/Imports'/Tests.hs index 2cfbf393..134ce926 100644 --- a/tests/Language/Haskell/Stylish/Step/Imports'/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Imports'/Tests.hs @@ -29,6 +29,7 @@ tests = testGroup "Language.Haskell.Stylish.Printer.Imports" , testCase "Import constructor specific" ex5 , testCase "Import constructor specific sorted" ex6 , testCase "Imports step does not change rest of file" ex7 + , testCase "Imports respect groups" ex8 ] -------------------------------------------------------------------------------- @@ -156,6 +157,24 @@ ex7 = input `assertFormatted` output , "foo = 1" ] +ex8 :: Assertion +ex8 = input `assertFormatted` output + where + input = + [ "import B" + , "-- Group divisor" + , "import A (X)" + , "import C" + , "import A qualified as Y (Y)" + ] + output = + [ "import B" + , "-- Group divisor" + , "import A (X)" + , "import A qualified as Y (Y)" + , "import C" + ] + -------------------------------------------------------------------------------- assertFormatted :: HasCallStack => Lines -> Lines -> Assertion assertFormatted input expected = withFrozenCallStack $ expected @=? testStep' (step Imports.Config) input From 8032ebb021032a1bd350a686d42acbf8dfd76044 Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Sat, 18 Jul 2020 07:24:32 +0200 Subject: [PATCH 019/135] Add ability to save return value of running printer --- lib/Language/Haskell/Stylish/Printer.hs | 13 +++++++++---- lib/Language/Haskell/Stylish/Step/Imports'.hs | 2 +- lib/Language/Haskell/Stylish/Step/ModuleHeader.hs | 2 +- 3 files changed, 11 insertions(+), 6 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Printer.hs b/lib/Language/Haskell/Stylish/Printer.hs index aee577cc..0cc84d30 100644 --- a/lib/Language/Haskell/Stylish/Printer.hs +++ b/lib/Language/Haskell/Stylish/Printer.hs @@ -14,6 +14,7 @@ module Language.Haskell.Stylish.Printer -- * Functions to use the printer , runPrinter + , runPrinter_ -- ** Combinators , comma @@ -53,7 +54,8 @@ import SrcLoc (srcSpanStartLine, srcSpanEndLi import Control.Monad (forM_, replicateM, replicateM_) import Control.Monad.Reader (MonadReader, ReaderT(..)) import Control.Monad.State (MonadState, State) -import Control.Monad.State (execState, gets, modify) +import Control.Monad.State (runState) +import Control.Monad.State (gets, modify) import Data.Foldable (find) import Data.Functor ((<&>)) import Data.List (delete) @@ -82,12 +84,15 @@ data PrinterState = PrinterState } deriving stock (Generic) -runPrinter :: PrinterConfig -> [RealLocated AnnotationComment] -> Printer a -> Lines +runPrinter :: PrinterConfig -> [RealLocated AnnotationComment] -> Printer a -> (a, Lines) runPrinter cfg comments (Printer printer) = let - PrinterState parsedLines _ startedLine _ = runReaderT printer cfg `execState` PrinterState [] 0 "" comments + (a, PrinterState parsedLines _ startedLine _) = runReaderT printer cfg `runState` PrinterState [] 0 "" comments in - parsedLines <> if startedLine == [] then [] else [startedLine] + (a, parsedLines <> if startedLine == [] then [] else [startedLine]) + +runPrinter_ :: PrinterConfig -> [RealLocated AnnotationComment] -> Printer a -> Lines +runPrinter_ cfg comments printer = snd (runPrinter cfg comments printer) putText :: String -> P () putText txt = do diff --git a/lib/Language/Haskell/Stylish/Step/Imports'.hs b/lib/Language/Haskell/Stylish/Step/Imports'.hs index 587d11e0..a9ca1be9 100644 --- a/lib/Language/Haskell/Stylish/Step/Imports'.hs +++ b/lib/Language/Haskell/Stylish/Step/Imports'.hs @@ -59,7 +59,7 @@ printImports _ ls m = = lastMaybe imports & fmap getEndLineUnsafe - printedImports = runPrinter PrinterConfig relevantComments do + printedImports = runPrinter_ PrinterConfig relevantComments do importsWithComments <- sortedAttachedComments imports forM_ (fmap (fmap sortImportDecls) importsWithComments) \(comments, importGroup) -> do forM_ comments \c -> putComment c >> newline diff --git a/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs b/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs index d68b7dd9..bc112a91 100644 --- a/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs +++ b/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs @@ -55,7 +55,7 @@ printModuleHeader _ ls m = & dropBeforeLocated name printedModuleHeader = - runPrinter PrinterConfig relevantComments (printHeader name exports haddocks) + runPrinter_ PrinterConfig relevantComments (printHeader name exports haddocks) getBlock loc = Block <$> fmap getStartLineUnsafe loc <*> fmap getEndLineUnsafe loc From da96a3baaab57f2465aa1fe48be6279c0096c5f4 Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Sat, 18 Jul 2020 14:25:05 +0200 Subject: [PATCH 020/135] Add GHC module for utility functions --- lib/Language/Haskell/Stylish/GHC.hs | 35 +++++++++++++++++++ lib/Language/Haskell/Stylish/Printer.hs | 18 +--------- lib/Language/Haskell/Stylish/Step/Imports'.hs | 2 +- .../Haskell/Stylish/Step/ModuleHeader.hs | 2 +- lib/Language/Haskell/Stylish/Util.hs | 17 --------- stylish-haskell.cabal | 2 ++ 6 files changed, 40 insertions(+), 36 deletions(-) create mode 100644 lib/Language/Haskell/Stylish/GHC.hs diff --git a/lib/Language/Haskell/Stylish/GHC.hs b/lib/Language/Haskell/Stylish/GHC.hs new file mode 100644 index 00000000..8910e8be --- /dev/null +++ b/lib/Language/Haskell/Stylish/GHC.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE LambdaCase #-} +-- | Utility functions for working with the GHC AST +module Language.Haskell.Stylish.GHC + ( dropAfterLocated + , dropBeforeLocated + , getEndLineUnsafe + , getStartLineUnsafe + ) where + +-------------------------------------------------------------------------------- +import SrcLoc (GenLocated(..), SrcSpan(..)) +import SrcLoc (Located, RealLocated) +import SrcLoc (srcSpanStartLine, srcSpanEndLine) + +getStartLineUnsafe :: Located a -> Int +getStartLineUnsafe = \case + (L (RealSrcSpan s) _) -> srcSpanStartLine s + _ -> error "could not get start line of block" + +getEndLineUnsafe :: Located a -> Int +getEndLineUnsafe = \case + (L (RealSrcSpan s) _) -> srcSpanEndLine s + _ -> error "could not get end line of block" + +dropAfterLocated :: Maybe (Located a) -> [RealLocated b] -> [RealLocated b] +dropAfterLocated loc xs = case loc of + Just (L (RealSrcSpan rloc) _) -> + filter (\(L x _) -> srcSpanEndLine rloc >= srcSpanStartLine x) xs + _ -> xs + +dropBeforeLocated :: Maybe (Located a) -> [RealLocated b] -> [RealLocated b] +dropBeforeLocated loc xs = case loc of + Just (L (RealSrcSpan rloc) _) -> + filter (\(L x _) -> srcSpanStartLine rloc <= srcSpanEndLine x) xs + _ -> xs diff --git a/lib/Language/Haskell/Stylish/Printer.hs b/lib/Language/Haskell/Stylish/Printer.hs index 0cc84d30..ba23968b 100644 --- a/lib/Language/Haskell/Stylish/Printer.hs +++ b/lib/Language/Haskell/Stylish/Printer.hs @@ -34,10 +34,6 @@ module Language.Haskell.Stylish.Printer , removeCommentTo , sortedAttachedComments - -- ** Helpers - , dropAfterLocated - , dropBeforeLocated - -- ** Outputable helpers , showOutputable , compareOutputable @@ -50,7 +46,7 @@ import Language.Haskell.Stylish.Parse (baseDynFlags) import ApiAnnotation (AnnotationComment(..)) import SrcLoc (GenLocated(..), RealLocated) import SrcLoc (Located, SrcSpan(..)) -import SrcLoc (srcSpanStartLine, srcSpanEndLine) +import SrcLoc (srcSpanStartLine) import Control.Monad (forM_, replicateM, replicateM_) import Control.Monad.Reader (MonadReader, ReaderT(..)) import Control.Monad.State (MonadState, State) @@ -204,15 +200,3 @@ sortedAttachedComments origs = go origs <&> fmap sortGroup pure $ (comments, L (RealSrcSpan rloc) x :| sameGroupOf nextGroupStartM) : restGroups go _ = pure [] - -dropAfterLocated :: Maybe (Located a) -> [RealLocated b] -> [RealLocated b] -dropAfterLocated loc xs = case loc of - Just (L (RealSrcSpan rloc) _) -> - filter (\(L x _) -> srcSpanEndLine rloc >= srcSpanStartLine x) xs - _ -> xs - -dropBeforeLocated :: Maybe (Located a) -> [RealLocated b] -> [RealLocated b] -dropBeforeLocated loc xs = case loc of - Just (L (RealSrcSpan rloc) _) -> - filter (\(L x _) -> srcSpanStartLine rloc <= srcSpanEndLine x) xs - _ -> xs diff --git a/lib/Language/Haskell/Stylish/Step/Imports'.hs b/lib/Language/Haskell/Stylish/Step/Imports'.hs index a9ca1be9..8c9f4376 100644 --- a/lib/Language/Haskell/Stylish/Step/Imports'.hs +++ b/lib/Language/Haskell/Stylish/Step/Imports'.hs @@ -27,7 +27,7 @@ import Language.Haskell.Stylish.Module import Language.Haskell.Stylish.Printer import Language.Haskell.Stylish.Step import Language.Haskell.Stylish.Editor -import Language.Haskell.Stylish.Util (getStartLineUnsafe, getEndLineUnsafe) +import Language.Haskell.Stylish.GHC data Config = Config diff --git a/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs b/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs index bc112a91..04dbe966 100644 --- a/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs +++ b/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs @@ -30,7 +30,7 @@ import Language.Haskell.Stylish.Editor import Language.Haskell.Stylish.Module import Language.Haskell.Stylish.Printer import Language.Haskell.Stylish.Step -import Language.Haskell.Stylish.Util (getStartLineUnsafe, getEndLineUnsafe) +import Language.Haskell.Stylish.GHC data Config = Config diff --git a/lib/Language/Haskell/Stylish/Util.hs b/lib/Language/Haskell/Stylish/Util.hs index 04408cc2..9883f4b5 100644 --- a/lib/Language/Haskell/Stylish/Util.hs +++ b/lib/Language/Haskell/Stylish/Util.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE LambdaCase #-} -------------------------------------------------------------------------------- module Language.Haskell.Stylish.Util ( nameToString @@ -14,9 +13,6 @@ module Language.Haskell.Stylish.Util , wrapMaybe , wrapRestMaybe - , getStartLineUnsafe - , getEndLineUnsafe - , withHead , withInit , withTail @@ -33,8 +29,6 @@ import Data.Maybe (fromMaybe, listToMaybe, maybeToList) import Data.Typeable (cast) import qualified Language.Haskell.Exts as H -import SrcLoc (GenLocated(..), Located, SrcSpan(..)) -import SrcLoc (srcSpanStartLine, srcSpanEndLine) -------------------------------------------------------------------------------- @@ -191,14 +185,3 @@ withInit f (x : xs) = f x : withInit f xs withTail :: (a -> a) -> [a] -> [a] withTail _ [] = [] withTail f (x : xs) = x : map f xs - -getStartLineUnsafe :: Located a -> Int -getStartLineUnsafe = \case - (L (RealSrcSpan s) _) -> srcSpanStartLine s - _ -> error "could not get start line of block" - -getEndLineUnsafe :: Located a -> Int -getEndLineUnsafe = \case - (L (RealSrcSpan s) _) -> srcSpanEndLine s - _ -> error "could not get end line of block" - diff --git a/stylish-haskell.cabal b/stylish-haskell.cabal index 5b44986a..b92cc958 100644 --- a/stylish-haskell.cabal +++ b/stylish-haskell.cabal @@ -29,6 +29,7 @@ Library Exposed-modules: Language.Haskell.Stylish + Language.Haskell.Stylish.GHC Language.Haskell.Stylish.Module Language.Haskell.Stylish.Printer Language.Haskell.Stylish.Step.Data @@ -113,6 +114,7 @@ Test-suite stylish-haskell-tests Language.Haskell.Stylish.Config.Internal Language.Haskell.Stylish.Config.Tests Language.Haskell.Stylish.Editor + Language.Haskell.Stylish.GHC Language.Haskell.Stylish.Module Language.Haskell.Stylish.Parse Language.Haskell.Stylish.Parse.Tests From a1e7cf96a94ca6622a70b63c918db871150175eb Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Sat, 18 Jul 2020 14:25:47 +0200 Subject: [PATCH 021/135] Make sure imports step respects groupings --- lib/Language/Haskell/Stylish/Module.hs | 30 +++++++- lib/Language/Haskell/Stylish/Step/Imports'.hs | 77 ++++++++++--------- .../Haskell/Stylish/Step/Imports'/Tests.hs | 23 ++++++ 3 files changed, 92 insertions(+), 38 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Module.hs b/lib/Language/Haskell/Stylish/Module.hs index e070ec1a..4bcba1a8 100644 --- a/lib/Language/Haskell/Stylish/Module.hs +++ b/lib/Language/Haskell/Stylish/Module.hs @@ -9,6 +9,7 @@ module Language.Haskell.Stylish.Module , Lines , moduleHeader , moduleImports + , moduleImportGroups , makeModule , moduleDecls , moduleComments @@ -24,15 +25,22 @@ module Language.Haskell.Stylish.Module -------------------------------------------------------------------------------- import qualified ApiAnnotation as GHC -import Data.Maybe (mapMaybe) +import Data.Function ((&)) +import Data.Maybe (listToMaybe, mapMaybe) import Data.List (sort) import qualified Lexer as GHC import qualified GHC.Hs as GHC import GHC.Hs.Extension (GhcPs) import GHC.Hs.Decls (LHsDecl) import GHC.Hs.ImpExp (LImportDecl) +import SrcLoc (GenLocated(..), RealLocated) +import SrcLoc (srcSpanStartLine) import qualified SrcLoc as GHC import qualified Module as GHC +import Util (lastMaybe) + +-------------------------------------------------------------------------------- +import Language.Haskell.Stylish.GHC -------------------------------------------------------------------------------- type Lines = [String] @@ -81,6 +89,26 @@ moduleComments = Comments . parsedComments moduleImports :: Module -> Imports moduleImports = Imports . GHC.hsmodImports . unLocated . parsedModule +moduleImportGroups :: Module -> [Imports] +moduleImportGroups m = go relevantComments imports + where + relevantComments + = moduleComments m + & rawComments + & dropBeforeLocated (listToMaybe imports) + & dropAfterLocated (lastMaybe imports) + + imports = rawImports (moduleImports m) + + go :: [RealLocated GHC.AnnotationComment] -> [LImportDecl GhcPs] -> [Imports] + go (L nextCommentPos _ : commentsRest) (imp : impRest) = + let + sameGroup = takeWhile (\i -> getStartLineUnsafe i < srcSpanStartLine nextCommentPos) impRest + rest = dropWhile (\i -> getStartLineUnsafe i <= srcSpanStartLine nextCommentPos) impRest + in + Imports (imp : sameGroup) : go commentsRest rest + go _comments imps = [Imports imps] + moduleHeader :: Module -> ModuleHeader moduleHeader (Module _ _ (GHC.L _ m)) = ModuleHeader { name = GHC.hsmodName m diff --git a/lib/Language/Haskell/Stylish/Step/Imports'.hs b/lib/Language/Haskell/Stylish/Step/Imports'.hs index 8c9f4376..3d1ef28f 100644 --- a/lib/Language/Haskell/Stylish/Step/Imports'.hs +++ b/lib/Language/Haskell/Stylish/Step/Imports'.hs @@ -36,43 +36,46 @@ step = makeStep "Imports" . printImports -------------------------------------------------------------------------------- printImports :: Config -> Lines -> Module -> Lines -printImports _ ls m = - let - imports = - rawImports (moduleImports m) - - relevantComments - = moduleComments m - & rawComments - & dropAfterLocated (lastMaybe imports) - & dropBeforeLocated (listToMaybe imports) - - importsBlock = Block - <$> importStart - <*> importEnd - - importStart - = listToMaybe imports - & fmap getStartLineUnsafe - - importEnd - = lastMaybe imports - & fmap getEndLineUnsafe - - printedImports = runPrinter_ PrinterConfig relevantComments do - importsWithComments <- sortedAttachedComments imports - forM_ (fmap (fmap sortImportDecls) importsWithComments) \(comments, importGroup) -> do - forM_ comments \c -> putComment c >> newline - forM_ importGroup \imp -> printPostQualified imp >> newline - in - case importStart of - Just start -> - let - deletes = fmap delete $ toList importsBlock - additions = [insert start printedImports] - in - applyChanges (deletes <> additions) ls - Nothing -> ls +printImports _ ls m = formatForImportGroups ls (moduleImportGroups m) + +formatForImportGroups :: Lines -> [Imports] -> Lines +formatForImportGroups ls [] = ls +formatForImportGroups ls (group : rest) = formatForImportGroups formattedGroup rest + where + formattedGroup :: Lines + formattedGroup = + let + imports = + rawImports group + + relevantComments = + [] + + importsBlock = Block + <$> importStart + <*> importEnd + + importStart + = listToMaybe imports + & fmap getStartLineUnsafe + + importEnd + = lastMaybe imports + & fmap getEndLineUnsafe + + formatting = runPrinter_ PrinterConfig relevantComments do + importsWithComments <- sortedAttachedComments imports + forM_ importsWithComments \(_, importGroup) -> do + forM_ (sortImportDecls importGroup) \imp -> printPostQualified imp >> newline + in + case importStart of + Just start -> + let + deletes = fmap delete $ toList importsBlock + additions = [insert start formatting] + in + applyChanges (deletes <> additions) ls + Nothing -> ls -------------------------------------------------------------------------------- printPostQualified :: LImportDecl GhcPs -> P () diff --git a/tests/Language/Haskell/Stylish/Step/Imports'/Tests.hs b/tests/Language/Haskell/Stylish/Step/Imports'/Tests.hs index 134ce926..89e1f1f3 100644 --- a/tests/Language/Haskell/Stylish/Step/Imports'/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Imports'/Tests.hs @@ -30,6 +30,7 @@ tests = testGroup "Language.Haskell.Stylish.Printer.Imports" , testCase "Import constructor specific sorted" ex6 , testCase "Imports step does not change rest of file" ex7 , testCase "Imports respect groups" ex8 + , testCase "Imports respects whitespace between groups" ex9 ] -------------------------------------------------------------------------------- @@ -175,6 +176,28 @@ ex8 = input `assertFormatted` output , "import C" ] +ex9 :: Assertion +ex9 = input `assertFormatted` output + where + input = + [ "--------" + , "import B" + , "" + , "-- Group divisor" + , "import A (X)" + , "import C" + , "import A qualified as Y (Y)" + ] + output = + [ "--------" + , "import B" + , "" + , "-- Group divisor" + , "import A (X)" + , "import A qualified as Y (Y)" + , "import C" + ] + -------------------------------------------------------------------------------- assertFormatted :: HasCallStack => Lines -> Lines -> Assertion assertFormatted input expected = withFrozenCallStack $ expected @=? testStep' (step Imports.Config) input From 05167498b3dca2306d2c3e4e89f59e3d3bc37a38 Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Sat, 18 Jul 2020 14:35:05 +0200 Subject: [PATCH 022/135] Fix hiding getting an extra space --- lib/Language/Haskell/Stylish/Step/Imports'.hs | 2 +- .../Language/Haskell/Stylish/Step/Imports'/Tests.hs | 13 +++++++++++++ 2 files changed, 14 insertions(+), 1 deletion(-) diff --git a/lib/Language/Haskell/Stylish/Step/Imports'.hs b/lib/Language/Haskell/Stylish/Step/Imports'.hs index 3d1ef28f..168c3c71 100644 --- a/lib/Language/Haskell/Stylish/Step/Imports'.hs +++ b/lib/Language/Haskell/Stylish/Step/Imports'.hs @@ -96,7 +96,7 @@ printPostQualified decl = do forM_ (ideclAs decl') \(L _ name) -> space >> putText "as" >> space >> putText (moduleNameString name) - when (isHiding decl') (space >> putText "hiding" >> space) + when (isHiding decl') (space >> putText "hiding") forM_ (snd <$> ideclHiding decl') \(L _ imports) -> let diff --git a/tests/Language/Haskell/Stylish/Step/Imports'/Tests.hs b/tests/Language/Haskell/Stylish/Step/Imports'/Tests.hs index 89e1f1f3..839b1ba3 100644 --- a/tests/Language/Haskell/Stylish/Step/Imports'/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Imports'/Tests.hs @@ -31,6 +31,7 @@ tests = testGroup "Language.Haskell.Stylish.Printer.Imports" , testCase "Imports step does not change rest of file" ex7 , testCase "Imports respect groups" ex8 , testCase "Imports respects whitespace between groups" ex9 + , testCase "Doesn't add extra space after 'hiding'" ex10 ] -------------------------------------------------------------------------------- @@ -198,6 +199,18 @@ ex9 = input `assertFormatted` output , "import C" ] +ex10 :: Assertion +ex10 = input `assertFormatted` output + where + input = + [ "import B hiding (X)" + , "import A hiding (X)" + ] + output = + [ "import A hiding (X)" + , "import B hiding (X)" + ] + -------------------------------------------------------------------------------- assertFormatted :: HasCallStack => Lines -> Lines -> Assertion assertFormatted input expected = withFrozenCallStack $ expected @=? testStep' (step Imports.Config) input From 9e72c966825fbd56708b31248d803d2de9315b19 Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Sat, 18 Jul 2020 19:07:13 +0200 Subject: [PATCH 023/135] Move baseDynFlags to GHC util module --- lib/Language/Haskell/Stylish/GHC.hs | 49 +++++++++++++++++++++++-- lib/Language/Haskell/Stylish/Parse.hs | 45 +---------------------- lib/Language/Haskell/Stylish/Printer.hs | 2 +- 3 files changed, 49 insertions(+), 47 deletions(-) diff --git a/lib/Language/Haskell/Stylish/GHC.hs b/lib/Language/Haskell/Stylish/GHC.hs index 8910e8be..899d9dfb 100644 --- a/lib/Language/Haskell/Stylish/GHC.hs +++ b/lib/Language/Haskell/Stylish/GHC.hs @@ -1,16 +1,27 @@ {-# LANGUAGE LambdaCase #-} +{-# OPTIONS_GHC -Wno-missing-fields #-} -- | Utility functions for working with the GHC AST module Language.Haskell.Stylish.GHC ( dropAfterLocated , dropBeforeLocated , getEndLineUnsafe , getStartLineUnsafe + , baseDynFlags ) where -------------------------------------------------------------------------------- -import SrcLoc (GenLocated(..), SrcSpan(..)) -import SrcLoc (Located, RealLocated) -import SrcLoc (srcSpanStartLine, srcSpanEndLine) +import DynFlags (Settings(..), defaultDynFlags) +import qualified DynFlags as GHC +import FileSettings (FileSettings(..)) +import GHC.Fingerprint (fingerprint0) +import GHC.Platform +import GHC.Version (cProjectVersion) +import GhcNameVersion (GhcNameVersion(..)) +import PlatformConstants (PlatformConstants(..)) +import SrcLoc (GenLocated(..), SrcSpan(..)) +import SrcLoc (Located, RealLocated) +import SrcLoc (srcSpanStartLine, srcSpanEndLine) +import ToolSettings (ToolSettings(..)) getStartLineUnsafe :: Located a -> Int getStartLineUnsafe = \case @@ -33,3 +44,35 @@ dropBeforeLocated loc xs = case loc of Just (L (RealSrcSpan rloc) _) -> filter (\(L x _) -> srcSpanStartLine rloc <= srcSpanEndLine x) xs _ -> xs + +baseDynFlags :: GHC.DynFlags +baseDynFlags = defaultDynFlags fakeSettings llvmConfig + where + fakeSettings = GHC.Settings + { sGhcNameVersion = GhcNameVersion "stylish-haskell" cProjectVersion + , sFileSettings = FileSettings {} + , sToolSettings = ToolSettings + { toolSettings_opt_P_fingerprint = fingerprint0, + toolSettings_pgm_F = "" + } + , sPlatformConstants = PlatformConstants + { pc_DYNAMIC_BY_DEFAULT = False + , pc_WORD_SIZE = 8 + } + , sTargetPlatform = Platform + { platformMini = PlatformMini + { platformMini_arch = ArchUnknown + , platformMini_os = OSUnknown + } + , platformWordSize = PW8 + , platformUnregisterised = True + , platformHasIdentDirective = False + , platformHasSubsectionsViaSymbols = False + , platformIsCrossCompiling = False + } + , sPlatformMisc = PlatformMisc {} + , sRawSettings = [] + } + + llvmConfig = GHC.LlvmConfig [] [] + diff --git a/lib/Language/Haskell/Stylish/Parse.hs b/lib/Language/Haskell/Stylish/Parse.hs index 236fd435..ae445368 100644 --- a/lib/Language/Haskell/Stylish/Parse.hs +++ b/lib/Language/Haskell/Stylish/Parse.hs @@ -1,9 +1,7 @@ {-# LANGUAGE LambdaCase #-} -{-# OPTIONS_GHC -Wno-missing-fields #-} -------------------------------------------------------------------------------- module Language.Haskell.Stylish.Parse ( parseModule - , baseDynFlags -- FIXME should be moved ) where @@ -11,16 +9,10 @@ module Language.Haskell.Stylish.Parse import Bag (bagToList) import Data.Function ((&)) import Data.Maybe (fromMaybe, listToMaybe) -import DynFlags (Settings(..), defaultDynFlags) import qualified DynFlags as GHC import FastString (mkFastString) -import FileSettings (FileSettings(..)) -import GHC.Fingerprint (fingerprint0) import qualified GHC.Hs as GHC import qualified GHC.LanguageExtensions as GHC -import GHC.Platform -import GHC.Version (cProjectVersion) -import GhcNameVersion (GhcNameVersion(..)) import qualified HeaderInfo as GHC import qualified HscTypes as GHC import Lexer (ParseResult(..)) @@ -28,16 +20,14 @@ import Lexer (mkPState, unP) import qualified Lexer as GHC import qualified Panic as GHC import qualified Parser as GHC -import PlatformConstants (PlatformConstants(..)) import SrcLoc (mkRealSrcLoc) import qualified SrcLoc as GHC import StringBuffer (stringToStringBuffer) import qualified StringBuffer as GHC import System.IO.Unsafe (unsafePerformIO) -import ToolSettings (ToolSettings(..)) -------------------------------------------------------------------------------- ---import Language.Haskell.Stylish.Config +import Language.Haskell.Stylish.GHC (baseDynFlags) import Language.Haskell.Stylish.Module type Extensions = [String] @@ -86,7 +76,7 @@ parseModule exts fp string = else s userExtensions = - fmap toLocatedExtensionFlag exts + fmap toLocatedExtensionFlag ("Haskell2010" : exts) -- FIXME: do we need `Haskell2010` here? toLocatedExtensionFlag flag = "-X" <> flag @@ -108,37 +98,6 @@ parseModule exts fp string = in unP GHC.parseModule parseState -baseDynFlags :: GHC.DynFlags -baseDynFlags = defaultDynFlags fakeSettings llvmConfig - where - fakeSettings = GHC.Settings - { sGhcNameVersion = GhcNameVersion "stylish-haskell" cProjectVersion - , sFileSettings = FileSettings {} - , sToolSettings = ToolSettings - { toolSettings_opt_P_fingerprint = fingerprint0, - toolSettings_pgm_F = "" - } - , sPlatformConstants = PlatformConstants - { pc_DYNAMIC_BY_DEFAULT = False - , pc_WORD_SIZE = 8 - } - , sTargetPlatform = Platform - { platformMini = PlatformMini - { platformMini_arch = ArchUnknown - , platformMini_os = OSUnknown - } - , platformWordSize = PW8 - , platformUnregisterised = True - , platformHasIdentDirective = False - , platformHasSubsectionsViaSymbols = False - , platformIsCrossCompiling = False - } - , sPlatformMisc = PlatformMisc {} - , sRawSettings = [] - } - - llvmConfig = GHC.LlvmConfig [] [] - -- | Parse 'DynFlags' from the extra options -- -- /Note:/ this function would be IO, but we're not using any of the internal diff --git a/lib/Language/Haskell/Stylish/Printer.hs b/lib/Language/Haskell/Stylish/Printer.hs index ba23968b..ec7ccc0e 100644 --- a/lib/Language/Haskell/Stylish/Printer.hs +++ b/lib/Language/Haskell/Stylish/Printer.hs @@ -40,7 +40,7 @@ module Language.Haskell.Stylish.Printer ) where -------------------------------------------------------------------------------- -import Language.Haskell.Stylish.Parse (baseDynFlags) +import Language.Haskell.Stylish.GHC (baseDynFlags) -------------------------------------------------------------------------------- import ApiAnnotation (AnnotationComment(..)) From 30c68a028c9f512f72d2a6a8bb209d3261f0fa00 Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Sat, 18 Jul 2020 19:07:30 +0200 Subject: [PATCH 024/135] Fix printing of exports that are symbolic --- lib/Language/Haskell/Stylish/Module.hs | 34 ++++++++++++++++--- lib/Language/Haskell/Stylish/Printer.hs | 28 +++++++++------ lib/Language/Haskell/Stylish/Step/Imports'.hs | 24 ++++++++----- .../Haskell/Stylish/Step/ModuleHeader.hs | 2 +- .../Haskell/Stylish/Step/Imports'/Tests.hs | 13 +++++++ 5 files changed, 76 insertions(+), 25 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Module.hs b/lib/Language/Haskell/Stylish/Module.hs index 4bcba1a8..af53e20c 100644 --- a/lib/Language/Haskell/Stylish/Module.hs +++ b/lib/Language/Haskell/Stylish/Module.hs @@ -1,19 +1,25 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE LambdaCase #-} module Language.Haskell.Stylish.Module - ( Module + ( -- * Data types + Module , ModuleHeader , Imports , Decls , Comments , Lines + , makeModule + + -- * Getters , moduleHeader , moduleImports , moduleImportGroups - , makeModule , moduleDecls , moduleComments + -- * Annotations + , lookupAnnotation + -- * Internal API getters , rawComments , rawImports @@ -27,6 +33,8 @@ module Language.Haskell.Stylish.Module import qualified ApiAnnotation as GHC import Data.Function ((&)) import Data.Maybe (listToMaybe, mapMaybe) +import Data.Map (Map) +import qualified Data.Map as Map import Data.List (sort) import qualified Lexer as GHC import qualified GHC.Hs as GHC @@ -34,6 +42,7 @@ import GHC.Hs.Extension (GhcPs) import GHC.Hs.Decls (LHsDecl) import GHC.Hs.ImpExp (LImportDecl) import SrcLoc (GenLocated(..), RealLocated) +import SrcLoc (RealSrcSpan(..), SrcSpan(..)) import SrcLoc (srcSpanStartLine) import qualified SrcLoc as GHC import qualified Module as GHC @@ -51,6 +60,7 @@ type Lines = [String] data Module = Module { parsedComments :: [GHC.RealLocated GHC.AnnotationComment] , parsedAnnotations :: [(GHC.ApiAnnKey, [GHC.SrcSpan])] + , parsedAnnotSrcs :: Map RealSrcSpan [GHC.AnnKeywordId] , parsedModule :: GHC.Located (GHC.HsModule GhcPs) } @@ -67,7 +77,7 @@ data ModuleHeader = ModuleHeader } makeModule :: GHC.PState -> GHC.Located (GHC.HsModule GHC.GhcPs) -> Module -makeModule pstate = Module comments annotations +makeModule pstate = Module comments annotations annotationMap where comments = sort @@ -78,7 +88,17 @@ makeModule pstate = Module comments annotations GHC.L (GHC.RealSrcSpan s) e -> Just (GHC.L s e) GHC.L (GHC.UnhelpfulSpan _) _ -> Nothing - annotations = GHC.annotations pstate + annotations + = GHC.annotations pstate + + annotationMap + = GHC.annotations pstate + & mapMaybe x + & Map.fromListWith (++) + + x = \case + ((RealSrcSpan rspan, annot), _) -> Just (rspan, [annot]) + _ -> Nothing moduleDecls :: Module -> Decls moduleDecls = Decls . GHC.hsmodDecls . unLocated . parsedModule @@ -110,12 +130,16 @@ moduleImportGroups m = go relevantComments imports go _comments imps = [Imports imps] moduleHeader :: Module -> ModuleHeader -moduleHeader (Module _ _ (GHC.L _ m)) = ModuleHeader +moduleHeader (Module _ _ _ (GHC.L _ m)) = ModuleHeader { name = GHC.hsmodName m , exports = GHC.hsmodExports m , haddocks = GHC.hsmodHaddockModHeader m } +lookupAnnotation :: GHC.SrcSpan -> Module -> [GHC.AnnKeywordId] +lookupAnnotation (RealSrcSpan rspan) m = Map.findWithDefault [] rspan (parsedAnnotSrcs m) +lookupAnnotation (UnhelpfulSpan _) _ = [] + unLocated :: GHC.Located a -> a unLocated (GHC.L _ a) = a diff --git a/lib/Language/Haskell/Stylish/Printer.hs b/lib/Language/Haskell/Stylish/Printer.hs index ec7ccc0e..e4e86f6a 100644 --- a/lib/Language/Haskell/Stylish/Printer.hs +++ b/lib/Language/Haskell/Stylish/Printer.hs @@ -19,20 +19,21 @@ module Language.Haskell.Stylish.Printer -- ** Combinators , comma , dot + , getAnnot + , indent , newline , parenthesize + , peekNextCommentPos , prefix , putComment , putText + , removeCommentTo + , removeLineComment , sep + , sortedAttachedComments , space , spaces , suffix - , indent - , peekNextCommentPos - , removeLineComment - , removeCommentTo - , sortedAttachedComments -- ** Outputable helpers , showOutputable @@ -43,7 +44,7 @@ module Language.Haskell.Stylish.Printer import Language.Haskell.Stylish.GHC (baseDynFlags) -------------------------------------------------------------------------------- -import ApiAnnotation (AnnotationComment(..)) +import ApiAnnotation (AnnKeywordId, AnnotationComment(..)) import SrcLoc (GenLocated(..), RealLocated) import SrcLoc (Located, SrcSpan(..)) import SrcLoc (srcSpanStartLine) @@ -63,6 +64,7 @@ import qualified Outputable as GHC import Prelude hiding (lines) -------------------------------------------------------------------------------- +import Language.Haskell.Stylish.Module (Module, lookupAnnotation) type P = Printer type Lines = [String] @@ -77,18 +79,19 @@ data PrinterState = PrinterState , linePos :: !Int , currentLine :: String , pendingComments :: [RealLocated AnnotationComment] + , parsedModule :: Module } deriving stock (Generic) -runPrinter :: PrinterConfig -> [RealLocated AnnotationComment] -> Printer a -> (a, Lines) -runPrinter cfg comments (Printer printer) = +runPrinter :: PrinterConfig -> [RealLocated AnnotationComment] -> Module -> Printer a -> (a, Lines) +runPrinter cfg comments m (Printer printer) = let - (a, PrinterState parsedLines _ startedLine _) = runReaderT printer cfg `runState` PrinterState [] 0 "" comments + (a, PrinterState parsedLines _ startedLine _ _) = runReaderT printer cfg `runState` PrinterState [] 0 "" comments m in (a, parsedLines <> if startedLine == [] then [] else [startedLine]) -runPrinter_ :: PrinterConfig -> [RealLocated AnnotationComment] -> Printer a -> Lines -runPrinter_ cfg comments printer = snd (runPrinter cfg comments printer) +runPrinter_ :: PrinterConfig -> [RealLocated AnnotationComment] -> Module -> Printer a -> Lines +runPrinter_ cfg comments m printer = snd (runPrinter cfg comments m printer) putText :: String -> P () putText txt = do @@ -173,6 +176,9 @@ removeComment p = do modify \s -> s { pendingComments = newPendingComments } pure $ fmap (\(L _ c) -> c) foundComment +getAnnot :: SrcSpan -> P [AnnKeywordId] +getAnnot spn = gets (lookupAnnotation spn . parsedModule) + peekNextCommentPos :: P (Maybe SrcSpan) peekNextCommentPos = do gets pendingComments <&> \case diff --git a/lib/Language/Haskell/Stylish/Step/Imports'.hs b/lib/Language/Haskell/Stylish/Step/Imports'.hs index 168c3c71..1d9aa02d 100644 --- a/lib/Language/Haskell/Stylish/Step/Imports'.hs +++ b/lib/Language/Haskell/Stylish/Step/Imports'.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE LambdaCase #-} module Language.Haskell.Stylish.Step.Imports' ( Config (..) @@ -6,6 +7,7 @@ module Language.Haskell.Stylish.Step.Imports' ) where -------------------------------------------------------------------------------- +import ApiAnnotation (AnnKeywordId(..)) import Control.Monad (forM_, when) import Data.Function ((&)) import Data.Foldable (toList) @@ -36,11 +38,11 @@ step = makeStep "Imports" . printImports -------------------------------------------------------------------------------- printImports :: Config -> Lines -> Module -> Lines -printImports _ ls m = formatForImportGroups ls (moduleImportGroups m) +printImports _ ls m = formatForImportGroups ls m (moduleImportGroups m) -formatForImportGroups :: Lines -> [Imports] -> Lines -formatForImportGroups ls [] = ls -formatForImportGroups ls (group : rest) = formatForImportGroups formattedGroup rest +formatForImportGroups :: Lines -> Module -> [Imports] -> Lines +formatForImportGroups ls _m [] = ls +formatForImportGroups ls m (group : rest) = formatForImportGroups formattedGroup m rest where formattedGroup :: Lines formattedGroup = @@ -63,7 +65,7 @@ formatForImportGroups ls (group : rest) = formatForImportGroups formattedGroup r = lastMaybe imports & fmap getEndLineUnsafe - formatting = runPrinter_ PrinterConfig relevantComments do + formatting = runPrinter_ PrinterConfig relevantComments m do importsWithComments <- sortedAttachedComments imports forM_ importsWithComments \(_, importGroup) -> do forM_ (sortImportDecls importGroup) \imp -> printPostQualified imp >> newline @@ -143,9 +145,15 @@ printIeWrappedName lie = unLocated lie & \case IEType n -> putText "type" >> space >> printRdrName n printRdrName :: Located RdrName -> P () -printRdrName (L _ n) = case n of - Unqual name -> - putText (showOutputable name) +printRdrName (L pos n) = case n of + Unqual name -> do + annots <- getAnnot pos + if AnnOpenP `elem` annots then do + putText "(" + putText (showOutputable name) + putText ")" + else + putText (showOutputable name) Qual modulePrefix name -> printModulePrefix modulePrefix >> dot >> putText (showOutputable name) Orig _ name -> diff --git a/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs b/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs index 04dbe966..9e5a1ff5 100644 --- a/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs +++ b/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs @@ -55,7 +55,7 @@ printModuleHeader _ ls m = & dropBeforeLocated name printedModuleHeader = - runPrinter_ PrinterConfig relevantComments (printHeader name exports haddocks) + runPrinter_ PrinterConfig relevantComments m (printHeader name exports haddocks) getBlock loc = Block <$> fmap getStartLineUnsafe loc <*> fmap getEndLineUnsafe loc diff --git a/tests/Language/Haskell/Stylish/Step/Imports'/Tests.hs b/tests/Language/Haskell/Stylish/Step/Imports'/Tests.hs index 839b1ba3..2e370d8d 100644 --- a/tests/Language/Haskell/Stylish/Step/Imports'/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Imports'/Tests.hs @@ -32,6 +32,7 @@ tests = testGroup "Language.Haskell.Stylish.Printer.Imports" , testCase "Imports respect groups" ex8 , testCase "Imports respects whitespace between groups" ex9 , testCase "Doesn't add extra space after 'hiding'" ex10 + , testCase "Should be able to format symbolic imports" ex11 ] -------------------------------------------------------------------------------- @@ -211,6 +212,18 @@ ex10 = input `assertFormatted` output , "import B hiding (X)" ] +ex11 :: Assertion +ex11 = input `assertFormatted` output + where + input = + [ "import Data.Aeson ((.=))" + , "import A hiding (X)" + ] + output = + [ "import A hiding (X)" + , "import Data.Aeson ((.=))" + ] + -------------------------------------------------------------------------------- assertFormatted :: HasCallStack => Lines -> Lines -> Assertion assertFormatted input expected = withFrozenCallStack $ expected @=? testStep' (step Imports.Config) input From d02f0b64b8b2bed04f0435fefe16b6a8e281d348 Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Sat, 18 Jul 2020 19:20:15 +0200 Subject: [PATCH 025/135] Add span to error message for hint on where error is --- lib/Language/Haskell/Stylish/Parse.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lib/Language/Haskell/Stylish/Parse.hs b/lib/Language/Haskell/Stylish/Parse.hs index ae445368..125241ac 100644 --- a/lib/Language/Haskell/Stylish/Parse.hs +++ b/lib/Language/Haskell/Stylish/Parse.hs @@ -13,6 +13,7 @@ import qualified DynFlags as GHC import FastString (mkFastString) import qualified GHC.Hs as GHC import qualified GHC.LanguageExtensions as GHC +import qualified ErrUtils as GHC import qualified HeaderInfo as GHC import qualified HscTypes as GHC import Lexer (ParseResult(..)) @@ -85,7 +86,7 @@ parseModule exts fp string = getParserStateErrors dynFlags state = GHC.getErrorMessages state dynFlags & bagToList - & fmap show + & fmap (\errMsg -> show (GHC.errMsgSpan errMsg) <> ": " <> show errMsg) filePath = fromMaybe "" fp From f555e4fc193a9c343d31c17885238b4bfc774dd7 Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Sun, 19 Jul 2020 08:02:54 +0200 Subject: [PATCH 026/135] Add config option to emit non-zero exit code when reformatting --- lib/Language/Haskell/Stylish/Config.hs | 17 ++++++++++++++ src/Main.hs | 32 +++++++++++++++++++++----- 2 files changed, 43 insertions(+), 6 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Config.hs b/lib/Language/Haskell/Stylish/Config.hs index a65b7035..b8a5913c 100644 --- a/lib/Language/Haskell/Stylish/Config.hs +++ b/lib/Language/Haskell/Stylish/Config.hs @@ -4,6 +4,7 @@ module Language.Haskell.Stylish.Config ( Extensions , Config (..) + , ExitCodeBehavior (..) , defaultConfigBytes , configFilePath , loadConfig @@ -62,8 +63,19 @@ data Config = Config , configLanguageExtensions :: [String] , configNewline :: IO.Newline , configCabal :: Bool + , configExitCode :: ExitCodeBehavior } +-------------------------------------------------------------------------------- +data ExitCodeBehavior + = NormalExitBehavior + | ErrorOnFormatExitBehavior + deriving (Eq) + +instance Show ExitCodeBehavior where + show NormalExitBehavior = "normal" + show ErrorOnFormatExitBehavior = "error_on_format" + -------------------------------------------------------------------------------- instance FromJSON Config where parseJSON = parseConfig @@ -127,6 +139,7 @@ parseConfig (A.Object o) = do <*> (o A..:? "language_extensions" A..!= []) <*> (o A..:? "newline" >>= parseEnum newlines IO.nativeNewline) <*> (o A..:? "cabal" A..!= True) + <*> (o A..:? "exit_code" >>= parseEnum exitCodes NormalExitBehavior) -- Then fill in the steps based on the partial config we already have stepValues <- o A..: "steps" :: A.Parser [A.Value] @@ -138,6 +151,10 @@ parseConfig (A.Object o) = do , ("lf", IO.LF) , ("crlf", IO.CRLF) ] + exitCodes = + [ ("normal", NormalExitBehavior) + , ("error_on_format", ErrorOnFormatExitBehavior) + ] parseConfig _ = mzero diff --git a/src/Main.hs b/src/Main.hs index a39c735f..769d9471 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -5,7 +5,7 @@ module Main -------------------------------------------------------------------------------- -import Control.Monad (forM_, unless) +import Control.Monad (forM_, unless, when) import qualified Data.ByteString.Char8 as BC8 --import Data.Monoid ((<>)) import Data.Version (showVersion) @@ -112,7 +112,10 @@ stylishHaskell sa = do forM_ steps $ \s -> verbose' $ "Enabled " ++ stepName s ++ " step" verbose' $ "Extra language extensions: " ++ show (configLanguageExtensions conf) - mapM_ (file sa conf) $ files' filesR + res <- foldMap (file sa conf) (files' filesR) + + verbose' $ "Exit code behavior: " ++ show (configExitCode conf) + when (configExitCode conf == ErrorOnFormatExitBehavior && res == DidFormat) exitFailure where verbose' = makeVerbose (saVerbose sa) files' x = case (saRecursive sa, null x) of @@ -120,16 +123,33 @@ stylishHaskell sa = do (_,True) -> [Nothing] -- Involving IO.stdin. (_,False) -> map Just x -- Process available files. +data FormattingResult + = DidFormat + | NoChange + deriving (Eq) + +instance Semigroup FormattingResult where + _ <> DidFormat = DidFormat + DidFormat <> _ = DidFormat + _ <> _ = NoChange + +instance Monoid FormattingResult where + mempty = NoChange -------------------------------------------------------------------------------- -- | Processes a single file, or stdin if no filepath is given -file :: StylishArgs -> Config -> Maybe FilePath -> IO () +file :: StylishArgs -> Config -> Maybe FilePath -> IO FormattingResult file sa conf mfp = do contents <- maybe getContents readUTF8File mfp - let result = runSteps (configLanguageExtensions conf) - mfp (configSteps conf) $ lines contents + let + inputLines = + lines contents + result = + runSteps (configLanguageExtensions conf) mfp (configSteps conf) inputLines case result of - Right ok -> write contents $ unlines ok + Right ok -> do + write contents (unlines ok) + pure $ if ok /= inputLines then DidFormat else NoChange Left err -> do IO.hPutStrLn IO.stderr err exitFailure From 3beaf57944850795c9582d83eba02fd1bf05d62b Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Tue, 21 Jul 2020 07:50:07 +0200 Subject: [PATCH 027/135] Implement data decl step --- lib/Language/Haskell/Stylish/Config.hs | 4 +- lib/Language/Haskell/Stylish/GHC.hs | 7 + lib/Language/Haskell/Stylish/Module.hs | 7 +- lib/Language/Haskell/Stylish/Printer.hs | 103 ++++- lib/Language/Haskell/Stylish/Step/Data.hs | 382 +++++++++++++----- lib/Language/Haskell/Stylish/Step/Imports'.hs | 36 +- .../Haskell/Stylish/Step/ModuleHeader.hs | 2 - .../Haskell/Stylish/Step/Data/Tests.hs | 44 +- 8 files changed, 432 insertions(+), 153 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Config.hs b/lib/Language/Haskell/Stylish/Config.hs index b8a5913c..b01d475b 100644 --- a/lib/Language/Haskell/Stylish/Config.hs +++ b/lib/Language/Haskell/Stylish/Config.hs @@ -229,7 +229,9 @@ parseRecords _ o = Data.step <$> (o A..: "equals" >>= parseIndent) <*> (o A..: "first_field" >>= parseIndent) <*> (o A..: "field_comment") - <*> (o A..: "deriving")) + <*> (o A..: "deriving") + <*> (o A..:? "break_enums" A..!= False) + <*> (o A..:? "break_single_constructors" A..!= True)) parseIndent :: A.Value -> A.Parser Data.Indent diff --git a/lib/Language/Haskell/Stylish/GHC.hs b/lib/Language/Haskell/Stylish/GHC.hs index 899d9dfb..8ef9388c 100644 --- a/lib/Language/Haskell/Stylish/GHC.hs +++ b/lib/Language/Haskell/Stylish/GHC.hs @@ -4,9 +4,11 @@ module Language.Haskell.Stylish.GHC ( dropAfterLocated , dropBeforeLocated + , dropBeforeAndAfter , getEndLineUnsafe , getStartLineUnsafe , baseDynFlags + , unLocated ) where -------------------------------------------------------------------------------- @@ -45,6 +47,9 @@ dropBeforeLocated loc xs = case loc of filter (\(L x _) -> srcSpanStartLine rloc <= srcSpanEndLine x) xs _ -> xs +dropBeforeAndAfter :: Located a -> [RealLocated b] -> [RealLocated b] +dropBeforeAndAfter loc = dropBeforeLocated (Just loc) . dropAfterLocated (Just loc) + baseDynFlags :: GHC.DynFlags baseDynFlags = defaultDynFlags fakeSettings llvmConfig where @@ -76,3 +81,5 @@ baseDynFlags = defaultDynFlags fakeSettings llvmConfig llvmConfig = GHC.LlvmConfig [] [] +unLocated :: Located a -> a +unLocated (L _ a) = a diff --git a/lib/Language/Haskell/Stylish/Module.hs b/lib/Language/Haskell/Stylish/Module.hs index af53e20c..713a536a 100644 --- a/lib/Language/Haskell/Stylish/Module.hs +++ b/lib/Language/Haskell/Stylish/Module.hs @@ -24,6 +24,7 @@ module Language.Haskell.Stylish.Module , rawComments , rawImports , rawModuleAnnotations + , rawModuleDecls , rawModuleExports , rawModuleHaddocks , rawModuleName @@ -140,9 +141,6 @@ lookupAnnotation :: GHC.SrcSpan -> Module -> [GHC.AnnKeywordId] lookupAnnotation (RealSrcSpan rspan) m = Map.findWithDefault [] rspan (parsedAnnotSrcs m) lookupAnnotation (UnhelpfulSpan _) _ = [] -unLocated :: GHC.Located a -> a -unLocated (GHC.L _ a) = a - -------------------------------------------------------------------------------- -- | Getter for internal components in imports newtype -- @@ -159,6 +157,9 @@ rawModuleExports = exports rawModuleHaddocks :: ModuleHeader -> Maybe GHC.LHsDocString rawModuleHaddocks = haddocks +rawModuleDecls :: Decls -> [LHsDecl GhcPs] +rawModuleDecls (Decls xs) = xs + rawComments :: Comments -> [GHC.RealLocated GHC.AnnotationComment] rawComments (Comments xs) = xs diff --git a/lib/Language/Haskell/Stylish/Printer.hs b/lib/Language/Haskell/Stylish/Printer.hs index e4e86f6a..bb9f9c87 100644 --- a/lib/Language/Haskell/Stylish/Printer.hs +++ b/lib/Language/Haskell/Stylish/Printer.hs @@ -2,6 +2,7 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} module Language.Haskell.Stylish.Printer @@ -20,14 +21,20 @@ module Language.Haskell.Stylish.Printer , comma , dot , getAnnot + , getCurrentLineLength + , getDocstrPrev , indent , newline , parenthesize , peekNextCommentPos , prefix , putComment + , putEolComment + , putOutputable + , putRdrName , putText , removeCommentTo + , removeCommentToEnd , removeLineComment , sep , sortedAttachedComments @@ -44,10 +51,16 @@ module Language.Haskell.Stylish.Printer import Language.Haskell.Stylish.GHC (baseDynFlags) -------------------------------------------------------------------------------- -import ApiAnnotation (AnnKeywordId, AnnotationComment(..)) +import ApiAnnotation (AnnKeywordId(..), AnnotationComment(..)) +import Module (ModuleName, moduleNameString) +import RdrName (RdrName(..)) import SrcLoc (GenLocated(..), RealLocated) import SrcLoc (Located, SrcSpan(..)) -import SrcLoc (srcSpanStartLine) +import SrcLoc (srcSpanStartLine, srcSpanEndLine) +import Outputable (Outputable) +import qualified Outputable as GHC + +-------------------------------------------------------------------------------- import Control.Monad (forM_, replicateM, replicateM_) import Control.Monad.Reader (MonadReader, ReaderT(..)) import Control.Monad.State (MonadState, State) @@ -55,12 +68,9 @@ import Control.Monad.State (runState) import Control.Monad.State (gets, modify) import Data.Foldable (find) import Data.Functor ((<&>)) -import Data.List (delete) +import Data.List (delete, isPrefixOf) import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NonEmpty -import GHC.Generics (Generic) -import Outputable (Outputable) -import qualified Outputable as GHC import Prelude hiding (lines) -------------------------------------------------------------------------------- @@ -81,7 +91,6 @@ data PrinterState = PrinterState , pendingComments :: [RealLocated AnnotationComment] , parsedModule :: Module } - deriving stock (Generic) runPrinter :: PrinterConfig -> [RealLocated AnnotationComment] -> Module -> Printer a -> (a, Lines) runPrinter cfg comments m (Printer printer) = @@ -98,6 +107,9 @@ putText txt = do l <- gets currentLine modify \s -> s { currentLine = l <> txt } +putOutputable :: Outputable a => a -> P () +putOutputable = putText . showOutputable + putComment :: AnnotationComment -> P () putComment = \case AnnLineComment s -> putText s @@ -108,6 +120,58 @@ putComment = \case AnnDocOptions s -> putText s AnnBlockComment s -> putText s +-- | Given the current start line of 'SrcSpan', remove and put EOL comment for same line +putEolComment :: SrcSpan -> P () +putEolComment = \case + RealSrcSpan rspan -> do + cmt <- removeComment \case + L rloc (AnnLineComment s) -> + and + [ srcSpanStartLine rspan == srcSpanStartLine rloc + , not ("-- ^" `isPrefixOf` s) + , not ("-- |" `isPrefixOf` s) + ] + _ -> False + forM_ cmt (\c -> space >> putComment c) + UnhelpfulSpan _ -> pure () + +putRdrName :: Located RdrName -> P () +putRdrName (L pos n) = case n of + Unqual name -> do + annots <- getAnnot pos + if AnnOpenP `elem` annots then do + putText "(" + putText (showOutputable name) + putText ")" + else if AnnBackquote `elem` annots then do + putText "`" + putText (showOutputable name) + putText "`" + else + putText (showOutputable name) + Qual modulePrefix name -> + putModulePrefix modulePrefix >> dot >> putText (showOutputable name) + Orig _ name -> + putText (showOutputable name) + Exact name -> + putText (showOutputable name) + +getDocstrPrev :: SrcSpan -> P (Maybe AnnotationComment) +getDocstrPrev = \case + UnhelpfulSpan _ -> pure Nothing + RealSrcSpan rspan -> do + removeComment \case + L rloc (AnnLineComment s) -> + and + [ srcSpanStartLine rspan == srcSpanStartLine rloc + , "-- ^" `isPrefixOf` s + ] + _ -> False + + +putModulePrefix :: ModuleName -> P () +putModulePrefix = putText . moduleNameString + newline :: P () newline = do l <- gets currentLine @@ -153,12 +217,22 @@ removeLineComment line = removeComment (\(L rloc _) -> srcSpanStartLine rloc == line) -- | Removes comments from the state up to 'line' and returns the ones that were removed -removeCommentTo :: Int -> P [AnnotationComment] -removeCommentTo line = +removeCommentTo :: SrcSpan -> P [AnnotationComment] +removeCommentTo = \case + UnhelpfulSpan _ -> pure [] + RealSrcSpan rspan -> removeCommentTo' (srcSpanStartLine rspan) + +removeCommentToEnd :: SrcSpan -> P [AnnotationComment] +removeCommentToEnd = \case + UnhelpfulSpan _ -> pure [] + RealSrcSpan rspan -> removeCommentTo' (srcSpanEndLine rspan) + +removeCommentTo' :: Int -> P [AnnotationComment] +removeCommentTo' line = removeComment (\(L rloc _) -> srcSpanStartLine rloc < line) >>= \case Nothing -> pure [] Just c -> do - rest <- removeCommentTo line + rest <- removeCommentTo' line pure (c : rest) -- | Remove a comment from the state given predicate 'p' @@ -179,6 +253,9 @@ removeComment p = do getAnnot :: SrcSpan -> P [AnnKeywordId] getAnnot spn = gets (lookupAnnotation spn . parsedModule) +getCurrentLineLength :: P Int +getCurrentLineLength = fmap length (gets currentLine) + peekNextCommentPos :: P (Maybe SrcSpan) peekNextCommentPos = do gets pendingComments <&> \case @@ -191,8 +268,8 @@ sortedAttachedComments origs = go origs <&> fmap sortGroup sortGroup = fmap (NonEmpty.sortBy compareOutputable) go :: [Located a] -> P [([AnnotationComment], NonEmpty (Located a))] - go (L (RealSrcSpan rloc) x : xs) = do - comments <- removeCommentTo (srcSpanStartLine rloc) + go (L rspan x : xs) = do + comments <- removeCommentTo rspan nextGroupStartM <- peekNextCommentPos let @@ -203,6 +280,6 @@ sortedAttachedComments origs = go origs <&> fmap sortGroup dropWhile (\(L p _) -> p <= nextGroupStart) xs restGroups <- go (restOf nextGroupStartM) - pure $ (comments, L (RealSrcSpan rloc) x :| sameGroupOf nextGroupStartM) : restGroups + pure $ (comments, L rspan x :| sameGroupOf nextGroupStartM) : restGroups go _ = pure [] diff --git a/lib/Language/Haskell/Stylish/Step/Data.hs b/lib/Language/Haskell/Stylish/Step/Data.hs index f2c9a188..09d69c00 100644 --- a/lib/Language/Haskell/Stylish/Step/Data.hs +++ b/lib/Language/Haskell/Stylish/Step/Data.hs @@ -1,126 +1,312 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE LambdaCase #-} +module Language.Haskell.Stylish.Step.Data + ( Config(..) + , Indent(..) + , step + ) where -module Language.Haskell.Stylish.Step.Data where +-------------------------------------------------------------------------------- +import Prelude hiding (init) -import Data.List (find, intercalate) -import Data.Maybe (fromMaybe, maybeToList) -import qualified Language.Haskell.Exts as H -import Language.Haskell.Exts.Comments +-------------------------------------------------------------------------------- +import Control.Monad (forM_, unless, when) +import Data.Function ((&)) +import Data.List (foldl') +import Data.Maybe (listToMaybe, mapMaybe) + +-------------------------------------------------------------------------------- +import ApiAnnotation (AnnotationComment) +import BasicTypes (LexicalFixity(..)) +import GHC.Hs.Decls (LHsDecl, HsDecl(..), HsDataDefn(..)) +import GHC.Hs.Decls (TyClDecl(..), NewOrData(..)) +import GHC.Hs.Decls (HsDerivingClause(..), DerivStrategy(..)) +import GHC.Hs.Decls (ConDecl(..)) +import GHC.Hs.Extension (GhcPs) +import GHC.Hs.Types (ConDeclField(..)) +import GHC.Hs.Types (LHsQTyVars(..), HsTyVarBndr(..)) +import GHC.Hs.Types (HsConDetails(..), HsImplicitBndrs(..)) +import RdrName (RdrName) +import SrcLoc (Located, RealLocated) +import SrcLoc (GenLocated(..)) + +-------------------------------------------------------------------------------- import Language.Haskell.Stylish.Block import Language.Haskell.Stylish.Editor +import Language.Haskell.Stylish.GHC +import Language.Haskell.Stylish.Module +import Language.Haskell.Stylish.Printer import Language.Haskell.Stylish.Step -import Language.Haskell.Stylish.Util -import Prelude hiding (init) data Indent = SameLine | Indent !Int - deriving (Show) + deriving (Show, Eq) data Config = Config - { cEquals :: !Indent + { cEquals :: !Indent -- ^ Indent between type constructor and @=@ sign (measured from column 0) - , cFirstField :: !Indent + , cFirstField :: !Indent -- ^ Indent between data constructor and @{@ line (measured from column with data constructor name) - , cFieldComment :: !Int + , cFieldComment :: !Int -- ^ Indent between column with @{@ and start of field line comment (this line has @cFieldComment = 2@) - , cDeriving :: !Int + , cDeriving :: !Int -- ^ Indent before @deriving@ lines (measured from column 0) + , cBreakEnums :: !Bool + -- ^ Break enums by newlines and follow the above rules + , cBreakSingleConstructors :: !Bool + -- ^ Break single constructors when enabled, e.g. @Indent 2@ will not cause newline after @=@ } deriving (Show) -datas :: H.Module l -> [H.Decl l] -datas (H.Module _ _ _ _ decls) = decls -datas _ = [] +step :: Config -> Step +step cfg + = makeStep "Data" + $ \ls m -> foldl' (formatDataDecl cfg m) ls (dataDecls m) + where + dataDecls :: Module -> [Located DataDecl] + dataDecls + = mapMaybe toDataDecl + . mapMaybe toTycl + . rawModuleDecls + . moduleDecls -type ChangeLine = Change String + toTycl :: LHsDecl GhcPs -> Maybe (Located (TyClDecl GhcPs)) + toTycl = \case + L pos (TyClD _ tyClDecl) -> Just (L pos tyClDecl) + _ -> Nothing -step :: Config -> Step -step cfg = oldMakeStep "Data" (step' cfg) + toDataDecl :: Located (TyClDecl GhcPs) -> Maybe (Located DataDecl) + toDataDecl = \case + L pos (DataDecl _ name tvars fixity defn) -> Just . L pos $ MkDataDecl + { dataDeclName = name + , dataTypeVars = tvars + , dataDefn = defn + , dataFixity = fixity + } + _ -> Nothing -step' :: Config -> Lines -> OldModule -> Lines -step' cfg ls (module', allComments) = applyChanges changes ls +formatDataDecl :: Config -> Module -> Lines -> Located DataDecl -> Lines +formatDataDecl cfg m ls ldecl@(L _pos decl) = + applyChanges + [ delete originalDeclBlock + , insert (getStartLineUnsafe ldecl) printedDecl + ] + ls where - datas' = datas $ fmap linesFromSrcSpan module' - changes = datas' >>= maybeToList . changeDecl allComments cfg + relevantComments :: [RealLocated AnnotationComment] + relevantComments + = moduleComments m + & rawComments + & dropBeforeAndAfter ldecl -findCommentOnLine :: LineBlock -> [Comment] -> Maybe Comment -findCommentOnLine lb = find commentOnLine - where - commentOnLine (Comment _ (H.SrcSpan _ start _ end _) _) = - blockStart lb == start && blockEnd lb == end + defn = dataDefn decl -findCommentBelowLine :: LineBlock -> [Comment] -> Maybe Comment -findCommentBelowLine lb = find commentOnLine - where - commentOnLine (Comment _ (H.SrcSpan _ start _ end _) _) = - blockStart lb == start - 1 && blockEnd lb == end - 1 + originalDeclBlock = + Block (getStartLineUnsafe ldecl) (getEndLineUnsafe ldecl) + + printedDecl = runPrinter_ PrinterConfig relevantComments m do + putText (newOrData decl) + space + putName decl + + when (hasConstructors decl) do + case cEquals cfg of + _ | singleConstructor decl && not (cBreakSingleConstructors cfg) -> + space + Indent x + | isEnum decl && not (cBreakEnums cfg) -> space + | otherwise -> newline >> spaces x + SameLine -> space + + putText "=" + space + + lineLengthAfterEq <- getCurrentLineLength + + if isEnum decl && not (cBreakEnums cfg) then + putUnbrokenEnum cfg decl + else + sep + (consIndent lineLengthAfterEq) + (fmap (putConstructor cfg lineLengthAfterEq) . dd_cons $ defn) + + when (isEnum decl && not (cBreakEnums cfg) && hasDeriving decl) do + space + + when (isRecord decl && hasDeriving decl) do + newline + spaces (cDeriving cfg) + + sep + (newline >> spaces (cDeriving cfg)) + (fmap putDeriving . unLocated . dd_derivs $ defn) + + consIndent eqIndent = newline >> case (cEquals cfg, cFirstField cfg) of + (SameLine, SameLine) -> spaces (eqIndent - 2) >> putText "|" >> space + (SameLine, Indent y) -> spaces (eqIndent + y - 4) >> putText "|" >> space + (Indent x, Indent _) -> spaces x >> putText "|" >> space + (Indent x, SameLine) -> spaces x >> putText "|" >> space + +data DataDecl = MkDataDecl + { dataDeclName :: Located RdrName + , dataTypeVars :: LHsQTyVars GhcPs + , dataDefn :: HsDataDefn GhcPs + , dataFixity :: LexicalFixity + } + +putDeriving :: Located (HsDerivingClause GhcPs) -> P () +putDeriving (L pos clause) = do + putText "deriving" + space + + forM_ (deriv_clause_strategy clause) \case + L _ StockStrategy -> putText "stock" >> space + L _ AnyclassStrategy -> putText "anyclass" >> space + L _ NewtypeStrategy -> putText "newtype" >> space + L _ (ViaStrategy _x) -> error "via printing not enabled yet" + + putText "(" + sep + (comma >> space) + (fmap putOutputable (fmap hsib_body . unLocated . deriv_clause_tys $ clause)) + putText ")" + + putEolComment pos + +putUnbrokenEnum :: Config -> DataDecl -> P () +putUnbrokenEnum cfg decl = + sep + (space >> putText "|" >> space) + (fmap (putConstructor cfg 0) . dd_cons . dataDefn $ decl) + +putName :: DataDecl -> P () +putName decl@MkDataDecl{..} = + if isInfix decl then do + forM_ firstTvar (\t -> putOutputable t >> space) + putRdrName dataDeclName + space + forM_ secondTvar (\t -> putOutputable t >> space) + else do + putRdrName dataDeclName + forM_ (hsq_explicit dataTypeVars) (\t -> space >> putOutputable t) -commentsWithin :: LineBlock -> [Comment] -> [Comment] -commentsWithin lb = filter within where - within (Comment _ (H.SrcSpan _ start _ end _) _) = - start >= blockStart lb && end <= blockEnd lb - -changeDecl :: [Comment] -> Config -> H.Decl LineBlock -> Maybe ChangeLine -changeDecl _ _ (H.DataDecl _ (H.DataType _) Nothing _ [] _) = Nothing -changeDecl allComments cfg@Config{..} (H.DataDecl block (H.DataType _) Nothing dhead decls derivings) - | hasRecordFields = Just $ change block (const $ concat newLines) - | otherwise = Nothing + firstTvar :: Maybe (Located (HsTyVarBndr GhcPs)) + firstTvar + = dataTypeVars + & hsq_explicit + & listToMaybe + + secondTvar :: Maybe (Located (HsTyVarBndr GhcPs)) + secondTvar + = dataTypeVars + & hsq_explicit + & drop 1 + & listToMaybe + +putConstructor :: Config -> Int -> Located (ConDecl GhcPs) -> P () +putConstructor cfg consIndent (L _ cons) = case cons of + ConDeclGADT{} -> error "Stylish does not support GADTs yet, ConDeclGADT encountered" + XConDecl{} -> error "XConDecl" + ConDeclH98{..} -> + putRdrName con_name >> case con_args of + InfixCon {} -> error "infix con" + PrefixCon xs -> do + unless (null xs) space + sep space (fmap putOutputable xs) + RecCon (L recPos (L posFirst firstArg : args)) -> do + skipToBrace >> putText "{" + bracePos <- getCurrentLineLength + space + + -- Unless everything's configured to be on the same line, put pending + -- comments + unless (cFirstField cfg == SameLine) do + removeCommentTo posFirst >>= mapM_ \c -> putComment c >> sepDecl bracePos + + -- Put first decl field + putConDeclField firstArg + unless (cFirstField cfg == SameLine) (putEolComment posFirst) + + -- Put tail decl fields + forM_ args \(L pos arg) -> do + sepDecl bracePos + removeCommentTo pos >>= mapM_ \c -> + spaces (cFieldComment cfg) >> putComment c >> sepDecl bracePos + comma + space + putConDeclField arg + putEolComment pos + + -- Print docstr after final field + removeCommentToEnd recPos >>= mapM_ \c -> + sepDecl bracePos >> spaces (cFieldComment cfg) >> putComment c + + -- Print whitespace to closing brace + sepDecl bracePos >> putText "}" + RecCon (L _ []) -> do + skipToBrace >> putText "{" + skipToBrace >> putText "}" + + where + skipToBrace = case (cEquals cfg, cFirstField cfg) of + (_, Indent y) | not (cBreakSingleConstructors cfg) -> newline >> spaces y + (SameLine, SameLine) -> space + (Indent x, Indent y) -> newline >> spaces (x + y + 2) + (SameLine, Indent y) -> newline >> spaces (consIndent + y) + (Indent _, SameLine) -> space + + sepDecl bracePos = newline >> spaces case (cEquals cfg, cFirstField cfg) of + (_, Indent y) | not (cBreakSingleConstructors cfg) -> y + (SameLine, SameLine) -> bracePos - 1 -- back one from brace pos to place comma + (Indent x, Indent y) -> x + y + 2 + (SameLine, Indent y) -> bracePos - 1 + y - 2 + (Indent x, SameLine) -> bracePos - 1 + x - 2 + +putConDeclField :: ConDeclField GhcPs -> P () +putConDeclField XConDeclField{} = pure () +putConDeclField ConDeclField{..} = do + sep + (comma >> space) + (fmap (putText . showOutputable) cd_fld_names) + space + putText "::" + space + putOutputable cd_fld_type + +newOrData :: DataDecl -> String +newOrData decl = if isNewtype decl then "newtype" else "data" + +isNewtype :: DataDecl -> Bool +isNewtype = (== NewType) . dd_ND . dataDefn + +isInfix :: DataDecl -> Bool +isInfix = (== Infix) . dataFixity + +isEnum :: DataDecl -> Bool +isEnum = all isUnary . dd_cons . dataDefn where - hasRecordFields = any - (\qual -> case qual of - (H.QualConDecl _ _ _ (H.RecDecl {})) -> True - _ -> False) - decls - - typeConstructor = "data " <> H.prettyPrint dhead - - -- In any case set @pipeIndent@ such that @|@ is aligned with @=@. - (firstLine, firstLineInit, pipeIndent) = - case cEquals of - SameLine -> (Nothing, typeConstructor <> " = ", length typeConstructor + 1) - Indent n -> (Just [[typeConstructor]], indent n "= ", n) - - newLines = fromMaybe [] firstLine ++ fmap constructors zipped <> [fmap (indent cDeriving . H.prettyPrint) derivings] - zipped = zip decls ([1..] ::[Int]) - - constructors (decl, 1) = processConstructor allComments firstLineInit cfg decl - constructors (decl, _) = processConstructor allComments (indent pipeIndent "| ") cfg decl -changeDecl _ _ _ = Nothing - -processConstructor :: [Comment] -> String -> Config -> H.QualConDecl LineBlock -> [String] -processConstructor allComments init Config{..} (H.QualConDecl _ _ _ (H.RecDecl _ dname (f:fs))) = do - fromMaybe [] firstLine <> n1 <> ns <> [indent fieldIndent "}"] + isUnary = \case + L _ (ConDeclH98 {..}) -> case con_args of + PrefixCon [] -> True + _ -> False + _ -> False + +isRecord :: DataDecl -> Bool +isRecord = any isRecord' . dd_cons . dataDefn where - n1 = processName firstLinePrefix (extractField f) - ns = fs >>= processName (indent fieldIndent ", ") . extractField - - -- Set @fieldIndent@ such that @,@ is aligned with @{@. - (firstLine, firstLinePrefix, fieldIndent) = - case cFirstField of - SameLine -> - ( Nothing - , init <> H.prettyPrint dname <> " { " - , length init + length (H.prettyPrint dname) + 1 - ) - Indent n -> - ( Just [init <> H.prettyPrint dname] - , indent (length init + n) "{ " - , length init + n - ) - - processName prefix (fnames, _type, lineComment, commentBelowLine) = - [prefix <> intercalate ", " (fmap H.prettyPrint fnames) <> " :: " <> H.prettyPrint _type <> addLineComment lineComment - ] ++ addCommentBelow commentBelowLine - - addLineComment (Just (Comment _ _ c)) = " --" <> c - addLineComment Nothing = "" - - -- Field comment indent is measured from the column with @{@, hence adding of @fieldIndent@ here. - addCommentBelow Nothing = [] - addCommentBelow (Just (Comment _ _ c)) = [indent (fieldIndent + cFieldComment) "--" <> c] - - extractField (H.FieldDecl lb names _type) = - (names, _type, findCommentOnLine lb allComments, findCommentBelowLine lb allComments) - -processConstructor _ init _ decl = [init <> trimLeft (H.prettyPrint decl)] + isRecord' :: Located (ConDecl GhcPs) -> Bool + isRecord' = \case + L _ ConDeclH98{con_args = RecCon {}} -> True + _ -> False + +hasConstructors :: DataDecl -> Bool +hasConstructors = not . null . dd_cons . dataDefn + +singleConstructor :: DataDecl -> Bool +singleConstructor = (== 1) . length . dd_cons . dataDefn + +hasDeriving :: DataDecl -> Bool +hasDeriving = not . null . unLocated . dd_derivs . dataDefn diff --git a/lib/Language/Haskell/Stylish/Step/Imports'.hs b/lib/Language/Haskell/Stylish/Step/Imports'.hs index 1d9aa02d..296fad69 100644 --- a/lib/Language/Haskell/Stylish/Step/Imports'.hs +++ b/lib/Language/Haskell/Stylish/Step/Imports'.hs @@ -7,7 +7,6 @@ module Language.Haskell.Stylish.Step.Imports' ) where -------------------------------------------------------------------------------- -import ApiAnnotation (AnnKeywordId(..)) import Control.Monad (forM_, when) import Data.Function ((&)) import Data.Foldable (toList) @@ -15,11 +14,13 @@ import Data.Maybe (listToMaybe) import Data.List (sortBy) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NonEmpty + +-------------------------------------------------------------------------------- import GHC.Hs.Extension (GhcPs) import qualified GHC.Hs.Extension as GHC import GHC.Hs.ImpExp -import Module (ModuleName, moduleNameString) -import RdrName +import Module (moduleNameString) +import RdrName (RdrName) import Util (lastMaybe) import SrcLoc (Located, GenLocated(..)) @@ -140,29 +141,9 @@ printImport = \case -------------------------------------------------------------------------------- printIeWrappedName :: LIEWrappedName RdrName -> P () printIeWrappedName lie = unLocated lie & \case - IEName n -> printRdrName n - IEPattern n -> putText "pattern" >> space >> printRdrName n - IEType n -> putText "type" >> space >> printRdrName n - -printRdrName :: Located RdrName -> P () -printRdrName (L pos n) = case n of - Unqual name -> do - annots <- getAnnot pos - if AnnOpenP `elem` annots then do - putText "(" - putText (showOutputable name) - putText ")" - else - putText (showOutputable name) - Qual modulePrefix name -> - printModulePrefix modulePrefix >> dot >> putText (showOutputable name) - Orig _ name -> - putText (showOutputable name) - Exact name -> - putText (showOutputable name) - -printModulePrefix :: ModuleName -> P () -printModulePrefix = putText . moduleNameString + IEName n -> putRdrName n + IEPattern n -> putText "pattern" >> space >> putRdrName n + IEType n -> putText "type" >> space >> putRdrName n moduleName :: LImportDecl GhcPs -> String moduleName @@ -182,9 +163,6 @@ isHiding = maybe False fst . ideclHiding -unLocated :: Located a -> a -unLocated (L _ a) = a - sortImportList :: [LIE GhcPs] -> [LIE GhcPs] sortImportList = sortBy $ currycated \case (IEVar _ n0, IEVar _ n1) -> compareOutputable n0 n1 diff --git a/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs b/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs index 9e5a1ff5..52b85bec 100644 --- a/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs +++ b/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs @@ -149,8 +149,6 @@ printExportList (L srcLoc exports) = do putText ")" >> space >> putText "where" >> attachEolCommentEnd srcLoc where - putOutputable = putText . showOutputable - printExports :: [([AnnotationComment], NonEmpty (GHC.LIE GhcPs))] -> P () printExports (([], firstInGroup :| groupRest) : rest) = do printExport firstInGroup diff --git a/tests/Language/Haskell/Stylish/Step/Data/Tests.hs b/tests/Language/Haskell/Stylish/Step/Data/Tests.hs index b43e6dc6..a5038165 100644 --- a/tests/Language/Haskell/Stylish/Step/Data/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Data/Tests.hs @@ -35,6 +35,7 @@ tests = testGroup "Language.Haskell.Stylish.Step.Data.Tests" , testCase "case 22" case22 , testCase "case 23" case23 , testCase "case 24" case24 + , testCase "case 25" case25 ] case00 :: Assertion @@ -165,7 +166,7 @@ case07 = expected @=? testStep (step sameSameStyle) input expected = input case08 :: Assertion -case08 = input @=? testStep (step sameSameStyle) input +case08 = expected @=? testStep (step sameSameStyle) input where input = unlines [ "module Herp where" @@ -173,6 +174,11 @@ case08 = input @=? testStep (step sameSameStyle) input , "data Phantom a =" , " Phantom" ] + expected = unlines + [ "module Herp where" + , "" + , "data Phantom a = Phantom" + ] case09 :: Assertion case09 = expected @=? testStep (step indentIndentStyle4) input @@ -333,7 +339,8 @@ case16 = expected @=? testStep (step indentIndentStyle) input , "" , "data Foo" , " = Foo" - , " { a :: Int -- ^ comment" + , " { a :: Int" + , " -- ^ comment" , " }" ] @@ -520,17 +527,40 @@ case24 = expected @=? testStep (step indentIndentStyle) input , " deriving (ToJSON)" ] +case25 :: Assertion +case25 = expected @=? testStep (step indentIndentStyle { cBreakSingleConstructors = False }) input + where + input = unlines + [ "data Foo a" + , " = Foo { a :: Int," + , " a2 :: String" + , " -- ^ some haddock" + , " }" + , " deriving (Eq, Show)" + , " deriving (ToJSON)" + ] + + expected = unlines + [ "data Foo a = Foo" + , " { a :: Int" + , " , a2 :: String" + , " -- ^ some haddock" + , " }" + , " deriving (Eq, Show)" + , " deriving (ToJSON)" + ] + sameSameStyle :: Config -sameSameStyle = Config SameLine SameLine 2 2 +sameSameStyle = Config SameLine SameLine 2 2 False True sameIndentStyle :: Config -sameIndentStyle = Config SameLine (Indent 2) 2 2 +sameIndentStyle = Config SameLine (Indent 2) 2 2 False True indentSameStyle :: Config -indentSameStyle = Config (Indent 2) SameLine 2 2 +indentSameStyle = Config (Indent 2) SameLine 2 2 False True indentIndentStyle :: Config -indentIndentStyle = Config (Indent 2) (Indent 2) 2 2 +indentIndentStyle = Config (Indent 2) (Indent 2) 2 2 False True indentIndentStyle4 :: Config -indentIndentStyle4 = Config (Indent 4) (Indent 4) 4 4 +indentIndentStyle4 = Config (Indent 4) (Indent 4) 4 4 False True From abae1606835424a384e11f5ef028ba6ee41298cc Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Tue, 21 Jul 2020 20:12:56 +0200 Subject: [PATCH 028/135] Add records step to list of finished steps --- lib/Language/Haskell/Stylish/Config.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Config.hs b/lib/Language/Haskell/Stylish/Config.hs index b01d475b..7e177ab8 100644 --- a/lib/Language/Haskell/Stylish/Config.hs +++ b/lib/Language/Haskell/Stylish/Config.hs @@ -173,9 +173,10 @@ catalog = M.fromList $ ] else -- Done: - [ ("imports", parseImports') - , ("module_header", parseModuleHeader) - , ("tabs", parseTabs) + [ ("imports", parseImports') + , ("module_header", parseModuleHeader) + , ("records", parseRecords) + , ("tabs", parseTabs) , ("trailing_whitespace", parseTrailingWhitespace) ] -- To be ported: From afb226eb5a1111135ba1caaff215dde27a1430de Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Tue, 21 Jul 2020 20:24:49 +0200 Subject: [PATCH 029/135] Implement deriving via printing --- lib/Language/Haskell/Stylish/Step/Data.hs | 10 +++++++++- .../Haskell/Stylish/Step/Data/Tests.hs | 20 +++++++++++++++++++ 2 files changed, 29 insertions(+), 1 deletion(-) diff --git a/lib/Language/Haskell/Stylish/Step/Data.hs b/lib/Language/Haskell/Stylish/Step/Data.hs index 09d69c00..64752fd9 100644 --- a/lib/Language/Haskell/Stylish/Step/Data.hs +++ b/lib/Language/Haskell/Stylish/Step/Data.hs @@ -165,7 +165,7 @@ putDeriving (L pos clause) = do L _ StockStrategy -> putText "stock" >> space L _ AnyclassStrategy -> putText "anyclass" >> space L _ NewtypeStrategy -> putText "newtype" >> space - L _ (ViaStrategy _x) -> error "via printing not enabled yet" + L _ (ViaStrategy _) -> pure () putText "(" sep @@ -173,6 +173,14 @@ putDeriving (L pos clause) = do (fmap putOutputable (fmap hsib_body . unLocated . deriv_clause_tys $ clause)) putText ")" + forM_ (deriv_clause_strategy clause) \case + L _ (ViaStrategy x) -> do + space + putText "via" + space + putOutputable x + _ -> pure () + putEolComment pos putUnbrokenEnum :: Config -> DataDecl -> P () diff --git a/tests/Language/Haskell/Stylish/Step/Data/Tests.hs b/tests/Language/Haskell/Stylish/Step/Data/Tests.hs index a5038165..3939056c 100644 --- a/tests/Language/Haskell/Stylish/Step/Data/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Data/Tests.hs @@ -36,6 +36,7 @@ tests = testGroup "Language.Haskell.Stylish.Step.Data.Tests" , testCase "case 23" case23 , testCase "case 24" case24 , testCase "case 25" case25 + , testCase "case 26" case26 ] case00 :: Assertion @@ -550,6 +551,25 @@ case25 = expected @=? testStep (step indentIndentStyle { cBreakSingleConstructor , " deriving (ToJSON)" ] +case26 :: Assertion +case26 = expected @=? testStep (step indentIndentStyle) input + where + input = unlines + [ "module Herp where" + , "" + , "data Foo = Foo { a :: Int } deriving (FromJSON) via Bla Foo" + ] + + expected = unlines + [ "module Herp where" + , "" + , "data Foo" + , " = Foo" + , " { a :: Int" + , " }" + , " deriving (FromJSON) via Bla Foo" + ] + sameSameStyle :: Config sameSameStyle = Config SameLine SameLine 2 2 False True From be7cdb9660800e154599f3b58490ac63d02ce556 Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Tue, 21 Jul 2020 23:39:56 +0200 Subject: [PATCH 030/135] Fix indentation on enums with deriving clauses --- lib/Language/Haskell/Stylish/Step/Data.hs | 21 ++++++++++--------- .../Haskell/Stylish/Step/Data/Tests.hs | 20 ++++++++++++++++++ 2 files changed, 31 insertions(+), 10 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Step/Data.hs b/lib/Language/Haskell/Stylish/Step/Data.hs index 64752fd9..815dfe7f 100644 --- a/lib/Language/Haskell/Stylish/Step/Data.hs +++ b/lib/Language/Haskell/Stylish/Step/Data.hs @@ -112,13 +112,14 @@ formatDataDecl cfg m ls ldecl@(L _pos decl) = putName decl when (hasConstructors decl) do - case cEquals cfg of - _ | singleConstructor decl && not (cBreakSingleConstructors cfg) -> + case (cEquals cfg, cFirstField cfg) of + (_, Indent x) | isEnum decl && cBreakEnums cfg -> newline >> spaces x + (_, _) | singleConstructor decl && not (cBreakSingleConstructors cfg) -> space - Indent x + (Indent x, _) | isEnum decl && not (cBreakEnums cfg) -> space | otherwise -> newline >> spaces x - SameLine -> space + (SameLine, _) -> space putText "=" space @@ -132,12 +133,12 @@ formatDataDecl cfg m ls ldecl@(L _pos decl) = (consIndent lineLengthAfterEq) (fmap (putConstructor cfg lineLengthAfterEq) . dd_cons $ defn) - when (isEnum decl && not (cBreakEnums cfg) && hasDeriving decl) do - space - - when (isRecord decl && hasDeriving decl) do - newline - spaces (cDeriving cfg) + when (hasDeriving decl) do + if isEnum decl && not (cBreakEnums cfg) then + space + else do + newline + spaces (cDeriving cfg) sep (newline >> spaces (cDeriving cfg)) diff --git a/tests/Language/Haskell/Stylish/Step/Data/Tests.hs b/tests/Language/Haskell/Stylish/Step/Data/Tests.hs index 3939056c..826bd17a 100644 --- a/tests/Language/Haskell/Stylish/Step/Data/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Data/Tests.hs @@ -37,6 +37,7 @@ tests = testGroup "Language.Haskell.Stylish.Step.Data.Tests" , testCase "case 24" case24 , testCase "case 25" case25 , testCase "case 26" case26 + , testCase "case 27" case27 ] case00 :: Assertion @@ -570,6 +571,25 @@ case26 = expected @=? testStep (step indentIndentStyle) input , " deriving (FromJSON) via Bla Foo" ] +case27 :: Assertion +case27 = expected @=? testStep (step sameIndentStyle { cBreakEnums = True }) input + where + input = unlines + [ "module Herp where" + , "" + , "data Foo = Foo | Bar | Baz deriving (Eq, Show)" + ] + + expected = unlines + [ "module Herp where" + , "" + , "data Foo" + , " = Foo" + , " | Bar" + , " | Baz" + , " deriving (Eq, Show)" + ] + sameSameStyle :: Config sameSameStyle = Config SameLine SameLine 2 2 False True From db7c1fab48b973a3585e6ff69f8a646b01f18698 Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Wed, 22 Jul 2020 10:08:07 +0200 Subject: [PATCH 031/135] Fix multi decl formatting and newtype formatting --- lib/Language/Haskell/Stylish/Step/Data.hs | 61 +++++++++------ .../Haskell/Stylish/Step/Data/Tests.hs | 75 +++++++++++++++++-- 2 files changed, 106 insertions(+), 30 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Step/Data.hs b/lib/Language/Haskell/Stylish/Step/Data.hs index 815dfe7f..20fb44f3 100644 --- a/lib/Language/Haskell/Stylish/Step/Data.hs +++ b/lib/Language/Haskell/Stylish/Step/Data.hs @@ -14,7 +14,6 @@ import Prelude hiding (init) -------------------------------------------------------------------------------- import Control.Monad (forM_, unless, when) import Data.Function ((&)) -import Data.List (foldl') import Data.Maybe (listToMaybe, mapMaybe) -------------------------------------------------------------------------------- @@ -24,7 +23,7 @@ import GHC.Hs.Decls (LHsDecl, HsDecl(..), HsDataDe import GHC.Hs.Decls (TyClDecl(..), NewOrData(..)) import GHC.Hs.Decls (HsDerivingClause(..), DerivStrategy(..)) import GHC.Hs.Decls (ConDecl(..)) -import GHC.Hs.Extension (GhcPs) +import GHC.Hs.Extension (GhcPs, noExtCon) import GHC.Hs.Types (ConDeclField(..)) import GHC.Hs.Types (LHsQTyVars(..), HsTyVarBndr(..)) import GHC.Hs.Types (HsConDetails(..), HsImplicitBndrs(..)) @@ -61,10 +60,11 @@ data Config = Config } deriving (Show) step :: Config -> Step -step cfg - = makeStep "Data" - $ \ls m -> foldl' (formatDataDecl cfg m) ls (dataDecls m) +step cfg = makeStep "Data" \ls m -> applyChanges (changes m) ls where + changes :: Module -> [ChangeLine] + changes m = fmap (formatDataDecl cfg m) (dataDecls m) + dataDecls :: Module -> [Located DataDecl] dataDecls = mapMaybe toDataDecl @@ -87,13 +87,11 @@ step cfg } _ -> Nothing -formatDataDecl :: Config -> Module -> Lines -> Located DataDecl -> Lines -formatDataDecl cfg m ls ldecl@(L _pos decl) = - applyChanges - [ delete originalDeclBlock - , insert (getStartLineUnsafe ldecl) printedDecl - ] - ls +type ChangeLine = Change String + +formatDataDecl :: Config -> Module -> Located DataDecl -> ChangeLine +formatDataDecl cfg m ldecl@(L _pos decl) = + change originalDeclBlock (const printedDecl) where relevantComments :: [RealLocated AnnotationComment] relevantComments @@ -128,6 +126,8 @@ formatDataDecl cfg m ls ldecl@(L _pos decl) = if isEnum decl && not (cBreakEnums cfg) then putUnbrokenEnum cfg decl + else if isNewtype decl then + forM_ (dd_cons defn) (putNewtypeConstructor cfg) else sep (consIndent lineLengthAfterEq) @@ -217,8 +217,10 @@ putName decl@MkDataDecl{..} = putConstructor :: Config -> Int -> Located (ConDecl GhcPs) -> P () putConstructor cfg consIndent (L _ cons) = case cons of - ConDeclGADT{} -> error "Stylish does not support GADTs yet, ConDeclGADT encountered" - XConDecl{} -> error "XConDecl" + ConDeclGADT{} -> + error "Stylish does not support GADTs yet, ConDeclGADT encountered" + XConDecl x -> + noExtCon x ConDeclH98{..} -> putRdrName con_name >> case con_args of InfixCon {} -> error "infix con" @@ -274,6 +276,29 @@ putConstructor cfg consIndent (L _ cons) = case cons of (SameLine, Indent y) -> bracePos - 1 + y - 2 (Indent x, SameLine) -> bracePos - 1 + x - 2 +putNewtypeConstructor :: Config -> Located (ConDecl GhcPs) -> P () +putNewtypeConstructor _ (L _ cons) = case cons of + XConDecl x -> + noExtCon x + ConDeclH98{..} -> + putRdrName con_name >> case con_args of + PrefixCon xs -> do + unless (null xs) space + sep space (fmap putOutputable xs) + RecCon (L _ [L _posFirst firstArg]) -> do + space + putText "{" + space + putConDeclField firstArg + space + putText "}" + RecCon (L _ _args) -> + error "encountered newtype with several arguments" + InfixCon {} -> + error "infix newtype constructor" + ConDeclGADT{} -> + error "GADT encountered in newtype" + putConDeclField :: ConDeclField GhcPs -> P () putConDeclField XConDeclField{} = pure () putConDeclField ConDeclField{..} = do @@ -303,14 +328,6 @@ isEnum = all isUnary . dd_cons . dataDefn _ -> False _ -> False -isRecord :: DataDecl -> Bool -isRecord = any isRecord' . dd_cons . dataDefn - where - isRecord' :: Located (ConDecl GhcPs) -> Bool - isRecord' = \case - L _ ConDeclH98{con_args = RecCon {}} -> True - _ -> False - hasConstructors :: DataDecl -> Bool hasConstructors = not . null . dd_cons . dataDefn diff --git a/tests/Language/Haskell/Stylish/Step/Data/Tests.hs b/tests/Language/Haskell/Stylish/Step/Data/Tests.hs index 826bd17a..18baffe7 100644 --- a/tests/Language/Haskell/Stylish/Step/Data/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Data/Tests.hs @@ -38,6 +38,7 @@ tests = testGroup "Language.Haskell.Stylish.Step.Data.Tests" , testCase "case 25" case25 , testCase "case 26" case26 , testCase "case 27" case27 + , testCase "case 28" case28 ] case00 :: Assertion @@ -581,14 +582,72 @@ case27 = expected @=? testStep (step sameIndentStyle { cBreakEnums = True }) inp ] expected = unlines - [ "module Herp where" - , "" - , "data Foo" - , " = Foo" - , " | Bar" - , " | Baz" - , " deriving (Eq, Show)" - ] + [ "module Herp where" + , "" + , "data Foo" + , " = Foo" + , " | Bar" + , " | Baz" + , " deriving (Eq, Show)" + ] + +-- This test case shows that if we edit multiple declarations, we fail to +-- properly replace them using the delete + add lines approach +-- +-- Instead we most likely need to save the file between each decl and get new +-- positions +case28 :: Assertion +case28 = expected @=? testStep (step sameIndentStyle { cBreakEnums = True }) input + where + input = unlines + [ "module Some.Types where" + , "" + , "newtype BankCode = BankCode {" + , " unBankCode :: Text" + , " }" + , " deriving stock (Generic, Eq, Show)" + , " deriving anyclass (Newtype)" + , "" + , "newtype CheckDigit = CheckDigit { unCheckDigit :: Text }" + , " deriving stock (Generic, Eq, Show)" + , " deriving anyclass (Newtype)" + , "" + , "newtype WrappedInt = WrappedInt Int" + , " deriving stock (Generic, Eq, Show)" + , " deriving anyclass (Newtype)" + , "" + , "data MandateStatus" + , " = Approved" + , " | Failed" + , " | UserCanceled" + , " | Inactive" + , " deriving stock (Generic, Show, Eq, Enum, Bounded)" + , " deriving (ToJSON, FromJSON) via SnakeCaseCapsEnumEncoding MandateStatus" + ] + + expected = unlines + [ "module Some.Types where" + , "" + , "newtype BankCode = BankCode { unBankCode :: Text }" + , " deriving stock (Generic, Eq, Show)" + , " deriving anyclass (Newtype)" + , "" + , "newtype CheckDigit = CheckDigit { unCheckDigit :: Text }" + , " deriving stock (Generic, Eq, Show)" + , " deriving anyclass (Newtype)" + , "" + , "newtype WrappedInt = WrappedInt Int" + , " deriving stock (Generic, Eq, Show)" + , " deriving anyclass (Newtype)" + , "" + , "data MandateStatus" + , " = Approved" + , " | Failed" + , " | UserCanceled" + , " | Inactive" + , " deriving stock (Generic, Show, Eq, Enum, Bounded)" + , " deriving (ToJSON, FromJSON) via SnakeCaseCapsEnumEncoding MandateStatus" + ] sameSameStyle :: Config sameSameStyle = Config SameLine SameLine 2 2 False True From 2e9a291b0d61a7fdeb8c4e59c7cb882d9a2a25f0 Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Wed, 22 Jul 2020 16:39:44 +0200 Subject: [PATCH 032/135] Handle infix constructors when printing data decls --- lib/Language/Haskell/Stylish/Step/Data.hs | 30 ++++++++++++++----- .../Haskell/Stylish/Step/Data/Tests.hs | 22 ++++++++++---- 2 files changed, 40 insertions(+), 12 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Step/Data.hs b/lib/Language/Haskell/Stylish/Step/Data.hs index 20fb44f3..fcf0f1da 100644 --- a/lib/Language/Haskell/Stylish/Step/Data.hs +++ b/lib/Language/Haskell/Stylish/Step/Data.hs @@ -222,12 +222,19 @@ putConstructor cfg consIndent (L _ cons) = case cons of XConDecl x -> noExtCon x ConDeclH98{..} -> - putRdrName con_name >> case con_args of - InfixCon {} -> error "infix con" + case con_args of + InfixCon arg1 arg2 -> do + putOutputable arg1 + space + putRdrName con_name + space + putOutputable arg2 PrefixCon xs -> do + putRdrName con_name unless (null xs) space sep space (fmap putOutputable xs) RecCon (L recPos (L posFirst firstArg : args)) -> do + putRdrName con_name skipToBrace >> putText "{" bracePos <- getCurrentLineLength space @@ -278,8 +285,6 @@ putConstructor cfg consIndent (L _ cons) = case cons of putNewtypeConstructor :: Config -> Located (ConDecl GhcPs) -> P () putNewtypeConstructor _ (L _ cons) = case cons of - XConDecl x -> - noExtCon x ConDeclH98{..} -> putRdrName con_name >> case con_args of PrefixCon xs -> do @@ -293,11 +298,22 @@ putNewtypeConstructor _ (L _ cons) = case cons of space putText "}" RecCon (L _ _args) -> - error "encountered newtype with several arguments" + error . mconcat $ + [ "Language.Haskell.Stylish.Step.Data.putNewtypeConstructor: " + , "encountered newtype with several arguments" + ] InfixCon {} -> - error "infix newtype constructor" + error . mconcat $ + [ "Language.Haskell.Stylish.Step.Data.putNewtypeConstructor: " + , "infix newtype constructor" + ] + XConDecl x -> + noExtCon x ConDeclGADT{} -> - error "GADT encountered in newtype" + error . mconcat $ + [ "Language.Haskell.Stylish.Step.Data.putNewtypeConstructor: " + , "GADT encountered in newtype" + ] putConDeclField :: ConDeclField GhcPs -> P () putConDeclField XConDeclField{} = pure () diff --git a/tests/Language/Haskell/Stylish/Step/Data/Tests.hs b/tests/Language/Haskell/Stylish/Step/Data/Tests.hs index 18baffe7..de7d5740 100644 --- a/tests/Language/Haskell/Stylish/Step/Data/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Data/Tests.hs @@ -39,6 +39,7 @@ tests = testGroup "Language.Haskell.Stylish.Step.Data.Tests" , testCase "case 26" case26 , testCase "case 27" case27 , testCase "case 28" case28 + , testCase "case 29" case29 ] case00 :: Assertion @@ -591,11 +592,6 @@ case27 = expected @=? testStep (step sameIndentStyle { cBreakEnums = True }) inp , " deriving (Eq, Show)" ] --- This test case shows that if we edit multiple declarations, we fail to --- properly replace them using the delete + add lines approach --- --- Instead we most likely need to save the file between each decl and get new --- positions case28 :: Assertion case28 = expected @=? testStep (step sameIndentStyle { cBreakEnums = True }) input where @@ -649,6 +645,22 @@ case28 = expected @=? testStep (step sameIndentStyle { cBreakEnums = True }) inp , " deriving (ToJSON, FromJSON) via SnakeCaseCapsEnumEncoding MandateStatus" ] +case29 :: Assertion +case29 = expected @=? testStep (step sameIndentStyle) input + where + input = unlines + [ "module Some.Types where" + , "" + , "data NonEmpty a" + , " = a :| [a]" + ] + + expected = unlines + [ "module Some.Types where" + , "" + , "data NonEmpty a = a :| [a]" + ] + sameSameStyle :: Config sameSameStyle = Config SameLine SameLine 2 2 False True From 24e7c44171aa127fb15841200ea3c817a4159d13 Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Wed, 22 Jul 2020 17:24:55 +0200 Subject: [PATCH 033/135] Make sure docstrings are included if they precede `=` sign --- lib/Language/Haskell/Stylish/Printer.hs | 14 +++++++ lib/Language/Haskell/Stylish/Step/Data.hs | 31 ++++++++++---- .../Haskell/Stylish/Step/Data/Tests.hs | 41 +++++++++++++++++++ 3 files changed, 77 insertions(+), 9 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Printer.hs b/lib/Language/Haskell/Stylish/Printer.hs index bb9f9c87..93d7f0f1 100644 --- a/lib/Language/Haskell/Stylish/Printer.hs +++ b/lib/Language/Haskell/Stylish/Printer.hs @@ -22,6 +22,7 @@ module Language.Haskell.Stylish.Printer , dot , getAnnot , getCurrentLineLength + , getDocstrNext , getDocstrPrev , indent , newline @@ -135,6 +136,19 @@ putEolComment = \case forM_ cmt (\c -> space >> putComment c) UnhelpfulSpan _ -> pure () +getDocstrNext :: SrcSpan -> P (Maybe AnnotationComment) +getDocstrNext = \case + UnhelpfulSpan _ -> pure Nothing + RealSrcSpan rspan -> do + removeComment \case + L rloc (AnnLineComment s) -> + and + [ srcSpanStartLine rspan + 1 == srcSpanStartLine rloc + , "-- |" `isPrefixOf` s + ] + _ -> False + + putRdrName :: Located RdrName -> P () putRdrName (L pos n) = case n of Unqual name -> do diff --git a/lib/Language/Haskell/Stylish/Step/Data.hs b/lib/Language/Haskell/Stylish/Step/Data.hs index fcf0f1da..672aab9e 100644 --- a/lib/Language/Haskell/Stylish/Step/Data.hs +++ b/lib/Language/Haskell/Stylish/Step/Data.hs @@ -90,7 +90,7 @@ step cfg = makeStep "Data" \ls m -> applyChanges (changes m) ls type ChangeLine = Change String formatDataDecl :: Config -> Module -> Located DataDecl -> ChangeLine -formatDataDecl cfg m ldecl@(L _pos decl) = +formatDataDecl cfg m ldecl@(L declPos decl) = change originalDeclBlock (const printedDecl) where relevantComments :: [RealLocated AnnotationComment] @@ -116,7 +116,10 @@ formatDataDecl cfg m ldecl@(L _pos decl) = space (Indent x, _) | isEnum decl && not (cBreakEnums cfg) -> space - | otherwise -> newline >> spaces x + | otherwise -> do + putEolComment declPos + newline >> spaces x + getDocstrNext declPos >>= mapM_ \c -> putComment c >> newline >> spaces x (SameLine, _) -> space putText "=" @@ -129,9 +132,19 @@ formatDataDecl cfg m ldecl@(L _pos decl) = else if isNewtype decl then forM_ (dd_cons defn) (putNewtypeConstructor cfg) else - sep - (consIndent lineLengthAfterEq) - (fmap (putConstructor cfg lineLengthAfterEq) . dd_cons $ defn) + case dd_cons defn of + [] -> pure () + lcon@(L pos _) : consRest -> do + unless (cFirstField cfg == SameLine) do + removeCommentTo pos >>= mapM_ \c -> putComment c >> newline + putConstructor cfg lineLengthAfterEq lcon + forM_ consRest \con@(L conPos _) -> do + unless (cFirstField cfg == SameLine) do + removeCommentTo conPos >>= mapM_ \c -> consIndent lineLengthAfterEq >> putComment c + consIndent lineLengthAfterEq + putText "|" + space + putConstructor cfg lineLengthAfterEq con when (hasDeriving decl) do if isEnum decl && not (cBreakEnums cfg) then @@ -145,10 +158,10 @@ formatDataDecl cfg m ldecl@(L _pos decl) = (fmap putDeriving . unLocated . dd_derivs $ defn) consIndent eqIndent = newline >> case (cEquals cfg, cFirstField cfg) of - (SameLine, SameLine) -> spaces (eqIndent - 2) >> putText "|" >> space - (SameLine, Indent y) -> spaces (eqIndent + y - 4) >> putText "|" >> space - (Indent x, Indent _) -> spaces x >> putText "|" >> space - (Indent x, SameLine) -> spaces x >> putText "|" >> space + (SameLine, SameLine) -> spaces (eqIndent - 2) + (SameLine, Indent y) -> spaces (eqIndent + y - 4) + (Indent x, Indent _) -> spaces x + (Indent x, SameLine) -> spaces x data DataDecl = MkDataDecl { dataDeclName :: Located RdrName diff --git a/tests/Language/Haskell/Stylish/Step/Data/Tests.hs b/tests/Language/Haskell/Stylish/Step/Data/Tests.hs index de7d5740..6d5e4f48 100644 --- a/tests/Language/Haskell/Stylish/Step/Data/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Data/Tests.hs @@ -40,6 +40,8 @@ tests = testGroup "Language.Haskell.Stylish.Step.Data.Tests" , testCase "case 27" case27 , testCase "case 28" case28 , testCase "case 29" case29 + , testCase "case 30" case30 + , testCase "case 31" case31 ] case00 :: Assertion @@ -661,6 +663,45 @@ case29 = expected @=? testStep (step sameIndentStyle) input , "data NonEmpty a = a :| [a]" ] +case30 :: Assertion +case30 = expected @=? testStep (step sameIndentStyle { cBreakEnums = True }) input + where + expected = input + input = unlines + [ "data ReasonCode" + , " = MissingTenantId" + , " -- TXN Errors:" + , " | TransactionDoesNotExist" + , " | TransactionAlreadyExists" + , " -- Engine errors:" + , " | EnginePersistenceError" + , " | EngineValidationError" + , " -- | Transaction was created in Info mode" + , " | RegisteredByNetworkEngine" + , " -- | Transaction was created in Routing mode" + , " | SentToNetworkEngine" + , " -- Network connection reasons:" + , " | SentToNetworkConnection" + , " | ReceivedByNetworkConnection" + , " | ValidatedByNetworkConnection" + ] + + +case31 :: Assertion +case31 = expected @=? testStep (step indentIndentStyle { cBreakEnums = True }) input + where + expected = input + input = unlines + [ "data ConfiguredLogger" + , " -- | Logs to file" + , " = LogTo FilePath" + , " -- | Logs to stdout" + , " | LogToConsole" + , " -- | No logging, discards all messages" + , " | NoLogging" + , " deriving stock (Generic, Show)" + ] + sameSameStyle :: Config sameSameStyle = Config SameLine SameLine 2 2 False True From 257e24a985453e1bee25c9dc6d3465385f72a239 Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Wed, 22 Jul 2020 18:12:08 +0200 Subject: [PATCH 034/135] Homogenize handling of comments between type name and `=` sign --- lib/Language/Haskell/Stylish/Printer.hs | 14 ------------- lib/Language/Haskell/Stylish/Step/Data.hs | 18 ++++++++-------- .../Haskell/Stylish/Step/Data/Tests.hs | 21 ++++++++++++++++++- 3 files changed, 29 insertions(+), 24 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Printer.hs b/lib/Language/Haskell/Stylish/Printer.hs index 93d7f0f1..bb9f9c87 100644 --- a/lib/Language/Haskell/Stylish/Printer.hs +++ b/lib/Language/Haskell/Stylish/Printer.hs @@ -22,7 +22,6 @@ module Language.Haskell.Stylish.Printer , dot , getAnnot , getCurrentLineLength - , getDocstrNext , getDocstrPrev , indent , newline @@ -136,19 +135,6 @@ putEolComment = \case forM_ cmt (\c -> space >> putComment c) UnhelpfulSpan _ -> pure () -getDocstrNext :: SrcSpan -> P (Maybe AnnotationComment) -getDocstrNext = \case - UnhelpfulSpan _ -> pure Nothing - RealSrcSpan rspan -> do - removeComment \case - L rloc (AnnLineComment s) -> - and - [ srcSpanStartLine rspan + 1 == srcSpanStartLine rloc - , "-- |" `isPrefixOf` s - ] - _ -> False - - putRdrName :: Located RdrName -> P () putRdrName (L pos n) = case n of Unqual name -> do diff --git a/lib/Language/Haskell/Stylish/Step/Data.hs b/lib/Language/Haskell/Stylish/Step/Data.hs index 672aab9e..56b7c92e 100644 --- a/lib/Language/Haskell/Stylish/Step/Data.hs +++ b/lib/Language/Haskell/Stylish/Step/Data.hs @@ -111,7 +111,9 @@ formatDataDecl cfg m ldecl@(L declPos decl) = when (hasConstructors decl) do case (cEquals cfg, cFirstField cfg) of - (_, Indent x) | isEnum decl && cBreakEnums cfg -> newline >> spaces x + (_, Indent x) | isEnum decl && cBreakEnums cfg -> do + putEolComment declPos + newline >> spaces x (_, _) | singleConstructor decl && not (cBreakSingleConstructors cfg) -> space (Indent x, _) @@ -119,24 +121,22 @@ formatDataDecl cfg m ldecl@(L declPos decl) = | otherwise -> do putEolComment declPos newline >> spaces x - getDocstrNext declPos >>= mapM_ \c -> putComment c >> newline >> spaces x (SameLine, _) -> space - putText "=" - space - - lineLengthAfterEq <- getCurrentLineLength + lineLengthAfterEq <- fmap (+2) getCurrentLineLength if isEnum decl && not (cBreakEnums cfg) then - putUnbrokenEnum cfg decl + putText "=" >> space >> putUnbrokenEnum cfg decl else if isNewtype decl then - forM_ (dd_cons defn) (putNewtypeConstructor cfg) + putText "=" >> space >> forM_ (dd_cons defn) (putNewtypeConstructor cfg) else case dd_cons defn of [] -> pure () lcon@(L pos _) : consRest -> do unless (cFirstField cfg == SameLine) do - removeCommentTo pos >>= mapM_ \c -> putComment c >> newline + removeCommentTo pos >>= mapM_ \c -> putComment c >> consIndent lineLengthAfterEq + putText "=" + space putConstructor cfg lineLengthAfterEq lcon forM_ consRest \con@(L conPos _) -> do unless (cFirstField cfg == SameLine) do diff --git a/tests/Language/Haskell/Stylish/Step/Data/Tests.hs b/tests/Language/Haskell/Stylish/Step/Data/Tests.hs index 6d5e4f48..ca469e5f 100644 --- a/tests/Language/Haskell/Stylish/Step/Data/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Data/Tests.hs @@ -42,6 +42,7 @@ tests = testGroup "Language.Haskell.Stylish.Step.Data.Tests" , testCase "case 29" case29 , testCase "case 30" case30 , testCase "case 31" case31 + , testCase "case 32" case32 ] case00 :: Assertion @@ -670,7 +671,7 @@ case30 = expected @=? testStep (step sameIndentStyle { cBreakEnums = True }) inp input = unlines [ "data ReasonCode" , " = MissingTenantId" - , " -- TXN Errors:" + , " -- Transaction errors:" , " | TransactionDoesNotExist" , " | TransactionAlreadyExists" , " -- Engine errors:" @@ -702,6 +703,24 @@ case31 = expected @=? testStep (step indentIndentStyle { cBreakEnums = True }) i , " deriving stock (Generic, Show)" ] +case32 :: Assertion +case32 = expected @=? testStep (step indentIndentStyle { cBreakEnums = True }) input + where + expected = input + input = unlines + [ "data RejectionReason" + , " -- InvalidState" + , " = CancellationFailed" + , " | TotalAmountConfirmationInvalid" + , " -- InvalidApiUsage" + , " | AccessTokenNotActive" + , " | VersionNotFound" + , " -- ValidationFailed" + , " | BankAccountExists" + , " deriving stock (Generic, Show, Eq)" + , " deriving (ToJSON, FromJSON) via SnakeCaseLowercaseEnumEncoding RejectionReason" + ] + sameSameStyle :: Config sameSameStyle = Config SameLine SameLine 2 2 False True From 92068f0325acc833b11eaa41e061fe821f14f52d Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Wed, 22 Jul 2020 22:24:53 +0200 Subject: [PATCH 035/135] Make sure newtypes are broken before `=` sign if indent eq is set --- lib/Language/Haskell/Stylish/Step/Data.hs | 2 +- .../Language/Haskell/Stylish/Step/Data/Tests.hs | 17 +++++++++++++++++ 2 files changed, 18 insertions(+), 1 deletion(-) diff --git a/lib/Language/Haskell/Stylish/Step/Data.hs b/lib/Language/Haskell/Stylish/Step/Data.hs index 56b7c92e..27a316ce 100644 --- a/lib/Language/Haskell/Stylish/Step/Data.hs +++ b/lib/Language/Haskell/Stylish/Step/Data.hs @@ -114,7 +114,7 @@ formatDataDecl cfg m ldecl@(L declPos decl) = (_, Indent x) | isEnum decl && cBreakEnums cfg -> do putEolComment declPos newline >> spaces x - (_, _) | singleConstructor decl && not (cBreakSingleConstructors cfg) -> + (_, _) | not (isNewtype decl) && singleConstructor decl && not (cBreakSingleConstructors cfg) -> space (Indent x, _) | isEnum decl && not (cBreakEnums cfg) -> space diff --git a/tests/Language/Haskell/Stylish/Step/Data/Tests.hs b/tests/Language/Haskell/Stylish/Step/Data/Tests.hs index ca469e5f..e2df86c6 100644 --- a/tests/Language/Haskell/Stylish/Step/Data/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Data/Tests.hs @@ -43,6 +43,7 @@ tests = testGroup "Language.Haskell.Stylish.Step.Data.Tests" , testCase "case 30" case30 , testCase "case 31" case31 , testCase "case 32" case32 + , testCase "case 33" case33 ] case00 :: Assertion @@ -721,6 +722,22 @@ case32 = expected @=? testStep (step indentIndentStyle { cBreakEnums = True }) i , " deriving (ToJSON, FromJSON) via SnakeCaseLowercaseEnumEncoding RejectionReason" ] +case33 :: Assertion +case33 = expected @=? testStep (step indentIndentStyle { cBreakEnums = True, cBreakSingleConstructors = False }) input + where + input = unlines + [ "module Some.Types where" + , "" + , "newtype NonEmpty a = NonEmpty { unNonEmpty :: a }" + ] + + expected = unlines + [ "module Some.Types where" + , "" + , "newtype NonEmpty a" + , " = NonEmpty { unNonEmpty :: a }" + ] + sameSameStyle :: Config sameSameStyle = Config SameLine SameLine 2 2 False True From cdcd2c50d1847cb300398dd279d9a083644a81cc Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Wed, 22 Jul 2020 22:34:28 +0200 Subject: [PATCH 036/135] Add support for indenting via clauses --- lib/Language/Haskell/Stylish/Config.hs | 3 +- lib/Language/Haskell/Stylish/Step/Data.hs | 17 +++++++---- .../Haskell/Stylish/Step/Data/Tests.hs | 30 +++++++++++++++---- 3 files changed, 38 insertions(+), 12 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Config.hs b/lib/Language/Haskell/Stylish/Config.hs index 7e177ab8..75851055 100644 --- a/lib/Language/Haskell/Stylish/Config.hs +++ b/lib/Language/Haskell/Stylish/Config.hs @@ -232,7 +232,8 @@ parseRecords _ o = Data.step <*> (o A..: "field_comment") <*> (o A..: "deriving") <*> (o A..:? "break_enums" A..!= False) - <*> (o A..:? "break_single_constructors" A..!= True)) + <*> (o A..:? "break_single_constructors" A..!= True) + <*> (o A..: "via" >>= parseIndent)) parseIndent :: A.Value -> A.Parser Data.Indent diff --git a/lib/Language/Haskell/Stylish/Step/Data.hs b/lib/Language/Haskell/Stylish/Step/Data.hs index 27a316ce..a55cc82d 100644 --- a/lib/Language/Haskell/Stylish/Step/Data.hs +++ b/lib/Language/Haskell/Stylish/Step/Data.hs @@ -57,6 +57,8 @@ data Config = Config -- ^ Break enums by newlines and follow the above rules , cBreakSingleConstructors :: !Bool -- ^ Break single constructors when enabled, e.g. @Indent 2@ will not cause newline after @=@ + , cVia :: !Indent + -- ^ Indentation between @via@ clause and start of deriving column start } deriving (Show) step :: Config -> Step @@ -155,7 +157,7 @@ formatDataDecl cfg m ldecl@(L declPos decl) = sep (newline >> spaces (cDeriving cfg)) - (fmap putDeriving . unLocated . dd_derivs $ defn) + (fmap (putDeriving cfg) . unLocated . dd_derivs $ defn) consIndent eqIndent = newline >> case (cEquals cfg, cFirstField cfg) of (SameLine, SameLine) -> spaces (eqIndent - 2) @@ -170,8 +172,8 @@ data DataDecl = MkDataDecl , dataFixity :: LexicalFixity } -putDeriving :: Located (HsDerivingClause GhcPs) -> P () -putDeriving (L pos clause) = do +putDeriving :: Config -> Located (HsDerivingClause GhcPs) -> P () +putDeriving cfg (L pos clause) = do putText "deriving" space @@ -188,11 +190,14 @@ putDeriving (L pos clause) = do putText ")" forM_ (deriv_clause_strategy clause) \case - L _ (ViaStrategy x) -> do - space + L _ (ViaStrategy tp) -> do + case cVia cfg of + SameLine -> space + Indent x -> newline >> spaces (x + cDeriving cfg) + putText "via" space - putOutputable x + putOutputable tp _ -> pure () putEolComment pos diff --git a/tests/Language/Haskell/Stylish/Step/Data/Tests.hs b/tests/Language/Haskell/Stylish/Step/Data/Tests.hs index e2df86c6..962ed421 100644 --- a/tests/Language/Haskell/Stylish/Step/Data/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Data/Tests.hs @@ -44,6 +44,7 @@ tests = testGroup "Language.Haskell.Stylish.Step.Data.Tests" , testCase "case 31" case31 , testCase "case 32" case32 , testCase "case 33" case33 + , testCase "case 34" case34 ] case00 :: Assertion @@ -738,17 +739,36 @@ case33 = expected @=? testStep (step indentIndentStyle { cBreakEnums = True, cBr , " = NonEmpty { unNonEmpty :: a }" ] +case34 :: Assertion +case34 = expected @=? testStep (step indentIndentStyle { cVia = Indent 2 }) input + where + input = unlines + [ "module Some.Types where" + , "" + , "newtype NonEmpty a = NonEmpty { unNonEmpty :: a }" + , " deriving (ToJSON, FromJSON) via Something Magic (NonEmpty a)" + ] + + expected = unlines + [ "module Some.Types where" + , "" + , "newtype NonEmpty a" + , " = NonEmpty { unNonEmpty :: a }" + , " deriving (ToJSON, FromJSON)" + , " via Something Magic (NonEmpty a)" + ] + sameSameStyle :: Config -sameSameStyle = Config SameLine SameLine 2 2 False True +sameSameStyle = Config SameLine SameLine 2 2 False True SameLine sameIndentStyle :: Config -sameIndentStyle = Config SameLine (Indent 2) 2 2 False True +sameIndentStyle = Config SameLine (Indent 2) 2 2 False True SameLine indentSameStyle :: Config -indentSameStyle = Config (Indent 2) SameLine 2 2 False True +indentSameStyle = Config (Indent 2) SameLine 2 2 False True SameLine indentIndentStyle :: Config -indentIndentStyle = Config (Indent 2) (Indent 2) 2 2 False True +indentIndentStyle = Config (Indent 2) (Indent 2) 2 2 False True SameLine indentIndentStyle4 :: Config -indentIndentStyle4 = Config (Indent 4) (Indent 4) 4 4 False True +indentIndentStyle4 = Config (Indent 4) (Indent 4) 4 4 False True SameLine From 915267181d4f82d1abcf1dee138911cd3102daf7 Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Thu, 23 Jul 2020 09:32:25 +0200 Subject: [PATCH 037/135] Fix function printing in data decl step --- lib/Language/Haskell/Stylish/Step/Data.hs | 16 +++++-- .../Haskell/Stylish/Step/Data/Tests.hs | 44 +++++++++++++++++++ 2 files changed, 57 insertions(+), 3 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Step/Data.hs b/lib/Language/Haskell/Stylish/Step/Data.hs index a55cc82d..80c14f38 100644 --- a/lib/Language/Haskell/Stylish/Step/Data.hs +++ b/lib/Language/Haskell/Stylish/Step/Data.hs @@ -23,8 +23,8 @@ import GHC.Hs.Decls (LHsDecl, HsDecl(..), HsDataDe import GHC.Hs.Decls (TyClDecl(..), NewOrData(..)) import GHC.Hs.Decls (HsDerivingClause(..), DerivStrategy(..)) import GHC.Hs.Decls (ConDecl(..)) -import GHC.Hs.Extension (GhcPs, noExtCon) -import GHC.Hs.Types (ConDeclField(..)) +import GHC.Hs.Extension (GhcPs, NoExtField(..), noExtCon) +import GHC.Hs.Types (HsType(..), ConDeclField(..)) import GHC.Hs.Types (LHsQTyVars(..), HsTyVarBndr(..)) import GHC.Hs.Types (HsConDetails(..), HsImplicitBndrs(..)) import RdrName (RdrName) @@ -342,7 +342,17 @@ putConDeclField ConDeclField{..} = do space putText "::" space - putOutputable cd_fld_type + putFieldType cd_fld_type + +putFieldType :: Located (HsType GhcPs) -> P () +putFieldType = \case + L _pos (HsFunTy NoExtField argTp funTp) -> do + putOutputable argTp + space + putText "->" + space + putFieldType funTp + other -> putOutputable other newOrData :: DataDecl -> String newOrData decl = if isNewtype decl then "newtype" else "data" diff --git a/tests/Language/Haskell/Stylish/Step/Data/Tests.hs b/tests/Language/Haskell/Stylish/Step/Data/Tests.hs index 962ed421..59560420 100644 --- a/tests/Language/Haskell/Stylish/Step/Data/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Data/Tests.hs @@ -45,6 +45,8 @@ tests = testGroup "Language.Haskell.Stylish.Step.Data.Tests" , testCase "case 32" case32 , testCase "case 33" case33 , testCase "case 34" case34 + , testCase "case 35" case35 + , testCase "case 36" case36 ] case00 :: Assertion @@ -758,6 +760,48 @@ case34 = expected @=? testStep (step indentIndentStyle { cVia = Indent 2 }) inpu , " via Something Magic (NonEmpty a)" ] +case35 :: Assertion +case35 = expected @=? testStep (step indentIndentStyle { cBreakEnums = True, cBreakSingleConstructors = False }) input + where + input = unlines + [ "module Some.Types where" + , "" + , "data Foo = Foo" + , " { _transfer :: MonetaryAmount" + , " -> TransactionId" + , " -> m (Either CreditTransferError TransactionId)" + , " }" + ] + + expected = unlines + [ "module Some.Types where" + , "" + , "data Foo = Foo" + , " { _transfer :: MonetaryAmount -> TransactionId -> m (Either CreditTransferError TransactionId)" + , " }" + ] + +case36 :: Assertion +case36 = expected @=? testStep (step indentIndentStyle { cBreakEnums = True, cBreakSingleConstructors = False }) input + where + input = unlines + [ "module Some.Types where" + , "" + , "data Foo = Foo" + , " { _transfer :: (a -> b)" + , " -> TransactionId" + , " -> m (Either CreditTransferError TransactionId)" + , " }" + ] + + expected = unlines + [ "module Some.Types where" + , "" + , "data Foo = Foo" + , " { _transfer :: (a -> b) -> TransactionId -> m (Either CreditTransferError TransactionId)" + , " }" + ] + sameSameStyle :: Config sameSameStyle = Config SameLine SameLine 2 2 False True SameLine From 5d636115193d3ca8e4d3f65f29b0f5d113a99656 Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Thu, 23 Jul 2020 10:44:15 +0200 Subject: [PATCH 038/135] Print type literals in a uniform way --- lib/Language/Haskell/Stylish/Step/Data.hs | 29 +++++++++++++++---- .../Haskell/Stylish/Step/Data/Tests.hs | 26 +++++++++++++++++ 2 files changed, 50 insertions(+), 5 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Step/Data.hs b/lib/Language/Haskell/Stylish/Step/Data.hs index 80c14f38..14513442 100644 --- a/lib/Language/Haskell/Stylish/Step/Data.hs +++ b/lib/Language/Haskell/Stylish/Step/Data.hs @@ -197,11 +197,16 @@ putDeriving cfg (L pos clause) = do putText "via" space - putOutputable tp + putType (getType tp) _ -> pure () putEolComment pos + where + getType = \case + HsIB _ tp -> tp + XHsImplicitBndrs x -> noExtCon x + putUnbrokenEnum :: Config -> DataDecl -> P () putUnbrokenEnum cfg decl = sep @@ -342,16 +347,30 @@ putConDeclField ConDeclField{..} = do space putText "::" space - putFieldType cd_fld_type + putType cd_fld_type -putFieldType :: Located (HsType GhcPs) -> P () -putFieldType = \case +putType :: Located (HsType GhcPs) -> P () +putType = \case L _pos (HsFunTy NoExtField argTp funTp) -> do putOutputable argTp space putText "->" space - putFieldType funTp + putType funTp + L _pos (HsAppTy NoExtField t1 t2) -> + putType t1 >> space >> putType t2 + L _pos (HsExplicitListTy NoExtField _ xs) -> do + putText "'[" + sep + (comma >> space) + (fmap putType xs) + putText "]" + L _pos (HsExplicitTupleTy NoExtField xs) -> do + putText "'(" + sep + (comma >> space) + (fmap putType xs) + putText ")" other -> putOutputable other newOrData :: DataDecl -> String diff --git a/tests/Language/Haskell/Stylish/Step/Data/Tests.hs b/tests/Language/Haskell/Stylish/Step/Data/Tests.hs index 59560420..429deaaa 100644 --- a/tests/Language/Haskell/Stylish/Step/Data/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Data/Tests.hs @@ -47,6 +47,7 @@ tests = testGroup "Language.Haskell.Stylish.Step.Data.Tests" , testCase "case 34" case34 , testCase "case 35" case35 , testCase "case 36" case36 + , testCase "case 37" case37 ] case00 :: Assertion @@ -802,6 +803,31 @@ case36 = expected @=? testStep (step indentIndentStyle { cBreakEnums = True, cBr , " }" ] +case37 :: Assertion +case37 = expected @=? testStep (step indentIndentStyle { cVia = Indent 2 }) input + where + input = unlines + [ "module Some.Types where" + , "" + , "newtype UndoFlowData" + , " = UndoFlowData { flowDataDetails :: FlowDataDetails }" + , " deriving stock (Generic, Eq, Show)" + , " deriving (ToJSON, FromJSON)" + , " via AddConstTextFields '[\"type0\" := \"undo\"," + , " \"type1\" := \"undo\"," + , " \"reversal_indicator\" := \"Undo\"] FlowDataDetails" + ] + + expected = unlines + [ "module Some.Types where" + , "" + , "newtype UndoFlowData" + , " = UndoFlowData { flowDataDetails :: FlowDataDetails }" + , " deriving stock (Generic, Eq, Show)" + , " deriving (ToJSON, FromJSON)" + , " via AddConstTextFields '[\"type0\" := \"undo\", \"type1\" := \"undo\", \"reversal_indicator\" := \"Undo\"] FlowDataDetails" + ] + sameSameStyle :: Config sameSameStyle = Config SameLine SameLine 2 2 False True SameLine From 137d048426434c0358abbb6df0396f95ae01ea3d Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Thu, 23 Jul 2020 10:54:19 +0200 Subject: [PATCH 039/135] Print type operators in a uniform way --- lib/Language/Haskell/Stylish/Step/Data.hs | 6 ++++ .../Haskell/Stylish/Step/Data/Tests.hs | 35 +++++++++++++++++++ 2 files changed, 41 insertions(+) diff --git a/lib/Language/Haskell/Stylish/Step/Data.hs b/lib/Language/Haskell/Stylish/Step/Data.hs index 14513442..9293d341 100644 --- a/lib/Language/Haskell/Stylish/Step/Data.hs +++ b/lib/Language/Haskell/Stylish/Step/Data.hs @@ -371,6 +371,12 @@ putType = \case (comma >> space) (fmap putType xs) putText ")" + L _pos (HsOpTy NoExtField lhs op rhs) -> do + putType lhs + space + putRdrName op + space + putType rhs other -> putOutputable other newOrData :: DataDecl -> String diff --git a/tests/Language/Haskell/Stylish/Step/Data/Tests.hs b/tests/Language/Haskell/Stylish/Step/Data/Tests.hs index 429deaaa..cea12e82 100644 --- a/tests/Language/Haskell/Stylish/Step/Data/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Data/Tests.hs @@ -48,6 +48,7 @@ tests = testGroup "Language.Haskell.Stylish.Step.Data.Tests" , testCase "case 35" case35 , testCase "case 36" case36 , testCase "case 37" case37 + , testCase "case 38" case38 ] case00 :: Assertion @@ -828,6 +829,40 @@ case37 = expected @=? testStep (step indentIndentStyle { cVia = Indent 2 }) inpu , " via AddConstTextFields '[\"type0\" := \"undo\", \"type1\" := \"undo\", \"reversal_indicator\" := \"Undo\"] FlowDataDetails" ] +case38 :: Assertion +case38 = expected @=? testStep (step indentIndentStyle { cVia = Indent 2 }) input + where + input = unlines + [ "data Flat = Flat" + , " { foo :: Int" + , " , bar :: Text" + , " , baz :: Double" + , " , qux :: Bool" + , " }" + , " deriving stock (Generic, Show, Eq)" + , " deriving (FromJSON, ToJSON)" + , " via GenericEncoded" + , " '[ FieldLabelModifier :=" + , " '[ \"foo\" ==> \"nestFoo#foo\"" + , " , \"bar\" ==> \"nestBar#bar\"" + , " , \"baz\" ==> \"nestFoo#baz\"" + , " ]" + , " ]" + , " Flat" + ] + + expected = unlines + [ "data Flat" + , " = Flat" + , " { foo :: Int" + , " , bar :: Text" + , " , baz :: Double" + , " , qux :: Bool" + , " }" + , " deriving stock (Generic, Show, Eq)" + , " deriving (FromJSON, ToJSON)" + , " via GenericEncoded '[FieldLabelModifier := '[\"foo\" ==> \"nestFoo#foo\", \"bar\" ==> \"nestBar#bar\", \"baz\" ==> \"nestFoo#baz\"]] Flat" + ] sameSameStyle :: Config sameSameStyle = Config SameLine SameLine 2 2 False True SameLine From f022ac21fa88d84d59a16185a6e7f31111cc9da2 Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Thu, 23 Jul 2020 11:22:47 +0200 Subject: [PATCH 040/135] Make sure nested type literals are properly printed --- lib/Language/Haskell/Stylish/Step/Data.hs | 55 ++++++++++++++++--- .../Haskell/Stylish/Step/Data/Tests.hs | 35 ++++++++++++ 2 files changed, 83 insertions(+), 7 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Step/Data.hs b/lib/Language/Haskell/Stylish/Step/Data.hs index 9293d341..57da12c3 100644 --- a/lib/Language/Haskell/Stylish/Step/Data.hs +++ b/lib/Language/Haskell/Stylish/Step/Data.hs @@ -350,34 +350,75 @@ putConDeclField ConDeclField{..} = do putType cd_fld_type putType :: Located (HsType GhcPs) -> P () -putType = \case - L _pos (HsFunTy NoExtField argTp funTp) -> do +putType ltp = case unLocated ltp of + HsFunTy NoExtField argTp funTp -> do putOutputable argTp space putText "->" space putType funTp - L _pos (HsAppTy NoExtField t1 t2) -> + HsAppTy NoExtField t1 t2 -> putType t1 >> space >> putType t2 - L _pos (HsExplicitListTy NoExtField _ xs) -> do + HsExplicitListTy NoExtField _ xs -> do putText "'[" sep (comma >> space) (fmap putType xs) putText "]" - L _pos (HsExplicitTupleTy NoExtField xs) -> do + HsExplicitTupleTy NoExtField xs -> do putText "'(" sep (comma >> space) (fmap putType xs) putText ")" - L _pos (HsOpTy NoExtField lhs op rhs) -> do + HsOpTy NoExtField lhs op rhs -> do putType lhs space putRdrName op space putType rhs - other -> putOutputable other + HsTyVar NoExtField _ rdrName -> + putRdrName rdrName + HsTyLit _ tp -> + putOutputable tp + HsParTy _ tp -> do + putText "(" + putType tp + putText ")" + HsTupleTy NoExtField _ xs -> do + putText "(" + sep + (comma >> space) + (fmap putType xs) + putText ")" + HsForAllTy NoExtField _ _ _ -> + putOutputable ltp + HsQualTy NoExtField _ _ -> + putOutputable ltp + HsAppKindTy _ _ _ -> + putOutputable ltp + HsListTy _ _ -> + putOutputable ltp + HsSumTy _ _ -> + putOutputable ltp + HsIParamTy _ _ _ -> + putOutputable ltp + HsKindSig _ _ _ -> + putOutputable ltp + HsStarTy _ _ -> + putOutputable ltp + HsSpliceTy _ _ -> + putOutputable ltp + HsDocTy _ _ _ -> + putOutputable ltp + HsBangTy _ _ _ -> + putOutputable ltp + HsRecTy _ _ -> + putOutputable ltp + HsWildCardTy _ -> + putOutputable ltp + XHsType _ -> + putOutputable ltp newOrData :: DataDecl -> String newOrData decl = if isNewtype decl then "newtype" else "data" diff --git a/tests/Language/Haskell/Stylish/Step/Data/Tests.hs b/tests/Language/Haskell/Stylish/Step/Data/Tests.hs index cea12e82..c4e1a3aa 100644 --- a/tests/Language/Haskell/Stylish/Step/Data/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Data/Tests.hs @@ -49,6 +49,7 @@ tests = testGroup "Language.Haskell.Stylish.Step.Data.Tests" , testCase "case 36" case36 , testCase "case 37" case37 , testCase "case 38" case38 + , testCase "case 39" case39 ] case00 :: Assertion @@ -863,6 +864,40 @@ case38 = expected @=? testStep (step indentIndentStyle { cVia = Indent 2 }) inpu , " deriving (FromJSON, ToJSON)" , " via GenericEncoded '[FieldLabelModifier := '[\"foo\" ==> \"nestFoo#foo\", \"bar\" ==> \"nestBar#bar\", \"baz\" ==> \"nestFoo#baz\"]] Flat" ] + +case39 :: Assertion +case39 = expected @=? testStep (step indentIndentStyle { cVia = Indent 2 }) input + where + input = unlines + [ "data CreditTransfer = CreditTransfer" + , " { nestedCreditorInfo :: CreditorInfo" + , " }" + , " deriving stock (Show, Eq, Generic)" + , " deriving (ToJSON, FromJSON) via" + , " ( UntaggedEncoded NordeaCreditTransfer" + , " & AddConstTextFields" + , " '[ \"request_type\" ':= \"credit_transfer\"" + , " , \"provider\" ':= \"nordea\"" + , " ]" + , " & FlattenFields '[\"nested_creditor_info\"]" + , " & RenameKeys" + , " '[ \"nested_creditor_info.creditor_agent_bic\" ==> \"creditor_agent_bic\"" + , " , \"nested_creditor_info.creditor_iban\" ==> \"creditor_iban\"" + , " , \"nested_creditor_info.creditor_name\" ==> \"creditor_name\"" + , " , \"nested_creditor_info.creditor_account\" ==> \"creditor_account\"" + , " ]" + , " )" + ] + + expected = unlines + [ "data CreditTransfer" + , " = CreditTransfer" + , " { nestedCreditorInfo :: CreditorInfo" + , " }" + , " deriving stock (Show, Eq, Generic)" + , " deriving (ToJSON, FromJSON)" + , " via (UntaggedEncoded NordeaCreditTransfer & AddConstTextFields '[\"request_type\" := \"credit_transfer\", \"provider\" := \"nordea\"] & FlattenFields '[\"nested_creditor_info\"] & RenameKeys '[\"nested_creditor_info.creditor_agent_bic\" ==> \"creditor_agent_bic\", \"nested_creditor_info.creditor_iban\" ==> \"creditor_iban\", \"nested_creditor_info.creditor_name\" ==> \"creditor_name\", \"nested_creditor_info.creditor_account\" ==> \"creditor_account\"])" + ] sameSameStyle :: Config sameSameStyle = Config SameLine SameLine 2 2 False True SameLine From 01a8dbd5ca5ad0da252d8389fb512a4534ced508 Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Thu, 23 Jul 2020 11:52:14 +0200 Subject: [PATCH 041/135] Fix printing of promoted constructors --- lib/Language/Haskell/Stylish/Printer.hs | 3 +++ tests/Language/Haskell/Stylish/Step/Data/Tests.hs | 2 +- 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/lib/Language/Haskell/Stylish/Printer.hs b/lib/Language/Haskell/Stylish/Printer.hs index bb9f9c87..4ef4f197 100644 --- a/lib/Language/Haskell/Stylish/Printer.hs +++ b/lib/Language/Haskell/Stylish/Printer.hs @@ -147,6 +147,9 @@ putRdrName (L pos n) = case n of putText "`" putText (showOutputable name) putText "`" + else if AnnSimpleQuote `elem` annots then do + putText "'" + putText (showOutputable name) else putText (showOutputable name) Qual modulePrefix name -> diff --git a/tests/Language/Haskell/Stylish/Step/Data/Tests.hs b/tests/Language/Haskell/Stylish/Step/Data/Tests.hs index c4e1a3aa..93773211 100644 --- a/tests/Language/Haskell/Stylish/Step/Data/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Data/Tests.hs @@ -896,7 +896,7 @@ case39 = expected @=? testStep (step indentIndentStyle { cVia = Indent 2 }) inpu , " }" , " deriving stock (Show, Eq, Generic)" , " deriving (ToJSON, FromJSON)" - , " via (UntaggedEncoded NordeaCreditTransfer & AddConstTextFields '[\"request_type\" := \"credit_transfer\", \"provider\" := \"nordea\"] & FlattenFields '[\"nested_creditor_info\"] & RenameKeys '[\"nested_creditor_info.creditor_agent_bic\" ==> \"creditor_agent_bic\", \"nested_creditor_info.creditor_iban\" ==> \"creditor_iban\", \"nested_creditor_info.creditor_name\" ==> \"creditor_name\", \"nested_creditor_info.creditor_account\" ==> \"creditor_account\"])" + , " via (UntaggedEncoded NordeaCreditTransfer & AddConstTextFields '[\"request_type\" ':= \"credit_transfer\", \"provider\" ':= \"nordea\"] & FlattenFields '[\"nested_creditor_info\"] & RenameKeys '[\"nested_creditor_info.creditor_agent_bic\" ==> \"creditor_agent_bic\", \"nested_creditor_info.creditor_iban\" ==> \"creditor_iban\", \"nested_creditor_info.creditor_name\" ==> \"creditor_name\", \"nested_creditor_info.creditor_account\" ==> \"creditor_account\"])" ] sameSameStyle :: Config sameSameStyle = Config SameLine SameLine 2 2 False True SameLine From 4be10fae87c3b2a8da51f838c910d8d6d6ba212e Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Thu, 23 Jul 2020 12:56:42 +0200 Subject: [PATCH 042/135] Move type printing to printer module --- lib/Language/Haskell/Stylish/Printer.hs | 75 +++++++++++++++++++ lib/Language/Haskell/Stylish/Step/Data.hs | 90 +++-------------------- 2 files changed, 87 insertions(+), 78 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Printer.hs b/lib/Language/Haskell/Stylish/Printer.hs index 4ef4f197..d2bb1dc5 100644 --- a/lib/Language/Haskell/Stylish/Printer.hs +++ b/lib/Language/Haskell/Stylish/Printer.hs @@ -31,6 +31,7 @@ module Language.Haskell.Stylish.Printer , putComment , putEolComment , putOutputable + , putType , putRdrName , putText , removeCommentTo @@ -52,6 +53,8 @@ import Language.Haskell.Stylish.GHC (baseDynFlags) -------------------------------------------------------------------------------- import ApiAnnotation (AnnKeywordId(..), AnnotationComment(..)) +import GHC.Hs.Extension (GhcPs, NoExtField(..)) +import GHC.Hs.Types (HsType(..)) import Module (ModuleName, moduleNameString) import RdrName (RdrName(..)) import SrcLoc (GenLocated(..), RealLocated) @@ -75,6 +78,7 @@ import Prelude hiding (lines) -------------------------------------------------------------------------------- import Language.Haskell.Stylish.Module (Module, lookupAnnotation) +import Language.Haskell.Stylish.GHC (unLocated) type P = Printer type Lines = [String] @@ -175,6 +179,77 @@ getDocstrPrev = \case putModulePrefix :: ModuleName -> P () putModulePrefix = putText . moduleNameString +putType :: Located (HsType GhcPs) -> P () +putType ltp = case unLocated ltp of + HsFunTy NoExtField argTp funTp -> do + putOutputable argTp + space + putText "->" + space + putType funTp + HsAppTy NoExtField t1 t2 -> + putType t1 >> space >> putType t2 + HsExplicitListTy NoExtField _ xs -> do + putText "'[" + sep + (comma >> space) + (fmap putType xs) + putText "]" + HsExplicitTupleTy NoExtField xs -> do + putText "'(" + sep + (comma >> space) + (fmap putType xs) + putText ")" + HsOpTy NoExtField lhs op rhs -> do + putType lhs + space + putRdrName op + space + putType rhs + HsTyVar NoExtField _ rdrName -> + putRdrName rdrName + HsTyLit _ tp -> + putOutputable tp + HsParTy _ tp -> do + putText "(" + putType tp + putText ")" + HsTupleTy NoExtField _ xs -> do + putText "(" + sep + (comma >> space) + (fmap putType xs) + putText ")" + HsForAllTy NoExtField _ _ _ -> + putOutputable ltp + HsQualTy NoExtField _ _ -> + putOutputable ltp + HsAppKindTy _ _ _ -> + putOutputable ltp + HsListTy _ _ -> + putOutputable ltp + HsSumTy _ _ -> + putOutputable ltp + HsIParamTy _ _ _ -> + putOutputable ltp + HsKindSig _ _ _ -> + putOutputable ltp + HsStarTy _ _ -> + putOutputable ltp + HsSpliceTy _ _ -> + putOutputable ltp + HsDocTy _ _ _ -> + putOutputable ltp + HsBangTy _ _ _ -> + putOutputable ltp + HsRecTy _ _ -> + putOutputable ltp + HsWildCardTy _ -> + putOutputable ltp + XHsType _ -> + putOutputable ltp + newline :: P () newline = do l <- gets currentLine diff --git a/lib/Language/Haskell/Stylish/Step/Data.hs b/lib/Language/Haskell/Stylish/Step/Data.hs index 57da12c3..910616db 100644 --- a/lib/Language/Haskell/Stylish/Step/Data.hs +++ b/lib/Language/Haskell/Stylish/Step/Data.hs @@ -23,8 +23,8 @@ import GHC.Hs.Decls (LHsDecl, HsDecl(..), HsDataDe import GHC.Hs.Decls (TyClDecl(..), NewOrData(..)) import GHC.Hs.Decls (HsDerivingClause(..), DerivStrategy(..)) import GHC.Hs.Decls (ConDecl(..)) -import GHC.Hs.Extension (GhcPs, NoExtField(..), noExtCon) -import GHC.Hs.Types (HsType(..), ConDeclField(..)) +import GHC.Hs.Extension (GhcPs, noExtCon) +import GHC.Hs.Types (ConDeclField(..)) import GHC.Hs.Types (LHsQTyVars(..), HsTyVarBndr(..)) import GHC.Hs.Types (HsConDetails(..), HsImplicitBndrs(..)) import RdrName (RdrName) @@ -339,86 +339,20 @@ putNewtypeConstructor _ (L _ cons) = case cons of ] putConDeclField :: ConDeclField GhcPs -> P () -putConDeclField XConDeclField{} = pure () -putConDeclField ConDeclField{..} = do - sep - (comma >> space) - (fmap (putText . showOutputable) cd_fld_names) - space - putText "::" - space - putType cd_fld_type - -putType :: Located (HsType GhcPs) -> P () -putType ltp = case unLocated ltp of - HsFunTy NoExtField argTp funTp -> do - putOutputable argTp - space - putText "->" - space - putType funTp - HsAppTy NoExtField t1 t2 -> - putType t1 >> space >> putType t2 - HsExplicitListTy NoExtField _ xs -> do - putText "'[" +putConDeclField = \case + ConDeclField{..} -> do sep (comma >> space) - (fmap putType xs) - putText "]" - HsExplicitTupleTy NoExtField xs -> do - putText "'(" - sep - (comma >> space) - (fmap putType xs) - putText ")" - HsOpTy NoExtField lhs op rhs -> do - putType lhs + (fmap (putText . showOutputable) cd_fld_names) space - putRdrName op + putText "::" space - putType rhs - HsTyVar NoExtField _ rdrName -> - putRdrName rdrName - HsTyLit _ tp -> - putOutputable tp - HsParTy _ tp -> do - putText "(" - putType tp - putText ")" - HsTupleTy NoExtField _ xs -> do - putText "(" - sep - (comma >> space) - (fmap putType xs) - putText ")" - HsForAllTy NoExtField _ _ _ -> - putOutputable ltp - HsQualTy NoExtField _ _ -> - putOutputable ltp - HsAppKindTy _ _ _ -> - putOutputable ltp - HsListTy _ _ -> - putOutputable ltp - HsSumTy _ _ -> - putOutputable ltp - HsIParamTy _ _ _ -> - putOutputable ltp - HsKindSig _ _ _ -> - putOutputable ltp - HsStarTy _ _ -> - putOutputable ltp - HsSpliceTy _ _ -> - putOutputable ltp - HsDocTy _ _ _ -> - putOutputable ltp - HsBangTy _ _ _ -> - putOutputable ltp - HsRecTy _ _ -> - putOutputable ltp - HsWildCardTy _ -> - putOutputable ltp - XHsType _ -> - putOutputable ltp + putType cd_fld_type + XConDeclField{} -> + error . mconcat $ + [ "Language.Haskell.Stylish.Step.Data.putConDeclField: " + , "XConDeclField encountered" + ] newOrData :: DataDecl -> String newOrData decl = if isNewtype decl then "newtype" else "data" From 34c5c2b5650a1ef7aef027b0f60f5735253c72ab Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Thu, 23 Jul 2020 13:11:17 +0200 Subject: [PATCH 043/135] Move around and document a few functions --- lib/Language/Haskell/Stylish/GHC.hs | 14 ++++ lib/Language/Haskell/Stylish/Printer.hs | 78 +++++++++++-------- .../Haskell/Stylish/Step/ModuleHeader.hs | 2 +- 3 files changed, 62 insertions(+), 32 deletions(-) diff --git a/lib/Language/Haskell/Stylish/GHC.hs b/lib/Language/Haskell/Stylish/GHC.hs index 8ef9388c..b64b218e 100644 --- a/lib/Language/Haskell/Stylish/GHC.hs +++ b/lib/Language/Haskell/Stylish/GHC.hs @@ -5,10 +5,16 @@ module Language.Haskell.Stylish.GHC ( dropAfterLocated , dropBeforeLocated , dropBeforeAndAfter + -- * Unsafe getters , getEndLineUnsafe , getStartLineUnsafe + -- * Standard settings , baseDynFlags + -- * Positions , unLocated + -- * Outputable operators + , showOutputable + , compareOutputable ) where -------------------------------------------------------------------------------- @@ -24,6 +30,7 @@ import SrcLoc (GenLocated(..), SrcSpan(..)) import SrcLoc (Located, RealLocated) import SrcLoc (srcSpanStartLine, srcSpanEndLine) import ToolSettings (ToolSettings(..)) +import qualified Outputable as GHC getStartLineUnsafe :: Located a -> Int getStartLineUnsafe = \case @@ -83,3 +90,10 @@ baseDynFlags = defaultDynFlags fakeSettings llvmConfig unLocated :: Located a -> a unLocated (L _ a) = a + +showOutputable :: GHC.Outputable a => a -> String +showOutputable = GHC.showPpr baseDynFlags + +compareOutputable :: GHC.Outputable a => a -> a -> Ordering +compareOutputable i0 i1 = compare (showOutputable i0) (showOutputable i1) + diff --git a/lib/Language/Haskell/Stylish/Printer.hs b/lib/Language/Haskell/Stylish/Printer.hs index d2bb1dc5..9b1ffc2c 100644 --- a/lib/Language/Haskell/Stylish/Printer.hs +++ b/lib/Language/Haskell/Stylish/Printer.hs @@ -23,7 +23,6 @@ module Language.Haskell.Stylish.Printer , getAnnot , getCurrentLineLength , getDocstrPrev - , indent , newline , parenthesize , peekNextCommentPos @@ -49,7 +48,7 @@ module Language.Haskell.Stylish.Printer ) where -------------------------------------------------------------------------------- -import Language.Haskell.Stylish.GHC (baseDynFlags) +import Prelude hiding (lines) -------------------------------------------------------------------------------- import ApiAnnotation (AnnKeywordId(..), AnnotationComment(..)) @@ -61,10 +60,9 @@ import SrcLoc (GenLocated(..), RealLocated) import SrcLoc (Located, SrcSpan(..)) import SrcLoc (srcSpanStartLine, srcSpanEndLine) import Outputable (Outputable) -import qualified Outputable as GHC -------------------------------------------------------------------------------- -import Control.Monad (forM_, replicateM, replicateM_) +import Control.Monad (forM_, replicateM_) import Control.Monad.Reader (MonadReader, ReaderT(..)) import Control.Monad.State (MonadState, State) import Control.Monad.State (runState) @@ -74,20 +72,22 @@ import Data.Functor ((<&>)) import Data.List (delete, isPrefixOf) import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NonEmpty -import Prelude hiding (lines) -------------------------------------------------------------------------------- -import Language.Haskell.Stylish.Module (Module, lookupAnnotation) -import Language.Haskell.Stylish.GHC (unLocated) +import Language.Haskell.Stylish.Module (Module, Lines, lookupAnnotation) +import Language.Haskell.Stylish.GHC (compareOutputable, showOutputable, unLocated) +-- | Shorthand for 'Printer' monad type P = Printer -type Lines = [String] +-- | Printer that keeps state of file newtype Printer a = Printer (ReaderT PrinterConfig (State PrinterState) a) deriving (Applicative, Functor, Monad, MonadReader PrinterConfig, MonadState PrinterState) +-- | Configuration for printer, currently empty data PrinterConfig = PrinterConfig +-- | State of printer data PrinterState = PrinterState { lines :: Lines , linePos :: !Int @@ -96,6 +96,7 @@ data PrinterState = PrinterState , parsedModule :: Module } +-- | Run printer to get printed lines out of module as well as return value of monad runPrinter :: PrinterConfig -> [RealLocated AnnotationComment] -> Module -> Printer a -> (a, Lines) runPrinter cfg comments m (Printer printer) = let @@ -103,17 +104,21 @@ runPrinter cfg comments m (Printer printer) = in (a, parsedLines <> if startedLine == [] then [] else [startedLine]) +-- | Run printer to get printed lines only runPrinter_ :: PrinterConfig -> [RealLocated AnnotationComment] -> Module -> Printer a -> Lines runPrinter_ cfg comments m printer = snd (runPrinter cfg comments m printer) +-- | Print text putText :: String -> P () putText txt = do l <- gets currentLine modify \s -> s { currentLine = l <> txt } +-- | Print an 'Outputable' putOutputable :: Outputable a => a -> P () putOutputable = putText . showOutputable +-- | Print any comment putComment :: AnnotationComment -> P () putComment = \case AnnLineComment s -> putText s @@ -139,6 +144,7 @@ putEolComment = \case forM_ cmt (\c -> space >> putComment c) UnhelpfulSpan _ -> pure () +-- | Print a 'RdrName' putRdrName :: Located RdrName -> P () putRdrName (L pos n) = case n of Unqual name -> do @@ -163,22 +169,11 @@ putRdrName (L pos n) = case n of Exact name -> putText (showOutputable name) -getDocstrPrev :: SrcSpan -> P (Maybe AnnotationComment) -getDocstrPrev = \case - UnhelpfulSpan _ -> pure Nothing - RealSrcSpan rspan -> do - removeComment \case - L rloc (AnnLineComment s) -> - and - [ srcSpanStartLine rspan == srcSpanStartLine rloc - , "-- ^" `isPrefixOf` s - ] - _ -> False - - +-- | Print module name putModulePrefix :: ModuleName -> P () putModulePrefix = putText . moduleNameString +-- | Print type putType :: Located (HsType GhcPs) -> P () putType ltp = case unLocated ltp of HsFunTy NoExtField argTp funTp -> do @@ -250,61 +245,78 @@ putType ltp = case unLocated ltp of XHsType _ -> putOutputable ltp +-- | Get a docstring on the start line of 'SrcSpan' that is a @-- ^@ comment +getDocstrPrev :: SrcSpan -> P (Maybe AnnotationComment) +getDocstrPrev = \case + UnhelpfulSpan _ -> pure Nothing + RealSrcSpan rspan -> do + removeComment \case + L rloc (AnnLineComment s) -> + and + [ srcSpanStartLine rspan == srcSpanStartLine rloc + , "-- ^" `isPrefixOf` s + ] + _ -> False + +-- | Print a newline newline :: P () newline = do l <- gets currentLine modify \s -> s { currentLine = "", linePos = 0, lines = lines s <> [l] } +-- | Print a space space :: P () space = putText " " +-- | Print a number of spaces spaces :: Int -> P () spaces i = replicateM_ i space +-- | Print a dot dot :: P () dot = putText "." +-- | Print a comma comma :: P () comma = putText "," +-- | Add parens around a printed action parenthesize :: P a -> P a parenthesize action = putText "(" *> action <* putText ")" +-- | Add separator between each element of the given printers sep :: P a -> [P a] -> P () sep _ [] = pure () sep s (first : rest) = first >> forM_ rest ((>>) s) +-- | Prefix a printer with another one prefix :: P a -> P b -> P b prefix pa pb = pa >> pb +-- | Suffix a printer with another one suffix :: P a -> P b -> P a suffix pa pb = pb >> pa -indent :: Int -> P a -> P a -indent i = (>>) (replicateM i space) - -showOutputable :: GHC.Outputable a => a -> String -showOutputable = GHC.showPpr baseDynFlags - -compareOutputable :: GHC.Outputable a => a -> a -> Ordering -compareOutputable i0 i1 = compare (showOutputable i0) (showOutputable i1) - -- | Gets comment on supplied 'line' and removes it from the state removeLineComment :: Int -> P (Maybe AnnotationComment) removeLineComment line = removeComment (\(L rloc _) -> srcSpanStartLine rloc == line) --- | Removes comments from the state up to 'line' and returns the ones that were removed +-- | Removes comments from the state up to start line of 'SrcSpan' and returns +-- the ones that were removed removeCommentTo :: SrcSpan -> P [AnnotationComment] removeCommentTo = \case UnhelpfulSpan _ -> pure [] RealSrcSpan rspan -> removeCommentTo' (srcSpanStartLine rspan) +-- | Removes comments from the state up to end line of 'SrcSpan' and returns +-- the ones that were removed removeCommentToEnd :: SrcSpan -> P [AnnotationComment] removeCommentToEnd = \case UnhelpfulSpan _ -> pure [] RealSrcSpan rspan -> removeCommentTo' (srcSpanEndLine rspan) +-- | Removes comments to the line number given and returns the ones removed removeCommentTo' :: Int -> P [AnnotationComment] removeCommentTo' line = removeComment (\(L rloc _) -> srcSpanStartLine rloc < line) >>= \case @@ -328,18 +340,22 @@ removeComment p = do modify \s -> s { pendingComments = newPendingComments } pure $ fmap (\(L _ c) -> c) foundComment +-- | Get all annotations for 'SrcSpan' getAnnot :: SrcSpan -> P [AnnKeywordId] getAnnot spn = gets (lookupAnnotation spn . parsedModule) +-- | Get current line length getCurrentLineLength :: P Int getCurrentLineLength = fmap length (gets currentLine) +-- | Peek at the next comment in the state peekNextCommentPos :: P (Maybe SrcSpan) peekNextCommentPos = do gets pendingComments <&> \case (L next _ : _) -> Just (RealSrcSpan next) [] -> Nothing +-- | Get sorted attached comments belonging to '[Located a]' given sortedAttachedComments :: Outputable a => [Located a] -> P [([AnnotationComment], NonEmpty (Located a))] sortedAttachedComments origs = go origs <&> fmap sortGroup where diff --git a/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs b/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs index 52b85bec..be6c0339 100644 --- a/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs +++ b/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs @@ -141,7 +141,7 @@ attachEolCommentEnd = \case printExportList :: Located [GHC.LIE GhcPs] -> P () printExportList (L srcLoc exports) = do newline - indent 2 (putText "(") >> when (notNull exports) space + spaces 2 >> putText "(" >> when (notNull exports) space exportsWithComments <- sortedAttachedComments exports From 2822e25ef954494b3b73ea8b46b9a20f6eb19f96 Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Thu, 23 Jul 2020 13:19:03 +0200 Subject: [PATCH 044/135] Fix double space after infix type name --- lib/Language/Haskell/Stylish/Step/Data.hs | 2 +- .../Haskell/Stylish/Step/Data/Tests.hs | 18 ++++++++++++++++++ 2 files changed, 19 insertions(+), 1 deletion(-) diff --git a/lib/Language/Haskell/Stylish/Step/Data.hs b/lib/Language/Haskell/Stylish/Step/Data.hs index 910616db..a0664a2a 100644 --- a/lib/Language/Haskell/Stylish/Step/Data.hs +++ b/lib/Language/Haskell/Stylish/Step/Data.hs @@ -219,7 +219,7 @@ putName decl@MkDataDecl{..} = forM_ firstTvar (\t -> putOutputable t >> space) putRdrName dataDeclName space - forM_ secondTvar (\t -> putOutputable t >> space) + forM_ secondTvar putOutputable else do putRdrName dataDeclName forM_ (hsq_explicit dataTypeVars) (\t -> space >> putOutputable t) diff --git a/tests/Language/Haskell/Stylish/Step/Data/Tests.hs b/tests/Language/Haskell/Stylish/Step/Data/Tests.hs index 93773211..4d1cef7d 100644 --- a/tests/Language/Haskell/Stylish/Step/Data/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Data/Tests.hs @@ -50,6 +50,7 @@ tests = testGroup "Language.Haskell.Stylish.Step.Data.Tests" , testCase "case 37" case37 , testCase "case 38" case38 , testCase "case 39" case39 + , testCase "case 40" case40 ] case00 :: Assertion @@ -898,6 +899,23 @@ case39 = expected @=? testStep (step indentIndentStyle { cVia = Indent 2 }) inpu , " deriving (ToJSON, FromJSON)" , " via (UntaggedEncoded NordeaCreditTransfer & AddConstTextFields '[\"request_type\" ':= \"credit_transfer\", \"provider\" ':= \"nordea\"] & FlattenFields '[\"nested_creditor_info\"] & RenameKeys '[\"nested_creditor_info.creditor_agent_bic\" ==> \"creditor_agent_bic\", \"nested_creditor_info.creditor_iban\" ==> \"creditor_iban\", \"nested_creditor_info.creditor_name\" ==> \"creditor_name\", \"nested_creditor_info.creditor_account\" ==> \"creditor_account\"])" ] + +case40 :: Assertion +case40 = expected @=? testStep (step indentIndentStyle { cBreakSingleConstructors = False }) input + where + input = unlines + [ "module X where" + , "" + , "data a :==> b =" + , " Arr a b" + ] + + expected = unlines + [ "module X where" + , "" + , "data a :==> b = Arr a b" + ] + sameSameStyle :: Config sameSameStyle = Config SameLine SameLine 2 2 False True SameLine From 6b636c814ce395987b011f89d608b927eec21775 Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Thu, 23 Jul 2020 13:41:50 +0200 Subject: [PATCH 045/135] Allow old steps to be run alongside new ones --- lib/Language/Haskell/Stylish.hs | 7 +- lib/Language/Haskell/Stylish/Config.hs | 58 +++---- lib/Language/Haskell/Stylish/Parse.hs | 63 ++++++- lib/Language/Haskell/Stylish/Step.hs | 15 +- lib/Language/Haskell/Stylish/Step/Imports'.hs | 9 +- lib/Language/Haskell/Stylish/Step/Imports.hs | 34 ++-- .../Haskell/Stylish/Step/Imports'/Tests.hs | 4 +- .../Haskell/Stylish/Step/Imports/Tests.hs | 162 +++++++++++++----- 8 files changed, 237 insertions(+), 115 deletions(-) diff --git a/lib/Language/Haskell/Stylish.hs b/lib/Language/Haskell/Stylish.hs index 2610f38c..220eff99 100644 --- a/lib/Language/Haskell/Stylish.hs +++ b/lib/Language/Haskell/Stylish.hs @@ -91,8 +91,11 @@ unicodeSyntax = UnicodeSyntax.step -------------------------------------------------------------------------------- runStep :: Extensions -> Maybe FilePath -> Lines -> Step -> Either String Lines -runStep exts mfp ls step = - stepFilter step ls <$> parseModule exts mfp (unlines ls) +runStep exts mfp ls = \case + Step _name step -> + step ls <$> parseModule exts mfp (unlines ls) + OldStep _name step -> + step ls <$> parseModuleHSE exts mfp (unlines ls) -------------------------------------------------------------------------------- runSteps :: diff --git a/lib/Language/Haskell/Stylish/Config.hs b/lib/Language/Haskell/Stylish/Config.hs index 75851055..6a051cfd 100644 --- a/lib/Language/Haskell/Stylish/Config.hs +++ b/lib/Language/Haskell/Stylish/Config.hs @@ -1,4 +1,5 @@ -------------------------------------------------------------------------------- +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} module Language.Haskell.Stylish.Config @@ -161,8 +162,8 @@ parseConfig _ = mzero -------------------------------------------------------------------------------- catalog :: Map String (Config -> A.Object -> A.Parser Step) catalog = M.fromList $ - if False then [ ("imports", parseImports) + , ("module_header", parseModuleHeader) , ("records", parseRecords) , ("language_pragmas", parseLanguagePragmas) , ("simple_align", parseSimpleAlign) @@ -171,20 +172,6 @@ catalog = M.fromList $ , ("trailing_whitespace", parseTrailingWhitespace) , ("unicode_syntax", parseUnicodeSyntax) ] - else - -- Done: - [ ("imports", parseImports') - , ("module_header", parseModuleHeader) - , ("records", parseRecords) - , ("tabs", parseTabs) - , ("trailing_whitespace", parseTrailingWhitespace) - ] - -- To be ported: - -- * data (records) - -- * language_pragmas - -- * simple_align - -- * squash - -- * unicode_syntax -------------------------------------------------------------------------------- @@ -256,20 +243,26 @@ parseSquash _ _ = return Squash.step -------------------------------------------------------------------------------- parseImports :: Config -> A.Object -> A.Parser Step -parseImports config o = Imports.step - <$> pure (configColumns config) - <*> (Imports.Options - <$> (o A..:? "align" >>= parseEnum aligns (def Imports.importAlign)) - <*> (o A..:? "list_align" >>= parseEnum listAligns (def Imports.listAlign)) - <*> (o A..:? "pad_module_names" A..!= def Imports.padModuleNames) - <*> (o A..:? "long_list_align" - >>= parseEnum longListAligns (def Imports.longListAlign)) - -- Note that padding has to be at least 1. Default is 4. - <*> (o A..:? "empty_list_align" - >>= parseEnum emptyListAligns (def Imports.emptyListAlign)) - <*> o A..:? "list_padding" A..!= def Imports.listPadding - <*> o A..:? "separate_lists" A..!= def Imports.separateLists - <*> o A..:? "space_surround" A..!= def Imports.spaceSurround) +parseImports config o = do + cfg <- + Imports.Options + <$> (o A..:? "align" >>= parseEnum aligns (def Imports.importAlign)) + <*> (o A..:? "list_align" >>= parseEnum listAligns (def Imports.listAlign)) + <*> (o A..:? "pad_module_names" A..!= def Imports.padModuleNames) + <*> (o A..:? "long_list_align" >>= parseEnum longListAligns (def Imports.longListAlign)) + -- Note that padding has to be at least 1. Default is 4. + <*> (o A..:? "empty_list_align" >>= parseEnum emptyListAligns (def Imports.emptyListAlign)) + <*> o A..:? "list_padding" A..!= def Imports.listPadding + <*> o A..:? "separate_lists" A..!= def Imports.separateLists + <*> o A..:? "space_surround" A..!= def Imports.spaceSurround + <*> o A..:? "ghc_lib_parser" A..!= False + + pure + if Imports.useGhcLibParser cfg then + Imports'.step cfg + else + Imports.step (configColumns config) cfg + where def f = f Imports.defaultOptions @@ -299,13 +292,6 @@ parseImports config o = Imports.step , ("right_after", Imports.RightAfter) ] --------------------------------------------------------------------------------- -parseImports' :: Config -> A.Object -> A.Parser Step -parseImports' _ _ - = pure - . Imports'.step - $ Imports'.Config - -------------------------------------------------------------------------------- parseLanguagePragmas :: Config -> A.Object -> A.Parser Step parseLanguagePragmas config o = LanguagePragmas.step diff --git a/lib/Language/Haskell/Stylish/Parse.hs b/lib/Language/Haskell/Stylish/Parse.hs index 125241ac..8e86bfff 100644 --- a/lib/Language/Haskell/Stylish/Parse.hs +++ b/lib/Language/Haskell/Stylish/Parse.hs @@ -2,13 +2,18 @@ -------------------------------------------------------------------------------- module Language.Haskell.Stylish.Parse ( parseModule + , parseModuleHSE ) where -------------------------------------------------------------------------------- -import Bag (bagToList) import Data.Function ((&)) +import Data.List (isPrefixOf, nub) import Data.Maybe (fromMaybe, listToMaybe) +import System.IO.Unsafe (unsafePerformIO) + +-------------------------------------------------------------------------------- +import Bag (bagToList) import qualified DynFlags as GHC import FastString (mkFastString) import qualified GHC.Hs as GHC @@ -25,11 +30,14 @@ import SrcLoc (mkRealSrcLoc) import qualified SrcLoc as GHC import StringBuffer (stringToStringBuffer) import qualified StringBuffer as GHC -import System.IO.Unsafe (unsafePerformIO) + +-------------------------------------------------------------------------------- +import qualified Language.Haskell.Exts as H -------------------------------------------------------------------------------- import Language.Haskell.Stylish.GHC (baseDynFlags) import Language.Haskell.Stylish.Module +import Language.Haskell.Stylish.Step (OldModule) type Extensions = [String] @@ -119,3 +127,54 @@ parsePragmasIntoDynFlags originalFlags extraOpts filepath str = unsafePerformIO where catchErrors act = GHC.handleGhcException reportErr (GHC.handleSourceError reportErr act) reportErr e = return $ Left (show e) + +-------------------------------------------------------------------------------- +-- | Abstraction over HSE's parsing +parseModuleHSE :: Extensions -> Maybe FilePath -> String -> Either String OldModule +parseModuleHSE extraExts mfp string = do + -- Determine the extensions: those specified in the file and the extra ones + let noPrefixes = unShebang . dropBom $ string + extraExts' = map H.classifyExtension extraExts + (lang, fileExts) = fromMaybe (Nothing, []) $ H.readExtensions noPrefixes + exts = nub $ fileExts ++ extraExts' ++ defaultExtensions + + -- Parsing options... + fp = fromMaybe "" mfp + mode = H.defaultParseMode + { H.extensions = exts + , H.fixities = Nothing + , H.baseLanguage = case lang of + Nothing -> H.baseLanguage H.defaultParseMode + Just l -> l + } + + -- Preprocessing + processed = if H.EnableExtension H.CPP `elem` exts + then unCpp noPrefixes + else noPrefixes + + case H.parseModuleWithComments mode processed of + H.ParseOk md -> return md + err -> Left $ + "Language.Haskell.Stylish.Parse.parseModule: could not parse " ++ + fp ++ ": " ++ show err + where + -- | Remove shebang lines + unShebang :: String -> String + unShebang str = + let (shebangs, other) = break (not . ("#!" `isPrefixOf`)) (lines str) in + unlines $ map (const "") shebangs ++ other + + -- | Syntax-related language extensions are always enabled for parsing. Since we + -- can't authoritatively know which extensions are enabled at compile-time, we + -- should try not to throw errors when parsing any GHC-accepted code. + defaultExtensions :: [H.Extension] + defaultExtensions = map H.EnableExtension + [ H.GADTs + , H.HereDocuments + , H.KindSignatures + , H.NewQualifiedOperators + , H.PatternGuards + , H.StandaloneDeriving + , H.UnicodeSyntax + ] diff --git a/lib/Language/Haskell/Stylish/Step.hs b/lib/Language/Haskell/Stylish/Step.hs index 27250af9..9b728529 100644 --- a/lib/Language/Haskell/Stylish/Step.hs +++ b/lib/Language/Haskell/Stylish/Step.hs @@ -16,14 +16,19 @@ import Language.Haskell.Stylish.Module type OldModule = (H.Module H.SrcSpanInfo, [H.Comment]) -------------------------------------------------------------------------------- -data Step = Step - { stepName :: String - , stepFilter :: Lines -> Module -> Lines - } +data Step + = Step + { stepName :: String + , stepFilter :: Lines -> Module -> Lines + } + | OldStep + { stepName :: String + , oldStepFilter :: Lines -> OldModule -> Lines + } -------------------------------------------------------------------------------- makeStep :: String -> (Lines -> Module -> Lines) -> Step makeStep = Step oldMakeStep :: String -> (Lines -> OldModule -> Lines) -> Step -oldMakeStep = undefined +oldMakeStep = OldStep diff --git a/lib/Language/Haskell/Stylish/Step/Imports'.hs b/lib/Language/Haskell/Stylish/Step/Imports'.hs index 296fad69..318eaa08 100644 --- a/lib/Language/Haskell/Stylish/Step/Imports'.hs +++ b/lib/Language/Haskell/Stylish/Step/Imports'.hs @@ -2,7 +2,7 @@ {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE LambdaCase #-} module Language.Haskell.Stylish.Step.Imports' - ( Config (..) + ( Options (..) , step ) where @@ -31,14 +31,13 @@ import Language.Haskell.Stylish.Printer import Language.Haskell.Stylish.Step import Language.Haskell.Stylish.Editor import Language.Haskell.Stylish.GHC +import Language.Haskell.Stylish.Step.Imports (Options(..)) -data Config = Config - -step :: Config -> Step +step :: Options -> Step step = makeStep "Imports" . printImports -------------------------------------------------------------------------------- -printImports :: Config -> Lines -> Module -> Lines +printImports :: Options -> Lines -> Module -> Lines printImports _ ls m = formatForImportGroups ls m (moduleImportGroups m) formatForImportGroups :: Lines -> Module -> [Imports] -> Lines diff --git a/lib/Language/Haskell/Stylish/Step/Imports.hs b/lib/Language/Haskell/Stylish/Step/Imports.hs index 014035a9..cc353a01 100644 --- a/lib/Language/Haskell/Stylish/Step/Imports.hs +++ b/lib/Language/Haskell/Stylish/Step/Imports.hs @@ -35,26 +35,28 @@ import Language.Haskell.Stylish.Util -------------------------------------------------------------------------------- data Options = Options - { importAlign :: ImportAlign - , listAlign :: ListAlign - , padModuleNames :: Bool - , longListAlign :: LongListAlign - , emptyListAlign :: EmptyListAlign - , listPadding :: ListPadding - , separateLists :: Bool - , spaceSurround :: Bool + { importAlign :: ImportAlign + , listAlign :: ListAlign + , padModuleNames :: Bool + , longListAlign :: LongListAlign + , emptyListAlign :: EmptyListAlign + , listPadding :: ListPadding + , separateLists :: Bool + , spaceSurround :: Bool + , useGhcLibParser :: Bool -- ^ if True, will use new printer } deriving (Eq, Show) defaultOptions :: Options defaultOptions = Options - { importAlign = Global - , listAlign = AfterAlias - , padModuleNames = True - , longListAlign = Inline - , emptyListAlign = Inherit - , listPadding = LPConstant 4 - , separateLists = True - , spaceSurround = False + { importAlign = Global + , listAlign = AfterAlias + , padModuleNames = True + , longListAlign = Inline + , emptyListAlign = Inherit + , listPadding = LPConstant 4 + , separateLists = True + , spaceSurround = False + , useGhcLibParser = False } data ListPadding diff --git a/tests/Language/Haskell/Stylish/Step/Imports'/Tests.hs b/tests/Language/Haskell/Stylish/Step/Imports'/Tests.hs index 2e370d8d..2d3a26c7 100644 --- a/tests/Language/Haskell/Stylish/Step/Imports'/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Imports'/Tests.hs @@ -12,9 +12,9 @@ import Prelude hiding (lines) -------------------------------------------------------------------------------- import Language.Haskell.Stylish.Module +import Language.Haskell.Stylish.Step.Imports (defaultOptions) import Language.Haskell.Stylish.Step.Imports' (step) import Language.Haskell.Stylish.Tests.Util (testStep') -import qualified Language.Haskell.Stylish.Step.Imports' as Imports @@ -226,4 +226,4 @@ ex11 = input `assertFormatted` output -------------------------------------------------------------------------------- assertFormatted :: HasCallStack => Lines -> Lines -> Assertion -assertFormatted input expected = withFrozenCallStack $ expected @=? testStep' (step Imports.Config) input +assertFormatted input expected = withFrozenCallStack $ expected @=? testStep' (step defaultOptions) input diff --git a/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs index 22031d4d..4aa94b41 100644 --- a/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs @@ -197,8 +197,11 @@ case07 = expected @=? testStep (step (Just 80) $ fromImportAlign File) input' -------------------------------------------------------------------------------- case08 :: Assertion -case08 = expected - @=? testStep (step (Just 80) $ Options Global WithAlias True Inline Inherit (LPConstant 4) True False) input +case08 = + let + options = Options Global WithAlias True Inline Inherit (LPConstant 4) True False False + in + expected @=? testStep (step (Just 80) options) input where expected = unlines [ "module Herp where" @@ -220,8 +223,11 @@ case08 = expected -------------------------------------------------------------------------------- case08b :: Assertion -case08b = expected - @=? testStep (step (Just 80) $ Options Global WithModuleName True Inline Inherit (LPConstant 4) True False) input +case08b = + let + options = Options Global WithModuleName True Inline Inherit (LPConstant 4) True False False + in + expected @=? testStep (step (Just 80) options) input where expected = unlines ["module Herp where" @@ -242,8 +248,11 @@ case08b = expected -------------------------------------------------------------------------------- case09 :: Assertion -case09 = expected - @=? testStep (step (Just 80) $ Options Global WithAlias True Multiline Inherit (LPConstant 4) True False) input +case09 = + let + options = Options Global WithAlias True Multiline Inherit (LPConstant 4) True False False + in + expected @=? testStep (step (Just 80) options) input where expected = unlines [ "module Herp where" @@ -276,8 +285,11 @@ case09 = expected -------------------------------------------------------------------------------- case10 :: Assertion -case10 = expected - @=? testStep (step (Just 40) $ Options Group WithAlias True Multiline Inherit (LPConstant 4) True False) input +case10 = + let + options = Options Group WithAlias True Multiline Inherit (LPConstant 4) True False False + in + expected @=? testStep (step (Just 40) options) input where expected = unlines [ "module Herp where" @@ -315,8 +327,11 @@ case10 = expected -------------------------------------------------------------------------------- case11 :: Assertion -case11 = expected - @=? testStep (step (Just 80) $ Options Group NewLine True Inline Inherit (LPConstant 4) True False) input +case11 = + let + options = Options Group NewLine True Inline Inherit (LPConstant 4) True False False + in + expected @=? testStep (step (Just 80) options) input where expected = unlines [ "module Herp where" @@ -342,8 +357,11 @@ case11 = expected case11b :: Assertion -case11b = expected - @=? testStep (step (Just 80) $ Options Group WithModuleName True Inline Inherit (LPConstant 4) True False) input +case11b = + let + options = Options Group WithModuleName True Inline Inherit (LPConstant 4) True False False + in + expected @=? testStep (step (Just 80) options) input where expected = unlines [ "module Herp where" @@ -364,8 +382,11 @@ case11b = expected -------------------------------------------------------------------------------- case12 :: Assertion -case12 = expected - @=? testStep (step (Just 80) $ Options Group NewLine True Inline Inherit (LPConstant 2) True False) input' +case12 = + let + options = Options Group NewLine True Inline Inherit (LPConstant 2) True False False + in + expected @=? testStep (step (Just 80) options) input' where input' = unlines [ "import Data.List (map)" @@ -379,8 +400,11 @@ case12 = expected -------------------------------------------------------------------------------- case12b :: Assertion -case12b = expected - @=? testStep (step (Just 80) $ Options Group WithModuleName True Inline Inherit (LPConstant 2) True False) input' +case12b = + let + options = Options Group WithModuleName True Inline Inherit (LPConstant 2) True False False + in + expected @=? testStep (step (Just 80) options) input' where input' = unlines [ "import Data.List (map)" @@ -391,8 +415,11 @@ case12b = expected -------------------------------------------------------------------------------- case13 :: Assertion -case13 = expected - @=? testStep (step (Just 80) $ Options None WithAlias True InlineWithBreak Inherit (LPConstant 4) True False) input' +case13 = + let + options = Options None WithAlias True InlineWithBreak Inherit (LPConstant 4) True False False + in + expected @=? testStep (step (Just 80) options) input' where input' = unlines [ "import qualified Data.List as List (concat, foldl, foldr, head, init," @@ -408,8 +435,11 @@ case13 = expected -------------------------------------------------------------------------------- case13b :: Assertion -case13b = expected - @=? testStep (step (Just 80) $ Options None WithModuleName True InlineWithBreak Inherit (LPConstant 4) True False) input' +case13b = + let + options = Options None WithModuleName True InlineWithBreak Inherit (LPConstant 4) True False False + in + expected @=? testStep (step (Just 80) options) input' where input' = unlines [ "import qualified Data.List as List (concat, foldl, foldr, head, init," @@ -425,9 +455,11 @@ case13b = expected -------------------------------------------------------------------------------- case14 :: Assertion -case14 = expected - @=? testStep - (step (Just 80) $ Options None WithAlias True InlineWithBreak Inherit (LPConstant 10) True False) expected +case14 = + let + options = Options None WithAlias True InlineWithBreak Inherit (LPConstant 10) True False False + in + expected @=? testStep (step (Just 80) options) expected where expected = unlines [ "import qualified Data.List as List (concat, map, null, reverse, tail, (++))" @@ -436,8 +468,11 @@ case14 = expected -------------------------------------------------------------------------------- case15 :: Assertion -case15 = expected - @=? testStep (step (Just 80) $ Options None AfterAlias True Multiline Inherit (LPConstant 4) True False) input' +case15 = + let + options = Options None AfterAlias True Multiline Inherit (LPConstant 4) True False False + in + expected @=? testStep (step (Just 80) options) input' where expected = unlines [ "import Data.Acid (AcidState)" @@ -462,8 +497,11 @@ case15 = expected -------------------------------------------------------------------------------- case16 :: Assertion -case16 = expected - @=? testStep (step (Just 80) $ Options None AfterAlias True Multiline Inherit (LPConstant 4) False False) input' +case16 = + let + options = Options None AfterAlias True Multiline Inherit (LPConstant 4) False False False + in + expected @=? testStep (step (Just 80) options) input' where expected = unlines [ "import Data.Acid (AcidState)" @@ -486,8 +524,11 @@ case16 = expected -------------------------------------------------------------------------------- case17 :: Assertion -case17 = expected - @=? testStep (step (Just 80) $ Options None AfterAlias True Multiline Inherit (LPConstant 4) True False) input' +case17 = + let + options = Options None AfterAlias True Multiline Inherit (LPConstant 4) True False False + in + expected @=? testStep (step (Just 80) options) input' where expected = unlines [ "import Control.Applicative (Applicative (pure, (<*>)))" @@ -504,8 +545,11 @@ case17 = expected -------------------------------------------------------------------------------- case18 :: Assertion -case18 = expected @=? testStep - (step (Just 40) $ Options None AfterAlias True InlineToMultiline Inherit (LPConstant 4) True False) input' +case18 = + let + options = Options None AfterAlias True InlineToMultiline Inherit (LPConstant 4) True False False + in + expected @=? testStep (step (Just 40) options) input' where expected = unlines ---------------------------------------- @@ -532,8 +576,11 @@ case18 = expected @=? testStep -------------------------------------------------------------------------------- case19 :: Assertion -case19 = expected @=? testStep - (step (Just 40) $ Options Global NewLine True InlineWithBreak RightAfter (LPConstant 17) True False) case19input +case19 = + let + options = Options Global NewLine True InlineWithBreak RightAfter (LPConstant 17) True False False + in + expected @=? testStep (step (Just 40) options) case19input where expected = unlines ---------------------------------------- @@ -548,8 +595,11 @@ case19 = expected @=? testStep case19b :: Assertion -case19b = expected @=? testStep - (step (Just 40) $ Options File NewLine True InlineWithBreak RightAfter (LPConstant 17) True False) case19input +case19b = + let + options = Options File NewLine True InlineWithBreak RightAfter (LPConstant 17) True False False + in + expected @=? testStep (step (Just 40) options) case19input where expected = unlines ---------------------------------------- @@ -564,8 +614,11 @@ case19b = expected @=? testStep case19c :: Assertion -case19c = expected @=? testStep - (step (Just 40) $ Options File NewLine True InlineWithBreak RightAfter LPModuleName True False) case19input +case19c = + let + options = Options File NewLine True InlineWithBreak RightAfter LPModuleName True False False + in + expected @=? testStep (step (Just 40) options) case19input where expected = unlines ---------------------------------------- @@ -580,8 +633,11 @@ case19c = expected @=? testStep case19d :: Assertion -case19d = expected @=? testStep - (step (Just 40) $ Options Global NewLine True InlineWithBreak RightAfter LPModuleName True False) case19input +case19d = + let + options = Options Global NewLine True InlineWithBreak RightAfter LPModuleName True False False + in + expected @=? testStep (step (Just 40) options) case19input where expected = unlines ---------------------------------------- @@ -683,8 +739,11 @@ case22 = expected -------------------------------------------------------------------------------- case23 :: Assertion -case23 = expected - @=? testStep (step (Just 40) $ Options None AfterAlias False Inline Inherit (LPConstant 4) True True) input' +case23 = + let + options = Options None AfterAlias False Inline Inherit (LPConstant 4) True True False + in + expected @=? testStep (step (Just 40) options) input' where expected = unlines [ "import Data.Acid ( AcidState )" @@ -708,8 +767,11 @@ case23 = expected -------------------------------------------------------------------------------- case23b :: Assertion -case23b = expected - @=? testStep (step (Just 40) $ Options None WithModuleName False Inline Inherit (LPConstant 4) True True) input' +case23b = + let + options = Options None WithModuleName False Inline Inherit (LPConstant 4) True True False + in + expected @=? testStep (step (Just 40) options) input' where expected = unlines [ "import Data.Acid ( AcidState )" @@ -734,8 +796,11 @@ case23b = expected -------------------------------------------------------------------------------- case24 :: Assertion -case24 = expected - @=? testStep (step (Just 40) $ Options None AfterAlias False InlineWithBreak Inherit (LPConstant 4) True True) input' +case24 = + let + options = Options None AfterAlias False InlineWithBreak Inherit (LPConstant 4) True True False + in + expected @=? testStep (step (Just 40) options) input' where expected = unlines [ "import Data.Acid ( AcidState )" @@ -758,8 +823,11 @@ case24 = expected -------------------------------------------------------------------------------- case25 :: Assertion -case25 = expected - @=? testStep (step (Just 80) $ Options Group AfterAlias False Multiline Inherit (LPConstant 4) False False) input' +case25 = + let + options = Options Group AfterAlias False Multiline Inherit (LPConstant 4) False False False + in + expected @=? testStep (step (Just 80) options) input' where expected = unlines [ "import Data.Acid (AcidState)" From b8677cd221070285cf484fe08980841637940e22 Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Thu, 23 Jul 2020 15:05:07 +0200 Subject: [PATCH 046/135] Fix issue where comment is not printed after type name and newline --- lib/Language/Haskell/Stylish/Step/Data.hs | 2 +- .../Haskell/Stylish/Step/Data/Tests.hs | 28 +++++++++++++++++++ 2 files changed, 29 insertions(+), 1 deletion(-) diff --git a/lib/Language/Haskell/Stylish/Step/Data.hs b/lib/Language/Haskell/Stylish/Step/Data.hs index a0664a2a..2b1d8344 100644 --- a/lib/Language/Haskell/Stylish/Step/Data.hs +++ b/lib/Language/Haskell/Stylish/Step/Data.hs @@ -135,7 +135,7 @@ formatDataDecl cfg m ldecl@(L declPos decl) = case dd_cons defn of [] -> pure () lcon@(L pos _) : consRest -> do - unless (cFirstField cfg == SameLine) do + unless (cFirstField cfg == SameLine || length consRest == 1 && not (cBreakSingleConstructors cfg)) do removeCommentTo pos >>= mapM_ \c -> putComment c >> consIndent lineLengthAfterEq putText "=" space diff --git a/tests/Language/Haskell/Stylish/Step/Data/Tests.hs b/tests/Language/Haskell/Stylish/Step/Data/Tests.hs index 4d1cef7d..d220759d 100644 --- a/tests/Language/Haskell/Stylish/Step/Data/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Data/Tests.hs @@ -51,6 +51,7 @@ tests = testGroup "Language.Haskell.Stylish.Step.Data.Tests" , testCase "case 38" case38 , testCase "case 39" case39 , testCase "case 40" case40 + , testCase "case 41" case41 ] case00 :: Assertion @@ -916,6 +917,33 @@ case40 = expected @=? testStep (step indentIndentStyle { cBreakSingleConstructor , "data a :==> b = Arr a b" ] +case41 :: Assertion +case41 = expected @=? testStep (step indentIndentStyle) input + where + input = expected + + expected = unlines + [ "module X where" + , "" + , "data Callback" + , " -- | Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor" + , " -- incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis" + , " -- nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat." + , " -- Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore" + , " -- eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident," + , " -- sunt in culpa qui officia deserunt mollit anim id est laborum." + , " = KafkaTopic" + , " { callbackTopic :: CallbackTopic" + , " -- ^ Name of topic to send updates to" + , " , callbackFormat :: CallbackFormat" + , " -- ^ The format used to send these updates" + , " }" + , " deriving stock (Generic, Eq, Show)" + , " deriving (ToJSON, FromJSON) via IdiomaticWithDescription CallbackDesc Callback" + , " deriving (HasGen) via Generically Callback" + , " deriving (FromField) via JsonField Callback" + ] + sameSameStyle :: Config sameSameStyle = Config SameLine SameLine 2 2 False True SameLine From 8826da318a7ec5ce529e89152c9d28eebbae5495 Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Thu, 23 Jul 2020 15:12:46 +0200 Subject: [PATCH 047/135] Add missing EOL comment printing to constructors --- lib/Language/Haskell/Stylish/Step/Data.hs | 1 + tests/Language/Haskell/Stylish/Step/Data/Tests.hs | 15 +++++++++++++++ 2 files changed, 16 insertions(+) diff --git a/lib/Language/Haskell/Stylish/Step/Data.hs b/lib/Language/Haskell/Stylish/Step/Data.hs index 2b1d8344..9c31b574 100644 --- a/lib/Language/Haskell/Stylish/Step/Data.hs +++ b/lib/Language/Haskell/Stylish/Step/Data.hs @@ -147,6 +147,7 @@ formatDataDecl cfg m ldecl@(L declPos decl) = putText "|" space putConstructor cfg lineLengthAfterEq con + putEolComment conPos when (hasDeriving decl) do if isEnum decl && not (cBreakEnums cfg) then diff --git a/tests/Language/Haskell/Stylish/Step/Data/Tests.hs b/tests/Language/Haskell/Stylish/Step/Data/Tests.hs index d220759d..45ce982e 100644 --- a/tests/Language/Haskell/Stylish/Step/Data/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Data/Tests.hs @@ -52,6 +52,7 @@ tests = testGroup "Language.Haskell.Stylish.Step.Data.Tests" , testCase "case 39" case39 , testCase "case 40" case40 , testCase "case 41" case41 + , testCase "case 42" case42 ] case00 :: Assertion @@ -944,6 +945,20 @@ case41 = expected @=? testStep (step indentIndentStyle) input , " deriving (FromField) via JsonField Callback" ] +case42 :: Assertion +case42 = expected @=? testStep (step indentIndentStyle) input + where + input = expected + + expected = unlines + [ "module X where" + , "" + , "data SignupError" + , " = IdempotencyConflict" + , " | ValidationError Text -- TODO: might be a sumtype of possible error codes" + , " deriving stock (Generic, Show, Eq)" + ] + sameSameStyle :: Config sameSameStyle = Config SameLine SameLine 2 2 False True SameLine From 126577e4555166c126acb21dc2740748285fdaf6 Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Thu, 23 Jul 2020 15:23:55 +0200 Subject: [PATCH 048/135] Rename step to show that it's using ghc-lib-parser --- lib/Language/Haskell/Stylish/Step/Imports'.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/Language/Haskell/Stylish/Step/Imports'.hs b/lib/Language/Haskell/Stylish/Step/Imports'.hs index 318eaa08..29e096ce 100644 --- a/lib/Language/Haskell/Stylish/Step/Imports'.hs +++ b/lib/Language/Haskell/Stylish/Step/Imports'.hs @@ -34,7 +34,7 @@ import Language.Haskell.Stylish.GHC import Language.Haskell.Stylish.Step.Imports (Options(..)) step :: Options -> Step -step = makeStep "Imports" . printImports +step = makeStep "Imports (ghc-lib-parser)" . printImports -------------------------------------------------------------------------------- printImports :: Options -> Lines -> Module -> Lines From 1749866d081dee2a6453e685cc787c504f45dc23 Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Thu, 23 Jul 2020 15:24:09 +0200 Subject: [PATCH 049/135] Fix incorrect error string in parseModuleHSE --- lib/Language/Haskell/Stylish/Parse.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/Language/Haskell/Stylish/Parse.hs b/lib/Language/Haskell/Stylish/Parse.hs index 8e86bfff..a284cde0 100644 --- a/lib/Language/Haskell/Stylish/Parse.hs +++ b/lib/Language/Haskell/Stylish/Parse.hs @@ -156,7 +156,7 @@ parseModuleHSE extraExts mfp string = do case H.parseModuleWithComments mode processed of H.ParseOk md -> return md err -> Left $ - "Language.Haskell.Stylish.Parse.parseModule: could not parse " ++ + "Language.Haskell.Stylish.Parse.parseModuleHSE: could not parse " ++ fp ++ ": " ++ show err where -- | Remove shebang lines From 0271e8a32a90998efd9385ba979e767822c2a3d0 Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Thu, 23 Jul 2020 16:45:40 +0200 Subject: [PATCH 050/135] Fix off-by-one error --- lib/Language/Haskell/Stylish/Step/Data.hs | 2 +- .../Language/Haskell/Stylish/Step/Data/Tests.hs | 17 +++++++++++++++++ 2 files changed, 18 insertions(+), 1 deletion(-) diff --git a/lib/Language/Haskell/Stylish/Step/Data.hs b/lib/Language/Haskell/Stylish/Step/Data.hs index 9c31b574..6c30f637 100644 --- a/lib/Language/Haskell/Stylish/Step/Data.hs +++ b/lib/Language/Haskell/Stylish/Step/Data.hs @@ -135,7 +135,7 @@ formatDataDecl cfg m ldecl@(L declPos decl) = case dd_cons defn of [] -> pure () lcon@(L pos _) : consRest -> do - unless (cFirstField cfg == SameLine || length consRest == 1 && not (cBreakSingleConstructors cfg)) do + unless (cFirstField cfg == SameLine || null consRest && not (cBreakSingleConstructors cfg)) do removeCommentTo pos >>= mapM_ \c -> putComment c >> consIndent lineLengthAfterEq putText "=" space diff --git a/tests/Language/Haskell/Stylish/Step/Data/Tests.hs b/tests/Language/Haskell/Stylish/Step/Data/Tests.hs index 45ce982e..0eb548da 100644 --- a/tests/Language/Haskell/Stylish/Step/Data/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Data/Tests.hs @@ -53,6 +53,7 @@ tests = testGroup "Language.Haskell.Stylish.Step.Data.Tests" , testCase "case 40" case40 , testCase "case 41" case41 , testCase "case 42" case42 + , testCase "case 43" case43 ] case00 :: Assertion @@ -959,6 +960,22 @@ case42 = expected @=? testStep (step indentIndentStyle) input , " deriving stock (Generic, Show, Eq)" ] +case43 :: Assertion +case43 = expected @=? testStep (step indentIndentStyle { cBreakEnums = True, cBreakSingleConstructors = False }) input + where + input = expected + + expected = unlines + [ "module X where" + , "" + , "data CallbackResult" + , " -- | Callback successfully sent" + , " = Success" + , " -- | Kafka error received" + , " | KafkaIssue KafkaError" + , " deriving (Eq, Show)" + ] + sameSameStyle :: Config sameSameStyle = Config SameLine SameLine 2 2 False True SameLine From e406fa103aa841d9a0678c9db17f849c9a0551c7 Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Thu, 23 Jul 2020 18:02:35 +0200 Subject: [PATCH 051/135] Work around edge-case where there are comments _in_ a deriving block --- lib/Language/Haskell/Stylish/Printer.hs | 20 +++++++++ lib/Language/Haskell/Stylish/Step/Data.hs | 29 ++++++------ .../Haskell/Stylish/Step/Data/Tests.hs | 44 +++++++++++++++++++ 3 files changed, 79 insertions(+), 14 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Printer.hs b/lib/Language/Haskell/Stylish/Printer.hs index 9b1ffc2c..85f5d198 100644 --- a/lib/Language/Haskell/Stylish/Printer.hs +++ b/lib/Language/Haskell/Stylish/Printer.hs @@ -30,6 +30,7 @@ module Language.Haskell.Stylish.Printer , putComment , putEolComment , putOutputable + , putAllSpanComments , putType , putRdrName , putText @@ -118,6 +119,16 @@ putText txt = do putOutputable :: Outputable a => a -> P () putOutputable = putText . showOutputable +putAllSpanComments :: P () -> SrcSpan -> P () +putAllSpanComments suff = \case + UnhelpfulSpan _ -> pure () + RealSrcSpan rspan -> do + cmts <- removeComments \(L rloc _) -> + srcSpanStartLine rloc >= srcSpanStartLine rspan && + srcSpanEndLine rloc <= srcSpanEndLine rspan + + forM_ cmts (\c -> putComment c >> suff) + -- | Print any comment putComment :: AnnotationComment -> P () putComment = \case @@ -325,6 +336,15 @@ removeCommentTo' line = rest <- removeCommentTo' line pure (c : rest) +-- | Removes comments from the state while given predicate 'p' is true +removeComments :: (RealLocated AnnotationComment -> Bool) -> P [AnnotationComment] +removeComments p = + removeComment p >>= \case + Just c -> do + rest <- removeComments p + pure (c : rest) + Nothing -> pure [] + -- | Remove a comment from the state given predicate 'p' removeComment :: (RealLocated AnnotationComment -> Bool) -> P (Maybe AnnotationComment) removeComment p = do diff --git a/lib/Language/Haskell/Stylish/Step/Data.hs b/lib/Language/Haskell/Stylish/Step/Data.hs index 6c30f637..90719d63 100644 --- a/lib/Language/Haskell/Stylish/Step/Data.hs +++ b/lib/Language/Haskell/Stylish/Step/Data.hs @@ -14,6 +14,7 @@ import Prelude hiding (init) -------------------------------------------------------------------------------- import Control.Monad (forM_, unless, when) import Data.Function ((&)) +import Data.Functor ((<&>)) import Data.Maybe (listToMaybe, mapMaybe) -------------------------------------------------------------------------------- @@ -92,7 +93,7 @@ step cfg = makeStep "Data" \ls m -> applyChanges (changes m) ls type ChangeLine = Change String formatDataDecl :: Config -> Module -> Located DataDecl -> ChangeLine -formatDataDecl cfg m ldecl@(L declPos decl) = +formatDataDecl cfg@Config{..} m ldecl@(L declPos decl) = change originalDeclBlock (const printedDecl) where relevantComments :: [RealLocated AnnotationComment] @@ -112,14 +113,14 @@ formatDataDecl cfg m ldecl@(L declPos decl) = putName decl when (hasConstructors decl) do - case (cEquals cfg, cFirstField cfg) of - (_, Indent x) | isEnum decl && cBreakEnums cfg -> do + case (cEquals, cFirstField) of + (_, Indent x) | isEnum decl && cBreakEnums -> do putEolComment declPos newline >> spaces x - (_, _) | not (isNewtype decl) && singleConstructor decl && not (cBreakSingleConstructors cfg) -> + (_, _) | not (isNewtype decl) && singleConstructor decl && not cBreakSingleConstructors -> space (Indent x, _) - | isEnum decl && not (cBreakEnums cfg) -> space + | isEnum decl && not cBreakEnums -> space | otherwise -> do putEolComment declPos newline >> spaces x @@ -127,7 +128,7 @@ formatDataDecl cfg m ldecl@(L declPos decl) = lineLengthAfterEq <- fmap (+2) getCurrentLineLength - if isEnum decl && not (cBreakEnums cfg) then + if isEnum decl && not cBreakEnums then putText "=" >> space >> putUnbrokenEnum cfg decl else if isNewtype decl then putText "=" >> space >> forM_ (dd_cons defn) (putNewtypeConstructor cfg) @@ -135,13 +136,13 @@ formatDataDecl cfg m ldecl@(L declPos decl) = case dd_cons defn of [] -> pure () lcon@(L pos _) : consRest -> do - unless (cFirstField cfg == SameLine || null consRest && not (cBreakSingleConstructors cfg)) do + unless (cFirstField == SameLine || null consRest && not cBreakSingleConstructors) do removeCommentTo pos >>= mapM_ \c -> putComment c >> consIndent lineLengthAfterEq putText "=" space putConstructor cfg lineLengthAfterEq lcon forM_ consRest \con@(L conPos _) -> do - unless (cFirstField cfg == SameLine) do + unless (cFirstField == SameLine) do removeCommentTo conPos >>= mapM_ \c -> consIndent lineLengthAfterEq >> putComment c consIndent lineLengthAfterEq putText "|" @@ -150,17 +151,17 @@ formatDataDecl cfg m ldecl@(L declPos decl) = putEolComment conPos when (hasDeriving decl) do - if isEnum decl && not (cBreakEnums cfg) then + if isEnum decl && not cBreakEnums then space else do newline - spaces (cDeriving cfg) + spaces cDeriving - sep - (newline >> spaces (cDeriving cfg)) - (fmap (putDeriving cfg) . unLocated . dd_derivs $ defn) + sep (newline >> spaces cDeriving) $ defn & dd_derivs & \(L pos ds) -> ds <&> \d -> do + putAllSpanComments (newline >> spaces cDeriving) pos + putDeriving cfg d - consIndent eqIndent = newline >> case (cEquals cfg, cFirstField cfg) of + consIndent eqIndent = newline >> case (cEquals, cFirstField) of (SameLine, SameLine) -> spaces (eqIndent - 2) (SameLine, Indent y) -> spaces (eqIndent + y - 4) (Indent x, Indent _) -> spaces x diff --git a/tests/Language/Haskell/Stylish/Step/Data/Tests.hs b/tests/Language/Haskell/Stylish/Step/Data/Tests.hs index 0eb548da..f16fa11c 100644 --- a/tests/Language/Haskell/Stylish/Step/Data/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Data/Tests.hs @@ -54,6 +54,7 @@ tests = testGroup "Language.Haskell.Stylish.Step.Data.Tests" , testCase "case 41" case41 , testCase "case 42" case42 , testCase "case 43" case43 + , testCase "case 44" case44 ] case00 :: Assertion @@ -976,6 +977,49 @@ case43 = expected @=? testStep (step indentIndentStyle { cBreakEnums = True, cBr , " deriving (Eq, Show)" ] +-- This test showcases a difficult to solve issue. If the comment is in a +-- deriving clause, it's very hard to guess the correct position of the entire +-- block. E.g. the deriving clause itself has the wrong position. However, if +-- we look at all deriving clauses we know where they start and end. +-- +-- This means that we've needed to make the decision to put all inline comments +-- before the deriving clause itself +case44 :: Assertion +case44 = expected @=? testStep (step indentIndentStyle { cBreakEnums = True, cBreakSingleConstructors = False, cVia = Indent 2 }) input + where + input = unlines + [ "module X where" + , "" + , " data CreditTransfer = CreditTransfer" + , " { amount :: Amount -- ^ 1 <= amount <= 999_999_999_999" + , " , date :: Day" + , " , accountNumber :: Account" + , " }" + , " deriving stock (Show, Eq, Generic)" + , " deriving (ToJSON, FromJSON) via" + , " AddConstTextFields" + , " '[\"notification_type\" ':= \"credit_transaction\"" + , " -- Note that the bcio name has \"transaction\"" + , " -- rather than \"transfer\"" + , " ]" + , " (UntaggedEncoded CreditTransfer)" + ] + expected = unlines + [ "module X where" + , "" + , "data CreditTransfer = CreditTransfer" + , " { amount :: Amount" + , " -- ^ 1 <= amount <= 999_999_999_999" + , " , date :: Day" + , " , accountNumber :: Account" + , " }" + , " -- Note that the bcio name has \"transaction\"" + , " -- rather than \"transfer\"" + , " deriving stock (Show, Eq, Generic)" + , " deriving (ToJSON, FromJSON)" + , " via AddConstTextFields '[\"notification_type\" ':= \"credit_transaction\"] (UntaggedEncoded CreditTransfer)" + ] + sameSameStyle :: Config sameSameStyle = Config SameLine SameLine 2 2 False True SameLine From a8f91c96c197b38424fcf7a615583e6bb2dd1f7b Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Thu, 23 Jul 2020 18:11:53 +0200 Subject: [PATCH 052/135] Make sure previous fix is idempotent --- lib/Language/Haskell/Stylish/Step/Data.hs | 2 ++ .../Haskell/Stylish/Step/Data/Tests.hs | 21 +++++++++++++++++++ 2 files changed, 23 insertions(+) diff --git a/lib/Language/Haskell/Stylish/Step/Data.hs b/lib/Language/Haskell/Stylish/Step/Data.hs index 90719d63..5f2ef058 100644 --- a/lib/Language/Haskell/Stylish/Step/Data.hs +++ b/lib/Language/Haskell/Stylish/Step/Data.hs @@ -154,6 +154,8 @@ formatDataDecl cfg@Config{..} m ldecl@(L declPos decl) = if isEnum decl && not cBreakEnums then space else do + removeCommentTo (defn & dd_derivs & \(L pos _) -> pos) >>= + mapM_ \c -> newline >> spaces cDeriving >> putComment c newline spaces cDeriving diff --git a/tests/Language/Haskell/Stylish/Step/Data/Tests.hs b/tests/Language/Haskell/Stylish/Step/Data/Tests.hs index f16fa11c..b83bc761 100644 --- a/tests/Language/Haskell/Stylish/Step/Data/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Data/Tests.hs @@ -55,6 +55,7 @@ tests = testGroup "Language.Haskell.Stylish.Step.Data.Tests" , testCase "case 42" case42 , testCase "case 43" case43 , testCase "case 44" case44 + , testCase "case 45" case45 ] case00 :: Assertion @@ -1020,6 +1021,26 @@ case44 = expected @=? testStep (step indentIndentStyle { cBreakEnums = True, cBr , " via AddConstTextFields '[\"notification_type\" ':= \"credit_transaction\"] (UntaggedEncoded CreditTransfer)" ] +case45 :: Assertion +case45 = expected @=? testStep (step indentIndentStyle { cBreakEnums = True, cBreakSingleConstructors = False, cVia = Indent 2 }) input + where + input = expected + expected = unlines + [ "module X where" + , "" + , "data CreditTransfer = CreditTransfer" + , " { amount :: Amount" + , " -- ^ 1 <= amount <= 999_999_999_999" + , " , date :: Day" + , " , accountNumber :: Account" + , " }" + , " -- Note that the bcio name has \"transaction\"" + , " -- rather than \"transfer\"" + , " deriving stock (Show, Eq, Generic)" + , " deriving (ToJSON, FromJSON)" + , " via AddConstTextFields '[\"notification_type\" ':= \"credit_transaction\"] (UntaggedEncoded CreditTransfer)" + ] + sameSameStyle :: Config sameSameStyle = Config SameLine SameLine 2 2 False True SameLine From ecb69c9f14d7b8d77f8d736e08040005e2afa51e Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Fri, 24 Jul 2020 07:16:21 +0200 Subject: [PATCH 053/135] Reformulate predicate for inserting comments before eq to single binding --- lib/Language/Haskell/Stylish/Step/Data.hs | 12 +++++++----- .../Haskell/Stylish/Step/Data/Tests.hs | 19 +++++++++++++++++++ 2 files changed, 26 insertions(+), 5 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Step/Data.hs b/lib/Language/Haskell/Stylish/Step/Data.hs index 5f2ef058..647ae3b1 100644 --- a/lib/Language/Haskell/Stylish/Step/Data.hs +++ b/lib/Language/Haskell/Stylish/Step/Data.hs @@ -113,18 +113,20 @@ formatDataDecl cfg@Config{..} m ldecl@(L declPos decl) = putName decl when (hasConstructors decl) do - case (cEquals, cFirstField) of + breakLineBeforeEq <- case (cEquals, cFirstField) of (_, Indent x) | isEnum decl && cBreakEnums -> do putEolComment declPos newline >> spaces x + pure True (_, _) | not (isNewtype decl) && singleConstructor decl && not cBreakSingleConstructors -> - space + False <$ space (Indent x, _) - | isEnum decl && not cBreakEnums -> space + | isEnum decl && not cBreakEnums -> False <$ space | otherwise -> do putEolComment declPos newline >> spaces x - (SameLine, _) -> space + pure True + (SameLine, _) -> False <$ space lineLengthAfterEq <- fmap (+2) getCurrentLineLength @@ -136,7 +138,7 @@ formatDataDecl cfg@Config{..} m ldecl@(L declPos decl) = case dd_cons defn of [] -> pure () lcon@(L pos _) : consRest -> do - unless (cFirstField == SameLine || null consRest && not cBreakSingleConstructors) do + when breakLineBeforeEq do removeCommentTo pos >>= mapM_ \c -> putComment c >> consIndent lineLengthAfterEq putText "=" space diff --git a/tests/Language/Haskell/Stylish/Step/Data/Tests.hs b/tests/Language/Haskell/Stylish/Step/Data/Tests.hs index b83bc761..b633b1f4 100644 --- a/tests/Language/Haskell/Stylish/Step/Data/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Data/Tests.hs @@ -56,6 +56,7 @@ tests = testGroup "Language.Haskell.Stylish.Step.Data.Tests" , testCase "case 43" case43 , testCase "case 44" case44 , testCase "case 45" case45 + , testCase "case 46" case46 ] case00 :: Assertion @@ -1041,6 +1042,24 @@ case45 = expected @=? testStep (step indentIndentStyle { cBreakEnums = True, cBr , " via AddConstTextFields '[\"notification_type\" ':= \"credit_transaction\"] (UntaggedEncoded CreditTransfer)" ] +case46 :: Assertion +case46 = expected @=? testStep (step indentIndentStyle { cBreakEnums = True, cBreakSingleConstructors = False, cVia = Indent 2 }) input + where + input = expected + expected = unlines + [ "module X where" + , "" + , "-- | A format detailing which encoding to use for the settlement events" + , "data CallbackFormat" + , " -- | The Avro schema is to be used" + , " = AvroEngineEvent" + , " deriving (Bounded, Enum, Generic, Eq, Show)" + , " deriving (ToJSON, FromJSON)" + , " via TypeTaggedWithDescription FormatDesc CallbackFormat" + , " deriving (HasGen)" + , " via EnumBounded CallbackFormat" + ] + sameSameStyle :: Config sameSameStyle = Config SameLine SameLine 2 2 False True SameLine From a9d6248252d33b7ee6299763b02f524e9f4654e0 Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Fri, 24 Jul 2020 18:17:35 +0200 Subject: [PATCH 054/135] Implement language pragma step with ghc-lib-parser --- lib/Language/Haskell/Stylish/Module.hs | 26 +++++++ .../Haskell/Stylish/Step/LanguagePragmas.hs | 69 ++++++++++++------- .../Stylish/Step/LanguagePragmas/Tests.hs | 11 +-- 3 files changed, 78 insertions(+), 28 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Module.hs b/lib/Language/Haskell/Stylish/Module.hs index 713a536a..e3a413a2 100644 --- a/lib/Language/Haskell/Stylish/Module.hs +++ b/lib/Language/Haskell/Stylish/Module.hs @@ -1,5 +1,8 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TupleSections #-} module Language.Haskell.Stylish.Module ( -- * Data types Module @@ -16,6 +19,7 @@ module Language.Haskell.Stylish.Module , moduleImportGroups , moduleDecls , moduleComments + , moduleLanguagePragmas -- * Annotations , lookupAnnotation @@ -33,10 +37,14 @@ module Language.Haskell.Stylish.Module -------------------------------------------------------------------------------- import qualified ApiAnnotation as GHC import Data.Function ((&)) +import Data.Functor ((<&>)) import Data.Maybe (listToMaybe, mapMaybe) import Data.Map (Map) import qualified Data.Map as Map import Data.List (sort) +import Data.List.NonEmpty (NonEmpty, nonEmpty) +import Data.Text (Text) +import qualified Data.Text as T import qualified Lexer as GHC import qualified GHC.Hs as GHC import GHC.Hs.Extension (GhcPs) @@ -107,6 +115,24 @@ moduleDecls = Decls . GHC.hsmodDecls . unLocated . parsedModule moduleComments :: Module -> Comments moduleComments = Comments . parsedComments +moduleLanguagePragmas :: Module -> [(RealSrcSpan, NonEmpty Text)] +moduleLanguagePragmas = mapMaybe toLanguagePragma . parsedComments + where + toLanguagePragma :: RealLocated GHC.AnnotationComment -> Maybe (RealSrcSpan, NonEmpty Text) + toLanguagePragma = \case + L pos (GHC.AnnBlockComment s) -> + Just (T.pack s) + >>= T.stripPrefix "{-#" + >>= T.stripSuffix "#-}" + <&> T.strip + <&> T.splitAt 8 -- length "LANGUAGE" - 1 + <&> fmap (T.splitOn ",") + <&> fmap (fmap T.strip) + <&> fmap (filter (not . T.null)) + >>= (\(T.toUpper . T.strip -> lang, xs) -> (lang,) <$> nonEmpty xs) + >>= (\(lang, nel) -> if lang == "LANGUAGE" then Just (pos, nel) else Nothing) + _ -> Nothing + moduleImports :: Module -> Imports moduleImports = Imports . GHC.hsmodImports . unLocated . parsedModule diff --git a/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs b/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs index 64f94e2a..19e08ce9 100644 --- a/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs +++ b/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- module Language.Haskell.Stylish.Step.LanguagePragmas ( Style (..) @@ -8,13 +10,20 @@ module Language.Haskell.Stylish.Step.LanguagePragmas -------------------------------------------------------------------------------- +import Data.List.NonEmpty (NonEmpty, fromList, toList) import qualified Data.Set as S +import Data.Text (Text) +import qualified Data.Text as T import qualified Language.Haskell.Exts as H +-------------------------------------------------------------------------------- +import SrcLoc (RealSrcSpan) +import SrcLoc (srcSpanStartLine, srcSpanEndLine) -------------------------------------------------------------------------------- import Language.Haskell.Stylish.Block import Language.Haskell.Stylish.Editor +import Language.Haskell.Stylish.Module import Language.Haskell.Stylish.Step import Language.Haskell.Stylish.Util @@ -91,10 +100,10 @@ prettyPragmas lp cols _ align CompactLine = compactLinePragmas lp cols ali -------------------------------------------------------------------------------- -- | Filter redundant (and duplicate) pragmas out of the groups. As a side -- effect, we also sort the pragmas in their group... -filterRedundant :: (String -> Bool) - -> [(l, [String])] - -> [(l, [String])] -filterRedundant isRedundant' = snd . foldr filterRedundant' (S.empty, []) +filterRedundant :: (Text -> Bool) + -> [(l, NonEmpty Text)] + -> [(l, [Text])] +filterRedundant isRedundant' = snd . foldr filterRedundant' (S.empty, []) . fmap (fmap toList) where filterRedundant' (l, xs) (known, zs) | S.null xs' = (known', zs) @@ -106,26 +115,40 @@ filterRedundant isRedundant' = snd . foldr filterRedundant' (S.empty, []) -------------------------------------------------------------------------------- step :: Maybe Int -> Style -> Bool -> Bool -> String -> Step -step = ((((oldMakeStep "LanguagePragmas" .) .) .) .) . step' +step = ((((makeStep "LanguagePragmas" .) .) .) .) . step' -------------------------------------------------------------------------------- -step' :: Maybe Int -> Style -> Bool -> Bool -> String -> Lines -> OldModule -> Lines -step' columns style align removeRedundant lngPrefix ls (module', _) - | null pragmas' = ls - | otherwise = applyChanges changes ls +step' :: Maybe Int -> Style -> Bool -> Bool -> String -> Lines -> Module -> Lines +step' columns style align removeRedundant lngPrefix ls m + | null languagePragmas = ls + | otherwise = applyChanges changes ls where isRedundant' - | removeRedundant = isRedundant module' + | removeRedundant = isRedundant m | otherwise = const False - pragmas' = pragmas $ fmap linesFromSrcSpan module' - longest = maximum $ map length $ snd =<< pragmas' - groups = [(b, concat pgs) | (b, pgs) <- groupAdjacent pragmas'] - changes = - [ change b (const $ prettyPragmas lngPrefix columns longest align style pg) - | (b, pg) <- filterRedundant isRedundant' groups - ] + languagePragmas = moduleLanguagePragmas m + + convertFstToBlock :: [(RealSrcSpan, a)] -> [(Block String, a)] + convertFstToBlock = fmap \(rspan, a) -> + (Block (srcSpanStartLine rspan) (srcSpanEndLine rspan), a) + + groupAdjacent' = + fmap turnSndBackToNel . groupAdjacent . fmap (fmap toList) + where + turnSndBackToNel (a, bss) = (a, fromList . concat $ bss) + + longest :: Int + longest = maximum $ map T.length $ toList . snd =<< languagePragmas + + groups :: [(Block String, NonEmpty Text)] + groups = [(b, pgs) | (b, pgs) <- groupAdjacent' (convertFstToBlock languagePragmas)] + + changes = + [ change b (const $ prettyPragmas lngPrefix columns longest align style (fmap T.unpack pg)) + | (b, pg) <- filterRedundant isRedundant' groups + ] -------------------------------------------------------------------------------- -- | Add a LANGUAGE pragma to a module if it is not present already. @@ -142,7 +165,7 @@ addLanguagePragma lg prag modu -------------------------------------------------------------------------------- -- | Check if a language pragma is redundant. We can't do this for all pragmas, -- but we do a best effort. -isRedundant :: H.Module H.SrcSpanInfo -> String -> Bool +isRedundant :: Module -> Text -> Bool isRedundant m "ViewPatterns" = isRedundantViewPatterns m isRedundant m "BangPatterns" = isRedundantBangPatterns m isRedundant _ _ = False @@ -150,13 +173,11 @@ isRedundant _ _ = False -------------------------------------------------------------------------------- -- | Check if the ViewPatterns language pragma is redundant. -isRedundantViewPatterns :: H.Module H.SrcSpanInfo -> Bool -isRedundantViewPatterns m = null - [() | H.PViewPat {} <- everything m :: [H.Pat H.SrcSpanInfo]] +isRedundantViewPatterns :: Module -> Bool +isRedundantViewPatterns _ = False -------------------------------------------------------------------------------- -- | Check if the BangPatterns language pragma is redundant. -isRedundantBangPatterns :: H.Module H.SrcSpanInfo -> Bool -isRedundantBangPatterns m = null - [() | H.PBangPat _ _ <- everything m :: [H.Pat H.SrcSpanInfo]] +isRedundantBangPatterns :: Module -> Bool +isRedundantBangPatterns _ = False diff --git a/tests/Language/Haskell/Stylish/Step/LanguagePragmas/Tests.hs b/tests/Language/Haskell/Stylish/Step/LanguagePragmas/Tests.hs index 0ede8036..01fc8acd 100644 --- a/tests/Language/Haskell/Stylish/Step/LanguagePragmas/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/LanguagePragmas/Tests.hs @@ -17,10 +17,8 @@ import Language.Haskell.Stylish.Tests.Util -------------------------------------------------------------------------------- tests :: Test -tests = testGroup "Language.Haskell.Stylish.Step.LanguagePragmas.Tests" +tests = testGroup "Language.Haskell.Stylish.Step.LanguagePragmas.Tests" $ [ testCase "case 01" case01 - , testCase "case 02" case02 - , testCase "case 03" case03 , testCase "case 04" case04 , testCase "case 05" case05 , testCase "case 06" case06 @@ -30,7 +28,12 @@ tests = testGroup "Language.Haskell.Stylish.Step.LanguagePragmas.Tests" , testCase "case 10" case10 , testCase "case 11" case11 , testCase "case 12" case12 - ] + ] ++ + if False then + [ testCase "case 02" case02 + , testCase "case 03" case03 + ] + else [] lANG :: String lANG = "LANGUAGE" From 58a12b4115bdde062e60588008a44ebe3bcf8fb8 Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Sat, 25 Jul 2020 09:32:51 +0200 Subject: [PATCH 055/135] Add SYB query function for `Module` --- lib/Language/Haskell/Stylish/Module.hs | 6 ++++++ lib/Language/Haskell/Stylish/Step/Data.hs | 21 ++++----------------- 2 files changed, 10 insertions(+), 17 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Module.hs b/lib/Language/Haskell/Stylish/Module.hs index e3a413a2..f95a9f1a 100644 --- a/lib/Language/Haskell/Stylish/Module.hs +++ b/lib/Language/Haskell/Stylish/Module.hs @@ -20,6 +20,7 @@ module Language.Haskell.Stylish.Module , moduleDecls , moduleComments , moduleLanguagePragmas + , queryModule -- * Annotations , lookupAnnotation @@ -38,6 +39,7 @@ module Language.Haskell.Stylish.Module import qualified ApiAnnotation as GHC import Data.Function ((&)) import Data.Functor ((<&>)) +import Data.Generics (Typeable, everything, mkQ) import Data.Maybe (listToMaybe, mapMaybe) import Data.Map (Map) import qualified Data.Map as Map @@ -167,6 +169,10 @@ lookupAnnotation :: GHC.SrcSpan -> Module -> [GHC.AnnKeywordId] lookupAnnotation (RealSrcSpan rspan) m = Map.findWithDefault [] rspan (parsedAnnotSrcs m) lookupAnnotation (UnhelpfulSpan _) _ = [] +-- | Query the module AST using @f@ +queryModule :: Typeable a => (a -> [b]) -> Module -> [b] +queryModule f = everything (++) (mkQ [] f) . parsedModule + -------------------------------------------------------------------------------- -- | Getter for internal components in imports newtype -- diff --git a/lib/Language/Haskell/Stylish/Step/Data.hs b/lib/Language/Haskell/Stylish/Step/Data.hs index 647ae3b1..71a32463 100644 --- a/lib/Language/Haskell/Stylish/Step/Data.hs +++ b/lib/Language/Haskell/Stylish/Step/Data.hs @@ -15,12 +15,12 @@ import Prelude hiding (init) import Control.Monad (forM_, unless, when) import Data.Function ((&)) import Data.Functor ((<&>)) -import Data.Maybe (listToMaybe, mapMaybe) +import Data.Maybe (listToMaybe) -------------------------------------------------------------------------------- import ApiAnnotation (AnnotationComment) import BasicTypes (LexicalFixity(..)) -import GHC.Hs.Decls (LHsDecl, HsDecl(..), HsDataDefn(..)) +import GHC.Hs.Decls (HsDecl(..), HsDataDefn(..)) import GHC.Hs.Decls (TyClDecl(..), NewOrData(..)) import GHC.Hs.Decls (HsDerivingClause(..), DerivStrategy(..)) import GHC.Hs.Decls (ConDecl(..)) @@ -69,26 +69,13 @@ step cfg = makeStep "Data" \ls m -> applyChanges (changes m) ls changes m = fmap (formatDataDecl cfg m) (dataDecls m) dataDecls :: Module -> [Located DataDecl] - dataDecls - = mapMaybe toDataDecl - . mapMaybe toTycl - . rawModuleDecls - . moduleDecls - - toTycl :: LHsDecl GhcPs -> Maybe (Located (TyClDecl GhcPs)) - toTycl = \case - L pos (TyClD _ tyClDecl) -> Just (L pos tyClDecl) - _ -> Nothing - - toDataDecl :: Located (TyClDecl GhcPs) -> Maybe (Located DataDecl) - toDataDecl = \case - L pos (DataDecl _ name tvars fixity defn) -> Just . L pos $ MkDataDecl + dataDecls = + queryModule \(L pos (TyClD _ (DataDecl _ name tvars fixity defn))) -> pure . L pos $ MkDataDecl { dataDeclName = name , dataTypeVars = tvars , dataDefn = defn , dataFixity = fixity } - _ -> Nothing type ChangeLine = Change String From ff3990ceb86fa9f6f324cd928765e4d5d962d311 Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Sat, 25 Jul 2020 09:33:21 +0200 Subject: [PATCH 056/135] Implement redundant view/bang pattern functions using SYB query API --- .../Haskell/Stylish/Step/LanguagePragmas.hs | 17 +++++++++++++++-- .../Stylish/Step/LanguagePragmas/Tests.hs | 11 ++++------- 2 files changed, 19 insertions(+), 9 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs b/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs index 19e08ce9..79ca13d9 100644 --- a/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs +++ b/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs @@ -1,5 +1,6 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} -------------------------------------------------------------------------------- module Language.Haskell.Stylish.Step.LanguagePragmas ( Style (..) @@ -17,6 +18,8 @@ import qualified Data.Text as T import qualified Language.Haskell.Exts as H -------------------------------------------------------------------------------- +import GHC.Hs.Extension (GhcPs) +import GHC.Hs.Pat (Pat(BangPat, ViewPat)) import SrcLoc (RealSrcSpan) import SrcLoc (srcSpanStartLine, srcSpanEndLine) @@ -174,10 +177,20 @@ isRedundant _ _ = False -------------------------------------------------------------------------------- -- | Check if the ViewPatterns language pragma is redundant. isRedundantViewPatterns :: Module -> Bool -isRedundantViewPatterns _ = False +isRedundantViewPatterns = null . queryModule getViewPat + where + getViewPat :: Pat GhcPs -> [()] + getViewPat = \case + ViewPat{} -> [()] + _ -> [] -------------------------------------------------------------------------------- -- | Check if the BangPatterns language pragma is redundant. isRedundantBangPatterns :: Module -> Bool -isRedundantBangPatterns _ = False +isRedundantBangPatterns = null . queryModule getBangPat + where + getBangPat :: Pat GhcPs -> [()] + getBangPat = \case + BangPat{} -> [()] + _ -> [] diff --git a/tests/Language/Haskell/Stylish/Step/LanguagePragmas/Tests.hs b/tests/Language/Haskell/Stylish/Step/LanguagePragmas/Tests.hs index 01fc8acd..0ede8036 100644 --- a/tests/Language/Haskell/Stylish/Step/LanguagePragmas/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/LanguagePragmas/Tests.hs @@ -17,8 +17,10 @@ import Language.Haskell.Stylish.Tests.Util -------------------------------------------------------------------------------- tests :: Test -tests = testGroup "Language.Haskell.Stylish.Step.LanguagePragmas.Tests" $ +tests = testGroup "Language.Haskell.Stylish.Step.LanguagePragmas.Tests" [ testCase "case 01" case01 + , testCase "case 02" case02 + , testCase "case 03" case03 , testCase "case 04" case04 , testCase "case 05" case05 , testCase "case 06" case06 @@ -28,12 +30,7 @@ tests = testGroup "Language.Haskell.Stylish.Step.LanguagePragmas.Tests" $ , testCase "case 10" case10 , testCase "case 11" case11 , testCase "case 12" case12 - ] ++ - if False then - [ testCase "case 02" case02 - , testCase "case 03" case03 - ] - else [] + ] lANG :: String lANG = "LANGUAGE" From 313bc7721ae1369f90a4a7bfd6ea12c41758d4e4 Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Sat, 25 Jul 2020 11:23:28 +0200 Subject: [PATCH 057/135] Fix remaining configuration tests --- .../Language/Haskell/Stylish/Config/Tests.hs | 1 + tests/Language/Haskell/Stylish/Tests.hs | 4 +++- tests/Language/Haskell/Stylish/Tests/Util.hs | 19 ++++++++++--------- 3 files changed, 14 insertions(+), 10 deletions(-) diff --git a/tests/Language/Haskell/Stylish/Config/Tests.hs b/tests/Language/Haskell/Stylish/Config/Tests.hs index a8b2ee28..73062ab0 100644 --- a/tests/Language/Haskell/Stylish/Config/Tests.hs +++ b/tests/Language/Haskell/Stylish/Config/Tests.hs @@ -153,6 +153,7 @@ dotStylish = unlines $ , " first_field: \"indent 2\"" , " field_comment: 2" , " deriving: 4" + , " via: \"indent 2\"" , "columns: 110" , "language_extensions:" , " - TemplateHaskell" diff --git a/tests/Language/Haskell/Stylish/Tests.hs b/tests/Language/Haskell/Stylish/Tests.hs index 97eab8a5..f1d60948 100644 --- a/tests/Language/Haskell/Stylish/Tests.hs +++ b/tests/Language/Haskell/Stylish/Tests.hs @@ -49,6 +49,7 @@ case02 = withTestDirTree $ do , " first_field: \"indent 2\"" , " field_comment: 2" , " deriving: 2" + , " via: \"indent 2\"" ] actual <- format (Just $ ConfigPath "test-config.yaml") Nothing input @@ -73,6 +74,7 @@ case03 = withTestDirTree $ do , " first_field: \"same_line\"" , " field_comment: 2" , " deriving: 2" + , " via: \"indent 2\"" ] actual <- format (Just $ ConfigPath "test-config.yaml") Nothing input @@ -98,7 +100,7 @@ case04 = (@?= result) =<< format Nothing (Just fileLocation) input fileLocation = "directory/File.hs" input = "module Herp" result = Left $ - "Language.Haskell.Stylish.Parse.parseModule: could not parse " <> + "Language.Haskell.Stylish.Parse.parseModuleHSE: could not parse " <> fileLocation <> ": ParseFailed (SrcLoc \".hs\" 2 1) \"Parse error: EOF\"" diff --git a/tests/Language/Haskell/Stylish/Tests/Util.hs b/tests/Language/Haskell/Stylish/Tests/Util.hs index aee52c64..073e3db0 100644 --- a/tests/Language/Haskell/Stylish/Tests/Util.hs +++ b/tests/Language/Haskell/Stylish/Tests/Util.hs @@ -24,19 +24,20 @@ import Language.Haskell.Stylish.Step -------------------------------------------------------------------------------- testStep :: Step -> String -> String -testStep step str = case parseModule [] Nothing str of - Left err -> error err - Right module' -> unlines $ stepFilter step ls module' +testStep s str = case s of + Step _ step -> + case parseModule [] Nothing str of + Left err -> error err + Right module' -> unlines $ step ls module' + OldStep _ step -> + case parseModuleHSE [] Nothing str of + Left err -> error err + Right module' -> unlines $ step ls module' where ls = lines str testStep' :: Step -> Lines -> Lines -testStep' step ls = case parseModule [] Nothing (unlines ls) of - Left err -> - error $ "parseAndFormat: Should've been able to parse input - " <> err - Right parsedModule -> - stepFilter step ls parsedModule - +testStep' s ls = lines $ testStep s (unlines ls) -------------------------------------------------------------------------------- -- | Create a temporary directory with a randomised name built from the template From 3b770278d5f283262119b921dc8638dcf0df7c21 Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Sat, 25 Jul 2020 11:31:59 +0200 Subject: [PATCH 058/135] Bump haskell docker image to get newer version of stack --- .circleci/config.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.circleci/config.yml b/.circleci/config.yml index e1e90202..d0e8d733 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -12,7 +12,7 @@ workflows: jobs: build: docker: - - image: 'haskell:8.6' + - image: 'haskell:8.8.3' steps: - checkout From 32385f424f4a8dfec0346694aff2e02908c92f9e Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Sat, 25 Jul 2020 11:52:08 +0200 Subject: [PATCH 059/135] Remove outputable helper export from printer module --- lib/Language/Haskell/Stylish/Printer.hs | 4 ---- 1 file changed, 4 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Printer.hs b/lib/Language/Haskell/Stylish/Printer.hs index 85f5d198..ae937496 100644 --- a/lib/Language/Haskell/Stylish/Printer.hs +++ b/lib/Language/Haskell/Stylish/Printer.hs @@ -42,10 +42,6 @@ module Language.Haskell.Stylish.Printer , space , spaces , suffix - - -- ** Outputable helpers - , showOutputable - , compareOutputable ) where -------------------------------------------------------------------------------- From 02505975918d17fa8e38fb61052a645dfe6b0a4f Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Sat, 25 Jul 2020 11:57:15 +0200 Subject: [PATCH 060/135] Document Module module --- lib/Language/Haskell/Stylish/Module.hs | 26 +++++++++++++++++++++----- 1 file changed, 21 insertions(+), 5 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Module.hs b/lib/Language/Haskell/Stylish/Module.hs index f95a9f1a..a10c83ba 100644 --- a/lib/Language/Haskell/Stylish/Module.hs +++ b/lib/Language/Haskell/Stylish/Module.hs @@ -75,18 +75,23 @@ data Module = Module , parsedModule :: GHC.Located (GHC.HsModule GhcPs) } +-- | Declarations in module newtype Decls = Decls [LHsDecl GhcPs] -data Imports = Imports [LImportDecl GhcPs] +-- | Imports in module +newtype Imports = Imports [LImportDecl GhcPs] -data Comments = Comments [GHC.RealLocated GHC.AnnotationComment] +-- | Comments associated with module +newtype Comments = Comments [GHC.RealLocated GHC.AnnotationComment] +-- | A module header is its name, exports and haddock docstring data ModuleHeader = ModuleHeader { name :: Maybe (GHC.Located GHC.ModuleName) , exports :: Maybe (GHC.Located [GHC.LIE GhcPs]) , haddocks :: Maybe GHC.LHsDocString } +-- | Create a module from GHC internal representations makeModule :: GHC.PState -> GHC.Located (GHC.HsModule GHC.GhcPs) -> Module makeModule pstate = Module comments annotations annotationMap where @@ -111,12 +116,15 @@ makeModule pstate = Module comments annotations annotationMap ((RealSrcSpan rspan, annot), _) -> Just (rspan, [annot]) _ -> Nothing +-- | Get all declarations in module moduleDecls :: Module -> Decls moduleDecls = Decls . GHC.hsmodDecls . unLocated . parsedModule +-- | Get comments in module moduleComments :: Module -> Comments moduleComments = Comments . parsedComments +-- | Get module language pragmas moduleLanguagePragmas :: Module -> [(RealSrcSpan, NonEmpty Text)] moduleLanguagePragmas = mapMaybe toLanguagePragma . parsedComments where @@ -135,9 +143,11 @@ moduleLanguagePragmas = mapMaybe toLanguagePragma . parsedComments >>= (\(lang, nel) -> if lang == "LANGUAGE" then Just (pos, nel) else Nothing) _ -> Nothing +-- | Get module imports moduleImports :: Module -> Imports moduleImports = Imports . GHC.hsmodImports . unLocated . parsedModule +-- | Get groups of imports from module moduleImportGroups :: Module -> [Imports] moduleImportGroups m = go relevantComments imports where @@ -158,6 +168,7 @@ moduleImportGroups m = go relevantComments imports Imports (imp : sameGroup) : go commentsRest rest go _comments imps = [Imports imps] +-- | Get module header moduleHeader :: Module -> ModuleHeader moduleHeader (Module _ _ _ (GHC.L _ m)) = ModuleHeader { name = GHC.hsmodName m @@ -165,7 +176,8 @@ moduleHeader (Module _ _ _ (GHC.L _ m)) = ModuleHeader , haddocks = GHC.hsmodHaddockModHeader m } -lookupAnnotation :: GHC.SrcSpan -> Module -> [GHC.AnnKeywordId] +-- | Query for annotations associated with a 'SrcSpan' +lookupAnnotation :: SrcSpan -> Module -> [GHC.AnnKeywordId] lookupAnnotation (RealSrcSpan rspan) m = Map.findWithDefault [] rspan (parsedAnnotSrcs m) lookupAnnotation (UnhelpfulSpan _) _ = [] @@ -175,25 +187,29 @@ queryModule f = everything (++) (mkQ [] f) . parsedModule -------------------------------------------------------------------------------- -- | Getter for internal components in imports newtype --- --- /Note:/ this function might be rawImports :: Imports -> [LImportDecl GhcPs] rawImports (Imports xs) = xs +-- | Getter for internal module name representation rawModuleName :: ModuleHeader -> Maybe (GHC.Located GHC.ModuleName) rawModuleName = name +-- | Getter for internal module exports representation rawModuleExports :: ModuleHeader -> Maybe (GHC.Located [GHC.LIE GhcPs]) rawModuleExports = exports +-- | Getter for internal module haddocks representation rawModuleHaddocks :: ModuleHeader -> Maybe GHC.LHsDocString rawModuleHaddocks = haddocks +-- | Getter for internal module decls representation rawModuleDecls :: Decls -> [LHsDecl GhcPs] rawModuleDecls (Decls xs) = xs +-- | Getter for internal module comments representation rawComments :: Comments -> [GHC.RealLocated GHC.AnnotationComment] rawComments (Comments xs) = xs +-- | Getter for internal module annotation representation rawModuleAnnotations :: Module -> [(GHC.ApiAnnKey, [GHC.SrcSpan])] rawModuleAnnotations = parsedAnnotations From e39bfd1d6ce307c26b951e34accaae842c6a1d12 Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Sat, 25 Jul 2020 12:01:40 +0200 Subject: [PATCH 061/135] Correct comment on language string length --- lib/Language/Haskell/Stylish/Module.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/Language/Haskell/Stylish/Module.hs b/lib/Language/Haskell/Stylish/Module.hs index a10c83ba..870fcbb2 100644 --- a/lib/Language/Haskell/Stylish/Module.hs +++ b/lib/Language/Haskell/Stylish/Module.hs @@ -135,7 +135,7 @@ moduleLanguagePragmas = mapMaybe toLanguagePragma . parsedComments >>= T.stripPrefix "{-#" >>= T.stripSuffix "#-}" <&> T.strip - <&> T.splitAt 8 -- length "LANGUAGE" - 1 + <&> T.splitAt 8 -- length "LANGUAGE" <&> fmap (T.splitOn ",") <&> fmap (fmap T.strip) <&> fmap (filter (not . T.null)) From e5d5a0e1b28ef93ea45db61cdf24f40fd40794ad Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Sat, 25 Jul 2020 12:06:09 +0200 Subject: [PATCH 062/135] Add comment for `putAllSpanComments` --- lib/Language/Haskell/Stylish/Printer.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/lib/Language/Haskell/Stylish/Printer.hs b/lib/Language/Haskell/Stylish/Printer.hs index ae937496..3e8ab746 100644 --- a/lib/Language/Haskell/Stylish/Printer.hs +++ b/lib/Language/Haskell/Stylish/Printer.hs @@ -115,6 +115,8 @@ putText txt = do putOutputable :: Outputable a => a -> P () putOutputable = putText . showOutputable +-- | Put all comments that has positions within 'SrcSpan' and separate by +-- passed @P ()@ putAllSpanComments :: P () -> SrcSpan -> P () putAllSpanComments suff = \case UnhelpfulSpan _ -> pure () From ff35fb3aa88ae43187fe03f4fc6c05c00cbaf960 Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Sat, 25 Jul 2020 12:08:13 +0200 Subject: [PATCH 063/135] Rename `putModulePrefix` to `putModuleName` --- lib/Language/Haskell/Stylish/Printer.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Printer.hs b/lib/Language/Haskell/Stylish/Printer.hs index 3e8ab746..5162b18f 100644 --- a/lib/Language/Haskell/Stylish/Printer.hs +++ b/lib/Language/Haskell/Stylish/Printer.hs @@ -172,15 +172,15 @@ putRdrName (L pos n) = case n of else putText (showOutputable name) Qual modulePrefix name -> - putModulePrefix modulePrefix >> dot >> putText (showOutputable name) + putModuleName modulePrefix >> dot >> putText (showOutputable name) Orig _ name -> putText (showOutputable name) Exact name -> putText (showOutputable name) -- | Print module name -putModulePrefix :: ModuleName -> P () -putModulePrefix = putText . moduleNameString +putModuleName :: ModuleName -> P () +putModuleName = putText . moduleNameString -- | Print type putType :: Located (HsType GhcPs) -> P () From 0dda96b059d7da9ee6831cd412c33750564abaf5 Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Sat, 25 Jul 2020 12:18:50 +0200 Subject: [PATCH 064/135] Document new configuration options --- data/stylish-haskell.yaml | 32 ++++++++++++++++++++++++++++++++ 1 file changed, 32 insertions(+) diff --git a/data/stylish-haskell.yaml b/data/stylish-haskell.yaml index d7de2606..334b9f1a 100644 --- a/data/stylish-haskell.yaml +++ b/data/stylish-haskell.yaml @@ -42,6 +42,22 @@ steps: # # # How many spaces to insert before "deriving" clause. Deriving clauses are always on separate lines. # deriving: 2 + # + # # How many spaces to insert before "via" clause counted from indentation of deriving clause + # # Possible values: + # # - "same_line" -- "{" and first field goes on the same line as the data constructor. + # # - "indent N" -- insert a new line and N spaces from the beginning of the data constructor + # via: "indent 2" + # + # # Wheter or not to break enums onto several lines + # # + # # Default: false + # break_enums: false + # + # # Whether or not to break single constructor data types before `=` sign + # # + # # Default: true + # break_single_constructors: true # Align the right hand side of some elements. This is quite conservative # and only applies to statements where each element occupies a single @@ -203,6 +219,22 @@ steps: # Default: false space_surround: false + # Enabling this argument will use the new GHC lib parsre to format imports. + # + # This currently assumes a few things, it will assume that you want post + # qualified imports. It is also not as feature complete as the old + # imports formatting. + # + # It does not remove redundant lines or merge lines. As such, the full + # feature scope is still pending. + # + # It _is_ however, a fine alternative if you are using features that are + # not parseable by haskell src extensions and you're comfortable with the + # presets. + # + # Default: false + ghc_lib_parser: false + # Language pragmas - language_pragmas: # We can generate different styles of language pragma lists. From 115325a387d50dda17a0c83a7ef08ce69da80b9b Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Sat, 25 Jul 2020 13:02:39 +0200 Subject: [PATCH 065/135] Fix issue with incomplete pattern match on AST --- lib/Language/Haskell/Stylish/Step/Data.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Step/Data.hs b/lib/Language/Haskell/Stylish/Step/Data.hs index 71a32463..4da3931a 100644 --- a/lib/Language/Haskell/Stylish/Step/Data.hs +++ b/lib/Language/Haskell/Stylish/Step/Data.hs @@ -69,13 +69,14 @@ step cfg = makeStep "Data" \ls m -> applyChanges (changes m) ls changes m = fmap (formatDataDecl cfg m) (dataDecls m) dataDecls :: Module -> [Located DataDecl] - dataDecls = - queryModule \(L pos (TyClD _ (DataDecl _ name tvars fixity defn))) -> pure . L pos $ MkDataDecl + dataDecls = queryModule \case + L pos (TyClD _ (DataDecl _ name tvars fixity defn)) -> pure . L pos $ MkDataDecl { dataDeclName = name , dataTypeVars = tvars , dataDefn = defn , dataFixity = fixity } + _ -> [] type ChangeLine = Change String From b47d6061b4a7ae4da0db07f2c0e7bce1451bdd33 Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Sat, 25 Jul 2020 23:39:06 +0200 Subject: [PATCH 066/135] Add missing documentation on how to enable module header formatting --- data/stylish-haskell.yaml | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/data/stylish-haskell.yaml b/data/stylish-haskell.yaml index 334b9f1a..ce98967e 100644 --- a/data/stylish-haskell.yaml +++ b/data/stylish-haskell.yaml @@ -15,6 +15,13 @@ steps: # # true. # add_language_pragma: true + # Format module header + # + # Currently, this option is not configurable and will format all exports and + # module declarations to minimize diffs + # + # - module_header: {} + # Format record definitions. This is disabled by default. # # You can control the layout of record fields. The only rules that can't be configured From 46ca865473223ba0917a3db89a97cd27a7758f91 Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Sun, 26 Jul 2020 18:15:05 +0200 Subject: [PATCH 067/135] Add configurability on curried context and implement simple GADT support --- data/stylish-haskell.yaml | 9 ++ lib/Language/Haskell/Stylish/Config.hs | 3 +- lib/Language/Haskell/Stylish/Step/Data.hs | 115 +++++++++++++++--- .../Haskell/Stylish/Step/Data/Tests.hs | 112 ++++++++++++++++- 4 files changed, 215 insertions(+), 24 deletions(-) diff --git a/data/stylish-haskell.yaml b/data/stylish-haskell.yaml index ce98967e..e3c0035b 100644 --- a/data/stylish-haskell.yaml +++ b/data/stylish-haskell.yaml @@ -65,6 +65,15 @@ steps: # # # # Default: true # break_single_constructors: true + # + # # Whether or not to curry constraints on function. + # # + # # E.g: @allValues :: Enum a => Bounded a => Proxy a -> [a]@ + # # + # # Instead of @allValues :: (Enum a, Bounded a) => Proxy a -> [a]@ + # # + # # Default: false + # curried_context: false # Align the right hand side of some elements. This is quite conservative # and only applies to statements where each element occupies a single diff --git a/lib/Language/Haskell/Stylish/Config.hs b/lib/Language/Haskell/Stylish/Config.hs index 6a051cfd..15d852ea 100644 --- a/lib/Language/Haskell/Stylish/Config.hs +++ b/lib/Language/Haskell/Stylish/Config.hs @@ -220,7 +220,8 @@ parseRecords _ o = Data.step <*> (o A..: "deriving") <*> (o A..:? "break_enums" A..!= False) <*> (o A..:? "break_single_constructors" A..!= True) - <*> (o A..: "via" >>= parseIndent)) + <*> (o A..: "via" >>= parseIndent) + <*> (o A..:? "curried_context" A..!= False)) parseIndent :: A.Value -> A.Parser Data.Indent diff --git a/lib/Language/Haskell/Stylish/Step/Data.hs b/lib/Language/Haskell/Stylish/Step/Data.hs index 4da3931a..89b25181 100644 --- a/lib/Language/Haskell/Stylish/Step/Data.hs +++ b/lib/Language/Haskell/Stylish/Step/Data.hs @@ -24,8 +24,9 @@ import GHC.Hs.Decls (HsDecl(..), HsDataDefn(..)) import GHC.Hs.Decls (TyClDecl(..), NewOrData(..)) import GHC.Hs.Decls (HsDerivingClause(..), DerivStrategy(..)) import GHC.Hs.Decls (ConDecl(..)) -import GHC.Hs.Extension (GhcPs, noExtCon) -import GHC.Hs.Types (ConDeclField(..)) +import GHC.Hs.Extension (GhcPs, NoExtField(..), noExtCon) +import GHC.Hs.Types (ConDeclField(..), HsContext) +import GHC.Hs.Types (HsType(..), ForallVisFlag(..)) import GHC.Hs.Types (LHsQTyVars(..), HsTyVarBndr(..)) import GHC.Hs.Types (HsConDetails(..), HsImplicitBndrs(..)) import RdrName (RdrName) @@ -60,6 +61,8 @@ data Config = Config -- ^ Break single constructors when enabled, e.g. @Indent 2@ will not cause newline after @=@ , cVia :: !Indent -- ^ Indentation between @via@ clause and start of deriving column start + , cCurriedContext :: !Bool + -- ^ If true, use curried context. E.g: @allValues :: Enum a => Bounded a => Proxy a -> [a]@ } deriving (Show) step :: Config -> Step @@ -100,6 +103,8 @@ formatDataDecl cfg@Config{..} m ldecl@(L declPos decl) = space putName decl + when (isGADT decl) (space >> putText "where") + when (hasConstructors decl) do breakLineBeforeEq <- case (cEquals, cFirstField) of (_, Indent x) | isEnum decl && cBreakEnums -> do @@ -128,15 +133,21 @@ formatDataDecl cfg@Config{..} m ldecl@(L declPos decl) = lcon@(L pos _) : consRest -> do when breakLineBeforeEq do removeCommentTo pos >>= mapM_ \c -> putComment c >> consIndent lineLengthAfterEq - putText "=" - space + + unless + (isGADT decl) + (putText "=" >> space) + putConstructor cfg lineLengthAfterEq lcon forM_ consRest \con@(L conPos _) -> do unless (cFirstField == SameLine) do removeCommentTo conPos >>= mapM_ \c -> consIndent lineLengthAfterEq >> putComment c consIndent lineLengthAfterEq - putText "|" - space + + unless + (isGADT decl) + (putText "|" >> space) + putConstructor cfg lineLengthAfterEq con putEolComment conPos @@ -234,18 +245,51 @@ putName decl@MkDataDecl{..} = putConstructor :: Config -> Int -> Located (ConDecl GhcPs) -> P () putConstructor cfg consIndent (L _ cons) = case cons of - ConDeclGADT{} -> - error "Stylish does not support GADTs yet, ConDeclGADT encountered" + ConDeclGADT{..} -> do + -- Put argument to constructor first: + case con_args of + PrefixCon _ -> do + sep + (comma >> space) + (fmap putRdrName con_names) + + InfixCon arg1 arg2 -> do + putType arg1 + space + forM_ con_names putRdrName + space + putType arg2 + RecCon _ -> + error . mconcat $ + [ "Language.Haskell.Stylish.Step.Data.putConstructor: " + , "encountered a GADT with record constructors, not supported yet" + ] + + -- Put type of constructor: + space + putText "::" + space + + when (unLocated con_forall) do + putText "forall" + space + sep space (fmap putOutputable $ hsq_explicit con_qvars) + dot + space + + forM_ con_mb_cxt (putContext cfg . unLocated) + putType con_res_ty + XConDecl x -> noExtCon x ConDeclH98{..} -> case con_args of InfixCon arg1 arg2 -> do - putOutputable arg1 + putType arg1 space putRdrName con_name space - putOutputable arg2 + putType arg2 PrefixCon xs -> do putRdrName con_name unless (null xs) space @@ -262,7 +306,7 @@ putConstructor cfg consIndent (L _ cons) = case cons of removeCommentTo posFirst >>= mapM_ \c -> putComment c >> sepDecl bracePos -- Put first decl field - putConDeclField firstArg + putConDeclField cfg firstArg unless (cFirstField cfg == SameLine) (putEolComment posFirst) -- Put tail decl fields @@ -272,7 +316,7 @@ putConstructor cfg consIndent (L _ cons) = case cons of spaces (cFieldComment cfg) >> putComment c >> sepDecl bracePos comma space - putConDeclField arg + putConDeclField cfg arg putEolComment pos -- Print docstr after final field @@ -301,7 +345,7 @@ putConstructor cfg consIndent (L _ cons) = case cons of (Indent x, SameLine) -> bracePos - 1 + x - 2 putNewtypeConstructor :: Config -> Located (ConDecl GhcPs) -> P () -putNewtypeConstructor _ (L _ cons) = case cons of +putNewtypeConstructor cfg (L _ cons) = case cons of ConDeclH98{..} -> putRdrName con_name >> case con_args of PrefixCon xs -> do @@ -311,7 +355,7 @@ putNewtypeConstructor _ (L _ cons) = case cons of space putText "{" space - putConDeclField firstArg + putConDeclField cfg firstArg space putText "}" RecCon (L _ _args) -> @@ -332,25 +376,60 @@ putNewtypeConstructor _ (L _ cons) = case cons of , "GADT encountered in newtype" ] -putConDeclField :: ConDeclField GhcPs -> P () -putConDeclField = \case +putContext :: Config -> HsContext GhcPs -> P () +putContext Config{..} = suffix (space >> putText "=>" >> space) . \case + [L _ (HsParTy _ tp)] | cCurriedContext -> + putType tp + [ctx] -> + putType ctx + ctxs | cCurriedContext -> + sep (space >> putText "=>" >> space) (fmap putType ctxs) + ctxs -> + parenthesize $ sep (comma >> space) (fmap putType ctxs) + +putConDeclField :: Config -> ConDeclField GhcPs -> P () +putConDeclField cfg = \case ConDeclField{..} -> do sep (comma >> space) - (fmap (putText . showOutputable) cd_fld_names) + (fmap putOutputable cd_fld_names) space putText "::" space - putType cd_fld_type + putType' cfg cd_fld_type XConDeclField{} -> error . mconcat $ [ "Language.Haskell.Stylish.Step.Data.putConDeclField: " , "XConDeclField encountered" ] +-- | A variant of 'putType' that takes 'cCurriedContext' into account +putType' :: Config -> Located (HsType GhcPs) -> P () +putType' cfg = \case + L _ (HsForAllTy NoExtField vis bndrs tp) -> do + putText "forall" + space + sep space (fmap putOutputable bndrs) + putText + if vis == ForallVis then "->" + else "." + space + putType' cfg tp + L _ (HsQualTy NoExtField ctx tp) -> do + putContext cfg (unLocated ctx) + putType' cfg tp + other -> putType other + newOrData :: DataDecl -> String newOrData decl = if isNewtype decl then "newtype" else "data" +isGADT :: DataDecl -> Bool +isGADT = any isGADTCons . dd_cons . dataDefn + where + isGADTCons = \case + L _ (ConDeclGADT {}) -> True + _ -> False + isNewtype :: DataDecl -> Bool isNewtype = (== NewType) . dd_ND . dataDefn diff --git a/tests/Language/Haskell/Stylish/Step/Data/Tests.hs b/tests/Language/Haskell/Stylish/Step/Data/Tests.hs index b633b1f4..db9451f1 100644 --- a/tests/Language/Haskell/Stylish/Step/Data/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Data/Tests.hs @@ -57,6 +57,12 @@ tests = testGroup "Language.Haskell.Stylish.Step.Data.Tests" , testCase "case 44" case44 , testCase "case 45" case45 , testCase "case 46" case46 + , testCase "case 47" case47 + , testCase "case 48" case48 + , testCase "case 49" case49 + , testCase "case 50" case50 + , testCase "case 51" case51 + , testCase "case 52" case52 ] case00 :: Assertion @@ -1060,17 +1066,113 @@ case46 = expected @=? testStep (step indentIndentStyle { cBreakEnums = True, cBr , " via EnumBounded CallbackFormat" ] +case47 :: Assertion +case47 = expected @=? testStep (step indentIndentStyle) input + where + input = expected + expected = unlines + [ "module X where" + , "" + , "-- | A GADT example" + , "data T a where" + , " D1 :: Int -> T String" + , " D2 :: T Bool" + , " D3 :: (a, a) -> T [a]" + ] + +case48 :: Assertion +case48 = expected @=? testStep (step indentIndentStyle) input + where + input = expected + expected = unlines + [ "module X where" + , "" + , "-- | A GADT example" + , "data T a where" + , " D1 :: Int -> T String" + , " D2 :: T Bool" + , " D3 :: forall a. (Eq a, Bounded a) => (a, a) -> T [a]" + ] + +case49 :: Assertion +case49 = expected @=? testStep (step indentIndentStyle) input + where + input = expected + expected = unlines + [ "module X where" + , "" + , "-- | A GADT example" + , "data T a where" + , " D1 :: Int -> T String" + , " D2 :: T Bool" + , " D3 :: forall a. (Eq a) => (a, a) -> T [a]" + ] + +case50 :: Assertion +case50 = expected @=? testStep (step indentIndentStyle { cCurriedContext = True }) input + where + input = expected + expected = unlines + [ "module X where" + , "" + , "-- | A GADT example" + , "data T a where" + , " D1 :: Int -> T String" + , " D2 :: T Bool" + , " D3 :: forall a. Eq a => (a, a) -> T [a]" + ] + +case51 :: Assertion +case51 = expected @=? testStep (step indentIndentStyle { cCurriedContext = True }) input + where + input = unlines + [ "module X where" + , "" + , "-- | A GADT example" + , "data T a where" + , " D1 :: Int -> T String" + , " D2 :: T Bool" + , " D3 :: forall a. (Eq a) => (a, a) -> T [a]" + ] + expected = unlines + [ "module X where" + , "" + , "-- | A GADT example" + , "data T a where" + , " D1 :: Int -> T String" + , " D2 :: T Bool" + , " D3 :: forall a. Eq a => (a, a) -> T [a]" + ] + +case52 :: Assertion +case52 = expected @=? testStep (step indentIndentStyle { cBreakSingleConstructors = False, cCurriedContext = True }) input + where + input = unlines + [ "module X where" + , "" + , "data Foo = Foo" + , " { foo :: forall a b. (Eq a, Bounded b) => a -> b -> [(a, b)]" + , " }" + ] + expected = unlines + [ "module X where" + , "" + , "data Foo = Foo" + , " { foo :: forall a b. Eq a => Bounded b => a -> b -> [(a, b)]" + , " }" + ] + sameSameStyle :: Config -sameSameStyle = Config SameLine SameLine 2 2 False True SameLine +sameSameStyle = Config SameLine SameLine 2 2 False True SameLine False sameIndentStyle :: Config -sameIndentStyle = Config SameLine (Indent 2) 2 2 False True SameLine +sameIndentStyle = Config SameLine (Indent 2) 2 2 False True SameLine False indentSameStyle :: Config -indentSameStyle = Config (Indent 2) SameLine 2 2 False True SameLine +indentSameStyle = Config (Indent 2) SameLine 2 2 False True SameLine False indentIndentStyle :: Config -indentIndentStyle = Config (Indent 2) (Indent 2) 2 2 False True SameLine +indentIndentStyle = Config (Indent 2) (Indent 2) 2 2 False True SameLine False indentIndentStyle4 :: Config -indentIndentStyle4 = Config (Indent 4) (Indent 4) 4 4 False True SameLine +indentIndentStyle4 = Config (Indent 4) (Indent 4) 4 4 False True SameLine False From 3f16447cce6606b73785d8fcc8ea7169f15f4a3b Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Tue, 28 Jul 2020 09:48:51 +0200 Subject: [PATCH 068/135] Fix typo in config file: 'parsre' -> 'parse' --- data/stylish-haskell.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/data/stylish-haskell.yaml b/data/stylish-haskell.yaml index e3c0035b..a41c6e16 100644 --- a/data/stylish-haskell.yaml +++ b/data/stylish-haskell.yaml @@ -235,7 +235,7 @@ steps: # Default: false space_surround: false - # Enabling this argument will use the new GHC lib parsre to format imports. + # Enabling this argument will use the new GHC lib parse to format imports. # # This currently assumes a few things, it will assume that you want post # qualified imports. It is also not as feature complete as the old From 0611d91fb76d4c508b01241ee14054251ab28d77 Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Tue, 28 Jul 2020 09:49:43 +0200 Subject: [PATCH 069/135] Remove redundant '$' --- lib/Language/Haskell/Stylish/Config.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/Language/Haskell/Stylish/Config.hs b/lib/Language/Haskell/Stylish/Config.hs index 15d852ea..8d65fd85 100644 --- a/lib/Language/Haskell/Stylish/Config.hs +++ b/lib/Language/Haskell/Stylish/Config.hs @@ -161,7 +161,7 @@ parseConfig _ = mzero -------------------------------------------------------------------------------- catalog :: Map String (Config -> A.Object -> A.Parser Step) -catalog = M.fromList $ +catalog = M.fromList [ ("imports", parseImports) , ("module_header", parseModuleHeader) , ("records", parseRecords) From b46676d38e45730e8842875c257e9870d916f10c Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Wed, 29 Jul 2020 09:58:29 +0200 Subject: [PATCH 070/135] Use `on` for compare function --- lib/Language/Haskell/Stylish/GHC.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/lib/Language/Haskell/Stylish/GHC.hs b/lib/Language/Haskell/Stylish/GHC.hs index b64b218e..ee2d59fc 100644 --- a/lib/Language/Haskell/Stylish/GHC.hs +++ b/lib/Language/Haskell/Stylish/GHC.hs @@ -17,6 +17,9 @@ module Language.Haskell.Stylish.GHC , compareOutputable ) where +-------------------------------------------------------------------------------- +import Data.Function (on) + -------------------------------------------------------------------------------- import DynFlags (Settings(..), defaultDynFlags) import qualified DynFlags as GHC @@ -95,5 +98,4 @@ showOutputable :: GHC.Outputable a => a -> String showOutputable = GHC.showPpr baseDynFlags compareOutputable :: GHC.Outputable a => a -> a -> Ordering -compareOutputable i0 i1 = compare (showOutputable i0) (showOutputable i1) - +compareOutputable = compare `on` showOutputable From 99ceb58b12567bec41ee7c465c448ec47092d53a Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Wed, 29 Jul 2020 10:03:12 +0200 Subject: [PATCH 071/135] Rename `Imports'` to `ImportsGHC` --- lib/Language/Haskell/Stylish/Config.hs | 4 ++-- .../Step/{Imports'.hs => ImportsGHC.hs} | 2 +- stylish-haskell.cabal | 6 +++--- .../Step/{Imports' => ImportsGHC}/Tests.hs | 18 +++++++++--------- tests/TestSuite.hs | 4 ++-- 5 files changed, 17 insertions(+), 17 deletions(-) rename lib/Language/Haskell/Stylish/Step/{Imports'.hs => ImportsGHC.hs} (99%) rename tests/Language/Haskell/Stylish/Step/{Imports' => ImportsGHC}/Tests.hs (88%) diff --git a/lib/Language/Haskell/Stylish/Config.hs b/lib/Language/Haskell/Stylish/Config.hs index 8d65fd85..67b85595 100644 --- a/lib/Language/Haskell/Stylish/Config.hs +++ b/lib/Language/Haskell/Stylish/Config.hs @@ -42,7 +42,7 @@ import Language.Haskell.Stylish.Config.Internal import Language.Haskell.Stylish.Step import qualified Language.Haskell.Stylish.Step.Data as Data import qualified Language.Haskell.Stylish.Step.Imports as Imports -import qualified Language.Haskell.Stylish.Step.Imports' as Imports' +import qualified Language.Haskell.Stylish.Step.ImportsGHC as ImportsGHC import qualified Language.Haskell.Stylish.Step.ModuleHeader as ModuleHeader import qualified Language.Haskell.Stylish.Step.LanguagePragmas as LanguagePragmas import qualified Language.Haskell.Stylish.Step.SimpleAlign as SimpleAlign @@ -260,7 +260,7 @@ parseImports config o = do pure if Imports.useGhcLibParser cfg then - Imports'.step cfg + ImportsGHC.step cfg else Imports.step (configColumns config) cfg diff --git a/lib/Language/Haskell/Stylish/Step/Imports'.hs b/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs similarity index 99% rename from lib/Language/Haskell/Stylish/Step/Imports'.hs rename to lib/Language/Haskell/Stylish/Step/ImportsGHC.hs index 29e096ce..0ecafb16 100644 --- a/lib/Language/Haskell/Stylish/Step/Imports'.hs +++ b/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs @@ -1,7 +1,7 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE LambdaCase #-} -module Language.Haskell.Stylish.Step.Imports' +module Language.Haskell.Stylish.Step.ImportsGHC ( Options (..) , step ) where diff --git a/stylish-haskell.cabal b/stylish-haskell.cabal index b92cc958..2ae30cb7 100644 --- a/stylish-haskell.cabal +++ b/stylish-haskell.cabal @@ -34,7 +34,7 @@ Library Language.Haskell.Stylish.Printer Language.Haskell.Stylish.Step.Data Language.Haskell.Stylish.Step.Imports - Language.Haskell.Stylish.Step.Imports' + Language.Haskell.Stylish.Step.ImportsGHC Language.Haskell.Stylish.Step.ModuleHeader Language.Haskell.Stylish.Step.LanguagePragmas Language.Haskell.Stylish.Step.SimpleAlign @@ -121,9 +121,9 @@ Test-suite stylish-haskell-tests Language.Haskell.Stylish.Printer Language.Haskell.Stylish.Step Language.Haskell.Stylish.Step.Imports - Language.Haskell.Stylish.Step.Imports' + Language.Haskell.Stylish.Step.ImportsGHC Language.Haskell.Stylish.Step.Imports.Tests - Language.Haskell.Stylish.Step.Imports'.Tests + Language.Haskell.Stylish.Step.ImportsGHC.Tests Language.Haskell.Stylish.Step.Data Language.Haskell.Stylish.Step.Data.Tests Language.Haskell.Stylish.Step.ModuleHeader diff --git a/tests/Language/Haskell/Stylish/Step/Imports'/Tests.hs b/tests/Language/Haskell/Stylish/Step/ImportsGHC/Tests.hs similarity index 88% rename from tests/Language/Haskell/Stylish/Step/Imports'/Tests.hs rename to tests/Language/Haskell/Stylish/Step/ImportsGHC/Tests.hs index 2d3a26c7..71a695f2 100644 --- a/tests/Language/Haskell/Stylish/Step/Imports'/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/ImportsGHC/Tests.hs @@ -1,20 +1,20 @@ -module Language.Haskell.Stylish.Step.Imports'.Tests +module Language.Haskell.Stylish.Step.ImportsGHC.Tests ( tests ) where -------------------------------------------------------------------------------- -import Test.Framework (Test, testGroup) -import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit (Assertion, (@=?)) -import GHC.Stack (HasCallStack, withFrozenCallStack) -import Prelude hiding (lines) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit (Assertion, (@=?)) +import GHC.Stack (HasCallStack, withFrozenCallStack) +import Prelude hiding (lines) -------------------------------------------------------------------------------- import Language.Haskell.Stylish.Module -import Language.Haskell.Stylish.Step.Imports (defaultOptions) -import Language.Haskell.Stylish.Step.Imports' (step) -import Language.Haskell.Stylish.Tests.Util (testStep') +import Language.Haskell.Stylish.Step.Imports (defaultOptions) +import Language.Haskell.Stylish.Step.ImportsGHC (step) +import Language.Haskell.Stylish.Tests.Util (testStep') diff --git a/tests/TestSuite.hs b/tests/TestSuite.hs index d318cddf..1dd9df92 100644 --- a/tests/TestSuite.hs +++ b/tests/TestSuite.hs @@ -21,7 +21,7 @@ import qualified Language.Haskell.Stylish.Step.Tabs.Tests import qualified Language.Haskell.Stylish.Step.TrailingWhitespace.Tests import qualified Language.Haskell.Stylish.Step.UnicodeSyntax.Tests import qualified Language.Haskell.Stylish.Tests -import qualified Language.Haskell.Stylish.Step.Imports'.Tests +import qualified Language.Haskell.Stylish.Step.ImportsGHC.Tests -------------------------------------------------------------------------------- @@ -30,8 +30,8 @@ main = defaultMain [ Language.Haskell.Stylish.Parse.Tests.tests , Language.Haskell.Stylish.Config.Tests.tests , Language.Haskell.Stylish.Step.Data.Tests.tests - , Language.Haskell.Stylish.Step.Imports'.Tests.tests , Language.Haskell.Stylish.Step.Imports.Tests.tests + , Language.Haskell.Stylish.Step.ImportsGHC.Tests.tests , Language.Haskell.Stylish.Step.LanguagePragmas.Tests.tests , Language.Haskell.Stylish.Step.ModuleHeader.Tests.tests , Language.Haskell.Stylish.Step.SimpleAlign.Tests.tests From 98e82ee68b7b2069287d6fe906cee080fdf89b5f Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Wed, 29 Jul 2020 10:08:32 +0200 Subject: [PATCH 072/135] Use CPP to get rid of monoid warning for newer GHC versions --- src/Main.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/Main.hs b/src/Main.hs index 769d9471..a41c1d86 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} -------------------------------------------------------------------------------- module Main ( main @@ -7,13 +8,16 @@ module Main -------------------------------------------------------------------------------- import Control.Monad (forM_, unless, when) import qualified Data.ByteString.Char8 as BC8 ---import Data.Monoid ((<>)) import Data.Version (showVersion) import qualified Options.Applicative as OA import System.Exit (exitFailure) import qualified System.IO as IO import qualified System.IO.Strict as IO.Strict +-------------------------------------------------------------------------------- +#if __GLASGOW_HASKELL__ < 808 +import Data.Monoid ((<>)) +#endif -------------------------------------------------------------------------------- import Language.Haskell.Stylish From 34f333b529ccdf4ab789b0e659e65f40fb62e62a Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Wed, 29 Jul 2020 11:04:44 +0200 Subject: [PATCH 073/135] Implement equality for `Import` decl --- lib/Language/Haskell/Stylish/Module.hs | 68 ++++++++++++++----- .../Haskell/Stylish/Step/ImportsGHC.hs | 4 +- 2 files changed, 54 insertions(+), 18 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Module.hs b/lib/Language/Haskell/Stylish/Module.hs index 870fcbb2..e8b6b8d3 100644 --- a/lib/Language/Haskell/Stylish/Module.hs +++ b/lib/Language/Haskell/Stylish/Module.hs @@ -7,7 +7,7 @@ module Language.Haskell.Stylish.Module ( -- * Data types Module , ModuleHeader - , Imports + , Import , Decls , Comments , Lines @@ -22,12 +22,15 @@ module Language.Haskell.Stylish.Module , moduleLanguagePragmas , queryModule + -- * Imports + , canMergeImport + -- * Annotations , lookupAnnotation -- * Internal API getters , rawComments - , rawImports + , rawImport , rawModuleAnnotations , rawModuleDecls , rawModuleExports @@ -36,8 +39,7 @@ module Language.Haskell.Stylish.Module ) where -------------------------------------------------------------------------------- -import qualified ApiAnnotation as GHC -import Data.Function ((&)) +import Data.Function ((&), on) import Data.Functor ((<&>)) import Data.Generics (Typeable, everything, mkQ) import Data.Maybe (listToMaybe, mapMaybe) @@ -47,14 +49,18 @@ import Data.List (sort) import Data.List.NonEmpty (NonEmpty, nonEmpty) import Data.Text (Text) import qualified Data.Text as T + +-------------------------------------------------------------------------------- +import qualified ApiAnnotation as GHC import qualified Lexer as GHC +import GHC.Hs (ImportDecl(..), ImportDeclQualifiedStyle(..)) import qualified GHC.Hs as GHC import GHC.Hs.Extension (GhcPs) import GHC.Hs.Decls (LHsDecl) import GHC.Hs.ImpExp (LImportDecl) import SrcLoc (GenLocated(..), RealLocated) import SrcLoc (RealSrcSpan(..), SrcSpan(..)) -import SrcLoc (srcSpanStartLine) +import SrcLoc (Located, srcSpanStartLine) import qualified SrcLoc as GHC import qualified Module as GHC import Util (lastMaybe) @@ -78,8 +84,34 @@ data Module = Module -- | Declarations in module newtype Decls = Decls [LHsDecl GhcPs] --- | Imports in module -newtype Imports = Imports [LImportDecl GhcPs] +-- | Import declaration in module +newtype Import = Import { unImport :: ImportDecl GhcPs } + +-- | Returns true if the two import declarations can be merged +canMergeImport :: Import -> Import -> Bool +canMergeImport (Import i0) (Import i1) = and $ fmap (\f -> f i0 i1) + [ (==) `on` ideclName + , (==) `on` ideclPkgQual + , (==) `on` ideclSource + , hasMergableQualified `on` ideclQualified + , (==) `on` ideclImplicit + , (==) `on` ideclAs + , (==) `on` fmap fst . ideclHiding -- same 'hiding' flags + ] + where + hasMergableQualified QualifiedPre QualifiedPost = True + hasMergableQualified QualifiedPost QualifiedPre = True + hasMergableQualified q0 q1 = q0 == q1 + +instance Eq Import where + i0 == i1 = canMergeImport i0 i1 && hasSameImports (unImport i0) (unImport i1) + where + hasSameImports = (==) `on` fmap snd . ideclHiding + +instance Ord Import where + compare (Import i0) (Import i1) = + ideclName i0 `compare` ideclName i1 <> + compareOutputable i0 i1 -- | Comments associated with module newtype Comments = Comments [GHC.RealLocated GHC.AnnotationComment] @@ -144,11 +176,15 @@ moduleLanguagePragmas = mapMaybe toLanguagePragma . parsedComments _ -> Nothing -- | Get module imports -moduleImports :: Module -> Imports -moduleImports = Imports . GHC.hsmodImports . unLocated . parsedModule +moduleImports :: Module -> [Located Import] +moduleImports m + = parsedModule m + & unLocated + & GHC.hsmodImports + & fmap \(L pos i) -> L pos (Import i) -- | Get groups of imports from module -moduleImportGroups :: Module -> [Imports] +moduleImportGroups :: Module -> [[Located Import]] moduleImportGroups m = go relevantComments imports where relevantComments @@ -157,16 +193,16 @@ moduleImportGroups m = go relevantComments imports & dropBeforeLocated (listToMaybe imports) & dropAfterLocated (lastMaybe imports) - imports = rawImports (moduleImports m) + imports = moduleImports m - go :: [RealLocated GHC.AnnotationComment] -> [LImportDecl GhcPs] -> [Imports] + go :: [RealLocated GHC.AnnotationComment] -> [Located Import] -> [[Located Import]] go (L nextCommentPos _ : commentsRest) (imp : impRest) = let sameGroup = takeWhile (\i -> getStartLineUnsafe i < srcSpanStartLine nextCommentPos) impRest rest = dropWhile (\i -> getStartLineUnsafe i <= srcSpanStartLine nextCommentPos) impRest in - Imports (imp : sameGroup) : go commentsRest rest - go _comments imps = [Imports imps] + (imp : sameGroup) : go commentsRest rest + go _comments imps = [imps] -- | Get module header moduleHeader :: Module -> ModuleHeader @@ -187,8 +223,8 @@ queryModule f = everything (++) (mkQ [] f) . parsedModule -------------------------------------------------------------------------------- -- | Getter for internal components in imports newtype -rawImports :: Imports -> [LImportDecl GhcPs] -rawImports (Imports xs) = xs +rawImport :: Located Import -> LImportDecl GhcPs +rawImport (L pos (Import i)) = L pos i -- | Getter for internal module name representation rawModuleName :: ModuleHeader -> Maybe (GHC.Located GHC.ModuleName) diff --git a/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs b/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs index 0ecafb16..6d56f697 100644 --- a/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs +++ b/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs @@ -40,7 +40,7 @@ step = makeStep "Imports (ghc-lib-parser)" . printImports printImports :: Options -> Lines -> Module -> Lines printImports _ ls m = formatForImportGroups ls m (moduleImportGroups m) -formatForImportGroups :: Lines -> Module -> [Imports] -> Lines +formatForImportGroups :: Lines -> Module -> [[Located Import]] -> Lines formatForImportGroups ls _m [] = ls formatForImportGroups ls m (group : rest) = formatForImportGroups formattedGroup m rest where @@ -48,7 +48,7 @@ formatForImportGroups ls m (group : rest) = formatForImportGroups formattedGroup formattedGroup = let imports = - rawImports group + fmap rawImport group relevantComments = [] From a556f59237c9d30ea784d4edd67fc578e9712237 Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Wed, 29 Jul 2020 12:57:55 +0200 Subject: [PATCH 074/135] Implement ability to merge imports in ImportsGHC --- lib/Language/Haskell/Stylish/Module.hs | 42 ++++++++++-- .../Haskell/Stylish/Step/ImportsGHC.hs | 68 ++++++++++++------- .../Haskell/Stylish/Step/ImportsGHC/Tests.hs | 16 ++++- 3 files changed, 93 insertions(+), 33 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Module.hs b/lib/Language/Haskell/Stylish/Module.hs index e8b6b8d3..bbbaaade 100644 --- a/lib/Language/Haskell/Stylish/Module.hs +++ b/lib/Language/Haskell/Stylish/Module.hs @@ -1,4 +1,6 @@ {-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} @@ -24,6 +26,7 @@ module Language.Haskell.Stylish.Module -- * Imports , canMergeImport + , mergeModuleImport -- * Annotations , lookupAnnotation @@ -45,7 +48,7 @@ import Data.Generics (Typeable, everything, mkQ) import Data.Maybe (listToMaybe, mapMaybe) import Data.Map (Map) import qualified Data.Map as Map -import Data.List (sort) +import Data.List (nubBy, sort) import Data.List.NonEmpty (NonEmpty, nonEmpty) import Data.Text (Text) import qualified Data.Text as T @@ -57,7 +60,7 @@ import GHC.Hs (ImportDecl(..), ImportDeclQual import qualified GHC.Hs as GHC import GHC.Hs.Extension (GhcPs) import GHC.Hs.Decls (LHsDecl) -import GHC.Hs.ImpExp (LImportDecl) +import Outputable (Outputable) import SrcLoc (GenLocated(..), RealLocated) import SrcLoc (RealSrcSpan(..), SrcSpan(..)) import SrcLoc (Located, srcSpanStartLine) @@ -86,16 +89,17 @@ newtype Decls = Decls [LHsDecl GhcPs] -- | Import declaration in module newtype Import = Import { unImport :: ImportDecl GhcPs } + deriving newtype (Outputable) -- | Returns true if the two import declarations can be merged canMergeImport :: Import -> Import -> Bool canMergeImport (Import i0) (Import i1) = and $ fmap (\f -> f i0 i1) - [ (==) `on` ideclName + [ (==) `on` unLocated . ideclName , (==) `on` ideclPkgQual , (==) `on` ideclSource , hasMergableQualified `on` ideclQualified , (==) `on` ideclImplicit - , (==) `on` ideclAs + , (==) `on` fmap unLocated . ideclAs , (==) `on` fmap fst . ideclHiding -- same 'hiding' flags ] where @@ -110,7 +114,7 @@ instance Eq Import where instance Ord Import where compare (Import i0) (Import i1) = - ideclName i0 `compare` ideclName i1 <> + ideclName i0 `compareOutputable` ideclName i1 <> compareOutputable i0 i1 -- | Comments associated with module @@ -204,6 +208,30 @@ moduleImportGroups m = go relevantComments imports (imp : sameGroup) : go commentsRest rest go _comments imps = [imps] +-- | Merge two import declarations, keeping positions from the first +-- +-- As alluded, this highlights an issue with merging imports. The GHC +-- annotation comments aren't attached to any particular AST node. This +-- means that right now, we're manually reconstructing the attachment. By +-- merging two import declarations, we lose that mapping. +-- +-- It's not really a big deal if we consider that people don't usually +-- comment imports themselves. It _is_ however, systemic and it'd be better +-- if we processed comments beforehand and attached them to all AST nodes in +-- our own representation. +mergeModuleImport :: Located Import -> Located Import -> Located Import +mergeModuleImport (L p0 (Import i0)) (L _p1 (Import i1)) = + L p0 $ Import i0 { ideclHiding = newImportNames } + where + newImportNames = + case (ideclHiding i0, ideclHiding i1) of + (Just (b, L p imps0), Just (_, L _ imps1)) -> Just (b, L p (imps0 `merge` imps1)) + (Nothing, Nothing) -> Nothing + (Just x, Nothing) -> Just x + (Nothing, Just x) -> Just x + merge xs ys + = nubBy ((==) `on` showOutputable) (xs ++ ys) + -- | Get module header moduleHeader :: Module -> ModuleHeader moduleHeader (Module _ _ _ (GHC.L _ m)) = ModuleHeader @@ -223,8 +251,8 @@ queryModule f = everything (++) (mkQ [] f) . parsedModule -------------------------------------------------------------------------------- -- | Getter for internal components in imports newtype -rawImport :: Located Import -> LImportDecl GhcPs -rawImport (L pos (Import i)) = L pos i +rawImport :: Import -> ImportDecl GhcPs +rawImport (Import i) = i -- | Getter for internal module name representation rawModuleName :: ModuleHeader -> Maybe (GHC.Located GHC.ModuleName) diff --git a/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs b/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs index 6d56f697..47913c6e 100644 --- a/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs +++ b/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs @@ -12,7 +12,7 @@ import Data.Function ((&)) import Data.Foldable (toList) import Data.Maybe (listToMaybe) import Data.List (sortBy) -import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NonEmpty -------------------------------------------------------------------------------- @@ -47,9 +47,6 @@ formatForImportGroups ls m (group : rest) = formatForImportGroups formattedGroup formattedGroup :: Lines formattedGroup = let - imports = - fmap rawImport group - relevantComments = [] @@ -58,17 +55,21 @@ formatForImportGroups ls m (group : rest) = formatForImportGroups formattedGroup <*> importEnd importStart - = listToMaybe imports + = listToMaybe group & fmap getStartLineUnsafe importEnd - = lastMaybe imports + = lastMaybe group & fmap getEndLineUnsafe formatting = runPrinter_ PrinterConfig relevantComments m do - importsWithComments <- sortedAttachedComments imports - forM_ importsWithComments \(_, importGroup) -> do - forM_ (sortImportDecls importGroup) \imp -> printPostQualified imp >> newline + importsWithComments <- sortedAttachedComments group + forM_ importsWithComments \(_, rawGroup) -> do + let + importGroup + = NonEmpty.sortWith unLocated rawGroup + & mergeImports + forM_ importGroup \imp -> printPostQualified imp >> newline in case importStart of Just start -> @@ -80,16 +81,16 @@ formatForImportGroups ls m (group : rest) = formatForImportGroups formattedGroup Nothing -> ls -------------------------------------------------------------------------------- -printPostQualified :: LImportDecl GhcPs -> P () -printPostQualified decl = do +printPostQualified :: Located Import -> P () +printPostQualified (L _ decl) = do let - decl' = unLocated decl + decl' = rawImport decl putText "import" >> space - when (ideclSource decl') (putText "{-# SOURCE #-}" >> space) + when (isSource decl) (putText "{-# SOURCE #-}" >> space) - when (ideclSafe decl') (putText "safe" >> space) + when (isSafe decl) (putText "safe" >> space) putText (moduleName decl) @@ -98,7 +99,7 @@ printPostQualified decl = do forM_ (ideclAs decl') \(L _ name) -> space >> putText "as" >> space >> putText (moduleNameString name) - when (isHiding decl') (space >> putText "hiding") + when (isHiding decl) (space >> putText "hiding") forM_ (snd <$> ideclHiding decl') \(L _ imports) -> let @@ -144,23 +145,45 @@ printIeWrappedName lie = unLocated lie & \case IEPattern n -> putText "pattern" >> space >> putRdrName n IEType n -> putText "type" >> space >> putRdrName n -moduleName :: LImportDecl GhcPs -> String +mergeImports :: NonEmpty (Located Import) -> NonEmpty (Located Import) +mergeImports (x :| []) = x :| [] +mergeImports (h :| (t : ts)) + | canMergeImport (unLocated h) (unLocated t) = mergeImports (mergeModuleImport h t :| ts) + | otherwise = h :| mergeImportsTail (t : ts) + where + mergeImportsTail (x : y : ys) + | canMergeImport (unLocated x) (unLocated y) = mergeImportsTail ((mergeModuleImport x y) : ys) + | otherwise = x : mergeImportsTail (y : ys) + mergeImportsTail xs = xs + +moduleName :: Import -> String moduleName = moduleNameString . unLocated . ideclName - . unLocated + . rawImport -isQualified :: LImportDecl GhcPs -> Bool +isQualified :: Import -> Bool isQualified = (/=) NotQualified . ideclQualified - . unLocated + . rawImport -isHiding :: ImportDecl GhcPs -> Bool +isHiding :: Import -> Bool isHiding = maybe False fst . ideclHiding + . rawImport + +isSource :: Import -> Bool +isSource + = ideclSource + . rawImport + +isSafe :: Import -> Bool +isSafe + = ideclSafe + . rawImport sortImportList :: [LIE GhcPs] -> [LIE GhcPs] sortImportList = sortBy $ currycated \case @@ -189,10 +212,5 @@ sortImportList = sortBy $ currycated \case _ -> EQ -sortImportDecls :: NonEmpty (LImportDecl GhcPs) -> NonEmpty (LImportDecl GhcPs) -sortImportDecls = NonEmpty.sortBy $ currycated \(a0, a1) -> - compareOutputable (ideclName a0) (ideclName a1) <> - compareOutputable a0 a1 - currycated :: ((a, b) -> c) -> (Located a -> Located b -> c) currycated f = \(L _ a) (L _ b) -> f (a, b) diff --git a/tests/Language/Haskell/Stylish/Step/ImportsGHC/Tests.hs b/tests/Language/Haskell/Stylish/Step/ImportsGHC/Tests.hs index 71a695f2..6c468c63 100644 --- a/tests/Language/Haskell/Stylish/Step/ImportsGHC/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/ImportsGHC/Tests.hs @@ -20,7 +20,7 @@ import Language.Haskell.Stylish.Tests.Util (testStep') -------------------------------------------------------------------------------- tests :: Test -tests = testGroup "Language.Haskell.Stylish.Printer.Imports" +tests = testGroup "Language.Haskell.Stylish.Step.ImportsGHC" [ testCase "Hello world" ex0 , testCase "Sorted simple" ex1 , testCase "Sorted import lists" ex2 @@ -33,6 +33,7 @@ tests = testGroup "Language.Haskell.Stylish.Printer.Imports" , testCase "Imports respects whitespace between groups" ex9 , testCase "Doesn't add extra space after 'hiding'" ex10 , testCase "Should be able to format symbolic imports" ex11 + , testCase "Able to merge equivalent imports" ex12 ] -------------------------------------------------------------------------------- @@ -224,6 +225,19 @@ ex11 = input `assertFormatted` output , "import Data.Aeson ((.=))" ] +ex12 :: Assertion +ex12 = input `assertFormatted` output + where + input = + [ "import Data.Aeson ((.=))" + , "import Data.Aeson ((.=))" + , "import A hiding (X)" + ] + output = + [ "import A hiding (X)" + , "import Data.Aeson ((.=))" + ] + -------------------------------------------------------------------------------- assertFormatted :: HasCallStack => Lines -> Lines -> Assertion assertFormatted input expected = withFrozenCallStack $ expected @=? testStep' (step defaultOptions) input From e1b7a6491d81fd7442b88f3336655cdcf58b5d04 Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Mon, 24 Aug 2020 13:24:00 +0200 Subject: [PATCH 075/135] Add formatting for long deriving clauses --- lib/Language/Haskell/Stylish/Config.hs | 9 +- lib/Language/Haskell/Stylish/Printer.hs | 20 +++- lib/Language/Haskell/Stylish/Step/Data.hs | 83 +++++++++++++--- .../Haskell/Stylish/Step/Data/Tests.hs | 96 +++++++++++++------ 4 files changed, 158 insertions(+), 50 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Config.hs b/lib/Language/Haskell/Stylish/Config.hs index 67b85595..ca61d154 100644 --- a/lib/Language/Haskell/Stylish/Config.hs +++ b/lib/Language/Haskell/Stylish/Config.hs @@ -212,7 +212,7 @@ parseSimpleAlign c o = SimpleAlign.step -------------------------------------------------------------------------------- parseRecords :: Config -> A.Object -> A.Parser Step -parseRecords _ o = Data.step +parseRecords c o = Data.step <$> (Data.Config <$> (o A..: "equals" >>= parseIndent) <*> (o A..: "first_field" >>= parseIndent) @@ -221,8 +221,11 @@ parseRecords _ o = Data.step <*> (o A..:? "break_enums" A..!= False) <*> (o A..:? "break_single_constructors" A..!= True) <*> (o A..: "via" >>= parseIndent) - <*> (o A..:? "curried_context" A..!= False)) - + <*> (o A..:? "curried_context" A..!= False) + <*> pure configMaxColumns) + where + configMaxColumns = + maybe Data.NoMaxColumns Data.MaxColumns (configColumns c) parseIndent :: A.Value -> A.Parser Data.Indent parseIndent = A.withText "Indent" $ \t -> diff --git a/lib/Language/Haskell/Stylish/Printer.hs b/lib/Language/Haskell/Stylish/Printer.hs index 5162b18f..a546b753 100644 --- a/lib/Language/Haskell/Stylish/Printer.hs +++ b/lib/Language/Haskell/Stylish/Printer.hs @@ -31,6 +31,7 @@ module Language.Haskell.Stylish.Printer , putEolComment , putOutputable , putAllSpanComments + , putCond , putType , putRdrName , putText @@ -63,7 +64,7 @@ import Control.Monad (forM_, replicateM_) import Control.Monad.Reader (MonadReader, ReaderT(..)) import Control.Monad.State (MonadState, State) import Control.Monad.State (runState) -import Control.Monad.State (gets, modify) +import Control.Monad.State (get, gets, modify, put) import Data.Foldable (find) import Data.Functor ((<&>)) import Data.List (delete, isPrefixOf) @@ -86,11 +87,11 @@ data PrinterConfig = PrinterConfig -- | State of printer data PrinterState = PrinterState - { lines :: Lines + { lines :: !Lines , linePos :: !Int - , currentLine :: String - , pendingComments :: [RealLocated AnnotationComment] - , parsedModule :: Module + , currentLine :: !String + , pendingComments :: ![RealLocated AnnotationComment] + , parsedModule :: !Module } -- | Run printer to get printed lines out of module as well as return value of monad @@ -111,6 +112,15 @@ putText txt = do l <- gets currentLine modify \s -> s { currentLine = l <> txt } +-- | Check condition post action, and use fallback if false +putCond :: (PrinterState -> Bool) -> P b -> P b -> P b +putCond p action fallback = do + prevState <- get + res <- action + currState <- get + if p currState then pure res + else put prevState >> fallback + -- | Print an 'Outputable' putOutputable :: Outputable a => a -> P () putOutputable = putText . showOutputable diff --git a/lib/Language/Haskell/Stylish/Step/Data.hs b/lib/Language/Haskell/Stylish/Step/Data.hs index 89b25181..27ed73c2 100644 --- a/lib/Language/Haskell/Stylish/Step/Data.hs +++ b/lib/Language/Haskell/Stylish/Step/Data.hs @@ -1,10 +1,12 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE DoAndIfThenElse #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} module Language.Haskell.Stylish.Step.Data ( Config(..) , Indent(..) + , MaxColumns(..) , step ) where @@ -15,6 +17,7 @@ import Prelude hiding (init) import Control.Monad (forM_, unless, when) import Data.Function ((&)) import Data.Functor ((<&>)) +import Data.List (sortBy) import Data.Maybe (listToMaybe) -------------------------------------------------------------------------------- @@ -46,6 +49,11 @@ data Indent | Indent !Int deriving (Show, Eq) +data MaxColumns + = MaxColumns !Int + | NoMaxColumns + deriving (Show, Eq) + data Config = Config { cEquals :: !Indent -- ^ Indent between type constructor and @=@ sign (measured from column 0) @@ -63,6 +71,7 @@ data Config = Config -- ^ Indentation between @via@ clause and start of deriving column start , cCurriedContext :: !Bool -- ^ If true, use curried context. E.g: @allValues :: Enum a => Bounded a => Proxy a -> [a]@ + , cMaxColumns :: !MaxColumns } deriving (Show) step :: Config -> Step @@ -178,27 +187,25 @@ data DataDecl = MkDataDecl } putDeriving :: Config -> Located (HsDerivingClause GhcPs) -> P () -putDeriving cfg (L pos clause) = do +putDeriving Config{..} (L pos clause) = do putText "deriving" - space forM_ (deriv_clause_strategy clause) \case - L _ StockStrategy -> putText "stock" >> space - L _ AnyclassStrategy -> putText "anyclass" >> space - L _ NewtypeStrategy -> putText "newtype" >> space + L _ StockStrategy -> space >> putText "stock" + L _ AnyclassStrategy -> space >> putText "anyclass" + L _ NewtypeStrategy -> space >> putText "newtype" L _ (ViaStrategy _) -> pure () - putText "(" - sep - (comma >> space) - (fmap putOutputable (fmap hsib_body . unLocated . deriv_clause_tys $ clause)) - putText ")" + putCond + withinColumns + oneLinePrint + multilinePrint forM_ (deriv_clause_strategy clause) \case L _ (ViaStrategy tp) -> do - case cVia cfg of + case cVia of SameLine -> space - Indent x -> newline >> spaces (x + cDeriving cfg) + Indent x -> newline >> spaces (x + cDeriving) putText "via" space @@ -212,6 +219,56 @@ putDeriving cfg (L pos clause) = do HsIB _ tp -> tp XHsImplicitBndrs x -> noExtCon x + withinColumns PrinterState{currentLine} = + case cMaxColumns of + MaxColumns maxCols -> length currentLine <= maxCols + NoMaxColumns -> True + + oneLinePrint = do + space + putText "(" + sep + (comma >> space) + (fmap putOutputable tys) + putText ")" + + multilinePrint = do + newline + spaces indentation + putText "(" + + forM_ headTy \t -> + space >> putOutputable t + + forM_ tailTy \t -> do + newline + spaces indentation + comma + space + putOutputable t + + newline + spaces indentation + putText ")" + + indentation = + cDeriving + case cFirstField of + Indent x -> x + SameLine -> 0 + + tys + = clause + & deriv_clause_tys + & unLocated + & sortBy compareOutputable + & fmap hsib_body + + headTy = + listToMaybe tys + + tailTy = + drop 1 tys + putUnbrokenEnum :: Config -> DataDecl -> P () putUnbrokenEnum cfg decl = sep diff --git a/tests/Language/Haskell/Stylish/Step/Data/Tests.hs b/tests/Language/Haskell/Stylish/Step/Data/Tests.hs index db9451f1..4357af63 100644 --- a/tests/Language/Haskell/Stylish/Step/Data/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Data/Tests.hs @@ -63,6 +63,8 @@ tests = testGroup "Language.Haskell.Stylish.Step.Data.Tests" , testCase "case 50" case50 , testCase "case 51" case51 , testCase "case 52" case52 + , testCase "case 53" case53 + , testCase "case 54" case54 ] case00 :: Assertion @@ -648,15 +650,15 @@ case28 = expected @=? testStep (step sameIndentStyle { cBreakEnums = True }) inp [ "module Some.Types where" , "" , "newtype BankCode = BankCode { unBankCode :: Text }" - , " deriving stock (Generic, Eq, Show)" + , " deriving stock (Eq, Generic, Show)" , " deriving anyclass (Newtype)" , "" , "newtype CheckDigit = CheckDigit { unCheckDigit :: Text }" - , " deriving stock (Generic, Eq, Show)" + , " deriving stock (Eq, Generic, Show)" , " deriving anyclass (Newtype)" , "" , "newtype WrappedInt = WrappedInt Int" - , " deriving stock (Generic, Eq, Show)" + , " deriving stock (Eq, Generic, Show)" , " deriving anyclass (Newtype)" , "" , "data MandateStatus" @@ -664,8 +666,8 @@ case28 = expected @=? testStep (step sameIndentStyle { cBreakEnums = True }) inp , " | Failed" , " | UserCanceled" , " | Inactive" - , " deriving stock (Generic, Show, Eq, Enum, Bounded)" - , " deriving (ToJSON, FromJSON) via SnakeCaseCapsEnumEncoding MandateStatus" + , " deriving stock (Bounded, Enum, Eq, Generic, Show)" + , " deriving (FromJSON, ToJSON) via SnakeCaseCapsEnumEncoding MandateStatus" ] case29 :: Assertion @@ -737,8 +739,8 @@ case32 = expected @=? testStep (step indentIndentStyle { cBreakEnums = True }) i , " | VersionNotFound" , " -- ValidationFailed" , " | BankAccountExists" - , " deriving stock (Generic, Show, Eq)" - , " deriving (ToJSON, FromJSON) via SnakeCaseLowercaseEnumEncoding RejectionReason" + , " deriving stock (Eq, Generic, Show)" + , " deriving (FromJSON, ToJSON) via SnakeCaseLowercaseEnumEncoding RejectionReason" ] case33 :: Assertion @@ -772,7 +774,7 @@ case34 = expected @=? testStep (step indentIndentStyle { cVia = Indent 2 }) inpu , "" , "newtype NonEmpty a" , " = NonEmpty { unNonEmpty :: a }" - , " deriving (ToJSON, FromJSON)" + , " deriving (FromJSON, ToJSON)" , " via Something Magic (NonEmpty a)" ] @@ -838,8 +840,8 @@ case37 = expected @=? testStep (step indentIndentStyle { cVia = Indent 2 }) inpu , "" , "newtype UndoFlowData" , " = UndoFlowData { flowDataDetails :: FlowDataDetails }" - , " deriving stock (Generic, Eq, Show)" - , " deriving (ToJSON, FromJSON)" + , " deriving stock (Eq, Generic, Show)" + , " deriving (FromJSON, ToJSON)" , " via AddConstTextFields '[\"type0\" := \"undo\", \"type1\" := \"undo\", \"reversal_indicator\" := \"Undo\"] FlowDataDetails" ] @@ -873,7 +875,7 @@ case38 = expected @=? testStep (step indentIndentStyle { cVia = Indent 2 }) inpu , " , baz :: Double" , " , qux :: Bool" , " }" - , " deriving stock (Generic, Show, Eq)" + , " deriving stock (Eq, Generic, Show)" , " deriving (FromJSON, ToJSON)" , " via GenericEncoded '[FieldLabelModifier := '[\"foo\" ==> \"nestFoo#foo\", \"bar\" ==> \"nestBar#bar\", \"baz\" ==> \"nestFoo#baz\"]] Flat" ] @@ -907,8 +909,8 @@ case39 = expected @=? testStep (step indentIndentStyle { cVia = Indent 2 }) inpu , " = CreditTransfer" , " { nestedCreditorInfo :: CreditorInfo" , " }" - , " deriving stock (Show, Eq, Generic)" - , " deriving (ToJSON, FromJSON)" + , " deriving stock (Eq, Generic, Show)" + , " deriving (FromJSON, ToJSON)" , " via (UntaggedEncoded NordeaCreditTransfer & AddConstTextFields '[\"request_type\" ':= \"credit_transfer\", \"provider\" ':= \"nordea\"] & FlattenFields '[\"nested_creditor_info\"] & RenameKeys '[\"nested_creditor_info.creditor_agent_bic\" ==> \"creditor_agent_bic\", \"nested_creditor_info.creditor_iban\" ==> \"creditor_iban\", \"nested_creditor_info.creditor_name\" ==> \"creditor_name\", \"nested_creditor_info.creditor_account\" ==> \"creditor_account\"])" ] @@ -949,8 +951,8 @@ case41 = expected @=? testStep (step indentIndentStyle) input , " , callbackFormat :: CallbackFormat" , " -- ^ The format used to send these updates" , " }" - , " deriving stock (Generic, Eq, Show)" - , " deriving (ToJSON, FromJSON) via IdiomaticWithDescription CallbackDesc Callback" + , " deriving stock (Eq, Generic, Show)" + , " deriving (FromJSON, ToJSON) via IdiomaticWithDescription CallbackDesc Callback" , " deriving (HasGen) via Generically Callback" , " deriving (FromField) via JsonField Callback" ] @@ -966,7 +968,7 @@ case42 = expected @=? testStep (step indentIndentStyle) input , "data SignupError" , " = IdempotencyConflict" , " | ValidationError Text -- TODO: might be a sumtype of possible error codes" - , " deriving stock (Generic, Show, Eq)" + , " deriving stock (Eq, Generic, Show)" ] case43 :: Assertion @@ -1003,8 +1005,8 @@ case44 = expected @=? testStep (step indentIndentStyle { cBreakEnums = True, cBr , " , date :: Day" , " , accountNumber :: Account" , " }" - , " deriving stock (Show, Eq, Generic)" - , " deriving (ToJSON, FromJSON) via" + , " deriving stock (Eq, Generic, Show)" + , " deriving (FromJSON, ToJSON) via" , " AddConstTextFields" , " '[\"notification_type\" ':= \"credit_transaction\"" , " -- Note that the bcio name has \"transaction\"" @@ -1023,8 +1025,8 @@ case44 = expected @=? testStep (step indentIndentStyle { cBreakEnums = True, cBr , " }" , " -- Note that the bcio name has \"transaction\"" , " -- rather than \"transfer\"" - , " deriving stock (Show, Eq, Generic)" - , " deriving (ToJSON, FromJSON)" + , " deriving stock (Eq, Generic, Show)" + , " deriving (FromJSON, ToJSON)" , " via AddConstTextFields '[\"notification_type\" ':= \"credit_transaction\"] (UntaggedEncoded CreditTransfer)" ] @@ -1043,8 +1045,8 @@ case45 = expected @=? testStep (step indentIndentStyle { cBreakEnums = True, cBr , " }" , " -- Note that the bcio name has \"transaction\"" , " -- rather than \"transfer\"" - , " deriving stock (Show, Eq, Generic)" - , " deriving (ToJSON, FromJSON)" + , " deriving stock (Eq, Generic, Show)" + , " deriving (FromJSON, ToJSON)" , " via AddConstTextFields '[\"notification_type\" ':= \"credit_transaction\"] (UntaggedEncoded CreditTransfer)" ] @@ -1059,8 +1061,8 @@ case46 = expected @=? testStep (step indentIndentStyle { cBreakEnums = True, cBr , "data CallbackFormat" , " -- | The Avro schema is to be used" , " = AvroEngineEvent" - , " deriving (Bounded, Enum, Generic, Eq, Show)" - , " deriving (ToJSON, FromJSON)" + , " deriving (Bounded, Enum, Eq, Generic, Show)" + , " deriving (FromJSON, ToJSON)" , " via TypeTaggedWithDescription FormatDesc CallbackFormat" , " deriving (HasGen)" , " via EnumBounded CallbackFormat" @@ -1162,17 +1164,53 @@ case52 = expected @=? testStep (step indentIndentStyle { cBreakSingleConstructor , " }" ] +case53 :: Assertion +case53 = expected @=? testStep (step indentIndentStyle { cMaxColumns = MaxColumns 80 }) input + where + input = unlines + [ "newtype Foo m a" + , " = Foo (m a)" + , " deriving newtype (Functor, Applicative, Monad, MonadError, MonadCatch, Foldable, Monoid)" + ] + expected = unlines + [ "newtype Foo m a" + , " = Foo (m a)" + , " deriving newtype" + , " ( Applicative" + , " , Foldable" + , " , Functor" + , " , Monad" + , " , MonadCatch" + , " , MonadError" + , " , Monoid" + , " )" + ] + +case54 :: Assertion +case54 = expected @=? testStep (step indentIndentStyle { cMaxColumns = MaxColumns 80 }) input + where + input = unlines + [ "newtype Foo m a" + , " = Foo (m a)" + , " deriving newtype (Functor, Applicative, Monad)" + ] + expected = unlines + [ "newtype Foo m a" + , " = Foo (m a)" + , " deriving newtype (Applicative, Functor, Monad)" + ] + sameSameStyle :: Config -sameSameStyle = Config SameLine SameLine 2 2 False True SameLine False +sameSameStyle = Config SameLine SameLine 2 2 False True SameLine False NoMaxColumns sameIndentStyle :: Config -sameIndentStyle = Config SameLine (Indent 2) 2 2 False True SameLine False +sameIndentStyle = Config SameLine (Indent 2) 2 2 False True SameLine False NoMaxColumns indentSameStyle :: Config -indentSameStyle = Config (Indent 2) SameLine 2 2 False True SameLine False +indentSameStyle = Config (Indent 2) SameLine 2 2 False True SameLine False NoMaxColumns indentIndentStyle :: Config -indentIndentStyle = Config (Indent 2) (Indent 2) 2 2 False True SameLine False +indentIndentStyle = Config (Indent 2) (Indent 2) 2 2 False True SameLine False NoMaxColumns indentIndentStyle4 :: Config -indentIndentStyle4 = Config (Indent 4) (Indent 4) 4 4 False True SameLine False +indentIndentStyle4 = Config (Indent 4) (Indent 4) 4 4 False True SameLine False NoMaxColumns From 18f96cb7eda6cef8a78b5f0818a9ae34912dda65 Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Mon, 24 Aug 2020 13:50:30 +0200 Subject: [PATCH 076/135] Pass max columns to ImportsGHC step --- lib/Language/Haskell/Stylish/Config.hs | 6 ++++-- lib/Language/Haskell/Stylish/Step/ImportsGHC.hs | 8 ++++---- tests/Language/Haskell/Stylish/Step/ImportsGHC/Tests.hs | 3 ++- 3 files changed, 10 insertions(+), 7 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Config.hs b/lib/Language/Haskell/Stylish/Config.hs index ca61d154..80c8a466 100644 --- a/lib/Language/Haskell/Stylish/Config.hs +++ b/lib/Language/Haskell/Stylish/Config.hs @@ -263,13 +263,15 @@ parseImports config o = do pure if Imports.useGhcLibParser cfg then - ImportsGHC.step cfg + ImportsGHC.step columns cfg else - Imports.step (configColumns config) cfg + Imports.step columns cfg where def f = f Imports.defaultOptions + columns = configColumns config + aligns = [ ("global", Imports.Global) , ("file", Imports.File) diff --git a/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs b/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs index 47913c6e..9675a192 100644 --- a/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs +++ b/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs @@ -33,12 +33,12 @@ import Language.Haskell.Stylish.Editor import Language.Haskell.Stylish.GHC import Language.Haskell.Stylish.Step.Imports (Options(..)) -step :: Options -> Step -step = makeStep "Imports (ghc-lib-parser)" . printImports +step :: Maybe Int -> Options -> Step +step columns = makeStep "Imports (ghc-lib-parser)" . printImports columns -------------------------------------------------------------------------------- -printImports :: Options -> Lines -> Module -> Lines -printImports _ ls m = formatForImportGroups ls m (moduleImportGroups m) +printImports :: Maybe Int -> Options -> Lines -> Module -> Lines +printImports _ _ ls m = formatForImportGroups ls m (moduleImportGroups m) formatForImportGroups :: Lines -> Module -> [[Located Import]] -> Lines formatForImportGroups ls _m [] = ls diff --git a/tests/Language/Haskell/Stylish/Step/ImportsGHC/Tests.hs b/tests/Language/Haskell/Stylish/Step/ImportsGHC/Tests.hs index 6c468c63..9faa27f7 100644 --- a/tests/Language/Haskell/Stylish/Step/ImportsGHC/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/ImportsGHC/Tests.hs @@ -240,4 +240,5 @@ ex12 = input `assertFormatted` output -------------------------------------------------------------------------------- assertFormatted :: HasCallStack => Lines -> Lines -> Assertion -assertFormatted input expected = withFrozenCallStack $ expected @=? testStep' (step defaultOptions) input +assertFormatted input expected = + withFrozenCallStack $ expected @=? testStep' (step Nothing defaultOptions) input From fe97c30decc623ebdf7283a6a6e95c8945386ee1 Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Mon, 24 Aug 2020 14:24:25 +0200 Subject: [PATCH 077/135] Add ability to split import lines that are too long --- lib/Language/Haskell/Stylish/Printer.hs | 7 ++- .../Haskell/Stylish/Step/ImportsGHC.hs | 50 +++++++++++++++---- .../Haskell/Stylish/Step/ImportsGHC/Tests.hs | 41 ++++++++++++++- 3 files changed, 84 insertions(+), 14 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Printer.hs b/lib/Language/Haskell/Stylish/Printer.hs index a546b753..d34bc097 100644 --- a/lib/Language/Haskell/Stylish/Printer.hs +++ b/lib/Language/Haskell/Stylish/Printer.hs @@ -21,6 +21,7 @@ module Language.Haskell.Stylish.Printer , comma , dot , getAnnot + , getCurrentLine , getCurrentLineLength , getDocstrPrev , newline @@ -372,9 +373,13 @@ removeComment p = do getAnnot :: SrcSpan -> P [AnnKeywordId] getAnnot spn = gets (lookupAnnotation spn . parsedModule) +-- | Get current line +getCurrentLine :: P String +getCurrentLine = gets currentLine + -- | Get current line length getCurrentLineLength :: P Int -getCurrentLineLength = fmap length (gets currentLine) +getCurrentLineLength = fmap length getCurrentLine -- | Peek at the next comment in the state peekNextCommentPos :: P (Maybe SrcSpan) diff --git a/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs b/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs index 9675a192..2655fd52 100644 --- a/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs +++ b/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs @@ -38,11 +38,13 @@ step columns = makeStep "Imports (ghc-lib-parser)" . printImports columns -------------------------------------------------------------------------------- printImports :: Maybe Int -> Options -> Lines -> Module -> Lines -printImports _ _ ls m = formatForImportGroups ls m (moduleImportGroups m) +printImports maxCols _ ls m = + formatForImportGroups maxCols ls m (moduleImportGroups m) -formatForImportGroups :: Lines -> Module -> [[Located Import]] -> Lines -formatForImportGroups ls _m [] = ls -formatForImportGroups ls m (group : rest) = formatForImportGroups formattedGroup m rest +formatForImportGroups :: Maybe Int -> Lines -> Module -> [[Located Import]] -> Lines +formatForImportGroups _maxCols ls _m [] = ls +formatForImportGroups maxCols ls m (group : rest) = + formatForImportGroups maxCols formattedGroup m rest where formattedGroup :: Lines formattedGroup = @@ -69,7 +71,7 @@ formatForImportGroups ls m (group : rest) = formatForImportGroups formattedGroup importGroup = NonEmpty.sortWith unLocated rawGroup & mergeImports - forM_ importGroup \imp -> printPostQualified imp >> newline + forM_ importGroup \imp -> printPostQualified maxCols imp >> newline in case importStart of Just start -> @@ -81,8 +83,8 @@ formatForImportGroups ls m (group : rest) = formatForImportGroups formattedGroup Nothing -> ls -------------------------------------------------------------------------------- -printPostQualified :: Located Import -> P () -printPostQualified (L _ decl) = do +printPostQualified :: Maybe Int -> Located Import -> P () +printPostQualified maxCols (L _ decl) = do let decl' = rawImport decl @@ -101,15 +103,41 @@ printPostQualified (L _ decl) = do when (isHiding decl) (space >> putText "hiding") + -- Since we might need to output the import module name several times, we + -- need to save it to a variable: + importDecl <- fmap putText getCurrentLine + forM_ (snd <$> ideclHiding decl') \(L _ imports) -> let printedImports = fmap (printImport . unLocated) (sortImportList imports) - separated = - sep (comma >> space) - in - space >> parenthesize (separated printedImports) + impHead = + listToMaybe printedImports + + impTail = + drop 1 printedImports + in do + forM_ impHead \printedImport -> do + space + putText "(" + printedImport + + forM_ impTail \printedImport -> do + len <- getCurrentLineLength + if maybe False (len >=) maxCols then do + putText ")" + newline + importDecl + space + putText "(" + else do + comma + space + + printedImport + + forM_ impHead \_ -> putText ")" -------------------------------------------------------------------------------- printImport :: IE GhcPs -> P () diff --git a/tests/Language/Haskell/Stylish/Step/ImportsGHC/Tests.hs b/tests/Language/Haskell/Stylish/Step/ImportsGHC/Tests.hs index 9faa27f7..fc79bdc0 100644 --- a/tests/Language/Haskell/Stylish/Step/ImportsGHC/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/ImportsGHC/Tests.hs @@ -34,6 +34,8 @@ tests = testGroup "Language.Haskell.Stylish.Step.ImportsGHC" , testCase "Doesn't add extra space after 'hiding'" ex10 , testCase "Should be able to format symbolic imports" ex11 , testCase "Able to merge equivalent imports" ex12 + , testCase "Obeys max columns setting" ex13 + , testCase "Obeys max columns setting with two in each" ex14 ] -------------------------------------------------------------------------------- @@ -238,7 +240,42 @@ ex12 = input `assertFormatted` output , "import Data.Aeson ((.=))" ] +ex13 :: Assertion +ex13 = input `assertFormattedCols` output + where + assertFormattedCols = + assertFormatted' (Just 10) + input = + [ "import Foo (A, B, C, D)" + , "import A hiding (X)" + ] + output = + [ "import A hiding (X)" + , "import Foo (A)" + , "import Foo (B)" + , "import Foo (C)" + , "import Foo (D)" + ] + +ex14 :: Assertion +ex14 = input `assertFormattedCols` output + where + assertFormattedCols = + assertFormatted' (Just 16) + input = + [ "import Foo (A, B, C, D)" + , "import A hiding (X)" + ] + output = + [ "import A hiding (X)" + , "import Foo (A, B)" + , "import Foo (C, D)" + ] + -------------------------------------------------------------------------------- assertFormatted :: HasCallStack => Lines -> Lines -> Assertion -assertFormatted input expected = - withFrozenCallStack $ expected @=? testStep' (step Nothing defaultOptions) input +assertFormatted = withFrozenCallStack $ assertFormatted' Nothing + +assertFormatted' :: HasCallStack => Maybe Int -> Lines -> Lines -> Assertion +assertFormatted' maxColumns input expected = + withFrozenCallStack $ expected @=? testStep' (step maxColumns defaultOptions) input From f9d5d77cff075e9eb423e53d6debc7936f0c4253 Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Tue, 25 Aug 2020 11:31:20 +0200 Subject: [PATCH 078/135] Add testing function that has sane expected/got for long lines --- tests/Language/Haskell/Stylish/Tests/Util.hs | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) diff --git a/tests/Language/Haskell/Stylish/Tests/Util.hs b/tests/Language/Haskell/Stylish/Tests/Util.hs index 073e3db0..b85a7e7a 100644 --- a/tests/Language/Haskell/Stylish/Tests/Util.hs +++ b/tests/Language/Haskell/Stylish/Tests/Util.hs @@ -1,12 +1,16 @@ +{-# LANGUAGE BlockArguments #-} module Language.Haskell.Stylish.Tests.Util ( testStep , testStep' , withTestDirTree + , (@=??) ) where -------------------------------------------------------------------------------- import Control.Exception (bracket, try) +import Control.Monad.Writer (execWriter, tell) +import Data.List (intercalate) import System.Directory (createDirectory, getCurrentDirectory, getTemporaryDirectory, @@ -15,6 +19,7 @@ import System.Directory (createDirectory, import System.FilePath (()) import System.IO.Error (isAlreadyExistsError) import System.Random (randomIO) +import Test.HUnit (Assertion, assertFailure) -------------------------------------------------------------------------------- @@ -68,3 +73,15 @@ withTestDirTree action = bracket setCurrentDirectory current *> removeDirectoryRecursive temp) (\(_, temp) -> setCurrentDirectory temp *> action) + +(@=??) :: Lines -> Lines -> Assertion +expected @=?? actual = + if expected == actual then pure () + else assertFailure $ intercalate "\n" $ execWriter do + tell ["Expected:"] + printLines expected + tell ["Got:"] + printLines actual + where + printLines = + mapM_ \line -> tell [" " <> line] From 14cc1174d81d8a055d47d1e76f74146fd78ab7ab Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Tue, 25 Aug 2020 11:31:45 +0200 Subject: [PATCH 079/135] Fix issue with multiple groups in due to abusing editor functions --- .../Haskell/Stylish/Step/ImportsGHC.hs | 70 ++++++--------- .../Haskell/Stylish/Step/ImportsGHC/Tests.hs | 88 +++++++++++++++++-- 2 files changed, 112 insertions(+), 46 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs b/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs index 2655fd52..96c74d5b 100644 --- a/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs +++ b/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs @@ -38,49 +38,37 @@ step columns = makeStep "Imports (ghc-lib-parser)" . printImports columns -------------------------------------------------------------------------------- printImports :: Maybe Int -> Options -> Lines -> Module -> Lines -printImports maxCols _ ls m = - formatForImportGroups maxCols ls m (moduleImportGroups m) +printImports maxCols _ ls m = applyChanges changes ls + where + changes = concatMap (formatGroup maxCols m) (moduleImportGroups m) + +formatGroup :: Maybe Int -> Module -> [Located Import] -> [Change String] +formatGroup _maxCols _m _imports@[] = [] +formatGroup maxCols m imports@(impHead : impTail) = do + let + newLines = formatImports maxCols (impHead :| impTail) m + + toList $ fmap (\block -> change block (const newLines)) (importBlock imports) -formatForImportGroups :: Maybe Int -> Lines -> Module -> [[Located Import]] -> Lines -formatForImportGroups _maxCols ls _m [] = ls -formatForImportGroups maxCols ls m (group : rest) = - formatForImportGroups maxCols formattedGroup m rest +importBlock :: [Located a] -> Maybe (Block String) +importBlock group = Block <$> importStart <*> importEnd where - formattedGroup :: Lines - formattedGroup = - let - relevantComments = - [] - - importsBlock = Block - <$> importStart - <*> importEnd - - importStart - = listToMaybe group - & fmap getStartLineUnsafe - - importEnd - = lastMaybe group - & fmap getEndLineUnsafe - - formatting = runPrinter_ PrinterConfig relevantComments m do - importsWithComments <- sortedAttachedComments group - forM_ importsWithComments \(_, rawGroup) -> do - let - importGroup - = NonEmpty.sortWith unLocated rawGroup - & mergeImports - forM_ importGroup \imp -> printPostQualified maxCols imp >> newline - in - case importStart of - Just start -> - let - deletes = fmap delete $ toList importsBlock - additions = [insert start formatting] - in - applyChanges (deletes <> additions) ls - Nothing -> ls + importStart + = listToMaybe group + & fmap getStartLineUnsafe + + importEnd + = lastMaybe group + & fmap getEndLineUnsafe + +formatImports :: Maybe Int -> NonEmpty (Located Import) -> Module -> Lines +formatImports maxCols rawGroup m = runPrinter_ PrinterConfig [] m do + let + group + = NonEmpty.sortWith unLocated rawGroup + & mergeImports + + forM_ group \imp -> printPostQualified maxCols imp >> newline -------------------------------------------------------------------------------- printPostQualified :: Maybe Int -> Located Import -> P () diff --git a/tests/Language/Haskell/Stylish/Step/ImportsGHC/Tests.hs b/tests/Language/Haskell/Stylish/Step/ImportsGHC/Tests.hs index fc79bdc0..e7ede200 100644 --- a/tests/Language/Haskell/Stylish/Step/ImportsGHC/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/ImportsGHC/Tests.hs @@ -5,16 +5,15 @@ module Language.Haskell.Stylish.Step.ImportsGHC.Tests -------------------------------------------------------------------------------- import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit (Assertion, (@=?)) +import Test.HUnit (Assertion) import GHC.Stack (HasCallStack, withFrozenCallStack) import Prelude hiding (lines) - -------------------------------------------------------------------------------- import Language.Haskell.Stylish.Module import Language.Haskell.Stylish.Step.Imports (defaultOptions) import Language.Haskell.Stylish.Step.ImportsGHC (step) -import Language.Haskell.Stylish.Tests.Util (testStep') +import Language.Haskell.Stylish.Tests.Util (testStep', (@=??)) @@ -36,6 +35,7 @@ tests = testGroup "Language.Haskell.Stylish.Step.ImportsGHC" , testCase "Able to merge equivalent imports" ex12 , testCase "Obeys max columns setting" ex13 , testCase "Obeys max columns setting with two in each" ex14 + , testCase "Respects multiple groups" ex15 ] -------------------------------------------------------------------------------- @@ -272,10 +272,88 @@ ex14 = input `assertFormattedCols` output , "import Foo (C, D)" ] --------------------------------------------------------------------------------- +ex15 :: Assertion +ex15 = input `assertFormattedCols` output + where + assertFormattedCols = + assertFormatted' (Just 100) + input = + [ "module Custom.Prelude" + , " ( LazyByteString" + , " , UUID" + , " , decodeUtf8Lenient" + , " , error" + , " , headMay" + , " , module X" + , " , nextRandomUUID" + , " , onChars" + , " , proxyOf" + , " , show" + , " , showStr" + , " , toLazyByteString" + , " , toStrictByteString" + , " , type (~>)" + , " , uuidToText" + , " ) where" + , "" + , "--------------------------------------------------------------------------------" + , "import Prelude as X hiding ((!!), appendFile, error, foldl, head, putStrLn, readFile, show, tail, take, unlines, unwords, words, writeFile)" + , "import Prelude qualified" + , "" + , "--------------------------------------------------------------------------------" + , "import Control.Lens as X ((%~), (&), (.~), (?~), (^.), (^?), _Left, _Right, over, preview, set, to, view)" + , "import Control.Lens.Extras as X (is)" + , "" + , "--------------------------------------------------------------------------------" + , "import Control.Applicative as X ((<|>))" + , "import Control.Monad as X ((<=<), (>=>), guard, unless, when)" + , "import Control.Monad.Except as X (ExceptT (..), MonadError (..), liftEither, runExceptT, withExceptT)" + , "import Control.Monad.IO.Unlift as X" + , "import Control.Monad.Reader as X (MonadReader (..), ReaderT (..), asks)" + , "import Control.Monad.Trans.Class as X (MonadTrans (lift))" + , "--------------------------------------------------------------------------------" + ] + output = + [ "module Custom.Prelude" + , " ( LazyByteString" + , " , UUID" + , " , decodeUtf8Lenient" + , " , error" + , " , headMay" + , " , module X" + , " , nextRandomUUID" + , " , onChars" + , " , proxyOf" + , " , show" + , " , showStr" + , " , toLazyByteString" + , " , toStrictByteString" + , " , type (~>)" + , " , uuidToText" + , " ) where" + , "" + , "--------------------------------------------------------------------------------" + , "import Prelude as X hiding ((!!), appendFile, error, foldl, head, putStrLn, readFile, show, tail, take)" + , "import Prelude as X hiding (unlines, unwords, words, writeFile)" + , "import Prelude qualified" + , "" + , "--------------------------------------------------------------------------------" + , "import Control.Lens as X ((%~), (&), (.~), (?~), (^.), (^?), _Left, _Right, over, preview, set, to, view)" + , "import Control.Lens.Extras as X (is)" + , "" + , "--------------------------------------------------------------------------------" + , "import Control.Applicative as X ((<|>))" + , "import Control.Monad as X ((<=<), (>=>), guard, unless, when)" + , "import Control.Monad.Except as X (ExceptT (..), MonadError (..), liftEither, runExceptT, withExceptT)" + , "import Control.Monad.IO.Unlift as X" + , "import Control.Monad.Reader as X (MonadReader (..), ReaderT (..), asks)" + , "import Control.Monad.Trans.Class as X (MonadTrans (lift))" + , "--------------------------------------------------------------------------------" + ] + assertFormatted :: HasCallStack => Lines -> Lines -> Assertion assertFormatted = withFrozenCallStack $ assertFormatted' Nothing assertFormatted' :: HasCallStack => Maybe Int -> Lines -> Lines -> Assertion assertFormatted' maxColumns input expected = - withFrozenCallStack $ expected @=? testStep' (step maxColumns defaultOptions) input + withFrozenCallStack $ expected @=?? testStep' (step maxColumns defaultOptions) input From 4208e1bfeb75bd44d738ac8550b9a7c0caef3a95 Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Tue, 25 Aug 2020 13:11:08 +0200 Subject: [PATCH 080/135] Don't split 'hiding' imports since it changes the scope --- .../Haskell/Stylish/Step/ImportsGHC.hs | 9 ++- .../Haskell/Stylish/Step/ImportsGHC/Tests.hs | 74 +++++++++---------- 2 files changed, 45 insertions(+), 38 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs b/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs index 96c74d5b..968689f0 100644 --- a/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs +++ b/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs @@ -113,7 +113,7 @@ printPostQualified maxCols (L _ decl) = do forM_ impTail \printedImport -> do len <- getCurrentLineLength - if maybe False (len >=) maxCols then do + if canSplit len then do putText ")" newline importDecl @@ -126,6 +126,13 @@ printPostQualified maxCols (L _ decl) = do printedImport forM_ impHead \_ -> putText ")" + where + canSplit len = and + [ -- If the max cols have been surpassed, split: + maybe False (len >=) maxCols + -- Splitting a 'hiding' import changes the scope, don't split hiding: + , not (isHiding decl) + ] -------------------------------------------------------------------------------- printImport :: IE GhcPs -> P () diff --git a/tests/Language/Haskell/Stylish/Step/ImportsGHC/Tests.hs b/tests/Language/Haskell/Stylish/Step/ImportsGHC/Tests.hs index e7ede200..a59e0dbf 100644 --- a/tests/Language/Haskell/Stylish/Step/ImportsGHC/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/ImportsGHC/Tests.hs @@ -301,7 +301,7 @@ ex15 = input `assertFormattedCols` output , "import Prelude qualified" , "" , "--------------------------------------------------------------------------------" - , "import Control.Lens as X ((%~), (&), (.~), (?~), (^.), (^?), _Left, _Right, over, preview, set, to, view)" + , "import Control.Lens as X ((%~), (&), (.~), (?~), (^.), (^?), _Left, _Right, iat, over, preview, sans, set, to, view)" , "import Control.Lens.Extras as X (is)" , "" , "--------------------------------------------------------------------------------" @@ -314,42 +314,42 @@ ex15 = input `assertFormattedCols` output , "--------------------------------------------------------------------------------" ] output = - [ "module Custom.Prelude" - , " ( LazyByteString" - , " , UUID" - , " , decodeUtf8Lenient" - , " , error" - , " , headMay" - , " , module X" - , " , nextRandomUUID" - , " , onChars" - , " , proxyOf" - , " , show" - , " , showStr" - , " , toLazyByteString" - , " , toStrictByteString" - , " , type (~>)" - , " , uuidToText" - , " ) where" - , "" - , "--------------------------------------------------------------------------------" - , "import Prelude as X hiding ((!!), appendFile, error, foldl, head, putStrLn, readFile, show, tail, take)" - , "import Prelude as X hiding (unlines, unwords, words, writeFile)" - , "import Prelude qualified" - , "" - , "--------------------------------------------------------------------------------" - , "import Control.Lens as X ((%~), (&), (.~), (?~), (^.), (^?), _Left, _Right, over, preview, set, to, view)" - , "import Control.Lens.Extras as X (is)" - , "" - , "--------------------------------------------------------------------------------" - , "import Control.Applicative as X ((<|>))" - , "import Control.Monad as X ((<=<), (>=>), guard, unless, when)" - , "import Control.Monad.Except as X (ExceptT (..), MonadError (..), liftEither, runExceptT, withExceptT)" - , "import Control.Monad.IO.Unlift as X" - , "import Control.Monad.Reader as X (MonadReader (..), ReaderT (..), asks)" - , "import Control.Monad.Trans.Class as X (MonadTrans (lift))" - , "--------------------------------------------------------------------------------" - ] + [ "module Custom.Prelude" + , " ( LazyByteString" + , " , UUID" + , " , decodeUtf8Lenient" + , " , error" + , " , headMay" + , " , module X" + , " , nextRandomUUID" + , " , onChars" + , " , proxyOf" + , " , show" + , " , showStr" + , " , toLazyByteString" + , " , toStrictByteString" + , " , type (~>)" + , " , uuidToText" + , " ) where" + , "" + , "--------------------------------------------------------------------------------" + , "import Prelude as X hiding ((!!), appendFile, error, foldl, head, putStrLn, readFile, show, tail, take, unlines, unwords, words, writeFile)" + , "import Prelude qualified" + , "" + , "--------------------------------------------------------------------------------" + , "import Control.Lens as X ((%~), (&), (.~), (?~), (^.), (^?), _Left, _Right, iat, over, preview, sans)" + , "import Control.Lens as X (set, to, view)" + , "import Control.Lens.Extras as X (is)" + , "" + , "--------------------------------------------------------------------------------" + , "import Control.Applicative as X ((<|>))" + , "import Control.Monad as X ((<=<), (>=>), guard, unless, when)" + , "import Control.Monad.Except as X (ExceptT (..), MonadError (..), liftEither, runExceptT, withExceptT)" + , "import Control.Monad.IO.Unlift as X" + , "import Control.Monad.Reader as X (MonadReader (..), ReaderT (..), asks)" + , "import Control.Monad.Trans.Class as X (MonadTrans (lift))" + , "--------------------------------------------------------------------------------" + ] assertFormatted :: HasCallStack => Lines -> Lines -> Assertion assertFormatted = withFrozenCallStack $ assertFormatted' Nothing From d11358ac49c6918fa3ed57aa90663b6985d64e9b Mon Sep 17 00:00:00 2001 From: Felix Mulder Date: Tue, 25 Aug 2020 13:44:19 +0200 Subject: [PATCH 081/135] Make sure that nullary imports are not deleted --- lib/Language/Haskell/Stylish/Step/ImportsGHC.hs | 10 +++++----- .../Haskell/Stylish/Step/ImportsGHC/Tests.hs | 17 +++++++++++++++++ 2 files changed, 22 insertions(+), 5 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs b/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs index 968689f0..d5a35e84 100644 --- a/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs +++ b/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs @@ -106,10 +106,10 @@ printPostQualified maxCols (L _ decl) = do impTail = drop 1 printedImports in do - forM_ impHead \printedImport -> do - space - putText "(" - printedImport + space + putText "(" + + forM_ impHead id forM_ impTail \printedImport -> do len <- getCurrentLineLength @@ -125,7 +125,7 @@ printPostQualified maxCols (L _ decl) = do printedImport - forM_ impHead \_ -> putText ")" + putText ")" where canSplit len = and [ -- If the max cols have been surpassed, split: diff --git a/tests/Language/Haskell/Stylish/Step/ImportsGHC/Tests.hs b/tests/Language/Haskell/Stylish/Step/ImportsGHC/Tests.hs index a59e0dbf..debd27fa 100644 --- a/tests/Language/Haskell/Stylish/Step/ImportsGHC/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/ImportsGHC/Tests.hs @@ -36,6 +36,7 @@ tests = testGroup "Language.Haskell.Stylish.Step.ImportsGHC" , testCase "Obeys max columns setting" ex13 , testCase "Obeys max columns setting with two in each" ex14 , testCase "Respects multiple groups" ex15 + , testCase "Doesn't delete nullary imports" ex16 ] -------------------------------------------------------------------------------- @@ -351,6 +352,22 @@ ex15 = input `assertFormattedCols` output , "--------------------------------------------------------------------------------" ] +ex16 :: Assertion +ex16 = input `assertFormatted` output + where + input = + [ "module Foo where" + , "" + , "import B ()" + , "import A ()" + ] + output = + [ "module Foo where" + , "" + , "import A ()" + , "import B ()" + ] + assertFormatted :: HasCallStack => Lines -> Lines -> Assertion assertFormatted = withFrozenCallStack $ assertFormatted' Nothing From ade14f9ec6fe8beb3de0a22bdd9f72dfa42f0148 Mon Sep 17 00:00:00 2001 From: Beatrice Vergani Date: Tue, 4 Aug 2020 12:18:55 +0200 Subject: [PATCH 082/135] Integrate Squash and Align steps --- lib/Language/Haskell/Stylish/Align.hs | 53 +++--- lib/Language/Haskell/Stylish/Module.hs | 6 +- .../Haskell/Stylish/Step/SimpleAlign.hs | 165 ++++++++++-------- lib/Language/Haskell/Stylish/Step/Squash.hs | 71 ++++---- lib/Language/Haskell/Stylish/Util.hs | 95 ++++++++++ 5 files changed, 249 insertions(+), 141 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Align.hs b/lib/Language/Haskell/Stylish/Align.hs index 1f28d7a5..c8a092f9 100644 --- a/lib/Language/Haskell/Stylish/Align.hs +++ b/lib/Language/Haskell/Stylish/Align.hs @@ -8,7 +8,7 @@ module Language.Haskell.Stylish.Align -------------------------------------------------------------------------------- import Data.List (nub) -import qualified Language.Haskell.Exts as H +import qualified SrcLoc as S -------------------------------------------------------------------------------- @@ -51,49 +51,48 @@ data Alignable a = Alignable , aRightLead :: !Int } deriving (Show) - -------------------------------------------------------------------------------- -- | Create changes that perform the alignment. + align - :: Maybe Int -- ^ Max columns - -> [Alignable H.SrcSpan] -- ^ Alignables - -> [Change String] -- ^ Changes performing the alignment. + :: Maybe Int -- ^ Max columns + -> [Alignable S.RealSrcSpan] -- ^ Alignables + -> [Change String] -- ^ Changes performing the alignment align _ [] = [] align maxColumns alignment - -- Do not make any change if we would go past the maximum number of columns. - | exceedsColumns (longestLeft + longestRight) = [] - | not (fixable alignment) = [] - | otherwise = map align' alignment + -- Do not make an changes if we would go past the maximum number of columns + | exceedsColumns (longestLeft + longestRight) = [] + | not (fixable alignment) = [] + | otherwise = map align' alignment where exceedsColumns i = case maxColumns of - Nothing -> False -- No number exceeds a maximum column count of - -- Nothing, because there is no limit to exceed. - Just c -> i > c + Nothing -> False + Just c -> i > c - -- The longest thing in the left column. - longestLeft = maximum $ map (H.srcSpanEndColumn . aLeft) alignment + -- The longest thing in the left column + longestLeft = maximum $ map (S.srcSpanEndCol . aLeft) alignment - -- The longest thing in the right column. + -- The longest thing in the right column longestRight = maximum - [ H.srcSpanEndColumn (aRight a) - H.srcSpanStartColumn (aRight a) - + aRightLead a - | a <- alignment - ] - - align' a = changeLine (H.srcSpanStartLine $ aContainer a) $ \str -> - let column = H.srcSpanEndColumn $ aLeft a - (pre, post) = splitAt column str - in [padRight longestLeft (trimRight pre) ++ trimLeft post] + [ S.srcSpanEndCol (aRight a) - S.srcSpanStartCol (aRight a) + + aRightLead a + | a <- alignment + ] + align' a = changeLine (S.srcSpanStartLine $ aContainer a) $ \str -> + let column = S.srcSpanEndCol $ aLeft a + (pre, post) = splitAt column str + in [padRight longestLeft (trimRight pre) ++ trimLeft post] -------------------------------------------------------------------------------- -- | Checks that all the alignables appear on a single line, and that they do -- not overlap. -fixable :: [Alignable H.SrcSpan] -> Bool + +fixable :: [Alignable S.RealSrcSpan] -> Bool fixable [] = False fixable [_] = False fixable fields = all singleLine containers && nonOverlapping containers where containers = map aContainer fields - singleLine s = H.srcSpanStartLine s == H.srcSpanEndLine s - nonOverlapping ss = length ss == length (nub $ map H.srcSpanStartLine ss) + singleLine s = S.srcSpanStartLine s == S.srcSpanEndLine s + nonOverlapping ss = length ss == length (nub $ map S.srcSpanStartLine ss) diff --git a/lib/Language/Haskell/Stylish/Module.hs b/lib/Language/Haskell/Stylish/Module.hs index bbbaaade..b38130ae 100644 --- a/lib/Language/Haskell/Stylish/Module.hs +++ b/lib/Language/Haskell/Stylish/Module.hs @@ -5,9 +5,10 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE DeriveDataTypeable #-} module Language.Haskell.Stylish.Module ( -- * Data types - Module + Module (..) , ModuleHeader , Import , Decls @@ -52,6 +53,7 @@ import Data.List (nubBy, sort) import Data.List.NonEmpty (NonEmpty, nonEmpty) import Data.Text (Text) import qualified Data.Text as T +import Data.Data (Data) -------------------------------------------------------------------------------- import qualified ApiAnnotation as GHC @@ -82,7 +84,7 @@ data Module = Module , parsedAnnotations :: [(GHC.ApiAnnKey, [GHC.SrcSpan])] , parsedAnnotSrcs :: Map RealSrcSpan [GHC.AnnKeywordId] , parsedModule :: GHC.Located (GHC.HsModule GhcPs) - } + } deriving (Data) -- | Declarations in module newtype Decls = Decls [LHsDecl GhcPs] diff --git a/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs b/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs index b9de329f..a0c83397 100644 --- a/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs +++ b/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs @@ -1,4 +1,5 @@ -------------------------------------------------------------------------------- +{-# LANGUAGE TypeFamilies #-} module Language.Haskell.Stylish.Step.SimpleAlign ( Config (..) , defaultConfig @@ -7,10 +8,10 @@ module Language.Haskell.Stylish.Step.SimpleAlign -------------------------------------------------------------------------------- -import Data.Data (Data) -import Data.List (foldl') import Data.Maybe (maybeToList) -import qualified Language.Haskell.Exts as H +import Data.List (foldl') +import qualified GHC.Hs as Hs +import qualified SrcLoc as S -------------------------------------------------------------------------------- @@ -18,6 +19,7 @@ import Language.Haskell.Stylish.Align import Language.Haskell.Stylish.Editor import Language.Haskell.Stylish.Step import Language.Haskell.Stylish.Util +import Language.Haskell.Stylish.Module -------------------------------------------------------------------------------- @@ -36,93 +38,102 @@ defaultConfig = Config , cRecords = True } - --------------------------------------------------------------------------------- -cases :: Data l => H.Module l -> [[H.Alt l]] -cases modu = [alts | H.Case _ _ alts <- everything modu] - - -------------------------------------------------------------------------------- --- | For this to work well, we require a way to merge annotations. This merge --- operation should follow the semigroup laws. -altToAlignable :: (l -> l -> l) -> H.Alt l -> Maybe (Alignable l) -altToAlignable _ (H.Alt _ _ _ (Just _)) = Nothing -altToAlignable _ (H.Alt ann pat rhs@(H.UnGuardedRhs _ _) Nothing) = Just $ - Alignable - { aContainer = ann - , aLeft = H.ann pat - , aRight = H.ann rhs - , aRightLead = length "-> " - } -altToAlignable - merge - (H.Alt ann pat (H.GuardedRhss _ [H.GuardedRhs _ guards rhs]) Nothing) = - -- We currently only support the case where an alternative has a single - -- guarded RHS. If there are more, we would need to return multiple - -- `Alignable`s from this function, which would be a significant change. - Just $ Alignable - { aContainer = ann - , aLeft = foldl' merge (H.ann pat) (map H.ann guards) - , aRight = H.ann rhs - , aRightLead = length "-> " - } -altToAlignable _ _ = Nothing - - --------------------------------------------------------------------------------- -tlpats :: Data l => H.Module l -> [[H.Match l]] -tlpats modu = [matches | H.FunBind _ matches <- everything modu] - +-- +tlpats :: (S.Located (Hs.HsModule Hs.GhcPs)) -> [[S.Located (Hs.Match Hs.GhcPs (Hs.LHsExpr Hs.GhcPs))]] +tlpats modu = + let + decls = map S.unLoc (Hs.hsmodDecls (S.unLoc modu)) + binds = [ bind | Hs.ValD _ bind <- decls ] + funMatches = map Hs.fun_matches binds + matches = map Hs.mg_alts funMatches + in + map S.unLoc matches -------------------------------------------------------------------------------- -matchToAlignable :: H.Match l -> Maybe (Alignable l) -matchToAlignable (H.InfixMatch _ _ _ _ _ _) = Nothing -matchToAlignable (H.Match _ _ [] _ _) = Nothing -matchToAlignable (H.Match _ _ _ _ (Just _)) = Nothing -matchToAlignable (H.Match ann name pats rhs Nothing) = Just $ Alignable - { aContainer = ann - , aLeft = last (H.ann name : map H.ann pats) - , aRight = H.ann rhs +records :: (S.Located (Hs.HsModule Hs.GhcPs)) -> [[S.Located (Hs.ConDeclField Hs.GhcPs)]] +records modu = + let + decls = map S.unLoc (Hs.hsmodDecls (S.unLoc modu)) + tyClDecls = [ tyClDecl | Hs.TyClD _ tyClDecl <- decls ] + dataDecls = [ d | d@(Hs.DataDecl _ _ _ _ _) <- tyClDecls ] + dataDefns = map Hs.tcdDataDefn dataDecls + conDecls = concatMap getConDecls dataDefns + conDeclDetails = map getConDeclDetails conDecls + llConDeclFields = getLocRecs conDeclDetails + lConDeclFields = concatMap S.unLoc llConDeclFields + in + [ lConDeclFields ] + + +matchToAlignable :: S.Located (Hs.Match Hs.GhcPs (Hs.LHsExpr Hs.GhcPs)) -> Maybe (Alignable S.RealSrcSpan) +matchToAlignable (S.L matchLoc (Hs.Match _ (Hs.FunRhs name _ _) pats grhss)) = do + body <- unguardedRhsBody grhss + let patsLocs = map S.getLoc pats + nameLoc = S.getLoc name + left = last (nameLoc : patsLocs) + bodyLoc = S.getLoc body + matchPos <- toRealSrcSpan matchLoc + leftPos <- toRealSrcSpan left + bodyPos <- toRealSrcSpan bodyLoc + Just $ Alignable + { aContainer = matchPos + , aLeft = leftPos + , aRight = bodyPos , aRightLead = length "= " } - - --------------------------------------------------------------------------------- -records :: H.Module l -> [[H.FieldDecl l]] -records modu = - [ fields - | H.Module _ _ _ _ decls <- [modu] - , H.DataDecl _ _ _ _ cons _ <- decls - , H.QualConDecl _ _ _ (H.RecDecl _ _ fields) <- cons - ] - - --------------------------------------------------------------------------------- -fieldDeclToAlignable :: H.FieldDecl a -> Maybe (Alignable a) -fieldDeclToAlignable (H.FieldDecl ann names ty) = Just $ Alignable - { aContainer = ann - , aLeft = H.ann (last names) - , aRight = H.ann ty +matchToAlignable (S.L _ (Hs.Match _ _ [] _)) = Nothing +matchToAlignable (S.L _ (Hs.Match _ _ _ _ )) = Nothing +matchToAlignable (S.L _ (Hs.XMatch x)) = Hs.noExtCon x + +caseToAlignable :: S.Located (Hs.Match Hs.GhcPs (Hs.LHsExpr Hs.GhcPs)) -> Maybe (Alignable S.RealSrcSpan) +caseToAlignable (S.L matchLoc m@(Hs.Match _ Hs.CaseAlt pats@(_ : _) grhss)) = do + let patsLocs = map S.getLoc pats + pat = last patsLocs + guards = getGuards m + guardsLocs = map S.getLoc guards + left = foldl' S.combineSrcSpans pat guardsLocs + body <- rhsBody grhss + matchPos <- toRealSrcSpan matchLoc + leftPos <- toRealSrcSpan left + rightPos <- toRealSrcSpan $ S.getLoc body + Just $ Alignable + { aContainer = matchPos + , aLeft = leftPos + , aRight = rightPos + , aRightLead = length "-> " + } +caseToAlignable (S.L _ (Hs.XMatch x)) = Hs.noExtCon x +caseToAlignable (S.L _ (Hs.Match _ _ _ _)) = Nothing + + +fieldDeclToAlignable :: S.Located (Hs.ConDeclField Hs.GhcPs) -> Maybe (Alignable S.RealSrcSpan) +fieldDeclToAlignable (S.L _ (Hs.XConDeclField x)) = Hs.noExtCon x +fieldDeclToAlignable (S.L matchLoc (Hs.ConDeclField _ names ty _)) = do + matchPos <- toRealSrcSpan matchLoc + leftPos <- toRealSrcSpan $ S.getLoc $ last names + tyPos <- toRealSrcSpan $ S.getLoc ty + Just $ Alignable + { aContainer = matchPos + , aLeft = leftPos + , aRight = tyPos , aRightLead = length ":: " } - --------------------------------------------------------------------------------- step :: Maybe Int -> Config -> Step -step maxColumns config = oldMakeStep "Cases" $ \ls (module', _) -> - let module'' = fmap H.srcInfoSpan module' +step maxColumns config = makeStep "Cases" $ \ls module' -> + let changes :: ((S.Located (Hs.HsModule Hs.GhcPs)) -> [[a]]) -> (a -> Maybe (Alignable S.RealSrcSpan)) -> [Change String] changes search toAlign = [ change_ - | case_ <- search module'' + | case_ <- search (parsedModule module') , aligns <- maybeToList (mapM toAlign case_) , change_ <- align maxColumns aligns ] - + configured :: [Change String] configured = concat $ - [ changes cases (altToAlignable H.mergeSrcSpan) - | cCases config - ] ++ - [changes tlpats matchToAlignable | cTopLevelPatterns config] ++ - [changes records fieldDeclToAlignable | cRecords config] - + [changes tlpats matchToAlignable | cTopLevelPatterns config] ++ + [changes records fieldDeclToAlignable | cRecords config] ++ + [changes everything caseToAlignable | cCases config] in applyChanges configured ls + + diff --git a/lib/Language/Haskell/Stylish/Step/Squash.hs b/lib/Language/Haskell/Stylish/Step/Squash.hs index cf3f9ef0..23d1e9fa 100644 --- a/lib/Language/Haskell/Stylish/Step/Squash.hs +++ b/lib/Language/Haskell/Stylish/Step/Squash.hs @@ -1,4 +1,7 @@ -------------------------------------------------------------------------------- +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE TypeFamilies #-} module Language.Haskell.Stylish.Step.Squash ( step ) where @@ -6,7 +9,8 @@ module Language.Haskell.Stylish.Step.Squash -------------------------------------------------------------------------------- import Data.Maybe (mapMaybe) -import qualified Language.Haskell.Exts as H +import qualified GHC.Hs as Hs +import qualified SrcLoc as S -------------------------------------------------------------------------------- @@ -17,46 +21,43 @@ import Language.Haskell.Stylish.Util -------------------------------------------------------------------------------- squash - :: (H.Annotated l, H.Annotated r) - => l H.SrcSpan -> r H.SrcSpan -> Maybe (Change String) -squash left right - | H.srcSpanEndLine lAnn == H.srcSpanStartLine rAnn = Just $ - changeLine (H.srcSpanEndLine lAnn) $ \str -> - let (pre, post) = splitAt (H.srcSpanEndColumn lAnn) str - in [trimRight pre ++ " " ++ trimLeft post] - | otherwise = Nothing - where - lAnn = H.ann left - rAnn = H.ann right - - --------------------------------------------------------------------------------- -squashFieldDecl :: H.FieldDecl H.SrcSpan -> Maybe (Change String) -squashFieldDecl (H.FieldDecl _ names type') + :: (S.HasSrcSpan l, S.HasSrcSpan r) + => l -> r -> Maybe (Change String) +squash left right = do + lAnn <- toRealSrcSpan $ S.getLoc left + rAnn <- toRealSrcSpan $ S.getLoc right + if S.srcSpanEndLine lAnn == S.srcSpanStartLine rAnn || + S.srcSpanEndLine lAnn + 1 == S.srcSpanStartLine rAnn + then Just $ + changeLine (S.srcSpanEndLine lAnn) $ \str -> + let (pre, post) = splitAt (S.srcSpanEndCol lAnn) str + in [trimRight pre ++ " " ++ trimLeft post] + else Nothing + + +-------------------------------------------------------------------------------- +squashFieldDecl :: Hs.ConDeclField Hs.GhcPs -> Maybe (Change String) +squashFieldDecl (Hs.ConDeclField _ names type' _) | null names = Nothing | otherwise = squash (last names) type' +squashFieldDecl (Hs.XConDeclField x) = Hs.noExtCon x -------------------------------------------------------------------------------- -squashMatch :: H.Match H.SrcSpan -> Maybe (Change String) -squashMatch (H.InfixMatch _ _ _ _ _ _) = Nothing -squashMatch (H.Match _ name pats rhs _) - | null pats = squash name rhs - | otherwise = squash (last pats) rhs - - --------------------------------------------------------------------------------- -squashAlt :: H.Alt H.SrcSpan -> Maybe (Change String) -squashAlt (H.Alt _ pat rhs _) = squash pat rhs +squashMatch :: Hs.Match Hs.GhcPs (Hs.LHsExpr Hs.GhcPs) -> Maybe (Change String) +squashMatch (Hs.Match _ (Hs.FunRhs name _ _) [] grhss) = do + body <- unguardedRhsBody grhss + squash name body +squashMatch (Hs.Match _ _ pats grhss) = do + body <- unguardedRhsBody grhss + squash (last pats) body +squashMatch (Hs.XMatch x) = Hs.noExtCon x -------------------------------------------------------------------------------- step :: Step -step = oldMakeStep "Squash" $ \ls (module', _) -> - let module'' = fmap H.srcInfoSpan module' - changes = concat - [ mapMaybe squashAlt (everything module'') - , mapMaybe squashMatch (everything module'') - , mapMaybe squashFieldDecl (everything module'') - ] - in applyChanges changes ls +step = makeStep "Squash" $ \ls (module') -> + let changes = + mapMaybe squashFieldDecl (everything module') ++ + mapMaybe squashMatch (everything module') in + applyChanges changes ls diff --git a/lib/Language/Haskell/Stylish/Util.hs b/lib/Language/Haskell/Stylish/Util.hs index 9883f4b5..cdd9b223 100644 --- a/lib/Language/Haskell/Stylish/Util.hs +++ b/lib/Language/Haskell/Stylish/Util.hs @@ -17,6 +17,20 @@ module Language.Haskell.Stylish.Util , withInit , withTail , withLast + + , toRealSrcSpan + + , traceOutputtable + , traceOutputtableM + + , unguardedRhsBody + , rhsBody + + , getConDecls + , getConDeclDetails + , getLocRecs + + , getGuards ) where @@ -28,7 +42,11 @@ import qualified Data.Generics as G import Data.Maybe (fromMaybe, listToMaybe, maybeToList) import Data.Typeable (cast) +import Debug.Trace (trace) import qualified Language.Haskell.Exts as H +import qualified Outputable +import qualified GHC.Hs as Hs +import qualified SrcLoc as S -------------------------------------------------------------------------------- @@ -185,3 +203,80 @@ withInit f (x : xs) = f x : withInit f xs withTail :: (a -> a) -> [a] -> [a] withTail _ [] = [] withTail f (x : xs) = x : map f xs + + +-------------------------------------------------------------------------------- +traceOutputtable :: Outputable.Outputable a => String -> a -> b -> b +traceOutputtable title x = + trace (title ++ ": " ++ (Outputable.showSDocUnsafe $ Outputable.ppr x)) + + +-------------------------------------------------------------------------------- +traceOutputtableM :: (Outputable.Outputable a, Monad m) => String -> a -> m () +traceOutputtableM title x = traceOutputtable title x $ pure () + + +-------------------------------------------------------------------------------- +-- take the (Maybe) RealSrcSpan out of the SrcSpan +toRealSrcSpan :: S.SrcSpan -> Maybe S.RealSrcSpan +toRealSrcSpan (S.RealSrcSpan s) = Just s +toRealSrcSpan _ = Nothing + + +-------------------------------------------------------------------------------- +-- Utility: grab the body out of guarded RHSs if it's a single unguarded one. +unguardedRhsBody :: Hs.GRHSs Hs.GhcPs a -> Maybe a +unguardedRhsBody (Hs.GRHSs _ [grhs] _) + | Hs.GRHS _ [] body <- S.unLoc grhs = Just body +unguardedRhsBody _ = Nothing + + +-- Utility: grab the body out of guarded RHSs +rhsBody :: Hs.GRHSs Hs.GhcPs a -> Maybe a +rhsBody (Hs.GRHSs _ [grhs] _) + | Hs.GRHS _ _ body <- S.unLoc grhs = Just body +rhsBody _ = Nothing + +-------------------------------------------------------------------------------- +-- get a list of un-located constructors +getConDecls :: Hs.HsDataDefn Hs.GhcPs -> [Hs.ConDecl Hs.GhcPs] +getConDecls d@(Hs.HsDataDefn _ _ _ _ _ _cons _) = + map S.unLoc $ Hs.dd_cons d +getConDecls (Hs.XHsDataDefn x) = Hs.noExtCon x + + +-------------------------------------------------------------------------------- +-- get Arguments from data Construction Declaration +getConDeclDetails :: Hs.ConDecl Hs.GhcPs -> Hs.HsConDeclDetails Hs.GhcPs +getConDeclDetails d@(Hs.ConDeclGADT _ _ _ _ _ _ _ _) = Hs.con_args d +getConDeclDetails d@(Hs.ConDeclH98 _ _ _ _ _ _ _) = Hs.con_args d +getConDeclDetails (Hs.XConDecl x) = Hs.noExtCon x + + +-------------------------------------------------------------------------------- +-- look for Record(s) in a list of Construction Declaration details +getLocRecs :: [Hs.HsConDeclDetails Hs.GhcPs] -> [S.Located [Hs.LConDeclField Hs.GhcPs]] +getLocRecs conDeclDetails = + [ rec | Hs.RecCon rec <- conDeclDetails ] + + +-------------------------------------------------------------------------------- +-- get guards in a guarded rhs of a Match +getGuards :: Hs.Match Hs.GhcPs (Hs.LHsExpr Hs.GhcPs) -> [Hs.GuardLStmt Hs.GhcPs] +getGuards (Hs.Match _ _ _ grhss) = + let + lgrhs = getLocGRHS grhss -- [] + grhs = map S.unLoc lgrhs + in + concatMap getGuardLStmts grhs +getGuards (Hs.XMatch x) = Hs.noExtCon x + + +getLocGRHS :: Hs.GRHSs Hs.GhcPs (Hs.LHsExpr Hs.GhcPs) -> [Hs.LGRHS Hs.GhcPs (Hs.LHsExpr Hs.GhcPs)] +getLocGRHS (Hs.GRHSs _ guardeds _) = guardeds +getLocGRHS (Hs.XGRHSs x) = Hs.noExtCon x + + +getGuardLStmts :: Hs.GRHS Hs.GhcPs (Hs.LHsExpr Hs.GhcPs) -> [Hs.GuardLStmt Hs.GhcPs] +getGuardLStmts (Hs.GRHS _ guards _) = guards +getGuardLStmts (Hs.XGRHS x) = Hs.noExtCon x From 5875a53a6cecda5492572a353939b2dad8a715f3 Mon Sep 17 00:00:00 2001 From: Beatrice Vergani Date: Thu, 27 Aug 2020 15:33:08 +0200 Subject: [PATCH 083/135] Change error msg in test --- tests/Language/Haskell/Stylish/Tests.hs | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/tests/Language/Haskell/Stylish/Tests.hs b/tests/Language/Haskell/Stylish/Tests.hs index f1d60948..b99e620a 100644 --- a/tests/Language/Haskell/Stylish/Tests.hs +++ b/tests/Language/Haskell/Stylish/Tests.hs @@ -100,10 +100,8 @@ case04 = (@?= result) =<< format Nothing (Just fileLocation) input fileLocation = "directory/File.hs" input = "module Herp" result = Left $ - "Language.Haskell.Stylish.Parse.parseModuleHSE: could not parse " <> - fileLocation <> - ": ParseFailed (SrcLoc \".hs\" 2 1) \"Parse error: EOF\"" - + fileLocation <> ": RealSrcSpan SrcSpanPoint \"directory/File.hs\" 2 1:" + <> " parse error (possibly incorrect indentation or mismatched brackets)\n" -------------------------------------------------------------------------------- -- | When providing current dir including folders and files. From ab9953448c2253073d2d07a02b920beb32938fed Mon Sep 17 00:00:00 2001 From: Beatrice Vergani Date: Mon, 31 Aug 2020 15:27:52 +0200 Subject: [PATCH 084/135] Implementated some options (align, pad_module_names, separate_lists, space surround). Edited ImportsGHC tests to use (defualt) options --- lib/Language/Haskell/Stylish/Config.hs | 2 +- lib/Language/Haskell/Stylish/Step/Imports.hs | 8 +- .../Haskell/Stylish/Step/ImportsGHC.hs | 144 +++++++++++++---- lib/Language/Haskell/Stylish/Step/Squash.hs | 1 + .../Haskell/Stylish/Step/ImportsGHC/Tests.hs | 149 +++++++++--------- 5 files changed, 191 insertions(+), 113 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Config.hs b/lib/Language/Haskell/Stylish/Config.hs index 80c8a466..39cce2f3 100644 --- a/lib/Language/Haskell/Stylish/Config.hs +++ b/lib/Language/Haskell/Stylish/Config.hs @@ -259,7 +259,7 @@ parseImports config o = do <*> o A..:? "list_padding" A..!= def Imports.listPadding <*> o A..:? "separate_lists" A..!= def Imports.separateLists <*> o A..:? "space_surround" A..!= def Imports.spaceSurround - <*> o A..:? "ghc_lib_parser" A..!= False + <*> o A..:? "ghc_lib_parser" A..!= True pure if Imports.useGhcLibParser cfg then diff --git a/lib/Language/Haskell/Stylish/Step/Imports.hs b/lib/Language/Haskell/Stylish/Step/Imports.hs index cc353a01..53706468 100644 --- a/lib/Language/Haskell/Stylish/Step/Imports.hs +++ b/lib/Language/Haskell/Stylish/Step/Imports.hs @@ -84,10 +84,10 @@ data EmptyListAlign deriving (Eq, Show) data LongListAlign - = Inline - | InlineWithBreak - | InlineToMultiline - | Multiline + = Inline -- inline + | InlineWithBreak -- new_line + | InlineToMultiline -- new_line_multiline + | Multiline -- multiline deriving (Eq, Show) diff --git a/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs b/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs index d5a35e84..5926a1dc 100644 --- a/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs +++ b/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs @@ -1,6 +1,7 @@ -{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE DoAndIfThenElse #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} module Language.Haskell.Stylish.Step.ImportsGHC ( Options (..) , step @@ -31,22 +32,23 @@ import Language.Haskell.Stylish.Printer import Language.Haskell.Stylish.Step import Language.Haskell.Stylish.Editor import Language.Haskell.Stylish.GHC -import Language.Haskell.Stylish.Step.Imports (Options(..)) +import Language.Haskell.Stylish.Step.Imports hiding (step) + step :: Maybe Int -> Options -> Step step columns = makeStep "Imports (ghc-lib-parser)" . printImports columns -------------------------------------------------------------------------------- printImports :: Maybe Int -> Options -> Lines -> Module -> Lines -printImports maxCols _ ls m = applyChanges changes ls +printImports maxCols align ls m = applyChanges changes ls where - changes = concatMap (formatGroup maxCols m) (moduleImportGroups m) + changes = concatMap (formatGroup maxCols align m) (moduleImportGroups m) -formatGroup :: Maybe Int -> Module -> [Located Import] -> [Change String] -formatGroup _maxCols _m _imports@[] = [] -formatGroup maxCols m imports@(impHead : impTail) = do +formatGroup :: Maybe Int -> Options -> Module -> [Located Import] -> [Change String] +formatGroup _maxCols _align _m _imports@[] = [] +formatGroup maxCols align m imports@(impHead : impTail) = do let - newLines = formatImports maxCols (impHead :| impTail) m + newLines = formatImports maxCols align (impHead :| impTail) m toList $ fmap (\block -> change block (const newLines)) (importBlock imports) @@ -61,20 +63,41 @@ importBlock group = Block <$> importStart <*> importEnd = lastMaybe group & fmap getEndLineUnsafe -formatImports :: Maybe Int -> NonEmpty (Located Import) -> Module -> Lines -formatImports maxCols rawGroup m = runPrinter_ PrinterConfig [] m do - let +formatImports :: Maybe Int -> Options -> NonEmpty (Located Import) -> Module -> Lines +formatImports maxCols align rawGroup m = runPrinter_ PrinterConfig [] m do + let + group = NonEmpty.sortWith unLocated rawGroup & mergeImports - forM_ group \imp -> printPostQualified maxCols imp >> newline + unLocatedGroup = fmap unLocated $ toList group + + anyQual = any isQualified unLocatedGroup + + fileAlign = case importAlign align of + File -> anyQual + _ -> False + + align' = importAlign align + padModuleNames' = padModuleNames align + padNames = align' /= None && padModuleNames' + padQual = case align' of + Global -> True + File -> fileAlign + Group -> anyQual + None -> False + + longest = longestImport unLocatedGroup + + forM_ group \imp -> printQualified maxCols align padQual padNames longest imp >> newline -------------------------------------------------------------------------------- -printPostQualified :: Maybe Int -> Located Import -> P () -printPostQualified maxCols (L _ decl) = do +printQualified :: Maybe Int -> Options -> Bool -> Bool -> Int -> Located Import -> P () +printQualified maxCols Options{..} padQual padNames longest (L _ decl) = do let - decl' = rawImport decl + decl' = rawImport decl + listPadding' = listPaddingValue (6 + 1 + qualifiedLength) listPadding putText "import" >> space @@ -82,14 +105,18 @@ printPostQualified maxCols (L _ decl) = do when (isSafe decl) (putText "safe" >> space) + when (isQualified decl) (putText "qualified" >> space) + + padQualified decl padQual + putText (moduleName decl) - when (isQualified decl) (space >> putText "qualified") + padImportsList decl padNames longest forM_ (ideclAs decl') \(L _ name) -> space >> putText "as" >> space >> putText (moduleNameString name) - when (isHiding decl) (space >> putText "hiding") + when (isHiding decl) (space >> putText "hiding") -- Since we might need to output the import module name several times, we -- need to save it to a variable: @@ -97,8 +124,8 @@ printPostQualified maxCols (L _ decl) = do forM_ (snd <$> ideclHiding decl') \(L _ imports) -> let - printedImports = - fmap (printImport . unLocated) (sortImportList imports) + printedImports = -- [P ()] + fmap ((printImport Options{..}) . unLocated) (sortImportList imports) impHead = listToMaybe printedImports @@ -108,12 +135,14 @@ printPostQualified maxCols (L _ decl) = do in do space putText "(" + + when spaceSurround space forM_ impHead id forM_ impTail \printedImport -> do len <- getCurrentLineLength - if canSplit len then do + if canSplit (len) then do putText ")" newline importDecl @@ -124,7 +153,8 @@ printPostQualified maxCols (L _ decl) = do space printedImport - + + when spaceSurround space putText ")" where canSplit len = and @@ -134,31 +164,40 @@ printPostQualified maxCols (L _ decl) = do , not (isHiding decl) ] + qualifiedDecl | isQualified decl = ["qualified"] + | padQual = + if isSource decl + then [] + else if isSafe decl + then [" "] + else [" "] + | otherwise = [] + qualifiedLength = if null qualifiedDecl then 0 else 1 + sum (map length qualifiedDecl) + -------------------------------------------------------------------------------- -printImport :: IE GhcPs -> P () -printImport = \case - IEVar _ name -> +printImport :: Options -> IE GhcPs -> P () +printImport Options{..} (IEVar _ name) = do printIeWrappedName name - IEThingAbs _ name -> +printImport _ (IEThingAbs _ name) = do printIeWrappedName name - IEThingAll _ name -> do +printImport _ (IEThingAll _ name) = do printIeWrappedName name space putText "(..)" - IEModuleContents _ (L _ m) -> +printImport _ (IEModuleContents _ (L _ m)) = do putText (moduleNameString m) - IEThingWith _ name _wildcard imps _ -> do +printImport Options{..} (IEThingWith _ name _wildcard imps _) = do printIeWrappedName name - space + when separateLists space parenthesize $ sep (comma >> space) (printIeWrappedName <$> sortBy compareOutputable imps) - IEGroup _ _ _ -> +printImport _ (IEGroup _ _ _ ) = error "Language.Haskell.Stylish.Printer.Imports.printImportExport: unhandled case 'IEGroup'" - IEDoc _ _ -> +printImport _ (IEDoc _ _) = error "Language.Haskell.Stylish.Printer.Imports.printImportExport: unhandled case 'IEDoc'" - IEDocNamed _ _ -> +printImport _ (IEDocNamed _ _) = error "Language.Haskell.Stylish.Printer.Imports.printImportExport: unhandled case 'IEDocNamed'" - XIE ext -> +printImport _ (XIE ext) = GHC.noExtCon ext -------------------------------------------------------------------------------- @@ -186,6 +225,37 @@ moduleName . ideclName . rawImport + +-------------------------------------------------------------------------------- +longestImport :: [Import] -> Int +longestImport = maximum . map importLength + +-- computes length till module name +importLength :: Import -> Int +importLength i = + let + srcLength | isSource i = length "{# SOURCE #}" + | otherwise = 0 + qualLength = length "qualified" + nameLength = length $ moduleName i + in + srcLength + qualLength + nameLength + +-------------------------------------------------------------------------------- +padQualified :: Import -> Bool -> P () +padQualified i padQual = do + let pads = length "qualified" + if padQual && not (isQualified i) + then (putText $ replicate pads ' ') >> space + else pure () + +padImportsList :: Import -> Bool -> Int -> P () +padImportsList i padNames longest = do + let diff = longest - importLength i + if padNames + then putText $ replicate diff ' ' + else pure () + isQualified :: Import -> Bool isQualified = (/=) NotQualified @@ -237,3 +307,9 @@ sortImportList = sortBy $ currycated \case currycated :: ((a, b) -> c) -> (Located a -> Located b -> c) currycated f = \(L _ a) (L _ b) -> f (a, b) + +-------------------------------------------------------------------------------- +listPaddingValue :: Int -> ListPadding -> Int +listPaddingValue _ (LPConstant n) = n +listPaddingValue n LPModuleName = n + diff --git a/lib/Language/Haskell/Stylish/Step/Squash.hs b/lib/Language/Haskell/Stylish/Step/Squash.hs index 23d1e9fa..ae54dc89 100644 --- a/lib/Language/Haskell/Stylish/Step/Squash.hs +++ b/lib/Language/Haskell/Stylish/Step/Squash.hs @@ -17,6 +17,7 @@ import qualified SrcLoc as S import Language.Haskell.Stylish.Editor import Language.Haskell.Stylish.Step import Language.Haskell.Stylish.Util +import Language.Haskell.Stylish.Module -------------------------------------------------------------------------------- diff --git a/tests/Language/Haskell/Stylish/Step/ImportsGHC/Tests.hs b/tests/Language/Haskell/Stylish/Step/ImportsGHC/Tests.hs index debd27fa..a9fd6d9a 100644 --- a/tests/Language/Haskell/Stylish/Step/ImportsGHC/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/ImportsGHC/Tests.hs @@ -48,8 +48,8 @@ ex0 = input `assertFormatted` output , "import A" ] output = - [ "import A" - , "import B" + [ "import A" + , "import B" ] ex1 :: Assertion @@ -59,15 +59,15 @@ ex1 = input `assertFormatted` output [ "import B" , "import A" , "import C" - , "import A qualified" - , "import B qualified as X" + , "import qualified A" + , "import qualified B as X" ] output = - [ "import A" - , "import A qualified" - , "import B" - , "import B qualified as X" - , "import C" + [ "import A" + , "import qualified A" + , "import B" + , "import qualified B as X" + , "import C" ] ex2 :: Assertion @@ -77,13 +77,13 @@ ex2 = input `assertFormatted` output [ "import B" , "import A (X)" , "import C" - , "import A qualified as Y (Y)" + , "import qualified A as Y (Y)" ] output = - [ "import A (X)" - , "import A qualified as Y (Y)" - , "import B" - , "import C" + [ "import A (X)" + , "import qualified A as Y (Y)" + , "import B" + , "import C" ] ex3 :: Assertion @@ -94,16 +94,16 @@ ex3 = input `assertFormatted` output , "import A (X, Z, Y)" , "import C" , "import qualified A as A0 (b, Y, a)" - , "import D qualified as D0 (Y, b, a)" - , "import E qualified as E0 (b, a, Y)" + , "import qualified D as D0 (Y, b, a)" + , "import qualified E as E0 (b, a, Y)" ] output = - [ "import A (X, Y, Z)" - , "import A qualified as A0 (Y, a, b)" - , "import B" - , "import C" - , "import D qualified as D0 (Y, a, b)" - , "import E qualified as E0 (Y, a, b)" + [ "import A (X, Y, Z)" + , "import qualified A as A0 (Y, a, b)" + , "import B" + , "import C" + , "import qualified D as D0 (Y, a, b)" + , "import qualified E as E0 (Y, a, b)" ] ex4 :: Assertion @@ -113,7 +113,7 @@ ex4 = input `assertFormatted` output [ "import A (X, Z(..), Y)" ] output = - [ "import A (X, Y, Z (..))" + [ "import A (X, Y, Z (..))" ] ex5 :: Assertion @@ -123,7 +123,7 @@ ex5 = input `assertFormatted` output [ "import A (X, Z(Z), Y)" ] output = - [ "import A (X, Y, Z (Z))" + [ "import A (X, Y, Z (Z))" ] ex6 :: Assertion @@ -133,7 +133,7 @@ ex6 = input `assertFormatted` output [ "import A (X, Z(X, Z, Y), Y)" ] output = - [ "import A (X, Y, Z (X, Y, Z))" + [ "import A (X, Y, Z (X, Y, Z))" ] ex7 :: Assertion @@ -145,20 +145,20 @@ ex7 = input `assertFormatted` output , "import A (X, Z, Y)" , "import C" , "import qualified A as A0 (b, Y, a)" - , "import D qualified as D0 (Y, b, a)" - , "import E qualified as E0 (b, a, Y)" + , "import qualified D as D0 (Y, b, a)" + , "import qualified E as E0 (b, a, Y)" , "-- hello" , "foo :: Int" , "foo = 1" ] output = [ "module Foo (tests) where" - , "import A (X, Y, Z)" - , "import A qualified as A0 (Y, a, b)" - , "import B" - , "import C" - , "import D qualified as D0 (Y, a, b)" - , "import E qualified as E0 (Y, a, b)" + , "import A (X, Y, Z)" + , "import qualified A as A0 (Y, a, b)" + , "import B" + , "import C" + , "import qualified D as D0 (Y, a, b)" + , "import qualified E as E0 (Y, a, b)" , "-- hello" , "foo :: Int" , "foo = 1" @@ -172,14 +172,14 @@ ex8 = input `assertFormatted` output , "-- Group divisor" , "import A (X)" , "import C" - , "import A qualified as Y (Y)" + , "import qualified A as Y (Y)" ] output = - [ "import B" + [ "import B" , "-- Group divisor" - , "import A (X)" - , "import A qualified as Y (Y)" - , "import C" + , "import A (X)" + , "import qualified A as Y (Y)" + , "import C" ] ex9 :: Assertion @@ -192,16 +192,16 @@ ex9 = input `assertFormatted` output , "-- Group divisor" , "import A (X)" , "import C" - , "import A qualified as Y (Y)" + , "import qualified A as Y (Y)" ] output = [ "--------" - , "import B" + , "import B" , "" , "-- Group divisor" - , "import A (X)" - , "import A qualified as Y (Y)" - , "import C" + , "import A (X)" + , "import qualified A as Y (Y)" + , "import C" ] ex10 :: Assertion @@ -212,8 +212,8 @@ ex10 = input `assertFormatted` output , "import A hiding (X)" ] output = - [ "import A hiding (X)" - , "import B hiding (X)" + [ "import A hiding (X)" + , "import B hiding (X)" ] ex11 :: Assertion @@ -224,8 +224,8 @@ ex11 = input `assertFormatted` output , "import A hiding (X)" ] output = - [ "import A hiding (X)" - , "import Data.Aeson ((.=))" + [ "import A hiding (X)" + , "import Data.Aeson ((.=))" ] ex12 :: Assertion @@ -237,8 +237,8 @@ ex12 = input `assertFormatted` output , "import A hiding (X)" ] output = - [ "import A hiding (X)" - , "import Data.Aeson ((.=))" + [ "import A hiding (X)" + , "import Data.Aeson ((.=))" ] ex13 :: Assertion @@ -251,26 +251,26 @@ ex13 = input `assertFormattedCols` output , "import A hiding (X)" ] output = - [ "import A hiding (X)" - , "import Foo (A)" - , "import Foo (B)" - , "import Foo (C)" - , "import Foo (D)" + [ "import A hiding (X)" + , "import Foo (A)" + , "import Foo (B)" + , "import Foo (C)" + , "import Foo (D)" ] ex14 :: Assertion ex14 = input `assertFormattedCols` output where assertFormattedCols = - assertFormatted' (Just 16) + assertFormatted' (Just 25) input = [ "import Foo (A, B, C, D)" , "import A hiding (X)" ] output = - [ "import A hiding (X)" - , "import Foo (A, B)" - , "import Foo (C, D)" + [ "import A hiding (X)" + , "import Foo (A, B)" + , "import Foo (C, D)" ] ex15 :: Assertion @@ -299,7 +299,7 @@ ex15 = input `assertFormattedCols` output , "" , "--------------------------------------------------------------------------------" , "import Prelude as X hiding ((!!), appendFile, error, foldl, head, putStrLn, readFile, show, tail, take, unlines, unwords, words, writeFile)" - , "import Prelude qualified" + , "import qualified Prelude" , "" , "--------------------------------------------------------------------------------" , "import Control.Lens as X ((%~), (&), (.~), (?~), (^.), (^?), _Left, _Right, iat, over, preview, sans, set, to, view)" @@ -334,21 +334,22 @@ ex15 = input `assertFormattedCols` output , " ) where" , "" , "--------------------------------------------------------------------------------" - , "import Prelude as X hiding ((!!), appendFile, error, foldl, head, putStrLn, readFile, show, tail, take, unlines, unwords, words, writeFile)" - , "import Prelude qualified" + , "import Prelude as X hiding ((!!), appendFile, error, foldl, head, putStrLn, readFile, show, tail, take, unlines, unwords, words, writeFile)" + , "import qualified Prelude" , "" , "--------------------------------------------------------------------------------" - , "import Control.Lens as X ((%~), (&), (.~), (?~), (^.), (^?), _Left, _Right, iat, over, preview, sans)" - , "import Control.Lens as X (set, to, view)" - , "import Control.Lens.Extras as X (is)" + , "import Control.Lens as X ((%~), (&), (.~), (?~), (^.), (^?), _Left, _Right, iat, over)" + , "import Control.Lens as X (preview, sans, set, to, view)" + , "import Control.Lens.Extras as X (is)" , "" , "--------------------------------------------------------------------------------" - , "import Control.Applicative as X ((<|>))" - , "import Control.Monad as X ((<=<), (>=>), guard, unless, when)" - , "import Control.Monad.Except as X (ExceptT (..), MonadError (..), liftEither, runExceptT, withExceptT)" - , "import Control.Monad.IO.Unlift as X" - , "import Control.Monad.Reader as X (MonadReader (..), ReaderT (..), asks)" - , "import Control.Monad.Trans.Class as X (MonadTrans (lift))" + , "import Control.Applicative as X ((<|>))" + , "import Control.Monad as X ((<=<), (>=>), guard, unless, when)" + , "import Control.Monad.Except as X (ExceptT (..), MonadError (..), liftEither, runExceptT)" + , "import Control.Monad.Except as X (withExceptT)" + , "import Control.Monad.IO.Unlift as X" + , "import Control.Monad.Reader as X (MonadReader (..), ReaderT (..), asks)" + , "import Control.Monad.Trans.Class as X (MonadTrans (lift))" , "--------------------------------------------------------------------------------" ] @@ -358,14 +359,14 @@ ex16 = input `assertFormatted` output input = [ "module Foo where" , "" - , "import B ()" - , "import A ()" + , "import B ()" + , "import A ()" ] output = [ "module Foo where" , "" - , "import A ()" - , "import B ()" + , "import A ()" + , "import B ()" ] assertFormatted :: HasCallStack => Lines -> Lines -> Assertion From 0a8e4a4cce00fd683de6f3f9199a5aa2daee72d7 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sat, 12 Sep 2020 17:32:32 +0200 Subject: [PATCH 085/135] Squash warnings --- lib/Language/Haskell/Stylish/Step/ImportsGHC.hs | 4 ++-- lib/Language/Haskell/Stylish/Step/Squash.hs | 1 - lib/Language/Haskell/Stylish/Util.hs | 1 + 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs b/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs index 5926a1dc..844bea9b 100644 --- a/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs +++ b/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs @@ -96,8 +96,8 @@ formatImports maxCols align rawGroup m = runPrinter_ PrinterConfig [] m do printQualified :: Maybe Int -> Options -> Bool -> Bool -> Int -> Located Import -> P () printQualified maxCols Options{..} padQual padNames longest (L _ decl) = do let - decl' = rawImport decl - listPadding' = listPaddingValue (6 + 1 + qualifiedLength) listPadding + decl' = rawImport decl + _listPadding' = listPaddingValue (6 + 1 + qualifiedLength) listPadding putText "import" >> space diff --git a/lib/Language/Haskell/Stylish/Step/Squash.hs b/lib/Language/Haskell/Stylish/Step/Squash.hs index ae54dc89..23d1e9fa 100644 --- a/lib/Language/Haskell/Stylish/Step/Squash.hs +++ b/lib/Language/Haskell/Stylish/Step/Squash.hs @@ -17,7 +17,6 @@ import qualified SrcLoc as S import Language.Haskell.Stylish.Editor import Language.Haskell.Stylish.Step import Language.Haskell.Stylish.Util -import Language.Haskell.Stylish.Module -------------------------------------------------------------------------------- diff --git a/lib/Language/Haskell/Stylish/Util.hs b/lib/Language/Haskell/Stylish/Util.hs index cdd9b223..ff673a60 100644 --- a/lib/Language/Haskell/Stylish/Util.hs +++ b/lib/Language/Haskell/Stylish/Util.hs @@ -1,4 +1,5 @@ -------------------------------------------------------------------------------- +{-# LANGUAGE PatternGuards #-} module Language.Haskell.Stylish.Util ( nameToString , isOperator From 32756fc0e83b3338c336b0e3264d8218cc61e40e Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sat, 12 Sep 2020 18:50:00 +0200 Subject: [PATCH 086/135] Backwards-compatible import thing sort --- .../Haskell/Stylish/Step/ImportsGHC.hs | 61 +++++++++---------- 1 file changed, 28 insertions(+), 33 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs b/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs index 844bea9b..7e66f380 100644 --- a/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs +++ b/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs @@ -11,8 +11,9 @@ module Language.Haskell.Stylish.Step.ImportsGHC import Control.Monad (forM_, when) import Data.Function ((&)) import Data.Foldable (toList) -import Data.Maybe (listToMaybe) -import Data.List (sortBy) +import Data.Ord (comparing) +import Data.Maybe (isJust, listToMaybe) +import Data.List (sortBy, isPrefixOf) import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NonEmpty @@ -23,7 +24,8 @@ import GHC.Hs.ImpExp import Module (moduleNameString) import RdrName (RdrName) import Util (lastMaybe) -import SrcLoc (Located, GenLocated(..)) +import SrcLoc (Located, GenLocated(..), unLoc) + -------------------------------------------------------------------------------- import Language.Haskell.Stylish.Block @@ -42,7 +44,8 @@ step columns = makeStep "Imports (ghc-lib-parser)" . printImports columns printImports :: Maybe Int -> Options -> Lines -> Module -> Lines printImports maxCols align ls m = applyChanges changes ls where - changes = concatMap (formatGroup maxCols align m) (moduleImportGroups m) + groups = moduleImportGroups m + changes = concatMap (formatGroup maxCols align m) groups formatGroup :: Maybe Int -> Options -> Module -> [Located Import] -> [Change String] formatGroup _maxCols _align _m _imports@[] = [] @@ -111,7 +114,10 @@ printQualified maxCols Options{..} padQual padNames longest (L _ decl) = do putText (moduleName decl) - padImportsList decl padNames longest + -- Only print spaces if something follows. + when (isJust (ideclAs decl') || isHiding decl || + not (null $ ideclHiding decl')) $ + padImportsList decl padNames longest forM_ (ideclAs decl') \(L _ name) -> space >> putText "as" >> space >> putText (moduleNameString name) @@ -279,34 +285,23 @@ isSafe . rawImport sortImportList :: [LIE GhcPs] -> [LIE GhcPs] -sortImportList = sortBy $ currycated \case - (IEVar _ n0, IEVar _ n1) -> compareOutputable n0 n1 - - (IEThingAbs _ n0, IEThingAbs _ n1) -> compareOutputable n0 n1 - (IEThingAbs _ n0, IEThingAll _ n1) -> compareOutputable n0 n1 - (IEThingAbs _ n0, IEThingWith _ n1 _ _ _) -> compareOutputable n0 n1 <> LT - - (IEThingAll _ n0, IEThingAll _ n1) -> compareOutputable n0 n1 - (IEThingAll _ n0, IEThingAbs _ n1) -> compareOutputable n0 n1 - (IEThingAll _ n0, IEThingWith _ n1 _ _ _) -> compareOutputable n0 n1 <> LT - - (IEThingWith _ n0 _ _ _, IEThingWith _ n1 _ _ _) -> compareOutputable n0 n1 - (IEThingWith _ n0 _ _ _, IEThingAll _ n1) -> compareOutputable n0 n1 <> GT - (IEThingWith _ n0 _ _ _, IEThingAbs _ n1) -> compareOutputable n0 n1 <> GT - - (IEVar _ _, _) -> GT - (_, IEVar _ _) -> LT - (IEThingAbs _ _, _) -> GT - (_, IEThingAbs _ _) -> LT - (IEThingAll _ _, _) -> GT - (_, IEThingAll _ _) -> LT - (IEThingWith _ _ _ _ _, _) -> GT - (_, IEThingWith _ _ _ _ _) -> LT - - _ -> EQ - -currycated :: ((a, b) -> c) -> (Located a -> Located b -> c) -currycated f = \(L _ a) (L _ b) -> f (a, b) +sortImportList = sortBy compareImportLIE + + +-------------------------------------------------------------------------------- +-- | The implementation is a bit hacky to get proper sorting for input specs: +-- constructors first, followed by functions, and then operators. +compareImportLIE :: LIE GhcPs -> LIE GhcPs -> Ordering +compareImportLIE = comparing $ key . unLoc + where + key :: IE GhcPs -> (Int, Bool, String) + key (IEVar _ n) = let o = showOutputable n in + (1, "(" `isPrefixOf` o, o) + key (IEThingAbs _ n) = (0, False, showOutputable n) + key (IEThingAll _ n) = (0, False, showOutputable n) + key (IEThingWith _ n _ _ _) = (0, False, showOutputable n) + key _ = (2, False, "") + -------------------------------------------------------------------------------- listPaddingValue :: Int -> ListPadding -> Int From ddba4c8c83f02d1baae9269f66cfac36601ef81a Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Mon, 14 Sep 2020 11:44:47 +0200 Subject: [PATCH 087/135] Backwards-compatible module grouping --- lib/Language/Haskell/Stylish/Module.hs | 34 +++++++++++--------------- 1 file changed, 14 insertions(+), 20 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Module.hs b/lib/Language/Haskell/Stylish/Module.hs index b38130ae..43a13bc1 100644 --- a/lib/Language/Haskell/Stylish/Module.hs +++ b/lib/Language/Haskell/Stylish/Module.hs @@ -46,7 +46,7 @@ module Language.Haskell.Stylish.Module import Data.Function ((&), on) import Data.Functor ((<&>)) import Data.Generics (Typeable, everything, mkQ) -import Data.Maybe (listToMaybe, mapMaybe) +import Data.Maybe (mapMaybe) import Data.Map (Map) import qualified Data.Map as Map import Data.List (nubBy, sort) @@ -65,10 +65,9 @@ import GHC.Hs.Decls (LHsDecl) import Outputable (Outputable) import SrcLoc (GenLocated(..), RealLocated) import SrcLoc (RealSrcSpan(..), SrcSpan(..)) -import SrcLoc (Located, srcSpanStartLine) +import SrcLoc (Located) import qualified SrcLoc as GHC import qualified Module as GHC -import Util (lastMaybe) -------------------------------------------------------------------------------- import Language.Haskell.Stylish.GHC @@ -191,24 +190,19 @@ moduleImports m -- | Get groups of imports from module moduleImportGroups :: Module -> [[Located Import]] -moduleImportGroups m = go relevantComments imports +moduleImportGroups = go [] Nothing . moduleImports where - relevantComments - = moduleComments m - & rawComments - & dropBeforeLocated (listToMaybe imports) - & dropAfterLocated (lastMaybe imports) - - imports = moduleImports m - - go :: [RealLocated GHC.AnnotationComment] -> [Located Import] -> [[Located Import]] - go (L nextCommentPos _ : commentsRest) (imp : impRest) = - let - sameGroup = takeWhile (\i -> getStartLineUnsafe i < srcSpanStartLine nextCommentPos) impRest - rest = dropWhile (\i -> getStartLineUnsafe i <= srcSpanStartLine nextCommentPos) impRest - in - (imp : sameGroup) : go commentsRest rest - go _comments imps = [imps] + -- Run through all imports (assume they are sorted already in order of + -- appearance in the file) and group the ones that are on consecutive + -- lines. + go :: [Located Import] -> Maybe Int -> [Located Import] + -> [[Located Import]] + go acc _ [] = if null acc then [] else [acc] + go acc mbCurrentLine (imp : impRest) = + let l2 = getStartLineUnsafe imp in + case mbCurrentLine of + Just l1 | l1 + 1 < l2 -> acc : go [imp] (Just l2) impRest + _ -> go (acc ++ [imp]) (Just l2) impRest -- | Merge two import declarations, keeping positions from the first -- From 35dcc9472d9754e9a2481b525955f2a97bc89af5 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Mon, 14 Sep 2020 19:47:46 +0200 Subject: [PATCH 088/135] Restore global/file alignment --- lib/Language/Haskell/Stylish/Module.hs | 13 ++-- .../Haskell/Stylish/Step/ImportsGHC.hs | 67 ++++++++++--------- 2 files changed, 43 insertions(+), 37 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Module.hs b/lib/Language/Haskell/Stylish/Module.hs index 43a13bc1..7f1fd96e 100644 --- a/lib/Language/Haskell/Stylish/Module.hs +++ b/lib/Language/Haskell/Stylish/Module.hs @@ -50,7 +50,7 @@ import Data.Maybe (mapMaybe) import Data.Map (Map) import qualified Data.Map as Map import Data.List (nubBy, sort) -import Data.List.NonEmpty (NonEmpty, nonEmpty) +import Data.List.NonEmpty (NonEmpty (..), nonEmpty) import Data.Text (Text) import qualified Data.Text as T import Data.Data (Data) @@ -189,21 +189,24 @@ moduleImports m & fmap \(L pos i) -> L pos (Import i) -- | Get groups of imports from module -moduleImportGroups :: Module -> [[Located Import]] +moduleImportGroups :: Module -> [NonEmpty (Located Import)] moduleImportGroups = go [] Nothing . moduleImports where -- Run through all imports (assume they are sorted already in order of -- appearance in the file) and group the ones that are on consecutive -- lines. go :: [Located Import] -> Maybe Int -> [Located Import] - -> [[Located Import]] - go acc _ [] = if null acc then [] else [acc] + -> [NonEmpty (Located Import)] + go acc _ [] = ne acc go acc mbCurrentLine (imp : impRest) = let l2 = getStartLineUnsafe imp in case mbCurrentLine of - Just l1 | l1 + 1 < l2 -> acc : go [imp] (Just l2) impRest + Just l1 | l1 + 1 < l2 -> ne acc ++ go [imp] (Just l2) impRest _ -> go (acc ++ [imp]) (Just l2) impRest + ne [] = [] + ne (x : xs) = [x :| xs] + -- | Merge two import declarations, keeping positions from the first -- -- As alluded, this highlights an issue with merging imports. The GHC diff --git a/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs b/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs index 7e66f380..e59b1603 100644 --- a/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs +++ b/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs @@ -23,7 +23,6 @@ import qualified GHC.Hs.Extension as GHC import GHC.Hs.ImpExp import Module (moduleNameString) import RdrName (RdrName) -import Util (lastMaybe) import SrcLoc (Located, GenLocated(..), unLoc) @@ -45,29 +44,29 @@ printImports :: Maybe Int -> Options -> Lines -> Module -> Lines printImports maxCols align ls m = applyChanges changes ls where groups = moduleImportGroups m - changes = concatMap (formatGroup maxCols align m) groups - -formatGroup :: Maybe Int -> Options -> Module -> [Located Import] -> [Change String] -formatGroup _maxCols _align _m _imports@[] = [] -formatGroup maxCols align m imports@(impHead : impTail) = do - let - newLines = formatImports maxCols align (impHead :| impTail) m - - toList $ fmap (\block -> change block (const newLines)) (importBlock imports) - -importBlock :: [Located a] -> Maybe (Block String) -importBlock group = Block <$> importStart <*> importEnd - where - importStart - = listToMaybe group - & fmap getStartLineUnsafe - - importEnd - = lastMaybe group - & fmap getEndLineUnsafe - -formatImports :: Maybe Int -> Options -> NonEmpty (Located Import) -> Module -> Lines -formatImports maxCols align rawGroup m = runPrinter_ PrinterConfig [] m do + moduleLongestImport = longestImport . fmap unLoc $ concatMap toList groups + changes = map (formatGroup maxCols align m moduleLongestImport) groups + +formatGroup + :: Maybe Int -> Options -> Module -> Int -> NonEmpty (Located Import) + -> Change String +formatGroup maxCols options m moduleLongestImport imports = + let newLines = formatImports maxCols options m moduleLongestImport imports in + change (importBlock imports) (const newLines) + +importBlock :: NonEmpty (Located a) -> Block String +importBlock group = Block + (getStartLineUnsafe $ NonEmpty.head group) + (getEndLineUnsafe $ NonEmpty.last group) + +formatImports + :: Maybe Int -- ^ Max columns. + -> Options -- ^ Options. + -> Module -- ^ Module. + -> Int -- ^ Longest import in module. + -> NonEmpty (Located Import) -> Lines +formatImports maxCols options m moduleLongestImport rawGroup = + runPrinter_ PrinterConfig [] m do let group @@ -78,22 +77,26 @@ formatImports maxCols align rawGroup m = runPrinter_ PrinterConfig [] m do anyQual = any isQualified unLocatedGroup - fileAlign = case importAlign align of + fileAlign = case importAlign options of File -> anyQual _ -> False - align' = importAlign align - padModuleNames' = padModuleNames align + align' = importAlign options + padModuleNames' = padModuleNames options padNames = align' /= None && padModuleNames' padQual = case align' of Global -> True File -> fileAlign Group -> anyQual None -> False - - longest = longestImport unLocatedGroup - forM_ group \imp -> printQualified maxCols align padQual padNames longest imp >> newline + longest = case align' of + Global -> moduleLongestImport + File -> moduleLongestImport + Group -> longestImport unLocatedGroup + None -> 0 + + forM_ group \imp -> printQualified maxCols options padQual padNames longest imp >> newline -------------------------------------------------------------------------------- printQualified :: Maybe Int -> Options -> Bool -> Bool -> Int -> Located Import -> P () @@ -233,8 +236,8 @@ moduleName -------------------------------------------------------------------------------- -longestImport :: [Import] -> Int -longestImport = maximum . map importLength +longestImport :: (Foldable f, Functor f) => f Import -> Int +longestImport xs = if null xs then 0 else maximum $ fmap importLength xs -- computes length till module name importLength :: Import -> Int From dac6f3b7dc038c77d46dc0b0de26e7d88c631da5 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Thu, 17 Sep 2020 12:02:07 +0200 Subject: [PATCH 089/135] Add a wrapping combinator --- lib/Language/Haskell/Stylish/Printer.hs | 33 ++++++++++++++++++- lib/Language/Haskell/Stylish/Step/Data.hs | 8 ++++- .../Haskell/Stylish/Step/ImportsGHC.hs | 20 +++++------ .../Haskell/Stylish/Step/ModuleHeader.hs | 5 +-- .../Haskell/Stylish/Step/Imports/Tests.hs | 5 +-- 5 files changed, 54 insertions(+), 17 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Printer.hs b/lib/Language/Haskell/Stylish/Printer.hs index d34bc097..5af5fc04 100644 --- a/lib/Language/Haskell/Stylish/Printer.hs +++ b/lib/Language/Haskell/Stylish/Printer.hs @@ -44,6 +44,9 @@ module Language.Haskell.Stylish.Printer , space , spaces , suffix + + -- ** Advanced combinators + , wrapping ) where -------------------------------------------------------------------------------- @@ -62,7 +65,7 @@ import Outputable (Outputable) -------------------------------------------------------------------------------- import Control.Monad (forM_, replicateM_) -import Control.Monad.Reader (MonadReader, ReaderT(..)) +import Control.Monad.Reader (MonadReader, ReaderT(..), asks) import Control.Monad.State (MonadState, State) import Control.Monad.State (runState) import Control.Monad.State (get, gets, modify, put) @@ -85,6 +88,8 @@ newtype Printer a = Printer (ReaderT PrinterConfig (State PrinterState) a) -- | Configuration for printer, currently empty data PrinterConfig = PrinterConfig + { columns :: !(Maybe Int) + } -- | State of printer data PrinterState = PrinterState @@ -410,3 +415,29 @@ sortedAttachedComments origs = go origs <&> fmap sortGroup pure $ (comments, L rspan x :| sameGroupOf nextGroupStartM) : restGroups go _ = pure [] + +wrapping + :: P a -- ^ First printer to run + -> P a -- ^ Printer to run if first printer violates max columns + -> P a -- ^ Result of either the first or the second printer +wrapping p1 p2 = do + maxCols <- asks columns + case maxCols of + -- No wrapping + Nothing -> p1 + Just c -> do + s0 <- get + x <- p1 + s1 <- get + if length (currentLine s1) <= c + -- No need to wrap + then pure x + else do + put s0 + y <- p2 + s2 <- get + if length (currentLine s1) == length (currentLine s2) + -- Wrapping didn't help! + then put s1 >> pure x + -- Wrapped + else pure y diff --git a/lib/Language/Haskell/Stylish/Step/Data.hs b/lib/Language/Haskell/Stylish/Step/Data.hs index 27ed73c2..bf39c7c2 100644 --- a/lib/Language/Haskell/Stylish/Step/Data.hs +++ b/lib/Language/Haskell/Stylish/Step/Data.hs @@ -107,7 +107,13 @@ formatDataDecl cfg@Config{..} m ldecl@(L declPos decl) = originalDeclBlock = Block (getStartLineUnsafe ldecl) (getEndLineUnsafe ldecl) - printedDecl = runPrinter_ PrinterConfig relevantComments m do + printerConfig = PrinterConfig + { columns = case cMaxColumns of + NoMaxColumns -> Nothing + MaxColumns n -> Just n + } + + printedDecl = runPrinter_ printerConfig relevantComments m do putText (newOrData decl) space putName decl diff --git a/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs b/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs index e59b1603..33d06983 100644 --- a/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs +++ b/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs @@ -66,7 +66,7 @@ formatImports -> Int -- ^ Longest import in module. -> NonEmpty (Located Import) -> Lines formatImports maxCols options m moduleLongestImport rawGroup = - runPrinter_ PrinterConfig [] m do + runPrinter_ (PrinterConfig maxCols) [] m do let group @@ -96,11 +96,11 @@ formatImports maxCols options m moduleLongestImport rawGroup = Group -> longestImport unLocatedGroup None -> 0 - forM_ group \imp -> printQualified maxCols options padQual padNames longest imp >> newline + forM_ group \imp -> printQualified options padQual padNames longest imp >> newline -------------------------------------------------------------------------------- -printQualified :: Maybe Int -> Options -> Bool -> Bool -> Int -> Located Import -> P () -printQualified maxCols Options{..} padQual padNames longest (L _ decl) = do +printQualified :: Options -> Bool -> Bool -> Int -> Located Import -> P () +printQualified Options{..} padQual padNames longest (L _ decl) = do let decl' = rawImport decl _listPadding' = listPaddingValue (6 + 1 + qualifiedLength) listPadding @@ -150,28 +150,26 @@ printQualified maxCols Options{..} padQual padNames longest (L _ decl) = do forM_ impHead id forM_ impTail \printedImport -> do - len <- getCurrentLineLength - if canSplit (len) then do + + wrapping (comma >> space >> printedImport) $ do putText ")" newline importDecl space putText "(" - else do - comma - space - - printedImport + printedImport when spaceSurround space putText ")" where + {- canSplit len = and [ -- If the max cols have been surpassed, split: maybe False (len >=) maxCols -- Splitting a 'hiding' import changes the scope, don't split hiding: , not (isHiding decl) ] + -} qualifiedDecl | isQualified decl = ["qualified"] | padQual = diff --git a/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs b/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs index be6c0339..9eaee2d3 100644 --- a/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs +++ b/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs @@ -54,8 +54,9 @@ printModuleHeader _ ls m = & dropAfterLocated exports & dropBeforeLocated name - printedModuleHeader = - runPrinter_ PrinterConfig relevantComments m (printHeader name exports haddocks) + -- TODO: pass max columns? + printedModuleHeader = runPrinter_ (PrinterConfig Nothing) relevantComments + m (printHeader name exports haddocks) getBlock loc = Block <$> fmap getStartLineUnsafe loc <*> fmap getEndLineUnsafe loc diff --git a/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs index 4aa94b41..d0f020e5 100644 --- a/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs @@ -12,6 +12,7 @@ import Test.HUnit (Assertion, (@=?)) -------------------------------------------------------------------------------- import Language.Haskell.Stylish.Step.Imports +import qualified Language.Haskell.Stylish.Step.ImportsGHC as GHC import Language.Haskell.Stylish.Tests.Util @@ -83,9 +84,9 @@ input = unlines -------------------------------------------------------------------------------- case01 :: Assertion -case01 = expected @=? testStep (step (Just 80) $ fromImportAlign Global) input +case01 = expected @=? testStep' (GHC.step (Just 80) $ fromImportAlign Global) (lines input) where - expected = unlines + expected = [ "module Herp where" , "" , "import Control.Monad" From 70cbdfd7be4ba67887dba8f5ab25e6cefe1c2f4e Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Thu, 17 Sep 2020 12:03:34 +0200 Subject: [PATCH 090/135] Fix test --- tests/Language/Haskell/Stylish/Step/ImportsGHC/Tests.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/Language/Haskell/Stylish/Step/ImportsGHC/Tests.hs b/tests/Language/Haskell/Stylish/Step/ImportsGHC/Tests.hs index a9fd6d9a..91538ec3 100644 --- a/tests/Language/Haskell/Stylish/Step/ImportsGHC/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/ImportsGHC/Tests.hs @@ -262,7 +262,7 @@ ex14 :: Assertion ex14 = input `assertFormattedCols` output where assertFormattedCols = - assertFormatted' (Just 25) + assertFormatted' (Just 26) input = [ "import Foo (A, B, C, D)" , "import A hiding (X)" From 091aaef6ae835e39e6898c3fd402dee67fd51800 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Fri, 18 Sep 2020 11:54:37 +0200 Subject: [PATCH 091/135] Refactor & fix off-by-one error --- lib/Language/Haskell/Stylish/Printer.hs | 6 ++ .../Haskell/Stylish/Step/ImportsGHC.hs | 59 ++++++++++--------- lib/Language/Haskell/Stylish/Util.hs | 19 ++++++ .../Haskell/Stylish/Step/ImportsGHC/Tests.hs | 2 +- 4 files changed, 57 insertions(+), 29 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Printer.hs b/lib/Language/Haskell/Stylish/Printer.hs index 5af5fc04..1d7b629b 100644 --- a/lib/Language/Haskell/Stylish/Printer.hs +++ b/lib/Language/Haskell/Stylish/Printer.hs @@ -46,6 +46,7 @@ module Language.Haskell.Stylish.Printer , suffix -- ** Advanced combinators + , modifyCurrentLine , wrapping ) where @@ -416,6 +417,11 @@ sortedAttachedComments origs = go origs <&> fmap sortGroup go _ = pure [] +modifyCurrentLine :: (String -> String) -> P () +modifyCurrentLine f = do + s0 <- get + put s0 {currentLine = f $ currentLine s0} + wrapping :: P a -- ^ First printer to run -> P a -- ^ Printer to run if first printer violates max columns diff --git a/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs b/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs index 33d06983..016cafbf 100644 --- a/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs +++ b/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs @@ -8,15 +8,16 @@ module Language.Haskell.Stylish.Step.ImportsGHC ) where -------------------------------------------------------------------------------- -import Control.Monad (forM_, when) +import Control.Monad (forM_, when, unless) import Data.Function ((&)) import Data.Foldable (toList) import Data.Ord (comparing) -import Data.Maybe (isJust, listToMaybe) +import Data.Maybe (isJust) import Data.List (sortBy, isPrefixOf) import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NonEmpty + -------------------------------------------------------------------------------- import GHC.Hs.Extension (GhcPs) import qualified GHC.Hs.Extension as GHC @@ -34,6 +35,7 @@ import Language.Haskell.Stylish.Step import Language.Haskell.Stylish.Editor import Language.Haskell.Stylish.GHC import Language.Haskell.Stylish.Step.Imports hiding (step) +import Language.Haskell.Stylish.Util step :: Maybe Int -> Options -> Step @@ -125,42 +127,42 @@ printQualified Options{..} padQual padNames longest (L _ decl) = do forM_ (ideclAs decl') \(L _ name) -> space >> putText "as" >> space >> putText (moduleNameString name) - when (isHiding decl) (space >> putText "hiding") + when (isHiding decl) (space >> putText "hiding") -- Since we might need to output the import module name several times, we -- need to save it to a variable: - importDecl <- fmap putText getCurrentLine + repeatedImportDecl <- fmap putText getCurrentLine forM_ (snd <$> ideclHiding decl') \(L _ imports) -> let printedImports = -- [P ()] fmap ((printImport Options{..}) . unLocated) (sortImportList imports) - impHead = - listToMaybe printedImports - - impTail = - drop 1 printedImports in do space - putText "(" - - when spaceSurround space - - forM_ impHead id - - forM_ impTail \printedImport -> do - - wrapping (comma >> space >> printedImport) $ do - putText ")" - newline - importDecl - space - putText "(" - printedImport - - when spaceSurround space - putText ")" + + if null printedImports then do + putText "()" + else do + putText "(" + when spaceSurround space + forM_ (flagEnds printedImports) $ \(imp, isFirst, isLast) -> do + wrapping + (do + unless isFirst space + imp + if isLast then putText ")" else comma) + (do + modifyCurrentLine . withLast $ \c -> if c == ',' then ')' else c + newline + repeatedImportDecl + space + putText "(" + imp + if isLast then putText ")" else comma) + + -- when spaceSurround space + -- putText ")" where {- canSplit len = and @@ -179,7 +181,8 @@ printQualified Options{..} padQual padNames longest (L _ decl) = do then [" "] else [" "] | otherwise = [] - qualifiedLength = if null qualifiedDecl then 0 else 1 + sum (map length qualifiedDecl) + qualifiedLength = if null qualifiedDecl then 0 else 1 + sum (map length qualifiedDecl) + -------------------------------------------------------------------------------- printImport :: Options -> IE GhcPs -> P () diff --git a/lib/Language/Haskell/Stylish/Util.hs b/lib/Language/Haskell/Stylish/Util.hs index ff673a60..f9e2ef00 100644 --- a/lib/Language/Haskell/Stylish/Util.hs +++ b/lib/Language/Haskell/Stylish/Util.hs @@ -1,5 +1,6 @@ -------------------------------------------------------------------------------- {-# LANGUAGE PatternGuards #-} +{-# LANGUAGE LambdaCase #-} module Language.Haskell.Stylish.Util ( nameToString , isOperator @@ -14,10 +15,12 @@ module Language.Haskell.Stylish.Util , wrapMaybe , wrapRestMaybe + -- * Extra list functions , withHead , withInit , withTail , withLast + , flagEnds , toRealSrcSpan @@ -200,12 +203,28 @@ withInit _ [] = [] withInit _ [x] = [x] withInit f (x : xs) = f x : withInit f xs + -------------------------------------------------------------------------------- withTail :: (a -> a) -> [a] -> [a] withTail _ [] = [] withTail f (x : xs) = x : map f xs + +-------------------------------------------------------------------------------- +-- | Utility for traversing through a list and knowing when you're at the +-- first and last element. +flagEnds :: [a] -> [(a, Bool, Bool)] +flagEnds = \case + [] -> [] + [x] -> [(x, True, True)] + x : y : zs -> (x, True, False) : go (y : zs) + where + go (x : y : zs) = (x, False, False) : go (y : zs) + go [x] = [(x, False, True)] + go [] = [] + + -------------------------------------------------------------------------------- traceOutputtable :: Outputable.Outputable a => String -> a -> b -> b traceOutputtable title x = diff --git a/tests/Language/Haskell/Stylish/Step/ImportsGHC/Tests.hs b/tests/Language/Haskell/Stylish/Step/ImportsGHC/Tests.hs index 91538ec3..678277a5 100644 --- a/tests/Language/Haskell/Stylish/Step/ImportsGHC/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/ImportsGHC/Tests.hs @@ -262,7 +262,7 @@ ex14 :: Assertion ex14 = input `assertFormattedCols` output where assertFormattedCols = - assertFormatted' (Just 26) + assertFormatted' (Just 27) input = [ "import Foo (A, B, C, D)" , "import A hiding (X)" From 95bb2cc685c69553fdbde8865cb26a18abff206e Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sat, 19 Sep 2020 14:58:14 +0200 Subject: [PATCH 092/135] list_align: add 'repeat' & restore options --- data/stylish-haskell.yaml | 5 ++ lib/Language/Haskell/Stylish/Config.hs | 1 + lib/Language/Haskell/Stylish/Step/Imports.hs | 3 + .../Haskell/Stylish/Step/ImportsGHC.hs | 68 ++++++++++--------- .../Haskell/Stylish/Step/ImportsGHC/Tests.hs | 8 ++- 5 files changed, 52 insertions(+), 33 deletions(-) diff --git a/data/stylish-haskell.yaml b/data/stylish-haskell.yaml index a41c6e16..2979afd5 100644 --- a/data/stylish-haskell.yaml +++ b/data/stylish-haskell.yaml @@ -133,6 +133,11 @@ steps: # > import qualified Data.List as List # > (concat, foldl, foldr, head, init, last, length) # + # - repeat: Repeat the module name to align the import list. + # + # > import qualified Data.List as List (concat, foldl, foldr, head) + # > import qualified Data.List as List (init, last, length) + # # Default: after_alias list_align: after_alias diff --git a/lib/Language/Haskell/Stylish/Config.hs b/lib/Language/Haskell/Stylish/Config.hs index 39cce2f3..cfc13b1e 100644 --- a/lib/Language/Haskell/Stylish/Config.hs +++ b/lib/Language/Haskell/Stylish/Config.hs @@ -284,6 +284,7 @@ parseImports config o = do , ("with_module_name", Imports.WithModuleName) , ("with_alias", Imports.WithAlias) , ("after_alias", Imports.AfterAlias) + , ("repeat", Imports.Repeat) ] longListAligns = diff --git a/lib/Language/Haskell/Stylish/Step/Imports.hs b/lib/Language/Haskell/Stylish/Step/Imports.hs index 53706468..7f633c77 100644 --- a/lib/Language/Haskell/Stylish/Step/Imports.hs +++ b/lib/Language/Haskell/Stylish/Step/Imports.hs @@ -76,6 +76,7 @@ data ListAlign | WithModuleName | WithAlias | AfterAlias + | Repeat deriving (Eq, Show) data EmptyListAlign @@ -293,7 +294,9 @@ prettyImport columns Options{..} padQualified padName longest imp . withLast (++ (maybeSpace ++ ")")) inlineWrapper = case listAlign of + -- Treat repeat as newline, code will be deleted anyway. NewLine -> (paddedNoSpecBase :) . wrapRestMaybe columns listPadding' + Repeat -> (paddedNoSpecBase :) . wrapRestMaybe columns listPadding' WithModuleName -> wrapMaybe columns paddedBase (withModuleNameBaseLength + 4) WithAlias -> wrapMaybe columns paddedBase (inlineBaseLength + 1) -- Add 1 extra space to ensure same padding as in original code. diff --git a/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs b/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs index 016cafbf..42fd0d1c 100644 --- a/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs +++ b/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs @@ -117,6 +117,7 @@ printQualified Options{..} padQual padNames longest (L _ decl) = do padQualified decl padQual + moduleNamePosition <- length <$> getCurrentLine putText (moduleName decl) -- Only print spaces if something follows. @@ -124,42 +125,47 @@ printQualified Options{..} padQual padNames longest (L _ decl) = do not (null $ ideclHiding decl')) $ padImportsList decl padNames longest + beforeAliasPosition <- length <$> getCurrentLine forM_ (ideclAs decl') \(L _ name) -> space >> putText "as" >> space >> putText (moduleNameString name) + afterAliasPosition <- length <$> getCurrentLine when (isHiding decl) (space >> putText "hiding") - -- Since we might need to output the import module name several times, we - -- need to save it to a variable: - repeatedImportDecl <- fmap putText getCurrentLine - - forM_ (snd <$> ideclHiding decl') \(L _ imports) -> - let - printedImports = -- [P ()] - fmap ((printImport Options{..}) . unLocated) (sortImportList imports) - - in do - space - - if null printedImports then do - putText "()" - else do - putText "(" - when spaceSurround space - forM_ (flagEnds printedImports) $ \(imp, isFirst, isLast) -> do - wrapping - (do - unless isFirst space - imp - if isLast then putText ")" else comma) - (do - modifyCurrentLine . withLast $ \c -> if c == ',' then ')' else c - newline - repeatedImportDecl - space - putText "(" - imp - if isLast then putText ")" else comma) + case snd <$> ideclHiding decl' of + Nothing -> pure () + Just (L _ []) -> putText " ()" + Just (L _ imports) -> do + let printedImports = -- [P ()] + fmap ((printImport Options{..}) . unLocated) (sortImportList imports) + putText " (" + + -- Since we might need to output the import module name several times, we + -- need to save it to a variable: + let offset = case listPadding of LPConstant n -> n; LPModuleName -> 0 + wrapPrefix <- case listAlign of + AfterAlias -> pure $ replicate (afterAliasPosition + 2) ' ' + WithAlias -> pure $ replicate (beforeAliasPosition + 1) ' ' + Repeat -> getCurrentLine + WithModuleName -> pure $ replicate (moduleNamePosition + offset) ' ' + NewLine -> pure $ replicate offset ' ' + + when spaceSurround space + forM_ (flagEnds printedImports) $ \(imp, isFirst, isLast) -> do + wrapping + (do + unless isFirst space + imp + if isLast then putText ")" else comma) + (do + case listAlign of + -- In 'Repeat' mode, end lines with ')' rather than ','. + Repeat -> modifyCurrentLine . withLast $ \c -> if c == ',' then ')' else c + _ -> pure () + newline + putText wrapPrefix + imp + if isLast then putText ")" else comma) -- when spaceSurround space -- putText ")" diff --git a/tests/Language/Haskell/Stylish/Step/ImportsGHC/Tests.hs b/tests/Language/Haskell/Stylish/Step/ImportsGHC/Tests.hs index 678277a5..31bd75bc 100644 --- a/tests/Language/Haskell/Stylish/Step/ImportsGHC/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/ImportsGHC/Tests.hs @@ -11,7 +11,7 @@ import Prelude hiding (lines) -------------------------------------------------------------------------------- import Language.Haskell.Stylish.Module -import Language.Haskell.Stylish.Step.Imports (defaultOptions) +import Language.Haskell.Stylish.Step.Imports (Options (..), defaultOptions, ListAlign (..)) import Language.Haskell.Stylish.Step.ImportsGHC (step) import Language.Haskell.Stylish.Tests.Util (testStep', (@=??)) @@ -374,4 +374,8 @@ assertFormatted = withFrozenCallStack $ assertFormatted' Nothing assertFormatted' :: HasCallStack => Maybe Int -> Lines -> Lines -> Assertion assertFormatted' maxColumns input expected = - withFrozenCallStack $ expected @=?? testStep' (step maxColumns defaultOptions) input + withFrozenCallStack $ expected @=?? testStep' (step maxColumns felixOptions) input + where + felixOptions = defaultOptions + { listAlign = Repeat + } From 27e9cc290173f151be541bf162cf07c9f4c4c0d3 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sat, 19 Sep 2020 15:17:28 +0200 Subject: [PATCH 093/135] ImportsGHC: old tests 1-7 working --- .../Haskell/Stylish/Step/ImportsGHC.hs | 24 ++++++++-------- .../Haskell/Stylish/Step/Imports/Tests.hs | 28 +++++++++---------- 2 files changed, 27 insertions(+), 25 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs b/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs index 42fd0d1c..19b06156 100644 --- a/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs +++ b/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs @@ -47,13 +47,18 @@ printImports maxCols align ls m = applyChanges changes ls where groups = moduleImportGroups m moduleLongestImport = longestImport . fmap unLoc $ concatMap toList groups - changes = map (formatGroup maxCols align m moduleLongestImport) groups + moduleAnyQual = any isQualified . fmap unLoc $ concatMap toList groups + changes = do + group <- groups + pure $ formatGroup maxCols align m + moduleLongestImport moduleAnyQual group formatGroup - :: Maybe Int -> Options -> Module -> Int -> NonEmpty (Located Import) - -> Change String -formatGroup maxCols options m moduleLongestImport imports = - let newLines = formatImports maxCols options m moduleLongestImport imports in + :: Maybe Int -> Options -> Module -> Int -> Bool + -> NonEmpty (Located Import) -> Change String +formatGroup maxCols options m moduleLongestImport moduleAnyQual imports = + let newLines = formatImports maxCols options m + moduleLongestImport moduleAnyQual imports in change (importBlock imports) (const newLines) importBlock :: NonEmpty (Located a) -> Block String @@ -66,8 +71,9 @@ formatImports -> Options -- ^ Options. -> Module -- ^ Module. -> Int -- ^ Longest import in module. + -> Bool -- ^ Qualified import is present in module. -> NonEmpty (Located Import) -> Lines -formatImports maxCols options m moduleLongestImport rawGroup = +formatImports maxCols options m moduleLongestImport moduleAnyQual rawGroup = runPrinter_ (PrinterConfig maxCols) [] m do let @@ -79,16 +85,12 @@ formatImports maxCols options m moduleLongestImport rawGroup = anyQual = any isQualified unLocatedGroup - fileAlign = case importAlign options of - File -> anyQual - _ -> False - align' = importAlign options padModuleNames' = padModuleNames options padNames = align' /= None && padModuleNames' padQual = case align' of Global -> True - File -> fileAlign + File -> moduleAnyQual Group -> anyQual None -> False diff --git a/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs index d0f020e5..6c6dd7fc 100644 --- a/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs @@ -106,9 +106,9 @@ case01 = expected @=? testStep' (GHC.step (Just 80) $ fromImportAlign Global) (l -------------------------------------------------------------------------------- case02 :: Assertion -case02 = expected @=? testStep (step (Just 80) $ fromImportAlign Group) input +case02 = expected @=? testStep' (GHC.step (Just 80) $ fromImportAlign Group) (lines input) where - expected = unlines + expected = [ "module Herp where" , "" , "import Control.Monad" @@ -127,9 +127,9 @@ case02 = expected @=? testStep (step (Just 80) $ fromImportAlign Group) input -------------------------------------------------------------------------------- case03 :: Assertion -case03 = expected @=? testStep (step (Just 80) $ fromImportAlign None) input +case03 = expected @=? testStep' (GHC.step (Just 80) $ fromImportAlign None) (lines input) where - expected = unlines + expected = [ "module Herp where" , "" , "import Control.Monad" @@ -148,13 +148,13 @@ case03 = expected @=? testStep (step (Just 80) $ fromImportAlign None) input -------------------------------------------------------------------------------- case04 :: Assertion -case04 = expected @=? testStep (step (Just 80) $ fromImportAlign Global) input' +case04 = expected @=? testStep' (GHC.step (Just 80) $ fromImportAlign Global) (lines input') where input' = "import Data.Aeson.Types (object, typeMismatch, FromJSON(..)," ++ "ToJSON(..), Value(..), parseEither, (.!=), (.:), (.:?), (.=))" - expected = unlines + expected = [ "import Data.Aeson.Types (FromJSON (..), ToJSON (..), Value (..)," , " object, parseEither, typeMismatch, (.!=)," , " (.:), (.:?), (.=))" @@ -163,17 +163,17 @@ case04 = expected @=? testStep (step (Just 80) $ fromImportAlign Global) input' -------------------------------------------------------------------------------- case05 :: Assertion -case05 = input' @=? testStep (step (Just 80) $ fromImportAlign Group) input' +case05 = input' @=? testStep' (GHC.step (Just 80) $ fromImportAlign Group) input' where - input' = "import Distribution.PackageDescription.Configuration " ++ - "(finalizePackageDescription)\n" + input' = ["import Distribution.PackageDescription.Configuration " ++ + "(finalizePackageDescription)"] -------------------------------------------------------------------------------- case06 :: Assertion -case06 = input' @=? testStep (step (Just 80) $ fromImportAlign File) input' +case06 = input' @=? testStep' (GHC.step (Just 80) $ fromImportAlign File) input' where - input' = unlines + input' = [ "import Bar.Qux" , "import Foo.Bar" ] @@ -181,15 +181,15 @@ case06 = input' @=? testStep (step (Just 80) $ fromImportAlign File) input' -------------------------------------------------------------------------------- case07 :: Assertion -case07 = expected @=? testStep (step (Just 80) $ fromImportAlign File) input' +case07 = expected @=? testStep' (GHC.step (Just 80) $ fromImportAlign File) input' where - input' = unlines + input' = [ "import Bar.Qux" , "" , "import qualified Foo.Bar" ] - expected = unlines + expected = [ "import Bar.Qux" , "" , "import qualified Foo.Bar" From 3d40d665aefb0de24125d9d156d2eefcb25dae27 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sat, 19 Sep 2020 15:40:57 +0200 Subject: [PATCH 094/135] Fix more tests --- .../Haskell/Stylish/Step/ImportsGHC.hs | 3 ++- .../Haskell/Stylish/Step/Imports/Tests.hs | 24 +++++++++---------- 2 files changed, 13 insertions(+), 14 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs b/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs index 19b06156..0408546d 100644 --- a/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs +++ b/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs @@ -162,7 +162,8 @@ printQualified Options{..} padQual padNames longest (L _ decl) = do (do case listAlign of -- In 'Repeat' mode, end lines with ')' rather than ','. - Repeat -> modifyCurrentLine . withLast $ \c -> if c == ',' then ')' else c + Repeat | not isFirst -> modifyCurrentLine . withLast $ + \c -> if c == ',' then ')' else c _ -> pure () newline putText wrapPrefix diff --git a/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs index 6c6dd7fc..5f3bda35 100644 --- a/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs @@ -202,9 +202,9 @@ case08 = let options = Options Global WithAlias True Inline Inherit (LPConstant 4) True False False in - expected @=? testStep (step (Just 80) options) input + expected @=? testStep' (GHC.step (Just 80) options) (lines input) where - expected = unlines + expected = [ "module Herp where" , "" , "import Control.Monad" @@ -228,9 +228,9 @@ case08b = let options = Options Global WithModuleName True Inline Inherit (LPConstant 4) True False False in - expected @=? testStep (step (Just 80) options) input + expected @=? testStep' (GHC.step (Just 80) options) (lines input) where - expected = unlines + expected = ["module Herp where" , "" , "import Control.Monad" @@ -253,9 +253,9 @@ case09 = let options = Options Global WithAlias True Multiline Inherit (LPConstant 4) True False False in - expected @=? testStep (step (Just 80) options) input + expected @=? testStep' (step (Just 80) options) (lines input) where - expected = unlines + expected = [ "module Herp where" , "" , "import Control.Monad" @@ -387,13 +387,13 @@ case12 = let options = Options Group NewLine True Inline Inherit (LPConstant 2) True False False in - expected @=? testStep (step (Just 80) options) input' + expected @=? testStep' (step (Just 80) options) input' where - input' = unlines + input' = [ "import Data.List (map)" ] - expected = unlines + expected = [ "import Data.List" , " (map)" ] @@ -405,11 +405,9 @@ case12b = let options = Options Group WithModuleName True Inline Inherit (LPConstant 2) True False False in - expected @=? testStep (step (Just 80) options) input' + expected @=? testStep' (GHC.step (Just 80) options) input' where - input' = unlines - [ "import Data.List (map)" - ] + input' = ["import Data.List (map)"] expected = input' From 9e70a881bcd87410afa3b1b823d97c36d7a720a2 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sun, 20 Sep 2020 15:09:56 +0200 Subject: [PATCH 095/135] patchForRepeatHiding --- lib/Language/Haskell/Stylish/Printer.hs | 6 +++++- lib/Language/Haskell/Stylish/Step/ImportsGHC.hs | 9 ++++++++- .../Haskell/Stylish/Step/ImportsGHC/Tests.hs | 14 +++++++------- 3 files changed, 20 insertions(+), 9 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Printer.hs b/lib/Language/Haskell/Stylish/Printer.hs index 1d7b629b..be0a25af 100644 --- a/lib/Language/Haskell/Stylish/Printer.hs +++ b/lib/Language/Haskell/Stylish/Printer.hs @@ -46,6 +46,7 @@ module Language.Haskell.Stylish.Printer , suffix -- ** Advanced combinators + , withColumns , modifyCurrentLine , wrapping ) where @@ -66,7 +67,7 @@ import Outputable (Outputable) -------------------------------------------------------------------------------- import Control.Monad (forM_, replicateM_) -import Control.Monad.Reader (MonadReader, ReaderT(..), asks) +import Control.Monad.Reader (MonadReader, ReaderT(..), asks, local) import Control.Monad.State (MonadState, State) import Control.Monad.State (runState) import Control.Monad.State (get, gets, modify, put) @@ -447,3 +448,6 @@ wrapping p1 p2 = do then put s1 >> pure x -- Wrapped else pure y + +withColumns :: Maybe Int -> P a -> P a +withColumns c = local $ \pc -> pc {columns = c} diff --git a/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs b/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs index 0408546d..cb5f27e2 100644 --- a/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs +++ b/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs @@ -153,7 +153,8 @@ printQualified Options{..} padQual padNames longest (L _ decl) = do NewLine -> pure $ replicate offset ' ' when spaceSurround space - forM_ (flagEnds printedImports) $ \(imp, isFirst, isLast) -> do + forM_ (flagEnds printedImports) $ \(imp, isFirst, isLast) -> + patchForRepeatHiding $ wrapping (do unless isFirst space @@ -182,6 +183,12 @@ printQualified Options{..} padQual padNames longest (L _ decl) = do ] -} + -- We cannot wrap/repeat 'hiding' imports since then we would get multiple + -- imports hiding different things. + patchForRepeatHiding = case listAlign of + Repeat | isHiding decl -> withColumns Nothing + _ -> id + qualifiedDecl | isQualified decl = ["qualified"] | padQual = if isSource decl diff --git a/tests/Language/Haskell/Stylish/Step/ImportsGHC/Tests.hs b/tests/Language/Haskell/Stylish/Step/ImportsGHC/Tests.hs index 31bd75bc..3e63adf4 100644 --- a/tests/Language/Haskell/Stylish/Step/ImportsGHC/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/ImportsGHC/Tests.hs @@ -334,19 +334,19 @@ ex15 = input `assertFormattedCols` output , " ) where" , "" , "--------------------------------------------------------------------------------" - , "import Prelude as X hiding ((!!), appendFile, error, foldl, head, putStrLn, readFile, show, tail, take, unlines, unwords, words, writeFile)" + , "import Prelude as X hiding (appendFile, error, foldl, head, putStrLn, readFile, show, tail, take, unlines, unwords, words, writeFile, (!!))" , "import qualified Prelude" , "" , "--------------------------------------------------------------------------------" - , "import Control.Lens as X ((%~), (&), (.~), (?~), (^.), (^?), _Left, _Right, iat, over)" - , "import Control.Lens as X (preview, sans, set, to, view)" - , "import Control.Lens.Extras as X (is)" + , "import Control.Lens as X (_Left, _Right, iat, over, preview, sans, set, to)" + , "import Control.Lens as X (view, (%~), (&), (.~), (?~), (^.), (^?))" + , "import Control.Lens.Extras as X (is)" , "" , "--------------------------------------------------------------------------------" , "import Control.Applicative as X ((<|>))" - , "import Control.Monad as X ((<=<), (>=>), guard, unless, when)" - , "import Control.Monad.Except as X (ExceptT (..), MonadError (..), liftEither, runExceptT)" - , "import Control.Monad.Except as X (withExceptT)" + , "import Control.Monad as X (guard, unless, when, (<=<), (>=>))" + , "import Control.Monad.Except as X (ExceptT (..), MonadError (..), liftEither)" + , "import Control.Monad.Except as X (runExceptT, withExceptT)" , "import Control.Monad.IO.Unlift as X" , "import Control.Monad.Reader as X (MonadReader (..), ReaderT (..), asks)" , "import Control.Monad.Trans.Class as X (MonadTrans (lift))" From a19d1674ce3a462a1d5475289409448979092c32 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sun, 20 Sep 2020 15:30:42 +0200 Subject: [PATCH 096/135] long_list_align: multiline --- .../Haskell/Stylish/Step/ImportsGHC.hs | 59 ++++++++++++------- .../Haskell/Stylish/Step/Imports/Tests.hs | 2 +- 2 files changed, 38 insertions(+), 23 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs b/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs index cb5f27e2..207170b5 100644 --- a/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs +++ b/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs @@ -8,7 +8,7 @@ module Language.Haskell.Stylish.Step.ImportsGHC ) where -------------------------------------------------------------------------------- -import Control.Monad (forM_, when, unless) +import Control.Monad (forM_, when) import Data.Function ((&)) import Data.Foldable (toList) import Data.Ord (comparing) @@ -138,38 +138,53 @@ printQualified Options{..} padQual padNames longest (L _ decl) = do Nothing -> pure () Just (L _ []) -> putText " ()" Just (L _ imports) -> do - let printedImports = -- [P ()] + let printedImports = flagEnds $ -- [P ()] fmap ((printImport Options{..}) . unLocated) (sortImportList imports) - putText " (" -- Since we might need to output the import module name several times, we -- need to save it to a variable: let offset = case listPadding of LPConstant n -> n; LPModuleName -> 0 + putOffset = putText $ replicate offset ' ' wrapPrefix <- case listAlign of - AfterAlias -> pure $ replicate (afterAliasPosition + 2) ' ' - WithAlias -> pure $ replicate (beforeAliasPosition + 1) ' ' - Repeat -> getCurrentLine - WithModuleName -> pure $ replicate (moduleNamePosition + offset) ' ' - NewLine -> pure $ replicate offset ' ' + AfterAlias -> pure $ replicate (afterAliasPosition + 2) ' ' + WithAlias -> pure $ replicate (beforeAliasPosition + 1) ' ' + Repeat -> fmap (++ " (") getCurrentLine + WithModuleName -> pure $ replicate (moduleNamePosition + offset) ' ' + NewLine -> pure $ replicate offset ' ' when spaceSurround space - forM_ (flagEnds printedImports) $ \(imp, isFirst, isLast) -> - patchForRepeatHiding $ - wrapping - (do - unless isFirst space + case longListAlign of + Multiline -> wrapping + -- Try to put everything on one line. + (forM_ printedImports $ \(imp, isFirst, isLast) -> do + when isFirst $ putText " (" imp - if isLast then putText ")" else comma) - (do - case listAlign of - -- In 'Repeat' mode, end lines with ')' rather than ','. - Repeat | not isFirst -> modifyCurrentLine . withLast $ - \c -> if c == ',' then ')' else c - _ -> pure () + if isLast then putText ")" else comma >> space) + -- Put everything on a separate line. + (forM_ printedImports $ \(imp, isFirst, isLast) -> do newline - putText wrapPrefix + putOffset + if isFirst then putText "( " else putText ", " imp - if isLast then putText ")" else comma) + when isLast $ newline >> putOffset >> putText ")") + + Inline -> forM_ printedImports $ \(imp, isFirst, isLast) -> + patchForRepeatHiding $ wrapping + (do + if isFirst then putText " (" else space + imp + if isLast then putText ")" else comma) + (do + case listAlign of + -- In 'Repeat' mode, end lines with ')' rather than ','. + Repeat | not isFirst -> modifyCurrentLine . withLast $ + \c -> if c == ',' then ')' else c + _ -> pure () + newline + putText wrapPrefix + imp + if isLast then putText ")" else comma) + _ -> error $ "TODO: " ++ show longListAlign -- when spaceSurround space -- putText ")" diff --git a/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs index 5f3bda35..d32adcdb 100644 --- a/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs @@ -253,7 +253,7 @@ case09 = let options = Options Global WithAlias True Multiline Inherit (LPConstant 4) True False False in - expected @=? testStep' (step (Just 80) options) (lines input) + expected @=? testStep' (GHC.step (Just 80) options) (lines input) where expected = [ "module Herp where" From f3ab35fc25b28bafc6c201165c1901a08c06ef1a Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sun, 20 Sep 2020 15:37:36 +0200 Subject: [PATCH 097/135] Fix spaces issue in long_list_align: multiline --- lib/Language/Haskell/Stylish/Step/ImportsGHC.hs | 1 + tests/Language/Haskell/Stylish/Step/Imports/Tests.hs | 4 ++-- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs b/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs index 207170b5..8231a6d6 100644 --- a/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs +++ b/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs @@ -162,6 +162,7 @@ printQualified Options{..} padQual padNames longest (L _ decl) = do if isLast then putText ")" else comma >> space) -- Put everything on a separate line. (forM_ printedImports $ \(imp, isFirst, isLast) -> do + when isFirst $ modifyCurrentLine trimRight -- We added some spaces. newline putOffset if isFirst then putText "( " else putText ", " diff --git a/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs index d32adcdb..692798db 100644 --- a/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs @@ -290,9 +290,9 @@ case10 = let options = Options Group WithAlias True Multiline Inherit (LPConstant 4) True False False in - expected @=? testStep (step (Just 40) options) input + expected @=? testStep' (GHC.step (Just 40) options) (lines input) where - expected = unlines + expected = [ "module Herp where" , "" , "import Control.Monad" From d08024e81d3a77cb2b4ed4f6e2541a402fabea77 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sun, 20 Sep 2020 15:48:25 +0200 Subject: [PATCH 098/135] Snippet for pretty diff --- .../Haskell/Stylish/Step/Imports/Tests.hs | 32 +++++++++++-------- tests/Language/Haskell/Stylish/Tests/Util.hs | 19 +++++++++++ 2 files changed, 38 insertions(+), 13 deletions(-) diff --git a/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs index 692798db..f6e7c575 100644 --- a/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs @@ -63,6 +63,11 @@ tests = testGroup "Language.Haskell.Stylish.Step.Imports.Tests" ] +-------------------------------------------------------------------------------- +inputSnippet :: Snippet +inputSnippet = Snippet $ lines input + + -------------------------------------------------------------------------------- input :: String input = unlines @@ -84,9 +89,9 @@ input = unlines -------------------------------------------------------------------------------- case01 :: Assertion -case01 = expected @=? testStep' (GHC.step (Just 80) $ fromImportAlign Global) (lines input) +case01 = expected @=? testSnippet (GHC.step (Just 80) $ fromImportAlign Global) inputSnippet where - expected = + expected = Snippet [ "module Herp where" , "" , "import Control.Monad" @@ -106,9 +111,9 @@ case01 = expected @=? testStep' (GHC.step (Just 80) $ fromImportAlign Global) (l -------------------------------------------------------------------------------- case02 :: Assertion -case02 = expected @=? testStep' (GHC.step (Just 80) $ fromImportAlign Group) (lines input) +case02 = expected @=? testSnippet (GHC.step (Just 80) $ fromImportAlign Group) inputSnippet where - expected = + expected = Snippet [ "module Herp where" , "" , "import Control.Monad" @@ -127,9 +132,9 @@ case02 = expected @=? testStep' (GHC.step (Just 80) $ fromImportAlign Group) (li -------------------------------------------------------------------------------- case03 :: Assertion -case03 = expected @=? testStep' (GHC.step (Just 80) $ fromImportAlign None) (lines input) +case03 = expected @=? testSnippet (GHC.step (Just 80) $ fromImportAlign None) inputSnippet where - expected = + expected = Snippet [ "module Herp where" , "" , "import Control.Monad" @@ -148,13 +153,13 @@ case03 = expected @=? testStep' (GHC.step (Just 80) $ fromImportAlign None) (lin -------------------------------------------------------------------------------- case04 :: Assertion -case04 = expected @=? testStep' (GHC.step (Just 80) $ fromImportAlign Global) (lines input') +case04 = expected @=? testSnippet (GHC.step (Just 80) $ fromImportAlign Global) input' where - input' = + input' = Snippet $ pure $ "import Data.Aeson.Types (object, typeMismatch, FromJSON(..)," ++ "ToJSON(..), Value(..), parseEither, (.!=), (.:), (.:?), (.=))" - expected = + expected = Snippet [ "import Data.Aeson.Types (FromJSON (..), ToJSON (..), Value (..)," , " object, parseEither, typeMismatch, (.!=)," , " (.:), (.:?), (.=))" @@ -163,9 +168,9 @@ case04 = expected @=? testStep' (GHC.step (Just 80) $ fromImportAlign Global) (l -------------------------------------------------------------------------------- case05 :: Assertion -case05 = input' @=? testStep' (GHC.step (Just 80) $ fromImportAlign Group) input' +case05 = input' @=? testSnippet (GHC.step (Just 80) $ fromImportAlign Group) input' where - input' = ["import Distribution.PackageDescription.Configuration " ++ + input' = Snippet ["import Distribution.PackageDescription.Configuration " ++ "(finalizePackageDescription)"] @@ -326,15 +331,16 @@ case10 = ] + -------------------------------------------------------------------------------- case11 :: Assertion case11 = let options = Options Group NewLine True Inline Inherit (LPConstant 4) True False False in - expected @=? testStep (step (Just 80) options) input + expected @=? testSnippet (GHC.step (Just 80) options) inputSnippet where - expected = unlines + expected = Snippet [ "module Herp where" , "" , "import Control.Monad" diff --git a/tests/Language/Haskell/Stylish/Tests/Util.hs b/tests/Language/Haskell/Stylish/Tests/Util.hs index b85a7e7a..f52c015e 100644 --- a/tests/Language/Haskell/Stylish/Tests/Util.hs +++ b/tests/Language/Haskell/Stylish/Tests/Util.hs @@ -2,6 +2,8 @@ module Language.Haskell.Stylish.Tests.Util ( testStep , testStep' + , Snippet (..) + , testSnippet , withTestDirTree , (@=??) ) where @@ -41,9 +43,26 @@ testStep s str = case s of where ls = lines str + +-------------------------------------------------------------------------------- testStep' :: Step -> Lines -> Lines testStep' s ls = lines $ testStep s (unlines ls) + +-------------------------------------------------------------------------------- +-- | 'Lines' that show as a normal string. +newtype Snippet = Snippet {unSnippet :: Lines} deriving (Eq) + + +-------------------------------------------------------------------------------- +instance Show Snippet where show = unlines . unSnippet + + +-------------------------------------------------------------------------------- +testSnippet :: Step -> Snippet -> Snippet +testSnippet s = Snippet . lines . testStep s . unlines . unSnippet + + -------------------------------------------------------------------------------- -- | Create a temporary directory with a randomised name built from the template -- provided From 33a9d28b17b90ae775740a01695825142734513d Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sun, 20 Sep 2020 17:08:50 +0200 Subject: [PATCH 099/135] Fix some list_align: newline issues --- .../Haskell/Stylish/Step/ImportsGHC.hs | 19 +++++++++++---- .../Haskell/Stylish/Step/Imports/Tests.hs | 23 ++++++++++--------- 2 files changed, 27 insertions(+), 15 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs b/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs index 8231a6d6..25845a6c 100644 --- a/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs +++ b/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs @@ -134,17 +134,22 @@ printQualified Options{..} padQual padNames longest (L _ decl) = do when (isHiding decl) (space >> putText "hiding") + let offset = case listPadding of LPConstant n -> n; LPModuleName -> 0 + putOffset = putText $ replicate offset ' ' + case snd <$> ideclHiding decl' of Nothing -> pure () - Just (L _ []) -> putText " ()" + Just (L _ []) -> case listAlign of + -- Should we remove this exception? + NewLine -> + modifyCurrentLine trimRight >> newline >> putOffset >> putText "()" + _ -> space >> putText "()" Just (L _ imports) -> do let printedImports = flagEnds $ -- [P ()] fmap ((printImport Options{..}) . unLocated) (sortImportList imports) -- Since we might need to output the import module name several times, we -- need to save it to a variable: - let offset = case listPadding of LPConstant n -> n; LPModuleName -> 0 - putOffset = putText $ replicate offset ' ' wrapPrefix <- case listAlign of AfterAlias -> pure $ replicate (afterAliasPosition + 2) ' ' WithAlias -> pure $ replicate (beforeAliasPosition + 1) ' ' @@ -172,7 +177,13 @@ printQualified Options{..} padQual padNames longest (L _ decl) = do Inline -> forM_ printedImports $ \(imp, isFirst, isLast) -> patchForRepeatHiding $ wrapping (do - if isFirst then putText " (" else space + if isFirst + then case listAlign of + NewLine -> do + modifyCurrentLine trimRight + newline >> putOffset >> putText "(" + _ -> putText " (" + else space imp if isLast then putText ")" else comma) (do diff --git a/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs index f6e7c575..920557be 100644 --- a/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs @@ -186,15 +186,16 @@ case06 = input' @=? testStep' (GHC.step (Just 80) $ fromImportAlign File) input' -------------------------------------------------------------------------------- case07 :: Assertion -case07 = expected @=? testStep' (GHC.step (Just 80) $ fromImportAlign File) input' +case07 = + expected @=? testSnippet (GHC.step (Just 80) $ fromImportAlign File) input' where - input' = + input' = Snippet [ "import Bar.Qux" , "" , "import qualified Foo.Bar" ] - expected = + expected = Snippet [ "import Bar.Qux" , "" , "import qualified Foo.Bar" @@ -207,9 +208,9 @@ case08 = let options = Options Global WithAlias True Inline Inherit (LPConstant 4) True False False in - expected @=? testStep' (GHC.step (Just 80) options) (lines input) + expected @=? testSnippet (GHC.step (Just 80) options) inputSnippet where - expected = + expected = Snippet [ "module Herp where" , "" , "import Control.Monad" @@ -233,9 +234,9 @@ case08b = let options = Options Global WithModuleName True Inline Inherit (LPConstant 4) True False False in - expected @=? testStep' (GHC.step (Just 80) options) (lines input) + expected @=? testSnippet (GHC.step (Just 80) options) inputSnippet where - expected = + expected = Snippet ["module Herp where" , "" , "import Control.Monad" @@ -258,9 +259,9 @@ case09 = let options = Options Global WithAlias True Multiline Inherit (LPConstant 4) True False False in - expected @=? testStep' (GHC.step (Just 80) options) (lines input) + expected @=? testSnippet (GHC.step (Just 80) options) inputSnippet where - expected = + expected = Snippet [ "module Herp where" , "" , "import Control.Monad" @@ -295,9 +296,9 @@ case10 = let options = Options Group WithAlias True Multiline Inherit (LPConstant 4) True False False in - expected @=? testStep' (GHC.step (Just 40) options) (lines input) + expected @=? testSnippet (GHC.step (Just 40) options) inputSnippet where - expected = + expected = Snippet [ "module Herp where" , "" , "import Control.Monad" From 1a05d46d182dccd606f9dc9ab5cbc28d84f07da5 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sun, 20 Sep 2020 17:22:14 +0200 Subject: [PATCH 100/135] Stub InlineWithBreak --- .../Haskell/Stylish/Step/ImportsGHC.hs | 63 +++++++++++-------- .../Haskell/Stylish/Step/Imports/Tests.hs | 16 ++--- 2 files changed, 44 insertions(+), 35 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs b/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs index 25845a6c..a0b67020 100644 --- a/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs +++ b/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs @@ -157,14 +157,40 @@ printQualified Options{..} padQual padNames longest (L _ decl) = do WithModuleName -> pure $ replicate (moduleNamePosition + offset) ' ' NewLine -> pure $ replicate offset ' ' + let -- Try to put everything on one line. + printAsSingleLine = forM_ printedImports $ \(imp, start, end) -> do + when start $ putText "(" + imp + if end then putText ")" else comma >> space + + -- Try to put everything one by one, wrapping if that fails. + printAsInlineWrapping = forM_ printedImports $ \(imp, start, end) -> + patchForRepeatHiding $ wrapping + (do + if start + then case listAlign of + NewLine -> do + modifyCurrentLine trimRight + newline >> putOffset >> putText "(" + _ -> putText " (" + else space + imp + if end then putText ")" else comma) + (do + case listAlign of + -- In 'Repeat' mode, end lines with ')' rather than ','. + Repeat | not start -> modifyCurrentLine . withLast $ + \c -> if c == ',' then ')' else c + _ -> pure () + newline + putText wrapPrefix + imp + if end then putText ")" else comma) + when spaceSurround space case longListAlign of Multiline -> wrapping - -- Try to put everything on one line. - (forM_ printedImports $ \(imp, isFirst, isLast) -> do - when isFirst $ putText " (" - imp - if isLast then putText ")" else comma >> space) + (space >> printAsSingleLine) -- Put everything on a separate line. (forM_ printedImports $ \(imp, isFirst, isLast) -> do when isFirst $ modifyCurrentLine trimRight -- We added some spaces. @@ -174,28 +200,11 @@ printQualified Options{..} padQual padNames longest (L _ decl) = do imp when isLast $ newline >> putOffset >> putText ")") - Inline -> forM_ printedImports $ \(imp, isFirst, isLast) -> - patchForRepeatHiding $ wrapping - (do - if isFirst - then case listAlign of - NewLine -> do - modifyCurrentLine trimRight - newline >> putOffset >> putText "(" - _ -> putText " (" - else space - imp - if isLast then putText ")" else comma) - (do - case listAlign of - -- In 'Repeat' mode, end lines with ')' rather than ','. - Repeat | not isFirst -> modifyCurrentLine . withLast $ - \c -> if c == ',' then ')' else c - _ -> pure () - newline - putText wrapPrefix - imp - if isLast then putText ")" else comma) + Inline -> printAsInlineWrapping + InlineWithBreak -> do + newline + printAsInlineWrapping + _ -> error $ "TODO: " ++ show longListAlign -- when spaceSurround space diff --git a/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs index 920557be..38ba4e35 100644 --- a/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs @@ -369,9 +369,9 @@ case11b = let options = Options Group WithModuleName True Inline Inherit (LPConstant 4) True False False in - expected @=? testStep (step (Just 80) options) input + expected @=? testSnippet (GHC.step (Just 80) options) inputSnippet where - expected = unlines + expected = Snippet [ "module Herp where" , "" , "import Control.Monad" @@ -394,13 +394,13 @@ case12 = let options = Options Group NewLine True Inline Inherit (LPConstant 2) True False False in - expected @=? testStep' (step (Just 80) options) input' + expected @=? testSnippet (GHC.step (Just 80) options) input' where - input' = + input' = Snippet [ "import Data.List (map)" ] - expected = + expected = Snippet [ "import Data.List" , " (map)" ] @@ -425,14 +425,14 @@ case13 = let options = Options None WithAlias True InlineWithBreak Inherit (LPConstant 4) True False False in - expected @=? testStep (step (Just 80) options) input' + expected @=? testSnippet (GHC.step (Just 80) options) input' where - input' = unlines + input' = Snippet [ "import qualified Data.List as List (concat, foldl, foldr, head, init," , " last, length, map, null, reverse, tail, (++))" ] - expected = unlines + expected = Snippet [ "import qualified Data.List as List" , " (concat, foldl, foldr, head, init, last, length, map, null, reverse, tail," , " (++))" From d4a146bfda7abf1927bf77450dcd162759f04820 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sun, 20 Sep 2020 18:37:52 +0200 Subject: [PATCH 101/135] Fix long_list_align: newline issue --- .../Haskell/Stylish/Step/ImportsGHC.hs | 24 +++++++++---------- 1 file changed, 11 insertions(+), 13 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs b/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs index a0b67020..6f9057d9 100644 --- a/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs +++ b/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs @@ -8,7 +8,7 @@ module Language.Haskell.Stylish.Step.ImportsGHC ) where -------------------------------------------------------------------------------- -import Control.Monad (forM_, when) +import Control.Monad (forM_, when, void) import Data.Function ((&)) import Data.Foldable (toList) import Data.Ord (comparing) @@ -164,16 +164,11 @@ printQualified Options{..} padQual padNames longest (L _ decl) = do if end then putText ")" else comma >> space -- Try to put everything one by one, wrapping if that fails. - printAsInlineWrapping = forM_ printedImports $ \(imp, start, end) -> + printAsInlineWrapping wprefix = forM_ printedImports $ + \(imp, start, end) -> patchForRepeatHiding $ wrapping (do - if start - then case listAlign of - NewLine -> do - modifyCurrentLine trimRight - newline >> putOffset >> putText "(" - _ -> putText " (" - else space + if start then putText "(" else space imp if end then putText ")" else comma) (do @@ -183,7 +178,7 @@ printQualified Options{..} padQual padNames longest (L _ decl) = do \c -> if c == ',' then ')' else c _ -> pure () newline - putText wrapPrefix + void wprefix imp if end then putText ")" else comma) @@ -200,10 +195,13 @@ printQualified Options{..} padQual padNames longest (L _ decl) = do imp when isLast $ newline >> putOffset >> putText ")") - Inline -> printAsInlineWrapping + Inline | NewLine <- listAlign -> do + modifyCurrentLine trimRight + newline >> putOffset >> printAsInlineWrapping (putText wrapPrefix) + Inline -> space >> printAsInlineWrapping (putText wrapPrefix) InlineWithBreak -> do - newline - printAsInlineWrapping + modifyCurrentLine trimRight + newline >> putOffset >> printAsInlineWrapping putOffset _ -> error $ "TODO: " ++ show longListAlign From 32dd4d206deacabb446003810a3edab0aaad332b Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sun, 20 Sep 2020 18:40:49 +0200 Subject: [PATCH 102/135] long_list_align: newline: try single line first --- lib/Language/Haskell/Stylish/Step/ImportsGHC.hs | 8 +++++--- tests/Language/Haskell/Stylish/Step/Imports/Tests.hs | 10 +++++----- 2 files changed, 10 insertions(+), 8 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs b/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs index 6f9057d9..8dbca637 100644 --- a/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs +++ b/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs @@ -199,9 +199,11 @@ printQualified Options{..} padQual padNames longest (L _ decl) = do modifyCurrentLine trimRight newline >> putOffset >> printAsInlineWrapping (putText wrapPrefix) Inline -> space >> printAsInlineWrapping (putText wrapPrefix) - InlineWithBreak -> do - modifyCurrentLine trimRight - newline >> putOffset >> printAsInlineWrapping putOffset + InlineWithBreak -> wrapping + (space >> printAsSingleLine) + (do + modifyCurrentLine trimRight + newline >> putOffset >> printAsInlineWrapping putOffset) _ -> error $ "TODO: " ++ show longListAlign diff --git a/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs index 38ba4e35..6cf02bea 100644 --- a/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs @@ -445,14 +445,14 @@ case13b = let options = Options None WithModuleName True InlineWithBreak Inherit (LPConstant 4) True False False in - expected @=? testStep (step (Just 80) options) input' + expected @=? testSnippet (GHC.step (Just 80) options) input' where - input' = unlines + input' = Snippet [ "import qualified Data.List as List (concat, foldl, foldr, head, init," , " last, length, map, null, reverse, tail, (++))" ] - expected = unlines + expected = Snippet [ "import qualified Data.List as List" , " (concat, foldl, foldr, head, init, last, length, map, null, reverse, tail," , " (++))" @@ -465,9 +465,9 @@ case14 = let options = Options None WithAlias True InlineWithBreak Inherit (LPConstant 10) True False False in - expected @=? testStep (step (Just 80) options) expected + expected @=? testSnippet (GHC.step (Just 80) options) expected where - expected = unlines + expected = Snippet [ "import qualified Data.List as List (concat, map, null, reverse, tail, (++))" ] From acec94cd9b2e5f2470ec9fa4495e863b9d44173e Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sun, 20 Sep 2020 19:05:14 +0200 Subject: [PATCH 103/135] sortImportList: sort inner list, too --- .../Haskell/Stylish/Step/ImportsGHC.hs | 45 +++++++++++-------- .../Haskell/Stylish/Step/Imports/Tests.hs | 18 ++++---- 2 files changed, 36 insertions(+), 27 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs b/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs index 8dbca637..3a3963cb 100644 --- a/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs +++ b/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs @@ -9,11 +9,12 @@ module Language.Haskell.Stylish.Step.ImportsGHC -------------------------------------------------------------------------------- import Control.Monad (forM_, when, void) +import Data.Char (isUpper) import Data.Function ((&)) import Data.Foldable (toList) import Data.Ord (comparing) import Data.Maybe (isJust) -import Data.List (sortBy, isPrefixOf) +import Data.List (sortBy, sortOn) import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NonEmpty @@ -252,7 +253,7 @@ printImport Options{..} (IEThingWith _ name _wildcard imps _) = do printIeWrappedName name when separateLists space parenthesize $ - sep (comma >> space) (printIeWrappedName <$> sortBy compareOutputable imps) + sep (comma >> space) (printIeWrappedName <$> imps) printImport _ (IEGroup _ _ _ ) = error "Language.Haskell.Stylish.Printer.Imports.printImportExport: unhandled case 'IEGroup'" printImport _ (IEDoc _ _) = @@ -341,22 +342,30 @@ isSafe . rawImport sortImportList :: [LIE GhcPs] -> [LIE GhcPs] -sortImportList = sortBy compareImportLIE - - --------------------------------------------------------------------------------- --- | The implementation is a bit hacky to get proper sorting for input specs: --- constructors first, followed by functions, and then operators. -compareImportLIE :: LIE GhcPs -> LIE GhcPs -> Ordering -compareImportLIE = comparing $ key . unLoc - where - key :: IE GhcPs -> (Int, Bool, String) - key (IEVar _ n) = let o = showOutputable n in - (1, "(" `isPrefixOf` o, o) - key (IEThingAbs _ n) = (0, False, showOutputable n) - key (IEThingAll _ n) = (0, False, showOutputable n) - key (IEThingWith _ n _ _ _) = (0, False, showOutputable n) - key _ = (2, False, "") +sortImportList = map (fmap sortInner) . sortBy compareImportLIE + where + compareImportLIE :: LIE GhcPs -> LIE GhcPs -> Ordering + compareImportLIE = comparing $ ieKey . unLoc + + sortInner :: IE GhcPs -> IE GhcPs + sortInner = \case + IEThingWith x n w ns fs -> IEThingWith x n w (sortOn nameKey ns) fs + ie -> ie + + -- | The implementation is a bit hacky to get proper sorting for input specs: + -- constructors first, followed by functions, and then operators. + ieKey :: IE GhcPs -> (Int, String) + ieKey = \case + IEVar _ n -> nameKey n + IEThingAbs _ n -> nameKey n + IEThingAll _ n -> nameKey n + IEThingWith _ n _ _ _ -> nameKey n + _ -> (2, "") + + nameKey n = case showOutputable n of + o@('(' : _) -> (2 :: Int, o) + o@(o0 : _) | isUpper o0 -> (0, o) + o -> (1, o) -------------------------------------------------------------------------------- diff --git a/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs index 6cf02bea..ec5ef7f6 100644 --- a/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs @@ -478,9 +478,9 @@ case15 = let options = Options None AfterAlias True Multiline Inherit (LPConstant 4) True False False in - expected @=? testStep (step (Just 80) options) input' + expected @=? testSnippet (GHC.step (Just 80) options) input' where - expected = unlines + expected = Snippet [ "import Data.Acid (AcidState)" , "import qualified Data.Acid as Acid" , " ( closeAcidState" @@ -492,7 +492,7 @@ case15 = , "import qualified Herp.Derp.Internal.Types.Foobar as Internal (bar, foo)" ] - input' = unlines + input' = Snippet [ "import Data.Acid (AcidState)" , "import qualified Data.Acid as Acid (closeAcidState, createCheckpoint, openLocalStateFrom)" , "import Data.Default.Class (Default (def))" @@ -507,9 +507,9 @@ case16 = let options = Options None AfterAlias True Multiline Inherit (LPConstant 4) False False False in - expected @=? testStep (step (Just 80) options) input' + expected @=? testSnippet (GHC.step (Just 80) options) input' where - expected = unlines + expected = Snippet [ "import Data.Acid (AcidState)" , "import Data.Default.Class (Default(def))" , "" @@ -518,7 +518,7 @@ case16 = , "import Data.Foo (Foo(Bar, Foo), Goo(Goo))" ] - input' = unlines + input' = Snippet [ "import Data.Acid (AcidState)" , "import Data.Default.Class (Default(def))" , "" @@ -534,15 +534,15 @@ case17 = let options = Options None AfterAlias True Multiline Inherit (LPConstant 4) True False False in - expected @=? testStep (step (Just 80) options) input' + expected @=? testSnippet (GHC.step (Just 80) options) input' where - expected = unlines + expected = Snippet [ "import Control.Applicative (Applicative (pure, (<*>)))" , "" , "import Data.Identity (Identity (Identity, runIdentity))" ] - input' = unlines + input' = Snippet [ "import Control.Applicative (Applicative ((<*>),pure))" , "" , "import Data.Identity (Identity (runIdentity,Identity))" From 81de6c8c10c2b98803094d11f777cf6fda42b274 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sun, 20 Sep 2020 19:11:13 +0200 Subject: [PATCH 104/135] long_list_align: new_line_multiline --- .../Haskell/Stylish/Step/ImportsGHC.hs | 27 +++++++++++-------- .../Haskell/Stylish/Step/Imports/Tests.hs | 6 ++--- 2 files changed, 19 insertions(+), 14 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs b/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs index 3a3963cb..f4cd19e5 100644 --- a/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs +++ b/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs @@ -182,20 +182,20 @@ printQualified Options{..} padQual padNames longest (L _ decl) = do void wprefix imp if end then putText ")" else comma) - - when spaceSurround space - case longListAlign of - Multiline -> wrapping - (space >> printAsSingleLine) -- Put everything on a separate line. - (forM_ printedImports $ \(imp, isFirst, isLast) -> do - when isFirst $ modifyCurrentLine trimRight -- We added some spaces. + printAsMultiLine = forM_ printedImports $ \(imp, start, end) -> do + when start $ modifyCurrentLine trimRight -- We added some spaces. newline putOffset - if isFirst then putText "( " else putText ", " + if start then putText "( " else putText ", " imp - when isLast $ newline >> putOffset >> putText ")") + when end $ newline >> putOffset >> putText ")" + when spaceSurround space + case longListAlign of + Multiline -> wrapping + (space >> printAsSingleLine) + printAsMultiLine Inline | NewLine <- listAlign -> do modifyCurrentLine trimRight newline >> putOffset >> printAsInlineWrapping (putText wrapPrefix) @@ -205,8 +205,13 @@ printQualified Options{..} padQual padNames longest (L _ decl) = do (do modifyCurrentLine trimRight newline >> putOffset >> printAsInlineWrapping putOffset) - - _ -> error $ "TODO: " ++ show longListAlign + InlineToMultiline -> wrapping + (space >> printAsSingleLine) + (wrapping + (do + modifyCurrentLine trimRight + newline >> putOffset >> printAsSingleLine) + printAsMultiLine) -- when spaceSurround space -- putText ")" diff --git a/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs index ec5ef7f6..838aaf05 100644 --- a/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs @@ -555,9 +555,9 @@ case18 = let options = Options None AfterAlias True InlineToMultiline Inherit (LPConstant 4) True False False in - expected @=? testStep (step (Just 40) options) input' + expected @=? testSnippet (GHC.step (Just 40) options) input' where - expected = unlines + expected = Snippet ---------------------------------------- [ "import Data.Foo as Foo (Bar, Baz, Foo)" , "" @@ -571,7 +571,7 @@ case18 = , " )" ] - input' = unlines + input' = Snippet [ "import Data.Foo as Foo (Bar, Baz, Foo)" , "" , "import Data.Identity (Identity (Identity, runIdentity))" From 142e45b07ac41bcd4a5714ddc386412833dd07e4 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sun, 20 Sep 2020 19:17:10 +0200 Subject: [PATCH 105/135] empty_list_align: right_after --- .../Haskell/Stylish/Step/ImportsGHC.hs | 9 +++--- .../Haskell/Stylish/Step/Imports/Tests.hs | 30 +++++++++---------- 2 files changed, 20 insertions(+), 19 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs b/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs index f4cd19e5..edcc89f3 100644 --- a/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs +++ b/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs @@ -140,11 +140,12 @@ printQualified Options{..} padQual padNames longest (L _ decl) = do case snd <$> ideclHiding decl' of Nothing -> pure () - Just (L _ []) -> case listAlign of - -- Should we remove this exception? - NewLine -> + Just (L _ []) -> case emptyListAlign of + RightAfter -> modifyCurrentLine trimRight >> space >> putText "()" + Inherit -> case listAlign of + NewLine -> modifyCurrentLine trimRight >> newline >> putOffset >> putText "()" - _ -> space >> putText "()" + _ -> space >> putText "()" Just (L _ imports) -> do let printedImports = flagEnds $ -- [P ()] fmap ((printImport Options{..}) . unLocated) (sortImportList imports) diff --git a/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs index 838aaf05..8ea34930 100644 --- a/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs @@ -586,9 +586,9 @@ case19 = let options = Options Global NewLine True InlineWithBreak RightAfter (LPConstant 17) True False False in - expected @=? testStep (step (Just 40) options) case19input + expected @=? testSnippet (GHC.step (Just 40) options) case19input where - expected = unlines + expected = Snippet ---------------------------------------- [ "import Prelude ()" , "import Prelude.Compat hiding" @@ -605,9 +605,9 @@ case19b = let options = Options File NewLine True InlineWithBreak RightAfter (LPConstant 17) True False False in - expected @=? testStep (step (Just 40) options) case19input + expected @=? testSnippet (step (Just 40) options) case19input where - expected = unlines + expected = Snippet ---------------------------------------- [ "import Prelude ()" , "import Prelude.Compat hiding" @@ -624,9 +624,9 @@ case19c = let options = Options File NewLine True InlineWithBreak RightAfter LPModuleName True False False in - expected @=? testStep (step (Just 40) options) case19input + expected @=? testSnippet (step (Just 40) options) case19input where - expected = unlines + expected = Snippet ---------------------------------------- [ "import Prelude ()" , "import Prelude.Compat hiding" @@ -643,9 +643,9 @@ case19d = let options = Options Global NewLine True InlineWithBreak RightAfter LPModuleName True False False in - expected @=? testStep (step (Just 40) options) case19input + expected @=? testSnippet (step (Just 40) options) case19input where - expected = unlines + expected = Snippet ---------------------------------------- [ "import Prelude ()" , "import Prelude.Compat hiding" @@ -657,13 +657,13 @@ case19d = ] -case19input :: String -case19input = unlines - [ "import Prelude.Compat hiding (foldMap)" - , "import Prelude ()" - , "" - , "import Data.List (foldl', intercalate, intersperse)" - ] +case19input :: Snippet +case19input = Snippet + [ "import Prelude.Compat hiding (foldMap)" + , "import Prelude ()" + , "" + , "import Data.List (foldl', intercalate, intersperse)" + ] -------------------------------------------------------------------------------- From 9fa97556e43e4ca041f70ac016d9570e4f0896a5 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sun, 20 Sep 2020 19:26:09 +0200 Subject: [PATCH 106/135] Fix list_padding: module_name --- lib/Language/Haskell/Stylish/Step/ImportsGHC.hs | 6 ++++-- tests/Language/Haskell/Stylish/Step/Imports/Tests.hs | 7 +++---- 2 files changed, 7 insertions(+), 6 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs b/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs index edcc89f3..c2efe8e6 100644 --- a/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs +++ b/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs @@ -135,8 +135,10 @@ printQualified Options{..} padQual padNames longest (L _ decl) = do when (isHiding decl) (space >> putText "hiding") - let offset = case listPadding of LPConstant n -> n; LPModuleName -> 0 - putOffset = putText $ replicate offset ' ' + let putOffset = putText $ replicate offset ' ' + offset = case listPadding of + LPConstant n -> n + LPModuleName -> moduleNamePosition case snd <$> ideclHiding decl' of Nothing -> pure () diff --git a/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs index 8ea34930..ee8e3883 100644 --- a/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs @@ -605,13 +605,12 @@ case19b = let options = Options File NewLine True InlineWithBreak RightAfter (LPConstant 17) True False False in - expected @=? testSnippet (step (Just 40) options) case19input + expected @=? testSnippet (GHC.step (Just 40) options) case19input where expected = Snippet ---------------------------------------- [ "import Prelude ()" - , "import Prelude.Compat hiding" - , " (foldMap)" + , "import Prelude.Compat hiding (foldMap)" , "" , "import Data.List" , " (foldl', intercalate," @@ -643,7 +642,7 @@ case19d = let options = Options Global NewLine True InlineWithBreak RightAfter LPModuleName True False False in - expected @=? testSnippet (step (Just 40) options) case19input + expected @=? testSnippet (GHC.step (Just 40) options) case19input where expected = Snippet ---------------------------------------- From c9153167c949995319b4f77d591a242cd4bd186d Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Mon, 21 Sep 2020 14:48:17 +0200 Subject: [PATCH 107/135] Unique import items, still needs merging --- .../Haskell/Stylish/Step/ImportsGHC.hs | 34 +++++++++++++++---- .../Haskell/Stylish/Step/Imports/Tests.hs | 11 +++--- 2 files changed, 33 insertions(+), 12 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs b/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs index c2efe8e6..df615263 100644 --- a/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs +++ b/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs @@ -17,6 +17,7 @@ import Data.Maybe (isJust) import Data.List (sortBy, sortOn) import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Set as Set -------------------------------------------------------------------------------- @@ -150,7 +151,8 @@ printQualified Options{..} padQual padNames longest (L _ decl) = do _ -> space >> putText "()" Just (L _ imports) -> do let printedImports = flagEnds $ -- [P ()] - fmap ((printImport Options{..}) . unLocated) (sortImportList imports) + fmap ((printImport Options{..}) . unLocated) + (prepareImportList imports) -- Since we might need to output the import module name several times, we -- need to save it to a variable: @@ -349,16 +351,25 @@ isSafe = ideclSafe . rawImport -sortImportList :: [LIE GhcPs] -> [LIE GhcPs] -sortImportList = map (fmap sortInner) . sortBy compareImportLIE +-------------------------------------------------------------------------------- +-- | Cleans up an import item list. +-- +-- * Sorts import items. +-- * Sort inner import lists, e.g. `import Control.Monad (Monad (return, join))` +-- * Removes duplicates from import lists. +prepareImportList :: [LIE GhcPs] -> [LIE GhcPs] +prepareImportList = + nubOn showOutputable . map (fmap prepareInner) . sortBy compareImportLIE where compareImportLIE :: LIE GhcPs -> LIE GhcPs -> Ordering compareImportLIE = comparing $ ieKey . unLoc - sortInner :: IE GhcPs -> IE GhcPs - sortInner = \case + prepareInner :: IE GhcPs -> IE GhcPs + prepareInner = \case + -- Simplify `A ()` to `A`. + IEThingWith x n NoIEWildcard [] [] -> IEThingAbs x n IEThingWith x n w ns fs -> IEThingWith x n w (sortOn nameKey ns) fs - ie -> ie + ie -> ie -- | The implementation is a bit hacky to get proper sorting for input specs: -- constructors first, followed by functions, and then operators. @@ -381,3 +392,14 @@ listPaddingValue :: Int -> ListPadding -> Int listPaddingValue _ (LPConstant n) = n listPaddingValue n LPModuleName = n + +-------------------------------------------------------------------------------- +nubOn :: Ord k => (a -> k) -> [a] -> [a] +nubOn f = go Set.empty + where + go _ [] = [] + go acc (x : xs) + | y `Set.member` acc = go acc xs + | otherwise = x : go (Set.insert y acc) xs + where + y = f x diff --git a/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs index ee8e3883..b668e827 100644 --- a/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs @@ -623,13 +623,12 @@ case19c = let options = Options File NewLine True InlineWithBreak RightAfter LPModuleName True False False in - expected @=? testSnippet (step (Just 40) options) case19input + expected @=? testSnippet (GHC.step (Just 40) options) case19input where expected = Snippet ---------------------------------------- [ "import Prelude ()" - , "import Prelude.Compat hiding" - , " (foldMap)" + , "import Prelude.Compat hiding (foldMap)" , "" , "import Data.List" , " (foldl', intercalate," @@ -687,9 +686,9 @@ case20 = expected -------------------------------------------------------------------------------- case21 :: Assertion case21 = expected - @=? testStep (step (Just 80) defaultOptions) input' + @=? testSnippet (GHC.step (Just 80) defaultOptions) input' where - expected = unlines + expected = Snippet [ "{-# LANGUAGE ExplicitNamespaces #-}" , "import X1 (A, B, C)" , "import X2 (A, B, C)" @@ -701,7 +700,7 @@ case21 = expected , "import X8 (type (+), (+))" , "import X9 hiding (x, y, z)" ] - input' = unlines + input' = Snippet [ "{-# LANGUAGE ExplicitNamespaces #-}" , "import X1 (A, B, A, C, A, B, A)" , "import X2 (C(), B(), A())" From 40c38fff6e96207922832dc72adcaac5cf83c3b6 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Mon, 21 Sep 2020 15:46:59 +0200 Subject: [PATCH 108/135] Stub out proper import item merging --- .../Haskell/Stylish/Step/ImportsGHC.hs | 37 ++++++++++++++++++- .../Haskell/Stylish/Step/Imports/Tests.hs | 6 +-- 2 files changed, 39 insertions(+), 4 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs b/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs index df615263..bd77cb09 100644 --- a/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs +++ b/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs @@ -11,12 +11,14 @@ module Language.Haskell.Stylish.Step.ImportsGHC import Control.Monad (forM_, when, void) import Data.Char (isUpper) import Data.Function ((&)) +import Data.Functor (($>)) import Data.Foldable (toList) import Data.Ord (comparing) import Data.Maybe (isJust) import Data.List (sortBy, sortOn) import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Map as Map import qualified Data.Set as Set @@ -359,8 +361,21 @@ isSafe -- * Removes duplicates from import lists. prepareImportList :: [LIE GhcPs] -> [LIE GhcPs] prepareImportList = - nubOn showOutputable . map (fmap prepareInner) . sortBy compareImportLIE + sortBy compareImportLIE . map (fmap prepareInner) . + concatMap (toList . snd) . Map.toAscList . mergeByName where + mergeByName :: [LIE GhcPs] -> Map.Map RdrName (NonEmpty (LIE GhcPs)) + mergeByName imports0 = Map.fromListWith + -- Note that ideally every NonEmpty will just have a single entry and we + -- will be able to merge everything into that entry. Exotic imports can + -- mess this up, though. So they end up in the tail of the list. + (\(x :| xs) (y :| ys) -> case ieMerge (unLocated x) (unLocated y) of + Just z -> (x $> z) :| (xs ++ ys) -- Keep source from `x` + Nothing -> x :| (xs ++ y : ys)) + [(ieName $ unLocated imp, imp :| []) | imp <- imports0] + + -- | TODO: get rid off this by adding a properly sorting newtype around + -- 'RdrName'. compareImportLIE :: LIE GhcPs -> LIE GhcPs -> Ordering compareImportLIE = comparing $ ieKey . unLoc @@ -386,6 +401,26 @@ prepareImportList = o@(o0 : _) | isUpper o0 -> (0, o) o -> (1, o) + -- Merge two import items, assuming they have the same name. + ieMerge :: IE GhcPs -> IE GhcPs -> Maybe (IE GhcPs) + ieMerge l@(IEVar _ _) _ = Just l + ieMerge _ r@(IEVar _ _) = Just r + ieMerge (IEThingAbs _ _) r = Just r + ieMerge l (IEThingAbs _ _) = Just l + ieMerge l@(IEThingAll _ _) _ = Just l + ieMerge _ r@(IEThingAll _ _) = Just r + ieMerge (IEThingWith x0 n0 w0 ns0 []) (IEThingWith _ _ w1 ns1 []) + | w0 /= w1 = Nothing + | otherwise = Just $ + -- TODO: sort the `ns0 ++ ns1`? + IEThingWith x0 n0 w0 (nubOn (unwrapName . unLocated) $ ns0 ++ ns1) [] + ieMerge _ _ = Nothing + + unwrapName :: IEWrappedName n -> n + unwrapName (IEName n) = unLocated n + unwrapName (IEPattern n) = unLocated n + unwrapName (IEType n) = unLocated n + -------------------------------------------------------------------------------- listPaddingValue :: Int -> ListPadding -> Int diff --git a/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs index b668e827..470b6796 100644 --- a/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs @@ -717,9 +717,9 @@ case21 = expected -------------------------------------------------------------------------------- case22 :: Assertion case22 = expected - @=? testStep (step (Just 80) defaultOptions) input' + @=? testSnippet (step (Just 80) defaultOptions) input' where - expected = unlines + expected = Snippet [ "{-# LANGUAGE PackageImports #-}" , "import A" , "import \"blah\" A" @@ -728,7 +728,7 @@ case22 = expected , "import \"foo\" B (shortName, someLongName, someLongerName," , " theLongestNameYet)" ] - input' = unlines + input' = Snippet [ "{-# LANGUAGE PackageImports #-}" , "import A" , "import \"foo\" A" From 514da218b254be8cca4b9003036e4b6b0dbc6ad0 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Mon, 21 Sep 2020 18:54:06 +0200 Subject: [PATCH 109/135] Refactor with ImportStats --- .../Haskell/Stylish/Step/ImportsGHC.hs | 118 +++++++++--------- .../Haskell/Stylish/Step/Imports/Tests.hs | 12 +- 2 files changed, 62 insertions(+), 68 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs b/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs index bd77cb09..032b68aa 100644 --- a/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs +++ b/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs @@ -50,19 +50,16 @@ printImports :: Maybe Int -> Options -> Lines -> Module -> Lines printImports maxCols align ls m = applyChanges changes ls where groups = moduleImportGroups m - moduleLongestImport = longestImport . fmap unLoc $ concatMap toList groups - moduleAnyQual = any isQualified . fmap unLoc $ concatMap toList groups + moduleStats = foldMap importStats . fmap unLoc $ concatMap toList groups changes = do group <- groups - pure $ formatGroup maxCols align m - moduleLongestImport moduleAnyQual group + pure $ formatGroup maxCols align m moduleStats group formatGroup - :: Maybe Int -> Options -> Module -> Int -> Bool + :: Maybe Int -> Options -> Module -> ImportStats -> NonEmpty (Located Import) -> Change String -formatGroup maxCols options m moduleLongestImport moduleAnyQual imports = - let newLines = formatImports maxCols options m - moduleLongestImport moduleAnyQual imports in +formatGroup maxCols options m moduleStats imports = + let newLines = formatImports maxCols options m moduleStats imports in change (importBlock imports) (const newLines) importBlock :: NonEmpty (Located a) -> Block String @@ -71,13 +68,12 @@ importBlock group = Block (getEndLineUnsafe $ NonEmpty.last group) formatImports - :: Maybe Int -- ^ Max columns. - -> Options -- ^ Options. - -> Module -- ^ Module. - -> Int -- ^ Longest import in module. - -> Bool -- ^ Qualified import is present in module. + :: Maybe Int -- ^ Max columns. + -> Options -- ^ Options. + -> Module -- ^ Module. + -> ImportStats -- ^ Module stats. -> NonEmpty (Located Import) -> Lines -formatImports maxCols options m moduleLongestImport moduleAnyQual rawGroup = +formatImports maxCols options m moduleStats rawGroup = runPrinter_ (PrinterConfig maxCols) [] m do let @@ -87,49 +83,48 @@ formatImports maxCols options m moduleLongestImport moduleAnyQual rawGroup = unLocatedGroup = fmap unLocated $ toList group - anyQual = any isQualified unLocatedGroup - align' = importAlign options padModuleNames' = padModuleNames options padNames = align' /= None && padModuleNames' - padQual = case align' of - Global -> True - File -> moduleAnyQual - Group -> anyQual - None -> False - longest = case align' of - Global -> moduleLongestImport - File -> moduleLongestImport - Group -> longestImport unLocatedGroup - None -> 0 + stats = case align' of + Global -> moduleStats {isAnyQualified = True} + File -> moduleStats + Group -> foldMap importStats unLocatedGroup + None -> mempty - forM_ group \imp -> printQualified options padQual padNames longest imp >> newline + forM_ group \imp -> printQualified options padNames stats imp >> newline -------------------------------------------------------------------------------- -printQualified :: Options -> Bool -> Bool -> Int -> Located Import -> P () -printQualified Options{..} padQual padNames longest (L _ decl) = do +printQualified :: Options -> Bool -> ImportStats -> Located Import -> P () +printQualified Options{..} padNames stats (L _ decl) = do let decl' = rawImport decl _listPadding' = listPaddingValue (6 + 1 + qualifiedLength) listPadding putText "import" >> space - when (isSource decl) (putText "{-# SOURCE #-}" >> space) + case (isSource decl, isAnySource stats) of + (True, _) -> putText "{-# SOURCE #-}" >> space + (_, True) -> putText " " >> space + _ -> pure () when (isSafe decl) (putText "safe" >> space) - when (isQualified decl) (putText "qualified" >> space) - - padQualified decl padQual + case (isQualified decl, isAnyQualified stats) of + (True, _) -> putText "qualified" >> space + (_, True) -> putText " " >> space + _ -> pure () moduleNamePosition <- length <$> getCurrentLine putText (moduleName decl) -- Only print spaces if something follows. - when (isJust (ideclAs decl') || isHiding decl || - not (null $ ideclHiding decl')) $ - padImportsList decl padNames longest + when padNames $ + when (isJust (ideclAs decl') || isHiding decl || + not (null $ ideclHiding decl')) $ + putText $ + replicate (isLongestImport stats - importModuleNameLength decl) ' ' beforeAliasPosition <- length <$> getCurrentLine forM_ (ideclAs decl') \(L _ name) -> @@ -239,7 +234,7 @@ printQualified Options{..} padQual padNames longest (L _ decl) = do _ -> id qualifiedDecl | isQualified decl = ["qualified"] - | padQual = + | isAnyQualified stats = if isSource decl then [] else if isSafe decl @@ -302,35 +297,34 @@ moduleName -------------------------------------------------------------------------------- -longestImport :: (Foldable f, Functor f) => f Import -> Int -longestImport xs = if null xs then 0 else maximum $ fmap importLength xs +data ImportStats = ImportStats + { isLongestImport :: !Int + , isAnySource :: !Bool + , isAnyQualified :: !Bool + , isAnySafe :: !Bool + } + +instance Semigroup ImportStats where + l <> r = ImportStats + { isLongestImport = isLongestImport l `max` isLongestImport r + , isAnySource = isAnySource l || isAnySource r + , isAnyQualified = isAnyQualified l || isAnyQualified r + , isAnySafe = isAnySafe l || isAnySafe r + } + +instance Monoid ImportStats where + mappend = (<>) + mempty = ImportStats 0 False False False + +importStats :: Import -> ImportStats +importStats i = + ImportStats (importModuleNameLength i) (isSource i) (isQualified i) (isSafe i) -- computes length till module name -importLength :: Import -> Int -importLength i = - let - srcLength | isSource i = length "{# SOURCE #}" - | otherwise = 0 - qualLength = length "qualified" - nameLength = length $ moduleName i - in - srcLength + qualLength + nameLength +importModuleNameLength :: Import -> Int +importModuleNameLength = length . moduleName -------------------------------------------------------------------------------- -padQualified :: Import -> Bool -> P () -padQualified i padQual = do - let pads = length "qualified" - if padQual && not (isQualified i) - then (putText $ replicate pads ' ') >> space - else pure () - -padImportsList :: Import -> Bool -> Int -> P () -padImportsList i padNames longest = do - let diff = longest - importLength i - if padNames - then putText $ replicate diff ' ' - else pure () - isQualified :: Import -> Bool isQualified = (/=) NotQualified diff --git a/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs index 470b6796..c9999cfe 100644 --- a/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs @@ -667,15 +667,15 @@ case19input = Snippet -------------------------------------------------------------------------------- case20 :: Assertion case20 = expected - @=? testStep (step (Just 80) defaultOptions) input' + @=? testSnippet (GHC.step (Just 80) defaultOptions) input' where - expected = unlines - [ "import {-# SOURCE #-} Data.ByteString as BS" - , "import qualified Data.Map as Map" - , "import Data.Set (empty)" + expected = Snippet + [ "import {-# SOURCE #-} Data.ByteString as BS" + , "import qualified Data.Map as Map" + , "import Data.Set (empty)" , "import {-# SOURCE #-} qualified Data.Text as T" ] - input' = unlines + input' = Snippet [ "import {-# SOURCE #-} Data.ByteString as BS" , "import {-# SOURCE #-} qualified Data.Text as T" , "import qualified Data.Map as Map" From 11530cf01991c33f99a4353db8453ca976a842ed Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Mon, 21 Sep 2020 19:25:49 +0200 Subject: [PATCH 110/135] Working package imports --- lib/Language/Haskell/Stylish/Module.hs | 2 ++ .../Haskell/Stylish/Step/ImportsGHC.hs | 21 +++++++++++++++++-- .../Haskell/Stylish/Step/Imports/Tests.hs | 2 +- 3 files changed, 22 insertions(+), 3 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Module.hs b/lib/Language/Haskell/Stylish/Module.hs index 7f1fd96e..3647f3c7 100644 --- a/lib/Language/Haskell/Stylish/Module.hs +++ b/lib/Language/Haskell/Stylish/Module.hs @@ -116,6 +116,8 @@ instance Eq Import where instance Ord Import where compare (Import i0) (Import i1) = ideclName i0 `compareOutputable` ideclName i1 <> + fmap showOutputable (ideclPkgQual i0) `compare` + fmap showOutputable (ideclPkgQual i1) <> compareOutputable i0 i1 -- | Comments associated with module diff --git a/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs b/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs index 032b68aa..3a725a86 100644 --- a/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs +++ b/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs @@ -23,6 +23,9 @@ import qualified Data.Set as Set -------------------------------------------------------------------------------- +import BasicTypes (StringLiteral (..), + SourceText (..)) +import qualified FastString as FS import GHC.Hs.Extension (GhcPs) import qualified GHC.Hs.Extension as GHC import GHC.Hs.ImpExp @@ -117,6 +120,7 @@ printQualified Options{..} padNames stats (L _ decl) = do _ -> pure () moduleNamePosition <- length <$> getCurrentLine + forM_ (ideclPkgQual decl') $ \pkg -> putText (stringLiteral pkg) >> space putText (moduleName decl) -- Only print spaces if something follows. @@ -320,9 +324,22 @@ importStats :: Import -> ImportStats importStats i = ImportStats (importModuleNameLength i) (isSource i) (isQualified i) (isSafe i) --- computes length till module name +-- Computes length till module name, includes package name. +-- TODO: this should reuse code with the printer importModuleNameLength :: Import -> Int -importModuleNameLength = length . moduleName +importModuleNameLength imp = + (case ideclPkgQual (rawImport imp) of + Nothing -> 0 + Just sl -> 1 + length (stringLiteral sl)) + + (length $ moduleName imp) + + +-------------------------------------------------------------------------------- +stringLiteral :: StringLiteral -> String +stringLiteral sl = case sl_st sl of + NoSourceText -> FS.unpackFS $ sl_fs sl + SourceText s -> s + -------------------------------------------------------------------------------- isQualified :: Import -> Bool diff --git a/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs index c9999cfe..ae35abbf 100644 --- a/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs @@ -717,7 +717,7 @@ case21 = expected -------------------------------------------------------------------------------- case22 :: Assertion case22 = expected - @=? testSnippet (step (Just 80) defaultOptions) input' + @=? testSnippet (GHC.step (Just 80) defaultOptions) input' where expected = Snippet [ "{-# LANGUAGE PackageImports #-}" From 1492fd4fd503312424a5af5b3dcb54f09241eade Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Wed, 23 Sep 2020 11:44:45 +0200 Subject: [PATCH 111/135] space_surround subtleties --- .../Haskell/Stylish/Step/ImportsGHC.hs | 29 +++++++++++++------ .../Haskell/Stylish/Step/Imports/Tests.hs | 8 +++-- 2 files changed, 25 insertions(+), 12 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs b/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs index 3a725a86..8c9be0d9 100644 --- a/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs +++ b/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs @@ -158,26 +158,29 @@ printQualified Options{..} padNames stats (L _ decl) = do -- Since we might need to output the import module name several times, we -- need to save it to a variable: wrapPrefix <- case listAlign of - AfterAlias -> pure $ replicate (afterAliasPosition + 2) ' ' + AfterAlias -> pure $ replicate (afterAliasPosition + 1) ' ' WithAlias -> pure $ replicate (beforeAliasPosition + 1) ' ' Repeat -> fmap (++ " (") getCurrentLine WithModuleName -> pure $ replicate (moduleNamePosition + offset) ' ' NewLine -> pure $ replicate offset ' ' - let -- Try to put everything on one line. + let -- Helper + doSpaceSurround = when spaceSurround space + + -- Try to put everything on one line. printAsSingleLine = forM_ printedImports $ \(imp, start, end) -> do - when start $ putText "(" + when start $ putText "(" >> doSpaceSurround imp - if end then putText ")" else comma >> space + if end then doSpaceSurround >> putText ")" else comma >> space -- Try to put everything one by one, wrapping if that fails. printAsInlineWrapping wprefix = forM_ printedImports $ \(imp, start, end) -> patchForRepeatHiding $ wrapping (do - if start then putText "(" else space + if start then putText "(" >> doSpaceSurround else space imp - if end then putText ")" else comma) + if end then doSpaceSurround >> putText ")" else comma) (do case listAlign of -- In 'Repeat' mode, end lines with ')' rather than ','. @@ -186,9 +189,18 @@ printQualified Options{..} padNames stats (L _ decl) = do _ -> pure () newline void wprefix + case listAlign of + Repeat -> pure () -- '(' already included in repeat + _ | start -> putText "(" >> doSpaceSurround + WithModuleName -> pure () + WithAlias -> pure () + AfterAlias -> space >> doSpaceSurround + NewLine -> pure () imp - if end then putText ")" else comma) - -- Put everything on a separate line. + if end then doSpaceSurround >> putText ")" else comma) + + -- Put everything on a separate line. 'spaceSurround' can be + -- ignored. printAsMultiLine = forM_ printedImports $ \(imp, start, end) -> do when start $ modifyCurrentLine trimRight -- We added some spaces. newline @@ -197,7 +209,6 @@ printQualified Options{..} padNames stats (L _ decl) = do imp when end $ newline >> putOffset >> putText ")" - when spaceSurround space case longListAlign of Multiline -> wrapping (space >> printAsSingleLine) diff --git a/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs index ae35abbf..cb02fcea 100644 --- a/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs @@ -170,6 +170,7 @@ case04 = expected @=? testSnippet (GHC.step (Just 80) $ fromImportAlign Global) case05 :: Assertion case05 = input' @=? testSnippet (GHC.step (Just 80) $ fromImportAlign Group) input' where + -- Putting this on a different line shouldn't really help. input' = Snippet ["import Distribution.PackageDescription.Configuration " ++ "(finalizePackageDescription)"] @@ -747,9 +748,10 @@ case23 = let options = Options None AfterAlias False Inline Inherit (LPConstant 4) True True False in - expected @=? testStep (step (Just 40) options) input' + expected @=? testSnippet (GHC.step (Just 40) options) input' where - expected = unlines + expected = Snippet + ---------------------------------------- [ "import Data.Acid ( AcidState )" , "import Data.Default.Class ( Default (def) )" , "" @@ -759,7 +761,7 @@ case23 = , " Goo )" ] - input' = unlines + input' = Snippet [ "import Data.Acid (AcidState)" , "import Data.Default.Class (Default(def))" , "" From 1d4c9ed148ece6983259f4151fca8f3cb3f51d66 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Wed, 23 Sep 2020 11:52:16 +0200 Subject: [PATCH 112/135] space_surround subtleties --- .../Haskell/Stylish/Step/ImportsGHC.hs | 35 +++---------------- .../Haskell/Stylish/Step/Imports/Tests.hs | 7 ++-- 2 files changed, 8 insertions(+), 34 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs b/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs index 8c9be0d9..282552db 100644 --- a/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs +++ b/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs @@ -101,9 +101,7 @@ formatImports maxCols options m moduleStats rawGroup = -------------------------------------------------------------------------------- printQualified :: Options -> Bool -> ImportStats -> Located Import -> P () printQualified Options{..} padNames stats (L _ decl) = do - let - decl' = rawImport decl - _listPadding' = listPaddingValue (6 + 1 + qualifiedLength) listPadding + let decl' = rawImport decl putText "import" >> space @@ -186,6 +184,9 @@ printQualified Options{..} padNames stats (L _ decl) = do -- In 'Repeat' mode, end lines with ')' rather than ','. Repeat | not start -> modifyCurrentLine . withLast $ \c -> if c == ',' then ')' else c + _ | start && spaceSurround -> + -- Only necessary if spaceSurround is enabled. + modifyCurrentLine trimRight _ -> pure () newline void wprefix @@ -229,35 +230,13 @@ printQualified Options{..} padNames stats (L _ decl) = do modifyCurrentLine trimRight newline >> putOffset >> printAsSingleLine) printAsMultiLine) - - -- when spaceSurround space - -- putText ")" where - {- - canSplit len = and - [ -- If the max cols have been surpassed, split: - maybe False (len >=) maxCols - -- Splitting a 'hiding' import changes the scope, don't split hiding: - , not (isHiding decl) - ] - -} - -- We cannot wrap/repeat 'hiding' imports since then we would get multiple -- imports hiding different things. patchForRepeatHiding = case listAlign of Repeat | isHiding decl -> withColumns Nothing _ -> id - qualifiedDecl | isQualified decl = ["qualified"] - | isAnyQualified stats = - if isSource decl - then [] - else if isSafe decl - then [" "] - else [" "] - | otherwise = [] - qualifiedLength = if null qualifiedDecl then 0 else 1 + sum (map length qualifiedDecl) - -------------------------------------------------------------------------------- printImport :: Options -> IE GhcPs -> P () @@ -444,12 +423,6 @@ prepareImportList = unwrapName (IEType n) = unLocated n --------------------------------------------------------------------------------- -listPaddingValue :: Int -> ListPadding -> Int -listPaddingValue _ (LPConstant n) = n -listPaddingValue n LPModuleName = n - - -------------------------------------------------------------------------------- nubOn :: Ord k => (a -> k) -> [a] -> [a] nubOn f = go Set.empty diff --git a/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs index cb02fcea..b396d2b1 100644 --- a/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs @@ -777,9 +777,10 @@ case23b = let options = Options None WithModuleName False Inline Inherit (LPConstant 4) True True False in - expected @=? testStep (step (Just 40) options) input' + expected @=? testSnippet (GHC.step (Just 40) options) input' where - expected = unlines + expected = Snippet + ---------------------------------------- [ "import Data.Acid ( AcidState )" , "import Data.Default.Class" , " ( Default (def) )" @@ -790,7 +791,7 @@ case23b = , " Goo )" ] - input' = unlines + input' = Snippet [ "import Data.Acid (AcidState)" , "import Data.Default.Class (Default(def))" , "" From 9df19ab51fff245d3390baa14b269c10586e8272 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Wed, 23 Sep 2020 11:59:27 +0200 Subject: [PATCH 113/135] space_surround subtleties --- lib/Language/Haskell/Stylish/Step/ImportsGHC.hs | 14 ++++++++++---- .../Language/Haskell/Stylish/Step/Imports/Tests.hs | 7 ++++--- 2 files changed, 14 insertions(+), 7 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs b/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs index 282552db..bec9af30 100644 --- a/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs +++ b/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs @@ -191,12 +191,18 @@ printQualified Options{..} padNames stats (L _ decl) = do newline void wprefix case listAlign of - Repeat -> pure () -- '(' already included in repeat + -- '(' already included in repeat + Repeat -> pure () + -- Print the much needed '(' _ | start -> putText "(" >> doSpaceSurround + -- Don't bother aligning if we're not in inline mode. + _ | longListAlign /= Inline -> pure () + -- 'Inline + AfterAlias' is really where we want to be careful + -- with spacing. + AfterAlias -> space >> doSpaceSurround WithModuleName -> pure () - WithAlias -> pure () - AfterAlias -> space >> doSpaceSurround - NewLine -> pure () + WithAlias -> pure () + NewLine -> pure () imp if end then doSpaceSurround >> putText ")" else comma) diff --git a/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs index b396d2b1..cc10814d 100644 --- a/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs @@ -807,9 +807,10 @@ case24 = let options = Options None AfterAlias False InlineWithBreak Inherit (LPConstant 4) True True False in - expected @=? testStep (step (Just 40) options) input' + expected @=? testSnippet (GHC.step (Just 40) options) input' where - expected = unlines + expected = Snippet + ---------------------------------------- [ "import Data.Acid ( AcidState )" , "import Data.Default.Class" , " ( Default (def) )" @@ -819,7 +820,7 @@ case24 = , " GooReallyLong )" ] - input' = unlines + input' = Snippet [ "import Data.Acid (AcidState)" , "import Data.Default.Class (Default(def))" , "" From 4885b95dd875f1dffa47877da5ce8e00d18da63d Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Wed, 23 Sep 2020 12:04:33 +0200 Subject: [PATCH 114/135] All import tests passing --- .../Haskell/Stylish/Step/Imports/Tests.hs | 20 ++++++++----------- 1 file changed, 8 insertions(+), 12 deletions(-) diff --git a/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs index cc10814d..62649934 100644 --- a/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs @@ -835,9 +835,9 @@ case25 = let options = Options Group AfterAlias False Multiline Inherit (LPConstant 4) False False False in - expected @=? testStep (step (Just 80) options) input' + expected @=? testSnippet (GHC.step (Just 80) options) input' where - expected = unlines + expected = Snippet [ "import Data.Acid (AcidState)" , "import Data.Default.Class (Default(def))" , "" @@ -846,7 +846,7 @@ case25 = , "" , "import Data.Foo (Foo(Bar, Foo), Goo(Goo))" ] - input' = unlines + input' = Snippet [ "import Data.Acid (AcidState)" , "import Data.Default.Class (Default(def))" , "" @@ -860,22 +860,18 @@ case25 = -------------------------------------------------------------------------------- case26 :: Assertion case26 = expected - @=? testStep (step (Just 80) options ) input' + @=? testSnippet (GHC.step (Just 80) options ) input' where options = defaultOptions { listAlign = NewLine, longListAlign = Multiline } - input' = unlines - [ "import Data.List" - ] - expected = unlines - [ "import Data.List" - ] + input' = Snippet ["import Data.List"] + expected = Snippet ["import Data.List"] -------------------------------------------------------------------------------- case27 :: Assertion -case27 = expected @=? testStep (step Nothing $ fromImportAlign Global) input +case27 = expected @=? testSnippet (GHC.step Nothing $ fromImportAlign Global) inputSnippet where - expected = unlines + expected = Snippet [ "module Herp where" , "" , "import Control.Monad" From d1d474bd88a9eb576c05be93bad952e21d335dff Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Wed, 23 Sep 2020 12:08:09 +0200 Subject: [PATCH 115/135] Refactor old tests a little --- .../Haskell/Stylish/Step/ImportsGHC.hs | 6 ++ .../Haskell/Stylish/Step/Imports/Tests.hs | 89 +++++++++---------- 2 files changed, 47 insertions(+), 48 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs b/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs index bec9af30..e1e03e01 100644 --- a/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs +++ b/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs @@ -4,6 +4,12 @@ {-# LANGUAGE RecordWildCards #-} module Language.Haskell.Stylish.Step.ImportsGHC ( Options (..) + , defaultOptions + , ImportAlign (..) + , ListAlign (..) + , LongListAlign (..) + , EmptyListAlign (..) + , ListPadding (..) , step ) where diff --git a/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs index 62649934..ed65824b 100644 --- a/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs @@ -5,18 +5,16 @@ module Language.Haskell.Stylish.Step.Imports.Tests -------------------------------------------------------------------------------- -import Test.Framework (Test, testGroup) -import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit (Assertion, (@=?)) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit (Assertion, (@=?)) -------------------------------------------------------------------------------- -import Language.Haskell.Stylish.Step.Imports -import qualified Language.Haskell.Stylish.Step.ImportsGHC as GHC +import Language.Haskell.Stylish.Step.ImportsGHC import Language.Haskell.Stylish.Tests.Util - -------------------------------------------------------------------------------- fromImportAlign :: ImportAlign -> Options fromImportAlign align = defaultOptions { importAlign = align } @@ -64,13 +62,8 @@ tests = testGroup "Language.Haskell.Stylish.Step.Imports.Tests" -------------------------------------------------------------------------------- -inputSnippet :: Snippet -inputSnippet = Snippet $ lines input - - --------------------------------------------------------------------------------- -input :: String -input = unlines +input :: Snippet +input = Snippet [ "module Herp where" , "" , "import qualified Data.Map as M" @@ -89,7 +82,7 @@ input = unlines -------------------------------------------------------------------------------- case01 :: Assertion -case01 = expected @=? testSnippet (GHC.step (Just 80) $ fromImportAlign Global) inputSnippet +case01 = expected @=? testSnippet (step (Just 80) $ fromImportAlign Global) input where expected = Snippet [ "module Herp where" @@ -111,7 +104,7 @@ case01 = expected @=? testSnippet (GHC.step (Just 80) $ fromImportAlign Global) -------------------------------------------------------------------------------- case02 :: Assertion -case02 = expected @=? testSnippet (GHC.step (Just 80) $ fromImportAlign Group) inputSnippet +case02 = expected @=? testSnippet (step (Just 80) $ fromImportAlign Group) input where expected = Snippet [ "module Herp where" @@ -132,7 +125,7 @@ case02 = expected @=? testSnippet (GHC.step (Just 80) $ fromImportAlign Group) i -------------------------------------------------------------------------------- case03 :: Assertion -case03 = expected @=? testSnippet (GHC.step (Just 80) $ fromImportAlign None) inputSnippet +case03 = expected @=? testSnippet (step (Just 80) $ fromImportAlign None) input where expected = Snippet [ "module Herp where" @@ -153,7 +146,7 @@ case03 = expected @=? testSnippet (GHC.step (Just 80) $ fromImportAlign None) in -------------------------------------------------------------------------------- case04 :: Assertion -case04 = expected @=? testSnippet (GHC.step (Just 80) $ fromImportAlign Global) input' +case04 = expected @=? testSnippet (step (Just 80) $ fromImportAlign Global) input' where input' = Snippet $ pure $ "import Data.Aeson.Types (object, typeMismatch, FromJSON(..)," ++ @@ -168,7 +161,7 @@ case04 = expected @=? testSnippet (GHC.step (Just 80) $ fromImportAlign Global) -------------------------------------------------------------------------------- case05 :: Assertion -case05 = input' @=? testSnippet (GHC.step (Just 80) $ fromImportAlign Group) input' +case05 = input' @=? testSnippet (step (Just 80) $ fromImportAlign Group) input' where -- Putting this on a different line shouldn't really help. input' = Snippet ["import Distribution.PackageDescription.Configuration " ++ @@ -177,7 +170,7 @@ case05 = input' @=? testSnippet (GHC.step (Just 80) $ fromImportAlign Group) inp -------------------------------------------------------------------------------- case06 :: Assertion -case06 = input' @=? testStep' (GHC.step (Just 80) $ fromImportAlign File) input' +case06 = input' @=? testStep' (step (Just 80) $ fromImportAlign File) input' where input' = [ "import Bar.Qux" @@ -188,7 +181,7 @@ case06 = input' @=? testStep' (GHC.step (Just 80) $ fromImportAlign File) input' -------------------------------------------------------------------------------- case07 :: Assertion case07 = - expected @=? testSnippet (GHC.step (Just 80) $ fromImportAlign File) input' + expected @=? testSnippet (step (Just 80) $ fromImportAlign File) input' where input' = Snippet [ "import Bar.Qux" @@ -209,7 +202,7 @@ case08 = let options = Options Global WithAlias True Inline Inherit (LPConstant 4) True False False in - expected @=? testSnippet (GHC.step (Just 80) options) inputSnippet + expected @=? testSnippet (step (Just 80) options) input where expected = Snippet [ "module Herp where" @@ -235,7 +228,7 @@ case08b = let options = Options Global WithModuleName True Inline Inherit (LPConstant 4) True False False in - expected @=? testSnippet (GHC.step (Just 80) options) inputSnippet + expected @=? testSnippet (step (Just 80) options) input where expected = Snippet ["module Herp where" @@ -260,7 +253,7 @@ case09 = let options = Options Global WithAlias True Multiline Inherit (LPConstant 4) True False False in - expected @=? testSnippet (GHC.step (Just 80) options) inputSnippet + expected @=? testSnippet (step (Just 80) options) input where expected = Snippet [ "module Herp where" @@ -297,7 +290,7 @@ case10 = let options = Options Group WithAlias True Multiline Inherit (LPConstant 4) True False False in - expected @=? testSnippet (GHC.step (Just 40) options) inputSnippet + expected @=? testSnippet (step (Just 40) options) input where expected = Snippet [ "module Herp where" @@ -340,7 +333,7 @@ case11 = let options = Options Group NewLine True Inline Inherit (LPConstant 4) True False False in - expected @=? testSnippet (GHC.step (Just 80) options) inputSnippet + expected @=? testSnippet (step (Just 80) options) input where expected = Snippet [ "module Herp where" @@ -370,7 +363,7 @@ case11b = let options = Options Group WithModuleName True Inline Inherit (LPConstant 4) True False False in - expected @=? testSnippet (GHC.step (Just 80) options) inputSnippet + expected @=? testSnippet (step (Just 80) options) input where expected = Snippet [ "module Herp where" @@ -395,7 +388,7 @@ case12 = let options = Options Group NewLine True Inline Inherit (LPConstant 2) True False False in - expected @=? testSnippet (GHC.step (Just 80) options) input' + expected @=? testSnippet (step (Just 80) options) input' where input' = Snippet [ "import Data.List (map)" @@ -413,7 +406,7 @@ case12b = let options = Options Group WithModuleName True Inline Inherit (LPConstant 2) True False False in - expected @=? testStep' (GHC.step (Just 80) options) input' + expected @=? testStep' (step (Just 80) options) input' where input' = ["import Data.List (map)"] @@ -426,7 +419,7 @@ case13 = let options = Options None WithAlias True InlineWithBreak Inherit (LPConstant 4) True False False in - expected @=? testSnippet (GHC.step (Just 80) options) input' + expected @=? testSnippet (step (Just 80) options) input' where input' = Snippet [ "import qualified Data.List as List (concat, foldl, foldr, head, init," @@ -446,7 +439,7 @@ case13b = let options = Options None WithModuleName True InlineWithBreak Inherit (LPConstant 4) True False False in - expected @=? testSnippet (GHC.step (Just 80) options) input' + expected @=? testSnippet (step (Just 80) options) input' where input' = Snippet [ "import qualified Data.List as List (concat, foldl, foldr, head, init," @@ -466,7 +459,7 @@ case14 = let options = Options None WithAlias True InlineWithBreak Inherit (LPConstant 10) True False False in - expected @=? testSnippet (GHC.step (Just 80) options) expected + expected @=? testSnippet (step (Just 80) options) expected where expected = Snippet [ "import qualified Data.List as List (concat, map, null, reverse, tail, (++))" @@ -479,7 +472,7 @@ case15 = let options = Options None AfterAlias True Multiline Inherit (LPConstant 4) True False False in - expected @=? testSnippet (GHC.step (Just 80) options) input' + expected @=? testSnippet (step (Just 80) options) input' where expected = Snippet [ "import Data.Acid (AcidState)" @@ -508,7 +501,7 @@ case16 = let options = Options None AfterAlias True Multiline Inherit (LPConstant 4) False False False in - expected @=? testSnippet (GHC.step (Just 80) options) input' + expected @=? testSnippet (step (Just 80) options) input' where expected = Snippet [ "import Data.Acid (AcidState)" @@ -535,7 +528,7 @@ case17 = let options = Options None AfterAlias True Multiline Inherit (LPConstant 4) True False False in - expected @=? testSnippet (GHC.step (Just 80) options) input' + expected @=? testSnippet (step (Just 80) options) input' where expected = Snippet [ "import Control.Applicative (Applicative (pure, (<*>)))" @@ -556,7 +549,7 @@ case18 = let options = Options None AfterAlias True InlineToMultiline Inherit (LPConstant 4) True False False in - expected @=? testSnippet (GHC.step (Just 40) options) input' + expected @=? testSnippet (step (Just 40) options) input' where expected = Snippet ---------------------------------------- @@ -587,7 +580,7 @@ case19 = let options = Options Global NewLine True InlineWithBreak RightAfter (LPConstant 17) True False False in - expected @=? testSnippet (GHC.step (Just 40) options) case19input + expected @=? testSnippet (step (Just 40) options) case19input where expected = Snippet ---------------------------------------- @@ -606,7 +599,7 @@ case19b = let options = Options File NewLine True InlineWithBreak RightAfter (LPConstant 17) True False False in - expected @=? testSnippet (GHC.step (Just 40) options) case19input + expected @=? testSnippet (step (Just 40) options) case19input where expected = Snippet ---------------------------------------- @@ -624,7 +617,7 @@ case19c = let options = Options File NewLine True InlineWithBreak RightAfter LPModuleName True False False in - expected @=? testSnippet (GHC.step (Just 40) options) case19input + expected @=? testSnippet (step (Just 40) options) case19input where expected = Snippet ---------------------------------------- @@ -642,7 +635,7 @@ case19d = let options = Options Global NewLine True InlineWithBreak RightAfter LPModuleName True False False in - expected @=? testSnippet (GHC.step (Just 40) options) case19input + expected @=? testSnippet (step (Just 40) options) case19input where expected = Snippet ---------------------------------------- @@ -668,7 +661,7 @@ case19input = Snippet -------------------------------------------------------------------------------- case20 :: Assertion case20 = expected - @=? testSnippet (GHC.step (Just 80) defaultOptions) input' + @=? testSnippet (step (Just 80) defaultOptions) input' where expected = Snippet [ "import {-# SOURCE #-} Data.ByteString as BS" @@ -687,7 +680,7 @@ case20 = expected -------------------------------------------------------------------------------- case21 :: Assertion case21 = expected - @=? testSnippet (GHC.step (Just 80) defaultOptions) input' + @=? testSnippet (step (Just 80) defaultOptions) input' where expected = Snippet [ "{-# LANGUAGE ExplicitNamespaces #-}" @@ -718,7 +711,7 @@ case21 = expected -------------------------------------------------------------------------------- case22 :: Assertion case22 = expected - @=? testSnippet (GHC.step (Just 80) defaultOptions) input' + @=? testSnippet (step (Just 80) defaultOptions) input' where expected = Snippet [ "{-# LANGUAGE PackageImports #-}" @@ -748,7 +741,7 @@ case23 = let options = Options None AfterAlias False Inline Inherit (LPConstant 4) True True False in - expected @=? testSnippet (GHC.step (Just 40) options) input' + expected @=? testSnippet (step (Just 40) options) input' where expected = Snippet ---------------------------------------- @@ -777,7 +770,7 @@ case23b = let options = Options None WithModuleName False Inline Inherit (LPConstant 4) True True False in - expected @=? testSnippet (GHC.step (Just 40) options) input' + expected @=? testSnippet (step (Just 40) options) input' where expected = Snippet ---------------------------------------- @@ -807,7 +800,7 @@ case24 = let options = Options None AfterAlias False InlineWithBreak Inherit (LPConstant 4) True True False in - expected @=? testSnippet (GHC.step (Just 40) options) input' + expected @=? testSnippet (step (Just 40) options) input' where expected = Snippet ---------------------------------------- @@ -835,7 +828,7 @@ case25 = let options = Options Group AfterAlias False Multiline Inherit (LPConstant 4) False False False in - expected @=? testSnippet (GHC.step (Just 80) options) input' + expected @=? testSnippet (step (Just 80) options) input' where expected = Snippet [ "import Data.Acid (AcidState)" @@ -860,7 +853,7 @@ case25 = -------------------------------------------------------------------------------- case26 :: Assertion case26 = expected - @=? testSnippet (GHC.step (Just 80) options ) input' + @=? testSnippet (step (Just 80) options ) input' where options = defaultOptions { listAlign = NewLine, longListAlign = Multiline } input' = Snippet ["import Data.List"] @@ -869,7 +862,7 @@ case26 = expected -------------------------------------------------------------------------------- case27 :: Assertion -case27 = expected @=? testSnippet (GHC.step Nothing $ fromImportAlign Global) inputSnippet +case27 = expected @=? testSnippet (step Nothing $ fromImportAlign Global) input where expected = Snippet [ "module Herp where" From 8b7d8078397212a5e23bab7ba80ca1bb888cb804 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Thu, 24 Sep 2020 16:44:28 +0200 Subject: [PATCH 116/135] Rip out old imports module --- lib/Language/Haskell/Stylish/Config.hs | 22 +- lib/Language/Haskell/Stylish/Step/Imports.hs | 766 ++++++++++-------- .../Haskell/Stylish/Step/ImportsGHC.hs | 447 ---------- stylish-haskell.cabal | 4 +- .../Tests.hs => Imports/FelixTests.hs} | 19 +- .../Haskell/Stylish/Step/Imports/Tests.hs | 8 +- tests/TestSuite.hs | 4 +- 7 files changed, 432 insertions(+), 838 deletions(-) delete mode 100644 lib/Language/Haskell/Stylish/Step/ImportsGHC.hs rename tests/Language/Haskell/Stylish/Step/{ImportsGHC/Tests.hs => Imports/FelixTests.hs} (94%) diff --git a/lib/Language/Haskell/Stylish/Config.hs b/lib/Language/Haskell/Stylish/Config.hs index cfc13b1e..4872f63e 100644 --- a/lib/Language/Haskell/Stylish/Config.hs +++ b/lib/Language/Haskell/Stylish/Config.hs @@ -1,5 +1,6 @@ -------------------------------------------------------------------------------- {-# LANGUAGE BlockArguments #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} module Language.Haskell.Stylish.Config @@ -42,7 +43,6 @@ import Language.Haskell.Stylish.Config.Internal import Language.Haskell.Stylish.Step import qualified Language.Haskell.Stylish.Step.Data as Data import qualified Language.Haskell.Stylish.Step.Imports as Imports -import qualified Language.Haskell.Stylish.Step.ImportsGHC as ImportsGHC import qualified Language.Haskell.Stylish.Step.ModuleHeader as ModuleHeader import qualified Language.Haskell.Stylish.Step.LanguagePragmas as LanguagePragmas import qualified Language.Haskell.Stylish.Step.SimpleAlign as SimpleAlign @@ -247,26 +247,17 @@ parseSquash _ _ = return Squash.step -------------------------------------------------------------------------------- parseImports :: Config -> A.Object -> A.Parser Step -parseImports config o = do - cfg <- - Imports.Options +parseImports config o = fmap (Imports.step columns) $ Imports.Options <$> (o A..:? "align" >>= parseEnum aligns (def Imports.importAlign)) <*> (o A..:? "list_align" >>= parseEnum listAligns (def Imports.listAlign)) <*> (o A..:? "pad_module_names" A..!= def Imports.padModuleNames) <*> (o A..:? "long_list_align" >>= parseEnum longListAligns (def Imports.longListAlign)) - -- Note that padding has to be at least 1. Default is 4. <*> (o A..:? "empty_list_align" >>= parseEnum emptyListAligns (def Imports.emptyListAlign)) - <*> o A..:? "list_padding" A..!= def Imports.listPadding + -- Note that padding has to be at least 1. Default is 4. + <*> (o A..:? "list_padding" >>= maybe (pure $ def Imports.listPadding) parseListPadding) <*> o A..:? "separate_lists" A..!= def Imports.separateLists <*> o A..:? "space_surround" A..!= def Imports.spaceSurround <*> o A..:? "ghc_lib_parser" A..!= True - - pure - if Imports.useGhcLibParser cfg then - ImportsGHC.step columns cfg - else - Imports.step columns cfg - where def f = f Imports.defaultOptions @@ -299,6 +290,11 @@ parseImports config o = do , ("right_after", Imports.RightAfter) ] + parseListPadding = \case + A.String "module_name" -> pure Imports.LPModuleName + A.Number n | n >= 1 -> pure $ Imports.LPConstant (truncate n) + v -> A.typeMismatch "'module_name' or >=1 number" v + -------------------------------------------------------------------------------- parseLanguagePragmas :: Config -> A.Object -> A.Parser Step parseLanguagePragmas config o = LanguagePragmas.step diff --git a/lib/Language/Haskell/Stylish/Step/Imports.hs b/lib/Language/Haskell/Stylish/Step/Imports.hs index 7f633c77..65f1e0b3 100644 --- a/lib/Language/Haskell/Stylish/Step/Imports.hs +++ b/lib/Language/Haskell/Stylish/Step/Imports.hs @@ -1,38 +1,55 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} --------------------------------------------------------------------------------- +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DoAndIfThenElse #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} module Language.Haskell.Stylish.Step.Imports - ( Options (..) - , defaultOptions - , ImportAlign (..) - , ListAlign (..) - , LongListAlign (..) - , EmptyListAlign (..) - , ListPadding (..) - , step - ) where - + ( Options (..) + , defaultOptions + , ImportAlign (..) + , ListAlign (..) + , LongListAlign (..) + , EmptyListAlign (..) + , ListPadding (..) + , step + ) where -------------------------------------------------------------------------------- -import Control.Arrow ((&&&)) -import Control.Monad (void) -import qualified Data.Aeson as A -import qualified Data.Aeson.Types as A -import Data.Char (toLower) -import Data.List (intercalate, sortBy) -import qualified Data.Map as M -import Data.Maybe (isJust, maybeToList) +import Control.Monad (forM_, when, void) +import Data.Char (isUpper) +import Data.Function ((&)) +import Data.Functor (($>)) +import Data.Foldable (toList) import Data.Ord (comparing) -import qualified Data.Set as S -import qualified Language.Haskell.Exts as H +import Data.Maybe (isJust) +import Data.List (sortBy, sortOn) +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Map as Map +import qualified Data.Set as Set + + +-------------------------------------------------------------------------------- +import BasicTypes (StringLiteral (..), + SourceText (..)) +import qualified FastString as FS +import GHC.Hs.Extension (GhcPs) +import qualified GHC.Hs.Extension as GHC +import GHC.Hs.ImpExp +import Module (moduleNameString) +import RdrName (RdrName) +import SrcLoc (Located, GenLocated(..), unLoc) -------------------------------------------------------------------------------- import Language.Haskell.Stylish.Block -import Language.Haskell.Stylish.Editor +import Language.Haskell.Stylish.Module +import Language.Haskell.Stylish.Printer import Language.Haskell.Stylish.Step +import Language.Haskell.Stylish.Editor +import Language.Haskell.Stylish.GHC import Language.Haskell.Stylish.Util + -------------------------------------------------------------------------------- data Options = Options { importAlign :: ImportAlign @@ -93,369 +110,398 @@ data LongListAlign -------------------------------------------------------------------------------- - -modifyImportSpecs :: ([H.ImportSpec l] -> [H.ImportSpec l]) - -> H.ImportDecl l -> H.ImportDecl l -modifyImportSpecs f imp = imp {H.importSpecs = f' <$> H.importSpecs imp} - where - f' (H.ImportSpecList l h specs) = H.ImportSpecList l h (f specs) - - --------------------------------------------------------------------------------- -imports :: H.Module l -> [H.ImportDecl l] -imports (H.Module _ _ _ is _) = is -imports _ = [] - - --------------------------------------------------------------------------------- -importName :: H.ImportDecl l -> String -importName i = let (H.ModuleName _ n) = H.importModule i in n - -importPackage :: H.ImportDecl l -> Maybe String -importPackage i = H.importPkg i - - --------------------------------------------------------------------------------- --- | A "compound import name" is import's name and package (if present). For --- instance, if you have an import @Foo.Bar@ from package @foobar@, the full --- name will be @"foobar" Foo.Bar@. -compoundImportName :: H.ImportDecl l -> String -compoundImportName i = - case importPackage i of - Nothing -> importName i - Just pkg -> show pkg ++ " " ++ importName i - - --------------------------------------------------------------------------------- -longestImport :: [H.ImportDecl l] -> Int -longestImport = maximum . map (length . compoundImportName) - - --------------------------------------------------------------------------------- --- | Compare imports for ordering -compareImports :: H.ImportDecl l -> H.ImportDecl l -> Ordering -compareImports = - comparing (map toLower . importName &&& - fmap (map toLower) . importPackage &&& - H.importQualified) +step :: Maybe Int -> Options -> Step +step columns = makeStep "Imports (ghc-lib-parser)" . printImports columns -------------------------------------------------------------------------------- --- | Remove (or merge) duplicated import specs. --- --- * When something is mentioned twice, it's removed: @A, A@ -> A --- * More general forms take priority: @A, A(..)@ -> @A(..)@ --- * Sometimes we have to combine imports: @A(x), A(y)@ -> @A(x, y)@ --- --- Import specs are always sorted by subsequent steps so we don't have to care --- about preserving order. -deduplicateImportSpecs :: Ord l => H.ImportDecl l -> H.ImportDecl l -deduplicateImportSpecs = - modifyImportSpecs $ - map recomposeImportSpec . - M.toList . M.fromListWith (<>) . - map decomposeImportSpec - --- | What we are importing (variable, class, etc) -data ImportEntity l - -- | A variable - = ImportVar l (H.Name l) - -- | Something that can be imported partially - | ImportClassOrData l (H.Name l) - -- | Something else ('H.IAbs') - | ImportOther l (H.Namespace l) (H.Name l) - deriving (Eq, Ord) - --- | What we are importing from an 'ImportClassOrData' -data ImportPortion l - = ImportSome [H.CName l] -- ^ @A(x, y, z)@ - | ImportAll -- ^ @A(..)@ - -instance Ord l => Semigroup (ImportPortion l) where - ImportSome a <> ImportSome b = ImportSome (setUnion a b) - _ <> _ = ImportAll - -instance Ord l => Monoid (ImportPortion l) where - mempty = ImportSome [] - mappend = (<>) - --- | O(n log n) union. -setUnion :: Ord a => [a] -> [a] -> [a] -setUnion a b = S.toList (S.fromList a `S.union` S.fromList b) - -decomposeImportSpec :: H.ImportSpec l -> (ImportEntity l, ImportPortion l) -decomposeImportSpec x = case x of - -- I checked and it looks like namespace's 'l' is always equal to x's 'l' - H.IAbs l space n -> case space of - H.NoNamespace _ -> (ImportClassOrData l n, ImportSome []) - H.TypeNamespace _ -> (ImportOther l space n, ImportSome []) - H.PatternNamespace _ -> (ImportOther l space n, ImportSome []) - H.IVar l n -> (ImportVar l n, ImportSome []) - H.IThingAll l n -> (ImportClassOrData l n, ImportAll) - H.IThingWith l n names -> (ImportClassOrData l n, ImportSome names) - -recomposeImportSpec :: (ImportEntity l, ImportPortion l) -> H.ImportSpec l -recomposeImportSpec (e, p) = case e of - ImportClassOrData l n -> case p of - ImportSome [] -> H.IAbs l (H.NoNamespace l) n - ImportSome names -> H.IThingWith l n names - ImportAll -> H.IThingAll l n - ImportVar l n -> H.IVar l n - ImportOther l space n -> H.IAbs l space n - +printImports :: Maybe Int -> Options -> Lines -> Module -> Lines +printImports maxCols align ls m = applyChanges changes ls + where + groups = moduleImportGroups m + moduleStats = foldMap importStats . fmap unLoc $ concatMap toList groups + changes = do + group <- groups + pure $ formatGroup maxCols align m moduleStats group + +formatGroup + :: Maybe Int -> Options -> Module -> ImportStats + -> NonEmpty (Located Import) -> Change String +formatGroup maxCols options m moduleStats imports = + let newLines = formatImports maxCols options m moduleStats imports in + change (importBlock imports) (const newLines) + +importBlock :: NonEmpty (Located a) -> Block String +importBlock group = Block + (getStartLineUnsafe $ NonEmpty.head group) + (getEndLineUnsafe $ NonEmpty.last group) + +formatImports + :: Maybe Int -- ^ Max columns. + -> Options -- ^ Options. + -> Module -- ^ Module. + -> ImportStats -- ^ Module stats. + -> NonEmpty (Located Import) -> Lines +formatImports maxCols options m moduleStats rawGroup = + runPrinter_ (PrinterConfig maxCols) [] m do + let + + group + = NonEmpty.sortWith unLocated rawGroup + & mergeImports + + unLocatedGroup = fmap unLocated $ toList group + + align' = importAlign options + padModuleNames' = padModuleNames options + padNames = align' /= None && padModuleNames' + + stats = case align' of + Global -> moduleStats {isAnyQualified = True} + File -> moduleStats + Group -> foldMap importStats unLocatedGroup + None -> mempty + + forM_ group \imp -> printQualified options padNames stats imp >> newline -------------------------------------------------------------------------------- --- | The implementation is a bit hacky to get proper sorting for input specs: --- constructors first, followed by functions, and then operators. -compareImportSpecs :: H.ImportSpec l -> H.ImportSpec l -> Ordering -compareImportSpecs = comparing key +printQualified :: Options -> Bool -> ImportStats -> Located Import -> P () +printQualified Options{..} padNames stats (L _ decl) = do + let decl' = rawImport decl + + putText "import" >> space + + case (isSource decl, isAnySource stats) of + (True, _) -> putText "{-# SOURCE #-}" >> space + (_, True) -> putText " " >> space + _ -> pure () + + when (isSafe decl) (putText "safe" >> space) + + case (isQualified decl, isAnyQualified stats) of + (True, _) -> putText "qualified" >> space + (_, True) -> putText " " >> space + _ -> pure () + + moduleNamePosition <- length <$> getCurrentLine + forM_ (ideclPkgQual decl') $ \pkg -> putText (stringLiteral pkg) >> space + putText (moduleName decl) + + -- Only print spaces if something follows. + when padNames $ + when (isJust (ideclAs decl') || isHiding decl || + not (null $ ideclHiding decl')) $ + putText $ + replicate (isLongestImport stats - importModuleNameLength decl) ' ' + + beforeAliasPosition <- length <$> getCurrentLine + forM_ (ideclAs decl') \(L _ name) -> + space >> putText "as" >> space >> putText (moduleNameString name) + afterAliasPosition <- length <$> getCurrentLine + + when (isHiding decl) (space >> putText "hiding") + + let putOffset = putText $ replicate offset ' ' + offset = case listPadding of + LPConstant n -> n + LPModuleName -> moduleNamePosition + + case snd <$> ideclHiding decl' of + Nothing -> pure () + Just (L _ []) -> case emptyListAlign of + RightAfter -> modifyCurrentLine trimRight >> space >> putText "()" + Inherit -> case listAlign of + NewLine -> + modifyCurrentLine trimRight >> newline >> putOffset >> putText "()" + _ -> space >> putText "()" + Just (L _ imports) -> do + let printedImports = flagEnds $ -- [P ()] + fmap ((printImport Options{..}) . unLocated) + (prepareImportList imports) + + -- Since we might need to output the import module name several times, we + -- need to save it to a variable: + wrapPrefix <- case listAlign of + AfterAlias -> pure $ replicate (afterAliasPosition + 1) ' ' + WithAlias -> pure $ replicate (beforeAliasPosition + 1) ' ' + Repeat -> fmap (++ " (") getCurrentLine + WithModuleName -> pure $ replicate (moduleNamePosition + offset) ' ' + NewLine -> pure $ replicate offset ' ' + + let -- Helper + doSpaceSurround = when spaceSurround space + + -- Try to put everything on one line. + printAsSingleLine = forM_ printedImports $ \(imp, start, end) -> do + when start $ putText "(" >> doSpaceSurround + imp + if end then doSpaceSurround >> putText ")" else comma >> space + + -- Try to put everything one by one, wrapping if that fails. + printAsInlineWrapping wprefix = forM_ printedImports $ + \(imp, start, end) -> + patchForRepeatHiding $ wrapping + (do + if start then putText "(" >> doSpaceSurround else space + imp + if end then doSpaceSurround >> putText ")" else comma) + (do + case listAlign of + -- In 'Repeat' mode, end lines with ')' rather than ','. + Repeat | not start -> modifyCurrentLine . withLast $ + \c -> if c == ',' then ')' else c + _ | start && spaceSurround -> + -- Only necessary if spaceSurround is enabled. + modifyCurrentLine trimRight + _ -> pure () + newline + void wprefix + case listAlign of + -- '(' already included in repeat + Repeat -> pure () + -- Print the much needed '(' + _ | start -> putText "(" >> doSpaceSurround + -- Don't bother aligning if we're not in inline mode. + _ | longListAlign /= Inline -> pure () + -- 'Inline + AfterAlias' is really where we want to be careful + -- with spacing. + AfterAlias -> space >> doSpaceSurround + WithModuleName -> pure () + WithAlias -> pure () + NewLine -> pure () + imp + if end then doSpaceSurround >> putText ")" else comma) + + -- Put everything on a separate line. 'spaceSurround' can be + -- ignored. + printAsMultiLine = forM_ printedImports $ \(imp, start, end) -> do + when start $ modifyCurrentLine trimRight -- We added some spaces. + newline + putOffset + if start then putText "( " else putText ", " + imp + when end $ newline >> putOffset >> putText ")" + + case longListAlign of + Multiline -> wrapping + (space >> printAsSingleLine) + printAsMultiLine + Inline | NewLine <- listAlign -> do + modifyCurrentLine trimRight + newline >> putOffset >> printAsInlineWrapping (putText wrapPrefix) + Inline -> space >> printAsInlineWrapping (putText wrapPrefix) + InlineWithBreak -> wrapping + (space >> printAsSingleLine) + (do + modifyCurrentLine trimRight + newline >> putOffset >> printAsInlineWrapping putOffset) + InlineToMultiline -> wrapping + (space >> printAsSingleLine) + (wrapping + (do + modifyCurrentLine trimRight + newline >> putOffset >> printAsSingleLine) + printAsMultiLine) where - key :: H.ImportSpec l -> (Int, Bool, String) - key (H.IVar _ x) = (1, isOperator x, nameToString x) - key (H.IAbs _ _ x) = (0, False, nameToString x) - key (H.IThingAll _ x) = (0, False, nameToString x) - key (H.IThingWith _ x _) = (0, False, nameToString x) + -- We cannot wrap/repeat 'hiding' imports since then we would get multiple + -- imports hiding different things. + patchForRepeatHiding = case listAlign of + Repeat | isHiding decl -> withColumns Nothing + _ -> id -------------------------------------------------------------------------------- --- | Sort the input spec list inside an 'H.ImportDecl' -sortImportSpecs :: H.ImportDecl l -> H.ImportDecl l -sortImportSpecs = modifyImportSpecs (sortBy compareImportSpecs) - +printImport :: Options -> IE GhcPs -> P () +printImport Options{..} (IEVar _ name) = do + printIeWrappedName name +printImport _ (IEThingAbs _ name) = do + printIeWrappedName name +printImport _ (IEThingAll _ name) = do + printIeWrappedName name + space + putText "(..)" +printImport _ (IEModuleContents _ (L _ m)) = do + putText (moduleNameString m) +printImport Options{..} (IEThingWith _ name _wildcard imps _) = do + printIeWrappedName name + when separateLists space + parenthesize $ + sep (comma >> space) (printIeWrappedName <$> imps) +printImport _ (IEGroup _ _ _ ) = + error "Language.Haskell.Stylish.Printer.Imports.printImportExport: unhandled case 'IEGroup'" +printImport _ (IEDoc _ _) = + error "Language.Haskell.Stylish.Printer.Imports.printImportExport: unhandled case 'IEDoc'" +printImport _ (IEDocNamed _ _) = + error "Language.Haskell.Stylish.Printer.Imports.printImportExport: unhandled case 'IEDocNamed'" +printImport _ (XIE ext) = + GHC.noExtCon ext -------------------------------------------------------------------------------- --- | Order of imports in sublist is: --- Constructors, accessors/methods, operators. -compareImportSubSpecs :: H.CName l -> H.CName l -> Ordering -compareImportSubSpecs = comparing key +printIeWrappedName :: LIEWrappedName RdrName -> P () +printIeWrappedName lie = unLocated lie & \case + IEName n -> putRdrName n + IEPattern n -> putText "pattern" >> space >> putRdrName n + IEType n -> putText "type" >> space >> putRdrName n + +mergeImports :: NonEmpty (Located Import) -> NonEmpty (Located Import) +mergeImports (x :| []) = x :| [] +mergeImports (h :| (t : ts)) + | canMergeImport (unLocated h) (unLocated t) = mergeImports (mergeModuleImport h t :| ts) + | otherwise = h :| mergeImportsTail (t : ts) where - key :: H.CName l -> (Int, Bool, String) - key (H.ConName _ x) = (0, False, nameToString x) - key (H.VarName _ x) = (1, isOperator x, nameToString x) - + mergeImportsTail (x : y : ys) + | canMergeImport (unLocated x) (unLocated y) = mergeImportsTail ((mergeModuleImport x y) : ys) + | otherwise = x : mergeImportsTail (y : ys) + mergeImportsTail xs = xs --------------------------------------------------------------------------------- --- | By default, haskell-src-exts pretty-prints --- --- > import Foo (Bar(..)) --- --- but we want --- --- > import Foo (Bar (..)) --- --- instead. -prettyImportSpec :: (Ord l) => Bool -> H.ImportSpec l -> String -prettyImportSpec separate = prettyImportSpec' - where - prettyImportSpec' (H.IThingAll _ n) = H.prettyPrint n ++ sep "(..)" - prettyImportSpec' (H.IThingWith _ n cns) = H.prettyPrint n - ++ sep "(" - ++ intercalate ", " - (map H.prettyPrint $ sortBy compareImportSubSpecs cns) - ++ ")" - prettyImportSpec' x = H.prettyPrint x - - sep = if separate then (' ' :) else id +moduleName :: Import -> String +moduleName + = moduleNameString + . unLocated + . ideclName + . rawImport -------------------------------------------------------------------------------- -prettyImport :: (Ord l, Show l) => - Maybe Int -> Options -> Bool -> Bool -> Int -> H.ImportDecl l -> [String] -prettyImport columns Options{..} padQualified padName longest imp - | (void `fmap` H.importSpecs imp) == emptyImportSpec = emptyWrap - | otherwise = case longListAlign of - Inline -> inlineWrap - InlineWithBreak -> longListWrapper inlineWrap inlineWithBreakWrap - InlineToMultiline -> longListWrapper inlineWrap inlineToMultilineWrap - Multiline -> longListWrapper inlineWrap multilineWrap - where - emptyImportSpec = Just (H.ImportSpecList () False []) - -- "import" + space + qualifiedLength has space in it. - listPadding' = listPaddingValue (6 + 1 + qualifiedLength) listPadding - where - qualifiedLength = - if null qualified then 0 else 1 + sum (map length qualified) - - longListWrapper shortWrap longWrap - | listAlign == NewLine - || length shortWrap > 1 - || exceedsColumns (length (head shortWrap)) - = longWrap - | otherwise = shortWrap - - emptyWrap = case emptyListAlign of - Inherit -> inlineWrap - RightAfter -> [paddedNoSpecBase ++ " ()"] - - inlineWrap = inlineWrapper - $ mapSpecs - $ withInit (++ ",") - . withHead (("(" ++ maybeSpace) ++) - . withLast (++ (maybeSpace ++ ")")) - - inlineWrapper = case listAlign of - -- Treat repeat as newline, code will be deleted anyway. - NewLine -> (paddedNoSpecBase :) . wrapRestMaybe columns listPadding' - Repeat -> (paddedNoSpecBase :) . wrapRestMaybe columns listPadding' - WithModuleName -> wrapMaybe columns paddedBase (withModuleNameBaseLength + 4) - WithAlias -> wrapMaybe columns paddedBase (inlineBaseLength + 1) - -- Add 1 extra space to ensure same padding as in original code. - AfterAlias -> withTail ((' ' : maybeSpace) ++) - . wrapMaybe columns paddedBase (afterAliasBaseLength + 1) - - inlineWithBreakWrap = paddedNoSpecBase : wrapRestMaybe columns listPadding' - ( mapSpecs - $ withInit (++ ",") - . withHead (("(" ++ maybeSpace) ++) - . withLast (++ (maybeSpace ++ ")"))) - - inlineToMultilineWrap - | length inlineWithBreakWrap > 2 - || any (exceedsColumns . length) (tail inlineWithBreakWrap) - = multilineWrap - | otherwise = inlineWithBreakWrap - - -- 'wrapRest 0' ensures that every item of spec list is on new line. - multilineWrap = paddedNoSpecBase : wrapRest 0 listPadding' - ( mapSpecs - ( withHead ("( " ++) - . withTail (", " ++)) - ++ closer) - where - closer = if null importSpecs - then [] - else [")"] - - paddedBase = base $ padImport $ compoundImportName imp - - paddedNoSpecBase = base $ padImportNoSpec $ compoundImportName imp - - padImport = if hasExtras && padName - then padRight longest - else id - - padImportNoSpec = if (isJust (H.importAs imp) || hasHiding) && padName - then padRight longest - else id - - base' baseName importAs hasHiding' = unwords $ concat $ - [ ["import"] - , source - , safe - , qualified - , [baseName] - , importAs - , hasHiding' - ] - - base baseName = base' baseName - ["as " ++ as | H.ModuleName _ as <- maybeToList $ H.importAs imp] - ["hiding" | hasHiding] - - inlineBaseLength = length $ - base' (padImport $ compoundImportName imp) [] [] - - withModuleNameBaseLength = length $ base' "" [] [] - - afterAliasBaseLength = length $ base' (padImport $ compoundImportName imp) - ["as " ++ as | H.ModuleName _ as <- maybeToList $ H.importAs imp] [] - - (hasHiding, importSpecs) = case H.importSpecs imp of - Just (H.ImportSpecList _ h l) -> (h, Just l) - _ -> (False, Nothing) - - hasExtras = isJust (H.importAs imp) || isJust (H.importSpecs imp) - - qualified - | H.importQualified imp = ["qualified"] - | padQualified = - if H.importSrc imp - then [] - else if H.importSafe imp - then [" "] - else [" "] - | otherwise = [] - - safe - | H.importSafe imp = ["safe"] - | otherwise = [] - - source - | H.importSrc imp = ["{-# SOURCE #-}"] - | otherwise = [] - - mapSpecs f = case importSpecs of - Nothing -> [] -- Import everything - Just [] -> ["()"] -- Instance only imports - Just is -> f $ map (prettyImportSpec separateLists) is - - maybeSpace = case spaceSurround of - True -> " " - False -> "" - - exceedsColumns i = case columns of - Nothing -> False -- No number exceeds a maximum column count of - -- Nothing, because there is no limit to exceed. - Just c -> i > c - +data ImportStats = ImportStats + { isLongestImport :: !Int + , isAnySource :: !Bool + , isAnyQualified :: !Bool + , isAnySafe :: !Bool + } --------------------------------------------------------------------------------- -prettyImportGroup :: Maybe Int -> Options -> Bool -> Int - -> [H.ImportDecl LineBlock] - -> Lines -prettyImportGroup columns align fileAlign longest imps = - concatMap (prettyImport columns align padQual padName longest') $ - sortBy compareImports imps - where - align' = importAlign align - padModuleNames' = padModuleNames align +instance Semigroup ImportStats where + l <> r = ImportStats + { isLongestImport = isLongestImport l `max` isLongestImport r + , isAnySource = isAnySource l || isAnySource r + , isAnyQualified = isAnyQualified l || isAnyQualified r + , isAnySafe = isAnySafe l || isAnySafe r + } - longest' = case align' of - Group -> longestImport imps - _ -> longest +instance Monoid ImportStats where + mappend = (<>) + mempty = ImportStats 0 False False False - padName = align' /= None && padModuleNames' +importStats :: Import -> ImportStats +importStats i = + ImportStats (importModuleNameLength i) (isSource i) (isQualified i) (isSafe i) - padQual = case align' of - Global -> True - File -> fileAlign - Group -> any H.importQualified imps - None -> False +-- Computes length till module name, includes package name. +-- TODO: this should reuse code with the printer +importModuleNameLength :: Import -> Int +importModuleNameLength imp = + (case ideclPkgQual (rawImport imp) of + Nothing -> 0 + Just sl -> 1 + length (stringLiteral sl)) + + (length $ moduleName imp) -------------------------------------------------------------------------------- -step :: Maybe Int -> Options -> Step -step columns = oldMakeStep "Imports" . step' columns +stringLiteral :: StringLiteral -> String +stringLiteral sl = case sl_st sl of + NoSourceText -> FS.unpackFS $ sl_fs sl + SourceText s -> s -------------------------------------------------------------------------------- -step' :: Maybe Int -> Options -> Lines -> OldModule -> Lines -step' columns align ls (module', _) = applyChanges - [ change block $ const $ - prettyImportGroup columns align fileAlign longest importGroup - | (block, importGroup) <- groups - ] - ls - where - imps = map (sortImportSpecs . deduplicateImportSpecs) $ - imports $ fmap linesFromSrcSpan module' - longest = longestImport imps - groups = groupAdjacent [(H.ann i, i) | i <- imps] - - fileAlign = case importAlign align of - File -> any H.importQualified imps - _ -> False +isQualified :: Import -> Bool +isQualified + = (/=) NotQualified + . ideclQualified + . rawImport + +isHiding :: Import -> Bool +isHiding + = maybe False fst + . ideclHiding + . rawImport + +isSource :: Import -> Bool +isSource + = ideclSource + . rawImport + +isSafe :: Import -> Bool +isSafe + = ideclSafe + . rawImport -------------------------------------------------------------------------------- -listPaddingValue :: Int -> ListPadding -> Int -listPaddingValue _ (LPConstant n) = n -listPaddingValue n LPModuleName = n +-- | Cleans up an import item list. +-- +-- * Sorts import items. +-- * Sort inner import lists, e.g. `import Control.Monad (Monad (return, join))` +-- * Removes duplicates from import lists. +prepareImportList :: [LIE GhcPs] -> [LIE GhcPs] +prepareImportList = + sortBy compareImportLIE . map (fmap prepareInner) . + concatMap (toList . snd) . Map.toAscList . mergeByName + where + mergeByName :: [LIE GhcPs] -> Map.Map RdrName (NonEmpty (LIE GhcPs)) + mergeByName imports0 = Map.fromListWith + -- Note that ideally every NonEmpty will just have a single entry and we + -- will be able to merge everything into that entry. Exotic imports can + -- mess this up, though. So they end up in the tail of the list. + (\(x :| xs) (y :| ys) -> case ieMerge (unLocated x) (unLocated y) of + Just z -> (x $> z) :| (xs ++ ys) -- Keep source from `x` + Nothing -> x :| (xs ++ y : ys)) + [(ieName $ unLocated imp, imp :| []) | imp <- imports0] + + -- | TODO: get rid off this by adding a properly sorting newtype around + -- 'RdrName'. + compareImportLIE :: LIE GhcPs -> LIE GhcPs -> Ordering + compareImportLIE = comparing $ ieKey . unLoc + + prepareInner :: IE GhcPs -> IE GhcPs + prepareInner = \case + -- Simplify `A ()` to `A`. + IEThingWith x n NoIEWildcard [] [] -> IEThingAbs x n + IEThingWith x n w ns fs -> IEThingWith x n w (sortOn nameKey ns) fs + ie -> ie + + -- | The implementation is a bit hacky to get proper sorting for input specs: + -- constructors first, followed by functions, and then operators. + ieKey :: IE GhcPs -> (Int, String) + ieKey = \case + IEVar _ n -> nameKey n + IEThingAbs _ n -> nameKey n + IEThingAll _ n -> nameKey n + IEThingWith _ n _ _ _ -> nameKey n + _ -> (2, "") + + nameKey n = case showOutputable n of + o@('(' : _) -> (2 :: Int, o) + o@(o0 : _) | isUpper o0 -> (0, o) + o -> (1, o) + + -- Merge two import items, assuming they have the same name. + ieMerge :: IE GhcPs -> IE GhcPs -> Maybe (IE GhcPs) + ieMerge l@(IEVar _ _) _ = Just l + ieMerge _ r@(IEVar _ _) = Just r + ieMerge (IEThingAbs _ _) r = Just r + ieMerge l (IEThingAbs _ _) = Just l + ieMerge l@(IEThingAll _ _) _ = Just l + ieMerge _ r@(IEThingAll _ _) = Just r + ieMerge (IEThingWith x0 n0 w0 ns0 []) (IEThingWith _ _ w1 ns1 []) + | w0 /= w1 = Nothing + | otherwise = Just $ + -- TODO: sort the `ns0 ++ ns1`? + IEThingWith x0 n0 w0 (nubOn (unwrapName . unLocated) $ ns0 ++ ns1) [] + ieMerge _ _ = Nothing + + unwrapName :: IEWrappedName n -> n + unwrapName (IEName n) = unLocated n + unwrapName (IEPattern n) = unLocated n + unwrapName (IEType n) = unLocated n --------------------------------------------------------------------------------- -instance A.FromJSON ListPadding where - parseJSON (A.String "module_name") = return LPModuleName - parseJSON (A.Number n) | n' >= 1 = return $ LPConstant n' - where - n' = truncate n - parseJSON v = A.typeMismatch "'module_name' or >=1 number" v +-------------------------------------------------------------------------------- +nubOn :: Ord k => (a -> k) -> [a] -> [a] +nubOn f = go Set.empty + where + go _ [] = [] + go acc (x : xs) + | y `Set.member` acc = go acc xs + | otherwise = x : go (Set.insert y acc) xs + where + y = f x diff --git a/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs b/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs deleted file mode 100644 index e1e03e01..00000000 --- a/lib/Language/Haskell/Stylish/Step/ImportsGHC.hs +++ /dev/null @@ -1,447 +0,0 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DoAndIfThenElse #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RecordWildCards #-} -module Language.Haskell.Stylish.Step.ImportsGHC - ( Options (..) - , defaultOptions - , ImportAlign (..) - , ListAlign (..) - , LongListAlign (..) - , EmptyListAlign (..) - , ListPadding (..) - , step - ) where - --------------------------------------------------------------------------------- -import Control.Monad (forM_, when, void) -import Data.Char (isUpper) -import Data.Function ((&)) -import Data.Functor (($>)) -import Data.Foldable (toList) -import Data.Ord (comparing) -import Data.Maybe (isJust) -import Data.List (sortBy, sortOn) -import Data.List.NonEmpty (NonEmpty(..)) -import qualified Data.List.NonEmpty as NonEmpty -import qualified Data.Map as Map -import qualified Data.Set as Set - - --------------------------------------------------------------------------------- -import BasicTypes (StringLiteral (..), - SourceText (..)) -import qualified FastString as FS -import GHC.Hs.Extension (GhcPs) -import qualified GHC.Hs.Extension as GHC -import GHC.Hs.ImpExp -import Module (moduleNameString) -import RdrName (RdrName) -import SrcLoc (Located, GenLocated(..), unLoc) - - --------------------------------------------------------------------------------- -import Language.Haskell.Stylish.Block -import Language.Haskell.Stylish.Module -import Language.Haskell.Stylish.Printer -import Language.Haskell.Stylish.Step -import Language.Haskell.Stylish.Editor -import Language.Haskell.Stylish.GHC -import Language.Haskell.Stylish.Step.Imports hiding (step) -import Language.Haskell.Stylish.Util - - -step :: Maybe Int -> Options -> Step -step columns = makeStep "Imports (ghc-lib-parser)" . printImports columns - --------------------------------------------------------------------------------- -printImports :: Maybe Int -> Options -> Lines -> Module -> Lines -printImports maxCols align ls m = applyChanges changes ls - where - groups = moduleImportGroups m - moduleStats = foldMap importStats . fmap unLoc $ concatMap toList groups - changes = do - group <- groups - pure $ formatGroup maxCols align m moduleStats group - -formatGroup - :: Maybe Int -> Options -> Module -> ImportStats - -> NonEmpty (Located Import) -> Change String -formatGroup maxCols options m moduleStats imports = - let newLines = formatImports maxCols options m moduleStats imports in - change (importBlock imports) (const newLines) - -importBlock :: NonEmpty (Located a) -> Block String -importBlock group = Block - (getStartLineUnsafe $ NonEmpty.head group) - (getEndLineUnsafe $ NonEmpty.last group) - -formatImports - :: Maybe Int -- ^ Max columns. - -> Options -- ^ Options. - -> Module -- ^ Module. - -> ImportStats -- ^ Module stats. - -> NonEmpty (Located Import) -> Lines -formatImports maxCols options m moduleStats rawGroup = - runPrinter_ (PrinterConfig maxCols) [] m do - let - - group - = NonEmpty.sortWith unLocated rawGroup - & mergeImports - - unLocatedGroup = fmap unLocated $ toList group - - align' = importAlign options - padModuleNames' = padModuleNames options - padNames = align' /= None && padModuleNames' - - stats = case align' of - Global -> moduleStats {isAnyQualified = True} - File -> moduleStats - Group -> foldMap importStats unLocatedGroup - None -> mempty - - forM_ group \imp -> printQualified options padNames stats imp >> newline - --------------------------------------------------------------------------------- -printQualified :: Options -> Bool -> ImportStats -> Located Import -> P () -printQualified Options{..} padNames stats (L _ decl) = do - let decl' = rawImport decl - - putText "import" >> space - - case (isSource decl, isAnySource stats) of - (True, _) -> putText "{-# SOURCE #-}" >> space - (_, True) -> putText " " >> space - _ -> pure () - - when (isSafe decl) (putText "safe" >> space) - - case (isQualified decl, isAnyQualified stats) of - (True, _) -> putText "qualified" >> space - (_, True) -> putText " " >> space - _ -> pure () - - moduleNamePosition <- length <$> getCurrentLine - forM_ (ideclPkgQual decl') $ \pkg -> putText (stringLiteral pkg) >> space - putText (moduleName decl) - - -- Only print spaces if something follows. - when padNames $ - when (isJust (ideclAs decl') || isHiding decl || - not (null $ ideclHiding decl')) $ - putText $ - replicate (isLongestImport stats - importModuleNameLength decl) ' ' - - beforeAliasPosition <- length <$> getCurrentLine - forM_ (ideclAs decl') \(L _ name) -> - space >> putText "as" >> space >> putText (moduleNameString name) - afterAliasPosition <- length <$> getCurrentLine - - when (isHiding decl) (space >> putText "hiding") - - let putOffset = putText $ replicate offset ' ' - offset = case listPadding of - LPConstant n -> n - LPModuleName -> moduleNamePosition - - case snd <$> ideclHiding decl' of - Nothing -> pure () - Just (L _ []) -> case emptyListAlign of - RightAfter -> modifyCurrentLine trimRight >> space >> putText "()" - Inherit -> case listAlign of - NewLine -> - modifyCurrentLine trimRight >> newline >> putOffset >> putText "()" - _ -> space >> putText "()" - Just (L _ imports) -> do - let printedImports = flagEnds $ -- [P ()] - fmap ((printImport Options{..}) . unLocated) - (prepareImportList imports) - - -- Since we might need to output the import module name several times, we - -- need to save it to a variable: - wrapPrefix <- case listAlign of - AfterAlias -> pure $ replicate (afterAliasPosition + 1) ' ' - WithAlias -> pure $ replicate (beforeAliasPosition + 1) ' ' - Repeat -> fmap (++ " (") getCurrentLine - WithModuleName -> pure $ replicate (moduleNamePosition + offset) ' ' - NewLine -> pure $ replicate offset ' ' - - let -- Helper - doSpaceSurround = when spaceSurround space - - -- Try to put everything on one line. - printAsSingleLine = forM_ printedImports $ \(imp, start, end) -> do - when start $ putText "(" >> doSpaceSurround - imp - if end then doSpaceSurround >> putText ")" else comma >> space - - -- Try to put everything one by one, wrapping if that fails. - printAsInlineWrapping wprefix = forM_ printedImports $ - \(imp, start, end) -> - patchForRepeatHiding $ wrapping - (do - if start then putText "(" >> doSpaceSurround else space - imp - if end then doSpaceSurround >> putText ")" else comma) - (do - case listAlign of - -- In 'Repeat' mode, end lines with ')' rather than ','. - Repeat | not start -> modifyCurrentLine . withLast $ - \c -> if c == ',' then ')' else c - _ | start && spaceSurround -> - -- Only necessary if spaceSurround is enabled. - modifyCurrentLine trimRight - _ -> pure () - newline - void wprefix - case listAlign of - -- '(' already included in repeat - Repeat -> pure () - -- Print the much needed '(' - _ | start -> putText "(" >> doSpaceSurround - -- Don't bother aligning if we're not in inline mode. - _ | longListAlign /= Inline -> pure () - -- 'Inline + AfterAlias' is really where we want to be careful - -- with spacing. - AfterAlias -> space >> doSpaceSurround - WithModuleName -> pure () - WithAlias -> pure () - NewLine -> pure () - imp - if end then doSpaceSurround >> putText ")" else comma) - - -- Put everything on a separate line. 'spaceSurround' can be - -- ignored. - printAsMultiLine = forM_ printedImports $ \(imp, start, end) -> do - when start $ modifyCurrentLine trimRight -- We added some spaces. - newline - putOffset - if start then putText "( " else putText ", " - imp - when end $ newline >> putOffset >> putText ")" - - case longListAlign of - Multiline -> wrapping - (space >> printAsSingleLine) - printAsMultiLine - Inline | NewLine <- listAlign -> do - modifyCurrentLine trimRight - newline >> putOffset >> printAsInlineWrapping (putText wrapPrefix) - Inline -> space >> printAsInlineWrapping (putText wrapPrefix) - InlineWithBreak -> wrapping - (space >> printAsSingleLine) - (do - modifyCurrentLine trimRight - newline >> putOffset >> printAsInlineWrapping putOffset) - InlineToMultiline -> wrapping - (space >> printAsSingleLine) - (wrapping - (do - modifyCurrentLine trimRight - newline >> putOffset >> printAsSingleLine) - printAsMultiLine) - where - -- We cannot wrap/repeat 'hiding' imports since then we would get multiple - -- imports hiding different things. - patchForRepeatHiding = case listAlign of - Repeat | isHiding decl -> withColumns Nothing - _ -> id - - --------------------------------------------------------------------------------- -printImport :: Options -> IE GhcPs -> P () -printImport Options{..} (IEVar _ name) = do - printIeWrappedName name -printImport _ (IEThingAbs _ name) = do - printIeWrappedName name -printImport _ (IEThingAll _ name) = do - printIeWrappedName name - space - putText "(..)" -printImport _ (IEModuleContents _ (L _ m)) = do - putText (moduleNameString m) -printImport Options{..} (IEThingWith _ name _wildcard imps _) = do - printIeWrappedName name - when separateLists space - parenthesize $ - sep (comma >> space) (printIeWrappedName <$> imps) -printImport _ (IEGroup _ _ _ ) = - error "Language.Haskell.Stylish.Printer.Imports.printImportExport: unhandled case 'IEGroup'" -printImport _ (IEDoc _ _) = - error "Language.Haskell.Stylish.Printer.Imports.printImportExport: unhandled case 'IEDoc'" -printImport _ (IEDocNamed _ _) = - error "Language.Haskell.Stylish.Printer.Imports.printImportExport: unhandled case 'IEDocNamed'" -printImport _ (XIE ext) = - GHC.noExtCon ext - --------------------------------------------------------------------------------- -printIeWrappedName :: LIEWrappedName RdrName -> P () -printIeWrappedName lie = unLocated lie & \case - IEName n -> putRdrName n - IEPattern n -> putText "pattern" >> space >> putRdrName n - IEType n -> putText "type" >> space >> putRdrName n - -mergeImports :: NonEmpty (Located Import) -> NonEmpty (Located Import) -mergeImports (x :| []) = x :| [] -mergeImports (h :| (t : ts)) - | canMergeImport (unLocated h) (unLocated t) = mergeImports (mergeModuleImport h t :| ts) - | otherwise = h :| mergeImportsTail (t : ts) - where - mergeImportsTail (x : y : ys) - | canMergeImport (unLocated x) (unLocated y) = mergeImportsTail ((mergeModuleImport x y) : ys) - | otherwise = x : mergeImportsTail (y : ys) - mergeImportsTail xs = xs - -moduleName :: Import -> String -moduleName - = moduleNameString - . unLocated - . ideclName - . rawImport - - --------------------------------------------------------------------------------- -data ImportStats = ImportStats - { isLongestImport :: !Int - , isAnySource :: !Bool - , isAnyQualified :: !Bool - , isAnySafe :: !Bool - } - -instance Semigroup ImportStats where - l <> r = ImportStats - { isLongestImport = isLongestImport l `max` isLongestImport r - , isAnySource = isAnySource l || isAnySource r - , isAnyQualified = isAnyQualified l || isAnyQualified r - , isAnySafe = isAnySafe l || isAnySafe r - } - -instance Monoid ImportStats where - mappend = (<>) - mempty = ImportStats 0 False False False - -importStats :: Import -> ImportStats -importStats i = - ImportStats (importModuleNameLength i) (isSource i) (isQualified i) (isSafe i) - --- Computes length till module name, includes package name. --- TODO: this should reuse code with the printer -importModuleNameLength :: Import -> Int -importModuleNameLength imp = - (case ideclPkgQual (rawImport imp) of - Nothing -> 0 - Just sl -> 1 + length (stringLiteral sl)) + - (length $ moduleName imp) - - --------------------------------------------------------------------------------- -stringLiteral :: StringLiteral -> String -stringLiteral sl = case sl_st sl of - NoSourceText -> FS.unpackFS $ sl_fs sl - SourceText s -> s - - --------------------------------------------------------------------------------- -isQualified :: Import -> Bool -isQualified - = (/=) NotQualified - . ideclQualified - . rawImport - -isHiding :: Import -> Bool -isHiding - = maybe False fst - . ideclHiding - . rawImport - -isSource :: Import -> Bool -isSource - = ideclSource - . rawImport - -isSafe :: Import -> Bool -isSafe - = ideclSafe - . rawImport - --------------------------------------------------------------------------------- --- | Cleans up an import item list. --- --- * Sorts import items. --- * Sort inner import lists, e.g. `import Control.Monad (Monad (return, join))` --- * Removes duplicates from import lists. -prepareImportList :: [LIE GhcPs] -> [LIE GhcPs] -prepareImportList = - sortBy compareImportLIE . map (fmap prepareInner) . - concatMap (toList . snd) . Map.toAscList . mergeByName - where - mergeByName :: [LIE GhcPs] -> Map.Map RdrName (NonEmpty (LIE GhcPs)) - mergeByName imports0 = Map.fromListWith - -- Note that ideally every NonEmpty will just have a single entry and we - -- will be able to merge everything into that entry. Exotic imports can - -- mess this up, though. So they end up in the tail of the list. - (\(x :| xs) (y :| ys) -> case ieMerge (unLocated x) (unLocated y) of - Just z -> (x $> z) :| (xs ++ ys) -- Keep source from `x` - Nothing -> x :| (xs ++ y : ys)) - [(ieName $ unLocated imp, imp :| []) | imp <- imports0] - - -- | TODO: get rid off this by adding a properly sorting newtype around - -- 'RdrName'. - compareImportLIE :: LIE GhcPs -> LIE GhcPs -> Ordering - compareImportLIE = comparing $ ieKey . unLoc - - prepareInner :: IE GhcPs -> IE GhcPs - prepareInner = \case - -- Simplify `A ()` to `A`. - IEThingWith x n NoIEWildcard [] [] -> IEThingAbs x n - IEThingWith x n w ns fs -> IEThingWith x n w (sortOn nameKey ns) fs - ie -> ie - - -- | The implementation is a bit hacky to get proper sorting for input specs: - -- constructors first, followed by functions, and then operators. - ieKey :: IE GhcPs -> (Int, String) - ieKey = \case - IEVar _ n -> nameKey n - IEThingAbs _ n -> nameKey n - IEThingAll _ n -> nameKey n - IEThingWith _ n _ _ _ -> nameKey n - _ -> (2, "") - - nameKey n = case showOutputable n of - o@('(' : _) -> (2 :: Int, o) - o@(o0 : _) | isUpper o0 -> (0, o) - o -> (1, o) - - -- Merge two import items, assuming they have the same name. - ieMerge :: IE GhcPs -> IE GhcPs -> Maybe (IE GhcPs) - ieMerge l@(IEVar _ _) _ = Just l - ieMerge _ r@(IEVar _ _) = Just r - ieMerge (IEThingAbs _ _) r = Just r - ieMerge l (IEThingAbs _ _) = Just l - ieMerge l@(IEThingAll _ _) _ = Just l - ieMerge _ r@(IEThingAll _ _) = Just r - ieMerge (IEThingWith x0 n0 w0 ns0 []) (IEThingWith _ _ w1 ns1 []) - | w0 /= w1 = Nothing - | otherwise = Just $ - -- TODO: sort the `ns0 ++ ns1`? - IEThingWith x0 n0 w0 (nubOn (unwrapName . unLocated) $ ns0 ++ ns1) [] - ieMerge _ _ = Nothing - - unwrapName :: IEWrappedName n -> n - unwrapName (IEName n) = unLocated n - unwrapName (IEPattern n) = unLocated n - unwrapName (IEType n) = unLocated n - - --------------------------------------------------------------------------------- -nubOn :: Ord k => (a -> k) -> [a] -> [a] -nubOn f = go Set.empty - where - go _ [] = [] - go acc (x : xs) - | y `Set.member` acc = go acc xs - | otherwise = x : go (Set.insert y acc) xs - where - y = f x diff --git a/stylish-haskell.cabal b/stylish-haskell.cabal index 1508b4f9..f4304a01 100644 --- a/stylish-haskell.cabal +++ b/stylish-haskell.cabal @@ -35,7 +35,6 @@ Library Language.Haskell.Stylish.Printer Language.Haskell.Stylish.Step.Data Language.Haskell.Stylish.Step.Imports - Language.Haskell.Stylish.Step.ImportsGHC Language.Haskell.Stylish.Step.ModuleHeader Language.Haskell.Stylish.Step.LanguagePragmas Language.Haskell.Stylish.Step.SimpleAlign @@ -127,9 +126,8 @@ Test-suite stylish-haskell-tests Language.Haskell.Stylish.Printer Language.Haskell.Stylish.Step Language.Haskell.Stylish.Step.Imports - Language.Haskell.Stylish.Step.ImportsGHC Language.Haskell.Stylish.Step.Imports.Tests - Language.Haskell.Stylish.Step.ImportsGHC.Tests + Language.Haskell.Stylish.Step.Imports.FelixTests Language.Haskell.Stylish.Step.Data Language.Haskell.Stylish.Step.Data.Tests Language.Haskell.Stylish.Step.ModuleHeader diff --git a/tests/Language/Haskell/Stylish/Step/ImportsGHC/Tests.hs b/tests/Language/Haskell/Stylish/Step/Imports/FelixTests.hs similarity index 94% rename from tests/Language/Haskell/Stylish/Step/ImportsGHC/Tests.hs rename to tests/Language/Haskell/Stylish/Step/Imports/FelixTests.hs index 3e63adf4..98c5d120 100644 --- a/tests/Language/Haskell/Stylish/Step/ImportsGHC/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Imports/FelixTests.hs @@ -1,19 +1,20 @@ -module Language.Haskell.Stylish.Step.ImportsGHC.Tests +-- | Tests contributed by Felix Mulder as part of +-- . +module Language.Haskell.Stylish.Step.Imports.FelixTests ( tests ) where -------------------------------------------------------------------------------- -import Test.Framework (Test, testGroup) -import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit (Assertion) -import GHC.Stack (HasCallStack, withFrozenCallStack) -import Prelude hiding (lines) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit (Assertion) +import GHC.Stack (HasCallStack, withFrozenCallStack) +import Prelude hiding (lines) -------------------------------------------------------------------------------- import Language.Haskell.Stylish.Module -import Language.Haskell.Stylish.Step.Imports (Options (..), defaultOptions, ListAlign (..)) -import Language.Haskell.Stylish.Step.ImportsGHC (step) -import Language.Haskell.Stylish.Tests.Util (testStep', (@=??)) +import Language.Haskell.Stylish.Step.Imports +import Language.Haskell.Stylish.Tests.Util (testStep', (@=??)) diff --git a/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs index ed65824b..0a6efc41 100644 --- a/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs @@ -5,13 +5,13 @@ module Language.Haskell.Stylish.Step.Imports.Tests -------------------------------------------------------------------------------- -import Test.Framework (Test, testGroup) -import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit (Assertion, (@=?)) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit (Assertion, (@=?)) -------------------------------------------------------------------------------- -import Language.Haskell.Stylish.Step.ImportsGHC +import Language.Haskell.Stylish.Step.Imports import Language.Haskell.Stylish.Tests.Util diff --git a/tests/TestSuite.hs b/tests/TestSuite.hs index 1dd9df92..501821b2 100644 --- a/tests/TestSuite.hs +++ b/tests/TestSuite.hs @@ -13,6 +13,7 @@ import qualified Language.Haskell.Stylish.Config.Tests import qualified Language.Haskell.Stylish.Parse.Tests import qualified Language.Haskell.Stylish.Step.Data.Tests import qualified Language.Haskell.Stylish.Step.Imports.Tests +import qualified Language.Haskell.Stylish.Step.Imports.FelixTests import qualified Language.Haskell.Stylish.Step.ModuleHeader.Tests import qualified Language.Haskell.Stylish.Step.LanguagePragmas.Tests import qualified Language.Haskell.Stylish.Step.SimpleAlign.Tests @@ -21,7 +22,6 @@ import qualified Language.Haskell.Stylish.Step.Tabs.Tests import qualified Language.Haskell.Stylish.Step.TrailingWhitespace.Tests import qualified Language.Haskell.Stylish.Step.UnicodeSyntax.Tests import qualified Language.Haskell.Stylish.Tests -import qualified Language.Haskell.Stylish.Step.ImportsGHC.Tests -------------------------------------------------------------------------------- @@ -31,7 +31,7 @@ main = defaultMain , Language.Haskell.Stylish.Config.Tests.tests , Language.Haskell.Stylish.Step.Data.Tests.tests , Language.Haskell.Stylish.Step.Imports.Tests.tests - , Language.Haskell.Stylish.Step.ImportsGHC.Tests.tests + , Language.Haskell.Stylish.Step.Imports.FelixTests.tests , Language.Haskell.Stylish.Step.LanguagePragmas.Tests.tests , Language.Haskell.Stylish.Step.ModuleHeader.Tests.tests , Language.Haskell.Stylish.Step.SimpleAlign.Tests.tests From 6e1220bf00ae84d21905c6fb5edada1cae51afdf Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Fri, 25 Sep 2020 18:42:16 +0200 Subject: [PATCH 117/135] WIP: operate on groups in SimpleAlign --- .../Haskell/Stylish/Step/SimpleAlign.hs | 75 ++++++++++++++----- .../Haskell/Stylish/Step/SimpleAlign/Tests.hs | 69 ++++++++++------- tests/Language/Haskell/Stylish/Tests/Util.hs | 18 ++++- 3 files changed, 114 insertions(+), 48 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs b/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs index a0c83397..3619fd30 100644 --- a/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs +++ b/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs @@ -8,7 +8,7 @@ module Language.Haskell.Stylish.Step.SimpleAlign -------------------------------------------------------------------------------- -import Data.Maybe (maybeToList) +import Data.Maybe (fromMaybe, maybeToList) import Data.List (foldl') import qualified GHC.Hs as Hs import qualified SrcLoc as S @@ -40,8 +40,8 @@ defaultConfig = Config -------------------------------------------------------------------------------- -- -tlpats :: (S.Located (Hs.HsModule Hs.GhcPs)) -> [[S.Located (Hs.Match Hs.GhcPs (Hs.LHsExpr Hs.GhcPs))]] -tlpats modu = +_tlpats :: (S.Located (Hs.HsModule Hs.GhcPs)) -> [[S.Located (Hs.Match Hs.GhcPs (Hs.LHsExpr Hs.GhcPs))]] +_tlpats modu = let decls = map S.unLoc (Hs.hsmodDecls (S.unLoc modu)) binds = [ bind | Hs.ValD _ bind <- decls ] @@ -66,8 +66,8 @@ records modu = [ lConDeclFields ] -matchToAlignable :: S.Located (Hs.Match Hs.GhcPs (Hs.LHsExpr Hs.GhcPs)) -> Maybe (Alignable S.RealSrcSpan) -matchToAlignable (S.L matchLoc (Hs.Match _ (Hs.FunRhs name _ _) pats grhss)) = do +_matchToAlignable :: S.Located (Hs.Match Hs.GhcPs (Hs.LHsExpr Hs.GhcPs)) -> Maybe (Alignable S.RealSrcSpan) +_matchToAlignable (S.L matchLoc (Hs.Match _ (Hs.FunRhs name _ _) pats grhss)) = do body <- unguardedRhsBody grhss let patsLocs = map S.getLoc pats nameLoc = S.getLoc name @@ -82,11 +82,22 @@ matchToAlignable (S.L matchLoc (Hs.Match _ (Hs.FunRhs name _ _) pats grhss)) = d , aRight = bodyPos , aRightLead = length "= " } -matchToAlignable (S.L _ (Hs.Match _ _ [] _)) = Nothing -matchToAlignable (S.L _ (Hs.Match _ _ _ _ )) = Nothing -matchToAlignable (S.L _ (Hs.XMatch x)) = Hs.noExtCon x - -caseToAlignable :: S.Located (Hs.Match Hs.GhcPs (Hs.LHsExpr Hs.GhcPs)) -> Maybe (Alignable S.RealSrcSpan) +_matchToAlignable (S.L _ (Hs.Match _ _ [] _)) = Nothing +_matchToAlignable (S.L _ (Hs.Match _ _ _ _ )) = Nothing +_matchToAlignable (S.L _ (Hs.XMatch x)) = Hs.noExtCon x + +{- +rhsBodies :: Hs.GRHSs Hs.GhcPs a -> [a] +rhsBodies (Hs.GRHSs _ grhss _) = [body | Hs.GRHS _ _ body <- map S.unLoc grhss] +-} + +matchGroupToAlignable + :: Hs.MatchGroup Hs.GhcPs (Hs.LHsExpr Hs.GhcPs) -> [Alignable S.RealSrcSpan] +matchGroupToAlignable (Hs.XMatchGroup x) = Hs.noExtCon x +matchGroupToAlignable (Hs.MG _ alts _) = + fromMaybe [] $ traverse caseToAlignable (S.unLoc alts) + +caseToAlignable :: S.Located (Hs.Match Hs.GhcPs (Hs.LHsExpr Hs.GhcPs)) -> Maybe (Alignable S.RealSrcSpan) caseToAlignable (S.L matchLoc m@(Hs.Match _ Hs.CaseAlt pats@(_ : _) grhss)) = do let patsLocs = map S.getLoc pats pat = last patsLocs @@ -103,6 +114,21 @@ caseToAlignable (S.L matchLoc m@(Hs.Match _ Hs.CaseAlt pats@(_ : _) grhss)) = do , aRight = rightPos , aRightLead = length "-> " } +caseToAlignable (S.L matchLoc (Hs.Match _ (Hs.FunRhs name _ _) pats@(_ : _) grhss)) = do + body <- unguardedRhsBody grhss + let patsLocs = map S.getLoc pats + nameLoc = S.getLoc name + left = last (nameLoc : patsLocs) + bodyLoc = S.getLoc body + matchPos <- toRealSrcSpan matchLoc + leftPos <- toRealSrcSpan left + bodyPos <- toRealSrcSpan bodyLoc + Just $ Alignable + { aContainer = matchPos + , aLeft = leftPos + , aRight = bodyPos + , aRightLead = length "= " + } caseToAlignable (S.L _ (Hs.XMatch x)) = Hs.noExtCon x caseToAlignable (S.L _ (Hs.Match _ _ _ _)) = Nothing @@ -122,18 +148,29 @@ fieldDeclToAlignable (S.L matchLoc (Hs.ConDeclField _ names ty _)) = do step :: Maybe Int -> Config -> Step step maxColumns config = makeStep "Cases" $ \ls module' -> - let changes :: ((S.Located (Hs.HsModule Hs.GhcPs)) -> [[a]]) -> (a -> Maybe (Alignable S.RealSrcSpan)) -> [Change String] - changes search toAlign = + let changes :: ((S.Located (Hs.HsModule Hs.GhcPs)) -> [a]) -> (a -> [Alignable S.RealSrcSpan]) -> [Change String] + changes search toAlign = concat $ + map (align maxColumns) . map toAlign $ search (parsedModule module') + {- [ change_ | case_ <- search (parsedModule module') , aligns <- maybeToList (mapM toAlign case_) - , change_ <- align maxColumns aligns + , change_ <- traceOutputtable "aligns" (length aligns) $ + align maxColumns aligns ] + -} configured :: [Change String] configured = concat $ - [changes tlpats matchToAlignable | cTopLevelPatterns config] ++ - [changes records fieldDeclToAlignable | cRecords config] ++ - [changes everything caseToAlignable | cCases config] - in applyChanges configured ls - - + -- [changes tlpats matchToAlignable | cTopLevelPatterns config] ++ + -- [changes records fieldDeclToAlignable | cRecords config] ++ + [changes everything matchGroupToAlignable | cCases config] + -- [changes everything caseToAlignable | cCases config] + + cases = everything (parsedModule module') :: [S.Located (Hs.Match Hs.GhcPs (Hs.LHsExpr Hs.GhcPs))] + matchgroups = everything (parsedModule module') :: [Hs.MatchGroup Hs.GhcPs (Hs.LHsExpr Hs.GhcPs)] + in + -- traceOutputtable "tlpats" (tlpats $ parsedModule module') $ + traceOutputtable "matchgroups" (length matchgroups) $ + traceOutputtable "records" (records $ parsedModule module') $ + traceOutputtable "cases" (cases) $ + applyChanges configured ls diff --git a/tests/Language/Haskell/Stylish/Step/SimpleAlign/Tests.hs b/tests/Language/Haskell/Stylish/Step/SimpleAlign/Tests.hs index a2a51fc2..56570604 100644 --- a/tests/Language/Haskell/Stylish/Step/SimpleAlign/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/SimpleAlign/Tests.hs @@ -1,4 +1,5 @@ -------------------------------------------------------------------------------- +{-# LANGUAGE OverloadedLists #-} module Language.Haskell.Stylish.Step.SimpleAlign.Tests ( tests ) where @@ -27,20 +28,21 @@ tests = testGroup "Language.Haskell.Stylish.Step.SimpleAlign.Tests" , testCase "case 07" case07 , testCase "case 08" case08 , testCase "case 09" case09 + , testCase "case 10" case10 ] -------------------------------------------------------------------------------- case01 :: Assertion -case01 = expected @=? testStep (step (Just 80) defaultConfig) input +case01 = expected @=? testSnippet (step (Just 80) defaultConfig) input where - input = unlines + input = Snippet [ "eitherToMaybe e = case e of" , " Left _ -> Nothing" , " Right x -> Just x" ] - expected = unlines + expected = Snippet [ "eitherToMaybe e = case e of" , " Left _ -> Nothing" , " Right x -> Just x" @@ -49,14 +51,14 @@ case01 = expected @=? testStep (step (Just 80) defaultConfig) input -------------------------------------------------------------------------------- case02 :: Assertion -case02 = expected @=? testStep (step (Just 80) defaultConfig) input +case02 = expected @=? testSnippet (step (Just 80) defaultConfig) input where - input = unlines + input = Snippet [ "eitherToMaybe (Left _) = Nothing" , "eitherToMaybe (Right x) = Just x" ] - expected = unlines + expected = Snippet [ "eitherToMaybe (Left _) = Nothing" , "eitherToMaybe (Right x) = Just x" ] @@ -64,14 +66,14 @@ case02 = expected @=? testStep (step (Just 80) defaultConfig) input -------------------------------------------------------------------------------- case03 :: Assertion -case03 = expected @=? testStep (step (Just 80) defaultConfig) input +case03 = expected @=? testSnippet (step (Just 80) defaultConfig) input where - input = unlines + input = Snippet [ "heady def [] = def" , "heady _ (x : _) = x" ] - expected = unlines + expected = Snippet [ "heady def [] = def" , "heady _ (x : _) = x" ] @@ -79,16 +81,16 @@ case03 = expected @=? testStep (step (Just 80) defaultConfig) input -------------------------------------------------------------------------------- case04 :: Assertion -case04 = expected @=? testStep (step (Just 80) defaultConfig) input +case04 = expected @=? testSnippet (step (Just 80) defaultConfig) input where - input = unlines + input = Snippet [ "data Foo = Foo" , " { foo :: Int" , " , barqux :: String" , " } deriving (Show)" ] - expected = unlines + expected = Snippet [ "data Foo = Foo" , " { foo :: Int" , " , barqux :: String" @@ -98,10 +100,10 @@ case04 = expected @=? testStep (step (Just 80) defaultConfig) input -------------------------------------------------------------------------------- case05 :: Assertion -case05 = input @=? testStep (step (Just 80) defaultConfig) input +case05 = input @=? testSnippet (step (Just 80) defaultConfig) input where -- Don't attempt to align this since a field spans multiple lines - input = unlines + input = Snippet [ "data Foo = Foo" , " { foo :: Int" , " , barqux" @@ -114,16 +116,16 @@ case05 = input @=? testStep (step (Just 80) defaultConfig) input case06 :: Assertion case06 = -- 22 max columns is /just/ enough to align this stuff. - expected @=? testStep (step (Just 22) defaultConfig) input + expected @=? testSnippet (step (Just 22) defaultConfig) input where - input = unlines + input = Snippet [ "data Foo = Foo" , " { foo :: String" , " , barqux :: Int" , " }" ] - expected = unlines + expected = Snippet [ "data Foo = Foo" , " { foo :: String" , " , barqux :: Int" @@ -135,16 +137,16 @@ case06 = case07 :: Assertion case07 = -- 21 max columns is /just NOT/ enough to align this stuff. - expected @=? testStep (step (Just 21) defaultConfig) input + expected @=? testSnippet (step (Just 21) defaultConfig) input where - input = unlines + input = Snippet [ "data Foo = Foo" , " { foo :: String" , " , barqux :: Int" , " }" ] - expected = unlines + expected = Snippet [ "data Foo = Foo" , " { foo :: String" , " , barqux :: Int" @@ -154,15 +156,15 @@ case07 = -------------------------------------------------------------------------------- case08 :: Assertion -case08 = expected @=? testStep (step (Just 80) defaultConfig) input +case08 = expected @=? testSnippet (step (Just 80) defaultConfig) input where - input = unlines + input = Snippet [ "canDrink mbAge = case mbAge of" , " Just age | age > 18 -> True" , " _ -> False" ] - expected = unlines + expected = Snippet [ "canDrink mbAge = case mbAge of" , " Just age | age > 18 -> True" , " _ -> False" @@ -172,18 +174,33 @@ case08 = expected @=? testStep (step (Just 80) defaultConfig) input -------------------------------------------------------------------------------- case09 :: Assertion case09 = - expected @=? testStep (step Nothing defaultConfig) input + expected @=? testSnippet (step Nothing defaultConfig) input where - input = unlines + input = Snippet [ "data Foo = Foo" , " { foo :: String" , " , barqux :: Int" , " }" ] - expected = unlines + expected = Snippet [ "data Foo = Foo" , " { foo :: String" , " , barqux :: Int" , " }" ] + + +-------------------------------------------------------------------------------- +case10 :: Assertion +case10 = assertSnippet (step Nothing defaultConfig) + [ "padQual = case align' of" + , " Global -> True" + , " File -> fileAlign" + , " Group -> anyQual" + ] + [ "padQual = case align' of" + , " Global -> True" + , " File -> fileAlign" + , " Group -> anyQual" + ] diff --git a/tests/Language/Haskell/Stylish/Tests/Util.hs b/tests/Language/Haskell/Stylish/Tests/Util.hs index f52c015e..82c86a0d 100644 --- a/tests/Language/Haskell/Stylish/Tests/Util.hs +++ b/tests/Language/Haskell/Stylish/Tests/Util.hs @@ -1,9 +1,11 @@ {-# LANGUAGE BlockArguments #-} +{-# LANGUAGE TypeFamilies #-} module Language.Haskell.Stylish.Tests.Util ( testStep , testStep' , Snippet (..) , testSnippet + , assertSnippet , withTestDirTree , (@=??) ) where @@ -18,10 +20,12 @@ import System.Directory (createDirectory, getTemporaryDirectory, removeDirectoryRecursive, setCurrentDirectory) +import GHC.Exts (IsList (..)) import System.FilePath (()) import System.IO.Error (isAlreadyExistsError) import System.Random (randomIO) -import Test.HUnit (Assertion, assertFailure) +import Test.HUnit (Assertion, assertFailure, + (@=?)) -------------------------------------------------------------------------------- @@ -53,16 +57,24 @@ testStep' s ls = lines $ testStep s (unlines ls) -- | 'Lines' that show as a normal string. newtype Snippet = Snippet {unSnippet :: Lines} deriving (Eq) - --------------------------------------------------------------------------------- instance Show Snippet where show = unlines . unSnippet +instance IsList Snippet where + type Item Snippet = String + fromList = Snippet + toList = unSnippet + -------------------------------------------------------------------------------- testSnippet :: Step -> Snippet -> Snippet testSnippet s = Snippet . lines . testStep s . unlines . unSnippet +-------------------------------------------------------------------------------- +assertSnippet :: Step -> Snippet -> Snippet -> Assertion +assertSnippet step input expected = expected @=? testSnippet step input + + -------------------------------------------------------------------------------- -- | Create a temporary directory with a randomised name built from the template -- provided From 706694aaf0219db491171df9f52bb54065062f28 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Fri, 25 Sep 2020 19:24:25 +0200 Subject: [PATCH 118/135] WIP: operate on groups in SimpleAlign --- .../Haskell/Stylish/Step/SimpleAlign.hs | 51 +++-- lib/Language/Haskell/Stylish/Util.hs | 26 --- .../Haskell/Stylish/Step/SimpleAlign/Tests.hs | 195 ++++++++---------- 3 files changed, 120 insertions(+), 152 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs b/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs index 3619fd30..7a7a62e9 100644 --- a/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs +++ b/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs @@ -26,6 +26,7 @@ import Language.Haskell.Stylish.Module data Config = Config { cCases :: !Bool , cTopLevelPatterns :: !Bool + -- TODO: Matches , cRecords :: !Bool } deriving (Show) @@ -52,18 +53,42 @@ _tlpats modu = -------------------------------------------------------------------------------- records :: (S.Located (Hs.HsModule Hs.GhcPs)) -> [[S.Located (Hs.ConDeclField Hs.GhcPs)]] -records modu = - let - decls = map S.unLoc (Hs.hsmodDecls (S.unLoc modu)) - tyClDecls = [ tyClDecl | Hs.TyClD _ tyClDecl <- decls ] - dataDecls = [ d | d@(Hs.DataDecl _ _ _ _ _) <- tyClDecls ] - dataDefns = map Hs.tcdDataDefn dataDecls - conDecls = concatMap getConDecls dataDefns - conDeclDetails = map getConDeclDetails conDecls - llConDeclFields = getLocRecs conDeclDetails - lConDeclFields = concatMap S.unLoc llConDeclFields - in +records modu = do + let decls = map S.unLoc (Hs.hsmodDecls (S.unLoc modu)) + tyClDecls = [ tyClDecl | Hs.TyClD _ tyClDecl <- decls ] + dataDecls = [ d | d@(Hs.DataDecl _ _ _ _ _) <- tyClDecls ] + dataDefns = map Hs.tcdDataDefn dataDecls + d@Hs.ConDeclH98 {} <- concatMap getConDecls dataDefns + pure $ do + Hs.RecCon rec <- [Hs.con_args d] + S.unLoc rec + {- + let conDeclDetails = getConDeclDetails conDecl + llConDeclFields = getLocRecs conDeclDetails + lConDeclFields = concatMap S.unLoc llConDeclFields [ lConDeclFields ] + -} + + where + getConDecls :: Hs.HsDataDefn Hs.GhcPs -> [Hs.ConDecl Hs.GhcPs] + getConDecls d@Hs.HsDataDefn {} = map S.unLoc $ Hs.dd_cons d + getConDecls (Hs.XHsDataDefn x) = Hs.noExtCon x + + +-------------------------------------------------------------------------------- +-- get Arguments from data Construction Declaration +getConDeclDetails :: Hs.ConDecl Hs.GhcPs -> Hs.HsConDeclDetails Hs.GhcPs +getConDeclDetails d@(Hs.ConDeclGADT _ _ _ _ _ _ _ _) = Hs.con_args d +getConDeclDetails d@(Hs.ConDeclH98 _ _ _ _ _ _ _) = Hs.con_args d +getConDeclDetails (Hs.XConDecl x) = Hs.noExtCon x + + +-------------------------------------------------------------------------------- +-- look for Record(s) in a list of Construction Declaration details +getLocRecs :: [Hs.HsConDeclDetails Hs.GhcPs] -> [S.Located [Hs.LConDeclField Hs.GhcPs]] +getLocRecs conDeclDetails = + [ rec | Hs.RecCon rec <- conDeclDetails ] + _matchToAlignable :: S.Located (Hs.Match Hs.GhcPs (Hs.LHsExpr Hs.GhcPs)) -> Maybe (Alignable S.RealSrcSpan) @@ -132,6 +157,8 @@ caseToAlignable (S.L matchLoc (Hs.Match _ (Hs.FunRhs name _ _) pats@(_ : _) grhs caseToAlignable (S.L _ (Hs.XMatch x)) = Hs.noExtCon x caseToAlignable (S.L _ (Hs.Match _ _ _ _)) = Nothing +recordToAlignable :: [S.Located (Hs.ConDeclField Hs.GhcPs)] -> [Alignable S.RealSrcSpan] +recordToAlignable = fromMaybe [] . traverse fieldDeclToAlignable fieldDeclToAlignable :: S.Located (Hs.ConDeclField Hs.GhcPs) -> Maybe (Alignable S.RealSrcSpan) fieldDeclToAlignable (S.L _ (Hs.XConDeclField x)) = Hs.noExtCon x @@ -162,7 +189,7 @@ step maxColumns config = makeStep "Cases" $ \ls module' -> configured :: [Change String] configured = concat $ -- [changes tlpats matchToAlignable | cTopLevelPatterns config] ++ - -- [changes records fieldDeclToAlignable | cRecords config] ++ + [changes records recordToAlignable | cRecords config] ++ [changes everything matchGroupToAlignable | cCases config] -- [changes everything caseToAlignable | cCases config] diff --git a/lib/Language/Haskell/Stylish/Util.hs b/lib/Language/Haskell/Stylish/Util.hs index f9e2ef00..e1368901 100644 --- a/lib/Language/Haskell/Stylish/Util.hs +++ b/lib/Language/Haskell/Stylish/Util.hs @@ -30,10 +30,6 @@ module Language.Haskell.Stylish.Util , unguardedRhsBody , rhsBody - , getConDecls - , getConDeclDetails - , getLocRecs - , getGuards ) where @@ -257,28 +253,6 @@ rhsBody (Hs.GRHSs _ [grhs] _) | Hs.GRHS _ _ body <- S.unLoc grhs = Just body rhsBody _ = Nothing --------------------------------------------------------------------------------- --- get a list of un-located constructors -getConDecls :: Hs.HsDataDefn Hs.GhcPs -> [Hs.ConDecl Hs.GhcPs] -getConDecls d@(Hs.HsDataDefn _ _ _ _ _ _cons _) = - map S.unLoc $ Hs.dd_cons d -getConDecls (Hs.XHsDataDefn x) = Hs.noExtCon x - - --------------------------------------------------------------------------------- --- get Arguments from data Construction Declaration -getConDeclDetails :: Hs.ConDecl Hs.GhcPs -> Hs.HsConDeclDetails Hs.GhcPs -getConDeclDetails d@(Hs.ConDeclGADT _ _ _ _ _ _ _ _) = Hs.con_args d -getConDeclDetails d@(Hs.ConDeclH98 _ _ _ _ _ _ _) = Hs.con_args d -getConDeclDetails (Hs.XConDecl x) = Hs.noExtCon x - - --------------------------------------------------------------------------------- --- look for Record(s) in a list of Construction Declaration details -getLocRecs :: [Hs.HsConDeclDetails Hs.GhcPs] -> [S.Located [Hs.LConDeclField Hs.GhcPs]] -getLocRecs conDeclDetails = - [ rec | Hs.RecCon rec <- conDeclDetails ] - -------------------------------------------------------------------------------- -- get guards in a guarded rhs of a Match diff --git a/tests/Language/Haskell/Stylish/Step/SimpleAlign/Tests.hs b/tests/Language/Haskell/Stylish/Step/SimpleAlign/Tests.hs index 56570604..2bf66eaf 100644 --- a/tests/Language/Haskell/Stylish/Step/SimpleAlign/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/SimpleAlign/Tests.hs @@ -8,7 +8,7 @@ module Language.Haskell.Stylish.Step.SimpleAlign.Tests -------------------------------------------------------------------------------- import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit (Assertion, (@=?)) +import Test.HUnit (Assertion) -------------------------------------------------------------------------------- @@ -34,76 +34,60 @@ tests = testGroup "Language.Haskell.Stylish.Step.SimpleAlign.Tests" -------------------------------------------------------------------------------- case01 :: Assertion -case01 = expected @=? testSnippet (step (Just 80) defaultConfig) input - where - input = Snippet - [ "eitherToMaybe e = case e of" - , " Left _ -> Nothing" - , " Right x -> Just x" - ] - - expected = Snippet - [ "eitherToMaybe e = case e of" - , " Left _ -> Nothing" - , " Right x -> Just x" - ] +case01 = assertSnippet (step (Just 80) defaultConfig) + [ "eitherToMaybe e = case e of" + , " Left _ -> Nothing" + , " Right x -> Just x" + ] + [ "eitherToMaybe e = case e of" + , " Left _ -> Nothing" + , " Right x -> Just x" + ] -------------------------------------------------------------------------------- case02 :: Assertion -case02 = expected @=? testSnippet (step (Just 80) defaultConfig) input - where - input = Snippet - [ "eitherToMaybe (Left _) = Nothing" - , "eitherToMaybe (Right x) = Just x" - ] - - expected = Snippet - [ "eitherToMaybe (Left _) = Nothing" - , "eitherToMaybe (Right x) = Just x" - ] +case02 = assertSnippet (step (Just 80) defaultConfig) + [ "eitherToMaybe (Left _) = Nothing" + , "eitherToMaybe (Right x) = Just x" + ] + [ "eitherToMaybe (Left _) = Nothing" + , "eitherToMaybe (Right x) = Just x" + ] -------------------------------------------------------------------------------- case03 :: Assertion -case03 = expected @=? testSnippet (step (Just 80) defaultConfig) input - where - input = Snippet - [ "heady def [] = def" - , "heady _ (x : _) = x" - ] - - expected = Snippet - [ "heady def [] = def" - , "heady _ (x : _) = x" - ] +case03 = assertSnippet (step (Just 80) defaultConfig) + [ "heady def [] = def" + , "heady _ (x : _) = x" + ] + [ "heady def [] = def" + , "heady _ (x : _) = x" + ] -------------------------------------------------------------------------------- case04 :: Assertion -case04 = expected @=? testSnippet (step (Just 80) defaultConfig) input - where - input = Snippet - [ "data Foo = Foo" - , " { foo :: Int" - , " , barqux :: String" - , " } deriving (Show)" - ] - - expected = Snippet - [ "data Foo = Foo" - , " { foo :: Int" - , " , barqux :: String" - , " } deriving (Show)" - ] +case04 = assertSnippet (step (Just 80) defaultConfig) + [ "data Foo = Foo" + , " { foo :: Int" + , " , barqux :: String" + , " } deriving (Show)" + ] + [ "data Foo = Foo" + , " { foo :: Int" + , " , barqux :: String" + , " } deriving (Show)" + ] -------------------------------------------------------------------------------- case05 :: Assertion -case05 = input @=? testSnippet (step (Just 80) defaultConfig) input +case05 = assertSnippet (step (Just 80) defaultConfig) input input where -- Don't attempt to align this since a field spans multiple lines - input = Snippet + input = [ "data Foo = Foo" , " { foo :: Int" , " , barqux" @@ -114,81 +98,64 @@ case05 = input @=? testSnippet (step (Just 80) defaultConfig) input -------------------------------------------------------------------------------- case06 :: Assertion -case06 = +case06 = assertSnippet -- 22 max columns is /just/ enough to align this stuff. - expected @=? testSnippet (step (Just 22) defaultConfig) input - where - input = Snippet - [ "data Foo = Foo" - , " { foo :: String" - , " , barqux :: Int" - , " }" - ] - - expected = Snippet - [ "data Foo = Foo" - , " { foo :: String" - , " , barqux :: Int" - , " }" - ] + (step (Just 22) defaultConfig) + [ "data Foo = Foo" + , " { foo :: String" + , " , barqux :: Int" + , " }" + ] + [ "data Foo = Foo" + , " { foo :: String" + , " , barqux :: Int" + , " }" + ] -------------------------------------------------------------------------------- case07 :: Assertion -case07 = +case07 = assertSnippet -- 21 max columns is /just NOT/ enough to align this stuff. - expected @=? testSnippet (step (Just 21) defaultConfig) input - where - input = Snippet - [ "data Foo = Foo" - , " { foo :: String" - , " , barqux :: Int" - , " }" - ] - - expected = Snippet - [ "data Foo = Foo" - , " { foo :: String" - , " , barqux :: Int" - , " }" - ] + (step (Just 21) defaultConfig) + [ "data Foo = Foo" + , " { foo :: String" + , " , barqux :: Int" + , " }" + ] + [ "data Foo = Foo" + , " { foo :: String" + , " , barqux :: Int" + , " }" + ] -------------------------------------------------------------------------------- case08 :: Assertion -case08 = expected @=? testSnippet (step (Just 80) defaultConfig) input - where - input = Snippet - [ "canDrink mbAge = case mbAge of" - , " Just age | age > 18 -> True" - , " _ -> False" - ] - - expected = Snippet - [ "canDrink mbAge = case mbAge of" - , " Just age | age > 18 -> True" - , " _ -> False" - ] +case08 = assertSnippet (step (Just 80) defaultConfig) + [ "canDrink mbAge = case mbAge of" + , " Just age | age > 18 -> True" + , " _ -> False" + ] + [ "canDrink mbAge = case mbAge of" + , " Just age | age > 18 -> True" + , " _ -> False" + ] -------------------------------------------------------------------------------- case09 :: Assertion -case09 = - expected @=? testSnippet (step Nothing defaultConfig) input - where - input = Snippet - [ "data Foo = Foo" - , " { foo :: String" - , " , barqux :: Int" - , " }" - ] - - expected = Snippet - [ "data Foo = Foo" - , " { foo :: String" - , " , barqux :: Int" - , " }" - ] +case09 = assertSnippet (step Nothing defaultConfig) + [ "data Foo = Foo" + , " { foo :: String" + , " , barqux :: Int" + , " }" + ] + [ "data Foo = Foo" + , " { foo :: String" + , " , barqux :: Int" + , " }" + ] -------------------------------------------------------------------------------- From cab57f341f21535391b1c1c9991b49fd868a4591 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Fri, 25 Sep 2020 19:46:21 +0200 Subject: [PATCH 119/135] Clean up Align module --- .../Haskell/Stylish/Step/SimpleAlign.hs | 148 ++++++------------ .../Haskell/Stylish/Step/SimpleAlign/Tests.hs | 28 ++++ 2 files changed, 76 insertions(+), 100 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs b/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs index 7a7a62e9..e02c2701 100644 --- a/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs +++ b/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs @@ -1,5 +1,5 @@ -------------------------------------------------------------------------------- -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilies #-} module Language.Haskell.Stylish.Step.SimpleAlign ( Config (..) , defaultConfig @@ -8,8 +8,9 @@ module Language.Haskell.Stylish.Step.SimpleAlign -------------------------------------------------------------------------------- -import Data.Maybe (fromMaybe, maybeToList) +import Control.Monad (guard) import Data.List (foldl') +import Data.Maybe (fromMaybe) import qualified GHC.Hs as Hs import qualified SrcLoc as S @@ -17,16 +18,15 @@ import qualified SrcLoc as S -------------------------------------------------------------------------------- import Language.Haskell.Stylish.Align import Language.Haskell.Stylish.Editor +import Language.Haskell.Stylish.Module import Language.Haskell.Stylish.Step import Language.Haskell.Stylish.Util -import Language.Haskell.Stylish.Module -------------------------------------------------------------------------------- data Config = Config { cCases :: !Bool , cTopLevelPatterns :: !Bool - -- TODO: Matches , cRecords :: !Bool } deriving (Show) @@ -39,36 +39,22 @@ defaultConfig = Config , cRecords = True } + -------------------------------------------------------------------------------- --- -_tlpats :: (S.Located (Hs.HsModule Hs.GhcPs)) -> [[S.Located (Hs.Match Hs.GhcPs (Hs.LHsExpr Hs.GhcPs))]] -_tlpats modu = - let - decls = map S.unLoc (Hs.hsmodDecls (S.unLoc modu)) - binds = [ bind | Hs.ValD _ bind <- decls ] - funMatches = map Hs.fun_matches binds - matches = map Hs.mg_alts funMatches - in - map S.unLoc matches +type Record = [S.Located (Hs.ConDeclField Hs.GhcPs)] + -------------------------------------------------------------------------------- -records :: (S.Located (Hs.HsModule Hs.GhcPs)) -> [[S.Located (Hs.ConDeclField Hs.GhcPs)]] +records :: S.Located (Hs.HsModule Hs.GhcPs) -> [Record] records modu = do let decls = map S.unLoc (Hs.hsmodDecls (S.unLoc modu)) tyClDecls = [ tyClDecl | Hs.TyClD _ tyClDecl <- decls ] dataDecls = [ d | d@(Hs.DataDecl _ _ _ _ _) <- tyClDecls ] dataDefns = map Hs.tcdDataDefn dataDecls d@Hs.ConDeclH98 {} <- concatMap getConDecls dataDefns - pure $ do - Hs.RecCon rec <- [Hs.con_args d] - S.unLoc rec - {- - let conDeclDetails = getConDeclDetails conDecl - llConDeclFields = getLocRecs conDeclDetails - lConDeclFields = concatMap S.unLoc llConDeclFields - [ lConDeclFields ] - -} - + case Hs.con_args d of + Hs.RecCon rec -> [S.unLoc rec] + _ -> [] where getConDecls :: Hs.HsDataDefn Hs.GhcPs -> [Hs.ConDecl Hs.GhcPs] getConDecls d@Hs.HsDataDefn {} = map S.unLoc $ Hs.dd_cons d @@ -76,59 +62,48 @@ records modu = do -------------------------------------------------------------------------------- --- get Arguments from data Construction Declaration -getConDeclDetails :: Hs.ConDecl Hs.GhcPs -> Hs.HsConDeclDetails Hs.GhcPs -getConDeclDetails d@(Hs.ConDeclGADT _ _ _ _ _ _ _ _) = Hs.con_args d -getConDeclDetails d@(Hs.ConDeclH98 _ _ _ _ _ _ _) = Hs.con_args d -getConDeclDetails (Hs.XConDecl x) = Hs.noExtCon x +recordToAlignable :: Record -> [Alignable S.RealSrcSpan] +recordToAlignable = fromMaybe [] . traverse fieldDeclToAlignable -------------------------------------------------------------------------------- --- look for Record(s) in a list of Construction Declaration details -getLocRecs :: [Hs.HsConDeclDetails Hs.GhcPs] -> [S.Located [Hs.LConDeclField Hs.GhcPs]] -getLocRecs conDeclDetails = - [ rec | Hs.RecCon rec <- conDeclDetails ] - - - -_matchToAlignable :: S.Located (Hs.Match Hs.GhcPs (Hs.LHsExpr Hs.GhcPs)) -> Maybe (Alignable S.RealSrcSpan) -_matchToAlignable (S.L matchLoc (Hs.Match _ (Hs.FunRhs name _ _) pats grhss)) = do - body <- unguardedRhsBody grhss - let patsLocs = map S.getLoc pats - nameLoc = S.getLoc name - left = last (nameLoc : patsLocs) - bodyLoc = S.getLoc body +fieldDeclToAlignable + :: S.Located (Hs.ConDeclField Hs.GhcPs) -> Maybe (Alignable S.RealSrcSpan) +fieldDeclToAlignable (S.L _ (Hs.XConDeclField x)) = Hs.noExtCon x +fieldDeclToAlignable (S.L matchLoc (Hs.ConDeclField _ names ty _)) = do matchPos <- toRealSrcSpan matchLoc - leftPos <- toRealSrcSpan left - bodyPos <- toRealSrcSpan bodyLoc + leftPos <- toRealSrcSpan $ S.getLoc $ last names + tyPos <- toRealSrcSpan $ S.getLoc ty Just $ Alignable { aContainer = matchPos , aLeft = leftPos - , aRight = bodyPos - , aRightLead = length "= " + , aRight = tyPos + , aRightLead = length ":: " } -_matchToAlignable (S.L _ (Hs.Match _ _ [] _)) = Nothing -_matchToAlignable (S.L _ (Hs.Match _ _ _ _ )) = Nothing -_matchToAlignable (S.L _ (Hs.XMatch x)) = Hs.noExtCon x -{- -rhsBodies :: Hs.GRHSs Hs.GhcPs a -> [a] -rhsBodies (Hs.GRHSs _ grhss _) = [body | Hs.GRHS _ _ body <- map S.unLoc grhss] --} +-------------------------------------------------------------------------------- matchGroupToAlignable - :: Hs.MatchGroup Hs.GhcPs (Hs.LHsExpr Hs.GhcPs) -> [Alignable S.RealSrcSpan] -matchGroupToAlignable (Hs.XMatchGroup x) = Hs.noExtCon x -matchGroupToAlignable (Hs.MG _ alts _) = - fromMaybe [] $ traverse caseToAlignable (S.unLoc alts) + :: Config + -> Hs.MatchGroup Hs.GhcPs (Hs.LHsExpr Hs.GhcPs) + -> [Alignable S.RealSrcSpan] +matchGroupToAlignable _conf (Hs.XMatchGroup x) = Hs.noExtCon x +matchGroupToAlignable conf (Hs.MG _ alts _) = + fromMaybe [] $ traverse (matchToAlignable conf) (S.unLoc alts) + -caseToAlignable :: S.Located (Hs.Match Hs.GhcPs (Hs.LHsExpr Hs.GhcPs)) -> Maybe (Alignable S.RealSrcSpan) -caseToAlignable (S.L matchLoc m@(Hs.Match _ Hs.CaseAlt pats@(_ : _) grhss)) = do +-------------------------------------------------------------------------------- +matchToAlignable + :: Config + -> S.Located (Hs.Match Hs.GhcPs (Hs.LHsExpr Hs.GhcPs)) + -> Maybe (Alignable S.RealSrcSpan) +matchToAlignable conf (S.L matchLoc m@(Hs.Match _ Hs.CaseAlt pats@(_ : _) grhss)) = do let patsLocs = map S.getLoc pats pat = last patsLocs guards = getGuards m guardsLocs = map S.getLoc guards left = foldl' S.combineSrcSpans pat guardsLocs + guard $ cCases conf body <- rhsBody grhss matchPos <- toRealSrcSpan matchLoc leftPos <- toRealSrcSpan left @@ -139,7 +114,8 @@ caseToAlignable (S.L matchLoc m@(Hs.Match _ Hs.CaseAlt pats@(_ : _) grhss)) = do , aRight = rightPos , aRightLead = length "-> " } -caseToAlignable (S.L matchLoc (Hs.Match _ (Hs.FunRhs name _ _) pats@(_ : _) grhss)) = do +matchToAlignable conf (S.L matchLoc (Hs.Match _ (Hs.FunRhs name _ _) pats@(_ : _) grhss)) = do + guard $ cTopLevelPatterns conf body <- unguardedRhsBody grhss let patsLocs = map S.getLoc pats nameLoc = S.getLoc name @@ -154,50 +130,22 @@ caseToAlignable (S.L matchLoc (Hs.Match _ (Hs.FunRhs name _ _) pats@(_ : _) grhs , aRight = bodyPos , aRightLead = length "= " } -caseToAlignable (S.L _ (Hs.XMatch x)) = Hs.noExtCon x -caseToAlignable (S.L _ (Hs.Match _ _ _ _)) = Nothing +matchToAlignable _conf (S.L _ (Hs.XMatch x)) = Hs.noExtCon x +matchToAlignable _conf (S.L _ (Hs.Match _ _ _ _)) = Nothing -recordToAlignable :: [S.Located (Hs.ConDeclField Hs.GhcPs)] -> [Alignable S.RealSrcSpan] -recordToAlignable = fromMaybe [] . traverse fieldDeclToAlignable - -fieldDeclToAlignable :: S.Located (Hs.ConDeclField Hs.GhcPs) -> Maybe (Alignable S.RealSrcSpan) -fieldDeclToAlignable (S.L _ (Hs.XConDeclField x)) = Hs.noExtCon x -fieldDeclToAlignable (S.L matchLoc (Hs.ConDeclField _ names ty _)) = do - matchPos <- toRealSrcSpan matchLoc - leftPos <- toRealSrcSpan $ S.getLoc $ last names - tyPos <- toRealSrcSpan $ S.getLoc ty - Just $ Alignable - { aContainer = matchPos - , aLeft = leftPos - , aRight = tyPos - , aRightLead = length ":: " - } +-------------------------------------------------------------------------------- step :: Maybe Int -> Config -> Step step maxColumns config = makeStep "Cases" $ \ls module' -> - let changes :: ((S.Located (Hs.HsModule Hs.GhcPs)) -> [a]) -> (a -> [Alignable S.RealSrcSpan]) -> [Change String] + let changes + :: (S.Located (Hs.HsModule Hs.GhcPs) -> [a]) + -> (a -> [Alignable S.RealSrcSpan]) + -> [Change String] changes search toAlign = concat $ map (align maxColumns) . map toAlign $ search (parsedModule module') - {- - [ change_ - | case_ <- search (parsedModule module') - , aligns <- maybeToList (mapM toAlign case_) - , change_ <- traceOutputtable "aligns" (length aligns) $ - align maxColumns aligns - ] - -} + configured :: [Change String] configured = concat $ - -- [changes tlpats matchToAlignable | cTopLevelPatterns config] ++ - [changes records recordToAlignable | cRecords config] ++ - [changes everything matchGroupToAlignable | cCases config] - -- [changes everything caseToAlignable | cCases config] - - cases = everything (parsedModule module') :: [S.Located (Hs.Match Hs.GhcPs (Hs.LHsExpr Hs.GhcPs))] - matchgroups = everything (parsedModule module') :: [Hs.MatchGroup Hs.GhcPs (Hs.LHsExpr Hs.GhcPs)] - in - -- traceOutputtable "tlpats" (tlpats $ parsedModule module') $ - traceOutputtable "matchgroups" (length matchgroups) $ - traceOutputtable "records" (records $ parsedModule module') $ - traceOutputtable "cases" (cases) $ + [changes records recordToAlignable | cRecords config] ++ + [changes everything (matchGroupToAlignable config)] in applyChanges configured ls diff --git a/tests/Language/Haskell/Stylish/Step/SimpleAlign/Tests.hs b/tests/Language/Haskell/Stylish/Step/SimpleAlign/Tests.hs index 2bf66eaf..fa17784e 100644 --- a/tests/Language/Haskell/Stylish/Step/SimpleAlign/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/SimpleAlign/Tests.hs @@ -29,6 +29,8 @@ tests = testGroup "Language.Haskell.Stylish.Step.SimpleAlign.Tests" , testCase "case 08" case08 , testCase "case 09" case09 , testCase "case 10" case10 + , testCase "case 11" case11 + , testCase "case 12" case12 ] @@ -171,3 +173,29 @@ case10 = assertSnippet (step Nothing defaultConfig) , " File -> fileAlign" , " Group -> anyQual" ] + + +-------------------------------------------------------------------------------- +case11 :: Assertion +case11 = assertSnippet (step Nothing defaultConfig) + [ "data Foo = Foo" + , " { foo :: String" + , " , barqux :: !Int" + , " }" + ] + [ "data Foo = Foo" + , " { foo :: String" + , " , barqux :: !Int" + , " }" + ] + + +-------------------------------------------------------------------------------- +case12 :: Assertion +case12 = assertSnippet (step Nothing defaultConfig {cCases = False}) input input + where + input = + [ "case x of" + , " Just y -> 1" + , " Nothing -> 2" + ] From 012deafd1c76b4e975e23662778a4b8fc4ffa979 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sat, 26 Sep 2020 16:14:27 +0200 Subject: [PATCH 120/135] Improve Show instance for Snippet --- tests/Language/Haskell/Stylish/Tests/Util.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/tests/Language/Haskell/Stylish/Tests/Util.hs b/tests/Language/Haskell/Stylish/Tests/Util.hs index 82c86a0d..88697d8f 100644 --- a/tests/Language/Haskell/Stylish/Tests/Util.hs +++ b/tests/Language/Haskell/Stylish/Tests/Util.hs @@ -57,7 +57,9 @@ testStep' s ls = lines $ testStep s (unlines ls) -- | 'Lines' that show as a normal string. newtype Snippet = Snippet {unSnippet :: Lines} deriving (Eq) -instance Show Snippet where show = unlines . unSnippet +-- Prefix with one newline since so HUnit will use a newline after `got: ` or +-- `expected: `. +instance Show Snippet where show = unlines . ("" :) . unSnippet instance IsList Snippet where type Item Snippet = String From eccacb0cce0e5533822862f9c26f8d0c59b86d36 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sat, 26 Sep 2020 16:16:23 +0200 Subject: [PATCH 121/135] Remove ghc_lib_parser option --- lib/Language/Haskell/Stylish/Config.hs | 1 - lib/Language/Haskell/Stylish/Step/Imports.hs | 2 - .../Haskell/Stylish/Step/Imports/Tests.hs | 46 +++++++++---------- 3 files changed, 23 insertions(+), 26 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Config.hs b/lib/Language/Haskell/Stylish/Config.hs index 4872f63e..16b7ff2f 100644 --- a/lib/Language/Haskell/Stylish/Config.hs +++ b/lib/Language/Haskell/Stylish/Config.hs @@ -257,7 +257,6 @@ parseImports config o = fmap (Imports.step columns) $ Imports.Options <*> (o A..:? "list_padding" >>= maybe (pure $ def Imports.listPadding) parseListPadding) <*> o A..:? "separate_lists" A..!= def Imports.separateLists <*> o A..:? "space_surround" A..!= def Imports.spaceSurround - <*> o A..:? "ghc_lib_parser" A..!= True where def f = f Imports.defaultOptions diff --git a/lib/Language/Haskell/Stylish/Step/Imports.hs b/lib/Language/Haskell/Stylish/Step/Imports.hs index 65f1e0b3..21ec1ff5 100644 --- a/lib/Language/Haskell/Stylish/Step/Imports.hs +++ b/lib/Language/Haskell/Stylish/Step/Imports.hs @@ -60,7 +60,6 @@ data Options = Options , listPadding :: ListPadding , separateLists :: Bool , spaceSurround :: Bool - , useGhcLibParser :: Bool -- ^ if True, will use new printer } deriving (Eq, Show) defaultOptions :: Options @@ -73,7 +72,6 @@ defaultOptions = Options , listPadding = LPConstant 4 , separateLists = True , spaceSurround = False - , useGhcLibParser = False } data ListPadding diff --git a/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs index 0a6efc41..474de668 100644 --- a/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs @@ -200,7 +200,7 @@ case07 = case08 :: Assertion case08 = let - options = Options Global WithAlias True Inline Inherit (LPConstant 4) True False False + options = Options Global WithAlias True Inline Inherit (LPConstant 4) True False in expected @=? testSnippet (step (Just 80) options) input where @@ -226,7 +226,7 @@ case08 = case08b :: Assertion case08b = let - options = Options Global WithModuleName True Inline Inherit (LPConstant 4) True False False + options = Options Global WithModuleName True Inline Inherit (LPConstant 4) True False in expected @=? testSnippet (step (Just 80) options) input where @@ -251,7 +251,7 @@ case08b = case09 :: Assertion case09 = let - options = Options Global WithAlias True Multiline Inherit (LPConstant 4) True False False + options = Options Global WithAlias True Multiline Inherit (LPConstant 4) True False in expected @=? testSnippet (step (Just 80) options) input where @@ -288,7 +288,7 @@ case09 = case10 :: Assertion case10 = let - options = Options Group WithAlias True Multiline Inherit (LPConstant 4) True False False + options = Options Group WithAlias True Multiline Inherit (LPConstant 4) True False in expected @=? testSnippet (step (Just 40) options) input where @@ -331,7 +331,7 @@ case10 = case11 :: Assertion case11 = let - options = Options Group NewLine True Inline Inherit (LPConstant 4) True False False + options = Options Group NewLine True Inline Inherit (LPConstant 4) True False in expected @=? testSnippet (step (Just 80) options) input where @@ -361,7 +361,7 @@ case11 = case11b :: Assertion case11b = let - options = Options Group WithModuleName True Inline Inherit (LPConstant 4) True False False + options = Options Group WithModuleName True Inline Inherit (LPConstant 4) True False in expected @=? testSnippet (step (Just 80) options) input where @@ -386,7 +386,7 @@ case11b = case12 :: Assertion case12 = let - options = Options Group NewLine True Inline Inherit (LPConstant 2) True False False + options = Options Group NewLine True Inline Inherit (LPConstant 2) True False in expected @=? testSnippet (step (Just 80) options) input' where @@ -404,7 +404,7 @@ case12 = case12b :: Assertion case12b = let - options = Options Group WithModuleName True Inline Inherit (LPConstant 2) True False False + options = Options Group WithModuleName True Inline Inherit (LPConstant 2) True False in expected @=? testStep' (step (Just 80) options) input' where @@ -417,7 +417,7 @@ case12b = case13 :: Assertion case13 = let - options = Options None WithAlias True InlineWithBreak Inherit (LPConstant 4) True False False + options = Options None WithAlias True InlineWithBreak Inherit (LPConstant 4) True False in expected @=? testSnippet (step (Just 80) options) input' where @@ -437,7 +437,7 @@ case13 = case13b :: Assertion case13b = let - options = Options None WithModuleName True InlineWithBreak Inherit (LPConstant 4) True False False + options = Options None WithModuleName True InlineWithBreak Inherit (LPConstant 4) True False in expected @=? testSnippet (step (Just 80) options) input' where @@ -457,7 +457,7 @@ case13b = case14 :: Assertion case14 = let - options = Options None WithAlias True InlineWithBreak Inherit (LPConstant 10) True False False + options = Options None WithAlias True InlineWithBreak Inherit (LPConstant 10) True False in expected @=? testSnippet (step (Just 80) options) expected where @@ -470,7 +470,7 @@ case14 = case15 :: Assertion case15 = let - options = Options None AfterAlias True Multiline Inherit (LPConstant 4) True False False + options = Options None AfterAlias True Multiline Inherit (LPConstant 4) True False in expected @=? testSnippet (step (Just 80) options) input' where @@ -499,7 +499,7 @@ case15 = case16 :: Assertion case16 = let - options = Options None AfterAlias True Multiline Inherit (LPConstant 4) False False False + options = Options None AfterAlias True Multiline Inherit (LPConstant 4) False False in expected @=? testSnippet (step (Just 80) options) input' where @@ -526,7 +526,7 @@ case16 = case17 :: Assertion case17 = let - options = Options None AfterAlias True Multiline Inherit (LPConstant 4) True False False + options = Options None AfterAlias True Multiline Inherit (LPConstant 4) True False in expected @=? testSnippet (step (Just 80) options) input' where @@ -547,7 +547,7 @@ case17 = case18 :: Assertion case18 = let - options = Options None AfterAlias True InlineToMultiline Inherit (LPConstant 4) True False False + options = Options None AfterAlias True InlineToMultiline Inherit (LPConstant 4) True False in expected @=? testSnippet (step (Just 40) options) input' where @@ -578,7 +578,7 @@ case18 = case19 :: Assertion case19 = let - options = Options Global NewLine True InlineWithBreak RightAfter (LPConstant 17) True False False + options = Options Global NewLine True InlineWithBreak RightAfter (LPConstant 17) True False in expected @=? testSnippet (step (Just 40) options) case19input where @@ -597,7 +597,7 @@ case19 = case19b :: Assertion case19b = let - options = Options File NewLine True InlineWithBreak RightAfter (LPConstant 17) True False False + options = Options File NewLine True InlineWithBreak RightAfter (LPConstant 17) True False in expected @=? testSnippet (step (Just 40) options) case19input where @@ -615,7 +615,7 @@ case19b = case19c :: Assertion case19c = let - options = Options File NewLine True InlineWithBreak RightAfter LPModuleName True False False + options = Options File NewLine True InlineWithBreak RightAfter LPModuleName True False in expected @=? testSnippet (step (Just 40) options) case19input where @@ -633,7 +633,7 @@ case19c = case19d :: Assertion case19d = let - options = Options Global NewLine True InlineWithBreak RightAfter LPModuleName True False False + options = Options Global NewLine True InlineWithBreak RightAfter LPModuleName True False in expected @=? testSnippet (step (Just 40) options) case19input where @@ -739,7 +739,7 @@ case22 = expected case23 :: Assertion case23 = let - options = Options None AfterAlias False Inline Inherit (LPConstant 4) True True False + options = Options None AfterAlias False Inline Inherit (LPConstant 4) True True in expected @=? testSnippet (step (Just 40) options) input' where @@ -768,7 +768,7 @@ case23 = case23b :: Assertion case23b = let - options = Options None WithModuleName False Inline Inherit (LPConstant 4) True True False + options = Options None WithModuleName False Inline Inherit (LPConstant 4) True True in expected @=? testSnippet (step (Just 40) options) input' where @@ -798,7 +798,7 @@ case23b = case24 :: Assertion case24 = let - options = Options None AfterAlias False InlineWithBreak Inherit (LPConstant 4) True True False + options = Options None AfterAlias False InlineWithBreak Inherit (LPConstant 4) True True in expected @=? testSnippet (step (Just 40) options) input' where @@ -826,7 +826,7 @@ case24 = case25 :: Assertion case25 = let - options = Options Group AfterAlias False Multiline Inherit (LPConstant 4) False False False + options = Options Group AfterAlias False Multiline Inherit (LPConstant 4) False False in expected @=? testSnippet (step (Just 80) options) input' where From 9078e35a637cdb05f5b9912db526031eb557376d Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sat, 26 Sep 2020 16:17:03 +0200 Subject: [PATCH 122/135] Make indent in ModuleHeader configurable --- data/stylish-haskell.yaml | 4 +- lib/Language/Haskell/Stylish/Config.hs | 6 +- .../Haskell/Stylish/Step/ModuleHeader.hs | 65 ++- .../Stylish/Step/ModuleHeader/Tests.hs | 497 +++++++++--------- 4 files changed, 300 insertions(+), 272 deletions(-) diff --git a/data/stylish-haskell.yaml b/data/stylish-haskell.yaml index 2979afd5..cec5cd5c 100644 --- a/data/stylish-haskell.yaml +++ b/data/stylish-haskell.yaml @@ -20,7 +20,9 @@ steps: # Currently, this option is not configurable and will format all exports and # module declarations to minimize diffs # - # - module_header: {} + # - module_header: + # # How many spaces use for indentation in the module header. + # indent: 4 # Format record definitions. This is disabled by default. # diff --git a/lib/Language/Haskell/Stylish/Config.hs b/lib/Language/Haskell/Stylish/Config.hs index 16b7ff2f..904b183a 100644 --- a/lib/Language/Haskell/Stylish/Config.hs +++ b/lib/Language/Haskell/Stylish/Config.hs @@ -194,10 +194,8 @@ parseEnum strs _ (Just k) = case lookup k strs of -------------------------------------------------------------------------------- parseModuleHeader :: Config -> A.Object -> A.Parser Step -parseModuleHeader _ _ - = pure - . ModuleHeader.step - $ ModuleHeader.Config +parseModuleHeader _ o = (ModuleHeader.step . ModuleHeader.Config) <$> + o A..:? "indent" A..!= 4 -------------------------------------------------------------------------------- parseSimpleAlign :: Config -> A.Object -> A.Parser Step diff --git a/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs b/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs index 9eaee2d3..708c3fd7 100644 --- a/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs +++ b/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs @@ -2,6 +2,7 @@ {-# LANGUAGE LambdaCase #-} module Language.Haskell.Stylish.Step.ModuleHeader ( Config (..) + , defaultConfig , step ) where @@ -34,12 +35,21 @@ import Language.Haskell.Stylish.GHC data Config = Config + -- TODO(jaspervdj): Use the same sorting as in `Imports`? + -- TODO: make sorting optional? + { indent :: Int + } + +defaultConfig :: Config +defaultConfig = Config + { indent = 4 + } step :: Config -> Step step = makeStep "Module header" . printModuleHeader printModuleHeader :: Config -> Lines -> Module -> Lines -printModuleHeader _ ls m = +printModuleHeader conf ls m = let header = moduleHeader m name = rawModuleName header @@ -56,7 +66,7 @@ printModuleHeader _ ls m = -- TODO: pass max columns? printedModuleHeader = runPrinter_ (PrinterConfig Nothing) relevantComments - m (printHeader name exports haddocks) + m (printHeader conf name exports haddocks) getBlock loc = Block <$> fmap getStartLineUnsafe loc <*> fmap getEndLineUnsafe loc @@ -110,12 +120,13 @@ printModuleHeader _ ls m = in applyChanges changes ls -printHeader :: - Maybe (Located GHC.ModuleName) +printHeader + :: Config + -> Maybe (Located GHC.ModuleName) -> Maybe (Located [GHC.LIE GhcPs]) -> Maybe GHC.LHsDocString -> P () -printHeader mname mexps _ = do +printHeader conf mname mexps _ = do forM_ mname \(L loc name) -> do putText "module" space @@ -123,8 +134,8 @@ printHeader mname mexps _ = do attachEolComment loc maybe - (when (isJust mname) do newline >> space >> space >> putText "where") - printExportList + (when (isJust mname) do newline >> spaces (indent conf) >> putText "where") + (printExportList conf) mexps attachEolComment :: SrcSpan -> P () @@ -139,10 +150,10 @@ attachEolCommentEnd = \case RealSrcSpan rspan -> removeLineComment (srcSpanEndLine rspan) >>= mapM_ \c -> space >> putComment c -printExportList :: Located [GHC.LIE GhcPs] -> P () -printExportList (L srcLoc exports) = do +printExportList :: Config -> Located [GHC.LIE GhcPs] -> P () +printExportList conf (L srcLoc exports) = do newline - spaces 2 >> putText "(" >> when (notNull exports) space + doIndent >> putText "(" >> when (notNull exports) space exportsWithComments <- sortedAttachedComments exports @@ -150,31 +161,49 @@ printExportList (L srcLoc exports) = do putText ")" >> space >> putText "where" >> attachEolCommentEnd srcLoc where + -- 'doIndent' is @x@: + -- + -- > module Foo + -- > xxxx( foo + -- > xxxx, bar + -- > xxxx) where + -- + -- 'doHang' is @y@: + -- + -- > module Foo + -- > xxxx( -- Some comment + -- > xxxxyyfoo + -- > xxxx) where + doIndent = spaces (indent conf) + doHang = do + len <- length <$> getCurrentLine + spaces $ indent conf + 2 - len + printExports :: [([AnnotationComment], NonEmpty (GHC.LIE GhcPs))] -> P () printExports (([], firstInGroup :| groupRest) : rest) = do printExport firstInGroup newline - spaces 2 + doIndent printExportsGroupTail groupRest printExportsTail rest printExports ((firstComment : comments, firstExport :| groupRest) : rest) = do - putComment firstComment >> newline >> spaces 2 - forM_ comments \c -> spaces 2 >> putComment c >> newline >> spaces 2 - spaces 2 + putComment firstComment >> newline >> doIndent + forM_ comments \c -> doHang >> putComment c >> newline >> doIndent + doHang printExport firstExport newline - spaces 2 + doIndent printExportsGroupTail groupRest printExportsTail rest printExports [] = - newline >> spaces 2 + newline >> doIndent printExportsTail :: [([AnnotationComment], NonEmpty (GHC.LIE GhcPs))] -> P () printExportsTail = mapM_ \(comments, exported) -> do - forM_ comments \c -> spaces 2 >> putComment c >> newline >> spaces 2 + forM_ comments \c -> doHang >> putComment c >> newline >> doIndent forM_ exported \export -> do comma >> space >> printExport export - newline >> spaces 2 + newline >> doIndent printExportsGroupTail :: [GHC.LIE GhcPs] -> P () printExportsGroupTail (x : xs) = printExportsTail [([], x :| xs)] diff --git a/tests/Language/Haskell/Stylish/Step/ModuleHeader/Tests.hs b/tests/Language/Haskell/Stylish/Step/ModuleHeader/Tests.hs index 63aca024..f0107232 100644 --- a/tests/Language/Haskell/Stylish/Step/ModuleHeader/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/ModuleHeader/Tests.hs @@ -1,291 +1,290 @@ +{-# LANGUAGE OverloadedLists #-} module Language.Haskell.Stylish.Step.ModuleHeader.Tests ( tests ) where -------------------------------------------------------------------------------- +import Prelude hiding (lines) import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit (Assertion, (@=?)) -import GHC.Stack (HasCallStack, withFrozenCallStack) -import Prelude hiding (lines) +import Test.HUnit (Assertion) -------------------------------------------------------------------------------- -import Language.Haskell.Stylish.Module -import Language.Haskell.Stylish.Tests.Util (testStep') -import Language.Haskell.Stylish.Step.ModuleHeader (step) -import qualified Language.Haskell.Stylish.Step.ModuleHeader as ModuleHeader - +import Language.Haskell.Stylish.Step.ModuleHeader +import Language.Haskell.Stylish.Tests.Util -------------------------------------------------------------------------------- tests :: Test tests = testGroup "Language.Haskell.Stylish.Printer.ModuleHeader" - [ testCase "Hello world" ex0 - , testCase "Empty exports list" ex1 - , testCase "Single exported variable" ex2 - , testCase "Multiple exported variables" ex3 - , testCase "Only reformats module header" ex4 - , testCase "Leaving pragmas in place" ex5 - , testCase "Leaving pragmas in place variant" ex6 - , testCase "Leaving comments in place" ex7 - , testCase "Exports all" ex8 - , testCase "Exports module" ex9 - , testCase "Exports symbol" ex10 - , testCase "Respects groups" ex11 - , testCase "'where' not repeated in case it isn't part of exports" ex12 - ] + [ testCase "Hello world" ex0 + , testCase "Empty exports list" ex1 + , testCase "Single exported variable" ex2 + , testCase "Multiple exported variables" ex3 + , testCase "Only reformats module header" ex4 + , testCase "Leaving pragmas in place" ex5 + , testCase "Leaving pragmas in place variant" ex6 + , testCase "Leaving comments in place" ex7 + , testCase "Exports all" ex8 + , testCase "Exports module" ex9 + , testCase "Exports symbol" ex10 + , testCase "Respects groups" ex11 + , testCase "'where' not repeated in case it isn't part of exports" ex12 + , testCase "Indents absent export list with 2 spaces" ex13 + , testCase "Indents with 2 spaces" ex14 + , testCase "Group doc with 2 spaces" ex15 + ] -------------------------------------------------------------------------------- ex0 :: Assertion -ex0 = input `assertFormatted` output - where - input = - [ "module Foo where" - ] - output = - [ "module Foo" - , " where" - ] +ex0 = assertSnippet (step defaultConfig) + [ "module Foo where" + ] + [ "module Foo" + , " where" + ] ex1 :: Assertion -ex1 = input `assertFormatted` output - where - input = - [ "module Foo () where" - ] - output = - [ "module Foo" - , " (" - , " ) where" - ] +ex1 = assertSnippet (step defaultConfig) + [ "module Foo () where" + ] + [ "module Foo" + , " (" + , " ) where" + ] ex2 :: Assertion -ex2 = input `assertFormatted` output - where - input = - [ "module Foo (tests) where" - ] - output = - [ "module Foo" - , " ( tests" - , " ) where" - ] +ex2 = assertSnippet (step defaultConfig) + [ "module Foo (tests) where" + ] + [ "module Foo" + , " ( tests" + , " ) where" + ] ex3 :: Assertion -ex3 = input `assertFormatted` output - where - input = - [ "module Foo (t1, t2, t3) where" - ] - output = - [ "module Foo" - , " ( t1" - , " , t2" - , " , t3" - , " ) where" - ] +ex3 = assertSnippet (step defaultConfig) + [ "module Foo (t1, t2, t3) where" + ] + [ "module Foo" + , " ( t1" + , " , t2" + , " , t3" + , " ) where" + ] ex4 :: Assertion -ex4 = input `assertFormatted` output - where - input = - [ "module Foo (" - , " t1," - , " t3," - , " t2" - , ") where" - , "" - , "" - , "-- | Docstring" - , "foo :: Int" - , "foo = 1" - ] - output = - [ "module Foo" - , " ( t1" - , " , t2" - , " , t3" - , " ) where" - , "" - , "" - , "-- | Docstring" - , "foo :: Int" - , "foo = 1" - ] +ex4 = assertSnippet (step defaultConfig) + [ "module Foo (" + , " t1," + , " t3," + , " t2" + , ") where" + , "" + , "" + , "-- | Docstring" + , "foo :: Int" + , "foo = 1" + ] + [ "module Foo" + , " ( t1" + , " , t2" + , " , t3" + , " ) where" + , "" + , "" + , "-- | Docstring" + , "foo :: Int" + , "foo = 1" + ] ex5 :: Assertion -ex5 = input `assertFormatted` output - where - input = - [ "{-# LANGUAGE DerivingVia #-}" - , "-- | This module docs" - , "module Foo (" - , " t1," - , " t3," - , " t2" - , ") where" - ] - output = - [ "{-# LANGUAGE DerivingVia #-}" - , "-- | This module docs" - , "module Foo" - , " ( t1" - , " , t2" - , " , t3" - , " ) where" - ] +ex5 = assertSnippet (step defaultConfig) + [ "{-# LANGUAGE DerivingVia #-}" + , "-- | This module docs" + , "module Foo (" + , " t1," + , " t3," + , " t2" + , ") where" + ] + [ "{-# LANGUAGE DerivingVia #-}" + , "-- | This module docs" + , "module Foo" + , " ( t1" + , " , t2" + , " , t3" + , " ) where" + ] + ex6 :: Assertion -ex6 = input `assertFormatted` output - where - input = - [ "-- | This module docs" - , "{-# LANGUAGE DerivingVia #-}" - , "module Foo (" - , " t1," - , " t3," - , " t2" - , ") where" - ] - output = - [ "-- | This module docs" - , "{-# LANGUAGE DerivingVia #-}" - , "module Foo" - , " ( t1" - , " , t2" - , " , t3" - , " ) where" - ] +ex6 = assertSnippet (step defaultConfig) + [ "-- | This module docs" + , "{-# LANGUAGE DerivingVia #-}" + , "module Foo (" + , " t1," + , " t3," + , " t2" + , ") where" + ] + [ "-- | This module docs" + , "{-# LANGUAGE DerivingVia #-}" + , "module Foo" + , " ( t1" + , " , t2" + , " , t3" + , " ) where" + ] ex7 :: Assertion -ex7 = input `assertFormatted` output - where - input = - [ "module Foo -- Foo" - , "(" - , " -- * t1 something" - , " t3," - , " t1," - , " -- * t2 something" - , " t2" - , ") where -- x" - , "-- y" - ] - output = - [ "module Foo -- Foo" - , " ( -- * t1 something" - , " t1" - , " , t3" - , " -- * t2 something" - , " , t2" - , " ) where -- x" - , "-- y" - ] +ex7 = assertSnippet (step defaultConfig) + [ "module Foo -- Foo" + , "(" + , " -- * t1 something" + , " t3," + , " t1," + , " -- * t2 something" + , " t2" + , ") where -- x" + , "-- y" + ] + [ "module Foo -- Foo" + , " ( -- * t1 something" + , " t1" + , " , t3" + , " -- * t2 something" + , " , t2" + , " ) where -- x" + , "-- y" + ] ex8 :: Assertion -ex8 = input `assertFormatted` output - where - input = - [ "module Foo (" - , " -- * t1 something" - , " t3," - , " A(..)," - , " -- * t2 something" - , " t2," - , " t1" - , ") where -- x" - , "-- y" - ] - output = - [ "module Foo" - , " ( -- * t1 something" - , " A (..)" - , " , t3" - , " -- * t2 something" - , " , t1" - , " , t2" - , " ) where -- x" - , "-- y" - ] +ex8 = assertSnippet (step defaultConfig) + [ "module Foo (" + , " -- * t1 something" + , " t3," + , " A(..)," + , " -- * t2 something" + , " t2," + , " t1" + , ") where -- x" + , "-- y" + ] + [ "module Foo" + , " ( -- * t1 something" + , " A (..)" + , " , t3" + , " -- * t2 something" + , " , t1" + , " , t2" + , " ) where -- x" + , "-- y" + ] ex9 :: Assertion -ex9 = input `assertFormatted` output - where - input = - [ "module Foo (" - , " -- * t1 something" - , " module A," - , " t3," - , " -- * t2 something" - , " t2" - , ") where -- x" - , "-- y" - ] - output = - [ "module Foo" - , " ( -- * t1 something" - , " module A" - , " , t3" - , " -- * t2 something" - , " , t2" - , " ) where -- x" - , "-- y" - ] +ex9 = assertSnippet (step defaultConfig) + [ "module Foo (" + , " -- * t1 something" + , " module A," + , " t3," + , " -- * t2 something" + , " t2" + , ") where -- x" + , "-- y" + ] + [ "module Foo" + , " ( -- * t1 something" + , " module A" + , " , t3" + , " -- * t2 something" + , " , t2" + , " ) where -- x" + , "-- y" + ] ex10 :: Assertion -ex10 = input `assertFormatted` output - where - input = - [ "module Foo (" - , " (<&>)" - , ") where -- x" - , "-- y" - ] - output = - [ "module Foo" - , " ( (<&>)" - , " ) where -- x" - , "-- y" - ] +ex10 = assertSnippet (step defaultConfig) + [ "module Foo (" + , " (<&>)" + , ") where -- x" + , "-- y" + ] + [ "module Foo" + , " ( (<&>)" + , " ) where -- x" + , "-- y" + ] ex11 :: Assertion -ex11 = input `assertFormatted` output - where - input = - [ "module Foo (" - , " -- group 1" - , " g1_1," - , " g1_0," - , " -- group 2" - , " g0_1," - , " g0_0" - , ") where" - ] - output = - [ "module Foo" - , " ( -- group 1" - , " g1_0" - , " , g1_1" - , " -- group 2" - , " , g0_0" - , " , g0_1" - , " ) where" - ] +ex11 = assertSnippet (step defaultConfig) + [ "module Foo (" + , " -- group 1" + , " g1_1," + , " g1_0," + , " -- group 2" + , " g0_1," + , " g0_0" + , ") where" + ] + [ "module Foo" + , " ( -- group 1" + , " g1_0" + , " , g1_1" + , " -- group 2" + , " , g0_0" + , " , g0_1" + , " ) where" + ] ex12 :: Assertion -ex12 = input `assertFormatted` output - where - input = - [ "module Foo" - , " where" - , "-- hmm" - ] - output = - [ "module Foo" - , " where" - , "-- hmm" - ] +ex12 = assertSnippet (step defaultConfig) + [ "module Foo" + , " where" + , "-- hmm" + ] + [ "module Foo" + , " where" + , "-- hmm" + ] --------------------------------------------------------------------------------- -assertFormatted :: HasCallStack => Lines -> Lines -> Assertion -assertFormatted input expected = withFrozenCallStack $ expected @=? testStep' (step ModuleHeader.Config) input +ex13 :: Assertion +ex13 = assertSnippet (step defaultConfig {indent = 2}) + [ "module Foo where" + ] + [ "module Foo" + , " where" + ] + +ex14 :: Assertion +ex14 = assertSnippet (step defaultConfig {indent = 2}) + [ "module Foo" + , " ( yes" + , " , no" + , " ) where" + ] + [ "module Foo" + , " ( no" + , " , yes" + , " ) where" + ] + +ex15 :: Assertion +ex15 = assertSnippet (step defaultConfig {indent = 2}) + [ "module Foo -- Foo" + , "(" + , " -- * t1 something" + , " t3," + , " t1," + , " -- * t2 something" + , " t2" + , ") where" + ] + [ "module Foo -- Foo" + , " ( -- * t1 something" + , " t1" + , " , t3" + , " -- * t2 something" + , " , t2" + , " ) where" + ] From 5eab669ec15e19db55d89006dd9ece552be69211 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Wed, 30 Sep 2020 15:45:58 +0200 Subject: [PATCH 123/135] Make module_header sorting optional --- data/stylish-haskell.yaml | 4 ++ lib/Language/Haskell/Stylish/Config.hs | 5 +- lib/Language/Haskell/Stylish/Printer.hs | 13 ++--- .../Haskell/Stylish/Step/ModuleHeader.hs | 54 +++++++++++-------- .../Stylish/Step/ModuleHeader/Tests.hs | 11 ++++ 5 files changed, 54 insertions(+), 33 deletions(-) diff --git a/data/stylish-haskell.yaml b/data/stylish-haskell.yaml index cec5cd5c..80892dcc 100644 --- a/data/stylish-haskell.yaml +++ b/data/stylish-haskell.yaml @@ -23,6 +23,10 @@ steps: # - module_header: # # How many spaces use for indentation in the module header. # indent: 4 + # + # # Should export lists be sorted? Sorting is only performed within the + # # export section, as delineated by Haddock comments. + # sort: true # Format record definitions. This is disabled by default. # diff --git a/lib/Language/Haskell/Stylish/Config.hs b/lib/Language/Haskell/Stylish/Config.hs index 904b183a..333736fd 100644 --- a/lib/Language/Haskell/Stylish/Config.hs +++ b/lib/Language/Haskell/Stylish/Config.hs @@ -194,8 +194,9 @@ parseEnum strs _ (Just k) = case lookup k strs of -------------------------------------------------------------------------------- parseModuleHeader :: Config -> A.Object -> A.Parser Step -parseModuleHeader _ o = (ModuleHeader.step . ModuleHeader.Config) <$> - o A..:? "indent" A..!= 4 +parseModuleHeader _ o = fmap ModuleHeader.step $ ModuleHeader.Config + <$> o A..:? "indent" A..!= (ModuleHeader.indent ModuleHeader.defaultConfig) + <*> o A..:? "sort" A..!= (ModuleHeader.sort ModuleHeader.defaultConfig) -------------------------------------------------------------------------------- parseSimpleAlign :: Config -> A.Object -> A.Parser Step diff --git a/lib/Language/Haskell/Stylish/Printer.hs b/lib/Language/Haskell/Stylish/Printer.hs index be0a25af..886f9129 100644 --- a/lib/Language/Haskell/Stylish/Printer.hs +++ b/lib/Language/Haskell/Stylish/Printer.hs @@ -40,7 +40,7 @@ module Language.Haskell.Stylish.Printer , removeCommentToEnd , removeLineComment , sep - , sortedAttachedComments + , groupAttachedComments , space , spaces , suffix @@ -75,11 +75,10 @@ import Data.Foldable (find) import Data.Functor ((<&>)) import Data.List (delete, isPrefixOf) import Data.List.NonEmpty (NonEmpty(..)) -import qualified Data.List.NonEmpty as NonEmpty -------------------------------------------------------------------------------- import Language.Haskell.Stylish.Module (Module, Lines, lookupAnnotation) -import Language.Haskell.Stylish.GHC (compareOutputable, showOutputable, unLocated) +import Language.Haskell.Stylish.GHC (showOutputable, unLocated) -- | Shorthand for 'Printer' monad type P = Printer @@ -395,12 +394,10 @@ peekNextCommentPos = do (L next _ : _) -> Just (RealSrcSpan next) [] -> Nothing --- | Get sorted attached comments belonging to '[Located a]' given -sortedAttachedComments :: Outputable a => [Located a] -> P [([AnnotationComment], NonEmpty (Located a))] -sortedAttachedComments origs = go origs <&> fmap sortGroup +-- | Get attached comments belonging to '[Located a]' given +groupAttachedComments :: [Located a] -> P [([AnnotationComment], NonEmpty (Located a))] +groupAttachedComments = go where - sortGroup = fmap (NonEmpty.sortBy compareOutputable) - go :: [Located a] -> P [([AnnotationComment], NonEmpty (Located a))] go (L rspan x : xs) = do comments <- removeCommentTo rspan diff --git a/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs b/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs index 708c3fd7..7b8ac5df 100644 --- a/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs +++ b/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs @@ -1,5 +1,5 @@ {-# LANGUAGE BlockArguments #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} module Language.Haskell.Stylish.Step.ModuleHeader ( Config (..) , defaultConfig @@ -7,42 +7,48 @@ module Language.Haskell.Stylish.Step.ModuleHeader ) where -------------------------------------------------------------------------------- -import ApiAnnotation (AnnotationComment(..), AnnKeywordId(..)) -import Control.Monad (forM_, join, when) -import Data.Foldable (find, toList) -import Data.Function ((&)) -import Data.List (sort, sortBy) -import Data.List.NonEmpty (NonEmpty(..)) -import Data.Maybe (listToMaybe, isJust) -import qualified GHC.Hs.Doc as GHC -import GHC.Hs.Extension (GhcPs) -import qualified GHC.Hs.Extension as GHC -import GHC.Hs.ImpExp (IE(..)) -import qualified GHC.Hs.ImpExp as GHC -import qualified Module as GHC -import SrcLoc (Located, GenLocated(..), SrcSpan(..)) -import SrcLoc (RealLocated) -import SrcLoc (srcSpanStartLine, srcSpanEndLine) -import Util (notNull) +import ApiAnnotation (AnnKeywordId (..), + AnnotationComment (..)) +import Control.Monad (forM_, join, when) +import Data.Bifunctor (second) +import Data.Foldable (find, toList) +import Data.Function ((&)) +import qualified Data.List as L +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Maybe (isJust, listToMaybe) +import qualified GHC.Hs.Doc as GHC +import GHC.Hs.Extension (GhcPs) +import qualified GHC.Hs.Extension as GHC +import GHC.Hs.ImpExp (IE (..)) +import qualified GHC.Hs.ImpExp as GHC +import qualified Module as GHC +import SrcLoc (GenLocated (..), Located, + RealLocated, SrcSpan (..), + srcSpanEndLine, + srcSpanStartLine) +import Util (notNull) -------------------------------------------------------------------------------- import Language.Haskell.Stylish.Block import Language.Haskell.Stylish.Editor +import Language.Haskell.Stylish.GHC import Language.Haskell.Stylish.Module import Language.Haskell.Stylish.Printer import Language.Haskell.Stylish.Step -import Language.Haskell.Stylish.GHC data Config = Config -- TODO(jaspervdj): Use the same sorting as in `Imports`? -- TODO: make sorting optional? { indent :: Int + , sort :: Bool } defaultConfig :: Config defaultConfig = Config { indent = 4 + , sort = True } step :: Config -> Step @@ -88,7 +94,7 @@ printModuleHeader conf ls m = = annotations & filter (\(((_, w), _)) -> w == AnnWhere) & fmap (head . snd) -- get position of annot - & sort + & L.sort & listToMaybe isModuleHeaderWhere :: Block a -> Bool @@ -155,7 +161,7 @@ printExportList conf (L srcLoc exports) = do newline doIndent >> putText "(" >> when (notNull exports) space - exportsWithComments <- sortedAttachedComments exports + exportsWithComments <- fmap (second doSort) <$> groupAttachedComments exports printExports exportsWithComments @@ -179,6 +185,8 @@ printExportList conf (L srcLoc exports) = do len <- length <$> getCurrentLine spaces $ indent conf + 2 - len + doSort = if sort conf then NonEmpty.sortBy compareOutputable else id + printExports :: [([AnnotationComment], NonEmpty (GHC.LIE GhcPs))] -> P () printExports (([], firstInGroup :| groupRest) : rest) = do printExport firstInGroup @@ -207,7 +215,7 @@ printExportList conf (L srcLoc exports) = do printExportsGroupTail :: [GHC.LIE GhcPs] -> P () printExportsGroupTail (x : xs) = printExportsTail [([], x :| xs)] - printExportsGroupTail [] = pure () + printExportsGroupTail [] = pure () printExport :: GHC.LIE GhcPs -> P () printExport (L _ export) = case export of @@ -225,7 +233,7 @@ printExportList conf (L srcLoc exports) = do putOutputable name space putText "(" - sep (comma >> space) (fmap putOutputable (sortBy compareOutputable imps)) + sep (comma >> space) (fmap putOutputable (L.sortBy compareOutputable imps)) putText ")" IEGroup _ _ _ -> error $ diff --git a/tests/Language/Haskell/Stylish/Step/ModuleHeader/Tests.hs b/tests/Language/Haskell/Stylish/Step/ModuleHeader/Tests.hs index f0107232..b6d6b892 100644 --- a/tests/Language/Haskell/Stylish/Step/ModuleHeader/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/ModuleHeader/Tests.hs @@ -33,6 +33,7 @@ tests = testGroup "Language.Haskell.Stylish.Printer.ModuleHeader" , testCase "Indents absent export list with 2 spaces" ex13 , testCase "Indents with 2 spaces" ex14 , testCase "Group doc with 2 spaces" ex15 + , testCase "Does not sort" ex16 ] -------------------------------------------------------------------------------- @@ -288,3 +289,13 @@ ex15 = assertSnippet (step defaultConfig {indent = 2}) , " , t2" , " ) where" ] + +ex16 :: Assertion +ex16 = assertSnippet (step defaultConfig {sort = False}) input input + where + input = + [ "module Foo" + , " ( yes" + , " , no" + , " ) where" + ] From 16217450df3ed2688457d8ac93adcc7d9d695bfe Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Wed, 30 Sep 2020 18:44:27 +0200 Subject: [PATCH 124/135] Add a consistent ordering module --- lib/Language/Haskell/Stylish/Ordering.hs | 61 +++++++++++++++++++ lib/Language/Haskell/Stylish/Step/Imports.hs | 39 +++--------- .../Haskell/Stylish/Step/ModuleHeader.hs | 10 +-- stylish-haskell.cabal | 2 + 4 files changed, 76 insertions(+), 36 deletions(-) create mode 100644 lib/Language/Haskell/Stylish/Ordering.hs diff --git a/lib/Language/Haskell/Stylish/Ordering.hs b/lib/Language/Haskell/Stylish/Ordering.hs new file mode 100644 index 00000000..1a05eb4e --- /dev/null +++ b/lib/Language/Haskell/Stylish/Ordering.hs @@ -0,0 +1,61 @@ +-------------------------------------------------------------------------------- +-- | There are a number of steps that sort items: 'Imports' and 'ModuleHeader', +-- and maybe more in the future. This module provides consistent sorting +-- utilities. +{-# LANGUAGE LambdaCase #-} +module Language.Haskell.Stylish.Ordering + ( compareLIE + , compareWrappedName + , unwrapName + ) where + + +-------------------------------------------------------------------------------- +import Data.Char (isUpper) +import Data.Ord (comparing) +import GHC.Hs +import RdrName (RdrName) +import SrcLoc (unLoc) + + +-------------------------------------------------------------------------------- +import Language.Haskell.Stylish.GHC (showOutputable) +import Outputable (Outputable) + + +-------------------------------------------------------------------------------- +-- | NOTE: Can we get rid off this by adding a properly sorting newtype around +-- 'RdrName'? +compareLIE :: LIE GhcPs -> LIE GhcPs -> Ordering +compareLIE = comparing $ ieKey . unLoc + where + -- | The implementation is a bit hacky to get proper sorting for input specs: + -- constructors first, followed by functions, and then operators. + ieKey :: IE GhcPs -> (Int, String) + ieKey = \case + IEVar _ n -> nameKey n + IEThingAbs _ n -> nameKey n + IEThingAll _ n -> nameKey n + IEThingWith _ n _ _ _ -> nameKey n + IEModuleContents _ n -> nameKey n + _ -> (2, "") + + +-------------------------------------------------------------------------------- +compareWrappedName :: IEWrappedName RdrName -> IEWrappedName RdrName -> Ordering +compareWrappedName = comparing nameKey + + +-------------------------------------------------------------------------------- +unwrapName :: IEWrappedName n -> n +unwrapName (IEName n) = unLoc n +unwrapName (IEPattern n) = unLoc n +unwrapName (IEType n) = unLoc n + + +-------------------------------------------------------------------------------- +nameKey :: Outputable name => name -> (Int, String) +nameKey n = case showOutputable n of + o@('(' : _) -> (2, o) + o@(o0 : _) | isUpper o0 -> (0, o) + o -> (1, o) diff --git a/lib/Language/Haskell/Stylish/Step/Imports.hs b/lib/Language/Haskell/Stylish/Step/Imports.hs index 21ec1ff5..9c1d82dc 100644 --- a/lib/Language/Haskell/Stylish/Step/Imports.hs +++ b/lib/Language/Haskell/Stylish/Step/Imports.hs @@ -15,13 +15,11 @@ module Language.Haskell.Stylish.Step.Imports -------------------------------------------------------------------------------- import Control.Monad (forM_, when, void) -import Data.Char (isUpper) -import Data.Function ((&)) +import Data.Function ((&), on) import Data.Functor (($>)) import Data.Foldable (toList) -import Data.Ord (comparing) import Data.Maybe (isJust) -import Data.List (sortBy, sortOn) +import Data.List (sortBy) import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Map as Map @@ -43,6 +41,7 @@ import SrcLoc (Located, GenLocated(..), unLoc -------------------------------------------------------------------------------- import Language.Haskell.Stylish.Block import Language.Haskell.Stylish.Module +import Language.Haskell.Stylish.Ordering import Language.Haskell.Stylish.Printer import Language.Haskell.Stylish.Step import Language.Haskell.Stylish.Editor @@ -432,7 +431,7 @@ isSafe -- * Removes duplicates from import lists. prepareImportList :: [LIE GhcPs] -> [LIE GhcPs] prepareImportList = - sortBy compareImportLIE . map (fmap prepareInner) . + sortBy compareLIE . map (fmap prepareInner) . concatMap (toList . snd) . Map.toAscList . mergeByName where mergeByName :: [LIE GhcPs] -> Map.Map RdrName (NonEmpty (LIE GhcPs)) @@ -445,33 +444,14 @@ prepareImportList = Nothing -> x :| (xs ++ y : ys)) [(ieName $ unLocated imp, imp :| []) | imp <- imports0] - -- | TODO: get rid off this by adding a properly sorting newtype around - -- 'RdrName'. - compareImportLIE :: LIE GhcPs -> LIE GhcPs -> Ordering - compareImportLIE = comparing $ ieKey . unLoc - prepareInner :: IE GhcPs -> IE GhcPs prepareInner = \case -- Simplify `A ()` to `A`. IEThingWith x n NoIEWildcard [] [] -> IEThingAbs x n - IEThingWith x n w ns fs -> IEThingWith x n w (sortOn nameKey ns) fs + IEThingWith x n w ns fs -> + IEThingWith x n w (sortBy (compareWrappedName `on` unLoc) ns) fs ie -> ie - -- | The implementation is a bit hacky to get proper sorting for input specs: - -- constructors first, followed by functions, and then operators. - ieKey :: IE GhcPs -> (Int, String) - ieKey = \case - IEVar _ n -> nameKey n - IEThingAbs _ n -> nameKey n - IEThingAll _ n -> nameKey n - IEThingWith _ n _ _ _ -> nameKey n - _ -> (2, "") - - nameKey n = case showOutputable n of - o@('(' : _) -> (2 :: Int, o) - o@(o0 : _) | isUpper o0 -> (0, o) - o -> (1, o) - -- Merge two import items, assuming they have the same name. ieMerge :: IE GhcPs -> IE GhcPs -> Maybe (IE GhcPs) ieMerge l@(IEVar _ _) _ = Just l @@ -484,14 +464,9 @@ prepareImportList = | w0 /= w1 = Nothing | otherwise = Just $ -- TODO: sort the `ns0 ++ ns1`? - IEThingWith x0 n0 w0 (nubOn (unwrapName . unLocated) $ ns0 ++ ns1) [] + IEThingWith x0 n0 w0 (nubOn (unwrapName . unLoc) $ ns0 ++ ns1) [] ieMerge _ _ = Nothing - unwrapName :: IEWrappedName n -> n - unwrapName (IEName n) = unLocated n - unwrapName (IEPattern n) = unLocated n - unwrapName (IEType n) = unLocated n - -------------------------------------------------------------------------------- nubOn :: Ord k => (a -> k) -> [a] -> [a] diff --git a/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs b/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs index 7b8ac5df..90f34789 100644 --- a/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs +++ b/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs @@ -12,7 +12,7 @@ import ApiAnnotation (AnnKeywordId (..), import Control.Monad (forM_, join, when) import Data.Bifunctor (second) import Data.Foldable (find, toList) -import Data.Function ((&)) +import Data.Function (on, (&)) import qualified Data.List as L import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NonEmpty @@ -26,7 +26,7 @@ import qualified Module as GHC import SrcLoc (GenLocated (..), Located, RealLocated, SrcSpan (..), srcSpanEndLine, - srcSpanStartLine) + srcSpanStartLine, unLoc) import Util (notNull) -------------------------------------------------------------------------------- @@ -34,6 +34,7 @@ import Language.Haskell.Stylish.Block import Language.Haskell.Stylish.Editor import Language.Haskell.Stylish.GHC import Language.Haskell.Stylish.Module +import Language.Haskell.Stylish.Ordering import Language.Haskell.Stylish.Printer import Language.Haskell.Stylish.Step @@ -185,7 +186,7 @@ printExportList conf (L srcLoc exports) = do len <- length <$> getCurrentLine spaces $ indent conf + 2 - len - doSort = if sort conf then NonEmpty.sortBy compareOutputable else id + doSort = if sort conf then NonEmpty.sortBy compareLIE else id printExports :: [([AnnotationComment], NonEmpty (GHC.LIE GhcPs))] -> P () printExports (([], firstInGroup :| groupRest) : rest) = do @@ -233,7 +234,8 @@ printExportList conf (L srcLoc exports) = do putOutputable name space putText "(" - sep (comma >> space) (fmap putOutputable (L.sortBy compareOutputable imps)) + sep (comma >> space) $ + fmap putOutputable $ L.sortBy (compareWrappedName `on` unLoc) imps putText ")" IEGroup _ _ _ -> error $ diff --git a/stylish-haskell.cabal b/stylish-haskell.cabal index f4304a01..13442690 100644 --- a/stylish-haskell.cabal +++ b/stylish-haskell.cabal @@ -50,6 +50,7 @@ Library Language.Haskell.Stylish.Config.Cabal Language.Haskell.Stylish.Config.Internal Language.Haskell.Stylish.Editor + Language.Haskell.Stylish.Ordering Language.Haskell.Stylish.Parse Language.Haskell.Stylish.Step Language.Haskell.Stylish.Util @@ -120,6 +121,7 @@ Test-suite stylish-haskell-tests Language.Haskell.Stylish.Config.Tests Language.Haskell.Stylish.Editor Language.Haskell.Stylish.GHC + Language.Haskell.Stylish.Ordering Language.Haskell.Stylish.Module Language.Haskell.Stylish.Parse Language.Haskell.Stylish.Parse.Tests From 627409063a50760518134ebdb80c43ed85b21369 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?=C5=81ukasz=20Go=C5=82=C4=99biewski?= Date: Sat, 26 Sep 2020 15:15:03 +0200 Subject: [PATCH 125/135] Rewrite UnicodeSyntax.hs to use ghc-lib-parser MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-authored-by: Paweł Szulc --- .../Haskell/Stylish/Step/LanguagePragmas.hs | 33 +++++--------- .../Haskell/Stylish/Step/UnicodeSyntax.hs | 43 +++++++++---------- lib/Language/Haskell/Stylish/Util.hs | 21 ++++++--- 3 files changed, 45 insertions(+), 52 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs b/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs index 79ca13d9..611fea18 100644 --- a/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs +++ b/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs @@ -1,6 +1,6 @@ -{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE LambdaCase #-} -------------------------------------------------------------------------------- module Language.Haskell.Stylish.Step.LanguagePragmas ( Style (..) @@ -19,9 +19,10 @@ import qualified Language.Haskell.Exts as H -------------------------------------------------------------------------------- import GHC.Hs.Extension (GhcPs) -import GHC.Hs.Pat (Pat(BangPat, ViewPat)) +import GHC.Hs.Pat (Pat (BangPat, ViewPat)) import SrcLoc (RealSrcSpan) -import SrcLoc (srcSpanStartLine, srcSpanEndLine) +import SrcLoc (srcSpanEndLine, + srcSpanStartLine) -------------------------------------------------------------------------------- import Language.Haskell.Stylish.Block @@ -32,26 +33,12 @@ import Language.Haskell.Stylish.Util -------------------------------------------------------------------------------- -data Style - = Vertical +data Style = Vertical | Compact | CompactLine deriving (Eq, Show) --------------------------------------------------------------------------------- -pragmas :: H.Module l -> [(l, [String])] -pragmas (H.Module _ _ ps _ _) = - [(l, map nameToString names) | H.LanguagePragma l names <- ps] -pragmas _ = [] - - --------------------------------------------------------------------------------- --- | The start of the first block -firstLocation :: [(Block a, [String])] -> Int -firstLocation = minimum . map (blockStart . fst) - - -------------------------------------------------------------------------------- verticalPragmas :: String -> Int -> Bool -> [String] -> Lines verticalPragmas lg longest align pragmas' = @@ -155,14 +142,14 @@ step' columns style align removeRedundant lngPrefix ls m -------------------------------------------------------------------------------- -- | Add a LANGUAGE pragma to a module if it is not present already. -addLanguagePragma :: String -> String -> H.Module H.SrcSpanInfo -> [Change String] +addLanguagePragma :: String -> String -> Module -> [Change String] addLanguagePragma lg prag modu | prag `elem` present = [] | otherwise = [insert line ["{-# " ++ lg ++ " " ++ prag ++ " #-}"]] where - pragmas' = pragmas (fmap linesFromSrcSpan modu) - present = concatMap snd pragmas' - line = if null pragmas' then 1 else firstLocation pragmas' + pragmas' = moduleLanguagePragmas modu + present = concatMap ((fmap T.unpack) . toList . snd) pragmas' + line = if null pragmas' then 1 else 0 --TODO: fixme firstLocation pragmas' -------------------------------------------------------------------------------- diff --git a/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs b/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs index 0c5a7fdb..2f0def63 100644 --- a/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs +++ b/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs @@ -10,17 +10,17 @@ import Data.List (isPrefixOf, import Data.Map (Map) import qualified Data.Map as M import Data.Maybe (maybeToList) -import qualified Language.Haskell.Exts as H - - +import GHC.Hs.Binds +import GHC.Hs.Extension (GhcPs) +import GHC.Hs.Types -------------------------------------------------------------------------------- import Language.Haskell.Stylish.Block import Language.Haskell.Stylish.Editor +import Language.Haskell.Stylish.Module import Language.Haskell.Stylish.Step import Language.Haskell.Stylish.Step.LanguagePragmas (addLanguagePragma) import Language.Haskell.Stylish.Util - -------------------------------------------------------------------------------- unicodeReplacements :: Map String String unicodeReplacements = M.fromList @@ -39,7 +39,7 @@ replaceAll :: [(Int, [(Int, String)])] -> [Change String] replaceAll = map changeLine' where changeLine' (r, ns) = changeLine r $ \str -> return $ - applyChanges + applyChanges [ change (Block c ec) (const repl) | (c, needle) <- sort ns , let ec = c + length needle - 1 @@ -54,33 +54,32 @@ groupPerLine = M.toList . M.fromListWith (++) . -------------------------------------------------------------------------------- -typeSigs :: H.Module H.SrcSpanInfo -> Lines -> [((Int, Int), String)] +typeSigs :: Module -> Lines -> [((Int, Int), String)] typeSigs module' ls = [ (pos, "::") - | H.TypeSig loc _ _ <- everything module' :: [H.Decl H.SrcSpanInfo] - , (start, end) <- infoPoints loc - , pos <- maybeToList $ between start end "::" ls + | TypeSig _ funLoc typeLoc <- everything (rawModuleDecls $ moduleDecls module') :: [Sig GhcPs] + , (_, funEnd) <- infoPoints funLoc + , (typeStart, _) <- infoPoints [hsSigWcType typeLoc] + , pos <- maybeToList $ between funEnd typeStart "::" ls ] - -------------------------------------------------------------------------------- -contexts :: H.Module H.SrcSpanInfo -> Lines -> [((Int, Int), String)] +contexts :: Module -> Lines -> [((Int, Int), String)] contexts module' ls = [ (pos, "=>") - | context <- everything module' :: [H.Context H.SrcSpanInfo] - , (start, end) <- infoPoints $ H.ann context - , pos <- maybeToList $ between start end "=>" ls + | TypeSig _ _ typeLoc <- everything (rawModuleDecls $ moduleDecls module') :: [Sig GhcPs] + , (start, end) <- infoPoints [hsSigWcType typeLoc] + , pos <- maybeToList $ between start end "=>" ls ] -------------------------------------------------------------------------------- -typeFuns :: H.Module H.SrcSpanInfo -> Lines -> [((Int, Int), String)] +typeFuns :: Module -> Lines -> [((Int, Int), String)] typeFuns module' ls = [ (pos, "->") - | H.TyFun _ t1 t2 <- everything module' - , let start = H.srcSpanEnd $ H.srcInfoSpan $ H.ann t1 - , let end = H.srcSpanStart $ H.srcInfoSpan $ H.ann t2 - , pos <- maybeToList $ between start end "->" ls + | TypeSig _ _ typeLoc <- everything (rawModuleDecls $ moduleDecls module') :: [Sig GhcPs] + , (start, end) <- infoPoints [hsSigWcType typeLoc] + , pos <- maybeToList $ between start end "->" ls ] @@ -105,12 +104,12 @@ between (startRow, startCol) (endRow, endCol) needle = -------------------------------------------------------------------------------- step :: Bool -> String -> Step -step = (oldMakeStep "UnicodeSyntax" .) . step' +step = (makeStep "UnicodeSyntax" .) . step' -------------------------------------------------------------------------------- -step' :: Bool -> String -> Lines -> OldModule -> Lines -step' alp lg ls (module', _) = applyChanges changes ls +step' :: Bool -> String -> Lines -> Module -> Lines +step' alp lg ls module' = applyChanges changes ls where changes = (if alp then addLanguagePragma lg "UnicodeSyntax" module' else []) ++ replaceAll perLine diff --git a/lib/Language/Haskell/Stylish/Util.hs b/lib/Language/Haskell/Stylish/Util.hs index e1368901..985f5fa8 100644 --- a/lib/Language/Haskell/Stylish/Util.hs +++ b/lib/Language/Haskell/Stylish/Util.hs @@ -1,6 +1,6 @@ -------------------------------------------------------------------------------- -{-# LANGUAGE PatternGuards #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternGuards #-} module Language.Haskell.Stylish.Util ( nameToString , isOperator @@ -35,7 +35,6 @@ module Language.Haskell.Stylish.Util -------------------------------------------------------------------------------- -import Control.Arrow ((&&&), (>>>)) import Data.Char (isAlpha, isSpace) import Data.Data (Data) import qualified Data.Generics as G @@ -43,9 +42,9 @@ import Data.Maybe (fromMaybe, listToMaybe, maybeToList) import Data.Typeable (cast) import Debug.Trace (trace) +import qualified GHC.Hs as Hs import qualified Language.Haskell.Exts as H import qualified Outputable -import qualified GHC.Hs as Hs import qualified SrcLoc as S @@ -86,8 +85,16 @@ everything = G.everything (++) (maybeToList . cast) -------------------------------------------------------------------------------- -infoPoints :: H.SrcSpanInfo -> [((Int, Int), (Int, Int))] -infoPoints = H.srcInfoPoints >>> map (H.srcSpanStart &&& H.srcSpanEnd) +infoPoints :: [S.Located pass] -> [((Int, Int), (Int, Int))] +infoPoints = fmap (helper . S.getLoc) + where + helper :: S.SrcSpan -> ((Int, Int), (Int, Int)) + helper (S.RealSrcSpan s) = do + let + start = S.realSrcSpanStart s + end = S.realSrcSpanEnd s + ((S.srcLocLine start, S.srcLocCol start), (S.srcLocLine end, S.srcLocCol end)) + helper _ = ((-1,-1), (-1,-1)) -------------------------------------------------------------------------------- @@ -135,7 +142,7 @@ noWrap :: String -- ^ Leading string -> Lines -- ^ Resulting lines noWrap leading _ind = noWrap' leading where - noWrap' ss [] = [ss] + noWrap' ss [] = [ss] noWrap' ss (str:strs) = noWrap' (ss ++ " " ++ str) strs @@ -257,7 +264,7 @@ rhsBody _ = Nothing -------------------------------------------------------------------------------- -- get guards in a guarded rhs of a Match getGuards :: Hs.Match Hs.GhcPs (Hs.LHsExpr Hs.GhcPs) -> [Hs.GuardLStmt Hs.GhcPs] -getGuards (Hs.Match _ _ _ grhss) = +getGuards (Hs.Match _ _ _ grhss) = let lgrhs = getLocGRHS grhss -- [] grhs = map S.unLoc lgrhs From 2adfb29fec1048947139f085cc26f88ade4160a5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?=C5=81ukasz=20Go=C5=82=C4=99biewski?= Date: Wed, 30 Sep 2020 21:59:55 +0200 Subject: [PATCH 126/135] Remove redundant import --- lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs b/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs index 611fea18..e8438fb7 100644 --- a/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs +++ b/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs @@ -15,7 +15,6 @@ import Data.List.NonEmpty (NonEmpty, fromList, toList) import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T -import qualified Language.Haskell.Exts as H -------------------------------------------------------------------------------- import GHC.Hs.Extension (GhcPs) From a34ab8561eec40fba7cbb9f255818bd0b29659c2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?=C5=81ukasz=20Go=C5=82=C4=99biewski?= Date: Wed, 30 Sep 2020 23:06:20 +0200 Subject: [PATCH 127/135] Fix addLanguagePragma --- lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs b/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs index e8438fb7..e22129f2 100644 --- a/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs +++ b/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs @@ -20,7 +20,8 @@ import qualified Data.Text as T import GHC.Hs.Extension (GhcPs) import GHC.Hs.Pat (Pat (BangPat, ViewPat)) import SrcLoc (RealSrcSpan) -import SrcLoc (srcSpanEndLine, +import SrcLoc (realSrcSpanStart, srcLocLine, + srcSpanEndLine, srcSpanStartLine) -------------------------------------------------------------------------------- @@ -146,9 +147,11 @@ addLanguagePragma lg prag modu | prag `elem` present = [] | otherwise = [insert line ["{-# " ++ lg ++ " " ++ prag ++ " #-}"]] where - pragmas' = moduleLanguagePragmas modu - present = concatMap ((fmap T.unpack) . toList . snd) pragmas' - line = if null pragmas' then 1 else 0 --TODO: fixme firstLocation pragmas' + pragmas' = moduleLanguagePragmas modu + present = concatMap ((fmap T.unpack) . toList . snd) pragmas' + line = if null pragmas' then 1 else firstLocation pragmas' + firstLocation :: [(RealSrcSpan, NonEmpty Text)] -> Int + firstLocation = minimum . fmap (srcLocLine . realSrcSpanStart . fst) -------------------------------------------------------------------------------- From 265db5ec80c5b8d0b254526c6da22db26d54a8d6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?=C5=81ukasz=20Go=C5=82=C4=99biewski?= Date: Wed, 30 Sep 2020 23:12:18 +0200 Subject: [PATCH 128/135] Remove obsolete code from Util.hs --- lib/Language/Haskell/Stylish/Util.hs | 22 +++------------------- 1 file changed, 3 insertions(+), 19 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Util.hs b/lib/Language/Haskell/Stylish/Util.hs index 985f5fa8..90bea635 100644 --- a/lib/Language/Haskell/Stylish/Util.hs +++ b/lib/Language/Haskell/Stylish/Util.hs @@ -2,9 +2,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternGuards #-} module Language.Haskell.Stylish.Util - ( nameToString - , isOperator - , indent + ( indent , padRight , everything , infoPoints @@ -35,15 +33,13 @@ module Language.Haskell.Stylish.Util -------------------------------------------------------------------------------- -import Data.Char (isAlpha, isSpace) +import Data.Char (isSpace) import Data.Data (Data) import qualified Data.Generics as G -import Data.Maybe (fromMaybe, listToMaybe, - maybeToList) +import Data.Maybe (maybeToList) import Data.Typeable (cast) import Debug.Trace (trace) import qualified GHC.Hs as Hs -import qualified Language.Haskell.Exts as H import qualified Outputable import qualified SrcLoc as S @@ -52,18 +48,6 @@ import qualified SrcLoc as S import Language.Haskell.Stylish.Step --------------------------------------------------------------------------------- -nameToString :: H.Name l -> String -nameToString (H.Ident _ str) = str -nameToString (H.Symbol _ str) = str - - --------------------------------------------------------------------------------- -isOperator :: H.Name l -> Bool -isOperator = fromMaybe False - . (fmap (not . isAlpha) . listToMaybe) - . nameToString - -------------------------------------------------------------------------------- indent :: Int -> String -> String indent len = (indentPrefix len ++) From 60526d81794c015ca62a8e7924a36b13b9bf2724 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?=C5=81ukasz=20Go=C5=82=C4=99biewski?= Date: Wed, 30 Sep 2020 23:18:59 +0200 Subject: [PATCH 129/135] Remove OldStep and OldModule --- lib/Language/Haskell/Stylish.hs | 2 - lib/Language/Haskell/Stylish/Parse.hs | 62 +------------------- lib/Language/Haskell/Stylish/Step.hs | 18 +----- tests/Language/Haskell/Stylish/Tests/Util.hs | 6 +- 4 files changed, 6 insertions(+), 82 deletions(-) diff --git a/lib/Language/Haskell/Stylish.hs b/lib/Language/Haskell/Stylish.hs index 220eff99..a767889e 100644 --- a/lib/Language/Haskell/Stylish.hs +++ b/lib/Language/Haskell/Stylish.hs @@ -94,8 +94,6 @@ runStep :: Extensions -> Maybe FilePath -> Lines -> Step -> Either String Lines runStep exts mfp ls = \case Step _name step -> step ls <$> parseModule exts mfp (unlines ls) - OldStep _name step -> - step ls <$> parseModuleHSE exts mfp (unlines ls) -------------------------------------------------------------------------------- runSteps :: diff --git a/lib/Language/Haskell/Stylish/Parse.hs b/lib/Language/Haskell/Stylish/Parse.hs index a284cde0..fe218c9a 100644 --- a/lib/Language/Haskell/Stylish/Parse.hs +++ b/lib/Language/Haskell/Stylish/Parse.hs @@ -2,7 +2,6 @@ -------------------------------------------------------------------------------- module Language.Haskell.Stylish.Parse ( parseModule - , parseModuleHSE ) where @@ -15,13 +14,13 @@ import System.IO.Unsafe (unsafePerformIO) -------------------------------------------------------------------------------- import Bag (bagToList) import qualified DynFlags as GHC +import qualified ErrUtils as GHC import FastString (mkFastString) import qualified GHC.Hs as GHC import qualified GHC.LanguageExtensions as GHC -import qualified ErrUtils as GHC import qualified HeaderInfo as GHC import qualified HscTypes as GHC -import Lexer (ParseResult(..)) +import Lexer (ParseResult (..)) import Lexer (mkPState, unP) import qualified Lexer as GHC import qualified Panic as GHC @@ -32,12 +31,8 @@ import StringBuffer (stringToStringBuffer) import qualified StringBuffer as GHC -------------------------------------------------------------------------------- -import qualified Language.Haskell.Exts as H - --------------------------------------------------------------------------------- -import Language.Haskell.Stylish.GHC (baseDynFlags) +import Language.Haskell.Stylish.GHC (baseDynFlags) import Language.Haskell.Stylish.Module -import Language.Haskell.Stylish.Step (OldModule) type Extensions = [String] @@ -127,54 +122,3 @@ parsePragmasIntoDynFlags originalFlags extraOpts filepath str = unsafePerformIO where catchErrors act = GHC.handleGhcException reportErr (GHC.handleSourceError reportErr act) reportErr e = return $ Left (show e) - --------------------------------------------------------------------------------- --- | Abstraction over HSE's parsing -parseModuleHSE :: Extensions -> Maybe FilePath -> String -> Either String OldModule -parseModuleHSE extraExts mfp string = do - -- Determine the extensions: those specified in the file and the extra ones - let noPrefixes = unShebang . dropBom $ string - extraExts' = map H.classifyExtension extraExts - (lang, fileExts) = fromMaybe (Nothing, []) $ H.readExtensions noPrefixes - exts = nub $ fileExts ++ extraExts' ++ defaultExtensions - - -- Parsing options... - fp = fromMaybe "" mfp - mode = H.defaultParseMode - { H.extensions = exts - , H.fixities = Nothing - , H.baseLanguage = case lang of - Nothing -> H.baseLanguage H.defaultParseMode - Just l -> l - } - - -- Preprocessing - processed = if H.EnableExtension H.CPP `elem` exts - then unCpp noPrefixes - else noPrefixes - - case H.parseModuleWithComments mode processed of - H.ParseOk md -> return md - err -> Left $ - "Language.Haskell.Stylish.Parse.parseModuleHSE: could not parse " ++ - fp ++ ": " ++ show err - where - -- | Remove shebang lines - unShebang :: String -> String - unShebang str = - let (shebangs, other) = break (not . ("#!" `isPrefixOf`)) (lines str) in - unlines $ map (const "") shebangs ++ other - - -- | Syntax-related language extensions are always enabled for parsing. Since we - -- can't authoritatively know which extensions are enabled at compile-time, we - -- should try not to throw errors when parsing any GHC-accepted code. - defaultExtensions :: [H.Extension] - defaultExtensions = map H.EnableExtension - [ H.GADTs - , H.HereDocuments - , H.KindSignatures - , H.NewQualifiedOperators - , H.PatternGuards - , H.StandaloneDeriving - , H.UnicodeSyntax - ] diff --git a/lib/Language/Haskell/Stylish/Step.hs b/lib/Language/Haskell/Stylish/Step.hs index 9b728529..c2cfc707 100644 --- a/lib/Language/Haskell/Stylish/Step.hs +++ b/lib/Language/Haskell/Stylish/Step.hs @@ -1,34 +1,20 @@ -------------------------------------------------------------------------------- module Language.Haskell.Stylish.Step ( Lines - , OldModule , Step (..) , makeStep - , oldMakeStep ) where -------------------------------------------------------------------------------- -import qualified Language.Haskell.Exts as H import Language.Haskell.Stylish.Module -------------------------------------------------------------------------------- -type OldModule = (H.Module H.SrcSpanInfo, [H.Comment]) - --------------------------------------------------------------------------------- -data Step - = Step - { stepName :: String +data Step = Step + { stepName :: String , stepFilter :: Lines -> Module -> Lines } - | OldStep - { stepName :: String - , oldStepFilter :: Lines -> OldModule -> Lines - } -------------------------------------------------------------------------------- makeStep :: String -> (Lines -> Module -> Lines) -> Step makeStep = Step - -oldMakeStep :: String -> (Lines -> OldModule -> Lines) -> Step -oldMakeStep = OldStep diff --git a/tests/Language/Haskell/Stylish/Tests/Util.hs b/tests/Language/Haskell/Stylish/Tests/Util.hs index 88697d8f..b3d200fa 100644 --- a/tests/Language/Haskell/Stylish/Tests/Util.hs +++ b/tests/Language/Haskell/Stylish/Tests/Util.hs @@ -15,12 +15,12 @@ module Language.Haskell.Stylish.Tests.Util import Control.Exception (bracket, try) import Control.Monad.Writer (execWriter, tell) import Data.List (intercalate) +import GHC.Exts (IsList (..)) import System.Directory (createDirectory, getCurrentDirectory, getTemporaryDirectory, removeDirectoryRecursive, setCurrentDirectory) -import GHC.Exts (IsList (..)) import System.FilePath (()) import System.IO.Error (isAlreadyExistsError) import System.Random (randomIO) @@ -40,10 +40,6 @@ testStep s str = case s of case parseModule [] Nothing str of Left err -> error err Right module' -> unlines $ step ls module' - OldStep _ step -> - case parseModuleHSE [] Nothing str of - Left err -> error err - Right module' -> unlines $ step ls module' where ls = lines str From 1edd83852b620f2a9e91b90b460e02bd47b82452 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?=C5=81ukasz=20Go=C5=82=C4=99biewski?= Date: Wed, 30 Sep 2020 23:43:52 +0200 Subject: [PATCH 130/135] Remove last remnants of Haskell.Exts --- lib/Language/Haskell/Stylish/Block.hs | 29 +++++---------------------- lib/Language/Haskell/Stylish/Parse.hs | 1 - 2 files changed, 5 insertions(+), 25 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Block.hs b/lib/Language/Haskell/Stylish/Block.hs index 1210d6eb..9b074206 100644 --- a/lib/Language/Haskell/Stylish/Block.hs +++ b/lib/Language/Haskell/Stylish/Block.hs @@ -4,8 +4,6 @@ module Language.Haskell.Stylish.Block , LineBlock , SpanBlock , blockLength - , linesFromSrcSpan - , spanFromSrcSpan , moveBlock , adjacent , merge @@ -16,9 +14,7 @@ module Language.Haskell.Stylish.Block -------------------------------------------------------------------------------- -import Control.Arrow (arr, (&&&), (>>>)) -import qualified Data.IntSet as IS -import qualified Language.Haskell.Exts as H +import qualified Data.IntSet as IS -------------------------------------------------------------------------------- @@ -26,7 +22,8 @@ import qualified Language.Haskell.Exts as H data Block a = Block { blockStart :: Int , blockEnd :: Int - } deriving (Eq, Ord, Show) + } + deriving (Eq, Ord, Show) -------------------------------------------------------------------------------- @@ -41,21 +38,6 @@ type SpanBlock = Block Char blockLength :: Block a -> Int blockLength (Block start end) = end - start + 1 - --------------------------------------------------------------------------------- -linesFromSrcSpan :: H.SrcSpanInfo -> LineBlock -linesFromSrcSpan = H.srcInfoSpan >>> - H.srcSpanStartLine &&& H.srcSpanEndLine >>> - arr (uncurry Block) - - --------------------------------------------------------------------------------- -spanFromSrcSpan :: H.SrcSpanInfo -> SpanBlock -spanFromSrcSpan = H.srcInfoSpan >>> - H.srcSpanStartColumn &&& H.srcSpanEndColumn >>> - arr (uncurry Block) - - -------------------------------------------------------------------------------- moveBlock :: Int -> Block a -> Block a moveBlock offset (Block start end) = Block (start + offset) (end + offset) @@ -98,6 +80,5 @@ groupAdjacent = foldr go [] mergeAdjacent :: [Block a] -> [Block a] mergeAdjacent (a : b : rest) | a `adjacent` b = merge a b : mergeAdjacent rest -mergeAdjacent (a : rest) = a : mergeAdjacent rest -mergeAdjacent [] = [] - +mergeAdjacent (a : rest) = a : mergeAdjacent rest +mergeAdjacent [] = [] diff --git a/lib/Language/Haskell/Stylish/Parse.hs b/lib/Language/Haskell/Stylish/Parse.hs index fe218c9a..b416a323 100644 --- a/lib/Language/Haskell/Stylish/Parse.hs +++ b/lib/Language/Haskell/Stylish/Parse.hs @@ -7,7 +7,6 @@ module Language.Haskell.Stylish.Parse -------------------------------------------------------------------------------- import Data.Function ((&)) -import Data.List (isPrefixOf, nub) import Data.Maybe (fromMaybe, listToMaybe) import System.IO.Unsafe (unsafePerformIO) From 642be116eb9f1f6004c2002713d938e2fff72106 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?=C5=81ukasz=20Go=C5=82=C4=99biewski?= Date: Wed, 30 Sep 2020 23:44:09 +0200 Subject: [PATCH 131/135] Remove haskell-src-exts dependency --- stack.yaml | 1 - stack.yaml.lock | 7 ------- stylish-haskell.cabal | 5 +---- 3 files changed, 1 insertion(+), 12 deletions(-) diff --git a/stack.yaml b/stack.yaml index 6bebdb3b..c8432256 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,7 +1,6 @@ resolver: lts-16.9 extra-deps: -- 'haskell-src-exts-1.23.0' - 'ghc-lib-parser-8.10.1.20200324' - 'aeson-1.5.2.0' - 'Cabal-3.2.0.0' diff --git a/stack.yaml.lock b/stack.yaml.lock index 8a1bfa4d..3b367489 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -4,13 +4,6 @@ # https://docs.haskellstack.org/en/stable/lock_files packages: -- completed: - hackage: haskell-src-exts-1.23.0@sha256:1bb9f7e97d569e56973133cb075fdcc1bfd11f90d94b035b5cf44814bb39a73d,4541 - pantry-tree: - size: 97804 - sha256: 8e5bc885533431db9bf75e9609f6b80b56ab0c289a903d701f8628e78322afd0 - original: - hackage: haskell-src-exts-1.23.0 - completed: hackage: ghc-lib-parser-8.10.1.20200324@sha256:6a0b014e97f627dd9ca177f26f184e2f2ff713ec1271045334ccb56ac7bfdff3,9116 pantry-tree: diff --git a/stylish-haskell.cabal b/stylish-haskell.cabal index 13442690..cb1f6a1c 100644 --- a/stylish-haskell.cabal +++ b/stylish-haskell.cabal @@ -66,14 +66,13 @@ Library directory >= 1.2.3 && < 1.4, filepath >= 1.1 && < 1.5, file-embed >= 0.0.10 && < 0.1, - haskell-src-exts >= 1.18 && < 1.24, ghc-lib-parser >= 8.10 && < 8.12, mtl >= 2.0 && < 2.3, syb >= 0.3 && < 0.8, text >= 1.2 && < 1.3, HsYAML-aeson >=0.2.0 && < 0.3, HsYAML >=0.2.0 && < 0.3 - + if impl(ghc < 8.0) Build-depends: semigroups >= 0.18 && < 0.20 @@ -97,7 +96,6 @@ Executable stylish-haskell directory >= 1.2.3 && < 1.4, filepath >= 1.1 && < 1.5, file-embed >= 0.0.10 && < 0.1, - haskell-src-exts >= 1.18 && < 1.24, ghc-lib-parser >= 8.10 && < 8.12, mtl >= 2.0 && < 2.3, syb >= 0.3 && < 0.8, @@ -166,7 +164,6 @@ Test-suite stylish-haskell-tests directory >= 1.2.3 && < 1.4, filepath >= 1.1 && < 1.5, file-embed >= 0.0.10 && < 0.1, - haskell-src-exts >= 1.18 && < 1.24, ghc-lib-parser >= 8.10 && < 8.12, mtl >= 2.0 && < 2.3, syb >= 0.3 && < 0.8, From b8274f8320324ff0165c41073155d92280092755 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Thu, 1 Oct 2020 12:13:04 +0200 Subject: [PATCH 132/135] Tickle CI cache --- .github/workflows/ci.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index a1f5174d..1aa23698 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -19,7 +19,7 @@ jobs: - uses: actions/checkout@v2 - - uses: actions/setup-haskell@v1.1 + - uses: actions/setup-haskell@v1.1.2 name: Setup Haskell Stack with: ghc-version: ${{ matrix.ghc }} @@ -29,7 +29,7 @@ jobs: name: Cache ~/.stack with: path: ~/.stack - key: ${{ runner.os }}-${{ matrix.ghc }}-v2 + key: ${{ runner.os }}-${{ matrix.ghc }}-v3 - name: Add ~/.local/bin to PATH run: echo "::add-path::$HOME/.local/bin" From d1a4e517c09f70a9850d18b248bda1c3ac64807c Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Thu, 1 Oct 2020 12:48:24 +0200 Subject: [PATCH 133/135] Clean up LanguagePragmas tests --- .../Stylish/Step/LanguagePragmas/Tests.hs | 287 ++++++++---------- 1 file changed, 132 insertions(+), 155 deletions(-) diff --git a/tests/Language/Haskell/Stylish/Step/LanguagePragmas/Tests.hs b/tests/Language/Haskell/Stylish/Step/LanguagePragmas/Tests.hs index 0ede8036..aa2c1960 100644 --- a/tests/Language/Haskell/Stylish/Step/LanguagePragmas/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/LanguagePragmas/Tests.hs @@ -1,4 +1,5 @@ -------------------------------------------------------------------------------- +{-# LANGUAGE OverloadedLists #-} module Language.Haskell.Stylish.Step.LanguagePragmas.Tests ( tests ) where @@ -7,7 +8,7 @@ module Language.Haskell.Stylish.Step.LanguagePragmas.Tests -------------------------------------------------------------------------------- import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit (Assertion, (@=?)) +import Test.HUnit (Assertion) -------------------------------------------------------------------------------- @@ -37,202 +38,178 @@ lANG = "LANGUAGE" -------------------------------------------------------------------------------- case01 :: Assertion -case01 = expected @=? testStep (step (Just 80) Vertical True False lANG) input - where - input = unlines - [ "{-# LANGUAGE ViewPatterns #-}" - , "{-# LANGUAGE TemplateHaskell, ViewPatterns #-}" - , "{-# LANGUAGE ScopedTypeVariables #-}" - , "module Main where" - ] +case01 = assertSnippet + (step (Just 80) Vertical True False lANG) + [ "{-# LANGUAGE ViewPatterns #-}" + , "{-# LANGUAGE TemplateHaskell, ViewPatterns #-}" + , "{-# LANGUAGE ScopedTypeVariables #-}" + , "module Main where" + ] - expected = unlines - [ "{-# LANGUAGE ScopedTypeVariables #-}" - , "{-# LANGUAGE TemplateHaskell #-}" - , "{-# LANGUAGE ViewPatterns #-}" - , "module Main where" - ] + [ "{-# LANGUAGE ScopedTypeVariables #-}" + , "{-# LANGUAGE TemplateHaskell #-}" + , "{-# LANGUAGE ViewPatterns #-}" + , "module Main where" + ] -------------------------------------------------------------------------------- case02 :: Assertion -case02 = expected @=? testStep (step (Just 80) Vertical True True lANG) input - where - input = unlines - [ "{-# LANGUAGE BangPatterns #-}" - , "{-# LANGUAGE ViewPatterns #-}" - , "increment ((+ 1) -> x) = x" - ] +case02 = assertSnippet + (step (Just 80) Vertical True True lANG) + [ "{-# LANGUAGE BangPatterns #-}" + , "{-# LANGUAGE ViewPatterns #-}" + , "increment ((+ 1) -> x) = x" + ] - expected = unlines - [ "{-# LANGUAGE ViewPatterns #-}" - , "increment ((+ 1) -> x) = x" - ] + [ "{-# LANGUAGE ViewPatterns #-}" + , "increment ((+ 1) -> x) = x" + ] -------------------------------------------------------------------------------- case03 :: Assertion -case03 = expected @=? testStep (step (Just 80) Vertical True True lANG) input - where - input = unlines - [ "{-# LANGUAGE BangPatterns #-}" - , "{-# LANGUAGE ViewPatterns #-}" - , "increment x = case x of !_ -> x + 1" - ] +case03 = assertSnippet + (step (Just 80) Vertical True True lANG) + [ "{-# LANGUAGE BangPatterns #-}" + , "{-# LANGUAGE ViewPatterns #-}" + , "increment x = case x of !_ -> x + 1" + ] - expected = unlines - [ "{-# LANGUAGE BangPatterns #-}" - , "increment x = case x of !_ -> x + 1" - ] + [ "{-# LANGUAGE BangPatterns #-}" + , "increment x = case x of !_ -> x + 1" + ] -------------------------------------------------------------------------------- case04 :: Assertion -case04 = expected @=? testStep (step (Just 80) Compact True False lANG) input - where - input = unlines - [ "{-# LANGUAGE TypeOperators, StandaloneDeriving, DeriveDataTypeable," - , " TemplateHaskell #-}" - , "{-# LANGUAGE TemplateHaskell, ViewPatterns #-}" - ] +case04 = assertSnippet + (step (Just 80) Compact True False lANG) + [ "{-# LANGUAGE TypeOperators, StandaloneDeriving, DeriveDataTypeable," + , " TemplateHaskell #-}" + , "{-# LANGUAGE TemplateHaskell, ViewPatterns #-}" + ] - expected = unlines - [ "{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving, " ++ - "TemplateHaskell," - , " TypeOperators, ViewPatterns #-}" - ] + [ "{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving, " ++ + "TemplateHaskell," + , " TypeOperators, ViewPatterns #-}" + ] -------------------------------------------------------------------------------- case05 :: Assertion -case05 = expected @=? testStep (step (Just 80) Vertical True False lANG) input - where - input = unlines - [ "{-# LANGUAGE CPP #-}" - , "" - , "#if __GLASGOW_HASKELL__ >= 702" - , "{-# LANGUAGE Trustworthy #-}" - , "#endif" - ] - - expected = unlines - [ "{-# LANGUAGE CPP #-}" - , "" - , "#if __GLASGOW_HASKELL__ >= 702" - , "{-# LANGUAGE Trustworthy #-}" - , "#endif" - ] +case05 = assertSnippet + (step (Just 80) Vertical True False lANG) + [ "{-# LANGUAGE CPP #-}" + , "" + , "#if __GLASGOW_HASKELL__ >= 702" + , "{-# LANGUAGE Trustworthy #-}" + , "#endif" + ] + + [ "{-# LANGUAGE CPP #-}" + , "" + , "#if __GLASGOW_HASKELL__ >= 702" + , "{-# LANGUAGE Trustworthy #-}" + , "#endif" + ] -------------------------------------------------------------------------------- case06 :: Assertion -case06 = expected @=? testStep (step (Just 80) CompactLine True False lANG) input - where - input = unlines - [ "{-# LANGUAGE TypeOperators, StandaloneDeriving, DeriveDataTypeable," - , " TemplateHaskell #-}" - , "{-# LANGUAGE TemplateHaskell, ViewPatterns #-}" - ] - expected = unlines - [ "{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving, " ++ - "TemplateHaskell #-}" - , "{-# LANGUAGE TypeOperators, ViewPatterns #-}" - ] +case06 = assertSnippet + (step (Just 80) CompactLine True False lANG) + [ "{-# LANGUAGE TypeOperators, StandaloneDeriving, DeriveDataTypeable," + , " TemplateHaskell #-}" + , "{-# LANGUAGE TemplateHaskell, ViewPatterns #-}" + ] + [ "{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving, " ++ + "TemplateHaskell #-}" + , "{-# LANGUAGE TypeOperators, ViewPatterns #-}" + ] -------------------------------------------------------------------------------- case07 :: Assertion -case07 = expected @=? testStep (step (Just 80) Vertical False False lANG) input - where - input = unlines - [ "{-# LANGUAGE ViewPatterns #-}" - , "{-# LANGUAGE TemplateHaskell, ViewPatterns #-}" - , "{-# LANGUAGE ScopedTypeVariables, NoImplicitPrelude #-}" - , "module Main where" - ] +case07 = assertSnippet + (step (Just 80) Vertical False False lANG) + [ "{-# LANGUAGE ViewPatterns #-}" + , "{-# LANGUAGE TemplateHaskell, ViewPatterns #-}" + , "{-# LANGUAGE ScopedTypeVariables, NoImplicitPrelude #-}" + , "module Main where" + ] - expected = unlines - [ "{-# LANGUAGE NoImplicitPrelude #-}" - , "{-# LANGUAGE ScopedTypeVariables #-}" - , "{-# LANGUAGE TemplateHaskell #-}" - , "{-# LANGUAGE ViewPatterns #-}" - , "module Main where" - ] + [ "{-# LANGUAGE NoImplicitPrelude #-}" + , "{-# LANGUAGE ScopedTypeVariables #-}" + , "{-# LANGUAGE TemplateHaskell #-}" + , "{-# LANGUAGE ViewPatterns #-}" + , "module Main where" + ] -------------------------------------------------------------------------------- case08 :: Assertion -case08 = expected @=? testStep (step (Just 80) CompactLine False False lANG) input - where - input = unlines - [ "{-# LANGUAGE TypeOperators, StandaloneDeriving, DeriveDataTypeable," - , " TemplateHaskell #-}" - , "{-# LANGUAGE TemplateHaskell, ViewPatterns #-}" - ] - expected = unlines - [ "{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving, " ++ - "TemplateHaskell #-}" - , "{-# LANGUAGE TypeOperators, ViewPatterns #-}" - ] +case08 = assertSnippet + (step (Just 80) CompactLine False False lANG) + [ "{-# LANGUAGE TypeOperators, StandaloneDeriving, DeriveDataTypeable," + , " TemplateHaskell #-}" + , "{-# LANGUAGE TemplateHaskell, ViewPatterns #-}" + ] + [ "{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving, " ++ + "TemplateHaskell #-}" + , "{-# LANGUAGE TypeOperators, ViewPatterns #-}" + ] -------------------------------------------------------------------------------- case09 :: Assertion -case09 = expected @=? testStep (step (Just 80) Compact True False lANG) input - where - input = unlines - [ "{-# LANGUAGE DefaultSignatures, FlexibleInstances, LambdaCase, " ++ - "TypeApplications" - , " #-}" - ] - expected = unlines - [ "{-# LANGUAGE DefaultSignatures, FlexibleInstances, LambdaCase," - , " TypeApplications #-}" - ] +case09 = assertSnippet + (step (Just 80) Compact True False lANG) + [ "{-# LANGUAGE DefaultSignatures, FlexibleInstances, LambdaCase, " ++ + "TypeApplications" + , " #-}" + ] + [ "{-# LANGUAGE DefaultSignatures, FlexibleInstances, LambdaCase," + , " TypeApplications #-}" + ] -------------------------------------------------------------------------------- case10 :: Assertion -case10 = expected @=? testStep (step (Just 80) Compact True False lANG) input - where - input = unlines - [ "{-# LANGUAGE NondecreasingIndentation, ScopedTypeVariables," - , " TypeApplications #-}" - ] - expected = unlines - [ "{-# LANGUAGE NondecreasingIndentation, ScopedTypeVariables, " ++ - "TypeApplications #-}" - ] +case10 = assertSnippet + (step (Just 80) Compact True False lANG) + [ "{-# LANGUAGE NondecreasingIndentation, ScopedTypeVariables," + , " TypeApplications #-}" + ] + [ "{-# LANGUAGE NondecreasingIndentation, ScopedTypeVariables, " ++ + "TypeApplications #-}" + ] -------------------------------------------------------------------------------- case11 :: Assertion -case11 = expected @=? testStep (step (Just 80) Vertical False False "language") input - where - input = unlines - [ "{-# LANGUAGE ViewPatterns #-}" - , "{-# LANGUAGE TemplateHaskell, ViewPatterns #-}" - , "{-# LANGUAGE ScopedTypeVariables, NoImplicitPrelude #-}" - , "module Main where" - ] - - expected = unlines - [ "{-# language NoImplicitPrelude #-}" - , "{-# language ScopedTypeVariables #-}" - , "{-# language TemplateHaskell #-}" - , "{-# language ViewPatterns #-}" - , "module Main where" - ] +case11 = assertSnippet + (step (Just 80) Vertical False False "language") + [ "{-# LANGUAGE ViewPatterns #-}" + , "{-# LANGUAGE TemplateHaskell, ViewPatterns #-}" + , "{-# LANGUAGE ScopedTypeVariables, NoImplicitPrelude #-}" + , "module Main where" + ] + + [ "{-# language NoImplicitPrelude #-}" + , "{-# language ScopedTypeVariables #-}" + , "{-# language TemplateHaskell #-}" + , "{-# language ViewPatterns #-}" + , "module Main where" + ] -------------------------------------------------------------------------------- case12 :: Assertion -case12 = expected @=? testStep (step Nothing Compact False False "language") input - where - input = unlines - [ "{-# LANGUAGE ViewPatterns, OverloadedStrings #-}" - , "{-# LANGUAGE TemplateHaskell, ViewPatterns #-}" - , "{-# LANGUAGE ScopedTypeVariables, NoImplicitPrelude #-}" - , "module Main where" - ] - - expected = unlines - [ "{-# language NoImplicitPrelude, OverloadedStrings, ScopedTypeVariables, TemplateHaskell, ViewPatterns #-}" - , "module Main where" - ] +case12 = assertSnippet + (step Nothing Compact False False "language") + [ "{-# LANGUAGE ViewPatterns, OverloadedStrings #-}" + , "{-# LANGUAGE TemplateHaskell, ViewPatterns #-}" + , "{-# LANGUAGE ScopedTypeVariables, NoImplicitPrelude #-}" + , "module Main where" + ] + + [ "{-# language NoImplicitPrelude, OverloadedStrings, ScopedTypeVariables, TemplateHaskell, ViewPatterns #-}" + , "module Main where" + ] From a229a2f4cd67ae4807d9db7024d305a5fe9171e3 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Thu, 1 Oct 2020 13:04:34 +0200 Subject: [PATCH 134/135] BangPatterns is removed when it shouldn't be --- .../Haskell/Stylish/Step/LanguagePragmas/Tests.hs | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/tests/Language/Haskell/Stylish/Step/LanguagePragmas/Tests.hs b/tests/Language/Haskell/Stylish/Step/LanguagePragmas/Tests.hs index aa2c1960..0c19c02b 100644 --- a/tests/Language/Haskell/Stylish/Step/LanguagePragmas/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/LanguagePragmas/Tests.hs @@ -31,6 +31,7 @@ tests = testGroup "Language.Haskell.Stylish.Step.LanguagePragmas.Tests" , testCase "case 10" case10 , testCase "case 11" case11 , testCase "case 12" case12 + , testCase "case 13" case13 ] lANG :: String @@ -200,6 +201,7 @@ case11 = assertSnippet , "module Main where" ] + -------------------------------------------------------------------------------- case12 :: Assertion case12 = assertSnippet @@ -213,3 +215,15 @@ case12 = assertSnippet [ "{-# language NoImplicitPrelude, OverloadedStrings, ScopedTypeVariables, TemplateHaskell, ViewPatterns #-}" , "module Main where" ] + + +-------------------------------------------------------------------------------- +case13 :: Assertion +case13 = assertSnippet + (step Nothing Vertical True True lANG) input input + where + input = + [ "{-# LANGUAGE BangPatterns #-}" + , "{-# LANGUAGE DeriveFunctor #-}" + , "main = let !x = 1 + 1 in print x" + ] From 79a16435029c2f77ad612527c8ebeac83efe29e1 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Thu, 1 Oct 2020 13:09:17 +0200 Subject: [PATCH 135/135] Also check for ! in Hs.Match --- .../Haskell/Stylish/Step/LanguagePragmas.hs | 37 ++++++++++++------- 1 file changed, 23 insertions(+), 14 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs b/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs index e22129f2..ddfdeb0b 100644 --- a/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs +++ b/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs @@ -1,7 +1,7 @@ +-------------------------------------------------------------------------------- {-# LANGUAGE BlockArguments #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} --------------------------------------------------------------------------------- module Language.Haskell.Stylish.Step.LanguagePragmas ( Style (..) , step @@ -16,14 +16,14 @@ import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T + -------------------------------------------------------------------------------- -import GHC.Hs.Extension (GhcPs) -import GHC.Hs.Pat (Pat (BangPat, ViewPat)) -import SrcLoc (RealSrcSpan) -import SrcLoc (realSrcSpanStart, srcLocLine, - srcSpanEndLine, +import qualified GHC.Hs as Hs +import SrcLoc (RealSrcSpan, realSrcSpanStart, + srcLocLine, srcSpanEndLine, srcSpanStartLine) + -------------------------------------------------------------------------------- import Language.Haskell.Stylish.Block import Language.Haskell.Stylish.Editor @@ -33,7 +33,8 @@ import Language.Haskell.Stylish.Util -------------------------------------------------------------------------------- -data Style = Vertical +data Style + = Vertical | Compact | CompactLine deriving (Eq, Show) @@ -168,18 +169,26 @@ isRedundant _ _ = False isRedundantViewPatterns :: Module -> Bool isRedundantViewPatterns = null . queryModule getViewPat where - getViewPat :: Pat GhcPs -> [()] + getViewPat :: Hs.Pat Hs.GhcPs -> [()] getViewPat = \case - ViewPat{} -> [()] - _ -> [] + Hs.ViewPat{} -> [()] + _ -> [] -------------------------------------------------------------------------------- -- | Check if the BangPatterns language pragma is redundant. isRedundantBangPatterns :: Module -> Bool -isRedundantBangPatterns = null . queryModule getBangPat +isRedundantBangPatterns modul = + (null $ queryModule getBangPat modul) && + (null $ queryModule getMatchStrict modul) where - getBangPat :: Pat GhcPs -> [()] + getBangPat :: Hs.Pat Hs.GhcPs -> [()] getBangPat = \case - BangPat{} -> [()] - _ -> [] + Hs.BangPat{} -> [()] + _ -> [] + + getMatchStrict :: Hs.Match Hs.GhcPs (Hs.LHsExpr Hs.GhcPs) -> [()] + getMatchStrict (Hs.XMatch m) = Hs.noExtCon m + getMatchStrict (Hs.Match _ ctx _ _) = case ctx of + Hs.FunRhs _ _ Hs.SrcStrict -> [()] + _ -> []