Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

updates for compatibility with ghc-9.10 #1594

Merged
merged 1 commit into from
Aug 26, 2024
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
1 change: 1 addition & 0 deletions .gitignore
Original file line number Diff line number Diff line change
Expand Up @@ -16,3 +16,4 @@ stack*.yaml.lock
.\#*\#
/.sl/
*.dump-hi
.DS_Store
1 change: 1 addition & 0 deletions cabal.project
Original file line number Diff line number Diff line change
@@ -0,0 +1 @@
packages: ./hlint.cabal
12 changes: 6 additions & 6 deletions hlint.cabal
Original file line number Diff line number Diff line change
@@ -1,7 +1,7 @@
cabal-version: 1.18
build-type: Simple
name: hlint
version: 3.8
version: 3.8.1
license: BSD3
license-file: LICENSE
category: Development
Expand Down Expand Up @@ -36,7 +36,7 @@ extra-source-files:
extra-doc-files:
README.md
CHANGES.txt
tested-with: GHC==9.8, GHC==9.6, GHC==9.4
tested-with: GHC==9.10, GHC==9.8, GHC==9.6

source-repository head
type: git
Expand Down Expand Up @@ -81,16 +81,16 @@ library
deriving-aeson >= 0.2,
filepattern >= 0.1.1

if !flag(ghc-lib) && impl(ghc >= 9.8.1) && impl(ghc < 9.9.0)
if !flag(ghc-lib) && impl(ghc >= 9.10.1) && impl(ghc < 9.11.0)
build-depends:
ghc == 9.8.*,
ghc == 9.10.*,
ghc-boot-th,
ghc-boot
else
build-depends:
ghc-lib-parser == 9.8.*
ghc-lib-parser == 9.10.*
build-depends:
ghc-lib-parser-ex >= 9.8.0.2 && < 9.8.1
ghc-lib-parser-ex >= 9.10.0.0 && < 9.11.0

if flag(gpl)
build-depends: hscolour >= 1.21
Expand Down
4 changes: 3 additions & 1 deletion src/CmdLine.hs
Original file line number Diff line number Diff line change
Expand Up @@ -327,7 +327,9 @@ getExtensions args = (lang, foldl f (startExts, []) exts)

langs, exts :: [String]
(langs, exts) = partition (isJust . flip lookup ls) args
ls = [ (show x, x) | x <- [Haskell98, Haskell2010 , GHC2021] ]

ls :: [(String, Language)]
ls = [(show x, x) | x <- enumerate]

f :: ([Extension], [Extension]) -> String -> ([Extension], [Extension])
f (a, e) ('N':'o':x) | Just x <- GhclibParserEx.readExtension x, let xs = expandDisable x = (deletes xs a, xs ++ deletes xs e)
Expand Down
8 changes: 4 additions & 4 deletions src/Config/Compute.hs
Original file line number Diff line number Diff line change
Expand Up @@ -53,17 +53,17 @@ findSetting x = []

findBind :: HsBind GhcPs -> [Setting]
findBind VarBind{var_id, var_rhs} = findExp var_id [] $ unLoc var_rhs
findBind FunBind{fun_id, fun_matches} = findExp (unLoc fun_id) [] $ HsLam noExtField fun_matches
findBind FunBind{fun_id, fun_matches} = findExp (unLoc fun_id) [] $ HsLam noAnn LamSingle fun_matches
findBind _ = []

