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, 103 insertions, 23 deletions

diff --git a/lib/Language/Haskell/Stylish/Util.hs b/lib/Language/Haskell/Stylish/Util.hs
index 9883f4b..90bea63 100644
--- a/lib/Language/Haskell/Stylish/Util.hs
+++ b/lib/Language/Haskell/Stylish/Util.hs
@@ -1,8 +1,8 @@
 --------------------------------------------------------------------------------
+{-# LANGUAGE LambdaCase    #-}
+{-# LANGUAGE PatternGuards #-}
 module Language.Haskell.Stylish.Util
-    ( nameToString
-    , isOperator
-    , indent
+    ( indent
     , padRight
     , everything
     , infoPoints
@@ -13,22 +13,35 @@ module Language.Haskell.Stylish.Util
     , 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 @@ import           Language.Haskell.Stylish.Step
 
 
 --------------------------------------------------------------------------------
-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 @@ everything = G.everything (++) (maybeToList . cast)
 
 
 --------------------------------------------------------------------------------
-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 @@ noWrap :: String    -- ^ Leading string
        -> 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 _ []       = []
 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