updates for compatibility with GHC HEAD

cabal.project

@@ -1,4 +1 @@
-if impl(ghc == 9.12.1)
-  allow-newer: ghc-prim, base, template-haskell
-
 packages: ./hlint.cabal

src/Config/Compute.hs

@@ -9,6 +9,7 @@ import GHC.Util
 import Config.Type
 import Fixity
 import Data.Generics.Uniplate.DataOnly
+import Data.List.NonEmpty(NonEmpty(..))
 import GHC.Hs hiding (Warning)
 import GHC.Types.Name.Reader
 import GHC.Types.Name
@@ -56,7 +57,7 @@ findBind FunBind{fun_id, fun_matches} = findExp (unLoc fun_id) [] $ HsLam noAnn
 findBind _ = []
 
 findExp :: IdP GhcPs -> [String] -> HsExpr GhcPs -> [Setting]
-findExp name vs (HsLam _ LamSingle MG{mg_alts=L _ [L _ Match{m_pats=L _ pats, m_grhss=GRHSs{grhssGRHSs=[L _ (GRHS _ [] x)], grhssLocalBinds=(EmptyLocalBinds _)}}]})
+findExp name vs (HsLam _ LamSingle MG{mg_alts=L _ [L _ Match{m_pats=L _ pats, m_grhss=GRHSs{grhssGRHSs=(L _ (GRHS _ [] x) :| []), grhssLocalBinds=(EmptyLocalBinds _)}}]})
     = if length pats == length ps then findExp name (vs++ps) $ unLoc x else []
     where ps = [rdrNameStr x | L _ (VarPat _ x) <- pats]
 findExp name vs HsLam{} = []

src/GHC/Util/Brackets.hs

@@ -59,12 +59,10 @@ instance Brackets (LocatedA (HsExpr GhcPs)) where
       _  -> False
       where
         isNegativeLit (HsInt _ i) = il_neg i
-        isNegativeLit (HsRat _ f _) = fl_neg f
         isNegativeLit (HsFloatPrim _ f) = fl_neg f
         isNegativeLit (HsDoublePrim _ f) = fl_neg f
         isNegativeLit (HsIntPrim _ x) = x < 0
         isNegativeLit (HsInt64Prim _ x) = x < 0
-        isNegativeLit (HsInteger _ x _) = x < 0
         isNegativeLit _ = False
         isNegativeOverLit OverLit {ol_val=HsIntegral i} = il_neg i
         isNegativeOverLit OverLit {ol_val=HsFractional f} = fl_neg f
@@ -131,8 +129,6 @@ instance Brackets (LocatedA (Pat GhcPs)) where
       isSignedLit HsInt{} = True
       isSignedLit HsIntPrim{} = True
       isSignedLit HsInt64Prim{} = True
-      isSignedLit HsInteger{} = True
-      isSignedLit HsRat{} = True
       isSignedLit HsFloatPrim{} = True
       isSignedLit HsDoublePrim{} = True
       isSignedLit _ = False

src/GHC/Util/FreeVars.hs

@@ -18,6 +18,7 @@ import Data.Generics.Uniplate.DataOnly
 import Data.Monoid
 import Data.Semigroup
 import Data.List.Extra
+import Data.List.NonEmpty(toList)
 import Data.Set (Set)
 import Data.Set qualified as Set
 import Prelude
@@ -123,7 +124,7 @@ instance FreeVars (LocatedA (HsExpr GhcPs)) where
     case flds of
       RegularRecUpdFields _ fs -> Set.unions $ freeVars e : map freeVars fs
       OverloadedRecUpdFields _ ps -> Set.unions $ freeVars e : map freeVars ps
-  freeVars (L _ (HsMultiIf _ grhss)) = free (allVars grhss) -- Multi-way if.
+  freeVars (L _ (HsMultiIf _ grhss)) = free (allVars (toList grhss)) -- Multi-way if.
   freeVars (L _ (HsTypedBracket _ e)) = freeVars e
   freeVars (L _ (HsUntypedBracket _ (ExpBr _ e))) = freeVars e
   freeVars (L _ (HsUntypedBracket _ (VarBr _ _ v))) = Set.fromList [occName (unLoc v)]
