[commit: ghc] wip/hasfield: Check HasField instances to prevent overlap with built-in solving (369a3de)
git at git.haskell.org
git at git.haskell.org
Sun Oct 9 13:32:30 UTC 2016
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/hasfield
Link : http://ghc.haskell.org/trac/ghc/changeset/369a3dee65caf2642c9f137b3154edd1d6d764f8/ghc
>---------------------------------------------------------------
commit 369a3dee65caf2642c9f137b3154edd1d6d764f8
Author: Adam Gundry <adam at well-typed.com>
Date: Sun Oct 9 13:01:16 2016 +0100
Check HasField instances to prevent overlap with built-in solving
>---------------------------------------------------------------
369a3dee65caf2642c9f137b3154edd1d6d764f8
compiler/typecheck/TcInteract.hs | 3 +-
compiler/typecheck/TcValidity.hs | 43 ++++++++++++++++++++++
compiler/types/TyCon.hs | 5 ++-
.../tests/overloadedrecflds/should_fail/all.T | 1 +
.../should_fail/hasfieldfail03.hs | 38 +++++++++++++++++++
.../should_fail/hasfieldfail03.stderr | 21 +++++++++++
6 files changed, 108 insertions(+), 3 deletions(-)
diff --git a/compiler/typecheck/TcInteract.hs b/compiler/typecheck/TcInteract.hs
index bf12f57..a2222ee 100644
--- a/compiler/typecheck/TcInteract.hs
+++ b/compiler/typecheck/TcInteract.hs
@@ -39,7 +39,6 @@ import FieldLabel
import FunDeps
import FamInst
import FamInstEnv
-import FastStringEnv ( lookupDFsEnv )
import Unify ( tcUnifyTyWithTFs )
import HsBinds ( emptyLocalBinds )
@@ -2203,7 +2202,7 @@ matchHasField dflags clas tys@[_k_ty, x_ty, r_ty, a_ty] loc
-- Check that the field belongs to the tycon, and get its
-- selector name from the FieldLabel
- ; case lookupDFsEnv (tyConFieldLabelEnv rep_tycon) x of
+ ; case lookupTyConFieldLabel x rep_tycon of
Nothing -> matchInstEnv dflags clas tys loc
Just fl -> do {
diff --git a/compiler/typecheck/TcValidity.hs b/compiler/typecheck/TcValidity.hs
index 49767fe..ca6ed33 100644
--- a/compiler/typecheck/TcValidity.hs
+++ b/compiler/typecheck/TcValidity.hs
@@ -1052,6 +1052,9 @@ checkValidInstHead ctxt clas cls_args
nameModule (getName clas) == mod)
(instTypeErr clas cls_args abstract_class_msg)
+ ; when (clas `hasKey` hasFieldClassNameKey) $
+ checkHasFieldInst clas cls_args
+
-- Check language restrictions;
-- but not for SPECIALISE instance pragmas
; let ty_args = filterOutInvisibleTypes (classTyCon clas) cls_args
@@ -1144,6 +1147,26 @@ instTypeErr cls tys msg
2 (quotes (pprClassPred cls tys)))
2 msg
+-- | See Note [Validity checking of HasField instances]
+checkHasFieldInst :: Class -> [Type] -> TcM ()
+checkHasFieldInst cls tys@[_k_ty, x_ty, r_ty, _a_ty] =
+ case splitTyConApp_maybe r_ty of
+ Nothing -> whoops (text "Record data type must be specified")
+ Just (tc, _)
+ | isFamilyTyCon tc -> whoops (text "Record data type may not be a data family")
+ | otherwise -> case isStrLitTy x_ty of
+ Just lbl
+ | isJust (lookupTyConFieldLabel lbl tc)
+ -> whoops (ppr tc <+> text "already has a field"
+ <+> quotes (ppr lbl))
+ | otherwise -> return ()
+ Nothing
+ | null (tyConFieldLabels tc) -> return ()
+ | otherwise -> whoops (ppr tc <+> text "has fields")
+ where
+ whoops = addErrTc . instTypeErr cls tys
+checkHasFieldInst _ tys = pprPanic "checkHasFieldInst" (ppr tys)
+
{- Note [Casts during validity checking]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider the (bogus)
@@ -1159,6 +1182,26 @@ the middle:
Eq ((Either |> g) a)
+Note [Validity checking of HasField instances]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The HasField class has magic constraint solving behaviour (see Note
+[HasField instances] in TcInteract). However, we permit users to
+declare their own instances, provided they do not clash with the
+built-in behaviour. In particular, we forbid:
+
+ 1. `HasField _ r _` where r is a variable
+
+ 2. `HasField _ (T ...) _` if T is a data family
+ (because it might have fields introduced later)
+
+ 3. `HasField x (T ...) _` where x is a variable,
+ if T has any fields at all
+
+ 4. `HasField "foo" (T ...) _` if T has a "foo" field
+
+The usual functional dependency checks also apply.
+
+
Note [Valid 'deriving' predicate]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
validDerivPred checks for OK 'deriving' context. See Note [Exotic
diff --git a/compiler/types/TyCon.hs b/compiler/types/TyCon.hs
index d0ecb70..9578303 100644
--- a/compiler/types/TyCon.hs
+++ b/compiler/types/TyCon.hs
@@ -23,7 +23,7 @@ module TyCon(
isVisibleTyConBinder, isInvisibleTyConBinder,
-- ** Field labels
- tyConFieldLabels, tyConFieldLabelEnv,
+ tyConFieldLabels, lookupTyConFieldLabel,
-- ** Constructing TyCons
mkAlgTyCon,
@@ -1277,6 +1277,9 @@ tyConFieldLabelEnv tc
| isAlgTyCon tc = algTcFields tc
| otherwise = emptyDFsEnv
+-- | Look up a field label belonging to this 'TyCon'
+lookupTyConFieldLabel :: FieldLabelString -> TyCon -> Maybe FieldLabel
+lookupTyConFieldLabel lbl tc = lookupDFsEnv (tyConFieldLabelEnv tc) lbl
-- | Make a map from strings to FieldLabels from all the data
-- constructors of this algebraic tycon
diff --git a/testsuite/tests/overloadedrecflds/should_fail/all.T b/testsuite/tests/overloadedrecflds/should_fail/all.T
index 25e36af..c98c509 100644
--- a/testsuite/tests/overloadedrecflds/should_fail/all.T
+++ b/testsuite/tests/overloadedrecflds/should_fail/all.T
@@ -36,3 +36,4 @@ test('hasfieldfail01',
extra_clean(['HasFieldFail01_A.hi', 'HasFieldFail01_A.o']),
multimod_compile_fail, ['hasfieldfail01', ''])
test('hasfieldfail02', normal, compile_fail, [''])
+test('hasfieldfail03', normal, compile_fail, [''])
diff --git a/testsuite/tests/overloadedrecflds/should_fail/hasfieldfail03.hs b/testsuite/tests/overloadedrecflds/should_fail/hasfieldfail03.hs
new file mode 100644
index 0000000..1d5c8af
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_fail/hasfieldfail03.hs
@@ -0,0 +1,38 @@
+{-# LANGUAGE DataKinds, FlexibleInstances, MultiParamTypeClasses, TypeFamilies #-}
+
+import GHC.Records (HasField(..))
+
+data T = MkT { foo :: Int, bar :: Int }
+
+-- This is far too polymorphic
+instance HasField "woo" a Bool where
+ fromLabel = const True
+
+-- This conflicts with the built-in instance
+instance HasField "foo" T Int where
+ fromLabel = foo
+
+-- So does this
+instance HasField "bar" T Bool where
+ fromLabel = const True
+
+-- This doesn't conflict because there is no "baz" field in T
+instance HasField "baz" T Bool where
+ fromLabel = const True
+
+-- Bool has no fields, so this is okay
+instance HasField a Bool Bool where
+ fromLabel = id
+
+
+data family V a b c d
+data instance V x Int y [z] = MkVInt { baz :: (x, y, z, Bool) }
+
+-- Data families cannot have HasField instances, because they may get
+-- fields defined later on
+instance HasField "baz" (V a b c d) Bool where
+ fromLabel = const True
+
+-- Function types can have HasField instances, in case it's useful
+instance HasField "woo" (a -> b) Bool where
+ fromLabel = const True
diff --git a/testsuite/tests/overloadedrecflds/should_fail/hasfieldfail03.stderr b/testsuite/tests/overloadedrecflds/should_fail/hasfieldfail03.stderr
new file mode 100644
index 0000000..2fb8dbd
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_fail/hasfieldfail03.stderr
@@ -0,0 +1,21 @@
+
+hasfieldfail03.hs:8:10: error:
+ • Illegal instance declaration for ‘HasField "woo" a Bool’
+ Record data type must be specified
+ • In the instance declaration for ‘HasField "woo" a Bool’
+
+hasfieldfail03.hs:12:10: error:
+ • Illegal instance declaration for ‘HasField "foo" T Int’
+ T already has a field ‘foo’
+ • In the instance declaration for ‘HasField "foo" T Int’
+
+hasfieldfail03.hs:16:10: error:
+ • Illegal instance declaration for ‘HasField "bar" T Bool’
+ T already has a field ‘bar’
+ • In the instance declaration for ‘HasField "bar" T Bool’
+
+hasfieldfail03.hs:33:10: error:
+ • Illegal instance declaration for
+ ‘HasField "baz" (V a b c d) Bool’
+ Record data type may not be a data family
+ • In the instance declaration for ‘HasField "baz" (V a b c d) Bool’
More information about the ghc-commits
mailing list