Skip to content

Commit

Permalink
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
updates for compatibility with GHC HEAD
Browse files Browse the repository at this point in the history
shayne-fletcher committed Dec 1, 2023
1 parent e760b31 commit 4a93b0f
Showing 26 changed files with 137 additions and 137 deletions.
8 changes: 4 additions & 4 deletions src/Config/Compute.hs
Original file line number Diff line number Diff line change
@@ -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 noAnn x $ nlHsPar $ noLocA $ HsApp noAnn y $ noLocA $ mkVar "_hlint"

findExp name vs bod = [SettingMatchExp $
HintRule Warning defaultHintName []
@@ -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 noAnn x $ nlHsPar y
f x = x


4 changes: 2 additions & 2 deletions src/Config/Yaml.hs
Original file line number Diff line number Diff line change
@@ -163,7 +163,7 @@ parseFail (Val focus path) msg = fail $
-- aim to show a smallish but relevant context
dotDot (fromMaybe (encode focus) $ listToMaybe $ dropWhile (\x -> BS.length x > 250) $ map encode contexts)
where
(steps, contexts) = unzip $ reverse path
(steps, contexts) = Prelude.unzip $ reverse path
dotDot x = let (a,b) = BS.splitAt 250 x in BS.unpack a ++ (if BS.null b then "" else "...")

parseArray :: Val -> Parser [Val]
@@ -441,7 +441,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 NoLayoutInfo Nothing Nothing) Nothing Nothing (concatMap f xs) [])
where
f (Right x) = [x]
f (Left x) | Just pkg <- Map.lookup x packages = pkg
2 changes: 1 addition & 1 deletion src/GHC/All.hs
Original file line number Diff line number Diff line change
@@ -101,7 +101,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
6 changes: 2 additions & 4 deletions src/GHC/Util/ApiAnnotation.hs
Original file line number Diff line number Diff line change
@@ -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
@@ -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
@@ -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

Check failure on line 108 in src/GHC/Util/ApiAnnotation.hs

GitHub Actions / test (ubuntu-latest, 9.4)

Not in scope: type constructor or class ‘NoCommentsLocation’

Check failure on line 108 in src/GHC/Util/ApiAnnotation.hs

GitHub Actions / test (windows-latest, 9.6)

Not in scope: type constructor or class ‘NoCommentsLocation’

Check failure on line 108 in src/GHC/Util/ApiAnnotation.hs

GitHub Actions / test (ubuntu-latest, 9.6)

Not in scope: type constructor or class ‘NoCommentsLocation’

Check failure on line 108 in src/GHC/Util/ApiAnnotation.hs

GitHub Actions / test (ubuntu-latest, 9.2)

Not in scope: type constructor or class ‘NoCommentsLocation’

Check failure on line 108 in src/GHC/Util/ApiAnnotation.hs

GitHub Actions / test (macOS-latest, 9.6)

Not in scope: type constructor or class ‘NoCommentsLocation’
mkFlags anc flags =
L anc $ EpaComment (EpaBlockComment ("{-# " ++ "OPTIONS_GHC " ++ unwords flags ++ " #-}")) (anchor anc)

mkLanguagePragmas :: Anchor -> [String] -> LEpaComment
mkLanguagePragmas :: NoCommentsLocation -> [String] -> LEpaComment

Check failure on line 112 in src/GHC/Util/ApiAnnotation.hs

GitHub Actions / test (ubuntu-latest, 9.4)

Not in scope: type constructor or class ‘NoCommentsLocation’

Check failure on line 112 in src/GHC/Util/ApiAnnotation.hs

GitHub Actions / test (windows-latest, 9.6)

Not in scope: type constructor or class ‘NoCommentsLocation’

Check failure on line 112 in src/GHC/Util/ApiAnnotation.hs

GitHub Actions / test (ubuntu-latest, 9.6)

Not in scope: type constructor or class ‘NoCommentsLocation’

