stylish-haskell 0.11.0.3 → 0.12.0.0

raw patch · 33 files changed

+4576/−1214 lines, 33 filesdep +ghc-lib-parserdep −haskell-src-extsdep ~Cabaldep ~basedep ~strictPVP ok

version bump matches the API change (PVP)

Dependencies added: ghc-lib-parser

Dependencies removed: haskell-src-exts

Dependency ranges changed: Cabal, base, strict

API changes (from Hackage documentation)

Files

• CHANGELOG +33/−0
• data/stylish-haskell.yaml +59/−0
• lib/Language/Haskell/Stylish.hs +11/−6
• lib/Language/Haskell/Stylish/Align.hs +26/−27
• lib/Language/Haskell/Stylish/Block.hs +9/−21
• lib/Language/Haskell/Stylish/Config.hs +53/−17
• lib/Language/Haskell/Stylish/GHC.hs +101/−0
• lib/Language/Haskell/Stylish/Module.hs +280/−0
• lib/Language/Haskell/Stylish/Ordering.hs +61/−0
• lib/Language/Haskell/Stylish/Parse.hs +87/−55
• lib/Language/Haskell/Stylish/Printer.hs +450/−0
• lib/Language/Haskell/Stylish/Step.hs +1/−13
• lib/Language/Haskell/Stylish/Step/Data.hs +478/−86
• lib/Language/Haskell/Stylish/Step/Imports.hs +376/−353
• lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs +72/−40
• lib/Language/Haskell/Stylish/Step/ModuleHeader.hs +250/−0
• lib/Language/Haskell/Stylish/Step/SimpleAlign.hs +91/−68
• lib/Language/Haskell/Stylish/Step/Squash.hs +33/−32
• lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs +19/−20
• lib/Language/Haskell/Stylish/Util.hs +103/−23
• src/Main.hs +31/−7
• stylish-haskell.cabal +22/−7
• tests/Language/Haskell/Stylish/Config/Tests.hs +1/−0
• tests/Language/Haskell/Stylish/Parse/Tests.hs +24/−24
• tests/Language/Haskell/Stylish/Step/Data/Tests.hs +687/−7
• tests/Language/Haskell/Stylish/Step/Imports/FelixTests.hs +382/−0
• tests/Language/Haskell/Stylish/Step/Imports/Tests.hs +203/−138
• tests/Language/Haskell/Stylish/Step/LanguagePragmas/Tests.hs +142/−151
• tests/Language/Haskell/Stylish/Step/ModuleHeader/Tests.hs +301/−0
• tests/Language/Haskell/Stylish/Step/SimpleAlign/Tests.hs +124/−112
• tests/Language/Haskell/Stylish/Tests.hs +4/−4
• tests/Language/Haskell/Stylish/Tests/Util.hs +58/−3
• tests/TestSuite.hs +4/−0

@@ -1,5 +1,38 @@ # CHANGELOG +- 0.12.0.0 (2020-10-02)+     *  Use ghc-lib-parser rather than haskell-src-exts++        This patch swaps out the parsing library from `haskell-src-exts` to+        `ghc-lib-parser`, which gives us better compatibility with GHC.++        Because almost every module heavily used the Haskell AST provided by+        `haskell-src-exts`, this was a huge effort and it would not have been+        possible without Felix Mulder doing an initial port, GSoC student+        Beatrice Vergani porting several other steps, and Łukasz Gołębiewski and+        Paweł Szulc who helped me finish up things in the home stretch.++        I've generally tried to keep styling 100% compatible with what was there+        before, but some issues may have unintentionally slipped in so please+        report those.++        This introduces one new import styling contributed by Felix: when+        wrapping import lists over multiple lines, you can repeat the module+        name, e.g.:++            import Control.Monad.Except as X (ExceptT (..), MonadError (..))+            import Control.Monad.Except as X (runExceptT, withExceptT)++        This is activated by using `import_align: repeat`.++        Secondly, a new Step was added, `module_header`, which formats the+        export list of a module, including the trailing `where` clause.  Details+        for this new step can be found in the `data/stylish-haskell.yaml`.++     *   Remove `semigroup` dependency for GHC >= 8.0+     *   Bump `strict` upper bound to 0.4+     *   Bump `Cabal` upper bound to 3.3 for test suite+ - 0.11.0.3 (2020-08-02)     * Set default-language to Haskell2010 

@@ -15,6 +15,19 @@   #     # true.   #     add_language_pragma: true +  # Format module header+  #+  # Currently, this option is not configurable and will format all exports and+  # module declarations to minimize diffs+  #+  # - module_header:+  #     # How many spaces use for indentation in the module header.+  #     indent: 4+  #+  #     # Should export lists be sorted?  Sorting is only performed within the+  #     # export section, as delineated by Haddock comments.+  #     sort: true+   # Format record definitions. This is disabled by default.   #   # You can control the layout of record fields. The only rules that can't be configured@@ -42,6 +55,31 @@   #   #     # How many spaces to insert before "deriving" clause. Deriving clauses are always on separate lines.   #     deriving: 2+  #+  #     # How many spaces to insert before "via" clause counted from indentation of deriving clause+  #     # Possible values:+  #     # - "same_line" -- "{" and first field goes on the same line as the data constructor.+  #     # - "indent N" -- insert a new line and N spaces from the beginning of the data constructor+  #     via: "indent 2"+  #+  #     # Wheter or not to break enums onto several lines+  #     #+  #     # Default: false+  #     break_enums: false+  #+  #     # Whether or not to break single constructor data types before `=` sign+  #     #+  #     # Default: true+  #     break_single_constructors: true+  #+  #     # Whether or not to curry constraints on function.+  #     #+  #     # E.g: @allValues :: Enum a => Bounded a => Proxy a -> [a]@+  #     #+  #     # Instead of @allValues :: (Enum a, Bounded a) => Proxy a -> [a]@+  #     #+  #     # Default: false+  #     curried_context: false    # Align the right hand side of some elements.  This is quite conservative   # and only applies to statements where each element occupies a single@@ -101,6 +139,11 @@       #   > import qualified Data.List      as List       #   >     (concat, foldl, foldr, head, init, last, length)       #+      # - repeat: Repeat the module name to align the import list.+      #+      #   > import qualified Data.List      as List (concat, foldl, foldr, head)+      #   > import qualified Data.List      as List (init, last, length)+      #       # Default: after_alias       list_align: after_alias @@ -202,6 +245,22 @@       #       # Default: false       space_surround: false++      # Enabling this argument will use the new GHC lib parse to format imports.+      #+      # This currently assumes a few things, it will assume that you want post+      # qualified imports. It is also not as feature complete as the old+      # imports formatting.+      #+      # It does not remove redundant lines or merge lines. As such, the full+      # feature scope is still pending.+      #+      # It _is_ however, a fine alternative if you are using features that are+      # not parseable by haskell src extensions and you're comfortable with the+      # presets.+      #+      # Default: false+      ghc_lib_parser: false    # Language pragmas   - language_pragmas:

@@ -91,14 +91,19 @@  -------------------------------------------------------------------------------- runStep :: Extensions -> Maybe FilePath -> Lines -> Step -> Either String Lines-runStep exts mfp ls step =-    stepFilter step ls <$> parseModule exts mfp (unlines ls)-+runStep exts mfp ls = \case+  Step _name step ->+    step ls <$> parseModule exts mfp (unlines ls)  ---------------------------------------------------------------------------------runSteps :: Extensions -> Maybe FilePath -> [Step] -> Lines-         -> Either String Lines-runSteps exts mfp steps ls = foldM (runStep exts mfp) ls steps+runSteps ::+     Extensions+  -> Maybe FilePath+  -> [Step]+  -> Lines+  -> Either String Lines+runSteps exts mfp steps ls =+ foldM (runStep exts mfp) ls steps  newtype ConfigPath = ConfigPath { unConfigPath :: FilePath } 

@@ -8,7 +8,7 @@  -------------------------------------------------------------------------------- import           Data.List                       (nub)-import qualified Language.Haskell.Exts           as H+import qualified SrcLoc                          as S   --------------------------------------------------------------------------------@@ -51,49 +51,48 @@     , aRightLead :: !Int     } deriving (Show) - -------------------------------------------------------------------------------- -- | Create changes that perform the alignment.+ align-    :: Maybe Int              -- ^ Max columns-    -> [Alignable H.SrcSpan]  -- ^ Alignables-    -> [Change String]        -- ^ Changes performing the alignment.+  :: Maybe Int                    -- ^ Max columns+  -> [Alignable S.RealSrcSpan]    -- ^ Alignables+  -> [Change String]              -- ^ Changes performing the alignment align _ [] = [] align maxColumns alignment-    -- Do not make any change if we would go past the maximum number of columns.-    | exceedsColumns (longestLeft + longestRight) = []-    | not (fixable alignment)                     = []-    | otherwise                                   = map align' alignment+  -- Do not make an changes if we would go past the maximum number of columns+  | exceedsColumns (longestLeft + longestRight)  = []+  | not (fixable alignment)                      = []+  | otherwise                                    = map align' alignment   where     exceedsColumns i = case maxColumns of-        Nothing -> False  -- No number exceeds a maximum column count of-                          -- Nothing, because there is no limit to exceed.-        Just c -> i > c+      Nothing -> False+      Just c  -> i > c -    -- The longest thing in the left column.-    longestLeft = maximum $ map (H.srcSpanEndColumn . aLeft) alignment+    -- The longest thing in the left column+    longestLeft = maximum $ map (S.srcSpanEndCol . aLeft) alignment -    -- The longest thing in the right column.+    -- The longest thing in the right column     longestRight = maximum-        [ H.srcSpanEndColumn (aRight a) - H.srcSpanStartColumn (aRight a)-            + aRightLead a-        | a <- alignment-        ]--    align' a = changeLine (H.srcSpanStartLine $ aContainer a) $ \str ->-        let column      = H.srcSpanEndColumn $ aLeft a-            (pre, post) = splitAt column str-        in [padRight longestLeft (trimRight pre) ++ trimLeft post]+      [ S.srcSpanEndCol (aRight a) - S.srcSpanStartCol (aRight a)+          + aRightLead a+      | a <- alignment+      ] +    align' a = changeLine (S.srcSpanStartLine $ aContainer a) $ \str ->+      let column = S.srcSpanEndCol $ aLeft a+          (pre, post) = splitAt column str+      in [padRight longestLeft (trimRight pre) ++ trimLeft post]   -------------------------------------------------------------------------------- -- | Checks that all the alignables appear on a single line, and that they do -- not overlap.-fixable :: [Alignable H.SrcSpan] -> Bool++fixable :: [Alignable S.RealSrcSpan] -> Bool fixable []     = False fixable [_]    = False fixable fields = all singleLine containers && nonOverlapping containers   where     containers        = map aContainer fields-    singleLine s      = H.srcSpanStartLine s == H.srcSpanEndLine s-    nonOverlapping ss = length ss == length (nub $ map H.srcSpanStartLine ss)+    singleLine s      = S.srcSpanStartLine s == S.srcSpanEndLine s+    nonOverlapping ss = length ss == length (nub $ map S.srcSpanStartLine ss)

@@ -4,20 +4,17 @@     , LineBlock     , SpanBlock     , blockLength-    , linesFromSrcSpan-    , spanFromSrcSpan     , moveBlock     , adjacent     , merge+    , mergeAdjacent     , overlapping     , groupAdjacent     ) where   ---------------------------------------------------------------------------------import           Control.Arrow         (arr, (&&&), (>>>))-import qualified Data.IntSet           as IS-import qualified Language.Haskell.Exts as H+import qualified Data.IntSet as IS   --------------------------------------------------------------------------------@@ -25,7 +22,8 @@ data Block a = Block     { blockStart :: Int     , blockEnd   :: Int-    } deriving (Eq, Ord, Show)+    }+    deriving (Eq, Ord, Show)   --------------------------------------------------------------------------------@@ -40,22 +38,7 @@ blockLength :: Block a -> Int blockLength (Block start end) = end - start + 1 - ---------------------------------------------------------------------------------linesFromSrcSpan :: H.SrcSpanInfo -> LineBlock-linesFromSrcSpan = H.srcInfoSpan >>>-    H.srcSpanStartLine &&& H.srcSpanEndLine >>>-    arr (uncurry Block)------------------------------------------------------------------------------------spanFromSrcSpan :: H.SrcSpanInfo -> SpanBlock-spanFromSrcSpan = H.srcInfoSpan >>>-    H.srcSpanStartColumn &&& H.srcSpanEndColumn >>>-    arr (uncurry Block)----------------------------------------------------------------------------------- moveBlock :: Int -> Block a -> Block a moveBlock offset (Block start end) = Block (start + offset) (end + offset) @@ -94,3 +77,8 @@     go (b1, x) gs = case break (adjacent b1 . fst) gs of         (_, [])               -> (b1, [x]) : gs         (ys, ((b2, xs) : zs)) -> (merge b1 b2, x : xs) : (ys ++ zs)++mergeAdjacent :: [Block a] -> [Block a]+mergeAdjacent (a : b : rest) | a `adjacent` b = merge a b : mergeAdjacent rest+mergeAdjacent (a : rest)     = a : mergeAdjacent rest+mergeAdjacent []             = []

@@ -1,9 +1,12 @@ --------------------------------------------------------------------------------+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE LambdaCase        #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell   #-} module Language.Haskell.Stylish.Config     ( Extensions     , Config (..)+    , ExitCodeBehavior (..)     , defaultConfigBytes     , configFilePath     , loadConfig@@ -40,6 +43,7 @@ import           Language.Haskell.Stylish.Step import qualified Language.Haskell.Stylish.Step.Data               as Data import qualified Language.Haskell.Stylish.Step.Imports            as Imports+import qualified Language.Haskell.Stylish.Step.ModuleHeader       as ModuleHeader import qualified Language.Haskell.Stylish.Step.LanguagePragmas    as LanguagePragmas import qualified Language.Haskell.Stylish.Step.SimpleAlign        as SimpleAlign import qualified Language.Haskell.Stylish.Step.Squash             as Squash@@ -60,9 +64,19 @@     , configLanguageExtensions :: [String]     , configNewline            :: IO.Newline     , configCabal              :: Bool+    , configExitCode           :: ExitCodeBehavior     } +--------------------------------------------------------------------------------+data ExitCodeBehavior+  = NormalExitBehavior+  | ErrorOnFormatExitBehavior+  deriving (Eq) +instance Show ExitCodeBehavior where+  show NormalExitBehavior = "normal"+  show ErrorOnFormatExitBehavior = "error_on_format"+ -------------------------------------------------------------------------------- instance FromJSON Config where     parseJSON = parseConfig@@ -126,6 +140,7 @@         <*> (o A..:? "language_extensions" A..!= [])         <*> (o A..:? "newline"             >>= parseEnum newlines IO.nativeNewline)         <*> (o A..:? "cabal"               A..!= True)+        <*> (o A..:? "exit_code"           >>= parseEnum exitCodes NormalExitBehavior)      -- Then fill in the steps based on the partial config we already have     stepValues <- o A..: "steps" :: A.Parser [A.Value]@@ -137,6 +152,10 @@         , ("lf",     IO.LF)         , ("crlf",   IO.CRLF)         ]+    exitCodes =+        [ ("normal", NormalExitBehavior)+        , ("error_on_format", ErrorOnFormatExitBehavior)+        ] parseConfig _            = mzero  @@ -144,6 +163,7 @@ catalog :: Map String (Config -> A.Object -> A.Parser Step) catalog = M.fromList     [ ("imports",             parseImports)+    , ("module_header",       parseModuleHeader)     , ("records",             parseRecords)     , ("language_pragmas",    parseLanguagePragmas)     , ("simple_align",        parseSimpleAlign)@@ -172,6 +192,11 @@     Nothing -> fail $ "Unknown option: " ++ k ++ ", should be one of: " ++         intercalate ", " (map fst strs) +--------------------------------------------------------------------------------+parseModuleHeader :: Config -> A.Object -> A.Parser Step+parseModuleHeader _ o = fmap ModuleHeader.step $ ModuleHeader.Config+    <$> o A..:? "indent" A..!= (ModuleHeader.indent ModuleHeader.defaultConfig)+    <*> o A..:? "sort"   A..!= (ModuleHeader.sort ModuleHeader.defaultConfig)  -------------------------------------------------------------------------------- parseSimpleAlign :: Config -> A.Object -> A.Parser Step@@ -186,13 +211,20 @@  -------------------------------------------------------------------------------- parseRecords :: Config -> A.Object -> A.Parser Step-parseRecords _ o = Data.step+parseRecords c o = Data.step     <$> (Data.Config         <$> (o A..: "equals" >>= parseIndent)         <*> (o A..: "first_field" >>= parseIndent)         <*> (o A..: "field_comment")-        <*> (o A..: "deriving"))-+        <*> (o A..: "deriving")+        <*> (o A..:? "break_enums" A..!= False)+        <*> (o A..:? "break_single_constructors" A..!= True)+        <*> (o A..: "via" >>= parseIndent)+        <*> (o A..:? "curried_context" A..!= False)+        <*> pure configMaxColumns)+  where+    configMaxColumns =+      maybe Data.NoMaxColumns Data.MaxColumns (configColumns c)  parseIndent :: A.Value -> A.Parser Data.Indent parseIndent = A.withText "Indent" $ \t ->@@ -214,23 +246,21 @@  -------------------------------------------------------------------------------- parseImports :: Config -> A.Object -> A.Parser Step-parseImports config o = Imports.step-    <$> pure (configColumns config)-    <*> (Imports.Options-        <$> (o A..:? "align" >>= parseEnum aligns (def Imports.importAlign))-        <*> (o A..:? "list_align" >>= parseEnum listAligns (def Imports.listAlign))-        <*> (o A..:? "pad_module_names" A..!= def Imports.padModuleNames)-        <*> (o A..:? "long_list_align"-            >>= parseEnum longListAligns (def Imports.longListAlign))-        -- Note that padding has to be at least 1. Default is 4.-        <*> (o A..:? "empty_list_align"-            >>= parseEnum emptyListAligns (def Imports.emptyListAlign))-        <*> o A..:? "list_padding" A..!= def Imports.listPadding-        <*> o A..:? "separate_lists" A..!= def Imports.separateLists-        <*> o A..:? "space_surround" A..!= def Imports.spaceSurround)+parseImports config o = fmap (Imports.step columns) $ Imports.Options+      <$> (o A..:? "align" >>= parseEnum aligns (def Imports.importAlign))+      <*> (o A..:? "list_align" >>= parseEnum listAligns (def Imports.listAlign))+      <*> (o A..:? "pad_module_names" A..!= def Imports.padModuleNames)+      <*> (o A..:? "long_list_align" >>= parseEnum longListAligns (def Imports.longListAlign))+      <*> (o A..:? "empty_list_align" >>= parseEnum emptyListAligns (def Imports.emptyListAlign))+      -- Note that padding has to be at least 1. Default is 4.+      <*> (o A..:? "list_padding" >>= maybe (pure $ def Imports.listPadding) parseListPadding)+      <*> o A..:? "separate_lists" A..!= def Imports.separateLists+      <*> o A..:? "space_surround" A..!= def Imports.spaceSurround   where     def f = f Imports.defaultOptions +    columns = configColumns config+     aligns =         [ ("global", Imports.Global)         , ("file",   Imports.File)@@ -243,6 +273,7 @@         , ("with_module_name",  Imports.WithModuleName)         , ("with_alias",        Imports.WithAlias)         , ("after_alias",       Imports.AfterAlias)+        , ("repeat",            Imports.Repeat)         ]      longListAligns =@@ -256,6 +287,11 @@         [ ("inherit", Imports.Inherit)         , ("right_after", Imports.RightAfter)         ]++    parseListPadding = \case+        A.String "module_name" -> pure Imports.LPModuleName+        A.Number n | n >= 1 -> pure $ Imports.LPConstant (truncate n)+        v -> A.typeMismatch "'module_name' or >=1 number" v  -------------------------------------------------------------------------------- parseLanguagePragmas :: Config -> A.Object -> A.Parser Step

