Commit 1767ebd6 authored by cgibbard's avatar cgibbard Committed by Madeline Haraj

Implement type applications in patterns

The haddock submodule is also updated so that it understands the changes
to patterns.

Add documentation for type applications in patterns with an example

Disable Scopes test

Fix invalid scopes error

Add a bit more documentation and a few additional examples.

Remove ErrTypeAppInPat as it is no longer relevant.

Apply suggestion to docs/users_guide/exts/type_applications.rst

Apply suggestion to docs/users_guide/exts/type_applications.rst

Apply suggestion to docs/users_guide/exts/type_applications.rst

Apply suggestion to libraries/template-haskell/changelog.md

Add should-fail test for the case of a misplaced type application in a pattern.

Add comments/haddock for rnImplicitTvOccs and rnImplicitTvBndrs helping to contrast them.

Add a backwards-compatibility conP to Language.Haskell.TH.Lib

Implement toHie for Void with absurd.

Split Scopes test into working and expected-failing part.
parent fc644b1a
Pipeline #27536 canceled with stages
in 40 minutes and 23 seconds
......@@ -51,6 +51,7 @@ import GHC.Utils.Panic
import Data.Data hiding ( Fixity )
import Data.List hiding ( foldr )
import Data.Function
import Data.Void
{-
************************************************************************
......@@ -766,7 +767,7 @@ instance (OutputableBndrId l, OutputableBndrId r,
ppr_details = case details of
InfixCon v1 v2 -> hsep [ppr v1, pprInfixOcc psyn, ppr v2]
PrefixCon vs -> hsep (pprPrefixOcc psyn : map ppr vs)
PrefixCon _ vs -> hsep (pprPrefixOcc psyn : map ppr vs)
RecCon vs -> pprPrefixOcc psyn
<> braces (sep (punctuate comma (map ppr vs)))
......@@ -1229,7 +1230,9 @@ pprMinimalSig (L _ bf) = ppr (fmap unLoc bf)
-}
-- | Haskell Pattern Synonym Details
type HsPatSynDetails pass = HsConDetails (LIdP pass) [RecordPatSynField (LIdP pass)]
type HsPatSynDetails pass = HsConDetails Void (LIdP pass) [RecordPatSynField (LIdP pass)]
-- The Void argument to HsConDetails here is a reflection of the fact that
-- type applications are not allowed in declarations of pattern synonyms at present.
-- See Note [Record PatSyn Fields]
-- | Record Pattern Synonym Field
......
......@@ -128,6 +128,7 @@ import GHC.Unit.Module.Warnings
import GHC.Data.Bag
import GHC.Data.Maybe
import Data.Data hiding (TyCon,Fixity, Infix)
import Data.Void
{-
************************************************************************
......@@ -1617,7 +1618,9 @@ or contexts in two parts:
-- | The arguments in a Haskell98-style data constructor.
type HsConDeclH98Details pass
= HsConDetails (HsScaled pass (LBangType pass)) (XRec pass [LConDeclField pass])
= HsConDetails Void (HsScaled pass (LBangType pass)) (XRec pass [LConDeclField pass])
-- The Void argument to HsConDetails here is a reflection of the fact that
-- type applications are not allowed in data constructor declarations.
-- | The arguments in a GADT constructor. Unlike Haskell98-style constructors,
-- GADT constructors cannot be declared with infix syntax. As a result, we do
......@@ -1716,8 +1719,8 @@ pprConDecl (ConDeclH98 { con_name = L _ con
ppr_details (InfixCon t1 t2) = hsep [ppr (hsScaledThing t1),
pprInfixOcc con,
ppr (hsScaledThing t2)]
ppr_details (PrefixCon tys) = hsep (pprPrefixOcc con
: map (pprHsType . unLoc . hsScaledThing) tys)
ppr_details (PrefixCon _ tys) = hsep (pprPrefixOcc con
: map (pprHsType . unLoc . hsScaledThing) tys)
ppr_details (RecCon fields) = pprPrefixOcc con
<+> pprConDeclFields (unLoc fields)
cxt = fromMaybe noLHsContext mcxt
......
......@@ -317,10 +317,10 @@ type instance ConLikeP GhcTc = ConLike
-- | Haskell Constructor Pattern Details
type HsConPatDetails p = HsConDetails (LPat p) (HsRecFields p (LPat p))
type HsConPatDetails p = HsConDetails (HsPatSigType (NoGhcTc p)) (LPat p) (HsRecFields p (LPat p))
hsConPatArgs :: HsConPatDetails p -> [LPat p]
hsConPatArgs (PrefixCon ps) = ps
hsConPatArgs (PrefixCon _ ps) = ps
hsConPatArgs (RecCon fs) = map (hsRecFieldArg . unLoc) (rec_flds fs)
hsConPatArgs (InfixCon p1 p2) = [p1,p2]
......@@ -580,10 +580,10 @@ pprPat (ConPat { pat_con = con
}
)
= case ghcPass @p of
GhcPs -> pprUserCon (unLoc con) details
GhcRn -> pprUserCon (unLoc con) details
GhcPs -> regular
GhcRn -> regular
GhcTc -> sdocOption sdocPrintTypecheckerElaboration $ \case
False -> pprUserCon (unLoc con) details
False -> regular
True ->
-- Tiresome; in 'GHC.Tc.Gen.Bind.tcRhs' we print out a typechecked Pat in an
-- error message, and we want to make sure it prints nicely
......@@ -595,6 +595,9 @@ pprPat (ConPat { pat_con = con
, cpt_dicts = dicts
, cpt_binds = binds
} = ext
where
regular :: OutputableBndr (ConLikeP (GhcPass p)) => SDoc
regular = pprUserCon (unLoc con) details
pprPat (XPat ext) = case ghcPass @p of
#if __GLASGOW_HASKELL__ < 811
GhcPs -> noExtCon ext
......@@ -611,12 +614,14 @@ pprUserCon :: (OutputableBndr con, OutputableBndrId p)
pprUserCon c (InfixCon p1 p2) = ppr p1 <+> pprInfixOcc c <+> ppr p2
pprUserCon c details = pprPrefixOcc c <+> pprConArgs details
pprConArgs :: (OutputableBndrId p)
=> HsConPatDetails (GhcPass p) -> SDoc
pprConArgs (PrefixCon pats) = fsep (map (pprParendLPat appPrec) pats)
pprConArgs (InfixCon p1 p2) = sep [ pprParendLPat appPrec p1
, pprParendLPat appPrec p2 ]
pprConArgs (RecCon rpats) = ppr rpats
pprConArgs (PrefixCon ts pats) = fsep (pprTyArgs ts : map (pprParendLPat appPrec) pats)
where pprTyArgs tyargs = fsep (map (\ty -> char '@' <> ppr ty) tyargs)
pprConArgs (InfixCon p1 p2) = sep [ pprParendLPat appPrec p1
, pprParendLPat appPrec p2 ]
pprConArgs (RecCon rpats) = ppr rpats
instance (Outputable arg)
=> Outputable (HsRecFields p arg) where
......@@ -647,7 +652,7 @@ mkPrefixConPat :: DataCon ->
-- Make a vanilla Prefix constructor pattern
mkPrefixConPat dc pats tys
= noLoc $ ConPat { pat_con = noLoc (RealDataCon dc)
, pat_args = PrefixCon pats
, pat_args = PrefixCon [] pats
, pat_con_ext = ConPatTc
{ cpt_tvs = []
, cpt_dicts = []
......@@ -837,7 +842,7 @@ patNeedsParens p = go
go :: Pat (GhcPass p) -> Bool
go (NPlusKPat {}) = p > opPrec
go (SplicePat {}) = False
go (ConPat { pat_args = ds})
go (ConPat { pat_args = ds })
= conPatNeedsParens p ds
go (SigPat {}) = p >= sigPrec
go (ViewPat {}) = True
......@@ -867,12 +872,12 @@ patNeedsParens p = go
-- | @'conPatNeedsParens' p cp@ returns 'True' if the constructor patterns @cp@
-- needs parentheses under precedence @p@.
conPatNeedsParens :: PprPrec -> HsConDetails a b -> Bool
conPatNeedsParens :: PprPrec -> HsConDetails t a b -> Bool
conPatNeedsParens p = go
where
go (PrefixCon args) = p >= appPrec && not (null args)
go (InfixCon {}) = p >= opPrec
go (RecCon {}) = False
go (PrefixCon ts args) = p >= appPrec && (not (null args) || not (null ts))
go (InfixCon {}) = p >= opPrec -- type args should be empty in this case
go (RecCon {}) = False
-- | @'parenthesizePat' p pat@ checks if @'patNeedsParens' p pat@ is true, and
-- if so, surrounds @pat@ with a 'ParPat'. Otherwise, it simply returns @pat@.
......
......@@ -46,7 +46,7 @@ module GHC.Hs.Type (
ConDeclField(..), LConDeclField, pprConDeclFields,
HsConDetails(..),
HsConDetails(..), noTypeArgs,
FieldOcc(..), LFieldOcc, mkFieldOcc,
AmbiguousFieldOcc(..), mkAmbiguousFieldOcc,
......@@ -107,10 +107,11 @@ import GHC.Types.SrcLoc
import GHC.Utils.Outputable
import GHC.Data.FastString
import GHC.Utils.Misc ( count )
import GHC.Parser.Annotation
import Data.Data hiding ( Fixity, Prefix, Infix )
import Data.Maybe
import GHC.Parser.Annotation
import Data.Void
{-
************************************************************************
......@@ -501,11 +502,18 @@ data HsWildCardBndrs pass thing
}
| XHsWildCardBndrs !(XXHsWildCardBndrs pass thing)
type instance XHsWC GhcPs b = NoExtField
type instance XHsWC GhcRn b = [Name]
type instance XHsWC GhcTc b = [Name]
instance IsPass p => Functor (HsWildCardBndrs (GhcPass p)) where
fmap f (HsWC { hswc_ext = x, hswc_body = body })
= case ghcPass @p of
GhcPs -> HsWC { hswc_ext = x, hswc_body = f body }
GhcRn -> HsWC { hswc_ext = x, hswc_body = f body }
GhcTc -> HsWC { hswc_ext = x, hswc_body = f body }
type instance XXHsWildCardBndrs (GhcPass _) b = NoExtCon
type instance XHsWC GhcPs _ = NoExtField
type instance XHsWC GhcRn _ = [Name]
type instance XHsWC GhcTc _ = [Name]
type instance XXHsWildCardBndrs (GhcPass _) _ = NoExtCon
-- | Types that can appear in pattern signatures, as well as the signatures for
-- term-level binders in RULES.
......@@ -1333,17 +1341,21 @@ instance OutputableBndrId p
-- a separate data type entirely (see 'HsConDeclGADTDetails' in
-- "GHC.Hs.Decls"). This is because GADT constructors cannot be declared with
-- infix syntax, unlike the concepts above (#18844).
data HsConDetails arg rec
= PrefixCon [arg] -- C p1 p2 p3
data HsConDetails tyarg arg rec
= PrefixCon [tyarg] [arg] -- C @t1 @t2 p1 p2 p3
| RecCon rec -- C { x = p1, y = p2 }
| InfixCon arg arg -- p1 `C` p2
deriving Data
instance (Outputable arg, Outputable rec)
=> Outputable (HsConDetails arg rec) where
ppr (PrefixCon args) = text "PrefixCon" <+> ppr args
ppr (RecCon rec) = text "RecCon:" <+> ppr rec
ppr (InfixCon l r) = text "InfixCon:" <+> ppr [l, r]
-- | An empty list that can be used to indicate that there are no type arguments allowed in cases where HsConDetails is applied to Void.
noTypeArgs :: [Void]
noTypeArgs = []
instance (Outputable tyarg, Outputable arg, Outputable rec)
=> Outputable (HsConDetails tyarg arg rec) where
ppr (PrefixCon tyargs args) = text "PrefixCon:" <+> hsep (map (\t -> text "@" <> ppr t) tyargs) <+> ppr args
ppr (RecCon rec) = text "RecCon:" <+> ppr rec
ppr (InfixCon l r) = text "InfixCon:" <+> ppr [l, r]
{-
Note [ConDeclField passs]
......
......@@ -480,28 +480,28 @@ nlConPat :: RdrName -> [LPat GhcPs] -> LPat GhcPs
nlConPat con pats = noLoc $ ConPat
{ pat_con_ext = noExtField
, pat_con = noLoc con
, pat_args = PrefixCon (map (parenthesizePat appPrec) pats)
, pat_args = PrefixCon [] (map (parenthesizePat appPrec) pats)
}
nlConPatName :: Name -> [LPat GhcRn] -> LPat GhcRn
nlConPatName con pats = noLoc $ ConPat
{ pat_con_ext = noExtField
, pat_con = noLoc con
, pat_args = PrefixCon (map (parenthesizePat appPrec) pats)
, pat_args = PrefixCon [] (map (parenthesizePat appPrec) pats)
}
nlNullaryConPat :: RdrName -> LPat GhcPs
nlNullaryConPat con = noLoc $ ConPat
{ pat_con_ext = noExtField
, pat_con = noLoc con
, pat_args = PrefixCon []
, pat_args = PrefixCon [] []
}
nlWildConPat :: DataCon -> LPat GhcPs
nlWildConPat con = noLoc $ ConPat
{ pat_con_ext = noExtField
, pat_con = noLoc $ getRdrName con
, pat_args = PrefixCon $
, pat_args = PrefixCon [] $
replicate (dataConSourceArity con)
nlWildPat
}
......@@ -1396,7 +1396,7 @@ lPatImplicits = hs_lpat
hs_pat _ = []
details :: Located Name -> HsConPatDetails GhcRn -> [(SrcSpan, [Name])]
details _ (PrefixCon ps) = hs_lpats ps
details _ (PrefixCon _ ps) = hs_lpats ps
details n (RecCon fs) =
[(err_loc, collectPatsBinders implicit_pats) | Just{} <- [rec_dotdot fs] ]
++ hs_lpats explicit_pats
......
......@@ -220,7 +220,7 @@ conArgDocs (ConDeclGADT{con_g_args = args, con_res_ty = res_ty}) =
h98ConArgDocs :: HsConDeclH98Details GhcRn -> Map Int HsDocString
h98ConArgDocs con_args = case con_args of
PrefixCon args -> con_arg_docs 0 $ map (unLoc . hsScaledThing) args
PrefixCon _ args -> con_arg_docs 0 $ map (unLoc . hsScaledThing) args
InfixCon arg1 arg2 -> con_arg_docs 0 [ unLoc (hsScaledThing arg1)
, unLoc (hsScaledThing arg2) ]
RecCon _ -> M.empty
......
......@@ -822,7 +822,7 @@ dsExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields
req_wrap = dict_req_wrap <.> mkWpTyApps in_inst_tys
pat = noLoc $ ConPat { pat_con = noLoc con
, pat_args = PrefixCon $ map nlVarPat arg_ids
, pat_args = PrefixCon [] $ map nlVarPat arg_ids
, pat_con_ext = ConPatTc
{ cpt_tvs = ex_tvs
, cpt_dicts = eqs_vars ++ theta_vars
......
......@@ -573,9 +573,9 @@ push_bang_into_newtype_arg :: SrcSpan
-> HsConPatDetails GhcTc -> HsConPatDetails GhcTc
-- See Note [Bang patterns and newtypes]
-- We are transforming !(N p) into (N !p)
push_bang_into_newtype_arg l _ty (PrefixCon (arg:args))
push_bang_into_newtype_arg l _ty (PrefixCon ts (arg:args))
= ASSERT( null args)
PrefixCon [L l (BangPat noExtField arg)]
PrefixCon ts [L l (BangPat noExtField arg)]
push_bang_into_newtype_arg l _ty (RecCon rf)
| HsRecFields { rec_flds = L lf fld : flds } <- rf
, HsRecField { hsRecFieldArg = arg } <- fld
......@@ -584,7 +584,7 @@ push_bang_into_newtype_arg l _ty (RecCon rf)
= L l (BangPat noExtField arg) })] })
push_bang_into_newtype_arg l ty (RecCon rf) -- If a user writes !(T {})
| HsRecFields { rec_flds = [] } <- rf
= PrefixCon [L l (BangPat noExtField (noLoc (WildPat ty)))]
= PrefixCon [] [L l (BangPat noExtField (noLoc (WildPat ty)))]
push_bang_into_newtype_arg _ _ cd
= pprPanic "push_bang_into_newtype_arg" (pprConArgs cd)
......
......@@ -248,7 +248,7 @@ same_fields flds1 flds2
selectConMatchVars :: [Scaled Type] -> ConArgPats -> DsM [Id]
selectConMatchVars arg_tys con = case con of
(RecCon {}) -> newSysLocalsDsNoLP arg_tys
(PrefixCon ps) -> selectMatchVars (zipMults arg_tys ps)
(PrefixCon _ ps) -> selectMatchVars (zipMults arg_tys ps)
(InfixCon p1 p2) -> selectMatchVars (zipMults arg_tys [p1, p2])
where
zipMults = zipWithEqual "selectConMatchVar" (\a b -> (scaledMult a, unLoc b))
......@@ -258,7 +258,7 @@ conArgPats :: [Scaled Type]-- Instantiated argument types
-- are probably never looked at anyway
-> ConArgPats
-> [Pat GhcTc]
conArgPats _arg_tys (PrefixCon ps) = map unLoc ps
conArgPats _arg_tys (PrefixCon _ ps) = map unLoc ps
conArgPats _arg_tys (InfixCon p1 p2) = [unLoc p1, unLoc p2]
conArgPats arg_tys (RecCon (HsRecFields { rec_flds = rpats }))
| null rpats = map WildPat (map scaledThing arg_tys)
......
......@@ -255,7 +255,7 @@ desugarListPat x pats = do
desugarConPatOut :: Id -> ConLike -> [Type] -> [TyVar]
-> [EvVar] -> HsConPatDetails GhcTc -> DsM [PmGrd]
desugarConPatOut x con univ_tys ex_tvs dicts = \case
PrefixCon ps -> go_field_pats (zip [0..] ps)
PrefixCon _ ps -> go_field_pats (zip [0..] ps)
InfixCon p1 p2 -> go_field_pats (zip [0..] [p1,p2])
RecCon (HsRecFields fs _) -> go_field_pats (rec_field_ps fs)
where
......
......@@ -1884,7 +1884,7 @@ rep_bind (L loc (PatSynBind _ (PSB { psb_id = syn
-- their pattern-only bound right hand sides have different names,
-- we want to treat them the same in TH. This is the reason why we
-- need an adjusted mkGenArgSyms in the `RecCon` case below.
mkGenArgSyms (PrefixCon args) = mkGenSyms (map unLoc args)
mkGenArgSyms (PrefixCon _ args) = mkGenSyms (map unLoc args)
mkGenArgSyms (InfixCon arg1 arg2) = mkGenSyms [unLoc arg1, unLoc arg2]
mkGenArgSyms (RecCon fields)
= do { let pats = map (unLoc . recordPatSynPatVar) fields
......@@ -1910,7 +1910,7 @@ repPatSynD (MkC syn) (MkC args) (MkC dir) (MkC pat)
= rep2 patSynDName [syn, args, dir, pat]
repPatSynArgs :: HsPatSynDetails GhcRn -> MetaM (Core (M TH.PatSynArgs))
repPatSynArgs (PrefixCon args)
repPatSynArgs (PrefixCon _ args)
= do { args' <- repList nameTyConName lookupLOcc args
; repPrefixPatSynArgs args' }
repPatSynArgs (InfixCon arg1 arg2)
......@@ -2016,7 +2016,9 @@ repP (SumPat _ p alt arity) = do { p1 <- repLP p
repP (ConPat NoExtField dc details)
= do { con_str <- lookupLOcc dc
; case details of
PrefixCon ps -> do { qs <- repLPs ps; repPcon con_str qs }
PrefixCon tyargs ps -> do { qs <- repLPs ps
; ts <- repListM typeTyConName (repTy . unLoc . hsps_body) tyargs
; repPcon con_str ts qs }
RecCon rec -> do { fps <- repListM fieldPatTyConName rep_fld (rec_flds rec)
; repPrec con_str fps }
InfixCon p1 p2 -> do { p1' <- repLP p1;
......@@ -2028,7 +2030,6 @@ repP (ConPat NoExtField dc details)
rep_fld (L _ fld) = do { MkC v <- lookupLOcc (hsRecFieldSel fld)
; MkC p <- repLP (hsRecFieldArg fld)
; rep2 fieldPatName [v,p] }
repP (NPat _ (L _ l) Nothing _) = do { a <- repOverloadedLiteral l
; repPlit a }
repP (ViewPat _ e p) = do { e' <- repLE e; p' <- repLP p; repPview e' p' }
......@@ -2249,8 +2250,8 @@ repPunboxedSum (MkC p) alt arity
, mkIntExprInt platform alt
, mkIntExprInt platform arity ] }
repPcon :: Core TH.Name -> Core [(M TH.Pat)] -> MetaM (Core (M TH.Pat))
repPcon (MkC s) (MkC ps) = rep2 conPName [s, ps]
repPcon :: Core TH.Name -> Core [(M TH.Type)] -> Core [(M TH.Pat)] -> MetaM (Core (M TH.Pat))
repPcon (MkC s) (MkC ts) (MkC ps) = rep2 conPName [s, ts, ps]
repPrec :: Core TH.Name -> Core [M (TH.Name, TH.Pat)] -> MetaM (Core (M TH.Pat))
repPrec (MkC c) (MkC rps) = rep2 recPName [c,rps]
......@@ -2621,7 +2622,7 @@ repH98DataCon :: Located Name
repH98DataCon con details
= do con' <- lookupLOcc con -- See Note [Binders and occurrences]
case details of
PrefixCon ps -> do
PrefixCon _ ps -> do
arg_tys <- repPrefixConArgs ps
rep2 normalCName [unC con', unC arg_tys]
InfixCon st1 st2 -> do
......
......@@ -18,6 +18,8 @@
Main functions for .hie file generation
-}
#include "HsVersions.h"
module GHC.Iface.Ext.Ast ( mkHieFile, mkHieFileWithSource, getCompressedAsts, enrichHie) where
import GHC.Utils.Outputable(ppr)
......@@ -55,6 +57,7 @@ import GHC.Types.Var.Env
import GHC.Builtin.Uniques
import GHC.Iface.Make ( mkIfaceExports )
import GHC.Utils.Panic
import GHC.Utils.Misc
import GHC.Data.Maybe
import GHC.Data.FastString
......@@ -69,7 +72,7 @@ import qualified Data.ByteString as BS
import qualified Data.Map as M
import qualified Data.Set as S
import Data.Data ( Data, Typeable )
import Data.List ( foldl1' )
import Data.Void ( Void, absurd )
import Control.Monad ( forM_ )
import Control.Monad.Trans.State.Strict
import Control.Monad.Trans.Reader
......@@ -484,6 +487,18 @@ patScopes rsp useScope patScope xs =
map (\(RS sc a) -> PS rsp useScope sc a) $
listScopes patScope xs
-- | 'listScopes' specialised to 'HsPatSigType'
tScopes
:: Scope
-> Scope
-> [HsPatSigType (GhcPass a)]
-> [TScoped (HsPatSigType (GhcPass a))]
tScopes scope rhsScope xs =
map (\(RS sc a) -> TS (ResolvedScopes [scope, sc]) (unLoc a)) $
listScopes rhsScope (map (\hsps -> L (getLoc $ hsps_body hsps) hsps) xs)
-- We make the HsPatSigType into a Located one by using the location of the underlying LHsType.
-- We then strip off the redundant location information afterward, and take the union of the given scope and those to the right when forming the TS.
-- | 'listScopes' specialised to 'TVScoped' things
tvScopes
:: TyVarScope
......@@ -567,6 +582,9 @@ class ToHie a where
class HasType a where
getTypeNode :: a -> HieM [HieAST Type]
instance ToHie Void where
toHie v = absurd v
instance (ToHie a) => ToHie [a] where
toHie = concatMapM toHie
......@@ -855,7 +873,7 @@ instance HiePass p => ToHie (Located (PatSynBind (GhcPass p) (GhcPass p))) where
varScope = mkLScope var
patScope = mkScope $ getLoc pat
detScope = case dets of
(PrefixCon args) -> foldr combineScopes NoScope $ map mkLScope args
(PrefixCon _ args) -> foldr combineScopes NoScope $ map mkLScope args
(InfixCon a b) -> combineScopes (mkLScope a) (mkLScope b)
(RecCon r) -> foldr go NoScope r
go (RecordPatSynField a b) c = combineScopes c
......@@ -863,7 +881,7 @@ instance HiePass p => ToHie (Located (PatSynBind (GhcPass p) (GhcPass p))) where
detSpan = case detScope of
LocalScope a -> Just a
_ -> Nothing
toBind (PrefixCon args) = PrefixCon $ map (C Use) args
toBind (PrefixCon ts args) = ASSERT(null ts) PrefixCon ts $ map (C Use) args
toBind (InfixCon a b) = InfixCon (C Use a) (C Use b)
toBind (RecCon r) = RecCon $ map (PSC detSpan) r
......@@ -945,7 +963,7 @@ instance HiePass p => ToHie (PScoped (Located (Pat (GhcPass p)))) where
, toHie $ L ospan wrap
, toHie $ map (C (EvidenceVarBind EvPatternBind evscope rsp)
. L ospan) ev_vars
]
]
]
HieRn ->
[ toHie $ C Use con
......@@ -985,9 +1003,10 @@ instance HiePass p => ToHie (PScoped (Located (Pat (GhcPass p)))) where
HieRn -> []
#endif
where
contextify :: a ~ LPat (GhcPass p) => HsConDetails a (HsRecFields (GhcPass p) a)
-> HsConDetails (PScoped a) (RContext (HsRecFields (GhcPass p) (PScoped a)))
contextify (PrefixCon args) = PrefixCon $ patScopes rsp scope pscope args
contextify :: a ~ LPat (GhcPass p) => HsConDetails (HsPatSigType (NoGhcTc (GhcPass p))) a (HsRecFields (GhcPass p) a)
-> HsConDetails (TScoped (HsPatSigType (NoGhcTc (GhcPass p)))) (PScoped a) (RContext (HsRecFields (GhcPass p) (PScoped a)))
contextify (PrefixCon tyargs args) = PrefixCon (tScopes scope argscope tyargs) (patScopes rsp scope pscope args)
where argscope = foldr combineScopes NoScope $ map mkLScope args
contextify (InfixCon a b) = InfixCon a' b'
where [a', b'] = patScopes rsp scope pscope [a,b]
contextify (RecCon r) = RecCon $ RC RecFieldMatch $ contextify_rec r
......@@ -1303,8 +1322,8 @@ instance HiePass p => ToHie (RScoped (ApplicativeArg (GhcPass p))) where
, toHie $ PS Nothing sc NoScope pat
]
instance (ToHie arg, ToHie rec) => ToHie (HsConDetails arg rec) where
toHie (PrefixCon args) = toHie args
instance (ToHie tyarg, ToHie arg, ToHie rec) => ToHie (HsConDetails tyarg arg rec) where
toHie (PrefixCon tyargs args) = concatM [ toHie tyargs, toHie args ]
toHie (RecCon rec) = toHie rec
toHie (InfixCon a b) = concatM [ toHie a, toHie b]
......@@ -1554,9 +1573,9 @@ instance ToHie (Located (ConDecl GhcRn)) where
rhsScope = combineScopes ctxScope argsScope
ctxScope = maybe NoScope mkLScope ctx
argsScope = case dets of
PrefixCon xs -> scaled_args_scope xs
InfixCon a b -> scaled_args_scope [a, b]
RecCon x -> mkLScope x
PrefixCon _ xs -> scaled_args_scope xs
InfixCon a b -> scaled_args_scope [a, b]
RecCon x -> mkLScope x
where scaled_args_scope :: [HsScaled GhcRn (LHsType GhcRn)] -> Scope
scaled_args_scope = foldr combineScopes NoScope . map (mkLScope . hsScaledThing)
......
......@@ -1580,7 +1580,7 @@ pattern_synonym_decl :: { LHsDecl GhcPs }
}}
pattern_synonym_lhs :: { (Located RdrName, HsPatSynDetails GhcPs, [AddAnn]) }
: con vars0 { ($1, PrefixCon $2, []) }
: con vars0 { ($1, PrefixCon noTypeArgs $2, []) }
| varid conop varid { ($2, InfixCon $1 $3, []) }
| con '{' cvars1 '}' { ($1, RecCon $3, [moc $2, mcc $4] ) }
......
......@@ -175,9 +175,6 @@ data ErrorDesc
| ErrIfTheElseInPat
-- ^ If-then-else syntax in pattern
| ErrTypeAppInPat
-- ^ Type-application in pattern
| ErrLambdaCaseInPat
-- ^ Lambda-case in pattern
......@@ -393,6 +390,8 @@ data Hint
| SuggestLetInDo
| SuggestPatternSynonyms
| SuggestInfixBindMaybeAtPat !RdrName
| TypeApplicationsInPatternsOnlyDataCons -- ^ Type applications in patterns are only allowed on data constructors
data LexErrKind
= LexErrKind_EOF -- ^ End of input
......
......@@ -263,9 +263,6 @@ pp_err = \case
ErrIfTheElseInPat
-> text "(if ... then ... else ...)-syntax in pattern"
ErrTypeAppInPat
-> text "Type applications in patterns are not yet supported"
ErrLambdaCaseInPat
-> text "(\\case ...)-syntax in pattern"
......@@ -607,6 +604,7 @@ pp_hint = \case
$$ if opIsAt fun
then perhaps_as_pat
else empty
TypeApplicationsInPatternsOnlyDataCons -> text "Type applications in patterns are only allowed on data constructors."
perhaps_as_pat :: SDoc
perhaps_as_pat = text "Perhaps you meant an as-pattern, which must not be surrounded by whitespace"
......
......@@ -575,9 +575,9 @@ mkPatSynMatchGroup (L loc patsyn_name) (L _ decls) =
do { unless (name == patsyn_name) $
wrongNameBindingErr loc decl
; match <- case details of
PrefixCon pats -> return $ Match { m_ext = noExtField
, m_ctxt = ctxt, m_pats = pats
, m_grhss = rhs }
PrefixCon _ pats -> return $ Match { m_ext = noExtField
, m_ctxt = ctxt, m_pats = pats
, m_grhss = rhs }
where
ctxt = FunRhs { mc_fun = ln
, mc_fixity = Prefix
......@@ -966,27 +966,31 @@ checkPattern_hints :: [Hint] -> PV (Located (PatBuilder GhcPs)) -> P (LPat GhcPs
checkPattern_hints hints pp = runPV_hints hints (pp >>= checkLPat)
checkLPat :: Located (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat e@(L l _) = checkPat l e []
checkLPat e@(L l _) = checkPat l e [] []
checkPat :: SrcSpan -> Located (PatBuilder GhcPs) -> [LPat GhcPs]
checkPat :: SrcSpan -> Located (PatBuilder GhcPs) -> [HsPatSigType GhcPs] -> [LPat GhcPs]
-> PV (LPat GhcPs)
checkPat loc (L l e@(PatBuilderVar (L _ c))) args
checkPat loc (L l e@(PatBuilderVar (L _ c))) tyargs args
| isRdrDataCon c = return . L loc $ ConPat