Apoorv Ingle pushed to branch wip/ani/kill-SrcCodeOrigin at Glasgow Haskell Compiler / GHC

Commits:

14 changed files:

Changes:

  • compiler/GHC/Hs/Instances.hs
    ... ... @@ -642,7 +642,7 @@ deriving instance Eq (IE GhcTc)
    642 642 
     -- TODO: I think we still need instances for StmtCtxt, ExprCtxt and PatCtxt ctors of ErrCtxtMsg
    643 643 
     instance Data ErrCtxtMsg where
    644 644 
       gunfold _ _ _ = error "no gunfold for ErrCtxtMsg"
    645 
    -  gfoldl _ _ _ = error "no goldl for ErrCtxtMsg"
    645 
    +  gfoldl _ _ _ = error "no gfoldl for ErrCtxtMsg"
    646 646 
       toConstr = error "no toConstr for ErrCtxtMsg"
    647 647 
       dataTypeOf = error "no dataTypeOf for ErrCtxtMsg"
    648 648

  • compiler/GHC/Tc/Errors.hs
    ... ... @@ -83,7 +83,6 @@ import qualified GHC.Data.Strict as Strict
    83 83
    84 84
    85 85 
     import Language.Haskell.Syntax.Basic (FieldLabelString(..))
    86 
    -import Language.Haskell.Syntax (HsExpr (RecordUpd, HsGetField, HsProjection))
    87 86
    88 87 
     import Control.Monad      ( when, foldM, forM_ )
    89 88 
     import Data.Bifunctor     ( bimap )
    ... ... @@ -2778,10 +2777,6 @@ isHasFieldOrigin = \case
    2778 2777 
       RecordUpdOrigin {} -> True
    2779 2778 
       RecordFieldProjectionOrigin {} -> True
    2780 2779 
       GetFieldOrigin {} -> True
    2781 
    -  ExpansionOrigin (ExprCtxt e)
    2782 
    -    | HsGetField{} <- e -> True
    2783 
    -    | RecordUpd{} <- e -> True
    2784 
    -    | HsProjection{} <- e -> True
    2785 2780 
       _ -> False
    2786 2781
    2787 2782 
     -----------------------

  • compiler/GHC/Tc/Errors/Ppr.hs
    ... ... @@ -7798,6 +7798,7 @@ pprErrCtxtMsg = \case
    7798 7798
    7799 7799 
         | otherwise
    7800 7800 
         -> empty
    7801 
    +      -- text "Debug" <+> vcat [ppr fun, ppr n_val_args, ppr res_fun, ppr res_env, ppr n_fun, ppr n_env]
    7801 7802 
         where
    7802 7803 
           not_fun ty   -- ty is definitely not an arrow type,
    7803 7804 
                        -- and cannot conceivably become one

  • compiler/GHC/Tc/Gen/App.hs
    ... ... @@ -907,10 +907,10 @@ tcInstFun do_ql inst_final ds_flag (fun_orig, rn_fun, fun_lspan) tc_fun fun_sigm
    907 907
    908 908 
                ; return (mkScaled mult_ty arg_nu) }
    909 909
    910 
    -    mk_herald :: HsExpr GhcTc -> HsExpr GhcRn -> CtOrigin
    910 
    +    mk_herald :: HsExpr GhcTc -> HsExpr GhcRn -> ExpectedFunTyCtxt
    911 911 
         mk_herald tc_fun arg
    912 912 
           = case fun_orig of
    913 
    -           ExpansionOrigin (StmtErrCtxt{}) -> ExpectedTySyntax DoStmtOrigin arg
    913 
    +           DoStmtOrigin -> ExpectedTySyntax DoStmtOrigin arg
    914 914 
                _ -> ExpectedFunTyArg (HsExprTcThing tc_fun) arg
    915 915
    916 916 
     -- Is the argument supposed to instantiate a forall?

  • compiler/GHC/Tc/Gen/Expr.hs
    ... ... @@ -1068,7 +1068,7 @@ tcSynArgE orig op sigma_ty syn_ty thing_inside
    1068 1068 
                    -- fixed RuntimeRep, as needed to call mkWpFun.
    1069 1069 
                ; return (result, match_wrapper <.> fun_wrap) }
    1070 1070 
           where
    1071 
    -        herald = ExpectedFunTySyntaxOp 1 orig op
    1071 
    +        herald = ExpectedFunTySyntaxOp orig op
    1072 1072
    1073 1073 
         go rho_ty (SynType the_ty)
    1074 1074 
           = do { wrap   <- tcSubTypePat orig GenSigCtxt the_ty rho_ty
    ... ... @@ -1097,7 +1097,7 @@ tcSynArgA orig op sigma_ty arg_shapes res_shape thing_inside
    1097 1097 
                   thing_inside (arg_results ++ res_results) (map scaledMult arg_tys ++ arg_res_mults)
    1098 1098 
            ; return (result, match_wrapper, arg_wrappers, res_wrapper) }
    1099 1099 
       where
    1100 
    -    herald = ExpectedFunTySyntaxOp (length arg_shapes) orig op
    1100 
    +    herald = ExpectedFunTySyntaxOp orig op
    1101 1101
    1102 1102 
         tc_syn_args_e :: [TcSigmaTypeFRR] -> [SyntaxOpType]
    1103 1103 
                       -> ([TcSigmaTypeFRR] -> [Mult] -> TcM a)
    ... ... @@ -1849,4 +1849,3 @@ checkMissingFields con_like rbinds arg_tys
    1849 1849 
         field_strs = conLikeImplBangs con_like
    1850 1850
    1851 1851 
         fl `elemField` flds = any (\ fl' -> flSelector fl == fl') flds
    1852 
    -

  • compiler/GHC/Tc/Gen/Head.hs
    ... ... @@ -465,7 +465,7 @@ tcInferAppHead_maybe fun = case fun of
    465 465 
                                                   -- visible type applications in the argument.
    466 466 
                                                   -- c.f. T19167
    467 467 
                                                   (\ (e, ds_flag, ty) -> (mkExpandedTc o e, ds_flag, ty)) <$>
    468 
    -                                                 tcExprSigma False (ExpansionOrigin o) e
    468 
    +                                                 tcExprSigma False (errCtxtCtOrigin o) e
    469 469 
                                                   )
    470 470 
           _                           -> return Nothing
    471 471

  • compiler/GHC/Tc/Gen/Match.hs
    ... ... @@ -114,7 +114,7 @@ tcFunBindMatches ctxt fun_name mult matches invis_pat_tys exp_ty
    114 114 
       = assertPpr (funBindPrecondition matches) (pprMatches matches) $
    115 115 
         do  {  -- Check that they all have the same no of arguments
    116 116 
               arity <- checkArgCounts matches
    117 
    -        ; let herald = ExpectedFunTyMatches arity (NameThing fun_name) matches
    117 
    +        ; let herald = ExpectedFunTyMatches (NameThing fun_name) matches
    118 118 
             ; traceTc "tcFunBindMatches 1" (ppr fun_name $$ ppr mult $$ ppr exp_ty $$ ppr arity)
    119 119
    120 120 
             ; (wrap_fun, r)

  • compiler/GHC/Tc/Gen/Pat.hs
    ... ... @@ -701,7 +701,7 @@ tc_pat scaled_exp_pat_ty@(Scaled w_pat exp_pat_ty) penv ps_pat thing_inside =
    701 701
    702 702 
             -- 'view_expr' must be a function; expose its argument/result types
    703 703 
             -- using 'matchActualFunTy'.
    704 
    -      ; let herald = ExpectedFunTyViewPat 1 $ unLoc view_expr
    704 
    +      ; let herald = ExpectedFunTyViewPat $ unLoc view_expr
    705 705 
           ; (view_expr_co1, Scaled _mult view_arg_ty, view_res_ty)
    706 706 
               <- matchActualFunTy herald (Just . HsExprRnThing $ unLoc view_expr)
    707 707 
                    (1, view_expr_rho) view_expr_rho

  • compiler/GHC/Tc/Instance/Class.hs
    ... ... @@ -20,7 +20,7 @@ import GHC.Tc.Instance.Typeable
    20 20 
     import GHC.Tc.Utils.TcMType
    21 21 
     import GHC.Tc.Types.Evidence
    22 22 
     import GHC.Tc.Types.CtLoc
    23 
    -import GHC.Tc.Types.Origin ( InstanceWhat (..), SafeOverlapping, CtOrigin(ExpansionOrigin) )
    23 
    +import GHC.Tc.Types.Origin ( InstanceWhat (..), SafeOverlapping, CtOrigin(GetFieldOrigin) )
    24 24 
     import GHC.Tc.Instance.Family( tcGetFamInstEnvs, tcLookupDataFamInst, FamInstEnvs )
    25 25 
     import GHC.Rename.Env( addUsedGRE, addUsedDataCons, DeprecationWarnings (..) )
    26 26
    ... ... @@ -1288,7 +1288,7 @@ warnIncompleteRecSel dflags sel_id ct_loc
    1288 1288
    1289 1289 
         -- GHC.Tc.Gen.App.tcInstFun arranges that the CtOrigin of (r.x) is GetFieldOrigin,
    1290 1290 
         -- despite the expansion to (getField @"x" r)
    1291 
    -    isGetFieldOrigin (ExpansionOrigin (ExprCtxt (HsGetField {}))) = True
    1291 
    +    isGetFieldOrigin GetFieldOrigin{} = True
    1292 1292 
         isGetFieldOrigin _                   = False
    1293 1293
    1294 1294 
     lookupHasFieldLabel

  • compiler/GHC/Tc/Types/ErrCtxt.hs
    ... ... @@ -21,7 +21,7 @@ import GHC.Hs.Extension
    21 21 
     import GHC.Parser.Annotation ( LocatedN, SrcSpanAnnA )
    22 22
    23 23 
     import GHC.Tc.Errors.Types.PromotionErr ( TermLevelUseCtxt )
    24 
    -import {-# SOURCE #-} GHC.Tc.Types.Origin   ( CtOrigin )
    24 
    +import {-# SOURCE #-} GHC.Tc.Types.Origin   ( CtOrigin, ExpectedFunTyCtxt )
    25 25 
     import GHC.Tc.Utils.TcType   ( TcType, TcTyCon, ExpType )
    26 26
    27 27 
     import GHC.Types.Basic       ( TyConFlavour )
    ... ... @@ -283,7 +283,7 @@ data ErrCtxtMsg
    283 283 
       -- | In a function application.
    284 284 
       | FunAppCtxt !FunAppCtxtFunArg !Int
    285 285 
       -- | In a function call.
    286 
    -  | FunTysCtxt !CtOrigin !Type !Int !Int
    286 
    +  | FunTysCtxt !ExpectedFunTyCtxt !Type !Int !Int
    287 287 
       -- | In the result of a function call.
    288 288 
       | FunResCtxt !(HsExpr GhcTc) !Int !Type !Type !Int !Int
    289 289 
       -- | In the declaration of a type constructor.

  • compiler/GHC/Tc/Types/LclEnv.hs
    ... ... @@ -211,9 +211,6 @@ setLclEnvSrcCodeOrigin ec = modifyLclCtxt (setLclCtxtSrcCodeOrigin ec)
    211 211 
     -- See Note [ErrCtxtStack Manipulation]
    212 212 
     setLclCtxtSrcCodeOrigin :: ErrCtxt -> TcLclCtxt -> TcLclCtxt
    213 213 
     setLclCtxtSrcCodeOrigin ec lclCtxt
    214 
    -  -- | ecs@(MkErrCtxt ExpansionCodeCtxt _ : _) <- tcl_err_ctxt lclCtxt
    215 
    -  -- , MkErrCtxt ExpansionCodeCtxt ExprCtxt{} <- ec
    216 
    -  -- = lclCtxt { tcl_err_ctxt =  ec : ecs }
    217 214 
       -- never stack 2 statement error contexts on top of each other
    218 215 
       | MkErrCtxt _ DoStmtErrCtxt{} : ecs <- tcl_err_ctxt lclCtxt
    219 216 
       , MkErrCtxt _ DoStmtErrCtxt{} <- ec

  • compiler/GHC/Tc/Types/Origin.hs
    ... ... @@ -9,9 +9,8 @@ module GHC.Tc.Types.Origin (
    9 9
    10 10 
       -- * CtOrigin
    11 11 
       CtOrigin(..), exprCtOrigin, lexprCtOrigin, matchesCtOrigin, grhssCtOrigin,
    12 
    -  srcCodeOriginCtOrigin,
    12 
    +  srcCodeOriginCtOrigin, errCtxtCtOrigin,
    13 13 
       invisibleOrigin_maybe, isVisibleOrigin, toInvisibleOrigin,
    14 
    -  updatePositionCtOrigin,
    15 14 
       pprCtOrigin, pprCtOriginBriefly, isGivenOrigin,
    16 15 
       defaultReprEqOrigins, isWantedSuperclassOrigin,
    17 16 
       ClsInstOrQC(..), NakedScFlag(..), NonLinearPatternReason(..),
    ... ... @@ -37,7 +36,7 @@ module GHC.Tc.Types.Origin (
    37 36 
       FRRArrowContext(..), pprFRRArrowContext,
    38 37
    39 38 
       -- ** ExpectedFunTy FixedRuntimeRepOrigin
    40 
    -  pprExpectedFunTyHerald,
    39 
    +  ExpectedFunTyCtxt(..), pprExpectedFunTyCtxt, pprExpectedFunTyHerald,
    41 40
    42 41 
       -- * InstanceWhat
    43 42 
       InstanceWhat(..), SafeOverlapping
    ... ... @@ -512,72 +511,6 @@ data CtOrigin
    512 511 
       | AmbiguityCheckOrigin UserTypeCtxt
    513 512 
       | ImplicitLiftOrigin HsImplicitLiftSplice
    514 513
    515 
    -  | ExpansionOrigin ErrCtxtMsg -- This is due to an expansion of the original thing given by the ErrCtxtMsg
    516 
    -
    517 
    -  | ExpectedTySyntax !CtOrigin (HsExpr GhcRn)
    518 
    -
    519 
    -  -- | A rebindable syntax operator is expected to have a function type.
    520 
    -  --
    521 
    -  -- Test cases for representation-polymorphism checks:
    522 
    -  --   RepPolyDoBind, RepPolyDoBody{1,2}, RepPolyMc{Bind,Body,Guard}, RepPolyNPlusK
    523 
    -  | forall (p :: Pass)
    524 
    -     . (OutputableBndrId p)
    525 
    -    => ExpectedFunTySyntaxOp Int
    526 
    -         !CtOrigin !(HsExpr (GhcPass p))
    527 
    -                    -- ^ rebindable syntax operator
    528 
    -
    529 
    -  -- | A view pattern must have a function type.
    530 
    -  --
    531 
    -  -- Test cases for representation-polymorphism checks:
    532 
    -  --   RepPolyBinder
    533 
    -  | ExpectedFunTyViewPat Int
    534 
    -    !(HsExpr GhcRn)
    535 
    -      -- ^ function used in the view pattern
    536 
    -
    537 
    -  -- | Need to be able to extract an argument type from a function type.
    538 
    -  --
    539 
    -  -- Test cases for representation-polymorphism checks:
    540 
    -  --   RepPolyApp
    541 
    -  | forall (p :: Pass)
    542 
    -     . Outputable (HsExpr (GhcPass p)) => ExpectedFunTyArg
    543 
    -          !TypedThing
    544 
    -            -- ^ function
    545 
    -          !(HsExpr (GhcPass p))
    546 
    -            -- ^ argument
    547 
    -
    548 
    -  -- | Ensure that a function defined by equations indeed has a function type
    549 
    -  -- with the appropriate number of arguments.
    550 
    -  --
    551 
    -  -- Test cases for representation-polymorphism checks:
    552 
    -  --   RepPolyBinder, RepPolyRecordPattern, RepPolyWildcardPattern
    553 
    -  | ExpectedFunTyMatches Int
    554 
    -      !TypedThing
    555 
    -        -- ^ name of the function
    556 
    -      !(MatchGroup GhcRn (LHsExpr GhcRn))
    557 
    -       -- ^ equations
    558 
    -
    559 
    -  -- | Ensure that a lambda abstraction has a function type.
    560 
    -  --
    561 
    -  -- Test cases for representation-polymorphism checks:
    562 
    -  --   RepPolyLambda, RepPolyMatch
    563 
    -  | ExpectedFunTyLam HsLamVariant
    564 
    -      !(HsExpr GhcRn)
    565 
    -       -- ^ the entire lambda-case expression
    566 
    -
    567 
    -  -- | A partial application of the constructor of a representation-polymorphic
    568 
    -  -- unlifted newtype in which the argument type does not have a fixed
    569 
    -  -- runtime representation.
    570 
    -  --
    571 
    -  -- Test cases: UnliftedNewtypesLevityBinder, UnliftedNewtypesCoerceFail.
    572 
    -  | FRRRepPolyUnliftedNewtype !DataCon
    573 
    -
    574 
    -
    575 
    -updatePositionCtOrigin :: Int -> CtOrigin -> CtOrigin
    576 
    -updatePositionCtOrigin i (ExpectedFunTySyntaxOp _ c e) = ExpectedFunTySyntaxOp i c e
    577 
    -updatePositionCtOrigin i (ExpectedFunTyViewPat _ e) = ExpectedFunTyViewPat i e
    578 
    -updatePositionCtOrigin i (ExpectedFunTyMatches _ t e) = ExpectedFunTyMatches i t e
    579 
    -updatePositionCtOrigin _ c = c
    580 
    -
    581 514
    582 515 
     data NonLinearPatternReason
    583 516 
       = LazyPatternReason
    ... ... @@ -680,18 +613,18 @@ exprCtOrigin (HsTypedBracket {}) = Shouldn'tHappenOrigin "TH typed bracket"
    680 613 
     exprCtOrigin (HsUntypedBracket {}) = Shouldn'tHappenOrigin "TH untyped bracket"
    681 614 
     exprCtOrigin (HsTypedSplice {})    = Shouldn'tHappenOrigin "TH typed splice"
    682 615 
     exprCtOrigin (HsUntypedSplice {})  = Shouldn'tHappenOrigin "TH untyped splice"
    683 
    -exprCtOrigin (HsProc {})         = Shouldn'tHappenOrigin "proc"
    684 
    -exprCtOrigin (HsStatic {})       = Shouldn'tHappenOrigin "static expression"
    685 
    -exprCtOrigin (HsEmbTy {})        = Shouldn'tHappenOrigin "type expression"
    686 
    -exprCtOrigin (HsHole _)          = Shouldn'tHappenOrigin "hole expression"
    687 
    -exprCtOrigin (HsForAll {})       = Shouldn'tHappenOrigin "forall telescope"    -- See Note [Types in terms]
    688 
    -exprCtOrigin (HsQual {})         = Shouldn'tHappenOrigin "constraint context"  -- See Note [Types in terms]
    689 
    -exprCtOrigin (HsFunArr {})       = Shouldn'tHappenOrigin "function arrow"      -- See Note [Types in terms]
    690 
    -exprCtOrigin e@(ExplicitList {})  = ExpansionOrigin (ExprCtxt e)
    691 
    -exprCtOrigin e@(HsIf {})          = ExpansionOrigin (ExprCtxt e)
    692 
    -exprCtOrigin e@(HsProjection _ _) = ExpansionOrigin (ExprCtxt e)
    693 
    -exprCtOrigin e@(RecordUpd{})      = ExpansionOrigin (ExprCtxt e)
    694 
    -exprCtOrigin e@(HsGetField{})     = ExpansionOrigin (ExprCtxt e)
    616 
    +exprCtOrigin (HsProc {})          = Shouldn'tHappenOrigin "proc"
    617 
    +exprCtOrigin (HsStatic {})        = Shouldn'tHappenOrigin "static expression"
    618 
    +exprCtOrigin (HsEmbTy {})         = Shouldn'tHappenOrigin "type expression"
    619 
    +exprCtOrigin (HsHole _)           = Shouldn'tHappenOrigin "hole expression"
    620 
    +exprCtOrigin (HsForAll {})        = Shouldn'tHappenOrigin "forall telescope"    -- See Note [Types in terms]
    621 
    +exprCtOrigin (HsQual {})          = Shouldn'tHappenOrigin "constraint context"  -- See Note [Types in terms]
    622 
    +exprCtOrigin (HsFunArr {})        = Shouldn'tHappenOrigin "function arrow"      -- See Note [Types in terms]
    623 
    +exprCtOrigin (ExplicitList {})    = ListOrigin
    624 
    +exprCtOrigin (HsIf {})            = IfThenElseOrigin
    625 
    +exprCtOrigin (HsProjection _ p)   = RecordFieldProjectionOrigin (FieldLabelStrings $ fmap noLocA p)
    626 
    +exprCtOrigin (RecordUpd _ _ flds) = RecordUpdOrigin flds
    627 
    +exprCtOrigin (HsGetField _ _ f)   = GetFieldOrigin (fmap field_label $ dfoLabel (unLoc f))
    695 628 
     exprCtOrigin (XExpr (ExpandedThingRn o _)) = errCtxtCtOrigin o
    696 629 
     exprCtOrigin (XExpr (HsRecSelRn f))  = OccurrenceOfRecSel $ L (getLoc $ foLabel f) (foExt f)
    697 630
    ... ... @@ -736,31 +669,6 @@ pprCtOrigin :: CtOrigin -> SDoc
    736 669 
     pprCtOrigin (GivenOrigin sk)
    737 670 
       = ctoHerald <+> ppr sk
    738 671
    739 
    -pprCtOrigin (ExpansionOrigin o)
    740 
    -  = ctoHerald <+> what
    741 
    -    where
    742 
    -      what :: SDoc
    743 
    -      what = case o of
    744 
    -        StmtErrCtxt{} ->
    745 
    -          text "a do statement"
    746 
    -        DoStmtErrCtxt{} ->
    747 
    -          text "a do statement"
    748 
    -        StmtErrCtxtPat _ _ p ->
    749 
    -          text "a do statement" $$
    750 
    -             text "with the failable pattern" <+> quotes (ppr p)
    751 
    -        ExprCtxt (HsGetField _ _ (L _ f)) ->
    752 
    -          hsep [text "selecting the field", quotes (ppr f)]
    753 
    -        ExprCtxt (HsOverLabel _ l) ->
    754 
    -          hsep [text "the overloaded label" , quotes (char '#' <> ppr l)]
    755 
    -        ExprCtxt (RecordUpd{}) -> text "a record update"
    756 
    -        ExprCtxt (ExplicitList{}) -> text "an overloaded list"
    757 
    -        ExprCtxt (HsIf{}) -> text "an if-then-else expression"
    758 
    -        ExprCtxt (HsProjection _ p) -> text "the record selector" <+>
    759 
    -             quotes (ppr ((FieldLabelStrings $ fmap noLocA p)))
    760 
    -        ExprCtxt e -> text "the expression" <+> (ppr e)
    761 
    -        RecordUpdCtxt{} -> text "a record update"
    762 
    -        _ -> text "shouldn't happen ExpansionOrigin pprCtOrigin"
    763 
    -
    764 672 
     pprCtOrigin (GivenSCOrigin sk d blk)
    765 673 
       = vcat [ ctoHerald <+> pprSkolInfo sk
    766 674 
              , whenPprDebug (braces (text "given-sc:" <+> ppr d <> comma <> ppr blk)) ]
    ... ... @@ -867,46 +775,9 @@ pprCtOrigin (NonLinearPatternOrigin reason pat)
    867 775 
       = hang (ctoHerald <+> text "a non-linear pattern" <+> quotes (ppr pat))
    868 776 
            2 (pprNonLinearPatternReason reason)
    869 777
    870 
    -pprCtOrigin (ExpectedTySyntax orig arg)
    871 
    -  =  vcat [ text "The expression" <+> quotes (ppr arg)
    872 
    -          , nest 2 (ppr orig) ]
    873 
    -
    874 
    -pprCtOrigin (ExpectedFunTySyntaxOp i orig op) =
    875 
    -      vcat [ sep [ the_arg_of i
    876 
    -                 , text "the rebindable syntax operator"
    877 
    -                 , quotes (ppr op) ]
    878 
    -           , nest 2 (ppr orig) ]
    879 
    -
    880 
    -pprCtOrigin (ExpectedFunTyViewPat i expr) =
    881 
    -      vcat [ the_arg_of i <+> text "the view pattern"
    882 
    -           , nest 2 (ppr expr) ]
    883 
    -pprCtOrigin (ExpectedFunTyArg fun arg) =
    884 
    -      sep [ text "The argument"
    885 
    -          , quotes (ppr arg)
    886 
    -          , text "of"
    887 
    -          , quotes (ppr fun) ]
    888 
    -pprCtOrigin (ExpectedFunTyMatches i fun (MG { mg_alts = L _ alts }))
    889 
    -      | null alts
    890 
    -      = the_arg_of i <+> quotes (ppr fun)
    891 
    -      | otherwise
    892 
    -      = text "The" <+> speakNth i <+> text "pattern in the equation" <> plural alts
    893 
    -     <+> text "for" <+> quotes (ppr fun)
    894 
    -pprCtOrigin (ExpectedFunTyLam lam_variant _) = binder_of $ lamCaseKeyword lam_variant
    895 
    -pprCtOrigin (FRRRepPolyUnliftedNewtype dc) =
    896 
    -      vcat [ text "Unsaturated use of a representation-polymorphic unlifted newtype."
    897 
    -           , text "The argument of the newtype constructor" <+> quotes (ppr dc) ]
    898 
    -
    899 778 
     pprCtOrigin simple_origin
    900 779 
       = ctoHerald <+> pprCtOriginBriefly simple_origin
    901 780
    902 
    -the_arg_of :: Int -> SDoc
    903 
    -the_arg_of i = text "The" <+> speakNth i <+> text "argument of"
    904 
    -
    905 
    -binder_of :: SDoc -> SDoc
    906 
    -binder_of what = text "The binder of the" <+> what <+> text "expression"
    907 
    -
    908 
    -
    909 
    -
    910 781 
     -- | Print CtOrigin briefly, with a one-liner
    911 782 
     pprCtOriginBriefly :: CtOrigin -> SDoc
    912 783 
     pprCtOriginBriefly = ppr_br  -- ppr_br is a local function with a short name!
    ... ... @@ -979,22 +850,6 @@ ppr_br (InstanceSigOrigin {}) = text "a type signature in an instance"
    979 850 
     ppr_br (AmbiguityCheckOrigin {})    = text "a type ambiguity check"
    980 851 
     ppr_br (ImpedanceMatching {})       = text "combining required constraints"
    981 852 
     ppr_br (NonLinearPatternOrigin _ pat) = hsep [text "a non-linear pattern" <+> quotes (ppr pat)]
    982 
    -ppr_br (ExpansionOrigin (ExprCtxt (HsOverLabel _ l))) = hsep [text "the overloaded label", quotes (char '#' <> ppr l)]
    983 
    -ppr_br (ExpansionOrigin (ExprCtxt (RecordUpd{}))) = text "a record update"
    984 
    -ppr_br (ExpansionOrigin (ExprCtxt (ExplicitList{}))) = text "an overloaded list"
    985 
    -ppr_br (ExpansionOrigin (ExprCtxt (HsIf{}))) = text "an if-then-else expression"
    986 
    -ppr_br (ExpansionOrigin (ExprCtxt e)) = text "an expression" <+> ppr e
    987 
    -ppr_br (ExpansionOrigin (StmtErrCtxt{})) = text "a do statement"
    988 
    -ppr_br (ExpansionOrigin (StmtErrCtxtPat{})) = text "a do statement"
    989 
    -ppr_br (ExpansionOrigin{}) = text "shouldn't happen ExpansionOrigin ppr_br"
    990 
    -ppr_br (ExpectedTySyntax o _) = ppr_br o
    991 
    -ppr_br (ExpectedFunTySyntaxOp{}) = text "a rebindable syntax operator"
    992 
    -ppr_br (ExpectedFunTyViewPat{}) = text "a view pattern"
    993 
    -ppr_br (ExpectedFunTyArg{}) = text "a funtion head"
    994 
    -ppr_br (ExpectedFunTyMatches{}) = text "a match statement"
    995 
    -ppr_br (ExpectedFunTyLam{}) = text "a lambda expression"
    996 
    -ppr_br (FRRRepPolyUnliftedNewtype{}) = text "a unlifted newtype"
    997 
    -
    998 853
    999 854 
     pprNonLinearPatternReason :: HasDebugCallStack => NonLinearPatternReason -> SDoc
    1000 855 
     pprNonLinearPatternReason LazyPatternReason = parens (text "non-variable lazy pattern aren't linear")
    ... ... @@ -1225,9 +1080,9 @@ data FixedRuntimeRepContext
    1225 1080 
       -- | A representation-polymorphism check arising from a call
    1226 1081 
       -- to 'matchExpectedFunTys' or 'matchActualFunTy'.
    1227 1082 
       --
    1228 
    -  -- See 'ExpectedFunTyOrigin' for more details.
    1083 
    +  -- See 'ExpectedFunTyCtxt' for more details.
    1229 1084 
       | FRRExpectedFunTy
    1230 
    -      !CtOrigin
    1085 
    +      !ExpectedFunTyCtxt
    1231 1086 
           !Int
    1232 1087 
             -- ^ argument position (1-indexed)
    1233 1088
    ... ... @@ -1314,7 +1169,7 @@ pprFixedRuntimeRepContext FRRBindStmtGuard
    1314 1169 
     pprFixedRuntimeRepContext (FRRArrow arrowContext)
    1315 1170 
       = pprFRRArrowContext arrowContext
    1316 1171 
     pprFixedRuntimeRepContext (FRRExpectedFunTy funTyOrig _)
    1317 
    -  = pprCtOrigin funTyOrig
    1172 
    +  = pprExpectedFunTyHerald funTyOrig
    1318 1173 
     pprFixedRuntimeRepContext (FRRDeepSubsumption is_exp pos mb_fun)
    1319 1174 
       = hsep [ text "The", what, text "type of the"
    1320 1175 
              , ppr (Argument pos)
    ... ... @@ -1540,15 +1395,136 @@ instance Outputable FRRArrowContext where
    1540 1395 
       ppr = pprFRRArrowContext
    1541 1396
    1542 1397
    1543 
    -pprExpectedFunTyHerald :: CtOrigin -> SDoc
    1398 
    +{- *********************************************************************
    1399 
    +*                                                                      *
    1400 
    +              FixedRuntimeRep: ExpectedFunTy origin
    1401 
    +*                                                                      *
    1402 
    +********************************************************************* -}
    1403 
    +
    1404 
    +-- | In what context are we calling 'matchExpectedFunTys'
    1405 
    +-- or 'matchActualFunTy'?
    1406 
    +--
    1407 
    +-- Used for two things:
    1408 
    +--
    1409 
    +--  1. Reporting error messages which explain that a function has been
    1410 
    +--     given an unexpected number of arguments.
    1411 
    +--     Uses 'pprExpectedFunTyHerald'.
    1412 
    +--     See Note [Herald for matchExpectedFunTys] in GHC.Tc.Utils.Unify.
    1413 
    +--
    1414 
    +--  2. Reporting representation-polymorphism errors when a function argument
    1415 
    +--     doesn't have a fixed RuntimeRep as per Note [Fixed RuntimeRep]
    1416 
    +--     in GHC.Tc.Utils.Concrete.
    1417 
    +--     Uses 'pprExpectedFunTyCtxt'.
    1418 
    +--     See 'FixedRuntimeRepContext' for the situations in which
    1419 
    +--     representation-polymorphism checks are performed.
    1420 
    +data ExpectedFunTyCtxt
    1421 
    +
    1422 
    +  -- | A rebindable syntax operator is expected to have a function type.
    1423 
    +  --
    1424 
    +  -- Test cases for representation-polymorphism checks:
    1425 
    +  --   RepPolyDoBind, RepPolyDoBody{1,2}, RepPolyMc{Bind,Body,Guard}, RepPolyNPlusK
    1426 
    +  = forall (p :: Pass)
    1427 
    +     . (OutputableBndrId p)
    1428 
    +    => ExpectedFunTySyntaxOp !CtOrigin !(HsExpr (GhcPass p))
    1429 
    +      -- ^ rebindable syntax operator
    1430 
    +
    1431 
    +  -- |
    1432 
    +  | ExpectedTySyntax !CtOrigin !(HsExpr GhcRn)
    1433 
    +
    1434 
    +  -- | A view pattern must have a function type.
    1435 
    +  --
    1436 
    +  -- Test cases for representation-polymorphism checks:
    1437 
    +  --   RepPolyBinder
    1438 
    +  | ExpectedFunTyViewPat
    1439 
    +    !(HsExpr GhcRn)
    1440 
    +      -- ^ function used in the view pattern
    1441 
    +
    1442 
    +  -- | Need to be able to extract an argument type from a function type.
    1443 
    +  --
    1444 
    +  -- Test cases for representation-polymorphism checks:
    1445 
    +  --   RepPolyApp
    1446 
    +  | forall (p :: Pass)
    1447 
    +     . Outputable (HsExpr (GhcPass p)) => ExpectedFunTyArg
    1448 
    +          !TypedThing
    1449 
    +            -- ^ function
    1450 
    +          !(HsExpr (GhcPass p))
    1451 
    +            -- ^ argument
    1452 
    +
    1453 
    +  -- | Ensure that a function defined by equations indeed has a function type
    1454 
    +  -- with the appropriate number of arguments.
    1455 
    +  --
    1456 
    +  -- Test cases for representation-polymorphism checks:
    1457 
    +  --   RepPolyBinder, RepPolyRecordPattern, RepPolyWildcardPattern
    1458 
    +  | ExpectedFunTyMatches
    1459 
    +      !TypedThing
    1460 
    +        -- ^ name of the function
    1461 
    +      !(MatchGroup GhcRn (LHsExpr GhcRn))
    1462 
    +       -- ^ equations
    1463 
    +
    1464 
    +  -- | Ensure that a lambda abstraction has a function type.
    1465 
    +  --
    1466 
    +  -- Test cases for representation-polymorphism checks:
    1467 
    +  --   RepPolyLambda, RepPolyMatch
    1468 
    +  | ExpectedFunTyLam HsLamVariant
    1469 
    +      !(HsExpr GhcRn)
    1470 
    +       -- ^ the entire lambda-case expression
    1471 
    +
    1472 
    +  -- | A partial application of the constructor of a representation-polymorphic
    1473 
    +  -- unlifted newtype in which the argument type does not have a fixed
    1474 
    +  -- runtime representation.
    1475 
    +  --
    1476 
    +  -- Test cases: UnliftedNewtypesLevityBinder, UnliftedNewtypesCoerceFail.
    1477 
    +  | FRRRepPolyUnliftedNewtype !DataCon
    1478 
    +
    1479 
    +pprExpectedFunTyCtxt :: ExpectedFunTyCtxt
    1480 
    +                       -> Int -- ^ argument position (starting at 1)
    1481 
    +                       -> SDoc
    1482 
    +pprExpectedFunTyCtxt funTy_origin i =
    1483 
    +  case funTy_origin of
    1484 
    +    ExpectedFunTySyntaxOp orig op ->
    1485 
    +      vcat [ sep [ the_arg_of
    1486 
    +                 , text "the rebindable syntax operator"
    1487 
    +                 , quotes (ppr op) ]
    1488 
    +           , nest 2 (ppr orig) ]
    1489 
    +    ExpectedTySyntax orig arg ->
    1490 
    +      vcat [ text "the expression" <+> quotes (ppr arg)
    1491 
    +           , nest 2 (ppr orig) ]
    1492 
    +    ExpectedFunTyViewPat expr ->
    1493 
    +      vcat [ the_arg_of <+> text "the view pattern"
    1494 
    +           , nest 2 (ppr expr) ]
    1495 
    +    ExpectedFunTyArg fun arg ->
    1496 
    +      sep [ text "The argument"
    1497 
    +          , quotes (ppr arg)
    1498 
    +          , text "of"
    1499 
    +          , quotes (ppr fun) ]
    1500 
    +    ExpectedFunTyMatches fun (MG { mg_alts = L _ alts })
    1501 
    +      | null alts
    1502 
    +      -> the_arg_of <+> quotes (ppr fun)
    1503 
    +      | otherwise
    1504 
    +      -> text "The" <+> speakNth i <+> text "pattern in the equation" <> plural alts
    1505 
    +     <+> text "for" <+> quotes (ppr fun)
    1506 
    +    ExpectedFunTyLam lam_variant _ -> binder_of $ lamCaseKeyword lam_variant
    1507 
    +    FRRRepPolyUnliftedNewtype dc ->
    1508 
    +      vcat [ text "Unsaturated use of a representation-polymorphic unlifted newtype."
    1509 
    +           , text "The argument of the newtype constructor" <+> quotes (ppr dc) ]
    1510 
    +  where
    1511 
    +    the_arg_of :: SDoc
    1512 
    +    the_arg_of = text "The" <+> speakNth i <+> text "argument of"
    1513 
    +
    1514 
    +    binder_of :: SDoc -> SDoc
    1515 
    +    binder_of what = text "The binder of the" <+> what <+> text "expression"
    1516 
    +
    1517 
    +pprExpectedFunTyHerald :: ExpectedFunTyCtxt -> SDoc
    1544 1518 
     pprExpectedFunTyHerald (ExpectedFunTySyntaxOp {})
    1545 1519 
       = text "This rebindable syntax expects a function with"
    1520 
    +pprExpectedFunTyHerald (ExpectedTySyntax orig _)
    1521 
    +  = pprCtOriginBriefly orig
    1546 1522 
     pprExpectedFunTyHerald (ExpectedFunTyViewPat {})
    1547 1523 
       = text "A view pattern expression expects"
    1548 1524 
     pprExpectedFunTyHerald (ExpectedFunTyArg fun _)
    1549 1525 
       = sep [ text "The function" <+> quotes (ppr fun)
    1550 1526 
             , text "is applied to" ]
    1551 
    -pprExpectedFunTyHerald (ExpectedFunTyMatches _ fun (MG { mg_alts = L _ alts }))
    1527 
    +pprExpectedFunTyHerald (ExpectedFunTyMatches fun (MG { mg_alts = L _ alts }))
    1552 1528 
       = text "The equation" <> plural alts <+> text "for" <+> quotes (ppr fun) <+> hasOrHave alts
    1553 1529 
     pprExpectedFunTyHerald (ExpectedFunTyLam lam_variant expr)
    1554 1530 
       = sep [ text "The" <+> lamCaseKeyword lam_variant <+> text "expression"
    ... ... @@ -1557,7 +1533,6 @@ pprExpectedFunTyHerald (ExpectedFunTyLam lam_variant expr)
    1557 1533 
             , text "has" ]
    1558 1534 
     pprExpectedFunTyHerald (FRRRepPolyUnliftedNewtype dc)
    1559 1535 
       = text "The unlifted newtype" <+> quotes (ppr dc) <+> text "expects"
    1560 
    -pprExpectedFunTyHerald orig = ppr (Shouldn'tHappenOrigin "pprExpectedFunTyHerald") <+> ppr orig
    1561 1536
    1562 1537 
     {- *******************************************************************
    1563 1538 
     *                                                                    *

  • compiler/GHC/Tc/Types/Origin.hs-boot
    ... ... @@ -5,6 +5,7 @@ import GHC.Utils.Misc ( HasDebugCallStack )
    5 5 
     import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type )
    6 6
    7 7 
     data CtOrigin
    8 
    +data ExpectedFunTyCtxt
    8 9 
     data SkolemInfoAnon
    9 10 
     data SkolemInfo
    10 11 
     data FixedRuntimeRepContext

  • compiler/GHC/Tc/Utils/Unify.hs
    ... ... @@ -139,7 +139,7 @@ import Data.Traversable (for)
    139 139 
     --
    140 140 
     -- See Note [Return arguments with a fixed RuntimeRep].
    141 141 
     matchActualFunTy
    142 
    -  :: CtOrigin
    142 
    +  :: ExpectedFunTyCtxt
    143 143 
           -- ^ See Note [Herald for matchExpectedFunTys]
    144 144 
       -> Maybe TypedThing
    145 145 
           -- ^ The thing with type TcSigmaType
    ... ... @@ -178,7 +178,7 @@ matchActualFunTy herald mb_thing err_info fun_ty
    178 178
    179 179 
         go (FunTy { ft_af = af, ft_mult = w, ft_arg = arg_ty, ft_res = res_ty })
    180 180 
           = assert (isVisibleFunArg af) $
    181 
    -      do { (arg_co, arg_ty) <- hasFixedRuntimeRep (FRRExpectedFunTy (updatePositionCtOrigin 1 herald) 1) arg_ty
    181 
    +      do { (arg_co, arg_ty) <- hasFixedRuntimeRep (FRRExpectedFunTy herald 1) arg_ty
    182 182 
              ; let fun_co = mkFunCo Nominal af
    183 183 
                               (mkReflCo Nominal w)
    184 184 
                               arg_co
    ... ... @@ -249,7 +249,7 @@ Ugh!
    249 249 
     -- INVARIANT: the returned argument types all have a syntactically fixed RuntimeRep
    250 250 
     -- in the sense of Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete.
    251 251 
     -- See Note [Return arguments with a fixed RuntimeRep].
    252 
    -matchActualFunTys :: CtOrigin -- ^ See Note [Herald for matchExpectedFunTys]
    252 
    +matchActualFunTys :: ExpectedFunTyCtxt -- ^ See Note [Herald for matchExpectedFunTys]
    253 253 
                       -> CtOrigin
    254 254 
                       -> Arity
    255 255 
                       -> TcSigmaType
    ... ... @@ -793,7 +793,7 @@ Example:
    793 793 
     -- in the sense of Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete.
    794 794 
     -- See Note [Return arguments with a fixed RuntimeRep].
    795 795 
     matchExpectedFunTys :: forall a.
    796 
    -                       CtOrigin  -- See Note [Herald for matchExpectedFunTys]
    796 
    +                       ExpectedFunTyCtxt  -- See Note [Herald for matchExpectedFunTys]
    797 797 
                         -> UserTypeCtxt
    798 798 
                         -> VisArity
    799 799 
                         -> ExpSigmaType
    ... ... @@ -875,7 +875,7 @@ matchExpectedFunTys herald ctx arity (Check top_ty) thing_inside
    875 875 
                                        , ft_arg = arg_ty, ft_res = res_ty })
    876 876 
           = assert (isVisibleFunArg af) $
    877 877 
             do { let arg_pos = arity - n_req + 1   -- 1 for the first argument etc
    878 
    -           ; (arg_co, arg_ty_frr) <- hasFixedRuntimeRep (FRRExpectedFunTy (updatePositionCtOrigin arg_pos herald) arg_pos) arg_ty
    878 
    +           ; (arg_co, arg_ty_frr) <- hasFixedRuntimeRep (FRRExpectedFunTy herald arg_pos) arg_ty
    879 879 
                ; let scaled_arg_ty_frr = Scaled mult arg_ty_frr
    880 880 
                ; (res_wrap, result) <- check (n_req - 1)
    881 881 
                                              (mkCheckExpFunPatTy scaled_arg_ty_frr : rev_pat_tys)
    ... ... @@ -947,19 +947,19 @@ matchExpectedFunTys herald ctx arity (Check top_ty) thing_inside
    947 947 
                ; co <- unifyType Nothing (mkScaledFunTys more_arg_tys res_ty) fun_ty
    948 948 
                ; return (mkWpCastN co, result) }
    949 949
    950 
    -new_infer_arg_ty :: CtOrigin -> Int -> TcM (Scaled ExpRhoTypeFRR)
    950 
    +new_infer_arg_ty :: ExpectedFunTyCtxt -> Int -> TcM (Scaled ExpRhoTypeFRR)
    951 951 
     new_infer_arg_ty herald arg_pos -- position for error messages only
    952 952 
       = do { mult     <- newFlexiTyVarTy multiplicityTy
    953 
    -       ; inf_hole <- newInferExpTypeFRR IIF_DeepRho (FRRExpectedFunTy (updatePositionCtOrigin arg_pos herald) arg_pos)
    953 
    +       ; inf_hole <- newInferExpTypeFRR IIF_DeepRho (FRRExpectedFunTy herald arg_pos)
    954 954 
            ; return (mkScaled mult inf_hole) }
    955 955
    956 
    -new_check_arg_ty :: CtOrigin -> Int -> TcM (Scaled TcType)
    956 
    +new_check_arg_ty :: ExpectedFunTyCtxt -> Int -> TcM (Scaled TcType)
    957 957 
     new_check_arg_ty herald arg_pos -- Position for error messages only, 1 for first arg
    958 958 
       = do { mult   <- newFlexiTyVarTy multiplicityTy
    959 
    -       ; arg_ty <- newOpenFlexiFRRTyVarTy (FRRExpectedFunTy (updatePositionCtOrigin arg_pos herald) arg_pos)
    959 
    +       ; arg_ty <- newOpenFlexiFRRTyVarTy (FRRExpectedFunTy herald arg_pos)
    960 960 
            ; return (mkScaled mult arg_ty) }
    961 961
    962 
    -mkFunTysMsg :: CtOrigin
    962 
    +mkFunTysMsg :: ExpectedFunTyCtxt
    963 963 
                 -> (VisArity, TcType)
    964 964 
                 -> ErrCtxtMsg
    965 965 
     -- See Note [Reporting application arity errors]

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