@@ -240,7 +241,7 @@ instance AllVars (HsStmtContext (GenLocated SrcSpanAnnN RdrName)) where
   allVars _ = mempty
 
 instance AllVars (GRHSs GhcPs (LocatedA (HsExpr GhcPs))) where
-  allVars (GRHSs _ grhss binds) = inVars binds (mconcatMap allVars grhss)
+  allVars (GRHSs _ grhss binds) = inVars binds (mconcatMap allVars (toList grhss))
 
 instance AllVars (LocatedAn NoEpAnns (GRHS GhcPs (LocatedA (HsExpr GhcPs)))) where
   allVars (L _ (GRHS _ guards expr)) = Vars (bound gs) (free gs ^+ (freeVars expr ^- bound gs)) where gs = allVars guards

src/GHC/Util/HsExpr.hs

@@ -33,6 +33,7 @@ import Control.Monad.Trans.Writer.CPS
 import Data.Data
 import Data.Generics.Uniplate.DataOnly
 import Data.List.Extra
+import Data.List.NonEmpty(NonEmpty(..), fromList, toList)
 import Data.Tuple.Extra
 import Data.Maybe
 
@@ -57,7 +58,7 @@ dotApps (x : xs) = dotApp x (dotApps xs)
 
 -- | @lambda [p0, p1..pn] body@ makes @\p1 p1 .. pn -> body@
 lambda :: [LPat GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs
-lambda vs body = noLocA $ HsLam noAnn LamSingle (MG (Generated OtherExpansion DoPmc) (noLocA [noLocA $ Match noExtField (LamAlt LamSingle) (L noSpanAnchor vs) (GRHSs emptyComments [noLocA $ GRHS noAnn [] body] (EmptyLocalBinds noExtField))]))
+lambda vs body = noLocA $ HsLam noAnn LamSingle (MG (Generated OtherExpansion DoPmc) (noLocA [noLocA $ Match noExtField (LamAlt LamSingle) (L noSpanAnchor vs) (GRHSs emptyComments (noLocA (GRHS noAnn [] body) :| []) (EmptyLocalBinds noExtField))]))
 
 -- | 'paren e' wraps 'e' in parens if 'e' is non-atomic.
 paren :: LHsExpr GhcPs -> LHsExpr GhcPs
@@ -124,7 +125,7 @@ simplifyExp (L l (OpApp _ x op y)) | isDol op = L l (HsApp noExtField x (nlHsPar
 simplifyExp e@(L _ (HsLet _ ((HsValBinds _ (ValBinds _ binds []))) z)) =
   -- An expression of the form, 'let x = y in z'.
   case binds of
-    [L _ (FunBind _ _ (MG _ (L _ [L _ (Match _(FunRhs (L _ x) _ _ _) (L _ []) (GRHSs _ [L _ (GRHS _ [] y)] ((EmptyLocalBinds _))))])))]
+    [L _ (FunBind _ _ (MG _ (L _ [L _ (Match _(FunRhs (L _ x) _ _ _) (L _ []) (GRHSs _ (L _ (GRHS _ [] y) :| []) ((EmptyLocalBinds _))))])))]
          -- If 'x' is not in the free variables of 'y', beta-reduce to
          -- 'z[(y)/x]'.
       | occNameStr x `notElem` vars y && length [() | Unqual a <- universeBi z, a == rdrNameOcc x] <= 1 ->
@@ -239,7 +240,7 @@ niceLambdaR [] e = (e, \s -> [Replace Expr s [("a", toSSA e)] "a"])
 -- Base case. Just a good old fashioned lambda.
 niceLambdaR ss e =
   let grhs = noLocA $ GRHS noAnn [] e :: LGRHS GhcPs (LHsExpr GhcPs)
-      grhss = GRHSs {grhssExt = emptyComments, grhssGRHSs=[grhs], grhssLocalBinds=EmptyLocalBinds noExtField}
+      grhss = GRHSs {grhssExt = emptyComments, grhssGRHSs=fromList [grhs], grhssLocalBinds=EmptyLocalBinds noExtField}
       match = noLocA $ Match {m_ext=noExtField, m_ctxt=LamAlt LamSingle, m_pats=noLocA $ map strToPat ss, m_grhss=grhss} :: LMatch GhcPs (LHsExpr GhcPs)
       matchGroup = MG {mg_ext=Generated OtherExpansion SkipPmc, mg_alts=noLocA [match]}
   in (noLocA $ HsLam noAnn LamSingle matchGroup, const [])
@@ -254,12 +255,12 @@ replaceBranches (L s (HsCase _ a (MG FromSource (L l bs)))) =
   (concatMap f bs, L s . HsCase noAnn a . MG (Generated OtherExpansion SkipPmc). L l . g bs)
   where
     f :: LMatch GhcPs (LHsExpr GhcPs) -> [LHsExpr GhcPs]
-    f (L _ (Match _ CaseAlt _ (GRHSs _ xs _))) = [x | (L _ (GRHS _ _ x)) <- xs]
+    f (L _ (Match _ CaseAlt _ (GRHSs _ xs _))) = [x | (L _ (GRHS _ _ x)) <- toList xs]
     f _ = error "GHC.Util.HsExpr.replaceBranches: unexpected XMatch"
 
     g :: [LMatch GhcPs (LHsExpr GhcPs)] -> [LHsExpr GhcPs] -> [LMatch GhcPs (LHsExpr GhcPs)]
     g (L s1 (Match _ CaseAlt a (GRHSs _ ns b)) : rest) xs =
-      L s1 (Match noExtField CaseAlt a (GRHSs emptyComments [L a (GRHS noAnn gs x) | (L a (GRHS _ gs _), x) <- zip ns as] b)) : g rest bs
+      L s1 (Match noExtField CaseAlt a (GRHSs emptyComments (fromList [L a (GRHS noAnn gs x) | (L a (GRHS _ gs _), x) <- zip (toList ns) as]) b)) : g rest bs
       where  (as, bs) = splitAt (length ns) xs
     g [] [] = []
     g _ _ = error "GHC.Util.HsExpr.replaceBranches': internal invariant failed, lists are of differing lengths"

src/GHC/Util/Unify.hs

@@ -120,6 +120,9 @@ unify' nm root x y
     | Just (x :: EpAnn AnnExplicitSum) <- cast x = Just mempty
     | Just (x :: EpAnn AnnFieldLabel) <- cast x = Just mempty
     | Just (x :: EpAnn (AnnList [EpToken ","])) <- cast x = Just mempty
+    | Just (x :: EpAnn (AnnList ())) <- cast x = Just mempty
+    | Just (x :: EpAnn (AnnList (EpToken "where"))) <- cast x = Just mempty
+    | Just (x :: EpAnn (AnnList (EpToken "hiding", [EpToken ","]))) <- cast x = Just mempty
     | Just (x :: EpAnn AnnListItem) <- cast x = Just mempty
     | Just (x :: EpAnn AnnParen) <- cast x = Just mempty
     | Just (x :: EpAnn AnnPragma) <- cast x = Just mempty
@@ -135,16 +138,34 @@ unify' nm root x y
     | Just (x :: EpAnn HsRuleAnn) <- cast x = Just mempty
     | Just (x :: EpAnn NameAnn) <- cast x = Just mempty
     | Just (x :: EpAnn NoEpAnns) <- cast x = Just mempty
-    | Just (x :: EpToken "let") <- cast x = Just mempty
-    | Just (x :: EpToken "in") <- cast x = Just mempty
-    | Just (x :: EpToken "@") <- cast x = Just mempty
+    | Just (x :: EpToken "|") <- cast x = Just mempty
+    | Just (x :: EpToken ",") <- cast x = Just mempty
+    | Just (x :: EpToken ";") <- cast x = Just mempty
+    | Just (x :: EpToken "`") <- cast x = Just mempty
+    | Just (x :: EpToken ".") <- cast x = Just mempty
+    | Just (x :: EpToken "\\") <- cast x = Just mempty
     | Just (x :: EpToken "(") <- cast x = Just mempty
     | Just (x :: EpToken ")") <- cast x = Just mempty
+    | Just (x :: EpToken "@") <- cast x = Just mempty
+    | Just (x :: EpToken "#-}") <- cast x = Just mempty
+    | Just (x :: EpToken "if") <- cast x = Just mempty
+    | Just (x :: EpToken "then") <- cast x = Just mempty
+    | Just (x :: EpToken "let") <- cast x = Just mempty
+    | Just (x :: EpToken "else") <- cast x = Just mempty
+    | Just (x :: EpToken "case") <- cast x = Just mempty
+    | Just (x :: EpToken "of") <- cast x = Just mempty
+    | Just (x :: EpToken "in") <- cast x = Just mempty
     | Just (x :: EpToken "type") <- cast x = Just mempty
     | Just (x :: EpToken "%") <- cast x = Just mempty
     | Just (x :: EpToken "%1") <- cast x = Just mempty
-    | Just (x :: EpToken "⊸") <- cast x = Just mempty
+    | Just (x :: EpToken "proc") <- cast x = Just mempty
+    | Just (x :: EpToken "static") <- cast x = Just mempty
+    | Just (x :: EpToken "qualified") <- cast x = Just mempty
+    | Just (x :: EpToken "safe") <- cast x = Just mempty
+    | Just (x :: EpToken "as") <- cast x = Just mempty
+    | Just (x :: EpToken "import") <- cast x = Just mempty
     | Just (x :: EpUniToken "->" "→") <- cast x = Just mempty
+    | Just (x :: EpUniToken "::" "∷") <- cast x = Just mempty
     | Just (x :: TokenLocation) <- cast y = Just mempty
     | Just (y :: SrcSpan) <- cast y = Just mempty
 

src/GHC/Util/View.hs

@@ -13,6 +13,7 @@ import GHC.Types.SrcLoc
 import GHC.Types.Basic
 import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader
 import GHC.Util.Brackets
+import Data.List.NonEmpty(NonEmpty(..))
 
 fromParen :: LocatedA (HsExpr GhcPs) -> LocatedA (HsExpr GhcPs)
 fromParen x = maybe x fromParen $ remParen x
@@ -33,7 +34,7 @@ data LamConst1 = NoLamConst1 | LamConst1 (LocatedA (HsExpr GhcPs))
 
 instance View (LocatedA (HsExpr GhcPs)) LamConst1 where
   view (fromParen -> (L _ (HsLam _ _ (MG FromSource (L _ [L _ (Match _ (LamAlt _) (L _ [L _ WildPat {}])
-    (GRHSs _ [L _ (GRHS _ [] x)] ((EmptyLocalBinds _))))]))))) = LamConst1 x
+    (GRHSs _ (L _ (GRHS _ [] x) :| []) ((EmptyLocalBinds _))))]))))) = LamConst1 x
   view _ = NoLamConst1
 
 instance View (LocatedA (HsExpr GhcPs)) RdrName_ where
