diff options
Diffstat (limited to 'compiler/parser/RdrHsSyn.lhs')
| -rw-r--r-- | compiler/parser/RdrHsSyn.lhs | 29 |
1 files changed, 28 insertions, 1 deletions
diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 0536286972..cd025a7384 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -16,7 +16,7 @@ module RdrHsSyn ( mkTySynonym, mkTyFamInstEqn, mkTyFamInst, mkFamDecl, - splitCon, splitPatSyn, mkInlinePragma, + splitCon, splitPatSyn, splitPatSynSig, mkInlinePragma, mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp mkTyLit, mkTyClD, mkInstD, @@ -431,6 +431,33 @@ splitPatSyn pat@(L loc (ConPatIn con details)) = do splitPatSyn pat@(L loc _) = parseErrorSDoc loc $ text "invalid pattern synonym declaration:" $$ ppr pat +-- Given two types like +-- Eq a => P a T b +-- and +-- Num b => R a b +-- +-- This returns +-- P as the name, +-- PrefixPatSyn [a, T, b] as the details, +-- R a b as the result type, +-- and (Eq a) and (Num b) as the provided and required thetas (respectively) +splitPatSynSig :: LHsType RdrName + -> LHsType RdrName + -> P (Located RdrName, HsPatSynDetails (LHsType RdrName), LHsType RdrName, LHsContext RdrName, LHsContext RdrName) +splitPatSynSig lty1 lty2 = do + (name, details) <- splitCon pat_ty + details' <- case details of + PrefixCon tys -> return $ PrefixPatSyn tys + InfixCon ty1 ty2 -> return $ InfixPatSyn ty1 ty2 + RecCon{} -> parseErrorSDoc (getLoc lty1) $ + text "record syntax not supported for pattern synonym declarations:" $$ ppr lty1 + return (name, details', res_ty, prov', req') + where + (_, prov, pat_ty) = splitLHsForAllTy lty1 + (_, req, res_ty) = splitLHsForAllTy lty2 + prov' = L (getLoc lty1) prov + req' = L (getLoc lty2) req + mkDeprecatedGadtRecordDecl :: SrcSpan -> Located RdrName -> [ConDeclField RdrName] |