diff options
4 files changed, 56 insertions, 2 deletions
diff --git a/compiler/typecheck/TcGenGenerics.hs b/compiler/typecheck/TcGenGenerics.hs index 9a1c506b33..acb39de9e1 100644 --- a/compiler/typecheck/TcGenGenerics.hs +++ b/compiler/typecheck/TcGenGenerics.hs @@ -737,7 +737,7 @@ mkBindsMetaD fix_env tycon = (dtBinds, allConBinds, allSelBinds) loc = srcLocSpan (getSrcLoc tycon) mkStringLHS s = [mkSimpleHsAlt nlWildPat (nlHsLit (mkHsString s))] datacons = tyConDataCons tycon - datasels = map (map flSelector . dataConFieldLabels) datacons + datasels = map dataConFieldLabels datacons tyConName_user = case tyConFamInst_maybe tycon of Just (ptycon, _) -> tyConName ptycon @@ -756,7 +756,7 @@ mkBindsMetaD fix_env tycon = (dtBinds, allConBinds, allSelBinds) conFixity_matches c = [mkSimpleHsAlt nlWildPat (fixity c)] conIsRecord_matches _ = [mkSimpleHsAlt nlWildPat (nlHsVar true_RDR)] - selName_matches s = mkStringLHS (occNameString (nameOccName s)) + selName_matches fl = mkStringLHS (unpackFS (flLabel fl)) -------------------------------------------------------------------------------- diff --git a/testsuite/tests/overloadedrecflds/should_run/all.T b/testsuite/tests/overloadedrecflds/should_run/all.T index 21391ac646..019a1efd99 100644 --- a/testsuite/tests/overloadedrecflds/should_run/all.T +++ b/testsuite/tests/overloadedrecflds/should_run/all.T @@ -8,6 +8,7 @@ test('overloadedrecfldsrun03', normal, compile_and_run, ['']) test('overloadedrecfldsrun04', normal, compile_and_run, ['']) test('overloadedrecfldsrun05', normal, compile_and_run, ['']) test('overloadedrecfldsrun06', normal, compile_and_run, ['']) +test('overloadedrecflds_generics', normal, compile_and_run, ['']) test('overloadedlabelsrun01', normal, compile_and_run, ['']) test('overloadedlabelsrun02', normal, compile_and_run, ['']) test('overloadedlabelsrun03', normal, compile_and_run, ['']) diff --git a/testsuite/tests/overloadedrecflds/should_run/overloadedrecflds_generics.hs b/testsuite/tests/overloadedrecflds/should_run/overloadedrecflds_generics.hs new file mode 100644 index 0000000000..987a24f9bc --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_run/overloadedrecflds_generics.hs @@ -0,0 +1,49 @@ +-- Test that DuplicateRecordFields doesn't affect the metadata +-- generated by GHC.Generics or Data.Data + +-- Based on a Stack Overflow post by bennofs +-- (http://stackoverflow.com/questions/24474581) +-- licensed under cc by-sa 3.0 + +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} + +import GHC.Generics +import Data.Data +import Data.Proxy + +type family FirstSelector (f :: * -> *) :: * +type instance FirstSelector (M1 D x f) = FirstSelector f +type instance FirstSelector (M1 C x f) = FirstSelector f +type instance FirstSelector (a :*: b) = FirstSelector a +type instance FirstSelector (M1 S s f) = s + +data SelectorProxy s (f :: * -> *) a = SelectorProxy +type SelectorProxy' s = SelectorProxy s Proxy () + +-- Extract the first selector name using GHC.Generics +firstSelectorName :: forall a. Selector (FirstSelector (Rep a)) + => Proxy a -> String +firstSelectorName _ = + selName (SelectorProxy :: SelectorProxy' (FirstSelector (Rep a))) + +-- Extract the list of selector names for a constructor using Data.Data +selectorNames :: Data a => a -> [String] +selectorNames = constrFields . toConstr + +data T = MkT { foo :: Int } deriving (Data, Generic) +data U = MkU { foo :: Int, bar :: Bool } deriving (Data, Generic) + +main = do -- This should yield "foo", not "$sel:foo:MkT" + print (firstSelectorName (Proxy :: Proxy T)) + -- Similarly this should yield "foo" + print (firstSelectorName (Proxy :: Proxy U)) + -- This should yield ["foo"] + print (selectorNames (MkT 3)) + -- And this should yield ["foo","bar"] + print (selectorNames (MkU 3 True)) diff --git a/testsuite/tests/overloadedrecflds/should_run/overloadedrecflds_generics.stdout b/testsuite/tests/overloadedrecflds/should_run/overloadedrecflds_generics.stdout new file mode 100644 index 0000000000..7212e4fb8c --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_run/overloadedrecflds_generics.stdout @@ -0,0 +1,4 @@ +"foo" +"foo" +["foo"] +["foo","bar"] |