Sjoerd Visscher pushed to branch wip/T18570 at Glasgow Haskell Compiler / GHC

Commits:

9 changed files:

Changes:

  • compiler/GHC/Core/DataCon.hs
    ... ... @@ -44,6 +44,7 @@ module GHC.Core.DataCon (
    44 44 
             dataConInstOrigArgTys, dataConRepArgTys, dataConResRepTyArgs,
    45 45 
             dataConInstUnivs,
    46 46 
             dataConFieldLabels, dataConFieldType, dataConFieldType_maybe,
    47 
    +        dataConOtherFieldsAllMultMany,
    47 48 
             dataConSrcBangs,
    48 49 
             dataConSourceArity, dataConRepArity,
    49 50 
             dataConIsInfix,
    ... ... @@ -1405,6 +1406,15 @@ dataConFieldType_maybe :: DataCon -> FieldLabelString
    1405 1406 
     dataConFieldType_maybe con label
    1406 1407 
       = find ((== label) . flLabel . fst) (dcFields con `zip` (scaledThing <$> dcOrigArgTys con))
    1407 1408
    1409 
    +-- | Check if all the fields of the 'DataCon' have multiplicity 'Many',
    1410 
    +-- except for the given labelled field. In this case the selector
    1411 
    +-- of the given field can be a linear function, since it is allowed
    1412 
    +-- to discard all the other fields.
    1413 
    +dataConOtherFieldsAllMultMany :: DataCon -> FieldLabelString -> Bool
    1414 
    +dataConOtherFieldsAllMultMany con label
    1415 
    +  = all (\(fld, mult) -> flLabel fld == label || isManyTy mult)
    1416 
    +      (dcFields con `zip` (scaledMult <$> dcOrigArgTys con))
    1417 
    +
    1408 1418 
     -- | Strictness/unpack annotations, from user; or, for imported
    1409 1419 
     -- DataCons, from the interface file
    1410 1420 
     -- The list is in one-to-one correspondence with the arity of the 'DataCon'

  • compiler/GHC/Tc/TyCl/PatSyn.hs
    ... ... @@ -725,7 +725,8 @@ tc_patsyn_finish lname dir is_infix lpat' prag_fn
    725 725
    726 726 
            -- Selectors
    727 727 
            ; has_sel <- xopt_FieldSelectors <$> getDynFlags
    728 
    -       ; let rn_rec_sel_binds = mkPatSynRecSelBinds patSyn (patSynFieldLabels patSyn) has_sel
    728 
    +      --  ; linearEnabled <- xoptM LangExt.LinearTypes
    729 
    +       ; let rn_rec_sel_binds = mkPatSynRecSelBinds True patSyn (patSynFieldLabels patSyn) has_sel
    729 730 
                  tything = AConLike (PatSynCon patSyn)
    730 731 
            ; tcg_env <- tcExtendGlobalEnv [tything] $
    731 732 
                         tcRecSelBinds rn_rec_sel_binds
    ... ... @@ -835,12 +836,13 @@ tcPatSynMatcher (L loc ps_name) lpat prag_fn
    835 836
    836 837 
            ; return ((matcher_name, matcher_sigma, is_unlifted), matcher_bind) }
    837 838
    838 
    -mkPatSynRecSelBinds :: PatSyn
    839 
    +mkPatSynRecSelBinds :: Bool
    840 
    +                    -> PatSyn
    839 841 
                         -> [FieldLabel]  -- ^ Visible field labels
    840 842 
                         -> FieldSelectors
    841 843 
                         -> [(Id, LHsBind GhcRn)]
    842 
    -mkPatSynRecSelBinds ps fields has_sel
    843 
    -  = [ mkOneRecordSelector [PatSynCon ps] (RecSelPatSyn ps) fld_lbl has_sel
    844 
    +mkPatSynRecSelBinds linearEnabled ps fields has_sel
    845 
    +  = [ mkOneRecordSelector linearEnabled [PatSynCon ps] (RecSelPatSyn ps) fld_lbl has_sel
    844 846 
         | fld_lbl <- fields ]
    845 847
    846 848 
     isUnidirectional :: HsPatSynDir a -> Bool

  • compiler/GHC/Tc/TyCl/Utils.hs
    ... ... @@ -32,7 +32,7 @@ import GHC.Tc.Utils.Env
    32 32 
     import GHC.Tc.Gen.Bind( tcValBinds )
    33 33 
     import GHC.Tc.Utils.TcType
    34 34
    35 
    -import GHC.Builtin.Types( unitTy )
    35 
    +import GHC.Builtin.Types( unitTy, manyDataConTy, multiplicityTy )
    36 36 
     import GHC.Builtin.Uniques ( mkBuiltinUnique )
    37 37
    38 38 
     import GHC.Hs
    ... ... @@ -71,6 +71,7 @@ import GHC.Types.Name.Env
    71 71 
     import GHC.Types.Name.Reader ( mkRdrUnqual )
    72 72 
     import GHC.Types.Id
    73 73 
     import GHC.Types.Id.Info
    74 
    +import GHC.Types.Var (mkTyVar)
    74 75 
     import GHC.Types.Var.Env
    75 76 
     import GHC.Types.Var.Set
    76 77 
     import GHC.Types.Unique.Set
    ... ... @@ -765,7 +766,8 @@ addTyConsToGblEnv tyclss
    765 766 
         do { traceTc "tcAddTyCons" $ vcat
    766 767 
                 [ text "tycons" <+> ppr tyclss
    767 768 
                 , text "implicits" <+> ppr implicit_things ]
    768 
    -       ; gbl_env <- tcRecSelBinds (mkRecSelBinds tyclss)
    769 
    +       ; linearEnabled <- xoptM LangExt.LinearTypes
    770 
    +       ; gbl_env <- tcRecSelBinds (mkRecSelBinds linearEnabled tyclss)
    769 771 
            ; th_bndrs <- tcTyThBinders implicit_things
    770 772 
            ; return (gbl_env, th_bndrs)
    771 773 
            }
    ... ... @@ -848,24 +850,24 @@ tcRecSelBinds sel_bind_prs
    848 850 
                                                  , let loc = getSrcSpan sel_id ]
    849 851 
         binds = [(NonRecursive, [bind]) | (_, bind) <- sel_bind_prs]
    850 852
    851 
    -mkRecSelBinds :: [TyCon] -> [(Id, LHsBind GhcRn)]
    853 
    +mkRecSelBinds :: Bool -> [TyCon] -> [(Id, LHsBind GhcRn)]
    852 854 
     -- NB We produce *un-typechecked* bindings, rather like 'deriving'
    853 855 
     --    This makes life easier, because the later type checking will add
    854 856 
     --    all necessary type abstractions and applications
    855 
    -mkRecSelBinds tycons
    856 
    -  = map mkRecSelBind [ (tc,fld) | tc <- tycons
    857 
    -                                , fld <- tyConFieldLabels tc ]
    857 
    +mkRecSelBinds linearEnabled tycons
    858 
    +  = [ mkRecSelBind linearEnabled tc fld | tc <- tycons
    859 
    +                                        , fld <- tyConFieldLabels tc ]
    858 860
    859 
    -mkRecSelBind :: (TyCon, FieldLabel) -> (Id, LHsBind GhcRn)
    860 
    -mkRecSelBind (tycon, fl)
    861 
    -  = mkOneRecordSelector all_cons (RecSelData tycon) fl
    861 
    +mkRecSelBind :: Bool -> TyCon -> FieldLabel -> (Id, LHsBind GhcRn)
    862 
    +mkRecSelBind linearEnabled tycon fl
    863 
    +  = mkOneRecordSelector linearEnabled all_cons (RecSelData tycon) fl
    862 864 
             FieldSelectors  -- See Note [NoFieldSelectors and naughty record selectors]
    863 865 
       where
    864 866 
         all_cons = map RealDataCon (tyConDataCons tycon)
    865 867
    866 
    -mkOneRecordSelector :: [ConLike] -> RecSelParent -> FieldLabel -> FieldSelectors
    868 
    +mkOneRecordSelector :: Bool -> [ConLike] -> RecSelParent -> FieldLabel -> FieldSelectors
    867 869 
                         -> (Id, LHsBind GhcRn)
    868 
    -mkOneRecordSelector all_cons idDetails fl has_sel
    870 
    +mkOneRecordSelector linearEnabled all_cons idDetails fl has_sel
    869 871 
       = (sel_id, L (noAnnSrcSpan loc) sel_bind)
    870 872 
       where
    871 873 
         loc      = getSrcSpan sel_name
    ... ... @@ -916,17 +918,23 @@ mkOneRecordSelector all_cons idDetails fl has_sel
    916 918 
                                                       -- thus suppressing making a binding
    917 919 
                                                       -- A slight hack!
    918 920
    921 
    +    all_other_fields_unrestricted = all all_other_unrestricted all_cons
    922 
    +      where
    923 
    +        all_other_unrestricted PatSynCon{} = False
    924 
    +        all_other_unrestricted (RealDataCon dc) = dataConOtherFieldsAllMultMany dc lbl
    925 
    +
    919 926 
         sel_ty | is_naughty = unitTy  -- See Note [Naughty record selectors]
    920 
    -           | otherwise  = mkForAllTys (tyVarSpecToBinders sel_tvbs) $
    927 
    +           | otherwise  = mkForAllTys (tyVarSpecToBinders (sel_tvbs ++ mult_tvb)) $
    921 928 
                               -- Urgh! See Note [The stupid context] in GHC.Core.DataCon
    922 
    -                          mkPhiTy (conLikeStupidTheta con1) $
    929 
    +                          mkPhiTy (conLikeStupidTheta con1)                       $
    923 930 
                               -- req_theta is empty for normal DataCon
    924 
    -                          mkPhiTy req_theta                 $
    925 
    -                          mkVisFunTyMany data_ty            $
    926 
    -                            -- Record selectors are always typed with Many. We
    927 
    -                            -- could improve on it in the case where all the
    928 
    -                            -- fields in all the constructor have multiplicity Many.
    931 
    +                          mkPhiTy req_theta                                       $
    932 
    +                          mkVisFunTy sel_mult data_ty                             $
    929 933 
                               field_ty
    934 
    +    (mult_tvb, sel_mult) = if linearEnabled && not_partial && all_other_fields_unrestricted
    935 
    +      then ([mkForAllTyBinder InferredSpec mult_var], mkTyVarTy mult_var)
    936 
    +      else ([], manyDataConTy)
    937 
    +    mult_var = mkTyVar (mkSysTvName (mkBuiltinUnique 1) (fsLit "m")) multiplicityTy
    930 938
    931 939 
         -- make the binding: sel (C2 { fld = x }) = x
    932 940 
         --                   sel (C7 { fld = x }) = x
    ... ... @@ -952,7 +960,7 @@ mkOneRecordSelector all_cons idDetails fl has_sel
    952 960 
         -- Add catch-all default case unless the case is exhaustive
    953 961 
         -- We do this explicitly so that we get a nice error message that
    954 962 
         -- mentions this particular record selector
    955 
    -    deflt | all dealt_with all_cons = []
    963 
    +    deflt | not_partial = []
    956 964 
               | otherwise = [mkSimpleMatch match_ctxt (wrapGenSpan [genWildPat])
    957 965 
                                 (genLHsApp
    958 966 
                                     (genHsVar (getName rEC_SEL_ERROR_ID))
    ... ... @@ -967,6 +975,7 @@ mkOneRecordSelector all_cons idDetails fl has_sel
    967 975 
             --              data instance T Int a where
    968 976 
             --                 A :: { fld :: Int } -> T Int Bool
    969 977 
             --                 B :: { fld :: Int } -> T Int Char
    978 
    +    not_partial = all dealt_with all_cons
    970 979 
         dealt_with :: ConLike -> Bool
    971 980 
         dealt_with (PatSynCon _) = False -- We can't predict overlap
    972 981 
         dealt_with con@(RealDataCon dc)

  • docs/users_guide/9.14.1-notes.rst
    ... ... @@ -78,6 +78,11 @@ Language
    78 78
    79 79 
       This causes the constructor to have type ``Rec :: Int %'Many -> Char %1 -> Record``.
    80 80
    81 
    +  Also record selector functions are now multiplicity-polymorphic when possible.
    82 
    +  In the above example the selector function ``y`` now has type
    83 
    +  ``y :: Record %m -> Char``, because the ``x`` field is allowed to be discarded.
    84 
    +  In particular this applies to the selector of a newtype wrapper.
    85 
    +
    81 86 
     Compiler
    82 87 
     ~~~~~~~~
    83 88

  • testsuite/tests/linear/should_compile/LinearRecordSelector.hs
    1 
    +{-# LANGUAGE LinearTypes, DataKinds, OverloadedRecordDot, RebindableSyntax #-}
    2 
    +module LinearRecordSelector where
    3 
    +
    4 
    +import GHC.Exts (Multiplicity(..))
    5 
    +import Prelude
    6 
    +
    7 
    +getField :: ()
    8 
    +getField = ()
    9 
    +
    10 
    +data Test = A { test :: Int, test2 %Many :: String } | B { test %Many :: Int, test3 %Many :: Char }
    11 
    +
    12 
    +test1 :: Test %1 -> Int
    13 
    +test1 a = test a
    14 
    +
    15 
    +testM :: Test -> Int
    16 
    +testM a = test a
    17 
    +
    18 
    +testX :: Test %m -> Int
    19 
    +testX = test
    20 
    +
    21 
    +newtype NT = NT { unNT :: Int }
    22 
    +
    23 
    +nt :: NT %m -> Int
    24 
    +nt a = unNT a
    25 
    +

  • testsuite/tests/linear/should_compile/all.T
    ... ... @@ -36,6 +36,7 @@ test('LinearTH3', normal, compile, [''])
    36 36 
     test('LinearTH4', req_th, compile, [''])
    37 37 
     test('LinearHole', normal, compile, [''])
    38 38 
     test('LinearDataConSections', normal, compile, [''])
    39 
    +test('LinearRecordSelector', normal, compile, ['-dcore-lint'])
    39 40 
     test('T18731', normal, compile, [''])
    40 41 
     test('T19400', unless(compiler_debugged(), skip), compile, [''])
    41 42 
     test('T20023', normal, compile, [''])

  • testsuite/tests/linear/should_fail/LinearRecordSelectorFail.hs
    1 
    +{-# LANGUAGE LinearTypes, DataKinds, OverloadedRecordDot, RebindableSyntax #-}
    2 
    +module LinearRecordSelector where
    3 
    +
    4 
    +import GHC.Exts (Multiplicity(..))
    5 
    +import Prelude
    6 
    +
    7 
    +getField :: ()
    8 
    +getField = ()
    9 
    +
    10 
    +data Test1 = A1 { testA11 :: Int, testA12 :: String }
    11 
    +
    12 
    +-- Fails because testA12 is linear
    13 
    +test1 :: Test1 %1 -> Int
    14 
    +test1 a = testA11 a
    15 
    +
    16 
    +data Test2 = A2 { testA2 :: Int } | B2 { testB2 %Many :: Char }
    17 
    +
    18 
    +-- Fails because testA2 is partial
    19 
    +test2 :: Test2 %1 -> Int
    20 
    +test2 a = testA2 a
    \ No newline at end of file

  • testsuite/tests/linear/should_fail/LinearRecordSelectorFail.stderr
    1 
    +LinearRecordSelectorFail.hs:14:7: error: [GHC-18872]
    2 
    +    • Couldn't match type ‘Many’ with ‘One’
    3 
    +        arising from multiplicity of ‘a’
    4 
    +    • In an equation for ‘test1’: test1 a = testA11 a
    5 
    +
    6 
    +LinearRecordSelectorFail.hs:20:7: error: [GHC-18872]
    7 
    +    • Couldn't match type ‘Many’ with ‘One’
    8 
    +        arising from multiplicity of ‘a’
    9 
    +    • In an equation for ‘test2’: test2 a = testA2 a
    10 
    +

  • testsuite/tests/linear/should_fail/all.T
    ... ... @@ -11,6 +11,7 @@ test('LinearNoExt', normal, compile_fail, [''])
    11 11 
     test('LinearNoExtU', normal, compile_fail, [''])
    12 12 
     test('LinearAsPat', normal, compile_fail, [''])
    13 13 
     test('LinearLazyPat', normal, compile_fail, [''])
    14 
    +test('LinearRecordSelectorFail', normal, compile_fail, [''])
    14 15 
     test('LinearRecordUpdate', normal, compile_fail, [''])
    15 16 
     test('LinearSeq', normal, compile_fail, [''])
    16 17 
     test('LinearViewPattern', normal, compile_fail, [''])

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help