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 (..), liftEither)
    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`.

Co-Authored-By: Beatrice Vergani <beatrice.vergani11@gmail.com>
Co-Authored-By: Paweł Szulc <paul.szulc@gmail.com>
Co-Authored-By: Łukasz Gołębiewski <lukasz.golebiewski@gmail.com>
Co-Authored-By: Felix Mulder <felix.mulder@klarna.com>

1 files changed, 72 insertions, 40 deletions

diff --git a/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs b/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs
index c9d461f..ddfdeb0 100644
--- a/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs
+++ b/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs
@@ -1,4 +1,7 @@
 --------------------------------------------------------------------------------
+{-# LANGUAGE BlockArguments    #-}
+{-# LANGUAGE LambdaCase        #-}
+{-# LANGUAGE OverloadedStrings #-}
 module Language.Haskell.Stylish.Step.LanguagePragmas
     ( Style (..)
     , step
@@ -8,13 +11,23 @@ module Language.Haskell.Stylish.Step.LanguagePragmas
 
 
 --------------------------------------------------------------------------------
+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 @@ data Style
 
 
 --------------------------------------------------------------------------------
-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 @@ prettyPragmas lp cols _       align CompactLine = compactLinePragmas lp cols ali
 --------------------------------------------------------------------------------
 -- | Filter redundant (and duplicate) pragmas out of the groups. As a side
 -- effect, we also sort the pragmas in their group...
-filterRedundant :: (String -> Bool)
-                -> [(l, [String])]
-                -> [(l, [String])]
-filterRedundant isRedundant' = snd . foldr filterRedundant' (S.empty, [])
+filterRedundant :: (Text -> Bool)
+                -> [(l, NonEmpty Text)]
+                -> [(l, [Text])]
+filterRedundant isRedundant' = snd . foldr filterRedundant' (S.empty, []) . fmap (fmap toList)
   where
     filterRedundant' (l, xs) (known, zs)
         | S.null xs' = (known', zs)
@@ -111,38 +111,54 @@ step = ((((makeStep "LanguagePragmas" .) .) .) .) . step'
 
 --------------------------------------------------------------------------------
 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 @@ isRedundant _ _              = False
 
 --------------------------------------------------------------------------------
 -- | Check if the ViewPatterns language pragma is redundant.
-isRedundantViewPatterns :: H.Module H.SrcSpanInfo -> Bool
-isRedundantViewPatterns m = null
-    [() | H.PViewPat {} <- everything m :: [H.Pat H.SrcSpanInfo]]
+isRedundantViewPatterns :: Module -> Bool
+isRedundantViewPatterns = 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 -> [()]
+      _                          -> []