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,11 @@ 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@(ExplicitList {})  = ExpansionOrigin (OrigExpr e)
    820 
    +exprCtOrigin e@(HsIf {})          = ExpansionOrigin (OrigExpr e)
    821 
    +exprCtOrigin e@(HsProjection _ _) = ExpansionOrigin (OrigExpr e)
    822 
    +exprCtOrigin e@(RecordUpd{})      = ExpansionOrigin (OrigExpr e)
    823 
    +exprCtOrigin e@(HsGetField{})     = ExpansionOrigin (OrigExpr e)
    825 824 
     exprCtOrigin (XExpr (ExpandedThingRn o _)) = ExpansionOrigin o
    826 825 
     exprCtOrigin (XExpr (PopErrCtxt e)) = exprCtOrigin e
    827 826 
     exprCtOrigin (XExpr (HsRecSelRn f))  = OccurrenceOfRecSel (foExt f)
    ... ... @@ -868,8 +867,10 @@ pprCtOrigin (ExpansionOrigin o)
    868 867 
             OrigExpr (HsGetField _ _ (L _ f)) ->
    869 868 
               hsep [text "selecting the field", quotes (ppr f)]
    870 869 
             OrigExpr (HsOverLabel _ l) ->
    871 
    -          hsep [text "the overloaded label" ,quotes (char '#' <> ppr l)]
    872 
    -        OrigExpr e@(RecordUpd{}) -> hsep [text "a record update" <+> quotes (ppr e) ]
    870 
    +          hsep [text "the overloaded label" , quotes (char '#' <> ppr l)]
    871 
    +        OrigExpr (RecordUpd{}) -> text "a record update"
    872 
    +        OrigExpr (ExplicitList{}) -> text "an overloaded list"
    873 
    +        OrigExpr (HsIf{}) -> text "an if-then-else expression"
    873 874 
             OrigExpr e -> text "the expression" <+> (ppr e)
    874 875
    875 876 
     pprCtOrigin (GivenSCOrigin sk d blk)
    ... ... @@ -1088,7 +1089,11 @@ pprCtO (WantedSuperclassOrigin {}) = text "a superclass constraint"
    1088 1089 
     pprCtO (InstanceSigOrigin {})       = text "a type signature in an instance"
    1089 1090 
     pprCtO (AmbiguityCheckOrigin {})    = text "a type ambiguity check"
    1090 1091 
     pprCtO (ImpedanceMatching {})       = text "combining required constraints"
    1091 
    -pprCtO (NonLinearPatternOrigin _ pat) = hsep [text "a non-linear pattern" <+> quotes (ppr pat)]
    1092 
    +pprCtO (NonLinearPatternOrigin _ pat) = hsep [text "a non-linear pattern", quotes (ppr pat)]
    1093 
    +pprCtO (ExpansionOrigin (OrigExpr (HsOverLabel _ l))) = hsep [text "the overloaded label", quotes (char '#' <> ppr l)]
    1094 
    +pprCtO (ExpansionOrigin (OrigExpr (RecordUpd{}))) = text "a record update"
    1095 
    +pprCtO (ExpansionOrigin (OrigExpr (ExplicitList{}))) = text "an overloaded list"
    1096 
    +pprCtO (ExpansionOrigin (OrigExpr (HsIf{}))) = text "an if-then-else expression"
    1092 1097 
     pprCtO (ExpansionOrigin (OrigExpr e)) = text "an expression" <+> ppr e
    1093 1098 
     pprCtO (ExpansionOrigin (OrigStmt{})) = text "a do statement"
    1094 1099 
     pprCtO (ExpansionOrigin (OrigPat{})) = text "a pattern"

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