From 3330d04320bd144b1661531bb61598280ceb2cbb Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Fri, 17 Dec 2021 15:18:13 +0100 Subject: [PATCH 01/32] WIP --- lib/Language/Haskell/Stylish/GHC.hs | 68 ++------ lib/Language/Haskell/Stylish/Module.hs | 199 ++++------------------- lib/Language/Haskell/Stylish/Ordering.hs | 28 ++-- lib/Language/Haskell/Stylish/Parse.hs | 104 +++--------- stack.yaml | 10 +- stack.yaml.lock | 24 ++- stylish-haskell.cabal | 85 +++++----- 7 files changed, 148 insertions(+), 370 deletions(-) diff --git a/lib/Language/Haskell/Stylish/GHC.hs b/lib/Language/Haskell/Stylish/GHC.hs index 51f8baa3..c3a14431 100644 --- a/lib/Language/Haskell/Stylish/GHC.hs +++ b/lib/Language/Haskell/Stylish/GHC.hs @@ -11,31 +11,28 @@ module Language.Haskell.Stylish.GHC , getStartLineUnsafe -- * Standard settings , baseDynFlags - -- * Positions - , unLocated -- * Outputable operators , showOutputable ) where -------------------------------------------------------------------------------- -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 qualified Outputable as GHC -import PlatformConstants (PlatformConstants (..)) -import SrcLoc (GenLocated (..), Located, RealLocated, - RealSrcSpan, SrcSpan (..), srcSpanEndLine, - srcSpanStartLine) -import ToolSettings (ToolSettings (..)) +import qualified GHC.Driver.Ppr as GHC (showPpr) +import GHC.Driver.Session (defaultDynFlags) +import qualified GHC.Driver.Session as GHC +import GHC.Types.SrcLoc (GenLocated (..), + Located, + RealLocated, + RealSrcSpan, + SrcSpan (..), + srcSpanEndLine, + srcSpanStartLine) +import qualified GHC.Utils.Outputable as GHC +import qualified Language.Haskell.GhclibParserEx.GHC.Settings.Config as GHCEx unsafeGetRealSrcSpan :: Located a -> RealSrcSpan unsafeGetRealSrcSpan = \case - (L (RealSrcSpan s) _) -> s - _ -> error "could not get source code location" + (L (RealSrcSpan s _) _) -> s + _ -> error "could not get source code location" getStartLineUnsafe :: Located a -> Int getStartLineUnsafe = srcSpanStartLine . unsafeGetRealSrcSpan @@ -45,13 +42,13 @@ getEndLineUnsafe = srcSpanEndLine . unsafeGetRealSrcSpan dropAfterLocated :: Maybe (Located a) -> [RealLocated b] -> [RealLocated b] dropAfterLocated loc xs = case loc of - Just (L (RealSrcSpan rloc) _) -> + 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) _) -> + Just (L (RealSrcSpan rloc _) _) -> filter (\(L x _) -> srcSpanStartLine rloc <= srcSpanEndLine x) xs _ -> xs @@ -59,38 +56,7 @@ dropBeforeAndAfter :: Located a -> [RealLocated b] -> [RealLocated b] dropBeforeAndAfter loc = dropBeforeLocated (Just loc) . dropAfterLocated (Just loc) 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 [] [] - -unLocated :: Located a -> a -unLocated (L _ a) = a +baseDynFlags = defaultDynFlags GHCEx.fakeSettings GHCEx.fakeLlvmConfig showOutputable :: GHC.Outputable a => a -> String showOutputable = GHC.showPpr baseDynFlags diff --git a/lib/Language/Haskell/Stylish/Module.hs b/lib/Language/Haskell/Stylish/Module.hs index 866991bc..53fdd840 100644 --- a/lib/Language/Haskell/Stylish/Module.hs +++ b/lib/Language/Haskell/Stylish/Module.hs @@ -1,74 +1,43 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} module Language.Haskell.Stylish.Module ( -- * Data types - Module (..) - , ModuleHeader + Module , Import (..) - , Decls - , Comments + , Comments (..) , Lines - , makeModule -- * Getters - , moduleHeader , moduleImports , moduleImportGroups - , moduleDecls - , moduleComments - , moduleLanguagePragmas , queryModule , groupByLine -- * Imports , canMergeImport , mergeModuleImport - - -- * Annotations - , lookupAnnotation - - -- * Internal API getters - , rawComments - , rawImport - , rawModuleAnnotations - , rawModuleDecls - , rawModuleExports - , rawModuleHaddocks - , rawModuleName ) where -------------------------------------------------------------------------------- -import Data.Function ((&), on) -import Data.Functor ((<&>)) -import Data.Generics (Typeable, everything, mkQ) -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.Text (Text) -import qualified Data.Text as T -import Data.Data (Data) +import Data.Function (on, (&)) +import Data.Generics (Typeable, everything, mkQ) +import Data.List (nubBy) +import Data.List.NonEmpty (NonEmpty (..)) -------------------------------------------------------------------------------- -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 Outputable (Outputable) -import SrcLoc (GenLocated(..), RealLocated) -import SrcLoc (RealSrcSpan(..), SrcSpan(..)) -import SrcLoc (Located) -import qualified SrcLoc as GHC -import qualified Module as GHC +import GHC.Hs (ImportDecl (..), + ImportDeclQualifiedStyle (..)) +import qualified GHC.Hs as GHC +import GHC.Hs.Extension (GhcPs) +import GHC.Types.SrcLoc (GenLocated (..)) +import GHC.Types.SrcLoc (RealSrcSpan (..)) +import GHC.Types.SrcLoc (Located, unLoc) +import qualified GHC.Types.SrcLoc as GHC +import GHC.Utils.Outputable (Outputable) -------------------------------------------------------------------------------- import Language.Haskell.Stylish.GHC @@ -79,15 +48,7 @@ type Lines = [String] -------------------------------------------------------------------------------- -- | Concrete module type -data Module = Module - { parsedComments :: [GHC.RealLocated GHC.AnnotationComment] - , 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] +type Module = GHC.Located GHC.HsModule -- | Import declaration in module newtype Import = Import { unImport :: ImportDecl GhcPs } @@ -96,88 +57,26 @@ 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` unLocated . ideclName + [ (==) `on` unLoc . ideclName , (==) `on` ideclPkgQual , (==) `on` ideclSource , hasMergableQualified `on` ideclQualified , (==) `on` ideclImplicit - , (==) `on` fmap unLocated . ideclAs + , (==) `on` fmap unLoc . ideclAs , (==) `on` fmap fst . ideclHiding -- same 'hiding' flags ] where hasMergableQualified QualifiedPre QualifiedPost = True hasMergableQualified QualifiedPost QualifiedPre = True - hasMergableQualified q0 q1 = q0 == q1 + hasMergableQualified q0 q1 = q0 == q1 -- | 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 - comments - = sort - . 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 - - annotations - = GHC.annotations pstate - - annotationMap - = GHC.annotations pstate - & mapMaybe x - & Map.fromListWith (++) - - x = \case - ((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 - 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" - <&> 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 +newtype Comments = Comments [GHC.RealLocated GHC.EpaComment] -- | Get module imports moduleImports :: Module -> [Located Import] -moduleImports m - = parsedModule m - & unLocated - & GHC.hsmodImports - & fmap \(L pos i) -> L pos (Import i) +moduleImports (L _ m) = + GHC.hsmodImports m & fmap \(L pos i) -> L (GHC.locA pos) (Import i) -- | Get groups of imports from module moduleImportGroups :: Module -> [NonEmpty (Located Import)] @@ -224,48 +123,6 @@ mergeModuleImport (L p0 (Import i0)) (L _p1 (Import i1)) = merge xs ys = nubBy ((==) `on` showOutputable) (xs ++ ys) --- | Get module header -moduleHeader :: Module -> ModuleHeader -moduleHeader (Module _ _ _ (GHC.L _ m)) = ModuleHeader - { name = GHC.hsmodName m - , exports = GHC.hsmodExports m - , haddocks = GHC.hsmodHaddockModHeader m - } - --- | Query for annotations associated with a 'SrcSpan' -lookupAnnotation :: 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 -rawImport :: Import -> ImportDecl GhcPs -rawImport (Import i) = i - --- | 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 +queryModule f = everything (++) (mkQ [] f) diff --git a/lib/Language/Haskell/Stylish/Ordering.hs b/lib/Language/Haskell/Stylish/Ordering.hs index ae9977fb..16228072 100644 --- a/lib/Language/Haskell/Stylish/Ordering.hs +++ b/lib/Language/Haskell/Stylish/Ordering.hs @@ -8,7 +8,6 @@ module Language.Haskell.Stylish.Ordering , compareLIE , compareWrappedName , compareOutputableCI - , unwrapName ) where @@ -17,12 +16,12 @@ import Data.Char (isUpper, toLower) import Data.Function (on) import Data.Ord (comparing) import GHC.Hs +import GHC.Types.Name.Reader (RdrName) +import GHC.Types.SrcLoc (unLoc) +import GHC.Utils.Outputable (Outputable) +import qualified GHC.Utils.Outputable as GHC import Language.Haskell.Stylish.GHC (showOutputable) import Language.Haskell.Stylish.Module (Import (..)) -import Outputable (Outputable) -import qualified Outputable as GHC -import RdrName (RdrName) -import SrcLoc (unLoc) @@ -47,12 +46,12 @@ compareLIE = comparing $ ieKey . unLoc -- 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, "") + IEVar _ n -> nameKey n + IEThingAbs _ n -> nameKey n + IEThingAll _ n -> nameKey n + IEThingWith _ n _ _ -> nameKey n + IEModuleContents _ n -> nameKey n + _ -> (2, "") -------------------------------------------------------------------------------- @@ -60,13 +59,6 @@ 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 diff --git a/lib/Language/Haskell/Stylish/Parse.hs b/lib/Language/Haskell/Stylish/Parse.hs index b416a323..2b68de70 100644 --- a/lib/Language/Haskell/Stylish/Parse.hs +++ b/lib/Language/Haskell/Stylish/Parse.hs @@ -6,31 +6,19 @@ module Language.Haskell.Stylish.Parse -------------------------------------------------------------------------------- -import Data.Function ((&)) -import Data.Maybe (fromMaybe, listToMaybe) -import System.IO.Unsafe (unsafePerformIO) +import Data.Maybe (listToMaybe) --------------------------------------------------------------------------------- -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 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 SrcLoc (mkRealSrcLoc) -import qualified SrcLoc as GHC -import StringBuffer (stringToStringBuffer) -import qualified StringBuffer as GHC -------------------------------------------------------------------------------- -import Language.Haskell.Stylish.GHC (baseDynFlags) +import GHC.Driver.Ppr as GHC +import qualified GHC.Driver.Session as GHC +import qualified GHC.LanguageExtensions.Type as LangExt +import qualified GHC.Parser.Errors.Ppr as GHC +import qualified GHC.Parser.Lexer as GHC +import qualified GHC.Utils.Error as GHC +import qualified GHC.Utils.Outputable as GHC +import qualified Language.Haskell.GhclibParserEx.GHC.Parser as GHCEx +import Language.Haskell.Stylish.GHC (baseDynFlags) import Language.Haskell.Stylish.Module type Extensions = [String] @@ -57,67 +45,17 @@ dropBom str = str -------------------------------------------------------------------------------- -- | Abstraction over GHC lib's parsing parseModule :: Extensions -> Maybe FilePath -> String -> Either String Module -parseModule exts fp string = - parsePragmasIntoDynFlags baseDynFlags userExtensions filePath string >>= \dynFlags -> - dropBom string - & removeCpp dynFlags - & runParser dynFlags - & toModule dynFlags +parseModule _exts fp string = + let input = removeCpp $ dropBom string in + case GHCEx.parseModule input dynFlags of + GHC.POk _ m -> Right m + GHC.PFailed ps -> Left . withFileName . GHC.showSDoc dynFlags . GHC.vcat . + GHC.pprMsgEnvelopeBagWithLoc . fmap GHC.pprError . snd $ + GHC.getMessages ps where - toModule :: GHC.DynFlags -> GHC.ParseResult (GHC.Located (GHC.HsModule GHC.GhcPs)) -> Either String Module - toModule dynFlags res = case res of - POk ps m -> - Right (makeModule ps m) - PFailed 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 - else s - - userExtensions = - fmap toLocatedExtensionFlag ("Haskell2010" : exts) -- FIXME: do we need `Haskell2010` here? - - toLocatedExtensionFlag flag - = "-X" <> flag - & GHC.L GHC.noSrcSpan + -- TODO: Add extensions again. + dynFlags = baseDynFlags - getParserStateErrors dynFlags state - = GHC.getErrorMessages state dynFlags - & bagToList - & fmap (\errMsg -> show (GHC.errMsgSpan errMsg) <> ": " <> show errMsg) + removeCpp s = if GHC.xopt LangExt.Cpp dynFlags then unCpp s else s - 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 - --- | 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) + withFileName x = maybe "" (<> ": ") fp <> x diff --git a/stack.yaml b/stack.yaml index d9672083..06998209 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,3 +1,11 @@ -resolver: lts-18.6 +resolver: lts-18.18 +compiler: ghc-9.0.1 + +extra-deps: +- 'ghc-lib-parser-9.2.1.20211101' +- 'ghc-lib-parser-ex-9.2.0.1' save-hackage-creds: false +nix: + packages: + - 'haskell.compiler.ghc901' diff --git a/stack.yaml.lock b/stack.yaml.lock index c8796d80..e66af23f 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -3,10 +3,24 @@ # For more information, please see the documentation at: # https://docs.haskellstack.org/en/stable/lock_files -packages: [] +packages: +- completed: + hackage: ghc-lib-parser-9.2.1.20211101@sha256:c7f5649391acb4ceec6770acce3b77dea8aad3fd442b2a32a1d0dbaede080c0b,12705 + pantry-tree: + size: 27578 + sha256: 445b7dd1908b8187dfdab87673a68f1ca42e2bcfd7dd68f04a3ad91a2215e3e2 + original: + hackage: ghc-lib-parser-9.2.1.20211101 +- completed: + hackage: ghc-lib-parser-ex-9.2.0.1@sha256:37444e3274afd4daaa96819bb4e05835524c2e16021a56861d6f8f014584992d,3605 + pantry-tree: + size: 2121 + sha256: 8cf2d2a4fa196121c7faef816474038d8a82b8ff8a8480ecf4a5cf256c380c4c + original: + hackage: ghc-lib-parser-ex-9.2.0.1 snapshots: - completed: - size: 587113 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/6.yaml - sha256: f74c482d7c93739ecf3abfbc0f2dea1c20a2dfb2462c689846ed55a9653b66f7 - original: lts-18.6 + size: 586296 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/18.yaml + sha256: 63539429076b7ebbab6daa7656cfb079393bf644971156dc349d7c0453694ac2 + original: lts-18.18 diff --git a/stylish-haskell.cabal b/stylish-haskell.cabal index cb62ce4f..eed4a26d 100644 --- a/stylish-haskell.cabal +++ b/stylish-haskell.cabal @@ -61,20 +61,21 @@ Library Paths_stylish_haskell Build-depends: - aeson >= 0.6 && < 1.6, - base >= 4.8 && < 5, - bytestring >= 0.9 && < 0.11, - Cabal >= 2.4 && < 3.3, - containers >= 0.3 && < 0.7, - directory >= 1.2.3 && < 1.4, - filepath >= 1.1 && < 1.5, - file-embed >= 0.0.10 && < 0.1, - 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 + aeson >= 0.6 && < 1.6, + base >= 4.8 && < 5, + bytestring >= 0.9 && < 0.11, + Cabal >= 2.4 && < 3.5, + containers >= 0.3 && < 0.7, + directory >= 1.2.3 && < 1.4, + filepath >= 1.1 && < 1.5, + file-embed >= 0.0.10 && < 0.1, + ghc-lib-parser >= 9.2 && < 9.3, + ghc-lib-parser-ex >= 9.2 && < 9.3, + 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: @@ -91,19 +92,20 @@ Executable stylish-haskell strict >= 0.3 && < 0.5, optparse-applicative >= 0.12 && < 0.17, -- Copied from regular dependencies... - aeson >= 0.6 && < 1.6, - base >= 4.8 && < 5, - bytestring >= 0.9 && < 0.11, - Cabal >= 2.4 && < 3.3, - containers >= 0.3 && < 0.7, - directory >= 1.2.3 && < 1.4, - filepath >= 1.1 && < 1.5, - file-embed >= 0.0.10 && < 0.1, - ghc-lib-parser >= 8.10 && < 8.12, - mtl >= 2.0 && < 2.3, - syb >= 0.3 && < 0.8, - HsYAML-aeson >=0.2.0 && < 0.3, - HsYAML >=0.2.0 && < 0.3 + aeson >= 0.6 && < 1.6, + base >= 4.8 && < 5, + bytestring >= 0.9 && < 0.11, + Cabal >= 2.4 && < 3.5, + containers >= 0.3 && < 0.7, + directory >= 1.2.3 && < 1.4, + filepath >= 1.1 && < 1.5, + file-embed >= 0.0.10 && < 0.1, + ghc-lib-parser >= 9.2 && < 9.3, + ghc-lib-parser-ex >= 9.2 && < 9.3, + mtl >= 2.0 && < 2.3, + syb >= 0.3 && < 0.8, + HsYAML-aeson >=0.2.0 && < 0.3, + HsYAML >=0.2.0 && < 0.3 Test-suite stylish-haskell-tests Ghc-options: -Wall @@ -163,20 +165,21 @@ Test-suite stylish-haskell-tests test-framework-hunit >= 0.2 && < 0.4, random >= 1.1, -- Copied from regular dependencies... - aeson >= 0.6 && < 1.6, - base >= 4.8 && < 5, - bytestring >= 0.9 && < 0.11, - Cabal >= 2.4 && < 3.3, - containers >= 0.3 && < 0.7, - directory >= 1.2.3 && < 1.4, - filepath >= 1.1 && < 1.5, - file-embed >= 0.0.10 && < 0.1, - 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 + aeson >= 0.6 && < 1.6, + base >= 4.8 && < 5, + bytestring >= 0.9 && < 0.11, + Cabal >= 2.4 && < 3.5, + containers >= 0.3 && < 0.7, + directory >= 1.2.3 && < 1.4, + filepath >= 1.1 && < 1.5, + file-embed >= 0.0.10 && < 0.1, + ghc-lib-parser >= 9.2 && < 9.3, + ghc-lib-parser-ex >= 9.2 && < 9.3, + 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 Source-repository head Type: git From 0baf8c73bcf7220f89c21f1b02af55647597d9a1 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Tue, 1 Feb 2022 13:09:09 +0100 Subject: [PATCH 02/32] WIP: compiling now, need to redo some steps --- lib/Language/Haskell/Stylish/Align.hs | 22 +- lib/Language/Haskell/Stylish/GHC.hs | 2 + lib/Language/Haskell/Stylish/Printer.hs | 224 ++++++++++-------- lib/Language/Haskell/Stylish/Step/Data.hs | 42 +--- lib/Language/Haskell/Stylish/Step/Imports.hs | 22 +- .../Haskell/Stylish/Step/LanguagePragmas.hs | 20 +- .../Haskell/Stylish/Step/ModuleHeader.hs | 32 +-- .../Haskell/Stylish/Step/SimpleAlign.hs | 103 ++++---- lib/Language/Haskell/Stylish/Step/Squash.hs | 17 +- .../Haskell/Stylish/Step/UnicodeSyntax.hs | 22 +- lib/Language/Haskell/Stylish/Util.hs | 33 +-- 11 files changed, 234 insertions(+), 305 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Align.hs b/lib/Language/Haskell/Stylish/Align.hs index c8a092f9..1e7a851a 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 SrcLoc as S +import qualified GHC.Types.SrcLoc as GHC -------------------------------------------------------------------------------- @@ -55,9 +55,9 @@ data Alignable a = Alignable -- | Create changes that perform the alignment. align - :: Maybe Int -- ^ Max columns - -> [Alignable S.RealSrcSpan] -- ^ Alignables - -> [Change String] -- ^ Changes performing the alignment + :: Maybe Int -- ^ Max columns + -> [Alignable GHC.RealSrcSpan] -- ^ Alignables + -> [Change String] -- ^ Changes performing the alignment align _ [] = [] align maxColumns alignment -- Do not make an changes if we would go past the maximum number of columns @@ -70,17 +70,17 @@ align maxColumns alignment Just c -> i > c -- The longest thing in the left column - longestLeft = maximum $ map (S.srcSpanEndCol . aLeft) alignment + longestLeft = maximum $ map (GHC.srcSpanEndCol . aLeft) alignment -- The longest thing in the right column longestRight = maximum - [ S.srcSpanEndCol (aRight a) - S.srcSpanStartCol (aRight a) + [ GHC.srcSpanEndCol (aRight a) - GHC.srcSpanStartCol (aRight a) + aRightLead a | a <- alignment ] - align' a = changeLine (S.srcSpanStartLine $ aContainer a) $ \str -> - let column = S.srcSpanEndCol $ aLeft a + align' a = changeLine (GHC.srcSpanStartLine $ aContainer a) $ \str -> + let column = GHC.srcSpanEndCol $ aLeft a (pre, post) = splitAt column str in [padRight longestLeft (trimRight pre) ++ trimLeft post] @@ -88,11 +88,11 @@ align maxColumns alignment -- | Checks that all the alignables appear on a single line, and that they do -- not overlap. -fixable :: [Alignable S.RealSrcSpan] -> Bool +fixable :: [Alignable GHC.RealSrcSpan] -> Bool fixable [] = False fixable [_] = False fixable fields = all singleLine containers && nonOverlapping containers where containers = map aContainer fields - singleLine s = S.srcSpanStartLine s == S.srcSpanEndLine s - nonOverlapping ss = length ss == length (nub $ map S.srcSpanStartLine ss) + singleLine s = GHC.srcSpanStartLine s == GHC.srcSpanEndLine s + nonOverlapping ss = length ss == length (nub $ map GHC.srcSpanStartLine ss) diff --git a/lib/Language/Haskell/Stylish/GHC.hs b/lib/Language/Haskell/Stylish/GHC.hs index c3a14431..6d4f2144 100644 --- a/lib/Language/Haskell/Stylish/GHC.hs +++ b/lib/Language/Haskell/Stylish/GHC.hs @@ -1,4 +1,5 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -Wno-missing-fields #-} -- | Utility functions for working with the GHC AST module Language.Haskell.Stylish.GHC @@ -28,6 +29,7 @@ import GHC.Types.SrcLoc (GenLocated srcSpanStartLine) import qualified GHC.Utils.Outputable as GHC import qualified Language.Haskell.GhclibParserEx.GHC.Settings.Config as GHCEx +import qualified GHC.Parser.Annotation as GHC unsafeGetRealSrcSpan :: Located a -> RealSrcSpan unsafeGetRealSrcSpan = \case diff --git a/lib/Language/Haskell/Stylish/Printer.hs b/lib/Language/Haskell/Stylish/Printer.hs index a356b2f4..7de089db 100644 --- a/lib/Language/Haskell/Stylish/Printer.hs +++ b/lib/Language/Haskell/Stylish/Printer.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE BlockArguments #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} @@ -20,28 +21,28 @@ module Language.Haskell.Stylish.Printer -- ** Combinators , comma , dot - , getAnnot + -- , getAnnot , getCurrentLine , getCurrentLineLength - , getDocstrPrev + -- , getDocstrPrev , newline , parenthesize - , peekNextCommentPos + -- , peekNextCommentPos , prefix , putComment - , putEolComment + -- , putEolComment , putOutputable - , putAllSpanComments + -- , putAllSpanComments , putCond , putType , putRdrName , putText - , removeCommentTo - , removeCommentToEnd - , removeLineComment + -- , removeCommentTo + -- , removeCommentToEnd + -- , removeLineComment , sep - , groupAttachedComments - , groupWithoutComments + -- , groupAttachedComments + -- , groupWithoutComments , space , spaces , suffix @@ -57,16 +58,14 @@ module Language.Haskell.Stylish.Printer import Prelude hiding (lines) -------------------------------------------------------------------------------- -import ApiAnnotation (AnnKeywordId(..), AnnotationComment(..)) -import BasicTypes (PromotionFlag(..)) -import GHC.Hs.Extension (GhcPs, NoExtField(..)) -import GHC.Hs.Types (HsType(..)) -import Module (ModuleName, moduleNameString) -import RdrName (RdrName(..)) -import SrcLoc (GenLocated(..), RealLocated) -import SrcLoc (Located, SrcSpan(..)) -import SrcLoc (srcSpanStartLine, srcSpanEndLine) -import Outputable (Outputable) +import GHC.Hs.Extension (GhcPs) +import GHC.Types.Name.Reader (RdrName(..)) +import GHC.Types.SrcLoc (GenLocated(..)) +import GHC.Utils.Outputable (Outputable) +import qualified GHC.Hs as GHC +import qualified GHC.Types.SrcLoc as GHC +import qualified GHC.Unit.Module.Name as GHC +import qualified GHC.Types.Basic as GHC -------------------------------------------------------------------------------- import Control.Monad (forM_, replicateM_) @@ -74,14 +73,11 @@ 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) -import Data.Foldable (find, toList) -import Data.Functor ((<&>)) -import Data.List (delete, isPrefixOf) -import Data.List.NonEmpty (NonEmpty(..)) +import Data.List (foldl') -------------------------------------------------------------------------------- -import Language.Haskell.Stylish.Module (Module, Lines, lookupAnnotation) -import Language.Haskell.Stylish.GHC (showOutputable, unLocated) +import Language.Haskell.Stylish.Module (Module, Lines) +import Language.Haskell.Stylish.GHC (showOutputable) -- | Shorthand for 'Printer' monad type P = Printer @@ -100,12 +96,12 @@ data PrinterState = PrinterState { lines :: !Lines , linePos :: !Int , currentLine :: !String - , pendingComments :: ![RealLocated AnnotationComment] + , pendingComments :: ![GHC.RealLocated GHC.EpaComment] , 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 :: PrinterConfig -> [GHC.RealLocated GHC.EpaComment] -> Module -> Printer a -> (a, Lines) runPrinter cfg comments m (Printer printer) = let (a, PrinterState parsedLines _ startedLine _ _) = runReaderT printer cfg `runState` PrinterState [] 0 "" comments m @@ -113,7 +109,7 @@ runPrinter cfg comments m (Printer printer) = (a, parsedLines <> if startedLine == [] then [] else [startedLine]) -- | Run printer to get printed lines only -runPrinter_ :: PrinterConfig -> [RealLocated AnnotationComment] -> Module -> Printer a -> Lines +runPrinter_ :: PrinterConfig -> [GHC.RealLocated GHC.EpaComment] -> Module -> Printer a -> Lines runPrinter_ cfg comments m printer = snd (runPrinter cfg comments m printer) -- | Print text @@ -137,6 +133,7 @@ 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 () @@ -146,24 +143,27 @@ putAllSpanComments suff = \case srcSpanEndLine rloc <= srcSpanEndLine rspan forM_ cmts (\c -> putComment c >> suff) +-} -- | Print any comment -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 +putComment :: GHC.EpaComment -> P () +putComment epaComment = case GHC.ac_tok epaComment of + GHC.EpaLineComment s -> putText s + GHC.EpaDocCommentNext s -> putText s + GHC.EpaDocCommentPrev s -> putText s + GHC.EpaDocCommentNamed s -> putText s + GHC.EpaDocSection _ s -> putText s + GHC.EpaDocOptions s -> putText s + GHC.EpaBlockComment s -> putText s + GHC.EpaEofComment -> pure () -- | 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) -> + L rloc epaComment | GHC.EpaLineComment s <- GHC.ac_tok epaComment -> and [ srcSpanStartLine rspan == srcSpanStartLine rloc , not ("-- ^" `isPrefixOf` s) @@ -172,123 +172,137 @@ putEolComment = \case _ -> False 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 - annots <- getAnnot pos - if AnnOpenP `elem` annots then do - putText "(" +putRdrName :: GenLocated GHC.SrcSpanAnnN RdrName -> P () +putRdrName rdrName = case GHC.unLoc rdrName of + Unqual name -> do + let (pre, post) = nameAnnAdornments $ + GHC.epAnnAnnsL $ GHC.ann $ GHC.getLoc rdrName + putText pre putText (showOutputable name) - putText ")" - else if AnnBackquote `elem` annots then do - putText "`" + putText post + Qual modulePrefix name -> + putModuleName modulePrefix >> dot >> putText (showOutputable name) + Orig _ name -> putText (showOutputable name) - putText "`" - else if AnnSimpleQuote `elem` annots then do - putText "'" + Exact name -> putText (showOutputable name) - else - putText (showOutputable name) - Qual modulePrefix name -> - putModuleName modulePrefix >> dot >> putText (showOutputable name) - Orig _ name -> - putText (showOutputable name) - Exact name -> - putText (showOutputable name) + +nameAnnAdornments :: [GHC.NameAnn] -> (String, String) +nameAnnAdornments = foldl' + (\(accl, accr) nameAnn -> + let (l, r) = nameAnnAdornment nameAnn in (accl ++ l, r ++ accr)) + (mempty, mempty) + +nameAnnAdornment :: GHC.NameAnn -> (String, String) +nameAnnAdornment = \case + GHC.NameAnn {..} -> fromAdornment nann_adornment + GHC.NameAnnCommas {..} -> fromAdornment nann_adornment + GHC.NameAnnOnly {..} -> fromAdornment nann_adornment + GHC.NameAnnRArrow {} -> (mempty, mempty) + GHC.NameAnnQuote {} -> ("'", mempty) + GHC.NameAnnTrailing {} -> (mempty, mempty) + where + fromAdornment GHC.NameParens = ("(", ")") + fromAdornment GHC.NameBackquotes = ("`", "`") + fromAdornment GHC.NameParensHash = ("#(", "#)") + fromAdornment GHC.NameSquare = ("[", "]") -- | Print module name -putModuleName :: ModuleName -> P () -putModuleName = putText . moduleNameString +putModuleName :: GHC.ModuleName -> P () +putModuleName = putText . GHC.moduleNameString -- | Print type -putType :: Located (HsType GhcPs) -> P () -putType ltp = case unLocated ltp of - HsFunTy NoExtField argTp funTp -> do +putType :: GHC.LHsType GhcPs -> P () +putType ltp = case GHC.unLoc ltp of + GHC.HsFunTy _ arrowTp argTp funTp -> do putOutputable argTp space - putText "->" + putOutputable arrowTp space putType funTp - HsAppTy NoExtField t1 t2 -> + GHC.HsAppTy _ t1 t2 -> putType t1 >> space >> putType t2 - HsExplicitListTy NoExtField _ xs -> do + GHC.HsExplicitListTy _ _ xs -> do putText "'[" sep (comma >> space) (fmap putType xs) putText "]" - HsExplicitTupleTy NoExtField xs -> do + GHC.HsExplicitTupleTy _ xs -> do putText "'(" sep (comma >> space) (fmap putType xs) putText ")" - HsOpTy NoExtField lhs op rhs -> do + GHC.HsOpTy _ lhs op rhs -> do putType lhs space putRdrName op space putType rhs - HsTyVar NoExtField flag rdrName -> do + GHC.HsTyVar _ flag rdrName -> do case flag of - IsPromoted -> putText "'" - NotPromoted -> pure () + GHC.IsPromoted -> putText "'" + GHC.NotPromoted -> pure () putRdrName rdrName - HsTyLit _ tp -> + GHC.HsTyLit _ tp -> putOutputable tp - HsParTy _ tp -> do + GHC.HsParTy _ tp -> do putText "(" putType tp putText ")" - HsTupleTy NoExtField _ xs -> do + GHC.HsTupleTy _ _ xs -> do putText "(" sep (comma >> space) (fmap putType xs) putText ")" - HsForAllTy NoExtField _ _ _ -> + GHC.HsForAllTy {} -> putOutputable ltp - HsQualTy NoExtField _ _ -> + GHC.HsQualTy {} -> putOutputable ltp - HsAppKindTy _ _ _ -> + GHC.HsAppKindTy _ _ _ -> putOutputable ltp - HsListTy _ _ -> + GHC.HsListTy _ _ -> putOutputable ltp - HsSumTy _ _ -> + GHC.HsSumTy _ _ -> putOutputable ltp - HsIParamTy _ _ _ -> + GHC.HsIParamTy _ _ _ -> putOutputable ltp - HsKindSig _ _ _ -> + GHC.HsKindSig _ _ _ -> putOutputable ltp - HsStarTy _ _ -> + GHC.HsStarTy _ _ -> putOutputable ltp - HsSpliceTy _ _ -> + GHC.HsSpliceTy _ _ -> putOutputable ltp - HsDocTy _ _ _ -> + GHC.HsDocTy _ _ _ -> putOutputable ltp - HsBangTy _ _ _ -> + GHC.HsBangTy _ _ _ -> putOutputable ltp - HsRecTy _ _ -> + GHC.HsRecTy _ _ -> putOutputable ltp - HsWildCardTy _ -> + GHC.HsWildCardTy _ -> putOutputable ltp - XHsType _ -> + GHC.XHsType _ -> putOutputable ltp -- | Get a docstring on the start line of 'SrcSpan' that is a @-- ^@ comment -getDocstrPrev :: SrcSpan -> P (Maybe AnnotationComment) +{- +getDocstrPrev :: SrcSpan -> P (Maybe GHC.EpaComment) getDocstrPrev = \case UnhelpfulSpan _ -> pure Nothing RealSrcSpan rspan -> do removeComment \case - L rloc (AnnLineComment s) -> + L rloc epaComment | GHC.EpaLineComment s <- GHC.ac_tok epaComment -> and [ srcSpanStartLine rspan == srcSpanStartLine rloc , "-- ^" `isPrefixOf` s ] _ -> False +-} -- | Print a newline newline :: P () @@ -336,27 +350,28 @@ pad n = do len <- length <$> getCurrentLine spaces $ n - len +{- -- | Gets comment on supplied 'line' and removes it from the state -removeLineComment :: Int -> P (Maybe AnnotationComment) +removeLineComment :: Int -> P (Maybe GHC.EpaComment) removeLineComment line = removeComment (\(L rloc _) -> srcSpanStartLine rloc == line) -- | Removes comments from the state up to start line of 'SrcSpan' and returns -- the ones that were removed -removeCommentTo :: SrcSpan -> P [AnnotationComment] +removeCommentTo :: SrcSpan -> P [GHC.EpaComment] 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 :: SrcSpan -> P [GHC.EpaComment] 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' :: Int -> P [GHC.EpaComment] removeCommentTo' line = removeComment (\(L rloc _) -> srcSpanStartLine rloc < line) >>= \case Nothing -> pure [] @@ -365,7 +380,7 @@ removeCommentTo' line = pure (c : rest) -- | Removes comments from the state while given predicate 'p' is true -removeComments :: (RealLocated AnnotationComment -> Bool) -> P [AnnotationComment] +removeComments :: (GHC.RealLocated GHC.EpaComment -> Bool) -> P [GHC.EpaComment] removeComments p = removeComment p >>= \case Just c -> do @@ -374,7 +389,7 @@ removeComments p = Nothing -> pure [] -- | Remove a comment from the state given predicate 'p' -removeComment :: (RealLocated AnnotationComment -> Bool) -> P (Maybe AnnotationComment) +removeComment :: (GHC.RealLocated GHC.EpaComment -> Bool) -> P (Maybe GHC.EpaComment) removeComment p = do comments <- gets pendingComments @@ -387,10 +402,7 @@ 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 getCurrentLine :: P String @@ -401,17 +413,20 @@ getCurrentLineLength :: P Int getCurrentLineLength = fmap length getCurrentLine -- | Peek at the next comment in the state +{- peekNextCommentPos :: P (Maybe SrcSpan) peekNextCommentPos = do gets pendingComments <&> \case (L next _ : _) -> Just (RealSrcSpan next) [] -> Nothing +-} -- | Get attached comments belonging to '[Located a]' given -groupAttachedComments :: [Located a] -> P [([AnnotationComment], NonEmpty (Located a))] +{- +groupAttachedComments :: [Located a] -> P [([GHC.EpaComment], NonEmpty (Located a))] groupAttachedComments = go where - go :: [Located a] -> P [([AnnotationComment], NonEmpty (Located a))] + go :: [Located a] -> P [([GHC.EpaComment], NonEmpty (Located a))] go (L rspan x : xs) = do comments <- removeCommentTo rspan nextGroupStartM <- peekNextCommentPos @@ -431,13 +446,14 @@ groupAttachedComments = go -- | A view on 'groupAttachedComments': return 'Just' when there is just a -- one big group without any comments. groupWithoutComments - :: [([AnnotationComment], NonEmpty (Located a))] + :: [([GHC.EpaComment], NonEmpty (Located a))] -> Maybe [Located a] groupWithoutComments grouped | all (null . fst) grouped = Just $ concatMap (toList . snd) grouped | otherwise = Nothing +-} modifyCurrentLine :: (String -> String) -> P () modifyCurrentLine f = do diff --git a/lib/Language/Haskell/Stylish/Step/Data.hs b/lib/Language/Haskell/Stylish/Step/Data.hs index de8628db..8827b7b5 100644 --- a/lib/Language/Haskell/Stylish/Step/Data.hs +++ b/lib/Language/Haskell/Stylish/Step/Data.hs @@ -16,43 +16,6 @@ module Language.Haskell.Stylish.Step.Data import Prelude hiding (init) -------------------------------------------------------------------------------- -import Control.Monad (forM_, unless, when) -import Data.Function ((&)) -import Data.Functor ((<&>)) -import Data.List (sortBy) -import Data.Maybe (listToMaybe) - --------------------------------------------------------------------------------- -import ApiAnnotation (AnnotationComment) -import BasicTypes (LexicalFixity (..)) -import GHC.Hs.Decls (ConDecl (..), - DerivStrategy (..), - HsDataDefn (..), - HsDecl (..), - HsDerivingClause (..), - NewOrData (..), - TyClDecl (..)) -import GHC.Hs.Extension (GhcPs, NoExtField (..), - noExtCon) -import GHC.Hs.Types (ConDeclField (..), - ForallVisFlag (..), - HsConDetails (..), - HsContext, - HsImplicitBndrs (..), - HsTyVarBndr (..), - HsType (..), LHsKind, - LHsQTyVars (..)) -import RdrName (RdrName) -import SrcLoc (GenLocated (..), Located, - RealLocated) - --------------------------------------------------------------------------------- -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 data Indent @@ -103,6 +66,9 @@ defaultConfig = Config } step :: Config -> Step +step _cfg = makeStep "Data" \ls _ -> ls + +{- step cfg = makeStep "Data" \ls m -> applyChanges (changes m) ls where changes :: Module -> [ChangeLine] @@ -561,3 +527,5 @@ 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 058d7c6e..55498c15 100644 --- a/lib/Language/Haskell/Stylish/Step/Imports.hs +++ b/lib/Language/Haskell/Stylish/Step/Imports.hs @@ -12,7 +12,7 @@ module Language.Haskell.Stylish.Step.Imports , ListPadding (..) , step - , printImport + -- , printImport ) where -------------------------------------------------------------------------------- @@ -28,27 +28,11 @@ 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.Ordering -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 -------------------------------------------------------------------------------- @@ -112,6 +96,8 @@ data LongListAlign -------------------------------------------------------------------------------- step :: Maybe Int -> Options -> Step +step _ _ = makeStep "Imports (ghc-lib-parser)" $ \ls _ -> ls +{- step columns = makeStep "Imports (ghc-lib-parser)" . printImports columns @@ -494,3 +480,5 @@ nubOn f = go Set.empty | otherwise = x : go (Set.insert y acc) xs where y = f x + +-} diff --git a/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs b/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs index 40720aea..b9d00247 100644 --- a/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs +++ b/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs @@ -19,9 +19,7 @@ import qualified Data.Text as T -------------------------------------------------------------------------------- import qualified GHC.Hs as Hs -import SrcLoc (RealSrcSpan, realSrcSpanStart, - srcLocLine, srcSpanEndLine, - srcSpanStartLine) +import qualified GHC.Types.SrcLoc as GHC -------------------------------------------------------------------------------- @@ -131,11 +129,11 @@ step' columns style align removeRedundant lngPrefix ls m | removeRedundant = isRedundant m | otherwise = const False - languagePragmas = moduleLanguagePragmas m + languagePragmas = [] -- moduleLanguagePragmas m - convertFstToBlock :: [(RealSrcSpan, a)] -> [(Block String, a)] + convertFstToBlock :: [(GHC.RealSrcSpan, a)] -> [(Block String, a)] convertFstToBlock = fmap \(rspan, a) -> - (Block (srcSpanStartLine rspan) (srcSpanEndLine rspan), a) + (Block (GHC.srcSpanStartLine rspan) (GHC.srcSpanEndLine rspan), a) groupAdjacent' = fmap turnSndBackToNel . groupAdjacent . fmap (fmap toList) @@ -156,15 +154,16 @@ step' columns style align removeRedundant lngPrefix ls m -------------------------------------------------------------------------------- -- | Add a LANGUAGE pragma to a module if it is not present already. addLanguagePragma :: String -> String -> Module -> [Change String] -addLanguagePragma lg prag modu +addLanguagePragma lg prag _modu | prag `elem` present = [] | otherwise = [insert line ["{-# " ++ lg ++ " " ++ prag ++ " #-}"]] where - pragmas' = moduleLanguagePragmas modu + -- pragmas' = moduleLanguagePragmas modu + pragmas' = [] 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) + firstLocation :: [(GHC.RealSrcSpan, NonEmpty Text)] -> Int + firstLocation = minimum . fmap (GHC.srcLocLine . GHC.realSrcSpanStart . fst) -------------------------------------------------------------------------------- @@ -200,7 +199,6 @@ isRedundantBangPatterns modul = _ -> [] 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 -> [()] _ -> [] diff --git a/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs b/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs index 4130745b..4e6a76e0 100644 --- a/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs +++ b/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs @@ -8,37 +8,9 @@ module Language.Haskell.Stylish.Step.ModuleHeader , step ) where --------------------------------------------------------------------------------- -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.ImpExp as GHC -import qualified Module as GHC -import SrcLoc (GenLocated (..), - Located, RealLocated, - SrcSpan (..), - srcSpanEndLine, - srcSpanStartLine, unLoc) -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.Ordering -import Language.Haskell.Stylish.Printer import Language.Haskell.Stylish.Step -import qualified Language.Haskell.Stylish.Step.Imports as Imports data Config = Config @@ -71,6 +43,8 @@ defaultConfig = Config } step :: Maybe Int -> Config -> Step +step _ _ = makeStep "Module header" $ \ls _ -> ls +{- step maxCols = makeStep "Module header" . printModuleHeader maxCols printModuleHeader :: Maybe Int -> Config -> Lines -> Module -> Lines @@ -300,3 +274,5 @@ printMultiLineExportList conf (L srcLoc exportsWithComments) = do -- 'Imports' and should be merged. printExport :: Config -> GHC.LIE GhcPs -> P () printExport conf = Imports.printImport (separateLists conf) . unLoc + +-} diff --git a/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs b/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs index 449c9d8e..4a594dbc 100644 --- a/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs +++ b/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs @@ -15,7 +15,8 @@ import Data.Foldable (toList) import Data.List (foldl', foldl1', sortOn) import Data.Maybe (fromMaybe) import qualified GHC.Hs as Hs -import qualified SrcLoc as S +import qualified GHC.Parser.Annotation as GHC +import qualified GHC.Types.SrcLoc as GHC -------------------------------------------------------------------------------- @@ -48,49 +49,49 @@ defaultConfig = Config , cMultiWayIf = Always } -groupAlign :: Align -> [Alignable S.RealSrcSpan] -> [[Alignable S.RealSrcSpan]] +groupAlign :: Align -> [Alignable GHC.RealSrcSpan] -> [[Alignable GHC.RealSrcSpan]] groupAlign a xs = case a of Never -> [] - Adjacent -> byLine . sortOn (S.srcSpanStartLine . aLeft) $ xs + Adjacent -> byLine . sortOn (GHC.srcSpanStartLine . aLeft) $ xs Always -> [xs] where byLine = map toList . groupByLine aLeft -------------------------------------------------------------------------------- -type Record = [S.Located (Hs.ConDeclField Hs.GhcPs)] +type Record = [GHC.LocatedA (Hs.ConDeclField Hs.GhcPs)] -------------------------------------------------------------------------------- -records :: S.Located (Hs.HsModule Hs.GhcPs) -> [Record] +records :: GHC.Located Hs.HsModule -> [Record] records modu = do - let decls = map S.unLoc (Hs.hsmodDecls (S.unLoc modu)) + let decls = map GHC.unLoc (Hs.hsmodDecls (GHC.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 case Hs.con_args d of - Hs.RecCon rec -> [S.unLoc rec] + Hs.RecCon rec -> [GHC.unLoc rec] _ -> [] where getConDecls :: Hs.HsDataDefn Hs.GhcPs -> [Hs.ConDecl Hs.GhcPs] - getConDecls d@Hs.HsDataDefn {} = map S.unLoc $ Hs.dd_cons d + getConDecls d@Hs.HsDataDefn {} = map GHC.unLoc $ Hs.dd_cons d getConDecls (Hs.XHsDataDefn x) = Hs.noExtCon x -------------------------------------------------------------------------------- -recordToAlignable :: Config -> Record -> [[Alignable S.RealSrcSpan]] +recordToAlignable :: Config -> Record -> [[Alignable GHC.RealSrcSpan]] recordToAlignable conf = groupAlign (cRecords conf) . 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 + :: GHC.LocatedA (Hs.ConDeclField Hs.GhcPs) -> Maybe (Alignable GHC.RealSrcSpan) +fieldDeclToAlignable (GHC.L _ (Hs.XConDeclField x)) = Hs.noExtCon x +fieldDeclToAlignable (GHC.L matchLoc (Hs.ConDeclField _ names ty _)) = do + matchPos <- GHC.srcSpanToRealSrcSpan $ GHC.locA matchLoc + leftPos <- GHC.srcSpanToRealSrcSpan $ GHC.getLoc $ last names + tyPos <- GHC.srcSpanToRealSrcSpan $ GHC.getLocA ty Just $ Alignable { aContainer = matchPos , aLeft = leftPos @@ -103,60 +104,60 @@ fieldDeclToAlignable (S.L matchLoc (Hs.ConDeclField _ names ty _)) = do matchGroupToAlignable :: Config -> Hs.MatchGroup Hs.GhcPs (Hs.LHsExpr Hs.GhcPs) - -> [[Alignable S.RealSrcSpan]] + -> [[Alignable GHC.RealSrcSpan]] matchGroupToAlignable _conf (Hs.XMatchGroup x) = Hs.noExtCon x matchGroupToAlignable conf (Hs.MG _ alts _) = cases' ++ patterns' where - (cases, patterns) = partitionEithers . fromMaybe [] $ traverse matchToAlignable (S.unLoc alts) + (cases, patterns) = partitionEithers . fromMaybe [] $ traverse matchToAlignable (GHC.unLoc alts) cases' = groupAlign (cCases conf) cases patterns' = groupAlign (cTopLevelPatterns conf) patterns -------------------------------------------------------------------------------- matchToAlignable - :: S.Located (Hs.Match Hs.GhcPs (Hs.LHsExpr Hs.GhcPs)) - -> Maybe (Either (Alignable S.RealSrcSpan) (Alignable S.RealSrcSpan)) -matchToAlignable (S.L matchLoc m@(Hs.Match _ Hs.CaseAlt pats@(_ : _) grhss)) = do - let patsLocs = map S.getLoc pats + :: GHC.LocatedA (Hs.Match Hs.GhcPs (Hs.LHsExpr Hs.GhcPs)) + -> Maybe (Either (Alignable GHC.RealSrcSpan) (Alignable GHC.RealSrcSpan)) +matchToAlignable (GHC.L matchLoc m@(Hs.Match _ Hs.CaseAlt pats@(_ : _) grhss)) = do + let patsLocs = map GHC.getLocA pats pat = last patsLocs guards = getGuards m - guardsLocs = map S.getLoc guards - left = foldl' S.combineSrcSpans pat guardsLocs + guardsLocs = map GHC.getLocA guards + left = foldl' GHC.combineSrcSpans pat guardsLocs body <- rhsBody grhss - matchPos <- toRealSrcSpan matchLoc - leftPos <- toRealSrcSpan left - rightPos <- toRealSrcSpan $ S.getLoc body + matchPos <- GHC.srcSpanToRealSrcSpan $ GHC.locA matchLoc + leftPos <- GHC.srcSpanToRealSrcSpan left + rightPos <- GHC.srcSpanToRealSrcSpan $ GHC.getLocA body Just . Left $ Alignable { aContainer = matchPos , aLeft = leftPos , aRight = rightPos , aRightLead = length "-> " } -matchToAlignable (S.L matchLoc (Hs.Match _ (Hs.FunRhs name _ _) pats@(_ : _) grhss)) = do +matchToAlignable (GHC.L matchLoc (Hs.Match _ (Hs.FunRhs name _ _) pats@(_ : _) grhss)) = do body <- unguardedRhsBody grhss - let patsLocs = map S.getLoc pats - nameLoc = S.getLoc name + let patsLocs = map GHC.getLocA pats + nameLoc = GHC.getLocA name left = last (nameLoc : patsLocs) - bodyLoc = S.getLoc body - matchPos <- toRealSrcSpan matchLoc - leftPos <- toRealSrcSpan left - bodyPos <- toRealSrcSpan bodyLoc + bodyLoc = GHC.getLocA body + matchPos <- GHC.srcSpanToRealSrcSpan $ GHC.locA matchLoc + leftPos <- GHC.srcSpanToRealSrcSpan left + bodyPos <- GHC.srcSpanToRealSrcSpan bodyLoc Just . Right $ Alignable { aContainer = matchPos , aLeft = leftPos , aRight = bodyPos , aRightLead = length "= " } -matchToAlignable (S.L _ (Hs.XMatch x)) = Hs.noExtCon x -matchToAlignable (S.L _ (Hs.Match _ _ _ _)) = Nothing +matchToAlignable (GHC.L _ (Hs.XMatch x)) = Hs.noExtCon x +matchToAlignable (GHC.L _ (Hs.Match _ _ _ _)) = Nothing -------------------------------------------------------------------------------- multiWayIfToAlignable :: Config -> Hs.LHsExpr Hs.GhcPs - -> [[Alignable S.RealSrcSpan]] -multiWayIfToAlignable conf (S.L _ (Hs.HsMultiIf _ grhss)) = + -> [[Alignable GHC.RealSrcSpan]] +multiWayIfToAlignable conf (GHC.L _ (Hs.HsMultiIf _ grhss)) = groupAlign (cMultiWayIf conf) as where as = fromMaybe [] $ traverse grhsToAlignable grhss @@ -165,34 +166,34 @@ multiWayIfToAlignable _conf _ = [] -------------------------------------------------------------------------------- grhsToAlignable - :: S.Located (Hs.GRHS Hs.GhcPs (Hs.LHsExpr Hs.GhcPs)) - -> Maybe (Alignable S.RealSrcSpan) -grhsToAlignable (S.L grhsloc (Hs.GRHS _ guards@(_ : _) body)) = do - let guardsLocs = map S.getLoc guards - bodyLoc = S.getLoc body - left = foldl1' S.combineSrcSpans guardsLocs - matchPos <- toRealSrcSpan grhsloc - leftPos <- toRealSrcSpan left - bodyPos <- toRealSrcSpan bodyLoc + :: GHC.Located (Hs.GRHS Hs.GhcPs (Hs.LHsExpr Hs.GhcPs)) + -> Maybe (Alignable GHC.RealSrcSpan) +grhsToAlignable (GHC.L grhsloc (Hs.GRHS _ guards@(_ : _) body)) = do + let guardsLocs = map GHC.getLocA guards + bodyLoc = GHC.getLocA $ body + left = foldl1' GHC.combineSrcSpans guardsLocs + matchPos <- GHC.srcSpanToRealSrcSpan grhsloc + leftPos <- GHC.srcSpanToRealSrcSpan left + bodyPos <- GHC.srcSpanToRealSrcSpan bodyLoc Just $ Alignable { aContainer = matchPos , aLeft = leftPos , aRight = bodyPos , aRightLead = length "-> " } -grhsToAlignable (S.L _ (Hs.XGRHS x)) = Hs.noExtCon x -grhsToAlignable (S.L _ _) = Nothing +grhsToAlignable (GHC.L _ (Hs.XGRHS x)) = Hs.noExtCon x +grhsToAlignable (GHC.L _ _) = Nothing -------------------------------------------------------------------------------- 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]]) + :: (GHC.Located Hs.HsModule -> [a]) + -> (a -> [[Alignable GHC.RealSrcSpan]]) -> [Change String] changes search toAlign = - (concatMap . concatMap) (align maxColumns) . map toAlign $ search (parsedModule module') + (concatMap . concatMap) (align maxColumns) . map toAlign $ search module' configured :: [Change String] configured = concat $ diff --git a/lib/Language/Haskell/Stylish/Step/Squash.hs b/lib/Language/Haskell/Stylish/Step/Squash.hs index 23d1e9fa..3bf972d0 100644 --- a/lib/Language/Haskell/Stylish/Step/Squash.hs +++ b/lib/Language/Haskell/Stylish/Step/Squash.hs @@ -8,24 +8,17 @@ module Language.Haskell.Stylish.Step.Squash -------------------------------------------------------------------------------- -import Data.Maybe (mapMaybe) -import qualified GHC.Hs as Hs -import qualified SrcLoc as S - - --------------------------------------------------------------------------------- -import Language.Haskell.Stylish.Editor import Language.Haskell.Stylish.Step -import Language.Haskell.Stylish.Util +{- -------------------------------------------------------------------------------- squash :: (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 + lAnn <- toRealSrcSpan $ GHC.getLoc left + rAnn <- toRealSrcSpan $ GHC.getLoc right if S.srcSpanEndLine lAnn == S.srcSpanStartLine rAnn || S.srcSpanEndLine lAnn + 1 == S.srcSpanStartLine rAnn then Just $ @@ -53,11 +46,15 @@ squashMatch (Hs.Match _ _ pats grhss) = do squash (last pats) body squashMatch (Hs.XMatch x) = Hs.noExtCon x +-} -------------------------------------------------------------------------------- step :: Step +step = makeStep "Squash" $ \ls _ -> 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/Step/UnicodeSyntax.hs b/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs index ff01deea..e415b3c4 100644 --- a/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs +++ b/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs @@ -5,22 +5,11 @@ module Language.Haskell.Stylish.Step.UnicodeSyntax -------------------------------------------------------------------------------- -import Data.List (isPrefixOf, - sort) -import Data.Map (Map) -import qualified Data.Map as M -import Data.Maybe (maybeToList) -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 @@ -80,7 +69,7 @@ between (startRow, startCol) (endRow, endCol) needle = search (r, c) (x : xs) | needle `isPrefixOf` x = Just (r, c) | otherwise = search (r, c + 1) (tail x : xs) - +-} -------------------------------------------------------------------------------- step :: Bool -> String -> Step @@ -89,9 +78,14 @@ step = (makeStep "UnicodeSyntax" .) . step' -------------------------------------------------------------------------------- step' :: Bool -> String -> Lines -> Module -> Lines +step' _alp _lg ls _module' = ls + +{- step' alp lg ls module' = applyChanges changes ls where changes = (if alp then addLanguagePragma lg "UnicodeSyntax" module' else []) ++ replaceAll perLine toReplace = [ "::", "=>", "->" ] perLine = sort $ groupPerLine $ concatMap (findSymbol module' ls) toReplace + +-} diff --git a/lib/Language/Haskell/Stylish/Util.hs b/lib/Language/Haskell/Stylish/Util.hs index 1d35a032..f2fc5def 100644 --- a/lib/Language/Haskell/Stylish/Util.hs +++ b/lib/Language/Haskell/Stylish/Util.hs @@ -5,7 +5,6 @@ module Language.Haskell.Stylish.Util ( indent , padRight , everything - , infoPoints , trimLeft , trimRight , wrap @@ -20,8 +19,6 @@ module Language.Haskell.Stylish.Util , withLast , flagEnds - , toRealSrcSpan - , traceOutputable , traceOutputableM @@ -40,12 +37,13 @@ import Data.Maybe (maybeToList) import Data.Typeable (cast) import Debug.Trace (trace) import qualified GHC.Hs as Hs -import qualified Outputable -import qualified SrcLoc as S +import qualified GHC.Types.SrcLoc as GHC +import qualified GHC.Utils.Outputable as GHC -------------------------------------------------------------------------------- import Language.Haskell.Stylish.Step +import Language.Haskell.Stylish.GHC (showOutputable) -------------------------------------------------------------------------------- @@ -69,6 +67,7 @@ everything = G.everything (++) (maybeToList . cast) -------------------------------------------------------------------------------- +{- infoPoints :: [S.Located pass] -> [((Int, Int), (Int, Int))] infoPoints = fmap (helper . S.getLoc) where @@ -79,7 +78,7 @@ infoPoints = fmap (helper . S.getLoc) end = S.realSrcSpanEnd s ((S.srcLocLine start, S.srcLocCol start), (S.srcLocLine end, S.srcLocCol end)) helper _ = ((-1,-1), (-1,-1)) - +-} -------------------------------------------------------------------------------- trimLeft :: String -> String @@ -213,35 +212,28 @@ flagEnds = \case -------------------------------------------------------------------------------- -traceOutputable :: Outputable.Outputable a => String -> a -> b -> b +traceOutputable :: GHC.Outputable a => String -> a -> b -> b traceOutputable title x = - trace (title ++ ": " ++ (Outputable.showSDocUnsafe $ Outputable.ppr x)) + trace (title ++ ": " ++ (showOutputable x)) -------------------------------------------------------------------------------- -traceOutputableM :: (Outputable.Outputable a, Monad m) => String -> a -> m () +traceOutputableM :: (GHC.Outputable a, Monad m) => String -> a -> m () traceOutputableM title x = traceOutputable 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 + | Hs.GRHS _ [] body <- GHC.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 + | Hs.GRHS _ _ body <- GHC.unLoc grhs = Just body rhsBody _ = Nothing @@ -251,17 +243,14 @@ 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 + grhs = map GHC.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 4d1f81d72d3255acf717afe8f8adc1b80db7b518 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Tue, 1 Feb 2022 16:20:36 +0100 Subject: [PATCH 03/32] Fix test compilation --- tests/Language/Haskell/Stylish/Tests/Util.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/tests/Language/Haskell/Stylish/Tests/Util.hs b/tests/Language/Haskell/Stylish/Tests/Util.hs index 53d2c712..ad214425 100644 --- a/tests/Language/Haskell/Stylish/Tests/Util.hs +++ b/tests/Language/Haskell/Stylish/Tests/Util.hs @@ -18,7 +18,7 @@ import Control.Exception (bracket, try) import Control.Monad.Writer (execWriter, tell) import Data.List (intercalate) import GHC.Exts (IsList (..)) -import GHC.Hs.Dump (showAstData, BlankSrcSpan(..)) +import GHC.Hs.Dump (showAstData, BlankSrcSpan(..), BlankEpAnnotations (..)) import Language.Haskell.Stylish.GHC (baseDynFlags) import System.Directory (createDirectory, getCurrentDirectory, @@ -30,12 +30,12 @@ import System.IO.Error (isAlreadyExistsError) import System.Random (randomIO) import Test.HUnit (Assertion, assertFailure, (@=?)) -import Outputable (showSDoc) import Data.Data (Data(..)) -------------------------------------------------------------------------------- import Language.Haskell.Stylish.Parse import Language.Haskell.Stylish.Step +import Language.Haskell.Stylish.GHC (showOutputable) import Language.Haskell.Stylish.Module (Module) -------------------------------------------------------------------------------- @@ -49,8 +49,8 @@ dumpAst :: Data a => (Module -> a) -> String -> String dumpAst extract str = let Right(theModule) = parseModule [] Nothing str ast = extract theModule - sdoc = showAstData BlankSrcSpan ast - in showSDoc baseDynFlags sdoc + sdoc = showAstData BlankSrcSpan BlankEpAnnotations ast + in showOutputable sdoc dumpModule :: String -> String dumpModule = dumpAst id From 923b94581b5a794e74d8777b3f2c8fd6051eb616 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Wed, 2 Feb 2022 13:39:33 +0100 Subject: [PATCH 04/32] Port Squash step to GHC-9.2 --- lib/Language/Haskell/Stylish/Step/Squash.hs | 54 ++++++++++----------- 1 file changed, 27 insertions(+), 27 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Step/Squash.hs b/lib/Language/Haskell/Stylish/Step/Squash.hs index 3bf972d0..bf4047f2 100644 --- a/lib/Language/Haskell/Stylish/Step/Squash.hs +++ b/lib/Language/Haskell/Stylish/Step/Squash.hs @@ -8,53 +8,53 @@ module Language.Haskell.Stylish.Step.Squash -------------------------------------------------------------------------------- +import Control.Monad (guard) +import Data.Maybe (mapMaybe) +import qualified GHC.Types.SrcLoc as GHC +import qualified GHC.Hs as GHC + + +-------------------------------------------------------------------------------- +import Language.Haskell.Stylish.Editor import Language.Haskell.Stylish.Step +import Language.Haskell.Stylish.Util -{- -------------------------------------------------------------------------------- -squash - :: (S.HasSrcSpan l, S.HasSrcSpan r) - => l -> r -> Maybe (Change String) +squash :: GHC.SrcSpan -> GHC.SrcSpan -> Maybe (Change String) squash left right = do - lAnn <- toRealSrcSpan $ GHC.getLoc left - rAnn <- toRealSrcSpan $ GHC.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 + l <- GHC.srcSpanToRealSrcSpan left + r <- GHC.srcSpanToRealSrcSpan right + guard $ + GHC.srcSpanEndLine l == GHC.srcSpanStartLine r || + GHC.srcSpanEndLine l + 1 == GHC.srcSpanStartLine r + pure $ changeLine (GHC.srcSpanEndLine l) $ \str -> + let (pre, post) = splitAt (GHC.srcSpanEndCol l) str + in [trimRight pre ++ " " ++ trimLeft post] -------------------------------------------------------------------------------- -squashFieldDecl :: Hs.ConDeclField Hs.GhcPs -> Maybe (Change String) -squashFieldDecl (Hs.ConDeclField _ names type' _) +squashFieldDecl :: GHC.ConDeclField GHC.GhcPs -> Maybe (Change String) +squashFieldDecl (GHC.ConDeclField _ names type' _) | null names = Nothing - | otherwise = squash (last names) type' -squashFieldDecl (Hs.XConDeclField x) = Hs.noExtCon x + | otherwise = squash (GHC.getLoc $ last names) (GHC.getLocA type') -------------------------------------------------------------------------------- -squashMatch :: Hs.Match Hs.GhcPs (Hs.LHsExpr Hs.GhcPs) -> Maybe (Change String) -squashMatch (Hs.Match _ (Hs.FunRhs name _ _) [] grhss) = do +squashMatch + :: GHC.Match GHC.GhcPs (GHC.LHsExpr GHC.GhcPs) -> Maybe (Change String) +squashMatch (GHC.Match _ (GHC.FunRhs name _ _) [] grhss) = do body <- unguardedRhsBody grhss - squash name body -squashMatch (Hs.Match _ _ pats grhss) = do + squash (GHC.getLocA name) (GHC.getLocA body) +squashMatch (GHC.Match _ _ pats grhss) = do body <- unguardedRhsBody grhss - squash (last pats) body -squashMatch (Hs.XMatch x) = Hs.noExtCon x + squash (GHC.getLocA $ last pats) (GHC.getLocA body) --} -------------------------------------------------------------------------------- step :: Step -step = makeStep "Squash" $ \ls _ -> ls -{- step = makeStep "Squash" $ \ls (module') -> let changes = mapMaybe squashFieldDecl (everything module') ++ mapMaybe squashMatch (everything module') in applyChanges changes ls --} From 68c33366884ee8808eeef5c00eac2a6740020ac5 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Wed, 2 Feb 2022 22:36:24 +0100 Subject: [PATCH 05/32] Support parsing language pragmas --- lib/Language/Haskell/Stylish/Module.hs | 31 ++++++++++-- lib/Language/Haskell/Stylish/Parse.hs | 11 +++-- .../Haskell/Stylish/Step/LanguagePragmas.hs | 49 +++++++++---------- .../Haskell/Stylish/Step/SimpleAlign.hs | 3 +- 4 files changed, 60 insertions(+), 34 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Module.hs b/lib/Language/Haskell/Stylish/Module.hs index 53fdd840..406b2dca 100644 --- a/lib/Language/Haskell/Stylish/Module.hs +++ b/lib/Language/Haskell/Stylish/Module.hs @@ -3,6 +3,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} module Language.Haskell.Stylish.Module ( -- * Data types @@ -20,15 +21,19 @@ module Language.Haskell.Stylish.Module -- * Imports , canMergeImport , mergeModuleImport + + -- * Pragmas + , moduleLanguagePragmas ) where + -------------------------------------------------------------------------------- +import Data.Char (toLower) import Data.Function (on, (&)) import Data.Generics (Typeable, everything, mkQ) -import Data.List (nubBy) +import qualified Data.List as L import Data.List.NonEmpty (NonEmpty (..)) - --------------------------------------------------------------------------------- +import Data.Maybe (mapMaybe) import GHC.Hs (ImportDecl (..), ImportDeclQualifiedStyle (..)) import qualified GHC.Hs as GHC @@ -39,9 +44,11 @@ import GHC.Types.SrcLoc (Located, unLoc) import qualified GHC.Types.SrcLoc as GHC import GHC.Utils.Outputable (Outputable) + -------------------------------------------------------------------------------- import Language.Haskell.Stylish.GHC + -------------------------------------------------------------------------------- type Lines = [String] @@ -121,8 +128,24 @@ mergeModuleImport (L p0 (Import i0)) (L _p1 (Import i1)) = (Just x, Nothing) -> Just x (Nothing, Just x) -> Just x merge xs ys - = nubBy ((==) `on` showOutputable) (xs ++ ys) + = L.nubBy ((==) `on` showOutputable) (xs ++ ys) -- | Query the module AST using @f@ queryModule :: Typeable a => (a -> [b]) -> Module -> [b] queryModule f = everything (++) (mkQ [] f) + +moduleLanguagePragmas :: Module -> [(RealSrcSpan, NonEmpty String)] +moduleLanguagePragmas = + mapMaybe prag . GHC.priorComments . GHC.comments . GHC.hsmodAnn . GHC.unLoc + where + prag :: GHC.LEpaComment -> Maybe (GHC.RealSrcSpan, NonEmpty String) + prag comment = case GHC.ac_tok (GHC.unLoc comment) of + GHC.EpaBlockComment str + | lang : p1 : ps <- tokenize str, map toLower lang == "language" -> + pure (GHC.anchor (GHC.getLoc comment), p1 :| ps) + _ -> Nothing + + tokenize = words . + map (\c -> if c == ',' then ' ' else c) . + takeWhile (/= '#') . + drop 1 . dropWhile (/= '#') diff --git a/lib/Language/Haskell/Stylish/Parse.hs b/lib/Language/Haskell/Stylish/Parse.hs index 2b68de70..e1a5f6d4 100644 --- a/lib/Language/Haskell/Stylish/Parse.hs +++ b/lib/Language/Haskell/Stylish/Parse.hs @@ -6,10 +6,12 @@ module Language.Haskell.Stylish.Parse -------------------------------------------------------------------------------- -import Data.Maybe (listToMaybe) +import Data.Maybe (fromMaybe, listToMaybe) -------------------------------------------------------------------------------- +import qualified GHC.Hs as GHC +import qualified GHC.Types.SrcLoc as GHC import GHC.Driver.Ppr as GHC import qualified GHC.Driver.Session as GHC import qualified GHC.LanguageExtensions.Type as LangExt @@ -18,8 +20,11 @@ import qualified GHC.Parser.Lexer as GHC import qualified GHC.Utils.Error as GHC import qualified GHC.Utils.Outputable as GHC import qualified Language.Haskell.GhclibParserEx.GHC.Parser as GHCEx -import Language.Haskell.Stylish.GHC (baseDynFlags) +import qualified Language.Haskell.GhclibParserEx.Fixity as GHCEx +import Language.Haskell.Stylish.GHC (baseDynFlags, showOutputable) import Language.Haskell.Stylish.Module +import Debug.Trace + type Extensions = [String] @@ -54,7 +59,7 @@ parseModule _exts fp string = GHC.getMessages ps where -- TODO: Add extensions again. - dynFlags = baseDynFlags + dynFlags = baseDynFlags `GHC.gopt_set` GHC.Opt_KeepRawTokenStream removeCpp s = if GHC.xopt LangExt.Cpp dynFlags then unCpp s else s diff --git a/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs b/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs index b9d00247..0f4b604b 100644 --- a/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs +++ b/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs @@ -13,12 +13,10 @@ 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 GHC.Hs as Hs +import qualified GHC.Hs as GHC import qualified GHC.Types.SrcLoc as GHC @@ -101,9 +99,9 @@ prettyPragmas lp _ _ _ VerticalCompact = verticalCompactPragmas lp -------------------------------------------------------------------------------- -- | Filter redundant (and duplicate) pragmas out of the groups. As a side -- effect, we also sort the pragmas in their group... -filterRedundant :: (Text -> Bool) - -> [(l, NonEmpty Text)] - -> [(l, [Text])] +filterRedundant :: (String -> Bool) + -> [(l, NonEmpty String)] + -> [(l, [String])] filterRedundant isRedundant' = snd . foldr filterRedundant' (S.empty, []) . fmap (fmap toList) where filterRedundant' (l, xs) (known, zs) @@ -129,7 +127,7 @@ step' columns style align removeRedundant lngPrefix ls m | removeRedundant = isRedundant m | otherwise = const False - languagePragmas = [] -- moduleLanguagePragmas m + languagePragmas = moduleLanguagePragmas m convertFstToBlock :: [(GHC.RealSrcSpan, a)] -> [(Block String, a)] convertFstToBlock = fmap \(rspan, a) -> @@ -141,35 +139,34 @@ step' columns style align removeRedundant lngPrefix ls m turnSndBackToNel (a, bss) = (a, fromList . concat $ bss) longest :: Int - longest = maximum $ map T.length $ toList . snd =<< languagePragmas + longest = maximum $ map length $ toList . snd =<< languagePragmas - groups :: [(Block String, NonEmpty Text)] + groups :: [(Block String, NonEmpty String)] groups = [(b, pgs) | (b, pgs) <- groupAdjacent' (convertFstToBlock languagePragmas)] changes = - [ change b (const $ prettyPragmas lngPrefix columns longest align style (fmap T.unpack pg)) + [ change b (const $ prettyPragmas lngPrefix columns longest align style pg) | (b, pg) <- filterRedundant isRedundant' groups ] -------------------------------------------------------------------------------- -- | Add a LANGUAGE pragma to a module if it is not present already. addLanguagePragma :: String -> String -> Module -> [Change String] -addLanguagePragma lg prag _modu +addLanguagePragma lg prag modu | prag `elem` present = [] | otherwise = [insert line ["{-# " ++ lg ++ " " ++ prag ++ " #-}"]] where - -- pragmas' = moduleLanguagePragmas modu - pragmas' = [] - present = concatMap ((fmap T.unpack) . toList . snd) pragmas' + pragmas' = moduleLanguagePragmas modu + present = concatMap (toList . snd) pragmas' line = if null pragmas' then 1 else firstLocation pragmas' - firstLocation :: [(GHC.RealSrcSpan, NonEmpty Text)] -> Int + firstLocation :: [(GHC.RealSrcSpan, NonEmpty String)] -> Int firstLocation = minimum . fmap (GHC.srcLocLine . GHC.realSrcSpanStart . fst) -------------------------------------------------------------------------------- -- | Check if a language pragma is redundant. We can't do this for all pragmas, -- but we do a best effort. -isRedundant :: Module -> Text -> Bool +isRedundant :: Module -> String -> Bool isRedundant m "ViewPatterns" = isRedundantViewPatterns m isRedundant m "BangPatterns" = isRedundantBangPatterns m isRedundant _ _ = False @@ -180,10 +177,10 @@ isRedundant _ _ = False isRedundantViewPatterns :: Module -> Bool isRedundantViewPatterns = null . queryModule getViewPat where - getViewPat :: Hs.Pat Hs.GhcPs -> [()] + getViewPat :: GHC.Pat GHC.GhcPs -> [()] getViewPat = \case - Hs.ViewPat{} -> [()] - _ -> [] + GHC.ViewPat{} -> [()] + _ -> [] -------------------------------------------------------------------------------- @@ -193,12 +190,12 @@ isRedundantBangPatterns modul = (null $ queryModule getBangPat modul) && (null $ queryModule getMatchStrict modul) where - getBangPat :: Hs.Pat Hs.GhcPs -> [()] + getBangPat :: GHC.Pat GHC.GhcPs -> [()] getBangPat = \case - Hs.BangPat{} -> [()] - _ -> [] + GHC.BangPat{} -> [()] + _ -> [] - getMatchStrict :: Hs.Match Hs.GhcPs (Hs.LHsExpr Hs.GhcPs) -> [()] - getMatchStrict (Hs.Match _ ctx _ _) = case ctx of - Hs.FunRhs _ _ Hs.SrcStrict -> [()] - _ -> [] + getMatchStrict :: GHC.Match GHC.GhcPs (GHC.LHsExpr GHC.GhcPs) -> [()] + getMatchStrict (GHC.Match _ ctx _ _) = case ctx of + GHC.FunRhs _ _ GHC.SrcStrict -> [()] + _ -> [] diff --git a/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs b/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs index 4a594dbc..e1476325 100644 --- a/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs +++ b/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs @@ -193,7 +193,8 @@ step maxColumns config = makeStep "Cases" $ \ls module' -> -> (a -> [[Alignable GHC.RealSrcSpan]]) -> [Change String] changes search toAlign = - (concatMap . concatMap) (align maxColumns) . map toAlign $ search module' + (concatMap . concatMap) (align maxColumns) . map toAlign $ + search module' configured :: [Change String] configured = concat $ From 4fecb41cc2d53a9f26231299712f79eba0f2092d Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Thu, 3 Feb 2022 09:22:37 +0100 Subject: [PATCH 06/32] WIP --- lib/Language/Haskell/Stylish/Parse.hs | 37 ++++++++++++++++++++------- 1 file changed, 28 insertions(+), 9 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Parse.hs b/lib/Language/Haskell/Stylish/Parse.hs index e1a5f6d4..ad8d215c 100644 --- a/lib/Language/Haskell/Stylish/Parse.hs +++ b/lib/Language/Haskell/Stylish/Parse.hs @@ -6,21 +6,26 @@ module Language.Haskell.Stylish.Parse -------------------------------------------------------------------------------- -import Data.Maybe (fromMaybe, listToMaybe) - - --------------------------------------------------------------------------------- -import qualified GHC.Hs as GHC -import qualified GHC.Types.SrcLoc as GHC +import Data.Maybe (fromMaybe, listToMaybe, mapMaybe) +import Data.List (stripPrefix) +import Control.Monad ((>=>)) +import qualified GHC.Data.StringBuffer as GHC +import qualified GHC.Hs as GHC +import qualified GHC.Types.SrcLoc as GHC +import qualified GHC.Driver.Config as GHC import GHC.Driver.Ppr as GHC import qualified GHC.Driver.Session as GHC import qualified GHC.LanguageExtensions.Type as LangExt import qualified GHC.Parser.Errors.Ppr as GHC import qualified GHC.Parser.Lexer as GHC +import qualified GHC.Parser.Header as GHC import qualified GHC.Utils.Error as GHC import qualified GHC.Utils.Outputable as GHC import qualified Language.Haskell.GhclibParserEx.GHC.Parser as GHCEx -import qualified Language.Haskell.GhclibParserEx.Fixity as GHCEx +import qualified Language.Haskell.GhclibParserEx.GHC.Driver.Session as GHCEx + + +-------------------------------------------------------------------------------- import Language.Haskell.Stylish.GHC (baseDynFlags, showOutputable) import Language.Haskell.Stylish.Module import Debug.Trace @@ -28,6 +33,7 @@ import Debug.Trace type Extensions = [String] + -------------------------------------------------------------------------------- -- | Filter out lines which use CPP macros unCpp :: String -> String @@ -39,6 +45,7 @@ unCpp = unlines . go False . lines nextMultiline = isCpp && not (null x) && last x == '\\' in (if isCpp then "" else x) : go nextMultiline xs + -------------------------------------------------------------------------------- -- | If the given string is prefixed with an UTF-8 Byte Order Mark, drop it -- because haskell-src-exts can't handle it. @@ -50,8 +57,9 @@ dropBom str = str -------------------------------------------------------------------------------- -- | Abstraction over GHC lib's parsing parseModule :: Extensions -> Maybe FilePath -> String -> Either String Module -parseModule _exts fp string = +parseModule externalExts fp string = let input = removeCpp $ dropBom string in + (trace ("options: " ++ show (mapMaybe (optionToPragma . GHC.unLoc) parseOptions))) $ case GHCEx.parseModule input dynFlags of GHC.POk _ m -> Right m GHC.PFailed ps -> Left . withFileName . GHC.showSDoc dynFlags . GHC.vcat . @@ -59,8 +67,19 @@ parseModule _exts fp string = GHC.getMessages ps where -- TODO: Add extensions again. - dynFlags = baseDynFlags `GHC.gopt_set` GHC.Opt_KeepRawTokenStream + dynFlags0 = foldl' + (\flags extStr -> case GHCEx.readExtension extStr of + Nothing -> flags) + baseDynFlags + externalExts + `GHC.gopt_set` GHC.Opt_KeepRawTokenStream + + parseOptions = GHC.getOptions dynFlags0 + (GHC.stringToStringBuffer string) + (fromMaybe "-" fp) removeCpp s = if GHC.xopt LangExt.Cpp dynFlags then unCpp s else s withFileName x = maybe "" (<> ": ") fp <> x + + optionToPragma = stripPrefix "-X" >=> GHCEx.readExtension From c67858030e9cf6146a9d20c753ba0a395114402a Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Thu, 3 Feb 2022 14:42:42 +0100 Subject: [PATCH 07/32] Grab language pragmas and dynflag them --- lib/Language/Haskell/Stylish/Parse.hs | 93 ++++++++++++++------------- 1 file changed, 50 insertions(+), 43 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Parse.hs b/lib/Language/Haskell/Stylish/Parse.hs index ad8d215c..9b66bf9b 100644 --- a/lib/Language/Haskell/Stylish/Parse.hs +++ b/lib/Language/Haskell/Stylish/Parse.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE LambdaCase #-} -------------------------------------------------------------------------------- module Language.Haskell.Stylish.Parse ( parseModule @@ -6,29 +5,30 @@ module Language.Haskell.Stylish.Parse -------------------------------------------------------------------------------- -import Data.Maybe (fromMaybe, listToMaybe, mapMaybe) -import Data.List (stripPrefix) -import Control.Monad ((>=>)) -import qualified GHC.Data.StringBuffer as GHC -import qualified GHC.Hs as GHC -import qualified GHC.Types.SrcLoc as GHC -import qualified GHC.Driver.Config as GHC -import GHC.Driver.Ppr as GHC -import qualified GHC.Driver.Session as GHC -import qualified GHC.LanguageExtensions.Type as LangExt -import qualified GHC.Parser.Errors.Ppr as GHC -import qualified GHC.Parser.Lexer as GHC -import qualified GHC.Parser.Header as GHC -import qualified GHC.Utils.Error as GHC -import qualified GHC.Utils.Outputable as GHC -import qualified Language.Haskell.GhclibParserEx.GHC.Parser as GHCEx +import Control.Monad ((>=>)) +import Data.List (foldl', + stripPrefix) +import Data.Maybe (fromMaybe, + listToMaybe, + mapMaybe) +import Data.Traversable (for) +import qualified GHC.Data.StringBuffer as GHC +import GHC.Driver.Ppr as GHC +import qualified GHC.Driver.Session as GHC +import qualified GHC.LanguageExtensions.Type as LangExt +import qualified GHC.Parser.Errors.Ppr as GHC +import qualified GHC.Parser.Header as GHC +import qualified GHC.Parser.Lexer as GHC +import qualified GHC.Types.SrcLoc as GHC +import qualified GHC.Utils.Error as GHC +import qualified GHC.Utils.Outputable as GHC import qualified Language.Haskell.GhclibParserEx.GHC.Driver.Session as GHCEx +import qualified Language.Haskell.GhclibParserEx.GHC.Parser as GHCEx -------------------------------------------------------------------------------- -import Language.Haskell.Stylish.GHC (baseDynFlags, showOutputable) +import Language.Haskell.Stylish.GHC (baseDynFlags) import Language.Haskell.Stylish.Module -import Debug.Trace type Extensions = [String] @@ -57,29 +57,36 @@ dropBom str = str -------------------------------------------------------------------------------- -- | Abstraction over GHC lib's parsing parseModule :: Extensions -> Maybe FilePath -> String -> Either String Module -parseModule externalExts fp string = - let input = removeCpp $ dropBom string in - (trace ("options: " ++ show (mapMaybe (optionToPragma . GHC.unLoc) parseOptions))) $ - case GHCEx.parseModule input dynFlags of - GHC.POk _ m -> Right m - GHC.PFailed ps -> Left . withFileName . GHC.showSDoc dynFlags . GHC.vcat . - GHC.pprMsgEnvelopeBagWithLoc . fmap GHC.pprError . snd $ - GHC.getMessages ps +parseModule externalExts0 fp string = do + -- Parse extensions. + externalExts1 <- for externalExts0 $ \s -> case GHCEx.readExtension s of + Nothing -> Left $ "Unknown extension: " ++ show s + Just e -> Right e + + -- Build first dynflags. + let dynFlags0 = foldl' GHC.xopt_set baseDynFlags externalExts1 + + -- Parse options from file + let fileOptions = fmap GHC.unLoc $ GHC.getOptions dynFlags0 + (GHC.stringToStringBuffer string) + (fromMaybe "-" fp) + fileExtensions = mapMaybe + (stripPrefix "-X" >=> GHCEx.readExtension) + fileOptions + + -- Set further dynflags. + let dynFlags1 = foldl' GHC.xopt_set dynFlags0 fileExtensions + `GHC.gopt_set` GHC.Opt_KeepRawTokenStream + + -- Possibly strip CPP. + let removeCpp s = if GHC.xopt LangExt.Cpp dynFlags1 then unCpp s else s + input = removeCpp $ dropBom string + + -- Actual parse. + case GHCEx.parseModule input dynFlags1 of + GHC.POk _ m -> Right m + GHC.PFailed ps -> Left . withFileName . GHC.showSDoc dynFlags1 . + GHC.vcat . GHC.pprMsgEnvelopeBagWithLoc . fmap GHC.pprError . snd $ + GHC.getMessages ps where - -- TODO: Add extensions again. - dynFlags0 = foldl' - (\flags extStr -> case GHCEx.readExtension extStr of - Nothing -> flags) - baseDynFlags - externalExts - `GHC.gopt_set` GHC.Opt_KeepRawTokenStream - - parseOptions = GHC.getOptions dynFlags0 - (GHC.stringToStringBuffer string) - (fromMaybe "-" fp) - - removeCpp s = if GHC.xopt LangExt.Cpp dynFlags then unCpp s else s - withFileName x = maybe "" (<> ": ") fp <> x - - optionToPragma = stripPrefix "-X" >=> GHCEx.readExtension From c38c2cad4328a7a5ef866697960dcac34387a301 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Thu, 3 Feb 2022 19:45:20 +0100 Subject: [PATCH 08/32] Prototype: Find -> --- .../Haskell/Stylish/Step/UnicodeSyntax.hs | 21 ++++++++++++++++++- 1 file changed, 20 insertions(+), 1 deletion(-) diff --git a/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs b/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs index e415b3c4..0b943bc2 100644 --- a/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs +++ b/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs @@ -4,9 +4,17 @@ module Language.Haskell.Stylish.Step.UnicodeSyntax ) where +-------------------------------------------------------------------------------- +import Debug.Trace +import qualified GHC.Hs as GHC +import qualified GHC.Parser.Annotation as GHC +import qualified GHC.Types.SrcLoc as GHC + + -------------------------------------------------------------------------------- import Language.Haskell.Stylish.Module import Language.Haskell.Stylish.Step +import Language.Haskell.Stylish.Util (everything) {- @@ -71,6 +79,15 @@ between (startRow, startCol) (endRow, endCol) needle = | otherwise = search (r, c + 1) (tail x : xs) -} + +-------------------------------------------------------------------------------- +funTyChanges :: GHC.HsType GHC.GhcPs -> [GHC.RealSrcSpan] +funTyChanges (GHC.HsFunTy xann arr _ _) + | GHC.HsUnrestrictedArrow GHC.NormalSyntax <- arr + , GHC.AddRarrowAnn (GHC.EpaSpan loc) <- GHC.anns xann = [loc] +funTyChanges _ = [] + + -------------------------------------------------------------------------------- step :: Bool -> String -> Step step = (makeStep "UnicodeSyntax" .) . step' @@ -78,7 +95,9 @@ step = (makeStep "UnicodeSyntax" .) . step' -------------------------------------------------------------------------------- step' :: Bool -> String -> Lines -> Module -> Lines -step' _alp _lg ls _module' = ls +step' _alp _lg ls modu = + trace ("funs at: " ++ show (concatMap funTyChanges $ everything modu)) $ + ls {- step' alp lg ls module' = applyChanges changes ls From 518897502797ca0808a3d19a79e1ef144610d442 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Fri, 4 Feb 2022 09:22:26 +0100 Subject: [PATCH 09/32] WIP --- .../Haskell/Stylish/Step/UnicodeSyntax.hs | 106 ++++++++++-------- 1 file changed, 60 insertions(+), 46 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs b/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs index 0b943bc2..24292e6c 100644 --- a/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs +++ b/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs @@ -5,6 +5,8 @@ module Language.Haskell.Stylish.Step.UnicodeSyntax -------------------------------------------------------------------------------- +import qualified Data.Map as M +import Data.Maybe (mapMaybe) import Debug.Trace import qualified GHC.Hs as GHC import qualified GHC.Parser.Annotation as GHC @@ -12,6 +14,7 @@ import qualified GHC.Types.SrcLoc as GHC -------------------------------------------------------------------------------- +import Language.Haskell.Stylish.GHC (showOutputable) import Language.Haskell.Stylish.Module import Language.Haskell.Stylish.Step import Language.Haskell.Stylish.Util (everything) @@ -29,63 +32,70 @@ unicodeReplacements = M.fromList , ("-<", "↢") , (">-", "↣") ] +-} + +-------------------------------------------------------------------------------- +-- Simple type that can do replacments on single lines (not spanning, removing +-- or adding lines). +newtype Replacement = Replacement + { unReplacement :: M.Map Int [(Int, Int, String)] + } deriving (Show) -------------------------------------------------------------------------------- -replaceAll :: [(Int, [(Int, String)])] -> [Change String] -replaceAll = map changeLine' - where - changeLine' (r, ns) = changeLine r $ \str -> return $ - applyChanges - [ change (Block c ec) (const repl) - | (c, needle) <- sort ns - , let ec = c + length needle - 1 - , repl <- maybeToList $ M.lookup needle unicodeReplacements - ] str +instance Semigroup Replacement where + Replacement l <> Replacement r = Replacement $ M.unionWith (++) l r -------------------------------------------------------------------------------- -groupPerLine :: [((Int, Int), a)] -> [(Int, [(Int, a)])] -groupPerLine = M.toList . M.fromListWith (++) . - map (\((r, c), x) -> (r, [(c, x)])) - --- | Find symbol positions in the module. Currently only searches in type --- signatures. -findSymbol :: Module -> Lines -> String -> [((Int, Int), String)] -findSymbol module' ls sym = - [ (pos, sym) - | TypeSig _ funLoc typeLoc <- everything (rawModuleDecls $ moduleDecls module') :: [Sig GhcPs] - , (funStart, _) <- infoPoints funLoc - , (_, typeEnd) <- infoPoints [hsSigWcType typeLoc] - , pos <- maybeToList $ between funStart typeEnd sym ls - ] +instance Monoid Replacement where + mempty = Replacement mempty + -------------------------------------------------------------------------------- --- | Search for a needle in a haystack of lines. Only part the inside (startRow, --- startCol), (endRow, endCol) is searched. The return value is the position of --- the needle. -between :: (Int, Int) -> (Int, Int) -> String -> Lines -> Maybe (Int, Int) -between (startRow, startCol) (endRow, endCol) needle = - search (startRow, startCol) . - withLast (take endCol) . - withHead (drop $ startCol - 1) . - take (endRow - startRow + 1) . - drop (startRow - 1) +mkReplacement :: GHC.RealSrcSpan -> String -> Replacement +mkReplacement rss repl + | GHC.srcSpanStartLine rss /= GHC.srcSpanEndLine rss = Replacement mempty + | otherwise = Replacement $ + M.singleton + (GHC.srcSpanStartLine rss) + [(GHC.srcSpanStartCol rss, GHC.srcSpanEndCol rss, repl)] + + +-------------------------------------------------------------------------------- +applyReplacement :: Replacement -> [String] -> [String] +applyReplacement (Replacement repl) ls = do + (i, l) <- zip [1 ..] ls + case M.lookup i repl of + Nothing -> pure l + Just repls -> pure $ go repls l where - search _ [] = Nothing - search (r, _) ([] : xs) = search (r + 1, 1) xs - search (r, c) (x : xs) - | needle `isPrefixOf` x = Just (r, c) - | otherwise = search (r, c + 1) (tail x : xs) --} + go [] l = l + go ((xstart, xend, x) : repls) l = + let l' = take (xstart - 1) l ++ x ++ drop (xend - 1) l in + go (mapMaybe (adjust (xstart, xend, x)) repls) l' + + adjust (xstart, xend, x) (ystart, yend, y) + | yend < xstart = Just (ystart, yend, y) + | ystart > xend = + let offset = length x - (xend - xstart + 1) in + Just (ystart + offset, yend + offset, y) + | otherwise = Nothing -------------------------------------------------------------------------------- -funTyChanges :: GHC.HsType GHC.GhcPs -> [GHC.RealSrcSpan] -funTyChanges (GHC.HsFunTy xann arr _ _) +hsTyReplacements :: GHC.HsType GHC.GhcPs -> Replacement +hsTyReplacements (GHC.HsFunTy xann arr _ _) | GHC.HsUnrestrictedArrow GHC.NormalSyntax <- arr - , GHC.AddRarrowAnn (GHC.EpaSpan loc) <- GHC.anns xann = [loc] -funTyChanges _ = [] + , GHC.AddRarrowAnn (GHC.EpaSpan loc) <- GHC.anns xann = + mkReplacement loc "→" +hsTyReplacements _ = mempty + + +-------------------------------------------------------------------------------- +hsSigReplacements :: GHC.LHsSigType GHC.GhcPs -> Replacement +hsSigReplacements (GHC.L l (GHC.HsSig xann _ _)) = + trace (showOutputable l) $ mempty -------------------------------------------------------------------------------- @@ -96,8 +106,12 @@ step = (makeStep "UnicodeSyntax" .) . step' -------------------------------------------------------------------------------- step' :: Bool -> String -> Lines -> Module -> Lines step' _alp _lg ls modu = - trace ("funs at: " ++ show (concatMap funTyChanges $ everything modu)) $ - ls + traceShow replacement $ + applyReplacement replacement ls + where + replacement = + foldMap hsTyReplacements (everything modu) <> + foldMap hsSigReplacements (everything modu) {- step' alp lg ls module' = applyChanges changes ls From b072627ff562cac1796967cf0a3a09ca7a9066e7 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Fri, 4 Feb 2022 15:14:20 +0100 Subject: [PATCH 10/32] Extract :: in UnicodeSyntax --- lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs b/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs index 24292e6c..47a56e0b 100644 --- a/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs +++ b/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs @@ -9,12 +9,10 @@ import qualified Data.Map as M import Data.Maybe (mapMaybe) import Debug.Trace import qualified GHC.Hs as GHC -import qualified GHC.Parser.Annotation as GHC import qualified GHC.Types.SrcLoc as GHC -------------------------------------------------------------------------------- -import Language.Haskell.Stylish.GHC (showOutputable) import Language.Haskell.Stylish.Module import Language.Haskell.Stylish.Step import Language.Haskell.Stylish.Util (everything) @@ -93,9 +91,12 @@ hsTyReplacements _ = mempty -------------------------------------------------------------------------------- -hsSigReplacements :: GHC.LHsSigType GHC.GhcPs -> Replacement -hsSigReplacements (GHC.L l (GHC.HsSig xann _ _)) = - trace (showOutputable l) $ mempty +hsSigReplacements :: GHC.Sig GHC.GhcPs -> Replacement +hsSigReplacements (GHC.TypeSig ann _ _) + | GHC.AddEpAnn GHC.AnnDcolon epaLoc <- GHC.asDcolon $ GHC.anns ann + , GHC.EpaSpan loc <- epaLoc = + mkReplacement loc "∷" +hsSigReplacements _ = mempty -------------------------------------------------------------------------------- From 9354f254e24661028c3d373bb8c96d793b5757b4 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Fri, 4 Feb 2022 17:11:33 +0100 Subject: [PATCH 11/32] =?UTF-8?q?UnicodeSyntax:=20support=20=E2=87=92?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs b/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs index 47a56e0b..1e280af3 100644 --- a/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs +++ b/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs @@ -87,6 +87,10 @@ hsTyReplacements (GHC.HsFunTy xann arr _ _) | GHC.HsUnrestrictedArrow GHC.NormalSyntax <- arr , GHC.AddRarrowAnn (GHC.EpaSpan loc) <- GHC.anns xann = mkReplacement loc "→" +hsTyReplacements (GHC.HsQualTy _ (Just ctx) _) + | Just arrow <- GHC.ac_darrow . GHC.anns . GHC.ann $ GHC.getLoc ctx + , (GHC.NormalSyntax, GHC.EpaSpan loc) <- arrow = + mkReplacement loc "⇒" hsTyReplacements _ = mempty From 971362c8d4f8881cb6d61fbe4d1f61c55df31586 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Fri, 4 Feb 2022 18:23:21 +0100 Subject: [PATCH 12/32] UnicodeSyntax seems to work now --- .../Haskell/Stylish/Step/LanguagePragmas.hs | 1 + .../Haskell/Stylish/Step/UnicodeSyntax.hs | 30 +++++++------------ 2 files changed, 11 insertions(+), 20 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs b/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs index 0f4b604b..39013ce9 100644 --- a/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs +++ b/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs @@ -149,6 +149,7 @@ step' columns style align removeRedundant lngPrefix ls m | (b, pg) <- filterRedundant isRedundant' groups ] + -------------------------------------------------------------------------------- -- | Add a LANGUAGE pragma to a module if it is not present already. addLanguagePragma :: String -> String -> Module -> [Change String] diff --git a/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs b/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs index 1e280af3..751d2b27 100644 --- a/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs +++ b/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs @@ -6,16 +6,16 @@ module Language.Haskell.Stylish.Step.UnicodeSyntax -------------------------------------------------------------------------------- import qualified Data.Map as M -import Data.Maybe (mapMaybe) -import Debug.Trace import qualified GHC.Hs as GHC import qualified GHC.Types.SrcLoc as GHC -------------------------------------------------------------------------------- +import Language.Haskell.Stylish.Editor import Language.Haskell.Stylish.Module import Language.Haskell.Stylish.Step -import Language.Haskell.Stylish.Util (everything) +import Language.Haskell.Stylish.Step.LanguagePragmas (addLanguagePragma) +import Language.Haskell.Stylish.Util (everything) {- @@ -71,14 +71,13 @@ applyReplacement (Replacement repl) ls = do go [] l = l go ((xstart, xend, x) : repls) l = let l' = take (xstart - 1) l ++ x ++ drop (xend - 1) l in - go (mapMaybe (adjust (xstart, xend, x)) repls) l' + go (adjust (xstart, xend, x) <$> repls) l' adjust (xstart, xend, x) (ystart, yend, y) - | yend < xstart = Just (ystart, yend, y) | ystart > xend = - let offset = length x - (xend - xstart + 1) in - Just (ystart + offset, yend + offset, y) - | otherwise = Nothing + let offset = length x - (xend - xstart) in + (ystart + offset, yend + offset, y) + | otherwise = (ystart, yend, y) -------------------------------------------------------------------------------- @@ -110,20 +109,11 @@ step = (makeStep "UnicodeSyntax" .) . step' -------------------------------------------------------------------------------- step' :: Bool -> String -> Lines -> Module -> Lines -step' _alp _lg ls modu = - traceShow replacement $ +step' alp lg ls modu = + applyChanges + (if alp then addLanguagePragma lg "UnicodeSyntax" modu else []) $ applyReplacement replacement ls where replacement = foldMap hsTyReplacements (everything modu) <> foldMap hsSigReplacements (everything modu) - -{- -step' alp lg ls module' = applyChanges changes ls - where - changes = (if alp then addLanguagePragma lg "UnicodeSyntax" module' else []) ++ - replaceAll perLine - toReplace = [ "::", "=>", "->" ] - perLine = sort $ groupPerLine $ concatMap (findSymbol module' ls) toReplace - --} From d024d9b59032de964e53c544db4f6db749ae8baa Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Mon, 7 Feb 2022 20:47:10 +0100 Subject: [PATCH 13/32] Work on Imports step and dependencies --- lib/Language/Haskell/Stylish/GHC.hs | 1 - lib/Language/Haskell/Stylish/Module.hs | 36 ++--- lib/Language/Haskell/Stylish/Ordering.hs | 8 +- lib/Language/Haskell/Stylish/Step/Imports.hs | 125 ++++++++---------- .../Stylish/Step/UnicodeSyntax/Tests.hs | 2 +- tests/Language/Haskell/Stylish/Tests/Util.hs | 1 - 6 files changed, 78 insertions(+), 95 deletions(-) diff --git a/lib/Language/Haskell/Stylish/GHC.hs b/lib/Language/Haskell/Stylish/GHC.hs index 6d4f2144..db9234c9 100644 --- a/lib/Language/Haskell/Stylish/GHC.hs +++ b/lib/Language/Haskell/Stylish/GHC.hs @@ -29,7 +29,6 @@ import GHC.Types.SrcLoc (GenLocated srcSpanStartLine) import qualified GHC.Utils.Outputable as GHC import qualified Language.Haskell.GhclibParserEx.GHC.Settings.Config as GHCEx -import qualified GHC.Parser.Annotation as GHC unsafeGetRealSrcSpan :: Located a -> RealSrcSpan unsafeGetRealSrcSpan = \case diff --git a/lib/Language/Haskell/Stylish/Module.hs b/lib/Language/Haskell/Stylish/Module.hs index 406b2dca..a53f0a64 100644 --- a/lib/Language/Haskell/Stylish/Module.hs +++ b/lib/Language/Haskell/Stylish/Module.hs @@ -8,12 +8,10 @@ module Language.Haskell.Stylish.Module ( -- * Data types Module - , Import (..) , Comments (..) , Lines -- * Getters - , moduleImports , moduleImportGroups , queryModule , groupByLine @@ -21,6 +19,7 @@ module Language.Haskell.Stylish.Module -- * Imports , canMergeImport , mergeModuleImport + , importModuleName -- * Pragmas , moduleLanguagePragmas @@ -33,7 +32,7 @@ import Data.Function (on, (&)) import Data.Generics (Typeable, everything, mkQ) import qualified Data.List as L import Data.List.NonEmpty (NonEmpty (..)) -import Data.Maybe (mapMaybe) +import Data.Maybe (fromMaybe, mapMaybe) import GHC.Hs (ImportDecl (..), ImportDeclQualifiedStyle (..)) import qualified GHC.Hs as GHC @@ -43,6 +42,7 @@ import GHC.Types.SrcLoc (RealSrcSpan (..)) import GHC.Types.SrcLoc (Located, unLoc) import qualified GHC.Types.SrcLoc as GHC import GHC.Utils.Outputable (Outputable) +import qualified GHC.Unit.Module.Name as GHC -------------------------------------------------------------------------------- @@ -57,13 +57,12 @@ type Lines = [String] -- | Concrete module type type Module = GHC.Located GHC.HsModule --- | Import declaration in module -newtype Import = Import { unImport :: ImportDecl GhcPs } - deriving newtype (Outputable) +importModuleName :: ImportDecl GhcPs -> String +importModuleName = GHC.moduleNameString . GHC.unLoc . GHC.ideclName -- | 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) +canMergeImport :: ImportDecl GhcPs -> ImportDecl GhcPs -> Bool +canMergeImport i0 i1 = and $ fmap (\f -> f i0 i1) [ (==) `on` unLoc . ideclName , (==) `on` ideclPkgQual , (==) `on` ideclSource @@ -80,14 +79,13 @@ canMergeImport (Import i0) (Import i1) = and $ fmap (\f -> f i0 i1) -- | Comments associated with module newtype Comments = Comments [GHC.RealLocated GHC.EpaComment] --- | Get module imports -moduleImports :: Module -> [Located Import] -moduleImports (L _ m) = - GHC.hsmodImports m & fmap \(L pos i) -> L (GHC.locA pos) (Import i) - -- | Get groups of imports from module -moduleImportGroups :: Module -> [NonEmpty (Located Import)] -moduleImportGroups = groupByLine unsafeGetRealSrcSpan . moduleImports +moduleImportGroups :: Module -> [NonEmpty (GHC.LImportDecl GHC.GhcPs)] +moduleImportGroups = + groupByLine (fromMaybe err . GHC.srcSpanToRealSrcSpan . GHC.getLocA) . + GHC.hsmodImports . GHC.unLoc + where + err = error "moduleImportGroups: import without soure span" -- The same logic as 'Language.Haskell.Stylish.Module.moduleImportGroups'. groupByLine :: (a -> RealSrcSpan) -> [a] -> [NonEmpty a] @@ -117,9 +115,11 @@ groupByLine f = go [] Nothing -- 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 } +mergeModuleImport + :: GHC.LImportDecl GHC.GhcPs -> GHC.LImportDecl GHC.GhcPs + -> GHC.LImportDecl GHC.GhcPs +mergeModuleImport (L p0 i0) (L _p1 i1) = + L p0 $ i0 { ideclHiding = newImportNames } where newImportNames = case (ideclHiding i0, ideclHiding i1) of diff --git a/lib/Language/Haskell/Stylish/Ordering.hs b/lib/Language/Haskell/Stylish/Ordering.hs index 16228072..3f1e4486 100644 --- a/lib/Language/Haskell/Stylish/Ordering.hs +++ b/lib/Language/Haskell/Stylish/Ordering.hs @@ -16,20 +16,20 @@ import Data.Char (isUpper, toLower) import Data.Function (on) import Data.Ord (comparing) import GHC.Hs +import qualified GHC.Hs as GHC import GHC.Types.Name.Reader (RdrName) import GHC.Types.SrcLoc (unLoc) import GHC.Utils.Outputable (Outputable) import qualified GHC.Utils.Outputable as GHC import Language.Haskell.Stylish.GHC (showOutputable) -import Language.Haskell.Stylish.Module (Import (..)) - -------------------------------------------------------------------------------- -- | Compare imports for sorting. Cannot easily be a lawful instance due to -- case insensitivity. -compareImports :: Import -> Import -> Ordering -compareImports (Import i0) (Import i1) = +compareImports + :: GHC.ImportDecl GHC.GhcPs -> GHC.ImportDecl GHC.GhcPs -> Ordering +compareImports i0 i1 = ideclName i0 `compareOutputableCI` ideclName i1 <> fmap showOutputable (ideclPkgQual i0) `compare` fmap showOutputable (ideclPkgQual i1) <> diff --git a/lib/Language/Haskell/Stylish/Step/Imports.hs b/lib/Language/Haskell/Stylish/Step/Imports.hs index 55498c15..86136b2b 100644 --- a/lib/Language/Haskell/Stylish/Step/Imports.hs +++ b/lib/Language/Haskell/Stylish/Step/Imports.hs @@ -17,35 +17,40 @@ module Language.Haskell.Stylish.Step.Imports -------------------------------------------------------------------------------- import Control.Monad (forM_, when, void) +import Data.Foldable (toList) import Data.Function ((&), on) import Data.Functor (($>)) -import Data.Foldable (toList) -import Data.Maybe (isJust) -import Data.List (sortBy) import Data.List.NonEmpty (NonEmpty(..)) +import Data.List (sortBy) +import Data.Maybe (isJust) import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Map as Map import qualified Data.Set as Set - - +import qualified GHC.Data.FastString as GHC +import qualified GHC.Hs as GHC +import qualified GHC.Types.Name.Reader as GHC +import qualified GHC.Types.SourceText as GHC +import qualified GHC.Types.SrcLoc as GHC +import qualified GHC.Unit.Types as GHC -------------------------------------------------------------------------------- import Language.Haskell.Stylish.Module import Language.Haskell.Stylish.Step +import Language.Haskell.Stylish.Ordering -------------------------------------------------------------------------------- data Options = Options - { importAlign :: ImportAlign - , listAlign :: ListAlign - , padModuleNames :: Bool - , longListAlign :: LongListAlign - , emptyListAlign :: EmptyListAlign - , listPadding :: ListPadding - , separateLists :: Bool - , spaceSurround :: Bool - , postQualified :: Bool + { importAlign :: ImportAlign + , listAlign :: ListAlign + , padModuleNames :: Bool + , longListAlign :: LongListAlign + , emptyListAlign :: EmptyListAlign + , listPadding :: ListPadding + , separateLists :: Bool + , spaceSurround :: Bool + , postQualified :: Bool } deriving (Eq, Show) defaultOptions :: Options @@ -353,12 +358,7 @@ mergeImports (h :| (t : ts)) | otherwise = x : mergeImportsTail (y : ys) mergeImportsTail xs = xs -moduleName :: Import -> String -moduleName - = moduleNameString - . unLocated - . ideclName - . rawImport +-} -------------------------------------------------------------------------------- @@ -381,49 +381,34 @@ instance Monoid ImportStats where mappend = (<>) mempty = ImportStats 0 False False False -importStats :: Import -> ImportStats +importStats :: GHC.ImportDecl GHC.GhcPs -> ImportStats importStats i = - ImportStats (importModuleNameLength i) (isSource i) (isQualified i) (isSafe i) + ImportStats (importModuleNameLength i) (isSource i) (isQualified i) (GHC.ideclSafe i) -- Computes length till module name, includes package name. -- TODO: this should reuse code with the printer -importModuleNameLength :: Import -> Int +importModuleNameLength :: GHC.ImportDecl GHC.GhcPs -> Int importModuleNameLength imp = - (case ideclPkgQual (rawImport imp) of + (case GHC.ideclPkgQual imp of Nothing -> 0 Just sl -> 1 + length (stringLiteral sl)) + - (length $ moduleName imp) + (length $ importModuleName imp) -------------------------------------------------------------------------------- -stringLiteral :: StringLiteral -> String -stringLiteral sl = case sl_st sl of - NoSourceText -> FS.unpackFS $ sl_fs sl - SourceText s -> s +stringLiteral :: GHC.StringLiteral -> String +stringLiteral = GHC.unpackFS . GHC.sl_fs -------------------------------------------------------------------------------- -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 +isQualified :: GHC.ImportDecl GHC.GhcPs -> Bool +isQualified = (/=) GHC.NotQualified . GHC.ideclQualified + +isHiding :: GHC.ImportDecl GHC.GhcPs -> Bool +isHiding = maybe False fst . GHC.ideclHiding + +isSource :: GHC.ImportDecl GHC.GhcPs -> Bool +isSource = (==) GHC.IsBoot . GHC.ideclSource -------------------------------------------------------------------------------- -- | Cleans up an import item list. @@ -431,42 +416,44 @@ isSafe -- * 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 :: [GHC.LIE GHC.GhcPs] -> [GHC.LIE GHC.GhcPs] prepareImportList = sortBy compareLIE . map (fmap prepareInner) . concatMap (toList . snd) . Map.toAscList . mergeByName where - mergeByName :: [LIE GhcPs] -> Map.Map RdrName (NonEmpty (LIE GhcPs)) + mergeByName + :: [GHC.LIE GHC.GhcPs] + -> Map.Map GHC.RdrName (NonEmpty (GHC.LIE GHC.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` + (\(x :| xs) (y :| ys) -> case ieMerge (GHC.unLoc x) (GHC.unLoc y) of + Just z -> (x $> z) :| (xs ++ ys) -- Keep source from `x` Nothing -> x :| (xs ++ y : ys)) - [(ieName $ unLocated imp, imp :| []) | imp <- imports0] + [(GHC.ieName $ GHC.unLoc imp, imp :| []) | imp <- imports0] - prepareInner :: IE GhcPs -> IE GhcPs + prepareInner :: GHC.IE GHC.GhcPs -> GHC.IE GHC.GhcPs prepareInner = \case -- Simplify `A ()` to `A`. - IEThingWith x n NoIEWildcard [] [] -> IEThingAbs x n - IEThingWith x n w ns fs -> - IEThingWith x n w (sortBy (compareWrappedName `on` unLoc) ns) fs + GHC.IEThingWith x n GHC.NoIEWildcard [] -> GHC.IEThingAbs x n + GHC.IEThingWith x n w ns -> + GHC.IEThingWith x n w (sortBy (compareWrappedName `on` GHC.unLoc) ns) ie -> ie -- 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 []) + ieMerge :: GHC.IE GHC.GhcPs -> GHC.IE GHC.GhcPs -> Maybe (GHC.IE GHC.GhcPs) + ieMerge l@(GHC.IEVar _ _) _ = Just l + ieMerge _ r@(GHC.IEVar _ _) = Just r + ieMerge (GHC.IEThingAbs _ _) r = Just r + ieMerge l (GHC.IEThingAbs _ _) = Just l + ieMerge l@(GHC.IEThingAll _ _) _ = Just l + ieMerge _ r@(GHC.IEThingAll _ _) = Just r + ieMerge (GHC.IEThingWith x0 n0 w0 ns0) (GHC.IEThingWith _ _ w1 ns1) | w0 /= w1 = Nothing | otherwise = Just $ -- TODO: sort the `ns0 ++ ns1`? - IEThingWith x0 n0 w0 (nubOn (unwrapName . unLoc) $ ns0 ++ ns1) [] + GHC.IEThingWith x0 n0 w0 (nubOn GHC.lieWrappedName $ ns0 ++ ns1) ieMerge _ _ = Nothing @@ -480,5 +467,3 @@ nubOn f = go Set.empty | otherwise = x : go (Set.insert y acc) xs where y = f x - --} diff --git a/tests/Language/Haskell/Stylish/Step/UnicodeSyntax/Tests.hs b/tests/Language/Haskell/Stylish/Step/UnicodeSyntax/Tests.hs index e2ba34fd..da1abae3 100644 --- a/tests/Language/Haskell/Stylish/Step/UnicodeSyntax/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/UnicodeSyntax/Tests.hs @@ -52,4 +52,4 @@ case02 = expected @=? testStep (step True "LaNgUaGe") input [ "{-# LaNgUaGe UnicodeSyntax #-}" , "sort ∷ Ord a ⇒ [a] → [a]" , "sort _ = []" - ] \ No newline at end of file + ] diff --git a/tests/Language/Haskell/Stylish/Tests/Util.hs b/tests/Language/Haskell/Stylish/Tests/Util.hs index ad214425..ba681000 100644 --- a/tests/Language/Haskell/Stylish/Tests/Util.hs +++ b/tests/Language/Haskell/Stylish/Tests/Util.hs @@ -19,7 +19,6 @@ import Control.Monad.Writer (execWriter, tell) import Data.List (intercalate) import GHC.Exts (IsList (..)) import GHC.Hs.Dump (showAstData, BlankSrcSpan(..), BlankEpAnnotations (..)) -import Language.Haskell.Stylish.GHC (baseDynFlags) import System.Directory (createDirectory, getCurrentDirectory, getTemporaryDirectory, From 2c6c720b0383997d3884998e29ba368193a0eb71 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Mon, 7 Feb 2022 20:50:27 +0100 Subject: [PATCH 14/32] Kill warnings --- lib/Language/Haskell/Stylish/Step/SimpleAlign.hs | 5 ----- 1 file changed, 5 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs b/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs index e1476325..975b33dc 100644 --- a/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs +++ b/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs @@ -76,7 +76,6 @@ records modu = do where getConDecls :: Hs.HsDataDefn Hs.GhcPs -> [Hs.ConDecl Hs.GhcPs] getConDecls d@Hs.HsDataDefn {} = map GHC.unLoc $ Hs.dd_cons d - getConDecls (Hs.XHsDataDefn x) = Hs.noExtCon x -------------------------------------------------------------------------------- @@ -87,7 +86,6 @@ recordToAlignable conf = groupAlign (cRecords conf) . fromMaybe [] . traverse fi -------------------------------------------------------------------------------- fieldDeclToAlignable :: GHC.LocatedA (Hs.ConDeclField Hs.GhcPs) -> Maybe (Alignable GHC.RealSrcSpan) -fieldDeclToAlignable (GHC.L _ (Hs.XConDeclField x)) = Hs.noExtCon x fieldDeclToAlignable (GHC.L matchLoc (Hs.ConDeclField _ names ty _)) = do matchPos <- GHC.srcSpanToRealSrcSpan $ GHC.locA matchLoc leftPos <- GHC.srcSpanToRealSrcSpan $ GHC.getLoc $ last names @@ -105,7 +103,6 @@ matchGroupToAlignable :: Config -> Hs.MatchGroup Hs.GhcPs (Hs.LHsExpr Hs.GhcPs) -> [[Alignable GHC.RealSrcSpan]] -matchGroupToAlignable _conf (Hs.XMatchGroup x) = Hs.noExtCon x matchGroupToAlignable conf (Hs.MG _ alts _) = cases' ++ patterns' where (cases, patterns) = partitionEithers . fromMaybe [] $ traverse matchToAlignable (GHC.unLoc alts) @@ -148,7 +145,6 @@ matchToAlignable (GHC.L matchLoc (Hs.Match _ (Hs.FunRhs name _ _) pats@(_ : _) g , aRight = bodyPos , aRightLead = length "= " } -matchToAlignable (GHC.L _ (Hs.XMatch x)) = Hs.noExtCon x matchToAlignable (GHC.L _ (Hs.Match _ _ _ _)) = Nothing @@ -181,7 +177,6 @@ grhsToAlignable (GHC.L grhsloc (Hs.GRHS _ guards@(_ : _) body)) = do , aRight = bodyPos , aRightLead = length "-> " } -grhsToAlignable (GHC.L _ (Hs.XGRHS x)) = Hs.noExtCon x grhsToAlignable (GHC.L _ _) = Nothing From bac4d8b99af64e16b709cfd38122654907e02e50 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Mon, 7 Feb 2022 20:58:09 +0100 Subject: [PATCH 15/32] Work on porting Imports step --- lib/Language/Haskell/Stylish/Step/Imports.hs | 50 +++++++++++--------- 1 file changed, 27 insertions(+), 23 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Step/Imports.hs b/lib/Language/Haskell/Stylish/Step/Imports.hs index 86136b2b..eef9d136 100644 --- a/lib/Language/Haskell/Stylish/Step/Imports.hs +++ b/lib/Language/Haskell/Stylish/Step/Imports.hs @@ -31,6 +31,7 @@ import qualified GHC.Hs as GHC import qualified GHC.Types.Name.Reader as GHC import qualified GHC.Types.SourceText as GHC import qualified GHC.Types.SrcLoc as GHC +import qualified GHC.Unit.Module.Name as GHC import qualified GHC.Unit.Types as GHC @@ -38,6 +39,7 @@ import qualified GHC.Unit.Types as GHC import Language.Haskell.Stylish.Module import Language.Haskell.Stylish.Step import Language.Haskell.Stylish.Ordering +import Language.Haskell.Stylish.Printer -------------------------------------------------------------------------------- @@ -309,57 +311,59 @@ printQualified Options{..} padNames stats (L _ decl) = do -------------------------------------------------------------------------------- -printImport :: Bool -> IE GhcPs -> P () -printImport _ (IEVar _ name) = do +-} +printImport :: Bool -> GHC.IE GHC.GhcPs -> P () +printImport _ (GHC.IEVar _ name) = do printIeWrappedName name -printImport _ (IEThingAbs _ name) = do +printImport _ (GHC.IEThingAbs _ name) = do printIeWrappedName name -printImport separateLists (IEThingAll _ name) = do +printImport separateLists (GHC.IEThingAll _ name) = do printIeWrappedName name when separateLists space putText "(..)" -printImport _ (IEModuleContents _ (L _ m)) = do +printImport _ (GHC.IEModuleContents _ modu) = do putText "module" space - putText (moduleNameString m) -printImport separateLists (IEThingWith _ name wildcard imps _) = do + putText . GHC.moduleNameString $ GHC.unLoc modu +printImport separateLists (GHC.IEThingWith _ name wildcard imps) = do printIeWrappedName name when separateLists space let ellipsis = case wildcard of - IEWildcard _position -> [putText ".."] - NoIEWildcard -> [] + GHC.IEWildcard _position -> [putText ".."] + GHC.NoIEWildcard -> [] parenthesize $ sep (comma >> space) (ellipsis <> fmap printIeWrappedName imps) -printImport _ (IEGroup _ _ _ ) = +printImport _ (GHC.IEGroup _ _ _ ) = error "Language.Haskell.Stylish.Printer.Imports.printImportExport: unhandled case 'IEGroup'" -printImport _ (IEDoc _ _) = +printImport _ (GHC.IEDoc _ _) = error "Language.Haskell.Stylish.Printer.Imports.printImportExport: unhandled case 'IEDoc'" -printImport _ (IEDocNamed _ _) = +printImport _ (GHC.IEDocNamed _ _) = error "Language.Haskell.Stylish.Printer.Imports.printImportExport: unhandled case 'IEDocNamed'" -printImport _ (XIE ext) = +printImport _ (GHC.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 +printIeWrappedName :: GHC.LIEWrappedName GHC.RdrName -> P () +printIeWrappedName lie = case GHC.unLoc lie of + GHC.IEName n -> putRdrName n + GHC.IEPattern _ n -> putText "pattern" >> space >> putRdrName n + GHC.IEType _ n -> putText "type" >> space >> putRdrName n + -mergeImports :: NonEmpty (Located Import) -> NonEmpty (Located Import) +mergeImports + :: NonEmpty (GHC.LImportDecl GHC.GhcPs) + -> NonEmpty (GHC.LImportDecl GHC.GhcPs) mergeImports (x :| []) = x :| [] mergeImports (h :| (t : ts)) - | canMergeImport (unLocated h) (unLocated t) = mergeImports (mergeModuleImport h t :| ts) + | canMergeImport (GHC.unLoc h) (GHC.unLoc 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) + | canMergeImport (GHC.unLoc x) (GHC.unLoc y) = mergeImportsTail ((mergeModuleImport x y) : ys) | otherwise = x : mergeImportsTail (y : ys) mergeImportsTail xs = xs --} - -------------------------------------------------------------------------------- data ImportStats = ImportStats From d46e4f2f927a42be71fadfdeeddd9f3062402cd7 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Tue, 8 Feb 2022 09:15:54 +0100 Subject: [PATCH 16/32] Port imports step --- lib/Language/Haskell/Stylish/Step/Imports.hs | 333 ++++++++++--------- 1 file changed, 173 insertions(+), 160 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Step/Imports.hs b/lib/Language/Haskell/Stylish/Step/Imports.hs index eef9d136..b75ab58b 100644 --- a/lib/Language/Haskell/Stylish/Step/Imports.hs +++ b/lib/Language/Haskell/Stylish/Step/Imports.hs @@ -22,7 +22,7 @@ import Data.Function ((&), on) import Data.Functor (($>)) import Data.List.NonEmpty (NonEmpty(..)) import Data.List (sortBy) -import Data.Maybe (isJust) +import Data.Maybe (fromMaybe, isJust) import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Map as Map import qualified Data.Set as Set @@ -36,10 +36,13 @@ import qualified GHC.Unit.Types as GHC -------------------------------------------------------------------------------- +import Language.Haskell.Stylish.Block +import Language.Haskell.Stylish.Editor import Language.Haskell.Stylish.Module -import Language.Haskell.Stylish.Step import Language.Haskell.Stylish.Ordering import Language.Haskell.Stylish.Printer +import Language.Haskell.Stylish.Step +import Language.Haskell.Stylish.Util -------------------------------------------------------------------------------- @@ -103,8 +106,6 @@ data LongListAlign -------------------------------------------------------------------------------- step :: Maybe Int -> Options -> Step -step _ _ = makeStep "Imports (ghc-lib-parser)" $ \ls _ -> ls -{- step columns = makeStep "Imports (ghc-lib-parser)" . printImports columns @@ -113,38 +114,41 @@ 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 + moduleStats = foldMap importStats . fmap GHC.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 + -> NonEmpty (GHC.LImportDecl GHC.GhcPs) -> 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 :: NonEmpty (GHC.LImportDecl GHC.GhcPs) -> Block String importBlock group = Block - (getStartLineUnsafe $ NonEmpty.head group) - (getEndLineUnsafe $ NonEmpty.last group) + (GHC.srcSpanStartLine . src $ NonEmpty.head group) + (GHC.srcSpanEndLine . src $ NonEmpty.last group) + where + src = fromMaybe (error "importBlock: missing location") . + GHC.srcSpanToRealSrcSpan . GHC.getLocA formatImports :: Maybe Int -- ^ Max columns. -> Options -- ^ Options. -> Module -- ^ Module. -> ImportStats -- ^ Module stats. - -> NonEmpty (Located Import) -> Lines + -> NonEmpty (GHC.LImportDecl GHC.GhcPs) -> Lines formatImports maxCols options m moduleStats rawGroup = runPrinter_ (PrinterConfig maxCols) [] m do let - group :: NonEmpty (Located Import) + group :: NonEmpty (GHC.LImportDecl GHC.GhcPs) group - = NonEmpty.sortBy (compareImports `on` unLocated) rawGroup + = NonEmpty.sortBy (compareImports `on` GHC.unLoc) rawGroup & mergeImports - unLocatedGroup = fmap unLocated $ toList group + unLocatedGroup = fmap GHC.unLoc $ toList group align' = importAlign options padModuleNames' = padModuleNames options @@ -158,151 +162,160 @@ formatImports maxCols options m moduleStats rawGroup = 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) - - let - module_ = do - 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) ' ' - pure moduleNamePosition - - moduleNamePosition <- - case (postQualified, isQualified decl, isAnyQualified stats) of - (False, True , _ ) -> putText "qualified" *> space *> module_ - (False, _ , True) -> putText " " *> space *> module_ - (True , True , _ ) -> module_ <* space <* putText "qualified" - _ -> module_ - - beforeAliasPosition <- length <$> getCurrentLine - - forM_ (ideclAs decl') \(L _ name) -> do - 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 separateLists) . 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) +-------------------------------------------------------------------------------- +printQualified + :: Options -> Bool -> ImportStats -> GHC.LImportDecl GHC.GhcPs -> P () +printQualified Options{..} padNames stats ldecl = do + putText "import" >> space + + case (isSource decl, isAnySource stats) of + (True, _) -> putText "{-# SOURCE #-}" >> space + (_, True) -> putText " " >> space + _ -> pure () + + when (GHC.ideclSafe decl) (putText "safe" >> space) + + let module_ = do + moduleNamePosition <- length <$> getCurrentLine + forM_ (GHC.ideclPkgQual decl) $ \pkg -> + putText (stringLiteral pkg) >> space + putText (importModuleName decl) + + -- Only print spaces if something follows. + let somethingFollows = + isJust (GHC.ideclAs decl) || isHiding decl || + not (null $ GHC.ideclHiding decl) + when (padNames && somethingFollows) $ putText $ replicate + (isLongestImport stats - importModuleNameLength decl) + ' ' + pure moduleNamePosition + + moduleNamePosition <- + case (postQualified, isQualified decl, isAnyQualified stats) of + (False, True , _ ) -> putText "qualified" *> space *> module_ + (False, _ , True) -> putText " " *> space *> module_ + (True , True , _ ) -> module_ <* space <* putText "qualified" + _ -> module_ + + beforeAliasPosition <- length <$> getCurrentLine + forM_ (GHC.ideclAs decl) $ \lname -> do + space >> putText "as" >> space + putText . GHC.moduleNameString $ GHC.unLoc lname + + afterAliasPosition <- length <$> getCurrentLine + + when (isHiding decl) (space >> putText "hiding") + + let putOffset = putText $ replicate offset ' ' + offset = case listPadding of + LPConstant n -> n + LPModuleName -> moduleNamePosition + + pure () + + case snd <$> GHC.ideclHiding decl of + Nothing -> pure () + Just limports | null (GHC.unLoc limports) -> case emptyListAlign of + RightAfter -> modifyCurrentLine trimRight >> space >> putText "()" + Inherit -> case listAlign of + NewLine -> do + modifyCurrentLine trimRight + newline >> putOffset >> putText "()" + _ -> space >> putText "()" + + Just limports -> do + let imports = GHC.unLoc limports + printedImports = flagEnds $ -- [P ()] + (printImport separateLists) . GHC.unLoc <$> + 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 ' ' + + -- Helper + let doSpaceSurround = when spaceSurround space + + -- Try to put everything on one line. + let 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. + let 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. + let 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 + decl = GHC.unLoc ldecl + -- We cannot wrap/repeat 'hiding' imports since then we would get multiple -- imports hiding different things. patchForRepeatHiding = case listAlign of @@ -311,7 +324,6 @@ printQualified Options{..} padNames stats (L _ decl) = do -------------------------------------------------------------------------------- --} printImport :: Bool -> GHC.IE GHC.GhcPs -> P () printImport _ (GHC.IEVar _ name) = do printIeWrappedName name @@ -339,8 +351,6 @@ printImport _ (GHC.IEDoc _ _) = error "Language.Haskell.Stylish.Printer.Imports.printImportExport: unhandled case 'IEDoc'" printImport _ (GHC.IEDocNamed _ _) = error "Language.Haskell.Stylish.Printer.Imports.printImportExport: unhandled case 'IEDocNamed'" -printImport _ (GHC.XIE ext) = - GHC.noExtCon ext -------------------------------------------------------------------------------- @@ -401,7 +411,9 @@ importModuleNameLength imp = -------------------------------------------------------------------------------- stringLiteral :: GHC.StringLiteral -> String -stringLiteral = GHC.unpackFS . GHC.sl_fs +stringLiteral sl = case GHC.sl_st sl of + GHC.NoSourceText -> show . GHC.unpackFS $ GHC.sl_fs sl + GHC.SourceText s -> s -------------------------------------------------------------------------------- @@ -414,6 +426,7 @@ isHiding = maybe False fst . GHC.ideclHiding isSource :: GHC.ImportDecl GHC.GhcPs -> Bool isSource = (==) GHC.IsBoot . GHC.ideclSource + -------------------------------------------------------------------------------- -- | Cleans up an import item list. -- From ab907d97c60a3fa8ee39fcc6281344686131fafb Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sat, 19 Feb 2022 14:31:02 +0100 Subject: [PATCH 17/32] Tiny cleanup --- lib/Language/Haskell/Stylish/Module.hs | 8 +++----- tests/Language/Haskell/Stylish/Step/Imports/FelixTests.hs | 2 +- 2 files changed, 4 insertions(+), 6 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Module.hs b/lib/Language/Haskell/Stylish/Module.hs index a53f0a64..17ca529e 100644 --- a/lib/Language/Haskell/Stylish/Module.hs +++ b/lib/Language/Haskell/Stylish/Module.hs @@ -28,7 +28,7 @@ module Language.Haskell.Stylish.Module -------------------------------------------------------------------------------- import Data.Char (toLower) -import Data.Function (on, (&)) +import Data.Function (on) import Data.Generics (Typeable, everything, mkQ) import qualified Data.List as L import Data.List.NonEmpty (NonEmpty (..)) @@ -37,11 +37,9 @@ import GHC.Hs (ImportDecl (..), ImportDeclQualifiedStyle (..)) import qualified GHC.Hs as GHC import GHC.Hs.Extension (GhcPs) -import GHC.Types.SrcLoc (GenLocated (..)) -import GHC.Types.SrcLoc (RealSrcSpan (..)) -import GHC.Types.SrcLoc (Located, unLoc) +import GHC.Types.SrcLoc (GenLocated (..), + RealSrcSpan (..), unLoc) import qualified GHC.Types.SrcLoc as GHC -import GHC.Utils.Outputable (Outputable) import qualified GHC.Unit.Module.Name as GHC diff --git a/tests/Language/Haskell/Stylish/Step/Imports/FelixTests.hs b/tests/Language/Haskell/Stylish/Step/Imports/FelixTests.hs index 57931d02..8fad01ff 100644 --- a/tests/Language/Haskell/Stylish/Step/Imports/FelixTests.hs +++ b/tests/Language/Haskell/Stylish/Step/Imports/FelixTests.hs @@ -21,7 +21,7 @@ import Language.Haskell.Stylish.Tests.Util (testStep', (@=??)) -------------------------------------------------------------------------------- tests :: Test -tests = testGroup "Language.Haskell.Stylish.Step.ImportsGHC" +tests = testGroup "Language.Haskell.Stylish.Step.Imports.FelixTests" [ testCase "Hello world" ex0 , testCase "Sorted simple" ex1 , testCase "Sorted import lists" ex2 From 02072ce403074fbb95acf8e000f8a30fbaedafb5 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Mon, 21 Feb 2022 17:17:29 +0100 Subject: [PATCH 18/32] Port ModuleHeader step --- lib/Language/Haskell/Stylish/Block.hs | 20 +- lib/Language/Haskell/Stylish/Comments.hs | 145 +++++++ lib/Language/Haskell/Stylish/Editor.hs | 4 +- lib/Language/Haskell/Stylish/GHC.hs | 12 +- lib/Language/Haskell/Stylish/Module.hs | 2 +- lib/Language/Haskell/Stylish/Printer.hs | 81 ++-- lib/Language/Haskell/Stylish/Step/Imports.hs | 15 +- .../Haskell/Stylish/Step/ModuleHeader.hs | 377 ++++++++---------- stylish-haskell.cabal | 2 + .../Stylish/Step/ModuleHeader/Tests.hs | 8 + 10 files changed, 397 insertions(+), 269 deletions(-) create mode 100644 lib/Language/Haskell/Stylish/Comments.hs diff --git a/lib/Language/Haskell/Stylish/Block.hs b/lib/Language/Haskell/Stylish/Block.hs index 9b074206..92402250 100644 --- a/lib/Language/Haskell/Stylish/Block.hs +++ b/lib/Language/Haskell/Stylish/Block.hs @@ -2,6 +2,7 @@ module Language.Haskell.Stylish.Block ( Block (..) , LineBlock + , realSrcSpanToLineBlock , SpanBlock , blockLength , moveBlock @@ -14,7 +15,8 @@ module Language.Haskell.Stylish.Block -------------------------------------------------------------------------------- -import qualified Data.IntSet as IS +import qualified Data.IntSet as IS +import qualified GHC.Types.SrcLoc as GHC -------------------------------------------------------------------------------- @@ -22,8 +24,12 @@ import qualified Data.IntSet as IS data Block a = Block { blockStart :: Int , blockEnd :: Int - } - deriving (Eq, Ord, Show) + } deriving (Eq, Ord, Show) + + +-------------------------------------------------------------------------------- +instance Semigroup (Block a) where + (<>) = merge -------------------------------------------------------------------------------- @@ -34,10 +40,16 @@ type LineBlock = Block String type SpanBlock = Block Char +-------------------------------------------------------------------------------- +realSrcSpanToLineBlock :: GHC.RealSrcSpan -> Block String +realSrcSpanToLineBlock s = Block (GHC.srcSpanStartLine s) (GHC.srcSpanEndLine s) + + -------------------------------------------------------------------------------- blockLength :: Block a -> Int blockLength (Block start end) = end - start + 1 + -------------------------------------------------------------------------------- moveBlock :: Int -> Block a -> Block a moveBlock offset (Block start end) = Block (start + offset) (end + offset) @@ -47,7 +59,7 @@ moveBlock offset (Block start end) = Block (start + offset) (end + offset) adjacent :: Block a -> Block a -> Bool adjacent b1 b2 = follows b1 b2 || follows b2 b1 where - follows (Block _ e1) (Block s2 _) = e1 + 1 == s2 + follows (Block _ e1) (Block s2 _) = e1 == s2 || e1 + 1 == s2 -------------------------------------------------------------------------------- diff --git a/lib/Language/Haskell/Stylish/Comments.hs b/lib/Language/Haskell/Stylish/Comments.hs new file mode 100644 index 00000000..f1b09853 --- /dev/null +++ b/lib/Language/Haskell/Stylish/Comments.hs @@ -0,0 +1,145 @@ +-------------------------------------------------------------------------------- +-- | Utilities for assocgating comments with things in a list. +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Language.Haskell.Stylish.Comments + ( CommentGroup (..) + , commentGroups + , commentGroupHasComments + , commentGroupSort + ) where + + +-------------------------------------------------------------------------------- +import Data.Function (on) +import Data.List (sortBy, sortOn) +import Data.Maybe (isNothing, maybeToList) +import qualified GHC.Hs as GHC +import qualified GHC.Types.SrcLoc as GHC +import qualified GHC.Utils.Outputable as GHC + + +-------------------------------------------------------------------------------- +import Language.Haskell.Stylish.Block +import Language.Haskell.Stylish.GHC + + +-------------------------------------------------------------------------------- +data CommentGroup a = CommentGroup + { cgBlock :: LineBlock + , cgPrior :: [GHC.LEpaComment] + , cgItems :: [(a, Maybe GHC.LEpaComment)] + , cgFollowing :: [GHC.LEpaComment] + } + + +-------------------------------------------------------------------------------- +instance GHC.Outputable a => Show (CommentGroup a) where + show CommentGroup {..} = "(CommentGroup (" ++ + show cgBlock ++ ") (" ++ + showOutputable cgPrior ++ ") (" ++ + showOutputable cgItems ++ ") (" ++ + showOutputable cgFollowing ++ "))" + + +-------------------------------------------------------------------------------- +commentGroups + :: forall a. + (a -> Maybe GHC.RealSrcSpan) + -> [a] + -> [GHC.LEpaComment] + -> [CommentGroup a] +commentGroups getSpan allItems allComments = + work Nothing (sortOn fst allItemsWithLines) (sortOn fst commentsWithLines) + where + allItemsWithLines :: [(LineBlock, a)] + allItemsWithLines = do + item <- allItems + s <- maybeToList $ getSpan item + pure (realSrcSpanToLineBlock s, item) + + commentsWithLines :: [(LineBlock, GHC.LEpaComment)] + commentsWithLines = do + comment <- allComments + let s = GHC.anchor $ GHC.getLoc comment + pure (realSrcSpanToLineBlock s, comment) + + work + :: Maybe (CommentGroup a) + -> [(LineBlock, a)] + -> [(LineBlock, GHC.LEpaComment)] + -> [CommentGroup a] + work mbCurrent items comments = case takeNext items comments of + Nothing -> maybeToList mbCurrent + Just (b, next, items', comments') -> + let (flush, current) = case mbCurrent of + Just c | adjacent (cgBlock c) b + , nextThingItem next + , following@(_ : _) <- cgFollowing c -> + ([c {cgFollowing = []}], CommentGroup b following [] []) + Just c | adjacent (cgBlock c) b -> + ([], c {cgBlock = cgBlock c <> b}) + _ -> (maybeToList mbCurrent, CommentGroup b [] [] []) + current' = case next of + NextItem i -> current {cgItems = cgItems current <> [(i, Nothing)]} + NextComment c + | null (cgItems current) -> current {cgPrior = cgPrior current <> [c]} + | otherwise -> current {cgFollowing = cgFollowing current <> [c]} + NextItemWithComment i c -> + current {cgItems = cgItems current <> [(i, Just c)]} in + flush ++ work (Just current') items' comments' + + + +-------------------------------------------------------------------------------- +takeNext + :: [(LineBlock, a)] + -> [(LineBlock, GHC.LEpaComment)] + -> Maybe (LineBlock, NextThing a, [(LineBlock, a)], [(LineBlock, GHC.LEpaComment)]) +takeNext [] [] = Nothing +takeNext [] ((cb, c) : comments) = + Just (cb, NextComment c, [], comments) +takeNext ((ib, i) : items) [] = + Just (ib, NextItem i, items, []) +takeNext ((ib, i) : items) ((cb, c) : comments) + | blockStart ib == blockStart cb = + Just (ib <> cb, NextItemWithComment i c, items, comments) + | blockStart ib < blockStart cb = + Just (ib, NextItem i, items, (cb, c) : comments) + | otherwise = + Just (cb, NextComment c, (ib, i) : items, comments) + + +-------------------------------------------------------------------------------- +data NextThing a + = NextComment GHC.LEpaComment + | NextItem a + | NextItemWithComment a GHC.LEpaComment + + +-------------------------------------------------------------------------------- +instance GHC.Outputable a => Show (NextThing a) where + show (NextComment c) = "NextComment " ++ showOutputable c + show (NextItem i) = "NextItem " ++ showOutputable i + show (NextItemWithComment i c) = + "NextItemWithComment " ++ showOutputable i ++ " " ++ showOutputable c + + +-------------------------------------------------------------------------------- +nextThingItem :: NextThing a -> Bool +nextThingItem (NextComment _) = False +nextThingItem (NextItem _) = True +nextThingItem (NextItemWithComment _ _) = True + + +-------------------------------------------------------------------------------- +commentGroupHasComments :: CommentGroup a -> Bool +commentGroupHasComments CommentGroup {..} = not $ + null cgPrior && all (isNothing . snd) cgItems && null cgFollowing + + +-------------------------------------------------------------------------------- +commentGroupSort :: (a -> a -> Ordering) -> CommentGroup a -> CommentGroup a +commentGroupSort cmp cg = cg + { cgItems = sortBy (cmp `on` fst) (cgItems cg) + } diff --git a/lib/Language/Haskell/Stylish/Editor.hs b/lib/Language/Haskell/Stylish/Editor.hs index f71d1f6d..dbed9421 100644 --- a/lib/Language/Haskell/Stylish/Editor.hs +++ b/lib/Language/Haskell/Stylish/Editor.hs @@ -9,7 +9,9 @@ -- when this is evaluated, we take into account that 4th line will become the -- 3rd line before it needs changing. module Language.Haskell.Stylish.Editor - ( Change + ( module Language.Haskell.Stylish.Block + + , Change , applyChanges , change diff --git a/lib/Language/Haskell/Stylish/GHC.hs b/lib/Language/Haskell/Stylish/GHC.hs index db9234c9..cb75fcf8 100644 --- a/lib/Language/Haskell/Stylish/GHC.hs +++ b/lib/Language/Haskell/Stylish/GHC.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -Wno-missing-fields #-} -- | Utility functions for working with the GHC AST @@ -14,12 +14,16 @@ module Language.Haskell.Stylish.GHC , baseDynFlags -- * Outputable operators , showOutputable + + -- * Deconstruction + , epAnnComments ) where -------------------------------------------------------------------------------- import qualified GHC.Driver.Ppr as GHC (showPpr) import GHC.Driver.Session (defaultDynFlags) import qualified GHC.Driver.Session as GHC +import qualified GHC.Hs as GHC import GHC.Types.SrcLoc (GenLocated (..), Located, RealLocated, @@ -61,3 +65,9 @@ baseDynFlags = defaultDynFlags GHCEx.fakeSettings GHCEx.fakeLlvmConfig showOutputable :: GHC.Outputable a => a -> String showOutputable = GHC.showPpr baseDynFlags + +epAnnComments :: GHC.EpAnn a -> [GHC.LEpaComment] +epAnnComments GHC.EpAnnNotUsed = [] +epAnnComments GHC.EpAnn {..} = case comments of + GHC.EpaComments {..} -> priorComments + GHC.EpaCommentsBalanced {..} -> priorComments ++ followingComments diff --git a/lib/Language/Haskell/Stylish/Module.hs b/lib/Language/Haskell/Stylish/Module.hs index 17ca529e..a45f94ff 100644 --- a/lib/Language/Haskell/Stylish/Module.hs +++ b/lib/Language/Haskell/Stylish/Module.hs @@ -134,7 +134,7 @@ queryModule f = everything (++) (mkQ [] f) moduleLanguagePragmas :: Module -> [(RealSrcSpan, NonEmpty String)] moduleLanguagePragmas = - mapMaybe prag . GHC.priorComments . GHC.comments . GHC.hsmodAnn . GHC.unLoc + mapMaybe prag . epAnnComments . GHC.hsmodAnn . GHC.unLoc where prag :: GHC.LEpaComment -> Maybe (GHC.RealSrcSpan, NonEmpty String) prag comment = case GHC.ac_tok (GHC.unLoc comment) of diff --git a/lib/Language/Haskell/Stylish/Printer.hs b/lib/Language/Haskell/Stylish/Printer.hs index 7de089db..2b4c01ae 100644 --- a/lib/Language/Haskell/Stylish/Printer.hs +++ b/lib/Language/Haskell/Stylish/Printer.hs @@ -1,11 +1,10 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE DoAndIfThenElse #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} module Language.Haskell.Stylish.Printer ( Printer(..) , PrinterConfig(..) @@ -58,26 +57,26 @@ module Language.Haskell.Stylish.Printer import Prelude hiding (lines) -------------------------------------------------------------------------------- +import qualified GHC.Hs as GHC import GHC.Hs.Extension (GhcPs) -import GHC.Types.Name.Reader (RdrName(..)) -import GHC.Types.SrcLoc (GenLocated(..)) -import GHC.Utils.Outputable (Outputable) -import qualified GHC.Hs as GHC -import qualified GHC.Types.SrcLoc as GHC -import qualified GHC.Unit.Module.Name as GHC -import qualified GHC.Types.Basic as GHC +import qualified GHC.Types.Basic as GHC +import GHC.Types.Name.Reader (RdrName (..)) +import GHC.Types.SrcLoc (GenLocated (..)) +import qualified GHC.Types.SrcLoc as GHC +import qualified GHC.Unit.Module.Name as GHC +import GHC.Utils.Outputable (Outputable) -------------------------------------------------------------------------------- import Control.Monad (forM_, replicateM_) -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) +import Control.Monad.Reader (MonadReader, ReaderT (..), + asks, local) +import Control.Monad.State (MonadState, State, get, gets, + modify, put, runState) import Data.List (foldl') -------------------------------------------------------------------------------- -import Language.Haskell.Stylish.Module (Module, Lines) import Language.Haskell.Stylish.GHC (showOutputable) +import Language.Haskell.Stylish.Module (Lines) -- | Shorthand for 'Printer' monad type P = Printer @@ -93,24 +92,22 @@ data PrinterConfig = PrinterConfig -- | State of printer data PrinterState = PrinterState - { lines :: !Lines - , linePos :: !Int + { lines :: !Lines + , linePos :: !Int , currentLine :: !String - , pendingComments :: ![GHC.RealLocated GHC.EpaComment] - , parsedModule :: !Module } -- | Run printer to get printed lines out of module as well as return value of monad -runPrinter :: PrinterConfig -> [GHC.RealLocated GHC.EpaComment] -> Module -> Printer a -> (a, Lines) -runPrinter cfg comments m (Printer printer) = +runPrinter :: PrinterConfig -> Printer a -> (a, Lines) +runPrinter cfg (Printer printer) = let - (a, PrinterState parsedLines _ startedLine _ _) = runReaderT printer cfg `runState` PrinterState [] 0 "" comments m + (a, PrinterState parsedLines _ startedLine) = runReaderT printer cfg `runState` PrinterState [] 0 "" in (a, parsedLines <> if startedLine == [] then [] else [startedLine]) -- | Run printer to get printed lines only -runPrinter_ :: PrinterConfig -> [GHC.RealLocated GHC.EpaComment] -> Module -> Printer a -> Lines -runPrinter_ cfg comments m printer = snd (runPrinter cfg comments m printer) +runPrinter_ :: PrinterConfig -> Printer a -> Lines +runPrinter_ cfg printer = snd (runPrinter cfg printer) -- | Print text putText :: String -> P () @@ -148,14 +145,14 @@ putAllSpanComments suff = \case -- | Print any comment putComment :: GHC.EpaComment -> P () putComment epaComment = case GHC.ac_tok epaComment of - GHC.EpaLineComment s -> putText s - GHC.EpaDocCommentNext s -> putText s - GHC.EpaDocCommentPrev s -> putText s + GHC.EpaLineComment s -> putText s + GHC.EpaDocCommentNext s -> putText s + GHC.EpaDocCommentPrev s -> putText s GHC.EpaDocCommentNamed s -> putText s - GHC.EpaDocSection _ s -> putText s - GHC.EpaDocOptions s -> putText s - GHC.EpaBlockComment s -> putText s - GHC.EpaEofComment -> pure () + GHC.EpaDocSection _ s -> putText s + GHC.EpaDocOptions s -> putText s + GHC.EpaBlockComment s -> putText s + GHC.EpaEofComment -> pure () -- | Given the current start line of 'SrcSpan', remove and put EOL comment for same line {- @@ -198,17 +195,17 @@ nameAnnAdornments = foldl' nameAnnAdornment :: GHC.NameAnn -> (String, String) nameAnnAdornment = \case - GHC.NameAnn {..} -> fromAdornment nann_adornment + GHC.NameAnn {..} -> fromAdornment nann_adornment GHC.NameAnnCommas {..} -> fromAdornment nann_adornment - GHC.NameAnnOnly {..} -> fromAdornment nann_adornment - GHC.NameAnnRArrow {} -> (mempty, mempty) - GHC.NameAnnQuote {} -> ("'", mempty) + GHC.NameAnnOnly {..} -> fromAdornment nann_adornment + GHC.NameAnnRArrow {} -> (mempty, mempty) + GHC.NameAnnQuote {} -> ("'", mempty) GHC.NameAnnTrailing {} -> (mempty, mempty) where - fromAdornment GHC.NameParens = ("(", ")") + fromAdornment GHC.NameParens = ("(", ")") fromAdornment GHC.NameBackquotes = ("`", "`") fromAdornment GHC.NameParensHash = ("#(", "#)") - fromAdornment GHC.NameSquare = ("[", "]") + fromAdornment GHC.NameSquare = ("[", "]") -- | Print module name putModuleName :: GHC.ModuleName -> P () @@ -332,7 +329,7 @@ parenthesize action = putText "(" *> action <* putText ")" -- | Add separator between each element of the given printers sep :: P a -> [P a] -> P () -sep _ [] = pure () +sep _ [] = pure () sep s (first : rest) = first >> forM_ rest ((>>) s) -- | Prefix a printer with another one diff --git a/lib/Language/Haskell/Stylish/Step/Imports.hs b/lib/Language/Haskell/Stylish/Step/Imports.hs index b75ab58b..7f4fba6e 100644 --- a/lib/Language/Haskell/Stylish/Step/Imports.hs +++ b/lib/Language/Haskell/Stylish/Step/Imports.hs @@ -12,7 +12,7 @@ module Language.Haskell.Stylish.Step.Imports , ListPadding (..) , step - -- , printImport + , printImport ) where -------------------------------------------------------------------------------- @@ -117,13 +117,13 @@ printImports maxCols align ls m = applyChanges changes ls moduleStats = foldMap importStats . fmap GHC.unLoc $ concatMap toList groups changes = do group <- groups - pure $ formatGroup maxCols align m moduleStats group + pure $ formatGroup maxCols align moduleStats group formatGroup - :: Maybe Int -> Options -> Module -> ImportStats + :: Maybe Int -> Options -> ImportStats -> NonEmpty (GHC.LImportDecl GHC.GhcPs) -> Change String -formatGroup maxCols options m moduleStats imports = - let newLines = formatImports maxCols options m moduleStats imports in +formatGroup maxCols options moduleStats imports = + let newLines = formatImports maxCols options moduleStats imports in change (importBlock imports) (const newLines) importBlock :: NonEmpty (GHC.LImportDecl GHC.GhcPs) -> Block String @@ -137,11 +137,10 @@ importBlock group = Block formatImports :: Maybe Int -- ^ Max columns. -> Options -- ^ Options. - -> Module -- ^ Module. -> ImportStats -- ^ Module stats. -> NonEmpty (GHC.LImportDecl GHC.GhcPs) -> Lines -formatImports maxCols options m moduleStats rawGroup = - runPrinter_ (PrinterConfig maxCols) [] m do +formatImports maxCols options moduleStats rawGroup = + runPrinter_ (PrinterConfig maxCols) do let group :: NonEmpty (GHC.LImportDecl GHC.GhcPs) group diff --git a/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs b/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs index 4e6a76e0..44bf9c73 100644 --- a/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs +++ b/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} module Language.Haskell.Stylish.Step.ModuleHeader ( Config (..) , BreakWhere (..) @@ -10,7 +11,26 @@ module Language.Haskell.Stylish.Step.ModuleHeader -------------------------------------------------------------------------------- +import Control.Applicative ((<|>)) +import Control.Monad (guard, unless, when) +import Data.Foldable (forM_) +import Data.Maybe (fromMaybe, isJust, + listToMaybe) +import qualified GHC.Hs as GHC +import qualified GHC.Types.SrcLoc as GHC +import qualified GHC.Unit.Module.Name as GHC + + +-------------------------------------------------------------------------------- +import Language.Haskell.Stylish.Comments +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 +import qualified Language.Haskell.Stylish.Step.Imports as Imports +import Language.Haskell.Stylish.Util (flagEnds) data Config = Config @@ -43,236 +63,169 @@ defaultConfig = Config } step :: Maybe Int -> Config -> Step -step _ _ = makeStep "Module header" $ \ls _ -> ls -{- step maxCols = makeStep "Module header" . printModuleHeader maxCols printModuleHeader :: Maybe Int -> Config -> Lines -> Module -> Lines -printModuleHeader maxCols conf ls m = - let - header = moduleHeader m - name = rawModuleName header - haddocks = rawModuleHaddocks header - exports = rawModuleExports header - annotations = rawModuleAnnotations m - - relevantComments :: [RealLocated AnnotationComment] - relevantComments - = moduleComments m - & rawComments - & dropAfterLocated exports - & dropBeforeLocated name - - printedModuleHeader = runPrinter_ (PrinterConfig maxCols) relevantComments - m (printHeader conf name exports haddocks) - - getBlock loc = - Block <$> fmap getStartLineUnsafe loc <*> fmap getEndLineUnsafe 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 - - whereM :: Maybe SrcSpan - whereM - = annotations - & filter (\(((_, w), _)) -> w == AnnWhere) - & fmap (head . snd) -- get position of annot - & L.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 - - deletes = - fmap delete $ mergeAdjacent $ toList nameBlock <> toList exportsBlock <> toList whereBlock - - startLine = - maybe 1 blockStart nameBlock - - additions = [insert startLine printedModuleHeader] - - changes = deletes <> additions - in +printModuleHeader maxCols conf ls lmodul = + let modul = GHC.unLoc lmodul + name = GHC.unLoc <$> GHC.hsmodName modul + haddocks = GHC.hsmodHaddockModHeader modul + + startLine = fromMaybe 1 $ moduleLine <|> + (fmap GHC.srcSpanStartLine . GHC.srcSpanToRealSrcSpan $ + GHC.getLoc lmodul) + + endLine = fromMaybe 1 $ whereLine <|> + (do + loc <- GHC.getLocA <$> GHC.hsmodExports modul + GHC.srcSpanEndLine <$> GHC.srcSpanToRealSrcSpan loc) + + keywordLine kw = listToMaybe $ do + GHC.EpAnn {..} <- pure $ GHC.hsmodAnn modul + GHC.AddEpAnn kw' (GHC.EpaSpan s) <- GHC.am_main anns + guard $ kw == kw' + pure $ GHC.srcSpanEndLine s + + moduleLine = keywordLine GHC.AnnModule + whereLine = keywordLine GHC.AnnWhere + + commentOnLine l = listToMaybe $ do + comment <- epAnnComments $ GHC.hsmodAnn modul + guard $ GHC.srcSpanStartLine (GHC.anchor $ GHC.getLoc comment) == l + pure comment + + moduleComment = moduleLine >>= commentOnLine + whereComment = + guard (whereLine /= moduleLine) >> whereLine >>= commentOnLine + + exportGroups = case GHC.hsmodExports modul of + Nothing -> Nothing + Just lexports -> Just $ doSort $ commentGroups + (GHC.srcSpanToRealSrcSpan . GHC.getLocA) + (GHC.unLoc lexports) + (epAnnComments . GHC.ann $ GHC.getLoc lexports) + + printedModuleHeader = runPrinter_ + (PrinterConfig maxCols) + (printHeader + conf name exportGroups haddocks moduleComment whereComment) + + deletes = delete (Block startLine endLine) + + additions = [insert startLine printedModuleHeader] + + changes = deletes : additions in + applyChanges changes ls -printHeader - :: Config - -> Maybe (Located GHC.ModuleName) - -> Maybe (Located [GHC.LIE GhcPs]) - -> Maybe GHC.LHsDocString - -> P () -printHeader conf mname mexps _ = do - forM_ mname \(L _ name) -> do - putText "module" - space - putText (showOutputable name) - - case mexps of - Nothing -> when (isJust mname) do - forM_ mname \(L nloc _) -> attachEolComment nloc - case breakWhere conf of - Always -> do - newline - spaces (indent conf) - _ -> space - putText "where" - Just (L loc exps) -> do - moduleComment <- getModuleComment - exportsWithComments <- fmap (second doSort) <$> groupAttachedComments exps - case breakWhere conf of - Single - | Just exportsWithoutComments <- groupWithoutComments exportsWithComments - , length exportsWithoutComments <= 1 - -> do - attachModuleComment moduleComment - printSingleLineExportList conf (L loc exportsWithoutComments) - Inline - | Just exportsWithoutComments <- groupWithoutComments exportsWithComments - -> do - wrapping - ( attachModuleComment moduleComment - >> printSingleLineExportList conf (L loc exportsWithoutComments)) - ( attachOpenBracket - >> attachModuleComment moduleComment - >> printMultiLineExportList conf (L loc exportsWithComments)) - _ -> do - attachOpenBracket - attachModuleComment moduleComment - printMultiLineExportList conf (L loc exportsWithComments) where + doSort = if sort conf then fmap (commentGroupSort compareLIE) else id - getModuleComment = do - maybemaybeComment <- traverse (\(L nloc _) -> removeModuleComment nloc) mname - pure $ join maybemaybeComment - - attachModuleComment moduleComment = - mapM_ (\c -> space >> putComment c) moduleComment +printHeader + :: Config + -> Maybe GHC.ModuleName + -> Maybe [CommentGroup (GHC.LIE GHC.GhcPs)] + -> Maybe GHC.LHsDocString + -> Maybe GHC.LEpaComment -- Comment attached to 'module' + -> Maybe GHC.LEpaComment -- Comment attached to 'where' + -> P () +printHeader conf mbName mbExps _ mbModuleComment mbWhereComment = do + forM_ mbName $ \name -> do + putText "module" + space + putText (showOutputable name) + + case mbExps of + Nothing -> do + when (isJust mbName) $ case breakWhere conf of + Always -> do + attachModuleComment + newline + spaces (indent conf) + _ -> space + putText "where" + Just exports -> case breakWhere conf of + Single | [] <- exports -> do + printSingleLineExportList conf [] + attachModuleComment + Single | [egroup] <- exports + , not (commentGroupHasComments egroup) + , [(export, _)] <- (cgItems egroup) -> do + printSingleLineExportList conf [export] + attachModuleComment + Inline | [] <- exports -> do + printSingleLineExportList conf [] + attachModuleComment + Inline | [egroup] <- exports, not (commentGroupHasComments egroup) -> do + wrapping + (printSingleLineExportList conf $ map fst $ cgItems egroup) + (do + attachOpenBracket + attachModuleComment + printMultiLineExportList conf exports) + _ -> do + attachOpenBracket + attachModuleComment + printMultiLineExportList conf exports + + forM_ mbWhereComment $ \whereComment -> do + space + putComment $ GHC.unLoc whereComment - doSort = if sort conf then NonEmpty.sortBy compareLIE else id + where + attachModuleComment = forM_ mbModuleComment $ \moduleComment -> do + space + putComment $ GHC.unLoc moduleComment attachOpenBracket - | openBracket conf == SameLine = putText " (" - | otherwise = pure () - -removeModuleComment :: SrcSpan -> P (Maybe AnnotationComment) -removeModuleComment = \case - UnhelpfulSpan _ -> pure Nothing - RealSrcSpan rspan -> - removeLineComment (srcSpanStartLine rspan) - -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 - -printSingleLineExportList :: Config -> Located [GHC.LIE GhcPs] -> P () -printSingleLineExportList conf (L srcLoc exports) = do - space >> putText "(" - printInlineExports exports - putText ")" >> space >> putText "where" >> attachEolCommentEnd srcLoc + | openBracket conf == SameLine = putText " (" + | otherwise = pure () + +printSingleLineExportList + :: Config -> [GHC.LIE GHC.GhcPs] -> P () +printSingleLineExportList conf exports = do + space >> putText "(" + printExports exports + putText ")" >> space >> putText "where" where - printInlineExports :: [GHC.LIE GhcPs] -> P () - printInlineExports = \case - [] -> pure () - [e] -> printExport conf e - (e:es) -> printExport conf e >> comma >> space >> printInlineExports es + printExports :: [GHC.LIE GHC.GhcPs] -> P () + printExports = \case + [] -> pure () + [e] -> putExport conf e + (e:es) -> putExport conf e >> comma >> space >> printExports es printMultiLineExportList :: Config - -> Located [([AnnotationComment], NonEmpty (GHC.LIE GhcPs))] + -> [CommentGroup (GHC.LIE GHC.GhcPs)] -> P () -printMultiLineExportList conf (L srcLoc exportsWithComments) = do - newline - doIndent >> putText firstChar >> when (notNull exportsWithComments) space - printExports exportsWithComments - - putText ")" >> space >> putText "where" >> attachEolCommentEnd srcLoc +printMultiLineExportList conf exports = do + newline + doIndent >> putText firstChar >> unless (null exports) space + mapM_ printExport $ flagEnds exports + when (null exports) $ newline >> doIndent + putText ")" >> space >> putText "where" where - -- 'doIndent' is @x@: - -- - -- > module Foo - -- > xxxx( foo - -- > xxxx, bar - -- > xxxx) where - -- - -- 'doHang' is @y@: - -- - -- > module Foo - -- > xxxx( -- Some comment - -- > xxxxyyfoo - -- > xxxx) where - - firstChar = - case openBracket conf of + printExport (CommentGroup {..}, firstGroup, _lastGroup) = do + forM_ (flagEnds cgPrior) $ \(cmt, start, _end) -> do + unless (firstGroup && start) $ space >> space + putComment $ GHC.unLoc cmt + newline >> doIndent + + forM_ (flagEnds cgItems) $ \((export, _), start, _end) -> do + if firstGroup && start then + unless (null cgPrior) $ space >> space + else + comma >> space + putExport conf export + newline >> doIndent + + firstChar = case openBracket conf of SameLine -> " " NextLine -> "(" doIndent = spaces (indent conf) - doHang = pad (indent conf + 2) - - printExports :: [([AnnotationComment], NonEmpty (GHC.LIE GhcPs))] -> P () - printExports (([], firstInGroup :| groupRest) : rest) = do - printExport conf firstInGroup - newline - doIndent - printExportsGroupTail groupRest - printExportsTail rest - printExports ((firstComment : comments, firstExport :| groupRest) : rest) = do - putComment firstComment >> newline >> doIndent - forM_ comments \c -> doHang >> putComment c >> newline >> doIndent - doHang - printExport conf firstExport - newline - doIndent - printExportsGroupTail groupRest - printExportsTail rest - printExports [] = - newline >> doIndent - - printExportsTail :: [([AnnotationComment], NonEmpty (GHC.LIE GhcPs))] -> P () - printExportsTail = mapM_ \(comments, exported) -> do - forM_ comments \c -> doHang >> putComment c >> newline >> doIndent - forM_ exported \export -> do - comma >> space >> printExport conf export - newline >> doIndent - - printExportsGroupTail :: [GHC.LIE GhcPs] -> P () - printExportsGroupTail (x : xs) = printExportsTail [([], x :| xs)] - printExportsGroupTail [] = pure () -- NOTE(jaspervdj): This code is almost the same as the import printing in -- 'Imports' and should be merged. -printExport :: Config -> GHC.LIE GhcPs -> P () -printExport conf = Imports.printImport (separateLists conf) . unLoc - --} +putExport :: Config -> GHC.LIE GHC.GhcPs -> P () +putExport conf = Imports.printImport (separateLists conf) . GHC.unLoc diff --git a/stylish-haskell.cabal b/stylish-haskell.cabal index eed4a26d..303483d0 100644 --- a/stylish-haskell.cabal +++ b/stylish-haskell.cabal @@ -46,6 +46,7 @@ Library Other-modules: Language.Haskell.Stylish.Align Language.Haskell.Stylish.Block + Language.Haskell.Stylish.Comments Language.Haskell.Stylish.Config Language.Haskell.Stylish.Config.Cabal Language.Haskell.Stylish.Config.Internal @@ -118,6 +119,7 @@ Test-suite stylish-haskell-tests Language.Haskell.Stylish Language.Haskell.Stylish.Align Language.Haskell.Stylish.Block + Language.Haskell.Stylish.Comments Language.Haskell.Stylish.Config Language.Haskell.Stylish.Config.Cabal Language.Haskell.Stylish.Config.Internal diff --git a/tests/Language/Haskell/Stylish/Step/ModuleHeader/Tests.hs b/tests/Language/Haskell/Stylish/Step/ModuleHeader/Tests.hs index 1cd387a8..a943fdfc 100644 --- a/tests/Language/Haskell/Stylish/Step/ModuleHeader/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/ModuleHeader/Tests.hs @@ -79,6 +79,7 @@ tests = testGroup "Language.Haskell.Stylish.Printer.ModuleHeader" , testCase "Single two exports, open_bracket = same_line" ex30a , testCase "Single one export with comment" ex31 , testCase "Single one export with comment, open_bracket = same_line" ex31a + , testCase "Single one module comment" ex32 ] -------------------------------------------------------------------------------- @@ -885,5 +886,12 @@ ex31a = assertSnippet (step Nothing $ defaultConfig {breakWhere = Single} & open , " ) where" ] +ex32 :: Assertion +ex32 = assertSnippet (step Nothing $ defaultConfig {breakWhere = Single}) + [ "module Foo (bar) where -- Foo" + ] + [ "module Foo (bar) where -- Foo" + ] + openBracketSameLine :: Config -> Config openBracketSameLine cfg = cfg { openBracket = SameLine } From 8a3b652e80e6146fd097f0cbd41e1c747f668352 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Tue, 22 Feb 2022 18:09:05 +0100 Subject: [PATCH 19/32] Turn on implied extensions --- lib/Language/Haskell/Stylish/Parse.hs | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Parse.hs b/lib/Language/Haskell/Stylish/Parse.hs index 9b66bf9b..f1a6b0ea 100644 --- a/lib/Language/Haskell/Stylish/Parse.hs +++ b/lib/Language/Haskell/Stylish/Parse.hs @@ -27,10 +27,11 @@ import qualified Language.Haskell.GhclibParserEx.GHC.Parser as GHCEx -------------------------------------------------------------------------------- -import Language.Haskell.Stylish.GHC (baseDynFlags) +import Language.Haskell.Stylish.GHC import Language.Haskell.Stylish.Module +-------------------------------------------------------------------------------- type Extensions = [String] @@ -64,7 +65,7 @@ parseModule externalExts0 fp string = do Just e -> Right e -- Build first dynflags. - let dynFlags0 = foldl' GHC.xopt_set baseDynFlags externalExts1 + let dynFlags0 = foldl' turnOn baseDynFlags externalExts1 -- Parse options from file let fileOptions = fmap GHC.unLoc $ GHC.getOptions dynFlags0 @@ -75,7 +76,7 @@ parseModule externalExts0 fp string = do fileOptions -- Set further dynflags. - let dynFlags1 = foldl' GHC.xopt_set dynFlags0 fileExtensions + let dynFlags1 = foldl' turnOn dynFlags0 fileExtensions `GHC.gopt_set` GHC.Opt_KeepRawTokenStream -- Possibly strip CPP. @@ -90,3 +91,8 @@ parseModule externalExts0 fp string = do GHC.getMessages ps where withFileName x = maybe "" (<> ": ") fp <> x + + turnOn dynFlags ext = foldl' + turnOn + (GHC.xopt_set dynFlags ext) + [rhs | (lhs, True, rhs) <- GHC.impliedXFlags, lhs == ext] From 00800f043f90da92d30080673c8c215569e2085c Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Tue, 22 Feb 2022 18:35:08 +0100 Subject: [PATCH 20/32] Fix error message test that slightly changed --- tests/Language/Haskell/Stylish/Tests.hs | 22 +++++++++++++++------- 1 file changed, 15 insertions(+), 7 deletions(-) diff --git a/tests/Language/Haskell/Stylish/Tests.hs b/tests/Language/Haskell/Stylish/Tests.hs index b99e620a..271016a9 100644 --- a/tests/Language/Haskell/Stylish/Tests.hs +++ b/tests/Language/Haskell/Stylish/Tests.hs @@ -1,16 +1,18 @@ -------------------------------------------------------------------------------- +{-# LANGUAGE LambdaCase #-} module Language.Haskell.Stylish.Tests ( tests ) where -------------------------------------------------------------------------------- -import Data.List (sort) +import Data.List (isInfixOf, sort) import System.Directory (createDirectory) import System.FilePath (normalise, ()) import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit (Assertion, (@?=)) +import Test.HUnit (Assertion, assertFailure, + (@?=)) -------------------------------------------------------------------------------- @@ -93,15 +95,21 @@ case03 = withTestDirTree $ do , " }" ] + -------------------------------------------------------------------------------- case04 :: Assertion -case04 = (@?= result) =<< format Nothing (Just fileLocation) input +case04 = format Nothing (Just fileLocation) input >>= \case + Right _ -> assertFailure "expected error" + Left err + | fileLocation `isInfixOf` err + , needle `isInfixOf` err -> pure () + | otherwise -> + assertFailure $ "Unexpected error: " ++ show err where - fileLocation = "directory/File.hs" input = "module Herp" - result = Left $ - fileLocation <> ": RealSrcSpan SrcSpanPoint \"directory/File.hs\" 2 1:" - <> " parse error (possibly incorrect indentation or mismatched brackets)\n" + fileLocation = "directory/File.hs" + needle = "possibly incorrect indentation or mismatched brackets" + -------------------------------------------------------------------------------- -- | When providing current dir including folders and files. From 686c76a3550fb3a4a3a1c87c0ae6a9c39c2dd58b Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Tue, 22 Feb 2022 20:21:10 +0100 Subject: [PATCH 21/32] Support inline comments in ModuleHeader step --- lib/Language/Haskell/Stylish/Printer.hs | 6 ++++++ .../Haskell/Stylish/Step/ModuleHeader.hs | 12 ++++-------- .../Haskell/Stylish/Step/ModuleHeader/Tests.hs | 18 ++++++++++++++++++ 3 files changed, 28 insertions(+), 8 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Printer.hs b/lib/Language/Haskell/Stylish/Printer.hs index 2b4c01ae..ec7eb20c 100644 --- a/lib/Language/Haskell/Stylish/Printer.hs +++ b/lib/Language/Haskell/Stylish/Printer.hs @@ -29,6 +29,7 @@ module Language.Haskell.Stylish.Printer -- , peekNextCommentPos , prefix , putComment + , putMaybeLineComment -- , putEolComment , putOutputable -- , putAllSpanComments @@ -154,6 +155,11 @@ putComment epaComment = case GHC.ac_tok epaComment of GHC.EpaBlockComment s -> putText s GHC.EpaEofComment -> pure () +putMaybeLineComment :: Maybe GHC.EpaComment -> P () +putMaybeLineComment = \case + Nothing -> pure () + Just cmt -> space >> putComment cmt + -- | Given the current start line of 'SrcSpan', remove and put EOL comment for same line {- putEolComment :: SrcSpan -> P () diff --git a/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs b/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs index 44bf9c73..4a90a024 100644 --- a/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs +++ b/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs @@ -168,14 +168,9 @@ printHeader conf mbName mbExps _ mbModuleComment mbWhereComment = do attachModuleComment printMultiLineExportList conf exports - forM_ mbWhereComment $ \whereComment -> do - space - putComment $ GHC.unLoc whereComment - + putMaybeLineComment $ GHC.unLoc <$> mbWhereComment where - attachModuleComment = forM_ mbModuleComment $ \moduleComment -> do - space - putComment $ GHC.unLoc moduleComment + attachModuleComment = putMaybeLineComment $ GHC.unLoc <$> mbModuleComment attachOpenBracket | openBracket conf == SameLine = putText " (" @@ -211,12 +206,13 @@ printMultiLineExportList conf exports = do putComment $ GHC.unLoc cmt newline >> doIndent - forM_ (flagEnds cgItems) $ \((export, _), start, _end) -> do + forM_ (flagEnds cgItems) $ \((export, mbComment), start, _end) -> do if firstGroup && start then unless (null cgPrior) $ space >> space else comma >> space putExport conf export + putMaybeLineComment $ GHC.unLoc <$> mbComment newline >> doIndent firstChar = case openBracket conf of diff --git a/tests/Language/Haskell/Stylish/Step/ModuleHeader/Tests.hs b/tests/Language/Haskell/Stylish/Step/ModuleHeader/Tests.hs index a943fdfc..4cb69b6c 100644 --- a/tests/Language/Haskell/Stylish/Step/ModuleHeader/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/ModuleHeader/Tests.hs @@ -80,6 +80,7 @@ tests = testGroup "Language.Haskell.Stylish.Printer.ModuleHeader" , testCase "Single one export with comment" ex31 , testCase "Single one export with comment, open_bracket = same_line" ex31a , testCase "Single one module comment" ex32 + , testCase "Inline comments" ex33 ] -------------------------------------------------------------------------------- @@ -893,5 +894,22 @@ ex32 = assertSnippet (step Nothing $ defaultConfig {breakWhere = Single}) [ "module Foo (bar) where -- Foo" ] +ex33 :: Assertion +ex33 = assertSnippet (step Nothing $ defaultConfig) + [ "module Foo (" + , " -- Bar" + , " bar, -- Inline bar" + , " -- Foo" + , " foo -- Inline foo" + , ") where" + ] + [ "module Foo" + , " ( -- Bar" + , " bar -- Inline bar" + , " -- Foo" -- NOTE(jaspervdj): I would prefer to have the `,` here + , " , foo -- Inline foo" + , " ) where" + ] + openBracketSameLine :: Config -> Config openBracketSameLine cfg = cfg { openBracket = SameLine } From 36ffdff40cc56dd63d16656fdd4eed96f5ef7236 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Tue, 22 Feb 2022 20:55:32 +0100 Subject: [PATCH 22/32] Fix some issues with Cabal --- lib/Language/Haskell/Stylish/Config/Cabal.hs | 1 - stylish-haskell.cabal | 6 +++--- tests/Language/Haskell/Stylish/Config/Tests.hs | 2 +- 3 files changed, 4 insertions(+), 5 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Config/Cabal.hs b/lib/Language/Haskell/Stylish/Config/Cabal.hs index 0160af47..ab2f0124 100644 --- a/lib/Language/Haskell/Stylish/Config/Cabal.hs +++ b/lib/Language/Haskell/Stylish/Config/Cabal.hs @@ -11,7 +11,6 @@ import Data.Maybe (maybeToList) import qualified Distribution.PackageDescription as Cabal import qualified Distribution.PackageDescription.Parsec as Cabal import qualified Distribution.Simple.Utils as Cabal -import qualified Distribution.Types.CondTree as Cabal import qualified Distribution.Verbosity as Cabal import qualified Language.Haskell.Extension as Language import Language.Haskell.Stylish.Verbose diff --git a/stylish-haskell.cabal b/stylish-haskell.cabal index 303483d0..74ebbc14 100644 --- a/stylish-haskell.cabal +++ b/stylish-haskell.cabal @@ -65,7 +65,7 @@ Library aeson >= 0.6 && < 1.6, base >= 4.8 && < 5, bytestring >= 0.9 && < 0.11, - Cabal >= 2.4 && < 3.5, + Cabal >= 3.4 && < 3.7, containers >= 0.3 && < 0.7, directory >= 1.2.3 && < 1.4, filepath >= 1.1 && < 1.5, @@ -96,7 +96,7 @@ Executable stylish-haskell aeson >= 0.6 && < 1.6, base >= 4.8 && < 5, bytestring >= 0.9 && < 0.11, - Cabal >= 2.4 && < 3.5, + Cabal >= 3.4 && < 3.7, containers >= 0.3 && < 0.7, directory >= 1.2.3 && < 1.4, filepath >= 1.1 && < 1.5, @@ -170,7 +170,7 @@ Test-suite stylish-haskell-tests aeson >= 0.6 && < 1.6, base >= 4.8 && < 5, bytestring >= 0.9 && < 0.11, - Cabal >= 2.4 && < 3.5, + Cabal >= 3.4 && < 3.7, containers >= 0.3 && < 0.7, directory >= 1.2.3 && < 1.4, filepath >= 1.1 && < 1.5, diff --git a/tests/Language/Haskell/Stylish/Config/Tests.hs b/tests/Language/Haskell/Stylish/Config/Tests.hs index 3af6249c..90c4f0d4 100644 --- a/tests/Language/Haskell/Stylish/Config/Tests.hs +++ b/tests/Language/Haskell/Stylish/Config/Tests.hs @@ -137,7 +137,7 @@ dotCabal includeExtensions = unlines $ , "license: BSD3" , "author: Angela Author" , "build-type: Simple" - , "cabal-version: >= 1.2" + , "cabal-version: >= 1.10" , "" , "library" , " build-depends: HUnit" From 4af229321219eee1241b9cca91f748d817385f21 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sun, 6 Mar 2022 14:42:39 +0100 Subject: [PATCH 23/32] WIP: Port Data step --- lib/Language/Haskell/Stylish/Printer.hs | 7 +- lib/Language/Haskell/Stylish/Step/Data.hs | 609 +++++++++--------- .../Haskell/Stylish/Step/Data/Tests.hs | 309 ++++----- 3 files changed, 468 insertions(+), 457 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Printer.hs b/lib/Language/Haskell/Stylish/Printer.hs index ec7eb20c..41011d53 100644 --- a/lib/Language/Haskell/Stylish/Printer.hs +++ b/lib/Language/Haskell/Stylish/Printer.hs @@ -157,7 +157,7 @@ putComment epaComment = case GHC.ac_tok epaComment of putMaybeLineComment :: Maybe GHC.EpaComment -> P () putMaybeLineComment = \case - Nothing -> pure () + Nothing -> pure () Just cmt -> space >> putComment cmt -- | Given the current start line of 'SrcSpan', remove and put EOL comment for same line @@ -223,7 +223,10 @@ putType ltp = case GHC.unLoc ltp of GHC.HsFunTy _ arrowTp argTp funTp -> do putOutputable argTp space - putOutputable arrowTp + case arrowTp of + GHC.HsUnrestrictedArrow {} -> putText "->" + GHC.HsLinearArrow {} -> putText "%1 ->" + GHC.HsExplicitMult {} -> putOutputable arrowTp space putType funTp GHC.HsAppTy _ t1 t2 -> diff --git a/lib/Language/Haskell/Stylish/Step/Data.hs b/lib/Language/Haskell/Stylish/Step/Data.hs index 8827b7b5..d6536f2f 100644 --- a/lib/Language/Haskell/Stylish/Step/Data.hs +++ b/lib/Language/Haskell/Stylish/Step/Data.hs @@ -1,8 +1,11 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DoAndIfThenElse #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DoAndIfThenElse #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} module Language.Haskell.Stylish.Step.Data ( Config(..) , defaultConfig @@ -12,12 +15,29 @@ module Language.Haskell.Stylish.Step.Data , step ) where + -------------------------------------------------------------------------------- +import Control.Monad (forM_, unless, when) +import Data.List (sortBy) +import Data.Maybe (listToMaybe, maybeToList) +import Debug.Trace +import qualified GHC.Hs as GHC +import qualified GHC.Types.Fixity as GHC +import qualified GHC.Types.Name.Reader as GHC +import qualified GHC.Types.SrcLoc as GHC import Prelude hiding (init) + -------------------------------------------------------------------------------- +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 + +-------------------------------------------------------------------------------- data Indent = SameLine | Indent !Int @@ -66,214 +86,211 @@ defaultConfig = Config } step :: Config -> Step -step _cfg = makeStep "Data" \ls _ -> ls - -{- -step cfg = makeStep "Data" \ls m -> applyChanges (changes m) ls +step cfg = makeStep "Data" \ls m -> + let ls' = applyChanges (changes m) ls + in ls -- TODO: ls' where changes :: Module -> [ChangeLine] - changes m = fmap (formatDataDecl cfg m) (dataDecls m) - - dataDecls :: Module -> [Located DataDecl] - dataDecls = queryModule \case - L pos (TyClD _ (DataDecl _ name tvars fixity defn)) -> pure . L pos $ MkDataDecl - { dataDeclName = name - , dataTypeVars = tvars - , dataDefn = defn - , dataFixity = fixity - } - _ -> [] + changes m = formatDataDecl cfg m <$> dataDecls m + + dataDecls :: Module -> [DataDecl] + dataDecls m = do + ldecl <- GHC.hsmodDecls $ GHC.unLoc m + GHC.TyClD _ tycld <- pure $ GHC.unLoc ldecl + loc <- maybeToList $ GHC.srcSpanToRealSrcSpan $ GHC.getLocA ldecl + case tycld of + GHC.DataDecl {..} -> pure $ MkDataDecl + { dataLoc = loc + , dataDeclName = tcdLName + , dataTypeVars = tcdTyVars + , dataDefn = tcdDataDefn + , dataFixity = tcdFixity + } + _ -> [] type ChangeLine = Change String -formatDataDecl :: Config -> Module -> Located DataDecl -> ChangeLine -formatDataDecl cfg@Config{..} m ldecl@(L declPos decl) = - change originalDeclBlock (const printedDecl) +data DataDecl = MkDataDecl + { dataLoc :: GHC.RealSrcSpan + , dataDeclName :: GHC.LocatedN GHC.RdrName + , dataTypeVars :: GHC.LHsQTyVars GHC.GhcPs + , dataDefn :: GHC.HsDataDefn GHC.GhcPs + , dataFixity :: GHC.LexicalFixity + } + + +formatDataDecl :: Config -> Module -> DataDecl -> ChangeLine +formatDataDecl cfg@Config{..} m decl@MkDataDecl {..} = + change originalDeclBlock (const printedDecl) where + {- relevantComments :: [RealLocated AnnotationComment] relevantComments = moduleComments m & rawComments & dropBeforeAndAfter ldecl + -} - defn = dataDefn decl - - originalDeclBlock = - Block (getStartLineUnsafe ldecl) (getEndLineUnsafe ldecl) + originalDeclBlock = Block + (GHC.srcSpanStartLine dataLoc) + (GHC.srcSpanEndLine dataLoc) printerConfig = PrinterConfig - { columns = case cMaxColumns of - NoMaxColumns -> Nothing - MaxColumns n -> Just n - } + { columns = case cMaxColumns of + NoMaxColumns -> Nothing + MaxColumns n -> Just n + } + + printedDecl = runPrinter_ printerConfig $ putDataDecl cfg decl - printedDecl = runPrinter_ printerConfig relevantComments m do - putText (newOrData decl) - space - putName decl +putDataDecl :: Config -> DataDecl -> P () +putDataDecl cfg@Config {..} decl = do + let defn = dataDefn decl + putText $ newOrData decl + space + putName decl - when (isGADT decl) (space >> putText "where") + when (isGADT decl) (space >> putText "where") - when (hasConstructors decl) do + when (hasConstructors decl) do 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 -> - False <$ space - (Indent x, _) - | isEnum decl && not cBreakEnums -> False <$ space - | otherwise -> do - putEolComment declPos - newline >> spaces x - pure True - (SameLine, _) -> False <$ space + (_, Indent x) | isEnum decl && cBreakEnums -> do + -- putEolComment declPos + newline >> spaces x + pure True + (_, _) + | not (isNewtype decl) + , singleConstructor decl && not cBreakSingleConstructors -> + False <$ space + (Indent x, _) + | isEnum decl && not cBreakEnums -> False <$ space + | otherwise -> do + -- putEolComment declPos + newline >> spaces x + pure True + (SameLine, _) -> False <$ space + pure () lineLengthAfterEq <- fmap (+2) getCurrentLineLength + if | isEnum decl && not cBreakEnums -> + putText "=" >> space >> putUnbrokenEnum cfg decl + | isNewtype decl -> do + putText "=" >> space + forM_ (GHC.dd_cons defn) $ putNewtypeConstructor cfg + | lcon : lcons <- GHC.dd_cons defn -> do + -- when breakLineBeforeEq do + -- removeCommentTo pos >>= mapM_ \c -> putComment c >> consIndent lineLengthAfterEq + unless (isGADT decl) (putText "=" >> space) + putConstructor cfg lineLengthAfterEq lcon + forM_ lcons $ \con -> do + -- unless (cFirstField == SameLine) do + -- removeCommentTo conPos >>= mapM_ \c -> consIndent lineLengthAfterEq >> putComment c + consIndent lineLengthAfterEq + + unless (isGADT decl) (putText "|" >> space) + + putConstructor cfg lineLengthAfterEq con + -- putEolComment conPos + | otherwise -> + pure () + + when (hasDeriving decl) do if isEnum decl && not cBreakEnums then - putText "=" >> space >> putUnbrokenEnum cfg decl - else if isNewtype decl then - putText "=" >> space >> forM_ (dd_cons defn) (putNewtypeConstructor cfg) - else - case dd_cons defn of - [] -> pure () - lcon@(L pos _) : consRest -> do - when breakLineBeforeEq do - removeCommentTo pos >>= mapM_ \c -> putComment c >> consIndent lineLengthAfterEq - - 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 - - unless - (isGADT decl) - (putText "|" >> space) - - putConstructor cfg lineLengthAfterEq con - putEolComment conPos - - when (hasDeriving decl) do - if isEnum decl && not cBreakEnums then space - else do - removeCommentTo (defn & dd_derivs & \(L pos _) -> pos) >>= - mapM_ \c -> newline >> spaces cDeriving >> putComment c + else do + -- removeCommentTo (defn & dd_derivs & \(L pos _) -> pos) >>= + -- mapM_ \c -> newline >> spaces cDeriving >> putComment c newline spaces cDeriving - sep (newline >> spaces cDeriving) $ defn & dd_derivs & \(L pos ds) -> ds <&> \d -> do - putAllSpanComments (newline >> spaces cDeriving) pos - putDeriving cfg d - + sep (newline >> spaces cDeriving) $ map + (\d -> do + -- putAllSpanComments (newline >> spaces cDeriving) pos + putDeriving cfg d) + (GHC.dd_derivs defn) + where consIndent eqIndent = newline >> case (cEquals, cFirstField) of - (SameLine, SameLine) -> spaces (eqIndent - 2) - (SameLine, Indent y) -> spaces (eqIndent + y - 4) - (Indent x, Indent _) -> spaces x - (Indent x, SameLine) -> spaces x + (SameLine, SameLine) -> spaces (eqIndent - 2) + (SameLine, Indent y) -> spaces (eqIndent + y - 4) + (Indent x, Indent _) -> spaces x + (Indent x, SameLine) -> spaces x + +putDeriving :: Config -> GHC.LHsDerivingClause GHC.GhcPs -> P () +putDeriving Config{..} lclause = do + let GHC.HsDerivingClause {..} = GHC.unLoc lclause + tys = (if cSortDeriving then sortBy compareOutputableCI else id) $ + map (GHC.sig_body . GHC.unLoc) $ + case GHC.unLoc deriv_clause_tys of + GHC.DctSingle _ t -> [t] + GHC.DctMulti _ ts -> ts + headTy = listToMaybe tys + tailTy = drop 1 tys + + putText "deriving" + + forM_ deriv_clause_strategy $ \lstrat -> case GHC.unLoc lstrat of + GHC.StockStrategy {} -> space >> putText "stock" + GHC.AnyclassStrategy {} -> space >> putText "anyclass" + GHC.NewtypeStrategy {} -> space >> putText "newtype" + GHC.ViaStrategy {} -> pure () + + putCond + withinColumns + do + space + putText "(" + sep + (comma >> space) + (fmap putOutputable tys) + putText ")" + do + newline + spaces indentation + putText "(" -data DataDecl = MkDataDecl - { dataDeclName :: Located RdrName - , dataTypeVars :: LHsQTyVars GhcPs - , dataDefn :: HsDataDefn GhcPs - , dataFixity :: LexicalFixity - } - -putDeriving :: Config -> Located (HsDerivingClause GhcPs) -> P () -putDeriving Config{..} (L pos clause) = do - putText "deriving" - - forM_ (deriv_clause_strategy clause) \case - L _ StockStrategy -> space >> putText "stock" - L _ AnyclassStrategy -> space >> putText "anyclass" - L _ NewtypeStrategy -> space >> putText "newtype" - L _ (ViaStrategy _) -> pure () - - putCond - withinColumns - oneLinePrint - multilinePrint - - forM_ (deriv_clause_strategy clause) \case - L _ (ViaStrategy tp) -> do - case cVia of - SameLine -> space - Indent x -> newline >> spaces (x + cDeriving) - - putText "via" - space - putType (getType tp) - _ -> pure () - - putEolComment pos + forM_ headTy \t -> + space >> putOutputable t - where - getType = \case - HsIB _ tp -> tp - XHsImplicitBndrs x -> noExtCon x + forM_ tailTy \t -> do + newline + spaces indentation + comma + space + putOutputable t + newline + spaces indentation + putText ")" + + forM_ deriv_clause_strategy $ \lstrat -> case GHC.unLoc lstrat of + GHC.ViaStrategy tp -> do + case cVia of + SameLine -> space + Indent x -> newline >> spaces (x + cDeriving) + + putText "via" + space + putType $ case tp of + GHC.XViaStrategyPs _ ty -> GHC.sig_body $ GHC.unLoc ty + _ -> pure () + + -- putEolComment pos + where 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 - & (if cSortDeriving then sortBy compareOutputableCI else id) - & fmap hsib_body - - headTy = - listToMaybe tys - - tailTy = - drop 1 tys - putUnbrokenEnum :: Config -> DataDecl -> P () -putUnbrokenEnum cfg decl = - sep +putUnbrokenEnum cfg decl = sep (space >> putText "|" >> space) - (fmap (putConstructor cfg 0) . dd_cons . dataDefn $ decl) + (fmap (putConstructor cfg 0) . GHC.dd_cons . dataDefn $ decl) putName :: DataDecl -> P () putName decl@MkDataDecl{..} = @@ -285,47 +302,29 @@ putName decl@MkDataDecl{..} = maybePutKindSig else do putRdrName dataDeclName - forM_ (hsq_explicit dataTypeVars) (\t -> space >> putOutputable t) + forM_ (GHC.hsq_explicit dataTypeVars) (\t -> space >> putOutputable t) maybePutKindSig where - firstTvar :: Maybe (Located (HsTyVarBndr GhcPs)) - firstTvar - = dataTypeVars - & hsq_explicit - & listToMaybe - - secondTvar :: Maybe (Located (HsTyVarBndr GhcPs)) - secondTvar - = dataTypeVars - & hsq_explicit - & drop 1 - & listToMaybe + firstTvar :: Maybe (GHC.LHsTyVarBndr () GHC.GhcPs) + firstTvar = listToMaybe $ GHC.hsq_explicit dataTypeVars + + secondTvar :: Maybe (GHC.LHsTyVarBndr () GHC.GhcPs) + secondTvar = listToMaybe . drop 1 $ GHC.hsq_explicit dataTypeVars maybePutKindSig :: Printer () maybePutKindSig = forM_ maybeKindSig (\k -> space >> putText "::" >> space >> putOutputable k) - maybeKindSig :: Maybe (LHsKind GhcPs) - maybeKindSig = dd_kindSig dataDefn + maybeKindSig :: Maybe (GHC.LHsKind GHC.GhcPs) + maybeKindSig = GHC.dd_kindSig dataDefn -putConstructor :: Config -> Int -> Located (ConDecl GhcPs) -> P () -putConstructor cfg consIndent (L _ cons) = case cons of - ConDeclGADT{..} -> do +putConstructor :: Config -> Int -> GHC.LConDecl GHC.GhcPs -> P () +putConstructor cfg consIndent lcons = case GHC.unLoc lcons of + GHC.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 $ + case con_g_args of + GHC.PrefixConGADT _ -> sep (comma >> space) $ fmap putRdrName con_names + GHC.RecConGADT _ -> error . mconcat $ [ "Language.Haskell.Stylish.Step.Data.putConstructor: " , "encountered a GADT with record constructors, not supported yet" ] @@ -335,27 +334,39 @@ putConstructor cfg consIndent (L _ cons) = case cons of putText "::" space - putForAll con_forall $ hsq_explicit con_qvars - forM_ con_mb_cxt (putContext cfg . unLocated) + putForAll + (case GHC.unLoc con_bndrs of + GHC.HsOuterImplicit {} -> False + GHC.HsOuterExplicit {} -> True) + (case GHC.unLoc con_bndrs of + GHC.HsOuterImplicit {..} -> [] + GHC.HsOuterExplicit {..} -> hso_bndrs) + forM_ con_mb_cxt $ putContext cfg + case con_g_args of + GHC.PrefixConGADT scaledTys -> forM_ scaledTys $ \scaledTy -> do + putType $ GHC.hsScaledThing scaledTy + space >> putText "->" >> space + GHC.RecConGADT _ -> error . mconcat $ + [ "Language.Haskell.Stylish.Step.Data.putConstructor: " + , "encountered a GADT with record constructors, not supported yet" + ] putType con_res_ty - XConDecl x -> - noExtCon x - ConDeclH98{..} -> do + GHC.ConDeclH98 {..} -> do putForAll con_forall con_ex_tvs - forM_ con_mb_cxt (putContext cfg . unLocated) + forM_ con_mb_cxt $ putContext cfg case con_args of - InfixCon arg1 arg2 -> do - putType arg1 + GHC.InfixCon arg1 arg2 -> do + putType $ GHC.hsScaledThing arg1 space putRdrName con_name space - putType arg2 - PrefixCon xs -> do + putType $ GHC.hsScaledThing arg2 + GHC.PrefixCon tyargs args -> do putRdrName con_name - unless (null xs) space - sep space (fmap putOutputable xs) - RecCon (L recPos (L posFirst firstArg : args)) -> do + unless (null args) space + sep space (fmap putOutputable args) + GHC.RecCon largs | firstArg : args <- GHC.unLoc largs -> do putRdrName con_name skipToBrace bracePos <- getCurrentLineLength @@ -365,30 +376,30 @@ putConstructor cfg consIndent (L _ cons) = case cons of -- 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 + -- unless (cFirstField cfg == SameLine) do + -- removeCommentTo posFirst >>= mapM_ \c -> putComment c >> sepDecl bracePos -- Put first decl field - pad fieldPos >> putConDeclField cfg firstArg - unless (cFirstField cfg == SameLine) (putEolComment posFirst) + pad fieldPos >> putConDeclField cfg (GHC.unLoc firstArg) + -- unless (cFirstField cfg == SameLine) (putEolComment posFirst) -- Put tail decl fields - forM_ args \(L pos arg) -> do + forM_ (GHC.unLoc <$> args) $ \arg -> do sepDecl bracePos - removeCommentTo pos >>= mapM_ \c -> - spaces (cFieldComment cfg) >> putComment c >> sepDecl bracePos + -- removeCommentTo pos >>= mapM_ \c -> + -- spaces (cFieldComment cfg) >> putComment c >> sepDecl bracePos comma space putConDeclField cfg arg - putEolComment pos + -- putEolComment pos -- Print docstr after final field - removeCommentToEnd recPos >>= mapM_ \c -> - sepDecl bracePos >> spaces (cFieldComment cfg) >> putComment c + -- removeCommentToEnd recPos >>= mapM_ \c -> + -- sepDecl bracePos >> spaces (cFieldComment cfg) >> putComment c -- Print whitespace to closing brace sepDecl bracePos >> putText "}" - RecCon (L _ []) -> do + GHC.RecCon _ -> do skipToBrace >> putText "{" skipToBrace >> putText "}" @@ -404,128 +415,124 @@ putConstructor cfg consIndent (L _ cons) = case cons of -- Jump to the next declaration. sepDecl bracePos = newline >> spaces case (cEquals cfg, cFirstField cfg) of (_, Indent y) | not (cBreakSingleConstructors cfg) -> y - (SameLine, SameLine) -> bracePos - (Indent x, Indent y) -> x + y + 2 - (SameLine, Indent y) -> bracePos + y - 2 - (Indent x, SameLine) -> bracePos + x - 2 - -putNewtypeConstructor :: Config -> Located (ConDecl GhcPs) -> P () -putNewtypeConstructor cfg (L _ cons) = case cons of - ConDeclH98{..} -> + (SameLine, SameLine) -> bracePos + (Indent x, Indent y) -> x + y + 2 + (SameLine, Indent y) -> bracePos + y - 2 + (Indent x, SameLine) -> bracePos + x - 2 + +putNewtypeConstructor :: Config -> GHC.LConDecl GHC.GhcPs -> P () +putNewtypeConstructor cfg lcons = case GHC.unLoc lcons of + GHC.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 + GHC.PrefixCon _ args -> do + unless (null args) space + sep space (fmap putOutputable args) + GHC.RecCon largs | [firstArg] <- GHC.unLoc largs -> do space putText "{" space - putConDeclField cfg firstArg + putConDeclField cfg $ GHC.unLoc firstArg space putText "}" - RecCon (L _ _args) -> + GHC.RecCon largs -> error . mconcat $ [ "Language.Haskell.Stylish.Step.Data.putNewtypeConstructor: " , "encountered newtype with several arguments" ] - InfixCon {} -> + GHC.InfixCon {} -> error . mconcat $ [ "Language.Haskell.Stylish.Step.Data.putNewtypeConstructor: " , "infix newtype constructor" ] - XConDecl x -> - noExtCon x - ConDeclGADT{} -> + GHC.ConDeclGADT{} -> error . mconcat $ [ "Language.Haskell.Stylish.Step.Data.putNewtypeConstructor: " , "GADT encountered in newtype" ] -putForAll :: Located Bool -> [Located (HsTyVarBndr GhcPs)] -> P () -putForAll forall ex_tvs = - when (unLocated forall) do +putForAll + :: GHC.OutputableBndrFlag s 'GHC.Parsed + => Bool -> [GHC.LHsTyVarBndr s GHC.GhcPs] -> P () +putForAll forall ex_tvs = when forall do putText "forall" space - sep space (fmap putOutputable ex_tvs) + sep space $ putOutputable . GHC.unLoc <$> ex_tvs dot space -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 +putContext :: Config -> GHC.LHsContext GHC.GhcPs -> P () +putContext Config{..} lctx = suffix (space >> putText "=>" >> space) $ + case ltys of + [lty] | GHC.HsParTy _ tp <- GHC.unLoc lty, cCurriedContext -> + putType tp + [ctx] -> + putType ctx + ctxs | cCurriedContext -> + sep (space >> putText "=>" >> space) (fmap putType ctxs) + ctxs -> + parenthesize $ sep (comma >> space) (fmap putType ctxs) + where + ltys = GHC.unLoc lctx :: [GHC.LHsType GHC.GhcPs] + +putConDeclField :: Config -> GHC.ConDeclField GHC.GhcPs -> P () +putConDeclField cfg GHC.ConDeclField {..} = do sep - (comma >> space) - (fmap putOutputable cd_fld_names) + (comma >> space) + (fmap putOutputable cd_fld_names) space putText "::" space 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 +putType' :: Config -> GHC.LHsType GHC.GhcPs -> P () +putType' cfg lty = case GHC.unLoc lty of + GHC.HsForAllTy GHC.NoExtField tele tp -> do + putText "forall" + space + sep space $ case tele of + GHC.HsForAllVis {..} -> putOutputable . GHC.unLoc <$> hsf_vis_bndrs + GHC.HsForAllInvis {..} -> putOutputable . GHC.unLoc <$> hsf_invis_bndrs + case tele of + GHC.HsForAllVis {} -> space >> putText "->" + GHC.HsForAllInvis {} -> putText "." + space + putType' cfg tp + GHC.HsQualTy GHC.NoExtField ctx tp -> do + forM_ ctx $ putContext cfg + putType' cfg tp + _ -> putType lty newOrData :: DataDecl -> String newOrData decl = if isNewtype decl then "newtype" else "data" isGADT :: DataDecl -> Bool -isGADT = any isGADTCons . dd_cons . dataDefn +isGADT = any isGADTCons . GHC.dd_cons . dataDefn where - isGADTCons = \case - L _ (ConDeclGADT {}) -> True - _ -> False + isGADTCons c = case GHC.unLoc c of + GHC.ConDeclGADT {} -> True + _ -> False isNewtype :: DataDecl -> Bool -isNewtype = (== NewType) . dd_ND . dataDefn +isNewtype = (== GHC.NewType) . GHC.dd_ND . dataDefn isInfix :: DataDecl -> Bool -isInfix = (== Infix) . dataFixity +isInfix = (== GHC.Infix) . dataFixity isEnum :: DataDecl -> Bool -isEnum = all isUnary . dd_cons . dataDefn +isEnum = all isUnary . GHC.dd_cons . dataDefn where - isUnary = \case - L _ (ConDeclH98 {..}) -> case con_args of - PrefixCon [] -> True - _ -> False + isUnary c = case GHC.unLoc c of + GHC.ConDeclH98 {..} -> case con_args of + GHC.PrefixCon tyargs args -> null tyargs && null args + _ -> False _ -> False hasConstructors :: DataDecl -> Bool -hasConstructors = not . null . dd_cons . dataDefn +hasConstructors = not . null . GHC.dd_cons . dataDefn singleConstructor :: DataDecl -> Bool -singleConstructor = (== 1) . length . dd_cons . dataDefn +singleConstructor = (== 1) . length . GHC.dd_cons . dataDefn hasDeriving :: DataDecl -> Bool -hasDeriving = not . null . unLocated . dd_derivs . dataDefn - --} +hasDeriving = not . null . GHC.dd_derivs . dataDefn diff --git a/tests/Language/Haskell/Stylish/Step/Data/Tests.hs b/tests/Language/Haskell/Stylish/Step/Data/Tests.hs index d4c599c7..1d14426b 100644 --- a/tests/Language/Haskell/Stylish/Step/Data/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Data/Tests.hs @@ -5,10 +5,10 @@ module Language.Haskell.Stylish.Step.Data.Tests ) where import Language.Haskell.Stylish.Step.Data -import Language.Haskell.Stylish.Tests.Util (assertSnippet, testStep) +import Language.Haskell.Stylish.Tests.Util (assertSnippet) import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit (Assertion, (@=?)) +import Test.HUnit (Assertion) tests :: Test tests = testGroup "Language.Haskell.Stylish.Step.Data.Tests" @@ -79,9 +79,9 @@ tests = testGroup "Language.Haskell.Stylish.Step.Data.Tests" ] case00 :: Assertion -case00 = expected @=? testStep (step sameSameStyle) input +case00 = assertSnippet (step sameSameStyle) input expected where - input = unlines + input = [ "module Herp where" , "" , "data Foo" @@ -90,15 +90,15 @@ case00 = expected @=? testStep (step sameSameStyle) input expected = input case01 :: Assertion -case01 = expected @=? testStep (step indentIndentStyle) input +case01 = assertSnippet (step indentIndentStyle) input expected where - input = unlines + input = [ "module Herp where" , "" , "data Foo = Foo { a :: Int }" ] - expected = unlines + expected = [ "module Herp where" , "" , "data Foo" @@ -108,14 +108,15 @@ case01 = expected @=? testStep (step indentIndentStyle) input ] case02 :: Assertion -case02 = expected @=? testStep (step indentIndentStyle) input +case02 = assertSnippet (step indentIndentStyle) input expected where - input = unlines + input = [ "module Herp where" , "" , "data Foo = Foo { a :: Int, a2 :: String }" ] - expected = unlines + + expected = [ "module Herp where" , "" , "data Foo" @@ -126,14 +127,14 @@ case02 = expected @=? testStep (step indentIndentStyle) input ] case03 :: Assertion -case03 = expected @=? testStep (step indentIndentStyle) input +case03 = assertSnippet (step indentIndentStyle) input expected where - input = unlines + input = [ "module Herp where" , "" , "data Foo a = Foo { a :: a, a2 :: String }" ] - expected = unlines + expected = [ "module Herp where" , "" , "data Foo a" @@ -144,14 +145,14 @@ case03 = expected @=? testStep (step indentIndentStyle) input ] case04 :: Assertion -case04 = expected @=? testStep (step indentIndentStyle) input +case04 = assertSnippet (step indentIndentStyle) input expected where - input = unlines + input = [ "module Herp where" , "" , "data Foo a = Foo { a :: a, a2 :: String } | Bar { b :: a }" ] - expected = unlines + expected = [ "module Herp where" , "" , "data Foo a" @@ -165,9 +166,9 @@ case04 = expected @=? testStep (step indentIndentStyle) input ] case05 :: Assertion -case05 = expected @=? testStep (step indentIndentStyle) input +case05 = assertSnippet (step indentIndentStyle) input expected where - input = unlines + input = [ "module Herp where" , "" , "data Foo = Foo {" @@ -175,7 +176,7 @@ case05 = expected @=? testStep (step indentIndentStyle) input , " , a2 :: String" , " }" ] - expected = unlines + expected = [ "module Herp where" , "" , "data Foo" @@ -186,9 +187,9 @@ case05 = expected @=? testStep (step indentIndentStyle) input ] case06 :: Assertion -case06 = expected @=? testStep (step sameSameStyle) input +case06 = assertSnippet (step sameSameStyle) input expected where - input = unlines + input = [ "module Herp where" , "" , "data Foo = Foo Int String" @@ -196,9 +197,9 @@ case06 = expected @=? testStep (step sameSameStyle) input expected = input case07 :: Assertion -case07 = expected @=? testStep (step sameSameStyle) input +case07 = assertSnippet (step sameSameStyle) input expected where - input = unlines + input = [ "module Herp where" , "" , "data Phantom a = Phantom" @@ -206,29 +207,29 @@ case07 = expected @=? testStep (step sameSameStyle) input expected = input case08 :: Assertion -case08 = expected @=? testStep (step sameSameStyle) input +case08 = assertSnippet (step sameSameStyle) input expected where - input = unlines + input = [ "module Herp where" , "" , "data Phantom a =" , " Phantom" ] - expected = unlines + expected = [ "module Herp where" , "" , "data Phantom a = Phantom" ] case09 :: Assertion -case09 = expected @=? testStep (step indentIndentStyle4) input +case09 = assertSnippet (step indentIndentStyle4) input expected where - input = unlines + input = [ "module Herp where" , "" , "data Foo a b = Foo { a :: a, a2 :: String } | Bar { b :: a, c:: b }" ] - expected = unlines + expected = [ "module Herp where" , "" , "data Foo a b" @@ -243,15 +244,15 @@ case09 = expected @=? testStep (step indentIndentStyle4) input ] case10 :: Assertion -case10 = expected @=? testStep (step indentIndentStyle) input +case10 = assertSnippet (step indentIndentStyle) input expected where - input = unlines + input = [ "module Herp where" , "" , "data Foo = Foo { a :: Int } deriving (Eq, Generic) deriving (Show)" ] - expected = unlines + expected = [ "module Herp where" , "" , "data Foo" @@ -263,16 +264,16 @@ case10 = expected @=? testStep (step indentIndentStyle) input ] case11 :: Assertion -case11 = expected @=? testStep (step indentIndentStyle) input +case11 = assertSnippet (step indentIndentStyle) input expected where - input = unlines + input = [ "{-# LANGUAGE DerivingStrategies #-}" , "module Herp where" , "" , "data Foo = Foo { a :: Int } deriving stock (Show)" ] - expected = unlines + expected = [ "{-# LANGUAGE DerivingStrategies #-}" , "module Herp where" , "" @@ -284,15 +285,15 @@ case11 = expected @=? testStep (step indentIndentStyle) input ] case12 :: Assertion -case12 = expected @=? testStep (step indentIndentStyle4) input +case12 = assertSnippet (step indentIndentStyle4) input expected where - input = unlines + input = [ "module Herp where" , "" , "data Point = Point { pointX, pointY :: Double , pointName :: String} deriving (Show)" ] - expected = unlines + expected = [ "module Herp where" , "" , "data Point" @@ -304,15 +305,15 @@ case12 = expected @=? testStep (step indentIndentStyle4) input ] case13 :: Assertion -case13 = expected @=? testStep (step indentIndentStyle) input +case13 = assertSnippet (step indentIndentStyle) input expected where - input = unlines + input = [ "module Herp where" , "" , "-- this is a comment" , "data Foo = Foo { a :: Int }" ] - expected = unlines + expected = [ "module Herp where" , "" , "-- this is a comment" @@ -323,16 +324,16 @@ case13 = expected @=? testStep (step indentIndentStyle) input ] case14 :: Assertion -case14 = expected @=? testStep (step indentIndentStyle) input +case14 = assertSnippet (step indentIndentStyle) input expected where - input = unlines + input = [ "module Herp where" , "" , "{- this is" , " a comment -}" , "data Foo = Foo { a :: Int }" ] - expected = unlines + expected = [ "module Herp where" , "" , "{- this is" @@ -344,9 +345,9 @@ case14 = expected @=? testStep (step indentIndentStyle) input ] case15 :: Assertion -case15 = expected @=? testStep (step indentIndentStyle) input +case15 = assertSnippet (step indentIndentStyle) input expected where - input = unlines + input = [ "module Herp where" , "" , "data Foo a = Foo" @@ -354,7 +355,7 @@ case15 = expected @=? testStep (step indentIndentStyle) input , " a2 :: String" , " }" ] - expected = unlines + expected = [ "module Herp where" , "" , "data Foo a" @@ -365,16 +366,16 @@ case15 = expected @=? testStep (step indentIndentStyle) input ] case16 :: Assertion -case16 = expected @=? testStep (step indentIndentStyle) input +case16 = assertSnippet (step indentIndentStyle) input expected where - input = unlines + input = [ "module Herp where" , "" , "data Foo = Foo {" , " a :: Int -- ^ comment" , " }" ] - expected = unlines + expected = [ "module Herp where" , "" , "data Foo" @@ -385,9 +386,9 @@ case16 = expected @=? testStep (step indentIndentStyle) input ] case17 :: Assertion -case17 = expected @=? testStep (step indentIndentStyle) input +case17 = assertSnippet (step indentIndentStyle) input expected where - input = unlines + input = [ "module Herp where" , "" , "data Foo a = Foo" @@ -396,7 +397,7 @@ case17 = expected @=? testStep (step indentIndentStyle) input , " a2 :: String" , " }" ] - expected = unlines + expected = [ "module Herp where" , "" , "data Foo a" @@ -408,9 +409,9 @@ case17 = expected @=? testStep (step indentIndentStyle) input ] case18 :: Assertion -case18 = expected @=? testStep (step indentIndentStyle) input +case18 = assertSnippet (step indentIndentStyle) input expected where - input = unlines + input = [ "module Herp where" , "" , "data Foo a = Foo" @@ -419,7 +420,7 @@ case18 = expected @=? testStep (step indentIndentStyle) input , " a2 :: String" , " }" ] - expected = unlines + expected = [ "module Herp where" , "" , "data Foo a" @@ -431,9 +432,9 @@ case18 = expected @=? testStep (step indentIndentStyle) input ] case19 :: Assertion -case19 = expected @=? testStep (step indentIndentStyle) input +case19 = assertSnippet (step indentIndentStyle) input expected where - input = unlines + input = [ "module Herp where" , "" , "data Foo a = Foo" @@ -442,7 +443,7 @@ case19 = expected @=? testStep (step indentIndentStyle) input , " age :: Int" , " }" ] - expected = unlines + expected = [ "module Herp where" , "" , "data Foo a" @@ -457,9 +458,9 @@ case19 = expected @=? testStep (step indentIndentStyle) input -- -- See https://github.com/haskell/stylish-haskell/issues/262 case20 :: Assertion -case20 = input @=? testStep (step indentIndentStyle) input +case20 = assertSnippet (step indentIndentStyle) input input where - input = unlines + input = [ "module Herp where" , "" , "data Tag = Title | Text deriving (Eq, Show)" @@ -529,9 +530,9 @@ case23 = assertSnippet (step indentSameStyle) ] case24 :: Assertion -case24 = expected @=? testStep (step indentIndentStyle) input +case24 = assertSnippet (step indentIndentStyle) input expected where - input = unlines + input = [ "data Foo a" , " = Foo { a :: Int," , " a2 :: String" @@ -541,7 +542,7 @@ case24 = expected @=? testStep (step indentIndentStyle) input , " deriving (ToJSON)" ] - expected = unlines + expected = [ "data Foo a" , " = Foo" , " { a :: Int" @@ -556,9 +557,9 @@ case24 = expected @=? testStep (step indentIndentStyle) input ] case25 :: Assertion -case25 = expected @=? testStep (step indentIndentStyle { cBreakSingleConstructors = False }) input +case25 = assertSnippet (step indentIndentStyle { cBreakSingleConstructors = False }) input expected where - input = unlines + input = [ "data Foo a" , " = Foo { a :: Int," , " a2 :: String" @@ -568,7 +569,7 @@ case25 = expected @=? testStep (step indentIndentStyle { cBreakSingleConstructor , " deriving (ToJSON)" ] - expected = unlines + expected = [ "data Foo a = Foo" , " { a :: Int" , " , a2 :: String" @@ -579,15 +580,15 @@ case25 = expected @=? testStep (step indentIndentStyle { cBreakSingleConstructor ] case26 :: Assertion -case26 = expected @=? testStep (step indentIndentStyle) input +case26 = assertSnippet (step indentIndentStyle) input expected where - input = unlines + input = [ "module Herp where" , "" , "data Foo = Foo { a :: Int } deriving (FromJSON) via Bla Foo" ] - expected = unlines + expected = [ "module Herp where" , "" , "data Foo" @@ -598,15 +599,15 @@ case26 = expected @=? testStep (step indentIndentStyle) input ] case27 :: Assertion -case27 = expected @=? testStep (step sameIndentStyle { cBreakEnums = True }) input +case27 = assertSnippet (step sameIndentStyle { cBreakEnums = True }) input expected where - input = unlines + input = [ "module Herp where" , "" , "data Foo = Foo | Bar | Baz deriving (Eq, Show)" ] - expected = unlines + expected = [ "module Herp where" , "" , "data Foo" @@ -617,9 +618,9 @@ case27 = expected @=? testStep (step sameIndentStyle { cBreakEnums = True }) inp ] case28 :: Assertion -case28 = expected @=? testStep (step sameIndentStyle { cBreakEnums = True }) input +case28 = assertSnippet (step sameIndentStyle { cBreakEnums = True }) input expected where - input = unlines + input = [ "module Some.Types where" , "" , "newtype BankCode = BankCode {" @@ -645,7 +646,7 @@ case28 = expected @=? testStep (step sameIndentStyle { cBreakEnums = True }) inp , " deriving (ToJSON, FromJSON) via SnakeCaseCapsEnumEncoding MandateStatus" ] - expected = unlines + expected = [ "module Some.Types where" , "" , "newtype BankCode = BankCode { unBankCode :: Text }" @@ -670,26 +671,26 @@ case28 = expected @=? testStep (step sameIndentStyle { cBreakEnums = True }) inp ] case29 :: Assertion -case29 = expected @=? testStep (step sameIndentStyle) input +case29 = assertSnippet (step sameIndentStyle) input expected where - input = unlines + input = [ "module Some.Types where" , "" , "data NonEmpty a" , " = a :| [a]" ] - expected = unlines + expected = [ "module Some.Types where" , "" , "data NonEmpty a = a :| [a]" ] case30 :: Assertion -case30 = expected @=? testStep (step sameIndentStyle { cBreakEnums = True }) input +case30 = assertSnippet (step sameIndentStyle { cBreakEnums = True }) input expected where expected = input - input = unlines + input = [ "data ReasonCode" , " = MissingTenantId" , " -- Transaction errors:" @@ -710,10 +711,10 @@ case30 = expected @=? testStep (step sameIndentStyle { cBreakEnums = True }) inp case31 :: Assertion -case31 = expected @=? testStep (step indentIndentStyle { cBreakEnums = True }) input +case31 = assertSnippet (step indentIndentStyle { cBreakEnums = True }) input expected where expected = input - input = unlines + input = [ "data ConfiguredLogger" , " -- | Logs to file" , " = LogTo FilePath" @@ -725,10 +726,10 @@ case31 = expected @=? testStep (step indentIndentStyle { cBreakEnums = True }) i ] case32 :: Assertion -case32 = expected @=? testStep (step indentIndentStyle { cBreakEnums = True }) input +case32 = assertSnippet (step indentIndentStyle { cBreakEnums = True }) input expected where expected = input - input = unlines + input = [ "data RejectionReason" , " -- InvalidState" , " = CancellationFailed" @@ -743,15 +744,15 @@ case32 = expected @=? testStep (step indentIndentStyle { cBreakEnums = True }) i ] case33 :: Assertion -case33 = expected @=? testStep (step indentIndentStyle { cBreakEnums = True, cBreakSingleConstructors = False }) input +case33 = assertSnippet (step indentIndentStyle { cBreakEnums = True, cBreakSingleConstructors = False }) input expected where - input = unlines + input = [ "module Some.Types where" , "" , "newtype NonEmpty a = NonEmpty { unNonEmpty :: a }" ] - expected = unlines + expected = [ "module Some.Types where" , "" , "newtype NonEmpty a" @@ -759,16 +760,16 @@ case33 = expected @=? testStep (step indentIndentStyle { cBreakEnums = True, cBr ] case34 :: Assertion -case34 = expected @=? testStep (step indentIndentStyle { cVia = Indent 2 }) input +case34 = assertSnippet (step indentIndentStyle { cVia = Indent 2 }) input expected where - input = unlines + input = [ "module Some.Types where" , "" , "newtype NonEmpty a = NonEmpty { unNonEmpty :: a }" , " deriving (ToJSON, FromJSON) via Something Magic (NonEmpty a)" ] - expected = unlines + expected = [ "module Some.Types where" , "" , "newtype NonEmpty a" @@ -778,9 +779,9 @@ case34 = expected @=? testStep (step indentIndentStyle { cVia = Indent 2 }) inpu ] case35 :: Assertion -case35 = expected @=? testStep (step indentIndentStyle { cBreakEnums = True, cBreakSingleConstructors = False }) input +case35 = assertSnippet (step indentIndentStyle { cBreakEnums = True, cBreakSingleConstructors = False }) input expected where - input = unlines + input = [ "module Some.Types where" , "" , "data Foo = Foo" @@ -790,7 +791,7 @@ case35 = expected @=? testStep (step indentIndentStyle { cBreakEnums = True, cBr , " }" ] - expected = unlines + expected = [ "module Some.Types where" , "" , "data Foo = Foo" @@ -799,9 +800,9 @@ case35 = expected @=? testStep (step indentIndentStyle { cBreakEnums = True, cBr ] case36 :: Assertion -case36 = expected @=? testStep (step indentIndentStyle { cBreakEnums = True, cBreakSingleConstructors = False }) input +case36 = assertSnippet (step indentIndentStyle { cBreakEnums = True, cBreakSingleConstructors = False }) input expected where - input = unlines + input = [ "module Some.Types where" , "" , "data Foo = Foo" @@ -811,7 +812,7 @@ case36 = expected @=? testStep (step indentIndentStyle { cBreakEnums = True, cBr , " }" ] - expected = unlines + expected = [ "module Some.Types where" , "" , "data Foo = Foo" @@ -820,9 +821,9 @@ case36 = expected @=? testStep (step indentIndentStyle { cBreakEnums = True, cBr ] case37 :: Assertion -case37 = expected @=? testStep (step indentIndentStyle { cVia = Indent 2 }) input +case37 = assertSnippet (step indentIndentStyle { cVia = Indent 2 }) input expected where - input = unlines + input = [ "module Some.Types where" , "" , "newtype UndoFlowData" @@ -834,7 +835,7 @@ case37 = expected @=? testStep (step indentIndentStyle { cVia = Indent 2 }) inpu , " \"reversal_indicator\" := \"Undo\"] FlowDataDetails" ] - expected = unlines + expected = [ "module Some.Types where" , "" , "newtype UndoFlowData" @@ -845,9 +846,9 @@ case37 = expected @=? testStep (step indentIndentStyle { cVia = Indent 2 }) inpu ] case38 :: Assertion -case38 = expected @=? testStep (step indentIndentStyle { cVia = Indent 2 }) input +case38 = assertSnippet (step indentIndentStyle { cVia = Indent 2 }) input expected where - input = unlines + input = [ "data Flat = Flat" , " { foo :: Int" , " , bar :: Text" @@ -866,7 +867,7 @@ case38 = expected @=? testStep (step indentIndentStyle { cVia = Indent 2 }) inpu , " Flat" ] - expected = unlines + expected = [ "data Flat" , " = Flat" , " { foo :: Int" @@ -880,9 +881,9 @@ case38 = expected @=? testStep (step indentIndentStyle { cVia = Indent 2 }) inpu ] case39 :: Assertion -case39 = expected @=? testStep (step indentIndentStyle { cVia = Indent 2 }) input +case39 = assertSnippet (step indentIndentStyle { cVia = Indent 2 }) input expected where - input = unlines + input = [ "data CreditTransfer = CreditTransfer" , " { nestedCreditorInfo :: CreditorInfo" , " }" @@ -903,7 +904,7 @@ case39 = expected @=? testStep (step indentIndentStyle { cVia = Indent 2 }) inpu , " )" ] - expected = unlines + expected = [ "data CreditTransfer" , " = CreditTransfer" , " { nestedCreditorInfo :: CreditorInfo" @@ -914,27 +915,27 @@ case39 = expected @=? testStep (step indentIndentStyle { cVia = Indent 2 }) inpu ] case40 :: Assertion -case40 = expected @=? testStep (step indentIndentStyle { cBreakSingleConstructors = False }) input +case40 = assertSnippet (step indentIndentStyle { cBreakSingleConstructors = False }) input expected where - input = unlines + input = [ "module X where" , "" , "data a :==> b =" , " Arr a b" ] - expected = unlines + expected = [ "module X where" , "" , "data a :==> b = Arr a b" ] case41 :: Assertion -case41 = expected @=? testStep (step indentIndentStyle) input +case41 = assertSnippet (step indentIndentStyle) input expected where input = expected - expected = unlines + expected = [ "module X where" , "" , "data Callback" @@ -957,11 +958,11 @@ case41 = expected @=? testStep (step indentIndentStyle) input ] case42 :: Assertion -case42 = expected @=? testStep (step indentIndentStyle) input +case42 = assertSnippet (step indentIndentStyle) input expected where input = expected - expected = unlines + expected = [ "module X where" , "" , "data SignupError" @@ -971,11 +972,11 @@ case42 = expected @=? testStep (step indentIndentStyle) input ] case43 :: Assertion -case43 = expected @=? testStep (step indentIndentStyle { cBreakEnums = True, cBreakSingleConstructors = False }) input +case43 = assertSnippet (step indentIndentStyle { cBreakEnums = True, cBreakSingleConstructors = False }) input expected where input = expected - expected = unlines + expected = [ "module X where" , "" , "data CallbackResult" @@ -994,9 +995,9 @@ case43 = expected @=? testStep (step indentIndentStyle { cBreakEnums = True, cBr -- 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 +case44 = assertSnippet (step indentIndentStyle { cBreakEnums = True, cBreakSingleConstructors = False, cVia = Indent 2 }) input expected where - input = unlines + input = [ "module X where" , "" , " data CreditTransfer = CreditTransfer" @@ -1013,7 +1014,7 @@ case44 = expected @=? testStep (step indentIndentStyle { cBreakEnums = True, cBr , " ]" , " (UntaggedEncoded CreditTransfer)" ] - expected = unlines + expected = [ "module X where" , "" , "data CreditTransfer = CreditTransfer" @@ -1030,10 +1031,10 @@ case44 = expected @=? testStep (step indentIndentStyle { cBreakEnums = True, cBr ] case45 :: Assertion -case45 = expected @=? testStep (step indentIndentStyle { cBreakEnums = True, cBreakSingleConstructors = False, cVia = Indent 2 }) input +case45 = assertSnippet (step indentIndentStyle { cBreakEnums = True, cBreakSingleConstructors = False, cVia = Indent 2 }) input expected where input = expected - expected = unlines + expected = [ "module X where" , "" , "data CreditTransfer = CreditTransfer" @@ -1050,10 +1051,10 @@ case45 = expected @=? testStep (step indentIndentStyle { cBreakEnums = True, cBr ] case46 :: Assertion -case46 = expected @=? testStep (step indentIndentStyle { cBreakEnums = True, cBreakSingleConstructors = False, cVia = Indent 2 }) input +case46 = assertSnippet (step indentIndentStyle { cBreakEnums = True, cBreakSingleConstructors = False, cVia = Indent 2 }) input expected where input = expected - expected = unlines + expected = [ "module X where" , "" , "-- | A format detailing which encoding to use for the settlement events" @@ -1068,10 +1069,10 @@ case46 = expected @=? testStep (step indentIndentStyle { cBreakEnums = True, cBr ] case47 :: Assertion -case47 = expected @=? testStep (step indentIndentStyle) input +case47 = assertSnippet (step indentIndentStyle) input expected where input = expected - expected = unlines + expected = [ "module X where" , "" , "-- | A GADT example" @@ -1082,10 +1083,10 @@ case47 = expected @=? testStep (step indentIndentStyle) input ] case48 :: Assertion -case48 = expected @=? testStep (step indentIndentStyle) input +case48 = assertSnippet (step indentIndentStyle) input expected where input = expected - expected = unlines + expected = [ "module X where" , "" , "-- | A GADT example" @@ -1096,10 +1097,10 @@ case48 = expected @=? testStep (step indentIndentStyle) input ] case49 :: Assertion -case49 = expected @=? testStep (step indentIndentStyle) input +case49 = assertSnippet (step indentIndentStyle) input expected where input = expected - expected = unlines + expected = [ "module X where" , "" , "-- | A GADT example" @@ -1110,10 +1111,10 @@ case49 = expected @=? testStep (step indentIndentStyle) input ] case50 :: Assertion -case50 = expected @=? testStep (step indentIndentStyle { cCurriedContext = True }) input +case50 = assertSnippet (step indentIndentStyle { cCurriedContext = True }) input expected where input = expected - expected = unlines + expected = [ "module X where" , "" , "-- | A GADT example" @@ -1124,9 +1125,9 @@ case50 = expected @=? testStep (step indentIndentStyle { cCurriedContext = True ] case51 :: Assertion -case51 = expected @=? testStep (step indentIndentStyle { cCurriedContext = True }) input +case51 = assertSnippet (step indentIndentStyle { cCurriedContext = True }) input expected where - input = unlines + input = [ "module X where" , "" , "-- | A GADT example" @@ -1135,7 +1136,7 @@ case51 = expected @=? testStep (step indentIndentStyle { cCurriedContext = True , " D2 :: T Bool" , " D3 :: forall a. (Eq a) => (a, a) -> T [a]" ] - expected = unlines + expected = [ "module X where" , "" , "-- | A GADT example" @@ -1146,16 +1147,16 @@ case51 = expected @=? testStep (step indentIndentStyle { cCurriedContext = True ] case52 :: Assertion -case52 = expected @=? testStep (step indentIndentStyle { cBreakSingleConstructors = False, cCurriedContext = True }) input +case52 = assertSnippet (step indentIndentStyle { cBreakSingleConstructors = False, cCurriedContext = True }) input expected where - input = unlines + input = [ "module X where" , "" , "data Foo = Foo" , " { foo :: forall a b. (Eq a, Bounded b) => a -> b -> [(a, b)]" , " }" ] - expected = unlines + expected = [ "module X where" , "" , "data Foo = Foo" @@ -1164,14 +1165,14 @@ case52 = expected @=? testStep (step indentIndentStyle { cBreakSingleConstructor ] case53 :: Assertion -case53 = expected @=? testStep (step indentIndentStyle { cMaxColumns = MaxColumns 80 }) input +case53 = assertSnippet (step indentIndentStyle { cMaxColumns = MaxColumns 80 }) input expected where - input = unlines + input = [ "newtype Foo m a" , " = Foo (m a)" , " deriving newtype (Functor, Applicative, Monad, MonadError, MonadCatch, Foldable, Monoid)" ] - expected = unlines + expected = [ "newtype Foo m a" , " = Foo (m a)" , " deriving newtype" @@ -1186,23 +1187,23 @@ case53 = expected @=? testStep (step indentIndentStyle { cMaxColumns = MaxColumn ] case54 :: Assertion -case54 = expected @=? testStep (step indentIndentStyle { cMaxColumns = MaxColumns 80 }) input +case54 = assertSnippet (step indentIndentStyle { cMaxColumns = MaxColumns 80 }) input expected where - input = unlines + input = [ "newtype Foo m a" , " = Foo (m a)" , " deriving newtype (Functor, Applicative, Monad)" ] - expected = unlines + expected = [ "newtype Foo m a" , " = Foo (m a)" , " deriving newtype (Applicative, Functor, Monad)" ] case55 :: Assertion -case55 = expected @=? testStep (step sameSameNoSortStyle) input +case55 = assertSnippet (step sameSameNoSortStyle) input expected where - input = unlines + input = [ "data Foo = Foo deriving (Z, Y, X, Bar, Abcd)" ] @@ -1284,9 +1285,9 @@ case57 = assertSnippet (step defaultConfig) -- -- See https://github.com/haskell/stylish-haskell/issues/330 case58 :: Assertion -case58 = expected @=? testStep (step sameIndentStyle) input +case58 = assertSnippet (step sameIndentStyle) input expected where - input = unlines + input = [ "module Herp where" , "" , "data Foo a = Foo" @@ -1316,9 +1317,9 @@ case60 = assertSnippet (step defaultConfig) -- -- Regression test for https://github.com/haskell/stylish-haskell/issues/282 case61 :: Assertion -case61 = expected @=? testStep (step sameIndentStyle) input +case61 = assertSnippet (step sameIndentStyle) input expected where - input = unlines + input = [ "module Herp where" , "" , "data Game = Game { _board :: Board -- ^ Board state" @@ -1329,7 +1330,7 @@ case61 = expected @=? testStep (step sameIndentStyle) input , " }" ] - expected = unlines + expected = [ "module Herp where" , "" , "data Game = Game" @@ -1350,9 +1351,9 @@ case61 = expected @=? testStep (step sameIndentStyle) input -- -- Regression test for https://github.com/haskell/stylish-haskell/issues/273 case62 :: Assertion -case62 = expected @=? testStep (step sameIndentStyle) input +case62 = assertSnippet (step sameIndentStyle) input expected where - input = unlines + input = [ "module Herp where" , "" , "data Foo = Foo" @@ -1365,7 +1366,7 @@ case62 = expected @=? testStep (step sameIndentStyle) input , " }" ] - expected = unlines + expected = [ "module Herp where" , "" , "data Foo = Foo" @@ -1379,9 +1380,9 @@ case62 = expected @=? testStep (step sameIndentStyle) input ] case63 :: Assertion -case63 = expected @=? testStep (step indentIndentStyle) input +case63 = assertSnippet (step indentIndentStyle) input expected where - input = unlines + input = [ "module Herp where" , "" , "data Foo :: * -> * where" From c489fb12ba3aeb5fcda247f3694cdc2d22155c29 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Tue, 15 Mar 2022 12:36:36 +0100 Subject: [PATCH 24/32] Clean up test suite, use assertSnippet everywhere --- tests/Language/Haskell/Stylish/Regressions.hs | 11 +- .../Stylish/Step/Imports/FelixTests.hs | 594 ++++++++---------- .../Haskell/Stylish/Step/Imports/Tests.hs | 28 +- .../Stylish/Step/LanguagePragmas/Tests.hs | 36 +- .../Haskell/Stylish/Step/Tabs/Tests.hs | 33 +- .../Stylish/Step/TrailingWhitespace/Tests.hs | 33 +- .../Stylish/Step/UnicodeSyntax/Tests.hs | 47 +- tests/Language/Haskell/Stylish/Tests/Util.hs | 56 +- 8 files changed, 366 insertions(+), 472 deletions(-) diff --git a/tests/Language/Haskell/Stylish/Regressions.hs b/tests/Language/Haskell/Stylish/Regressions.hs index 90d54603..4db5be1d 100644 --- a/tests/Language/Haskell/Stylish/Regressions.hs +++ b/tests/Language/Haskell/Stylish/Regressions.hs @@ -5,23 +5,24 @@ module Language.Haskell.Stylish.Regressions ) where import Language.Haskell.Stylish.Step.Imports -import Language.Haskell.Stylish.Tests.Util (testStep) +import Language.Haskell.Stylish.Tests.Util (assertSnippet) import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit (Assertion, (@=?)) +import Test.HUnit (Assertion) tests :: Test tests = testGroup "Language.Haskell.Stylish.Regressions" [ testCase "case 00 (#198)" case00 ] + -- | Error parsing '(,) #198 -- -- See https://github.com/haskell/stylish-haskell/issues/198 case00 :: Assertion -case00 = expected @=? testStep (step (Just 80) $ importStepConfig Global) input +case00 = assertSnippet (step (Just 80) $ importStepConfig Global) input input where - input = unlines + input = [ "{-# LANGUAGE TemplateHaskell #-}" , "" , "import Language.Haskell.TH.Syntax" @@ -29,7 +30,5 @@ case00 = expected @=? testStep (step (Just 80) $ importStepConfig Global) input , "main = print $ showName '(,)" ] - expected = input - importStepConfig :: ImportAlign -> Options importStepConfig align = defaultOptions { importAlign = align } diff --git a/tests/Language/Haskell/Stylish/Step/Imports/FelixTests.hs b/tests/Language/Haskell/Stylish/Step/Imports/FelixTests.hs index 8fad01ff..418e1981 100644 --- a/tests/Language/Haskell/Stylish/Step/Imports/FelixTests.hs +++ b/tests/Language/Haskell/Stylish/Step/Imports/FelixTests.hs @@ -1,383 +1,321 @@ +-------------------------------------------------------------------------------- -- | Tests contributed by Felix Mulder as part of -- . +{-# LANGUAGE OverloadedLists #-} module Language.Haskell.Stylish.Step.Imports.FelixTests ( tests ) where + -------------------------------------------------------------------------------- -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 Language.Haskell.Stylish.Module import Language.Haskell.Stylish.Step.Imports -import Language.Haskell.Stylish.Tests.Util (testStep', (@=??)) - +import Language.Haskell.Stylish.Tests.Util (assertSnippet) -------------------------------------------------------------------------------- tests :: Test tests = testGroup "Language.Haskell.Stylish.Step.Imports.FelixTests" - [ 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 - , 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 - , 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 - , testCase "Respects multiple groups" ex15 - , testCase "Doesn't delete nullary imports" ex16 - ] + [ 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 + , 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 + , 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 + , testCase "Respects multiple groups" ex15 + , testCase "Doesn't delete nullary imports" ex16 + ] + -------------------------------------------------------------------------------- ex0 :: Assertion -ex0 = input `assertFormatted` output - where - input = - [ "import B" - , "import A" - ] - output = - [ "import A" - , "import B" - ] +ex0 = assertSnippet (step Nothing felixOptions) + [ "import B" + , "import A" + ] + [ "import A" + , "import B" + ] ex1 :: Assertion -ex1 = input `assertFormatted` output - where - input = - [ "import B" - , "import A" - , "import C" - , "import qualified A" - , "import qualified B as X" - ] - output = - [ "import A" - , "import qualified A" - , "import B" - , "import qualified B as X" - , "import C" - ] +ex1 = assertSnippet (step Nothing felixOptions) + [ "import B" + , "import A" + , "import C" + , "import qualified A" + , "import qualified B as X" + ] + [ "import A" + , "import qualified A" + , "import B" + , "import qualified B as X" + , "import C" + ] ex2 :: Assertion -ex2 = input `assertFormatted` output - where - input = - [ "import B" - , "import A (X)" - , "import C" - , "import qualified A as Y (Y)" - ] - output = - [ "import A (X)" - , "import qualified A as Y (Y)" - , "import B" - , "import C" - ] +ex2 = assertSnippet (step Nothing felixOptions) + [ "import B" + , "import A (X)" + , "import C" + , "import qualified A as Y (Y)" + ] + [ "import A (X)" + , "import qualified A 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 qualified D as D0 (Y, b, a)" - , "import qualified E as E0 (b, a, Y)" - ] - output = - [ "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)" - ] +ex3 = assertSnippet (step Nothing felixOptions) + [ "import B" + , "import A (X, Z, Y)" + , "import C" + , "import qualified A as A0 (b, Y, a)" + , "import qualified D as D0 (Y, b, a)" + , "import qualified E as E0 (b, a, Y)" + ] + [ "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 -ex4 = input `assertFormatted` output - where - input = - [ "import A (X, Z(..), Y)" - ] - output = - [ "import A (X, Y, Z (..))" - ] +ex4 = assertSnippet (step Nothing felixOptions) + [ "import A (X, Z(..), Y)" + ] + [ "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))" - ] +ex5 = assertSnippet (step Nothing felixOptions) + [ "import A (X, Z(Z), Y)" + ] + [ "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))" - ] +ex6 = assertSnippet (step Nothing felixOptions) + [ "import A (X, Z(X, Z, Y), Y)" + ] + [ "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 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 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" - ] +ex7 = assertSnippet (step Nothing felixOptions) + [ "module Foo (tests) where" + , "import B" + , "import A (X, Z, Y)" + , "import C" + , "import qualified A as A0 (b, Y, a)" + , "import qualified D as D0 (Y, b, a)" + , "import qualified E as E0 (b, a, Y)" + , "-- hello" + , "foo :: Int" + , "foo = 1" + ] + [ "module Foo (tests) where" + , "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" + ] ex8 :: Assertion -ex8 = input `assertFormatted` output - where - input = - [ "import B" - , "-- Group divisor" - , "import A (X)" - , "import C" - , "import qualified A as Y (Y)" - ] - output = - [ "import B" - , "-- Group divisor" - , "import A (X)" - , "import qualified A as Y (Y)" - , "import C" - ] +ex8 = assertSnippet (step Nothing felixOptions) + [ "import B" + , "-- Group divisor" + , "import A (X)" + , "import C" + , "import qualified A as Y (Y)" + ] + [ "import B" + , "-- Group divisor" + , "import A (X)" + , "import qualified A as Y (Y)" + , "import C" + ] ex9 :: Assertion -ex9 = input `assertFormatted` output - where - input = - [ "--------" - , "import B" - , "" - , "-- Group divisor" - , "import A (X)" - , "import C" - , "import qualified A as Y (Y)" - ] - output = - [ "--------" - , "import B" - , "" - , "-- Group divisor" - , "import A (X)" - , "import qualified A as Y (Y)" - , "import C" - ] +ex9 = assertSnippet (step Nothing felixOptions) + [ "--------" + , "import B" + , "" + , "-- Group divisor" + , "import A (X)" + , "import C" + , "import qualified A as Y (Y)" + ] + [ "--------" + , "import B" + , "" + , "-- Group divisor" + , "import A (X)" + , "import qualified A as Y (Y)" + , "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)" - ] +ex10 = assertSnippet (step Nothing felixOptions) + [ "import B hiding (X)" + , "import A hiding (X)" + ] + [ "import A hiding (X)" + , "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 ((.=))" - ] +ex11 = assertSnippet (step Nothing felixOptions) + [ "import Data.Aeson ((.=))" + , "import A hiding (X)" + ] + [ "import A hiding (X)" + , "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 ((.=))" - ] +ex12 = assertSnippet (step Nothing felixOptions) + [ "import Data.Aeson ((.=))" + , "import Data.Aeson ((.=))" + , "import A hiding (X)" + ] + [ "import A hiding (X)" + , "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)" - ] +ex13 = assertSnippet (step (Just 10) felixOptions) + [ "import Foo (A, B, C, D)" + , "import A hiding (X)" + ] + [ "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 27) - input = - [ "import Foo (A, B, C, D)" - , "import A hiding (X)" - ] - output = - [ "import A hiding (X)" - , "import Foo (A, B)" - , "import Foo (C, D)" - ] +ex14 = assertSnippet (step (Just 27) felixOptions) + [ "import Foo (A, B, C, D)" + , "import A hiding (X)" + ] + [ "import A hiding (X)" + , "import Foo (A, B)" + , "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 qualified Prelude" - , "" - , "--------------------------------------------------------------------------------" - , "import Control.Lens as X ((%~), (&), (.~), (?~), (^.), (^?), _Left, _Right, iat, over, 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))" - , "--------------------------------------------------------------------------------" - ] - 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, unlines, unwords, words, writeFile, (!!))" - , "import qualified Prelude" - , "" - , "--------------------------------------------------------------------------------" - , "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)" - , "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))" - , "--------------------------------------------------------------------------------" - ] +ex15 = assertSnippet (step (Just 100) felixOptions) + [ "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 qualified Prelude" + , "" + , "--------------------------------------------------------------------------------" + , "import Control.Lens as X ((%~), (&), (.~), (?~), (^.), (^?), _Left, _Right, iat, over, 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))" + , "--------------------------------------------------------------------------------" + ] + [ "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 qualified Prelude" + , "" + , "--------------------------------------------------------------------------------" + , "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)" + , "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))" + , "--------------------------------------------------------------------------------" + ] 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 +ex16 = assertSnippet (step Nothing felixOptions) + [ "module Foo where" + , "" + , "import B ()" + , "import A ()" + ] + [ "module Foo where" + , "" + , "import A ()" + , "import B ()" + ] -assertFormatted' :: HasCallStack => Maybe Int -> Lines -> Lines -> Assertion -assertFormatted' maxColumns input expected = - withFrozenCallStack $ expected @=?? testStep' (step maxColumns felixOptions) input - where - felixOptions = defaultOptions - { listAlign = Repeat - } +felixOptions :: Options +felixOptions = defaultOptions + { listAlign = Repeat + } diff --git a/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs index f80e48cf..5065c6b8 100644 --- a/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs @@ -8,7 +8,7 @@ module Language.Haskell.Stylish.Step.Imports.Tests -------------------------------------------------------------------------------- import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit (Assertion, (@=?)) +import Test.HUnit (Assertion) -------------------------------------------------------------------------------- @@ -601,21 +601,17 @@ case19input = Snippet -------------------------------------------------------------------------------- case20 :: Assertion -case20 = expected - @=? testSnippet (step (Just 80) defaultOptions) input' - where - 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' = Snippet - [ "import {-# SOURCE #-} Data.ByteString as BS" - , "import {-# SOURCE #-} qualified Data.Text as T" - , "import qualified Data.Map as Map" - , "import Data.Set (empty)" - ] +case20 = assertSnippet (step (Just 80) defaultOptions) + [ "import {-# SOURCE #-} Data.ByteString as BS" + , "import {-# SOURCE #-} qualified Data.Text as T" + , "import qualified Data.Map as Map" + , "import Data.Set (empty)" + ] + [ "import {-# SOURCE #-} Data.ByteString as BS" + , "import qualified Data.Map as Map" + , "import Data.Set (empty)" + , "import {-# SOURCE #-} qualified Data.Text as T" + ] -------------------------------------------------------------------------------- diff --git a/tests/Language/Haskell/Stylish/Step/LanguagePragmas/Tests.hs b/tests/Language/Haskell/Stylish/Step/LanguagePragmas/Tests.hs index 3dade50b..ecb6a7f9 100644 --- a/tests/Language/Haskell/Stylish/Step/LanguagePragmas/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/LanguagePragmas/Tests.hs @@ -8,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) -------------------------------------------------------------------------------- @@ -231,22 +231,18 @@ case13 = assertSnippet -------------------------------------------------------------------------------- case14 :: Assertion -case14 = expected @=? testStep (step Nothing VerticalCompact 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" - ] +case14 = assertSnippet (step Nothing VerticalCompact False False "language") + [ "{-# LANGUAGE ViewPatterns, OverloadedStrings #-}" + , "{-# LANGUAGE TemplateHaskell, ViewPatterns #-}" + , "{-# LANGUAGE ScopedTypeVariables, NoImplicitPrelude #-}" + , "module Main where" + ] + [ "{-# language" + , " NoImplicitPrelude" + , " , OverloadedStrings" + , " , ScopedTypeVariables" + , " , TemplateHaskell" + , " , ViewPatterns" + , " #-}" + , "module Main where" + ] diff --git a/tests/Language/Haskell/Stylish/Step/Tabs/Tests.hs b/tests/Language/Haskell/Stylish/Step/Tabs/Tests.hs index 1127a872..ac440724 100644 --- a/tests/Language/Haskell/Stylish/Step/Tabs/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Tabs/Tests.hs @@ -1,4 +1,5 @@ -------------------------------------------------------------------------------- +{-# LANGUAGE OverloadedLists #-} module Language.Haskell.Stylish.Step.Tabs.Tests ( tests ) where @@ -7,7 +8,7 @@ module Language.Haskell.Stylish.Step.Tabs.Tests -------------------------------------------------------------------------------- import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit (Assertion, (@=?)) +import Test.HUnit (Assertion) -------------------------------------------------------------------------------- @@ -24,20 +25,16 @@ tests = testGroup "Language.Haskell.Stylish.Step.Tabs.Tests" -------------------------------------------------------------------------------- case01 :: Assertion -case01 = expected @=? testStep (step 4) input - where - input = unlines - [ "module Main" - , "\t\twhere" - , "data Foo" - , "\t= Bar" - , " | Qux" - ] - - expected = unlines - [ "module Main" - , " where" - , "data Foo" - , " = Bar" - , " | Qux" - ] +case01 = assertSnippet (step 4) + [ "module Main" + , "\t\twhere" + , "data Foo" + , "\t= Bar" + , " | Qux" + ] + [ "module Main" + , " where" + , "data Foo" + , " = Bar" + , " | Qux" + ] diff --git a/tests/Language/Haskell/Stylish/Step/TrailingWhitespace/Tests.hs b/tests/Language/Haskell/Stylish/Step/TrailingWhitespace/Tests.hs index 0593c0a9..960fd484 100644 --- a/tests/Language/Haskell/Stylish/Step/TrailingWhitespace/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/TrailingWhitespace/Tests.hs @@ -1,4 +1,5 @@ -------------------------------------------------------------------------------- +{-# LANGUAGE OverloadedLists #-} module Language.Haskell.Stylish.Step.TrailingWhitespace.Tests ( tests ) where @@ -7,7 +8,7 @@ module Language.Haskell.Stylish.Step.TrailingWhitespace.Tests -------------------------------------------------------------------------------- import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit (Assertion, (@=?)) +import Test.HUnit (Assertion) -------------------------------------------------------------------------------- @@ -24,20 +25,16 @@ tests = testGroup "Language.Haskell.Stylish.Step.TrailingWhitespace.Tests" -------------------------------------------------------------------------------- case01 :: Assertion -case01 = expected @=? testStep step input - where - input = unlines - [ "module Main where" - , " \t" - , "data Foo = Bar | Qux\t " - , "\12" -- page break - , " \12" -- malformed page break - ] - - expected = unlines - [ "module Main where" - , "" - , "data Foo = Bar | Qux" - , "\12" -- page break - , "" - ] +case01 = assertSnippet step + [ "module Main where" + , " \t" + , "data Foo = Bar | Qux\t " + , "\12" -- page break + , " \12" -- malformed page break + ] + [ "module Main where" + , "" + , "data Foo = Bar | Qux" + , "\12" -- page break + , "" + ] diff --git a/tests/Language/Haskell/Stylish/Step/UnicodeSyntax/Tests.hs b/tests/Language/Haskell/Stylish/Step/UnicodeSyntax/Tests.hs index da1abae3..95988390 100644 --- a/tests/Language/Haskell/Stylish/Step/UnicodeSyntax/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/UnicodeSyntax/Tests.hs @@ -1,13 +1,14 @@ -------------------------------------------------------------------------------- +{-# LANGUAGE OverloadedLists #-} module Language.Haskell.Stylish.Step.UnicodeSyntax.Tests ( tests ) where -------------------------------------------------------------------------------- -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) -------------------------------------------------------------------------------- @@ -25,31 +26,23 @@ tests = testGroup "Language.Haskell.Stylish.Step.UnicodeSyntax.Tests" -------------------------------------------------------------------------------- case01 :: Assertion -case01 = expected @=? testStep (step True "LANGUAGE") input - where - input = unlines - [ "sort :: Ord a => [a] -> [a]" - , "sort _ = []" - ] - - expected = unlines - [ "{-# LANGUAGE UnicodeSyntax #-}" - , "sort ∷ Ord a ⇒ [a] → [a]" - , "sort _ = []" - ] +case01 = assertSnippet (step True "LANGUAGE") + [ "sort :: Ord a => [a] -> [a]" + , "sort _ = []" + ] + [ "{-# LANGUAGE UnicodeSyntax #-}" + , "sort ∷ Ord a ⇒ [a] → [a]" + , "sort _ = []" + ] -------------------------------------------------------------------------------- case02 :: Assertion -case02 = expected @=? testStep (step True "LaNgUaGe") input - where - input = unlines - [ "sort :: Ord a => [a] -> [a]" - , "sort _ = []" - ] - - expected = unlines - [ "{-# LaNgUaGe UnicodeSyntax #-}" - , "sort ∷ Ord a ⇒ [a] → [a]" - , "sort _ = []" - ] +case02 = assertSnippet (step True "LaNgUaGe") + [ "sort :: Ord a => [a] -> [a]" + , "sort _ = []" + ] + [ "{-# LaNgUaGe UnicodeSyntax #-}" + , "sort ∷ Ord a ⇒ [a] → [a]" + , "sort _ = []" + ] diff --git a/tests/Language/Haskell/Stylish/Tests/Util.hs b/tests/Language/Haskell/Stylish/Tests/Util.hs index ba681000..3fcfc996 100644 --- a/tests/Language/Haskell/Stylish/Tests/Util.hs +++ b/tests/Language/Haskell/Stylish/Tests/Util.hs @@ -3,39 +3,34 @@ module Language.Haskell.Stylish.Tests.Util ( dumpAst , dumpModule - , testStep - , testStep' , Snippet (..) - , testSnippet , assertSnippet , withTestDirTree - , (@=??) ) where -------------------------------------------------------------------------------- -import Control.Exception (bracket, try) -import Control.Monad.Writer (execWriter, tell) -import Data.List (intercalate) -import GHC.Exts (IsList (..)) -import GHC.Hs.Dump (showAstData, BlankSrcSpan(..), BlankEpAnnotations (..)) -import System.Directory (createDirectory, - getCurrentDirectory, - getTemporaryDirectory, - removeDirectoryRecursive, - setCurrentDirectory) -import System.FilePath (()) -import System.IO.Error (isAlreadyExistsError) -import System.Random (randomIO) -import Test.HUnit (Assertion, assertFailure, - (@=?)) -import Data.Data (Data(..)) +import Control.Exception (bracket, try) +import Data.Data (Data (..)) +import GHC.Exts (IsList (..)) +import GHC.Hs.Dump (BlankEpAnnotations (..), + BlankSrcSpan (..), + showAstData) +import System.Directory (createDirectory, + getCurrentDirectory, + getTemporaryDirectory, + removeDirectoryRecursive, + setCurrentDirectory) +import System.FilePath (()) +import System.IO.Error (isAlreadyExistsError) +import System.Random (randomIO) +import Test.HUnit (Assertion, (@=?)) -------------------------------------------------------------------------------- +import Language.Haskell.Stylish.GHC (showOutputable) +import Language.Haskell.Stylish.Module (Module) import Language.Haskell.Stylish.Parse import Language.Haskell.Stylish.Step -import Language.Haskell.Stylish.GHC (showOutputable) -import Language.Haskell.Stylish.Module (Module) -------------------------------------------------------------------------------- -- | Takes a Haskell source as an argument and parse it into a Module. @@ -65,11 +60,6 @@ testStep s str = case s of 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) @@ -123,15 +113,3 @@ 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 2a228e2e30e9a5a25a074b5ec8cfbc43f73bd19a Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Tue, 15 Mar 2022 16:06:23 +0100 Subject: [PATCH 25/32] WIP: Port Data step --- lib/Language/Haskell/Stylish/Step/Data.hs | 51 ++++++++++++++++------- 1 file changed, 35 insertions(+), 16 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Step/Data.hs b/lib/Language/Haskell/Stylish/Step/Data.hs index d6536f2f..4e65ab5d 100644 --- a/lib/Language/Haskell/Stylish/Step/Data.hs +++ b/lib/Language/Haskell/Stylish/Step/Data.hs @@ -30,11 +30,13 @@ import Prelude hiding (init) -------------------------------------------------------------------------------- import Language.Haskell.Stylish.Editor +import Language.Haskell.Stylish.Comments 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 +import Language.Haskell.Stylish.Util -------------------------------------------------------------------------------- @@ -374,31 +376,48 @@ putConstructor cfg consIndent lcons = case GHC.unLoc lcons of let fieldPos = bracePos + 2 space + let commented = commentGroups + (GHC.srcSpanToRealSrcSpan . GHC.getLocA) + (GHC.unLoc largs) + (epAnnComments . GHC.ann $ GHC.getLoc largs) + + forM_ (flagEnds commented) $ \(CommentGroup {..}, firstCommentGroup, lastCommentGroup) -> do + -- 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 - pad fieldPos >> putConDeclField cfg (GHC.unLoc firstArg) - -- unless (cFirstField cfg == SameLine) (putEolComment posFirst) - - -- Put tail decl fields - forM_ (GHC.unLoc <$> args) $ \arg -> do - sepDecl bracePos - -- removeCommentTo pos >>= mapM_ \c -> - -- spaces (cFieldComment cfg) >> putComment c >> sepDecl bracePos - comma - space - putConDeclField cfg arg - -- putEolComment pos - + forM_ cgPrior $ \lc -> do + pad fieldPos + putComment $ GHC.unLoc lc + sepDecl bracePos -- >> spaces (cFieldComment cfg) + + forM_ (flagEnds cgItems) $ \((item, mbInlineComment), firstItem, lastItem) -> do + if firstCommentGroup && firstItem + then pad fieldPos + else do + comma + space + putConDeclField cfg $ GHC.unLoc item + case mbInlineComment of + Just c | cFirstField cfg == SameLine -> + putMaybeLineComment . Just $ GHC.unLoc c + Just c -> do + sepDecl bracePos >> spaces (cFieldComment cfg) + putComment $ GHC.unLoc c + _ -> pure () + sepDecl bracePos + + forM_ cgFollowing $ \lc -> do + spaces (cFieldComment cfg) + putComment $ GHC.unLoc lc + sepDecl bracePos -- Print docstr after final field -- removeCommentToEnd recPos >>= mapM_ \c -> -- sepDecl bracePos >> spaces (cFieldComment cfg) >> putComment c -- Print whitespace to closing brace - sepDecl bracePos >> putText "}" + putText "}" GHC.RecCon _ -> do skipToBrace >> putText "{" skipToBrace >> putText "}" From b530507caf0d1ea263984df89ca5aad080adf872 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Tue, 15 Mar 2022 17:09:17 +0100 Subject: [PATCH 26/32] Clean up test suite a bit --- .../Haskell/Stylish/Step/Data/Tests.hs | 555 ++++++++---------- 1 file changed, 256 insertions(+), 299 deletions(-) diff --git a/tests/Language/Haskell/Stylish/Step/Data/Tests.hs b/tests/Language/Haskell/Stylish/Step/Data/Tests.hs index 1d14426b..5e1df658 100644 --- a/tests/Language/Haskell/Stylish/Step/Data/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Data/Tests.hs @@ -79,169 +79,142 @@ tests = testGroup "Language.Haskell.Stylish.Step.Data.Tests" ] case00 :: Assertion -case00 = assertSnippet (step sameSameStyle) input expected +case00 = assertSnippet (step sameSameStyle) input input where input = - [ "module Herp where" - , "" - , "data Foo" - ] - - expected = input + [ "module Herp where" + , "" + , "data Foo" + ] case01 :: Assertion -case01 = assertSnippet (step indentIndentStyle) input expected - where - input = - [ "module Herp where" - , "" - , "data Foo = Foo { a :: Int }" - ] - - expected = - [ "module Herp where" - , "" - , "data Foo" - , " = Foo" - , " { a :: Int" - , " }" - ] +case01 = assertSnippet (step indentIndentStyle) + [ "module Herp where" + , "" + , "data Foo = Foo { a :: Int }" + ] + [ "module Herp where" + , "" + , "data Foo" + , " = Foo" + , " { a :: Int" + , " }" + ] case02 :: Assertion -case02 = assertSnippet (step indentIndentStyle) input expected - where - input = - [ "module Herp where" - , "" - , "data Foo = Foo { a :: Int, a2 :: String }" - ] - - expected = - [ "module Herp where" - , "" - , "data Foo" - , " = Foo" - , " { a :: Int" - , " , a2 :: String" - , " }" - ] +case02 = assertSnippet (step indentIndentStyle) + [ "module Herp where" + , "" + , "data Foo = Foo { a :: Int, a2 :: String }" + ] + [ "module Herp where" + , "" + , "data Foo" + , " = Foo" + , " { a :: Int" + , " , a2 :: String" + , " }" + ] case03 :: Assertion -case03 = assertSnippet (step indentIndentStyle) input expected - where - input = - [ "module Herp where" - , "" - , "data Foo a = Foo { a :: a, a2 :: String }" - ] - expected = - [ "module Herp where" - , "" - , "data Foo a" - , " = Foo" - , " { a :: a" - , " , a2 :: String" - , " }" - ] +case03 = assertSnippet (step indentIndentStyle) + [ "module Herp where" + , "" + , "data Foo a = Foo { a :: a, a2 :: String }" + ] + [ "module Herp where" + , "" + , "data Foo a" + , " = Foo" + , " { a :: a" + , " , a2 :: String" + , " }" + ] case04 :: Assertion -case04 = assertSnippet (step indentIndentStyle) input expected - where - input = - [ "module Herp where" - , "" - , "data Foo a = Foo { a :: a, a2 :: String } | Bar { b :: a }" - ] - expected = - [ "module Herp where" - , "" - , "data Foo a" - , " = Foo" - , " { a :: a" - , " , a2 :: String" - , " }" - , " | Bar" - , " { b :: a" - , " }" - ] +case04 = assertSnippet (step indentIndentStyle) + [ "module Herp where" + , "" + , "data Foo a = Foo { a :: a, a2 :: String } | Bar { b :: a }" + ] + [ "module Herp where" + , "" + , "data Foo a" + , " = Foo" + , " { a :: a" + , " , a2 :: String" + , " }" + , " | Bar" + , " { b :: a" + , " }" + ] case05 :: Assertion -case05 = assertSnippet (step indentIndentStyle) input expected - where - input = - [ "module Herp where" - , "" - , "data Foo = Foo {" - , " a :: Int" - , " , a2 :: String" - , " }" - ] - expected = - [ "module Herp where" - , "" - , "data Foo" - , " = Foo" - , " { a :: Int" - , " , a2 :: String" - , " }" - ] +case05 = assertSnippet (step indentIndentStyle) + [ "module Herp where" + , "" + , "data Foo = Foo {" + , " a :: Int" + , " , a2 :: String" + , " }" + ] + [ "module Herp where" + , "" + , "data Foo" + , " = Foo" + , " { a :: Int" + , " , a2 :: String" + , " }" + ] case06 :: Assertion -case06 = assertSnippet (step sameSameStyle) input expected +case06 = assertSnippet (step sameSameStyle) input input where input = - [ "module Herp where" - , "" - , "data Foo = Foo Int String" - ] - expected = input + [ "module Herp where" + , "" + , "data Foo = Foo Int String" + ] case07 :: Assertion -case07 = assertSnippet (step sameSameStyle) input expected +case07 = assertSnippet (step sameSameStyle) input input where input = - [ "module Herp where" - , "" - , "data Phantom a = Phantom" - ] - expected = input + [ "module Herp where" + , "" + , "data Phantom a = Phantom" + ] case08 :: Assertion -case08 = assertSnippet (step sameSameStyle) input expected - where - input = - [ "module Herp where" - , "" - , "data Phantom a =" - , " Phantom" - ] - expected = - [ "module Herp where" - , "" - , "data Phantom a = Phantom" - ] +case08 = assertSnippet (step sameSameStyle) + [ "module Herp where" + , "" + , "data Phantom a =" + , " Phantom" + ] + [ "module Herp where" + , "" + , "data Phantom a = Phantom" + ] case09 :: Assertion -case09 = assertSnippet (step indentIndentStyle4) input expected - where - input = - [ "module Herp where" - , "" - , "data Foo a b = Foo { a :: a, a2 :: String } | Bar { b :: a, c:: b }" - ] - expected = - [ "module Herp where" - , "" - , "data Foo a b" - , " = Foo" - , " { a :: a" - , " , a2 :: String" - , " }" - , " | Bar" - , " { b :: a" - , " , c :: b" - , " }" - ] +case09 = assertSnippet (step indentIndentStyle4) + [ "module Herp where" + , "" + , "data Foo a b = Foo { a :: a, a2 :: String } | Bar { b :: a, c:: b }" + ] + [ "module Herp where" + , "" + , "data Foo a b" + , " = Foo" + , " { a :: a" + , " , a2 :: String" + , " }" + , " | Bar" + , " { b :: a" + , " , c :: b" + , " }" + ] case10 :: Assertion case10 = assertSnippet (step indentIndentStyle) input expected @@ -366,93 +339,81 @@ case15 = assertSnippet (step indentIndentStyle) input expected ] case16 :: Assertion -case16 = assertSnippet (step indentIndentStyle) input expected - where - input = - [ "module Herp where" - , "" - , "data Foo = Foo {" - , " a :: Int -- ^ comment" - , " }" - ] - expected = - [ "module Herp where" - , "" - , "data Foo" - , " = Foo" - , " { a :: Int" - , " -- ^ comment" - , " }" - ] +case16 = assertSnippet (step indentIndentStyle) + [ "module Herp where" + , "" + , "data Foo = Foo {" + , " a :: Int -- ^ comment" + , " }" + ] + [ "module Herp where" + , "" + , "data Foo" + , " = Foo" + , " { a :: Int" + , " -- ^ comment" + , " }" + ] case17 :: Assertion -case17 = assertSnippet (step indentIndentStyle) input expected - where - input = - [ "module Herp where" - , "" - , "data Foo a = Foo" - , " { a :: a," - , "-- comment" - , " a2 :: String" - , " }" - ] - expected = - [ "module Herp where" - , "" - , "data Foo a" - , " = Foo" - , " { a :: a" - , " -- comment" - , " , a2 :: String" - , " }" - ] +case17 = assertSnippet (step indentIndentStyle) + [ "module Herp where" + , "" + , "data Foo a = Foo" + , " { a :: a," + , "-- comment" + , " a2 :: String" + , " }" + ] + [ "module Herp where" + , "" + , "data Foo a" + , " = Foo" + , " { a :: a" + , " -- comment" + , " , a2 :: String" + , " }" + ] case18 :: Assertion -case18 = assertSnippet (step indentIndentStyle) input expected - where - input = - [ "module Herp where" - , "" - , "data Foo a = Foo" - , " { a :: a," - , "-- ^ comment" - , " a2 :: String" - , " }" - ] - expected = - [ "module Herp where" - , "" - , "data Foo a" - , " = Foo" - , " { a :: a" - , " -- ^ comment" - , " , a2 :: String" - , " }" - ] +case18 = assertSnippet (step indentIndentStyle) + [ "module Herp where" + , "" + , "data Foo a = Foo" + , " { a :: a," + , "-- ^ comment" + , " a2 :: String" + , " }" + ] + [ "module Herp where" + , "" + , "data Foo a" + , " = Foo" + , " { a :: a" + , " -- ^ comment" + , " , a2 :: String" + , " }" + ] case19 :: Assertion -case19 = assertSnippet (step indentIndentStyle) input expected - where - input = - [ "module Herp where" - , "" - , "data Foo a = Foo" - , " { firstName, lastName :: String," - , "-- ^ names" - , " age :: Int" - , " }" - ] - expected = - [ "module Herp where" - , "" - , "data Foo a" - , " = Foo" - , " { firstName, lastName :: String" - , " -- ^ names" - , " , age :: Int" - , " }" - ] +case19 = assertSnippet (step indentIndentStyle) + [ "module Herp where" + , "" + , "data Foo a = Foo" + , " { firstName, lastName :: String," + , "-- ^ names" + , " age :: Int" + , " }" + ] + [ "module Herp where" + , "" + , "data Foo a" + , " = Foo" + , " { firstName, lastName :: String" + , " -- ^ names" + , " , age :: Int" + , " }" + ] -- | Should not break Enums (data without records) formatting -- @@ -468,93 +429,89 @@ case20 = assertSnippet (step indentIndentStyle) input input case21 :: Assertion case21 = assertSnippet (step sameSameStyle) - [ "data Foo a" - , " = Foo { a :: Int," - , " a2 :: String" - , " -- ^ some haddock" - , " }" - , " | Bar { b :: a } deriving (Eq, Show)" - , " deriving (ToJSON)" - ] - [ "data Foo a = Foo { a :: Int" - , " , a2 :: String" - , " -- ^ some haddock" - , " }" - , " | Bar { b :: a" - , " }" - , " deriving (Eq, Show)" - , " deriving (ToJSON)" - ] + [ "data Foo a" + , " = Foo { a :: Int," + , " a2 :: String" + , " -- ^ some haddock" + , " }" + , " | Bar { b :: a } deriving (Eq, Show)" + , " deriving (ToJSON)" + ] + [ "data Foo a = Foo { a :: Int" + , " , a2 :: String" + , " -- ^ some haddock" + , " }" + , " | Bar { b :: a" + , " }" + , " deriving (Eq, Show)" + , " deriving (ToJSON)" + ] case22 :: Assertion case22 = assertSnippet (step sameIndentStyle) - [ "data Foo a" - , " = Foo { a :: Int," - , " a2 :: String" - , " -- ^ some haddock" - , " }" - , " | Bar { b :: a } deriving (Eq, Show)" - , " deriving (ToJSON)" - ] - [ "data Foo a = Foo" - , " { a :: Int" - , " , a2 :: String" - , " -- ^ some haddock" - , " }" - , " | Bar" - , " { b :: a" - , " }" - , " deriving (Eq, Show)" - , " deriving (ToJSON)" - ] + [ "data Foo a" + , " = Foo { a :: Int," + , " a2 :: String" + , " -- ^ some haddock" + , " }" + , " | Bar { b :: a } deriving (Eq, Show)" + , " deriving (ToJSON)" + ] + [ "data Foo a = Foo" + , " { a :: Int" + , " , a2 :: String" + , " -- ^ some haddock" + , " }" + , " | Bar" + , " { b :: a" + , " }" + , " deriving (Eq, Show)" + , " deriving (ToJSON)" + ] case23 :: Assertion case23 = assertSnippet (step indentSameStyle) - [ "data Foo a" - , " = Foo { a :: Int," - , " a2 :: String" - , " -- ^ some haddock" - , " }" - , " | Bar { b :: a } deriving (Eq, Show)" - , " deriving (ToJSON)" - ] - [ "data Foo a" - , " = Foo { a :: Int" - , " , a2 :: String" - , " -- ^ some haddock" - , " }" - , " | Bar { b :: a" - , " }" - , " deriving (Eq, Show)" - , " deriving (ToJSON)" - ] + [ "data Foo a" + , " = Foo { a :: Int," + , " a2 :: String" + , " -- ^ some haddock" + , " }" + , " | Bar { b :: a } deriving (Eq, Show)" + , " deriving (ToJSON)" + ] + [ "data Foo a" + , " = Foo { a :: Int" + , " , a2 :: String" + , " -- ^ some haddock" + , " }" + , " | Bar { b :: a" + , " }" + , " deriving (Eq, Show)" + , " deriving (ToJSON)" + ] case24 :: Assertion -case24 = assertSnippet (step indentIndentStyle) input expected - where - input = - [ "data Foo a" - , " = Foo { a :: Int," - , " a2 :: String" - , " -- ^ some haddock" - , " }" - , " | Bar { b :: a } deriving (Eq, Show)" - , " deriving (ToJSON)" - ] - - expected = - [ "data Foo a" - , " = Foo" - , " { a :: Int" - , " , a2 :: String" - , " -- ^ some haddock" - , " }" - , " | Bar" - , " { b :: a" - , " }" - , " deriving (Eq, Show)" - , " deriving (ToJSON)" - ] +case24 = assertSnippet (step indentIndentStyle) + [ "data Foo a" + , " = Foo { a :: Int," + , " a2 :: String" + , " -- ^ some haddock" + , " }" + , " | Bar { b :: a } deriving (Eq, Show)" + , " deriving (ToJSON)" + ] + [ "data Foo a" + , " = Foo" + , " { a :: Int" + , " , a2 :: String" + , " -- ^ some haddock" + , " }" + , " | Bar" + , " { b :: a" + , " }" + , " deriving (Eq, Show)" + , " deriving (ToJSON)" + ] case25 :: Assertion case25 = assertSnippet (step indentIndentStyle { cBreakSingleConstructors = False }) input expected From aa3f916d724c4d89489e4403c01bce3f06ee0735 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Tue, 15 Mar 2022 19:13:56 +0100 Subject: [PATCH 27/32] WIP: Port Data step --- lib/Language/Haskell/Stylish/Step/Data.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Step/Data.hs b/lib/Language/Haskell/Stylish/Step/Data.hs index 4e65ab5d..48b7325e 100644 --- a/lib/Language/Haskell/Stylish/Step/Data.hs +++ b/lib/Language/Haskell/Stylish/Step/Data.hs @@ -102,7 +102,8 @@ step cfg = makeStep "Data" \ls m -> loc <- maybeToList $ GHC.srcSpanToRealSrcSpan $ GHC.getLocA ldecl case tycld of GHC.DataDecl {..} -> pure $ MkDataDecl - { dataLoc = loc + { dataComments = epAnnComments tcdDExt + , dataLoc = loc , dataDeclName = tcdLName , dataTypeVars = tcdTyVars , dataDefn = tcdDataDefn @@ -113,7 +114,8 @@ step cfg = makeStep "Data" \ls m -> type ChangeLine = Change String data DataDecl = MkDataDecl - { dataLoc :: GHC.RealSrcSpan + { dataComments :: [GHC.LEpaComment] + , dataLoc :: GHC.RealSrcSpan , dataDeclName :: GHC.LocatedN GHC.RdrName , dataTypeVars :: GHC.LHsQTyVars GHC.GhcPs , dataDefn :: GHC.HsDataDefn GHC.GhcPs From 3b24f2d52046806a00bf2fe1d470f96f2ea98d51 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Wed, 16 Mar 2022 09:10:45 +0100 Subject: [PATCH 28/32] Refactor cabal file --- stylish-haskell.cabal | 150 +++++++++++++----------------------------- 1 file changed, 46 insertions(+), 104 deletions(-) diff --git a/stylish-haskell.cabal b/stylish-haskell.cabal index 74ebbc14..da68174e 100644 --- a/stylish-haskell.cabal +++ b/stylish-haskell.cabal @@ -23,20 +23,47 @@ Extra-source-files: README.markdown, data/stylish-haskell.yaml -Library - Hs-source-dirs: lib +Common depends Ghc-options: -Wall Default-language: Haskell2010 + Build-depends: + aeson >= 0.6 && < 1.6, + base >= 4.8 && < 5, + bytestring >= 0.9 && < 0.11, + Cabal >= 3.4 && < 3.7, + containers >= 0.3 && < 0.7, + directory >= 1.2.3 && < 1.4, + filepath >= 1.1 && < 1.5, + file-embed >= 0.0.10 && < 0.1, + ghc-lib-parser >= 9.2 && < 9.3, + ghc-lib-parser-ex >= 9.2 && < 9.3, + 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 + +Library + Import: depends + Hs-source-dirs: lib + Exposed-modules: Language.Haskell.Stylish + Language.Haskell.Stylish.Config Language.Haskell.Stylish.GHC Language.Haskell.Stylish.Module + Language.Haskell.Stylish.Parse Language.Haskell.Stylish.Printer + Language.Haskell.Stylish.Step Language.Haskell.Stylish.Step.Data Language.Haskell.Stylish.Step.Imports - Language.Haskell.Stylish.Step.ModuleHeader Language.Haskell.Stylish.Step.LanguagePragmas + Language.Haskell.Stylish.Step.ModuleHeader Language.Haskell.Stylish.Step.SimpleAlign Language.Haskell.Stylish.Step.Squash Language.Haskell.Stylish.Step.Tabs @@ -47,13 +74,10 @@ Library Language.Haskell.Stylish.Align Language.Haskell.Stylish.Block Language.Haskell.Stylish.Comments - Language.Haskell.Stylish.Config 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 Language.Haskell.Stylish.Verbose Paths_stylish_haskell @@ -61,127 +85,45 @@ Library Autogen-modules: Paths_stylish_haskell - Build-depends: - aeson >= 0.6 && < 1.6, - base >= 4.8 && < 5, - bytestring >= 0.9 && < 0.11, - Cabal >= 3.4 && < 3.7, - containers >= 0.3 && < 0.7, - directory >= 1.2.3 && < 1.4, - filepath >= 1.1 && < 1.5, - file-embed >= 0.0.10 && < 0.1, - ghc-lib-parser >= 9.2 && < 9.3, - ghc-lib-parser-ex >= 9.2 && < 9.3, - 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 - Executable stylish-haskell - Ghc-options: -Wall - Hs-source-dirs: src - Main-is: Main.hs - Default-language: Haskell2010 + Import: depends + Hs-source-dirs: src + Main-is: Main.hs Build-depends: stylish-haskell, strict >= 0.3 && < 0.5, - optparse-applicative >= 0.12 && < 0.17, - -- Copied from regular dependencies... - aeson >= 0.6 && < 1.6, - base >= 4.8 && < 5, - bytestring >= 0.9 && < 0.11, - Cabal >= 3.4 && < 3.7, - containers >= 0.3 && < 0.7, - directory >= 1.2.3 && < 1.4, - filepath >= 1.1 && < 1.5, - file-embed >= 0.0.10 && < 0.1, - ghc-lib-parser >= 9.2 && < 9.3, - ghc-lib-parser-ex >= 9.2 && < 9.3, - mtl >= 2.0 && < 2.3, - syb >= 0.3 && < 0.8, - HsYAML-aeson >=0.2.0 && < 0.3, - HsYAML >=0.2.0 && < 0.3 + optparse-applicative >= 0.12 && < 0.17 Test-suite stylish-haskell-tests - Ghc-options: -Wall - Hs-source-dirs: tests lib - Main-is: TestSuite.hs - Type: exitcode-stdio-1.0 - Default-language: Haskell2010 + Import: depends + Hs-source-dirs: tests + Main-is: TestSuite.hs + Type: exitcode-stdio-1.0 Other-modules: - Language.Haskell.Stylish - Language.Haskell.Stylish.Align - Language.Haskell.Stylish.Block - Language.Haskell.Stylish.Comments - Language.Haskell.Stylish.Config - Language.Haskell.Stylish.Config.Cabal - Language.Haskell.Stylish.Config.Internal 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 - Language.Haskell.Stylish.Printer - Language.Haskell.Stylish.Step - Language.Haskell.Stylish.Step.Imports - Language.Haskell.Stylish.Step.Imports.Tests - Language.Haskell.Stylish.Step.Imports.FelixTests - Language.Haskell.Stylish.Step.Data + Language.Haskell.Stylish.Regressions 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.Imports.FelixTests + Language.Haskell.Stylish.Step.Imports.Tests Language.Haskell.Stylish.Step.LanguagePragmas.Tests - Language.Haskell.Stylish.Step.SimpleAlign + Language.Haskell.Stylish.Step.ModuleHeader.Tests Language.Haskell.Stylish.Step.SimpleAlign.Tests - Language.Haskell.Stylish.Step.Squash Language.Haskell.Stylish.Step.Squash.Tests - Language.Haskell.Stylish.Step.Tabs Language.Haskell.Stylish.Step.Tabs.Tests - Language.Haskell.Stylish.Step.TrailingWhitespace Language.Haskell.Stylish.Step.TrailingWhitespace.Tests - Language.Haskell.Stylish.Step.UnicodeSyntax Language.Haskell.Stylish.Step.UnicodeSyntax.Tests - Language.Haskell.Stylish.Regressions Language.Haskell.Stylish.Tests Language.Haskell.Stylish.Tests.Util - Language.Haskell.Stylish.Util - Language.Haskell.Stylish.Verbose - Paths_stylish_haskell - - Autogen-modules: - Paths_stylish_haskell Build-depends: - HUnit >= 1.2 && < 1.7, - test-framework >= 0.4 && < 0.9, - test-framework-hunit >= 0.2 && < 0.4, + stylish-haskell, + HUnit >= 1.2 && < 1.7, random >= 1.1, - -- Copied from regular dependencies... - aeson >= 0.6 && < 1.6, - base >= 4.8 && < 5, - bytestring >= 0.9 && < 0.11, - Cabal >= 3.4 && < 3.7, - containers >= 0.3 && < 0.7, - directory >= 1.2.3 && < 1.4, - filepath >= 1.1 && < 1.5, - file-embed >= 0.0.10 && < 0.1, - ghc-lib-parser >= 9.2 && < 9.3, - ghc-lib-parser-ex >= 9.2 && < 9.3, - 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 + test-framework >= 0.4 && < 0.9, + test-framework-hunit >= 0.2 && < 0.4, Source-repository head Type: git From 838eac482cfb96ba93e1504f730b42ebea732cd1 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Wed, 16 Mar 2022 15:08:03 +0100 Subject: [PATCH 29/32] WIP: Port Data step --- lib/Language/Haskell/Stylish/Config.hs | 22 ++-- lib/Language/Haskell/Stylish/GHC.hs | 15 ++- lib/Language/Haskell/Stylish/Step/Data.hs | 95 ++++++++------ .../Haskell/Stylish/Step/Data/Tests.hs | 123 ++++++++++-------- 4 files changed, 152 insertions(+), 103 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Config.hs b/lib/Language/Haskell/Stylish/Config.hs index 5cf4950e..3865a8d1 100644 --- a/lib/Language/Haskell/Stylish/Config.hs +++ b/lib/Language/Haskell/Stylish/Config.hs @@ -247,7 +247,7 @@ parseRecords c o = Data.step <$> (Data.Config <$> (o A..: "equals" >>= parseIndent) <*> (o A..: "first_field" >>= parseIndent) - <*> (o A..: "field_comment") + <*> (o A..: "field_comment" >>= parseIndent) <*> (o A..: "deriving") <*> (o A..:? "break_enums" A..!= False) <*> (o A..:? "break_single_constructors" A..!= True) @@ -260,17 +260,15 @@ parseRecords c o = Data.step maybe Data.NoMaxColumns Data.MaxColumns (configColumns c) parseIndent :: A.Value -> A.Parser Data.Indent -parseIndent = A.withText "Indent" $ \t -> - if t == "same_line" - then return Data.SameLine - else - if "indent " `T.isPrefixOf` t - then - case readMaybe (T.unpack $ T.drop 7 t) of - Just n -> return $ Data.Indent n - Nothing -> fail $ "Indent: not a number" <> T.unpack (T.drop 7 t) - else fail $ "can't parse indent setting: " <> T.unpack t - +parseIndent = \case + num@(A.Number _) -> Data.Indent <$> A.parseJSON num + A.String "same_line" -> return Data.SameLine + A.String t | "indent " `T.isPrefixOf` t -> + case readMaybe (T.unpack $ T.drop 7 t) of + Just n -> return $ Data.Indent n + Nothing -> fail $ "Indent: not a number" <> T.unpack (T.drop 7 t) + A.String t -> fail $ "can't parse indent setting: " <> T.unpack t + _ -> fail "Expected int or string for indent value" -------------------------------------------------------------------------------- parseSquash :: Config -> A.Object -> A.Parser Step diff --git a/lib/Language/Haskell/Stylish/GHC.hs b/lib/Language/Haskell/Stylish/GHC.hs index cb75fcf8..dfad431c 100644 --- a/lib/Language/Haskell/Stylish/GHC.hs +++ b/lib/Language/Haskell/Stylish/GHC.hs @@ -17,9 +17,15 @@ module Language.Haskell.Stylish.GHC -- * Deconstruction , epAnnComments + , deepAnnComments ) where -------------------------------------------------------------------------------- +import Data.Generics (Data, + Typeable, + everything, + mkQ) +import Data.List (sortOn) import qualified GHC.Driver.Ppr as GHC (showPpr) import GHC.Driver.Session (defaultDynFlags) import qualified GHC.Driver.Session as GHC @@ -31,6 +37,7 @@ import GHC.Types.SrcLoc (GenLocated SrcSpan (..), srcSpanEndLine, srcSpanStartLine) +import qualified GHC.Types.SrcLoc as GHC import qualified GHC.Utils.Outputable as GHC import qualified Language.Haskell.GhclibParserEx.GHC.Settings.Config as GHCEx @@ -68,6 +75,12 @@ showOutputable = GHC.showPpr baseDynFlags epAnnComments :: GHC.EpAnn a -> [GHC.LEpaComment] epAnnComments GHC.EpAnnNotUsed = [] -epAnnComments GHC.EpAnn {..} = case comments of +epAnnComments GHC.EpAnn {..} = priorAndFollowing comments + +deepAnnComments :: (Data a, Typeable a) => a -> [GHC.LEpaComment] +deepAnnComments = everything (++) (mkQ [] priorAndFollowing) + +priorAndFollowing :: GHC.EpAnnComments -> [GHC.LEpaComment] +priorAndFollowing = sortOn (GHC.anchor . GHC.getLoc) . \case GHC.EpaComments {..} -> priorComments GHC.EpaCommentsBalanced {..} -> priorComments ++ followingComments diff --git a/lib/Language/Haskell/Stylish/Step/Data.hs b/lib/Language/Haskell/Stylish/Step/Data.hs index 48b7325e..88ccad78 100644 --- a/lib/Language/Haskell/Stylish/Step/Data.hs +++ b/lib/Language/Haskell/Stylish/Step/Data.hs @@ -55,7 +55,7 @@ data Config = Config -- ^ Indent between type constructor and @=@ sign (measured from column 0) , cFirstField :: !Indent -- ^ Indent between data constructor and @{@ line (measured from column with data constructor name) - , cFieldComment :: !Int + , cFieldComment :: !Indent -- ^ Indent between column with @{@ and start of field line comment (this line has @cFieldComment = 2@) , cDeriving :: !Int -- ^ Indent before @deriving@ lines (measured from column 0) @@ -77,7 +77,7 @@ defaultConfig :: Config defaultConfig = Config { cEquals = Indent 4 , cFirstField = Indent 4 - , cFieldComment = 2 + , cFieldComment = Indent 2 , cDeriving = 4 , cBreakEnums = True , cBreakSingleConstructors = False @@ -88,9 +88,7 @@ defaultConfig = Config } step :: Config -> Step -step cfg = makeStep "Data" \ls m -> - let ls' = applyChanges (changes m) ls - in ls -- TODO: ls' +step cfg = makeStep "Data" \ls m -> applyChanges (changes m) ls where changes :: Module -> [ChangeLine] changes m = formatDataDecl cfg m <$> dataDecls m @@ -150,6 +148,15 @@ formatDataDecl cfg@Config{..} m decl@MkDataDecl {..} = putDataDecl :: Config -> DataDecl -> P () putDataDecl cfg@Config {..} decl = do let defn = dataDefn decl + constructorComments = commentGroups + (GHC.srcSpanToRealSrcSpan . GHC.getLocA) + (GHC.dd_cons defn) + (dataComments decl) + + onelineEnum = + isEnum decl && not cBreakEnums && + all (not . commentGroupHasComments) constructorComments + putText $ newOrData decl space putName decl @@ -159,7 +166,6 @@ putDataDecl cfg@Config {..} decl = do when (hasConstructors decl) do breakLineBeforeEq <- case (cEquals, cFirstField) of (_, Indent x) | isEnum decl && cBreakEnums -> do - -- putEolComment declPos newline >> spaces x pure True (_, _) @@ -167,9 +173,8 @@ putDataDecl cfg@Config {..} decl = do , singleConstructor decl && not cBreakSingleConstructors -> False <$ space (Indent x, _) - | isEnum decl && not cBreakEnums -> False <$ space + | onelineEnum -> False <$ space | otherwise -> do - -- putEolComment declPos newline >> spaces x pure True (SameLine, _) -> False <$ space @@ -177,41 +182,48 @@ putDataDecl cfg@Config {..} decl = do lineLengthAfterEq <- fmap (+2) getCurrentLineLength - if | isEnum decl && not cBreakEnums -> + if | onelineEnum -> putText "=" >> space >> putUnbrokenEnum cfg decl | isNewtype decl -> do putText "=" >> space forM_ (GHC.dd_cons defn) $ putNewtypeConstructor cfg - | lcon : lcons <- GHC.dd_cons defn -> do - -- when breakLineBeforeEq do - -- removeCommentTo pos >>= mapM_ \c -> putComment c >> consIndent lineLengthAfterEq - unless (isGADT decl) (putText "=" >> space) - putConstructor cfg lineLengthAfterEq lcon - forM_ lcons $ \con -> do - -- unless (cFirstField == SameLine) do - -- removeCommentTo conPos >>= mapM_ \c -> consIndent lineLengthAfterEq >> putComment c - consIndent lineLengthAfterEq - - unless (isGADT decl) (putText "|" >> space) - - putConstructor cfg lineLengthAfterEq con - -- putEolComment conPos + | not . null $ GHC.dd_cons defn -> do + forM_ (flagEnds constructorComments) $ \(CommentGroup {..}, firstGroup, lastGroup) -> do + forM_ cgPrior $ \lc -> do + putComment $ GHC.unLoc lc + consIndent lineLengthAfterEq + + forM_ (flagEnds cgItems) $ \((lcon, mbInlineComment), firstItem, lastItem) -> do + unless (isGADT decl) $ do + putText $ if firstGroup && firstItem then "=" else "|" + space + putConstructor cfg lineLengthAfterEq lcon + putMaybeLineComment $ GHC.unLoc <$> mbInlineComment + unless (lastGroup && lastItem) $ + consIndent lineLengthAfterEq + + forM_ cgFollowing $ \lc -> do + consIndent lineLengthAfterEq + putComment $ GHC.unLoc lc + | otherwise -> pure () + let derivingComments = deepAnnComments (GHC.dd_derivs defn) + when (hasDeriving decl) do - if isEnum decl && not cBreakEnums then + if onelineEnum && null derivingComments then space else do - -- removeCommentTo (defn & dd_derivs & \(L pos _) -> pos) >>= - -- mapM_ \c -> newline >> spaces cDeriving >> putComment c + forM_ derivingComments $ \lc -> do + newline + spaces cDeriving + putComment $ GHC.unLoc lc newline spaces cDeriving sep (newline >> spaces cDeriving) $ map - (\d -> do - -- putAllSpanComments (newline >> spaces cDeriving) pos - putDeriving cfg d) + (putDeriving cfg) (GHC.dd_derivs defn) where consIndent eqIndent = newline >> case (cEquals, cFirstField) of @@ -220,14 +232,19 @@ putDataDecl cfg@Config {..} decl = do (Indent x, Indent _) -> spaces x (Indent x, SameLine) -> spaces x +derivingClauseTypes + :: GHC.HsDerivingClause GHC.GhcPs -> [GHC.LHsSigType GHC.GhcPs] +derivingClauseTypes GHC.HsDerivingClause {..} = + case GHC.unLoc deriv_clause_tys of + GHC.DctSingle _ t -> [t] + GHC.DctMulti _ ts -> ts + putDeriving :: Config -> GHC.LHsDerivingClause GHC.GhcPs -> P () putDeriving Config{..} lclause = do - let GHC.HsDerivingClause {..} = GHC.unLoc lclause + let clause@GHC.HsDerivingClause {..} = GHC.unLoc lclause tys = (if cSortDeriving then sortBy compareOutputableCI else id) $ map (GHC.sig_body . GHC.unLoc) $ - case GHC.unLoc deriv_clause_tys of - GHC.DctSingle _ t -> [t] - GHC.DctMulti _ ts -> ts + derivingClauseTypes clause headTy = listToMaybe tys tailTy = drop 1 tys @@ -402,16 +419,18 @@ putConstructor cfg consIndent lcons = case GHC.unLoc lcons of space putConDeclField cfg $ GHC.unLoc item case mbInlineComment of - Just c | cFirstField cfg == SameLine -> - putMaybeLineComment . Just $ GHC.unLoc c - Just c -> do - sepDecl bracePos >> spaces (cFieldComment cfg) + Just c | Indent s <- cFieldComment cfg -> do + sepDecl bracePos >> spaces s putComment $ GHC.unLoc c + Just c | SameLine <- cFieldComment cfg -> do + putMaybeLineComment . Just $ GHC.unLoc c _ -> pure () sepDecl bracePos forM_ cgFollowing $ \lc -> do - spaces (cFieldComment cfg) + spaces $ case cFieldComment cfg of + SameLine -> 2 -- or indent to previous inline comment? + Indent n -> n putComment $ GHC.unLoc lc sepDecl bracePos -- Print docstr after final field diff --git a/tests/Language/Haskell/Stylish/Step/Data/Tests.hs b/tests/Language/Haskell/Stylish/Step/Data/Tests.hs index 5e1df658..acc59a99 100644 --- a/tests/Language/Haskell/Stylish/Step/Data/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Data/Tests.hs @@ -76,6 +76,8 @@ tests = testGroup "Language.Haskell.Stylish.Step.Data.Tests" , testCase "case 61 (issue 282)" case61 , testCase "case 62 (issue 273)" case62 , testCase "case 63 (issue 338)" case63 + , testCase "case 64" case64 + , testCase "case 65" case65 ] case00 :: Assertion @@ -318,25 +320,22 @@ case14 = assertSnippet (step indentIndentStyle) input expected ] case15 :: Assertion -case15 = assertSnippet (step indentIndentStyle) input expected - where - input = - [ "module Herp where" - , "" - , "data Foo a = Foo" - , " { a :: a, -- comment" - , " a2 :: String" - , " }" - ] - expected = - [ "module Herp where" - , "" - , "data Foo a" - , " = Foo" - , " { a :: a -- comment" - , " , a2 :: String" - , " }" - ] +case15 = assertSnippet (step indentIndentStyle {cFieldComment = SameLine}) + [ "module Herp where" + , "" + , "data Foo a = Foo" + , " { a :: a, -- comment" + , " a2 :: String" + , " }" + ] + [ "module Herp where" + , "" + , "data Foo a" + , " = Foo" + , " { a :: a -- comment" + , " , a2 :: String" + , " }" + ] case16 :: Assertion case16 = assertSnippet (step indentIndentStyle) @@ -1308,33 +1307,29 @@ case61 = assertSnippet (step sameIndentStyle) input expected -- -- Regression test for https://github.com/haskell/stylish-haskell/issues/273 case62 :: Assertion -case62 = assertSnippet (step sameIndentStyle) input expected - where - input = - [ "module Herp where" - , "" - , "data Foo = Foo" - , " { -- | This is a comment above some line." - , " -- It can span multiple lines." - , " fooName :: String" - , " , fooAge :: Int" - , " -- ^ This is a comment below some line." - , " -- It can span multiple lines." - , " }" - ] - - expected = - [ "module Herp where" - , "" - , "data Foo = Foo" - , " { -- | This is a comment above some line." - , " -- It can span multiple lines." - , " fooName :: String" - , " , fooAge :: Int" - , " -- ^ This is a comment below some line." - , " -- It can span multiple lines." - , " }" - ] +case62 = assertSnippet (step sameIndentStyle) + [ "module Herp where" + , "" + , "data Foo = Foo" + , " { -- | This is a comment above some line." + , " -- It can span multiple lines." + , " fooName :: String" + , " , fooAge :: Int" + , " -- ^ This is a comment below some line." + , " -- It can span multiple lines." + , " }" + ] + [ "module Herp where" + , "" + , "data Foo = Foo" + , " { -- | This is a comment above some line." + , " -- It can span multiple lines." + , " fooName :: String" + , " , fooAge :: Int" + , " -- ^ This is a comment below some line." + , " -- It can span multiple lines." + , " }" + ] case63 :: Assertion case63 = assertSnippet (step indentIndentStyle) input expected @@ -1347,20 +1342,44 @@ case63 = assertSnippet (step indentIndentStyle) input expected ] expected = input +case64 :: Assertion +case64 = assertSnippet (step indentIndentStyle) input input + where + input = + [ "data Foo" + , " = Bar Int" + , " -- ^ Following comment" + , " | Qux Int" + , " -- ^ Second following comment" + , " deriving (Show)" + ] + +case65 :: Assertion +case65 = assertSnippet (step indentIndentStyle) input input + where + input = + [ "data Foo" + , " = Bar" + , " -- ^ Following comment" + , " | Qux" + , " -- ^ Second following comment" + , " deriving (Show)" + ] + sameSameStyle :: Config -sameSameStyle = Config SameLine SameLine 2 2 False True SameLine False True NoMaxColumns +sameSameStyle = Config SameLine SameLine (Indent 2) 2 False True SameLine False True NoMaxColumns sameIndentStyle :: Config -sameIndentStyle = Config SameLine (Indent 2) 2 2 False True SameLine False True NoMaxColumns +sameIndentStyle = Config SameLine (Indent 2) (Indent 2) 2 False True SameLine False True NoMaxColumns indentSameStyle :: Config -indentSameStyle = Config (Indent 2) SameLine 2 2 False True SameLine False True NoMaxColumns +indentSameStyle = Config (Indent 2) SameLine (Indent 2) 2 False True SameLine False True NoMaxColumns indentIndentStyle :: Config -indentIndentStyle = Config (Indent 2) (Indent 2) 2 2 False True SameLine False True NoMaxColumns +indentIndentStyle = Config (Indent 2) (Indent 2) (Indent 2) 2 False True SameLine False True NoMaxColumns indentIndentStyle4 :: Config -indentIndentStyle4 = Config (Indent 4) (Indent 4) 4 4 False True SameLine False True NoMaxColumns +indentIndentStyle4 = Config (Indent 4) (Indent 4) (Indent 4) 4 False True SameLine False True NoMaxColumns sameSameNoSortStyle :: Config -sameSameNoSortStyle = Config SameLine SameLine 2 2 False True SameLine False False NoMaxColumns +sameSameNoSortStyle = Config SameLine SameLine (Indent 2) 2 False True SameLine False False NoMaxColumns From d363adea5dc2efe779d276cae972110877c47412 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Wed, 16 Mar 2022 20:16:00 +0100 Subject: [PATCH 30/32] Bump dependencies --- stylish-haskell.cabal | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/stylish-haskell.cabal b/stylish-haskell.cabal index da68174e..fbef01b1 100644 --- a/stylish-haskell.cabal +++ b/stylish-haskell.cabal @@ -28,7 +28,7 @@ Common depends Default-language: Haskell2010 Build-depends: - aeson >= 0.6 && < 1.6, + aeson >= 0.6 && < 2.1, base >= 4.8 && < 5, bytestring >= 0.9 && < 0.11, Cabal >= 3.4 && < 3.7, @@ -93,7 +93,7 @@ Executable stylish-haskell Build-depends: stylish-haskell, strict >= 0.3 && < 0.5, - optparse-applicative >= 0.12 && < 0.17 + optparse-applicative >= 0.12 && < 0.18 Test-suite stylish-haskell-tests Import: depends From 5d2ea844a7108575dfe7657ff6694fa6ff19666b Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Wed, 16 Mar 2022 20:29:26 +0100 Subject: [PATCH 31/32] Cleanup --- lib/Language/Haskell/Stylish/Printer.hs | 139 ---------------------- lib/Language/Haskell/Stylish/Step/Data.hs | 51 +++----- 2 files changed, 16 insertions(+), 174 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Printer.hs b/lib/Language/Haskell/Stylish/Printer.hs index 41011d53..49098547 100644 --- a/lib/Language/Haskell/Stylish/Printer.hs +++ b/lib/Language/Haskell/Stylish/Printer.hs @@ -20,29 +20,19 @@ module Language.Haskell.Stylish.Printer -- ** Combinators , comma , dot - -- , getAnnot , getCurrentLine , getCurrentLineLength - -- , getDocstrPrev , newline , parenthesize - -- , peekNextCommentPos , prefix , putComment , putMaybeLineComment - -- , putEolComment , putOutputable - -- , putAllSpanComments , putCond , putType , putRdrName , putText - -- , removeCommentTo - -- , removeCommentToEnd - -- , removeLineComment , sep - -- , groupAttachedComments - -- , groupWithoutComments , space , spaces , suffix @@ -160,23 +150,6 @@ putMaybeLineComment = \case Nothing -> pure () Just cmt -> space >> putComment cmt --- | 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 epaComment | GHC.EpaLineComment s <- GHC.ac_tok epaComment -> - and - [ srcSpanStartLine rspan == srcSpanStartLine rloc - , not ("-- ^" `isPrefixOf` s) - , not ("-- |" `isPrefixOf` s) - ] - _ -> False - forM_ cmt (\c -> space >> putComment c) - UnhelpfulSpan _ -> pure () --} - -- | Print a 'RdrName' putRdrName :: GenLocated GHC.SrcSpanAnnN RdrName -> P () putRdrName rdrName = case GHC.unLoc rdrName of @@ -295,21 +268,6 @@ putType ltp = case GHC.unLoc ltp of GHC.XHsType _ -> putOutputable ltp --- | Get a docstring on the start line of 'SrcSpan' that is a @-- ^@ comment -{- -getDocstrPrev :: SrcSpan -> P (Maybe GHC.EpaComment) -getDocstrPrev = \case - UnhelpfulSpan _ -> pure Nothing - RealSrcSpan rspan -> do - removeComment \case - L rloc epaComment | GHC.EpaLineComment s <- GHC.ac_tok epaComment -> - and - [ srcSpanStartLine rspan == srcSpanStartLine rloc - , "-- ^" `isPrefixOf` s - ] - _ -> False --} - -- | Print a newline newline :: P () newline = do @@ -356,60 +314,6 @@ pad n = do len <- length <$> getCurrentLine spaces $ n - len -{- --- | Gets comment on supplied 'line' and removes it from the state -removeLineComment :: Int -> P (Maybe GHC.EpaComment) -removeLineComment line = - removeComment (\(L rloc _) -> srcSpanStartLine rloc == line) - --- | Removes comments from the state up to start line of 'SrcSpan' and returns --- the ones that were removed -removeCommentTo :: SrcSpan -> P [GHC.EpaComment] -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 [GHC.EpaComment] -removeCommentToEnd = \case - UnhelpfulSpan _ -> pure [] - RealSrcSpan rspan -> removeCommentTo' (srcSpanEndLine rspan) - --- | Removes comments to the line number given and returns the ones removed -removeCommentTo' :: Int -> P [GHC.EpaComment] -removeCommentTo' line = - removeComment (\(L rloc _) -> srcSpanStartLine rloc < line) >>= \case - Nothing -> pure [] - Just c -> do - rest <- removeCommentTo' line - pure (c : rest) - --- | Removes comments from the state while given predicate 'p' is true -removeComments :: (GHC.RealLocated GHC.EpaComment -> Bool) -> P [GHC.EpaComment] -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 :: (GHC.RealLocated GHC.EpaComment -> Bool) -> P (Maybe GHC.EpaComment) -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 --} - -- | Get current line getCurrentLine :: P String getCurrentLine = gets currentLine @@ -418,49 +322,6 @@ getCurrentLine = gets currentLine getCurrentLineLength :: P Int getCurrentLineLength = fmap length getCurrentLine --- | Peek at the next comment in the state -{- -peekNextCommentPos :: P (Maybe SrcSpan) -peekNextCommentPos = do - gets pendingComments <&> \case - (L next _ : _) -> Just (RealSrcSpan next) - [] -> Nothing --} - --- | Get attached comments belonging to '[Located a]' given -{- -groupAttachedComments :: [Located a] -> P [([GHC.EpaComment], NonEmpty (Located a))] -groupAttachedComments = go - where - go :: [Located a] -> P [([GHC.EpaComment], NonEmpty (Located a))] - go (L rspan x : xs) = do - comments <- removeCommentTo rspan - 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 rspan x :| sameGroupOf nextGroupStartM) : restGroups - - go _ = pure [] - --- | A view on 'groupAttachedComments': return 'Just' when there is just a --- one big group without any comments. -groupWithoutComments - :: [([GHC.EpaComment], NonEmpty (Located a))] - -> Maybe [Located a] -groupWithoutComments grouped - | all (null . fst) grouped - = Just $ concatMap (toList . snd) grouped - | otherwise - = Nothing --} - modifyCurrentLine :: (String -> String) -> P () modifyCurrentLine f = do s0 <- get diff --git a/lib/Language/Haskell/Stylish/Step/Data.hs b/lib/Language/Haskell/Stylish/Step/Data.hs index 88ccad78..44dac368 100644 --- a/lib/Language/Haskell/Stylish/Step/Data.hs +++ b/lib/Language/Haskell/Stylish/Step/Data.hs @@ -20,7 +20,6 @@ module Language.Haskell.Stylish.Step.Data import Control.Monad (forM_, unless, when) import Data.List (sortBy) import Data.Maybe (listToMaybe, maybeToList) -import Debug.Trace import qualified GHC.Hs as GHC import qualified GHC.Types.Fixity as GHC import qualified GHC.Types.Name.Reader as GHC @@ -91,7 +90,7 @@ step :: Config -> Step step cfg = makeStep "Data" \ls m -> applyChanges (changes m) ls where changes :: Module -> [ChangeLine] - changes m = formatDataDecl cfg m <$> dataDecls m + changes m = formatDataDecl cfg <$> dataDecls m dataDecls :: Module -> [DataDecl] dataDecls m = do @@ -121,18 +120,10 @@ data DataDecl = MkDataDecl } -formatDataDecl :: Config -> Module -> DataDecl -> ChangeLine -formatDataDecl cfg@Config{..} m decl@MkDataDecl {..} = +formatDataDecl :: Config -> DataDecl -> ChangeLine +formatDataDecl cfg@Config{..} decl@MkDataDecl {..} = change originalDeclBlock (const printedDecl) where - {- - relevantComments :: [RealLocated AnnotationComment] - relevantComments - = moduleComments m - & rawComments - & dropBeforeAndAfter ldecl - -} - originalDeclBlock = Block (GHC.srcSpanStartLine dataLoc) (GHC.srcSpanEndLine dataLoc) @@ -164,21 +155,16 @@ putDataDecl cfg@Config {..} decl = do when (isGADT decl) (space >> putText "where") when (hasConstructors decl) do - breakLineBeforeEq <- case (cEquals, cFirstField) of - (_, Indent x) | isEnum decl && cBreakEnums -> do - newline >> spaces x - pure True + case (cEquals, cFirstField) of + (_, Indent x) | isEnum decl && cBreakEnums -> newline >> spaces x (_, _) | not (isNewtype decl) , singleConstructor decl && not cBreakSingleConstructors -> - False <$ space + space (Indent x, _) - | onelineEnum -> False <$ space - | otherwise -> do - newline >> spaces x - pure True - (SameLine, _) -> False <$ space - pure () + | onelineEnum -> space + | otherwise -> newline >> spaces x + (SameLine, _) -> space lineLengthAfterEq <- fmap (+2) getCurrentLineLength @@ -360,7 +346,7 @@ putConstructor cfg consIndent lcons = case GHC.unLoc lcons of GHC.HsOuterImplicit {} -> False GHC.HsOuterExplicit {} -> True) (case GHC.unLoc con_bndrs of - GHC.HsOuterImplicit {..} -> [] + GHC.HsOuterImplicit {} -> [] GHC.HsOuterExplicit {..} -> hso_bndrs) forM_ con_mb_cxt $ putContext cfg case con_g_args of @@ -383,11 +369,11 @@ putConstructor cfg consIndent lcons = case GHC.unLoc lcons of putRdrName con_name space putType $ GHC.hsScaledThing arg2 - GHC.PrefixCon tyargs args -> do + GHC.PrefixCon _tyargs args -> do putRdrName con_name unless (null args) space sep space (fmap putOutputable args) - GHC.RecCon largs | firstArg : args <- GHC.unLoc largs -> do + GHC.RecCon largs | _ : _ <- GHC.unLoc largs -> do putRdrName con_name skipToBrace bracePos <- getCurrentLineLength @@ -400,18 +386,16 @@ putConstructor cfg consIndent lcons = case GHC.unLoc lcons of (GHC.unLoc largs) (epAnnComments . GHC.ann $ GHC.getLoc largs) - forM_ (flagEnds commented) $ \(CommentGroup {..}, firstCommentGroup, lastCommentGroup) -> do + forM_ (flagEnds commented) $ \(CommentGroup {..}, firstCommentGroup, _) -> do -- 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 forM_ cgPrior $ \lc -> do pad fieldPos putComment $ GHC.unLoc lc - sepDecl bracePos -- >> spaces (cFieldComment cfg) + sepDecl bracePos - forM_ (flagEnds cgItems) $ \((item, mbInlineComment), firstItem, lastItem) -> do + forM_ (flagEnds cgItems) $ \((item, mbInlineComment), firstItem, _) -> do if firstCommentGroup && firstItem then pad fieldPos else do @@ -433,9 +417,6 @@ putConstructor cfg consIndent lcons = case GHC.unLoc lcons of Indent n -> n putComment $ GHC.unLoc lc sepDecl bracePos - -- Print docstr after final field - -- removeCommentToEnd recPos >>= mapM_ \c -> - -- sepDecl bracePos >> spaces (cFieldComment cfg) >> putComment c -- Print whitespace to closing brace putText "}" @@ -474,7 +455,7 @@ putNewtypeConstructor cfg lcons = case GHC.unLoc lcons of putConDeclField cfg $ GHC.unLoc firstArg space putText "}" - GHC.RecCon largs -> + GHC.RecCon {} -> error . mconcat $ [ "Language.Haskell.Stylish.Step.Data.putNewtypeConstructor: " , "encountered newtype with several arguments" From 9cddf9f761cf3431f0b7e6afa708532e3050c904 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Wed, 16 Mar 2022 20:37:03 +0100 Subject: [PATCH 32/32] Consistent field comment indentation --- lib/Language/Haskell/Stylish/Config.hs | 5 ++--- lib/Language/Haskell/Stylish/Step/Data.hs | 14 +++++--------- .../Language/Haskell/Stylish/Step/Data/Tests.hs | 17 +++++++++-------- 3 files changed, 16 insertions(+), 20 deletions(-) diff --git a/lib/Language/Haskell/Stylish/Config.hs b/lib/Language/Haskell/Stylish/Config.hs index 3865a8d1..5c11ef9b 100644 --- a/lib/Language/Haskell/Stylish/Config.hs +++ b/lib/Language/Haskell/Stylish/Config.hs @@ -247,7 +247,7 @@ parseRecords c o = Data.step <$> (Data.Config <$> (o A..: "equals" >>= parseIndent) <*> (o A..: "first_field" >>= parseIndent) - <*> (o A..: "field_comment" >>= parseIndent) + <*> (o A..: "field_comment") <*> (o A..: "deriving") <*> (o A..:? "break_enums" A..!= False) <*> (o A..:? "break_single_constructors" A..!= True) @@ -261,14 +261,13 @@ parseRecords c o = Data.step parseIndent :: A.Value -> A.Parser Data.Indent parseIndent = \case - num@(A.Number _) -> Data.Indent <$> A.parseJSON num A.String "same_line" -> return Data.SameLine A.String t | "indent " `T.isPrefixOf` t -> case readMaybe (T.unpack $ T.drop 7 t) of Just n -> return $ Data.Indent n Nothing -> fail $ "Indent: not a number" <> T.unpack (T.drop 7 t) A.String t -> fail $ "can't parse indent setting: " <> T.unpack t - _ -> fail "Expected int or string for indent value" + _ -> fail "Expected string for indent value" -------------------------------------------------------------------------------- parseSquash :: Config -> A.Object -> A.Parser Step diff --git a/lib/Language/Haskell/Stylish/Step/Data.hs b/lib/Language/Haskell/Stylish/Step/Data.hs index 44dac368..fd53b794 100644 --- a/lib/Language/Haskell/Stylish/Step/Data.hs +++ b/lib/Language/Haskell/Stylish/Step/Data.hs @@ -54,7 +54,7 @@ data Config = Config -- ^ Indent between type constructor and @=@ sign (measured from column 0) , cFirstField :: !Indent -- ^ Indent between data constructor and @{@ line (measured from column with data constructor name) - , cFieldComment :: !Indent + , cFieldComment :: !Int -- ^ Indent between column with @{@ and start of field line comment (this line has @cFieldComment = 2@) , cDeriving :: !Int -- ^ Indent before @deriving@ lines (measured from column 0) @@ -76,7 +76,7 @@ defaultConfig :: Config defaultConfig = Config { cEquals = Indent 4 , cFirstField = Indent 4 - , cFieldComment = Indent 2 + , cFieldComment = 2 , cDeriving = 4 , cBreakEnums = True , cBreakSingleConstructors = False @@ -403,18 +403,14 @@ putConstructor cfg consIndent lcons = case GHC.unLoc lcons of space putConDeclField cfg $ GHC.unLoc item case mbInlineComment of - Just c | Indent s <- cFieldComment cfg -> do - sepDecl bracePos >> spaces s + Just c -> do + sepDecl bracePos >> spaces (cFieldComment cfg) putComment $ GHC.unLoc c - Just c | SameLine <- cFieldComment cfg -> do - putMaybeLineComment . Just $ GHC.unLoc c _ -> pure () sepDecl bracePos forM_ cgFollowing $ \lc -> do - spaces $ case cFieldComment cfg of - SameLine -> 2 -- or indent to previous inline comment? - Indent n -> n + spaces $ cFieldComment cfg putComment $ GHC.unLoc lc sepDecl bracePos diff --git a/tests/Language/Haskell/Stylish/Step/Data/Tests.hs b/tests/Language/Haskell/Stylish/Step/Data/Tests.hs index acc59a99..6904a8b0 100644 --- a/tests/Language/Haskell/Stylish/Step/Data/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Data/Tests.hs @@ -320,7 +320,7 @@ case14 = assertSnippet (step indentIndentStyle) input expected ] case15 :: Assertion -case15 = assertSnippet (step indentIndentStyle {cFieldComment = SameLine}) +case15 = assertSnippet (step indentIndentStyle) [ "module Herp where" , "" , "data Foo a = Foo" @@ -332,7 +332,8 @@ case15 = assertSnippet (step indentIndentStyle {cFieldComment = SameLine}) , "" , "data Foo a" , " = Foo" - , " { a :: a -- comment" + , " { a :: a" + , " -- comment" , " , a2 :: String" , " }" ] @@ -1367,19 +1368,19 @@ case65 = assertSnippet (step indentIndentStyle) input input ] sameSameStyle :: Config -sameSameStyle = Config SameLine SameLine (Indent 2) 2 False True SameLine False True NoMaxColumns +sameSameStyle = Config SameLine SameLine 2 2 False True SameLine False True NoMaxColumns sameIndentStyle :: Config -sameIndentStyle = Config SameLine (Indent 2) (Indent 2) 2 False True SameLine False True NoMaxColumns +sameIndentStyle = Config SameLine (Indent 2) 2 2 False True SameLine False True NoMaxColumns indentSameStyle :: Config -indentSameStyle = Config (Indent 2) SameLine (Indent 2) 2 False True SameLine False True NoMaxColumns +indentSameStyle = Config (Indent 2) SameLine 2 2 False True SameLine False True NoMaxColumns indentIndentStyle :: Config -indentIndentStyle = Config (Indent 2) (Indent 2) (Indent 2) 2 False True SameLine False True NoMaxColumns +indentIndentStyle = Config (Indent 2) (Indent 2) 2 2 False True SameLine False True NoMaxColumns indentIndentStyle4 :: Config -indentIndentStyle4 = Config (Indent 4) (Indent 4) (Indent 4) 4 False True SameLine False True NoMaxColumns +indentIndentStyle4 = Config (Indent 4) (Indent 4) 4 4 False True SameLine False True NoMaxColumns sameSameNoSortStyle :: Config -sameSameNoSortStyle = Config SameLine SameLine (Indent 2) 2 False True SameLine False False NoMaxColumns +sameSameNoSortStyle = Config SameLine SameLine 2 2 False True SameLine False False NoMaxColumns