summaryrefslogtreecommitdiff
path: root/compiler/parser/RdrHsSyn.hs
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/parser/RdrHsSyn.hs')
-rw-r--r--compiler/parser/RdrHsSyn.hs156
1 files changed, 83 insertions, 73 deletions
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index 7d14f6568d..4b744fe69a 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -16,7 +16,7 @@ module RdrHsSyn (
mkTyData, mkDataFamInst,
mkTySynonym, mkTyFamInstEqn,
mkTyFamInst,
- mkFamDecl,
+ mkFamDecl, mkLHsSigType,
splitCon, mkInlinePragma,
mkPatSynMatchGroup,
mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
@@ -48,7 +48,7 @@ module RdrHsSyn (
checkMonadComp, -- P (HsStmtContext RdrName)
checkCommand, -- LHsExpr RdrName -> P (LHsCmd RdrName)
checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
- checkValSig, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
+ checkValSigLhs,
checkDoAndIfThenElse,
checkRecordSyntax,
parseErrorSDoc,
@@ -140,11 +140,12 @@ mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls
; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
; tyvars <- checkTyVarsP (ptext (sLit "class")) whereDots cls tparams
; at_defs <- mapM (eitherToP . mkATDefault) at_insts
- ; return (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, tcdTyVars = tyvars,
- tcdFDs = snd (unLoc fds), tcdSigs = sigs,
- tcdMeths = binds,
- tcdATs = ats, tcdATDefs = at_defs, tcdDocs = docs,
- tcdFVs = placeHolderNames })) }
+ ; return (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, tcdTyVars = tyvars
+ , tcdFDs = snd (unLoc fds)
+ , tcdSigs = mkClassOpSigs sigs
+ , tcdMeths = binds
+ , tcdATs = ats, tcdATDefs = at_defs, tcdDocs = docs
+ , tcdFVs = placeHolderNames })) }
mkATDefault :: LTyFamInstDecl RdrName
-> Either (SrcSpan, SDoc) (LTyFamDefltEqn RdrName)
@@ -156,7 +157,7 @@ mkATDefault :: LTyFamInstDecl RdrName
-- from Convert.hs
mkATDefault (L loc (TyFamInstDecl { tfid_eqn = L _ e }))
| TyFamEqn { tfe_tycon = tc, tfe_pats = pats, tfe_rhs = rhs } <- e
- = do { tvs <- checkTyVars (ptext (sLit "default")) equalsDots tc (hswb_cts pats)
+ = do { tvs <- checkTyVars (ptext (sLit "default")) equalsDots tc (hsib_body pats)
; return (L loc (TyFamEqn { tfe_tycon = tc
, tfe_pats = tvs
, tfe_rhs = rhs })) }
@@ -167,7 +168,7 @@ mkTyData :: SrcSpan
-> Located (Maybe (LHsContext RdrName), LHsType RdrName)
-> Maybe (LHsKind RdrName)
-> [LConDecl RdrName]
- -> Maybe (Located [LHsType RdrName])
+ -> HsDeriving RdrName
-> P (LTyClDecl RdrName)
mkTyData loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv
= do { (tc, tparams,ann) <- checkTyClHdr False tycl_hdr
@@ -183,7 +184,7 @@ mkDataDefn :: NewOrData
-> Maybe (LHsContext RdrName)
-> Maybe (LHsKind RdrName)
-> [LConDecl RdrName]
- -> Maybe (Located [LHsType RdrName])
+ -> HsDeriving RdrName
-> P (HsDataDefn RdrName)
mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
= do { checkDatatypeContext mcxt
@@ -212,7 +213,7 @@ mkTyFamInstEqn :: LHsType RdrName
mkTyFamInstEqn lhs rhs
= do { (tc, tparams, ann) <- checkTyClHdr False lhs
; return (TyFamEqn { tfe_tycon = tc
- , tfe_pats = mkHsWithBndrs tparams
+ , tfe_pats = mkHsImplicitBndrs tparams
, tfe_rhs = rhs },
ann) }
@@ -222,7 +223,7 @@ mkDataFamInst :: SrcSpan
-> Located (Maybe (LHsContext RdrName), LHsType RdrName)
-> Maybe (LHsKind RdrName)
-> [LConDecl RdrName]
- -> Maybe (Located [LHsType RdrName])
+ -> HsDeriving RdrName
-> P (LInstDecl RdrName)
mkDataFamInst loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv
= do { (tc, tparams,ann) <- checkTyClHdr False tycl_hdr
@@ -230,7 +231,7 @@ mkDataFamInst loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_
; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
; return (L loc (DataFamInstD (
DataFamInstDecl { dfid_tycon = tc
- , dfid_pats = mkHsWithBndrs tparams
+ , dfid_pats = mkHsImplicitBndrs tparams
, dfid_defn = defn, dfid_fvs = placeHolderNames }))) }
mkTyFamInst :: SrcSpan
@@ -486,52 +487,58 @@ mkPatSynMatchGroup (L _ patsyn_name) (L _ decls) =
text "pattern synonym 'where' clause must bind the pattern synonym's name" <+>
quotes (ppr patsyn_name) $$ ppr decl
-mkSimpleConDecl :: Located RdrName -> [LHsTyVarBndr RdrName]
+mkSimpleConDecl :: Located RdrName -> Maybe [LHsTyVarBndr RdrName]
-> LHsContext RdrName -> HsConDeclDetails RdrName
-> ConDecl RdrName
-mkSimpleConDecl name qvars cxt details
+mkSimpleConDecl name mb_forall cxt details
= ConDecl { con_names = [name]
- , con_explicit = Explicit
- , con_qvars = mkHsQTvs qvars
+ , con_explicit = explicit
+ , con_qvars = qvars
, con_cxt = cxt
, con_details = details
, con_res = ResTyH98
, con_doc = Nothing }
+ where
+ (explicit, qvars) = case mb_forall of
+ Nothing -> (False, mkHsQTvs [])
+ Just tvs -> (True, mkHsQTvs tvs)
mkGadtDecl :: [Located RdrName]
-> LHsType RdrName -- Always a HsForAllTy
-> ([AddAnn], ConDecl RdrName)
-mkGadtDecl names (L l ty) =
- let (anns, ty') = flattenHsForAllTyKeepAnns ty
- gadt = mkGadtDecl' names (L l ty')
- in (anns, gadt)
+mkGadtDecl names ty = ([], mkGadtDecl' names ty)
mkGadtDecl' :: [Located RdrName]
- -> LHsType RdrName -- Always a HsForAllTy
- -> (ConDecl RdrName)
+ -> LHsType RdrName
+ -> ConDecl RdrName
-- We allow C,D :: ty
-- and expand it as if it had been
-- C :: ty; D :: ty
-- (Just like type signatures in general.)
-mkGadtDecl' names (L ls (HsForAllTy imp _ qvars cxt tau))
+
+mkGadtDecl' names lbody_ty@(L loc body_ty)
= mk_gadt_con names
where
+ (tvs, cxt, tau) = splitLHsSigmaTy lbody_ty
(details, res_ty) -- See Note [Sorting out the result type]
= case tau of
L _ (HsFunTy (L l (HsRecTy flds)) res_ty)
- -> (RecCon (L l flds), res_ty)
- _other -> (PrefixCon [], tau)
+ -> (RecCon (L l flds), res_ty)
+ _other -> (PrefixCon [], tau)
+
+ explicit = case body_ty of
+ HsForAllTy {} -> True
+ _ -> False
mk_gadt_con names
= ConDecl { con_names = names
- , con_explicit = imp
- , con_qvars = qvars
+ , con_explicit = explicit
+ , con_qvars = mkHsQTvs tvs
, con_cxt = cxt
, con_details = details
- , con_res = ResTyGADT ls res_ty
+ , con_res = ResTyGADT loc res_ty
, con_doc = Nothing }
-mkGadtDecl' _ other_ty = pprPanic "mkGadtDecl" (ppr other_ty)
tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
tyConToDataCon loc tc
@@ -647,7 +654,7 @@ really doesn't matter!
-- * For PrefixCon we keep all the args in the ResTyGADT
-- * For RecCon we do not
-checkTyVarsP :: SDoc -> SDoc -> Located RdrName -> [LHsType RdrName] -> P (LHsTyVarBndrs RdrName)
+checkTyVarsP :: SDoc -> SDoc -> Located RdrName -> [LHsType RdrName] -> P (LHsQTyVars RdrName)
-- Same as checkTyVars, but in the P monad
checkTyVarsP pp_what equals_or_where tc tparms
= eitherToP $ checkTyVars pp_what equals_or_where tc tparms
@@ -657,7 +664,7 @@ eitherToP :: Either (SrcSpan, SDoc) a -> P a
eitherToP (Left (loc, doc)) = parseErrorSDoc loc doc
eitherToP (Right thing) = return thing
checkTyVars :: SDoc -> SDoc -> Located RdrName -> [LHsType RdrName]
- -> Either (SrcSpan, SDoc) (LHsTyVarBndrs RdrName)
+ -> Either (SrcSpan, SDoc) (LHsQTyVars RdrName)
-- Check whether the given list of type parameters are all type variables
-- (possibly with a kind signature)
-- We use the Either monad because it's also called (via mkATDefault) from
@@ -815,15 +822,8 @@ checkAPat msg loc e0 = do
-- view pattern is well-formed if the pattern is
EViewPat expr patE -> checkLPat msg patE >>=
(return . (\p -> ViewPat expr p placeHolderType))
- ExprWithTySig e t _ -> do e <- checkLPat msg e
- -- Pattern signatures are parsed as sigtypes,
- -- but they aren't explicit forall points. Hence
- -- we have to remove the implicit forall here.
- let t' = case t of
- L _ (HsForAllTy Implicit _ _
- (L _ []) ty) -> ty
- other -> other
- return (SigPatIn e (mkHsWithBndrs t'))
+ ExprWithTySig e t -> do e <- checkLPat msg e
+ return (SigPatIn e t)
-- n+k patterns
OpApp (L nloc (HsVar (L _ n))) (L _ (HsVar (L _ plus))) _
@@ -890,14 +890,14 @@ checkValDef :: SDoc
checkValDef msg lhs (Just sig) grhss
-- x :: ty = rhs parses as a *pattern* binding
= checkPatBind msg (L (combineLocs lhs sig)
- (ExprWithTySig lhs sig PlaceHolder)) grhss
+ (ExprWithTySig lhs (mkLHsSigWcType sig))) grhss
checkValDef msg lhs opt_sig g@(L l (_,grhss))
= do { mb_fun <- isFunLhs lhs
; case mb_fun of
Just (fun, is_infix, pats, ann) ->
checkFunBind msg ann (getLoc lhs)
- fun is_infix pats opt_sig (L l grhss)
+ fun is_infix pats opt_sig (L l grhss)
Nothing -> checkPatBind msg lhs g }
checkFunBind :: SDoc
@@ -914,9 +914,11 @@ checkFunBind msg ann lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
let match_span = combineSrcSpans lhs_loc rhs_span
-- Add back the annotations stripped from any HsPar values in the lhs
-- mapM_ (\a -> a match_span) ann
- return (ann,makeFunBind fun
- [L match_span (Match (FunBindMatch fun is_infix)
- ps opt_sig grhss)])
+ return (ann, makeFunBind fun
+ [L match_span (Match { m_fixity = FunBindMatch fun is_infix
+ , m_pats = ps
+ , m_type = opt_sig
+ , m_grhss = grhss })])
-- The span of the match covers the entire equation.
-- That isn't quite right, but it'll do for now.
@@ -939,26 +941,26 @@ checkPatBind msg lhs (L _ (_,grhss))
; return ([],PatBind lhs grhss placeHolderType placeHolderNames
([],[])) }
-checkValSig
- :: LHsExpr RdrName
- -> LHsType RdrName
- -> P (Sig RdrName)
-checkValSig (L l (HsVar (L _ v))) ty
- | isUnqual v && not (isDataOcc (rdrNameOcc v))
- = return (TypeSig [L l v] ty PlaceHolder)
-checkValSig lhs@(L l _) ty
+checkValSigLhs :: LHsExpr RdrName -> P (Located RdrName)
+checkValSigLhs (L _ (HsVar lrdr@(L _ v)))
+ | isUnqual v
+ , not (isDataOcc (rdrNameOcc v))
+ = return lrdr
+
+checkValSigLhs lhs@(L l _)
= parseErrorSDoc l ((text "Invalid type signature:" <+>
- ppr lhs <+> text "::" <+> ppr ty)
- $$ text hint)
+ ppr lhs <+> text ":: ...")
+ $$ text hint)
where
- hint | foreign_RDR `looks_like` lhs =
- "Perhaps you meant to use ForeignFunctionInterface?"
- | default_RDR `looks_like` lhs =
- "Perhaps you meant to use DefaultSignatures?"
- | pattern_RDR `looks_like` lhs =
- "Perhaps you meant to use PatternSynonyms?"
- | otherwise =
- "Should be of form <variable> :: <type>"
+ hint | foreign_RDR `looks_like` lhs
+ = "Perhaps you meant to use ForeignFunctionInterface?"
+ | default_RDR `looks_like` lhs
+ = "Perhaps you meant to use DefaultSignatures?"
+ | pattern_RDR `looks_like` lhs
+ = "Perhaps you meant to use PatternSynonyms?"
+ | otherwise
+ = "Should be of form <variable> :: <type>"
+
-- A common error is to forget the ForeignFunctionInterface flag
-- so check for that, and suggest. cf Trac #3805
-- Sadly 'foreign import' still barfs 'parse error' because 'import' is a keyword
@@ -1242,24 +1244,30 @@ mkInlinePragma src (inl, match_info) mb_act
--
mkImport :: Located CCallConv
-> Located Safety
- -> (Located StringLiteral, Located RdrName, LHsType RdrName)
+ -> (Located StringLiteral, Located RdrName, LHsSigType RdrName)
-> P (HsDecl RdrName)
mkImport (L lc cconv) (L ls safety) (L loc (StringLiteral esrc entity), v, ty)
| cconv == PrimCallConv = do
let funcTarget = CFunction (StaticTarget esrc entity Nothing True)
importSpec = CImport (L lc PrimCallConv) (L ls safety) Nothing funcTarget
(L loc (unpackFS entity))
- return (ForD (ForeignImport v ty noForeignImportCoercionYet importSpec))
+ return (ForD (ForeignImport { fd_name = v, fd_sig_ty = ty
+ , fd_co = noForeignImportCoercionYet
+ , fd_fi = importSpec }))
| cconv == JavaScriptCallConv = do
let funcTarget = CFunction (StaticTarget esrc entity Nothing True)
importSpec = CImport (L lc JavaScriptCallConv) (L ls safety) Nothing
funcTarget (L loc (unpackFS entity))
- return (ForD (ForeignImport v ty noForeignImportCoercionYet importSpec))
+ return (ForD (ForeignImport { fd_name = v, fd_sig_ty = ty
+ , fd_co = noForeignImportCoercionYet
+ , fd_fi = importSpec }))
| otherwise = do
case parseCImport (L lc cconv) (L ls safety) (mkExtName (unLoc v))
(unpackFS entity) (L loc (unpackFS entity)) of
Nothing -> parseErrorSDoc loc (text "Malformed entity string")
- Just importSpec -> return (ForD (ForeignImport v ty noForeignImportCoercionYet importSpec))
+ Just importSpec -> return (ForD (ForeignImport { fd_name = v, fd_sig_ty = ty
+ , fd_co = noForeignImportCoercionYet
+ , fd_fi = importSpec }))
-- the string "foo" is ambigous: either a header or a C identifier. The
-- C identifier case comes first in the alternatives below, so we pick
@@ -1321,12 +1329,14 @@ parseCImport cconv safety nm str sourceText =
-- construct a foreign export declaration
--
mkExport :: Located CCallConv
- -> (Located StringLiteral, Located RdrName, LHsType RdrName)
+ -> (Located StringLiteral, Located RdrName, LHsSigType RdrName)
-> P (HsDecl RdrName)
-mkExport (L lc cconv) (L le (StringLiteral esrc entity), v, ty) = do
- return $ ForD (ForeignExport v ty noForeignExportCoercionYet
- (CExport (L lc (CExportStatic esrc entity' cconv))
- (L le (unpackFS entity))))
+mkExport (L lc cconv) (L le (StringLiteral esrc entity), v, ty)
+ = return $ ForD $
+ ForeignExport { fd_name = v, fd_sig_ty = ty
+ , fd_co = noForeignExportCoercionYet
+ , fd_fe = CExport (L lc (CExportStatic esrc entity' cconv))
+ (L le (unpackFS entity)) }
where
entity' | nullFS entity = mkExtName (unLoc v)
| otherwise = entity
View Lorry Controller Status