Check failure on line 112 in src/GHC/Util/ApiAnnotation.hs

GitHub Actions / test (ubuntu-latest, 9.2)

Not in scope: type constructor or class ‘NoCommentsLocation’

Check failure on line 112 in src/GHC/Util/ApiAnnotation.hs

GitHub Actions / test (macOS-latest, 9.6)

Not in scope: type constructor or class ‘NoCommentsLocation’
mkLanguagePragmas anc exts =
L anc $ EpaComment (EpaBlockComment ("{-# " ++ "LANGUAGE " ++ intercalate ", " exts ++ " #-}")) (anchor anc)
2 changes: 1 addition & 1 deletion src/GHC/Util/Brackets.hs
Original file line number Diff line number Diff line change
@@ -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
16 changes: 8 additions & 8 deletions src/GHC/Util/FreeVars.hs
Original file line number Diff line number Diff line change
@@ -99,8 +99,8 @@ 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.

Check failure on line 102 in src/GHC/Util/FreeVars.hs

GitHub Actions / test (ubuntu-latest, 9.4)

Not in scope: data constructor ‘LamSingle’

Check failure on line 102 in src/GHC/Util/FreeVars.hs

GitHub Actions / test (windows-latest, 9.6)

Not in scope: data constructor ‘LamSingle’

Check failure on line 102 in src/GHC/Util/FreeVars.hs

GitHub Actions / test (ubuntu-latest, 9.6)

Not in scope: data constructor ‘LamSingle’

Check failure on line 102 in src/GHC/Util/FreeVars.hs

GitHub Actions / test (macOS-latest, 9.6)

Not in scope: data constructor ‘LamSingle’
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 _ (HsDo _ ctxt (L _ stmts))) = snd $ foldl' alg mempty stmts -- Do block.
@@ -122,8 +122,8 @@ instance FreeVars (LocatedA (HsExpr GhcPs)) where
freeVars (L _ (RecordCon _ _ (HsRecFields flds _))) = Set.unions $ map freeVars flds -- Record construction.
freeVars (L _ (RecordUpd _ e flds)) =
case flds of
Left fs -> Set.unions $ freeVars e : map freeVars fs
Right ps -> Set.unions $ freeVars e : map freeVars ps
RegularRecUpdFields _ fs -> Set.unions $ freeVars e : map freeVars fs

Check failure on line 125 in src/GHC/Util/FreeVars.hs

GitHub Actions / test (ubuntu-latest, 9.4)

Not in scope: data constructor ‘RegularRecUpdFields’

Check failure on line 125 in src/GHC/Util/FreeVars.hs

GitHub Actions / test (windows-latest, 9.6)

Not in scope: data constructor ‘RegularRecUpdFields’

Check failure on line 125 in src/GHC/Util/FreeVars.hs

GitHub Actions / test (ubuntu-latest, 9.6)

Not in scope: data constructor ‘RegularRecUpdFields’

Check failure on line 125 in src/GHC/Util/FreeVars.hs

GitHub Actions / test (macOS-latest, 9.6)

Not in scope: data constructor ‘RegularRecUpdFields’
OverloadedRecUpdFields _ ps -> Set.unions $ freeVars e : map freeVars ps

Check failure on line 126 in src/GHC/Util/FreeVars.hs

GitHub Actions / test (ubuntu-latest, 9.4)

Not in scope: data constructor ‘OverloadedRecUpdFields’

Check failure on line 126 in src/GHC/Util/FreeVars.hs

GitHub Actions / test (windows-latest, 9.6)

Not in scope: data constructor ‘OverloadedRecUpdFields’

Check failure on line 126 in src/GHC/Util/FreeVars.hs

GitHub Actions / test (ubuntu-latest, 9.6)

Not in scope: data constructor ‘OverloadedRecUpdFields’

Check failure on line 126 in src/GHC/Util/FreeVars.hs

GitHub Actions / test (macOS-latest, 9.6)