@@ -62,4 +63,4 @@ instance View (LocatedA (Pat GhcPs)) PApp_ where
 
 -- A lambda with no guards and no where clauses
 pattern SimpleLambda :: [LocatedA (Pat GhcPs)] -> LocatedA (HsExpr GhcPs) -> LocatedA (HsExpr GhcPs)
-pattern SimpleLambda vs body <- L _ (HsLam _ LamSingle (MG _ (L _ [L _ (Match _ _ (L _ vs) (GRHSs _ [L _ (GRHS _ [] body)] ((EmptyLocalBinds _))))])))
+pattern SimpleLambda vs body <- L _ (HsLam _ LamSingle (MG _ (L _ [L _ (Match _ _ (L _ vs) (GRHSs _ (L _ (GRHS _ [] body) :| []) ((EmptyLocalBinds _))))])))

src/Hint/Lambda.hs

@@ -110,7 +110,9 @@ module Hint.Lambda(lambdaHint) where
 
 import Hint.Type (DeclHint, Idea, Note(RequiresExtension), suggest, warn, toSS, toSSA, suggestN, ideaNote, substVars, toRefactSrcSpan)
 import Util
+import Data.List qualified
 import Data.List.Extra
+import Data.List.NonEmpty(NonEmpty(..))
 import Data.Set (Set)
 import Data.Set qualified as Set
 import Refact.Types hiding (Match)
