diff options
Diffstat (limited to 'compiler/parser/RdrHsSyn.hs')
| -rw-r--r-- | compiler/parser/RdrHsSyn.hs | 25 |
1 files changed, 25 insertions, 0 deletions
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 |