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'] }
dsExpr (HsApp fun arg)
= mkCoreAppDs <$> dsLExpr fun <*> dsLExpr arg
+
\end{code}
Operator sections. At first it looks as if we can convert
-Subproject commit 6e1e4b67d01a6447f7dd44f7b5450ddc400000d9
+Subproject commit 7523e5094db5e00224ba034b00aa243e69211c9f
| 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.
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))
module HsDoc,
Fixity,
- HsModule(..), HsExtCore(..),
+ HsModule(..), HsExtCore(..), CodeFlavor(..)
) where
-- friends:
\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 {
| 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:]
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
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 ":]")
collect_sig_pat (ConPatIn _ ps) acc = foldr collect_sig_lpat acc (hsConPatArgs ps)
collect_sig_pat _ acc = acc -- Literals, vars, wildcard
\end{code}
+
+
+
getLexState, popLexState, pushLexState,
extension, bangPatEnabled, datatypeContextsEnabled,
addWarning,
- incrBracketDepth, decrBracketDepth, getParserBrakDepth,
+ incrBracketDepth, incrBracketDepth1, decrBracketDepth, getParserBrakDepth, pushBracketDepth, popBracketDepth,
lexTokenStream
) where
import Ctype
import BasicTypes ( InlineSpec(..), RuleMatchInfo(..), FractionalLit(..) )
import Util ( readRational )
+import HsSyn (CodeFlavor(..))
import Control.Monad
import Data.Bits
"<[" / { 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 }
| ITvbar
| ITlarrow
| ITrarrow
+ | ITkappa
| ITat
| ITtilde
| ITdarrow
-- Heterogeneous Metaprogramming extension
| ITopenBrak -- <[
| ITcloseBrak -- ]>
+ | ITopenBrak1 -- <{
+ | ITcloseBrak1 -- }>
| ITescape -- ~~
| ITescapeDollar -- ~~$
| ITdoublePercent -- %%
,("|", ITvbar, always)
,("<-", ITlarrow, always)
,("->", ITrarrow, always)
+ ,("~~>", ITkappa, always)
,("@", ITat, always)
,("~", ITtilde, always)
,("=>", ITdarrow, always)
-- 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
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
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
import GHC.Exts
import Data.Char
import Control.Monad ( mplus )
+
}
+
{-
-----------------------------------------------------------------------------
24 Februar 2006
'|' { L _ ITvbar }
'<-' { L _ ITlarrow }
'->' { L _ ITrarrow }
+ '~~>' { L _ ITkappa }
'@' { L _ ITat }
'~' { L _ ITtilde }
'=>' { L _ ITdarrow }
'|)' { L _ ITcparenbar }
'<[' { L _ ITopenBrak }
']>' { L _ ITcloseBrak }
+ '<{' { L _ ITopenBrak1 }
+ '}>' { L _ ITcloseBrak1 }
'~~' { L _ ITescape }
'~~$' { L _ ITescapeDollar }
'%%' { L _ ITdoublePercent }
| 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] }
| 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 }
| '(' 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) }
; 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 }
| 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 }
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 >>
}
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 }
| '(|' 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 }
| 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") }
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
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
+ }
+ }
+
}
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)
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)
-- 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
-- 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
-- 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 -------------------
-- * Heterogeneous Metaprogramming
mkHetMetCodeTypeTy,
hetMetCodeTypeTyConName,
- hetMetCodeTypeTyCon, isHetMetCodeTypeTyCon,
+ hetMetCodeTypeTyCon,
+ isHetMetCodeTypeTyCon,
hetMetCodeTypeTyCon_RDR,
+ mkHetMetKappaTy,
+ hetMetKappaTyConName,
+ hetMetKappaTyCon,
+ hetMetKappaTyCon_RDR,
+ isHetMetKappaTyCon,
+
-- * Parallel arrays
mkPArrTy,
parrTyCon, parrFakeCon, isPArrTyCon, isPArrFakeCon,
, listTyCon
, parrTyCon
, hetMetCodeTypeTyCon
+ , hetMetKappaTyCon
]
\end{code}
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
consDataCon_RDR = nameRdrName consDataConName
parrTyCon_RDR = nameRdrName parrTyConName
hetMetCodeTypeTyCon_RDR = nameRdrName hetMetCodeTypeTyConName
+hetMetKappaTyCon_RDR = nameRdrName hetMetKappaTyConName
\end{code}
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
= 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)
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)
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
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
$ 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 =
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 ->
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)
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
| 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