diff options
Diffstat (limited to 'compiler/parser')
| -rw-r--r-- | compiler/parser/Parser.y | 14 | ||||
| -rw-r--r-- | compiler/parser/RdrHsSyn.hs | 25 |
2 files changed, 39 insertions, 0 deletions
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index 276fcb1c5b..f32ce4a5e0 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -1049,6 +1049,7 @@ topdecls_semi :: { OrdList (LHsDecl GhcPs) } topdecl :: { LHsDecl GhcPs } : cl_decl { sL1 $1 (TyClD noExtField (unLoc $1)) } | ty_decl { sL1 $1 (TyClD noExtField (unLoc $1)) } + | standalone_kind_sig { sL1 $1 (KindSigD noExtField (unLoc $1)) } | inst_decl { sL1 $1 (InstD noExtField (unLoc $1)) } | stand_alone_deriving { sLL $1 $> (DerivD noExtField (unLoc $1)) } | role_annot { sL1 $1 (RoleAnnotD noExtField (unLoc $1)) } @@ -1131,6 +1132,19 @@ ty_decl :: { LTyClDecl GhcPs } (snd $ unLoc $4) Nothing) (mj AnnData $1:mj AnnFamily $2:(fst $ unLoc $4)) } +-- standalone kind signature +standalone_kind_sig :: { LStandaloneKindSig GhcPs } + : 'type' sks_vars '::' ktypedoc + {% amms (mkStandaloneKindSig (comb2 $1 $4) $2 $4) + [mj AnnType $1,mu AnnDcolon $3] } + +-- See also: sig_vars +sks_vars :: { Located [Located RdrName] } -- Returned in reverse order + : sks_vars ',' oqtycon + {% addAnnotation (gl $ head $ unLoc $1) AnnComma (gl $2) >> + return (sLL $1 $> ($3 : unLoc $1)) } + | oqtycon { sL1 $1 [$1] } + inst_decl :: { LInstDecl GhcPs } : 'instance' overlap_pragma inst_type where_inst {% do { (binds, sigs, _, ats, adts, _) <- cvBindsAndSigs (snd $ unLoc $4) diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs index 538c20cc8a..0686f669d3 100644 --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -23,6 +23,7 @@ module RdrHsSyn ( mkClassDecl, mkTyData, mkDataFamInst, mkTySynonym, mkTyFamInstEqn, + mkStandaloneKindSig, mkTyFamInst, mkFamDecl, mkLHsSigType, mkInlinePragma, @@ -239,6 +240,30 @@ mkTySynonym loc lhs rhs , tcdFixity = fixity , tcdRhs = rhs })) } +mkStandaloneKindSig + :: SrcSpan + -> Located [Located RdrName] -- LHS + -> LHsKind GhcPs -- RHS + -> P (LStandaloneKindSig GhcPs) +mkStandaloneKindSig loc lhs rhs = + do { vs <- mapM check_lhs_name (unLoc lhs) + ; v <- check_singular_lhs (reverse vs) + ; return $ cL loc $ StandaloneKindSig noExtField v (mkLHsSigType rhs) } + where + check_lhs_name v@(unLoc->name) = + if isUnqual name && isTcOcc (rdrNameOcc name) + then return v + else addFatalError (getLoc v) $ + hang (text "Expected an unqualified type constructor:") 2 (ppr v) + check_singular_lhs vs = + case vs of + [] -> panic "mkStandaloneKindSig: empty left-hand side" + [v] -> return v + _ -> addFatalError (getLoc lhs) $ + vcat [ hang (text "Standalone kind signatures do not support multiple names at the moment:") + 2 (pprWithCommas ppr vs) + , text "See https://gitlab.haskell.org/ghc/ghc/issues/16754 for details." ] + mkTyFamInstEqn :: Maybe [LHsTyVarBndr GhcPs] -> LHsType GhcPs -> LHsType GhcPs |