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, 92 insertions, 69 deletions

diff --git a/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs b/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs
index 5e61123..e02c270 100644
--- a/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs
+++ b/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs
@@ -1,4 +1,5 @@
 --------------------------------------------------------------------------------
+{-# LANGUAGE TypeFamilies #-}
 module Language.Haskell.Stylish.Step.SimpleAlign
     ( Config (..)
     , defaultConfig
@@ -7,15 +8,17 @@ module Language.Haskell.Stylish.Step.SimpleAlign
 
 
 --------------------------------------------------------------------------------
-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 @@ defaultConfig = Config
 
 
 --------------------------------------------------------------------------------
-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