GitLab

ce879a76

by Apoorv Ingle at 2025-11-24T10:12:25-06:00

- look through applications to check if we need deepsubsumption
- Tests cleanup

 -{-# LANGUAGE DeepSubsumption #-}
  -- -----------------------------------------------------------------------------
  --
  -- (c) The University of Glasgow 1993-2004

@@ -8,7 +8,6 @@
  {-# LANGUAGE LambdaCase #-}
  {-# LANGUAGE BlockArguments #-}
  {-# LANGUAGE ViewPatterns #-}
 -{-# LANGUAGE DeepSubsumption #-}
  module GHC.Driver.Downsweep
    ( downsweep
    , downsweepThunk

@@ -36,8 +36,7 @@ module GHC.Hs (
          module GHC.Parser.Annotation,
          HsModule(..), AnnsModule(..),
 -        HsParsedModule(..), XModulePs(..),
+-
 +        HsParsedModule(..), XModulePs(..)
  ) where
  -- friends:

@@ -1157,7 +1157,8 @@ the typechecker:
    * HsDo, where we give the SrcSpan of the entire do block to each
      ApplicativeStmt.
    * Expanded (via ExpandedThingRn) ExplicitList{}, where we give the SrcSpan of the original
 -    list expression to the 'fromListN' call.
 +    list expression to the expanded expression. The 'fromListN' is assigned
 +    a generated location span
  In order for the implicit function calls to not be confused for actual
  occurrences of functions in the source code, most of this extra information

@@ -8,7 +8,6 @@
  {-# LANGUAGE TypeApplications #-}
  {-# LANGUAGE TypeFamilies #-}
  {-# LANGUAGE OverloadedStrings #-}
 -{-# LANGUAGE DeepSubsumption #-}
  {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic TcRnMessage
  {-# LANGUAGE InstanceSigs #-}

@@ -486,11 +486,18 @@ getDeepSubsumptionFlag_DataConHead app_head =
       ; return $
           if | user_ds
              -> Deep DeepSub
 -            | XExpr (ConLikeTc (RealDataCon {})) <- app_head
 -            -> Deep TopSub
              | otherwise
 -            -> Shallow
 -    }
 +            -> go app_head
 +     }
 +  where
 +    go :: HsExpr GhcTc -> DeepSubsumptionFlag
 +    go app_head
 +     | XExpr (ConLikeTc (RealDataCon {})) <- app_head
 +     = Deep TopSub
 +     | HsApp _ f _ <- app_head
 +     = go (unLoc f)
 +     | otherwise
 +     = Shallow
  finishApp :: (HsExpr GhcTc, SrcSpan) -> [HsExprArg 'TcpTc]
            -> TcRhoType -> HsWrapper

@@ -63,7 +63,7 @@ module GHC.Tc.Utils.Monad(
    -- * Error management
    getSrcCodeOrigin,
    getSrcSpanM, setSrcSpan, setSrcSpanA, addLocM,
 -  inGeneratedCode, -- setInGeneratedCode,
 +  inGeneratedCode,
    wrapLocM, wrapLocFstM, wrapLocFstMA, wrapLocSndM, wrapLocSndMA, wrapLocM_,
    wrapLocMA_,wrapLocMA,
    getErrsVar, setErrsVar,

No preview for this file type

No preview for this file type

+-
 -module Main where
+-
 -main :: IO ()
 -main = do putStrLn "Hello"
 -          putStrLn "World"

 -{-# OPTIONS_GHC -Wall #-}
 -{-# OPTIONS_GHC -Wno-unused-local-binds #-}
 -{-# OPTIONS_GHC -Wno-unused-top-binds #-}
+-
 -main :: IO ()
 -main = do
 -  pure ()
 -  where
 -    biz :: IO ()
 -    biz = do
 -      pure (10 :: Integer)
 -      pure ()
+-
 -biz' :: IO ()
 -biz' = do
 -  pure (10 :: Integer)
 -  pure ()

 +module Test where
++
++
 +qqqq :: [String]
 +qqqq = (show (1 :: Int) :) $ ["2"]
++
 +main :: IO ()
 +main = do
 +  putStrLn "abc"
 +  putStrLn $ concat qqqq

+-
 -{-# OPTIONS_GHC -Wall #-}
 -{-# OPTIONS_GHC -Wno-unused-local-binds #-}
 -{-# OPTIONS_GHC -Wno-unused-top-binds #-}
+-
 -module T25996 where
+-
 -main :: IO ()
 -main = do
 -  pure ()
 -  where
 -    biz :: IO ()
 -    biz = do
 -      pure (10 :: Integer)
 -      pure ()
+-
 -biz' :: IO ()
 -biz' = do
 -  pure (10 :: Integer)
 -  pure ()

@@ -658,8 +658,8 @@ def onlyHsParLocs(x):
      """
      ls = x.split("\n")
      filteredLines = (loc.strip() for (loc,hspar) in zip(ls,ls[5:])
 -                      if hspar.strip().startswith("(HsPar")
 -                        and not "<no location info>" in loc)
 +		      if hspar.strip().startswith("(HsPar")
 +			and not "<no location info>" in loc)
      return '\n'.join(filteredLines)
  test('T15242', normalise_errmsg_fun(onlyHsParLocs), compile, [''])
  test('T15431', normal, compile, [''])
@@ -957,3 +957,4 @@ test('T17705', normal, compile, [''])
  test('T14745', normal, compile, [''])
  test('T26451', normal, compile, [''])
  test('T26582', normal, compile, [''])
 +test('ExpansionQLIm', normal, compile, [''])

+-
 -{-# LANGUAGE TypeFamilies #-}
 -module T25970 where
+-
 -y :: IO ()
 -y = putStrLn "y"
+-
+-
 -type family K a where
 -  K a = Bool
+-
 -x :: IO (K b)
 -x = do
 -  y
 -  pure () -- The error should point here or on the whole do block
+-
 -x' :: IO (K b)
 -x' = y >> pure ()

+-
 -{-# OPTIONS_GHC -Wall #-}
 -{-# OPTIONS_GHC -Wno-unused-local-binds #-}
 -{-# OPTIONS_GHC -Wno-unused-top-binds #-}
+-
 -module T25996 where
+-
 -main :: IO ()
 -main = do
 -  pure ()
 -  where
 -    biz :: IO ()
 -    biz = do
 -      pure (10 :: Integer) -- This warning should be reported only once
 -      pure ()
+-
 -biz' :: IO ()
 -biz' = do
 -  pure (10 :: Integer)
 -  pure ()

+-
  T7857.hs:8:11: error: [GHC-39999]
      • Could not deduce ‘PrintfType a0’ arising from a use of ‘printf’
 -      from the context: PrintfArg t
 -        bound by the inferred type of g :: PrintfArg t => t -> b
 +      from the context: PrintfArg q
 +        bound by the inferred type of g :: PrintfArg q => q -> b
          at T7857.hs:8:1-21
        The type variable ‘a0’ is ambiguous
        Potentially matching instances:
@@ -15,3 +14,4 @@ T7857.hs:8:11: error: [GHC-39999]
      • In the second argument of ‘($)’, namely ‘printf "" i’
        In the expression: f $ printf "" i
        In an equation for ‘g’: g i = f $ printf "" i
++

  tcfail181.hs:17:9: error: [GHC-39999]
 -    • Could not deduce ‘Monad m0’ arising from a record update
 +    • Could not deduce ‘Monad m0’ arising from a use of ‘foo’
        from the context: Monad m
          bound by the inferred type of
                     wog :: Monad m => p -> Something (m Bool) e