[commit: ghc] wip/hasfield: Reintroduce OverloadedRecordFields extension, with specialised behaviour (307ab8e)
git at git.haskell.org
git at git.haskell.org
Sat Oct 8 16:15:33 UTC 2016
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/hasfield
Link : http://ghc.haskell.org/trac/ghc/changeset/307ab8ed1c15b7ea779f00389cca11e44dbeb44d/ghc
>---------------------------------------------------------------
commit 307ab8ed1c15b7ea779f00389cca11e44dbeb44d
Author: Adam Gundry <adam at well-typed.com>
Date: Sat Oct 8 14:39:52 2016 +0100
Reintroduce OverloadedRecordFields extension, with specialised behaviour
>---------------------------------------------------------------
307ab8ed1c15b7ea779f00389cca11e44dbeb44d
compiler/main/DynFlags.hs | 1 +
compiler/parser/Lexer.x | 3 +-
compiler/typecheck/TcExpr.hs | 52 +++++++++++++++-------
.../ghc-boot-th/GHC/LanguageExtensions/Type.hs | 1 +
testsuite/tests/overloadedrecflds/ghci/all.T | 1 +
.../ghci/overloadedrecfldsghci01.script | 8 ++++
.../ghci/overloadedrecfldsghci01.stdout | 5 +++
7 files changed, 54 insertions(+), 17 deletions(-)
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 7978c03..63d0d16 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -3661,6 +3661,7 @@ xFlagsDeps = [
"instead use per-instance pragmas OVERLAPPING/OVERLAPPABLE/OVERLAPS",
flagSpec "OverloadedLabels" LangExt.OverloadedLabels,
flagSpec "OverloadedLists" LangExt.OverloadedLists,
+ flagSpec "OverloadedRecordFields" LangExt.OverloadedRecordFields,
flagSpec "OverloadedStrings" LangExt.OverloadedStrings,
flagSpec "PackageImports" LangExt.PackageImports,
flagSpec "ParallelArrays" LangExt.ParallelArrays,
diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 6800fab..de71c18 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -2231,7 +2231,8 @@ mkParserFlags flags =
.|. ThQuotesBit `setBitIf` xopt LangExt.TemplateHaskellQuotes flags
.|. QqBit `setBitIf` xopt LangExt.QuasiQuotes flags
.|. IpBit `setBitIf` xopt LangExt.ImplicitParams flags
- .|. OverloadedLabelsBit `setBitIf` xopt LangExt.OverloadedLabels flags
+ .|. OverloadedLabelsBit `setBitIf` (xopt LangExt.OverloadedLabels flags
+ || xopt LangExt.OverloadedRecordFields flags)
.|. ExplicitForallBit `setBitIf` xopt LangExt.ExplicitForAll flags
.|. BangPatBit `setBitIf` xopt LangExt.BangPatterns flags
.|. HaddockBit `setBitIf` gopt Opt_Haddock flags
diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs
index 3a5f715..63396f2 100644
--- a/compiler/typecheck/TcExpr.hs
+++ b/compiler/typecheck/TcExpr.hs
@@ -218,17 +218,29 @@ tcExpr e@(HsIPVar x) res_ty
origin = IPOccOrigin x
tcExpr e@(HsOverLabel l) res_ty -- See Note [Type-checking overloaded labels]
- = do { isLabelClass <- tcLookupClass isLabelClassName
- ; alpha <- newOpenFlexiTyVarTy
- ; let lbl = mkStrLitTy l
- pred = mkClassPred isLabelClass [lbl, alpha]
- ; loc <- getSrcSpanM
- ; var <- emitWantedEvVar origin pred
- ; tcWrapResult e (fromDict pred (HsVar (L loc var))) alpha res_ty }
+ = do { dflags <- getDynFlags
+ ; if xopt LangExt.OverloadedLabels dflags
+ then do { isLabelClass <- tcLookupClass isLabelClassName
+ ; alpha <- newFlexiTyVarTy liftedTypeKind
+ ; let pred = mkClassPred isLabelClass [lbl, alpha]
+ ; loc <- getSrcSpanM
+ ; var <- emitWantedEvVar origin pred
+ ; tcWrapResult e (fromDict pred (HsVar (L loc var))) alpha res_ty }
+ else do { -- must be OverloadedRecordFields alone
+ hasFieldClass <- tcLookupClass hasFieldClassName
+ ; alpha <- newFlexiTyVarTy liftedTypeKind
+ ; beta <- newFlexiTyVarTy liftedTypeKind
+ ; let pred = mkClassPred hasFieldClass [typeSymbolKind, lbl, alpha, beta]
+ ; loc <- getSrcSpanM
+ ; var <- emitWantedEvVar origin pred
+ ; tcWrapResult e (fromDict pred (HsVar (L loc var))) (mkFunTy alpha beta) res_ty }
+ }
where
- -- Coerces a dictionary for `IsLabel "x" t` into `t`.
+ -- Coerces a dictionary for `IsLabel "x" t` into `t`,
+ -- or `HasField "x" r a into `r -> a`.
fromDict pred = HsWrap $ mkWpCastR $ unwrapIP pred
origin = OverLabelOrigin l
+ lbl = mkStrLitTy l
tcExpr (HsLam match) res_ty
= do { (match', wrap) <- tcMatchLambda herald match_ctxt match res_ty
@@ -263,18 +275,26 @@ tcExpr e@(ExprWithTySig expr sig_ty) res_ty
{-
Note [Type-checking overloaded labels]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Recall that (in GHC.OverloadedLabels) we have
+Recall that we have
- class IsLabel (x :: Symbol) a where
+ class IsLabel (x :: Symbol) a where -- in GHC.OverloadedLabels
fromLabel :: a
-When we see an overloaded label like `#foo`, we generate a fresh
-variable `alpha` for the type and emit an `IsLabel "foo" alpha`
-constraint. Because the `IsLabel` class has a single method, it is
-represented by a newtype, so we can coerce `IsLabel "foo" alpha` to
-`alpha` (just like for implicit parameters).
+ class HasField (x :: k) r a | x r -> a where -- in GHC.Records
+ fromLabel :: r -> a
+
+We translate `#foo` to `fromLabel @"foo"`, where we use
+
+ * `GHC.OverloadedLabels.fromLabel` if `OverloadedLabels` is enabled
+ * `GHC.Records.fromLabel` otherwise (`OverloadedRecordFields` must be enabled)
-That is, we translate `#foo` to `fromLabel @"foo"`.
+In the first case, when we see an overloaded label like `#foo`, we
+generate a fresh variable `alpha` for the type and emit an
+`IsLabel "foo" alpha` constraint. Because the `IsLabel` class has a
+single method, it is represented by a newtype, so we can coerce
+`IsLabel "foo" alpha` to `alpha` (just like for implicit parameters).
+The second case is similar, but we generate two fresh variables and
+emit a `HasField` constraint.
-}
diff --git a/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs b/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs
index ff26ec6..248677f 100644
--- a/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs
+++ b/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs
@@ -121,6 +121,7 @@ data Extension
| BinaryLiterals
| NegativeLiterals
| DuplicateRecordFields
+ | OverloadedRecordFields
| OverloadedLabels
| EmptyCase
| PatternSynonyms
diff --git a/testsuite/tests/overloadedrecflds/ghci/all.T b/testsuite/tests/overloadedrecflds/ghci/all.T
index 6a95bb2..1fd9f65 100644
--- a/testsuite/tests/overloadedrecflds/ghci/all.T
+++ b/testsuite/tests/overloadedrecflds/ghci/all.T
@@ -1,2 +1,3 @@
test('duplicaterecfldsghci01', combined_output, ghci_script, ['duplicaterecfldsghci01.script'])
+test('overloadedrecfldsghci01', combined_output, ghci_script, ['overloadedrecfldsghci01.script'])
test('overloadedlabelsghci01', combined_output, ghci_script, ['overloadedlabelsghci01.script'])
diff --git a/testsuite/tests/overloadedrecflds/ghci/overloadedrecfldsghci01.script b/testsuite/tests/overloadedrecflds/ghci/overloadedrecfldsghci01.script
new file mode 100644
index 0000000..afe7536
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/ghci/overloadedrecfldsghci01.script
@@ -0,0 +1,8 @@
+:set -XOverloadedRecordFields
+:t #x
+:m + GHC.Records
+:t #foo . #bar
+data T = MkT { foo :: Int }
+#foo (MkT 42)
+:set -XOverloadedLabels
+:t #x
diff --git a/testsuite/tests/overloadedrecflds/ghci/overloadedrecfldsghci01.stdout b/testsuite/tests/overloadedrecflds/ghci/overloadedrecfldsghci01.stdout
new file mode 100644
index 0000000..13fe63a
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/ghci/overloadedrecfldsghci01.stdout
@@ -0,0 +1,5 @@
+#x :: GHC.Records.HasField "x" t2 t1 => t2 -> t1
+#foo . #bar
+ :: (HasField "foo" t1 c, HasField "bar" t2 t1) => t2 -> c
+42
+#x :: GHC.OverloadedLabels.IsLabel "x" t => t
More information about the ghc-commits
mailing list