diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,5 +1,10 @@ # CHANGELOG +- 0.14.0.0 (2022-03-16) + * Port to GHC 9.2 AST (by jaspervdj) + * Case insensitive import sort (by vlatkoB) + * Fix issue with dissappearing GADT kind signatures (by Łukasz Gołębiewski) + - 0.13.0.0 (2021-09-15) * Don't remove ticks on promoted data types (by Jim McStanton) * Add break_only_where option (by 1Computer1) diff --git a/data/stylish-haskell.yaml b/data/stylish-haskell.yaml --- a/data/stylish-haskell.yaml +++ b/data/stylish-haskell.yaml @@ -85,7 +85,7 @@ # # Sort typeclass names in the "deriving" list alphabetically. # sort_deriving: true # - # # Wheter or not to break enums onto several lines + # # Whether or not to break enums onto several lines # # # # Default: false # break_enums: false diff --git a/lib/Language/Haskell/Stylish/Align.hs b/lib/Language/Haskell/Stylish/Align.hs --- a/lib/Language/Haskell/Stylish/Align.hs +++ b/lib/Language/Haskell/Stylish/Align.hs @@ -8,7 +8,7 @@ -------------------------------------------------------------------------------- import Data.List (nub) -import qualified SrcLoc as S +import qualified GHC.Types.SrcLoc as GHC -------------------------------------------------------------------------------- @@ -55,9 +55,9 @@ -- | 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 @@ 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 @@ -- | 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/Block.hs b/lib/Language/Haskell/Stylish/Block.hs --- 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 @@ -------------------------------------------------------------------------------- -import qualified Data.IntSet as IS +import qualified Data.IntSet as IS +import qualified GHC.Types.SrcLoc as GHC -------------------------------------------------------------------------------- @@ -22,11 +24,15 @@ data Block a = Block { blockStart :: Int , blockEnd :: Int - } - deriving (Eq, Ord, Show) + } deriving (Eq, Ord, Show) -------------------------------------------------------------------------------- +instance Semigroup (Block a) where + (<>) = merge + + +-------------------------------------------------------------------------------- type LineBlock = Block String @@ -35,9 +41,15 @@ -------------------------------------------------------------------------------- +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 @@ 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 --- /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/Config.hs b/lib/Language/Haskell/Stylish/Config.hs --- a/lib/Language/Haskell/Stylish/Config.hs +++ b/lib/Language/Haskell/Stylish/Config.hs @@ -260,17 +260,14 @@ 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 + 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 string for indent value" -------------------------------------------------------------------------------- parseSquash :: Config -> A.Object -> A.Parser Step diff --git a/lib/Language/Haskell/Stylish/Config/Cabal.hs b/lib/Language/Haskell/Stylish/Config/Cabal.hs --- a/lib/Language/Haskell/Stylish/Config/Cabal.hs +++ b/lib/Language/Haskell/Stylish/Config/Cabal.hs @@ -11,7 +11,6 @@ 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/lib/Language/Haskell/Stylish/Editor.hs b/lib/Language/Haskell/Stylish/Editor.hs --- 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 --- a/lib/Language/Haskell/Stylish/GHC.hs +++ b/lib/Language/Haskell/Stylish/GHC.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -Wno-missing-fields #-} -- | Utility functions for working with the GHC AST module Language.Haskell.Stylish.GHC @@ -11,35 +12,39 @@ , getStartLineUnsafe -- * Standard settings , baseDynFlags - -- * Positions - , unLocated -- * Outputable operators , showOutputable - , compareOutputable - ) where --------------------------------------------------------------------------------- -import Data.Function (on) + -- * Deconstruction + , epAnnComments + , deepAnnComments + ) 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 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 +import qualified GHC.Hs as GHC +import GHC.Types.SrcLoc (GenLocated (..), + Located, + RealLocated, + RealSrcSpan, + 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 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 @@ -49,13 +54,13 @@ 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 @@ -63,41 +68,19 @@ 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 -compareOutputable :: GHC.Outputable a => a -> a -> Ordering -compareOutputable = compare `on` showOutputable +epAnnComments :: GHC.EpAnn a -> [GHC.LEpaComment] +epAnnComments GHC.EpAnnNotUsed = [] +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/Module.hs b/lib/Language/Haskell/Stylish/Module.hs --- a/lib/Language/Haskell/Stylish/Module.hs +++ b/lib/Language/Haskell/Stylish/Module.hs @@ -1,199 +1,89 @@ -{-# 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 RecordWildCards #-} +{-# LANGUAGE TupleSections #-} module Language.Haskell.Stylish.Module ( -- * Data types - Module (..) - , ModuleHeader - , Import - , Decls - , Comments + Module + , Comments (..) , Lines - , makeModule -- * Getters - , moduleHeader - , moduleImports , moduleImportGroups - , moduleDecls - , moduleComments - , moduleLanguagePragmas , queryModule , groupByLine -- * Imports , canMergeImport , mergeModuleImport - - -- * Annotations - , lookupAnnotation + , importModuleName - -- * Internal API getters - , rawComments - , rawImport - , rawModuleAnnotations - , rawModuleDecls - , rawModuleExports - , rawModuleHaddocks - , rawModuleName + -- * Pragmas + , moduleLanguagePragmas ) 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 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 Data.Char (toLower) +import Data.Function (on) +import Data.Generics (Typeable, everything, mkQ) +import qualified Data.List as L +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Maybe (fromMaybe, mapMaybe) +import GHC.Hs (ImportDecl (..), + ImportDeclQualifiedStyle (..)) +import qualified GHC.Hs as GHC +import GHC.Hs.Extension (GhcPs) +import GHC.Types.SrcLoc (GenLocated (..), + RealSrcSpan (..), unLoc) +import qualified GHC.Types.SrcLoc as GHC +import qualified GHC.Unit.Module.Name as GHC + -------------------------------------------------------------------------------- import Language.Haskell.Stylish.GHC + -------------------------------------------------------------------------------- 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 } - 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) - [ (==) `on` unLocated . ideclName +canMergeImport :: ImportDecl GhcPs -> ImportDecl GhcPs -> Bool +canMergeImport i0 i1 = and $ fmap (\f -> f i0 i1) + [ (==) `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 - -instance Eq Import where - i0 == i1 = canMergeImport i0 i1 && hasSameImports (unImport i0) (unImport i1) - where - hasSameImports = (==) `on` fmap snd . ideclHiding - -instance Ord Import where - compare (Import i0) (Import i1) = - ideclName i0 `compareOutputable` ideclName i1 <> - fmap showOutputable (ideclPkgQual i0) `compare` - fmap showOutputable (ideclPkgQual i1) <> - compareOutputable i0 i1 + 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 - --- | Get module imports -moduleImports :: Module -> [Located Import] -moduleImports m - = parsedModule m - & unLocated - & GHC.hsmodImports - & fmap \(L pos i) -> L pos (Import i) +newtype Comments = Comments [GHC.RealLocated GHC.EpaComment] -- | 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] @@ -223,9 +113,11 @@ -- 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 @@ -234,50 +126,24 @@ (Just x, Nothing) -> Just x (Nothing, Just x) -> Just x merge xs ys - = nubBy ((==) `on` showOutputable) (xs ++ ys) - --- | Get module header -moduleHeader :: Module -> ModuleHeader -moduleHeader (Module _ _ _ (GHC.L _ m)) = ModuleHeader - { 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 _) _ = [] + = L.nubBy ((==) `on` showOutputable) (xs ++ ys) -- | 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 +queryModule f = everything (++) (mkQ [] f) --- | Getter for internal module comments representation -rawComments :: Comments -> [GHC.RealLocated GHC.AnnotationComment] -rawComments (Comments xs) = xs +moduleLanguagePragmas :: Module -> [(RealSrcSpan, NonEmpty String)] +moduleLanguagePragmas = + 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 + GHC.EpaBlockComment str + | lang : p1 : ps <- tokenize str, map toLower lang == "language" -> + pure (GHC.anchor (GHC.getLoc comment), p1 :| ps) + _ -> Nothing --- | Getter for internal module annotation representation -rawModuleAnnotations :: Module -> [(GHC.ApiAnnKey, [GHC.SrcSpan])] -rawModuleAnnotations = parsedAnnotations + tokenize = words . + map (\c -> if c == ',' then ' ' else c) . + takeWhile (/= '#') . + drop 1 . dropWhile (/= '#') diff --git a/lib/Language/Haskell/Stylish/Ordering.hs b/lib/Language/Haskell/Stylish/Ordering.hs --- a/lib/Language/Haskell/Stylish/Ordering.hs +++ b/lib/Language/Haskell/Stylish/Ordering.hs @@ -4,23 +4,36 @@ -- utilities. {-# LANGUAGE LambdaCase #-} module Language.Haskell.Stylish.Ordering - ( compareLIE + ( compareImports + , compareLIE , compareWrappedName - , unwrapName + , compareOutputableCI ) where -------------------------------------------------------------------------------- -import Data.Char (isUpper) -import Data.Ord (comparing) +import Data.Char (isUpper, toLower) +import Data.Function (on) +import Data.Ord (comparing) import GHC.Hs -import RdrName (RdrName) -import SrcLoc (unLoc) +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.GHC (showOutputable) -import Outputable (Outputable) +-- | Compare imports for sorting. Cannot easily be a lawful instance due to +-- case insensitivity. +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) <> + compareOutputableCI i0 i1 -------------------------------------------------------------------------------- @@ -33,12 +46,12 @@ -- 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, "") -------------------------------------------------------------------------------- @@ -47,15 +60,13 @@ -------------------------------------------------------------------------------- -unwrapName :: IEWrappedName n -> n -unwrapName (IEName n) = unLoc n -unwrapName (IEPattern n) = unLoc n -unwrapName (IEType n) = unLoc n - - --------------------------------------------------------------------------------- nameKey :: Outputable name => name -> (Int, String) nameKey n = case showOutputable n of o@('(' : _) -> (2, o) o@(o0 : _) | isUpper o0 -> (0, o) o -> (1, o) + + +-------------------------------------------------------------------------------- +compareOutputableCI :: GHC.Outputable a => a -> a -> Ordering +compareOutputableCI = compare `on` (map toLower . showOutputable) diff --git a/lib/Language/Haskell/Stylish/Parse.hs b/lib/Language/Haskell/Stylish/Parse.hs --- 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,35 +5,36 @@ -------------------------------------------------------------------------------- -import Data.Function ((&)) -import Data.Maybe (fromMaybe, listToMaybe) -import System.IO.Unsafe (unsafePerformIO) +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 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 Language.Haskell.Stylish.GHC import Language.Haskell.Stylish.Module + +-------------------------------------------------------------------------------- type Extensions = [String] + -------------------------------------------------------------------------------- -- | Filter out lines which use CPP macros unCpp :: String -> String @@ -46,6 +46,7 @@ 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. @@ -57,67 +58,41 @@ -------------------------------------------------------------------------------- -- | 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 - 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? +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 - toLocatedExtensionFlag flag - = "-X" <> flag - & GHC.L GHC.noSrcSpan + -- Build first dynflags. + let dynFlags0 = foldl' turnOn baseDynFlags externalExts1 - getParserStateErrors dynFlags state - = GHC.getErrorMessages state dynFlags - & bagToList - & fmap (\errMsg -> show (GHC.errMsgSpan errMsg) <> ": " <> show errMsg) + -- Parse options from file + let fileOptions = fmap GHC.unLoc $ GHC.getOptions dynFlags0 + (GHC.stringToStringBuffer string) + (fromMaybe "-" fp) + fileExtensions = mapMaybe + (stripPrefix "-X" >=> GHCEx.readExtension) + fileOptions - filePath = - fromMaybe "" fp + -- Set further dynflags. + let dynFlags1 = foldl' turnOn dynFlags0 fileExtensions + `GHC.gopt_set` GHC.Opt_KeepRawTokenStream - 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 + -- Possibly strip CPP. + let removeCpp s = if GHC.xopt LangExt.Cpp dynFlags1 then unCpp s else s + input = removeCpp $ dropBom string --- | 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 + -- 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 - catchErrors act = GHC.handleGhcException reportErr (GHC.handleSourceError reportErr act) - reportErr e = return $ Left (show e) + withFileName x = maybe "" (<> ": ") fp <> x + + turnOn dynFlags ext = foldl' + turnOn + (GHC.xopt_set dynFlags ext) + [rhs | (lhs, True, rhs) <- GHC.impliedXFlags, lhs == ext] diff --git a/lib/Language/Haskell/Stylish/Printer.hs b/lib/Language/Haskell/Stylish/Printer.hs --- a/lib/Language/Haskell/Stylish/Printer.hs +++ b/lib/Language/Haskell/Stylish/Printer.hs @@ -1,10 +1,10 @@ -{-# LANGUAGE BangPatterns #-} -{-# 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(..) @@ -20,28 +20,19 @@ -- ** Combinators , comma , dot - , getAnnot , getCurrentLine , getCurrentLineLength - , getDocstrPrev , newline , parenthesize - , peekNextCommentPos , prefix , putComment - , putEolComment + , putMaybeLineComment , putOutputable - , putAllSpanComments , putCond , putType , putRdrName , putText - , removeCommentTo - , removeCommentToEnd - , removeLineComment , sep - , groupAttachedComments - , groupWithoutComments , space , spaces , suffix @@ -57,31 +48,26 @@ 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 qualified GHC.Hs as GHC +import GHC.Hs.Extension (GhcPs) +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 Data.Foldable (find, toList) -import Data.Functor ((<&>)) -import Data.List (delete, isPrefixOf) -import Data.List.NonEmpty (NonEmpty(..)) +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, lookupAnnotation) -import Language.Haskell.Stylish.GHC (showOutputable, unLocated) +import Language.Haskell.Stylish.GHC (showOutputable) +import Language.Haskell.Stylish.Module (Lines) -- | Shorthand for 'Printer' monad type P = Printer @@ -97,24 +83,22 @@ -- | State of printer data PrinterState = PrinterState - { lines :: !Lines - , linePos :: !Int + { lines :: !Lines + , linePos :: !Int , currentLine :: !String - , pendingComments :: ![RealLocated AnnotationComment] - , parsedModule :: !Module } -- | Run printer to get printed lines out of module as well as return value of monad -runPrinter :: PrinterConfig -> [RealLocated AnnotationComment] -> Module -> Printer a -> (a, Lines) -runPrinter cfg comments m (Printer printer) = +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 -> [RealLocated AnnotationComment] -> 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 () @@ -137,6 +121,7 @@ -- | Put all comments that has positions within 'SrcSpan' and separate by -- passed @P ()@ +{- putAllSpanComments :: P () -> SrcSpan -> P () putAllSpanComments suff = \case UnhelpfulSpan _ -> pure () @@ -146,150 +131,143 @@ 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) -> - and - [ srcSpanStartLine rspan == srcSpanStartLine rloc - , not ("-- ^" `isPrefixOf` s) - , not ("-- |" `isPrefixOf` s) - ] - _ -> False - forM_ cmt (\c -> space >> putComment c) - UnhelpfulSpan _ -> pure () +putMaybeLineComment :: Maybe GHC.EpaComment -> P () +putMaybeLineComment = \case + Nothing -> pure () + Just cmt -> space >> putComment cmt -- | 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 "(" - putText (showOutputable name) - putText ")" - else if AnnBackquote `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 AnnSimpleQuote `elem` annots then do - putText "'" + putText post + Qual modulePrefix name -> + putModuleName modulePrefix >> dot >> putText (showOutputable name) + Orig _ name -> putText (showOutputable name) - else + Exact name -> 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 "->" + case arrowTp of + GHC.HsUnrestrictedArrow {} -> putText "->" + GHC.HsLinearArrow {} -> putText "%1 ->" + GHC.HsExplicitMult {} -> 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 = \case - UnhelpfulSpan _ -> pure Nothing - RealSrcSpan rspan -> do - removeComment \case - L rloc (AnnLineComment s) -> - and - [ srcSpanStartLine rspan == srcSpanStartLine rloc - , "-- ^" `isPrefixOf` s - ] - _ -> False - -- | Print a newline newline :: P () newline = do @@ -318,7 +296,7 @@ -- | 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 @@ -336,62 +314,6 @@ len <- length <$> getCurrentLine spaces $ n - len --- | Gets comment on supplied 'line' and removes it from the state -removeLineComment :: Int -> P (Maybe AnnotationComment) -removeLineComment line = - removeComment (\(L rloc _) -> srcSpanStartLine rloc == line) - --- | Removes comments from the state up to start line of 'SrcSpan' and returns --- the ones that were removed -removeCommentTo :: SrcSpan -> P [AnnotationComment] -removeCommentTo = \case - UnhelpfulSpan _ -> pure [] - RealSrcSpan rspan -> removeCommentTo' (srcSpanStartLine rspan) - --- | Removes comments from the state up to end line of 'SrcSpan' and returns --- the ones that were removed -removeCommentToEnd :: SrcSpan -> P [AnnotationComment] -removeCommentToEnd = \case - UnhelpfulSpan _ -> pure [] - RealSrcSpan rspan -> removeCommentTo' (srcSpanEndLine rspan) - --- | Removes comments to the line number given and returns the ones removed -removeCommentTo' :: Int -> P [AnnotationComment] -removeCommentTo' line = - removeComment (\(L rloc _) -> srcSpanStartLine rloc < line) >>= \case - Nothing -> pure [] - Just c -> do - rest <- removeCommentTo' line - pure (c : rest) - --- | Removes comments from the state while given predicate 'p' is true -removeComments :: (RealLocated AnnotationComment -> Bool) -> P [AnnotationComment] -removeComments p = - removeComment p >>= \case - Just c -> do - rest <- removeComments p - pure (c : rest) - Nothing -> pure [] - --- | Remove a comment from the state given predicate 'p' -removeComment :: (RealLocated AnnotationComment -> Bool) -> P (Maybe AnnotationComment) -removeComment p = do - 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 all annotations for 'SrcSpan' -getAnnot :: SrcSpan -> P [AnnKeywordId] -getAnnot spn = gets (lookupAnnotation spn . parsedModule) - -- | Get current line getCurrentLine :: P String getCurrentLine = gets currentLine @@ -399,45 +321,6 @@ -- | Get current line length 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 = go - where - go :: [Located a] -> P [([AnnotationComment], 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 - :: [([AnnotationComment], 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 --- 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,45 +15,30 @@ , step ) where --------------------------------------------------------------------------------- -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 Control.Monad (forM_, unless, when) +import Data.List (sortBy) +import Data.Maybe (listToMaybe, maybeToList) +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 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 (..), LHsQTyVars (..)) -import RdrName (RdrName) -import SrcLoc (GenLocated (..), Located, - RealLocated) -------------------------------------------------------------------------------- -import Language.Haskell.Stylish.Block 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 + +-------------------------------------------------------------------------------- data Indent = SameLine | Indent !Int @@ -102,208 +90,214 @@ step cfg = makeStep "Data" \ls m -> applyChanges (changes m) ls where changes :: Module -> [ChangeLine] - changes m = fmap (formatDataDecl cfg m) (dataDecls m) + changes m = formatDataDecl cfg <$> 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 - } - _ -> [] + 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 + { dataComments = epAnnComments tcdDExt + , 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) - where - relevantComments :: [RealLocated AnnotationComment] - relevantComments - = moduleComments m - & rawComments - & dropBeforeAndAfter ldecl +data DataDecl = MkDataDecl + { dataComments :: [GHC.LEpaComment] + , dataLoc :: GHC.RealSrcSpan + , dataDeclName :: GHC.LocatedN GHC.RdrName + , dataTypeVars :: GHC.LHsQTyVars GHC.GhcPs + , dataDefn :: GHC.HsDataDefn GHC.GhcPs + , dataFixity :: GHC.LexicalFixity + } - defn = dataDefn decl - originalDeclBlock = - Block (getStartLineUnsafe ldecl) (getEndLineUnsafe ldecl) +formatDataDecl :: Config -> DataDecl -> ChangeLine +formatDataDecl cfg@Config{..} decl@MkDataDecl {..} = + change originalDeclBlock (const printedDecl) + where + 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 relevantComments m do - putText (newOrData decl) - space - putName decl + printedDecl = runPrinter_ printerConfig $ putDataDecl cfg decl - when (isGADT decl) (space >> putText "where") +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) - 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 + onelineEnum = + isEnum decl && not cBreakEnums && + all (not . commentGroupHasComments) constructorComments + putText $ newOrData decl + space + putName decl + + when (isGADT decl) (space >> putText "where") + + when (hasConstructors decl) do + case (cEquals, cFirstField) of + (_, Indent x) | isEnum decl && cBreakEnums -> newline >> spaces x + (_, _) + | not (isNewtype decl) + , singleConstructor decl && not cBreakSingleConstructors -> + space + (Indent x, _) + | onelineEnum -> space + | otherwise -> newline >> spaces x + (SameLine, _) -> space + lineLengthAfterEq <- fmap (+2) getCurrentLineLength - 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 + if | onelineEnum -> + putText "=" >> space >> putUnbrokenEnum cfg decl + | isNewtype decl -> do + putText "=" >> space + forM_ (GHC.dd_cons defn) $ putNewtypeConstructor cfg + | not . null $ GHC.dd_cons defn -> do + forM_ (flagEnds constructorComments) $ \(CommentGroup {..}, firstGroup, lastGroup) -> do + forM_ cgPrior $ \lc -> do + putComment $ GHC.unLoc lc + consIndent lineLengthAfterEq - unless - (isGADT decl) - (putText "=" >> space) + 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 - putConstructor cfg lineLengthAfterEq lcon - forM_ consRest \con@(L conPos _) -> do - unless (cFirstField == SameLine) do - removeCommentTo conPos >>= mapM_ \c -> consIndent lineLengthAfterEq >> putComment c - consIndent lineLengthAfterEq + forM_ cgFollowing $ \lc -> do + consIndent lineLengthAfterEq + putComment $ GHC.unLoc lc - unless - (isGADT decl) - (putText "|" >> space) + | otherwise -> + pure () - putConstructor cfg lineLengthAfterEq con - putEolComment conPos + let derivingComments = deepAnnComments (GHC.dd_derivs defn) - when (hasDeriving decl) do - if isEnum decl && not cBreakEnums then + when (hasDeriving decl) do + if onelineEnum && null derivingComments then space - else do - removeCommentTo (defn & dd_derivs & \(L pos _) -> pos) >>= - mapM_ \c -> newline >> spaces cDeriving >> putComment c + else do + forM_ derivingComments $ \lc -> do + newline + spaces cDeriving + putComment $ GHC.unLoc lc 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 + (putDeriving cfg) + (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 -data DataDecl = MkDataDecl - { dataDeclName :: Located RdrName - , dataTypeVars :: LHsQTyVars GhcPs - , dataDefn :: HsDataDefn GhcPs - , dataFixity :: LexicalFixity - } +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 -> Located (HsDerivingClause GhcPs) -> P () -putDeriving Config{..} (L pos clause) = do - putText "deriving" +putDeriving :: Config -> GHC.LHsDerivingClause GHC.GhcPs -> P () +putDeriving Config{..} lclause = do + let clause@GHC.HsDerivingClause {..} = GHC.unLoc lclause + tys = (if cSortDeriving then sortBy compareOutputableCI else id) $ + map (GHC.sig_body . GHC.unLoc) $ + derivingClauseTypes clause + headTy = listToMaybe tys + tailTy = drop 1 tys - forM_ (deriv_clause_strategy clause) \case - L _ StockStrategy -> space >> putText "stock" - L _ AnyclassStrategy -> space >> putText "anyclass" - L _ NewtypeStrategy -> space >> putText "newtype" - L _ (ViaStrategy _) -> pure () + putText "deriving" - putCond - withinColumns - oneLinePrint - multilinePrint + 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 () - forM_ (deriv_clause_strategy clause) \case - L _ (ViaStrategy tp) -> do - case cVia of - SameLine -> space - Indent x -> newline >> spaces (x + cDeriving) + putCond + withinColumns + do + space + putText "(" + sep + (comma >> space) + (fmap putOutputable tys) + putText ")" + do + newline + spaces indentation + putText "(" - putText "via" - space - putType (getType tp) - _ -> pure () + forM_ headTy \t -> + space >> putOutputable t - putEolComment pos + forM_ tailTy \t -> do + newline + spaces indentation + comma + space + putOutputable t - where - getType = \case - HsIB _ tp -> tp - XHsImplicitBndrs x -> noExtCon x + 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 compareOutputable 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{..} = @@ -312,42 +306,32 @@ putRdrName dataDeclName space forM_ secondTvar putOutputable + 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 + firstTvar :: Maybe (GHC.LHsTyVarBndr () GHC.GhcPs) + firstTvar = listToMaybe $ GHC.hsq_explicit dataTypeVars - secondTvar :: Maybe (Located (HsTyVarBndr GhcPs)) - secondTvar - = dataTypeVars - & hsq_explicit - & drop 1 - & listToMaybe + secondTvar :: Maybe (GHC.LHsTyVarBndr () GHC.GhcPs) + secondTvar = listToMaybe . drop 1 $ GHC.hsq_explicit dataTypeVars -putConstructor :: Config -> Int -> Located (ConDecl GhcPs) -> P () -putConstructor cfg consIndent (L _ cons) = case cons of - ConDeclGADT{..} -> do - -- Put argument to constructor first: - case con_args of - PrefixCon _ -> do - sep - (comma >> space) - (fmap putRdrName con_names) + maybePutKindSig :: Printer () + maybePutKindSig = forM_ maybeKindSig (\k -> space >> putText "::" >> space >> putOutputable k) - InfixCon arg1 arg2 -> do - putType arg1 - space - forM_ con_names putRdrName - space - putType arg2 - RecCon _ -> - error . mconcat $ + maybeKindSig :: Maybe (GHC.LHsKind GHC.GhcPs) + maybeKindSig = GHC.dd_kindSig dataDefn + +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_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" ] @@ -357,27 +341,39 @@ 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 | _ : _ <- GHC.unLoc largs -> do putRdrName con_name skipToBrace bracePos <- getCurrentLineLength @@ -385,32 +381,42 @@ 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, _) -> 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 firstArg - unless (cFirstField cfg == SameLine) (putEolComment posFirst) + forM_ cgPrior $ \lc -> do + pad fieldPos + putComment $ GHC.unLoc lc + sepDecl bracePos - -- Put tail decl fields - forM_ args \(L pos arg) -> do - sepDecl bracePos - removeCommentTo pos >>= mapM_ \c -> - spaces (cFieldComment cfg) >> putComment c >> sepDecl bracePos - comma - space - putConDeclField cfg arg - putEolComment pos + forM_ (flagEnds cgItems) $ \((item, mbInlineComment), firstItem, _) -> do + if firstCommentGroup && firstItem + then pad fieldPos + else do + comma + space + putConDeclField cfg $ GHC.unLoc item + case mbInlineComment of + Just c -> do + sepDecl bracePos >> spaces (cFieldComment cfg) + putComment $ GHC.unLoc c + _ -> pure () + sepDecl bracePos - -- Print docstr after final field - removeCommentToEnd recPos >>= mapM_ \c -> - sepDecl bracePos >> spaces (cFieldComment cfg) >> putComment c + forM_ cgFollowing $ \lc -> do + spaces $ cFieldComment cfg + putComment $ GHC.unLoc lc + sepDecl bracePos -- Print whitespace to closing brace - sepDecl bracePos >> putText "}" - RecCon (L _ []) -> do + putText "}" + GHC.RecCon _ -> do skipToBrace >> putText "{" skipToBrace >> putText "}" @@ -426,126 +432,124 @@ -- 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 + (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{..} -> +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 {} -> 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) +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 -> ConDeclField GhcPs -> P () -putConDeclField cfg = \case - ConDeclField{..} -> do +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/lib/Language/Haskell/Stylish/Step/Imports.hs b/lib/Language/Haskell/Stylish/Step/Imports.hs --- a/lib/Language/Haskell/Stylish/Step/Imports.hs +++ b/lib/Language/Haskell/Stylish/Step/Imports.hs @@ -17,51 +17,45 @@ -------------------------------------------------------------------------------- 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 (fromMaybe, isJust) import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Map as Map import qualified Data.Set as Set - - --------------------------------------------------------------------------------- -import BasicTypes (StringLiteral (..), - SourceText (..)) -import qualified FastString as FS -import GHC.Hs.Extension (GhcPs) -import qualified GHC.Hs.Extension as GHC -import GHC.Hs.ImpExp -import Module (moduleNameString) -import RdrName (RdrName) -import SrcLoc (Located, GenLocated(..), unLoc) +import 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.Module.Name as GHC +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.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 -------------------------------------------------------------------------------- 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 @@ -120,38 +114,40 @@ 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 + pure $ formatGroup maxCols align moduleStats group formatGroup - :: Maybe Int -> Options -> Module -> ImportStats - -> NonEmpty (Located Import) -> Change String -formatGroup maxCols options m moduleStats imports = - let newLines = formatImports maxCols options m moduleStats imports in + :: Maybe Int -> Options -> ImportStats + -> NonEmpty (GHC.LImportDecl GHC.GhcPs) -> Change String +formatGroup maxCols options moduleStats imports = + let newLines = formatImports maxCols options 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 -formatImports maxCols options m moduleStats rawGroup = - runPrinter_ (PrinterConfig maxCols) [] m do + -> NonEmpty (GHC.LImportDecl GHC.GhcPs) -> Lines +formatImports maxCols options moduleStats rawGroup = + runPrinter_ (PrinterConfig maxCols) do let - + group :: NonEmpty (GHC.LImportDecl GHC.GhcPs) group - = NonEmpty.sortWith 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 @@ -165,151 +161,160 @@ 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 +printQualified + :: Options -> Bool -> ImportStats -> GHC.LImportDecl GHC.GhcPs -> P () +printQualified Options{..} padNames stats ldecl = do + putText "import" >> space - putText "import" >> space + case (isSource decl, isAnySource stats) of + (True, _) -> putText "{-# SOURCE #-}" >> space + (_, True) -> putText " " >> space + _ -> pure () - case (isSource decl, isAnySource stats) of - (True, _) -> putText "{-# SOURCE #-}" >> space - (_, True) -> putText " " >> space - _ -> pure () + when (GHC.ideclSafe decl) (putText "safe" >> space) - when (isSafe decl) (putText "safe" >> space) + let module_ = do + moduleNamePosition <- length <$> getCurrentLine + forM_ (GHC.ideclPkgQual decl) $ \pkg -> + putText (stringLiteral pkg) >> space + putText (importModuleName decl) - 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 + -- 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_ + 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 + beforeAliasPosition <- length <$> getCurrentLine + forM_ (GHC.ideclAs decl) $ \lname -> do + space >> putText "as" >> space + putText . GHC.moduleNameString $ GHC.unLoc lname - forM_ (ideclAs decl') \(L _ name) -> do - space >> putText "as" >> space >> putText (moduleNameString name) + afterAliasPosition <- length <$> getCurrentLine - afterAliasPosition <- length <$> getCurrentLine + when (isHiding decl) (space >> putText "hiding") - when (isHiding decl) (space >> putText "hiding") + let putOffset = putText $ replicate offset ' ' + offset = case listPadding of + LPConstant n -> n + LPModuleName -> moduleNamePosition - let putOffset = putText $ replicate offset ' ' - offset = case listPadding of - LPConstant n -> n - LPModuleName -> moduleNamePosition + pure () - 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) + 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 "()" - -- 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 ' ' + Just limports -> do + let imports = GHC.unLoc limports + printedImports = flagEnds $ -- [P ()] + (printImport separateLists) . GHC.unLoc <$> + prepareImportList imports - let -- Helper - doSpaceSurround = when spaceSurround space + -- 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 ' ' - -- 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 + -- Helper + let doSpaceSurround = when spaceSurround 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) + -- 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 - -- 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 ")" + -- 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) - 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) + -- 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 @@ -318,63 +323,57 @@ -------------------------------------------------------------------------------- -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) = - 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 -moduleName :: Import -> String -moduleName - = moduleNameString - . unLocated - . ideclName - . rawImport - -------------------------------------------------------------------------------- data ImportStats = ImportStats { isLongestImport :: !Int @@ -395,49 +394,37 @@ 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 sl = case GHC.sl_st sl of + GHC.NoSourceText -> show . GHC.unpackFS $ GHC.sl_fs sl + GHC.SourceText s -> s -------------------------------------------------------------------------------- -isQualified :: Import -> Bool -isQualified - = (/=) NotQualified - . ideclQualified - . rawImport +isQualified :: GHC.ImportDecl GHC.GhcPs -> Bool +isQualified = (/=) GHC.NotQualified . GHC.ideclQualified -isHiding :: Import -> Bool -isHiding - = maybe False fst - . ideclHiding - . rawImport +isHiding :: GHC.ImportDecl GHC.GhcPs -> Bool +isHiding = maybe False fst . GHC.ideclHiding -isSource :: Import -> Bool -isSource - = ideclSource - . rawImport +isSource :: GHC.ImportDecl GHC.GhcPs -> Bool +isSource = (==) GHC.IsBoot . GHC.ideclSource -isSafe :: Import -> Bool -isSafe - = ideclSafe - . rawImport -------------------------------------------------------------------------------- -- | Cleans up an import item list. @@ -445,42 +432,44 @@ -- * 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 diff --git a/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs b/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs --- a/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs +++ b/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs @@ -13,15 +13,11 @@ -------------------------------------------------------------------------------- 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 SrcLoc (RealSrcSpan, realSrcSpanStart, - srcLocLine, srcSpanEndLine, - srcSpanStartLine) +import qualified GHC.Hs as GHC +import qualified GHC.Types.SrcLoc as GHC -------------------------------------------------------------------------------- @@ -103,9 +99,9 @@ -------------------------------------------------------------------------------- -- | 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) @@ -133,9 +129,9 @@ 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) @@ -143,16 +139,17 @@ 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] @@ -161,16 +158,16 @@ | otherwise = [insert line ["{-# " ++ lg ++ " " ++ prag ++ " #-}"]] where pragmas' = moduleLanguagePragmas modu - present = concatMap ((fmap T.unpack) . toList . snd) pragmas' + present = concatMap (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 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 @@ -181,10 +178,10 @@ isRedundantViewPatterns :: Module -> Bool isRedundantViewPatterns = null . queryModule getViewPat where - getViewPat :: Hs.Pat Hs.GhcPs -> [()] + getViewPat :: GHC.Pat GHC.GhcPs -> [()] getViewPat = \case - Hs.ViewPat{} -> [()] - _ -> [] + GHC.ViewPat{} -> [()] + _ -> [] -------------------------------------------------------------------------------- @@ -194,13 +191,12 @@ (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.XMatch m) = Hs.noExtCon m - 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/ModuleHeader.hs b/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs --- 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 (..) @@ -8,30 +9,20 @@ , 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 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.Block +import Language.Haskell.Stylish.Comments import Language.Haskell.Stylish.Editor import Language.Haskell.Stylish.GHC import Language.Haskell.Stylish.Module @@ -39,6 +30,7 @@ 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 @@ -74,229 +66,162 @@ 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) +printModuleHeader maxCols conf ls lmodul = + let modul = GHC.unLoc lmodul + name = GHC.unLoc <$> GHC.hsmodName modul + haddocks = GHC.hsmodHaddockModHeader modul - getBlock loc = - Block <$> fmap getStartLineUnsafe loc <*> fmap getEndLineUnsafe loc + startLine = fromMaybe 1 $ moduleLine <|> + (fmap GHC.srcSpanStartLine . GHC.srcSpanToRealSrcSpan $ + GHC.getLoc lmodul) - 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 + endLine = fromMaybe 1 $ whereLine <|> + (do + loc <- GHC.getLocA <$> GHC.hsmodExports modul + GHC.srcSpanEndLine <$> GHC.srcSpanToRealSrcSpan loc) - nameBlock = - getBlock name + 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 - exportsBlock = - join $ adjustOffsetFrom <$> nameBlock <*> getBlock exports + moduleLine = keywordLine GHC.AnnModule + whereLine = keywordLine GHC.AnnWhere - whereM :: Maybe SrcSpan - whereM - = annotations - & filter (\(((_, w), _)) -> w == AnnWhere) - & fmap (head . snd) -- get position of annot - & L.sort - & listToMaybe + commentOnLine l = listToMaybe $ do + comment <- epAnnComments $ GHC.hsmodAnn modul + guard $ GHC.srcSpanStartLine (GHC.anchor $ GHC.getLoc comment) == l + pure comment - isModuleHeaderWhere :: Block a -> Bool - isModuleHeaderWhere w - = not - . overlapping - $ [w] <> toList nameBlock <> toList exportsBlock + moduleComment = moduleLine >>= commentOnLine + whereComment = + guard (whereLine /= moduleLine) >> whereLine >>= commentOnLine - toLineBlock :: SrcSpan -> Block a - toLineBlock (RealSrcSpan s) = Block (srcSpanStartLine s) (srcSpanEndLine s) - toLineBlock s - = error - $ "'where' block was not a RealSrcSpan" <> show s + 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) - whereBlock - = whereM - & fmap toLineBlock - & find isModuleHeaderWhere + printedModuleHeader = runPrinter_ + (PrinterConfig maxCols) + (printHeader + conf name exportGroups haddocks moduleComment whereComment) - deletes = - fmap delete $ mergeAdjacent $ toList nameBlock <> toList exportsBlock <> toList whereBlock + deletes = delete (Block startLine endLine) - startLine = - maybe 1 blockStart nameBlock + additions = [insert startLine printedModuleHeader] - additions = [insert startLine printedModuleHeader] + changes = deletes : additions in - 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 +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) - attachModuleComment moduleComment = - mapM_ (\c -> space >> putComment c) moduleComment + 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 - doSort = if sort conf then NonEmpty.sortBy compareLIE else id + putMaybeLineComment $ GHC.unLoc <$> mbWhereComment + where + attachModuleComment = putMaybeLineComment $ GHC.unLoc <$> mbModuleComment 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 + | openBracket conf == SameLine = putText " (" + | otherwise = pure () -printSingleLineExportList :: Config -> Located [GHC.LIE GhcPs] -> P () -printSingleLineExportList conf (L srcLoc exports) = do - space >> putText "(" - printInlineExports exports - putText ")" >> space >> putText "where" >> attachEolCommentEnd srcLoc +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 + printExport (CommentGroup {..}, firstGroup, _lastGroup) = do + forM_ (flagEnds cgPrior) $ \(cmt, start, _end) -> do + unless (firstGroup && start) $ space >> space + putComment $ GHC.unLoc cmt + newline >> doIndent - firstChar = - case openBracket conf of + 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 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/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs b/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs --- a/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs +++ b/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs @@ -15,7 +15,8 @@ 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,47 @@ , 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 (Hs.XHsDataDefn x) = Hs.noExtCon x + getConDecls d@Hs.HsDataDefn {} = map GHC.unLoc $ Hs.dd_cons d -------------------------------------------------------------------------------- -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 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 +102,58 @@ matchGroupToAlignable :: Config -> Hs.MatchGroup Hs.GhcPs (Hs.LHsExpr Hs.GhcPs) - -> [[Alignable S.RealSrcSpan]] -matchGroupToAlignable _conf (Hs.XMatchGroup x) = Hs.noExtCon x + -> [[Alignable GHC.RealSrcSpan]] 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.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 +162,34 @@ -------------------------------------------------------------------------------- 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 _ _) = 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 --- a/lib/Language/Haskell/Stylish/Step/Squash.hs +++ b/lib/Language/Haskell/Stylish/Step/Squash.hs @@ -8,9 +8,10 @@ -------------------------------------------------------------------------------- -import Data.Maybe (mapMaybe) -import qualified GHC.Hs as Hs -import qualified SrcLoc as S +import Control.Monad (guard) +import Data.Maybe (mapMaybe) +import qualified GHC.Types.SrcLoc as GHC +import qualified GHC.Hs as GHC -------------------------------------------------------------------------------- @@ -20,38 +21,34 @@ -------------------------------------------------------------------------------- -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 $ S.getLoc left - rAnn <- toRealSrcSpan $ S.getLoc right - if S.srcSpanEndLine lAnn == S.srcSpanStartLine rAnn || - S.srcSpanEndLine lAnn + 1 == S.srcSpanStartLine rAnn - then Just $ - changeLine (S.srcSpanEndLine lAnn) $ \str -> - let (pre, post) = splitAt (S.srcSpanEndCol lAnn) str - in [trimRight pre ++ " " ++ trimLeft post] - else Nothing + 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) -------------------------------------------------------------------------------- diff --git a/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs b/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs --- a/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs +++ b/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs @@ -5,22 +5,20 @@ -------------------------------------------------------------------------------- -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 qualified Data.Map as M +import qualified GHC.Hs as GHC +import qualified GHC.Types.SrcLoc 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.Step.LanguagePragmas (addLanguagePragma) -import Language.Haskell.Stylish.Util +import Language.Haskell.Stylish.Util (everything) + +{- -------------------------------------------------------------------------------- unicodeReplacements :: Map String String unicodeReplacements = M.fromList @@ -32,66 +30,90 @@ , ("-<", "↢") , (">-", "↣") ] +-} +-------------------------------------------------------------------------------- +-- 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)])) +instance Monoid Replacement where + mempty = Replacement mempty --- | 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 - ] -------------------------------------------------------------------------------- --- | 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 (adjust (xstart, xend, x) <$> repls) l' + adjust (xstart, xend, x) (ystart, yend, y) + | ystart > xend = + let offset = length x - (xend - xstart) in + (ystart + offset, yend + offset, y) + | otherwise = (ystart, yend, y) + -------------------------------------------------------------------------------- +hsTyReplacements :: GHC.HsType GHC.GhcPs -> Replacement +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 + + +-------------------------------------------------------------------------------- +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 + + +-------------------------------------------------------------------------------- step :: Bool -> String -> Step step = (makeStep "UnicodeSyntax" .) . step' -------------------------------------------------------------------------------- step' :: Bool -> String -> Lines -> Module -> Lines -step' alp lg ls module' = applyChanges changes ls +step' alp lg ls modu = + applyChanges + (if alp then addLanguagePragma lg "UnicodeSyntax" modu else []) $ + applyReplacement replacement ls where - changes = (if alp then addLanguagePragma lg "UnicodeSyntax" module' else []) ++ - replaceAll perLine - toReplace = [ "::", "=>", "->" ] - perLine = sort $ groupPerLine $ concatMap (findSymbol module' ls) toReplace + replacement = + foldMap hsTyReplacements (everything modu) <> + foldMap hsSigReplacements (everything modu) diff --git a/lib/Language/Haskell/Stylish/Util.hs b/lib/Language/Haskell/Stylish/Util.hs --- a/lib/Language/Haskell/Stylish/Util.hs +++ b/lib/Language/Haskell/Stylish/Util.hs @@ -5,7 +5,6 @@ ( indent , padRight , everything - , infoPoints , trimLeft , trimRight , wrap @@ -20,8 +19,6 @@ , withLast , flagEnds - , toRealSrcSpan - , traceOutputable , traceOutputableM @@ -40,12 +37,13 @@ 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 @@ -------------------------------------------------------------------------------- +{- infoPoints :: [S.Located pass] -> [((Int, Int), (Int, Int))] infoPoints = fmap (helper . S.getLoc) where @@ -79,7 +78,7 @@ 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 @@ -------------------------------------------------------------------------------- -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 _ _ _ 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 diff --git a/stylish-haskell.cabal b/stylish-haskell.cabal --- a/stylish-haskell.cabal +++ b/stylish-haskell.cabal @@ -1,6 +1,6 @@ Cabal-version: 2.4 Name: stylish-haskell -Version: 0.13.0.0 +Version: 0.14.0.0 Synopsis: Haskell code prettifier Homepage: https://github.com/haskell/stylish-haskell License: BSD-3-Clause @@ -23,20 +23,47 @@ README.markdown, data/stylish-haskell.yaml -Library - Hs-source-dirs: lib +Common depends Ghc-options: -Wall Default-language: Haskell2010 + Build-depends: + aeson >= 0.6 && < 2.1, + 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 @@ -46,13 +73,11 @@ Other-modules: Language.Haskell.Stylish.Align Language.Haskell.Stylish.Block - Language.Haskell.Stylish.Config + Language.Haskell.Stylish.Comments 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 @@ -60,123 +85,45 @@ Autogen-modules: 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 - - 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 >= 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 + optparse-applicative >= 0.12 && < 0.18 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.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 >= 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 + test-framework >= 0.4 && < 0.9, + test-framework-hunit >= 0.2 && < 0.4, Source-repository head Type: git diff --git a/tests/Language/Haskell/Stylish/Config/Tests.hs b/tests/Language/Haskell/Stylish/Config/Tests.hs --- a/tests/Language/Haskell/Stylish/Config/Tests.hs +++ b/tests/Language/Haskell/Stylish/Config/Tests.hs @@ -137,7 +137,7 @@ , "license: BSD3" , "author: Angela Author" , "build-type: Simple" - , "cabal-version: >= 1.2" + , "cabal-version: >= 1.10" , "" , "library" , " build-depends: HUnit" diff --git a/tests/Language/Haskell/Stylish/Regressions.hs b/tests/Language/Haskell/Stylish/Regressions.hs --- a/tests/Language/Haskell/Stylish/Regressions.hs +++ b/tests/Language/Haskell/Stylish/Regressions.hs @@ -5,31 +5,30 @@ ) 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" , "" , "main = print $ showName '(,)" ] - - expected = input importStepConfig :: ImportAlign -> Options importStepConfig align = defaultOptions { importAlign = align } diff --git a/tests/Language/Haskell/Stylish/Step/Data/Tests.hs b/tests/Language/Haskell/Stylish/Step/Data/Tests.hs --- a/tests/Language/Haskell/Stylish/Step/Data/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Data/Tests.hs @@ -5,10 +5,10 @@ ) 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" @@ -75,182 +75,159 @@ , testCase "case 60" case60 , 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 -case00 = expected @=? testStep (step sameSameStyle) input +case00 = assertSnippet (step sameSameStyle) input input where - input = unlines - [ "module Herp where" - , "" - , "data Foo" - ] - - expected = input + input = + [ "module Herp where" + , "" + , "data Foo" + ] case01 :: Assertion -case01 = expected @=? testStep (step indentIndentStyle) input - where - input = unlines - [ "module Herp where" - , "" - , "data Foo = Foo { a :: Int }" - ] - - expected = unlines - [ "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 = expected @=? testStep (step indentIndentStyle) input - where - input = unlines - [ "module Herp where" - , "" - , "data Foo = Foo { a :: Int, a2 :: String }" - ] - expected = unlines - [ "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 = expected @=? testStep (step indentIndentStyle) input - where - input = unlines - [ "module Herp where" - , "" - , "data Foo a = Foo { a :: a, a2 :: String }" - ] - expected = unlines - [ "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 = expected @=? testStep (step indentIndentStyle) input - where - input = unlines - [ "module Herp where" - , "" - , "data Foo a = Foo { a :: a, a2 :: String } | Bar { b :: a }" - ] - expected = unlines - [ "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 = expected @=? testStep (step indentIndentStyle) input - where - input = unlines - [ "module Herp where" - , "" - , "data Foo = Foo {" - , " a :: Int" - , " , a2 :: String" - , " }" - ] - expected = unlines - [ "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 = expected @=? testStep (step sameSameStyle) input +case06 = assertSnippet (step sameSameStyle) input input where - input = unlines - [ "module Herp where" - , "" - , "data Foo = Foo Int String" - ] - expected = input + input = + [ "module Herp where" + , "" + , "data Foo = Foo Int String" + ] case07 :: Assertion -case07 = expected @=? testStep (step sameSameStyle) input +case07 = assertSnippet (step sameSameStyle) input input where - input = unlines - [ "module Herp where" - , "" - , "data Phantom a = Phantom" - ] - expected = input + input = + [ "module Herp where" + , "" + , "data Phantom a = Phantom" + ] case08 :: Assertion -case08 = expected @=? testStep (step sameSameStyle) input - where - input = unlines - [ "module Herp where" - , "" - , "data Phantom a =" - , " Phantom" - ] - expected = unlines - [ "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 = expected @=? testStep (step indentIndentStyle4) input - where - input = unlines - [ "module Herp where" - , "" - , "data Foo a b = Foo { a :: a, a2 :: String } | Bar { b :: a, c:: b }" - ] - expected = unlines - [ "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 = 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" @@ -262,16 +239,16 @@ ] 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" , "" @@ -283,15 +260,15 @@ ] 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" @@ -303,15 +280,15 @@ ] 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" @@ -322,16 +299,16 @@ ] 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" @@ -343,122 +320,108 @@ ] case15 :: Assertion -case15 = expected @=? testStep (step indentIndentStyle) input - where - input = unlines - [ "module Herp where" - , "" - , "data Foo a = Foo" - , " { a :: a, -- comment" - , " a2 :: String" - , " }" - ] - expected = unlines - [ "module Herp where" - , "" - , "data Foo a" - , " = Foo" - , " { a :: a -- comment" - , " , a2 :: String" - , " }" - ] +case15 = 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" + , " }" + ] case16 :: Assertion -case16 = expected @=? testStep (step indentIndentStyle) input - where - input = unlines - [ "module Herp where" - , "" - , "data Foo = Foo {" - , " a :: Int -- ^ comment" - , " }" - ] - expected = unlines - [ "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 = expected @=? testStep (step indentIndentStyle) input - where - input = unlines - [ "module Herp where" - , "" - , "data Foo a = Foo" - , " { a :: a," - , "-- comment" - , " a2 :: String" - , " }" - ] - expected = unlines - [ "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 = expected @=? testStep (step indentIndentStyle) input - where - input = unlines - [ "module Herp where" - , "" - , "data Foo a = Foo" - , " { a :: a," - , "-- ^ comment" - , " a2 :: String" - , " }" - ] - expected = unlines - [ "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 = expected @=? testStep (step indentIndentStyle) input - where - input = unlines - [ "module Herp where" - , "" - , "data Foo a = Foo" - , " { firstName, lastName :: String," - , "-- ^ names" - , " age :: Int" - , " }" - ] - expected = unlines - [ "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 -- -- 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)" @@ -466,98 +429,94 @@ 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 = expected @=? testStep (step indentIndentStyle) input - where - input = unlines - [ "data Foo a" - , " = Foo { a :: Int," - , " a2 :: String" - , " -- ^ some haddock" - , " }" - , " | Bar { b :: a } deriving (Eq, Show)" - , " deriving (ToJSON)" - ] - - expected = unlines - [ "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 = 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" @@ -567,7 +526,7 @@ , " deriving (ToJSON)" ] - expected = unlines + expected = [ "data Foo a = Foo" , " { a :: Int" , " , a2 :: String" @@ -578,15 +537,15 @@ ] 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" @@ -597,15 +556,15 @@ ] 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" @@ -616,9 +575,9 @@ ] 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 {" @@ -644,7 +603,7 @@ , " deriving (ToJSON, FromJSON) via SnakeCaseCapsEnumEncoding MandateStatus" ] - expected = unlines + expected = [ "module Some.Types where" , "" , "newtype BankCode = BankCode { unBankCode :: Text }" @@ -669,26 +628,26 @@ ] 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:" @@ -709,10 +668,10 @@ 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" @@ -724,10 +683,10 @@ ] 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" @@ -742,15 +701,15 @@ ] 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" @@ -758,16 +717,16 @@ ] 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" @@ -777,9 +736,9 @@ ] 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" @@ -789,7 +748,7 @@ , " }" ] - expected = unlines + expected = [ "module Some.Types where" , "" , "data Foo = Foo" @@ -798,9 +757,9 @@ ] 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" @@ -810,7 +769,7 @@ , " }" ] - expected = unlines + expected = [ "module Some.Types where" , "" , "data Foo = Foo" @@ -819,9 +778,9 @@ ] 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" @@ -833,7 +792,7 @@ , " \"reversal_indicator\" := \"Undo\"] FlowDataDetails" ] - expected = unlines + expected = [ "module Some.Types where" , "" , "newtype UndoFlowData" @@ -844,9 +803,9 @@ ] 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" @@ -865,7 +824,7 @@ , " Flat" ] - expected = unlines + expected = [ "data Flat" , " = Flat" , " { foo :: Int" @@ -879,9 +838,9 @@ ] 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" , " }" @@ -902,7 +861,7 @@ , " )" ] - expected = unlines + expected = [ "data CreditTransfer" , " = CreditTransfer" , " { nestedCreditorInfo :: CreditorInfo" @@ -913,27 +872,27 @@ ] 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" @@ -956,11 +915,11 @@ ] 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" @@ -970,11 +929,11 @@ ] 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" @@ -993,9 +952,9 @@ -- 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" @@ -1012,7 +971,7 @@ , " ]" , " (UntaggedEncoded CreditTransfer)" ] - expected = unlines + expected = [ "module X where" , "" , "data CreditTransfer = CreditTransfer" @@ -1029,10 +988,10 @@ ] 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" @@ -1049,10 +1008,10 @@ ] 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" @@ -1067,10 +1026,10 @@ ] 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" @@ -1081,10 +1040,10 @@ ] 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" @@ -1095,10 +1054,10 @@ ] 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" @@ -1109,10 +1068,10 @@ ] 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" @@ -1123,9 +1082,9 @@ ] 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" @@ -1134,7 +1093,7 @@ , " D2 :: T Bool" , " D3 :: forall a. (Eq a) => (a, a) -> T [a]" ] - expected = unlines + expected = [ "module X where" , "" , "-- | A GADT example" @@ -1145,16 +1104,16 @@ ] 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" @@ -1163,14 +1122,14 @@ ] 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" @@ -1185,23 +1144,23 @@ ] 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)" ] @@ -1283,9 +1242,9 @@ -- -- 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" @@ -1315,9 +1274,9 @@ -- -- 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" @@ -1328,7 +1287,7 @@ , " }" ] - expected = unlines + expected = [ "module Herp where" , "" , "data Game = Game" @@ -1349,33 +1308,64 @@ -- -- Regression test for https://github.com/haskell/stylish-haskell/issues/273 case62 :: Assertion -case62 = expected @=? testStep (step sameIndentStyle) input +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 where - input = unlines + 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." - , " }" + , "data Foo :: * -> * where" + , " Bar :: () -> Foo ()" ] + expected = input - expected = unlines - [ "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." - , " }" - ] +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 diff --git a/tests/Language/Haskell/Stylish/Step/Imports/FelixTests.hs b/tests/Language/Haskell/Stylish/Step/Imports/FelixTests.hs --- 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.ImportsGHC" - [ 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 - ] +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 + ] + -------------------------------------------------------------------------------- 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 --- a/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs @@ -8,7 +8,7 @@ -------------------------------------------------------------------------------- import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit (Assertion, (@=?)) +import Test.HUnit (Assertion) -------------------------------------------------------------------------------- @@ -69,6 +69,7 @@ , testCase "case 35" case35 , testCase "case 36" case36 , testCase "case 37" case37 + , testCase "case 38" case38 ] @@ -600,21 +601,17 @@ -------------------------------------------------------------------------------- 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" + ] -------------------------------------------------------------------------------- @@ -922,4 +919,14 @@ , "import Data.Aeson qualified as JSON (encode, decode)" ] [ "import Data.Aeson qualified as JSON (Value, decode, encode)" + ] + +-------------------------------------------------------------------------------- +case38 :: Assertion +case38 = assertSnippet (step (Just 80) $ fromImportAlign File) + [ "import HSP" + , "import Happstack.Server" + ] + [ "import Happstack.Server" + , "import HSP" ] diff --git a/tests/Language/Haskell/Stylish/Step/LanguagePragmas/Tests.hs b/tests/Language/Haskell/Stylish/Step/LanguagePragmas/Tests.hs --- a/tests/Language/Haskell/Stylish/Step/LanguagePragmas/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/LanguagePragmas/Tests.hs @@ -8,7 +8,7 @@ -------------------------------------------------------------------------------- import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit (Assertion, (@=?)) +import Test.HUnit (Assertion) -------------------------------------------------------------------------------- @@ -231,22 +231,18 @@ -------------------------------------------------------------------------------- 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/ModuleHeader/Tests.hs b/tests/Language/Haskell/Stylish/Step/ModuleHeader/Tests.hs --- a/tests/Language/Haskell/Stylish/Step/ModuleHeader/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/ModuleHeader/Tests.hs @@ -79,6 +79,8 @@ , 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 + , testCase "Inline comments" ex33 ] -------------------------------------------------------------------------------- @@ -882,6 +884,30 @@ [ "module Foo (" , " -- * Foo" , " Foo" + , " ) where" + ] + +ex32 :: Assertion +ex32 = assertSnippet (step Nothing $ defaultConfig {breakWhere = Single}) + [ "module Foo (bar) where -- Foo" + ] + [ "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" ] diff --git a/tests/Language/Haskell/Stylish/Step/Tabs/Tests.hs b/tests/Language/Haskell/Stylish/Step/Tabs/Tests.hs --- 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 @@ -------------------------------------------------------------------------------- import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit (Assertion, (@=?)) +import Test.HUnit (Assertion) -------------------------------------------------------------------------------- @@ -24,20 +25,16 @@ -------------------------------------------------------------------------------- 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 --- 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 @@ -------------------------------------------------------------------------------- import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit (Assertion, (@=?)) +import Test.HUnit (Assertion) -------------------------------------------------------------------------------- @@ -24,20 +25,16 @@ -------------------------------------------------------------------------------- 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 --- 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 @@ -------------------------------------------------------------------------------- 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.hs b/tests/Language/Haskell/Stylish/Tests.hs --- 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 @@ , " }" ] + -------------------------------------------------------------------------------- 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. diff --git a/tests/Language/Haskell/Stylish/Tests/Util.hs b/tests/Language/Haskell/Stylish/Tests/Util.hs --- a/tests/Language/Haskell/Stylish/Tests/Util.hs +++ b/tests/Language/Haskell/Stylish/Tests/Util.hs @@ -3,40 +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(..)) -import Language.Haskell.Stylish.GHC (baseDynFlags) -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 Outputable (showSDoc) -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.Module (Module) -------------------------------------------------------------------------------- -- | Takes a Haskell source as an argument and parse it into a Module. @@ -49,8 +43,8 @@ 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 @@ -67,11 +61,6 @@ -------------------------------------------------------------------------------- -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) @@ -124,15 +113,3 @@ 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]