From: Adam Megacz Date: Thu, 1 Sep 2011 04:37:51 +0000 (-0700) Subject: add support for <{..}> and ~~> syntax as well as typing for Kappa-calculus X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=9241ac84d10f7e6b23841da2c0765275072ad7c1 add support for <{..}> and ~~> syntax as well as typing for Kappa-calculus --- diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index 2ac19ce..64b3476 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@ -217,12 +217,29 @@ dsLExpr (L loc e) = putSrcSpanDs loc $ dsExpr e dsExpr :: HsExpr Id -> DsM CoreExpr dsExpr (HsPar e) = dsLExpr e -dsExpr (HsHetMetBrak c e) = do { e' <- dsExpr (unLoc e) - ; brak <- dsLookupGlobalId hetmet_brak_name - ; return $ mkApps (Var brak) [ (Type c), (Type $ exprType e'), e'] } -dsExpr (HsHetMetEsc c t e) = do { e' <- dsExpr (unLoc e) - ; esc <- dsLookupGlobalId hetmet_esc_name - ; return $ mkApps (Var esc) [ (Type c), (Type t), e'] } +dsExpr (HsHetMetBrak c e) = + do { e' <- dsExpr (unLoc e) + ; brak <- dsLookupGlobalId hetmet_brak_name + ; return $ mkApps (Var brak) [ (Type c), (Type $ exprType e'), e'] } +dsExpr (HsHetMetEsc c t e) = + do { e' <- dsExpr (unLoc e) + ; esc <- dsLookupGlobalId hetmet_esc_name + ; return $ mkApps (Var esc) [ (Type c), (Type t), e'] } +dsExpr (HsKappa a_Match) = + do { e' <- dsExpr (HsLam a_Match) + ; let ([ua],bc) = tcSplitFunTys (exprType e') + ; let (_,[_,a]) = tcSplitAppTys ua + ; let (_,[b,c]) = tcSplitAppTys bc + ; kap <- dsLookupGlobalId hetmet_kappa_name + ; return $ mkApps (Var kap) [ (Type a), (Type b), (Type c), e'] } +dsExpr (HsKappaApp e1 e2) = + do { e1' <- dsExpr (unLoc e1) + ; e2' <- dsExpr (unLoc e2) + ; let (_,[_ ,a]) = tcSplitAppTys $ exprType e2' + ; let (_,[ab,c]) = tcSplitAppTys $ exprType e1' + ; let (_,[a,b]) = tcSplitAppTys $ ab + ; kap_app <- dsLookupGlobalId hetmet_kappa_app_name + ; return $ mkApps (Var kap_app) [ (Type a), (Type b), (Type c), e1', e2'] } dsExpr (HsHetMetCSP c e) = do { e' <- dsExpr (unLoc e) ; csp <- dsLookupGlobalId hetmet_csp_name ; return $ mkApps (Var csp) [ (Type c), (Type $ exprType e'), e'] } @@ -247,6 +264,7 @@ dsExpr (HsLam a_Match) dsExpr (HsApp fun arg) = mkCoreAppDs <$> dsLExpr fun <*> dsLExpr arg + \end{code} Operator sections. At first it looks as if we can convert diff --git a/compiler/hetmet b/compiler/hetmet index 6e1e4b6..7523e50 160000 --- a/compiler/hetmet +++ b/compiler/hetmet @@ -1 +1 @@ -Subproject commit 6e1e4b67d01a6447f7dd44f7b5450ddc400000d9 +Subproject commit 7523e5094db5e00224ba034b00aa243e69211c9f diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs index c3c372d..8ea0c4f 100644 --- a/compiler/hsSyn/HsExpr.lhs +++ b/compiler/hsSyn/HsExpr.lhs @@ -106,6 +106,10 @@ data HsExpr id | HsApp (LHsExpr id) (LHsExpr id) -- Application + | HsKappa (MatchGroup id) + + | HsKappaApp (LHsExpr id) (LHsExpr id) + -- Operator applications: -- NB Bracketed ops such as (+) come out as Vars. @@ -360,13 +364,15 @@ ppr_expr (HsIPVar v) = ppr v ppr_expr (HsLit lit) = ppr lit ppr_expr (HsOverLit lit) = ppr lit ppr_expr (HsPar e) = parens (ppr_lexpr e) -ppr_expr (HsHetMetBrak _ e) = ptext (sLit "<[") <> (ppr_lexpr e) <> ptext (sLit "]>") -ppr_expr (HsHetMetEsc _ _ e) = ptext (sLit "~~") <> (ppr_lexpr e) -ppr_expr (HsHetMetCSP _ e) = ptext (sLit "%%") <> (ppr_lexpr e) +ppr_expr (HsHetMetBrak _ e) = ptext (sLit "<[") <> (ppr_lexpr e) <> ptext (sLit "]>") +ppr_expr (HsHetMetEsc _ _ e) = ptext (sLit "~~") <> (ppr_lexpr e) +ppr_expr (HsHetMetCSP _ e) = ptext (sLit "%%") <> (ppr_lexpr e) ppr_expr (HsCoreAnn s e) = vcat [ptext (sLit "HsCoreAnn") <+> ftext s, ppr_lexpr e] +ppr_expr (HsKappaApp e1 e2) = ppr_expr $ HsApp e1 e2 +ppr_expr (HsKappa e) = ppr_expr $ HsLam e ppr_expr (HsApp e1 e2) = let (fun, args) = collect_args e1 [e2] in hang (ppr_lexpr fun) 2 (sep (map pprParendExpr args)) diff --git a/compiler/hsSyn/HsSyn.lhs b/compiler/hsSyn/HsSyn.lhs index ce748eb..be7e003 100644 --- a/compiler/hsSyn/HsSyn.lhs +++ b/compiler/hsSyn/HsSyn.lhs @@ -23,7 +23,7 @@ module HsSyn ( module HsDoc, Fixity, - HsModule(..), HsExtCore(..), + HsModule(..), HsExtCore(..), CodeFlavor(..) ) where -- friends: @@ -50,6 +50,9 @@ import Data.Data hiding ( Fixity ) \end{code} \begin{code} + +data CodeFlavor = LambdaFlavor | KappaFlavor + -- | All we actually declare here is the top-level structure for a module. data HsModule name = HsModule { diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs index 75e6c23..c64dfd8 100644 --- a/compiler/hsSyn/HsTypes.lhs +++ b/compiler/hsSyn/HsTypes.lhs @@ -152,6 +152,9 @@ data HsType name | HsFunTy (LHsType name) -- function type (LHsType name) + | HsKappaTy (LHsType name) -- first-order function type + (LHsType name) + | HsListTy (LHsType name) -- Element type | HsPArrTy (LHsType name) -- Elem. type of parallel array: [:t:] @@ -453,7 +456,8 @@ ppr_mono_ty _ (HsTupleTy con tys) = tupleParens con (interpp'SP tys) ppr_mono_ty _ (HsKindSig ty kind) = parens (ppr_mono_lty pREC_TOP ty <+> dcolon <+> pprKind kind) ppr_mono_ty _ (HsListTy ty) = brackets (ppr_mono_lty pREC_TOP ty) ppr_mono_ty _ (HsPArrTy ty) = pabrackets (ppr_mono_lty pREC_TOP ty) -ppr_mono_ty _ (HsModalBoxType ecn ty) = ppr_modalBoxType (ppr ecn) (ppr_mono_lty pREC_TOP ty) +ppr_mono_ty prec (HsKappaTy ty1 ty2) = ppr_kappa_ty prec ty1 ty2 +ppr_mono_ty _ (HsModalBoxType ecn ty) = ppr_modalBoxType (ppr ecn) (ppr_mono_lty pREC_TOP ty) ppr_mono_ty _ (HsPredTy pred) = ppr pred ppr_mono_ty _ (HsSpliceTy s _ _) = pprSplice s ppr_mono_ty _ (HsCoreTy ty) = ppr ty @@ -487,6 +491,14 @@ ppr_fun_ty ctxt_prec ty1 ty2 maybeParen ctxt_prec pREC_FUN $ sep [p1, ptext (sLit "->") <+> p2] +ppr_kappa_ty :: (OutputableBndr name) => Int -> LHsType name -> LHsType name -> SDoc +ppr_kappa_ty ctxt_prec ty1 ty2 + = let p1 = ppr_mono_lty pREC_FUN ty1 + p2 = ppr_mono_lty pREC_TOP ty2 + in + maybeParen ctxt_prec pREC_FUN $ + sep [p1, ptext (sLit "~~>") <+> p2] + -------------------------- pabrackets :: SDoc -> SDoc pabrackets p = ptext (sLit "[:") <> p <> ptext (sLit ":]") diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index cc57e05..9767afa 100644 --- a/compiler/hsSyn/HsUtils.lhs +++ b/compiler/hsSyn/HsUtils.lhs @@ -737,3 +737,6 @@ collect_sig_pat (TuplePat pats _ _) acc = foldr collect_sig_lpat acc pats collect_sig_pat (ConPatIn _ ps) acc = foldr collect_sig_lpat acc (hsConPatArgs ps) collect_sig_pat _ acc = acc -- Literals, vars, wildcard \end{code} + + + diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index c9b2e1c..5bf9800 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -56,7 +56,7 @@ module Lexer ( getLexState, popLexState, pushLexState, extension, bangPatEnabled, datatypeContextsEnabled, addWarning, - incrBracketDepth, decrBracketDepth, getParserBrakDepth, + incrBracketDepth, incrBracketDepth1, decrBracketDepth, getParserBrakDepth, pushBracketDepth, popBracketDepth, lexTokenStream ) where @@ -72,6 +72,7 @@ import Module import Ctype import BasicTypes ( InlineSpec(..), RuleMatchInfo(..), FractionalLit(..) ) import Util ( readRational ) +import HsSyn (CodeFlavor(..)) import Control.Monad import Data.Bits @@ -330,6 +331,9 @@ $tab+ { warn Opt_WarnTabs (text "Warning: Tab character") } "<[" / { ifExtension hetMetEnabled `alexAndPred` notFollowedBySymbol } { special ITopenBrak } "]>" / { ifExtension hetMetEnabled } { special ITcloseBrak } + "<{" / { ifExtension hetMetEnabled `alexAndPred` notFollowedBySymbol } + { special ITopenBrak1 } + "}>" / { ifExtension hetMetEnabled } { special ITcloseBrak1 } "~~" / { ifExtension hetMetEnabled } { special ITescape } "%%" / { ifExtension hetMetEnabled } { special ITdoublePercent } "~~$" / { ifExtension hetMetEnabled } { special ITescapeDollar } @@ -503,6 +507,7 @@ data Token | ITvbar | ITlarrow | ITrarrow + | ITkappa | ITat | ITtilde | ITdarrow @@ -582,6 +587,8 @@ data Token -- Heterogeneous Metaprogramming extension | ITopenBrak -- <[ | ITcloseBrak -- ]> + | ITopenBrak1 -- <{ + | ITcloseBrak1 -- }> | ITescape -- ~~ | ITescapeDollar -- ~~$ | ITdoublePercent -- %% @@ -702,6 +709,7 @@ reservedSymsFM = listToUFM $ ,("|", ITvbar, always) ,("<-", ITlarrow, always) ,("->", ITrarrow, always) + ,("~~>", ITkappa, always) ,("@", ITat, always) ,("~", ITtilde, always) ,("=>", ITdarrow, always) @@ -1548,7 +1556,8 @@ data PState = PState { -- Have we just had the '}' for a let block? If so, than an 'in' -- token doesn't need to close anything: alr_justClosedExplicitLetBlock :: Bool, - code_type_bracket_depth :: Int + code_type_bracket_depth :: [CodeFlavor], + code_type_bracket_depth_stack :: [CodeFlavor] } -- last_loc and last_len are used when generating error messages, -- and in pushCurrentContext only. Sigh, if only Happy passed the @@ -1616,10 +1625,20 @@ setSrcLoc :: RealSrcLoc -> P () setSrcLoc new_loc = P $ \s -> POk s{loc=new_loc} () incrBracketDepth :: P () -incrBracketDepth = P $ \s -> POk (s{code_type_bracket_depth = (code_type_bracket_depth s)+1}) () +incrBracketDepth = P $ \s -> POk (s{code_type_bracket_depth = LambdaFlavor:(code_type_bracket_depth s)}) () +incrBracketDepth1 :: P () +incrBracketDepth1 = P $ \s -> POk (s{code_type_bracket_depth = KappaFlavor:(code_type_bracket_depth s)}) () decrBracketDepth :: P () -decrBracketDepth = P $ \s -> POk (s{code_type_bracket_depth = (code_type_bracket_depth s)-1}) () -getParserBrakDepth :: P Int +decrBracketDepth = P $ \s -> POk (s{code_type_bracket_depth = tail (code_type_bracket_depth s)}) () +pushBracketDepth :: P () +pushBracketDepth = P $ \s -> POk (s{code_type_bracket_depth = tail (code_type_bracket_depth s), + code_type_bracket_depth_stack = (head (code_type_bracket_depth s)):(code_type_bracket_depth_stack s) + }) () +popBracketDepth :: P () +popBracketDepth = P $ \s -> POk (s{code_type_bracket_depth = (head (code_type_bracket_depth_stack s)):(code_type_bracket_depth s), + code_type_bracket_depth_stack = tail (code_type_bracket_depth_stack s) + }) () +getParserBrakDepth :: P [CodeFlavor] getParserBrakDepth = P $ \s -> POk s (code_type_bracket_depth s) getSrcLoc :: P RealSrcLoc @@ -1905,7 +1924,8 @@ mkPState flags buf loc = alr_context = [], alr_expecting_ocurly = Nothing, alr_justClosedExplicitLetBlock = False, - code_type_bracket_depth = 0 + code_type_bracket_depth = [], + code_type_bracket_depth_stack = [] } where bitmap = ffiBit `setBitIf` xopt Opt_ForeignFunctionInterface flags diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 1a847ec..bd93101 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -60,8 +60,10 @@ import Control.Monad ( unless ) import GHC.Exts import Data.Char import Control.Monad ( mplus ) + } + {- ----------------------------------------------------------------------------- 24 Februar 2006 @@ -277,6 +279,7 @@ incorrect. '|' { L _ ITvbar } '<-' { L _ ITlarrow } '->' { L _ ITrarrow } + '~~>' { L _ ITkappa } '@' { L _ ITat } '~' { L _ ITtilde } '=>' { L _ ITdarrow } @@ -307,6 +310,8 @@ incorrect. '|)' { L _ ITcparenbar } '<[' { L _ ITopenBrak } ']>' { L _ ITcloseBrak } + '<{' { L _ ITopenBrak1 } + '}>' { L _ ITcloseBrak1 } '~~' { L _ ITescape } '~~$' { L _ ITescapeDollar } '%%' { L _ ITdoublePercent } @@ -475,7 +480,8 @@ export :: { LIE RdrName } | oqtycon '(' ')' { LL (IEThingWith (unLoc $1) []) } | oqtycon '(' qcnames ')' { LL (IEThingWith (unLoc $1) (reverse $3)) } | 'module' modid { LL (IEModuleContents (unLoc $2)) } - | '<[' incdepth export decdepth ']>' { $3 } + | '<[' incdepth export decdepth ']>' { $3 } + | '<{' incdepth1 export decdepth '}>' { $3 } qcnames :: { [RdrName] } : qcnames ',' qcname_ext { unLoc $3 : $1 } | qcname_ext { [unLoc $1] } @@ -1000,6 +1006,7 @@ type :: { LHsType RdrName } | btype qtyconop type { LL $ HsOpTy $1 $2 $3 } | btype tyvarop type { LL $ HsOpTy $1 $2 $3 } | btype '->' ctype { LL $ HsFunTy $1 $3 } + | btype '~~>' ctype { LL $ HsKappaTy $1 $3 } | btype '~' btype { LL $ HsPredTy (HsEqualP $1 $3) } typedoc :: { LHsType RdrName } @@ -1025,7 +1032,7 @@ atype :: { LHsType RdrName } | '(' ctype ',' comma_types1 ')' { LL $ HsTupleTy Boxed ($2:$4) } | '(#' comma_types1 '#)' { LL $ HsTupleTy Unboxed $2 } | '[' ctype ']' { LL $ HsListTy $2 } - | '<[' ctype ']>' '@' tyvar { LL $ HsModalBoxType (unLoc $5) $2 } + | '<[' ctype ']>' '@' tyvar { LL $ HsModalBoxType (unLoc $5) $2 } | '[:' ctype ':]' { LL $ HsPArrTy $2 } | '(' ctype ')' { LL $ HsParTy $2 } | '(' ctype '::' kind ')' { LL $ HsKindSig $2 (unLoc $4) } @@ -1271,8 +1278,11 @@ quasiquote :: { Located (HsQuasiQuote RdrName) } ; quoterId = mkUnqual varName quoter } in L1 (mkHsQuasiQuote quoterId (RealSrcSpan quoteSpan) quote) } -incdepth :: { Located () } : {% do { incrBracketDepth ; return $ noLoc () } } -decdepth :: { Located () } : {% do { decrBracketDepth ; return $ noLoc () } } +incdepth :: { Located () } : {% do { incrBracketDepth ; return $ noLoc () } } +incdepth1 :: { Located () } : {% do { incrBracketDepth1 ; return $ noLoc () } } +decdepth :: { Located () } : {% do { decrBracketDepth ; return $ noLoc () } } +pushdepth :: { Located () } : {% do { pushBracketDepth ; return $ noLoc () } } +popdepth :: { Located () } : {% do { popBracketDepth ; return $ noLoc () } } exp :: { LHsExpr RdrName } @@ -1282,7 +1292,7 @@ exp :: { LHsExpr RdrName } | infixexp '-<<' exp { LL $ HsArrApp $1 $3 placeHolderType HsHigherOrderApp True } | infixexp '>>-' exp { LL $ HsArrApp $3 $1 placeHolderType HsHigherOrderApp False} | infixexp { $1 } - | '~~$' decdepth exp incdepth { sL (comb2 $3 $>) (HsHetMetEsc placeHolderType placeHolderType $3) } + | '~~$' pushdepth exp popdepth {% do { x <- mkHsHetMetEsc placeHolderType placeHolderType $3; return $ sL (comb2 $3 $>) x } } infixexp :: { LHsExpr RdrName } : exp10 { $1 } @@ -1290,9 +1300,12 @@ infixexp :: { LHsExpr RdrName } exp10 :: { LHsExpr RdrName } : '\\' apat apats opt_asig '->' exp - { LL $ HsLam (mkMatchGroup [LL $ Match ($2:$3) $4 - (unguardedGRHSs $6) - ]) } + {% do { x <- getParserBrakDepth + ; return + $ case x of + KappaFlavor:_ -> LL $ HsKappa (mkMatchGroup[LL $ Match ($2:$3) $4 (unguardedGRHSs $6) ]) + _ -> LL $ HsLam (mkMatchGroup [LL $ Match ($2:$3) $4 (unguardedGRHSs $6) ]) + } } | 'let' binds 'in' exp { LL $ HsLet (unLoc $2) $4 } | 'if' exp optSemi 'then' exp optSemi 'else' exp {% checkDoAndIfThenElse $2 $3 $5 $6 $8 >> @@ -1342,7 +1355,12 @@ hpc_annot :: { Located (FastString,(Int,Int),(Int,Int)) } } fexp :: { LHsExpr RdrName } - : fexp aexp { LL $ HsApp $1 $2 } + : fexp aexp {% do { x <- getParserBrakDepth + ; return $ case x of + [] -> LL $ HsApp $1 $2 + LambdaFlavor:_ -> LL $ HsApp $1 $2 + KappaFlavor:_ -> LL $ HsKappaApp $1 $2 + } } | aexp { $1 } aexp :: { LHsExpr RdrName } @@ -1409,9 +1427,10 @@ aexp2 :: { LHsExpr RdrName } | '(|' aexp2 cmdargs '|)' { LL $ HsArrForm $2 Nothing (reverse $3) } -- code type notation extension - | '<[' incdepth exp decdepth ']>' { sL (comb2 $3 $>) (HsHetMetBrak placeHolderType $3) } - | '~~' decdepth aexp incdepth { sL (comb2 $3 $>) (HsHetMetEsc placeHolderType placeHolderType $3) } - | '%%' decdepth aexp incdepth { sL (comb2 $3 $>) (HsHetMetCSP placeHolderType $3) } + | '<[' incdepth exp decdepth ']>' { sL (comb2 $3 $>) (HsHetMetBrak placeHolderType $3) } + | '<{' incdepth1 exp decdepth '}>' { sL (comb2 $3 $>) (HsHetMetBrak placeHolderType $3) } + | '~~' pushdepth aexp popdepth {% do { x <- mkHsHetMetEsc placeHolderType placeHolderType $3; return $ sL (comb2 $3 $>) x } } + | '%%' pushdepth aexp popdepth { sL (comb2 $3 $>) (HsHetMetCSP placeHolderType $3) } cmdargs :: { [LHsCmdTop RdrName] } : cmdargs acmd { $2 : $1 } @@ -1846,7 +1865,7 @@ qvarid :: { Located RdrName } | PREFIXQVARSYM { L1 $! mkQual varName (getPREFIXQVARSYM $1) } varid :: { Located RdrName } - : VARID {% do { depth <- getParserBrakDepth ; return (L1 $! mkUnqual (varNameDepth depth) (getVARID $1)) } } + : VARID {% do { depth <- getParserBrakDepth ; return (L1 $! mkUnqual (varNameDepth $ length depth) (getVARID $1)) } } | special_id { L1 $! mkUnqual varName (unLoc $1) } | 'unsafe' { L1 $! mkUnqual varName (fsLit "unsafe") } | 'safe' { L1 $! mkUnqual varName (fsLit "safe") } @@ -1872,9 +1891,9 @@ varsym :: { Located RdrName } varsym_no_minus :: { Located RdrName } -- varsym not including '-' : VARSYM {% do { depth <- getParserBrakDepth - ; return (L1 $! mkUnqual (varNameDepth depth) (getVARSYM $1)) } } + ; return (L1 $! mkUnqual (varNameDepth $ length depth) (getVARSYM $1)) } } | special_sym {% do { depth <- getParserBrakDepth - ; return (L1 $! mkUnqual (varNameDepth depth) (unLoc $1)) } } + ; return (L1 $! mkUnqual (varNameDepth $ length depth) (unLoc $1)) } } -- These special_ids are treated as keywords in various places, -- but as ordinary ids elsewhere. 'special_id' collects all these @@ -2055,4 +2074,12 @@ fileSrcSpan = do l <- getSrcLoc; let loc = mkSrcLoc (srcLocFile l) 1 1; return (mkSrcSpan loc loc) + +mkHsHetMetEsc a b c = do { depth <- getParserBrakDepth + ; return $ case head depth of + { LambdaFlavor -> HsHetMetEsc a b c + ; KappaFlavor -> HsHetMetEsc a b c + } + } + } diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 0e265e9..8c14214 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -122,6 +122,7 @@ extract_lty (L loc ty) acc HsAppTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc) HsListTy ty -> extract_lty ty acc HsPArrTy ty -> extract_lty ty acc + HsKappaTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc) HsModalBoxType ecn ty -> extract_lty ty (extract_tv loc ecn acc) HsTupleTy _ tys -> extract_ltys tys acc HsFunTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc) @@ -647,7 +648,7 @@ checkAPat :: DynFlags -> SrcSpan -> HsExpr RdrName -> P (Pat RdrName) checkAPat dynflags loc e0 = case e0 of EWildPat -> return (WildPat placeHolderType) HsVar x -> return (VarPat x) - HsHetMetBrak _ p -> checkAPat dynflags loc (unLoc p) + HsHetMetBrak _ p -> checkAPat dynflags loc (unLoc p) HsLit l -> return (LitPat l) -- Overloaded numeric patterns (e.g. f 0 x = x) diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index eaa3e8a..9206ad5 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -215,6 +215,7 @@ basicKnownKeyNames -- Code types hetmet_brak_name, hetmet_esc_name, hetmet_csp_name, + hetmet_kappa_name, hetmet_kappa_app_name, hetmet_guest_integer_literal_name, hetmet_guest_string_literal_name, hetmet_guest_char_literal_name, -- Annotation type checking @@ -894,10 +895,13 @@ appPName pkg = varQual (gHC_PARR pkg) (fsLit "+:+") appPI -- code type things hetmet_brak_name, hetmet_esc_name, hetmet_csp_name :: Name +hetmet_kappa_name, hetmet_kappa_app_name :: Name hetmet_guest_integer_literal_name, hetmet_guest_string_literal_name, hetmet_guest_char_literal_name :: Name -hetmet_brak_name = varQual gHC_HETMET_CODETYPES (fsLit "hetmet_brak") hetmet_brak_key -hetmet_esc_name = varQual gHC_HETMET_CODETYPES (fsLit "hetmet_esc") hetmet_esc_key -hetmet_csp_name = varQual gHC_HETMET_CODETYPES (fsLit "hetmet_csp") hetmet_csp_key +hetmet_brak_name = varQual gHC_HETMET_CODETYPES (fsLit "hetmet_brak") hetmet_brak_key +hetmet_esc_name = varQual gHC_HETMET_CODETYPES (fsLit "hetmet_esc") hetmet_esc_key +hetmet_csp_name = varQual gHC_HETMET_CODETYPES (fsLit "hetmet_csp") hetmet_csp_key +hetmet_kappa_name = varQual gHC_HETMET_CODETYPES (fsLit "hetmet_kappa") hetmet_kappa_key +hetmet_kappa_app_name = varQual gHC_HETMET_CODETYPES (fsLit "hetmet_kappa_app") hetmet_kappa_app_key hetmet_guest_integer_literal_name = varQual gHC_HETMET_CODETYPES (fsLit "guestIntegerLiteral") hetmet_guest_integer_literal_key hetmet_guest_string_literal_name = varQual gHC_HETMET_CODETYPES (fsLit "guestStringLiteral") hetmet_guest_string_literal_key hetmet_guest_char_literal_name = varQual gHC_HETMET_CODETYPES (fsLit "guestCharLiteral") hetmet_guest_char_literal_key @@ -1517,16 +1521,20 @@ mzipIdKey = mkPreludeMiscIdUnique 134 -- code types hetMetCodeTypeTyConKey :: Unique hetMetCodeTypeTyConKey = mkPreludeTyConUnique 135 +hetMetKappaTyConKey :: Unique +hetMetKappaTyConKey = mkPreludeTyConUnique 137 hetmet_guest_integer_literal_key, hetmet_guest_string_literal_key, hetmet_guest_char_literal_key :: Unique -hetmet_guest_integer_literal_key = mkPreludeMiscIdUnique 134 -hetmet_guest_string_literal_key = mkPreludeMiscIdUnique 135 -hetmet_guest_char_literal_key = mkPreludeMiscIdUnique 136 +hetmet_guest_integer_literal_key = mkPreludeMiscIdUnique 138 +hetmet_guest_string_literal_key = mkPreludeMiscIdUnique 139 +hetmet_guest_char_literal_key = mkPreludeMiscIdUnique 140 hetmet_brak_key, hetmet_esc_key, hetmet_csp_key :: Unique -hetmet_brak_key = mkPreludeMiscIdUnique 161 -hetmet_esc_key = mkPreludeMiscIdUnique 162 -hetmet_csp_key = mkPreludeMiscIdUnique 163 +hetmet_brak_key = mkPreludeMiscIdUnique 141 +hetmet_esc_key = mkPreludeMiscIdUnique 143 +hetmet_csp_key = mkPreludeMiscIdUnique 145 +hetmet_kappa_key = mkPreludeMiscIdUnique 146 +hetmet_kappa_app_key = mkPreludeMiscIdUnique 147 ---------------- Template Haskell ------------------- diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs index bc45028..e420d7b 100644 --- a/compiler/prelude/TysWiredIn.lhs +++ b/compiler/prelude/TysWiredIn.lhs @@ -50,9 +50,16 @@ module TysWiredIn ( -- * Heterogeneous Metaprogramming mkHetMetCodeTypeTy, hetMetCodeTypeTyConName, - hetMetCodeTypeTyCon, isHetMetCodeTypeTyCon, + hetMetCodeTypeTyCon, + isHetMetCodeTypeTyCon, hetMetCodeTypeTyCon_RDR, + mkHetMetKappaTy, + hetMetKappaTyConName, + hetMetKappaTyCon, + hetMetKappaTyCon_RDR, + isHetMetKappaTyCon, + -- * Parallel arrays mkPArrTy, parrTyCon, parrFakeCon, isPArrTyCon, isPArrFakeCon, @@ -122,6 +129,7 @@ wiredInTyCons = [ unitTyCon -- Not treated like other tuples, because , listTyCon , parrTyCon , hetMetCodeTypeTyCon + , hetMetKappaTyCon ] \end{code} @@ -172,8 +180,12 @@ hetMetCodeTypeDataConName :: Name hetMetCodeTypeDataConName = mkWiredInDataConName BuiltInSyntax gHC_HETMET_CODETYPES (fsLit "<[]>") hetMetCodeTypeDataConKey hetMetCodeTypeDataCon +hetMetKappaTyConName :: Name +hetMetKappaTyConName = mkWiredInTyConName BuiltInSyntax gHC_HETMET_CODETYPES (fsLit "~~>") hetMetKappaTyConKey hetMetKappaTyCon + boolTyCon_RDR, false_RDR, true_RDR, intTyCon_RDR, charTyCon_RDR, - intDataCon_RDR, listTyCon_RDR, consDataCon_RDR, parrTyCon_RDR, hetMetCodeTypeTyCon_RDR :: RdrName + intDataCon_RDR, listTyCon_RDR, consDataCon_RDR, parrTyCon_RDR, hetMetCodeTypeTyCon_RDR, + hetMetKappaTyCon_RDR :: RdrName boolTyCon_RDR = nameRdrName boolTyConName false_RDR = nameRdrName falseDataConName true_RDR = nameRdrName trueDataConName @@ -184,6 +196,7 @@ listTyCon_RDR = nameRdrName listTyConName consDataCon_RDR = nameRdrName consDataConName parrTyCon_RDR = nameRdrName parrTyConName hetMetCodeTypeTyCon_RDR = nameRdrName hetMetCodeTypeTyConName +hetMetKappaTyCon_RDR = nameRdrName hetMetKappaTyConName \end{code} @@ -614,16 +627,25 @@ Heterogeneous Metaprogramming mkHetMetCodeTypeTy :: TyVar -> Type -> Type mkHetMetCodeTypeTy ecn ty = mkTyConApp hetMetCodeTypeTyCon [(mkTyVarTy ecn), ty] +mkHetMetKappaTy :: Type -> Type -> Type +mkHetMetKappaTy a b = mkTyConApp hetMetKappaTyCon [a, b] + ecTyVar = head ecTyVars -- | Represents the type constructor of box types hetMetCodeTypeTyCon :: TyCon hetMetCodeTypeTyCon = pcNonRecDataTyCon hetMetCodeTypeTyConName [ecTyVar, betaTyVar] [hetMetCodeTypeDataCon] +hetMetKappaTyCon :: TyCon +hetMetKappaTyCon = pcNonRecDataTyCon hetMetKappaTyConName [alphaTyVar, betaTyVar] [] + -- | Check whether a type constructor is the constructor for box types isHetMetCodeTypeTyCon :: TyCon -> Bool isHetMetCodeTypeTyCon tc = tyConName tc == hetMetCodeTypeTyConName +isHetMetKappaTyCon :: TyCon -> Bool +isHetMetKappaTyCon tc = tyConName tc == hetMetKappaTyConName + hetMetCodeTypeDataCon :: DataCon hetMetCodeTypeDataCon = pcDataCon hetMetCodeTypeDataConName diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs index 9b1f08e..35300e0 100644 --- a/compiler/rename/RnExpr.lhs +++ b/compiler/rename/RnExpr.lhs @@ -177,6 +177,13 @@ rnExpr (HsHetMetCSP c e) = do { (e', fv_e) <- updLclEnv (\x -> x { tcl_hetMetLevel = tail (tcl_hetMetLevel x) }) $ rnLExpr e ; return (HsHetMetCSP c e', fv_e) } +rnExpr (HsKappa matches) + = rnMatchGroup LambdaExpr matches `thenM` \ (matches', fvMatch) -> + return (HsKappa matches', fvMatch) +rnExpr (HsKappaApp fun arg) + = rnLExpr fun `thenM` \ (fun',fvFun) -> + rnLExpr arg `thenM` \ (arg',fvArg) -> + return (HsKappaApp fun' arg', fvFun `plusFV` fvArg) diff --git a/compiler/rename/RnHsSyn.lhs b/compiler/rename/RnHsSyn.lhs index f4fdc3b..9e6cb9d 100644 --- a/compiler/rename/RnHsSyn.lhs +++ b/compiler/rename/RnHsSyn.lhs @@ -39,7 +39,7 @@ charTyCon_name = getName charTyCon listTyCon_name = getName listTyCon parrTyCon_name = getName parrTyCon hetMetCodeTypeTyCon_name :: Name -hetMetCodeTypeTyCon_name = getName hetMetCodeTypeTyCon +hetMetCodeTypeTyCon_name = getName hetMetCodeTypeTyCon tupleTyCon_name :: Boxity -> Int -> Name tupleTyCon_name boxity n = getName (tupleTyCon boxity n) @@ -59,7 +59,12 @@ extractHsTyNames ty get (HsAppTy ty1 ty2) = getl ty1 `unionNameSets` getl ty2 get (HsListTy ty) = unitNameSet listTyCon_name `unionNameSets` getl ty get (HsPArrTy ty) = unitNameSet parrTyCon_name `unionNameSets` getl ty - get (HsModalBoxType ecn ty) = (unitNameSet ecn) `unionNameSets` (unitNameSet hetMetCodeTypeTyCon_name) `unionNameSets` (getl ty) + get (HsModalBoxType ecn ty) = (unitNameSet ecn) + `unionNameSets` + (unitNameSet hetMetCodeTypeTyCon_name) + `unionNameSets` + (getl ty) + get (HsKappaTy ty1 ty2) = getl ty1 `unionNameSets` getl ty2 get (HsTupleTy _ tys) = extractHsTyNames_s tys get (HsFunTy ty1 ty2) = getl ty1 `unionNameSets` getl ty2 get (HsPredTy p) = extractHsPredTyNames p diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs index 31382c2..88e3e26 100644 --- a/compiler/rename/RnTypes.lhs +++ b/compiler/rename/RnTypes.lhs @@ -168,6 +168,11 @@ rnHsType doc (HsModalBoxType ecn ty) = do ty' <- rnLHsType doc ty return (HsModalBoxType ecn' ty') +rnHsType doc (HsKappaTy ty1 ty2) = do + ty1' <- rnLHsType doc ty1 + ty2' <- rnLHsType doc ty2 + return $ HsKappaTy ty1' ty2' + -- Unboxed tuples are allowed to have poly-typed arguments. These -- sometimes crop up as a result of CPR worker-wrappering dictionaries. rnHsType doc (HsTupleTy tup_con tys) = do diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index 70592af..86e8f09 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -186,6 +186,26 @@ tcExpr (HsHetMetCSP _ e) res_ty = $ tcExpr (unLoc e) res_ty ; return $ HsHetMetCSP (TyVarTy $ head cur_level) (noLoc expr') } +tcExpr (HsKappa match) res_ty = + do { v1 <- newFlexiTyVar liftedTypeKind + ; v2 <- newFlexiTyVar liftedTypeKind + ; v3 <- newFlexiTyVar liftedTypeKind + ; (_, [ty_ab, ty_c]) <- matchExpectedTyConApp hetMetKappaTyCon res_ty + ; (_, [ty_a, ty_b]) <- matchExpectedTyConApp pairTyCon ty_ab + ; (co_fn, match') <- tcMatchLambda match (mkFunTy + (mkHetMetKappaTy unitTy ty_a) + (mkHetMetKappaTy ty_b ty_c)) + ; return (HsKappa match') } + +tcExpr (HsKappaApp e1 e2) res_ty = + do { v1 <- newFlexiTyVar liftedTypeKind + ; v2 <- newFlexiTyVar liftedTypeKind + ; v3 <- newFlexiTyVar liftedTypeKind + ; e1' <- tcExpr (unLoc e1) (mkHetMetKappaTy (mkTyConApp pairTyCon [(TyVarTy v1), (TyVarTy v2)]) (TyVarTy v3)) + ; e2' <- tcExpr (unLoc e2) (mkHetMetKappaTy unitTy (TyVarTy v1)) + ; unifyType res_ty (mkHetMetKappaTy (TyVarTy v2) (TyVarTy v3)) + ; return (HsKappaApp (noLoc e1') (noLoc e2')) } + tcExpr (HsApp e1 e2) res_ty = tcApp e1 [e2] res_ty tcExpr (HsLit lit) res_ty = diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index 6ba78d9..5ce40fc 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -562,6 +562,17 @@ zonkExpr env (HsHetMetCSP c e) e' <- zonkLExpr env e return (HsHetMetCSP c' e') +zonkExpr env (HsKappa matches) + = do { matches' <- zonkMatchGroup env matches + ; returnM (HsKappa matches') + } + +zonkExpr env (HsKappaApp e1 e2) + = do { e1' <- zonkLExpr env e1 + ; e2' <- zonkLExpr env e2 + ; returnM (HsKappaApp e1' e2') + } + zonkExpr env (SectionL expr op) = zonkLExpr env expr `thenM` \ new_expr -> zonkLExpr env op `thenM` \ new_op -> diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index f826e72..4fe6b60 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -370,6 +370,11 @@ kc_hs_type (HsModalBoxType ecn ty) = do ty' <- kcLiftedType ty return (HsModalBoxType ecn ty', liftedTypeKind) +kc_hs_type (HsKappaTy ty1 ty2) = do + ty1' <- kc_check_lhs_type ty1 (EK argTypeKind EkUnk) + ty2' <- kcTypeType ty2 + return (HsKappaTy ty1' ty2', liftedTypeKind) + kc_hs_type (HsKindSig ty k) = do ty' <- kc_check_lhs_type ty (EK k EkKindSig) return (HsKindSig ty' k, k) @@ -581,6 +586,11 @@ ds_type (HsModalBoxType ecn ty) = do checkWiredInTyCon hetMetCodeTypeTyCon return (mkHetMetCodeTypeTy (mkTyVar ecn ecKind) tau_ty) +ds_type (HsKappaTy ty1 ty2) = do + tau_ty1 <- dsHsType ty1 + tau_ty2 <- dsHsType ty2 + return (mkHetMetKappaTy tau_ty1 tau_ty2) + ds_type (HsTupleTy boxity tys) = do tau_tys <- dsHsTypes tys checkWiredInTyCon tycon diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs index 4f0e9d8..ec20914 100644 --- a/compiler/types/TypeRep.lhs +++ b/compiler/types/TypeRep.lhs @@ -652,6 +652,9 @@ pprTcApp p pp tc tys | isTupleTyCon tc && tyConArity tc == length tys = tupleParens (tupleTyConBoxity tc) (sep (punctuate comma (map (pp TopPrec) tys))) + | tc `hasKey` hetMetKappaTyConKey, [ty1,ty2] <- tys + = pp TopPrec ty1 <> ptext (sLit "~~>") <> pp TopPrec ty2 + | tc `hasKey` hetMetCodeTypeTyConKey, [ty1,ty2] <- tys = ptext (sLit "<[") <> pp TopPrec ty2 <> ptext (sLit "]>@") <> pp TopPrec ty1