From: Adam Megacz Date: Wed, 2 Mar 2011 21:35:00 +0000 (-0800) Subject: Initial checkin of HetMet / -XModalTypes modifications X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=34c8d0312071f7d0f4d221a997d3408c653ef9e5;hp=cb8fb4dc68b503474bd65c0a669d9018a3ce96fe Initial checkin of HetMet / -XModalTypes modifications --- diff --git a/compiler/basicTypes/Name.lhs b/compiler/basicTypes/Name.lhs index 70cf298..de8a3a3 100644 --- a/compiler/basicTypes/Name.lhs +++ b/compiler/basicTypes/Name.lhs @@ -64,6 +64,7 @@ module Name ( getSrcLoc, getSrcSpan, getOccString, pprInfixName, pprPrefixName, pprModulePrefix, + getNameDepth, setNameDepth, -- Re-export the OccName stuff module OccName @@ -111,6 +112,12 @@ data Name = Name { -- (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 diff --git a/compiler/basicTypes/OccName.lhs b/compiler/basicTypes/OccName.lhs index f02ae8d..c528acb 100644 --- a/compiler/basicTypes/OccName.lhs +++ b/compiler/basicTypes/OccName.lhs @@ -25,8 +25,8 @@ module OccName ( -- ** 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, @@ -114,7 +114,7 @@ import Data.Data %************************************************************************ \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 @@ -144,6 +144,7 @@ data NameSpace = VarName -- Variables, including "real" data constructors 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 @@ -155,8 +156,23 @@ dataName = DataName 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 @@ -172,27 +188,27 @@ isTvNameSpace _ = False 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} @@ -333,7 +349,7 @@ easy to build an OccEnv. \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 @@ -430,7 +446,7 @@ setOccNameSpace sp (OccName _ occ) = OccName sp occ isVarOcc, isTvOcc, isTcOcc, isDataOcc :: OccName -> Bool -isVarOcc (OccName VarName _) = True +isVarOcc (OccName (VarName _) _) = True isVarOcc _ = False isTvOcc (OccName TvName _) = True @@ -442,12 +458,12 @@ isTcOcc _ = False -- | /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 @@ -456,7 +472,7 @@ 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 @@ -467,7 +483,7 @@ 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! @@ -639,7 +655,7 @@ mkDFunOcc :: String -- ^ Typically the class and type glommed together e.g. @Or -- 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" @@ -678,7 +694,7 @@ guys never show up in error messages. What a hack. \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} @@ -814,21 +830,22 @@ isSymbolASCII c = c `elem` "!#$%&*+./<=>?@\\^|~-" \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 diff --git a/compiler/basicTypes/Unique.lhs b/compiler/basicTypes/Unique.lhs index 4180604..396feea 100644 --- a/compiler/basicTypes/Unique.lhs +++ b/compiler/basicTypes/Unique.lhs @@ -369,9 +369,14 @@ mkRegSubUnique = mkUnique 'S' 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)) diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs index 7954444..4e9ef8c 100644 --- a/compiler/cmm/CLabel.hs +++ b/compiler/cmm/CLabel.hs @@ -277,6 +277,10 @@ data ForeignLabelSource 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. @@ -1013,7 +1017,7 @@ pprCLbl ModuleRegdLabel 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 @@ -1034,8 +1038,8 @@ pprCLbl (HpcTicksLabel mod) 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") diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs index 60dec30..7d0be3f 100644 --- a/compiler/deSugar/Desugar.lhs +++ b/compiler/deSugar/Desugar.lhs @@ -8,6 +8,7 @@ The Desugarer: turning HsSyn into Core. \begin{code} module Desugar ( deSugar, deSugarExpr ) where +import TysWiredIn (unitDataConId) import DynFlags import StaticFlags import HscTypes @@ -40,6 +41,8 @@ import MonadUtils import OrdList import Data.List import Data.IORef +import DsHetMet +import Control.Exception ( catch, ErrorCall, Exception(..) ) \end{code} %************************************************************************ @@ -134,7 +137,25 @@ deSugar hsc_env ; (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 @@ -222,7 +243,7 @@ deSugarExpr :: HscEnv 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 $ @@ -232,8 +253,10 @@ deSugarExpr hsc_env this_mod rdr_env type_env tc_expr = do 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} diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index 4084310..9d1edc7 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@ -216,6 +216,16 @@ 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 (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)) diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs index 4d0a148..2c2d7f2 100644 --- a/compiler/deSugar/DsForeign.lhs +++ b/compiler/deSugar/DsForeign.lhs @@ -525,7 +525,7 @@ mkFExportCBits c_nm maybe_target arg_htys res_hty is_IO_res_ty cc 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 @@ -550,9 +550,8 @@ mkFExportCBits c_nm maybe_target arg_htys res_hty is_IO_res_ty cc 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 $$ @@ -590,6 +589,10 @@ mkFExportCBits c_nm maybe_target arg_htys res_hty is_IO_res_ty cc , 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 = @@ -606,11 +609,10 @@ 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) diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs index 06616f1..b7fe6fc 100644 --- a/compiler/hsSyn/HsExpr.lhs +++ b/compiler/hsSyn/HsExpr.lhs @@ -223,6 +223,13 @@ data HsExpr id (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 @@ -353,6 +360,9 @@ 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 (HsCoreAnn s e) = vcat [ptext (sLit "HsCoreAnn") <+> ftext s, ppr_lexpr e] diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs index 38608a4..def44c5 100644 --- a/compiler/hsSyn/HsTypes.lhs +++ b/compiler/hsSyn/HsTypes.lhs @@ -155,6 +155,8 @@ data HsType name | 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) @@ -439,6 +441,7 @@ 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 _ (HsPredTy pred) = ppr pred ppr_mono_ty _ (HsNumTy n) = integer n -- generics only ppr_mono_ty _ (HsSpliceTy s _ _) = pprSplice s @@ -476,6 +479,10 @@ ppr_fun_ty ctxt_prec ty1 ty2 -------------------------- 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} diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 9147a92..a94a3f4 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -308,6 +308,7 @@ data ExtensionFlag | 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 @@ -1586,6 +1587,7 @@ xFlags = [ 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 ), @@ -1675,6 +1677,11 @@ impliedFlags , (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) diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 5e65356..872c7aa 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -55,6 +55,7 @@ module Lexer ( getLexState, popLexState, pushLexState, extension, bangPatEnabled, datatypeContextsEnabled, addWarning, + incrBracketDepth, decrBracketDepth, getParserBrakDepth, lexTokenStream ) where @@ -325,6 +326,15 @@ $tab+ { warn Opt_WarnTabs (text "Warning: Tab character") } } <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 } } @@ -570,6 +580,13 @@ data Token | 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 @@ -1523,7 +1540,8 @@ data PState = PState { 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 @@ -1590,6 +1608,13 @@ setExts f = P $ \s -> POk s{ extsBitmap = f (extsBitmap s) } () 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 @@ -1798,6 +1823,8 @@ relaxedLayoutBit :: Int relaxedLayoutBit = 24 nondecreasingIndentationBit :: Int nondecreasingIndentationBit = 25 +hetMetBit :: Int +hetMetBit = 31 always :: Int -> Bool always _ = True @@ -1807,6 +1834,8 @@ parrEnabled :: Int -> Bool 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 @@ -1868,13 +1897,15 @@ mkPState flags buf loc = 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 diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index a0cc964..3958b9c 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -39,7 +39,7 @@ import Type ( funTyCon ) 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, @@ -304,6 +304,11 @@ incorrect. '#)' { L _ ITcubxparen } '(|' { L _ IToparenbar } '|)' { L _ ITcparenbar } + '<[' { L _ ITopenBrak } + ']>' { L _ ITcloseBrak } + '~~' { L _ ITescape } + '~~$' { L _ ITescapeDollar } + '%%' { L _ ITdoublePercent } ';' { L _ ITsemi } ',' { L _ ITcomma } '`' { L _ ITbackquote } @@ -1011,6 +1016,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 ':]' { LL $ HsPArrTy $2 } | '(' ctype ')' { LL $ HsParTy $2 } | '(' ctype '::' kind ')' { LL $ HsKindSig $2 (unLoc $4) } @@ -1214,6 +1220,7 @@ decl :: { Located (OrdList (LHsDecl RdrName)) } | 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) } @@ -1231,6 +1238,7 @@ sigdecl :: { Located (OrdList (LHsDecl 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)))) @@ -1255,6 +1263,10 @@ quasiquote :: { Located (HsQuasiQuote RdrName) } ; 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 } @@ -1262,6 +1274,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) } infixexp :: { LHsExpr RdrName } : exp10 { $1 } @@ -1392,6 +1405,11 @@ aexp2 :: { LHsExpr RdrName } -- 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 -} { [] } @@ -1823,7 +1841,7 @@ qvarid :: { Located RdrName } | 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") } @@ -1848,9 +1866,10 @@ varsym :: { Located RdrName } | '-' { 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 diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 47abf23..ed11fd8 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 + 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 @@ -804,6 +805,8 @@ checkValSig :: 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) diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index 4d3c446..0f027c5 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -211,6 +211,11 @@ basicKnownKeyNames -- 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 @@ -243,6 +248,7 @@ gHC_PRIM, gHC_TYPES, gHC_UNIT, gHC_ORDERING, gHC_GENERICS, 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, @@ -267,6 +273,7 @@ gHC_INTEGER = mkIntegerModule (fsLit "GHC.Integer") 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") @@ -755,6 +762,16 @@ toPName = varQual gHC_PARR (fsLit "toP") toPIdKey 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 @@ -1066,6 +1083,10 @@ opaqueTyConKey = mkPreludeTyConUnique 133 stringTyConKey :: Unique stringTyConKey = mkPreludeTyConUnique 134 +-- Heterogeneous Metaprogramming code type constructor +hetMetCodeTypeTyConKey :: Unique +hetMetCodeTypeTyConKey = mkPreludeTyConUnique 135 + ---------------- Template Haskell ------------------- -- USES TyConUniques 100-129 ----------------------------------------------------- @@ -1113,6 +1134,10 @@ parrDataConKey = mkPreludeDataConUnique 24 leftDataConKey, rightDataConKey :: Unique leftDataConKey = mkPreludeDataConUnique 25 rightDataConKey = mkPreludeDataConUnique 26 + +-- Data constructor for Heterogeneous Metaprogramming code types +hetMetCodeTypeDataConKey :: Unique +hetMetCodeTypeDataConKey = mkPreludeDataConUnique 27 \end{code} %************************************************************************ @@ -1305,6 +1330,16 @@ realToFracIdKey = mkPreludeMiscIdUnique 128 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 ----------------------------------------------------- diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs index f77b272..aaef164 100644 --- a/compiler/prelude/TysWiredIn.lhs +++ b/compiler/prelude/TysWiredIn.lhs @@ -47,6 +47,12 @@ module TysWiredIn ( -- * Unit unitTy, + -- * Heterogeneous Metaprogramming + mkHetMetCodeTypeTy, + hetMetCodeTypeTyConName, + hetMetCodeTypeTyCon, isHetMetCodeTypeTyCon, + hetMetCodeTypeTyCon_RDR, + -- * Parallel arrays mkPArrTy, parrTyCon, parrFakeCon, isPArrTyCon, isPArrFakeCon, @@ -124,6 +130,7 @@ wiredInTyCons = [ unitTyCon -- Not treated like other tuples, because , intTyCon , listTyCon , parrTyCon + , hetMetCodeTypeTyCon , unsafeCoercionTyCon , symCoercionTyCon , transCoercionTyCon @@ -172,8 +179,14 @@ parrTyConName, parrDataConName :: Name 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 @@ -183,6 +196,7 @@ intDataCon_RDR = nameRdrName intDataConName listTyCon_RDR = nameRdrName listTyConName consDataCon_RDR = nameRdrName consDataConName parrTyCon_RDR = nameRdrName parrTyConName +hetMetCodeTypeTyCon_RDR = nameRdrName hetMetCodeTypeTyConName \end{code} @@ -610,3 +624,26 @@ isPArrFakeCon dcon = dcon == parrFakeCon (dataConSourceArity dcon) \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} diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index 97f4ab3..a5aa5e1 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -36,6 +36,7 @@ module RnEnv ( import LoadIface ( loadInterfaceForName, loadSrcInterface ) import IfaceEnv ( lookupOrig, newGlobalBinder, newIPName ) +import TcEnv ( getHetMetLevel ) import HsSyn import RdrHsSyn ( extractHsTyRdrTyVars ) import RdrName @@ -757,14 +758,14 @@ checks the type of the user thing against the type of the standard thing. 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 diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs index 6d425d0..3a288bb 100644 --- a/compiler/rename/RnExpr.lhs +++ b/compiler/rename/RnExpr.lhs @@ -25,7 +25,7 @@ import RnBinds ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS, rnMatchGroup, makeMiniFixityEnv) import HsSyn import TcRnMonad -import TcEnv ( thRnBrack ) +import TcEnv ( thRnBrack, getHetMetLevel ) import RnEnv import RnTypes ( rnHsTypeFVs, rnSplice, checkTH, mkOpFormRn, mkOpAppRn, mkNegAppRn, checkSectionPrec) @@ -34,6 +34,7 @@ import DynFlags import BasicTypes ( FixityDirection(..) ) import PrelNames +import Var ( TyVar, varName ) import Name import NameSet import RdrName @@ -84,6 +85,13 @@ rnExprs ls = rnExprs' ls emptyUniqSet 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 @@ -157,6 +165,21 @@ rnExpr (NegApp e _) 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 @@ -273,7 +296,9 @@ rnExpr (HsIf _ p b1 b2) ; 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) diff --git a/compiler/rename/RnHsSyn.lhs b/compiler/rename/RnHsSyn.lhs index 9226cb4..535aca2 100644 --- a/compiler/rename/RnHsSyn.lhs +++ b/compiler/rename/RnHsSyn.lhs @@ -20,7 +20,7 @@ module RnHsSyn( 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 ) @@ -40,6 +40,8 @@ charTyCon_name, listTyCon_name, parrTyCon_name :: Name 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) @@ -59,6 +61,7 @@ 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 (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 138ffa2..8405e8c 100644 --- a/compiler/rename/RnTypes.lhs +++ b/compiler/rename/RnTypes.lhs @@ -170,6 +170,11 @@ rnHsType doc (HsPArrTy ty) = do 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 diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index 354e4b2..c6789f4 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -29,6 +29,7 @@ module TcEnv( tcLookupId, tcLookupTyVar, getScopedTyVarBinds, getInLocalScope, wrongThingErr, pprBinders, + getHetMetLevel, tcExtendRecEnv, -- For knot-tying @@ -405,11 +406,19 @@ tcExtendIdEnv ids thing_inside = tcExtendIdEnv2 [(idName id, id) | id <- ids] th 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 @@ -418,11 +427,13 @@ tcExtendGhciEnv :: [TcId] -> TcM a -> TcM a -- 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: @@ -432,7 +443,7 @@ tc_extend_local_id_env -- This is the guy who does the work -- 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'} @@ -440,7 +451,9 @@ tc_extend_local_id_env env th_lvl names_w_ids thing_inside 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] diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index 3f5a258..a068e53 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -42,6 +42,7 @@ import DataCon import Name import TyCon import Type +import TypeRep import Coercion import Var import VarSet @@ -136,12 +137,52 @@ tcInfExpr e = tcInfer (tcExpr e) %************************************************************************ \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 @@ -960,24 +1001,40 @@ tcInferId n = tcInferIdWithOrig (OccurrenceOf n) n 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 diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index b7b572f..4f2eda7 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -542,6 +542,22 @@ zonkExpr env (HsPar e) = 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 -> diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index 71eb55e..f7f3da6 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -365,6 +365,10 @@ kc_hs_type (HsPArrTy ty) = do 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) @@ -589,6 +593,13 @@ ds_type (HsPArrTy ty) = do 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 diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index 37e1166..1d5a3f7 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -134,7 +134,8 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this tcl_tyvars = tvs_var, tcl_lie = lie_var, tcl_meta = meta_var, - tcl_untch = initTyVarUnique + tcl_untch = initTyVarUnique, + tcl_hetMetLevel = [] } ; } ; diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index 96ca3b3..eee07e8 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -372,6 +372,7 @@ data TcLclEnv -- Changes as we move inside an expression -- 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 @@ -508,7 +509,9 @@ data TcTyThing | 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 @@ -523,7 +526,8 @@ instance Outputable TcTyThing where -- Debugging only 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 diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs index 8551409..aa1f941 100644 --- a/compiler/types/TypeRep.lhs +++ b/compiler/types/TypeRep.lhs @@ -543,6 +543,8 @@ ppr_tc_app _ tc [ty] | 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