Use ghc-lib-parser with stylish-haskell

.circleci/config.yml

@@ -12,7 +12,7 @@ workflows:
 jobs:
   build:
     docker:
-      - image: 'haskell:8.6'
+      - image: 'haskell:8.8.3'
 
     steps:
       - checkout

data/stylish-haskell.yaml

@@ -15,6 +15,13 @@ steps:
   #     # true.
   #     add_language_pragma: true
 
+  # Format module header
+  #
+  # Currently, this option is not configurable and will format all exports and
+  # module declarations to minimize diffs
+  #
+  # - module_header: {}
+
   # Format record definitions. This is disabled by default.
   #
   # You can control the layout of record fields. The only rules that can't be configured
@@ -42,6 +49,31 @@ steps:
   #
   #     # How many spaces to insert before "deriving" clause. Deriving clauses are always on separate lines.
   #     deriving: 2
+  #
+  #     # How many spaces to insert before "via" clause counted from indentation of deriving clause
+  #     # Possible values:
+  #     # - "same_line" -- "{" and first field goes on the same line as the data constructor.
+  #     # - "indent N" -- insert a new line and N spaces from the beginning of the data constructor
+  #     via: "indent 2"
+  #
+  #     # Wheter or not to break enums onto several lines
+  #     #
+  #     # Default: false
+  #     break_enums: false
+  #
+  #     # Whether or not to break single constructor data types before `=` sign
+  #     #
+  #     # Default: true
+  #     break_single_constructors: true
+  #
+  #     # 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
@@ -203,6 +235,22 @@ steps:
       # 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:
       # We can generate different styles of language pragma lists.

lib/Language/Haskell/Stylish.hs

@@ -91,14 +91,21 @@ unicodeSyntax = UnicodeSyntax.step
 
 --------------------------------------------------------------------------------
 runStep :: Extensions -> Maybe FilePath -> Lines -> Step -> Either String Lines
-runStep exts mfp ls step =
-    stepFilter step ls <$> parseModule exts mfp (unlines ls)
-
+runStep exts mfp ls = \case
+  Step _name step ->
+    step ls <$> parseModule exts mfp (unlines ls)
+  OldStep _name step ->
+    step ls <$> parseModuleHSE exts mfp (unlines ls)
 
 --------------------------------------------------------------------------------
-runSteps :: 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 }
 

lib/Language/Haskell/Stylish/Block.hs

@@ -9,6 +9,7 @@ module Language.Haskell.Stylish.Block
     , moveBlock
     , adjacent
     , merge
+    , mergeAdjacent
     , overlapping
     , groupAdjacent
     ) where
@@ -94,3 +95,9 @@ groupAdjacent = foldr go []
     go (b1, x) gs = case break (adjacent b1 . fst) gs of
         (_, [])               -> (b1, [x]) : gs
         (ys, ((b2, xs) : zs)) -> (merge b1 b2, x : xs) : (ys ++ zs)
+
+mergeAdjacent :: [Block a] -> [Block a]
+mergeAdjacent (a : b : rest) | a `adjacent` b = merge a b : mergeAdjacent rest
+mergeAdjacent (a : rest) = a : mergeAdjacent rest
+mergeAdjacent [] = []
+

lib/Language/Haskell/Stylish/Config.hs

@@ -1,9 +1,11 @@
 --------------------------------------------------------------------------------
+{-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell   #-}
 module Language.Haskell.Stylish.Config
     ( Extensions
     , Config (..)
+    , ExitCodeBehavior (..)
     , defaultConfigBytes
     , configFilePath
     , loadConfig
@@ -40,6 +42,8 @@ import           Language.Haskell.Stylish.Config.Internal
 import           Language.Haskell.Stylish.Step
 import qualified Language.Haskell.Stylish.Step.Data               as Data
 import qualified Language.Haskell.Stylish.Step.Imports            as Imports
+import qualified Language.Haskell.Stylish.Step.ImportsGHC         as ImportsGHC
+import qualified Language.Haskell.Stylish.Step.ModuleHeader       as ModuleHeader
 import qualified Language.Haskell.Stylish.Step.LanguagePragmas    as LanguagePragmas
 import qualified Language.Haskell.Stylish.Step.SimpleAlign        as SimpleAlign
 import qualified Language.Haskell.Stylish.Step.Squash             as Squash
@@ -60,8 +64,18 @@ data Config = Config
     , configLanguageExtensions :: [String]
     , configNewline            :: IO.Newline
     , configCabal              :: Bool
+    , configExitCode           :: ExitCodeBehavior
     }
 
+--------------------------------------------------------------------------------
+data ExitCodeBehavior
+  = NormalExitBehavior
+  | ErrorOnFormatExitBehavior
+  deriving (Eq)
+
+instance Show ExitCodeBehavior where
+  show NormalExitBehavior = "normal"
+  show ErrorOnFormatExitBehavior = "error_on_format"
 
 --------------------------------------------------------------------------------
 instance FromJSON Config where
@@ -126,6 +140,7 @@ parseConfig (A.Object o) = do
         <*> (o A..:? "language_extensions" A..!= [])
         <*> (o A..:? "newline"             >>= parseEnum newlines IO.nativeNewline)
         <*> (o A..:? "cabal"               A..!= True)
+        <*> (o A..:? "exit_code"           >>= parseEnum exitCodes NormalExitBehavior)
 
     -- Then fill in the steps based on the partial config we already have
     stepValues <- o A..: "steps" :: A.Parser [A.Value]
@@ -137,13 +152,18 @@ parseConfig (A.Object o) = do
         , ("lf",     IO.LF)
         , ("crlf",   IO.CRLF)
         ]