@@ -149,7 +151,7 @@ lambdaBind :: LHsBind GhcPs -> RType -> [Idea]
 lambdaBind
     o@(L _ origBind@FunBind {fun_id = funName@(L loc1 _), fun_matches =
         MG {mg_alts =
-            L _ [L _ (Match _ ctxt@(FunRhs _ Prefix _ _) (L _ pats) (GRHSs _ [L _ (GRHS _ [] origBody@(L loc2 _))] bind))]}}) rtype
+            L _ [L _ (Match _ ctxt@(FunRhs _ Prefix _ _) (L _ pats) (GRHSs _ (L _ (GRHS _ [] origBody@(L loc2 _)) :| []) bind))]}}) rtype
     | EmptyLocalBinds _ <- bind
     , isLambda $ fromParen origBody
     , null (universeBi pats :: [HsExpr GhcPs])
@@ -172,7 +174,7 @@ lambdaBind
     where
           reform :: [LPat GhcPs] -> LHsExpr GhcPs -> Located (HsDecl GhcPs)
           reform ps b = L (combineSrcSpans (locA loc1) (locA loc2)) $ ValD noExtField $
-             origBind {fun_matches = MG (Generated OtherExpansion SkipPmc) (noLocA [noLocA $ Match noExtField ctxt (L noSpanAnchor ps) $ GRHSs emptyComments [noLocA $ GRHS noAnn [] b] $ EmptyLocalBinds noExtField])}
+             origBind {fun_matches = MG (Generated OtherExpansion SkipPmc) (noLocA [noLocA $ Match noExtField ctxt (L noSpanAnchor ps) $ GRHSs emptyComments (noLocA (GRHS noAnn [] b) :| []) $ EmptyLocalBinds noExtField])}
 
           mkSubtsAndTpl newPats newBody = (sub, tpl)
             where
