diff options
Diffstat (limited to 'compiler/parser')
| -rw-r--r-- | compiler/parser/Parser.y | 12 | ||||
| -rw-r--r-- | compiler/parser/RdrHsSyn.hs | 72 |
2 files changed, 31 insertions, 53 deletions
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index fb5c8dbd45..bbde989293 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -1895,10 +1895,9 @@ gadt_constr_with_doc gadt_constr :: { LConDecl RdrName } -- see Note [Difference in parsing GADT and data constructors] -- Returns a list because of: C,D :: ty - : con_list '::' ctype - {% do { let { (anns,gadtDecl) = mkGadtDecl (unLoc $1) $3 } - ; ams (sLL $1 $> gadtDecl) - (mu AnnDcolon $2:anns) } } + : con_list '::' sigtype + {% ams (sLL $1 $> (mkGadtDecl (unLoc $1) (mkLHsSigType $3))) + [mu AnnDcolon $2] } {- Note [Difference in parsing GADT and data constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1925,13 +1924,13 @@ constrs1 :: { Located [LConDecl RdrName] } constr :: { LConDecl RdrName } : maybe_docnext forall context '=>' constr_stuff maybe_docprev {% ams (let (con,details) = unLoc $5 in - addConDoc (L (comb4 $2 $3 $4 $5) (mkSimpleConDecl con + addConDoc (L (comb4 $2 $3 $4 $5) (mkConDeclH98 con (snd $ unLoc $2) $3 details)) ($1 `mplus` $6)) (mu AnnDarrow $4:(fst $ unLoc $2)) } | maybe_docnext forall constr_stuff maybe_docprev {% ams ( let (con,details) = unLoc $3 in - addConDoc (L (comb2 $2 $3) (mkSimpleConDecl con + addConDoc (L (comb2 $2 $3) (mkConDeclH98 con (snd $ unLoc $2) (noLoc []) details)) ($1 `mplus` $4)) (fst $ unLoc $2) } @@ -2671,7 +2670,6 @@ stmtlist :: { Located ([AddAnn],[LStmt RdrName (LHsExpr RdrName)]) } -- here, because we need too much lookahead if we see do { e ; } -- So we use BodyStmts throughout, and switch the last one over -- in ParseUtils.checkDo instead --- AZ: TODO check that we can retrieve multiple semis. stmts :: { Located ([AddAnn],[LStmt RdrName (LHsExpr RdrName)]) } : stmts ';' stmt {% if null (snd $ unLoc $1) diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs index 4b744fe69a..70be8e5d0e 100644 --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -35,7 +35,8 @@ module RdrHsSyn ( mkExport, mkExtName, -- RdrName -> CLabelString mkGadtDecl, -- [Located RdrName] -> LHsType RdrName -> ConDecl RdrName - mkSimpleConDecl, + gadtDeclDetails, + mkConDeclH98, mkATDefault, -- Bunch of functions in the parser monad for @@ -487,38 +488,30 @@ 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 -> Maybe [LHsTyVarBndr RdrName] +mkConDeclH98 :: Located RdrName -> Maybe [LHsTyVarBndr RdrName] -> LHsContext RdrName -> HsConDeclDetails RdrName -> ConDecl RdrName -mkSimpleConDecl name mb_forall cxt details - = ConDecl { con_names = [name] - , 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) +mkConDeclH98 name mb_forall cxt details + = ConDeclH98 { con_name = name + , con_qvars = fmap mkHsQTvs mb_forall + , con_cxt = Just cxt + -- AZ:TODO: when can cxt be Nothing? + -- remembering that () is a valid context. + , con_details = details + , con_doc = Nothing } mkGadtDecl :: [Located RdrName] - -> LHsType RdrName -- Always a HsForAllTy - -> ([AddAnn], ConDecl RdrName) -mkGadtDecl names ty = ([], mkGadtDecl' names ty) - -mkGadtDecl' :: [Located 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 lbody_ty@(L loc body_ty) - = mk_gadt_con names + -> LHsSigType RdrName -- Always a HsForAllTy + -> ConDecl RdrName +mkGadtDecl names ty = ConDeclGADT { con_names = names + , con_type = ty + , con_doc = Nothing } + +-- AZ:TODO: this probably belongs in a different module +gadtDeclDetails :: LHsSigType name + -> (HsConDeclDetails name,LHsType name,LHsContext name,[LHsTyVarBndr name]) +gadtDeclDetails (HsIB {hsib_body = lbody_ty}) = (details,res_ty,cxt,tvs) where (tvs, cxt, tau) = splitLHsSigmaTy lbody_ty (details, res_ty) -- See Note [Sorting out the result type] @@ -527,19 +520,6 @@ mkGadtDecl' names lbody_ty@(L loc body_ty) -> (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 = explicit - , con_qvars = mkHsQTvs tvs - , con_cxt = cxt - , con_details = details - , con_res = ResTyGADT loc res_ty - , con_doc = Nothing } - tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName) tyConToDataCon loc tc | isTcOcc (rdrNameOcc tc) @@ -639,19 +619,19 @@ really doesn't matter! -- | Note [Sorting out the result type] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- In a GADT declaration which is not a record, we put the whole constr --- type into the ResTyGADT for now; the renamer will unravel it once it --- has sorted out operator fixities. Consider for example +-- In a GADT declaration which is not a record, we put the whole constr type +-- into the res_ty for a ConDeclGADT for now; the renamer will unravel it once +-- it has sorted out operator fixities. Consider for example -- C :: a :*: b -> a :*: b -> a :+: b -- Initially this type will parse as -- a :*: (b -> (a :*: (b -> (a :+: b)))) - +-- -- so it's hard to split up the arguments until we've done the precedence -- resolution (in the renamer) On the other hand, for a record -- { x,y :: Int } -> a :*: b -- there is no doubt. AND we need to sort records out so that -- we can bring x,y into scope. So: --- * For PrefixCon we keep all the args in the ResTyGADT +-- * For PrefixCon we keep all the args in the res_ty -- * For RecCon we do not checkTyVarsP :: SDoc -> SDoc -> Located RdrName -> [LHsType RdrName] -> P (LHsQTyVars RdrName) |