Commit 40e77740 authored by cactus's avatar cactus

Add parser support for explicitly bidirectional pattern synonyms

parent 12644c3c
......@@ -441,15 +441,18 @@ ppr_monobind (PatSynBind{ patsyn_id = L _ psyn, patsyn_args = details,
patsyn_def = pat, patsyn_dir = dir })
= ppr_lhs <+> ppr_rhs
where
ppr_lhs = ptext (sLit "pattern") <+> ppr_details details
ppr_lhs = ptext (sLit "pattern") <+> ppr_details
ppr_simple syntax = syntax <+> ppr pat
ppr_details (InfixPatSyn v1 v2) = hsep [ppr v1, pprInfixOcc psyn, ppr v2]
ppr_details (PrefixPatSyn vs) = hsep (pprPrefixOcc psyn : map ppr vs)
(is_infix, ppr_details) = case details of
InfixPatSyn v1 v2 -> (True, hsep [ppr v1, pprInfixOcc psyn, ppr v2])
PrefixPatSyn vs -> (False, hsep (pprPrefixOcc psyn : map ppr vs))
ppr_rhs = case dir of
Unidirectional -> ppr_simple (ptext (sLit "<-"))
ImplicitBidirectional -> ppr_simple equals
Unidirectional -> ppr_simple (ptext (sLit "<-"))
ImplicitBidirectional -> ppr_simple equals
ExplicitBidirectional mg -> ppr_simple (ptext (sLit "<-")) <+> ptext (sLit "where") $$
(nest 2 $ pprFunBind psyn is_infix mg)
ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars
, abs_exports = exports, abs_binds = val_binds
......@@ -785,10 +788,9 @@ instance Traversable HsPatSynDetails where
traverse f (InfixPatSyn left right) = InfixPatSyn <$> f left <*> f right
traverse f (PrefixPatSyn args) = PrefixPatSyn <$> traverse f args
data HsPatSynDirLR idL idR
data HsPatSynDir id
= Unidirectional
| ImplicitBidirectional
| ExplicitBidirectional (MatchGroup id (LHsExpr id))
deriving (Data, Typeable)
type HsPatSynDir id = HsPatSynDirLR id id
\end{code}
......@@ -856,6 +856,16 @@ pattern_synonym_decl :: { LHsDecl RdrName }
{% do { (name, args) <- splitPatSyn $2
; return $ LL . ValD $ mkPatSynBind name args $4 Unidirectional
}}
| 'pattern' pat '<-' pat where_decls
{% do { (name, args) <- splitPatSyn $2
; mg <- toPatSynMatchGroup name $5
; return $ LL . ValD $
mkPatSynBind name args $4 (ExplicitBidirectional mg)
}}
where_decls :: { Located (OrdList (LHsDecl RdrName)) }
: 'where' '{' decls '}' { $3 }
| 'where' vocurly decls close { $3 }
vars0 :: { [Located RdrName] }
: {- empty -} { [] }
......
......@@ -16,7 +16,8 @@ module RdrHsSyn (
mkTySynonym, mkTyFamInstEqn,
mkTyFamInst,
mkFamDecl,
splitCon, splitPatSyn, mkInlinePragma,
splitCon, mkInlinePragma,
splitPatSyn, toPatSynMatchGroup,
mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
mkTyLit,
mkTyClD, mkInstD,
......@@ -435,18 +436,49 @@ splitPatSyn pat@(L loc (ConPatIn con details)) = do
details' <- case details of
PrefixCon pats -> liftM PrefixPatSyn (mapM patVar pats)
InfixCon pat1 pat2 -> liftM2 InfixPatSyn (patVar pat1) (patVar pat2)
RecCon{} -> parseErrorSDoc loc $
text "record syntax not supported for pattern synonym declarations:" $$ ppr pat
RecCon{} -> recordPatSynErr loc pat
return (con, details')
where
patVar :: LPat RdrName -> P (Located RdrName)
patVar (L loc (VarPat v)) = return $ L loc v
patVar (L _ (ParPat pat)) = patVar pat
patVar pat@(L loc _) = parseErrorSDoc loc $
text "Pattern synonym arguments must be variable names:" $$ ppr pat
patVar (L loc pat) = parseErrorSDoc loc $
text "Pattern synonym arguments must be variable names:" $$
ppr pat
splitPatSyn pat@(L loc _) = parseErrorSDoc loc $
text "invalid pattern synonym declaration:" $$ ppr pat
recordPatSynErr :: SrcSpan -> LPat RdrName -> P a
recordPatSynErr loc pat =
parseErrorSDoc loc $
text "record syntax not supported for pattern synonym declarations:" $$
ppr pat
toPatSynMatchGroup :: Located RdrName -> Located (OrdList (LHsDecl RdrName)) -> P (MatchGroup RdrName (LHsExpr RdrName))
toPatSynMatchGroup (L _ patsyn_name) (L _ decls) =
do { matches <- mapM fromDecl (fromOL decls)
; return $ mkMatchGroup FromSource matches }
where
fromDecl (L loc decl@(ValD (PatBind pat@(L _ (ConPatIn (L _ name) details)) rhs _ _ _))) =
do { unless (name == patsyn_name) $
wrongNameBindingErr loc decl
; match <- case details of
PrefixCon pats -> return $ Match pats Nothing rhs
InfixCon pat1 pat2 -> return $ Match [pat1, pat2] Nothing rhs
RecCon{} -> recordPatSynErr loc pat
; return $ L loc match }
fromDecl (L loc decl) = extraDeclErr loc decl
extraDeclErr loc decl =
parseErrorSDoc loc $
text "pattern synonym 'where' clause must contain a single binding:" $$
ppr decl
wrongNameBindingErr loc decl =
parseErrorSDoc loc $
text "pattern synonym 'where' clause must bind the pattern synonym's name" <+>
quotes (ppr patsyn_name) $$ ppr decl
mkDeprecatedGadtRecordDecl :: SrcSpan
-> Located RdrName
-> [ConDeclField RdrName]
......
......@@ -489,6 +489,9 @@ zonkPatSynDetails env = traverse (wrapLocM $ zonkIdBndr env)
zonkPatSynDir :: ZonkEnv -> HsPatSynDir TcId -> TcM (ZonkEnv, HsPatSynDir Id)
zonkPatSynDir env Unidirectional = return (env, Unidirectional)
zonkPatSynDir env ImplicitBidirectional = return (env, ImplicitBidirectional)
zonkPatSynDir env (ExplicitBidirectional mg) = do
mg' <- zonkMatchGroup env zonkLExpr mg
return (env, ExplicitBidirectional mg')
zonkSpecPrags :: ZonkEnv -> TcSpecPrags -> TcM TcSpecPrags
zonkSpecPrags _ IsDefaultMethod = return IsDefaultMethod
......
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