findExp :: IdP GhcPs -> [String] -> HsExpr GhcPs -> [Setting]
findExp name vs (HsLam _ MG{mg_alts=L _ [L _ Match{m_pats, m_grhss=GRHSs{grhssGRHSs=[L _ (GRHS _ [] x)], grhssLocalBinds=(EmptyLocalBinds _)}}]})
findExp name vs (HsLam _ LamSingle MG{mg_alts=L _ [L _ Match{m_pats, m_grhss=GRHSs{grhssGRHSs=[L _ (GRHS _ [] x)], grhssLocalBinds=(EmptyLocalBinds _)}}]})
= if length m_pats == length ps then findExp name (vs++ps) $ unLoc x else []
where ps = [rdrNameStr x | L _ (VarPat _ x) <- m_pats]
findExp name vs HsLam{} = []
findExp name vs HsVar{} = []
findExp name vs (OpApp _ x dot y) | isDot dot = findExp name (vs++["_hlint"]) $
HsApp EpAnnNotUsed x $ nlHsPar $ noLocA $ HsApp EpAnnNotUsed y $ noLocA $ mkVar "_hlint"
HsApp noExtField x $ nlHsPar $ noLocA $ HsApp noExtField y $ noLocA $ mkVar "_hlint"

findExp name vs bod = [SettingMatchExp $
HintRule Warning defaultHintName []
Expand All @@ -74,7 +74,7 @@ findExp name vs bod = [SettingMatchExp $

rep = zip vs $ map (mkVar . pure) ['a'..]
f (HsVar _ x) | Just y <- lookup (rdrNameStr x) rep = y
f (OpApp _ x dol y) | isDol dol = HsApp EpAnnNotUsed x $ nlHsPar y
f (OpApp _ x dol y) | isDol dol = HsApp noExtField x $ nlHsPar y
f x = x


Expand Down
2 changes: 1 addition & 1 deletion src/Config/Haskell.hs
Original file line number Diff line number Diff line change
Expand Up @@ -45,7 +45,7 @@ readPragma (HsAnnotation _ provenance expr) = f expr
Nothing -> errorOn expr "bad classify pragma"
Just severity -> Just $ Classify severity (trimStart b) "" name
where (a,b) = break isSpace $ trimStart $ drop 6 s
f (L _ (HsPar _ _ x _)) = f x
f (L _ (HsPar _ x)) = f x
f (L _ (ExprWithTySig _ x _)) = f x
f _ = Nothing

Expand Down
2 changes: 1 addition & 1 deletion src/Config/Yaml.hs
Original file line number Diff line number Diff line change
Expand Up @@ -442,7 +442,7 @@ settingsFromConfigYaml (mconcat -> ConfigYaml configs) = settings ++ concatMap f
scope'= asScope' packageMap' (map (fmap unextendInstances) groupImports)

asScope' :: Map.HashMap String [LocatedA (ImportDecl GhcPs)] -> [Either String (LocatedA (ImportDecl GhcPs))] -> Scope
asScope' packages xs = scopeCreate (HsModule (XModulePs EpAnnNotUsed NoLayoutInfo Nothing Nothing) Nothing Nothing (concatMap f xs) [])
asScope' packages xs = scopeCreate (HsModule (XModulePs noAnn EpNoLayout Nothing Nothing) Nothing Nothing (concatMap f xs) [])
where
f (Right x) = [x]
f (Left x) | Just pkg <- Map.lookup x packages = pkg
Expand Down
3 changes: 1 addition & 2 deletions src/Fixity.hs
Original file line number Diff line number Diff line change
Expand Up @@ -14,7 +14,6 @@ import GHC.Types.Name.Reader
import GHC.Types.Fixity
import GHC.Types.SourceText
import GHC.Parser.Annotation
import Language.Haskell.Syntax.Extension
import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader
import Language.Haskell.GhclibParserEx.Fixity

Expand Down Expand Up @@ -52,7 +51,7 @@ fromFixity (name, Fixity _ i dir) = (name, assoc dir, i)
InfixN -> NotAssociative

toFixitySig :: FixityInfo -> FixitySig GhcPs
toFixitySig (toFixity -> (name, x)) = FixitySig noExtField [noLocA $ mkRdrUnqual (mkVarOcc name)] x
toFixitySig (toFixity -> (name, x)) = FixitySig NoNamespaceSpecifier [noLocA $ mkRdrUnqual (mkVarOcc name)] x

defaultFixities :: [FixityInfo]
defaultFixities = map fromFixity $ customFixities ++ baseFixities ++ lensFixities ++ otherFixities
Expand Down
2 changes: 1 addition & 1 deletion src/GHC/All.hs
Original file line number Diff line number Diff line change
Expand Up @@ -103,7 +103,7 @@ firstDeclComments :: ModuleEx -> EpAnnComments
firstDeclComments m =
case hsmodDecls . unLoc . ghcModule $ m of
[] -> EpaCommentsBalanced [] []
L (SrcSpanAnn ann _) _ : _ -> comments ann
L ann _ : _ -> comments ann

-- | The error handler invoked when GHC parsing has failed.
ghcFailOpParseModuleEx :: String
Expand Down
6 changes: 2 additions & 4 deletions src/GHC/Util/ApiAnnotation.hs
Original file line number Diff line number Diff line change
Expand Up @@ -45,7 +45,6 @@ comment_ (L _ (EpaComment (EpaDocComment ds ) _)) = renderHsDocString ds
comment_ (L _ (EpaComment (EpaDocOptions s) _)) = s
comment_ (L _ (EpaComment (EpaLineComment s) _)) = s
comment_ (L _ (EpaComment (EpaBlockComment s) _)) = s
comment_ (L _ (EpaComment EpaEofComment _)) = ""

-- | The comment string with delimiters removed.
commentText :: LEpaComment -> String
Expand All @@ -55,7 +54,6 @@ commentText = trimCommentDelims . comment_
-- `EpAnn`
comments :: EpAnn ann -> EpAnnComments
comments EpAnn{ GHC.Parser.Annotation.comments = result } = result
comments EpAnnNotUsed = emptyComments

isCommentMultiline :: LEpaComment -> Bool
isCommentMultiline (L _ (EpaComment (EpaBlockComment _) _)) = True
Expand Down Expand Up @@ -107,10 +105,10 @@ languagePragmas ps =
, let exts = map trim (splitOn "," rest)]

-- Given a list of flags, make a GHC options pragma.
mkFlags :: Anchor -> [String] -> LEpaComment
mkFlags :: NoCommentsLocation -> [String] -> LEpaComment
mkFlags anc flags =
L anc $ EpaComment (EpaBlockComment ("{-# " ++ "OPTIONS_GHC " ++ unwords flags ++ " #-}")) (anchor anc)

mkLanguagePragmas :: Anchor -> [String] -> LEpaComment
mkLanguagePragmas :: NoCommentsLocation -> [String] -> LEpaComment
mkLanguagePragmas anc exts =
L anc $ EpaComment (EpaBlockComment ("{-# " ++ "LANGUAGE " ++ intercalate ", " exts ++ " #-}")) (anchor anc)
10 changes: 5 additions & 5 deletions src/GHC/Util/Brackets.hs
Original file line number Diff line number Diff line change
Expand Up @@ -26,9 +26,9 @@ instance Brackets (LocatedA (HsExpr GhcPs)) where
-- result in a "naked" section. Consequently, given an expression,
-- when stripping brackets (c.f. 'Hint.Brackets), don't remove the
-- paren's surrounding a section - they are required.
remParen (L _ (HsPar _ _ (L _ SectionL{}) _)) = Nothing
remParen (L _ (HsPar _ _ (L _ SectionR{}) _)) = Nothing
remParen (L _ (HsPar _ _ x _)) = Just x
remParen (L _ (HsPar _ (L _ SectionL{}))) = Nothing
remParen (L _ (HsPar _ (L _ SectionR{}))) = Nothing
remParen (L _ (HsPar _ x)) = Just x
remParen _ = Nothing

addParen = nlHsPar
Expand Down Expand Up @@ -108,7 +108,7 @@ isAtomOrApp (L _ (HsApp _ _ x)) = isAtomOrApp x
isAtomOrApp _ = False

instance Brackets (LocatedA (Pat GhcPs)) where
remParen (L _ (ParPat _ _ x _)) = Just x
remParen (L _ (ParPat _ x)) = Just x
remParen _ = Nothing

addParen = nlParPat
Expand Down Expand Up @@ -151,7 +151,7 @@ instance Brackets (LocatedA (Pat GhcPs)) where
instance Brackets (LocatedA (HsType GhcPs)) where
remParen (L _ (HsParTy _ x)) = Just x
remParen _ = Nothing
addParen e = noLocA $ HsParTy EpAnnNotUsed e
addParen e = noLocA $ HsParTy noAnn e

isAtom (L _ x) = case x of
HsParTy{} -> True
Expand Down
16 changes: 8 additions & 8 deletions src/GHC/Util/FreeVars.hs
Original file line number Diff line number Diff line change
Expand Up @@ -99,10 +99,10 @@ unqualNames _ = []
instance FreeVars (LocatedA (HsExpr GhcPs)) where
freeVars (L _ (HsVar _ x)) = Set.fromList $ unqualNames x -- Variable.
freeVars (L _ (HsUnboundVar _ x)) = Set.fromList [rdrNameOcc x] -- Unbound variable; also used for "holes".
freeVars (L _ (HsLam _ mg)) = free (allVars mg) -- Lambda abstraction. Currently always a single match.
freeVars (L _ (HsLamCase _ _ MG{mg_alts=(L _ ms)})) = free (allVars ms) -- Lambda case
freeVars (L _ (HsLam _ LamSingle mg)) = free (allVars mg) -- Lambda abstraction. Currently always a single match.
freeVars (L _ (HsLam _ _ MG{mg_alts=(L _ ms)})) = free (allVars ms) -- Lambda case
freeVars (L _ (HsCase _ of_ MG{mg_alts=(L _ ms)})) = freeVars of_ ^+ free (allVars ms) -- Case expr.
freeVars (L _ (HsLet _ _ binds _ e)) = inFree binds e -- Let (rec).
freeVars (L _ (HsLet _ binds e)) = inFree binds e -- Let (rec).
freeVars (L _ (HsDo _ ctxt (L _ stmts))) = snd $ foldl' alg mempty stmts -- Do block.
where
alg ::
Expand Down Expand Up @@ -169,11 +169,11 @@ instance FreeVars (HsTupArg GhcPs) where
freeVars (Present _ args) = freeVars args
freeVars _ = mempty

instance FreeVars (LocatedA (HsFieldBind (LocatedAn NoEpAnns (FieldOcc GhcPs)) (LocatedA (HsExpr GhcPs)))) where
instance FreeVars (LocatedA (HsFieldBind (LocatedA (FieldOcc GhcPs)) (LocatedA (HsExpr GhcPs)))) where
freeVars o@(L _ (HsFieldBind _ x _ True)) = Set.singleton $ occName $ unLoc $ foLabel $ unLoc x -- a pun
freeVars o@(L _ (HsFieldBind _ _ x _)) = freeVars x

instance FreeVars (LocatedA (HsFieldBind (LocatedAn NoEpAnns (AmbiguousFieldOcc GhcPs)) (LocatedA (HsExpr GhcPs)))) where
instance FreeVars (LocatedA (HsFieldBind (LocatedA (AmbiguousFieldOcc GhcPs)) (LocatedA (HsExpr GhcPs)))) where
freeVars (L _ (HsFieldBind _ x _ True)) = Set.singleton $ rdrNameOcc $ ambiguousFieldOccRdrName $ unLoc x -- a pun
freeVars (L _ (HsFieldBind _ _ x _)) = freeVars x

Expand All @@ -182,7 +182,7 @@ instance FreeVars (LocatedA (HsFieldBind (LocatedAn NoEpAnns (FieldLabelStrings

instance AllVars (LocatedA (Pat GhcPs)) where
allVars (L _ (VarPat _ (L _ x))) = Vars (Set.singleton $ rdrNameOcc x) Set.empty -- Variable pattern.
allVars (L _ (AsPat _ n _ x)) = allVars (noLocA $ VarPat noExtField n :: LocatedA (Pat GhcPs)) <> allVars x -- As pattern.
allVars (L _ (AsPat _ n x)) = allVars (noLocA $ VarPat noExtField n :: LocatedA (Pat GhcPs)) <> allVars x -- As pattern.
allVars (L _ (ConPat _ _ (RecCon (HsRecFields flds _)))) = allVars flds
allVars (L _ (NPlusKPat _ n _ _ _ _)) = allVars (noLocA $ VarPat noExtField n :: LocatedA (Pat GhcPs)) -- n+k pattern.
allVars (L _ (ViewPat _ e p)) = freeVars_ e <> allVars p -- View pattern.
Expand All @@ -203,7 +203,7 @@ instance AllVars (LocatedA (Pat GhcPs)) where

allVars p = allVars $ children p

instance AllVars (LocatedA (HsFieldBind (LocatedAn NoEpAnns (FieldOcc GhcPs)) (LocatedA (Pat GhcPs)))) where
instance AllVars (LocatedA (HsFieldBind (LocatedA (FieldOcc GhcPs)) (LocatedA (Pat GhcPs)))) where
allVars (L _ (HsFieldBind _ _ x _)) = allVars x

instance AllVars (LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))) where
Expand Down Expand Up @@ -241,7 +241,7 @@ instance AllVars (LocatedA (Match GhcPs (LocatedA (HsExpr GhcPs)))) where
allVars (L _ (Match _ (StmtCtxt ctxt) pats grhss)) = allVars ctxt <> allVars pats <> allVars grhss -- Pattern of a do-stmt, list comprehension, pattern guard etc.
allVars (L _ (Match _ _ pats grhss)) = inVars (allVars pats) (allVars grhss) -- Everything else.

instance AllVars (HsStmtContext GhcPs) where
instance AllVars (HsStmtContext (GenLocated SrcSpanAnnN RdrName)) where
allVars (PatGuard FunRhs{mc_fun=n}) = allVars (noLocA $ VarPat noExtField n :: LocatedA (Pat GhcPs))
allVars ParStmtCtxt{} = mempty -- Come back to it.
allVars TransStmtCtxt{} = mempty -- Come back to it.
Expand Down
40 changes: 20 additions & 20 deletions src/GHC/Util/HsExpr.hs
Original file line number Diff line number Diff line change
Expand Up @@ -49,7 +49,7 @@ import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader

-- | 'dotApp a b' makes 'a . b'.
dotApp :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
dotApp x y = noLocA $ OpApp EpAnnNotUsed x (noLocA $ HsVar noExtField (noLocA $ mkVarUnqual (fsLit "."))) y
dotApp x y = noLocA $ OpApp noAnn x (noLocA $ HsVar noExtField (noLocA $ mkVarUnqual (fsLit "."))) y

dotApps :: [LHsExpr GhcPs] -> LHsExpr GhcPs
dotApps [] = error "GHC.Util.HsExpr.dotApps', does not work on an empty list"
Expand All @@ -58,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 noExtField (MG (Generated DoPmc) (noLocA [noLocA $ Match EpAnnNotUsed LambdaExpr vs (GRHSs emptyComments [noLocA $ GRHS EpAnnNotUsed [] body] (EmptyLocalBinds noExtField))]))
lambda vs body = noLocA $ HsLam noAnn LamSingle (MG (Generated OtherExpansion DoPmc) (noLocA [noLocA $ Match noAnn (LamAlt LamSingle) 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
Expand All @@ -72,7 +72,7 @@ universeParentExp xs = concat [(Nothing, x) : f x | x <- childrenBi xs]


apps :: [LHsExpr GhcPs] -> LHsExpr GhcPs
apps = foldl1' mkApp where mkApp x y = noLocA (HsApp EpAnnNotUsed x y)
apps = foldl1' mkApp where mkApp x y = noLocA (HsApp noExtField x y)

fromApps :: LHsExpr GhcPs -> [LHsExpr GhcPs]
fromApps (L _ (HsApp _ x y)) = fromApps x ++ [y]
Expand All @@ -86,7 +86,7 @@ universeApps :: LHsExpr GhcPs -> [LHsExpr GhcPs]
universeApps x = x : concatMap universeApps (childrenApps x)

descendAppsM :: Monad m => (LHsExpr GhcPs -> m (LHsExpr GhcPs)) -> LHsExpr GhcPs -> m (LHsExpr GhcPs)
descendAppsM f (L l (HsApp _ x y)) = (\x y -> L l $ HsApp EpAnnNotUsed x y) <$> descendAppsM f x <*> f y
descendAppsM f (L l (HsApp _ x y)) = (\x y -> L l $ HsApp noExtField x y) <$> descendAppsM f x <*> f y
descendAppsM f x = descendM f x

transformAppsM :: Monad m => (LHsExpr GhcPs -> m (LHsExpr GhcPs)) -> LHsExpr GhcPs -> m (LHsExpr GhcPs)
Expand Down Expand Up @@ -117,12 +117,12 @@ rebracket1 = descendBracket (True, )
-- A list of application, with any necessary brackets.
appsBracket :: [LHsExpr GhcPs] -> LHsExpr GhcPs
appsBracket = foldl1 mkApp
where mkApp x y = rebracket1 (noLocA $ HsApp EpAnnNotUsed x y)
where mkApp x y = rebracket1 (noLocA $ HsApp noExtField x y)

simplifyExp :: LHsExpr GhcPs -> LHsExpr GhcPs
-- Replace appliciations 'f $ x' with 'f (x)'.
simplifyExp (L l (OpApp _ x op y)) | isDol op = L l (HsApp EpAnnNotUsed x (nlHsPar y))
simplifyExp e@(L _ (HsLet _ _ ((HsValBinds _ (ValBinds _ binds []))) _ z)) =
simplifyExp (L l (OpApp _ x op y)) | isDol op = L l (HsApp noExtField x (nlHsPar y))
simplifyExp e@(L _ (HsLet _ ((HsValBinds _ (ValBinds _ binds []))) z)) =
-- An expression of the form, 'let x = y in z'.
case bagToList binds of
[L _ (FunBind _ _ (MG _ (L _ [L _ (Match _(FunRhs (L _ x) _ _) [] (GRHSs _[L _ (GRHS _ [] y)] ((EmptyLocalBinds _))))])))]
Expand Down Expand Up @@ -159,7 +159,7 @@ niceLambdaR :: [String]
niceLambdaR xs (SimpleLambda [] x) = niceLambdaR xs x

-- Rewrite @\xs -> (e)@ as @\xs -> e@.
niceLambdaR xs (L _ (HsPar _ _ x _)) = niceLambdaR xs x
niceLambdaR xs (L _ (HsPar _ x)) = niceLambdaR xs x

-- @\vs v -> ($) e v@ ==> @\vs -> e@
-- @\vs v -> e $ v@ ==> @\vs -> e@
Expand All @@ -177,7 +177,7 @@ niceLambdaR [v] (L _ (OpApp _ e f (view -> Var_ v')))
, vars e `disjoint` [v]
, L _ (HsVar _ (L _ fname)) <- f
, isSymOcc $ rdrNameOcc fname
= let res = nlHsPar $ noLocA $ SectionL EpAnnNotUsed e f
= let res = nlHsPar $ noLocA $ SectionL noExtField e f
in (res, \s -> [Replace Expr s [] (unsafePrettyPrint res)])

-- @\vs v -> f x v@ ==> @\vs -> f x@
Expand All @@ -198,7 +198,7 @@ niceLambdaR xs (SimpleLambda ((view -> PVar_ v):vs) x)
-- lexeme, or it all gets too complex).
niceLambdaR [x] (view -> App2 op@(L _ (HsVar _ (L _ tag))) l r)
| isLexeme r, view l == Var_ x, x `notElem` vars r, allowRightSection (occNameStr tag) =
let e = rebracket1 $ addParen (noLocA $ SectionR EpAnnNotUsed op r)
let e = rebracket1 $ addParen (noLocA $ SectionR noExtField op r)
in (e, \s -> [Replace Expr s [] (unsafePrettyPrint e)])
-- Rewrite (1) @\x -> f (b x)@ as @f . b@, (2) @\x -> f $ b x@ as @f . b@.
niceLambdaR [x] y
Expand All @@ -213,7 +213,7 @@ niceLambdaR [x] y
factor (L _ (OpApp _ y op (factor -> Just (z, ss))))| isDol op
= let r = niceDotApp y z
in if astEq r z then Just (r, ss) else Just (r, y : ss)
factor (L _ (HsPar _ _ y@(L _ HsApp{}) _)) = factor y
factor (L _ (HsPar _ y@(L _ HsApp{}))) = factor y
factor _ = Nothing
mkRefact :: [LHsExpr GhcPs] -> R.SrcSpan -> Refactoring R.SrcSpan
mkRefact subts s =
Expand All @@ -231,36 +231,36 @@ niceLambdaR [x, y] (view -> App2 op (view -> Var_ y1) (view -> Var_ x1))
)
where
gen :: LHsExpr GhcPs -> LHsExpr GhcPs
gen = noLocA . HsApp EpAnnNotUsed (strToVar "flip")
gen = noLocA . HsApp noExtField (strToVar "flip")
. if isAtom op then id else addParen

-- We're done factoring, but have no variables left, so we shouldn't make a lambda.
-- @\ -> e@ ==> @e@
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 EpAnnNotUsed [] e :: LGRHS GhcPs (LHsExpr GhcPs)
let grhs = noLocA $ GRHS noAnn [] e :: LGRHS GhcPs (LHsExpr GhcPs)
grhss = GRHSs {grhssExt = emptyComments, grhssGRHSs=[grhs], grhssLocalBinds=EmptyLocalBinds noExtField}
match = noLocA $ Match {m_ext=EpAnnNotUsed, m_ctxt=LambdaExpr, m_pats=map strToPat ss, m_grhss=grhss} :: LMatch GhcPs (LHsExpr GhcPs)
matchGroup = MG {mg_ext=Generated DoPmc, mg_alts=noLocA [match]}
in (noLocA $ HsLam noExtField matchGroup, const [])
match = noLocA $ Match {m_ext=noAnn, m_ctxt=LamAlt LamSingle, m_pats=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 [])


-- 'case' and 'if' expressions have branches, nothing else does (this
-- doesn't consider 'HsMultiIf' perhaps it should?).
replaceBranches :: LHsExpr GhcPs -> ([LHsExpr GhcPs], [LHsExpr GhcPs] -> LHsExpr GhcPs)
replaceBranches (L l (HsIf _ a b c)) = ([b, c], \[b, c] -> L l (HsIf EpAnnNotUsed a b c))
replaceBranches (L l (HsIf _ a b c)) = ([b, c], \[b, c] -> L l (HsIf noAnn a b c))

replaceBranches (L s (HsCase _ a (MG FromSource (L l bs)))) =
(concatMap f bs, L s . HsCase EpAnnNotUsed a . MG (Generated DoPmc). L l . g 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 _ = 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 EpAnnNotUsed CaseAlt a (GRHSs emptyComments [L a (GRHS EpAnnNotUsed gs x) | (L a (GRHS _ gs _), x) <- zip ns as] b)) : g rest bs
L s1 (Match noAnn CaseAlt a (GRHSs emptyComments [L a (GRHS noAnn gs x) | (L a (GRHS _ gs _), x) <- zip 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"
Expand Down Expand Up @@ -298,7 +298,7 @@ descendBracketOld op x = (descendIndex g1 x, descendIndex' g2 x)
g1 a b = fst (g a b)
g2 a b = writer $ snd (g a b)

f i (L _ (HsPar _ _ y _)) z w
f i (L _ (HsPar _ y)) z w
| not $ needBracketOld i x y = (y, removeBracket z)
where
-- If the template expr is a Var, record it so that we can remove the brackets
Expand Down
Loading
Loading