| ... |
... |
@@ -25,14 +25,13 @@ import GHC.Types.SourceText ( SourceText(..) ) |
|
25
|
25
|
import GHC.Builtin.KnownOccs
|
|
26
|
26
|
import GHC.Builtin.WiredIn.Ids ( leftSectionName, rightSectionName )
|
|
27
|
27
|
import GHC.Rename.Utils
|
|
28
|
|
-import GHC.Rename.Env ( lookupOccRnNone )
|
|
|
28
|
+import GHC.Rename.Env ( lookupOccRnNone, lookupSyntaxName )
|
|
29
|
29
|
|
|
30
|
30
|
import GHC.Utils.Panic
|
|
31
|
31
|
import GHC.Utils.Outputable
|
|
32
|
32
|
|
|
33
|
33
|
import qualified Data.List.NonEmpty as NE ( map, head, (<|) )
|
|
34
|
34
|
import Data.List.NonEmpty ( NonEmpty(..), init, last, tail )
|
|
35
|
|
-import Data.Maybe ( isJust )
|
|
36
|
35
|
|
|
37
|
36
|
import qualified GHC.LanguageExtensions as LangExt
|
|
38
|
37
|
import GHC.Builtin.KnownKeys (getFieldClassOpOcc)
|
| ... |
... |
@@ -119,6 +118,9 @@ Wrinkle (TBE1) |
|
119
|
118
|
|
|
120
|
119
|
-}
|
|
121
|
120
|
|
|
|
121
|
+ifThenElseOcc :: KnownOcc
|
|
|
122
|
+ifThenElseOcc = rdrNameOcc $ mkVarUnqual (fsLit "ifThenElse")
|
|
|
123
|
+
|
|
122
|
124
|
-- See Note [Typechecking by expansion: overview]
|
|
123
|
125
|
tcExpand :: HsExpr GhcRn -> TcM (Maybe (HsExpansion GhcRn))
|
|
124
|
126
|
|
| ... |
... |
@@ -168,61 +170,55 @@ tcExpand e@(HsIf NoRebindable p b1 b2 ) |
|
168
|
170
|
= do { isRebindableOn <- getThRebindableSyntax
|
|
169
|
171
|
-- Check if we are actually expanding a template haskell generated spliced-in expression
|
|
170
|
172
|
-- and the original expression was typed in a rebindable context
|
|
171
|
|
- ; if isJust isRebindableOn
|
|
172
|
|
- then do
|
|
173
|
|
- { ifThenElseName <- lookupOccRnNone (mkVarUnqual (fsLit "ifThenElse"))
|
|
174
|
|
- -- This ought to pass as ifThenElse would be added into the enviornment
|
|
175
|
|
- -- by the setThRebindableSyntax call below
|
|
176
|
|
- ; return $ Just $
|
|
177
|
|
- HSE { hse_ctxt = ExprCtxt e
|
|
178
|
|
- , hse_exp = wrapGenSpan $ genHsApps ifThenElseName [p, b1, b2] }
|
|
179
|
|
- }
|
|
180
|
|
- else return Nothing }
|
|
181
|
|
-tcExpand e@(HsIf (Rebindable rs_table) p b1 b2)
|
|
182
|
|
- | Just ifThenElseName <- lookup (rdrNameOcc $ mkVarUnqual (fsLit "ifThenElse")) rs_table
|
|
183
|
|
- = return $ Just $
|
|
184
|
|
- HSE { hse_ctxt = ExprCtxt e
|
|
185
|
|
- , hse_exp = wrapGenSpan $ genHsApps ifThenElseName [p, b1, b2]
|
|
186
|
|
- }
|
|
187
|
|
- | otherwise
|
|
188
|
|
- = pprPanic "tcExpand" (vcat [ text "Should Never Happen: could not find ifThenElse in rs_table"
|
|
189
|
|
- , ppr e ])
|
|
|
173
|
+ ; case isRebindableOn of
|
|
|
174
|
+ Just mod ->
|
|
|
175
|
+ do { ifThenElseName <- lookupOccRnNone (mkRdrQual mod ifThenElseOcc)
|
|
|
176
|
+ -- This ought to pass as ifThenElse would be added into the enviornment
|
|
|
177
|
+ -- by the setThRebindableSyntax call below (hopefully)
|
|
|
178
|
+ ; return $ Just $
|
|
|
179
|
+ HSE { hse_ctxt = ExprCtxt e
|
|
|
180
|
+ , hse_exp = wrapGenSpan $ genHsApps ifThenElseName [p, b1, b2] }
|
|
|
181
|
+ }
|
|
|
182
|
+ _ -> return Nothing
|
|
|
183
|
+ }
|
|
|
184
|
+tcExpand e@(HsIf (Rebindable _) p b1 b2)
|
|
|
185
|
+ = do { (ifThenElseName, _) <- lookupSyntaxName ifThenElseOcc
|
|
|
186
|
+ ; return $ Just $
|
|
|
187
|
+ HSE { hse_ctxt = ExprCtxt e
|
|
|
188
|
+ , hse_exp = wrapGenSpan $ genHsApps ifThenElseName [p, b1, b2]
|
|
|
189
|
+ }
|
|
|
190
|
+ }
|
|
|
191
|
+
|
|
190
|
192
|
|
|
191
|
193
|
------------------------------------------
|
|
192
|
194
|
-- Record dot syntax
|
|
193
|
195
|
|
|
194
|
|
-tcExpand e@(HsGetField (Rebindable rs_table) expr f)
|
|
195
|
|
- | Just getField <- lookup getFieldClassOpOcc rs_table
|
|
196
|
|
- = return $ Just $
|
|
197
|
|
- HSE { hse_ctxt = ExprCtxt e
|
|
198
|
|
- , hse_exp = wrapGenSpan $ (mkGetField getField expr (fmap (unLoc . dfoLabel) f)) }
|
|
199
|
|
- | otherwise
|
|
200
|
|
- = pprPanic "tcExpand" (vcat [ text "Should Never Happen: could not find getField in rs_table"
|
|
201
|
|
- , ppr e ])
|
|
202
|
|
-
|
|
203
|
|
-tcExpand e@(HsProjection (Rebindable rs_table) fs)
|
|
204
|
|
- | Just getField <- lookup getFieldClassOpOcc rs_table
|
|
205
|
|
- , Just circ <- lookup (rdrNameOcc compose_RDR) rs_table
|
|
206
|
|
- = return $ Just $
|
|
207
|
|
- HSE { hse_ctxt = ExprCtxt e
|
|
208
|
|
- , hse_exp = wrapGenSpan $ (mkProjection getField circ $ NE.map (unLoc . dfoLabel) fs) }
|
|
209
|
|
- | otherwise
|
|
210
|
|
- = pprPanic "tcExpand" (vcat [ text "Should Never Happen: could not find getField or circ in rs_table"
|
|
211
|
|
- , ppr e])
|
|
212
|
|
-
|
|
|
196
|
+tcExpand e@(HsGetField (Rebindable _) expr f)
|
|
|
197
|
+ = do { (getFieldName, _) <- lookupSyntaxName getFieldClassOpOcc
|
|
|
198
|
+ ; return $ Just $
|
|
|
199
|
+ HSE { hse_ctxt = ExprCtxt e
|
|
|
200
|
+ , hse_exp = wrapGenSpan $ (mkGetField getFieldName expr (fmap (unLoc . dfoLabel) f)) }
|
|
|
201
|
+ }
|
|
|
202
|
+tcExpand (HsGetField _ _ _) = return Nothing
|
|
213
|
203
|
|
|
|
204
|
+tcExpand e@(HsProjection (Rebindable _) fs)
|
|
|
205
|
+ = do { (getFieldName, _) <- lookupSyntaxName getFieldClassOpOcc
|
|
|
206
|
+ ; (circName, _) <- lookupSyntaxName (rdrNameOcc compose_RDR)
|
|
|
207
|
+ ; return $ Just $
|
|
|
208
|
+ HSE { hse_ctxt = ExprCtxt e
|
|
|
209
|
+ , hse_exp = wrapGenSpan $ (mkProjection getFieldName circName $ NE.map (unLoc . dfoLabel) fs) }
|
|
|
210
|
+ }
|
|
|
211
|
+tcExpand (HsProjection _ _) = return Nothing
|
|
|
212
|
+
|
|
|
213
|
+tcExpand e@(RecordUpd (Rebindable _) (L l expr) (OverloadedRecUpdFields { olRecUpdFields = us}))
|
|
|
214
|
+ = do {
|
|
|
215
|
+ (getFieldName, _) <- lookupSyntaxName getFieldClassOpOcc
|
|
|
216
|
+ ; (setFieldName, _) <- lookupSyntaxName setFieldClassOpOcc
|
|
|
217
|
+ ; return $ Just $
|
|
|
218
|
+ HSE { hse_ctxt = ExprCtxt e
|
|
|
219
|
+ , hse_exp = wrapGenSpan $ mkRecordDotUpd getFieldName setFieldName (L l expr) us } }
|
|
214
|
220
|
tcExpand (RecordUpd NoRebindable _ _ ) = return Nothing -- until #27160 is fixed
|
|
215
|
221
|
|
|
216
|
|
-tcExpand e@(RecordUpd (Rebindable rs_table) (L l expr) (OverloadedRecUpdFields { olRecUpdFields = us}))
|
|
217
|
|
- | Just getField <- lookup getFieldClassOpOcc rs_table
|
|
218
|
|
- , Just setField <- lookup setFieldClassOpOcc rs_table
|
|
219
|
|
- = return $ Just $
|
|
220
|
|
- HSE { hse_ctxt = ExprCtxt e
|
|
221
|
|
- , hse_exp = wrapGenSpan $ mkRecordDotUpd getField setField (L l expr) us }
|
|
222
|
|
- | otherwise
|
|
223
|
|
- = pprPanic "tcExpand" (vcat [ text "Should Never Happen: could not find getField or setfield in rs_table"
|
|
224
|
|
- , ppr e ])
|
|
225
|
|
-
|
|
226
|
222
|
------------------------------------------
|
|
227
|
223
|
-- Left and Right Sections
|
|
228
|
224
|
|
| ... |
... |
@@ -306,6 +302,7 @@ tcExpand e@(XExpr (ReSynBindsRn m inner_e)) |
|
306
|
302
|
= setThRebindableSyntax m $
|
|
307
|
303
|
-- set environment variable to be in rebindable syntax
|
|
308
|
304
|
-- add the required rebindable syntax binding names into the environment
|
|
|
305
|
+
|
|
309
|
306
|
do {
|
|
310
|
307
|
-- now try expanding inner_e
|
|
311
|
308
|
; traceTc "tcExpand: ReSynBindsRn" (ppr e)
|
| ... |
... |
@@ -519,3 +516,24 @@ mkRecordDotUpd get_field set_field exp updates = foldl' fieldUpdate (unLoc exp) |
|
519
|
516
|
where
|
|
520
|
517
|
fieldUpdate :: HsExpr GhcRn -> LHsRecUpdProj GhcRn -> HsExpr GhcRn
|
|
521
|
518
|
fieldUpdate acc lpu = unLoc $ (mkProjUpdateSetField get_field set_field lpu) (wrapGenSpan acc)
|
|
|
519
|
+
|
|
|
520
|
+
|
|
|
521
|
+----------------------------------------------------
|
|
|
522
|
+-- Template Haskell Splices with Rebindable Syntax
|
|
|
523
|
+
|
|
|
524
|
+-- We have a module name
|
|
|
525
|
+-- We need to get the toplevel environment of that module
|
|
|
526
|
+-- so that we can (implicitly) add it to the current module
|
|
|
527
|
+-- and then type check the splice expression
|
|
|
528
|
+
|
|
|
529
|
+-- getExternalModIface :: Name -> TcM (Maybe ModIface)
|
|
|
530
|
+-- getExternalModIface nm = do
|
|
|
531
|
+-- isLocal <- nameIsLocalOrFrom <$> getModule <*> pure nm
|
|
|
532
|
+-- if isLocal
|
|
|
533
|
+-- then pure Nothing -- should not be reached, unless there is a circular dependency
|
|
|
534
|
+-- else case nameModule_maybe nm of
|
|
|
535
|
+-- Nothing -> pure Nothing
|
|
|
536
|
+-- Just modNm -> do
|
|
|
537
|
+-- hsc_env <- getTopEnv
|
|
|
538
|
+-- iface <- liftIO $ hscGetModuleInterface hsc_env modNm
|
|
|
539
|
+-- pure (Just iface) |