diff options
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/ghc.mk | 2 | ||||
| -rw-r--r-- | compiler/hsSyn/HsTypes.hs | 28 | ||||
| -rw-r--r-- | compiler/parser/ApiAnnotation.hs | 3 | ||||
| -rw-r--r-- | compiler/parser/Parser.y | 25 | ||||
| -rw-r--r-- | compiler/parser/RdrHsSyn.hs | 12 |
5 files changed, 44 insertions, 26 deletions
diff --git a/compiler/ghc.mk b/compiler/ghc.mk index 09559019fc..7bb72c2f59 100644 --- a/compiler/ghc.mk +++ b/compiler/ghc.mk @@ -494,6 +494,7 @@ compiler_stage2_dll0_MODULES = \ CoreUnfold \ CoreUtils \ CostCentre \ + Ctype \ DataCon \ Demand \ Digraph \ @@ -532,6 +533,7 @@ compiler_stage2_dll0_MODULES = \ InstEnv \ Kind \ Lexeme \ + Lexer \ ListSetOps \ Literal \ Maybes \ diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs index a48210773a..cdb5efe534 100644 --- a/compiler/hsSyn/HsTypes.hs +++ b/compiler/hsSyn/HsTypes.hs @@ -38,6 +38,7 @@ module HsTypes ( mkExplicitHsForAllTy, mkImplicitHsForAllTy, mkQualifiedHsForAllTy, mkHsForAllTy, flattenTopLevelLHsForAllTy,flattenTopLevelHsForAllTy, + flattenHsForAllTyKeepAnns, hsExplicitTvs, hsTyVarName, mkHsWithBndrs, hsLKiTyVarNames, hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsLTyVarLocNames, @@ -67,6 +68,7 @@ import SrcLoc import StaticFlags import Outputable import FastString +import Lexer ( AddAnn, mkParensApiAnn ) import Maybes( isJust ) import Data.Data hiding ( Fixity ) @@ -606,24 +608,30 @@ flattenTopLevelLHsForAllTy (L l ty) = L l (flattenTopLevelHsForAllTy ty) flattenTopLevelHsForAllTy :: HsType name -> HsType name flattenTopLevelHsForAllTy (HsForAllTy exp extra tvs (L l []) ty) - = mk_forall_ty l exp extra tvs ty + = snd $ mk_forall_ty [] l exp extra tvs ty flattenTopLevelHsForAllTy ty = ty +flattenHsForAllTyKeepAnns :: HsType name -> ([AddAnn],HsType name) +flattenHsForAllTyKeepAnns (HsForAllTy exp extra tvs (L l []) ty) + = mk_forall_ty [] l exp extra tvs ty +flattenHsForAllTyKeepAnns ty = ([],ty) + -- mk_forall_ty makes a pure for-all type (no context) -mk_forall_ty :: SrcSpan -> HsExplicitFlag -> Maybe SrcSpan -> LHsTyVarBndrs name - -> LHsType name -> HsType name -mk_forall_ty _ exp1 extra1 tvs1 (L _ (HsForAllTy exp2 extra qtvs2 ctxt ty)) = - HsForAllTy (exp1 `plus` exp2) (mergeExtra extra1 extra) - (tvs1 `mappend` qtvs2) ctxt ty +mk_forall_ty :: [AddAnn] -> SrcSpan -> HsExplicitFlag -> Maybe SrcSpan + -> LHsTyVarBndrs name + -> LHsType name -> ([AddAnn],HsType name) +mk_forall_ty ann _ exp1 extra1 tvs1 (L _ (HsForAllTy exp2 extra qtvs2 ctxt ty)) + = (ann,HsForAllTy (exp1 `plus` exp2) (mergeExtra extra1 extra) + (tvs1 `mappend` qtvs2) ctxt ty) where -- Bias the merging of extra's to the top level, so that a single -- wildcard context will prevail mergeExtra (Just s) _ = Just s mergeExtra _ e = e -mk_forall_ty l exp extra tvs (L _ (HsParTy ty)) - = mk_forall_ty l exp extra tvs ty -mk_forall_ty l exp extra tvs ty - = HsForAllTy exp extra tvs (L l []) ty +mk_forall_ty ann l exp extra tvs (L lp (HsParTy ty)) + = mk_forall_ty (ann ++ mkParensApiAnn lp) l exp extra tvs ty +mk_forall_ty ann l exp extra tvs ty + = (ann,HsForAllTy exp extra tvs (L l []) ty) -- Even if tvs is empty, we still make a HsForAll! -- In the Implicit case, this signals the place to do implicit quantification -- In the Explicit case, it prevents implicit quantification diff --git a/compiler/parser/ApiAnnotation.hs b/compiler/parser/ApiAnnotation.hs index babd93a0ab..0c80ec7270 100644 --- a/compiler/parser/ApiAnnotation.hs +++ b/compiler/parser/ApiAnnotation.hs @@ -233,6 +233,8 @@ data AnnKeywordId | AnnOpen -- ^ '(\#' or '{-\# LANGUAGE' etc | AnnOpenC -- ^ '{' | AnnOpenP -- ^ '(' + | AnnOpenPE -- ^ '$(' + | AnnOpenPTE -- ^ '$$(' | AnnOpenS -- ^ '[' | AnnPackageName | AnnPattern @@ -248,6 +250,7 @@ data AnnKeywordId | AnnThen | AnnThIdSplice -- ^ '$' | AnnThIdTySplice -- ^ '$$' + | AnnThTyQuote -- ^ double ''' | AnnTilde -- ^ '~' | AnnTildehsh -- ^ '~#' | AnnType diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index 53a7b7c8d0..bc2bed8ad2 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -1459,7 +1459,7 @@ ctypedoc :: { LHsType RdrName } >> return (sLL $1 $> $ mkQualifiedHsForAllTy $1 $3) } | ipvar '::' type {% ams (sLL $1 $> (HsIParamTy (unLoc $1) $3)) - [mj AnnDcolon $2] } + [mj AnnVal $1,mj AnnDcolon $2] } | typedoc { $1 } ---------------------- @@ -1556,9 +1556,10 @@ atype :: { LHsType RdrName } [mop $1,mj AnnDcolon $3,mcp $5] } | quasiquote { sL1 $1 (HsQuasiQuoteTy (unLoc $1)) } | '$(' exp ')' {% ams (sLL $1 $> $ mkHsSpliceTy $2) - [mo $1,mc $3] } - | TH_ID_SPLICE { sLL $1 $> $ mkHsSpliceTy $ sL1 $1 $ HsVar $ - mkUnqual varName (getTH_ID_SPLICE $1) } + [mj AnnOpenPE $1,mj AnnCloseP $3] } + | TH_ID_SPLICE {%ams (sLL $1 $> $ mkHsSpliceTy $ sL1 $1 $ HsVar $ + mkUnqual varName (getTH_ID_SPLICE $1)) + [mj AnnThIdSplice $1] } -- see Note [Promotion] for the followings | SIMPLEQUOTE qcon_nowiredlist {% ams (sLL $1 $> $ HsTyVar $ unLoc $2) [mj AnnSimpleQuote $1,mj AnnName $2] } | SIMPLEQUOTE '(' ctype ',' comma_types1 ')' @@ -1731,9 +1732,9 @@ gadt_constrs :: { Located [LConDecl RdrName] } gadt_constr :: { LConDecl RdrName } -- Returns a list because of: C,D :: ty : con_list '::' sigtype - {% do { gadtDecl <- mkGadtDecl (unLoc $1) $3 + {% do { (anns,gadtDecl) <- mkGadtDecl (unLoc $1) $3 ; ams (sLL $1 $> $ gadtDecl) - [mj AnnDcolon $2] } } + (mj AnnDcolon $2:anns) } } -- Deprecated syntax for GADT record declarations | oqtycon '{' fielddecls '}' '::' sigtype @@ -2180,8 +2181,8 @@ aexp2 :: { LHsExpr RdrName } | SIMPLEQUOTE qvar {% ams (sLL $1 $> $ HsBracket (VarBr True (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] } | SIMPLEQUOTE qcon {% ams (sLL $1 $> $ HsBracket (VarBr True (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] } - | TH_TY_QUOTE tyvar {% ams (sLL $1 $> $ HsBracket (VarBr False (unLoc $2))) [mj AnnThIdSplice $1,mj AnnName $2] } - | TH_TY_QUOTE gtycon {% ams (sLL $1 $> $ HsBracket (VarBr False (unLoc $2))) [mj AnnThIdSplice $1,mj AnnName $2] } + | TH_TY_QUOTE tyvar {% ams (sLL $1 $> $ HsBracket (VarBr False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] } + | TH_TY_QUOTE gtycon {% ams (sLL $1 $> $ HsBracket (VarBr False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] } | '[|' exp '|]' {% ams (sLL $1 $> $ HsBracket (ExpBr $2)) [mo $1,mc $3] } | '[||' exp '||]' {% ams (sLL $1 $> $ HsBracket (TExpBr $2)) [mo $1,mc $3]} | '[t|' ctype '|]' {% checkNoPartialType @@ -2205,12 +2206,14 @@ splice_exp :: { LHsExpr RdrName } (sL1 $1 $ HsVar (mkUnqual varName (getTH_ID_SPLICE $1)))) [mj AnnThIdSplice $1] } - | '$(' exp ')' {% ams (sLL $1 $> $ mkHsSpliceE $2) [mo $1,mc $3] } + | '$(' exp ')' {% ams (sLL $1 $> $ mkHsSpliceE $2) + [mj AnnOpenPE $1,mj AnnCloseP $3] } | TH_ID_TY_SPLICE {% ams (sL1 $1 $ mkHsSpliceTE (sL1 $1 $ HsVar (mkUnqual varName (getTH_ID_TY_SPLICE $1)))) [mj AnnThIdTySplice $1] } - | '$$(' exp ')' {% ams (sLL $1 $> $ mkHsSpliceTE $2) [mo $1,mc $3] } + | '$$(' exp ')' {% ams (sLL $1 $> $ mkHsSpliceTE $2) + [mj AnnOpenPTE $1,mj AnnCloseP $3] } cmdargs :: { [LHsCmdTop RdrName] } : cmdargs acmd { $2 : $1 } @@ -2279,7 +2282,7 @@ commas_tup_tail : commas tup_tail then [L (last $ fst $1) missingTupArg] else $2 in (head $ fst $1 - ,(map (\l -> L l missingTupArg) (init $ fst $1)) ++ tt)) } } + ,(map (\l -> L l missingTupArg) (tail $ fst $1)) ++ tt)) } } -- Always follows a comma tup_tail :: { [LHsTupArg RdrName] } diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs index ed22808ab8..cc019d14bf 100644 --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -623,9 +623,12 @@ mkSimpleConDecl name qvars cxt details mkGadtDecl :: [Located RdrName] -> LHsType RdrName -- Always a HsForAllTy - -> P (ConDecl RdrName) -mkGadtDecl names (L l ty) - = mkGadtDecl' names (L l (flattenTopLevelHsForAllTy ty)) + -> P ([AddAnn], ConDecl RdrName) +mkGadtDecl names (L l ty) = do + let + (anns,ty') = flattenHsForAllTyKeepAnns ty + gadt <- mkGadtDecl' names (L l ty') + return (anns,gadt) mkGadtDecl' :: [Located RdrName] -> LHsType RdrName -- Always a HsForAllTy @@ -858,8 +861,7 @@ checkAPat msg loc e0 = do L _ (HsForAllTy Implicit _ _ (L _ []) ty) -> ty other -> other - return (SigPatIn e (mkHsWithBndrs - (L (getLoc t) (HsParTy t')))) + return (SigPatIn e (mkHsWithBndrs t')) -- n+k patterns OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _ |