updates for GHC HEAD

src/GHC/Util/Brackets.hs

@@ -36,8 +36,6 @@ instance Brackets (LocatedA (HsExpr GhcPs)) where
   isAtom (L _ x) = case x of
       HsVar{} -> True
       HsUnboundVar{} -> True
-      -- Technically atomic, but lots of people think it shouldn't be
-      HsRecSel{} -> False
       -- Only relevant for OverloadedRecordDot extension
       HsGetField{} -> True
       HsOverLabel{} -> True
@@ -61,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
@@ -133,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

@@ -128,7 +128,6 @@ instance FreeVars (LocatedA (HsExpr GhcPs)) where
   freeVars (L _ (HsUntypedBracket _ (ExpBr _ e))) = freeVars e
   freeVars (L _ (HsUntypedBracket _ (VarBr _ _ v))) = Set.fromList [occName (unLoc v)]
 
-  freeVars (L _ HsRecSel{}) = mempty -- Variable pointing to a record selector.
   freeVars (L _ HsOverLabel{}) = mempty -- Overloaded label. The id of the in-scope fromLabel.
   freeVars (L _ HsIPVar{}) = mempty -- Implicit parameter.
   freeVars (L _ HsOverLit{}) = mempty -- Overloaded literal.
@@ -172,10 +171,6 @@ instance FreeVars (LocatedA (HsFieldBind (LocatedA (FieldOcc GhcPs)) (LocatedA (
    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 (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
   freeVars (L _ (HsFieldBind _ _ x _)) = freeVars x
 

src/GHC/Util/HsExpr.hs

@@ -48,7 +48,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 noAnn x (noLocA $ HsVar noExtField (noLocA $ mkVarUnqual (fsLit "."))) y
+dotApp x y = noLocA $ OpApp noExtField 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"
@@ -57,7 +57,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 noAnn (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 +124,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 ->
@@ -240,7 +240,7 @@ niceLambdaR [] e = (e, \s -> [Replace Expr s [("a", toSSA e)] "a"])
 niceLambdaR ss e =
   let grhs = noLocA $ GRHS noAnn [] e :: LGRHS GhcPs (LHsExpr GhcPs)
       grhss = GRHSs {grhssExt = emptyComments, grhssGRHSs=[grhs], grhssLocalBinds=EmptyLocalBinds noExtField}
-      match = noLocA $ Match {m_ext=noAnn, m_ctxt=LamAlt LamSingle, m_pats=noLocA $ map strToPat ss, m_grhss=grhss} :: LMatch GhcPs (LHsExpr GhcPs)
+      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 [])
 
@@ -259,7 +259,7 @@ replaceBranches (L s (HsCase _ a (MG FromSource (L l bs)))) =
 
     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 noAnn 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 [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"

src/GHC/Util/Unify.hs

@@ -78,7 +78,7 @@ 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 noAnn lhs y rhs))
+      | Just y <- lookup (rdrNameStr x) bind = Just (L loc (OpApp noExtField lhs y rhs))
     -- Left sections.
     exp (L loc (SectionL _ exp (L _ (HsVar _ x))))
       | Just y <- lookup (rdrNameStr x) bind = Just (L loc (SectionL noExtField exp y))
@@ -164,7 +164,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 noAnn y11 dot y121)) dot' y122
+            unifyComposed' nm x1 (noLocA (OpApp noExtField y11 dot y121)) dot' y122
           _ -> Nothing
 
 -- unifyExp handles the cases where both x and y are HsApp, or y is OpApp. Otherwise,

src/Hint/Bracket.hs

@@ -287,16 +287,16 @@ dollar = concatMap f . universe
           ++  -- Special case of (v1 . v2) <$> v3
           [ (suggest "Redundant bracket" (reLoc x) (reLoc y) [r]){ideaSpan = locA locPar}
           | L _ (OpApp _ (L locPar (HsPar _ o1@(L locNoPar (OpApp _ _ (isDot -> True) _)))) o2 v3) <- [x], varToStr o2 == "<$>"
-          , let y = noLocA (OpApp noAnn o1 o2 v3) :: LHsExpr GhcPs
+          , let y = noLocA (OpApp noExtField o1 o2 v3) :: LHsExpr GhcPs
           , let r = Replace Expr (toRefactSrcSpan (locA locPar)) [("a", toRefactSrcSpan (locA locNoPar))] "a"]
           ++
           [ suggest "Redundant section" (reLoc x) (reLoc y) [r]
           | L _ (HsApp _ (L _ (HsPar _ (L _ (SectionL _ a b)))) c) <- [x]
           -- , error $ show (unsafePrettyPrint a, gshow b, unsafePrettyPrint c)
-          , let y = noLocA $ OpApp noAnn a b c :: LHsExpr GhcPs
+          , let y = noLocA $ OpApp noExtField a b c :: LHsExpr GhcPs
           , let r = Replace Expr (toSSA x) [("x", toSSA a), ("op", toSSA b), ("y", toSSA c)] "x op y"]
 
 splitInfix :: LHsExpr GhcPs -> [(LHsExpr GhcPs -> LHsExpr GhcPs, LHsExpr GhcPs)]
 splitInfix (L l (OpApp _ lhs op rhs)) =
-  [(L l . OpApp noAnn lhs op, rhs), (\lhs -> L l (OpApp noAnn lhs op rhs), lhs)]
+  [(L l . OpApp noExtField lhs op, rhs), (\lhs -> L l (OpApp noExtField lhs op rhs), lhs)]
 splitInfix _ = []

src/Hint/Lambda.hs

@@ -149,7 +149,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 +172,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 noAnn 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

src/Hint/List.hs

@@ -260,7 +260,7 @@ useCons False (view -> App2 op x y) | varToStr op == "++"
     f _ = Nothing
 
     gen :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
-    gen x = noLocA . OpApp noAnn x (noLocA (HsVar noExtField  (noLocA consDataCon_RDR)))
+    gen x = noLocA . OpApp noExtField x (noLocA (HsVar noExtField  (noLocA consDataCon_RDR)))
 useCons _ _ = Nothing
 
 typeListChar :: LHsType GhcPs

src/Hint/ListRec.hs

@@ -175,7 +175,7 @@ findCase x = do
       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.
-      match e = Match{m_ext=noAnn,m_pats=noLocA ps12, m_grhss=gRHSSs e, ..} -- Match.
+      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.
 

src/Hint/Monad.hs

@@ -120,7 +120,7 @@ monadExp decl parentDo parentExpr x =
     (view -> App2 op x1 x2) | isTag ">>" op -> f x1
     (view -> App2 op x1 (view -> LamConst1 _)) | isTag ">>=" op -> f x1
     (L l (HsApp _ op x)) | isTag "void" op -> seenVoid (L l . HsApp noExtField op) x
-    (L l (OpApp _ op dol x)) | isTag "void" op, isDol dol -> seenVoid (L l . OpApp noAnn op dol) x
+    (L l (OpApp _ op dol x)) | isTag "void" op, isDol dol -> seenVoid (L l . OpApp noExtField op dol) x
     (L loc (HsDo _ ctx (L loc2 [L loc3 (BodyStmt _ y _ _ )]))) ->
       let doOrMDo = case ctx of MDoExpr _ -> "mdo"; _ -> "do"
        in [ ideaRemove Ignore ("Redundant " ++ doOrMDo) (doSpan doOrMDo (locA loc)) doOrMDo [Replace Expr (toSSA x) [("y", toSSA y)] "y"]
@@ -191,7 +191,7 @@ modifyAppHead f = go id
     go :: (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> (LHsExpr GhcPs, Maybe a)
     go wrap (L l (HsPar _ x)) = go (wrap . L l . \y -> HsPar noAnn y) x
     go wrap (L l (HsApp _ x y)) = go (\x -> wrap $ L l (HsApp noExtField x y)) x
-    go wrap (L l (OpApp _ x op y)) | isDol op = go (\x -> wrap $ L l (OpApp noAnn x op y)) x
+    go wrap (L l (OpApp _ x op y)) | isDol op = go (\x -> wrap $ L l (OpApp noExtField x op y)) x
     go wrap (L l (HsVar _ x)) = (wrap (L l (HsVar NoExtField x')), Just a)
       where (x', a) = f x
     go _ expr = (expr, Nothing)
@@ -207,8 +207,8 @@ monadNoResult :: String -> (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs ->
 monadNoResult inside wrap (L l (HsPar _ x)) = monadNoResult inside (wrap . nlHsPar) x
 monadNoResult inside wrap (L l (HsApp _ x y)) = monadNoResult inside (\x -> wrap $ L l (HsApp noExtField x y)) x
 monadNoResult inside wrap (L l (OpApp _ x tag@(L _ (HsVar _ (L _ op))) y))
-    | isDol tag = monadNoResult inside (\x -> wrap $ L l (OpApp noAnn x tag y)) x
-    | occNameStr op == ">>=" = monadNoResult inside (wrap . L l . OpApp noAnn x tag) y
+    | isDol tag = monadNoResult inside (\x -> wrap $ L l (OpApp noExtField x tag y)) x
+    | occNameStr op == ">>=" = monadNoResult inside (wrap . L l . OpApp noExtField x tag) y
 monadNoResult inside wrap x
     | x2 : _ <- filter (`isTag` x) badFuncs
     , let x3 = x2 ++ "_"
@@ -260,7 +260,7 @@ monadStep wrap
     , q@(L _ (BodyStmt _ (fromApplies -> (ret:f:fs, view -> Var_ v)) _ _))]
   | isReturn ret, notDol x, u == v, length fs < 3, all isSimple (f : fs), v `notElem` vars (f : fs)
   =
-      [warn "Use <$>" (reLoc (wrap o)) (reLoc (wrap [noLocA $ BodyStmt noExtField (noLocA $ OpApp noAnn (foldl' (\acc e -> noLocA $ OpApp noAnn acc (strToVar ".") e) f fs) (strToVar "<$>") x) noSyntaxExpr noSyntaxExpr]))
+      [warn "Use <$>" (reLoc (wrap o)) (reLoc (wrap [noLocA $ BodyStmt noExtField (noLocA $ OpApp noExtField (foldl' (\acc e -> noLocA $ OpApp noExtField acc (strToVar ".") e) f fs) (strToVar "<$>") x) noSyntaxExpr noSyntaxExpr]))
       [Replace Stmt (toSSA g) (("x", toSSA x):zip vs (toSSA <$> f:fs)) (intercalate " . " (take (length fs + 1) vs) ++ " <$> x"), Delete Stmt (toSSA q)]]
   where
     isSimple (fromApps -> xs) = all isAtom (x : xs)
@@ -296,7 +296,7 @@ monadLet xs = mapMaybe mkLet xs
         let p = noLocA $ mkRdrUnqual (mkVarOcc lhs)
             grhs = noLocA (GRHS noAnn [] rhs)
             grhss = GRHSs emptyComments [grhs] (EmptyLocalBinds noExtField)
-            match = noLocA $ Match noAnn (FunRhs p Prefix NoSrcStrict) (noLocA []) grhss
+            match = noLocA $ Match noExtField (FunRhs p Prefix NoSrcStrict noAnn) (noLocA []) grhss
             fb = noLocA $ FunBind noExtField p (MG (Generated OtherExpansion SkipPmc) (noLocA [match]))
             binds = [fb]
             valBinds = ValBinds NoAnnSortKey binds []

src/Hint/Pattern.hs

@@ -194,7 +194,7 @@ asPattern (L loc x) = concatMap decl (universeBi x)
     decl _ = []
 
     match :: LMatch GhcPs (LHsExpr GhcPs) -> (Pattern, String -> Pattern -> [Refactoring R.SrcSpan] -> Idea)
-    match o@(L loc (Match _ ctx (L lpats pats) grhss)) = (Pattern (locA loc) R.Match pats grhss, \msg (Pattern _ _ pats grhss) rs -> suggest msg (reLoc o) (noLoc (Match noAnn ctx  (L lpats pats) grhss) :: Located (Match GhcPs (LHsExpr GhcPs))) rs)
+    match o@(L loc (Match _ ctx (L lpats pats) grhss)) = (Pattern (locA loc) R.Match pats grhss, \msg (Pattern _ _ pats grhss) rs -> suggest msg (reLoc o) (noLoc (Match noExtField ctx  (L lpats pats) grhss) :: Located (Match GhcPs (LHsExpr GhcPs))) rs)
 
 -- First Bool is if 'Strict' is a language extension. Second Bool is
 -- if this pattern in this context is going to be evaluated strictly.