Simon Peyton Jones pushed to branch wip/T27744 at Glasgow Haskell Compiler / GHC

Commits:

3 changed files:

Changes:

  • compiler/GHC/Tc/TyCl/PatSyn.hs
    ... ... @@ -875,8 +875,9 @@ tcPatSynMatcher (L loc ps_name) lpat prag_fn
    875 875 
                  mg = MG{ mg_alts = L (l2l $ getLoc match) [match]
    876 876 
                         , mg_ext = MatchGroupTc [] res_ty gen
    877 877 
                         }
    878 
    -             matcher_arity = length req_theta + 3
    879 
    -             -- See Note [Pragmas for pattern synonyms]
    878 
    +
    879 
    +             matcher_arity :: VisArity -- VisArity excludes dictionary arguments!
    880 
    +             matcher_arity = 3         -- See Note [Pragmas for pattern synonyms]
    880 881
    881 882 
            -- Add INLINE pragmas; see Note [Pragmas for pattern synonyms]
    882 883 
            -- NB: prag_fn is keyed by the PatSyn Name, not the (internal) matcher name
    ... ... @@ -967,9 +968,8 @@ tcPatSynBuilderBind prag_fn (PSB { psb_id = ps_lname@(L loc ps_name)
    967 968 
              let builder_id = mkExportedVanillaId builder_name builder_ty
    968 969 
                              -- See Note [Exported LocalIds] in GHC.Types.Id
    969 970
    970 
    -             (_, req_theta, _, prov_theta, arg_tys, _) = patSynSigBndr patsyn
    971 
    -             builder_arity = length req_theta + length prov_theta
    972 
    -                             + length arg_tys
    971 
    +             builder_arity :: VisArity   -- VisArity excludes dictionary arguments!
    972 
    +             builder_arity = length (patSynArgs patsyn)
    973 973 
                                  + (if need_dummy_arg then 1 else 0)
    974 974
    975 975 
            -- Add INLINE pragmas; see Note [Pragmas for pattern synonyms]
    ... ... @@ -1348,13 +1348,20 @@ entire pattern synonym is supported. For example:
    1348 1348 
     When no pragma is provided for a pattern, the inlining decision might change
    1349 1349 
     between different versions of GHC.
    1350 1350
    1351 
    -Implementation notes.  The prag_fn passed in to tcPatSynDecl will have a binding
    1352 
    -for the /pattern synonym/ Name, thus
    1353 
    -      InlinedPattern :-> INLINE
    1354 
    -From this we cook up an INLINE pragma for the matcher (in tcPatSynMatcher)
    1355 
    -and builder (in tcPatSynBuilderBind), by looking up the /pattern synonym/
    1356 
    -Name in the prag_fn, and then using addInlinePragArity to add the right
    1357 
    -inl_sat field to that INLINE pragma for the matcher or builder respectively.
    1351 
    +Implementation notes.
    1352 
    +
    1353 
    +* The prag_fn passed in to tcPatSynDecl will have a binding
    1354 
    +  for the /pattern synonym/ Name, thus
    1355 
    +        InlinedPattern :-> INLINE
    1356 
    +  From this we cook up an INLINE pragma for the matcher (in tcPatSynMatcher)
    1357 
    +  and builder (in tcPatSynBuilderBind), by looking up the /pattern synonym/
    1358 
    +  Name in the prag_fn, and then using `addInlinePragArity` to add the right
    1359 
    +  inl_sat field to that INLINE pragma for the matcher or builder respectively.
    1360 
    +
    1361 
    +* Note that the arity passed to `addInlinePragArity` is the `VisArity`, the /visible/
    1362 
    +  arity.  That specifically /excludes/ dictionary arguments, which are dealt with by
    1363 
    +  `addInlinePragArity`.   The builder and matcher have no Required type args, so we
    1364 
    +  don't need to worry about them in the `VisArity`.
    1358 1365 
      -}
    1359 1366
    1360 1367

  • testsuite/tests/patsyn/should_compile/T27744.hs
    1 
    +{-# LANGUAGE CPP #-}
    2 
    +
    3 
    +{-# LANGUAGE BangPatterns #-}
    4 
    +{-# LANGUAGE GADTs #-}
    5 
    +{-# LANGUAGE PolyKinds #-}
    6 
    +{-# LANGUAGE ScopedTypeVariables #-}
    7 
    +{-# LANGUAGE TypeOperators #-}
    8 
    +{-# LANGUAGE PatternSynonyms #-}
    9 
    +{-# LANGUAGE RoleAnnotations #-}
    10 
    +{-# LANGUAGE StandaloneKindSignatures #-}
    11 
    +{-# LANGUAGE ViewPatterns #-}
    12 
    +
    13 
    +-- | A facility for faking GADTs that work sufficiently similarly
    14 
    +-- to unary natural numbers.
    15 
    +module T27744
    16 
    +  ( Nattish (Zeroy, Succy)
    17 
    +  )
    18 
    +  where
    19 
    +import Unsafe.Coerce (unsafeCoerce)
    20 
    +import Data.Kind (Type)
    21 
    +
    22 
    +type Nattish :: forall k. k -> (k -> k) -> k -> Type
    23 
    +newtype Nattish zero succ n = Nattish Word
    24 
    +type role Nattish nominal nominal nominal
    25 
    +
    26 
    +data Res zero succ n where
    27 
    +  ResZero :: Res zero succ zero
    28 
    +  ResSucc :: !(Nattish zero succ n) -> Res zero succ (succ n)
    29 
    +
    30 
    +check :: Nattish zero succ n -> Res zero succ n
    31 
    +check (Nattish 0) = unsafeCoerce ResZero
    32 
    +check (Nattish n) = unsafeCoerce $ ResSucc (Nattish (n - 1))
    33 
    +
    34 
    +pattern Zeroy :: forall {k} zero succ (n :: k). () => n ~ zero => Nattish zero succ n
    35 
    +pattern Zeroy <- (check -> ResZero)
    36 
    +  where
    37 
    +    Zeroy = Nattish 0
    38 
    +{-# INLINE Zeroy #-}
    39 
    +
    40 
    +pattern Succy :: forall {k} zero succ (n :: k). () => forall (n' :: k). n ~ succ n' => Nattish zero succ n' -> Nattish zero succ n
    41 
    +pattern Succy n <- (check -> ResSucc n)
    42 
    +  where
    43 
    +    Succy (Nattish n) = Nattish (n + 1)
    44 
    +{-# INLINE Succy #-}
    45 
    +
    46 
    +{-# COMPLETE Zeroy, Succy #-}

  • testsuite/tests/patsyn/should_compile/all.T
    ... ... @@ -94,3 +94,4 @@ test('T26331a', normal, compile, [''])
    94 94 
     test('T27440a', normal, compile, [''])
    95 95 
     test('T27440b', normal, compile, [''])
    96 96 
     test('T27440c', normal, compile, [''])
    97 
    +test('T27744', normal, compile, [''])

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help Notification message regarding https://gitlab.haskell.org/ghc/ghc/-/commit/a583c921f39dfde1738fe3dd32bb5e886cde447c at 1787772968