+    exitCodes =
+        [ ("normal", NormalExitBehavior)
+        , ("error_on_format", ErrorOnFormatExitBehavior)
+        ]
 parseConfig _            = mzero
 
 
 --------------------------------------------------------------------------------
 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,12 @@ parseEnum strs _   (Just k) = case lookup k strs of
     Nothing -> fail $ "Unknown option: " ++ k ++ ", should be one of: " ++
         intercalate ", " (map fst strs)
 
+--------------------------------------------------------------------------------
+parseModuleHeader :: Config -> A.Object -> A.Parser Step
+parseModuleHeader _ _
+  = pure
+  . ModuleHeader.step
+  $ ModuleHeader.Config
 
 --------------------------------------------------------------------------------
 parseSimpleAlign :: Config -> A.Object -> A.Parser Step
@@ -186,13 +212,20 @@ parseSimpleAlign c o = SimpleAlign.step
 
 --------------------------------------------------------------------------------
 parseRecords :: Config -> A.Object -> A.Parser Step
-parseRecords _ o = Data.step
+parseRecords c o = Data.step
     <$> (Data.Config
         <$> (o A..: "equals" >>= parseIndent)
         <*> (o A..: "first_field" >>= parseIndent)
         <*> (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 +247,31 @@ parseSquash _ _ = return Squash.step
 
 --------------------------------------------------------------------------------
 parseImports :: Config -> A.Object -> A.Parser Step
-parseImports config o = Imports.step
-    <$> pure (configColumns config)
-    <*> (Imports.Options
-        <$> (o A..:? "align" >>= parseEnum aligns (def Imports.importAlign))
-        <*> (o A..:? "list_align" >>= parseEnum listAligns (def Imports.listAlign))
-        <*> (o A..:? "pad_module_names" A..!= def Imports.padModuleNames)
-        <*> (o A..:? "long_list_align"
-            >>= parseEnum longListAligns (def Imports.longListAlign))
-        -- Note that padding has to be at least 1. Default is 4.
-        <*> (o A..:? "empty_list_align"
-            >>= parseEnum emptyListAligns (def Imports.emptyListAlign))
-        <*> o A..:? "list_padding" A..!= def Imports.listPadding
-        <*> o A..:? "separate_lists" A..!= def Imports.separateLists
-        <*> o A..:? "space_surround" A..!= def Imports.spaceSurround)
+parseImports config o = do
+  cfg <-
+    Imports.Options
+      <$> (o A..:? "align" >>= parseEnum aligns (def Imports.importAlign))
+      <*> (o A..:? "list_align" >>= parseEnum listAligns (def Imports.listAlign))
+      <*> (o A..:? "pad_module_names" A..!= def Imports.padModuleNames)
+      <*> (o A..:? "long_list_align" >>= parseEnum longListAligns (def Imports.longListAlign))
+      -- Note that padding has to be at least 1. Default is 4.
+      <*> (o A..:? "empty_list_align" >>= parseEnum emptyListAligns (def Imports.emptyListAlign))
+      <*> o A..:? "list_padding" A..!= def Imports.listPadding
+      <*> o A..:? "separate_lists" A..!= def Imports.separateLists
+      <*> o A..:? "space_surround" A..!= def Imports.spaceSurround
+      <*> o A..:? "ghc_lib_parser" A..!= False
+
+  pure
+    if Imports.useGhcLibParser cfg then
+      ImportsGHC.step columns cfg
+    else
+      Imports.step columns cfg
+
   where
     def f = f Imports.defaultOptions
 
+    columns = configColumns config
+
     aligns =
         [ ("global", Imports.Global)
         , ("file",   Imports.File)

lib/Language/Haskell/Stylish/GHC.hs

@@ -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