getSrcLoc, getSrcSpan, getOccString,
pprInfixName, pprPrefixName, pprModulePrefix,
+ getNameDepth, setNameDepth,
-- Re-export the OccName stuff
module OccName
-- (and real!) space leaks, due to the fact that we don't look at
-- the SrcLoc in a Name all that often.
+setNameDepth :: Int -> Name -> Name
+setNameDepth depth name = name { n_occ = setOccNameDepth depth (n_occ name) }
+
+getNameDepth :: Name -> Int
+getNameDepth name = getOccNameDepth $ n_occ name
+
data NameSort
= External Module
-- ** Construction
-- $real_vs_source_data_constructors
- tcName, clsName, tcClsName, dataName, varName,
- tvName, srcDataName,
+ tcName, clsName, tcClsName, dataName, varName, varNameDepth,
+ tvName, srcDataName, setOccNameDepth, getOccNameDepth,
-- ** Pretty Printing
pprNameSpace, pprNonVarNameSpace, pprNameSpaceBrief,
%************************************************************************
\begin{code}
-data NameSpace = VarName -- Variables, including "real" data constructors
+data NameSpace = VarName Int -- Variables, including "real" data constructors; Int is the syntactic HetMet bracket depth
| DataName -- "Source" data constructors
| TvName -- Type variables
| TcClsName -- Type constructors and classes; Haskell has them
tcName, clsName, tcClsName :: NameSpace
dataName, srcDataName :: NameSpace
tvName, varName :: NameSpace
+varNameDepth :: Int -> NameSpace
-- Though type constructors and classes are in the same name space now,
-- the NameSpace type is abstract, so we can easily separate them later
srcDataName = DataName -- Haskell-source data constructors should be
-- in the Data name space
-tvName = TvName
-varName = VarName
+tvName = TvName
+
+varName = VarName 0
+varNameDepth = VarName
+
+getOccNameDepth :: OccName -> Int
+getOccNameDepth name =
+ case occNameSpace name of
+ (VarName d) -> d
+ _ -> 0
+setOccNameDepth :: Int -> OccName -> OccName
+setOccNameDepth depth name =
+ case occNameSpace name of
+ (VarName _) -> name{ occNameSpace = VarName depth }
+ ns -> if depth==0
+ then name
+ else error ("tried to change the depth of a name in namespace " ++ (showSDoc $ ppr name))
isDataConNameSpace :: NameSpace -> Bool
isDataConNameSpace DataName = True
isVarNameSpace :: NameSpace -> Bool -- Variables or type variables, but not constructors
isVarNameSpace TvName = True
-isVarNameSpace VarName = True
+isVarNameSpace (VarName _) = True
isVarNameSpace _ = False
isValNameSpace :: NameSpace -> Bool
isValNameSpace DataName = True
-isValNameSpace VarName = True
+isValNameSpace (VarName _) = True
isValNameSpace _ = False
pprNameSpace :: NameSpace -> SDoc
pprNameSpace DataName = ptext (sLit "data constructor")
-pprNameSpace VarName = ptext (sLit "variable")
+pprNameSpace (VarName _) = ptext (sLit "variable")
pprNameSpace TvName = ptext (sLit "type variable")
pprNameSpace TcClsName = ptext (sLit "type constructor or class")
pprNonVarNameSpace :: NameSpace -> SDoc
-pprNonVarNameSpace VarName = empty
+pprNonVarNameSpace (VarName _) = empty
pprNonVarNameSpace ns = pprNameSpace ns
pprNameSpaceBrief :: NameSpace -> SDoc
pprNameSpaceBrief DataName = char 'd'
-pprNameSpaceBrief VarName = char 'v'
+pprNameSpaceBrief (VarName _) = char 'v'
pprNameSpaceBrief TvName = ptext (sLit "tv")
pprNameSpaceBrief TcClsName = ptext (sLit "tc")
\end{code}
\begin{code}
instance Uniquable OccName where
-- See Note [The Unique of an OccName]
- getUnique (OccName VarName fs) = mkVarOccUnique fs
+ getUnique (OccName (VarName depth) fs) = mkVarOccUnique fs depth
getUnique (OccName DataName fs) = mkDataOccUnique fs
getUnique (OccName TvName fs) = mkTvOccUnique fs
getUnique (OccName TcClsName fs) = mkTcOccUnique fs
isVarOcc, isTvOcc, isTcOcc, isDataOcc :: OccName -> Bool
-isVarOcc (OccName VarName _) = True
+isVarOcc (OccName (VarName _) _) = True
isVarOcc _ = False
isTvOcc (OccName TvName _) = True
-- | /Value/ 'OccNames's are those that are either in
-- the variable or data constructor namespaces
isValOcc :: OccName -> Bool
-isValOcc (OccName VarName _) = True
+isValOcc (OccName (VarName _) _) = True
isValOcc (OccName DataName _) = True
isValOcc _ = False
isDataOcc (OccName DataName _) = True
-isDataOcc (OccName VarName s)
+isDataOcc (OccName (VarName _) s)
| isLexCon s = pprPanic "isDataOcc: check me" (ppr s)
-- Jan06: I don't think this should happen
isDataOcc _ = False
-- a symbol (e.g. @:@, or @[]@)
isDataSymOcc :: OccName -> Bool
isDataSymOcc (OccName DataName s) = isLexConSym s
-isDataSymOcc (OccName VarName s)
+isDataSymOcc (OccName (VarName _) s)
| isLexConSym s = pprPanic "isDataSymOcc: check me" (ppr s)
-- Jan06: I don't think this should happen
isDataSymOcc _ = False
isSymOcc :: OccName -> Bool
isSymOcc (OccName DataName s) = isLexConSym s
isSymOcc (OccName TcClsName s) = isLexConSym s
-isSymOcc (OccName VarName s) = isLexSym s
+isSymOcc (OccName (VarName _) s) = isLexSym s
isSymOcc (OccName TvName s) = isLexSym s
-- Pretty inefficient!
-- what the mother module will call it.
mkDFunOcc info_str is_boot set
- = chooseUniqueOcc VarName (prefix ++ info_str) set
+ = chooseUniqueOcc (VarName 0) (prefix ++ info_str) set
where
prefix | is_boot = "$fx"
| otherwise = "$f"
\begin{code}
mkMethodOcc :: OccName -> OccName
-mkMethodOcc occ@(OccName VarName _) = occ
+mkMethodOcc occ@(OccName (VarName _) _) = occ
mkMethodOcc occ = mk_simple_deriv varName "$m" occ
\end{code}
\begin{code}
instance Binary NameSpace where
- put_ bh VarName = do
- putByte bh 0
+ put_ bh (VarName depth) = do if depth > 255-4
+ then error "FIXME: no support for serializing VarNames at this syntactic depth"
+ else putByte bh ((fromIntegral ((depth+3) :: Int)))
put_ bh DataName = do
- putByte bh 1
+ putByte bh 0
put_ bh TvName = do
- putByte bh 2
+ putByte bh 1
put_ bh TcClsName = do
- putByte bh 3
+ putByte bh 2
get bh = do
h <- getByte bh
case h of
- 0 -> do return VarName
- 1 -> do return DataName
- 2 -> do return TvName
- _ -> do return TcClsName
+ 0 -> do return DataName
+ 1 -> do return TvName
+ 2 -> do return TcClsName
+ n -> do return (VarName (fromIntegral (n-3)))
instance Binary OccName where
put_ bh (OccName aa ab) = do
mkRegPairUnique = mkUnique 'P'
mkRegClassUnique = mkUnique 'L'
-mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique :: FastString -> Unique
+mkVarOccUnique :: FastString -> Int -> Unique
+mkVarOccUnique fs depth =
+ if depth > 255
+ then error "FIXME: no support for syntactic depth > 255"
+ else mkUnique 'i' ((iBox (uniqueOfFS fs)) * 8 + depth )
+
+mkDataOccUnique, mkTvOccUnique, mkTcOccUnique :: FastString -> Unique
-- See Note [The Unique of an OccName] in OccName
-mkVarOccUnique fs = mkUnique 'i' (iBox (uniqueOfFS fs))
mkDataOccUnique fs = mkUnique 'd' (iBox (uniqueOfFS fs))
mkTvOccUnique fs = mkUnique 'v' (iBox (uniqueOfFS fs))
mkTcOccUnique fs = mkUnique 'c' (iBox (uniqueOfFS fs))
deriving (Eq, Ord)
+closureSuffix' :: Name -> SDoc
+closureSuffix' hs_fn =
+ if depth==0 then ptext (sLit "") else ptext (sLit $ (show depth))
+ where depth = getNameDepth hs_fn
-- | For debugging problems with the CLabel representation.
-- We can't make a Show instance for CLabel because lots of its components don't have instances.
pprCLbl (ForeignLabel str _ _ _)
= ftext str
-pprCLbl (IdLabel name cafs flavor) = ppr name <> ppIdFlavor flavor
+pprCLbl (IdLabel name cafs flavor) = ppr name <> ppIdFlavor name flavor
pprCLbl (CC_Label cc) = ppr cc
pprCLbl (CCS_Label ccs) = ppr ccs
pprCLbl HpcModuleNameLabel
= ptext (sLit "_hpc_module_name_str")
-ppIdFlavor :: IdLabelInfo -> SDoc
-ppIdFlavor x = pp_cSEP <>
+ppIdFlavor :: Name -> IdLabelInfo -> SDoc
+ppIdFlavor n x = pp_cSEP <> closureSuffix' n <>
(case x of
Closure -> ptext (sLit "closure")
SRT -> ptext (sLit "srt")
\begin{code}
module Desugar ( deSugar, deSugarExpr ) where
+import TysWiredIn (unitDataConId)
import DynFlags
import StaticFlags
import HscTypes
import OrdList
import Data.List
import Data.IORef
+import DsHetMet
+import Control.Exception ( catch, ErrorCall, Exception(..) )
\end{code}
%************************************************************************
; (ds_binds, ds_rules_for_imps) <- simpleOptPgm dflags final_pgm rules_for_imps
-- The simpleOptPgm gets rid of type
-- bindings plus any stupid dead code
-
+{-
+ ; dumpIfSet_dyn dflags Opt_D_dump_proof "input to flattener" (text $ showSDoc $ pprCoreBindings ds_binds)
+ ; let uhandler (err::ErrorCall)
+ = dumpIfSet_dyn dflags Opt_D_dump_proof "System FC Proof"
+ (text $ "\\begin{verbatim}\n" ++
+ show err ++
+ "\\end{verbatim}\n\n")
+ in (dumpIfSet_dyn dflags Opt_D_dump_proof "System FC Proof" $
+ (vcat (map (\ bind -> let e = case bind of
+ NonRec b e -> e
+ Rec lve -> Let (Rec lve) (Var unitDataConId)
+ in text $ "\\begin{verbatim}\n" ++
+ (showSDoc $ pprCoreBindings ds_binds) ++
+ "\\end{verbatim}\n\n" ++
+ "$$\n"++
+ (core2proofAndShow e) ++
+ "$$\n"
+ ) ds_binds))) `Control.Exception.catch` uhandler
+-}
; endPass dflags CoreDesugar ds_binds ds_rules_for_imps
; let used_names = mkUsedNames tcg_env
deSugarExpr hsc_env this_mod rdr_env type_env tc_expr = do
let dflags = hsc_dflags hsc_env
- showPass dflags "Desugar"
+ showPass dflags "Desugarz"
-- Do desugaring
(msgs, mb_core_expr) <- initDs hsc_env this_mod rdr_env type_env $
Nothing -> return (msgs, Nothing)
Just expr -> do
+{-
-- Dump output
- dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr expr)
+ dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (text $ "$$\n"++(core2proofAndShow expr)++"$$\n")
+-}
return (msgs, Just expr)
\end{code}
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 (HsHetMetCSP c e) = do { e' <- dsExpr (unLoc e)
+ ; csp <- dsLookupGlobalId hetmet_csp_name
+ ; return $ mkApps (Var csp) [ (Type c), (Type $ exprType e'), e'] }
dsExpr (ExprWithTySigOut e _) = dsLExpr e
dsExpr (HsVar var) = return (Var var)
dsExpr (HsIPVar ip) = return (Var (ipNameName ip))
the_cfun
= case maybe_target of
Nothing -> text "(StgClosure*)deRefStablePtr(the_stableptr)"
- Just hs_fn -> char '&' <> ppr hs_fn <> text "_closure"
+ Just hs_fn -> char '&' <> ppr hs_fn <> text (closureSuffix hs_fn)
cap = text "cap" <> comma
extern_decl
= case maybe_target of
Nothing -> empty
- Just hs_fn -> text "extern StgClosure " <> ppr hs_fn <> text "_closure" <> semi
+ Just hs_fn -> text "extern StgClosure " <> ppr hs_fn <> text (closureSuffix hs_fn) <> semi
-
-- finally, the whole darn thing
c_bits =
space $$
, rbrace
]
+closureSuffix :: Id -> String
+closureSuffix hs_fn =
+ if depth==0 then "_closure" else "_"++(show depth)++"closure"
+ where depth = getNameDepth (Var.varName hs_fn)
foreignExportInitialiser :: Id -> SDoc
foreignExportInitialiser hs_fn =
<> text "() __attribute__((constructor));"
, text "static void stginit_export_" <> ppr hs_fn <> text "()"
, braces (text "getStablePtr"
- <> parens (text "(StgPtr) &" <> ppr hs_fn <> text "_closure")
+ <> parens (text "(StgPtr) &" <> ppr hs_fn <> text (closureSuffix hs_fn))
<> semi)
]
-
mkHObj :: Type -> SDoc
mkHObj t = text "rts_mk" <> text (showFFIType t)
(LHsCmdTop id) -- body of the abstraction
-- always has an empty stack
+ -----------------------------------------------------------
+ -- Heterogeneous Metaprogramming extension
+
+ | HsHetMetBrak PostTcType (LHsExpr id) -- code type brackets
+ | HsHetMetEsc PostTcType PostTcType (LHsExpr id) -- code type escape
+ | HsHetMetCSP PostTcType (LHsExpr id) -- code type cross-stage persistence
+
---------------------------------------
-- The following are commands, not expressions proper
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 (HsCoreAnn s e)
= vcat [ptext (sLit "HsCoreAnn") <+> ftext s, ppr_lexpr e]
| HsPArrTy (LHsType name) -- Elem. type of parallel array: [:t:]
+ | HsModalBoxType name (LHsType name) -- modal types; first argument is the environment classifier
+
| HsTupleTy Boxity
[LHsType name] -- Element types (length gives arity)
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 _ (HsPredTy pred) = ppr pred
ppr_mono_ty _ (HsNumTy n) = integer n -- generics only
ppr_mono_ty _ (HsSpliceTy s _ _) = pprSplice s
--------------------------
pabrackets :: SDoc -> SDoc
pabrackets p = ptext (sLit "[:") <> p <> ptext (sLit ":]")
+
+ppr_modalBoxType :: SDoc -> SDoc -> SDoc
+ppr_modalBoxType ecn p = ptext (sLit "<[") <> p <> ptext (sLit "]>@") <> ecn
+
\end{code}
| Opt_GHCForeignImportPrim
| Opt_ParallelArrays -- Syntactic support for parallel arrays
| Opt_Arrows -- Arrow-notation syntax
+ | Opt_ModalTypes -- Heterogeneous Metaprogramming (modal types, brackets, escape, CSP)
| Opt_TemplateHaskell
| Opt_QuasiQuotes
| Opt_ImplicitParams
deprecatedForExtension "DoRec"),
( "DoRec", Opt_DoRec, nop ),
( "Arrows", Opt_Arrows, nop ),
+ ( "ModalTypes", Opt_ModalTypes, nop ),
( "ParallelArrays", Opt_ParallelArrays, nop ),
( "TemplateHaskell", Opt_TemplateHaskell, checkTemplateHaskellOk ),
( "QuasiQuotes", Opt_QuasiQuotes, nop ),
, (Opt_PolymorphicComponents, turnOn, Opt_ExplicitForAll)
, (Opt_FlexibleInstances, turnOn, Opt_TypeSynonymInstances)
+ , (Opt_ModalTypes, turnOn, Opt_RankNTypes)
+ , (Opt_ModalTypes, turnOn, Opt_ExplicitForAll)
+ , (Opt_ModalTypes, turnOn, Opt_RebindableSyntax)
+ , (Opt_ModalTypes, turnOff, Opt_MonomorphismRestriction)
+
, (Opt_RebindableSyntax, turnOff, Opt_ImplicitPrelude) -- NB: turn off!
, (Opt_GADTs, turnOn, Opt_GADTSyntax)
getLexState, popLexState, pushLexState,
extension, bangPatEnabled, datatypeContextsEnabled,
addWarning,
+ incrBracketDepth, decrBracketDepth, getParserBrakDepth,
lexTokenStream
) where
}
<0> {
+ "<[" / { ifExtension hetMetEnabled `alexAndPred` notFollowedBySymbol }
+ { special ITopenBrak }
+ "]>" / { ifExtension hetMetEnabled } { special ITcloseBrak }
+ "~~" / { ifExtension hetMetEnabled } { special ITescape }
+ "%%" / { ifExtension hetMetEnabled } { special ITdoublePercent }
+ "~~$" / { ifExtension hetMetEnabled } { special ITescapeDollar }
+}
+
+<0> {
\? @varid / { ifExtension ipEnabled } { skip_one_varid ITdupipvarid }
}
| ITLarrowtail -- -<<
| ITRarrowtail -- >>-
+ -- Heterogeneous Metaprogramming extension
+ | ITopenBrak -- <[
+ | ITcloseBrak -- ]>
+ | ITescape -- ~~
+ | ITescapeDollar -- ~~$
+ | ITdoublePercent -- %%
+
| ITunknown String -- Used when the lexer can't make sense of it
| ITeof -- end of file token
alr_expecting_ocurly :: Maybe ALRLayout,
-- Have we just had the '}' for a let block? If so, than an 'in'
-- token doesn't need to close anything:
- alr_justClosedExplicitLetBlock :: Bool
+ alr_justClosedExplicitLetBlock :: Bool,
+ code_type_bracket_depth :: Int
}
-- last_loc and last_len are used when generating error messages,
-- and in pushCurrentContext only. Sigh, if only Happy passed the
setSrcLoc :: SrcLoc -> 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}) ()
+decrBracketDepth :: P ()
+decrBracketDepth = P $ \s -> POk (s{code_type_bracket_depth = (code_type_bracket_depth s)-1}) ()
+getParserBrakDepth :: P Int
+getParserBrakDepth = P $ \s -> POk s (code_type_bracket_depth s)
+
getSrcLoc :: P SrcLoc
getSrcLoc = P $ \s@(PState{ loc=loc }) -> POk s loc
relaxedLayoutBit = 24
nondecreasingIndentationBit :: Int
nondecreasingIndentationBit = 25
+hetMetBit :: Int
+hetMetBit = 31
always :: Int -> Bool
always _ = True
parrEnabled flags = testBit flags parrBit
arrowsEnabled :: Int -> Bool
arrowsEnabled flags = testBit flags arrowsBit
+hetMetEnabled :: Int -> Bool
+hetMetEnabled flags = testBit flags hetMetBit
thEnabled :: Int -> Bool
thEnabled flags = testBit flags thBit
ipEnabled :: Int -> Bool
alr_last_loc = noSrcSpan,
alr_context = [],
alr_expecting_ocurly = Nothing,
- alr_justClosedExplicitLetBlock = False
+ alr_justClosedExplicitLetBlock = False,
+ code_type_bracket_depth = 0
}
where
bitmap = genericsBit `setBitIf` xopt Opt_Generics flags
.|. ffiBit `setBitIf` xopt Opt_ForeignFunctionInterface flags
.|. parrBit `setBitIf` xopt Opt_ParallelArrays flags
.|. arrowsBit `setBitIf` xopt Opt_Arrows flags
+ .|. hetMetBit `setBitIf` xopt Opt_ModalTypes flags
.|. thBit `setBitIf` xopt Opt_TemplateHaskell flags
.|. qqBit `setBitIf` xopt Opt_QuasiQuotes flags
.|. ipBit `setBitIf` xopt Opt_ImplicitParams flags
import ForeignCall ( Safety(..), CExportSpec(..), CLabelString,
CCallConv(..), CCallTarget(..), defaultCCallConv
)
-import OccName ( varName, dataName, tcClsName, tvName )
+import OccName ( varName, varNameDepth, dataName, tcClsName, tvName )
import DataCon ( DataCon, dataConName )
import SrcLoc ( Located(..), unLoc, getLoc, noLoc, combineSrcSpans,
SrcSpan, combineLocs, srcLocFile,
'#)' { L _ ITcubxparen }
'(|' { L _ IToparenbar }
'|)' { L _ ITcparenbar }
+ '<[' { L _ ITopenBrak }
+ ']>' { L _ ITcloseBrak }
+ '~~' { L _ ITescape }
+ '~~$' { L _ ITescapeDollar }
+ '%%' { L _ ITdoublePercent }
';' { L _ ITsemi }
',' { L _ ITcomma }
'`' { L _ ITbackquote }
| '(' 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 ':]' { LL $ HsPArrTy $2 }
| '(' ctype ')' { LL $ HsParTy $2 }
| '(' ctype '::' kind ')' { LL $ HsKindSig $2 (unLoc $4) }
| infixexp opt_sig rhs {% do { r <- checkValDef $1 $2 $3;
let { l = comb2 $1 $> };
return $! (sL l (unitOL $! (sL l $ ValD r))) } }
+
| docdecl { LL $ unitOL $1 }
rhs :: { Located (GRHSs RdrName) }
: infixexp '::' sigtypedoc {% do s <- checkValSig $1 $3
; return (LL $ unitOL (LL $ SigD s)) }
-- See Note [Declaration/signature overlap] for why we need infixexp here
+
| var ',' sig_vars '::' sigtypedoc
{ LL $ toOL [ LL $ SigD (TypeSig n $5) | n <- $1 : unLoc $3 ] }
| infix prec ops { LL $ toOL [ LL $ SigD (FixSig (FixitySig n (Fixity $2 (unLoc $1))))
; quoterId = mkUnqual varName quoter }
in L1 (mkHsQuasiQuote quoterId quoteSpan quote) }
+incdepth :: { Located () } : {% do { incrBracketDepth ; return $ noLoc () } }
+decdepth :: { Located () } : {% do { decrBracketDepth ; return $ noLoc () } }
+
+
exp :: { LHsExpr RdrName }
: infixexp '::' sigtype { LL $ ExprWithTySig $1 $3 }
| infixexp '-<' exp { LL $ HsArrApp $1 $3 placeHolderType HsFirstOrderApp True }
| 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) }
infixexp :: { LHsExpr RdrName }
: exp10 { $1 }
-- arrow notation extension
| '(|' 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) }
+
cmdargs :: { [LHsCmdTop RdrName] }
: cmdargs acmd { $2 : $1 }
| {- empty -} { [] }
| PREFIXQVARSYM { L1 $! mkQual varName (getPREFIXQVARSYM $1) }
varid :: { Located RdrName }
- : VARID { L1 $! mkUnqual varName (getVARID $1) }
+ : VARID {% do { depth <- getParserBrakDepth ; return (L1 $! mkUnqual (varNameDepth depth) (getVARID $1)) } }
| special_id { L1 $! mkUnqual varName (unLoc $1) }
| 'unsafe' { L1 $! mkUnqual varName (fsLit "unsafe") }
| 'safe' { L1 $! mkUnqual varName (fsLit "safe") }
| '-' { L1 $ mkUnqual varName (fsLit "-") }
varsym_no_minus :: { Located RdrName } -- varsym not including '-'
- : VARSYM { L1 $ mkUnqual varName (getVARSYM $1) }
- | special_sym { L1 $ mkUnqual varName (unLoc $1) }
-
+ : VARSYM {% do { depth <- getParserBrakDepth
+ ; return (L1 $! mkUnqual (varNameDepth depth) (getVARSYM $1)) } }
+ | special_sym {% do { depth <- getParserBrakDepth
+ ; return (L1 $! mkUnqual (varNameDepth depth) (unLoc $1)) } }
-- These special_ids are treated as keywords in various places,
-- but as ordinary ids elsewhere. 'special_id' collects all these
HsAppTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc)
HsListTy ty -> extract_lty ty acc
HsPArrTy ty -> extract_lty ty acc
+ HsModalBoxType ecn ty -> extract_lty ty acc
HsTupleTy _ tys -> extract_ltys tys acc
HsFunTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc)
HsPredTy p -> extract_pred p acc
:: LHsExpr RdrName
-> LHsType RdrName
-> P (Sig RdrName)
+checkValSig (L l (HsHetMetBrak _ e)) ty
+ = checkValSig e ty
checkValSig (L l (HsVar v)) ty
| isUnqual v && not (isDataOcc (rdrNameOcc v))
= return (TypeSig (L l v) ty)
-- Other classes
randomClassName, randomGenClassName, monadPlusClassName,
+ -- Code types
+ hetmet_brak_name, hetmet_esc_name, hetmet_csp_name,
+ hetmet_guest_integer_literal_name, hetmet_guest_string_literal_name,
+ hetmet_guest_char_literal_name,
+
-- Annotation type checking
toAnnotationWrapperName
gHC_MAGIC,
gHC_CLASSES, gHC_BASE, gHC_ENUM,
gHC_SHOW, gHC_READ, gHC_NUM, gHC_INTEGER, gHC_INTEGER_TYPE, gHC_LIST, gHC_PARR,
+ gHC_HETMET_CODETYPES,
gHC_TUPLE, dATA_TUPLE, dATA_EITHER, dATA_STRING, dATA_FOLDABLE, dATA_TRAVERSABLE,
gHC_PACK, gHC_CONC, gHC_IO, gHC_IO_Exception,
gHC_ST, gHC_ARR, gHC_STABLE, gHC_ADDR, gHC_PTR, gHC_ERR, gHC_REAL,
gHC_INTEGER_TYPE= mkIntegerModule (fsLit "GHC.Integer.Type")
gHC_LIST = mkBaseModule (fsLit "GHC.List")
gHC_PARR = mkBaseModule (fsLit "GHC.PArr")
+gHC_HETMET_CODETYPES = mkBaseModule (fsLit "GHC.HetMet.CodeTypes")
gHC_TUPLE = mkPrimModule (fsLit "GHC.Tuple")
dATA_TUPLE = mkBaseModule (fsLit "Data.Tuple")
dATA_EITHER = mkBaseModule (fsLit "Data.Either")
emptyPName = varQual gHC_PARR (fsLit "emptyP") emptyPIdKey
appPName = varQual gHC_PARR (fsLit "+:+") appPIdKey
+-- code type things
+hetmet_brak_name, hetmet_esc_name, hetmet_csp_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_guest_integer_literal_name = varQual gHC_HETMET_CODETYPES (fsLit "hetmet_guest_integer_literal") hetmet_guest_integer_literal_key
+hetmet_guest_string_literal_name = varQual gHC_HETMET_CODETYPES (fsLit "hetmet_guest_string_literal") hetmet_guest_string_literal_key
+hetmet_guest_char_literal_name = varQual gHC_HETMET_CODETYPES (fsLit "hetmet_guest_char_literal") hetmet_guest_char_literal_key
+
-- IO things
ioTyConName, ioDataConName, thenIOName, bindIOName, returnIOName,
failIOName :: Name
stringTyConKey :: Unique
stringTyConKey = mkPreludeTyConUnique 134
+-- Heterogeneous Metaprogramming code type constructor
+hetMetCodeTypeTyConKey :: Unique
+hetMetCodeTypeTyConKey = mkPreludeTyConUnique 135
+
---------------- Template Haskell -------------------
-- USES TyConUniques 100-129
-----------------------------------------------------
leftDataConKey, rightDataConKey :: Unique
leftDataConKey = mkPreludeDataConUnique 25
rightDataConKey = mkPreludeDataConUnique 26
+
+-- Data constructor for Heterogeneous Metaprogramming code types
+hetMetCodeTypeDataConKey :: Unique
+hetMetCodeTypeDataConKey = mkPreludeDataConUnique 27
\end{code}
%************************************************************************
toIntegerClassOpKey = mkPreludeMiscIdUnique 129
toRationalClassOpKey = mkPreludeMiscIdUnique 130
+-- code types
+hetmet_brak_key, hetmet_esc_key, hetmet_csp_key :: Unique
+hetmet_brak_key = mkPreludeMiscIdUnique 131
+hetmet_esc_key = mkPreludeMiscIdUnique 132
+hetmet_csp_key = mkPreludeMiscIdUnique 133
+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
+
---------------- Template Haskell -------------------
-- USES IdUniques 200-399
-----------------------------------------------------
-- * Unit
unitTy,
+ -- * Heterogeneous Metaprogramming
+ mkHetMetCodeTypeTy,
+ hetMetCodeTypeTyConName,
+ hetMetCodeTypeTyCon, isHetMetCodeTypeTyCon,
+ hetMetCodeTypeTyCon_RDR,
+
-- * Parallel arrays
mkPArrTy,
parrTyCon, parrFakeCon, isPArrTyCon, isPArrFakeCon,
, intTyCon
, listTyCon
, parrTyCon
+ , hetMetCodeTypeTyCon
, unsafeCoercionTyCon
, symCoercionTyCon
, transCoercionTyCon
parrTyConName = mkWiredInTyConName BuiltInSyntax gHC_PARR (fsLit "[::]") parrTyConKey parrTyCon
parrDataConName = mkWiredInDataConName UserSyntax gHC_PARR (fsLit "PArr") parrDataConKey parrDataCon
+hetMetCodeTypeTyConName :: Name
+hetMetCodeTypeTyConName = mkWiredInTyConName BuiltInSyntax gHC_HETMET_CODETYPES (fsLit "<[]>@") hetMetCodeTypeTyConKey hetMetCodeTypeTyCon
+hetMetCodeTypeDataConName :: Name
+hetMetCodeTypeDataConName =
+ mkWiredInDataConName BuiltInSyntax gHC_HETMET_CODETYPES (fsLit "<[]>") hetMetCodeTypeDataConKey hetMetCodeTypeDataCon
+
boolTyCon_RDR, false_RDR, true_RDR, intTyCon_RDR, charTyCon_RDR,
- intDataCon_RDR, listTyCon_RDR, consDataCon_RDR, parrTyCon_RDR:: RdrName
+ intDataCon_RDR, listTyCon_RDR, consDataCon_RDR, parrTyCon_RDR, hetMetCodeTypeTyCon_RDR :: RdrName
boolTyCon_RDR = nameRdrName boolTyConName
false_RDR = nameRdrName falseDataConName
true_RDR = nameRdrName trueDataConName
listTyCon_RDR = nameRdrName listTyConName
consDataCon_RDR = nameRdrName consDataConName
parrTyCon_RDR = nameRdrName parrTyConName
+hetMetCodeTypeTyCon_RDR = nameRdrName hetMetCodeTypeTyConName
\end{code}
\end{code}
+Heterogeneous Metaprogramming
+
+\begin{code}
+-- | Construct a type representing the application of the box type
+mkHetMetCodeTypeTy :: TyVar -> Type -> Type
+mkHetMetCodeTypeTy ecn ty = mkTyConApp hetMetCodeTypeTyCon [(mkTyVarTy ecn), ty]
+
+-- | Represents the type constructor of box types
+hetMetCodeTypeTyCon :: TyCon
+hetMetCodeTypeTyCon = pcNonRecDataTyCon hetMetCodeTypeTyConName [alphaTyVar, betaTyVar] [hetMetCodeTypeDataCon]
+
+-- | Check whether a type constructor is the constructor for box types
+isHetMetCodeTypeTyCon :: TyCon -> Bool
+isHetMetCodeTypeTyCon tc = tyConName tc == hetMetCodeTypeTyConName
+
+hetMetCodeTypeDataCon :: DataCon
+hetMetCodeTypeDataCon = pcDataCon
+ hetMetCodeTypeDataConName
+ [betaTyVar] -- forall'ed type variables
+ [betaTy]
+ hetMetCodeTypeTyCon
+
+\end{code}
import LoadIface ( loadInterfaceForName, loadSrcInterface )
import IfaceEnv ( lookupOrig, newGlobalBinder, newIPName )
+import TcEnv ( getHetMetLevel )
import HsSyn
import RdrHsSyn ( extractHsTyRdrTyVars )
import RdrName
lookupSyntaxName :: Name -- The standard name
-> RnM (SyntaxExpr Name, FreeVars) -- Possibly a non-standard name
lookupSyntaxName std_name
- = xoptM Opt_RebindableSyntax `thenM` \ rebindable_on ->
- if not rebindable_on then normal_case
- else
- -- Get the similarly named thing from the local environment
- lookupOccRn (mkRdrUnqual (nameOccName std_name)) `thenM` \ usr_name ->
- return (HsVar usr_name, unitFV usr_name)
- where
- normal_case = return (HsVar std_name, emptyFVs)
+ = do ec <- getHetMetLevel
+ std_name' <- return $ setNameDepth (length ec) std_name
+ rebindable_on <- xoptM Opt_RebindableSyntax
+ if not rebindable_on
+ then return (HsVar std_name', emptyFVs)
+ else do usr_name <- lookupOccRn (mkRdrUnqual (nameOccName std_name'))
+ return (HsVar usr_name, unitFV usr_name)
+ -- Get the similarly named thing from the local environment
lookupSyntaxTable :: [Name] -- Standard names
-> RnM (SyntaxTable Name, FreeVars) -- See comments with HsExpr.ReboundNames
rnMatchGroup, makeMiniFixityEnv)
import HsSyn
import TcRnMonad
-import TcEnv ( thRnBrack )
+import TcEnv ( thRnBrack, getHetMetLevel )
import RnEnv
import RnTypes ( rnHsTypeFVs, rnSplice, checkTH,
mkOpFormRn, mkOpAppRn, mkNegAppRn, checkSectionPrec)
import BasicTypes ( FixityDirection(..) )
import PrelNames
+import Var ( TyVar, varName )
import Name
import NameSet
import RdrName
Variables. We look up the variable and return the resulting name.
\begin{code}
+
+-- during the renamer phase we only care about the length of the
+-- current HetMet level; the actual tyvars don't
+-- matter, so we use bottoms for them
+dummyTyVar :: TyVar
+dummyTyVar = error "tried to force RnExpr.dummyTyVar"
+
rnLExpr :: LHsExpr RdrName -> RnM (LHsExpr Name, FreeVars)
rnLExpr = wrapLocFstM rnExpr
mkNegAppRn e' neg_name `thenM` \ final_e ->
return (final_e, fv_e `plusFV` fv_neg)
+rnExpr (HsHetMetBrak c e)
+ = do { (e', fv_e) <- updLclEnv (\x -> x { tcl_hetMetLevel = dummyTyVar:(tcl_hetMetLevel x) }) $ rnLExpr e
+ ; return (HsHetMetBrak c e', fv_e)
+ }
+rnExpr (HsHetMetEsc c t e)
+ = do { (e', fv_e) <- updLclEnv (\x -> x { tcl_hetMetLevel = tail (tcl_hetMetLevel x) }) $ rnLExpr e
+ ; return (HsHetMetEsc c t e', fv_e)
+ }
+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)
+ }
+
+
+
------------------------------------------
-- Template Haskell extensions
-- Don't ifdef-GHCI them because we want to fail gracefully
; rebind <- xoptM Opt_RebindableSyntax
; if not rebind
then return (HsIf Nothing p' b1' b2', plusFVs [fvP, fvB1, fvB2])
- else do { c <- liftM HsVar (lookupOccRn (mkVarUnqual (fsLit "ifThenElse")))
+ else do { hetMetLevel <- getHetMetLevel
+ ; n <- lookupOccRn $ mkRdrUnqual $ setOccNameDepth (length hetMetLevel) (mkVarOccFS (fsLit "ifThenElse"))
+ ; c <- return $ HsVar n
; return (HsIf (Just c) p' b1' b2', plusFVs [fvP, fvB1, fvB2]) }}
rnExpr (HsType a)
import HsSyn
import Class ( FunDep )
-import TysWiredIn ( tupleTyCon, listTyCon, parrTyCon, charTyCon )
+import TysWiredIn ( tupleTyCon, listTyCon, parrTyCon, hetMetCodeTypeTyCon, charTyCon )
import Name ( Name, getName, isTyVarName )
import NameSet
import BasicTypes ( Boxity )
charTyCon_name = getName charTyCon
listTyCon_name = getName listTyCon
parrTyCon_name = getName parrTyCon
+hetMetCodeTypeTyCon_name :: Name
+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 (HsTupleTy _ tys) = extractHsTyNames_s tys
get (HsFunTy ty1 ty2) = getl ty1 `unionNameSets` getl ty2
get (HsPredTy p) = extractHsPredTyNames p
ty' <- rnLHsType doc ty
return (HsPArrTy ty')
+rnHsType doc (HsModalBoxType ecn ty) = do
+ ecn' <- lookupOccRn ecn
+ ty' <- rnLHsType doc ty
+ return (HsModalBoxType ecn' ty')
+
-- 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
tcLookupId, tcLookupTyVar, getScopedTyVarBinds,
getInLocalScope,
wrongThingErr, pprBinders,
+ getHetMetLevel,
tcExtendRecEnv, -- For knot-tying
tcExtendIdEnv1 :: Name -> TcId -> TcM a -> TcM a
tcExtendIdEnv1 name id thing_inside = tcExtendIdEnv2 [(name,id)] thing_inside
+getHetMetLevel :: TcM [TyVar]
+getHetMetLevel =
+ do { env <- getEnv
+ ; return $ case env of Env { env_lcl = e' } -> case e' of TcLclEnv { tcl_hetMetLevel = x } -> x
+ }
+
tcExtendIdEnv2 :: [(Name,TcId)] -> TcM a -> TcM a
-- Invariant: the TcIds are fully zonked (see tcExtendIdEnv above)
tcExtendIdEnv2 names_w_ids thing_inside
= do { env <- getLclEnv
- ; tc_extend_local_id_env env (thLevel (tcl_th_ctxt env)) names_w_ids thing_inside }
+ ; hetMetLevel <- getHetMetLevel
+ ; tc_extend_local_id_env env (thLevel (tcl_th_ctxt env)) hetMetLevel names_w_ids thing_inside }
+
tcExtendGhciEnv :: [TcId] -> TcM a -> TcM a
-- Used to bind Ids for GHCi identifiers bound earlier in the user interaction
-- GHCi has already compiled it to bytecode
tcExtendGhciEnv ids thing_inside
= do { env <- getLclEnv
- ; tc_extend_local_id_env env impLevel [(idName id, id) | id <- ids] thing_inside }
+ ; hetMetLevel <- getHetMetLevel
+ ; tc_extend_local_id_env env impLevel hetMetLevel [(idName id, id) | id <- ids] thing_inside }
tc_extend_local_id_env -- This is the guy who does the work
:: TcLclEnv
-> ThLevel
+ -> [TyVar]
-> [(Name,TcId)]
-> TcM a -> TcM a
-- Invariant: the TcIds are fully zonked. Reasons:
-- in the types, because instantiation does not look through such things
-- (c) The call to tyVarsOfTypes is ok without looking through refs
-tc_extend_local_id_env env th_lvl names_w_ids thing_inside
+tc_extend_local_id_env env th_lvl hetMetLevel names_w_ids thing_inside
= do { traceTc "env2" (ppr extra_env)
; gtvs' <- tcExtendGlobalTyVars (tcl_tyvars env) extra_global_tyvars
; let env' = env {tcl_env = le', tcl_tyvars = gtvs', tcl_rdr = rdr_env'}
where
extra_global_tyvars = tcTyVarsOfTypes [idType id | (_,id) <- names_w_ids]
extra_env = [ (name, ATcId { tct_id = id,
- tct_level = th_lvl })
+ tct_level = th_lvl,
+ tct_hetMetLevel = hetMetLevel
+ })
| (name,id) <- names_w_ids]
le' = extendNameEnvList (tcl_env env) extra_env
rdr_env' = extendLocalRdrEnvList (tcl_rdr env) [name | (name,_) <- names_w_ids]
import Name
import TyCon
import Type
+import TypeRep
import Coercion
import Var
import VarSet
%************************************************************************
\begin{code}
+
+updHetMetLevel :: ([TyVar] -> [TyVar]) -> TcM a -> TcM a
+updHetMetLevel f comp =
+ updEnv
+ (\oldenv -> let oldlev = (case oldenv of Env { env_lcl = e' } -> case e' of TcLclEnv { tcl_hetMetLevel = x } -> x)
+ in (oldenv { env_lcl = (env_lcl oldenv) { tcl_hetMetLevel = f oldlev } }))
+
+ comp
+
+addEscapes :: [TyVar] -> HsExpr Name -> HsExpr Name
+addEscapes [] e = e
+addEscapes (t:ts) e = HsHetMetEsc (TyVarTy t) placeHolderType (noLoc (addEscapes ts e))
+
+getIdLevel :: Name -> TcM [TyVar]
+getIdLevel name
+ = do { thing <- tcLookup name
+ ; case thing of
+ ATcId { tct_hetMetLevel = variable_hetMetLevel } -> return $ variable_hetMetLevel
+ _ -> return []
+ }
+
tcExpr :: HsExpr Name -> TcRhoType -> TcM (HsExpr TcId)
tcExpr e res_ty | debugIsOn && isSigmaTy res_ty -- Sanity check
= pprPanic "tcExpr: sigma" (ppr res_ty $$ ppr e)
tcExpr (HsVar name) res_ty = tcCheckId name res_ty
+tcExpr (HsHetMetBrak _ e) res_ty =
+ do { (coi, [inferred_name,elt_ty]) <- matchExpectedTyConApp hetMetCodeTypeTyCon res_ty
+ ; fresh_ec_name <- newFlexiTyVar liftedTypeKind
+ ; expr' <- updHetMetLevel (\old_lev -> (fresh_ec_name:old_lev))
+ $ tcPolyExpr e elt_ty
+ ; unifyType (TyVarTy fresh_ec_name) inferred_name
+ ; return $ mkHsWrapCoI coi (HsHetMetBrak (TyVarTy fresh_ec_name) expr') }
+tcExpr (HsHetMetEsc _ _ e) res_ty =
+ do { cur_level <- getHetMetLevel
+ ; expr' <- updHetMetLevel (\old_lev -> tail old_lev)
+ $ tcExpr (unLoc e) (mkTyConApp hetMetCodeTypeTyCon [(TyVarTy $ head cur_level),res_ty])
+ ; ty' <- zonkTcType res_ty
+ ; return $ mkHsWrapCoI (ACo res_ty) (HsHetMetEsc (TyVarTy $ head cur_level) ty' (noLoc expr')) }
+tcExpr (HsHetMetCSP _ e) res_ty =
+ do { cur_level <- getHetMetLevel
+ ; expr' <- updHetMetLevel (\old_lev -> tail old_lev)
+ $ tcExpr (unLoc e) res_ty
+ ; return $ mkHsWrapCoI (ACo res_ty) (HsHetMetCSP (TyVarTy $ head cur_level) (noLoc expr')) }
+
tcExpr (HsApp e1 e2) res_ty = tcApp e1 [e2] res_ty
tcExpr (HsLit lit) res_ty = do { let lit_ty = hsLitType lit
tcInferIdWithOrig :: CtOrigin -> Name -> TcM (HsExpr TcId, TcRhoType)
-- Look up an occurrence of an Id, and instantiate it (deeply)
-tcInferIdWithOrig orig id_name
- = do { id <- lookup_id
- ; (id_expr, id_rho) <- instantiateOuter orig id
- ; (wrap, rho) <- deeplyInstantiate orig id_rho
- ; return (mkHsWrap wrap id_expr, rho) }
+tcInferIdWithOrig orig id_name =
+ do { id_level <- getIdLevel id_name
+ ; cur_level <- getHetMetLevel
+ ; if (length id_level < length cur_level)
+ then do { (lhexp, tcrho) <-
+ tcInferRho (noLoc $ addEscapes (take ((length cur_level) - (length id_level)) cur_level) (HsVar id_name))
+ ; return (unLoc lhexp, tcrho)
+ }
+ else tcInferIdWithOrig' orig id_name
+ }
+
+tcInferIdWithOrig' orig id_name =
+ do { id <- lookup_id
+ ; (id_expr, id_rho) <- instantiateOuter orig id
+ ; (wrap, rho) <- deeplyInstantiate orig id_rho
+ ; return (mkHsWrap wrap id_expr, rho) }
where
lookup_id :: TcM TcId
lookup_id
= do { thing <- tcLookup id_name
; case thing of
- ATcId { tct_id = id, tct_level = lvl }
+ ATcId { tct_id = id, tct_level = lvl, tct_hetMetLevel = variable_hetMetLevel }
-> do { check_naughty id -- Note [Local record selectors]
; checkThLocalId id lvl
+ ; current_hetMetLevel <- getHetMetLevel
+ ; mapM
+ (\(name1,name2) -> unifyType (TyVarTy name1) (TyVarTy name2))
+ (zip variable_hetMetLevel current_hetMetLevel)
; return id }
AGlobal (AnId id)
- -> do { check_naughty id; return id }
- -- A global cannot possibly be ill-staged
+ -> do { check_naughty id
+ ; return id }
+ -- A global cannot possibly be ill-staged in Template Haskell
-- nor does it need the 'lifting' treatment
-- hence no checkTh stuff here
= zonkLExpr env e `thenM` \new_e ->
returnM (HsPar new_e)
+zonkExpr env (HsHetMetBrak c e)
+ = do c' <- zonkTcTypeToType env c
+ e' <- zonkLExpr env e
+ return (HsHetMetBrak c' e')
+
+zonkExpr env (HsHetMetEsc c t e)
+ = do c' <- zonkTcTypeToType env c
+ t' <- zonkTcTypeToType env t
+ e' <- zonkLExpr env e
+ return (HsHetMetEsc c' t' e')
+
+zonkExpr env (HsHetMetCSP c e)
+ = do c' <- zonkTcTypeToType env c
+ e' <- zonkLExpr env e
+ return (HsHetMetCSP c' e')
+
zonkExpr env (SectionL expr op)
= zonkLExpr env expr `thenM` \ new_expr ->
zonkLExpr env op `thenM` \ new_op ->
ty' <- kcLiftedType ty
return (HsPArrTy ty', liftedTypeKind)
+kc_hs_type (HsModalBoxType ecn ty) = do
+ ty' <- kcLiftedType ty
+ return (HsModalBoxType ecn ty', liftedTypeKind)
+
kc_hs_type (HsNumTy n)
= return (HsNumTy n, liftedTypeKind)
checkWiredInTyCon parrTyCon
return (mkPArrTy tau_ty)
+ds_type (HsModalBoxType ecn ty) = do
+ ecn' <- ds_app (HsTyVar ecn) []
+ tau_ty <- dsHsType ty
+ checkWiredInTyCon hetMetCodeTypeTyCon
+ return (mkHetMetCodeTypeTy (tcGetTyVar "totally bogus, dude" ecn') tau_ty)
+
+
ds_type (HsTupleTy boxity tys) = do
tau_tys <- dsHsTypes tys
checkWiredInTyCon tycon
tcl_tyvars = tvs_var,
tcl_lie = lie_var,
tcl_meta = meta_var,
- tcl_untch = initTyVarUnique
+ tcl_untch = initTyVarUnique,
+ tcl_hetMetLevel = []
} ;
} ;
-- We still need the unsullied global name env so that
-- we can look up record field names
+ tcl_hetMetLevel :: [TyVar], -- The current environment classifier level (list-of-names)
tcl_env :: TcTypeEnv, -- The local type environment: Ids and
-- TyVars defined in this module
| ATcId { -- Ids defined in this module; may not be fully zonked
tct_id :: TcId,
- tct_level :: ThLevel }
+ tct_level :: ThLevel,
+ tct_hetMetLevel :: [TyVar]
+ }
| ATyVar Name TcType -- The type to which the lexically scoped type vaiable
-- is currently refined. We only need the Name
ppr elt@(ATcId {}) = text "Identifier" <>
brackets (ppr (tct_id elt) <> dcolon
<> ppr (varType (tct_id elt)) <> comma
- <+> ppr (tct_level elt))
+ <+> ppr (tct_level elt)
+ <+> ppr (tct_hetMetLevel elt))
ppr (ATyVar tv _) = text "Type variable" <+> quotes (ppr tv)
ppr (AThing k) = text "AThing" <+> ppr k
| tc `hasKey` argTypeKindTyConKey = ptext (sLit "??")
ppr_tc_app p tc tys
+ | [ecvar,ty] <- tys, tc `hasKey` hetMetCodeTypeTyConKey
+ = ptext (sLit "<[") <> pprType ty <> ptext (sLit "]>@") <> ppr ecvar
| isTupleTyCon tc && tyConArity tc == length tys
= tupleParens (tupleTyConBoxity tc) (sep (punctuate comma (map pprType tys)))
| otherwise
projects / ghc-hetmet.git / commitdiff