@@ -0,0 +1,101 @@+{-# LANGUAGE LambdaCase #-}+{-# OPTIONS_GHC -Wno-missing-fields #-}+-- | Utility functions for working with the GHC AST+module Language.Haskell.Stylish.GHC+  ( dropAfterLocated+  , dropBeforeLocated+  , dropBeforeAndAfter+    -- * Unsafe getters+  , getEndLineUnsafe+  , getStartLineUnsafe+    -- * Standard settings+  , baseDynFlags+    -- * Positions+  , unLocated+    -- * Outputable operators+  , showOutputable+  , compareOutputable+  ) where++--------------------------------------------------------------------------------+import           Data.Function (on)++--------------------------------------------------------------------------------+import           DynFlags                        (Settings(..), defaultDynFlags)+import qualified DynFlags                        as GHC+import           FileSettings                    (FileSettings(..))+import           GHC.Fingerprint                 (fingerprint0)+import           GHC.Platform+import           GHC.Version                     (cProjectVersion)+import           GhcNameVersion                  (GhcNameVersion(..))+import           PlatformConstants               (PlatformConstants(..))+import           SrcLoc                          (GenLocated(..), SrcSpan(..))+import           SrcLoc                          (Located, RealLocated)+import           SrcLoc                          (srcSpanStartLine, srcSpanEndLine)+import           ToolSettings                    (ToolSettings(..))+import qualified Outputable                      as GHC++getStartLineUnsafe :: Located a -> Int+getStartLineUnsafe = \case+  (L (RealSrcSpan s) _) -> srcSpanStartLine s+  _ -> error "could not get start line of block"++getEndLineUnsafe :: Located a -> Int+getEndLineUnsafe = \case+  (L (RealSrcSpan s) _) -> srcSpanEndLine s+  _ -> error "could not get end line of block"++dropAfterLocated :: Maybe (Located a) -> [RealLocated b] -> [RealLocated b]+dropAfterLocated loc xs = case loc of+  Just (L (RealSrcSpan rloc) _) ->+    filter (\(L x _) -> srcSpanEndLine rloc >= srcSpanStartLine x) xs+  _ -> xs++dropBeforeLocated :: Maybe (Located a) -> [RealLocated b] -> [RealLocated b]+dropBeforeLocated loc xs = case loc of+  Just (L (RealSrcSpan rloc) _) ->+    filter (\(L x _) -> srcSpanStartLine rloc <= srcSpanEndLine x) xs+  _ -> xs++dropBeforeAndAfter :: Located a -> [RealLocated b] -> [RealLocated b]+dropBeforeAndAfter loc = dropBeforeLocated (Just loc) . dropAfterLocated (Just loc)++baseDynFlags :: GHC.DynFlags+baseDynFlags = defaultDynFlags fakeSettings llvmConfig+  where+    fakeSettings = GHC.Settings+      { sGhcNameVersion = GhcNameVersion "stylish-haskell" cProjectVersion+      , sFileSettings = FileSettings {}+      , sToolSettings = ToolSettings+        { toolSettings_opt_P_fingerprint = fingerprint0,+          toolSettings_pgm_F = ""+        }+      , sPlatformConstants = PlatformConstants+        { pc_DYNAMIC_BY_DEFAULT = False+        , pc_WORD_SIZE = 8+        }+      , sTargetPlatform = Platform+        { platformMini = PlatformMini+          { platformMini_arch = ArchUnknown+          , platformMini_os = OSUnknown+          }+        , platformWordSize = PW8+        , platformUnregisterised = True+        , platformHasIdentDirective = False+        , platformHasSubsectionsViaSymbols = False+        , platformIsCrossCompiling = False+        }+      , sPlatformMisc = PlatformMisc {}+      , sRawSettings = []+      }++    llvmConfig = GHC.LlvmConfig [] []++unLocated :: Located a -> a+unLocated (L _ a) = a++showOutputable :: GHC.Outputable a => a -> String+showOutputable = GHC.showPpr baseDynFlags++compareOutputable :: GHC.Outputable a => a -> a -> Ordering+compareOutputable = compare `on` showOutputable

@@ -0,0 +1,280 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE DeriveDataTypeable #-}+module Language.Haskell.Stylish.Module+  ( -- * Data types+    Module (..)+  , ModuleHeader+  , Import+  , Decls+  , Comments+  , Lines+  , makeModule++    -- * Getters+  , moduleHeader+  , moduleImports+  , moduleImportGroups+  , moduleDecls+  , moduleComments+  , moduleLanguagePragmas+  , queryModule++    -- * Imports+  , canMergeImport+  , mergeModuleImport++    -- * Annotations+  , lookupAnnotation++    -- * Internal API getters+  , rawComments+  , rawImport+  , rawModuleAnnotations+  , rawModuleDecls+  , rawModuleExports+  , rawModuleHaddocks+  , rawModuleName+  ) where++--------------------------------------------------------------------------------+import           Data.Function                   ((&), on)+import           Data.Functor                    ((<&>))+import           Data.Generics                   (Typeable, everything, mkQ)+import           Data.Maybe                      (mapMaybe)+import           Data.Map                        (Map)+import qualified Data.Map                        as Map+import           Data.List                       (nubBy, sort)+import           Data.List.NonEmpty              (NonEmpty (..), nonEmpty)+import           Data.Text                       (Text)+import qualified Data.Text                       as T+import           Data.Data                       (Data)++--------------------------------------------------------------------------------+import 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           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]++-- | Import declaration in module+newtype Import = Import { unImport :: ImportDecl GhcPs }+  deriving newtype (Outputable)++-- | Returns true if the two import declarations can be merged+canMergeImport :: Import -> Import -> Bool+canMergeImport (Import i0) (Import i1) = and $ fmap (\f -> f i0 i1)+  [ (==) `on` unLocated . ideclName+  , (==) `on` ideclPkgQual+  , (==) `on` ideclSource+  , hasMergableQualified `on` ideclQualified+  , (==) `on` ideclImplicit+  , (==) `on` fmap unLocated . 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++-- | 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)++-- | Get groups of imports from module+moduleImportGroups :: Module -> [NonEmpty (Located Import)]+moduleImportGroups = go [] Nothing . moduleImports+  where+    -- Run through all imports (assume they are sorted already in order of+    -- appearance in the file) and group the ones that are on consecutive+    -- lines.+    go  :: [Located Import] -> Maybe Int -> [Located Import]+        -> [NonEmpty (Located Import)]+    go acc _        []                   = ne acc+    go acc mbCurrentLine (imp : impRest) =+        let l2 = getStartLineUnsafe imp in+        case mbCurrentLine of+            Just l1 | l1 + 1 < l2 -> ne acc ++ go [imp] (Just l2) impRest+            _                     -> go (acc ++ [imp]) (Just l2) impRest++    ne []       = []+    ne (x : xs) = [x :| xs]++-- | Merge two import declarations, keeping positions from the first+--+--   As alluded, this highlights an issue with merging imports. The GHC+--   annotation comments aren't attached to any particular AST node. This+--   means that right now, we're manually reconstructing the attachment. By+--   merging two import declarations, we lose that mapping.+--+--   It's not really a big deal if we consider that people don't usually+--   comment imports themselves. It _is_ however, systemic and it'd be better+--   if we processed comments beforehand and attached them to all AST nodes in+--   our own representation.+mergeModuleImport :: Located Import -> Located Import -> Located Import+mergeModuleImport (L p0 (Import i0)) (L _p1 (Import i1)) =+  L p0 $ Import i0 { ideclHiding = newImportNames }+  where+    newImportNames =+      case (ideclHiding i0, ideclHiding i1) of+        (Just (b, L p imps0), Just (_, L _ imps1)) -> Just (b, L p (imps0 `merge` imps1))+        (Nothing, Nothing) -> Nothing+        (Just x, Nothing) -> Just x+        (Nothing, Just x) -> Just x+    merge xs ys+      = nubBy ((==) `on` showOutputable) (xs ++ ys)++-- | Get module header+moduleHeader :: Module -> ModuleHeader+moduleHeader (Module _ _ _ (GHC.L _ m)) = ModuleHeader+  { name = GHC.hsmodName m+  , exports = GHC.hsmodExports m+  , haddocks = GHC.hsmodHaddockModHeader m+  }++-- | Query for annotations associated with a 'SrcSpan'+lookupAnnotation :: SrcSpan -> Module -> [GHC.AnnKeywordId]+lookupAnnotation (RealSrcSpan rspan) m = Map.findWithDefault [] rspan (parsedAnnotSrcs m)+lookupAnnotation (UnhelpfulSpan _) _ = []++-- | Query the module AST using @f@+queryModule :: Typeable a => (a -> [b]) -> Module -> [b]+queryModule f = everything (++) (mkQ [] f) . parsedModule++--------------------------------------------------------------------------------+-- | Getter for internal components in imports newtype+rawImport :: Import -> ImportDecl GhcPs+rawImport (Import i) = i++-- | Getter for internal module name representation+rawModuleName :: ModuleHeader -> Maybe (GHC.Located GHC.ModuleName)+rawModuleName = name++-- | Getter for internal module exports representation+rawModuleExports :: ModuleHeader -> Maybe (GHC.Located [GHC.LIE GhcPs])+rawModuleExports = exports++-- | Getter for internal module haddocks representation+rawModuleHaddocks :: ModuleHeader -> Maybe GHC.LHsDocString+rawModuleHaddocks = haddocks++-- | Getter for internal module decls representation+rawModuleDecls :: Decls -> [LHsDecl GhcPs]+rawModuleDecls (Decls xs) = xs++-- | Getter for internal module comments representation+rawComments :: Comments -> [GHC.RealLocated GHC.AnnotationComment]+rawComments (Comments xs) = xs++-- | Getter for internal module annotation representation+rawModuleAnnotations :: Module -> [(GHC.ApiAnnKey, [GHC.SrcSpan])]+rawModuleAnnotations = parsedAnnotations

@@ -0,0 +1,61 @@+--------------------------------------------------------------------------------+-- | There are a number of steps that sort items: 'Imports' and 'ModuleHeader',+-- and maybe more in the future.  This module provides consistent sorting+-- utilities.+{-# LANGUAGE LambdaCase #-}+module Language.Haskell.Stylish.Ordering+    ( compareLIE+    , compareWrappedName+    , unwrapName+    ) where+++--------------------------------------------------------------------------------+import           Data.Char                    (isUpper)+import           Data.Ord                     (comparing)+import           GHC.Hs+import           RdrName                      (RdrName)+import           SrcLoc                       (unLoc)+++--------------------------------------------------------------------------------+import           Language.Haskell.Stylish.GHC (showOutputable)+import           Outputable                   (Outputable)+++--------------------------------------------------------------------------------+-- | NOTE: Can we get rid off this by adding a properly sorting newtype around+-- 'RdrName'?+compareLIE :: LIE GhcPs -> LIE GhcPs -> Ordering+compareLIE = comparing $ ieKey . unLoc+  where+    -- | The implementation is a bit hacky to get proper sorting for input specs:+    -- constructors first, followed by functions, and then operators.+    ieKey :: IE GhcPs -> (Int, String)+    ieKey = \case+        IEVar _ n             -> nameKey n+        IEThingAbs _ n        -> nameKey n+        IEThingAll _ n        -> nameKey n+        IEThingWith _ n _ _ _ -> nameKey n+        IEModuleContents _ n  -> nameKey n+        _                     -> (2, "")+++--------------------------------------------------------------------------------+compareWrappedName :: IEWrappedName RdrName -> IEWrappedName RdrName -> Ordering+compareWrappedName = comparing nameKey+++--------------------------------------------------------------------------------+unwrapName :: IEWrappedName n -> n+unwrapName (IEName n)    = unLoc n+unwrapName (IEPattern n) = unLoc n+unwrapName (IEType n)    = unLoc n+++--------------------------------------------------------------------------------+nameKey :: Outputable name => name -> (Int, String)+nameKey n = case showOutputable n of+    o@('(' : _)             -> (2, o)+    o@(o0 : _) | isUpper o0 -> (0, o)+    o                       -> (1, o)

@@ -1,35 +1,39 @@+{-# LANGUAGE LambdaCase #-} -------------------------------------------------------------------------------- module Language.Haskell.Stylish.Parse-    ( parseModule-    ) where+  ( parseModule+  ) where   ---------------------------------------------------------------------------------import           Data.List                       (isPrefixOf, nub)+import           Data.Function                   ((&)) import           Data.Maybe                      (fromMaybe, listToMaybe)-import qualified Language.Haskell.Exts           as H-+import           System.IO.Unsafe                (unsafePerformIO)  ---------------------------------------------------------------------------------import           Language.Haskell.Stylish.Config-import           Language.Haskell.Stylish.Step-+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  ----------------------------------------------------------------------------------- | Syntax-related language extensions are always enabled for parsing. Since we--- can't authoritatively know which extensions are enabled at compile-time, we--- should try not to throw errors when parsing any GHC-accepted code.-defaultExtensions :: [H.Extension]-defaultExtensions = map H.EnableExtension-  [ H.GADTs-  , H.HereDocuments-  , H.KindSignatures-  , H.NewQualifiedOperators-  , H.PatternGuards-  , H.StandaloneDeriving-  , H.UnicodeSyntax-  ]+import           Language.Haskell.Stylish.GHC    (baseDynFlags)+import           Language.Haskell.Stylish.Module +type Extensions = [String]  -------------------------------------------------------------------------------- -- | Filter out lines which use CPP macros@@ -42,16 +46,7 @@             nextMultiline = isCpp && not (null x) && last x == '\\'         in (if isCpp then "" else x) : go nextMultiline xs - ----------------------------------------------------------------------------------- | Remove shebang lines-unShebang :: String -> String-unShebang str =-    let (shebangs, other) = break (not . ("#!" `isPrefixOf`)) (lines str) in-    unlines $ map (const "") shebangs ++ other----------------------------------------------------------------------------------- -- | If the given string is prefixed with an UTF-8 Byte Order Mark, drop it -- because haskell-src-exts can't handle it. dropBom :: String -> String@@ -60,32 +55,69 @@   ----------------------------------------------------------------------------------- | Abstraction over HSE's parsing+-- | Abstraction over GHC lib's parsing parseModule :: Extensions -> Maybe FilePath -> String -> Either String Module-parseModule extraExts mfp string = do-    -- Determine the extensions: those specified in the file and the extra ones-    let noPrefixes       = unShebang . dropBom $ string-        extraExts'       = map H.classifyExtension extraExts-        (lang, fileExts) = fromMaybe (Nothing, []) $ H.readExtensions noPrefixes-        exts             = nub $ fileExts ++ extraExts' ++ defaultExtensions+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 -        -- Parsing options...-        fp       = fromMaybe "<unknown>" mfp-        mode     = H.defaultParseMode-            { H.extensions   = exts-            , H.fixities     = Nothing-            , H.baseLanguage = case lang of-                Nothing -> H.baseLanguage H.defaultParseMode-                Just l  -> l-            }+    removeCpp dynFlags s =+      if GHC.xopt GHC.Cpp dynFlags then unCpp s+      else s -        -- Preprocessing-        processed = if H.EnableExtension H.CPP `elem` exts-                       then unCpp noPrefixes-                       else noPrefixes+    userExtensions =+      fmap toLocatedExtensionFlag ("Haskell2010" : exts) -- FIXME: do we need `Haskell2010` here? -    case H.parseModuleWithComments mode processed of-        H.ParseOk md -> return md-        err          -> Left $-            "Language.Haskell.Stylish.Parse.parseModule: could not parse " ++-            fp ++ ": " ++ show err+    toLocatedExtensionFlag flag+      = "-X" <> flag+      & GHC.L GHC.noSrcSpan++    getParserStateErrors dynFlags state+      = GHC.getErrorMessages state dynFlags+      & bagToList+      & fmap (\errMsg -> show (GHC.errMsgSpan errMsg) <> ": " <> show errMsg)++    filePath =+      fromMaybe "<interactive>" fp++    runParser :: GHC.DynFlags -> String -> GHC.ParseResult (GHC.Located (GHC.HsModule GHC.GhcPs))+    runParser flags str =+      let+        filename = mkFastString filePath+        parseState = mkPState flags (stringToStringBuffer str) (mkRealSrcLoc filename 1 1)+      in+        unP GHC.parseModule parseState++-- | Parse 'DynFlags' from the extra options+--+--   /Note:/ this function would be IO, but we're not using any of the internal+--   features that constitute side effectful computation. So I think it's fine+--   if we run this to avoid changing the interface too much.+parsePragmasIntoDynFlags ::+     GHC.DynFlags+  -> [GHC.Located String]+  -> FilePath+  -> String+  -> Either String GHC.DynFlags+{-# NOINLINE parsePragmasIntoDynFlags #-}+parsePragmasIntoDynFlags originalFlags extraOpts filepath str = unsafePerformIO $ catchErrors $ do+  let opts = GHC.getOptions originalFlags (GHC.stringToStringBuffer str) filepath+  (parsedFlags, _invalidFlags, _warnings) <- GHC.parseDynamicFilePragma originalFlags (opts <> extraOpts)+  -- FIXME: have a look at 'leftovers' since it should be empty+  return $ Right $ parsedFlags `GHC.gopt_set` GHC.Opt_KeepRawTokenStream+  where+    catchErrors act = GHC.handleGhcException reportErr (GHC.handleSourceError reportErr act)+    reportErr e = return $ Left (show e)

@@ -0,0 +1,450 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DoAndIfThenElse #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+module Language.Haskell.Stylish.Printer+  ( Printer(..)+  , PrinterConfig(..)+  , PrinterState(..)++    -- * Alias+  , P++    -- * Functions to use the printer+  , runPrinter+  , runPrinter_++    -- ** Combinators+  , comma+  , dot+  , getAnnot+  , getCurrentLine+  , getCurrentLineLength+  , getDocstrPrev+  , newline+  , parenthesize+  , peekNextCommentPos+  , prefix+  , putComment+  , putEolComment+  , putOutputable+  , putAllSpanComments+  , putCond+  , putType+  , putRdrName+  , putText+  , removeCommentTo+  , removeCommentToEnd+  , removeLineComment+  , sep+  , groupAttachedComments+  , space+  , spaces+  , suffix++    -- ** Advanced combinators+  , withColumns+  , modifyCurrentLine+  , wrapping+  ) where++--------------------------------------------------------------------------------+import           Prelude                         hiding (lines)++--------------------------------------------------------------------------------+import           ApiAnnotation                   (AnnKeywordId(..), AnnotationComment(..))+import           GHC.Hs.Extension                (GhcPs, NoExtField(..))+import           GHC.Hs.Types                    (HsType(..))+import           Module                          (ModuleName, moduleNameString)+import           RdrName                         (RdrName(..))+import           SrcLoc                          (GenLocated(..), RealLocated)+import           SrcLoc                          (Located, SrcSpan(..))+import           SrcLoc                          (srcSpanStartLine, srcSpanEndLine)+import           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)+import           Data.Functor                    ((<&>))+import           Data.List                       (delete, isPrefixOf)+import           Data.List.NonEmpty              (NonEmpty(..))++--------------------------------------------------------------------------------+import           Language.Haskell.Stylish.Module (Module, Lines, lookupAnnotation)+import           Language.Haskell.Stylish.GHC    (showOutputable, unLocated)++-- | Shorthand for 'Printer' monad+type P = Printer++-- | Printer that keeps state of file+newtype Printer a = Printer (ReaderT PrinterConfig (State PrinterState) a)+  deriving (Applicative, Functor, Monad, MonadReader PrinterConfig, MonadState PrinterState)++-- | Configuration for printer, currently empty+data PrinterConfig = PrinterConfig+    { columns :: !(Maybe Int)+    }++-- | State of printer+data PrinterState = PrinterState+  { 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) =+  let+    (a, PrinterState parsedLines _ startedLine _ _) = runReaderT printer cfg `runState` PrinterState [] 0 "" comments m+  in+    (a, parsedLines <> if startedLine == [] then [] else [startedLine])++-- | Run printer to get printed lines only+runPrinter_ :: PrinterConfig -> [RealLocated AnnotationComment] -> Module -> Printer a -> Lines+runPrinter_ cfg comments m printer = snd (runPrinter cfg comments m printer)++-- | Print text+putText :: String -> P ()+putText txt = do+  l <- gets currentLine+  modify \s -> s { currentLine = l <> txt }++-- | Check condition post action, and use fallback if false+putCond :: (PrinterState -> Bool) -> P b -> P b -> P b+putCond p action fallback = do+  prevState <- get+  res <- action+  currState <- get+  if p currState then pure res+  else put prevState >> fallback++-- | Print an 'Outputable'+putOutputable :: Outputable a => a -> P ()+putOutputable = putText . showOutputable++-- | Put all comments that has positions within 'SrcSpan' and separate by+--   passed @P ()@+putAllSpanComments :: P () -> SrcSpan -> P ()+putAllSpanComments suff = \case+  UnhelpfulSpan _ -> pure ()+  RealSrcSpan rspan -> do+    cmts <- removeComments \(L rloc _) ->+      srcSpanStartLine rloc >= srcSpanStartLine rspan &&+      srcSpanEndLine rloc <= srcSpanEndLine rspan++    forM_ cmts (\c -> putComment c >> suff)++-- | Print any comment+putComment :: AnnotationComment -> P ()+putComment = \case+  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++-- | 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 ()++-- | 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 "`"+      putText (showOutputable name)+      putText "`"+    else if AnnSimpleQuote `elem` annots then do+      putText "'"+      putText (showOutputable name)+    else+      putText (showOutputable name)+  Qual modulePrefix name ->+    putModuleName modulePrefix >> dot >> putText (showOutputable name)+  Orig _ name ->+    putText (showOutputable name)+  Exact name ->+    putText (showOutputable name)++-- | Print module name+putModuleName :: ModuleName -> P ()+putModuleName = putText . moduleNameString++-- | Print type+putType :: Located (HsType GhcPs) -> P ()+putType ltp = case unLocated ltp of+  HsFunTy NoExtField argTp funTp -> do+    putOutputable argTp+    space+    putText "->"+    space+    putType funTp+  HsAppTy NoExtField t1 t2 ->+    putType t1 >> space >> putType t2+  HsExplicitListTy NoExtField _ xs -> do+    putText "'["+    sep+      (comma >> space)+      (fmap putType xs)+    putText "]"+  HsExplicitTupleTy NoExtField xs -> do+    putText "'("+    sep+      (comma >> space)+      (fmap putType xs)+    putText ")"+  HsOpTy NoExtField lhs op rhs -> do+    putType lhs+    space+    putRdrName op+    space+    putType rhs+  HsTyVar NoExtField _ rdrName ->+    putRdrName rdrName+  HsTyLit _ tp ->+    putOutputable tp+  HsParTy _ tp -> do+    putText "("+    putType tp+    putText ")"+  HsTupleTy NoExtField _ xs -> do+    putText "("+    sep+      (comma >> space)+      (fmap putType xs)+    putText ")"+  HsForAllTy NoExtField _ _ _ ->+    putOutputable ltp+  HsQualTy NoExtField _ _ ->+    putOutputable ltp+  HsAppKindTy _ _ _ ->+    putOutputable ltp+  HsListTy _ _ ->+    putOutputable ltp+  HsSumTy _ _ ->+    putOutputable ltp+  HsIParamTy _ _ _ ->+    putOutputable ltp+  HsKindSig _ _ _ ->+    putOutputable ltp+  HsStarTy _ _ ->+    putOutputable ltp+  HsSpliceTy _ _ ->+    putOutputable ltp+  HsDocTy _ _ _ ->+    putOutputable ltp+  HsBangTy _ _ _ ->+    putOutputable ltp+  HsRecTy _ _ ->+    putOutputable ltp+  HsWildCardTy _ ->+    putOutputable ltp+  XHsType _ ->+    putOutputable ltp++-- | Get a docstring on the start line of 'SrcSpan' that is a @-- ^@ comment+getDocstrPrev :: SrcSpan -> P (Maybe AnnotationComment)+getDocstrPrev = \case+  UnhelpfulSpan _ -> pure Nothing+  RealSrcSpan rspan -> do+    removeComment \case+      L rloc (AnnLineComment s) ->+        and+          [ srcSpanStartLine rspan == srcSpanStartLine rloc+          , "-- ^" `isPrefixOf` s+          ]+      _ -> False++-- | Print a newline+newline :: P ()+newline = do+  l <- gets currentLine+  modify \s -> s { currentLine = "", linePos = 0, lines = lines s <> [l] }++-- | Print a space+space :: P ()+space = putText " "++-- | Print a number of spaces+spaces :: Int -> P ()+spaces i = replicateM_ i space++-- | Print a dot+dot :: P ()+dot = putText "."++-- | Print a comma+comma :: P ()+comma = putText ","++-- | Add parens around a printed action+parenthesize :: P a -> P a+parenthesize action = putText "(" *> action <* putText ")"++-- | Add separator between each element of the given printers+sep :: P a -> [P a] -> P ()+sep _ [] = pure ()+sep s (first : rest) = first >> forM_ rest ((>>) s)++-- | Prefix a printer with another one+prefix :: P a -> P b -> P b+prefix pa pb = pa >> pb++-- | Suffix a printer with another one+suffix :: P a -> P b -> P a+suffix pa pb = pb >> pa++-- | 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++-- | 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 []++modifyCurrentLine :: (String -> String) -> P ()+modifyCurrentLine f = do+    s0 <- get+    put s0 {currentLine = f $ currentLine s0}++wrapping+    :: P a  -- ^ First printer to run+    -> P a  -- ^ Printer to run if first printer violates max columns+    -> P a  -- ^ Result of either the first or the second printer+wrapping p1 p2 = do+    maxCols <- asks columns+    case maxCols of+        -- No wrapping+        Nothing -> p1+        Just c  -> do+            s0 <- get+            x <- p1+            s1 <- get+            if length (currentLine s1) <= c+                -- No need to wrap+                then pure x+                else do+                    put s0+                    y <- p2+                    s2 <- get+                    if length (currentLine s1) == length (currentLine s2)+                        -- Wrapping didn't help!+                        then put s1 >> pure x+                        -- Wrapped+                        else pure y++withColumns :: Maybe Int -> P a -> P a+withColumns c = local $ \pc -> pc {columns = c}

@@ -1,31 +1,19 @@ -------------------------------------------------------------------------------- module Language.Haskell.Stylish.Step     ( Lines-    , Module     , Step (..)     , makeStep     ) where   ---------------------------------------------------------------------------------import qualified Language.Haskell.Exts as H------------------------------------------------------------------------------------type Lines = [String]-------------------------------------------------------------------------------------- | Concrete module type-type Module = (H.Module H.SrcSpanInfo, [H.Comment])-+import           Language.Haskell.Stylish.Module  -------------------------------------------------------------------------------- data Step = Step     { stepName   :: String     , stepFilter :: Lines -> Module -> Lines     }-  -------------------------------------------------------------------------------- makeStep :: String -> (Lines -> Module -> Lines) -> Step

@@ -1,126 +1,518 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DoAndIfThenElse #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-}+module Language.Haskell.Stylish.Step.Data+  ( Config(..)+  , Indent(..)+  , MaxColumns(..)+  , step+  ) where -module Language.Haskell.Stylish.Step.Data where+--------------------------------------------------------------------------------+import           Prelude                          hiding (init) -import           Data.List                       (find, intercalate)-import           Data.Maybe                      (fromMaybe, maybeToList)-import qualified Language.Haskell.Exts           as H-import           Language.Haskell.Exts.Comments+--------------------------------------------------------------------------------+import           Control.Monad                    (forM_, unless, when)+import           Data.Function                    ((&))+import           Data.Functor                     ((<&>))+import           Data.List                        (sortBy)+import           Data.Maybe                       (listToMaybe)++--------------------------------------------------------------------------------+import           ApiAnnotation                    (AnnotationComment)+import           BasicTypes                       (LexicalFixity(..))+import           GHC.Hs.Decls                     (HsDecl(..), HsDataDefn(..))+import           GHC.Hs.Decls                     (TyClDecl(..), NewOrData(..))+import           GHC.Hs.Decls                     (HsDerivingClause(..), DerivStrategy(..))+import           GHC.Hs.Decls                     (ConDecl(..))+import           GHC.Hs.Extension                 (GhcPs, NoExtField(..), noExtCon)+import           GHC.Hs.Types                     (ConDeclField(..), HsContext)+import           GHC.Hs.Types                     (HsType(..), ForallVisFlag(..))+import           GHC.Hs.Types                     (LHsQTyVars(..), HsTyVarBndr(..))+import           GHC.Hs.Types                     (HsConDetails(..), HsImplicitBndrs(..))+import           RdrName                          (RdrName)+import           SrcLoc                           (Located, RealLocated)+import           SrcLoc                           (GenLocated(..))++-------------------------------------------------------------------------------- import           Language.Haskell.Stylish.Block import           Language.Haskell.Stylish.Editor+import           Language.Haskell.Stylish.GHC+import           Language.Haskell.Stylish.Module+import           Language.Haskell.Stylish.Printer import           Language.Haskell.Stylish.Step-import           Language.Haskell.Stylish.Util-import           Prelude                         hiding (init)  data Indent     = SameLine     | Indent !Int-  deriving (Show)+  deriving (Show, Eq) +data MaxColumns+  = MaxColumns !Int+  | NoMaxColumns+  deriving (Show, Eq)+ data Config = Config-    { cEquals           :: !Indent+    { cEquals                  :: !Indent       -- ^ Indent between type constructor and @=@ sign (measured from column 0)-    , cFirstField       :: !Indent+    , cFirstField              :: !Indent       -- ^ Indent between data constructor and @{@ line (measured from column with data constructor name)-    , cFieldComment     :: !Int+    , cFieldComment            :: !Int       -- ^ Indent between column with @{@ and start of field line comment (this line has @cFieldComment = 2@)-    , cDeriving         :: !Int+    , cDeriving                :: !Int       -- ^ Indent before @deriving@ lines (measured from column 0)+    , cBreakEnums              :: !Bool+      -- ^ Break enums by newlines and follow the above rules+    , cBreakSingleConstructors :: !Bool+      -- ^ Break single constructors when enabled, e.g. @Indent 2@ will not cause newline after @=@+    , cVia                     :: !Indent+      -- ^ Indentation between @via@ clause and start of deriving column start+    , cCurriedContext          :: !Bool+      -- ^ If true, use curried context. E.g: @allValues :: Enum a => Bounded a => Proxy a -> [a]@+    , cMaxColumns              :: !MaxColumns     } deriving (Show) -datas :: H.Module l -> [H.Decl l]-datas (H.Module _ _ _ _ decls) = decls-datas _                        = []+step :: Config -> Step+step cfg = makeStep "Data" \ls m -> applyChanges (changes m) ls+  where+    changes :: Module -> [ChangeLine]+    changes m = fmap (formatDataDecl cfg m) (dataDecls m) -type ChangeLine = Change String+    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+        }+      _ -> [] -step :: Config -> Step-step cfg = makeStep "Data" (step' cfg)+type ChangeLine = Change String -step' :: Config -> Lines -> Module -> Lines-step' cfg ls (module', allComments) = applyChanges changes ls+formatDataDecl :: Config -> Module -> Located DataDecl -> ChangeLine+formatDataDecl cfg@Config{..} m ldecl@(L declPos decl) =+  change originalDeclBlock (const printedDecl)   where-    datas' = datas $ fmap linesFromSrcSpan module'-    changes = datas' >>= maybeToList . changeDecl allComments cfg+    relevantComments :: [RealLocated AnnotationComment]+    relevantComments+      = moduleComments m+      & rawComments+      & dropBeforeAndAfter ldecl -findCommentOnLine :: LineBlock -> [Comment] -> Maybe Comment-findCommentOnLine lb = find commentOnLine-  where-    commentOnLine (Comment _ (H.SrcSpan _ start _ end _) _) =-      blockStart lb == start && blockEnd lb == end+    defn = dataDefn decl -findCommentBelowLine :: LineBlock -> [Comment] -> Maybe Comment-findCommentBelowLine lb = find commentOnLine-  where-    commentOnLine (Comment _ (H.SrcSpan _ start _ end _) _) =-      blockStart lb == start - 1 && blockEnd lb == end - 1+    originalDeclBlock =+      Block (getStartLineUnsafe ldecl) (getEndLineUnsafe ldecl) -commentsWithin :: LineBlock -> [Comment] -> [Comment]-commentsWithin lb = filter within+    printerConfig = PrinterConfig+      { columns = case cMaxColumns of+          NoMaxColumns -> Nothing+          MaxColumns n -> Just n+      }++    printedDecl = runPrinter_ printerConfig relevantComments m do+      putText (newOrData decl)+      space+      putName decl++      when (isGADT decl) (space >> putText "where")++      when (hasConstructors decl) do+        breakLineBeforeEq <- case (cEquals, cFirstField) of+          (_, Indent x) | isEnum decl && cBreakEnums -> do+            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++        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++              unless+                (isGADT decl)+                (putText "=" >> space)++              putConstructor cfg lineLengthAfterEq lcon+              forM_ consRest \con@(L conPos _) -> do+                unless (cFirstField == SameLine) do+                  removeCommentTo conPos >>= mapM_ \c -> consIndent lineLengthAfterEq >> putComment c+                consIndent lineLengthAfterEq++                unless+                  (isGADT decl)+                  (putText "|" >> space)++                putConstructor cfg lineLengthAfterEq con+                putEolComment conPos++        when (hasDeriving decl) do+          if isEnum decl && not cBreakEnums then+            space+          else do+            removeCommentTo (defn & dd_derivs & \(L pos _) -> pos) >>=+              mapM_ \c -> newline >> spaces cDeriving >> putComment c+            newline+            spaces cDeriving++        sep (newline >> spaces cDeriving) $ defn & dd_derivs & \(L pos ds) -> ds <&> \d -> do+          putAllSpanComments (newline >> spaces cDeriving) pos+          putDeriving cfg d++    consIndent eqIndent = newline >> case (cEquals, cFirstField) of+      (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+  }++putDeriving :: Config -> Located (HsDerivingClause GhcPs) -> P ()+putDeriving Config{..} (L pos clause) = do+  putText "deriving"++  forM_ (deriv_clause_strategy clause) \case+    L _ StockStrategy -> space >> putText "stock"+    L _ AnyclassStrategy -> space >> putText "anyclass"+    L _ NewtypeStrategy -> space >> putText "newtype"+    L _ (ViaStrategy _) -> pure ()++  putCond+    withinColumns+    oneLinePrint+    multilinePrint++  forM_ (deriv_clause_strategy clause) \case+    L _ (ViaStrategy tp) -> do+      case cVia of+        SameLine -> space+        Indent x -> newline >> spaces (x + cDeriving)++      putText "via"+      space+      putType (getType tp)+    _ -> pure ()++  putEolComment pos+   where-    within (Comment _ (H.SrcSpan _ start _ end _) _) =-      start >= blockStart lb && end <= blockEnd lb+    getType = \case+      HsIB _ tp -> tp+      XHsImplicitBndrs x -> noExtCon x -changeDecl :: [Comment] -> Config -> H.Decl LineBlock -> Maybe ChangeLine-changeDecl _ _ (H.DataDecl _ (H.DataType _) Nothing _ [] _) = Nothing-changeDecl allComments cfg@Config{..} (H.DataDecl block (H.DataType _) Nothing dhead decls derivings)-  | hasRecordFields = Just $ change block (const $ concat newLines)-  | otherwise       = Nothing+    withinColumns PrinterState{currentLine} =+      case cMaxColumns of+        MaxColumns maxCols -> length currentLine <= maxCols+        NoMaxColumns -> True++    oneLinePrint = do+      space+      putText "("+      sep+        (comma >> space)+        (fmap putOutputable tys)+      putText ")"++    multilinePrint = do+      newline+      spaces indentation+      putText "("++      forM_ headTy \t ->+        space >> putOutputable t++      forM_ tailTy \t -> do+        newline+        spaces indentation+        comma+        space+        putOutputable t++      newline+      spaces indentation+      putText ")"++    indentation =+      cDeriving + case cFirstField of+        Indent x -> x+        SameLine -> 0++    tys+      = clause+      & deriv_clause_tys+      & unLocated+      & sortBy compareOutputable+      & fmap hsib_body++    headTy =+      listToMaybe tys++    tailTy =+      drop 1 tys++putUnbrokenEnum :: Config -> DataDecl -> P ()+putUnbrokenEnum cfg decl =+  sep+    (space >> putText "|" >> space)+    (fmap (putConstructor cfg 0) . dd_cons . dataDefn $ decl)++putName :: DataDecl -> P ()+putName decl@MkDataDecl{..} =+  if isInfix decl then do+    forM_ firstTvar (\t -> putOutputable t >> space)+    putRdrName dataDeclName+    space+    forM_ secondTvar putOutputable+  else do+    putRdrName dataDeclName+    forM_ (hsq_explicit dataTypeVars) (\t -> space >> putOutputable t)+   where-    hasRecordFields = any-      (\qual -> case qual of-                  (H.QualConDecl _ _ _ (H.RecDecl {})) -> True-                  _ -> False)-      decls+    firstTvar :: Maybe (Located (HsTyVarBndr GhcPs))+    firstTvar+      = dataTypeVars+      & hsq_explicit+      & listToMaybe -    typeConstructor = "data " <> H.prettyPrint dhead+    secondTvar :: Maybe (Located (HsTyVarBndr GhcPs))+    secondTvar+      = dataTypeVars+      & hsq_explicit+      & drop 1+      & listToMaybe -    -- In any case set @pipeIndent@ such that @|@ is aligned with @=@.-    (firstLine, firstLineInit, pipeIndent) =-      case cEquals of-        SameLine -> (Nothing, typeConstructor <> " = ", length typeConstructor + 1)-        Indent n -> (Just [[typeConstructor]], indent n "= ", n)+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) -    newLines = fromMaybe [] firstLine ++ fmap constructors zipped <> [fmap (indent cDeriving . H.prettyPrint) derivings]-    zipped = zip decls ([1..] ::[Int])+      InfixCon arg1 arg2 -> do+        putType arg1+        space+        forM_ con_names putRdrName+        space+        putType arg2+      RecCon _ ->+        error . mconcat $+          [ "Language.Haskell.Stylish.Step.Data.putConstructor: "+          , "encountered a GADT with record constructors, not supported yet"+          ] -    constructors (decl, 1) = processConstructor allComments firstLineInit cfg decl-    constructors (decl, _) = processConstructor allComments (indent pipeIndent "| ") cfg decl-changeDecl _ _ _ = Nothing+    -- Put type of constructor:+    space+    putText "::"+    space -processConstructor :: [Comment] -> String -> Config -> H.QualConDecl LineBlock -> [String]-processConstructor allComments init Config{..} (H.QualConDecl _ _ _ (H.RecDecl _ dname (f:fs))) = do-  fromMaybe [] firstLine <> n1 <> ns <> [indent fieldIndent "}"]+    when (unLocated con_forall) do+      putText "forall"+      space+      sep space (fmap putOutputable $ hsq_explicit con_qvars)+      dot+      space++    forM_ con_mb_cxt (putContext cfg . unLocated)+    putType con_res_ty++  XConDecl x ->+    noExtCon x+  ConDeclH98{..} ->+    case con_args of+      InfixCon arg1 arg2 -> do+        putType arg1+        space+        putRdrName con_name+        space+        putType arg2+      PrefixCon xs -> do+        putRdrName con_name+        unless (null xs) space+        sep space (fmap putOutputable xs)+      RecCon (L recPos (L posFirst firstArg : args)) -> do+        putRdrName con_name+        skipToBrace >> putText "{"+        bracePos <- getCurrentLineLength+        space++        -- Unless everything's configured to be on the same line, put pending+        -- comments+        unless (cFirstField cfg == SameLine) do+          removeCommentTo posFirst >>= mapM_ \c -> putComment c >> sepDecl bracePos++        -- Put first decl field+        putConDeclField cfg firstArg+        unless (cFirstField cfg == SameLine) (putEolComment posFirst)++        -- Put tail decl fields+        forM_ args \(L pos arg) -> do+          sepDecl bracePos+          removeCommentTo pos >>= mapM_ \c ->+            spaces (cFieldComment cfg) >> putComment c >> sepDecl bracePos+          comma+          space+          putConDeclField cfg arg+          putEolComment pos++        -- Print docstr after final field+        removeCommentToEnd recPos >>= mapM_ \c ->+          sepDecl bracePos >> spaces (cFieldComment cfg) >> putComment c++        -- Print whitespace to closing brace+        sepDecl bracePos >> putText "}"+      RecCon (L _ []) -> do+        skipToBrace >> putText "{"+        skipToBrace >> putText "}"++    where+      skipToBrace = case (cEquals cfg, cFirstField cfg) of+        (_, Indent y) | not (cBreakSingleConstructors cfg) -> newline >> spaces y+        (SameLine, SameLine) -> space+        (Indent x, Indent y) -> newline >> spaces (x + y + 2)+        (SameLine, Indent y) -> newline >> spaces (consIndent + y)+        (Indent _, SameLine) -> space++      sepDecl bracePos = newline >> spaces case (cEquals cfg, cFirstField cfg) of+        (_, Indent y) | not (cBreakSingleConstructors cfg) -> y+        (SameLine, SameLine) -> bracePos - 1 -- back one from brace pos to place comma+        (Indent x, Indent y) -> x + y + 2+        (SameLine, Indent y) -> bracePos - 1 + y - 2+        (Indent x, SameLine) -> bracePos - 1 + x - 2++putNewtypeConstructor :: Config -> Located (ConDecl GhcPs) -> P ()+putNewtypeConstructor cfg (L _ cons) = case cons of+  ConDeclH98{..} ->+    putRdrName con_name >> case con_args of+      PrefixCon xs -> do+        unless (null xs) space+        sep space (fmap putOutputable xs)+      RecCon (L _ [L _posFirst firstArg]) -> do+        space+        putText "{"+        space+        putConDeclField cfg firstArg+        space+        putText "}"+      RecCon (L _ _args) ->+        error . mconcat $+          [ "Language.Haskell.Stylish.Step.Data.putNewtypeConstructor: "+          , "encountered newtype with several arguments"+          ]+      InfixCon {} ->+        error . mconcat $+          [ "Language.Haskell.Stylish.Step.Data.putNewtypeConstructor: "+          , "infix newtype constructor"+          ]+  XConDecl x ->+    noExtCon x+  ConDeclGADT{} ->+    error . mconcat $+      [ "Language.Haskell.Stylish.Step.Data.putNewtypeConstructor: "+      , "GADT encountered in newtype"+      ]++putContext :: Config -> HsContext GhcPs -> P ()+putContext Config{..} = suffix (space >> putText "=>" >> space) . \case+  [L _ (HsParTy _ tp)] | cCurriedContext ->+    putType tp+  [ctx] ->+    putType ctx+  ctxs | cCurriedContext ->+    sep (space >> putText "=>" >> space) (fmap putType ctxs)+  ctxs ->+    parenthesize $ sep (comma >> space) (fmap putType ctxs)++putConDeclField :: Config -> ConDeclField GhcPs -> P ()+putConDeclField cfg = \case+  ConDeclField{..} -> do+    sep+      (comma >> space)+      (fmap 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++newOrData :: DataDecl -> String+newOrData decl = if isNewtype decl then "newtype" else "data"++isGADT :: DataDecl -> Bool+isGADT = any isGADTCons . dd_cons . dataDefn   where-    n1 = processName firstLinePrefix (extractField f)-    ns = fs >>= processName (indent fieldIndent ", ") . extractField+    isGADTCons = \case+      L _ (ConDeclGADT {}) -> True+      _ -> False -    -- Set @fieldIndent@ such that @,@ is aligned with @{@.-    (firstLine, firstLinePrefix, fieldIndent) =-      case cFirstField of-        SameLine ->-          ( Nothing-          , init <> H.prettyPrint dname <> " { "-          , length init + length (H.prettyPrint dname) + 1-          )-        Indent n ->-          ( Just [init <> H.prettyPrint dname]-          , indent (length init + n) "{ "-          , length init + n-          )+isNewtype :: DataDecl -> Bool+isNewtype = (== NewType) . dd_ND . dataDefn -    processName prefix (fnames, _type, lineComment, commentBelowLine) =-      [prefix <> intercalate ", " (fmap H.prettyPrint fnames) <> " :: " <> H.prettyPrint _type <> addLineComment lineComment-      ] ++ addCommentBelow commentBelowLine+isInfix :: DataDecl -> Bool+isInfix = (== Infix) . dataFixity -    addLineComment (Just (Comment _ _ c)) = " --" <> c-    addLineComment Nothing                = ""+isEnum :: DataDecl -> Bool+isEnum = all isUnary . dd_cons . dataDefn+  where+    isUnary = \case+      L _ (ConDeclH98 {..}) -> case con_args of+        PrefixCon [] -> True+        _ -> False+      _ -> False -    -- Field comment indent is measured from the column with @{@, hence adding of @fieldIndent@ here.-    addCommentBelow Nothing                = []-    addCommentBelow (Just (Comment _ _ c)) = [indent (fieldIndent + cFieldComment) "--" <> c]+hasConstructors :: DataDecl -> Bool+hasConstructors = not . null . dd_cons . dataDefn -    extractField (H.FieldDecl lb names _type) =-      (names, _type, findCommentOnLine lb allComments, findCommentBelowLine lb allComments)+singleConstructor :: DataDecl -> Bool+singleConstructor = (== 1) . length . dd_cons . dataDefn -processConstructor _ init _ decl = [init <> trimLeft (H.prettyPrint decl)]+hasDeriving :: DataDecl -> Bool+hasDeriving = not . null . unLocated . dd_derivs . dataDefn

@@ -1,61 +1,76 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards   #-}---------------------------------------------------------------------------------+{-# LANGUAGE BlockArguments  #-}+{-# LANGUAGE DoAndIfThenElse #-}+{-# LANGUAGE LambdaCase      #-}+{-# LANGUAGE RecordWildCards #-} module Language.Haskell.Stylish.Step.Imports-    ( Options (..)-    , defaultOptions-    , ImportAlign (..)-    , ListAlign (..)-    , LongListAlign (..)-    , EmptyListAlign (..)-    , ListPadding (..)-    , step-    ) where+  ( Options (..)+  , defaultOptions+  , ImportAlign (..)+  , ListAlign (..)+  , LongListAlign (..)+  , EmptyListAlign (..)+  , ListPadding (..)+  , step+  ) where +--------------------------------------------------------------------------------+import           Control.Monad                   (forM_, when, void)+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 qualified Data.List.NonEmpty              as NonEmpty+import qualified Data.Map                        as Map+import qualified Data.Set                        as Set + ---------------------------------------------------------------------------------import           Control.Arrow                   ((&&&))-import           Control.Monad                   (void)-import qualified Data.Aeson                      as A-import qualified Data.Aeson.Types                as A-import           Data.Char                       (toLower)-import           Data.List                       (intercalate, sortBy)-import qualified Data.Map                        as M-import           Data.Maybe                      (isJust, maybeToList)-import           Data.Ord                        (comparing)-import qualified Data.Set                        as S-import           Data.Semigroup                  (Semigroup ((<>)))-import qualified Language.Haskell.Exts           as H+import           BasicTypes                      (StringLiteral (..),+                                                  SourceText (..))+import qualified FastString                      as FS+import           GHC.Hs.Extension                (GhcPs)+import qualified GHC.Hs.Extension                as GHC+import           GHC.Hs.ImpExp+import           Module                          (moduleNameString)+import           RdrName                         (RdrName)+import           SrcLoc                          (Located, GenLocated(..), unLoc)   -------------------------------------------------------------------------------- import           Language.Haskell.Stylish.Block-import           Language.Haskell.Stylish.Editor+import           Language.Haskell.Stylish.Module+import           Language.Haskell.Stylish.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+    { importAlign     :: ImportAlign+    , listAlign       :: ListAlign+    , padModuleNames  :: Bool+    , longListAlign   :: LongListAlign+    , emptyListAlign  :: EmptyListAlign+    , listPadding     :: ListPadding+    , separateLists   :: Bool+    , spaceSurround   :: Bool     } deriving (Eq, Show)  defaultOptions :: Options defaultOptions = Options-    { importAlign    = Global-    , listAlign      = AfterAlias-    , padModuleNames = True-    , longListAlign  = Inline-    , emptyListAlign = Inherit-    , listPadding    = LPConstant 4-    , separateLists  = True-    , spaceSurround  = False+    { importAlign     = Global+    , listAlign       = AfterAlias+    , padModuleNames  = True+    , longListAlign   = Inline+    , emptyListAlign  = Inherit+    , listPadding     = LPConstant 4+    , separateLists   = True+    , spaceSurround   = False     }  data ListPadding@@ -75,6 +90,7 @@     | WithModuleName     | WithAlias     | AfterAlias+    | Repeat     deriving (Eq, Show)  data EmptyListAlign@@ -83,375 +99,382 @@     deriving (Eq, Show)  data LongListAlign-    = Inline-    | InlineWithBreak-    | InlineToMultiline-    | Multiline+    = Inline -- inline+    | InlineWithBreak -- new_line+    | InlineToMultiline -- new_line_multiline+    | Multiline -- multiline     deriving (Eq, Show)   --------------------------------------------------------------------------------+step :: Maybe Int -> Options -> Step+step columns = makeStep "Imports (ghc-lib-parser)" . printImports columns -modifyImportSpecs :: ([H.ImportSpec l] -> [H.ImportSpec l])-                  -> H.ImportDecl l -> H.ImportDecl l-modifyImportSpecs f imp = imp {H.importSpecs = f' <$> H.importSpecs imp}++--------------------------------------------------------------------------------+printImports :: Maybe Int -> Options -> Lines -> Module -> Lines+printImports maxCols align ls m = applyChanges changes ls   where-    f' (H.ImportSpecList l h specs) = H.ImportSpecList l h (f specs)+    groups = moduleImportGroups m+    moduleStats = foldMap importStats . fmap unLoc $ concatMap toList groups+    changes = do+        group <- groups+        pure $ formatGroup maxCols align m moduleStats group +formatGroup+    :: Maybe Int -> Options -> Module -> ImportStats+    -> NonEmpty (Located Import) -> Change String+formatGroup maxCols options m moduleStats imports =+    let newLines = formatImports maxCols options m moduleStats imports in+    change (importBlock imports) (const newLines) ----------------------------------------------------------------------------------imports :: H.Module l -> [H.ImportDecl l]-imports (H.Module _ _ _ is _) = is-imports _                     = []+importBlock :: NonEmpty (Located a) -> Block String+importBlock group = Block+    (getStartLineUnsafe $ NonEmpty.head group)+    (getEndLineUnsafe   $ NonEmpty.last group) +formatImports+    :: Maybe Int    -- ^ Max columns.+    -> Options      -- ^ Options.+    -> Module       -- ^ Module.+    -> ImportStats  -- ^ Module stats.+    -> NonEmpty (Located Import) -> Lines+formatImports maxCols options m moduleStats rawGroup =+  runPrinter_ (PrinterConfig maxCols) [] m do+  let +     +    group+      = NonEmpty.sortWith unLocated rawGroup+      & mergeImports ----------------------------------------------------------------------------------importName :: H.ImportDecl l -> String-importName i = let (H.ModuleName _ n) = H.importModule i in n+    unLocatedGroup = fmap unLocated $ toList group -importPackage :: H.ImportDecl l -> Maybe String-importPackage i = H.importPkg i+    align' = importAlign options+    padModuleNames' = padModuleNames options+    padNames = align' /= None && padModuleNames' +    stats = case align' of+        Global -> moduleStats {isAnyQualified = True}+        File   -> moduleStats+        Group  -> foldMap importStats unLocatedGroup+        None   -> mempty +  forM_ group \imp -> printQualified options padNames stats imp >> newline+ ----------------------------------------------------------------------------------- | A "compound import name" is import's name and package (if present). For--- instance, if you have an import @Foo.Bar@ from package @foobar@, the full--- name will be @"foobar" Foo.Bar@.-compoundImportName :: H.ImportDecl l -> String-compoundImportName i =-  case importPackage i of-    Nothing  -> importName i-    Just pkg -> show pkg ++ " " ++ importName i+printQualified :: Options -> Bool -> ImportStats -> Located Import -> P ()+printQualified Options{..} padNames stats (L _ decl) = do+  let decl' = rawImport decl +  putText "import" >> space ----------------------------------------------------------------------------------longestImport :: [H.ImportDecl l] -> Int-longestImport = maximum . map (length . compoundImportName)+  case (isSource decl, isAnySource stats) of+    (True, _) -> putText "{-# SOURCE #-}" >> space+    (_, True) -> putText "              " >> space+    _         -> pure () +  when (isSafe decl) (putText "safe" >> space) ------------------------------------------------------------------------------------ | Compare imports for ordering-compareImports :: H.ImportDecl l -> H.ImportDecl l -> Ordering-compareImports =-  comparing (map toLower . importName &&&-             fmap (map toLower) . importPackage &&&-             H.importQualified)+  case (isQualified decl, isAnyQualified stats) of+    (True, _) -> putText "qualified" >> space+    (_, True) -> putText "         " >> space+    _         -> pure () +  moduleNamePosition <- length <$> getCurrentLine+  forM_ (ideclPkgQual decl') $ \pkg -> putText (stringLiteral pkg) >> space+  putText (moduleName decl) ------------------------------------------------------------------------------------ | Remove (or merge) duplicated import specs.------ * When something is mentioned twice, it's removed: @A, A@ -> A--- * More general forms take priority: @A, A(..)@ -> @A(..)@--- * Sometimes we have to combine imports: @A(x), A(y)@ -> @A(x, y)@------ Import specs are always sorted by subsequent steps so we don't have to care--- about preserving order.-deduplicateImportSpecs :: Ord l => H.ImportDecl l -> H.ImportDecl l-deduplicateImportSpecs =-  modifyImportSpecs $-    map recomposeImportSpec .-    M.toList . M.fromListWith (<>) .-    map decomposeImportSpec+  -- Only print spaces if something follows.+  when padNames $+    when (isJust (ideclAs decl') || isHiding decl ||+            not (null $ ideclHiding decl')) $+      putText $+        replicate (isLongestImport stats - importModuleNameLength decl) ' ' --- | What we are importing (variable, class, etc)-data ImportEntity l-  -- | A variable-  = ImportVar l (H.Name l)-  -- | Something that can be imported partially-  | ImportClassOrData l (H.Name l)-  -- | Something else ('H.IAbs')-  | ImportOther l (H.Namespace l) (H.Name l)-  deriving (Eq, Ord)+  beforeAliasPosition <- length <$> getCurrentLine+  forM_ (ideclAs decl') \(L _ name) ->+    space >> putText "as" >> space >> putText (moduleNameString name)+  afterAliasPosition <- length <$> getCurrentLine --- | What we are importing from an 'ImportClassOrData'-data ImportPortion l-  = ImportSome [H.CName l]  -- ^ @A(x, y, z)@-  | ImportAll               -- ^ @A(..)@+  when (isHiding decl) (space >> putText "hiding") -instance Ord l => Semigroup (ImportPortion l) where-  ImportSome a <> ImportSome b = ImportSome (setUnion a b)-  _ <> _                       = ImportAll+  let putOffset = putText $ replicate offset ' '+      offset = case listPadding of+        LPConstant n -> n+        LPModuleName -> moduleNamePosition -instance Ord l => Monoid (ImportPortion l) where-  mempty = ImportSome []-  mappend = (<>)+  case snd <$> ideclHiding decl' of+    Nothing            -> pure ()+    Just (L _ [])      -> case emptyListAlign of+      RightAfter -> modifyCurrentLine trimRight >> space >> putText "()"+      Inherit -> case listAlign of+        NewLine ->+          modifyCurrentLine trimRight >> newline >> putOffset >> putText "()"+        _ -> space >> putText "()"+    Just (L _ imports) -> do+      let printedImports = flagEnds $ -- [P ()]+            fmap ((printImport Options{..}) . unLocated)+            (prepareImportList imports) --- | O(n log n) union.-setUnion :: Ord a => [a] -> [a] -> [a]-setUnion a b = S.toList (S.fromList a `S.union` S.fromList b)+      -- 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 ' ' -decomposeImportSpec :: H.ImportSpec l -> (ImportEntity l, ImportPortion l)-decomposeImportSpec x = case x of-  -- I checked and it looks like namespace's 'l' is always equal to x's 'l'-  H.IAbs l space n -> case space of-    H.NoNamespace      _ -> (ImportClassOrData l n, ImportSome [])-    H.TypeNamespace    _ -> (ImportOther l space n, ImportSome [])-    H.PatternNamespace _ -> (ImportOther l space n, ImportSome [])-  H.IVar l n             -> (ImportVar l n, ImportSome [])-  H.IThingAll l n        -> (ImportClassOrData l n, ImportAll)-  H.IThingWith l n names -> (ImportClassOrData l n, ImportSome names)+      let -- Helper+          doSpaceSurround = when spaceSurround space -recomposeImportSpec :: (ImportEntity l, ImportPortion l) -> H.ImportSpec l-recomposeImportSpec (e, p) = case e of-  ImportClassOrData l n -> case p of-    ImportSome []    -> H.IAbs l (H.NoNamespace l) n-    ImportSome names -> H.IThingWith l n names-    ImportAll        -> H.IThingAll l n-  ImportVar l n         -> H.IVar l n-  ImportOther l space n -> H.IAbs l space n+          -- Try to put everything on one line.+          printAsSingleLine = forM_ printedImports $ \(imp, start, end) -> do+            when start $ putText "(" >> doSpaceSurround+            imp+            if end then doSpaceSurround >> putText ")" else comma >> space +          -- Try to put everything one by one, wrapping if that fails.+          printAsInlineWrapping wprefix = forM_ printedImports $+            \(imp, start, end) ->+            patchForRepeatHiding $ wrapping+              (do+                if start then putText "(" >> doSpaceSurround else space+                imp+                if end then doSpaceSurround >> putText ")" else comma)+              (do+                case listAlign of+                    -- In 'Repeat' mode, end lines with ')' rather than ','.+                    Repeat | not start -> modifyCurrentLine . withLast $+                        \c -> if c == ',' then ')' else c+                    _ | start && spaceSurround ->+                        -- Only necessary if spaceSurround is enabled.+                        modifyCurrentLine trimRight+                    _ -> pure ()+                newline+                void wprefix+                case listAlign of+                  -- '(' already included in repeat+                  Repeat         -> pure ()+                  -- Print the much needed '('+                  _ | start      -> putText "(" >> doSpaceSurround+                  -- Don't bother aligning if we're not in inline mode.+                  _ | longListAlign /= Inline -> pure ()+                  -- 'Inline + AfterAlias' is really where we want to be careful+                  -- with spacing.+                  AfterAlias -> space >> doSpaceSurround+                  WithModuleName -> pure ()+                  WithAlias -> pure ()+                  NewLine -> pure ()+                imp+                if end then doSpaceSurround >> putText ")" else comma) ------------------------------------------------------------------------------------ | The implementation is a bit hacky to get proper sorting for input specs:--- constructors first, followed by functions, and then operators.-compareImportSpecs :: H.ImportSpec l -> H.ImportSpec l -> Ordering-compareImportSpecs = comparing key+          -- Put everything on a separate line.  'spaceSurround' can be+          -- ignored.+          printAsMultiLine = forM_ printedImports $ \(imp, start, end) -> do+            when start $ modifyCurrentLine trimRight  -- We added some spaces.+            newline+            putOffset+            if start then putText "( " else putText ", "+            imp+            when end $ newline >> putOffset >> putText ")"++      case longListAlign of+        Multiline -> wrapping+          (space >> printAsSingleLine)+          printAsMultiLine+        Inline | NewLine <- listAlign -> do+          modifyCurrentLine trimRight+          newline >> putOffset >> printAsInlineWrapping (putText wrapPrefix)+        Inline -> space >> printAsInlineWrapping (putText wrapPrefix)+        InlineWithBreak -> wrapping+          (space >> printAsSingleLine)+          (do+            modifyCurrentLine trimRight+            newline >> putOffset >> printAsInlineWrapping putOffset)+        InlineToMultiline -> wrapping+          (space >> printAsSingleLine)+          (wrapping+            (do+              modifyCurrentLine trimRight+              newline >> putOffset >> printAsSingleLine)+            printAsMultiLine)   where-    key :: H.ImportSpec l -> (Int, Bool, String)-    key (H.IVar _ x)         = (1, isOperator x, nameToString x)-    key (H.IAbs _ _ x)       = (0, False, nameToString x)-    key (H.IThingAll _ x)    = (0, False, nameToString x)-    key (H.IThingWith _ x _) = (0, False, nameToString x)+    -- We cannot wrap/repeat 'hiding' imports since then we would get multiple+    -- imports hiding different things.+    patchForRepeatHiding = case listAlign of+        Repeat | isHiding decl -> withColumns Nothing+        _                      -> id   ----------------------------------------------------------------------------------- | Sort the input spec list inside an 'H.ImportDecl'-sortImportSpecs :: H.ImportDecl l -> H.ImportDecl l-sortImportSpecs = modifyImportSpecs (sortBy compareImportSpecs)-+printImport :: Options -> IE GhcPs -> P ()+printImport Options{..} (IEVar _ name) = do+    printIeWrappedName name+printImport _ (IEThingAbs _ name) = do+    printIeWrappedName name+printImport _ (IEThingAll _ name) = do+    printIeWrappedName name+    space+    putText "(..)"+printImport _ (IEModuleContents _ (L _ m)) = do+    putText (moduleNameString m)+printImport Options{..} (IEThingWith _ name _wildcard imps _) = do+    printIeWrappedName name+    when separateLists space+    parenthesize $+      sep (comma >> space) (printIeWrappedName <$> imps)+printImport _ (IEGroup _ _ _ ) =+    error "Language.Haskell.Stylish.Printer.Imports.printImportExport: unhandled case 'IEGroup'"+printImport _ (IEDoc _ _) =+    error "Language.Haskell.Stylish.Printer.Imports.printImportExport: unhandled case 'IEDoc'"+printImport _ (IEDocNamed _ _) =+    error "Language.Haskell.Stylish.Printer.Imports.printImportExport: unhandled case 'IEDocNamed'"+printImport _ (XIE ext) =+    GHC.noExtCon ext  ----------------------------------------------------------------------------------- | Order of imports in sublist is:--- Constructors, accessors/methods, operators.-compareImportSubSpecs :: H.CName l -> H.CName l -> Ordering-compareImportSubSpecs = comparing key-  where-    key :: H.CName l -> (Int, Bool, String)-    key (H.ConName _ x) = (0, False,        nameToString x)-    key (H.VarName _ x) = (1, isOperator x, nameToString x)-+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 ------------------------------------------------------------------------------------ | By default, haskell-src-exts pretty-prints------ > import Foo (Bar(..))------ but we want------ > import Foo (Bar (..))------ instead.-prettyImportSpec :: (Ord l) => Bool -> H.ImportSpec l -> String-prettyImportSpec separate = prettyImportSpec'+mergeImports :: NonEmpty (Located Import) -> NonEmpty (Located Import)+mergeImports (x :| []) = x :| []+mergeImports (h :| (t : ts))+  | canMergeImport (unLocated h) (unLocated t) = mergeImports (mergeModuleImport h t :| ts)+  | otherwise = h :| mergeImportsTail (t : ts)   where-    prettyImportSpec' (H.IThingAll  _ n)     = H.prettyPrint n ++ sep "(..)"-    prettyImportSpec' (H.IThingWith _ n cns) = H.prettyPrint n-        ++ sep "("-        ++ intercalate ", "-          (map H.prettyPrint $ sortBy compareImportSubSpecs cns)-        ++ ")"-    prettyImportSpec' x                      = H.prettyPrint x+    mergeImportsTail (x : y : ys)+      | canMergeImport (unLocated x) (unLocated y) = mergeImportsTail ((mergeModuleImport x y) : ys)+      | otherwise = x : mergeImportsTail (y : ys)+    mergeImportsTail xs = xs -    sep = if separate then (' ' :) else id+moduleName :: Import -> String+moduleName+  = moduleNameString+  . unLocated+  . ideclName+  . rawImport   ---------------------------------------------------------------------------------prettyImport :: (Ord l, Show l) =>-    Maybe Int -> Options -> Bool -> Bool -> Int -> H.ImportDecl l -> [String]-prettyImport columns Options{..} padQualified padName longest imp-    | (void `fmap` H.importSpecs imp) == emptyImportSpec = emptyWrap-    | otherwise = case longListAlign of-        Inline            -> inlineWrap-        InlineWithBreak   -> longListWrapper inlineWrap inlineWithBreakWrap-        InlineToMultiline -> longListWrapper inlineWrap inlineToMultilineWrap-        Multiline         -> longListWrapper inlineWrap multilineWrap-  where-    emptyImportSpec = Just (H.ImportSpecList () False [])-    -- "import" + space + qualifiedLength has space in it.-    listPadding' = listPaddingValue (6 + 1 + qualifiedLength) listPadding-      where-        qualifiedLength =-            if null qualified then 0 else 1 + sum (map length qualified)+data ImportStats = ImportStats+    { isLongestImport :: !Int+    , isAnySource     :: !Bool+    , isAnyQualified  :: !Bool+    , isAnySafe       :: !Bool+    } -    longListWrapper shortWrap longWrap-        | listAlign == NewLine-        || length shortWrap > 1-        || exceedsColumns (length (head shortWrap))-            = longWrap-        | otherwise = shortWrap+instance Semigroup ImportStats where+    l <> r = ImportStats+        { isLongestImport = isLongestImport l `max` isLongestImport r+        , isAnySource     = isAnySource     l ||    isAnySource     r+        , isAnyQualified  = isAnyQualified  l ||    isAnyQualified  r+        , isAnySafe       = isAnySafe       l ||    isAnySafe       r+        } -    emptyWrap = case emptyListAlign of-        Inherit    -> inlineWrap-        RightAfter -> [paddedNoSpecBase ++ " ()"]+instance Monoid ImportStats where+    mappend = (<>)+    mempty  = ImportStats 0 False False False -    inlineWrap = inlineWrapper-        $ mapSpecs-        $ withInit (++ ",")-        . withHead (("(" ++ maybeSpace) ++)-        . withLast (++ (maybeSpace ++ ")"))+importStats :: Import -> ImportStats+importStats i =+    ImportStats (importModuleNameLength i) (isSource i) (isQualified i) (isSafe i) -    inlineWrapper = case listAlign of-        NewLine        -> (paddedNoSpecBase :) . wrapRestMaybe columns listPadding'-        WithModuleName -> wrapMaybe columns paddedBase (withModuleNameBaseLength + 4)-        WithAlias      -> wrapMaybe columns paddedBase (inlineBaseLength + 1)-        -- Add 1 extra space to ensure same padding as in original code.-        AfterAlias     -> withTail ((' ' : maybeSpace) ++)-            . wrapMaybe columns paddedBase (afterAliasBaseLength + 1)+-- Computes length till module name, includes package name.+-- TODO: this should reuse code with the printer+importModuleNameLength :: Import -> Int+importModuleNameLength imp =+    (case ideclPkgQual (rawImport imp) of+        Nothing -> 0+        Just sl -> 1 + length (stringLiteral sl)) ++    (length $ moduleName imp) -    inlineWithBreakWrap = paddedNoSpecBase : wrapRestMaybe columns listPadding'-        ( mapSpecs-        $ withInit (++ ",")-        . withHead (("(" ++ maybeSpace) ++)-        . withLast (++ (maybeSpace ++ ")"))) -    inlineToMultilineWrap-        | length inlineWithBreakWrap > 2-        || any (exceedsColumns . length) (tail inlineWithBreakWrap)-            = multilineWrap-        | otherwise = inlineWithBreakWrap--    -- 'wrapRest 0' ensures that every item of spec list is on new line.-    multilineWrap = paddedNoSpecBase : wrapRest 0 listPadding'-        ( mapSpecs-          ( withHead ("( " ++)-          . withTail (", " ++))-        ++ closer)-      where-        closer = if null importSpecs-            then []-            else [")"]--    paddedBase = base $ padImport $ compoundImportName imp--    paddedNoSpecBase = base $ padImportNoSpec $ compoundImportName imp--    padImport = if hasExtras && padName-        then padRight longest-        else id--    padImportNoSpec = if (isJust (H.importAs imp) || hasHiding) && padName-        then padRight longest-        else id--    base' baseName importAs hasHiding' = unwords $ concat $-        [ ["import"]-        , source-        , safe-        , qualified-        , [baseName]-        , importAs-        , hasHiding'-        ]--    base baseName = base' baseName-        ["as " ++ as | H.ModuleName _ as <- maybeToList $ H.importAs imp]-        ["hiding" | hasHiding]--    inlineBaseLength = length $-                       base' (padImport $ compoundImportName imp) [] []--    withModuleNameBaseLength = length $ base' "" [] []--    afterAliasBaseLength = length $ base' (padImport $ compoundImportName imp)-        ["as " ++ as | H.ModuleName _ as <- maybeToList $ H.importAs imp] []--    (hasHiding, importSpecs) = case H.importSpecs imp of-        Just (H.ImportSpecList _ h l) -> (h, Just l)-        _                             -> (False, Nothing)--    hasExtras = isJust (H.importAs imp) || isJust (H.importSpecs imp)--    qualified-        | H.importQualified imp = ["qualified"]-        | padQualified          =-              if H.importSrc imp-                  then []-                  else if H.importSafe imp-                           then ["    "]-                           else ["         "]-        | otherwise             = []--    safe-        | H.importSafe imp = ["safe"]-        | otherwise        = []--    source-        | H.importSrc imp = ["{-# SOURCE #-}"]-        | otherwise       = []--    mapSpecs f = case importSpecs of-        Nothing -> []     -- Import everything-        Just [] -> ["()"] -- Instance only imports-        Just is -> f $ map (prettyImportSpec separateLists) is--    maybeSpace = case spaceSurround of-        True  -> " "-        False -> ""--    exceedsColumns i = case columns of-        Nothing -> False  -- No number exceeds a maximum column count of-                          -- Nothing, because there is no limit to exceed.-        Just c -> i > c+--------------------------------------------------------------------------------+stringLiteral :: StringLiteral -> String+stringLiteral sl = case sl_st sl of+    NoSourceText -> FS.unpackFS $ sl_fs sl+    SourceText s -> s   ---------------------------------------------------------------------------------prettyImportGroup :: Maybe Int -> Options -> Bool -> Int-                  -> [H.ImportDecl LineBlock]-                  -> Lines-prettyImportGroup columns align fileAlign longest imps =-    concatMap (prettyImport columns align padQual padName longest') $-    sortBy compareImports imps-  where-    align' = importAlign align-    padModuleNames' = padModuleNames align--    longest' = case align' of-        Group -> longestImport imps-        _     -> longest+isQualified :: Import -> Bool+isQualified+  = (/=) NotQualified+  . ideclQualified+  . rawImport -    padName = align' /= None && padModuleNames'+isHiding :: Import -> Bool+isHiding+  = maybe False fst+  . ideclHiding+  . rawImport -    padQual = case align' of-        Global -> True-        File   -> fileAlign-        Group  -> any H.importQualified imps-        None   -> False+isSource :: Import -> Bool+isSource+  = ideclSource+  . rawImport +isSafe :: Import -> Bool+isSafe+  = ideclSafe+  . rawImport  ---------------------------------------------------------------------------------step :: Maybe Int -> Options -> Step-step columns = makeStep "Imports" . step' columns+-- | Cleans up an import item list.+--+-- * Sorts import items.+-- * Sort inner import lists, e.g. `import Control.Monad (Monad (return, join))`+-- * Removes duplicates from import lists.+prepareImportList :: [LIE GhcPs] -> [LIE GhcPs]+prepareImportList =+  sortBy compareLIE . map (fmap prepareInner) .+  concatMap (toList . snd) . Map.toAscList . mergeByName+ where+  mergeByName :: [LIE GhcPs] -> Map.Map RdrName (NonEmpty (LIE GhcPs))+  mergeByName imports0 = Map.fromListWith+    -- Note that ideally every NonEmpty will just have a single entry and we+    -- will be able to merge everything into that entry.  Exotic imports can+    -- mess this up, though.  So they end up in the tail of the list.+    (\(x :| xs) (y :| ys) -> case ieMerge (unLocated x) (unLocated y) of+      Just z -> (x $> z) :| (xs ++ ys)  -- Keep source from `x`+      Nothing -> x :| (xs ++ y : ys))+    [(ieName $ unLocated imp, imp :| []) | imp <- imports0] +  prepareInner :: IE GhcPs -> IE GhcPs+  prepareInner = \case+    -- Simplify `A ()` to `A`.+    IEThingWith x n NoIEWildcard [] [] -> IEThingAbs x n+    IEThingWith x n w ns fs ->+      IEThingWith x n w (sortBy (compareWrappedName `on` unLoc) ns) fs+    ie -> ie ----------------------------------------------------------------------------------step' :: Maybe Int -> Options -> Lines -> Module -> Lines-step' columns align ls (module', _) = applyChanges-    [ change block $ const $-        prettyImportGroup columns align fileAlign longest importGroup-    | (block, importGroup) <- groups-    ]-    ls-  where-    imps    = map (sortImportSpecs . deduplicateImportSpecs) $-              imports $ fmap linesFromSrcSpan module'-    longest = longestImport imps-    groups  = groupAdjacent [(H.ann i, i) | i <- imps]+  -- Merge two import items, assuming they have the same name.+  ieMerge :: IE GhcPs -> IE GhcPs -> Maybe (IE GhcPs)+  ieMerge l@(IEVar _ _)      _                  = Just l+  ieMerge _                  r@(IEVar _ _)      = Just r+  ieMerge (IEThingAbs _ _)   r                  = Just r+  ieMerge l                  (IEThingAbs _ _)   = Just l+  ieMerge l@(IEThingAll _ _) _                  = Just l+  ieMerge _                  r@(IEThingAll _ _) = Just r+  ieMerge (IEThingWith x0 n0 w0 ns0 []) (IEThingWith _ _ w1 ns1 [])+    | w0 /= w1  = Nothing+    | otherwise = Just $+        -- TODO: sort the `ns0 ++ ns1`?+        IEThingWith x0 n0 w0 (nubOn (unwrapName . unLoc) $ ns0 ++ ns1) []+  ieMerge _ _ = Nothing -    fileAlign = case importAlign align of-        File -> any H.importQualified imps-        _    -> False  ---------------------------------------------------------------------------------listPaddingValue :: Int -> ListPadding -> Int-listPaddingValue _ (LPConstant n) = n-listPaddingValue n LPModuleName   = n------------------------------------------------------------------------------------instance A.FromJSON ListPadding where-    parseJSON (A.String "module_name") = return LPModuleName-    parseJSON (A.Number n) | n' >= 1   = return $ LPConstant n'-      where-        n' = truncate n-    parseJSON v                        = A.typeMismatch "'module_name' or >=1 number" v+nubOn :: Ord k => (a -> k) -> [a] -> [a]+nubOn f = go Set.empty+ where+  go _   []              = []+  go acc (x : xs)+    | y `Set.member` acc = go acc xs+    | otherwise          = x : go (Set.insert y acc) xs+   where+    y = f x

@@ -1,4 +1,7 @@ --------------------------------------------------------------------------------+{-# LANGUAGE BlockArguments    #-}+{-# LANGUAGE LambdaCase        #-}+{-# LANGUAGE OverloadedStrings #-} module Language.Haskell.Stylish.Step.LanguagePragmas     ( Style (..)     , step@@ -8,13 +11,23 @@   --------------------------------------------------------------------------------+import           Data.List.NonEmpty              (NonEmpty, fromList, toList) import qualified Data.Set                        as S-import qualified Language.Haskell.Exts           as H+import           Data.Text                       (Text)+import qualified Data.Text                       as T   --------------------------------------------------------------------------------+import qualified GHC.Hs                          as Hs+import           SrcLoc                          (RealSrcSpan, realSrcSpanStart,+                                                  srcLocLine, srcSpanEndLine,+                                                  srcSpanStartLine)+++-------------------------------------------------------------------------------- import           Language.Haskell.Stylish.Block import           Language.Haskell.Stylish.Editor+import           Language.Haskell.Stylish.Module import           Language.Haskell.Stylish.Step import           Language.Haskell.Stylish.Util @@ -28,19 +41,6 @@   ---------------------------------------------------------------------------------pragmas :: H.Module l -> [(l, [String])]-pragmas (H.Module _ _ ps _ _) =-    [(l, map nameToString names) | H.LanguagePragma l names <- ps]-pragmas _                     = []-------------------------------------------------------------------------------------- | The start of the first block-firstLocation :: [(Block a, [String])] -> Int-firstLocation = minimum . map (blockStart . fst)----------------------------------------------------------------------------------- verticalPragmas :: String -> Int -> Bool -> [String] -> Lines verticalPragmas lg longest align pragmas' =     [ "{-# " ++ lg ++ " " ++ pad pragma ++ " #-}"@@ -91,10 +91,10 @@ -------------------------------------------------------------------------------- -- | Filter redundant (and duplicate) pragmas out of the groups. As a side -- effect, we also sort the pragmas in their group...-filterRedundant :: (String -> Bool)-                -> [(l, [String])]-                -> [(l, [String])]-filterRedundant isRedundant' = snd . foldr filterRedundant' (S.empty, [])+filterRedundant :: (Text -> Bool)+                -> [(l, NonEmpty Text)]+                -> [(l, [Text])]+filterRedundant isRedundant' = snd . foldr filterRedundant' (S.empty, []) . fmap (fmap toList)   where     filterRedundant' (l, xs) (known, zs)         | S.null xs' = (known', zs)@@ -111,38 +111,54 @@  -------------------------------------------------------------------------------- step' :: Maybe Int -> Style -> Bool -> Bool -> String -> Lines -> Module -> Lines-step' columns style align removeRedundant lngPrefix ls (module', _)-    | null pragmas' = ls-    | otherwise     = applyChanges changes ls+step' columns style align removeRedundant lngPrefix ls m+  | null languagePragmas = ls+  | otherwise = applyChanges changes ls   where     isRedundant'-        | removeRedundant = isRedundant module'+        | removeRedundant = isRedundant m         | otherwise       = const False-    pragmas' = pragmas $ fmap linesFromSrcSpan module'-    longest  = maximum $ map length $ snd =<< pragmas'-    groups   = [(b, concat pgs) | (b, pgs) <- groupAdjacent pragmas']-    changes  =-        [ change b (const $ prettyPragmas lngPrefix columns longest align style pg)-        | (b, pg) <- filterRedundant isRedundant' groups-        ] +    languagePragmas = moduleLanguagePragmas m +    convertFstToBlock :: [(RealSrcSpan, a)] -> [(Block String, a)]+    convertFstToBlock = fmap \(rspan, a) ->+      (Block (srcSpanStartLine rspan) (srcSpanEndLine rspan), a)++    groupAdjacent' =+      fmap turnSndBackToNel . groupAdjacent . fmap (fmap toList)+      where+        turnSndBackToNel (a, bss) = (a, fromList . concat $ bss)++    longest :: Int+    longest  = maximum $ map T.length $ toList . snd =<< languagePragmas++    groups :: [(Block String, NonEmpty Text)]+    groups = [(b, pgs) | (b, pgs) <- groupAdjacent' (convertFstToBlock languagePragmas)]++    changes =+      [ change b (const $ prettyPragmas lngPrefix columns longest align style (fmap T.unpack pg))+      | (b, pg) <- filterRedundant isRedundant' groups+      ]+ -------------------------------------------------------------------------------- -- | Add a LANGUAGE pragma to a module if it is not present already.-addLanguagePragma :: String -> String -> H.Module H.SrcSpanInfo -> [Change String]+addLanguagePragma :: String -> String -> Module -> [Change String] addLanguagePragma lg prag modu     | prag `elem` present = []     | otherwise           = [insert line ["{-# " ++ lg ++ " " ++ prag ++ " #-}"]]   where-    pragmas' = pragmas (fmap linesFromSrcSpan modu)-    present  = concatMap snd pragmas'-    line     = if null pragmas' then 1 else firstLocation pragmas'+    pragmas'      = moduleLanguagePragmas modu+    present       = concatMap ((fmap T.unpack) . toList . snd) pragmas'+    line          = if null pragmas' then 1 else firstLocation pragmas'+    firstLocation :: [(RealSrcSpan, NonEmpty Text)] -> Int+    firstLocation = minimum . fmap (srcLocLine . realSrcSpanStart . fst)   -------------------------------------------------------------------------------- -- | Check if a language pragma is redundant. We can't do this for all pragmas, -- but we do a best effort.-isRedundant :: H.Module H.SrcSpanInfo -> String -> Bool+isRedundant :: Module -> Text -> Bool isRedundant m "ViewPatterns" = isRedundantViewPatterns m isRedundant m "BangPatterns" = isRedundantBangPatterns m isRedundant _ _              = False@@ -150,13 +166,29 @@  -------------------------------------------------------------------------------- -- | Check if the ViewPatterns language pragma is redundant.-isRedundantViewPatterns :: H.Module H.SrcSpanInfo -> Bool-isRedundantViewPatterns m = null-    [() | H.PViewPat {} <- everything m :: [H.Pat H.SrcSpanInfo]]+isRedundantViewPatterns :: Module -> Bool+isRedundantViewPatterns = null . queryModule getViewPat+  where+    getViewPat :: Hs.Pat Hs.GhcPs -> [()]+    getViewPat = \case+      Hs.ViewPat{} -> [()]+      _            -> []   -------------------------------------------------------------------------------- -- | Check if the BangPatterns language pragma is redundant.-isRedundantBangPatterns :: H.Module H.SrcSpanInfo -> Bool-isRedundantBangPatterns m = null-    [() | H.PBangPat _ _ <- everything m :: [H.Pat H.SrcSpanInfo]]+isRedundantBangPatterns :: Module -> Bool+isRedundantBangPatterns modul =+    (null $ queryModule getBangPat modul) &&+    (null $ queryModule getMatchStrict modul)+  where+    getBangPat :: Hs.Pat Hs.GhcPs -> [()]+    getBangPat = \case+      Hs.BangPat{} -> [()]+      _            -> []++    getMatchStrict :: Hs.Match Hs.GhcPs (Hs.LHsExpr Hs.GhcPs) -> [()]+    getMatchStrict (Hs.XMatch m) = Hs.noExtCon m+    getMatchStrict (Hs.Match _ ctx _ _) = case ctx of+      Hs.FunRhs _ _ Hs.SrcStrict -> [()]+      _                          -> []

@@ -0,0 +1,250 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE LambdaCase     #-}+module Language.Haskell.Stylish.Step.ModuleHeader+  ( Config (..)+  , defaultConfig+  , step+  ) where++--------------------------------------------------------------------------------+import           ApiAnnotation                    (AnnKeywordId (..),+                                                   AnnotationComment (..))+import           Control.Monad                    (forM_, join, when)+import           Data.Bifunctor                   (second)+import           Data.Foldable                    (find, toList)+import           Data.Function                    (on, (&))+import qualified Data.List                        as L+import           Data.List.NonEmpty               (NonEmpty (..))+import qualified Data.List.NonEmpty               as NonEmpty+import           Data.Maybe                       (isJust, listToMaybe)+import qualified GHC.Hs.Doc                       as GHC+import           GHC.Hs.Extension                 (GhcPs)+import qualified GHC.Hs.Extension                 as GHC+import           GHC.Hs.ImpExp                    (IE (..))+import qualified GHC.Hs.ImpExp                    as GHC+import qualified Module                           as GHC+import           SrcLoc                           (GenLocated (..), Located,+                                                   RealLocated, SrcSpan (..),+                                                   srcSpanEndLine,+                                                   srcSpanStartLine, unLoc)+import           Util                             (notNull)++--------------------------------------------------------------------------------+import           Language.Haskell.Stylish.Block+import           Language.Haskell.Stylish.Editor+import           Language.Haskell.Stylish.GHC+import           Language.Haskell.Stylish.Module+import           Language.Haskell.Stylish.Ordering+import           Language.Haskell.Stylish.Printer+import           Language.Haskell.Stylish.Step+++data Config = Config+    -- TODO(jaspervdj): Use the same sorting as in `Imports`?+    -- TODO: make sorting optional?+    { indent :: Int+    , sort   :: Bool+    }++defaultConfig :: Config+defaultConfig = Config+    { indent = 4+    , sort   = True+    }++step :: Config -> Step+step = makeStep "Module header" . printModuleHeader++printModuleHeader :: Config -> Lines -> Module -> Lines+printModuleHeader 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++    -- TODO: pass max columns?+    printedModuleHeader = runPrinter_ (PrinterConfig Nothing) relevantComments+        m (printHeader conf name exports haddocks)++    getBlock loc =+      Block <$> fmap getStartLineUnsafe loc <*> fmap getEndLineUnsafe loc++    adjustOffsetFrom :: Block a -> Block a -> Maybe (Block a)+    adjustOffsetFrom (Block s0 _) b2@(Block s1 e1)+      | s0 >= s1 && s0 >= e1 = Nothing+      | s0 >= s1 = Just (Block (s0 + 1) e1)+      | otherwise = Just b2++    nameBlock =+      getBlock name++    exportsBlock =+      join $ adjustOffsetFrom <$> nameBlock <*> getBlock exports++    whereM :: Maybe SrcSpan+    whereM+      = annotations+      & filter (\(((_, w), _)) -> w == AnnWhere)+      & fmap (head . snd) -- get position of annot+      & L.sort+      & listToMaybe++    isModuleHeaderWhere :: Block a -> Bool+    isModuleHeaderWhere w+      = not+      . overlapping+      $ [w] <> toList nameBlock <> toList exportsBlock++    toLineBlock :: SrcSpan -> Block a+    toLineBlock (RealSrcSpan s) = Block (srcSpanStartLine s) (srcSpanEndLine s)+    toLineBlock s+      = error+      $ "'where' block was not a RealSrcSpan" <> show s++    whereBlock+      = whereM+      & fmap toLineBlock+      & find isModuleHeaderWhere++    deletes =+      fmap delete $ mergeAdjacent $ toList nameBlock <> toList exportsBlock <> toList whereBlock++    startLine =+      maybe 1 blockStart nameBlock++    additions = [insert startLine printedModuleHeader]++    changes = deletes <> additions+  in+    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 loc name) -> do+    putText "module"+    space+    putText (showOutputable name)+    attachEolComment loc++  maybe+    (when (isJust mname) do newline >> spaces (indent conf) >> putText "where")+    (printExportList conf)+    mexps++attachEolComment :: SrcSpan -> P ()+attachEolComment = \case+  UnhelpfulSpan _ -> pure ()+  RealSrcSpan rspan ->+    removeLineComment (srcSpanStartLine rspan) >>= mapM_ \c -> space >> putComment c++attachEolCommentEnd :: SrcSpan -> P ()+attachEolCommentEnd = \case+  UnhelpfulSpan _ -> pure ()+  RealSrcSpan rspan ->+    removeLineComment (srcSpanEndLine rspan) >>= mapM_ \c -> space >> putComment c++printExportList :: Config -> Located [GHC.LIE GhcPs] -> P ()+printExportList conf (L srcLoc exports) = do+  newline+  doIndent >> putText "(" >> when (notNull exports) space++  exportsWithComments <- fmap (second doSort) <$> groupAttachedComments exports++  printExports exportsWithComments++  putText ")" >> space >> putText "where" >> attachEolCommentEnd srcLoc+  where+    -- 'doIndent' is @x@:+    --+    -- > module Foo+    -- > xxxx( foo+    -- > xxxx, bar+    -- > xxxx) where+    --+    -- 'doHang' is @y@:+    --+    -- > module Foo+    -- > xxxx( -- Some comment+    -- > xxxxyyfoo+    -- > xxxx) where+    doIndent = spaces (indent conf)+    doHang = do+        len <- length <$> getCurrentLine+        spaces $ indent conf + 2 - len++    doSort = if sort conf then NonEmpty.sortBy compareLIE else id++    printExports :: [([AnnotationComment], NonEmpty (GHC.LIE GhcPs))] -> P ()+    printExports (([], firstInGroup :| groupRest) : rest) = do+      printExport 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 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 export+        newline >> doIndent++    printExportsGroupTail :: [GHC.LIE GhcPs] -> P ()+    printExportsGroupTail (x : xs) = printExportsTail [([], x :| xs)]+    printExportsGroupTail []       = pure ()++    printExport :: GHC.LIE GhcPs -> P ()+    printExport (L _ export) = case export of+      IEVar _ name -> putOutputable name+      IEThingAbs _ name -> putOutputable name+      IEThingAll _ name -> do+        putOutputable name+        space+        putText "(..)"+      IEModuleContents _ (L _ m) -> do+        putText "module"+        space+        putText (showOutputable m)+      IEThingWith _ name _wildcard imps _ -> do+        putOutputable name+        space+        putText "("+        sep (comma >> space) $+          fmap putOutputable $ L.sortBy (compareWrappedName `on` unLoc) imps+        putText ")"+      IEGroup _ _ _ ->+        error $+          "Language.Haskell.Stylish.Printer.Imports.printImportExport: unhandled case 'IEGroup'" <> showOutputable export+      IEDoc _ _ ->+        error $+          "Language.Haskell.Stylish.Printer.Imports.printImportExport: unhandled case 'IEDoc'" <> showOutputable export+      IEDocNamed _ _ ->+        error $+          "Language.Haskell.Stylish.Printer.Imports.printImportExport: unhandled case 'IEDocNamed'" <> showOutputable export+      XIE ext ->+        GHC.noExtCon ext

@@ -1,4 +1,5 @@ --------------------------------------------------------------------------------+{-# LANGUAGE TypeFamilies #-} module Language.Haskell.Stylish.Step.SimpleAlign     ( Config (..)     , defaultConfig@@ -7,15 +8,17 @@   ---------------------------------------------------------------------------------import           Data.Data                       (Data)+import           Control.Monad                   (guard) import           Data.List                       (foldl')-import           Data.Maybe                      (maybeToList)-import qualified Language.Haskell.Exts           as H+import           Data.Maybe                      (fromMaybe)+import qualified GHC.Hs                          as Hs+import qualified SrcLoc                          as S   -------------------------------------------------------------------------------- import           Language.Haskell.Stylish.Align import           Language.Haskell.Stylish.Editor+import           Language.Haskell.Stylish.Module import           Language.Haskell.Stylish.Step import           Language.Haskell.Stylish.Util @@ -38,91 +41,111 @@   ---------------------------------------------------------------------------------cases :: Data l => H.Module l -> [[H.Alt l]]-cases modu = [alts | H.Case _ _ alts <- everything modu]+type Record = [S.Located (Hs.ConDeclField Hs.GhcPs)]   ----------------------------------------------------------------------------------- | For this to work well, we require a way to merge annotations.  This merge--- operation should follow the semigroup laws.-altToAlignable :: (l -> l -> l) -> H.Alt l -> Maybe (Alignable l)-altToAlignable _ (H.Alt _   _   _   (Just _)) = Nothing-altToAlignable _ (H.Alt ann pat rhs@(H.UnGuardedRhs _ _) Nothing) = Just $-    Alignable-        { aContainer = ann-        , aLeft      = H.ann pat-        , aRight     = H.ann rhs-        , aRightLead = length "-> "-        }-altToAlignable-        merge-        (H.Alt ann pat (H.GuardedRhss _ [H.GuardedRhs _ guards rhs]) Nothing) =-    -- We currently only support the case where an alternative has a single-    -- guarded RHS.  If there are more, we would need to return multiple-    -- `Alignable`s from this function, which would be a significant change.-    Just $ Alignable-        { aContainer = ann-        , aLeft      = foldl' merge (H.ann pat) (map H.ann guards)-        , aRight     = H.ann rhs-        , aRightLead = length "-> "-        }-altToAlignable _ _ = Nothing+records :: S.Located (Hs.HsModule Hs.GhcPs) -> [Record]+records modu = do+  let decls           = map S.unLoc (Hs.hsmodDecls (S.unLoc modu))+      tyClDecls       = [ tyClDecl | Hs.TyClD _ tyClDecl <- decls ]+      dataDecls       = [ d | d@(Hs.DataDecl _ _ _ _ _)  <- tyClDecls ]+      dataDefns       = map Hs.tcdDataDefn dataDecls+  d@Hs.ConDeclH98 {} <- concatMap getConDecls dataDefns+  case Hs.con_args d of+      Hs.RecCon rec -> [S.unLoc rec]+      _             -> []+ where+  getConDecls :: Hs.HsDataDefn Hs.GhcPs -> [Hs.ConDecl Hs.GhcPs]+  getConDecls d@Hs.HsDataDefn {} = map S.unLoc $ Hs.dd_cons d+  getConDecls (Hs.XHsDataDefn x) = Hs.noExtCon x   ---------------------------------------------------------------------------------tlpats :: Data l => H.Module l -> [[H.Match l]]-tlpats modu = [matches | H.FunBind _ matches <- everything modu]+recordToAlignable :: Record -> [Alignable S.RealSrcSpan]+recordToAlignable = fromMaybe [] . traverse fieldDeclToAlignable   ---------------------------------------------------------------------------------matchToAlignable :: H.Match l -> Maybe (Alignable l)-matchToAlignable (H.InfixMatch _ _ _ _ _ _)           = Nothing-matchToAlignable (H.Match _   _    []   _   _)        = Nothing-matchToAlignable (H.Match _   _    _    _   (Just _)) = Nothing-matchToAlignable (H.Match ann name pats rhs Nothing)  = Just $ Alignable-    { aContainer = ann-    , aLeft      = last (H.ann name : map H.ann pats)-    , aRight     = H.ann rhs-    , aRightLead = length "= "+fieldDeclToAlignable+    :: S.Located (Hs.ConDeclField Hs.GhcPs) -> Maybe (Alignable S.RealSrcSpan)+fieldDeclToAlignable (S.L _ (Hs.XConDeclField x)) = Hs.noExtCon x+fieldDeclToAlignable (S.L matchLoc (Hs.ConDeclField _ names ty _)) = do+  matchPos <- toRealSrcSpan matchLoc+  leftPos  <- toRealSrcSpan $ S.getLoc $ last names+  tyPos    <- toRealSrcSpan $ S.getLoc ty+  Just $ Alignable+    { aContainer = matchPos+    , aLeft      = leftPos+    , aRight     = tyPos+    , aRightLead = length ":: "     }   ---------------------------------------------------------------------------------records :: H.Module l -> [[H.FieldDecl l]]-records modu =-    [ fields-    | H.Module _ _ _ _ decls                     <- [modu]-    , H.DataDecl _ _ _ _ cons _                  <- decls-    , H.QualConDecl _ _ _ (H.RecDecl _ _ fields) <- cons-    ]+matchGroupToAlignable+    :: Config+    -> Hs.MatchGroup Hs.GhcPs (Hs.LHsExpr Hs.GhcPs)+    -> [Alignable S.RealSrcSpan]+matchGroupToAlignable _conf (Hs.XMatchGroup x) = Hs.noExtCon x+matchGroupToAlignable conf (Hs.MG _ alts _) =+  fromMaybe [] $ traverse (matchToAlignable conf) (S.unLoc alts)   ---------------------------------------------------------------------------------fieldDeclToAlignable :: H.FieldDecl a -> Maybe (Alignable a)-fieldDeclToAlignable (H.FieldDecl ann names ty) = Just $ Alignable-    { aContainer = ann-    , aLeft      = H.ann (last names)-    , aRight     = H.ann ty-    , aRightLead = length ":: "+matchToAlignable+    :: Config+    -> S.Located (Hs.Match Hs.GhcPs (Hs.LHsExpr Hs.GhcPs))+    -> Maybe (Alignable S.RealSrcSpan)+matchToAlignable conf (S.L matchLoc m@(Hs.Match _ Hs.CaseAlt pats@(_ : _) grhss)) = do+  let patsLocs   = map S.getLoc pats+      pat        = last patsLocs+      guards     = getGuards m+      guardsLocs = map S.getLoc guards+      left       = foldl' S.combineSrcSpans pat guardsLocs+  guard $ cCases conf+  body     <- rhsBody grhss+  matchPos <- toRealSrcSpan matchLoc+  leftPos  <- toRealSrcSpan left+  rightPos <- toRealSrcSpan $ S.getLoc body+  Just $ Alignable+    { aContainer = matchPos+    , aLeft      = leftPos+    , aRight     = rightPos+    , aRightLead = length "-> "     }+matchToAlignable conf (S.L matchLoc (Hs.Match _ (Hs.FunRhs name _ _) pats@(_ : _) grhss)) = do+  guard $ cTopLevelPatterns conf+  body <- unguardedRhsBody grhss+  let patsLocs = map S.getLoc pats+      nameLoc  = S.getLoc name+      left     = last (nameLoc : patsLocs)+      bodyLoc  = S.getLoc body+  matchPos <- toRealSrcSpan matchLoc+  leftPos  <- toRealSrcSpan left+  bodyPos  <- toRealSrcSpan bodyLoc+  Just $ Alignable+    { aContainer = matchPos+    , aLeft      = leftPos+    , aRight     = bodyPos+    , aRightLead = length "= "+    }+matchToAlignable _conf (S.L _ (Hs.XMatch x))       = Hs.noExtCon x+matchToAlignable _conf (S.L _ (Hs.Match _ _ _ _))  = Nothing   -------------------------------------------------------------------------------- step :: Maybe Int -> Config -> Step-step maxColumns config = makeStep "Cases" $ \ls (module', _) ->-    let module''               = fmap H.srcInfoSpan module'-        changes search toAlign =-            [ change_-            | case_   <- search module''-            , aligns  <- maybeToList (mapM toAlign case_)-            , change_ <- align maxColumns aligns-            ]+step maxColumns config = makeStep "Cases" $ \ls module' ->+    let changes+            :: (S.Located (Hs.HsModule Hs.GhcPs) -> [a])+            -> (a -> [Alignable S.RealSrcSpan])+            -> [Change String]+        changes search toAlign = concat $+            map (align maxColumns) . map toAlign $ search (parsedModule module') +        configured :: [Change String]         configured = concat $-            [ changes cases (altToAlignable H.mergeSrcSpan)-            | cCases config-            ] ++-            [changes tlpats  matchToAlignable | cTopLevelPatterns config] ++-            [changes records fieldDeclToAlignable | cRecords config]--    in applyChanges configured ls+            [changes records recordToAlignable | cRecords config] +++            [changes everything (matchGroupToAlignable config)] in+    applyChanges configured ls

@@ -1,4 +1,7 @@ --------------------------------------------------------------------------------+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE PatternGuards         #-}+{-# LANGUAGE TypeFamilies          #-} module Language.Haskell.Stylish.Step.Squash     ( step     ) where@@ -6,7 +9,8 @@  -------------------------------------------------------------------------------- import           Data.Maybe                      (mapMaybe)-import qualified Language.Haskell.Exts           as H+import qualified GHC.Hs                          as Hs+import qualified SrcLoc                          as S   --------------------------------------------------------------------------------@@ -17,46 +21,43 @@  -------------------------------------------------------------------------------- squash-    :: (H.Annotated l, H.Annotated r)-    => l H.SrcSpan -> r H.SrcSpan -> Maybe (Change String)-squash left right-  | H.srcSpanEndLine lAnn == H.srcSpanStartLine rAnn = Just $-        changeLine (H.srcSpanEndLine lAnn) $ \str ->-        let (pre, post) = splitAt (H.srcSpanEndColumn lAnn) str-        in  [trimRight pre ++ " " ++ trimLeft post]-  | otherwise = Nothing-  where-    lAnn = H.ann left-    rAnn = H.ann right+    :: (S.HasSrcSpan l, S.HasSrcSpan r)+    => l -> r -> Maybe (Change String)+squash left right = do+  lAnn <- toRealSrcSpan $ S.getLoc left+  rAnn <- toRealSrcSpan $ S.getLoc right+  if S.srcSpanEndLine lAnn == S.srcSpanStartLine rAnn ||+      S.srcSpanEndLine lAnn + 1 == S.srcSpanStartLine rAnn+    then Just $+          changeLine (S.srcSpanEndLine lAnn) $ \str ->+          let (pre, post) = splitAt (S.srcSpanEndCol lAnn) str+          in [trimRight pre ++ " " ++ trimLeft post]+    else Nothing   ---------------------------------------------------------------------------------squashFieldDecl :: H.FieldDecl H.SrcSpan -> Maybe (Change String)-squashFieldDecl (H.FieldDecl _ names type')+squashFieldDecl :: Hs.ConDeclField Hs.GhcPs -> Maybe (Change String)+squashFieldDecl (Hs.ConDeclField _ names type' _)   | null names = Nothing   | otherwise  = squash (last names) type'------------------------------------------------------------------------------------squashMatch :: H.Match H.SrcSpan -> Maybe (Change String)-squashMatch (H.InfixMatch _ _ _ _ _ _) = Nothing-squashMatch (H.Match _ name pats rhs _)-  | null pats = squash name        rhs-  | otherwise = squash (last pats) rhs+squashFieldDecl (Hs.XConDeclField x) = Hs.noExtCon x   ---------------------------------------------------------------------------------squashAlt :: H.Alt H.SrcSpan -> Maybe (Change String)-squashAlt (H.Alt _ pat rhs _) = squash pat rhs+squashMatch :: Hs.Match Hs.GhcPs (Hs.LHsExpr Hs.GhcPs) -> Maybe (Change String)+squashMatch (Hs.Match _ (Hs.FunRhs name _ _) [] grhss) = do+    body <- unguardedRhsBody grhss+    squash name body+squashMatch (Hs.Match _ _ pats grhss) = do+    body <- unguardedRhsBody grhss+    squash (last pats) body+squashMatch (Hs.XMatch x) = Hs.noExtCon x   -------------------------------------------------------------------------------- step :: Step-step = makeStep "Squash" $ \ls (module', _) ->-    let module'' = fmap H.srcInfoSpan module'-        changes  = concat-            [ mapMaybe squashAlt       (everything module'')-            , mapMaybe squashMatch     (everything module'')-            , mapMaybe squashFieldDecl (everything module'')-            ]-    in applyChanges changes ls+step = makeStep "Squash" $ \ls (module') ->+    let changes =+            mapMaybe squashFieldDecl (everything module') +++            mapMaybe squashMatch (everything module') in+    applyChanges changes ls

@@ -10,17 +10,17 @@ import           Data.Map                                      (Map) import qualified Data.Map                                      as M import           Data.Maybe                                    (maybeToList)-import qualified Language.Haskell.Exts                         as H--+import           GHC.Hs.Binds+import           GHC.Hs.Extension                              (GhcPs)+import           GHC.Hs.Types -------------------------------------------------------------------------------- import           Language.Haskell.Stylish.Block import           Language.Haskell.Stylish.Editor+import           Language.Haskell.Stylish.Module import           Language.Haskell.Stylish.Step import           Language.Haskell.Stylish.Step.LanguagePragmas (addLanguagePragma) import           Language.Haskell.Stylish.Util - -------------------------------------------------------------------------------- unicodeReplacements :: Map String String unicodeReplacements = M.fromList@@ -39,7 +39,7 @@ replaceAll = map changeLine'   where     changeLine' (r, ns) = changeLine r $ \str -> return $-        applyChanges +        applyChanges             [ change (Block c ec) (const repl)             | (c, needle) <- sort ns             , let ec = c + length needle - 1@@ -54,33 +54,32 @@   ---------------------------------------------------------------------------------typeSigs :: H.Module H.SrcSpanInfo -> Lines -> [((Int, Int), String)]+typeSigs :: Module -> Lines -> [((Int, Int), String)] typeSigs module' ls =     [ (pos, "::")-    | H.TypeSig loc _ _  <- everything module' :: [H.Decl H.SrcSpanInfo]-    , (start, end)       <- infoPoints loc-    , pos                <- maybeToList $ between start end "::" ls+    | TypeSig _ funLoc typeLoc <- everything (rawModuleDecls $ moduleDecls module') :: [Sig GhcPs]+    , (_, funEnd)              <- infoPoints funLoc+    , (typeStart, _)           <- infoPoints [hsSigWcType typeLoc]+    , pos                      <- maybeToList $ between funEnd typeStart "::" ls     ] - ---------------------------------------------------------------------------------contexts :: H.Module H.SrcSpanInfo -> Lines -> [((Int, Int), String)]+contexts :: Module -> Lines -> [((Int, Int), String)] contexts module' ls =     [ (pos, "=>")-    | context      <- everything module' :: [H.Context H.SrcSpanInfo]-    , (start, end) <- infoPoints $ H.ann context-    , pos          <- maybeToList $ between start end "=>" ls+    | TypeSig _ _ typeLoc <- everything (rawModuleDecls $ moduleDecls module') :: [Sig GhcPs]+    , (start, end)        <- infoPoints [hsSigWcType typeLoc]+    , pos                 <- maybeToList $ between start end "=>" ls     ]   ---------------------------------------------------------------------------------typeFuns :: H.Module H.SrcSpanInfo -> Lines -> [((Int, Int), String)]+typeFuns :: Module -> Lines -> [((Int, Int), String)] typeFuns module' ls =     [ (pos, "->")-    | H.TyFun _ t1 t2 <- everything module'-    , let start = H.srcSpanEnd $ H.srcInfoSpan $ H.ann t1-    , let end   = H.srcSpanStart $ H.srcInfoSpan $ H.ann t2-    , pos <- maybeToList $ between start end "->" ls+    | TypeSig _ _ typeLoc <- everything (rawModuleDecls $ moduleDecls module') :: [Sig GhcPs]+    , (start, end)        <- infoPoints [hsSigWcType typeLoc]+    , pos                 <- maybeToList $ between start end "->" ls     ]  @@ -110,7 +109,7 @@  -------------------------------------------------------------------------------- step' :: Bool -> String -> Lines -> Module -> Lines-step' alp lg ls (module', _) = applyChanges changes ls+step' alp lg ls module' = applyChanges changes ls   where     changes = (if alp then addLanguagePragma lg "UnicodeSyntax" module' else []) ++         replaceAll perLine

@@ -1,8 +1,8 @@ --------------------------------------------------------------------------------+{-# LANGUAGE LambdaCase    #-}+{-# LANGUAGE PatternGuards #-} module Language.Haskell.Stylish.Util-    ( nameToString-    , isOperator-    , indent+    ( indent     , padRight     , everything     , infoPoints@@ -13,22 +13,35 @@     , wrapMaybe     , wrapRestMaybe +    -- * Extra list functions     , withHead     , withInit     , withTail     , withLast+    , flagEnds++    , toRealSrcSpan++    , traceOutputtable+    , traceOutputtableM++    , unguardedRhsBody+    , rhsBody++    , getGuards     ) where   ---------------------------------------------------------------------------------import           Control.Arrow                 ((&&&), (>>>))-import           Data.Char                     (isAlpha, isSpace)+import           Data.Char                     (isSpace) import           Data.Data                     (Data) import qualified Data.Generics                 as G-import           Data.Maybe                    (fromMaybe, listToMaybe,-                                                maybeToList)+import           Data.Maybe                    (maybeToList) import           Data.Typeable                 (cast)-import qualified Language.Haskell.Exts         as H+import           Debug.Trace                   (trace)+import qualified GHC.Hs                        as Hs+import qualified Outputable+import qualified SrcLoc                        as S   --------------------------------------------------------------------------------@@ -36,18 +49,6 @@   ---------------------------------------------------------------------------------nameToString :: H.Name l -> String-nameToString (H.Ident _ str)  = str-nameToString (H.Symbol _ str) = str------------------------------------------------------------------------------------isOperator :: H.Name l -> Bool-isOperator = fromMaybe False-    . (fmap (not . isAlpha) . listToMaybe)-    . nameToString---------------------------------------------------------------------------------- indent :: Int -> String -> String indent len = (indentPrefix len ++) @@ -68,8 +69,16 @@   ---------------------------------------------------------------------------------infoPoints :: H.SrcSpanInfo -> [((Int, Int), (Int, Int))]-infoPoints = H.srcInfoPoints >>> map (H.srcSpanStart &&& H.srcSpanEnd)+infoPoints :: [S.Located pass] -> [((Int, Int), (Int, Int))]+infoPoints = fmap (helper . S.getLoc)+  where+    helper :: S.SrcSpan -> ((Int, Int), (Int, Int))+    helper (S.RealSrcSpan s) = do+               let+                start = S.realSrcSpanStart s+                end = S.realSrcSpanEnd s+               ((S.srcLocLine start, S.srcLocCol start), (S.srcLocLine end, S.srcLocCol end))+    helper _                   = ((-1,-1), (-1,-1))   --------------------------------------------------------------------------------@@ -117,7 +126,7 @@        -> Lines     -- ^ Resulting lines noWrap leading _ind = noWrap' leading   where-    noWrap' ss [] = [ss]+    noWrap' ss []         = [ss]     noWrap' ss (str:strs) = noWrap' (ss ++ " " ++ str) strs  @@ -181,7 +190,78 @@ withInit _ [x]      = [x] withInit f (x : xs) = f x : withInit f xs + -------------------------------------------------------------------------------- withTail :: (a -> a) -> [a] -> [a] withTail _ []       = [] withTail f (x : xs) = x : map f xs++++--------------------------------------------------------------------------------+-- | Utility for traversing through a list and knowing when you're at the+-- first and last element.+flagEnds :: [a] -> [(a, Bool, Bool)]+flagEnds = \case+    [] -> []+    [x] -> [(x, True, True)]+    x : y : zs -> (x, True, False) : go (y : zs)+  where+    go (x : y : zs) = (x, False, False) : go (y : zs)+    go [x]          = [(x, False, True)]+    go []           = []+++--------------------------------------------------------------------------------+traceOutputtable :: Outputable.Outputable a => String -> a -> b -> b+traceOutputtable title x =+    trace (title ++ ": " ++ (Outputable.showSDocUnsafe $ Outputable.ppr x))+++--------------------------------------------------------------------------------+traceOutputtableM :: (Outputable.Outputable a, Monad m) => String -> a -> m ()+traceOutputtableM title x = traceOutputtable title x $ pure ()+++--------------------------------------------------------------------------------+-- take the (Maybe) RealSrcSpan out of the SrcSpan+toRealSrcSpan :: S.SrcSpan -> Maybe S.RealSrcSpan+toRealSrcSpan (S.RealSrcSpan s) = Just s+toRealSrcSpan _                 = Nothing+++--------------------------------------------------------------------------------+-- Utility: grab the body out of guarded RHSs if it's a single unguarded one.+unguardedRhsBody :: Hs.GRHSs Hs.GhcPs a -> Maybe a+unguardedRhsBody (Hs.GRHSs _ [grhs] _)+    | Hs.GRHS _ [] body <- S.unLoc grhs = Just body+unguardedRhsBody _ = Nothing+++-- Utility: grab the body out of guarded RHSs+rhsBody :: Hs.GRHSs Hs.GhcPs a -> Maybe a+rhsBody (Hs.GRHSs _ [grhs] _)+    | Hs.GRHS _ _ body <- S.unLoc grhs = Just body+rhsBody _ = Nothing+++--------------------------------------------------------------------------------+-- get guards in a guarded rhs of a Match+getGuards :: Hs.Match Hs.GhcPs (Hs.LHsExpr Hs.GhcPs) -> [Hs.GuardLStmt Hs.GhcPs]+getGuards (Hs.Match _ _ _ grhss) =+  let+    lgrhs = getLocGRHS grhss -- []+    grhs  = map S.unLoc lgrhs+  in+    concatMap getGuardLStmts grhs+getGuards (Hs.XMatch x) = Hs.noExtCon x+++getLocGRHS :: Hs.GRHSs Hs.GhcPs (Hs.LHsExpr Hs.GhcPs) -> [Hs.LGRHS Hs.GhcPs (Hs.LHsExpr Hs.GhcPs)]+getLocGRHS (Hs.GRHSs _ guardeds _) = guardeds+getLocGRHS (Hs.XGRHSs x)           = Hs.noExtCon x+++getGuardLStmts :: Hs.GRHS Hs.GhcPs (Hs.LHsExpr Hs.GhcPs) -> [Hs.GuardLStmt Hs.GhcPs]+getGuardLStmts (Hs.GRHS _ guards _) = guards+getGuardLStmts (Hs.XGRHS x)         = Hs.noExtCon x

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} -------------------------------------------------------------------------------- module Main     ( main@@ -5,15 +6,18 @@   ---------------------------------------------------------------------------------import           Control.Monad            (forM_, unless)+import           Control.Monad            (forM_, unless, when) import qualified Data.ByteString.Char8    as BC8-import           Data.Monoid              ((<>)) import           Data.Version             (showVersion) import qualified Options.Applicative      as OA import           System.Exit              (exitFailure) import qualified System.IO                as IO import qualified System.IO.Strict         as IO.Strict +--------------------------------------------------------------------------------+#if __GLASGOW_HASKELL__ < 808+import           Data.Monoid              ((<>))+#endif  -------------------------------------------------------------------------------- import           Language.Haskell.Stylish@@ -112,7 +116,10 @@             forM_ steps $ \s -> verbose' $ "Enabled " ++ stepName s ++ " step"             verbose' $ "Extra language extensions: " ++                 show (configLanguageExtensions conf)-            mapM_ (file sa conf) $ files' filesR+            res <- foldMap (file sa conf) (files' filesR)++            verbose' $ "Exit code behavior: " ++ show (configExitCode conf)+            when (configExitCode conf == ErrorOnFormatExitBehavior && res == DidFormat) exitFailure   where     verbose' = makeVerbose (saVerbose sa)     files' x = case (saRecursive sa, null x) of@@ -120,16 +127,33 @@       (_,True)    -> [Nothing]  -- Involving IO.stdin.       (_,False)   -> map Just x -- Process available files. +data FormattingResult+  = DidFormat+  | NoChange+  deriving (Eq) +instance Semigroup FormattingResult where+  _ <> DidFormat = DidFormat+  DidFormat <> _ = DidFormat+  _ <> _ = NoChange++instance Monoid FormattingResult where+  mempty = NoChange+ -------------------------------------------------------------------------------- -- | Processes a single file, or stdin if no filepath is given-file :: StylishArgs -> Config -> Maybe FilePath -> IO ()+file :: StylishArgs -> Config -> Maybe FilePath -> IO FormattingResult file sa conf mfp = do     contents <- maybe getContents readUTF8File mfp-    let result = runSteps (configLanguageExtensions conf)-            mfp (configSteps conf) $ lines contents+    let+      inputLines =+        lines contents+      result =+        runSteps (configLanguageExtensions conf) mfp (configSteps conf) inputLines     case result of-        Right ok  -> write contents $ unlines ok+        Right ok  -> do+            write contents (unlines ok)+            pure $ if ok /= inputLines then DidFormat else NoChange         Left  err -> do             IO.hPutStrLn IO.stderr err             exitFailure

@@ -1,5 +1,5 @@ Name:          stylish-haskell-Version:       0.11.0.3+Version:       0.12.0.0 Synopsis:      Haskell code prettifier Homepage:      https://github.com/jaspervdj/stylish-haskell License:       BSD3@@ -30,8 +30,12 @@    Exposed-modules:     Language.Haskell.Stylish+    Language.Haskell.Stylish.GHC+    Language.Haskell.Stylish.Module+    Language.Haskell.Stylish.Printer     Language.Haskell.Stylish.Step.Data     Language.Haskell.Stylish.Step.Imports+    Language.Haskell.Stylish.Step.ModuleHeader     Language.Haskell.Stylish.Step.LanguagePragmas     Language.Haskell.Stylish.Step.SimpleAlign     Language.Haskell.Stylish.Step.Squash@@ -46,6 +50,7 @@     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@@ -61,14 +66,17 @@     directory        >= 1.2.3  && < 1.4,     filepath         >= 1.1    && < 1.5,     file-embed       >= 0.0.10 && < 0.1,-    haskell-src-exts >= 1.18   && < 1.24,+    ghc-lib-parser   >= 8.10   && < 8.12,     mtl              >= 2.0    && < 2.3,-    semigroups       >= 0.18   && < 0.20,     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@@ -77,7 +85,7 @@    Build-depends:     stylish-haskell,-    strict               >= 0.3  && < 0.4,+    strict               >= 0.3  && < 0.5,     optparse-applicative >= 0.12 && < 0.16,     -- Copied from regular dependencies...     aeson            >= 0.6    && < 1.6,@@ -88,7 +96,7 @@     directory        >= 1.2.3  && < 1.4,     filepath         >= 1.1    && < 1.5,     file-embed       >= 0.0.10 && < 0.1,-    haskell-src-exts >= 1.18   && < 1.24,+    ghc-lib-parser   >= 8.10   && < 8.12,     mtl              >= 2.0    && < 2.3,     syb              >= 0.3    && < 0.8,     HsYAML-aeson     >=0.2.0   && < 0.3,@@ -110,13 +118,20 @@     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.Step.Data.Tests+    Language.Haskell.Stylish.Step.ModuleHeader+    Language.Haskell.Stylish.Step.ModuleHeader.Tests     Language.Haskell.Stylish.Step.LanguagePragmas     Language.Haskell.Stylish.Step.LanguagePragmas.Tests     Language.Haskell.Stylish.Step.SimpleAlign@@ -144,12 +159,12 @@     aeson            >= 0.6    && < 1.6,     base             >= 4.8    && < 5,     bytestring       >= 0.9    && < 0.11,-    Cabal            >= 2.4    && < 3.1,+    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,-    haskell-src-exts >= 1.18   && < 1.24,+    ghc-lib-parser   >= 8.10   && < 8.12,     mtl              >= 2.0    && < 2.3,     syb              >= 0.3    && < 0.8,     text             >= 1.2    && < 1.3,

@@ -153,6 +153,7 @@   , "      first_field: \"indent 2\""   , "      field_comment: 2"   , "      deriving: 4"+  , "      via: \"indent 2\""   , "columns: 110"   , "language_extensions:"   , "  - TemplateHaskell"

@@ -6,7 +6,8 @@ -------------------------------------------------------------------------------- import           Test.Framework                 (Test, testGroup) import           Test.Framework.Providers.HUnit (testCase)-import           Test.HUnit                     (Assertion, assert)+import           Test.HUnit                     (Assertion, assertFailure)+import           GHC.Stack                      (HasCallStack, withFrozenCallStack)   --------------------------------------------------------------------------------@@ -33,18 +34,18 @@  -------------------------------------------------------------------------------- testShebangExt :: Assertion-testShebangExt = assert $ isRight $ parseModule [] Nothing input-                         where-                           input = unlines-                               [ "#!env runghc"-                               , "{-# LANGUAGE CPP #-}"-                               , "#define foo bar \\"-                               , "             qux"-                               ]+testShebangExt = returnsRight $ parseModule [] Nothing input+  where+    input = unlines+      [ "#!env runghc"+      , "{-# LANGUAGE CPP #-}"+      , "#define foo bar \\"+      , "             qux"+      ]  -------------------------------------------------------------------------------- testBom :: Assertion-testBom = assert $ isRight $ parseModule [] Nothing input+testBom = returnsRight $ parseModule [] Nothing input   where     input = unlines         [ '\xfeff' : "foo :: Int"@@ -54,13 +55,13 @@  -------------------------------------------------------------------------------- testExtraExtensions :: Assertion-testExtraExtensions = assert $ isRight $+testExtraExtensions = returnsRight $     parseModule ["TemplateHaskell"] Nothing "$(foo)"   -------------------------------------------------------------------------------- testMultilineCpp :: Assertion-testMultilineCpp = assert $ isRight $ parseModule [] Nothing $ unlines+testMultilineCpp = returnsRight $ parseModule [] Nothing $ unlines     [ "{-# LANGUAGE CPP #-}"     , "#define foo bar \\"     , "             qux"@@ -69,7 +70,7 @@  -------------------------------------------------------------------------------- testHaskell2010 :: Assertion-testHaskell2010 = assert $ isRight $ parseModule [] Nothing $ unlines+testHaskell2010 = returnsRight $ parseModule [] Nothing $ unlines     [ "{-# LANGUAGE Haskell2010 #-}"     , "module X where"     , "foo x | Just y <- x = y"@@ -78,7 +79,7 @@  -------------------------------------------------------------------------------- testShebang :: Assertion-testShebang = assert $ isRight $ parseModule [] Nothing $ unlines+testShebang = returnsRight $ parseModule [] Nothing $ unlines     [ "#!runhaskell"     , "module Main where"     , "main = return ()"@@ -87,7 +88,7 @@ --------------------------------------------------------------------------------  testShebangDouble :: Assertion-testShebangDouble = assert $ isRight $ parseModule [] Nothing $ unlines+testShebangDouble = returnsRight $ parseModule [] Nothing $ unlines     [ "#!nix-shell"     , "#!nix-shell -i runhaskell -p haskellPackages.ghc"     , "module Main where"@@ -100,7 +101,7 @@ -- enabled for parsing, even when the pragma is absent.  testGADTs :: Assertion-testGADTs = assert $ isRight $ parseModule [] Nothing $ unlines+testGADTs = returnsRight $ parseModule [] Nothing $ unlines   [ "module Main where"   , "data SafeList a b where"   , "  Nil :: SafeList a Empty"@@ -108,36 +109,35 @@   ]  testKindSignatures :: Assertion-testKindSignatures = assert $ isRight $ parseModule [] Nothing $ unlines+testKindSignatures = returnsRight $ parseModule [] Nothing $ unlines   [ "module Main where"   , "data D :: * -> * -> * where"   , "  D :: a -> b -> D a b"   ]  testStandaloneDeriving :: Assertion-testStandaloneDeriving = assert $ isRight $ parseModule [] Nothing $ unlines+testStandaloneDeriving = returnsRight $ parseModule [] Nothing $ unlines   [ "module Main where"   , "deriving instance Show MyType"   ]  testUnicodeSyntax :: Assertion-testUnicodeSyntax = assert $ isRight $ parseModule [] Nothing $ unlines+testUnicodeSyntax = returnsRight $ parseModule [] Nothing $ unlines   [ "module Main where"   , "monadic ∷ (Monad m) ⇒ m a → m a"   , "monadic = id"   ]  testXmlSyntaxRegression :: Assertion-testXmlSyntaxRegression = assert $ isRight $ parseModule [] Nothing $ unlines+testXmlSyntaxRegression = returnsRight $ parseModule [] Nothing $ unlines   [ "smaller a b = a <b"   ]  testMagicHashRegression :: Assertion-testMagicHashRegression = assert $ isRight $ parseModule [] Nothing $ unlines+testMagicHashRegression = returnsRight $ parseModule [] Nothing $ unlines   [ "xs = \"foo\"#|1#|'a'#|bar#|Nil"   ]  ---------------------------------------------------------------------------------isRight :: Either a b -> Bool-isRight (Right _) = True-isRight _         = False+returnsRight :: HasCallStack => Show a => Either a b -> Assertion+returnsRight action = withFrozenCallStack $ either (assertFailure . show) mempty action

@@ -35,6 +35,36 @@     , testCase "case 22" case22     , testCase "case 23" case23     , testCase "case 24" case24+    , testCase "case 25" case25+    , testCase "case 26" case26+    , testCase "case 27" case27+    , testCase "case 28" case28+    , testCase "case 29" case29+    , testCase "case 30" case30+    , testCase "case 31" case31+    , testCase "case 32" case32+    , testCase "case 33" case33+    , testCase "case 34" case34+    , testCase "case 35" case35+    , testCase "case 36" case36+    , testCase "case 37" case37+    , testCase "case 38" case38+    , testCase "case 39" case39+    , testCase "case 40" case40+    , testCase "case 41" case41+    , testCase "case 42" case42+    , testCase "case 43" case43+    , testCase "case 44" case44+    , testCase "case 45" case45+    , testCase "case 46" case46+    , testCase "case 47" case47+    , testCase "case 48" case48+    , testCase "case 49" case49+    , testCase "case 50" case50+    , testCase "case 51" case51+    , testCase "case 52" case52+    , testCase "case 53" case53+    , testCase "case 54" case54     ]  case00 :: Assertion@@ -165,7 +195,7 @@     expected = input  case08 :: Assertion-case08 = input @=? testStep (step sameSameStyle) input+case08 = expected @=? testStep (step sameSameStyle) input   where     input = unlines       [ "module Herp where"@@ -173,6 +203,11 @@       , "data Phantom a ="       , "  Phantom"       ]+    expected = unlines+      [ "module Herp where"+      , ""+      , "data Phantom a = Phantom"+      ]  case09 :: Assertion case09 = expected @=? testStep (step indentIndentStyle4) input@@ -333,7 +368,8 @@       , ""       , "data Foo"       , "  = Foo"-      , "      { a :: Int -- ^ comment"+      , "      { a :: Int"+      , "        -- ^ comment"       , "      }"       ] @@ -520,17 +556,661 @@        , "  deriving (ToJSON)"        ] +case25 :: Assertion+case25 = expected @=? testStep (step indentIndentStyle { cBreakSingleConstructors = False }) input+  where+    input = unlines+       [ "data Foo a"+       , "  = Foo { a :: Int,"+       , "          a2 :: String"+       , "          -- ^ some haddock"+       , "        }"+       , "  deriving (Eq, Show)"+       , "  deriving (ToJSON)"+       ]++    expected = unlines+       [ "data Foo a = Foo"+       , "  { a :: Int"+       , "  , a2 :: String"+       , "    -- ^ some haddock"+       , "  }"+       , "  deriving (Eq, Show)"+       , "  deriving (ToJSON)"+       ]++case26 :: Assertion+case26 = expected @=? testStep (step indentIndentStyle) input+  where+    input = unlines+      [ "module Herp where"+      , ""+      , "data Foo = Foo { a :: Int } deriving (FromJSON) via Bla Foo"+      ]++    expected = unlines+       [ "module Herp where"+       , ""+       , "data Foo"+       , "  = Foo"+       , "      { a :: Int"+       , "      }"+       , "  deriving (FromJSON) via Bla Foo"+       ]++case27 :: Assertion+case27 = expected @=? testStep (step sameIndentStyle { cBreakEnums = True }) input+  where+    input = unlines+      [ "module Herp where"+      , ""+      , "data Foo = Foo | Bar | Baz deriving (Eq, Show)"+      ]++    expected = unlines+      [ "module Herp where"+      , ""+      , "data Foo"+      , "  = Foo"+      , "  | Bar"+      , "  | Baz"+      , "  deriving (Eq, Show)"+      ]++case28 :: Assertion+case28 = expected @=? testStep (step sameIndentStyle { cBreakEnums = True }) input+  where+    input = unlines+      [ "module Some.Types where"+      , ""+      , "newtype BankCode = BankCode {"+      , "    unBankCode :: Text"+      , "  }"+      , "  deriving stock (Generic, Eq, Show)"+      , "  deriving anyclass (Newtype)"+      , ""+      , "newtype CheckDigit = CheckDigit { unCheckDigit :: Text }"+      , "  deriving stock (Generic, Eq, Show)"+      , "  deriving anyclass (Newtype)"+      , ""+      , "newtype WrappedInt = WrappedInt Int"+      , "  deriving stock (Generic, Eq, Show)"+      , "  deriving anyclass (Newtype)"+      , ""+      , "data MandateStatus"+      , "  = Approved"+      , "  | Failed"+      , "  | UserCanceled"+      , "  | Inactive"+      , "  deriving stock (Generic, Show, Eq, Enum, Bounded)"+      , "  deriving (ToJSON, FromJSON) via SnakeCaseCapsEnumEncoding MandateStatus"+      ]++    expected = unlines+      [ "module Some.Types where"+      , ""+      , "newtype BankCode = BankCode { unBankCode :: Text }"+      , "  deriving stock (Eq, Generic, Show)"+      , "  deriving anyclass (Newtype)"+      , ""+      , "newtype CheckDigit = CheckDigit { unCheckDigit :: Text }"+      , "  deriving stock (Eq, Generic, Show)"+      , "  deriving anyclass (Newtype)"+      , ""+      , "newtype WrappedInt = WrappedInt Int"+      , "  deriving stock (Eq, Generic, Show)"+      , "  deriving anyclass (Newtype)"+      , ""+      , "data MandateStatus"+      , "  = Approved"+      , "  | Failed"+      , "  | UserCanceled"+      , "  | Inactive"+      , "  deriving stock (Bounded, Enum, Eq, Generic, Show)"+      , "  deriving (FromJSON, ToJSON) via SnakeCaseCapsEnumEncoding MandateStatus"+      ]++case29 :: Assertion+case29 = expected @=? testStep (step sameIndentStyle) input+  where+    input = unlines+      [ "module Some.Types where"+      , ""+      , "data NonEmpty a"+      , "  = a :| [a]"+      ]++    expected = unlines+      [ "module Some.Types where"+      , ""+      , "data NonEmpty a = a :| [a]"+      ]++case30 :: Assertion+case30 = expected @=? testStep (step sameIndentStyle { cBreakEnums = True }) input+  where+    expected = input+    input = unlines+      [ "data ReasonCode"+      , "  = MissingTenantId"+      , "  -- Transaction errors:"+      , "  | TransactionDoesNotExist"+      , "  | TransactionAlreadyExists"+      , "  -- Engine errors:"+      , "  | EnginePersistenceError"+      , "  | EngineValidationError"+      , "  -- | Transaction was created in Info mode"+      , "  | RegisteredByNetworkEngine"+      , "  -- | Transaction was created in Routing mode"+      , "  | SentToNetworkEngine"+      , "  -- Network connection reasons:"+      , "  | SentToNetworkConnection"+      , "  | ReceivedByNetworkConnection"+      , "  | ValidatedByNetworkConnection"+      ]+++case31 :: Assertion+case31 = expected @=? testStep (step indentIndentStyle { cBreakEnums = True }) input+  where+    expected = input+    input = unlines+      [ "data ConfiguredLogger"+      , "  -- | Logs to file"+      , "  = LogTo FilePath"+      , "  -- | Logs to stdout"+      , "  | LogToConsole"+      , "  -- | No logging, discards all messages"+      , "  | NoLogging"+      , "  deriving stock (Generic, Show)"+      ]++case32 :: Assertion+case32 = expected @=? testStep (step indentIndentStyle { cBreakEnums = True }) input+  where+    expected = input+    input = unlines+      [ "data RejectionReason"+      , "  -- InvalidState"+      , "  = CancellationFailed"+      , "  | TotalAmountConfirmationInvalid"+      , "  -- InvalidApiUsage"+      , "  | AccessTokenNotActive"+      , "  | VersionNotFound"+      , "  -- ValidationFailed"+      , "  | BankAccountExists"+      , "  deriving stock (Eq, Generic, Show)"+      , "  deriving (FromJSON, ToJSON) via SnakeCaseLowercaseEnumEncoding RejectionReason"+      ]++case33 :: Assertion+case33 = expected @=? testStep (step indentIndentStyle { cBreakEnums = True, cBreakSingleConstructors = False }) input+  where+    input = unlines+      [ "module Some.Types where"+      , ""+      , "newtype NonEmpty a = NonEmpty { unNonEmpty :: a }"+      ]++    expected = unlines+      [ "module Some.Types where"+      , ""+      , "newtype NonEmpty a"+      , "  = NonEmpty { unNonEmpty :: a }"+      ]++case34 :: Assertion+case34 = expected @=? testStep (step indentIndentStyle { cVia = Indent 2 }) input+  where+    input = unlines+      [ "module Some.Types where"+      , ""+      , "newtype NonEmpty a = NonEmpty { unNonEmpty :: a }"+      , "     deriving (ToJSON, FromJSON) via Something Magic (NonEmpty a)"+      ]++    expected = unlines+      [ "module Some.Types where"+      , ""+      , "newtype NonEmpty a"+      , "  = NonEmpty { unNonEmpty :: a }"+      , "  deriving (FromJSON, ToJSON)"+      , "    via Something Magic (NonEmpty a)"+      ]++case35 :: Assertion+case35 = expected @=? testStep (step indentIndentStyle { cBreakEnums = True, cBreakSingleConstructors = False }) input+  where+    input = unlines+      [ "module Some.Types where"+      , ""+      , "data Foo = Foo"+      , "  { _transfer :: MonetaryAmount"+      , "      -> TransactionId"+      , "      -> m (Either CreditTransferError TransactionId)"+      , "  }"+      ]++    expected = unlines+      [ "module Some.Types where"+      , ""+      , "data Foo = Foo"+      , "  { _transfer :: MonetaryAmount -> TransactionId -> m (Either CreditTransferError TransactionId)"+      , "  }"+      ]++case36 :: Assertion+case36 = expected @=? testStep (step indentIndentStyle { cBreakEnums = True, cBreakSingleConstructors = False }) input+  where+    input = unlines+      [ "module Some.Types where"+      , ""+      , "data Foo = Foo"+      , "  { _transfer :: (a -> b)"+      , "      -> TransactionId"+      , "      -> m (Either CreditTransferError TransactionId)"+      , "  }"+      ]++    expected = unlines+      [ "module Some.Types where"+      , ""+      , "data Foo = Foo"+      , "  { _transfer :: (a -> b) -> TransactionId -> m (Either CreditTransferError TransactionId)"+      , "  }"+      ]++case37 :: Assertion+case37 = expected @=? testStep (step indentIndentStyle { cVia = Indent 2 }) input+  where+    input = unlines+      [ "module Some.Types where"+      , ""+      , "newtype UndoFlowData"+      , "  = UndoFlowData { flowDataDetails :: FlowDataDetails }"+      , "  deriving stock (Generic, Eq, Show)"+      , "  deriving (ToJSON, FromJSON)"+      , "    via AddConstTextFields '[\"type0\" := \"undo\","+      , "                             \"type1\" := \"undo\","+      , "                     \"reversal_indicator\" := \"Undo\"] FlowDataDetails"+      ]++    expected = unlines+      [ "module Some.Types where"+      , ""+      , "newtype UndoFlowData"+      , "  = UndoFlowData { flowDataDetails :: FlowDataDetails }"+      , "  deriving stock (Eq, Generic, Show)"+      , "  deriving (FromJSON, ToJSON)"+      , "    via AddConstTextFields '[\"type0\" := \"undo\", \"type1\" := \"undo\", \"reversal_indicator\" := \"Undo\"] FlowDataDetails"+      ]++case38 :: Assertion+case38 = expected @=? testStep (step indentIndentStyle { cVia = Indent 2 }) input+  where+    input = unlines+      [ "data Flat = Flat"+      , "  { foo :: Int"+      , "  , bar :: Text"+      , "  , baz :: Double"+      , "  , qux :: Bool"+      , "  }"+      , "  deriving stock (Generic, Show, Eq)"+      , "  deriving (FromJSON, ToJSON)"+      , "    via GenericEncoded"+      , "      '[ FieldLabelModifier :="+      , "        '[ \"foo\" ==> \"nestFoo#foo\""+      , "         , \"bar\" ==> \"nestBar#bar\""+      , "         , \"baz\" ==> \"nestFoo#baz\""+      , "         ]"+      , "       ]"+      , "      Flat"+      ]++    expected = unlines+      [ "data Flat"+      , "  = Flat"+      , "      { foo :: Int"+      , "      , bar :: Text"+      , "      , baz :: Double"+      , "      , qux :: Bool"+      , "      }"+      , "  deriving stock (Eq, Generic, Show)"+      , "  deriving (FromJSON, ToJSON)"+      , "    via GenericEncoded '[FieldLabelModifier := '[\"foo\" ==> \"nestFoo#foo\", \"bar\" ==> \"nestBar#bar\", \"baz\" ==> \"nestFoo#baz\"]] Flat"+      ]++case39 :: Assertion+case39 = expected @=? testStep (step indentIndentStyle { cVia = Indent 2 }) input+  where+    input = unlines+      [ "data CreditTransfer = CreditTransfer"+      , "  { nestedCreditorInfo :: CreditorInfo"+      , "  }"+      , "  deriving stock (Show, Eq, Generic)"+      , "  deriving (ToJSON, FromJSON) via"+      , "    ( UntaggedEncoded NordeaCreditTransfer"+      , "    & AddConstTextFields"+      , "      '[ \"request_type\" ':= \"credit_transfer\""+      , "       , \"provider\" ':= \"nordea\""+      , "       ]"+      , "    & FlattenFields '[\"nested_creditor_info\"]"+      , "    & RenameKeys"+      , "        '[ \"nested_creditor_info.creditor_agent_bic\" ==> \"creditor_agent_bic\""+      , "         , \"nested_creditor_info.creditor_iban\" ==> \"creditor_iban\""+      , "         , \"nested_creditor_info.creditor_name\" ==> \"creditor_name\""+      , "         , \"nested_creditor_info.creditor_account\" ==> \"creditor_account\""+      , "         ]"+      , "    )"+      ]++    expected = unlines+      [ "data CreditTransfer"+      , "  = CreditTransfer"+      , "      { nestedCreditorInfo :: CreditorInfo"+      , "      }"+      , "  deriving stock (Eq, Generic, Show)"+      , "  deriving (FromJSON, ToJSON)"+      , "    via (UntaggedEncoded NordeaCreditTransfer & AddConstTextFields '[\"request_type\" ':= \"credit_transfer\", \"provider\" ':= \"nordea\"] & FlattenFields '[\"nested_creditor_info\"] & RenameKeys '[\"nested_creditor_info.creditor_agent_bic\" ==> \"creditor_agent_bic\", \"nested_creditor_info.creditor_iban\" ==> \"creditor_iban\", \"nested_creditor_info.creditor_name\" ==> \"creditor_name\", \"nested_creditor_info.creditor_account\" ==> \"creditor_account\"])"+      ]++case40 :: Assertion+case40 = expected @=? testStep (step indentIndentStyle { cBreakSingleConstructors = False }) input+  where+    input = unlines+      [ "module X where"+      , ""+      , "data a :==> b    ="+      , "                  Arr a b"+      ]++    expected = unlines+      [ "module X where"+      , ""+      , "data a :==> b = Arr a b"+      ]++case41 :: Assertion+case41 = expected @=? testStep (step indentIndentStyle) input+  where+    input = expected++    expected = unlines+      [ "module X where"+      , ""+      , "data Callback"+      , "  -- | Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor"+      , "  --   incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis"+      , "  --   nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat."+      , "  --   Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore"+      , "  --   eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident,"+      , "  --   sunt in culpa qui officia deserunt mollit anim id est laborum."+      , "  = KafkaTopic"+      , "      { callbackTopic :: CallbackTopic"+      , "        -- ^ Name of topic to send updates to"+      , "      , callbackFormat :: CallbackFormat"+      , "        -- ^ The format used to send these updates"+      , "      }"+      , "  deriving stock (Eq, Generic, Show)"+      , "  deriving (FromJSON, ToJSON) via IdiomaticWithDescription CallbackDesc Callback"+      , "  deriving (HasGen) via Generically Callback"+      , "  deriving (FromField) via JsonField Callback"+      ]++case42 :: Assertion+case42 = expected @=? testStep (step indentIndentStyle) input+  where+    input = expected++    expected = unlines+      [ "module X where"+      , ""+      , "data SignupError"+      , "  = IdempotencyConflict"+      , "  | ValidationError Text -- TODO: might be a sumtype of possible error codes"+      , "  deriving stock (Eq, Generic, Show)"+      ]++case43 :: Assertion+case43 = expected @=? testStep (step indentIndentStyle { cBreakEnums = True, cBreakSingleConstructors = False }) input+  where+    input = expected++    expected = unlines+      [ "module X where"+      , ""+      , "data CallbackResult"+      , "  -- | Callback successfully sent"+      , "  = Success"+      , "  -- | Kafka error received"+      , "  | KafkaIssue KafkaError"+      , "  deriving (Eq, Show)"+      ]++-- This test showcases a difficult to solve issue. If the comment is in a+-- deriving clause, it's very hard to guess the correct position of the entire+-- block. E.g. the deriving clause itself has the wrong position. However, if+-- we look at all deriving clauses we know where they start and end.+--+-- This means that we've needed to make the decision to put all inline comments+-- before the deriving clause itself+case44 :: Assertion+case44 = expected @=? testStep (step indentIndentStyle { cBreakEnums = True, cBreakSingleConstructors = False, cVia = Indent 2 }) input+  where+    input = unlines+      [ "module X where"+      , ""+      , " data CreditTransfer = CreditTransfer"+      , "   { amount :: Amount -- ^ 1 <= amount <= 999_999_999_999"+      , "   , date :: Day"+      , "   , accountNumber :: Account"+      , "   }"+      , "   deriving stock (Eq, Generic, Show)"+      , "   deriving (FromJSON, ToJSON) via"+      , "     AddConstTextFields"+      , "       '[\"notification_type\" ':= \"credit_transaction\""+      , "         -- Note that the bcio name has \"transaction\""+      , "         -- rather than \"transfer\""+      , "        ]"+      , "        (UntaggedEncoded CreditTransfer)"+      ]+    expected = unlines+      [ "module X where"+      , ""+      , "data CreditTransfer = CreditTransfer"+      , "  { amount :: Amount"+      , "    -- ^ 1 <= amount <= 999_999_999_999"+      , "  , date :: Day"+      , "  , accountNumber :: Account"+      , "  }"+      , "  -- Note that the bcio name has \"transaction\""+      , "  -- rather than \"transfer\""+      , "  deriving stock (Eq, Generic, Show)"+      , "  deriving (FromJSON, ToJSON)"+      , "    via AddConstTextFields '[\"notification_type\" ':= \"credit_transaction\"] (UntaggedEncoded CreditTransfer)"+      ]++case45 :: Assertion+case45 = expected @=? testStep (step indentIndentStyle { cBreakEnums = True, cBreakSingleConstructors = False, cVia = Indent 2 }) input+  where+    input = expected+    expected = unlines+      [ "module X where"+      , ""+      , "data CreditTransfer = CreditTransfer"+      , "  { amount :: Amount"+      , "    -- ^ 1 <= amount <= 999_999_999_999"+      , "  , date :: Day"+      , "  , accountNumber :: Account"+      , "  }"+      , "  -- Note that the bcio name has \"transaction\""+      , "  -- rather than \"transfer\""+      , "  deriving stock (Eq, Generic, Show)"+      , "  deriving (FromJSON, ToJSON)"+      , "    via AddConstTextFields '[\"notification_type\" ':= \"credit_transaction\"] (UntaggedEncoded CreditTransfer)"+      ]++case46 :: Assertion+case46 = expected @=? testStep (step indentIndentStyle { cBreakEnums = True, cBreakSingleConstructors = False, cVia = Indent 2 }) input+  where+    input = expected+    expected = unlines+      [ "module X where"+      , ""+      , "-- | A format detailing which encoding to use for the settlement events"+      , "data CallbackFormat"+      , "  -- | The Avro schema is to be used"+      , "  = AvroEngineEvent"+      , "  deriving (Bounded, Enum, Eq, Generic, Show)"+      , "  deriving (FromJSON, ToJSON)"+      , "    via TypeTaggedWithDescription FormatDesc CallbackFormat"+      , "  deriving (HasGen)"+      , "    via EnumBounded CallbackFormat"+      ]++case47 :: Assertion+case47 = expected @=? testStep (step indentIndentStyle) input+  where+    input = expected+    expected = unlines+      [ "module X where"+      , ""+      , "-- | A GADT example"+      , "data T a where"+      , "  D1 :: Int -> T String"+      , "  D2 :: T Bool"+      , "  D3 :: (a, a) -> T [a]"+      ]++case48 :: Assertion+case48 = expected @=? testStep (step indentIndentStyle) input+  where+    input = expected+    expected = unlines+      [ "module X where"+      , ""+      , "-- | A GADT example"+      , "data T a where"+      , "  D1 :: Int -> T String"+      , "  D2 :: T Bool"+      , "  D3 :: forall a. (Eq a, Bounded a) => (a, a) -> T [a]"+      ]++case49 :: Assertion+case49 = expected @=? testStep (step indentIndentStyle) input+  where+    input = expected+    expected = unlines+      [ "module X where"+      , ""+      , "-- | A GADT example"+      , "data T a where"+      , "  D1 :: Int -> T String"+      , "  D2 :: T Bool"+      , "  D3 :: forall a. (Eq a) => (a, a) -> T [a]"+      ]++case50 :: Assertion+case50 = expected @=? testStep (step indentIndentStyle { cCurriedContext = True }) input+  where+    input = expected+    expected = unlines+      [ "module X where"+      , ""+      , "-- | A GADT example"+      , "data T a where"+      , "  D1 :: Int -> T String"+      , "  D2 :: T Bool"+      , "  D3 :: forall a. Eq a => (a, a) -> T [a]"+      ]++case51 :: Assertion+case51 = expected @=? testStep (step indentIndentStyle { cCurriedContext = True }) input+  where+    input = unlines+      [ "module X where"+      , ""+      , "-- | A GADT example"+      , "data T a where"+      , "  D1 :: Int -> T String"+      , "  D2 :: T Bool"+      , "  D3 :: forall a. (Eq a) => (a, a) -> T [a]"+      ]+    expected = unlines+      [ "module X where"+      , ""+      , "-- | A GADT example"+      , "data T a where"+      , "  D1 :: Int -> T String"+      , "  D2 :: T Bool"+      , "  D3 :: forall a. Eq a => (a, a) -> T [a]"+      ]++case52 :: Assertion+case52 = expected @=? testStep (step indentIndentStyle { cBreakSingleConstructors = False, cCurriedContext = True }) input+  where+    input = unlines+      [ "module X where"+      , ""+      , "data Foo = Foo"+      , "  { foo :: forall a b. (Eq a, Bounded b) => a -> b -> [(a, b)]"+      , "  }"+      ]+    expected = unlines+      [ "module X where"+      , ""+      , "data Foo = Foo"+      , "  { foo :: forall a b. Eq a => Bounded b => a -> b -> [(a, b)]"+      , "  }"+      ]++case53 :: Assertion+case53 = expected @=? testStep (step indentIndentStyle { cMaxColumns = MaxColumns 80 }) input+  where+    input = unlines+      [ "newtype Foo m a"+      , "  = Foo (m a)"+      , "  deriving newtype (Functor, Applicative, Monad, MonadError, MonadCatch, Foldable, Monoid)"+      ]+    expected = unlines+      [ "newtype Foo m a"+      , "  = Foo (m a)"+      , "  deriving newtype"+      , "    ( Applicative"+      , "    , Foldable"+      , "    , Functor"+      , "    , Monad"+      , "    , MonadCatch"+      , "    , MonadError"+      , "    , Monoid"+      , "    )"+      ]++case54 :: Assertion+case54 = expected @=? testStep (step indentIndentStyle { cMaxColumns = MaxColumns 80 }) input+  where+    input = unlines+      [ "newtype Foo m a"+      , "  = Foo (m a)"+      , "  deriving newtype (Functor, Applicative, Monad)"+      ]+    expected = unlines+      [ "newtype Foo m a"+      , "  = Foo (m a)"+      , "  deriving newtype (Applicative, Functor, Monad)"+      ]+ sameSameStyle :: Config-sameSameStyle = Config SameLine SameLine 2 2+sameSameStyle = Config SameLine SameLine 2 2 False True SameLine False NoMaxColumns  sameIndentStyle :: Config-sameIndentStyle = Config SameLine (Indent 2) 2 2+sameIndentStyle = Config SameLine (Indent 2) 2 2 False True SameLine False NoMaxColumns  indentSameStyle :: Config-indentSameStyle = Config (Indent 2) SameLine 2 2+indentSameStyle = Config (Indent 2) SameLine 2 2 False True SameLine False NoMaxColumns  indentIndentStyle :: Config-indentIndentStyle = Config (Indent 2) (Indent 2) 2 2+indentIndentStyle = Config (Indent 2) (Indent 2) 2 2 False True SameLine False NoMaxColumns  indentIndentStyle4 :: Config-indentIndentStyle4 = Config (Indent 4) (Indent 4) 4 4+indentIndentStyle4 = Config (Indent 4) (Indent 4) 4 4 False True SameLine False NoMaxColumns

@@ -0,0 +1,382 @@+-- | Tests contributed by Felix Mulder as part of+-- <https://github.com/jaspervdj/stylish-haskell/pull/293>.+module Language.Haskell.Stylish.Step.Imports.FelixTests+  ( tests+  ) where++--------------------------------------------------------------------------------+import           Test.Framework                        (Test, testGroup)+import           Test.Framework.Providers.HUnit        (testCase)+import           Test.HUnit                            (Assertion)+import           GHC.Stack                             (HasCallStack, withFrozenCallStack)+import           Prelude                               hiding (lines)++--------------------------------------------------------------------------------+import           Language.Haskell.Stylish.Module+import           Language.Haskell.Stylish.Step.Imports+import           Language.Haskell.Stylish.Tests.Util   (testStep', (@=??))++++--------------------------------------------------------------------------------+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+  ]++--------------------------------------------------------------------------------+ex0 :: Assertion+ex0 = input `assertFormatted` output+  where+    input =+      [ "import B"+      , "import A"+      ]+    output =+      [ "import           A"+      , "import           B"+      ]++ex1 :: Assertion+ex1 = input `assertFormatted` output+  where+    input =+      [ "import B"+      , "import A"+      , "import C"+      , "import qualified A"+      , "import qualified B as X"+      ]+    output =+      [ "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"+      ]++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)"+      ]++ex4 :: Assertion+ex4 = input `assertFormatted` output+  where+    input =+      [ "import A (X, Z(..), Y)"+      ]+    output =+      [ "import           A (X, Y, Z (..))"+      ]++ex5 :: Assertion+ex5 = input `assertFormatted` output+  where+    input =+      [ "import A (X, Z(Z), Y)"+      ]+    output =+      [ "import           A (X, Y, Z (Z))"+      ]++ex6 :: Assertion+ex6 = input `assertFormatted` output+  where+    input =+      [ "import A (X, Z(X, Z, Y), Y)"+      ]+    output =+      [ "import           A (X, Y, Z (X, Y, Z))"+      ]++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"+      ]++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"+      ]++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"+      ]++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)"+      ]++ex11 :: Assertion+ex11 = input `assertFormatted` output+  where+    input =+      [ "import Data.Aeson ((.=))"+      , "import A  hiding (X)"+      ]+    output =+      [ "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 ((.=))"+      ]++ex13 :: Assertion+ex13 = input `assertFormattedCols` output+  where+    assertFormattedCols =+      assertFormatted' (Just 10)+    input =+      [ "import Foo (A, B, C, D)"+      , "import A  hiding (X)"+      ]+    output =+      [ "import           A   hiding (X)"+      , "import           Foo (A)"+      , "import           Foo (B)"+      , "import           Foo (C)"+      , "import           Foo (D)"+      ]++ex14 :: Assertion+ex14 = input `assertFormattedCols` output+  where+    assertFormattedCols =+      assertFormatted' (Just 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)"+      ]++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))"+      , "--------------------------------------------------------------------------------"+      ]++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++assertFormatted' :: HasCallStack => Maybe Int -> Lines -> Lines -> Assertion+assertFormatted' maxColumns input expected =+  withFrozenCallStack $ expected @=?? testStep' (step maxColumns felixOptions) input+  where+    felixOptions = defaultOptions+        { listAlign = Repeat+        }

@@ -5,9 +5,9 @@   ---------------------------------------------------------------------------------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, (@=?))   --------------------------------------------------------------------------------@@ -15,7 +15,6 @@ import           Language.Haskell.Stylish.Tests.Util  - -------------------------------------------------------------------------------- fromImportAlign :: ImportAlign -> Options fromImportAlign align = defaultOptions { importAlign = align }@@ -63,8 +62,8 @@   ---------------------------------------------------------------------------------input :: String-input = unlines+input :: Snippet+input = Snippet     [ "module Herp where"     , ""     , "import qualified Data.Map  as M"@@ -83,9 +82,9 @@  -------------------------------------------------------------------------------- case01 :: Assertion-case01 = expected @=? testStep (step (Just 80) $ fromImportAlign Global) input+case01 = expected @=? testSnippet (step (Just 80) $ fromImportAlign Global) input   where-    expected = unlines+    expected = Snippet         [ "module Herp where"         , ""         , "import           Control.Monad"@@ -105,9 +104,9 @@  -------------------------------------------------------------------------------- case02 :: Assertion-case02 = expected @=? testStep (step (Just 80) $ fromImportAlign Group) input+case02 = expected @=? testSnippet (step (Just 80) $ fromImportAlign Group) input   where-    expected = unlines+    expected = Snippet         [ "module Herp where"         , ""         , "import           Control.Monad"@@ -126,9 +125,9 @@  -------------------------------------------------------------------------------- case03 :: Assertion-case03 = expected @=? testStep (step (Just 80) $ fromImportAlign None) input+case03 = expected @=? testSnippet (step (Just 80) $ fromImportAlign None) input   where-    expected = unlines+    expected = Snippet         [ "module Herp where"         , ""         , "import Control.Monad"@@ -147,13 +146,13 @@  -------------------------------------------------------------------------------- case04 :: Assertion-case04 = expected @=? testStep (step (Just 80) $ fromImportAlign Global) input'+case04 = expected @=? testSnippet (step (Just 80) $ fromImportAlign Global) input'   where-    input' =+    input' = Snippet $ pure $         "import Data.Aeson.Types (object, typeMismatch, FromJSON(..)," ++         "ToJSON(..), Value(..), parseEither, (.!=), (.:), (.:?), (.=))" -    expected = unlines+    expected = Snippet         [ "import           Data.Aeson.Types (FromJSON (..), ToJSON (..), Value (..),"         , "                                   object, parseEither, typeMismatch, (.!=),"         , "                                   (.:), (.:?), (.=))"@@ -162,17 +161,18 @@  -------------------------------------------------------------------------------- case05 :: Assertion-case05 = input' @=? testStep (step (Just 80) $ fromImportAlign Group) input'+case05 = input' @=? testSnippet (step (Just 80) $ fromImportAlign Group) input'   where-    input' = "import Distribution.PackageDescription.Configuration " ++-        "(finalizePackageDescription)\n"+    -- Putting this on a different line shouldn't really help.+    input' = Snippet ["import Distribution.PackageDescription.Configuration " +++        "(finalizePackageDescription)"]   -------------------------------------------------------------------------------- case06 :: Assertion-case06 = input' @=? testStep (step (Just 80) $ fromImportAlign File) input'+case06 = input' @=? testStep' (step (Just 80) $ fromImportAlign File) input'   where-    input' = unlines+    input' =         [ "import Bar.Qux"         , "import Foo.Bar"         ]@@ -180,15 +180,16 @@  -------------------------------------------------------------------------------- case07 :: Assertion-case07 = expected @=? testStep (step (Just 80) $ fromImportAlign File) input'+case07 =+    expected @=? testSnippet (step (Just 80) $ fromImportAlign File) input'   where-    input' = unlines+    input' = Snippet         [ "import Bar.Qux"         , ""         , "import qualified Foo.Bar"         ] -    expected = unlines+    expected = Snippet         [ "import           Bar.Qux"         , ""         , "import qualified Foo.Bar"@@ -197,10 +198,13 @@  -------------------------------------------------------------------------------- case08 :: Assertion-case08 = expected-    @=? testStep (step (Just 80) $ Options Global WithAlias True Inline Inherit (LPConstant 4) True False) input+case08 =+  let+    options = Options Global WithAlias True Inline Inherit (LPConstant 4) True False+  in+    expected @=? testSnippet (step (Just 80) options) input   where-    expected = unlines+    expected = Snippet         [ "module Herp where"         , ""         , "import           Control.Monad"@@ -220,10 +224,13 @@  -------------------------------------------------------------------------------- case08b :: Assertion-case08b = expected-    @=? testStep (step (Just 80) $ Options Global WithModuleName True Inline Inherit (LPConstant 4) True False) input+case08b =+  let+    options = Options Global WithModuleName True Inline Inherit (LPConstant 4) True False+  in+    expected @=? testSnippet (step (Just 80) options) input   where-    expected = unlines+    expected = Snippet         ["module Herp where"         , ""         , "import           Control.Monad"@@ -242,10 +249,13 @@  -------------------------------------------------------------------------------- case09 :: Assertion-case09 = expected-    @=? testStep (step (Just 80) $ Options Global WithAlias True Multiline Inherit (LPConstant 4) True False) input+case09 =+  let+    options = Options Global WithAlias True Multiline Inherit (LPConstant 4) True False+  in+    expected @=? testSnippet (step (Just 80) options) input   where-    expected = unlines+    expected = Snippet         [ "module Herp where"         , ""         , "import           Control.Monad"@@ -276,10 +286,13 @@  -------------------------------------------------------------------------------- case10 :: Assertion-case10 = expected-    @=? testStep (step (Just 40) $ Options Group WithAlias True Multiline Inherit (LPConstant 4) True False) input+case10 =+  let+    options = Options Group WithAlias True Multiline Inherit (LPConstant 4) True False+  in+    expected @=? testSnippet (step (Just 40) options) input   where-    expected = unlines+    expected = Snippet         [ "module Herp where"         , ""         , "import           Control.Monad"@@ -313,12 +326,16 @@         ]  + -------------------------------------------------------------------------------- case11 :: Assertion-case11 = expected-    @=? testStep (step (Just 80) $ Options Group NewLine True Inline Inherit (LPConstant 4) True False) input+case11 =+  let+    options = Options Group NewLine True Inline Inherit (LPConstant 4) True False+  in+    expected @=? testSnippet (step (Just 80) options) input   where-    expected = unlines+    expected = Snippet         [ "module Herp where"         , ""         , "import           Control.Monad"@@ -342,10 +359,13 @@   case11b :: Assertion-case11b = expected-    @=? testStep (step (Just 80) $ Options Group WithModuleName True Inline Inherit (LPConstant 4) True False) input+case11b =+  let+    options = Options Group WithModuleName True Inline Inherit (LPConstant 4) True False+  in+    expected @=? testSnippet (step (Just 80) options) input   where-    expected = unlines+    expected = Snippet         [ "module Herp where"         , ""         , "import           Control.Monad"@@ -364,14 +384,17 @@  -------------------------------------------------------------------------------- case12 :: Assertion-case12 = expected-    @=? testStep (step (Just 80) $ Options Group NewLine True Inline Inherit (LPConstant 2) True False) input'+case12 =+  let+    options = Options Group NewLine True Inline Inherit (LPConstant 2) True False+  in+    expected @=? testSnippet (step (Just 80) options) input'   where-    input' = unlines+    input' = Snippet         [ "import Data.List (map)"         ] -    expected = unlines+    expected = Snippet         [ "import Data.List"         , "  (map)"         ]@@ -379,27 +402,31 @@  -------------------------------------------------------------------------------- case12b :: Assertion-case12b = expected-    @=? testStep (step (Just 80) $ Options Group WithModuleName True Inline Inherit (LPConstant 2) True False) input'+case12b =+  let+    options = Options Group WithModuleName True Inline Inherit (LPConstant 2) True False+  in+    expected @=? testStep' (step (Just 80) options) input'   where-    input' = unlines-        [ "import Data.List (map)"-        ]+    input' =  ["import Data.List (map)"]      expected = input'   -------------------------------------------------------------------------------- case13 :: Assertion-case13 = expected-    @=? testStep (step (Just 80) $ Options None WithAlias True InlineWithBreak Inherit (LPConstant 4) True False) input'+case13 =+  let+    options = Options None WithAlias True InlineWithBreak Inherit (LPConstant 4) True False+  in+    expected @=? testSnippet (step (Just 80) options) input'   where-    input' = unlines+    input' = Snippet         [ "import qualified Data.List as List (concat, foldl, foldr, head, init,"         , "    last, length, map, null, reverse, tail, (++))"         ] -    expected = unlines+    expected = Snippet         [ "import qualified Data.List as List"         , "    (concat, foldl, foldr, head, init, last, length, map, null, reverse, tail,"         , "    (++))"@@ -408,15 +435,18 @@  -------------------------------------------------------------------------------- case13b :: Assertion-case13b = expected-    @=? testStep (step (Just 80) $ Options None WithModuleName True InlineWithBreak Inherit (LPConstant 4) True False) input'+case13b =+  let+    options = Options None WithModuleName True InlineWithBreak Inherit (LPConstant 4) True False+  in+    expected @=? testSnippet (step (Just 80) options) input'   where-    input' = unlines+    input' = Snippet         [ "import qualified Data.List as List (concat, foldl, foldr, head, init,"         , "    last, length, map, null, reverse, tail, (++))"         ] -    expected = unlines+    expected = Snippet         [ "import qualified Data.List as List"         , "    (concat, foldl, foldr, head, init, last, length, map, null, reverse, tail,"         , "    (++))"@@ -425,21 +455,26 @@  -------------------------------------------------------------------------------- case14 :: Assertion-case14 = expected-    @=? testStep-      (step (Just 80) $ Options None WithAlias True InlineWithBreak Inherit (LPConstant 10) True False) expected+case14 =+  let+    options = Options None WithAlias True InlineWithBreak Inherit (LPConstant 10) True False+  in+    expected @=? testSnippet (step (Just 80) options) expected   where-    expected = unlines+    expected = Snippet         [ "import qualified Data.List as List (concat, map, null, reverse, tail, (++))"         ]   -------------------------------------------------------------------------------- case15 :: Assertion-case15 = expected-    @=? testStep (step (Just 80) $ Options None AfterAlias True Multiline Inherit (LPConstant 4) True False) input'+case15 =+  let+    options = Options None AfterAlias True Multiline Inherit (LPConstant 4) True False+  in+    expected @=? testSnippet (step (Just 80) options) input'   where-    expected = unlines+    expected = Snippet         [ "import Data.Acid (AcidState)"         , "import qualified Data.Acid as Acid"         , "    ( closeAcidState"@@ -451,7 +486,7 @@         , "import qualified Herp.Derp.Internal.Types.Foobar as Internal (bar, foo)"         ] -    input' = unlines+    input' = Snippet         [ "import Data.Acid (AcidState)"         , "import qualified Data.Acid as Acid (closeAcidState, createCheckpoint, openLocalStateFrom)"         , "import Data.Default.Class (Default (def))"@@ -462,10 +497,13 @@  -------------------------------------------------------------------------------- case16 :: Assertion-case16 = expected-    @=? testStep (step (Just 80) $ Options None AfterAlias True Multiline Inherit (LPConstant 4) False False) input'+case16 =+  let+    options = Options None AfterAlias True Multiline Inherit (LPConstant 4) False False+  in+    expected @=? testSnippet (step (Just 80) options) input'   where-    expected = unlines+    expected = Snippet         [ "import Data.Acid (AcidState)"         , "import Data.Default.Class (Default(def))"         , ""@@ -474,7 +512,7 @@         , "import Data.Foo (Foo(Bar, Foo), Goo(Goo))"         ] -    input' = unlines+    input' = Snippet         [ "import Data.Acid (AcidState)"         , "import Data.Default.Class (Default(def))"         , ""@@ -486,16 +524,19 @@  -------------------------------------------------------------------------------- case17 :: Assertion-case17 = expected-    @=? testStep (step (Just 80) $ Options None AfterAlias True Multiline Inherit (LPConstant 4) True False) input'+case17 =+  let+    options = Options None AfterAlias True Multiline Inherit (LPConstant 4) True False+  in+    expected @=? testSnippet (step (Just 80) options) input'   where-    expected = unlines+    expected = Snippet         [ "import Control.Applicative (Applicative (pure, (<*>)))"         , ""         , "import Data.Identity (Identity (Identity, runIdentity))"         ] -    input' = unlines+    input' = Snippet         [ "import Control.Applicative (Applicative ((<*>),pure))"         , ""         , "import Data.Identity (Identity (runIdentity,Identity))"@@ -504,10 +545,13 @@  -------------------------------------------------------------------------------- case18 :: Assertion-case18 = expected @=? testStep-    (step (Just 40) $ Options None AfterAlias True InlineToMultiline Inherit (LPConstant 4) True False) input'+case18 =+  let+    options = Options None AfterAlias True InlineToMultiline Inherit (LPConstant 4) True False+  in+    expected @=? testSnippet (step (Just 40) options) input'   where-    expected = unlines+    expected = Snippet            ----------------------------------------         [ "import Data.Foo as Foo (Bar, Baz, Foo)"         , ""@@ -521,7 +565,7 @@         , "    )"         ] -    input' = unlines+    input' = Snippet         [ "import Data.Foo as Foo (Bar, Baz, Foo)"         , ""         , "import Data.Identity (Identity (Identity, runIdentity))"@@ -532,10 +576,13 @@  -------------------------------------------------------------------------------- case19 :: Assertion-case19 = expected @=? testStep-    (step (Just 40) $ Options Global NewLine True InlineWithBreak RightAfter (LPConstant 17) True False) case19input+case19 =+  let+    options = Options Global NewLine True InlineWithBreak RightAfter (LPConstant 17) True False+  in+    expected @=? testSnippet (step (Just 40) options) case19input   where-    expected = unlines+    expected = Snippet            ----------------------------------------         [ "import           Prelude ()"         , "import           Prelude.Compat hiding"@@ -548,14 +595,16 @@   case19b :: Assertion-case19b = expected @=? testStep-    (step (Just 40) $ Options File NewLine True InlineWithBreak RightAfter (LPConstant 17) True False) case19input+case19b =+  let+    options = Options File NewLine True InlineWithBreak RightAfter (LPConstant 17) True False+  in+    expected @=? testSnippet (step (Just 40) options) case19input   where-    expected = unlines+    expected = Snippet            ----------------------------------------         [ "import Prelude ()"-        , "import Prelude.Compat hiding"-        , "                 (foldMap)"+        , "import Prelude.Compat hiding (foldMap)"         , ""         , "import Data.List"         , "                 (foldl', intercalate,"@@ -564,14 +613,16 @@   case19c :: Assertion-case19c = expected @=? testStep-    (step (Just 40) $ Options File NewLine True InlineWithBreak RightAfter LPModuleName True False) case19input+case19c =+  let+    options = Options File NewLine True InlineWithBreak RightAfter LPModuleName True False+  in+    expected @=? testSnippet (step (Just 40) options) case19input   where-    expected = unlines+    expected = Snippet            ----------------------------------------         [ "import Prelude ()"-        , "import Prelude.Compat hiding"-        , "       (foldMap)"+        , "import Prelude.Compat hiding (foldMap)"         , ""         , "import Data.List"         , "       (foldl', intercalate,"@@ -580,10 +631,13 @@   case19d :: Assertion-case19d = expected @=? testStep-    (step (Just 40) $ Options Global NewLine True InlineWithBreak RightAfter LPModuleName True False) case19input+case19d =+  let+    options = Options Global NewLine True InlineWithBreak RightAfter LPModuleName True False+  in+    expected @=? testSnippet (step (Just 40) options) case19input   where-    expected = unlines+    expected = Snippet            ----------------------------------------         [ "import           Prelude ()"         , "import           Prelude.Compat hiding"@@ -595,27 +649,27 @@         ]  -case19input :: String-case19input = unlines-        [ "import Prelude.Compat hiding (foldMap)"-        , "import Prelude ()"-        , ""-        , "import Data.List (foldl', intercalate, intersperse)"-        ]+case19input :: Snippet+case19input = Snippet+    [ "import Prelude.Compat hiding (foldMap)"+    , "import Prelude ()"+    , ""+    , "import Data.List (foldl', intercalate, intersperse)"+    ]   -------------------------------------------------------------------------------- case20 :: Assertion case20 = expected-    @=? testStep (step (Just 80) defaultOptions) input'+    @=? testSnippet (step (Just 80) defaultOptions) input'   where-    expected = unlines-        [ "import {-# SOURCE #-} Data.ByteString as BS"-        , "import qualified Data.Map        as Map"-        , "import           Data.Set        (empty)"+    expected = Snippet+        [ "import {-# SOURCE #-}           Data.ByteString as BS"+        , "import                qualified Data.Map        as Map"+        , "import                          Data.Set        (empty)"         , "import {-# SOURCE #-} qualified Data.Text       as T"         ]-    input' = unlines+    input' = Snippet         [ "import {-# SOURCE #-}    Data.ByteString as BS"         , "import {-# SOURCE #-} qualified Data.Text as T"         , "import qualified   Data.Map as Map"@@ -626,9 +680,9 @@ -------------------------------------------------------------------------------- case21 :: Assertion case21 = expected-    @=? testStep (step (Just 80) defaultOptions) input'+    @=? testSnippet (step (Just 80) defaultOptions) input'   where-    expected = unlines+    expected = Snippet         [ "{-# LANGUAGE ExplicitNamespaces #-}"         , "import           X1 (A, B, C)"         , "import           X2 (A, B, C)"@@ -640,7 +694,7 @@         , "import           X8 (type (+), (+))"         , "import           X9 hiding (x, y, z)"         ]-    input' = unlines+    input' = Snippet         [ "{-# LANGUAGE ExplicitNamespaces #-}"         , "import X1 (A, B, A, C, A, B, A)"         , "import X2 (C(), B(), A())"@@ -657,9 +711,9 @@ -------------------------------------------------------------------------------- case22 :: Assertion case22 = expected-    @=? testStep (step (Just 80) defaultOptions) input'+    @=? testSnippet (step (Just 80) defaultOptions) input'   where-    expected = unlines+    expected = Snippet         [ "{-# LANGUAGE PackageImports #-}"         , "import           A"         , "import           \"blah\" A"@@ -668,7 +722,7 @@         , "import           \"foo\" B  (shortName, someLongName, someLongerName,"         , "                           theLongestNameYet)"         ]-    input' = unlines+    input' = Snippet         [ "{-# LANGUAGE PackageImports #-}"         , "import A"         , "import \"foo\" A"@@ -683,10 +737,14 @@  -------------------------------------------------------------------------------- case23 :: Assertion-case23 = expected-    @=? testStep (step (Just 40) $ Options None AfterAlias False Inline Inherit (LPConstant 4) True True) input'+case23 =+  let+    options = Options None AfterAlias False Inline Inherit (LPConstant 4) True True+  in+    expected @=? testSnippet (step (Just 40) options) input'   where-    expected = unlines+    expected = Snippet+           ----------------------------------------         [ "import Data.Acid ( AcidState )"         , "import Data.Default.Class ( Default (def) )"         , ""@@ -696,7 +754,7 @@         , "                            Goo )"         ] -    input' = unlines+    input' = Snippet         [ "import Data.Acid (AcidState)"         , "import Data.Default.Class (Default(def))"         , ""@@ -708,10 +766,14 @@  -------------------------------------------------------------------------------- case23b :: Assertion-case23b = expected-    @=? testStep (step (Just 40) $ Options None WithModuleName False Inline Inherit (LPConstant 4) True True) input'+case23b =+  let+    options = Options None WithModuleName False Inline Inherit (LPConstant 4) True True+  in+    expected @=? testSnippet (step (Just 40) options) input'   where-    expected = unlines+    expected = Snippet+           ----------------------------------------         [ "import Data.Acid ( AcidState )"         , "import Data.Default.Class"         , "           ( Default (def) )"@@ -722,7 +784,7 @@         , "           Goo )"         ] -    input' = unlines+    input' = Snippet         [ "import Data.Acid (AcidState)"         , "import Data.Default.Class (Default(def))"         , ""@@ -734,10 +796,14 @@  -------------------------------------------------------------------------------- case24 :: Assertion-case24 = expected-    @=? testStep (step (Just 40) $ Options None AfterAlias False InlineWithBreak Inherit (LPConstant 4) True True) input'+case24 =+  let+    options = Options None AfterAlias False InlineWithBreak Inherit (LPConstant 4) True True+  in+    expected @=? testSnippet (step (Just 40) options) input'   where-    expected = unlines+    expected = Snippet+           ----------------------------------------         [ "import Data.Acid ( AcidState )"         , "import Data.Default.Class"         , "    ( Default (def) )"@@ -747,7 +813,7 @@         , "    GooReallyLong )"         ] -    input' = unlines+    input' = Snippet         [ "import Data.Acid (AcidState)"         , "import Data.Default.Class (Default(def))"         , ""@@ -758,10 +824,13 @@  -------------------------------------------------------------------------------- case25 :: Assertion-case25 = expected-    @=? testStep (step (Just 80) $ Options Group AfterAlias False Multiline Inherit (LPConstant 4) False False) input'+case25 =+  let+    options = Options Group AfterAlias False Multiline Inherit (LPConstant 4) False False+  in+    expected @=? testSnippet (step (Just 80) options) input'   where-    expected = unlines+    expected = Snippet         [ "import Data.Acid (AcidState)"         , "import Data.Default.Class (Default(def))"         , ""@@ -770,7 +839,7 @@         , ""         , "import Data.Foo (Foo(Bar, Foo), Goo(Goo))"         ]-    input' = unlines+    input' = Snippet         [ "import Data.Acid (AcidState)"         , "import Data.Default.Class (Default(def))"         , ""@@ -784,22 +853,18 @@ -------------------------------------------------------------------------------- case26 :: Assertion case26 = expected-    @=? testStep (step (Just 80) options ) input'+    @=? testSnippet (step (Just 80) options ) input'   where     options = defaultOptions { listAlign = NewLine, longListAlign = Multiline }-    input' = unlines-        [ "import Data.List"-        ]-    expected = unlines-        [ "import           Data.List"-        ]+    input' = Snippet ["import Data.List"]+    expected = Snippet ["import           Data.List"]   -------------------------------------------------------------------------------- case27 :: Assertion-case27 = expected @=? testStep (step Nothing $ fromImportAlign Global) input+case27 = expected @=? testSnippet (step Nothing $ fromImportAlign Global) input   where-    expected = unlines+    expected = Snippet         [ "module Herp where"         , ""         , "import           Control.Monad"

@@ -1,4 +1,5 @@ --------------------------------------------------------------------------------+{-# LANGUAGE OverloadedLists #-} module Language.Haskell.Stylish.Step.LanguagePragmas.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)   --------------------------------------------------------------------------------@@ -30,6 +31,7 @@     , testCase "case 10" case10     , testCase "case 11" case11     , testCase "case 12" case12+    , testCase "case 13" case13     ]  lANG :: String@@ -37,202 +39,191 @@  -------------------------------------------------------------------------------- case01 :: Assertion-case01 = expected @=? testStep (step (Just 80) Vertical True False lANG) input-  where-    input = unlines-        [ "{-# LANGUAGE ViewPatterns #-}"-        , "{-# LANGUAGE TemplateHaskell, ViewPatterns #-}"-        , "{-# LANGUAGE ScopedTypeVariables #-}"-        , "module Main where"-        ]+case01 = assertSnippet+    (step (Just 80) Vertical True False lANG)+    [ "{-# LANGUAGE ViewPatterns #-}"+    , "{-# LANGUAGE TemplateHaskell, ViewPatterns #-}"+    , "{-# LANGUAGE ScopedTypeVariables #-}"+    , "module Main where"+    ] -    expected = unlines-        [ "{-# LANGUAGE ScopedTypeVariables #-}"-        , "{-# LANGUAGE TemplateHaskell     #-}"-        , "{-# LANGUAGE ViewPatterns        #-}"-        , "module Main where"-        ]+    [ "{-# LANGUAGE ScopedTypeVariables #-}"+    , "{-# LANGUAGE TemplateHaskell     #-}"+    , "{-# LANGUAGE ViewPatterns        #-}"+    , "module Main where"+    ]   -------------------------------------------------------------------------------- case02 :: Assertion-case02 = expected @=? testStep (step (Just 80) Vertical True True lANG) input-  where-    input = unlines-        [ "{-# LANGUAGE BangPatterns #-}"-        , "{-# LANGUAGE ViewPatterns #-}"-        , "increment ((+ 1) -> x) = x"-        ]+case02 = assertSnippet+    (step (Just 80) Vertical True True lANG)+    [ "{-# LANGUAGE BangPatterns #-}"+    , "{-# LANGUAGE ViewPatterns #-}"+    , "increment ((+ 1) -> x) = x"+    ] -    expected = unlines-        [ "{-# LANGUAGE ViewPatterns #-}"-        , "increment ((+ 1) -> x) = x"-        ]+    [ "{-# LANGUAGE ViewPatterns #-}"+    , "increment ((+ 1) -> x) = x"+    ]   -------------------------------------------------------------------------------- case03 :: Assertion-case03 = expected @=? testStep (step (Just 80) Vertical True True lANG) input-  where-    input = unlines-        [ "{-# LANGUAGE BangPatterns #-}"-        , "{-# LANGUAGE ViewPatterns #-}"-        , "increment x = case x of !_ -> x + 1"-        ]+case03 = assertSnippet+    (step (Just 80) Vertical True True lANG)+    [ "{-# LANGUAGE BangPatterns #-}"+    , "{-# LANGUAGE ViewPatterns #-}"+    , "increment x = case x of !_ -> x + 1"+    ] -    expected = unlines-        [ "{-# LANGUAGE BangPatterns #-}"-        , "increment x = case x of !_ -> x + 1"-        ]+    [ "{-# LANGUAGE BangPatterns #-}"+    , "increment x = case x of !_ -> x + 1"+    ]   -------------------------------------------------------------------------------- case04 :: Assertion-case04 = expected @=? testStep (step (Just 80) Compact True False lANG) input-  where-    input = unlines-        [ "{-# LANGUAGE TypeOperators, StandaloneDeriving, DeriveDataTypeable,"-        , "    TemplateHaskell #-}"-        , "{-# LANGUAGE TemplateHaskell, ViewPatterns #-}"-        ]+case04 = assertSnippet+    (step (Just 80) Compact True False lANG)+    [ "{-# LANGUAGE TypeOperators, StandaloneDeriving, DeriveDataTypeable,"+    , "    TemplateHaskell #-}"+    , "{-# LANGUAGE TemplateHaskell, ViewPatterns #-}"+    ] -    expected = unlines-        [ "{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving, " ++-            "TemplateHaskell,"-        , "             TypeOperators, ViewPatterns #-}"-        ]+    [ "{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving, " +++        "TemplateHaskell,"+    , "             TypeOperators, ViewPatterns #-}"+    ]   -------------------------------------------------------------------------------- case05 :: Assertion-case05 = expected @=? testStep (step (Just 80) Vertical True False lANG) input-  where-    input = unlines-        [ "{-# LANGUAGE CPP #-}"-        , ""-        , "#if __GLASGOW_HASKELL__ >= 702"-        , "{-# LANGUAGE Trustworthy #-}"-        , "#endif"-        ]+case05 = assertSnippet+    (step (Just 80) Vertical True False lANG)+    [ "{-# LANGUAGE CPP #-}"+    , ""+    , "#if __GLASGOW_HASKELL__ >= 702"+    , "{-# LANGUAGE Trustworthy #-}"+    , "#endif"+    ] -    expected = unlines-        [ "{-# LANGUAGE CPP         #-}"-        , ""-        , "#if __GLASGOW_HASKELL__ >= 702"-        , "{-# LANGUAGE Trustworthy #-}"-        , "#endif"-        ]+    [ "{-# LANGUAGE CPP         #-}"+    , ""+    , "#if __GLASGOW_HASKELL__ >= 702"+    , "{-# LANGUAGE Trustworthy #-}"+    , "#endif"+    ]   -------------------------------------------------------------------------------- case06 :: Assertion-case06 = expected @=? testStep (step (Just 80) CompactLine True False lANG) input-  where-    input = unlines-        [ "{-# LANGUAGE TypeOperators, StandaloneDeriving, DeriveDataTypeable,"-        , "    TemplateHaskell #-}"-        , "{-# LANGUAGE TemplateHaskell, ViewPatterns #-}"-        ]-    expected = unlines-        [ "{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving, " ++-          "TemplateHaskell #-}"-        , "{-# LANGUAGE TypeOperators, ViewPatterns                             #-}"-        ]+case06 = assertSnippet+    (step (Just 80) CompactLine True False lANG)+    [ "{-# LANGUAGE TypeOperators, StandaloneDeriving, DeriveDataTypeable,"+    , "    TemplateHaskell #-}"+    , "{-# LANGUAGE TemplateHaskell, ViewPatterns #-}"+    ]+    [ "{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving, " +++      "TemplateHaskell #-}"+    , "{-# LANGUAGE TypeOperators, ViewPatterns                             #-}"+    ]  -------------------------------------------------------------------------------- case07 :: Assertion-case07 = expected @=? testStep (step (Just 80) Vertical False False lANG) input-  where-    input = unlines-        [ "{-# LANGUAGE ViewPatterns #-}"-        , "{-# LANGUAGE TemplateHaskell, ViewPatterns #-}"-        , "{-# LANGUAGE ScopedTypeVariables, NoImplicitPrelude #-}"-        , "module Main where"-        ]+case07 = assertSnippet+    (step (Just 80) Vertical False False lANG)+    [ "{-# LANGUAGE ViewPatterns #-}"+    , "{-# LANGUAGE TemplateHaskell, ViewPatterns #-}"+    , "{-# LANGUAGE ScopedTypeVariables, NoImplicitPrelude #-}"+    , "module Main where"+    ] -    expected = unlines-        [ "{-# LANGUAGE NoImplicitPrelude #-}"-        , "{-# LANGUAGE ScopedTypeVariables #-}"-        , "{-# LANGUAGE TemplateHaskell #-}"-        , "{-# LANGUAGE ViewPatterns #-}"-        , "module Main where"-        ]+    [ "{-# LANGUAGE NoImplicitPrelude #-}"+    , "{-# LANGUAGE ScopedTypeVariables #-}"+    , "{-# LANGUAGE TemplateHaskell #-}"+    , "{-# LANGUAGE ViewPatterns #-}"+    , "module Main where"+    ]   -------------------------------------------------------------------------------- case08 :: Assertion-case08 = expected @=? testStep (step (Just 80) CompactLine False False lANG) input-  where-    input = unlines-        [ "{-# LANGUAGE TypeOperators, StandaloneDeriving, DeriveDataTypeable,"-        , "    TemplateHaskell #-}"-        , "{-# LANGUAGE TemplateHaskell, ViewPatterns #-}"-        ]-    expected = unlines-        [ "{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving, " ++-          "TemplateHaskell #-}"-        , "{-# LANGUAGE TypeOperators, ViewPatterns #-}"-        ]+case08 = assertSnippet+    (step (Just 80) CompactLine False False lANG)+    [ "{-# LANGUAGE TypeOperators, StandaloneDeriving, DeriveDataTypeable,"+    , "    TemplateHaskell #-}"+    , "{-# LANGUAGE TemplateHaskell, ViewPatterns #-}"+    ]+    [ "{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving, " +++      "TemplateHaskell #-}"+    , "{-# LANGUAGE TypeOperators, ViewPatterns #-}"+    ]   -------------------------------------------------------------------------------- case09 :: Assertion-case09 = expected @=? testStep (step (Just 80) Compact True False lANG) input-  where-    input = unlines-        [ "{-# LANGUAGE DefaultSignatures, FlexibleInstances, LambdaCase, " ++-          "TypeApplications"-        , "             #-}"-        ]-    expected = unlines-        [ "{-# LANGUAGE DefaultSignatures, FlexibleInstances, LambdaCase,"-        , "             TypeApplications #-}"-        ]+case09 = assertSnippet+    (step (Just 80) Compact True False lANG)+    [ "{-# LANGUAGE DefaultSignatures, FlexibleInstances, LambdaCase, " +++      "TypeApplications"+    , "             #-}"+    ]+    [ "{-# LANGUAGE DefaultSignatures, FlexibleInstances, LambdaCase,"+    , "             TypeApplications #-}"+    ]  -------------------------------------------------------------------------------- case10 :: Assertion-case10 = expected @=? testStep (step (Just 80) Compact True False lANG) input-  where-    input = unlines-        [ "{-# LANGUAGE NondecreasingIndentation, ScopedTypeVariables,"-        , "             TypeApplications #-}"-        ]-    expected = unlines-        [ "{-# LANGUAGE NondecreasingIndentation, ScopedTypeVariables, " ++-          "TypeApplications #-}"-        ]+case10 = assertSnippet+    (step (Just 80) Compact True False lANG)+    [ "{-# LANGUAGE NondecreasingIndentation, ScopedTypeVariables,"+    , "             TypeApplications #-}"+    ]+    [ "{-# LANGUAGE NondecreasingIndentation, ScopedTypeVariables, " +++      "TypeApplications #-}"+    ]  -------------------------------------------------------------------------------- case11 :: Assertion-case11 = expected @=? testStep (step (Just 80) Vertical False False "language") input-  where-    input = unlines-        [ "{-# LANGUAGE ViewPatterns #-}"-        , "{-# LANGUAGE TemplateHaskell, ViewPatterns #-}"-        , "{-# LANGUAGE ScopedTypeVariables, NoImplicitPrelude #-}"-        , "module Main where"-        ]+case11 = assertSnippet+    (step (Just 80) Vertical False False "language")+    [ "{-# LANGUAGE ViewPatterns #-}"+    , "{-# LANGUAGE TemplateHaskell, ViewPatterns #-}"+    , "{-# LANGUAGE ScopedTypeVariables, NoImplicitPrelude #-}"+    , "module Main where"+    ] -    expected = unlines-        [ "{-# language NoImplicitPrelude #-}"-        , "{-# language ScopedTypeVariables #-}"-        , "{-# language TemplateHaskell #-}"-        , "{-# language ViewPatterns #-}"-        , "module Main where"-        ]+    [ "{-# language NoImplicitPrelude #-}"+    , "{-# language ScopedTypeVariables #-}"+    , "{-# language TemplateHaskell #-}"+    , "{-# language ViewPatterns #-}"+    , "module Main where"+    ] + -------------------------------------------------------------------------------- case12 :: Assertion-case12 = expected @=? testStep (step Nothing Compact False False "language") input-  where-    input = unlines-        [ "{-# LANGUAGE ViewPatterns, OverloadedStrings #-}"-        , "{-# LANGUAGE TemplateHaskell, ViewPatterns #-}"-        , "{-# LANGUAGE ScopedTypeVariables, NoImplicitPrelude #-}"-        , "module Main where"-        ]+case12 = assertSnippet+    (step Nothing Compact False False "language")+    [ "{-# LANGUAGE ViewPatterns, OverloadedStrings #-}"+    , "{-# LANGUAGE TemplateHaskell, ViewPatterns #-}"+    , "{-# LANGUAGE ScopedTypeVariables, NoImplicitPrelude #-}"+    , "module Main where"+    ] -    expected = unlines-        [ "{-# language NoImplicitPrelude, OverloadedStrings, ScopedTypeVariables, TemplateHaskell, ViewPatterns #-}"-        , "module Main where"+    [ "{-# language NoImplicitPrelude, OverloadedStrings, ScopedTypeVariables, TemplateHaskell, ViewPatterns #-}"+    , "module Main where"+    ]+++--------------------------------------------------------------------------------+case13 :: Assertion+case13 = assertSnippet+    (step Nothing Vertical True True lANG) input input+  where+    input =+        [ "{-# LANGUAGE BangPatterns  #-}"+        , "{-# LANGUAGE DeriveFunctor #-}"+        , "main = let !x = 1 + 1 in print x"         ]

@@ -0,0 +1,301 @@+{-# LANGUAGE OverloadedLists #-}+module Language.Haskell.Stylish.Step.ModuleHeader.Tests+  ( tests+  ) where++--------------------------------------------------------------------------------+import           Prelude                                    hiding (lines)+import           Test.Framework                             (Test, testGroup)+import           Test.Framework.Providers.HUnit             (testCase)+import           Test.HUnit                                 (Assertion)++--------------------------------------------------------------------------------+import           Language.Haskell.Stylish.Step.ModuleHeader+import           Language.Haskell.Stylish.Tests.Util+++--------------------------------------------------------------------------------+tests :: Test+tests = testGroup "Language.Haskell.Stylish.Printer.ModuleHeader"+    [ testCase "Hello world" ex0+    , testCase "Empty exports list" ex1+    , testCase "Single exported variable" ex2+    , testCase "Multiple exported variables" ex3+    , testCase "Only reformats module header" ex4+    , testCase "Leaving pragmas in place" ex5+    , testCase "Leaving pragmas in place variant" ex6+    , testCase "Leaving comments in place" ex7+    , testCase "Exports all" ex8+    , testCase "Exports module" ex9+    , testCase "Exports symbol" ex10+    , testCase "Respects groups" ex11+    , testCase "'where' not repeated in case it isn't part of exports" ex12+    , testCase "Indents absent export list with 2 spaces" ex13+    , testCase "Indents with 2 spaces" ex14+    , testCase "Group doc with 2 spaces" ex15+    , testCase "Does not sort" ex16+    ]++--------------------------------------------------------------------------------+ex0 :: Assertion+ex0 = assertSnippet (step defaultConfig)+    [ "module Foo where"+    ]+    [ "module Foo"+    , "    where"+    ]++ex1 :: Assertion+ex1 = assertSnippet (step defaultConfig)+    [ "module Foo () where"+    ]+    [ "module Foo"+    , "    ("+    , "    ) where"+    ]++ex2 :: Assertion+ex2 = assertSnippet (step defaultConfig)+    [ "module Foo (tests) where"+    ]+    [ "module Foo"+    , "    ( tests"+    , "    ) where"+    ]++ex3 :: Assertion+ex3 = assertSnippet (step defaultConfig)+    [ "module Foo (t1, t2, t3) where"+    ]+    [ "module Foo"+    , "    ( t1"+    , "    , t2"+    , "    , t3"+    , "    ) where"+    ]++ex4 :: Assertion+ex4 = assertSnippet (step defaultConfig)+    [ "module Foo ("+    , "  t1,"+    , "  t3,"+    , "  t2"+    , ") where"+    , ""+    , ""+    , "-- | Docstring"+    , "foo :: Int"+    , "foo = 1"+    ]+    [ "module Foo"+    , "    ( t1"+    , "    , t2"+    , "    , t3"+    , "    ) where"+    , ""+    , ""+    , "-- | Docstring"+    , "foo :: Int"+    , "foo = 1"+    ]++ex5 :: Assertion+ex5 = assertSnippet (step defaultConfig)+    [ "{-# LANGUAGE DerivingVia #-}"+    , "-- | This module docs"+    , "module Foo ("+    , "  t1,"+    , "  t3,"+    , "  t2"+    , ") where"+    ]+    [ "{-# LANGUAGE DerivingVia #-}"+    , "-- | This module docs"+    , "module Foo"+    , "    ( t1"+    , "    , t2"+    , "    , t3"+    , "    ) where"+    ]++ex6 :: Assertion+ex6 = assertSnippet (step defaultConfig)+    [ "-- | This module docs"+    , "{-# LANGUAGE DerivingVia #-}"+    , "module Foo ("+    , "    t1,"+    , "    t3,"+    , "    t2"+    , ") where"+    ]+    [ "-- | This module docs"+    , "{-# LANGUAGE DerivingVia #-}"+    , "module Foo"+    , "    ( t1"+    , "    , t2"+    , "    , t3"+    , "    ) where"+    ]++ex7 :: Assertion+ex7 = assertSnippet (step defaultConfig)+    [ "module Foo -- Foo"+    , "("+    , " -- * t1 something"+    , "  t3,"+    , "  t1,"+    , " -- * t2 something"+    , "  t2"+    , ") where -- x"+    , "-- y"+    ]+    [ "module Foo -- Foo"+    , "    ( -- * t1 something"+    , "      t1"+    , "    , t3"+    , "      -- * t2 something"+    , "    , t2"+    , "    ) where -- x"+    , "-- y"+    ]+++ex8 :: Assertion+ex8 = assertSnippet (step defaultConfig)+    [ "module Foo ("+    , " -- * t1 something"+    , "  t3,"+    , "  A(..),"+    , " -- * t2 something"+    , "  t2,"+    , "  t1"+    , ") where -- x"+    , "-- y"+    ]+    [ "module Foo"+    , "    ( -- * t1 something"+    , "      A (..)"+    , "    , t3"+    , "      -- * t2 something"+    , "    , t1"+    , "    , t2"+    , "    ) where -- x"+    , "-- y"+    ]++ex9 :: Assertion+ex9 = assertSnippet (step defaultConfig)+    [ "module Foo ("+    , " -- * t1 something"+    , "  module A,"+    , "  t3,"+    , " -- * t2 something"+    , "  t2"+    , ") where -- x"+    , "-- y"+    ]+    [ "module Foo"+    , "    ( -- * t1 something"+    , "      module A"+    , "    , t3"+    , "      -- * t2 something"+    , "    , t2"+    , "    ) where -- x"+    , "-- y"+    ]++ex10 :: Assertion+ex10 = assertSnippet (step defaultConfig)+    [ "module Foo ("+    , "  (<&>)"+    , ") where -- x"+    , "-- y"+    ]+    [ "module Foo"+    , "    ( (<&>)"+    , "    ) where -- x"+    , "-- y"+    ]++ex11 :: Assertion+ex11 = assertSnippet (step defaultConfig)+    [ "module Foo ("+    , "  -- group 1"+    , " g1_1,"+    , " g1_0,"+    , "  -- group 2"+    , " g0_1,"+    , " g0_0"+    , ") where"+    ]+    [ "module Foo"+    , "    ( -- group 1"+    , "      g1_0"+    , "    , g1_1"+    , "      -- group 2"+    , "    , g0_0"+    , "    , g0_1"+    , "    ) where"+    ]++ex12 :: Assertion+ex12 = assertSnippet (step defaultConfig)+    [ "module Foo"+    , "  where"+    , "-- hmm"+    ]+    [ "module Foo"+    , "    where"+    , "-- hmm"+    ]++ex13 :: Assertion+ex13 = assertSnippet (step defaultConfig {indent = 2})+    [ "module Foo where"+    ]+    [ "module Foo"+    , "  where"+    ]++ex14 :: Assertion+ex14 = assertSnippet (step defaultConfig {indent = 2})+    [ "module Foo"+    , "  ( yes"+    , "  , no"+    , "  ) where"+    ]+    [ "module Foo"+    , "  ( no"+    , "  , yes"+    , "  ) where"+    ]++ex15 :: Assertion+ex15 = assertSnippet (step defaultConfig {indent = 2})+    [ "module Foo -- Foo"+    , "("+    , " -- * t1 something"+    , "  t3,"+    , "  t1,"+    , " -- * t2 something"+    , "  t2"+    , ") where"+    ]+    [ "module Foo -- Foo"+    , "  ( -- * t1 something"+    , "    t1"+    , "  , t3"+    , "    -- * t2 something"+    , "  , t2"+    , "  ) where"+    ]++ex16 :: Assertion+ex16 = assertSnippet (step defaultConfig {sort = False}) input input+  where+    input =+      [ "module Foo"+      , "    ( yes"+      , "    , no"+      , "    ) where"+      ]

@@ -1,4 +1,5 @@ --------------------------------------------------------------------------------+{-# LANGUAGE OverloadedLists #-} module Language.Haskell.Stylish.Step.SimpleAlign.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)   --------------------------------------------------------------------------------@@ -27,81 +28,68 @@     , testCase "case 07" case07     , testCase "case 08" case08     , testCase "case 09" case09+    , testCase "case 10" case10+    , testCase "case 11" case11+    , testCase "case 12" case12     ]   -------------------------------------------------------------------------------- case01 :: Assertion-case01 = expected @=? testStep (step (Just 80) defaultConfig) input-  where-    input = unlines-        [ "eitherToMaybe e = case e of"-        , "    Left _ -> Nothing"-        , "    Right x -> Just x"-        ]--    expected = unlines-        [ "eitherToMaybe e = case e of"-        , "    Left _  -> Nothing"-        , "    Right x -> Just x"-        ]+case01 = assertSnippet (step (Just 80) defaultConfig)+    [ "eitherToMaybe e = case e of"+    , "    Left _ -> Nothing"+    , "    Right x -> Just x"+    ]+    [ "eitherToMaybe e = case e of"+    , "    Left _  -> Nothing"+    , "    Right x -> Just x"+    ]   -------------------------------------------------------------------------------- case02 :: Assertion-case02 = expected @=? testStep (step (Just 80) defaultConfig) input-  where-    input = unlines-        [ "eitherToMaybe (Left _) = Nothing"-        , "eitherToMaybe (Right x) = Just x"-        ]--    expected = unlines-        [ "eitherToMaybe (Left _)  = Nothing"-        , "eitherToMaybe (Right x) = Just x"-        ]+case02 = assertSnippet (step (Just 80) defaultConfig)+    [ "eitherToMaybe (Left _) = Nothing"+    , "eitherToMaybe (Right x) = Just x"+    ]+    [ "eitherToMaybe (Left _)  = Nothing"+    , "eitherToMaybe (Right x) = Just x"+    ]   -------------------------------------------------------------------------------- case03 :: Assertion-case03 = expected @=? testStep (step (Just 80) defaultConfig) input-  where-    input = unlines-        [ "heady def [] = def"-        , "heady _ (x : _) = x"-        ]--    expected = unlines-        [ "heady def []    = def"-        , "heady _ (x : _) = x"-        ]+case03 = assertSnippet (step (Just 80) defaultConfig)+    [ "heady def [] = def"+    , "heady _ (x : _) = x"+    ]+    [ "heady def []    = def"+    , "heady _ (x : _) = x"+    ]   -------------------------------------------------------------------------------- case04 :: Assertion-case04 = expected @=? testStep (step (Just 80) defaultConfig) input-  where-    input = unlines-        [ "data Foo = Foo"-        , "    { foo :: Int"-        , "    , barqux :: String"-        , "    } deriving (Show)"-        ]--    expected = unlines-        [ "data Foo = Foo"-        , "    { foo    :: Int"-        , "    , barqux :: String"-        , "    } deriving (Show)"-        ]+case04 = assertSnippet (step (Just 80) defaultConfig)+    [ "data Foo = Foo"+    , "    { foo :: Int"+    , "    , barqux :: String"+    , "    } deriving (Show)"+    ]+    [ "data Foo = Foo"+    , "    { foo    :: Int"+    , "    , barqux :: String"+    , "    } deriving (Show)"+    ]   -------------------------------------------------------------------------------- case05 :: Assertion-case05 = input @=? testStep (step (Just 80) defaultConfig) input+case05 = assertSnippet (step (Just 80) defaultConfig) input input   where     -- Don't attempt to align this since a field spans multiple lines-    input = unlines+    input =         [ "data Foo = Foo"         , "    { foo :: Int"         , "    , barqux"@@ -112,78 +100,102 @@  -------------------------------------------------------------------------------- case06 :: Assertion-case06 =+case06 = assertSnippet     -- 22 max columns is /just/ enough to align this stuff.-    expected @=? testStep (step (Just 22) defaultConfig) input-  where-    input = unlines-        [ "data Foo = Foo"-        , "    { foo :: String"-        , "    , barqux :: Int"-        , "    }"-        ]--    expected = unlines-        [ "data Foo = Foo"-        , "    { foo    :: String"-        , "    , barqux :: Int"-        , "    }"-        ]+    (step (Just 22) defaultConfig)+    [ "data Foo = Foo"+    , "    { foo :: String"+    , "    , barqux :: Int"+    , "    }"+    ]+    [ "data Foo = Foo"+    , "    { foo    :: String"+    , "    , barqux :: Int"+    , "    }"+    ]   -------------------------------------------------------------------------------- case07 :: Assertion-case07 =+case07 = assertSnippet     -- 21 max columns is /just NOT/ enough to align this stuff.-    expected @=? testStep (step (Just 21) defaultConfig) input-  where-    input = unlines-        [ "data Foo = Foo"-        , "    { foo :: String"-        , "    , barqux :: Int"-        , "    }"-        ]--    expected = unlines-        [ "data Foo = Foo"-        , "    { foo :: String"-        , "    , barqux :: Int"-        , "    }"-        ]+    (step (Just 21) defaultConfig)+    [ "data Foo = Foo"+    , "    { foo :: String"+    , "    , barqux :: Int"+    , "    }"+    ]+    [ "data Foo = Foo"+    , "    { foo :: String"+    , "    , barqux :: Int"+    , "    }"+    ]   -------------------------------------------------------------------------------- case08 :: Assertion-case08 = expected @=? testStep (step (Just 80) defaultConfig) input-  where-    input = unlines-        [ "canDrink mbAge = case mbAge of"-        , "    Just age | age > 18 -> True"-        , "    _ -> False"-        ]--    expected = unlines-        [ "canDrink mbAge = case mbAge of"-        , "    Just age | age > 18 -> True"-        , "    _                   -> False"-        ]+case08 = assertSnippet (step (Just 80) defaultConfig)+    [ "canDrink mbAge = case mbAge of"+    , "    Just age | age > 18 -> True"+    , "    _ -> False"+    ]+    [ "canDrink mbAge = case mbAge of"+    , "    Just age | age > 18 -> True"+    , "    _                   -> False"+    ]   -------------------------------------------------------------------------------- case09 :: Assertion-case09 =-    expected @=? testStep (step Nothing defaultConfig) input-  where-    input = unlines-        [ "data Foo = Foo"-        , "    { foo :: String"-        , "    , barqux :: Int"-        , "    }"-        ]+case09 = assertSnippet (step Nothing defaultConfig)+    [ "data Foo = Foo"+    , "    { foo :: String"+    , "    , barqux :: Int"+    , "    }"+    ]+    [ "data Foo = Foo"+    , "    { foo    :: String"+    , "    , barqux :: Int"+    , "    }"+    ] -    expected = unlines-        [ "data Foo = Foo"-        , "    { foo    :: String"-        , "    , barqux :: Int"-        , "    }"++--------------------------------------------------------------------------------+case10 :: Assertion+case10 = assertSnippet (step Nothing defaultConfig)+    [ "padQual  = case align' of"+    , "  Global -> True"+    , "  File    -> fileAlign"+    , "  Group    -> anyQual"+    ]+    [ "padQual  = case align' of"+    , "  Global -> True"+    , "  File   -> fileAlign"+    , "  Group  -> anyQual"+    ]+++--------------------------------------------------------------------------------+case11 :: Assertion+case11 = assertSnippet (step Nothing defaultConfig)+    [ "data Foo = Foo"+    , "    { foo  :: String"+    , "    , barqux  :: !Int"+    , "    }"+    ]+    [ "data Foo = Foo"+    , "    { foo    :: String"+    , "    , barqux :: !Int"+    , "    }"+    ]+++--------------------------------------------------------------------------------+case12 :: Assertion+case12 = assertSnippet (step Nothing defaultConfig {cCases = False}) input input+  where+    input =+        [ "case x of"+        , "  Just y -> 1"+        , "  Nothing -> 2"         ]

@@ -49,6 +49,7 @@         , "      first_field: \"indent 2\""         , "      field_comment: 2"         , "      deriving: 2"+        , "      via: \"indent 2\""         ]      actual <- format (Just $ ConfigPath "test-config.yaml") Nothing input@@ -73,6 +74,7 @@         , "      first_field: \"same_line\""         , "      field_comment: 2"         , "      deriving: 2"+        , "      via: \"indent 2\""         ]      actual <- format (Just $ ConfigPath "test-config.yaml") Nothing input@@ -98,10 +100,8 @@     fileLocation = "directory/File.hs"     input = "module Herp"     result = Left $-      "Language.Haskell.Stylish.Parse.parseModule: could not parse " <>-      fileLocation <>-      ": ParseFailed (SrcLoc \"<unknown>.hs\" 2 1) \"Parse error: EOF\""-+      fileLocation <> ": RealSrcSpan SrcSpanPoint \"directory/File.hs\" 2 1:" +      <> " parse error (possibly incorrect indentation or mismatched brackets)\n"  -------------------------------------------------------------------------------- -- | When providing current dir including folders and files.

@@ -1,11 +1,21 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE TypeFamilies   #-} module Language.Haskell.Stylish.Tests.Util     ( 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           System.Directory               (createDirectory,                                                  getCurrentDirectory,                                                  getTemporaryDirectory,@@ -14,6 +24,8 @@ import           System.FilePath                ((</>)) import           System.IO.Error                (isAlreadyExistsError) import           System.Random                  (randomIO)+import           Test.HUnit                     (Assertion, assertFailure,+                                                 (@=?))   --------------------------------------------------------------------------------@@ -23,14 +35,45 @@  -------------------------------------------------------------------------------- testStep :: Step -> String -> String-testStep step str = case parseModule [] Nothing str of-    Left err      -> error err-    Right module' -> unlines $ stepFilter step ls module'+testStep s str = case s of+  Step _ step ->+    case parseModule [] Nothing str of+      Left err      -> error err+      Right module' -> unlines $ step ls module'   where     ls = lines str   --------------------------------------------------------------------------------+testStep' :: Step -> Lines -> Lines+testStep' s ls = lines $ testStep s (unlines ls)+++--------------------------------------------------------------------------------+-- | 'Lines' that show as a normal string.+newtype Snippet = Snippet {unSnippet :: Lines} deriving (Eq)++-- Prefix with one newline since so HUnit will use a newline after `got: ` or+-- `expected: `.+instance Show Snippet where show = unlines . ("" :) . unSnippet++instance IsList Snippet where+    type Item Snippet = String+    fromList = Snippet+    toList   = unSnippet+++--------------------------------------------------------------------------------+testSnippet :: Step -> Snippet -> Snippet+testSnippet s = Snippet . lines . testStep s . unlines . unSnippet+++--------------------------------------------------------------------------------+assertSnippet :: Step -> Snippet -> Snippet -> Assertion+assertSnippet step input expected = expected @=? testSnippet step input+++-------------------------------------------------------------------------------- -- | Create a temporary directory with a randomised name built from the template -- provided createTempDirectory :: String -> IO FilePath@@ -59,3 +102,15 @@         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]

@@ -13,6 +13,8 @@ import qualified Language.Haskell.Stylish.Parse.Tests import qualified Language.Haskell.Stylish.Step.Data.Tests import qualified Language.Haskell.Stylish.Step.Imports.Tests+import qualified Language.Haskell.Stylish.Step.Imports.FelixTests+import qualified Language.Haskell.Stylish.Step.ModuleHeader.Tests import qualified Language.Haskell.Stylish.Step.LanguagePragmas.Tests import qualified Language.Haskell.Stylish.Step.SimpleAlign.Tests import qualified Language.Haskell.Stylish.Step.Squash.Tests@@ -29,7 +31,9 @@     , Language.Haskell.Stylish.Config.Tests.tests     , Language.Haskell.Stylish.Step.Data.Tests.tests     , Language.Haskell.Stylish.Step.Imports.Tests.tests+    , Language.Haskell.Stylish.Step.Imports.FelixTests.tests     , Language.Haskell.Stylish.Step.LanguagePragmas.Tests.tests+    , Language.Haskell.Stylish.Step.ModuleHeader.Tests.tests     , Language.Haskell.Stylish.Step.SimpleAlign.Tests.tests     , Language.Haskell.Stylish.Step.Squash.Tests.tests     , Language.Haskell.Stylish.Step.Tabs.Tests.tests