Not in scope: data constructor ‘OverloadedRecUpdFields’
freeVars (L _ (HsMultiIf _ grhss)) = free (allVars grhss) -- Multi-way if.
freeVars (L _ (HsTypedBracket _ e)) = freeVars e
freeVars (L _ (HsUntypedBracket _ (ExpBr _ e))) = freeVars e
@@ -169,12 +169,12 @@ 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
freeVars (L _ (HsFieldBind _ x _ True)) = Set.singleton $ rdrNameOcc $ rdrNameAmbiguousFieldOcc $ unLoc x -- a pun
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

instance FreeVars (LocatedA (HsFieldBind (LocatedAn NoEpAnns (FieldLabelStrings GhcPs)) (LocatedA (HsExpr GhcPs)))) where
@@ -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
32 changes: 16 additions & 16 deletions src/GHC/Util/HsExpr.hs
Original file line number Diff line number Diff line change
@@ -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"
@@ -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 (noLocA [noLocA $ Match EpAnnNotUsed LambdaExpr vs (GRHSs emptyComments [noLocA $ GRHS EpAnnNotUsed [] body] (EmptyLocalBinds noExtField))]))
lambda vs body = noLocA $ HsLam noAnn LamSingle (MG (Generated 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
@@ -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 noAnn x y)

fromApps :: LHsExpr GhcPs -> [LHsExpr GhcPs]
fromApps (L _ (HsApp _ x y)) = fromApps x ++ [y]
@@ -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 noAnn 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)
@@ -117,11 +117,11 @@ 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 noAnn 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 (L l (OpApp _ x op y)) | isDol op = L l (HsApp noAnn 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
@@ -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 noAnn e f
in (res, \s -> [Replace Expr s [] (unsafePrettyPrint res)])

-- @\vs v -> f x v@ ==> @\vs -> f x@
@@ -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 noAnn 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
@@ -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 noAnn (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, 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 DoPmc, 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 . L l . g bs)
(concatMap f bs, L s . HsCase noAnn a . MG (Generated DoPmc). 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"
6 changes: 3 additions & 3 deletions src/GHC/Util/SrcLoc.hs
Original file line number Diff line number Diff line change
@@ -17,9 +17,9 @@ import Data.Default
import Data.Data
import Data.Generics.Uniplate.DataOnly

-- Get the 'SrcSpan' out of a value located by an 'Anchor' (e.g.
-- comments).
getAncLoc :: GenLocated Anchor a -> SrcSpan
-- Get the 'SrcSpan' out of a value located by an 'NoCommentsLocation'
-- (e.g. comments).
getAncLoc :: GenLocated NoCommentsLocation a -> SrcSpan

Check failure on line 22 in src/GHC/Util/SrcLoc.hs

GitHub Actions / test (ubuntu-latest, 9.4)

Not in scope: type constructor or class ‘NoCommentsLocation’

Check failure on line 22 in src/GHC/Util/SrcLoc.hs

GitHub Actions / test (windows-latest, 9.6)

Not in scope: type constructor or class ‘NoCommentsLocation’

Check failure on line 22 in src/GHC/Util/SrcLoc.hs

GitHub Actions / test (ubuntu-latest, 9.6)

Not in scope: type constructor or class ‘NoCommentsLocation’

Check failure on line 22 in src/GHC/Util/SrcLoc.hs

GitHub Actions / test (macOS-latest, 9.6)

Not in scope: type constructor or class ‘NoCommentsLocation’
getAncLoc o = RealSrcSpan (anchor (getLoc o)) GHC.Data.Strict.Nothing

-- 'stripLocs x' is 'x' with all contained source locs replaced by
17 changes: 8 additions & 9 deletions src/GHC/Util/Unify.hs
Original file line number Diff line number Diff line change
@@ -77,13 +77,13 @@ substitute (Subst bind) = transformBracketOld exp . transformBi pat . transformB
exp (L _ (HsVar _ x)) = lookup (rdrNameStr x) bind
-- Operator applications.
exp (L loc (OpApp _ lhs (L _ (HsVar _ x)) rhs))
| Just y <- lookup (rdrNameStr x) bind = Just (L loc (OpApp EpAnnNotUsed lhs y rhs))
| Just y <- lookup (rdrNameStr x) bind = Just (L loc (OpApp noAnn lhs y rhs))
-- Left sections.
exp (L loc (SectionL _ exp (L _ (HsVar _ x))))
| Just y <- lookup (rdrNameStr x) bind = Just (L loc (SectionL EpAnnNotUsed exp y))
| Just y <- lookup (rdrNameStr x) bind = Just (L loc (SectionL noAnn exp y))
-- Right sections.
exp (L loc (SectionR _ (L _ (HsVar _ x)) exp))
| Just y <- lookup (rdrNameStr x) bind = Just (L loc (SectionR EpAnnNotUsed y exp))
| Just y <- lookup (rdrNameStr x) bind = Just (L loc (SectionR noAnn y exp))
exp _ = Nothing

pat :: LPat GhcPs -> LPat GhcPs
@@ -126,7 +126,6 @@ unify' nm root x y
| Just (x :: EpAnn AnnsIf) <- cast x = Just mempty
| Just (x :: EpAnn AnnSig) <- cast x = Just mempty
| Just (x :: EpAnn AnnsModule) <- cast x = Just mempty
| Just (x :: EpAnn EpaLocation) <- cast x = Just mempty
| Just (x :: EpAnn EpAnnHsCase) <- cast x = Just mempty
| Just (x :: EpAnn EpAnnImportDecl) <- cast x = Just mempty
| Just (x :: EpAnn EpAnnSumPat) <- cast x = Just mempty
@@ -154,7 +153,7 @@ unifyComposed' nm x1 y11 dot y12 =
((, Just y11) <$> unifyExp' nm False x1 y12)
<|> case y12 of
(L _ (OpApp _ y121 dot' y122)) | isDot dot' ->
unifyComposed' nm x1 (noLocA (OpApp EpAnnNotUsed y11 dot y121)) dot' y122
unifyComposed' nm x1 (noLocA (OpApp noAnn y11 dot y121)) dot' y122
_ -> Nothing

-- unifyExp handles the cases where both x and y are HsApp, or y is OpApp. Otherwise,
@@ -188,7 +187,7 @@ unifyExp nm root x@(L _ (HsApp _ x1 x2)) (L _ (HsApp _ y1 y2)) =
-- Attempt #1: rewrite '(fun1 . fun2) arg' as 'fun1 (fun2 arg)', and unify it with 'x'.
-- The guard ensures that you don't get duplicate matches because the matching engine
-- auto-generates hints in dot-form.
(, Nothing) <$> unifyExp' nm root x (noLocA (HsApp EpAnnNotUsed y11 (noLocA (HsApp EpAnnNotUsed y12 y2))))
(, Nothing) <$> unifyExp' nm root x (noLocA (HsApp noAnn y11 (noLocA (HsApp noAnn y12 y2))))
else do
-- Attempt #2: rewrite '(fun1 . fun2 ... funn) arg' as 'fun1 $ (fun2 ... funn) arg',
-- 'fun1 . fun2 $ (fun3 ... funn) arg', 'fun1 . fun2 . fun3 $ (fun4 ... funn) arg',
@@ -203,9 +202,9 @@ unifyExp nm root x@(L _ (HsApp _ x1 x2)) (L _ (HsApp _ y1 y2)) =
unifyExp nm root x (L _ (OpApp _ lhs2 op2@(L _ (HsVar _ op2')) rhs2))
| (L _ (OpApp _ lhs1 op1@(L _ (HsVar _ op1')) rhs1)) <- x =
guard (nm op1' op2') >> (, Nothing) <$> liftA2 (<>) (unifyExp' nm False lhs1 lhs2) (unifyExp' nm False rhs1 rhs2)
| isDol op2 = unifyExp nm root x $ noLocA (HsApp EpAnnNotUsed lhs2 rhs2)
| isAmp op2 = unifyExp nm root x $ noLocA (HsApp EpAnnNotUsed rhs2 lhs2)
| otherwise = unifyExp nm root x $ noLocA (HsApp EpAnnNotUsed (noLocA (HsApp EpAnnNotUsed op2 (addPar lhs2))) (addPar rhs2))
| isDol op2 = unifyExp nm root x $ noLocA (HsApp noAnn lhs2 rhs2)
| isAmp op2 = unifyExp nm root x $ noLocA (HsApp noAnn rhs2 lhs2)
| otherwise = unifyExp nm root x $ noLocA (HsApp noAnn (noLocA (HsApp noAnn op2 (addPar lhs2))) (addPar rhs2))
where
-- add parens around when desugaring the expression, if necessary
addPar :: LHsExpr GhcPs -> LHsExpr GhcPs
4 changes: 2 additions & 2 deletions src/GHC/Util/View.hs
Original file line number Diff line number Diff line change
@@ -32,7 +32,7 @@ data App2 = NoApp2 | App2 (LocatedA (HsExpr GhcPs)) (LocatedA (HsExpr GhcPs))
data LamConst1 = NoLamConst1 | LamConst1 (LocatedA (HsExpr GhcPs))

instance View (LocatedA (HsExpr GhcPs)) LamConst1 where
view (fromParen -> (L _ (HsLam _ (MG FromSource (L _ [L _ (Match _ LambdaExpr [L _ WildPat {}]
view (fromParen -> (L _ (HsLam _ _ (MG FromSource (L _ [L _ (Match _ (LamAlt _) [L _ WildPat {}]

Check failure on line 35 in src/GHC/Util/View.hs

GitHub Actions / test (ubuntu-latest, 9.4)

Not in scope: data constructor ‘LamAlt’

Check failure on line 35 in src/GHC/Util/View.hs

GitHub Actions / test (windows-latest, 9.6)

Not in scope: data constructor ‘LamAlt’

Check failure on line 35 in src/GHC/Util/View.hs

GitHub Actions / test (ubuntu-latest, 9.6)

Not in scope: data constructor ‘LamAlt’

Check failure on line 35 in src/GHC/Util/View.hs

GitHub Actions / test (macOS-latest, 9.6)

Not in scope: data constructor ‘LamAlt’
(GRHSs _ [L _ (GRHS _ [] x)] ((EmptyLocalBinds _))))]))))) = LamConst1 x
view _ = NoLamConst1

@@ -62,4 +62,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 _ (MG _ (L _ [L _ (Match _ _ vs (GRHSs _ [L _ (GRHS _ [] body)] ((EmptyLocalBinds _))))])))
pattern SimpleLambda vs body <- L _ (HsLam _ LamSingle (MG _ (L _ [L _ (Match _ _ vs (GRHSs _ [L _ (GRHS _ [] body)] ((EmptyLocalBinds _))))])))

Check failure on line 65 in src/GHC/Util/View.hs

GitHub Actions / test (ubuntu-latest, 9.4)

Not in scope: data constructor ‘LamSingle’

Check failure on line 65 in src/GHC/Util/View.hs

GitHub Actions / test (windows-latest, 9.6)

Not in scope: data constructor ‘LamSingle’

Check failure on line 65 in src/GHC/Util/View.hs

GitHub Actions / test (ubuntu-latest, 9.6)

Not in scope: data constructor ‘LamSingle’

Check failure on line 65 in src/GHC/Util/View.hs

GitHub Actions / test (macOS-latest, 9.6)

Not in scope: data constructor ‘LamSingle’
Loading

0 comments on commit 4a93b0f

Please sign in to comment.