Apoorv Ingle pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC

Commits:

2 changed files:

Changes:

  • compiler/GHC/Tc/Instance/Class.hs
    ... ... @@ -22,7 +22,7 @@ import GHC.Tc.Instance.Typeable
    22 22 
     import GHC.Tc.Utils.TcMType
    23 23 
     import GHC.Tc.Types.Evidence
    24 24 
     import GHC.Tc.Types.CtLoc
    25 
    -import GHC.Tc.Types.Origin ( InstanceWhat (..), SafeOverlapping, CtOrigin(GetFieldOrigin) )
    25 
    +import GHC.Tc.Types.Origin ( InstanceWhat (..), SafeOverlapping, CtOrigin(ExpansionOrigin) )
    26 26 
     import GHC.Tc.Instance.Family( tcGetFamInstEnvs, tcInstNewTyCon_maybe, tcLookupDataFamInst, FamInstEnvs )
    27 27 
     import GHC.Rename.Env( addUsedGRE, addUsedDataCons, DeprecationWarnings (..) )
    28 28
    ... ... @@ -61,7 +61,7 @@ import GHC.Data.Maybe ( expectJust )
    61 61
    62 62 
     import GHC.Unit.Module.Warnings
    63 63
    64 
    -import GHC.Hs.Extension
    64 
    +import GHC.Hs
    65 65
    66 66 
     import Language.Haskell.Syntax.Basic (FieldLabelString(..))
    67 67 
     import GHC.Types.Id.Info
    ... ... @@ -1327,7 +1327,7 @@ warnIncompleteRecSel dflags sel_id ct_loc
    1327 1327
    1328 1328 
         -- GHC.Tc.Gen.App.tcInstFun arranges that the CtOrigin of (r.x) is GetFieldOrigin,
    1329 1329 
         -- despite the expansion to (getField @"x" r)
    1330 
    -    isGetFieldOrigin (GetFieldOrigin {}) = True
    1330 
    +    isGetFieldOrigin (ExpansionOrigin (OrigExpr (HsGetField {}))) = True
    1331 1331 
         isGetFieldOrigin _                   = False
    1332 1332
    1333 1333 
     lookupHasFieldLabel

  • compiler/GHC/Tc/Types/Origin.hs
    ... ... @@ -783,10 +783,7 @@ lexprCtOrigin (L _ e) = exprCtOrigin e
    783 783
    784 784 
     exprCtOrigin :: HsExpr GhcRn -> CtOrigin
    785 785 
     exprCtOrigin (HsVar _ (L _ (WithUserRdr _ name))) = OccurrenceOf name
    786 
    -exprCtOrigin e@(HsGetField _ _ (L _ _)) = ExpansionOrigin (OrigExpr e)
    787 
    -                                        -- GetFieldOrigin (field_label $ unLoc $ dfoLabel f)
    788 786 
     exprCtOrigin (HsOverLabel _ l)  = OverLabelOrigin l
    789 
    -exprCtOrigin (ExplicitList {})    = ListOrigin
    790 787 
     exprCtOrigin (HsIPVar _ ip)       = IPOccOrigin ip
    791 788 
     exprCtOrigin (HsOverLit _ lit)    = LiteralOrigin lit
    792 789 
     exprCtOrigin (HsLit {})           = Shouldn'tHappenOrigin "concrete literal"
    ... ... @@ -796,18 +793,15 @@ exprCtOrigin (HsAppType _ e1 _) = lexprCtOrigin e1
    796 793 
     exprCtOrigin (OpApp _ _ op _)     = lexprCtOrigin op
    797 794 
     exprCtOrigin (NegApp _ e _)       = lexprCtOrigin e
    798 795 
     exprCtOrigin (HsPar _ e)          = lexprCtOrigin e
    799 
    -exprCtOrigin e@(HsProjection _ _) = ExpansionOrigin (OrigExpr e)
    800 796 
     exprCtOrigin (SectionL _ _ _)     = SectionOrigin
    801 797 
     exprCtOrigin (SectionR _ _ _)     = SectionOrigin
    802 798 
     exprCtOrigin (ExplicitTuple {})   = Shouldn'tHappenOrigin "explicit tuple"
    803 799 
     exprCtOrigin ExplicitSum{}        = Shouldn'tHappenOrigin "explicit sum"
    804 800 
     exprCtOrigin (HsCase _ _ matches) = matchesCtOrigin matches
    805 
    -exprCtOrigin (HsIf {})           = IfThenElseOrigin
    806 801 
     exprCtOrigin (HsMultiIf _ rhs)   = lGRHSCtOrigin rhs
    807 802 
     exprCtOrigin (HsLet _ _ e)       = lexprCtOrigin e
    808 803 
     exprCtOrigin (HsDo {})           = DoStmtOrigin
    809 804 
     exprCtOrigin (RecordCon {})      = Shouldn'tHappenOrigin "record construction"
    810 
    -exprCtOrigin (RecordUpd{})       = RecordUpdOrigin
    811 805 
     exprCtOrigin (ExprWithTySig {})  = ExprSigOrigin
    812 806 
     exprCtOrigin (ArithSeq {})       = Shouldn'tHappenOrigin "arithmetic sequence"
    813 807 
     exprCtOrigin (HsPragE _ _ e)     = lexprCtOrigin e
    ... ... @@ -822,6 +816,12 @@ exprCtOrigin (HsHole _) = Shouldn'tHappenOrigin "hole expression"
    822 816 
     exprCtOrigin (HsForAll {})       = Shouldn'tHappenOrigin "forall telescope"    -- See Note [Types in terms]
    823 817 
     exprCtOrigin (HsQual {})         = Shouldn'tHappenOrigin "constraint context"  -- See Note [Types in terms]
    824 818 
     exprCtOrigin (HsFunArr {})       = Shouldn'tHappenOrigin "function arrow"      -- See Note [Types in terms]
    819 
    +exprCtOrigin e@(HsProjection _ _) = ExpansionOrigin (OrigExpr e)
    820 
    +exprCtOrigin e@(ExplicitList {})  = ExpansionOrigin (OrigExpr e)
    821 
    +exprCtOrigin e@(HsIf {})          = ExpansionOrigin (OrigExpr e)
    822 
    +exprCtOrigin e@(RecordUpd{})      = ExpansionOrigin (OrigExpr e)
    823 
    +exprCtOrigin e@(HsGetField{}) = ExpansionOrigin (OrigExpr e)
    824 
    +                                  -- GetFieldOrigin (field_label $ unLoc $ dfoLabel f)
    825 825 
     exprCtOrigin (XExpr (ExpandedThingRn o _)) = ExpansionOrigin o
    826 826 
     exprCtOrigin (XExpr (PopErrCtxt e)) = exprCtOrigin e
    827 827 
     exprCtOrigin (XExpr (HsRecSelRn f))  = OccurrenceOfRecSel (foExt f)
    ... ... @@ -869,7 +869,9 @@ pprCtOrigin (ExpansionOrigin o)
    869 869 
               hsep [text "selecting the field", quotes (ppr f)]
    870 870 
             OrigExpr (HsOverLabel _ l) ->
    871 871 
               hsep [text "the overloaded label" ,quotes (char '#' <> ppr l)]
    872 
    -        OrigExpr e@(RecordUpd{}) -> hsep [text "a record update" <+> quotes (ppr e) ]
    872 
    +        OrigExpr (RecordUpd{}) -> hsep [text "a record update"]
    873 
    +        OrigExpr (ExplicitList{}) -> text "an overloaded list"
    874 
    +        OrigExpr (HsIf{}) -> text "an if-then-else expression"
    873 875 
             OrigExpr e -> text "the expression" <+> (ppr e)
    874 876
    875 877 
     pprCtOrigin (GivenSCOrigin sk d blk)

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help