[Git][ghc/ghc][wip/T18599] GetField desugar on typecheck
Shayne Fletcher
gitlab at gitlab.haskell.org
Mon Dec 14 01:13:55 UTC 2020
Shayne Fletcher pushed to branch wip/T18599 at Glasgow Haskell Compiler / GHC
Commits:
3015d6d7 by Shayne Fletcher at 2020-12-13T20:13:40-05:00
GetField desugar on typecheck
- - - - -
6 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Types/Origin.hs
- testsuite/tests/parser/should_run/RecordDotSyntax.hs
Changes:
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -495,7 +495,6 @@ data HsExpr p
, gf_expr :: LHsExpr p
, gf_field :: Located FastString
, gf_get_field :: Maybe (IdP p)
- , gf_getField :: LHsExpr p -- Desugared equivalent 'getField' term.
}
-- ^ @Just id@ means @RebindableSyntax@ is in use and gives the id
-- of the in-scope 'getField'.
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -2763,7 +2763,6 @@ mkGetField loc arg field =
, gf_expr = arg
, gf_field = field
, gf_get_field = Nothing
- , gf_getField = mkGet arg field
}
mkProjection :: SrcSpan -> [Located FastString] -> LHsExpr GhcPs
=====================================
compiler/GHC/Rename/Expr.hs
=====================================
@@ -212,22 +212,41 @@ rnExpr (NegApp _ e _)
------------------------------------------
-- Record dot syntax
-rnExpr (GetField x e f _ g)
- = do { (e', _) <- rnLExpr e
- ; (g', fv) <- rnLExpr g
- ; return (GetField x e' f Nothing g', fv)
+
+rnExpr (GetField x e f _)
+ = do { rebindable_on <- xoptM LangExt.RebindableSyntax
+ ; (e', fvs) <- rnLExpr e
+ ; if rebindable_on
+ then do {
+ getField <- lookupOccRn (mkVarUnqual (fsLit "getField"))
+ ; return (GetField x e' f (Just getField), fvs `plusFV` unitFV getField)
+ }
+ else return (GetField x e' f Nothing, fvs)
}
rnExpr (Projection x fs _ p)
- = do { (p', fv) <- rnLExpr p
- ; return (Projection x fs Nothing p', fv)
+ = do { rebindable_on <- xoptM LangExt.RebindableSyntax
+ ; (p', fv) <- rnLExpr p
+ ; if rebindable_on
+ then do {
+ getField <- lookupOccRn (mkVarUnqual (fsLit "getField"))
+ ; return (Projection x fs (Just getField) p', fv)
+ }
+ else return (Projection x fs Nothing p', fv)
}
rnExpr (RecordDotUpd x e us _ f)
- = do { (e', _) <- rnLExpr e
+ = do { rebindable_on <- xoptM LangExt.RebindableSyntax
+ ; (e', _) <- rnLExpr e
; us' <- map fst <$> mapM rnRecUpdProj us
; (f', fv) <- rnLExpr f
- ; return (RecordDotUpd x e' us' Nothing f', fv)
+ ; if rebindable_on
+ then do {
+ getField <- lookupOccRn (mkVarUnqual (fsLit "getField"))
+ ; setField <- lookupOccRn (mkVarUnqual (fsLit "setField"))
+ ; return (RecordDotUpd x e' us'(Just (getField, setField)) f', fv)
+ }
+ else return (RecordDotUpd x e' us' Nothing f', fv)
}
where
rnRecUpdProj :: LHsRecUpdProj GhcPs -> RnM (LHsRecUpdProj GhcRn, FreeVars)
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -86,6 +86,8 @@ import qualified GHC.LanguageExtensions as LangExt
import Data.Function
import Data.List (partition, sortBy, groupBy, intersect)
+import GHC.Types.Fixity
+
{-
************************************************************************
* *
@@ -934,7 +936,14 @@ tcExpr (ArithSeq _ witness seq) res_ty
* *
************************************************************************
-}
-tcExpr (GetField _ _ _ _ (L _ g)) res_ty = tcExpr g res_ty
+
+tcExpr (GetField _ arg field mb_getField) res_ty
+ = do { -- See Note [Type-checking record dot syntax] (not written yet)
+ loc <- getSrcSpanM
+ ; case mb_getField of
+ Just getField -> tcExpr (mkGet loc getField arg field) res_ty
+ Nothing -> panic "tcExpr: GetField: Not implemented"
+ }
tcExpr (Projection _ _ _ (L _ p)) res_ty = tcExpr p res_ty
tcExpr (RecordDotUpd _ _ _ _ (L _ s)) res_ty = tcExpr s res_ty
@@ -1830,3 +1839,34 @@ checkClosedInStaticForm name = do
-- When @n@ is not closed, we traverse the graph reachable from @n@ to build
-- the reason.
--
+
+-----------------------------------------
+-- Bits and pieces for RecordDotSyntax.
+
+mkParen :: SrcSpan -> LHsExpr GhcRn -> LHsExpr GhcRn
+mkParen loc = L loc . HsPar noExtField
+
+mkApp :: SrcSpan -> LHsExpr GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn
+mkApp loc x = L loc . HsApp noExtField x
+
+_mkOpApp :: LHsExpr GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn
+_mkOpApp x op = noLoc . OpApp (Fixity NoSourceText minPrecedence InfixL) x op
+
+mkAppType :: SrcSpan -> LHsExpr GhcRn -> GenLocated SrcSpan (HsType (NoGhcTc GhcRn)) -> LHsExpr GhcRn
+mkAppType loc expr = L loc . HsAppType noExtField expr . mkEmptyWildCardBndrs
+
+mkSelector :: SrcSpan -> FastString -> LHsType GhcRn
+mkSelector loc = L loc . HsTyLit noExtField . HsStrTy NoSourceText
+
+-- mkGet arg field calcuates a get_field @field arg expression.
+-- e.g. z.x = mkGet z x = get_field @x z
+mkGet :: SrcSpan -> Name -> LHsExpr GhcRn -> Located FastString -> HsExpr GhcRn
+mkGet loc get_field arg field = unLoc (head $ mkGet' loc get_field [arg] field)
+
+mkGet' :: SrcSpan -> Name -> [LHsExpr GhcRn] -> Located FastString -> [LHsExpr GhcRn]
+mkGet' loc get_field l@(r : _) (L _ field) =
+ mkApp loc (mkAppType loc (L loc (HsVar noExtField (L loc get_field)))
+ (mkSelector loc field)) (mkParen loc r)
+ : l
+
+mkGet' _ _ [] _ = panic "mkGet' : The impossible has happened!"
=====================================
compiler/GHC/Tc/Types/Origin.hs
=====================================
@@ -493,7 +493,7 @@ exprCtOrigin (HsAppType _ e1 _) = lexprCtOrigin e1
exprCtOrigin (OpApp _ _ op _) = lexprCtOrigin op
exprCtOrigin (NegApp _ e _) = lexprCtOrigin e
exprCtOrigin (HsPar _ e) = lexprCtOrigin e
-exprCtOrigin (GetField _ e _ _ _) = lexprCtOrigin e
+exprCtOrigin (GetField _ e _ _ ) = lexprCtOrigin e
exprCtOrigin (Projection _ _ _ _) = SectionOrigin
exprCtOrigin (SectionL _ _ _) = SectionOrigin
exprCtOrigin (SectionR _ _ _) = SectionOrigin
=====================================
testsuite/tests/parser/should_run/RecordDotSyntax.hs
=====================================
@@ -7,6 +7,9 @@
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE RebindableSyntax #-}
+import Prelude
+
-- Choice (C2a).
import Data.Function -- for &
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3015d6d7a93f2a9ff25aef98042757bb431bc0f7
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3015d6d7a93f2a9ff25aef98042757bb431bc0f7
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20201213/76fb526b/attachment-0001.html>
More information about the ghc-commits
mailing list