@@ -334,7 +336,7 @@ fromLambda x = ([], x)
 mkOrigPats :: Maybe String -> [LPat GhcPs] -> ([LPat GhcPs], [String])
 mkOrigPats funName pats = (zipWith munge vars pats', vars)
   where
-    (Set.unions -> used, pats') = unzip (map f pats)
+    (Set.unions -> used, pats') = Data.List.unzip (map f pats)
 
     -- Remove variables that occur in the function name or patterns with wildcards
     vars = filter (\s -> s `Set.notMember` used && Just s /= funName) substVars

src/Hint/ListRec.hs

@@ -35,6 +35,7 @@ import Hint.Type (DeclHint, Severity(Suggestion, Warning), idea, toSSA)
 
 import Data.Generics.Uniplate.DataOnly
 import Data.List.Extra
+import Data.List.NonEmpty(NonEmpty(..))
 import Data.Maybe
 import Data.Either.Extra
 import Control.Monad
@@ -140,7 +141,7 @@ asDo (view ->
                  L _ Match {  m_ctxt=(LamAlt LamSingle)
                             , m_pats=L _ [v@(L _ VarPat{})]
                             , m_grhss=GRHSs _
-                                        [L _ (GRHS _ [] rhs)]
+                                        (L _ (GRHS _ [] rhs) :| [])
                                         (EmptyLocalBinds _)}]}))
       ) =
   [ noLocA $ BindStmt noAnn v lhs
@@ -174,7 +175,7 @@ findCase x = do
   let ps12 = let (a, b) = splitAt p1 ps1 in map strToPat (a ++ xs : b) -- Function arguments.
       emptyLocalBinds = EmptyLocalBinds noExtField :: HsLocalBindsLR GhcPs GhcPs -- Empty where clause.
       gRHS e = noLocA $ GRHS noAnn [] e :: LGRHS GhcPs (LHsExpr GhcPs) -- Guarded rhs.
-      gRHSSs e = GRHSs emptyComments [gRHS e] emptyLocalBinds -- Guarded rhs set.
+      gRHSSs e = GRHSs emptyComments (gRHS e :| []) emptyLocalBinds -- Guarded rhs set.
       match e = Match{m_ext=noExtField,m_pats=noLocA ps12, m_grhss=gRHSSs e, ..} -- Match.
       matchGroup e = MG{mg_alts=noLocA [noLocA $ match e], mg_ext=Generated OtherExpansion SkipPmc, ..} -- Match group.
       funBind e = FunBind {fun_matches=matchGroup e, ..} :: HsBindLR GhcPs GhcPs -- Fun bind.
@@ -208,7 +209,7 @@ findBranch (L _ x) = do
   Match { m_ctxt = FunRhs {mc_fun=(L _ name)}
             , m_pats = ps
             , m_grhss =
-              GRHSs {grhssGRHSs=[L l (GRHS _ [] body)]
+              GRHSs {grhssGRHSs=(L l (GRHS _ [] body) :| [])
                         , grhssLocalBinds=EmptyLocalBinds _
                         }
             } <- pure x

src/Hint/Monad.hs

@@ -89,6 +89,7 @@ import Data.Generics.Uniplate.DataOnly
 import Data.Tuple.Extra
 import Data.Maybe
 import Data.List.Extra
+import Data.List.NonEmpty(NonEmpty(..))
 import Refact.Types hiding (Match)
 import Refact.Types qualified as R
 
@@ -295,7 +296,7 @@ monadLet xs = mapMaybe mkLet xs
     template lhs rhs =
         let p = noLocA $ mkRdrUnqual (mkVarOcc lhs)
             grhs = noLocA (GRHS noAnn [] rhs)
-            grhss = GRHSs emptyComments [grhs] (EmptyLocalBinds noExtField)
+            grhss = GRHSs emptyComments (grhs :| []) (EmptyLocalBinds noExtField)
             match = noLocA $ Match noExtField (FunRhs p Prefix NoSrcStrict noAnn) (noLocA []) grhss
             fb = noLocA $ FunBind noExtField p (MG (Generated OtherExpansion SkipPmc) (noLocA [match]))
             binds = [fb]

src/Hint/Naming.hs

@@ -90,12 +90,12 @@ shorten :: LHsDecl GhcPs -> LHsDecl GhcPs
 shorten (L locDecl (ValD ttg0 bind@(FunBind _ _ matchGroup@(MG FromSource (L locMatches matches))))) =
     L locDecl (ValD ttg0 bind {fun_matches = matchGroup {mg_alts = L locMatches $ map shortenMatch matches}})
 shorten (L locDecl (ValD ttg0 bind@(PatBind _ _ _ grhss@(GRHSs _ rhss _)))) =
-    L locDecl (ValD ttg0 bind {pat_rhs = grhss {grhssGRHSs = map shortenLGRHS rhss}})
+    L locDecl (ValD ttg0 bind {pat_rhs = grhss {grhssGRHSs = fmap shortenLGRHS rhss}})
 shorten x = x
 
 shortenMatch :: LMatch GhcPs (LHsExpr GhcPs) -> LMatch GhcPs (LHsExpr GhcPs)
 shortenMatch (L locMatch match@(Match _ _ _ grhss@(GRHSs _ rhss _))) =
-    L locMatch match {m_grhss = grhss {grhssGRHSs = map shortenLGRHS rhss}}
+    L locMatch match {m_grhss = grhss {grhssGRHSs = fmap shortenLGRHS rhss}}
 
 shortenLGRHS :: LGRHS GhcPs (LHsExpr GhcPs) -> LGRHS GhcPs (LHsExpr GhcPs)
 shortenLGRHS (L locGRHS (GRHS ttg0 guards (L locExpr _))) =