Apoorv Ingle pushed to branch wip/ani/T27156 at Glasgow Haskell Compiler / GHC

Commits:

1 changed file:

Changes:

  • compiler/GHC/Tc/Gen/Expand.hs
    ... ... @@ -5,7 +5,7 @@
    5 5 
     (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
    6 6 
     -}
    7 7
    8 
    -module GHC.Tc.Gen.Expand( tcExpand, tcExpandNoTcM ) where
    8 
    +module GHC.Tc.Gen.Expand( tcExpand ) where
    9 9
    10 10 
     import GHC.Prelude hiding (last, init, tail)
    11 11 
     import GHC.Data.FastString
    ... ... @@ -120,15 +120,14 @@ Wrinkle (TBE1)
    120 120
    121 121 
     -- See Note [Typechecking by expansion: overview]
    122 122 
     tcExpand :: HsExpr GhcRn -> TcM (Maybe (HsExpansion GhcRn))
    123 
    -tcExpandNoTcM :: HsExpr GhcRn -> Maybe (HsExpansion GhcRn)
    124 123
    125 124 
     ------------------------------------------
    126 125 
     -- Overloaded labels
    127 
    -tcExpandNoTcM e@(HsOverLabel (_, Rebindable rs_table) v)
    126 
    +tcExpand e@(HsOverLabel (_, Rebindable rs_table) v)
    128 127 
       | Just fromLabelName <- lookup (nameOccName fromLabelClassOpName) rs_table
    129 128 
       , let hs_ty_arg = mkEmptyWildCardBndrs $ wrapGenSpan $
    130 129 
                           HsTyLit noExtField (HsString NoSourceText v)
    131 
    -  = Just $
    130 
    +  = return $ Just $
    132 131 
         HSE { hse_ctxt = ExprCtxt e
    133 132 
             , hse_exp = wrapGenSpan $ HsAppType noExtField (genLHsVar fromLabelName) hs_ty_arg
    134 133 
             }
    ... ... @@ -139,11 +138,11 @@ tcExpandNoTcM e@(HsOverLabel (_, Rebindable rs_table) v)
    139 138
    140 139 
     ------------------------------------------
    141 140 
     -- Qualified Literals
    142 
    -tcExpandNoTcM e@(HsQualLit _ QualLit{ql_val = ql_val, ql_ext = (L _ fromStringName)})
    141 
    +tcExpand e@(HsQualLit _ QualLit{ql_val = ql_val, ql_ext = (L _ fromStringName)})
    143 142 
       = do { let hsLit = case ql_val of
    144 143 
                             -- See Note [Implementation of QualifiedStrings]
    145 144 
                             HsQualString st s -> HsString st s
    146 
    -       ; Just $
    145 
    +       ; return $ Just $
    147 146 
              HSE { hse_ctxt = ExprCtxt e
    148 147 
                  , hse_exp = wrapGenSpan $ genHsApps fromStringName [genLHsLit hsLit]
    149 148 
                  }
    ... ... @@ -152,8 +151,8 @@ tcExpandNoTcM e@(HsQualLit _ QualLit{ql_val = ql_val, ql_ext = (L _ fromStringNa
    152 151
    153 152 
     ------------------------------------------
    154 153 
     -- Operator Applications
    155 
    -tcExpandNoTcM e@(OpApp _ arg1 op arg2)
    156 
    -  = Just $
    154 
    +tcExpand e@(OpApp _ arg1 op arg2)
    155 
    +  = return $ Just $
    157 156 
         HSE { hse_ctxt = ExprCtxt e
    158 157 
             , hse_exp  = foldl ap op [arg1,arg2] }
    159 158 
       where
    ... ... @@ -164,11 +163,11 @@ tcExpandNoTcM e@(OpApp _ arg1 op arg2)
    164 163
    165 164 
     -- NoRebindable <=> rebindable is turned off
    166 165 
     --             so we typecheck the HsIf in tcExprNoExpand
    167 
    -tcExpandNoTcM (HsIf NoRebindable _ _ _ )
    168 
    -  = Nothing
    169 
    -tcExpandNoTcM e@(HsIf (Rebindable rs_table) p b1 b2)
    166 
    +tcExpand (HsIf NoRebindable _ _ _ )
    167 
    +  = return Nothing
    168 
    +tcExpand e@(HsIf (Rebindable rs_table) p b1 b2)
    170 169 
       | Just ifThenElseName <- lookup (rdrNameOcc $ mkVarUnqual (fsLit "ifThenElse")) rs_table
    171 
    -  = Just $
    170 
    +  = return $ Just $
    172 171 
         HSE { hse_ctxt = ExprCtxt e
    173 172 
             , hse_exp = wrapGenSpan $ genHsApps ifThenElseName [p, b1, b2]
    174 173 
             }
    ... ... @@ -179,19 +178,19 @@ tcExpandNoTcM e@(HsIf (Rebindable rs_table) p b1 b2)
    179 178 
     ------------------------------------------
    180 179 
     -- Record dot syntax
    181 180
    182 
    -tcExpandNoTcM e@(HsGetField (Rebindable rs_table) expr f)
    181 
    +tcExpand e@(HsGetField (Rebindable rs_table) expr f)
    183 182 
      | Just getField <- lookup (nameOccName getFieldName) rs_table
    184 
    - = Just $
    183 
    + = return $ Just $
    185 184 
        HSE { hse_ctxt = ExprCtxt e
    186 185 
            , hse_exp = wrapGenSpan $ (mkGetField getField expr (fmap (unLoc . dfoLabel) f)) }
    187 186 
      | otherwise
    188 187 
      = pprPanic "tcExpand" (vcat [ text "Should Never Happen: could not find getField in rs_table"
    189 188 
                                  , ppr e ])
    190 189
    191 
    -tcExpandNoTcM e@(HsProjection (Rebindable rs_table) fs)
    190 
    +tcExpand e@(HsProjection (Rebindable rs_table) fs)
    192 191 
      | Just getField <- lookup (nameOccName getFieldName) rs_table
    193 192 
      , Just circ <- lookup (rdrNameOcc compose_RDR) rs_table
    194 
    - = Just $
    193 
    + = return $ Just $
    195 194 
        HSE { hse_ctxt = ExprCtxt e
    196 195 
            , hse_exp = wrapGenSpan $ (mkProjection getField circ $ NE.map (unLoc . dfoLabel) fs) }
    197 196 
      | otherwise
    ... ... @@ -199,32 +198,18 @@ tcExpandNoTcM e@(HsProjection (Rebindable rs_table) fs)
    199 198 
                                  , ppr e])
    200 199
    201 200
    202 
    -tcExpandNoTcM (RecordUpd NoRebindable _ _ ) = Nothing -- until #27160 is fixed
    201 
    +tcExpand (RecordUpd NoRebindable _ _ ) = return Nothing -- until #27160 is fixed
    203 202
    204 
    -tcExpandNoTcM e@(RecordUpd (Rebindable rs_table) (L l expr) (OverloadedRecUpdFields { olRecUpdFields = us}))
    203 
    +tcExpand e@(RecordUpd (Rebindable rs_table) (L l expr) (OverloadedRecUpdFields { olRecUpdFields = us}))
    205 204 
      | Just getField <- lookup (nameOccName getFieldName) rs_table
    206 205 
      , Just setField <- lookup (nameOccName setFieldName) rs_table
    207 
    - = Just $
    206 
    + = return $ Just $
    208 207 
        HSE { hse_ctxt = ExprCtxt e
    209 208 
            , hse_exp = wrapGenSpan $ mkRecordDotUpd getField setField (L l expr) us }
    210 209 
      | otherwise
    211 210 
      = pprPanic "tcExpand" (vcat [ text "Should Never Happen: could not find getField or setfield in rs_table"
    212 211 
                                  , ppr e ])
    213 212
    214 
    -
    215 
    -
    216 
    -------------------------
    217 
    --- XExpr
    218 
    --- Expansions are idempotent, XExprs do not expand again
    219 
    -tcExpandNoTcM (XExpr (ExpandedThingRn hse))
    220 
    -  = Just hse
    221 
    -
    222 
    -
    223 
    -tcExpandNoTcM _
    224 
    -  = Nothing
    225 
    -
    226 
    -
    227 
    -
    228 213 
     ------------------------------------------
    229 214 
     -- Left and Right Sections
    230 215
    ... ... @@ -301,10 +286,13 @@ tcExpand e@(HsUntypedSplice splice_res _)
    301 286 
                      , hse_exp  = wrapGenSpan fun }
    302 287 
            }
    303 288
    304 
    -tcExpand e = return $ tcExpandNoTcM e
    305 
    -
    306 
    -
    289 
    +------------------------
    290 
    +-- XExpr
    291 
    +-- Expansions are idempotent, XExprs do not expand again
    292 
    +tcExpand (XExpr (ExpandedThingRn hse))
    293 
    +  = return $ Just hse
    307 294
    295 
    +tcExpand _ = return $ Nothing
    308 296
    309 297
    310 298

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