Commit 24420385 authored by Adam Gundry's avatar Adam Gundry Committed by Ben Gamari

Fix interaction of DuplicateRecordFields and GHC.Generics

This prevents GHC.Generics from exposing mangled selector names
when used on a datatype defined with DuplicateRecordFields enabled.

Test Plan:
New test overloadedrecflds_generics, which tests that both
GHC.Generics and Data.Data use the correct field labels, not mangled
names.

Reviewers: kosmikus, simonpj, austin, bgamari

Reviewed By: bgamari

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D1486
parent a586622c
...@@ -737,7 +737,7 @@ mkBindsMetaD fix_env tycon = (dtBinds, allConBinds, allSelBinds) ...@@ -737,7 +737,7 @@ mkBindsMetaD fix_env tycon = (dtBinds, allConBinds, allSelBinds)
loc = srcLocSpan (getSrcLoc tycon) loc = srcLocSpan (getSrcLoc tycon)
mkStringLHS s = [mkSimpleHsAlt nlWildPat (nlHsLit (mkHsString s))] mkStringLHS s = [mkSimpleHsAlt nlWildPat (nlHsLit (mkHsString s))]
datacons = tyConDataCons tycon datacons = tyConDataCons tycon
datasels = map (map flSelector . dataConFieldLabels) datacons datasels = map dataConFieldLabels datacons
tyConName_user = case tyConFamInst_maybe tycon of tyConName_user = case tyConFamInst_maybe tycon of
Just (ptycon, _) -> tyConName ptycon Just (ptycon, _) -> tyConName ptycon
...@@ -756,7 +756,7 @@ mkBindsMetaD fix_env tycon = (dtBinds, allConBinds, allSelBinds) ...@@ -756,7 +756,7 @@ mkBindsMetaD fix_env tycon = (dtBinds, allConBinds, allSelBinds)
conFixity_matches c = [mkSimpleHsAlt nlWildPat (fixity c)] conFixity_matches c = [mkSimpleHsAlt nlWildPat (fixity c)]
conIsRecord_matches _ = [mkSimpleHsAlt nlWildPat (nlHsVar true_RDR)] conIsRecord_matches _ = [mkSimpleHsAlt nlWildPat (nlHsVar true_RDR)]
selName_matches s = mkStringLHS (occNameString (nameOccName s)) selName_matches fl = mkStringLHS (unpackFS (flLabel fl))
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
......
...@@ -8,6 +8,7 @@ test('overloadedrecfldsrun03', normal, compile_and_run, ['']) ...@@ -8,6 +8,7 @@ test('overloadedrecfldsrun03', normal, compile_and_run, [''])
test('overloadedrecfldsrun04', normal, compile_and_run, ['']) test('overloadedrecfldsrun04', normal, compile_and_run, [''])
test('overloadedrecfldsrun05', normal, compile_and_run, ['']) test('overloadedrecfldsrun05', normal, compile_and_run, [''])
test('overloadedrecfldsrun06', normal, compile_and_run, ['']) test('overloadedrecfldsrun06', normal, compile_and_run, [''])
test('overloadedrecflds_generics', normal, compile_and_run, [''])
test('overloadedlabelsrun01', normal, compile_and_run, ['']) test('overloadedlabelsrun01', normal, compile_and_run, [''])
test('overloadedlabelsrun02', normal, compile_and_run, ['']) test('overloadedlabelsrun02', normal, compile_and_run, [''])
test('overloadedlabelsrun03', normal, compile_and_run, ['']) test('overloadedlabelsrun03', normal, compile_and_run, [''])
......
-- 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))
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment