From: Adam Megacz Date: Tue, 31 May 2011 02:34:22 +0000 (-0700) Subject: merge GHC HEAD X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=b2524b3960999fffdb3767900f58825903f6560f;hp=-c merge GHC HEAD --- b2524b3960999fffdb3767900f58825903f6560f diff --combined compiler/basicTypes/OccName.lhs index bae5419,446d11a..5b5f620 --- a/compiler/basicTypes/OccName.lhs +++ b/compiler/basicTypes/OccName.lhs @@@ -25,8 -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, @@@ -48,11 -48,12 +48,12 @@@ -- ** Derived 'OccName's isDerivedOccName, - mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, + mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkGenDefMethodOcc, mkDerivedTyConOcc, mkNewTyCoOcc, mkClassOpAuxOcc, mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc, mkClassTyConOcc, mkClassDataConOcc, mkDictOcc, mkIPOcc, mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2, + mkGenD, mkGenR, mkGenRCo, mkGenC, mkGenS, mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, mkSuperDictSelOcc, mkLocalOcc, mkMethodOcc, mkInstTyTcOcc, mkInstTyCoOcc, mkEqPredCoOcc, @@@ -114,7 -115,7 +115,7 @@@ import Data.Dat %************************************************************************ \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,7 -145,6 +145,7 @@@ 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 @@@ -156,23 -156,8 +157,23 @@@ dataName = DataNam 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 @@@ -188,27 -173,27 +189,27 @@@ isTvNameSpace _ = Fals 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} @@@ -348,7 -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 @@@ -445,7 -430,7 +446,7 @@@ setOccNameSpace sp (OccName _ occ) = Oc isVarOcc, isTvOcc, isTcOcc, isDataOcc :: OccName -> Bool -isVarOcc (OccName VarName _) = True +isVarOcc (OccName (VarName _) _) = True isVarOcc _ = False isTvOcc (OccName TvName _) = True @@@ -457,12 -442,12 +458,12 @@@ isTcOcc _ = Fals -- | /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 @@@ -471,7 -456,7 +472,7 @@@ -- 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 @@@ -482,7 -467,7 +483,7 @@@ 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! @@@ -555,9 -540,10 +556,10 @@@ isDerivedOccName occ \end{code} \begin{code} - mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkDerivedTyConOcc, - mkClassTyConOcc, mkClassDataConOcc, mkDictOcc, mkIPOcc, - mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2, + mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkGenDefMethodOcc, + mkDerivedTyConOcc, mkClassTyConOcc, mkClassDataConOcc, mkDictOcc, + mkIPOcc, mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2, + mkGenD, mkGenR, mkGenRCo, mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, mkNewTyCoOcc, mkInstTyCoOcc, mkEqPredCoOcc, mkClassOpAuxOcc, mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc, @@@ -569,6 -555,7 +571,7 @@@ mkDataConWrapperOcc = mk_simple_deriv varName "$W" mkWorkerOcc = mk_simple_deriv varName "$w" mkDefaultMethodOcc = mk_simple_deriv varName "$dm" + mkGenDefMethodOcc = mk_simple_deriv varName "$gdm" mkClassOpAuxOcc = mk_simple_deriv varName "$c" mkDerivedTyConOcc = mk_simple_deriv tcName ":" -- The : prefix makes sure it classifies mkClassTyConOcc = mk_simple_deriv tcName "T:" -- as a tycon/datacon @@@ -587,10 -574,23 +590,23 @@@ mkCon2TagOcc = mk_simple_deriv v mkTag2ConOcc = mk_simple_deriv varName "$tag2con_" mkMaxTagOcc = mk_simple_deriv varName "$maxtag_" - -- Generic derivable classes + -- Generic derivable classes (old) mkGenOcc1 = mk_simple_deriv varName "$gfrom" mkGenOcc2 = mk_simple_deriv varName "$gto" + -- Generic deriving mechanism (new) + mkGenD = mk_simple_deriv tcName "D1" + + mkGenC :: OccName -> Int -> OccName + mkGenC occ m = mk_deriv tcName ("C1_" ++ show m) (occNameString occ) + + mkGenS :: OccName -> Int -> Int -> OccName + mkGenS occ m n = mk_deriv tcName ("S1_" ++ show m ++ "_" ++ show n) + (occNameString occ) + + mkGenR = mk_simple_deriv tcName "Rep_" + mkGenRCo = mk_simple_deriv tcName "CoRep_" + -- data T = MkT ... deriving( Data ) needs defintions for -- $tT :: Data.Generics.Basics.DataType -- $cMkT :: Data.Generics.Basics.Constr @@@ -654,7 -654,7 +670,7 @@@ mkDFunOcc :: String -- ^ Typically th -- 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" @@@ -693,7 -693,7 +709,7 @@@ guys never show up in error messages. \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} @@@ -829,22 -829,21 +845,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 --combined compiler/cmm/CLabel.hs index a7dabc6,3451c7d..1ba1126 --- a/compiler/cmm/CLabel.hs +++ b/compiler/cmm/CLabel.hs @@@ -101,7 -101,7 +101,7 @@@ module CLabel hasCAF, infoLblToEntryLbl, entryLblToInfoLbl, cvtToClosureLbl, cvtToSRTLbl, needsCDecl, isAsmTemp, maybeAsmTemp, externallyVisibleCLabel, - isMathFun, isCas, + isMathFun, isCFunctionLabel, isGcPtrLabel, labelDynamic, pprCLabel @@@ -254,10 -254,6 +254,10 @@@ data ForeignLabelSourc 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. @@@ -594,14 -590,6 +594,6 @@@ maybeAsmTemp (AsmTempLabel uq) = Jus maybeAsmTemp _ = Nothing - -- | Check whether a label corresponds to our cas function. - -- We #include the prototype for this, so we need to avoid - -- generating out own C prototypes. - isCas :: CLabel -> Bool - isCas (CmmLabel pkgId fn _) = pkgId == rtsPackageId && fn == fsLit "cas" - isCas _ = False - - -- | Check whether a label corresponds to a C function that has -- a prototype in a system header somehere, or is built-in -- to the C compiler. For these labels we avoid generating our @@@ -862,8 -850,8 +854,8 @@@ instance Outputable CLabel wher pprCLabel :: CLabel -> SDoc - #if ! OMIT_NATIVE_CODEGEN pprCLabel (AsmTempLabel u) + | cGhcWithNativeCodeGen == "YES" = getPprStyle $ \ sty -> if asmStyle sty then ptext asmTempLabelPrefix <> pprUnique u @@@ -871,23 -859,22 +863,22 @@@ char '_' <> pprUnique u pprCLabel (DynamicLinkerLabel info lbl) + | cGhcWithNativeCodeGen == "YES" = pprDynamicLinkerAsmLabel info lbl pprCLabel PicBaseLabel + | cGhcWithNativeCodeGen == "YES" = ptext (sLit "1b") pprCLabel (DeadStripPreventer lbl) + | cGhcWithNativeCodeGen == "YES" = pprCLabel lbl <> ptext (sLit "_dsp") - #endif - pprCLabel lbl = - #if ! OMIT_NATIVE_CODEGEN - getPprStyle $ \ sty -> - if asmStyle sty then - maybe_underscore (pprAsmCLbl lbl) - else - #endif - pprCLbl lbl + pprCLabel lbl + = getPprStyle $ \ sty -> + if cGhcWithNativeCodeGen == "YES" && asmStyle sty + then maybe_underscore (pprAsmCLbl lbl) + else pprCLbl lbl maybe_underscore doc | underscorePrefix = pp_cSEP <> doc @@@ -977,7 -964,7 +968,7 @@@ pprCLbl (RtsLabel (RtsSlowTickyCtr pat) 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 @@@ -988,8 -975,8 +979,8 @@@ pprCLbl (PlainModuleInitLabel mod pprCLbl (HpcTicksLabel mod) = ptext (sLit "_hpc_tickboxes_") <> ppr mod <> ptext (sLit "_hpc") -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 --combined compiler/deSugar/Desugar.lhs index 0e7c032,7b008e9..b2131ca --- a/compiler/deSugar/Desugar.lhs +++ b/compiler/deSugar/Desugar.lhs @@@ -18,7 -18,6 +18,7 @@@ import I import Name import CoreSyn import CoreSubst +import CoqPass ( coqPassCoreToString, coqPassCoreToCore ) import PprCore import DsMonad import DsExpr @@@ -41,12 -40,6 +41,12 @@@ import MonadUtil import OrdList import Data.List import Data.IORef +import PrelNames +import UniqSupply +import UniqFM +import CoreFVs +import Type +import Coercion \end{code} %************************************************************************ @@@ -56,7 -49,6 +56,7 @@@ %************************************************************************ \begin{code} + -- | Main entry point to the desugarer. deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages, Maybe ModGuts) -- Can modify PCS by faulting in more declarations @@@ -97,32 -89,7 +97,32 @@@ deSugar hsc_en <- case target of HscNothing -> return (emptyMessages, - Just ([], nilOL, [], [], NoStubs, hpcInfo, emptyModBreaks)) + Just ([], nilOL, [], [], NoStubs, hpcInfo, emptyModBreaks, undefined, undefined + , undefined + , undefined + , undefined + , undefined + , undefined + , undefined + , undefined + , undefined + , undefined + , undefined + , undefined + , undefined + , undefined + , undefined + , undefined + , undefined + , undefined + , undefined + , undefined + , undefined + , undefined + , undefined + , undefined + , undefined + )) _ -> do (binds_cvr,ds_hpc_info, modBreaks) <- if (opt_Hpc @@@ -138,32 -105,6 +138,32 @@@ ; (ds_fords, foreign_prs) <- dsForeigns fords ; ds_rules <- mapMaybeM dsRule rules ; ds_vects <- mapM dsVect vects + ; hetmet_brak <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_brak_name else return undefined + ; hetmet_esc <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_esc_name else return undefined + ; hetmet_flatten <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_flatten_name else return undefined + ; hetmet_unflatten <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_unflatten_name else return undefined + ; hetmet_flattened_id <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_flattened_id_name else return undefined + ; hetmet_PGArrow <- if dopt Opt_F_coqpass dflags then dsLookupTyCon hetmet_PGArrow_name else return undefined + ; hetmet_PGArrow_unit <- if dopt Opt_F_coqpass dflags then dsLookupTyCon hetmet_PGArrow_unit_name else return undefined + ; hetmet_PGArrow_tensor <- if dopt Opt_F_coqpass dflags then dsLookupTyCon hetmet_PGArrow_tensor_name else return undefined + ; hetmet_PGArrow_exponent <- if dopt Opt_F_coqpass dflags then dsLookupTyCon hetmet_PGArrow_exponent_name else return undefined + ; hetmet_pga_id <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_id_name else return undefined + ; hetmet_pga_comp <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_comp_name else return undefined + ; hetmet_pga_first <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_first_name else return undefined + ; hetmet_pga_second <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_second_name else return undefined + ; hetmet_pga_cancell <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_cancell_name else return undefined + ; hetmet_pga_cancelr <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_cancelr_name else return undefined + ; hetmet_pga_uncancell <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_uncancell_name else return undefined + ; hetmet_pga_uncancelr <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_uncancelr_name else return undefined + ; hetmet_pga_assoc <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_assoc_name else return undefined + ; hetmet_pga_unassoc <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_unassoc_name else return undefined + ; hetmet_pga_copy <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_copy_name else return undefined + ; hetmet_pga_drop <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_drop_name else return undefined + ; hetmet_pga_swap <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_swap_name else return undefined + ; hetmet_pga_applyl <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_applyl_name else return undefined + ; hetmet_pga_applyr <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_applyr_name else return undefined + ; hetmet_pga_curryl <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_curryl_name else return undefined + ; hetmet_pga_curryr <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_curryr_name else return undefined ; let hpc_init | opt_Hpc = hpcInitCode mod ds_hpc_info | otherwise = empty @@@ -171,61 -112,11 +171,61 @@@ , foreign_prs `appOL` core_prs `appOL` spec_prs , spec_rules ++ ds_rules, ds_vects , ds_fords `appendStubC` hpc_init - , ds_hpc_info, modBreaks) } + , ds_hpc_info, modBreaks, hetmet_brak, hetmet_esc + , hetmet_flatten + , hetmet_unflatten + , hetmet_flattened_id + , hetmet_PGArrow + , hetmet_PGArrow_unit + , hetmet_PGArrow_tensor + , hetmet_PGArrow_exponent + , hetmet_pga_id + , hetmet_pga_comp + , hetmet_pga_first + , hetmet_pga_second + , hetmet_pga_cancell + , hetmet_pga_cancelr + , hetmet_pga_uncancell + , hetmet_pga_uncancelr + , hetmet_pga_assoc + , hetmet_pga_unassoc + , hetmet_pga_copy + , hetmet_pga_drop + , hetmet_pga_swap + , hetmet_pga_applyl + , hetmet_pga_applyr + , hetmet_pga_curryl + , hetmet_pga_curryr + ) } ; case mb_res of { Nothing -> return (msgs, Nothing) ; - Just (ds_ev_binds, all_prs, all_rules, ds_vects, ds_fords,ds_hpc_info, modBreaks) -> do + Just (ds_ev_binds, all_prs, all_rules, ds_vects, ds_fords,ds_hpc_info, modBreaks + , hetmet_brak, hetmet_esc + , hetmet_flatten + , hetmet_unflatten + , hetmet_flattened_id + , hetmet_PGArrow + , hetmet_PGArrow_unit + , hetmet_PGArrow_tensor + , hetmet_PGArrow_exponent + , hetmet_pga_id + , hetmet_pga_comp + , hetmet_pga_first + , hetmet_pga_second + , hetmet_pga_cancell + , hetmet_pga_cancelr + , hetmet_pga_uncancell + , hetmet_pga_uncancelr + , hetmet_pga_assoc + , hetmet_pga_unassoc + , hetmet_pga_copy + , hetmet_pga_drop + , hetmet_pga_swap + , hetmet_pga_applyl + , hetmet_pga_applyr + , hetmet_pga_curryl + , hetmet_pga_curryr) -> do { -- Add export flags to bindings keep_alive <- readIORef keep_var @@@ -234,7 -125,7 +234,7 @@@ final_prs = addExportFlagsAndRules target export_set keep_alive rules_for_locals (fromOL all_prs) - final_pgm = combineEvBinds ds_ev_binds final_prs + final_pgm = simplifyBinds $ combineEvBinds ds_ev_binds final_prs -- Notice that we put the whole lot in a big Rec, even the foreign binds -- When compiling PrelFloat, which defines data Float = F# Float# -- we want F# to be in scope in the foreign marshalling code! @@@ -246,59 -137,11 +246,59 @@@ (vcat [ pprCoreBindings final_pgm , pprRules rules_for_imps ]) - ; (ds_binds, ds_rules_for_imps) <- simpleOptPgm dflags final_pgm rules_for_imps + ; (final_pgm', rules_for_imps') <- if dopt Opt_F_simpleopt_before_flatten dflags + then simpleOptPgm dflags final_pgm rules_for_imps + else return (final_pgm, rules_for_imps) + + ; ds_binds <- if dopt Opt_F_coqpass dflags + then do { us <- mkSplitUniqSupply '~' + ; let do_flatten = dopt Opt_F_flatten dflags + ; let do_skolemize = dopt Opt_F_skolemize dflags + ; return (coqPassCoreToCore + do_flatten + do_skolemize + hetmet_brak + hetmet_esc + hetmet_flatten + hetmet_unflatten + hetmet_flattened_id + us + final_pgm' + hetmet_PGArrow + hetmet_PGArrow_unit + hetmet_PGArrow_tensor + hetmet_PGArrow_exponent + hetmet_pga_id + hetmet_pga_comp + hetmet_pga_first + hetmet_pga_second + hetmet_pga_cancell + hetmet_pga_cancelr + hetmet_pga_uncancell + hetmet_pga_uncancelr + hetmet_pga_assoc + hetmet_pga_unassoc + hetmet_pga_copy + hetmet_pga_drop + hetmet_pga_swap + hetmet_pga_applyl + hetmet_pga_applyr + hetmet_pga_curryl + hetmet_pga_curryr) + } + else return final_pgm + + ; (ds_binds', ds_rules_for_imps) <- if dopt Opt_F_simpleopt_before_flatten dflags + then return (ds_binds, rules_for_imps') + else simpleOptPgm dflags ds_binds rules_for_imps' -- The simpleOptPgm gets rid of type -- bindings plus any stupid dead code - ; endPass dflags CoreDesugar ds_binds ds_rules_for_imps + ; dumpIfSet_dyn dflags Opt_D_dump_proofs "Coq Pass Output" $ text $ coqPassCoreToString ds_binds' + + ; dumpIfSet_dyn dflags Opt_D_coqpass "After Coq Pass" (text $ showSDoc $ pprCoreBindings ds_binds') + + ; endPass dflags CoreDesugar ds_binds' ds_rules_for_imps ; let used_names = mkUsedNames tcg_env ; deps <- mkDependencies tcg_env @@@ -320,7 -163,7 +320,7 @@@ mg_inst_env = inst_env, mg_fam_inst_env = fam_inst_env, mg_rules = ds_rules_for_imps, - mg_binds = ds_binds, + mg_binds = ds_binds', mg_foreign = ds_fords, mg_hpc_info = ds_hpc_info, mg_modBreaks = modBreaks, @@@ -535,6 -378,8 +535,8 @@@ switching off EnableRewriteRules. See That keeps the desugaring of list comprehensions simple too. + + Nor do we want to warn of conversion identities on the LHS; the rule is precisly to optimise them: {-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-} @@@ -561,35 -406,3 +563,35 @@@ dsVect (L loc (HsVect v rhs) -- ; return $ Vect v (Just rhs') -- } \end{code} + + + +\begin{code} +-- +-- Simplification routines run before the flattener. We can't use +-- simpleOptPgm -- it doesn't preserve the order of subexpressions or +-- let-binding groups. +-- +simplify :: Expr CoreBndr -> Expr CoreBndr +simplify (Var v) = Var v +simplify (App e1 e2) = App (simplify e1) (simplify e2) +simplify (Lit lit) = Lit lit +simplify (Note note e) = Note note (simplify e) +simplify (Cast e co) = if tcEqType (fst $ coercionKind co) (snd $ coercionKind co) + then simplify e + else Cast (simplify e) co +simplify (Lam v e) = Lam v (simplify e) +simplify (Type t) = Type t +simplify (Case e b ty as) = Case (simplify e) b ty (map (\(a,b,e) -> (a,b,simplify e)) as) +simplify (Let bind body) = foldr Let (simplify body) (simplifyBind bind) + +simplifyBind :: Bind CoreBndr -> [Bind CoreBndr] +simplifyBind (NonRec b e) = [NonRec b (simplify e)] +simplifyBind (Rec []) = [] +simplifyBind (Rec (rbs@((b,e):rbs'))) = + if or $ map (\x -> elemUFM x (exprFreeIds e)) (map fst rbs) + then [Rec (map (\(v,e) -> (v,simplify e)) rbs)] + else (NonRec b (simplify e)):(simplifyBind $ Rec rbs') + +simplifyBinds = concatMap simplifyBind - \end{code} ++\end{code} diff --combined compiler/deSugar/DsExpr.lhs index 5b566a0,e33b113..2ac19ce --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@@ -49,8 -49,8 +49,8 @@@ import DynFlag import StaticFlags import CostCentre import Id - import Var import VarSet + import VarEnv import DataCon import TysWiredIn import BasicTypes @@@ -216,16 -216,6 +216,16 @@@ dsLExpr (L loc e) = putSrcSpanDs loc $ 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)) @@@ -335,26 -325,12 +335,12 @@@ dsExpr (HsLet binds body) = d -- We need the `ListComp' form to use `deListComp' (rather than the "do" form) -- because the interpretation of `stmts' depends on what sort of thing it is. -- - dsExpr (HsDo ListComp stmts body result_ty) - = -- Special case for list comprehensions - dsListComp stmts body elt_ty - where - [elt_ty] = tcTyConAppArgs result_ty - - dsExpr (HsDo DoExpr stmts body result_ty) - = dsDo stmts body result_ty - - dsExpr (HsDo GhciStmt stmts body result_ty) - = dsDo stmts body result_ty - - dsExpr (HsDo MDoExpr stmts body result_ty) - = dsDo stmts body result_ty - - dsExpr (HsDo PArrComp stmts body result_ty) - = -- Special case for array comprehensions - dsPArrComp (map unLoc stmts) body elt_ty - where - [elt_ty] = tcTyConAppArgs result_ty + dsExpr (HsDo ListComp stmts res_ty) = dsListComp stmts res_ty + dsExpr (HsDo PArrComp stmts _) = dsPArrComp (map unLoc stmts) + dsExpr (HsDo DoExpr stmts _) = dsDo stmts + dsExpr (HsDo GhciStmt stmts _) = dsDo stmts + dsExpr (HsDo MDoExpr stmts _) = dsDo stmts + dsExpr (HsDo MonadComp stmts _) = dsMonadComp stmts dsExpr (HsIf mb_fun guard_expr then_expr else_expr) = do { pred <- dsLExpr guard_expr @@@ -537,12 -513,12 +523,12 @@@ dsExpr expr@(RecordUpd record_expr (HsR mk_alt upd_fld_env con = do { let (univ_tvs, ex_tvs, eq_spec, - eq_theta, dict_theta, arg_tys, _) = dataConFullSig con + theta, arg_tys, _) = dataConFullSig con subst = mkTopTvSubst (univ_tvs `zip` in_inst_tys) -- I'm not bothering to clone the ex_tvs ; eqs_vars <- mapM newPredVarDs (substTheta subst (eqSpecPreds eq_spec)) - ; theta_vars <- mapM newPredVarDs (substTheta subst (eq_theta ++ dict_theta)) + ; theta_vars <- mapM newPredVarDs (substTheta subst theta) ; arg_ids <- newSysLocalsDs (substTys subst arg_tys) ; let val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg (dataConFieldLabels con) arg_ids @@@ -553,21 -529,21 +539,21 @@@ wrap = mkWpEvVarApps theta_vars `WpCompose` mkWpTyApps (mkTyVarTys ex_tvs) `WpCompose` mkWpTyApps [ty | (tv, ty) <- univ_tvs `zip` out_inst_tys - , isNothing (lookupTyVar wrap_subst tv) ] + , not (tv `elemVarEnv` wrap_subst) ] rhs = foldl (\a b -> nlHsApp a b) inst_con val_args -- Tediously wrap the application in a cast -- Note [Update for GADTs] wrapped_rhs | null eq_spec = rhs | otherwise = mkLHsWrap (WpCast wrap_co) rhs - wrap_co = mkTyConApp tycon [ lookup tv ty - | (tv,ty) <- univ_tvs `zip` out_inst_tys] - lookup univ_tv ty = case lookupTyVar wrap_subst univ_tv of - Just ty' -> ty' - Nothing -> ty - wrap_subst = mkTopTvSubst [ (tv,mkSymCoercion (mkTyVarTy co_var)) - | ((tv,_),co_var) <- eq_spec `zip` eqs_vars ] - + wrap_co = mkTyConAppCo tycon [ lookup tv ty + | (tv,ty) <- univ_tvs `zip` out_inst_tys] + lookup univ_tv ty = case lookupVarEnv wrap_subst univ_tv of + Just co' -> co' + Nothing -> mkReflCo ty + wrap_subst = mkVarEnv [ (tv, mkSymCo (mkCoVarCo co_var)) + | ((tv,_),co_var) <- eq_spec `zip` eqs_vars ] + pat = noLoc $ ConPatOut { pat_con = noLoc con, pat_tvs = ex_tvs , pat_dicts = eqs_vars ++ theta_vars , pat_binds = emptyTcEvBinds @@@ -607,7 -583,7 +593,7 @@@ dsExpr (HsTick ix vars e) = d dsExpr (HsBinTick ixT ixF e) = do e2 <- dsLExpr e - do { ASSERT(exprType e2 `coreEqType` boolTy) + do { ASSERT(exprType e2 `eqType` boolTy) mkBinaryTickBox ixT ixF e2 } \end{code} @@@ -718,25 -694,20 +704,20 @@@ handled in DsListComp). Basically doe Haskell 98 report: \begin{code} - dsDo :: [LStmt Id] - -> LHsExpr Id - -> Type -- Type of the whole expression - -> DsM CoreExpr - - dsDo stmts body result_ty + dsDo :: [LStmt Id] -> DsM CoreExpr + dsDo stmts = goL stmts where - -- result_ty must be of the form (m b) - (m_ty, _b_ty) = tcSplitAppTy result_ty - - goL [] = dsLExpr body - goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts) + goL [] = panic "dsDo" + goL (L loc stmt:lstmts) = putSrcSpanDs loc (go loc stmt lstmts) - go _ (ExprStmt rhs then_expr _) stmts + go _ (LastStmt body _) stmts + = ASSERT( null stmts ) dsLExpr body + -- The 'return' op isn't used for 'do' expressions + + go _ (ExprStmt rhs then_expr _ _) stmts = do { rhs2 <- dsLExpr rhs - ; case tcSplitAppTy_maybe (exprType rhs2) of - Just (container_ty, returning_ty) -> warnDiscardedDoBindings rhs container_ty returning_ty - _ -> return () + ; warnDiscardedDoBindings rhs (exprType rhs2) ; then_expr2 <- dsExpr then_expr ; rest <- goL stmts ; return (mkApps then_expr2 [rhs2, rest]) } @@@ -760,29 -731,29 +741,29 @@@ go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids , recS_rec_ids = rec_ids, recS_ret_fn = return_op , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op - , recS_rec_rets = rec_rets }) stmts + , recS_rec_rets = rec_rets, recS_ret_ty = body_ty }) stmts = ASSERT( length rec_ids > 0 ) goL (new_bind_stmt : stmts) where - -- returnE <- dsExpr return_id - -- mfixE <- dsExpr mfix_id - new_bind_stmt = L loc $ BindStmt (mkLHsPatTup later_pats) mfix_app - bind_op + new_bind_stmt = L loc $ BindStmt (mkLHsPatTup later_pats) + mfix_app bind_op noSyntaxExpr -- Tuple cannot fail tup_ids = rec_ids ++ filterOut (`elem` rec_ids) later_ids + tup_ty = mkBoxedTupleTy (map idType tup_ids) -- Deals with singleton case rec_tup_pats = map nlVarPat tup_ids later_pats = rec_tup_pats rets = map noLoc rec_rets - - mfix_app = nlHsApp (noLoc mfix_op) mfix_arg - mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body] - (mkFunTy tup_ty body_ty)) - mfix_pat = noLoc $ LazyPat $ mkLHsPatTup rec_tup_pats - body = noLoc $ HsDo DoExpr rec_stmts return_app body_ty - return_app = nlHsApp (noLoc return_op) (mkLHsTupleExpr rets) - body_ty = mkAppTy m_ty tup_ty - tup_ty = mkBoxedTupleTy (map idType tup_ids) -- Deals with singleton case + mfix_app = nlHsApp (noLoc mfix_op) mfix_arg + mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body] + (mkFunTy tup_ty body_ty)) + mfix_pat = noLoc $ LazyPat $ mkLHsPatTup rec_tup_pats + body = noLoc $ HsDo DoExpr (rec_stmts ++ [ret_stmt]) body_ty + ret_app = nlHsApp (noLoc return_op) (mkLHsTupleExpr rets) + ret_stmt = noLoc $ mkLastStmt ret_app + -- This LastStmt will be desugared with dsDo, + -- which ignores the return_op in the LastStmt, + -- so we must apply the return_op explicitly handle_failure :: LPat Id -> MatchResult -> SyntaxExpr Id -> DsM CoreExpr -- In a do expression, pattern-match failure just calls @@@ -800,104 -771,6 +781,6 @@@ mk_fail_msg pat = "Pattern match failur showSDoc (ppr (getLoc pat)) \end{code} - Translation for RecStmt's: - ----------------------------- - We turn (RecStmt [v1,..vn] stmts) into: - - (v1,..,vn) <- mfix (\~(v1,..vn). do stmts - return (v1,..vn)) - - \begin{code} - {- - dsMDo :: HsStmtContext Name - -> [(Name,Id)] - -> [LStmt Id] - -> LHsExpr Id - -> Type -- Type of the whole expression - -> DsM CoreExpr - - dsMDo ctxt tbl stmts body result_ty - = goL stmts - where - goL [] = dsLExpr body - goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts) - - (m_ty, b_ty) = tcSplitAppTy result_ty -- result_ty must be of the form (m b) - return_id = lookupEvidence tbl returnMName - bind_id = lookupEvidence tbl bindMName - then_id = lookupEvidence tbl thenMName - fail_id = lookupEvidence tbl failMName - - go _ (LetStmt binds) stmts - = do { rest <- goL stmts - ; dsLocalBinds binds rest } - - go _ (ExprStmt rhs then_expr rhs_ty) stmts - = do { rhs2 <- dsLExpr rhs - ; warnDiscardedDoBindings rhs m_ty rhs_ty - ; then_expr2 <- dsExpr then_expr - ; rest <- goL stmts - ; return (mkApps then_expr2 [rhs2, rest]) } - - go _ (BindStmt pat rhs bind_op _) stmts - = do { body <- goL stmts - ; rhs' <- dsLExpr rhs - ; bind_op' <- dsExpr bind_op - ; var <- selectSimpleMatchVarL pat - ; match <- matchSinglePat (Var var) (StmtCtxt ctxt) pat - result_ty (cantFailMatchResult body) - ; match_code <- handle_failure pat match fail_op - ; return (mkApps bind_op [rhs', Lam var match_code]) } - - go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids - , recS_rec_ids = rec_ids, recS_rec_rets = rec_rets - , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op }) stmts - = ASSERT( length rec_ids > 0 ) - ASSERT( length rec_ids == length rec_rets ) - ASSERT( isEmptyTcEvBinds _ev_binds ) - pprTrace "dsMDo" (ppr later_ids) $ - goL (new_bind_stmt : stmts) - where - new_bind_stmt = L loc $ BindStmt (mk_tup_pat later_pats) mfix_app - bind_op noSyntaxExpr - - -- Remove the later_ids that appear (without fancy coercions) - -- in rec_rets, because there's no need to knot-tie them separately - -- See Note [RecStmt] in HsExpr - later_ids' = filter (`notElem` mono_rec_ids) later_ids - mono_rec_ids = [ id | HsVar id <- rec_rets ] - - mfix_app = nlHsApp (noLoc mfix_op) mfix_arg - mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body] - (mkFunTy tup_ty body_ty)) - - -- The rec_tup_pat must bind the rec_ids only; remember that the - -- trimmed_laters may share the same Names - -- Meanwhile, the later_pats must bind the later_vars - rec_tup_pats = map mk_wild_pat later_ids' ++ map nlVarPat rec_ids - later_pats = map nlVarPat later_ids' ++ map mk_later_pat rec_ids - rets = map nlHsVar later_ids' ++ map noLoc rec_rets - - mfix_pat = noLoc $ LazyPat $ mk_tup_pat rec_tup_pats - body = noLoc $ HsDo ctxt rec_stmts return_app body_ty - body_ty = mkAppTy m_ty tup_ty - tup_ty = mkBoxedTupleTy (map idType (later_ids' ++ rec_ids)) -- Deals with singleton case - - return_app = nlHsApp (noLoc return_op) (mkLHsTupleExpr rets) - - mk_wild_pat :: Id -> LPat Id - mk_wild_pat v = noLoc $ WildPat $ idType v - - mk_later_pat :: Id -> LPat Id - mk_later_pat v | v `elem` later_ids' = mk_wild_pat v - | otherwise = nlVarPat v - - mk_tup_pat :: [LPat Id] -> LPat Id - mk_tup_pat [p] = p - mk_tup_pat ps = noLoc $ mkVanillaTuplePat ps Boxed - -} - \end{code} - %************************************************************************ %* * @@@ -914,7 -787,7 +797,7 @@@ warnAboutIdentities (Var v) co_f | idName v `elem` conversionNames , let fun_ty = exprType (co_fn (Var v)) , Just (arg_ty, res_ty) <- splitFunTy_maybe fun_ty - , arg_ty `tcEqType` res_ty -- So we are converting ty -> ty + , arg_ty `eqType` res_ty -- So we are converting ty -> ty = warnDs (vcat [ ptext (sLit "Call of") <+> ppr v <+> dcolon <+> ppr fun_ty , nest 2 $ ptext (sLit "can probably be omitted") , parens (ptext (sLit "Use -fno-warn-identities to suppress this messsage)")) @@@ -937,30 -810,34 +820,34 @@@ conversionName \begin{code} -- Warn about certain types of values discarded in monadic bindings (#3263) - warnDiscardedDoBindings :: LHsExpr Id -> Type -> Type -> DsM () - warnDiscardedDoBindings rhs container_ty returning_ty = do { - -- Warn about discarding non-() things in 'monadic' binding - ; warn_unused <- doptDs Opt_WarnUnusedDoBind - ; if warn_unused && not (returning_ty `tcEqType` unitTy) - then warnDs (unusedMonadBind rhs returning_ty) - else do { - -- Warn about discarding m a things in 'monadic' binding of the same type, - -- but only if we didn't already warn due to Opt_WarnUnusedDoBind - ; warn_wrong <- doptDs Opt_WarnWrongDoBind - ; case tcSplitAppTy_maybe returning_ty of - Just (returning_container_ty, _) -> when (warn_wrong && container_ty `tcEqType` returning_container_ty) $ - warnDs (wrongMonadBind rhs returning_ty) - _ -> return () } } + warnDiscardedDoBindings :: LHsExpr Id -> Type -> DsM () + warnDiscardedDoBindings rhs rhs_ty + | Just (m_ty, elt_ty) <- tcSplitAppTy_maybe rhs_ty + = do { -- Warn about discarding non-() things in 'monadic' binding + ; warn_unused <- doptDs Opt_WarnUnusedDoBind + ; if warn_unused && not (isUnitTy elt_ty) + then warnDs (unusedMonadBind rhs elt_ty) + else + -- Warn about discarding m a things in 'monadic' binding of the same type, + -- but only if we didn't already warn due to Opt_WarnUnusedDoBind + do { warn_wrong <- doptDs Opt_WarnWrongDoBind + ; case tcSplitAppTy_maybe elt_ty of + Just (elt_m_ty, _) | warn_wrong, m_ty `eqType` elt_m_ty + -> warnDs (wrongMonadBind rhs elt_ty) + _ -> return () } } + + | otherwise -- RHS does have type of form (m ty), which is wierd + = return () -- but at lesat this warning is irrelevant unusedMonadBind :: LHsExpr Id -> Type -> SDoc - unusedMonadBind rhs returning_ty - = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr returning_ty <> dot $$ + unusedMonadBind rhs elt_ty + = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr elt_ty <> dot $$ ptext (sLit "Suppress this warning by saying \"_ <- ") <> ppr rhs <> ptext (sLit "\",") $$ ptext (sLit "or by using the flag -fno-warn-unused-do-bind") wrongMonadBind :: LHsExpr Id -> Type -> SDoc - wrongMonadBind rhs returning_ty - = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr returning_ty <> dot $$ + wrongMonadBind rhs elt_ty + = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr elt_ty <> dot $$ ptext (sLit "Suppress this warning by saying \"_ <- ") <> ppr rhs <> ptext (sLit "\",") $$ ptext (sLit "or by using the flag -fno-warn-wrong-do-bind") \end{code} diff --combined compiler/deSugar/DsForeign.lhs index 2c2d7f2,b391b8f..aee1594 --- a/compiler/deSugar/DsForeign.lhs +++ b/compiler/deSugar/DsForeign.lhs @@@ -28,7 -28,6 +28,6 @@@ import Typ import TyCon import Coercion import TcType - import Var import CmmExpr import CmmUtils @@@ -140,7 -139,7 +139,7 @@@ dsCImport id (CLabel cid) cconv _ = d IsFunction _ -> IsData (resTy, foRhs) <- resultWrapper ty - ASSERT(fromJust resTy `coreEqType` addrPrimTy) -- typechecker ensures this + ASSERT(fromJust resTy `eqType` addrPrimTy) -- typechecker ensures this let rhs = foRhs (Lit (MachLabel cid stdcall_info fod)) stdcall_info = fun_type_arg_stdcall_info cconv ty @@@ -382,9 -381,9 +381,9 @@@ dsFExportDynamic id cconv = d ccall_adj <- dsCCall adjustor adj_args PlayRisky (mkTyConApp io_tc [res_ty]) -- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback - let io_app = mkLams tvs $ - Lam cback $ - mkCoerceI (mkSymCoI co) $ + let io_app = mkLams tvs $ + Lam cback $ + mkCoerce (mkSymCo co) $ mkApps (Var bindIOId) [ Type stable_ptr_ty , Type res_ty @@@ -483,7 -482,7 +482,7 @@@ mkFExportCBits c_nm maybe_target arg_ht typeCmmType (mkStablePtrPrimTy alphaTy)) -- stuff to do with the return type of the C function - res_hty_is_unit = res_hty `coreEqType` unitTy -- Look through any newtypes + res_hty_is_unit = res_hty `eqType` unitTy -- Look through any newtypes cResType | res_hty_is_unit = text "void" | otherwise = showStgType res_hty @@@ -525,7 -524,7 +524,7 @@@ 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,8 -549,9 +549,8 @@@ 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 $$ @@@ -589,10 -589,6 +588,10 @@@ , 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 = @@@ -609,10 -605,11 +608,10 @@@ <> 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) @@@ -677,7 -674,7 +676,7 @@@ getPrimTyOf t -- e.g. 'W' is a signed 32-bit integer. primTyDescChar :: Type -> Char primTyDescChar ty - | ty `coreEqType` unitTy = 'v' + | ty `eqType` unitTy = 'v' | otherwise = case typePrimRep (getPrimTyOf ty) of IntRep -> signed_word diff --combined compiler/ghc.cabal.in index 0a56719,b3d9f0c..8a98775 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@@ -36,11 -36,6 +36,6 @@@ Flag ghc Default: False Manual: True - Flag ncg - Description: Build the NCG. - Default: False - Manual: True - Flag stage1 Description: Is this stage 1? Default: False @@@ -88,9 -83,6 +83,6 @@@ Librar CPP-Options: -DGHCI Include-Dirs: ../libffi/build/include - if !flag(ncg) - CPP-Options: -DOMIT_NATIVE_CODEGEN - Build-Depends: bin-package-db Build-Depends: hoopl @@@ -269,7 -261,6 +261,7 @@@ CoreTidy CoreUnfold CoreUtils + CoqPass ExternalCore MkCore MkExternalCore @@@ -425,6 -416,7 +417,7 @@@ Generics InstEnv TyCon + Kind Type TypeRep Unify @@@ -451,6 -443,7 +444,7 @@@ MonadUtils OrdList Outputable + Pair Panic Pretty Serialized @@@ -491,10 -484,7 +485,7 @@@ Vectorise.Exp Vectorise - -- We only need to expose more modules as some of the ncg code is used - -- by the LLVM backend so its always included - if flag(ncg) - Exposed-Modules: + Exposed-Modules: AsmCodeGen TargetReg NCGMonad @@@ -504,10 -494,6 +495,6 @@@ RegClass PIC Platform - Alpha.Regs - Alpha.RegInfo - Alpha.Instr - Alpha.CodeGen X86.Regs X86.RegInfo X86.Instr @@@ -566,7 -552,6 +553,6 @@@ TcSplice Convert ByteCodeAsm - ByteCodeFFI ByteCodeGen ByteCodeInstr ByteCodeItbls diff --combined compiler/hsSyn/HsExpr.lhs index b7fe6fc,dd33cae..c3c372d --- a/compiler/hsSyn/HsExpr.lhs +++ b/compiler/hsSyn/HsExpr.lhs @@@ -23,6 -23,8 +23,8 @@@ import Nam import BasicTypes import DataCon import SrcLoc + import Util( dropTail ) + import StaticFlags( opt_PprStyle_Debug ) import Outputable import FastString @@@ -146,8 -148,6 +148,6 @@@ data HsExpr i -- because in this context we never use -- the PatGuard or ParStmt variant [LStmt id] -- "do":one or more stmts - (LHsExpr id) -- The body; the last expression in the - -- 'do' of [ body | ... ] in a list comp PostTcType -- Type of the whole expression | ExplicitList -- syntactic list @@@ -223,13 -223,6 +223,13 @@@ (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 @@@ -360,9 -353,6 +360,9 @@@ ppr_expr (HsIPVar v) = ppr 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] @@@ -449,7 -439,7 +449,7 @@@ ppr_expr (HsLet binds expr = sep [hang (ptext (sLit "let")) 2 (pprBinds binds), hang (ptext (sLit "in")) 2 (ppr expr)] - ppr_expr (HsDo do_or_list_comp stmts body _) = pprDo do_or_list_comp stmts body + ppr_expr (HsDo do_or_list_comp stmts _) = pprDo do_or_list_comp stmts ppr_expr (ExplicitList _ exprs) = brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs))) @@@ -585,7 -575,7 +585,7 @@@ pprParendExpr exp HsPar {} -> pp_as_was HsBracket {} -> pp_as_was HsBracketOut _ [] -> pp_as_was - HsDo sc _ _ _ + HsDo sc _ _ | isListCompExpr sc -> pp_as_was _ -> parens pp_as_was @@@ -840,51 -830,59 +840,59 @@@ type LStmtLR idL idR = Located (StmtLR type Stmt id = StmtLR id id - -- The SyntaxExprs in here are used *only* for do-notation, which - -- has rebindable syntax. Otherwise they are unused. + -- The SyntaxExprs in here are used *only* for do-notation and monad + -- comprehensions, which have rebindable syntax. Otherwise they are unused. data StmtLR idL idR - = BindStmt (LPat idL) + = LastStmt -- Always the last Stmt in ListComp, MonadComp, PArrComp, + -- and (after the renamer) DoExpr, MDoExpr + -- Not used for GhciStmt, PatGuard, which scope over other stuff + (LHsExpr idR) + (SyntaxExpr idR) -- The return operator, used only for MonadComp + -- For ListComp, PArrComp, we use the baked-in 'return' + -- For DoExpr, MDoExpr, we don't appply a 'return' at all + -- See Note [Monad Comprehensions] + | BindStmt (LPat idL) (LHsExpr idR) - (SyntaxExpr idR) -- The (>>=) operator + (SyntaxExpr idR) -- The (>>=) operator; see Note [The type of bind] (SyntaxExpr idR) -- The fail operator -- The fail operator is noSyntaxExpr -- if the pattern match can't fail | ExprStmt (LHsExpr idR) -- See Note [ExprStmt] (SyntaxExpr idR) -- The (>>) operator + (SyntaxExpr idR) -- The `guard` operator; used only in MonadComp + -- See notes [Monad Comprehensions] PostTcType -- Element type of the RHS (used for arrows) | LetStmt (HsLocalBindsLR idL idR) - -- ParStmts only occur in a list comprehension + -- ParStmts only occur in a list/monad comprehension | ParStmt [([LStmt idL], [idR])] - -- After renaming, the ids are the binders bound by the stmts and used - -- after them - - -- "qs, then f by e" ==> TransformStmt qs binders f (Just e) - -- "qs, then f" ==> TransformStmt qs binders f Nothing - | TransformStmt - [LStmt idL] -- Stmts are the ones to the left of the 'then' - - [idR] -- After renaming, the IDs are the binders occurring - -- within this transform statement that are used after it - - (LHsExpr idR) -- "then f" - - (Maybe (LHsExpr idR)) -- "by e" (optional) - - | GroupStmt - [LStmt idL] -- Stmts to the *left* of the 'group' - -- which generates the tuples to be grouped - - [(idR, idR)] -- See Note [GroupStmt binder map] + (SyntaxExpr idR) -- Polymorphic `mzip` for monad comprehensions + (SyntaxExpr idR) -- The `>>=` operator + (SyntaxExpr idR) -- Polymorphic `return` operator + -- with type (forall a. a -> m a) + -- See notes [Monad Comprehensions] + -- After renaming, the ids are the binders + -- bound by the stmts and used after themp + + | TransStmt { + trS_form :: TransForm, + trS_stmts :: [LStmt idL], -- Stmts to the *left* of the 'group' + -- which generates the tuples to be grouped + + trS_bndrs :: [(idR, idR)], -- See Note [TransStmt binder map] - (Maybe (LHsExpr idR)) -- "by e" (optional) + trS_using :: LHsExpr idR, + trS_by :: Maybe (LHsExpr idR), -- "by e" (optional) + -- Invariant: if trS_form = GroupBy, then grp_by = Just e - (Either -- "using f" - (LHsExpr idR) -- Left f => explicit "using f" - (SyntaxExpr idR)) -- Right f => implicit; filled in with 'groupWith' - + trS_ret :: SyntaxExpr idR, -- The monomorphic 'return' function for + -- the inner monad comprehensions + trS_bind :: SyntaxExpr idR, -- The '(>>=)' operator + trS_fmap :: SyntaxExpr idR -- The polymorphic 'fmap' function for desugaring + -- Only for 'group' forms + } -- See Note [Monad Comprehensions] -- Recursive statement (see Note [How RecStmt works] below) | RecStmt @@@ -915,20 -913,44 +923,44 @@@ -- because the Id may be *polymorphic*, but -- the returned thing has to be *monomorphic*, -- so they may be type applications + + , recS_ret_ty :: PostTcType -- The type of of do { stmts; return (a,b,c) } + -- With rebindable syntax the type might not + -- be quite as simple as (m (tya, tyb, tyc)). } deriving (Data, Typeable) + + data TransForm -- The 'f' below is the 'using' function, 'e' is the by function + = ThenForm -- then f or then f by e + | GroupFormU -- group using f or group using f by e + | GroupFormB -- group by e + -- In the GroupByFormB, trS_using is filled in with + -- 'groupWith' (list comprehensions) or + -- 'groupM' (monad comprehensions) + deriving (Data, Typeable) \end{code} - Note [GroupStmt binder map] + Note [The type of bind in Stmts] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + Some Stmts, notably BindStmt, keep the (>>=) bind operator. + We do NOT assume that it has type + (>>=) :: m a -> (a -> m b) -> m b + In some cases (see Trac #303, #1537) it might have a more + exotic type, such as + (>>=) :: m i j a -> (a -> m j k b) -> m i k b + So we must be careful not to make assumptions about the type. + In particular, the monad may not be uniform throughout. + + Note [TransStmt binder map] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ - The [(idR,idR)] in a GroupStmt behaves as follows: + The [(idR,idR)] in a TransStmt behaves as follows: * Before renaming: [] * After renaming: [ (x27,x27), ..., (z35,z35) ] These are the variables - bound by the stmts to the left of the 'group' + bound by the stmts to the left of the 'group' and used either in the 'by' clause, or in the stmts following the 'group' Each item is a pair of identical variables. @@@ -962,7 -984,13 +994,13 @@@ depends on the context. Consider the f E :: Bool Translation: if E then fail else ... - Array comprehensions are handled like list comprehensions -=chak + A monad comprehension of type (m res_ty) + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * ExprStmt E Bool: [ .. | .... E ] + E :: Bool + Translation: guard E >> ... + + Array comprehensions are handled like list comprehensions. Note [How RecStmt works] ~~~~~~~~~~~~~~~~~~~~~~~~ @@@ -1003,23 -1031,60 +1041,60 @@@ A (RecStmt stmts) types as if you had w where v1..vn are the later_ids r1..rm are the rec_ids + Note [Monad Comprehensions] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~ + Monad comprehensions require separate functions like 'return' and + '>>=' for desugaring. These functions are stored in the statements + used in monad comprehensions. For example, the 'return' of the 'LastStmt' + expression is used to lift the body of the monad comprehension: + + [ body | stmts ] + => + stmts >>= \bndrs -> return body + + In transform and grouping statements ('then ..' and 'then group ..') the + 'return' function is required for nested monad comprehensions, for example: + + [ body | stmts, then f, rest ] + => + f [ env | stmts ] >>= \bndrs -> [ body | rest ] + + ExprStmts require the 'Control.Monad.guard' function for boolean + expressions: + + [ body | exp, stmts ] + => + guard exp >> [ body | stmts ] + + Grouping/parallel statements require the 'Control.Monad.Group.groupM' and + 'Control.Monad.Zip.mzip' functions: + + [ body | stmts, then group by e, rest] + => + groupM [ body | stmts ] >>= \bndrs -> [ body | rest ] + + [ body | stmts1 | stmts2 | .. ] + => + mzip stmts1 (mzip stmts2 (..)) >>= \(bndrs1, (bndrs2, ..)) -> return body + + In any other context than 'MonadComp', the fields for most of these + 'SyntaxExpr's stay bottom. + \begin{code} instance (OutputableBndr idL, OutputableBndr idR) => Outputable (StmtLR idL idR) where ppr stmt = pprStmt stmt pprStmt :: (OutputableBndr idL, OutputableBndr idR) => (StmtLR idL idR) -> SDoc + pprStmt (LastStmt expr _) = ifPprDebug (ptext (sLit "[last]")) <+> ppr expr pprStmt (BindStmt pat expr _ _) = hsep [ppr pat, ptext (sLit "<-"), ppr expr] pprStmt (LetStmt binds) = hsep [ptext (sLit "let"), pprBinds binds] - pprStmt (ExprStmt expr _ _) = ppr expr - pprStmt (ParStmt stmtss) = hsep (map doStmts stmtss) + pprStmt (ExprStmt expr _ _ _) = ppr expr + pprStmt (ParStmt stmtss _ _ _) = hsep (map doStmts stmtss) where doStmts stmts = ptext (sLit "| ") <> ppr stmts - pprStmt (TransformStmt stmts bndrs using by) - = sep (ppr_lc_stmts stmts ++ [pprTransformStmt bndrs using by]) - - pprStmt (GroupStmt stmts _ by using) - = sep (ppr_lc_stmts stmts ++ [pprGroupStmt by using]) + pprStmt (TransStmt { trS_stmts = stmts, trS_by = by, trS_using = using, trS_form = form }) + = sep (ppr_lc_stmts stmts ++ [pprTransStmt by using form]) pprStmt (RecStmt { recS_stmts = segment, recS_rec_ids = rec_ids , recS_later_ids = later_ids }) @@@ -1034,40 -1099,47 +1109,47 @@@ pprTransformStmt bndrs using b , nest 2 (ppr using) , nest 2 (pprBy by)] - pprGroupStmt :: OutputableBndr id => Maybe (LHsExpr id) - -> Either (LHsExpr id) (SyntaxExpr is) + pprTransStmt :: OutputableBndr id => Maybe (LHsExpr id) + -> LHsExpr id -> TransForm -> SDoc - pprGroupStmt by using - = sep [ ptext (sLit "then group"), nest 2 (pprBy by), nest 2 (ppr_using using)] - where - ppr_using (Right _) = empty - ppr_using (Left e) = ptext (sLit "using") <+> ppr e + pprTransStmt by using ThenForm + = sep [ ptext (sLit "then"), nest 2 (ppr using), nest 2 (pprBy by)] + pprTransStmt by _ GroupFormB + = sep [ ptext (sLit "then group"), nest 2 (pprBy by) ] + pprTransStmt by using GroupFormU + = sep [ ptext (sLit "then group"), nest 2 (pprBy by), nest 2 (ptext (sLit "using") <+> ppr using)] pprBy :: OutputableBndr id => Maybe (LHsExpr id) -> SDoc pprBy Nothing = empty pprBy (Just e) = ptext (sLit "by") <+> ppr e - pprDo :: OutputableBndr id => HsStmtContext any -> [LStmt id] -> LHsExpr id -> SDoc - pprDo DoExpr stmts body = ptext (sLit "do") <+> ppr_do_stmts stmts body - pprDo GhciStmt stmts body = ptext (sLit "do") <+> ppr_do_stmts stmts body - pprDo MDoExpr stmts body = ptext (sLit "mdo") <+> ppr_do_stmts stmts body - pprDo ListComp stmts body = brackets $ pprComp stmts body - pprDo PArrComp stmts body = pa_brackets $ pprComp stmts body - pprDo _ _ _ = panic "pprDo" -- PatGuard, ParStmtCxt - - ppr_do_stmts :: OutputableBndr id => [LStmt id] -> LHsExpr id -> SDoc + pprDo :: OutputableBndr id => HsStmtContext any -> [LStmt id] -> SDoc + pprDo DoExpr stmts = ptext (sLit "do") <+> ppr_do_stmts stmts + pprDo GhciStmt stmts = ptext (sLit "do") <+> ppr_do_stmts stmts + pprDo ArrowExpr stmts = ptext (sLit "do") <+> ppr_do_stmts stmts + pprDo MDoExpr stmts = ptext (sLit "mdo") <+> ppr_do_stmts stmts + pprDo ListComp stmts = brackets $ pprComp stmts + pprDo PArrComp stmts = pa_brackets $ pprComp stmts + pprDo MonadComp stmts = brackets $ pprComp stmts + pprDo _ _ = panic "pprDo" -- PatGuard, ParStmtCxt + + ppr_do_stmts :: OutputableBndr id => [LStmt id] -> SDoc -- Print a bunch of do stmts, with explicit braces and semicolons, -- so that we are not vulnerable to layout bugs - ppr_do_stmts stmts body - = lbrace <+> pprDeeperList vcat ([ppr s <> semi | s <- stmts] ++ [ppr body]) + ppr_do_stmts stmts + = lbrace <+> pprDeeperList vcat (punctuate semi (map ppr stmts)) <+> rbrace ppr_lc_stmts :: OutputableBndr id => [LStmt id] -> [SDoc] ppr_lc_stmts stmts = [ppr s <> comma | s <- stmts] - pprComp :: OutputableBndr id => [LStmt id] -> LHsExpr id -> SDoc - pprComp quals body -- Prints: body | qual1, ..., qualn - = hang (ppr body <+> char '|') 2 (interpp'SP quals) + pprComp :: OutputableBndr id => [LStmt id] -> SDoc + pprComp quals -- Prints: body | qual1, ..., qualn + | not (null quals) + , L _ (LastStmt body _) <- last quals + = hang (ppr body <+> char '|') 2 (interpp'SP (dropTail 1 quals)) + | otherwise + = pprPanic "pprComp" (interpp'SP quals) \end{code} %************************************************************************ @@@ -1185,26 -1257,35 +1267,35 @@@ data HsMatchContext id -- Context of data HsStmtContext id = ListComp - | DoExpr - | GhciStmt -- A command-line Stmt in GHCi pat <- rhs - | MDoExpr -- Recursive do-expression + | MonadComp | PArrComp -- Parallel array comprehension + + | DoExpr -- do { ... } + | MDoExpr -- mdo { ... } ie recursive do-expression + | ArrowExpr -- do-notation in an arrow-command context + + | GhciStmt -- A command-line Stmt in GHCi pat <- rhs | PatGuard (HsMatchContext id) -- Pattern guard for specified thing | ParStmtCtxt (HsStmtContext id) -- A branch of a parallel stmt - | TransformStmtCtxt (HsStmtContext id) -- A branch of a transform stmt + | TransStmtCtxt (HsStmtContext id) -- A branch of a transform stmt deriving (Data, Typeable) \end{code} \begin{code} - isDoExpr :: HsStmtContext id -> Bool - isDoExpr DoExpr = True - isDoExpr MDoExpr = True - isDoExpr _ = False - isListCompExpr :: HsStmtContext id -> Bool - isListCompExpr ListComp = True - isListCompExpr PArrComp = True - isListCompExpr _ = False + -- Uses syntax [ e | quals ] + isListCompExpr ListComp = True + isListCompExpr PArrComp = True + isListCompExpr MonadComp = True + isListCompExpr (ParStmtCtxt c) = isListCompExpr c + isListCompExpr (TransStmtCtxt c) = isListCompExpr c + isListCompExpr _ = False + + isMonadCompExpr :: HsStmtContext id -> Bool + isMonadCompExpr MonadComp = True + isMonadCompExpr (ParStmtCtxt ctxt) = isMonadCompExpr ctxt + isMonadCompExpr (TransStmtCtxt ctxt) = isMonadCompExpr ctxt + isMonadCompExpr _ = False \end{code} \begin{code} @@@ -1241,33 -1322,41 +1332,41 @@@ pprMatchContextNoun ProcExpr = p pprMatchContextNoun (StmtCtxt ctxt) = ptext (sLit "pattern binding in") $$ pprStmtContext ctxt - pprStmtContext :: Outputable id => HsStmtContext id -> SDoc + ----------------- + pprAStmtContext, pprStmtContext :: Outputable id => HsStmtContext id -> SDoc + pprAStmtContext ctxt = article <+> pprStmtContext ctxt + where + pp_an = ptext (sLit "an") + pp_a = ptext (sLit "a") + article = case ctxt of + MDoExpr -> pp_an + PArrComp -> pp_an + GhciStmt -> pp_an + _ -> pp_a + + + ----------------- + pprStmtContext GhciStmt = ptext (sLit "interactive GHCi command") + pprStmtContext DoExpr = ptext (sLit "'do' block") + pprStmtContext MDoExpr = ptext (sLit "'mdo' block") + pprStmtContext ArrowExpr = ptext (sLit "'do' block in an arrow command") + pprStmtContext ListComp = ptext (sLit "list comprehension") + pprStmtContext MonadComp = ptext (sLit "monad comprehension") + pprStmtContext PArrComp = ptext (sLit "array comprehension") + pprStmtContext (PatGuard ctxt) = ptext (sLit "pattern guard for") $$ pprMatchContext ctxt + + -- Drop the inner contexts when reporting errors, else we get + -- Unexpected transform statement + -- in a transformed branch of + -- transformed branch of + -- transformed branch of monad comprehension pprStmtContext (ParStmtCtxt c) - = sep [ptext (sLit "a parallel branch of"), pprStmtContext c] - pprStmtContext (TransformStmtCtxt c) - = sep [ptext (sLit "a transformed branch of"), pprStmtContext c] - pprStmtContext (PatGuard ctxt) - = ptext (sLit "a pattern guard for") $$ pprMatchContext ctxt - pprStmtContext GhciStmt = ptext (sLit "an interactive GHCi command") - pprStmtContext DoExpr = ptext (sLit "a 'do' expression") - pprStmtContext MDoExpr = ptext (sLit "an 'mdo' expression") - pprStmtContext ListComp = ptext (sLit "a list comprehension") - pprStmtContext PArrComp = ptext (sLit "an array comprehension") - - {- - pprMatchRhsContext (FunRhs fun) = ptext (sLit "a right-hand side of function") <+> quotes (ppr fun) - pprMatchRhsContext CaseAlt = ptext (sLit "the body of a case alternative") - pprMatchRhsContext PatBindRhs = ptext (sLit "the right-hand side of a pattern binding") - pprMatchRhsContext LambdaExpr = ptext (sLit "the body of a lambda") - pprMatchRhsContext ProcExpr = ptext (sLit "the body of a proc") - pprMatchRhsContext other = panic "pprMatchRhsContext" -- RecUpd, StmtCtxt - - -- Used for the result statement of comprehension - -- e.g. the 'e' in [ e | ... ] - -- or the 'r' in f x = r - pprStmtResultContext (PatGuard ctxt) = pprMatchRhsContext ctxt - pprStmtResultContext other = ptext (sLit "the result of") <+> pprStmtContext other - -} + | opt_PprStyle_Debug = sep [ptext (sLit "parallel branch of"), pprAStmtContext c] + | otherwise = pprStmtContext c + pprStmtContext (TransStmtCtxt c) + | opt_PprStyle_Debug = sep [ptext (sLit "transformed branch of"), pprAStmtContext c] + | otherwise = pprStmtContext c + -- Used to generate the string for a *runtime* error message matchContextErrString :: Outputable id => HsMatchContext id -> SDoc @@@ -1278,14 -1367,16 +1377,16 @@@ matchContextErrString RecUp matchContextErrString LambdaExpr = ptext (sLit "lambda") matchContextErrString ProcExpr = ptext (sLit "proc") matchContextErrString ThPatQuote = panic "matchContextErrString" -- Not used at runtime - matchContextErrString (StmtCtxt (ParStmtCtxt c)) = matchContextErrString (StmtCtxt c) - matchContextErrString (StmtCtxt (TransformStmtCtxt c)) = matchContextErrString (StmtCtxt c) - matchContextErrString (StmtCtxt (PatGuard _)) = ptext (sLit "pattern guard") - matchContextErrString (StmtCtxt GhciStmt) = ptext (sLit "interactive GHCi command") - matchContextErrString (StmtCtxt DoExpr) = ptext (sLit "'do' expression") - matchContextErrString (StmtCtxt MDoExpr) = ptext (sLit "'mdo' expression") - matchContextErrString (StmtCtxt ListComp) = ptext (sLit "list comprehension") - matchContextErrString (StmtCtxt PArrComp) = ptext (sLit "array comprehension") + matchContextErrString (StmtCtxt (ParStmtCtxt c)) = matchContextErrString (StmtCtxt c) + matchContextErrString (StmtCtxt (TransStmtCtxt c)) = matchContextErrString (StmtCtxt c) + matchContextErrString (StmtCtxt (PatGuard _)) = ptext (sLit "pattern guard") + matchContextErrString (StmtCtxt GhciStmt) = ptext (sLit "interactive GHCi command") + matchContextErrString (StmtCtxt DoExpr) = ptext (sLit "'do' block") + matchContextErrString (StmtCtxt ArrowExpr) = ptext (sLit "'do' block") + matchContextErrString (StmtCtxt MDoExpr) = ptext (sLit "'mdo' block") + matchContextErrString (StmtCtxt ListComp) = ptext (sLit "list comprehension") + matchContextErrString (StmtCtxt MonadComp) = ptext (sLit "monad comprehension") + matchContextErrString (StmtCtxt PArrComp) = ptext (sLit "array comprehension") \end{code} \begin{code} @@@ -1296,11 -1387,16 +1397,16 @@@ pprMatchInCtxt ctxt match = hang (ptex pprStmtInCtxt :: (OutputableBndr idL, OutputableBndr idR) => HsStmtContext idL -> StmtLR idL idR -> SDoc - pprStmtInCtxt ctxt stmt = hang (ptext (sLit "In a stmt of") <+> pprStmtContext ctxt <> colon) - 4 (ppr_stmt stmt) + pprStmtInCtxt ctxt (LastStmt e _) + | isListCompExpr ctxt -- For [ e | .. ], do not mutter about "stmts" + = hang (ptext (sLit "In the expression:")) 2 (ppr e) + + pprStmtInCtxt ctxt stmt + = hang (ptext (sLit "In a stmt of") <+> pprAStmtContext ctxt <> colon) + 2 (ppr_stmt stmt) where -- For Group and Transform Stmts, don't print the nested stmts! - ppr_stmt (GroupStmt _ _ by using) = pprGroupStmt by using - ppr_stmt (TransformStmt _ bndrs using by) = pprTransformStmt bndrs using by - ppr_stmt stmt = pprStmt stmt + ppr_stmt (TransStmt { trS_by = by, trS_using = using + , trS_form = form }) = pprTransStmt by using form + ppr_stmt stmt = pprStmt stmt \end{code} diff --combined compiler/hsSyn/HsTypes.lhs index def44c5,7dbb16d..7159540 --- a/compiler/hsSyn/HsTypes.lhs +++ b/compiler/hsSyn/HsTypes.lhs @@@ -155,8 -155,6 +155,8 @@@ data HsType nam | 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) @@@ -170,8 -168,6 +170,6 @@@ -- interface files smaller), so when printing a HsType we may need to -- add parens. - | HsNumTy Integer -- Generics only - | HsPredTy (HsPred name) -- Only used in the type of an instance -- declaration, eg. Eq [a] -> Eq a -- ^^^^ @@@ -441,9 -437,7 +439,8 @@@ ppr_mono_ty _ (HsTupleTy con 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 ppr_mono_ty _ (HsCoreTy ty) = ppr ty @@@ -479,10 -473,6 +476,10 @@@ ppr_fun_ty ctxt_prec ty1 ty -------------------------- 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 --combined compiler/iface/BinIface.hs index ac21632,c80628b..b3de3f4 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@@ -1,4 -1,3 +1,3 @@@ - {-# OPTIONS_GHC -O #-} -- We always optimise this, otherwise performance of a non-optimised -- compiler is severely affected @@@ -903,10 -902,11 +902,11 @@@ instance Binary IfaceType wher put_ bh (IfaceTyConApp (IfaceAnyTc k) []) = do { putByte bh 17; put_ bh k } -- Generic cases put_ bh (IfaceTyConApp (IfaceTc tc) tys) = do { putByte bh 18; put_ bh tc; put_ bh tys } put_ bh (IfaceTyConApp tc tys) = do { putByte bh 19; put_ bh tc; put_ bh tys } + put_ bh (IfaceCoConApp cc tys) = do { putByte bh 20; put_ bh cc; put_ bh tys } + get bh = do h <- getByte bh case h of @@@ -939,11 -939,11 +939,11 @@@ 17 -> do { k <- get bh; return (IfaceTyConApp (IfaceAnyTc k) []) } 18 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp (IfaceTc tc) tys) } - _ -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp tc tys) } + 19 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp tc tys) } + _ -> do { cc <- get bh; tys <- get bh; return (IfaceCoConApp cc tys) } instance Binary IfaceTyCon where -- Int,Char,Bool can't show up here because they can't not be saturated - put_ bh IfaceIntTc = putByte bh 1 put_ bh IfaceBoolTc = putByte bh 2 put_ bh IfaceCharTc = putByte bh 3 @@@ -954,9 -954,9 +954,9 @@@ put_ bh IfaceUnliftedTypeKindTc = putByte bh 8 put_ bh IfaceUbxTupleKindTc = putByte bh 9 put_ bh IfaceArgTypeKindTc = putByte bh 10 - put_ bh (IfaceTupTc bx ar) = do { putByte bh 11; put_ bh bx; put_ bh ar } - put_ bh (IfaceTc ext) = do { putByte bh 12; put_ bh ext } - put_ bh (IfaceAnyTc k) = do { putByte bh 13; put_ bh k } + put_ bh (IfaceTupTc bx ar) = do { putByte bh 11; put_ bh bx; put_ bh ar } + put_ bh (IfaceTc ext) = do { putByte bh 12; put_ bh ext } + put_ bh (IfaceAnyTc k) = do { putByte bh 13; put_ bh k } get bh = do h <- getByte bh @@@ -973,7 -973,27 +973,27 @@@ 10 -> return IfaceArgTypeKindTc 11 -> do { bx <- get bh; ar <- get bh; return (IfaceTupTc bx ar) } 12 -> do { ext <- get bh; return (IfaceTc ext) } - _ -> do { k <- get bh; return (IfaceAnyTc k) } + _ -> do { k <- get bh; return (IfaceAnyTc k) } + + instance Binary IfaceCoCon where + put_ bh (IfaceCoAx n) = do { putByte bh 0; put_ bh n } + put_ bh IfaceReflCo = putByte bh 1 + put_ bh IfaceUnsafeCo = putByte bh 2 + put_ bh IfaceSymCo = putByte bh 3 + put_ bh IfaceTransCo = putByte bh 4 + put_ bh IfaceInstCo = putByte bh 5 + put_ bh (IfaceNthCo d) = do { putByte bh 6; put_ bh d } + + get bh = do + h <- getByte bh + case h of + 0 -> do { n <- get bh; return (IfaceCoAx n) } + 1 -> return IfaceReflCo + 2 -> return IfaceUnsafeCo + 3 -> return IfaceSymCo + 4 -> return IfaceTransCo + 5 -> return IfaceInstCo + _ -> do { d <- get bh; return (IfaceNthCo d) } instance Binary IfacePredType where put_ bh (IfaceClassP aa ab) = do @@@ -1013,50 -1033,50 +1033,50 @@@ instance Binary IfaceExpr wher put_ bh (IfaceType ab) = do putByte bh 1 put_ bh ab - put_ bh (IfaceTuple ac ad) = do + put_ bh (IfaceCo ab) = do putByte bh 2 + put_ bh ab + put_ bh (IfaceTuple ac ad) = do + putByte bh 3 put_ bh ac put_ bh ad put_ bh (IfaceLam ae af) = do - putByte bh 3 + putByte bh 4 put_ bh ae put_ bh af put_ bh (IfaceApp ag ah) = do - putByte bh 4 + putByte bh 5 put_ bh ag put_ bh ah - -- gaw 2004 - put_ bh (IfaceCase ai aj al ak) = do - putByte bh 5 + put_ bh (IfaceCase ai aj ak) = do + putByte bh 6 put_ bh ai put_ bh aj - -- gaw 2004 - put_ bh al put_ bh ak put_ bh (IfaceLet al am) = do - putByte bh 6 + putByte bh 7 put_ bh al put_ bh am put_ bh (IfaceNote an ao) = do - putByte bh 7 + putByte bh 8 put_ bh an put_ bh ao put_ bh (IfaceLit ap) = do - putByte bh 8 + putByte bh 9 put_ bh ap put_ bh (IfaceFCall as at) = do - putByte bh 9 + putByte bh 10 put_ bh as put_ bh at put_ bh (IfaceExt aa) = do - putByte bh 10 + putByte bh 11 put_ bh aa put_ bh (IfaceCast ie ico) = do - putByte bh 11 + putByte bh 12 put_ bh ie put_ bh ico put_ bh (IfaceTick m ix) = do - putByte bh 12 + putByte bh 13 put_ bh m put_ bh ix get bh = do @@@ -1066,39 -1086,38 +1086,38 @@@ return (IfaceLcl aa) 1 -> do ab <- get bh return (IfaceType ab) - 2 -> do ac <- get bh + 2 -> do ab <- get bh + return (IfaceCo ab) + 3 -> do ac <- get bh ad <- get bh return (IfaceTuple ac ad) - 3 -> do ae <- get bh + 4 -> do ae <- get bh af <- get bh return (IfaceLam ae af) - 4 -> do ag <- get bh + 5 -> do ag <- get bh ah <- get bh return (IfaceApp ag ah) - 5 -> do ai <- get bh + 6 -> do ai <- get bh aj <- get bh - -- gaw 2004 - al <- get bh ak <- get bh - -- gaw 2004 - return (IfaceCase ai aj al ak) - 6 -> do al <- get bh + return (IfaceCase ai aj ak) + 7 -> do al <- get bh am <- get bh return (IfaceLet al am) - 7 -> do an <- get bh + 8 -> do an <- get bh ao <- get bh return (IfaceNote an ao) - 8 -> do ap <- get bh + 9 -> do ap <- get bh return (IfaceLit ap) - 9 -> do as <- get bh - at <- get bh - return (IfaceFCall as at) - 10 -> do aa <- get bh + 10 -> do as <- get bh + at <- get bh + return (IfaceFCall as at) + 11 -> do aa <- get bh return (IfaceExt aa) - 11 -> do ie <- get bh + 12 -> do ie <- get bh ico <- get bh return (IfaceCast ie ico) - 12 -> do m <- get bh + 13 -> do m <- get bh ix <- get bh return (IfaceTick m ix) _ -> panic ("get IfaceExpr " ++ show h) @@@ -1282,20 -1301,16 +1301,20 @@@ instance Binary IfaceNote wher -- to avoid re-building it in various places. So we build the OccName -- when de-serialising. +-- NOTE regarding HetMet extensions: this screws up Adam's heinous +-- hide-the-syntactical-level-in-the-namespace trick. + instance Binary IfaceDecl where put_ bh (IfaceId name ty details idinfo) = do putByte bh 0 put_ bh (occNameFS name) + put_ bh (getOccNameDepth name) put_ bh ty put_ bh details put_ bh idinfo put_ _ (IfaceForeign _ _) = error "Binary.put_(IfaceDecl): IfaceForeign" - put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8) = do + put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7) = do putByte bh 2 put_ bh (occNameFS a1) put_ bh a2 @@@ -1304,7 -1319,6 +1323,6 @@@ put_ bh a5 put_ bh a6 put_ bh a7 - put_ bh a8 put_ bh (IfaceSyn a1 a2 a3 a4 a5) = do putByte bh 3 put_ bh (occNameFS a1) @@@ -1325,11 -1339,10 +1343,11 @@@ h <- getByte bh case h of 0 -> do name <- get bh + depth <- get bh ty <- get bh details <- get bh idinfo <- get bh - occ <- return $! mkOccNameFS varName name + occ <- return $! mkOccNameFS (varNameDepth depth) name return (IfaceId occ ty details idinfo) 1 -> error "Binary.get(TyClDecl): ForeignType" 2 -> do @@@ -1340,9 -1353,8 +1358,8 @@@ a5 <- get bh a6 <- get bh a7 <- get bh - a8 <- get bh occ <- return $! mkOccNameFS tcName a1 - return (IfaceData occ a2 a3 a4 a5 a6 a7 a8) + return (IfaceData occ a2 a3 a4 a5 a6 a7) 3 -> do a1 <- get bh a2 <- get bh @@@ -1441,15 -1453,13 +1458,15 @@@ instance Binary IfaceConDecl wher instance Binary IfaceClassOp where put_ bh (IfaceClassOp n def ty) = do put_ bh (occNameFS n) + put_ bh (getOccNameDepth n) put_ bh def put_ bh ty get bh = do n <- get bh + depth <- get bh def <- get bh ty <- get bh - occ <- return $! mkOccNameFS varName n + occ <- return $! mkOccNameFS (varNameDepth depth) n return (IfaceClassOp occ def ty) instance Binary IfaceRule where diff --combined compiler/iface/TcIface.lhs index 3a274a0,7ac95b1..f29bf85 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@@ -21,6 -21,7 +21,7 @@@ import BuildTyC import TcRnMonad import TcType import Type + import Coercion import TypeRep import HscTypes import Annotations @@@ -39,7 -40,6 +40,6 @@@ import TyCo import DataCon import TysWiredIn import TysPrim ( anyTyConOfKind ) - import Var ( Var, TyVar ) import BasicTypes ( Arity, nonRuleLoopBreaker ) import qualified Var import VarEnv @@@ -144,7 -144,7 +144,7 @@@ importDecl nam where nd_doc = ptext (sLit "Need decl for") <+> ppr name not_found_msg = hang (ptext (sLit "Can't find interface-file declaration for") <+> - pprNameSpace (occNameSpace (nameOccName name)) <+> ppr name) + pprNameSpace (occNameSpace (nameOccName name)) <+> (ppr (nameOccName name))) 2 (vcat [ptext (sLit "Probable cause: bug in .hi-boot file, or inconsistent .hi file"), ptext (sLit "Use -ddump-if-trace to get an idea of which file caused the error")]) \end{code} @@@ -433,7 -433,6 +433,6 @@@ tc_iface_decl parent _ (IfaceData {ifNa ifCtxt = ctxt, ifGadtSyntax = gadt_syn, ifCons = rdr_cons, ifRec = is_rec, - ifGeneric = want_generic, ifFamInst = mb_family }) = bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do { tc_name <- lookupIfaceTop occ_name @@@ -442,7 -441,7 +441,7 @@@ ; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons ; mb_fam_inst <- tcFamInst mb_family ; buildAlgTyCon tc_name tyvars stupid_theta cons is_rec - want_generic gadt_syn parent mb_fam_inst + gadt_syn parent mb_fam_inst }) ; traceIf (text "tcIfaceDecl4" <+> ppr tycon) ; return (ATyCon tycon) } @@@ -791,20 -790,56 +790,56 @@@ tcIfaceType (IfaceAppTy t1 t2) = do tcIfaceType (IfaceFunTy t1 t2) = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (FunTy t1' t2') } tcIfaceType (IfaceTyConApp tc ts) = do { tc' <- tcIfaceTyCon tc; ts' <- tcIfaceTypes ts; return (mkTyConApp tc' ts') } tcIfaceType (IfaceForAllTy tv t) = bindIfaceTyVar tv $ \ tv' -> do { t' <- tcIfaceType t; return (ForAllTy tv' t') } - tcIfaceType (IfacePredTy st) = do { st' <- tcIfacePredType st; return (PredTy st') } + tcIfaceType (IfacePredTy st) = do { st' <- tcIfacePred tcIfaceType st; return (PredTy st') } + tcIfaceType t@(IfaceCoConApp {}) = pprPanic "tcIfaceType" (ppr t) tcIfaceTypes :: [IfaceType] -> IfL [Type] tcIfaceTypes tys = mapM tcIfaceType tys ----------------------------------------- - tcIfacePredType :: IfacePredType -> IfL PredType - tcIfacePredType (IfaceClassP cls ts) = do { cls' <- tcIfaceClass cls; ts' <- tcIfaceTypes ts; return (ClassP cls' ts') } - tcIfacePredType (IfaceIParam ip t) = do { ip' <- newIPName ip; t' <- tcIfaceType t; return (IParam ip' t') } - tcIfacePredType (IfaceEqPred t1 t2) = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (EqPred t1' t2') } + tcIfacePred :: (IfaceType -> IfL a) -> IfacePredType -> IfL (Pred a) + tcIfacePred tc (IfaceClassP cls ts) + = do { cls' <- tcIfaceClass cls; ts' <- mapM tc ts; return (ClassP cls' ts') } + tcIfacePred tc (IfaceIParam ip t) + = do { ip' <- newIPName ip; t' <- tc t; return (IParam ip' t') } + tcIfacePred tc (IfaceEqPred t1 t2) + = do { t1' <- tc t1; t2' <- tc t2; return (EqPred t1' t2') } ----------------------------------------- tcIfaceCtxt :: IfaceContext -> IfL ThetaType - tcIfaceCtxt sts = mapM tcIfacePredType sts + tcIfaceCtxt sts = mapM (tcIfacePred tcIfaceType) sts + \end{code} + + %************************************************************************ + %* * + Coercions + %* * + %************************************************************************ + + \begin{code} + tcIfaceCo :: IfaceType -> IfL Coercion + tcIfaceCo (IfaceTyVar n) = mkCoVarCo <$> tcIfaceCoVar n + tcIfaceCo (IfaceAppTy t1 t2) = mkAppCo <$> tcIfaceCo t1 <*> tcIfaceCo t2 + tcIfaceCo (IfaceFunTy t1 t2) = mkFunCo <$> tcIfaceCo t1 <*> tcIfaceCo t2 + tcIfaceCo (IfaceTyConApp tc ts) = mkTyConAppCo <$> tcIfaceTyCon tc <*> mapM tcIfaceCo ts + tcIfaceCo (IfaceCoConApp tc ts) = tcIfaceCoApp tc ts + tcIfaceCo (IfaceForAllTy tv t) = bindIfaceTyVar tv $ \ tv' -> + mkForAllCo tv' <$> tcIfaceCo t + -- tcIfaceCo (IfacePredTy co) = mkPredCo <$> tcIfacePred tcIfaceCo co + tcIfaceCo (IfacePredTy _) = panic "tcIfaceCo" + + tcIfaceCoApp :: IfaceCoCon -> [IfaceType] -> IfL Coercion + tcIfaceCoApp IfaceReflCo [t] = Refl <$> tcIfaceType t + tcIfaceCoApp (IfaceCoAx n) ts = AxiomInstCo <$> tcIfaceCoAxiom n <*> mapM tcIfaceCo ts + tcIfaceCoApp IfaceUnsafeCo [t1,t2] = UnsafeCo <$> tcIfaceType t1 <*> tcIfaceType t2 + tcIfaceCoApp IfaceSymCo [t] = SymCo <$> tcIfaceCo t + tcIfaceCoApp IfaceTransCo [t1,t2] = TransCo <$> tcIfaceCo t1 <*> tcIfaceCo t2 + tcIfaceCoApp IfaceInstCo [t1,t2] = InstCo <$> tcIfaceCo t1 <*> tcIfaceType t2 + tcIfaceCoApp (IfaceNthCo d) [t] = NthCo d <$> tcIfaceCo t + tcIfaceCoApp cc ts = pprPanic "toIfaceCoApp" (ppr cc <+> ppr ts) + + tcIfaceCoVar :: FastString -> IfL CoVar + tcIfaceCoVar = tcIfaceLclId \end{code} @@@ -819,6 -854,12 +854,12 @@@ tcIfaceExpr :: IfaceExpr -> IfL CoreExp tcIfaceExpr (IfaceType ty) = Type <$> tcIfaceType ty + tcIfaceExpr (IfaceCo co) + = Coercion <$> tcIfaceCo co + + tcIfaceExpr (IfaceCast expr co) + = Cast <$> tcIfaceExpr expr <*> tcIfaceCo co + tcIfaceExpr (IfaceLcl name) = Var <$> tcIfaceLclId name @@@ -853,7 -894,7 +894,7 @@@ tcIfaceExpr (IfaceLam bndr body tcIfaceExpr (IfaceApp fun arg) = App <$> tcIfaceExpr fun <*> tcIfaceExpr arg - tcIfaceExpr (IfaceCase scrut case_bndr ty alts) = do + tcIfaceExpr (IfaceCase scrut case_bndr alts) = do scrut' <- tcIfaceExpr scrut case_bndr_name <- newIfaceName (mkVarOccFS case_bndr) let @@@ -868,8 -909,7 +909,7 @@@ extendIfaceIdEnv [case_bndr'] $ do alts' <- mapM (tcIfaceAlt scrut' tc_app) alts - ty' <- tcIfaceType ty - return (Case scrut' case_bndr' ty' alts') + return (Case scrut' case_bndr' (coreAltsType alts') alts') tcIfaceExpr (IfaceLet (IfaceNonRec (IfLetBndr fs ty info) rhs) body) = do { name <- newIfaceName (mkVarOccFS fs) @@@ -898,11 -938,6 +938,6 @@@ tcIfaceExpr (IfaceLet (IfaceRec pairs) (idName id) (idType id) info ; return (setIdInfo id id_info, rhs') } - tcIfaceExpr (IfaceCast expr co) = do - expr' <- tcIfaceExpr expr - co' <- tcIfaceType co - return (Cast expr' co') - tcIfaceExpr (IfaceNote note expr) = do expr' <- tcIfaceExpr expr case note of @@@ -942,14 -977,13 +977,13 @@@ tcIfaceDataAlt :: DataCon -> [Type] -> tcIfaceDataAlt con inst_tys arg_strs rhs = do { us <- newUniqueSupply ; let uniqs = uniqsFromSupply us - ; let (ex_tvs, co_tvs, arg_ids) + ; let (ex_tvs, arg_ids) = dataConRepFSInstPat arg_strs uniqs con inst_tys - all_tvs = ex_tvs ++ co_tvs - ; rhs' <- extendIfaceTyVarEnv all_tvs $ + ; rhs' <- extendIfaceTyVarEnv ex_tvs $ extendIfaceIdEnv arg_ids $ tcIfaceExpr rhs - ; return (DataAlt con, all_tvs ++ arg_ids, rhs') } + ; return (DataAlt con, ex_tvs ++ arg_ids, rhs') } \end{code} @@@ -1217,6 -1251,10 +1251,10 @@@ tcIfaceClass :: Name -> IfL Clas tcIfaceClass name = do { thing <- tcIfaceGlobal name ; return (tyThingClass thing) } + tcIfaceCoAxiom :: Name -> IfL CoAxiom + tcIfaceCoAxiom name = do { thing <- tcIfaceGlobal name + ; return (tyThingCoAxiom thing) } + tcIfaceDataCon :: Name -> IfL DataCon tcIfaceDataCon name = do { thing <- tcIfaceGlobal name ; case thing of diff --combined compiler/main/DynFlags.hs index 6fe6708,d9f3246..7e5dff0 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@@ -60,7 -60,7 +60,7 @@@ module DynFlags supportedLanguagesAndExtensions, -- ** DynFlag C compiler options - machdepCCOpts, picCCOpts, + picCCOpts, -- * Configuration of the stg-to-stg passes StgToDo(..), @@@ -77,9 -77,7 +77,7 @@@ #include "HsVersions.h" - #ifndef OMIT_NATIVE_CODEGEN import Platform - #endif import Module import PackageConfig import PrelNames ( mAIN ) @@@ -110,7 -108,8 +108,8 @@@ import Data.Cha import Data.List import Data.Map (Map) import qualified Data.Map as Map - -- import Data.Maybe + import Data.Set (Set) + import qualified Data.Set as Set import System.FilePath import System.IO ( stderr, hPutChar ) @@@ -125,6 -124,21 +124,21 @@@ data DynFla | Opt_D_dump_raw_cmm | Opt_D_dump_cmmz | Opt_D_dump_cmmz_pretty + -- All of the cmmz subflags (there are a lot!) Automatically + -- enabled if you run -ddump-cmmz + | Opt_D_dump_cmmz_cbe + | Opt_D_dump_cmmz_proc + | Opt_D_dump_cmmz_spills + | Opt_D_dump_cmmz_rewrite + | Opt_D_dump_cmmz_dead + | Opt_D_dump_cmmz_stub + | Opt_D_dump_cmmz_sp + | Opt_D_dump_cmmz_procmap + | Opt_D_dump_cmmz_split + | Opt_D_dump_cmmz_lower + | Opt_D_dump_cmmz_info + | Opt_D_dump_cmmz_cafs + -- end cmmz subflags | Opt_D_dump_cps_cmm | Opt_D_dump_cvt_cmm | Opt_D_dump_asm @@@ -190,13 -204,6 +204,13 @@@ | Opt_DoCmmLinting | Opt_DoAsmLinting + | Opt_F_coqpass -- run the core-to-core coqPass, but don't change anything (just "parse/unparse") + | Opt_F_skolemize -- run the core-to-core coqPass, skolemizing the proof + | Opt_F_flatten -- run the core-to-core coqPass, flattening the proof + | Opt_F_simpleopt_before_flatten -- run the "simplPgmOpt" before the coqPass + | Opt_D_dump_proofs -- dump natural deduction typing proof of the coqpass input + | Opt_D_coqpass -- run the core-to-string coqPass and dumps the result + | Opt_WarnIsError -- -Werror; makes warnings fatal | Opt_WarnDuplicateExports | Opt_WarnHiShadows @@@ -267,7 -274,6 +281,6 @@@ -- misc opts | Opt_Pp | Opt_ForceRecomp - | Opt_DryRun | Opt_ExcessPrecision | Opt_EagerBlackHoling | Opt_ReadUserPackageConf @@@ -327,11 -333,9 +340,10 @@@ data ExtensionFla | 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 - | Opt_Generics -- "Derivable type classes" | Opt_ImplicitPrelude | Opt_ScopedTypeVariables | Opt_UnboxedTuples @@@ -353,6 -357,9 +365,9 @@@ | Opt_DeriveFunctor | Opt_DeriveTraversable | Opt_DeriveFoldable + | Opt_DeriveGeneric -- Allow deriving Generic/1 + | Opt_DefaultSignatures -- Allow extra signatures for defmeths + | Opt_Generics -- Old generic classes, now deprecated | Opt_TypeSynonymInstances | Opt_FlexibleContexts @@@ -368,6 -375,7 +383,7 @@@ | Opt_KindSignatures | Opt_ParallelListComp | Opt_TransformListComp + | Opt_MonadComprehensions | Opt_GeneralizedNewtypeDeriving | Opt_RecursiveDo | Opt_DoRec @@@ -410,9 -418,7 +426,7 @@@ data DynFlags = DynFlags floatLamArgs :: Maybe Int, -- ^ Arg count for lambda floating -- See CoreMonad.FloatOutSwitches - #ifndef OMIT_NATIVE_CODEGEN - targetPlatform :: Platform, -- ^ The platform we're compiling for. Used by the NCG. - #endif + targetPlatform :: Platform.Platform, -- ^ The platform we're compiling for. Used by the NCG. cmdlineHcIncludes :: [String], -- ^ @\-\#includes@ importPaths :: [FilePath], mainModIs :: Module, @@@ -491,6 -497,11 +505,11 @@@ filesToClean :: IORef [FilePath], dirsToClean :: IORef (Map FilePath FilePath), + -- Names of files which were generated from -ddump-to-file; used to + -- track which ones we need to truncate because it's our first run + -- through + generatedDumps :: IORef (Set FilePath), + -- hsc dynamic flags flags :: [DynFlag], -- Don't change this without updating extensionFlags: @@@ -638,6 -649,14 +657,14 @@@ data HscTarge | HscNothing -- ^ Don't generate any code. See notes above. deriving (Eq, Show) + showHscTargetFlag :: HscTarget -> String + showHscTargetFlag HscC = "-fvia-c" + showHscTargetFlag HscAsm = "-fasm" + showHscTargetFlag HscLlvm = "-fllvm" + showHscTargetFlag HscJava = panic "No flag for HscJava" + showHscTargetFlag HscInterpreted = "-fbyte-code" + showHscTargetFlag HscNothing = "-fno-code" + -- | Will this target result in an object file on the disk? isObjectTarget :: HscTarget -> Bool isObjectTarget HscC = True @@@ -700,8 -719,9 +727,9 @@@ defaultHscTarget = defaultObjectTarge -- object files on the current platform. defaultObjectTarget :: HscTarget defaultObjectTarget + | cGhcUnregisterised == "YES" = HscC | cGhcWithNativeCodeGen == "YES" = HscAsm - | otherwise = HscC + | otherwise = HscLlvm data DynLibLoader = Deployable @@@ -718,12 -738,14 +746,14 @@@ initDynFlags dflags = d ways <- readIORef v_Ways refFilesToClean <- newIORef [] refDirsToClean <- newIORef Map.empty + refGeneratedDumps <- newIORef Set.empty return dflags{ ways = ways, buildTag = mkBuildTag (filter (not . wayRTSOnly) ways), rtsBuildTag = mkBuildTag ways, filesToClean = refFilesToClean, - dirsToClean = refDirsToClean + dirsToClean = refDirsToClean, + generatedDumps = refGeneratedDumps } -- | The normal 'DynFlags'. Note that they is not suitable for use in this form @@@ -742,15 -764,13 +772,13 @@@ defaultDynFlags mySettings maxSimplIterations = 4, shouldDumpSimplPhase = Nothing, ruleCheck = Nothing, - specConstrThreshold = Just 200, + specConstrThreshold = Just 2000, specConstrCount = Just 3, - liberateCaseThreshold = Just 200, + liberateCaseThreshold = Just 2000, floatLamArgs = Just 0, -- Default: float only if no fvs strictnessBefore = [], - #ifndef OMIT_NATIVE_CODEGEN targetPlatform = defaultTargetPlatform, - #endif cmdlineHcIncludes = [], importPaths = ["."], mainModIs = mAIN, @@@ -801,6 -821,7 +829,7 @@@ -- end of ghc -M values filesToClean = panic "defaultDynFlags: No filesToClean", dirsToClean = panic "defaultDynFlags: No dirsToClean", + generatedDumps = panic "defaultDynFlags: No generatedDumps", haddockOptions = Nothing, flags = defaultFlags, language = Nothing, @@@ -809,12 -830,12 +838,12 @@@ log_action = \severity srcSpan style msg -> case severity of - SevOutput -> printOutput (msg style) - SevInfo -> printErrs (msg style) - SevFatal -> printErrs (msg style) + SevOutput -> printSDoc msg style + SevInfo -> printErrs msg style + SevFatal -> printErrs msg style _ -> do hPutChar stderr '\n' - printErrs ((mkLocMessage srcSpan msg) style) + printErrs (mkLocMessage srcSpan msg) style -- careful (#2302): printErrs prints in UTF-8, whereas -- converting to string first and using hPutStr would -- just emit the low 8 bits of each unicode char. @@@ -854,7 -875,11 +883,11 @@@ languageExtensions Nothin -- But NB it's implied by GADTs etc -- SLPJ September 2010 : Opt_NondecreasingIndentation -- This has been on by default for some time - : languageExtensions (Just Haskell2010) + : delete Opt_DatatypeContexts -- The Haskell' committee decided to + -- remove datatype contexts from the + -- language: + -- http://www.haskell.org/pipermail/haskell-prime/2011-January/003335.html + (languageExtensions (Just Haskell2010)) languageExtensions (Just Haskell98) = [Opt_ImplicitPrelude, @@@ -1106,16 -1131,7 +1139,7 @@@ parseDynamicFlags_ dflags0 args pkg_fla = runCmdLine (processArgs flag_spec args') dflags0 when (not (null errs)) $ ghcError $ errorsToGhcException errs - let (pic_warns, dflags2) - #if !(x86_64_TARGET_ARCH && linux_TARGET_OS) - | (not opt_Static || opt_PIC) && hscTarget dflags1 == HscLlvm - = ([L noSrcSpan $ "Warning: -fllvm is incompatible with -fPIC and -" - ++ "dynamic on this platform;\n ignoring -fllvm"], - dflags1{ hscTarget = HscAsm }) - #endif - | otherwise = ([], dflags1) - - return (dflags2, leftover, pic_warns ++ warns) + return (dflags1, leftover, warns) {- ********************************************************************** @@@ -1139,7 -1155,7 +1163,7 @@@ allFlags = map ('-':) --------------- The main flags themselves ------------------ dynamic_flags :: [Flag (CmdLineP DynFlags)] dynamic_flags = [ - Flag "n" (NoArg (setDynFlag Opt_DryRun)) + Flag "n" (NoArg (addWarn "The -n flag is deprecated and no longer has any effect")) , Flag "cpp" (NoArg (setExtensionFlag Opt_Cpp)) , Flag "F" (NoArg (setDynFlag Opt_Pp)) , Flag "#include" @@@ -1199,8 -1215,8 +1223,8 @@@ , Flag "dylib-install-name" (hasArg setDylibInstallName) ------- Libraries --------------------------------------------------- - , Flag "L" (Prefix addLibraryPath) - , Flag "l" (AnySuffix (upd . addOptl)) + , Flag "L" (Prefix addLibraryPath) + , Flag "l" (hasArg (addOptl . ("-l" ++))) ------- Frameworks -------------------------------------------------- -- -framework-path should really be -F ... @@@ -1268,6 -1284,18 +1292,18 @@@ , Flag "ddump-raw-cmm" (setDumpFlag Opt_D_dump_raw_cmm) , Flag "ddump-cmmz" (setDumpFlag Opt_D_dump_cmmz) , Flag "ddump-cmmz-pretty" (setDumpFlag Opt_D_dump_cmmz_pretty) + , Flag "ddump-cmmz-cbe" (setDumpFlag Opt_D_dump_cmmz_cbe) + , Flag "ddump-cmmz-spills" (setDumpFlag Opt_D_dump_cmmz_spills) + , Flag "ddump-cmmz-proc" (setDumpFlag Opt_D_dump_cmmz_proc) + , Flag "ddump-cmmz-rewrite" (setDumpFlag Opt_D_dump_cmmz_rewrite) + , Flag "ddump-cmmz-dead" (setDumpFlag Opt_D_dump_cmmz_dead) + , Flag "ddump-cmmz-stub" (setDumpFlag Opt_D_dump_cmmz_stub) + , Flag "ddump-cmmz-sp" (setDumpFlag Opt_D_dump_cmmz_sp) + , Flag "ddump-cmmz-procmap" (setDumpFlag Opt_D_dump_cmmz_procmap) + , Flag "ddump-cmmz-split" (setDumpFlag Opt_D_dump_cmmz_split) + , Flag "ddump-cmmz-lower" (setDumpFlag Opt_D_dump_cmmz_lower) + , Flag "ddump-cmmz-info" (setDumpFlag Opt_D_dump_cmmz_info) + , Flag "ddump-cmmz-cafs" (setDumpFlag Opt_D_dump_cmmz_cafs) , Flag "ddump-core-stats" (setDumpFlag Opt_D_dump_core_stats) , Flag "ddump-cps-cmm" (setDumpFlag Opt_D_dump_cps_cmm) , Flag "ddump-cvt-cmm" (setDumpFlag Opt_D_dump_cvt_cmm) @@@ -1336,14 -1364,6 +1372,14 @@@ setVerbosity (Just 2))) , Flag "dfaststring-stats" (NoArg (setDynFlag Opt_D_faststring_stats)) + ------ Coq-in-GHC --------------------------- + , Flag "ddump-proofs" (NoArg (setDynFlag Opt_D_dump_proofs)) + , Flag "ddump-coqpass" (NoArg (setDynFlag Opt_D_coqpass)) + , Flag "fcoqpass" (NoArg (setDynFlag Opt_F_coqpass)) + , Flag "fsimpleopt-before-flatten" (NoArg (setDynFlag Opt_F_simpleopt_before_flatten)) + , Flag "fflatten" (NoArg (do { setDynFlag Opt_F_coqpass ; setDynFlag Opt_F_flatten })) + , Flag "funsafe-skolemize" (NoArg (do { setDynFlag Opt_F_coqpass ; setDynFlag Opt_F_flatten ; setDynFlag Opt_F_skolemize })) + ------ Machine dependant (-m) stuff --------------------------- , Flag "monly-2-regs" (NoArg (addWarn "The -monly-2-regs flag does nothing; it will be removed in a future GHC release")) @@@ -1361,10 -1381,11 +1397,11 @@@ , Flag "w" (NoArg (mapM_ unSetDynFlag minuswRemovesOpts)) ------ Optimisation flags ------------------------------------------ - , Flag "O" (noArg (setOptLevel 1)) - , Flag "Onot" (noArgDF (setOptLevel 0) "Use -O0 instead") - , Flag "Odph" (noArg setDPHOpt) - , Flag "O" (OptIntSuffix (\mb_n -> upd (setOptLevel (mb_n `orElse` 1)))) + , Flag "O" (noArgM (setOptLevel 1)) + , Flag "Onot" (noArgM (\dflags -> do deprecate "Use -O0 instead" + setOptLevel 0 dflags)) + , Flag "Odph" (noArgM setDPHOpt) + , Flag "O" (optIntSuffixM (\mb_n -> setOptLevel (mb_n `orElse` 1))) -- If the number is missing, use 1 , Flag "fsimplifier-phases" (intSuffix (\n d -> d{ simplPhases = n })) @@@ -1631,6 -1652,7 +1668,7 @@@ xFlags = ( "EmptyDataDecls", Opt_EmptyDataDecls, nop ), ( "ParallelListComp", Opt_ParallelListComp, nop ), ( "TransformListComp", Opt_TransformListComp, nop ), + ( "MonadComprehensions", Opt_MonadComprehensions, nop), ( "ForeignFunctionInterface", Opt_ForeignFunctionInterface, nop ), ( "UnliftedFFITypes", Opt_UnliftedFFITypes, nop ), ( "GHCForeignImportPrim", Opt_GHCForeignImportPrim, nop ), @@@ -1639,15 -1661,15 +1677,16 @@@ ( "RankNTypes", Opt_RankNTypes, nop ), ( "ImpredicativeTypes", Opt_ImpredicativeTypes, nop), ( "TypeOperators", Opt_TypeOperators, nop ), - ( "RecursiveDo", Opt_RecursiveDo, + ( "RecursiveDo", Opt_RecursiveDo, -- Enables 'mdo' deprecatedForExtension "DoRec"), - ( "DoRec", Opt_DoRec, nop ), + ( "DoRec", Opt_DoRec, nop ), -- Enables 'rec' keyword ( "Arrows", Opt_Arrows, nop ), + ( "ModalTypes", Opt_ModalTypes, nop ), ( "ParallelArrays", Opt_ParallelArrays, nop ), ( "TemplateHaskell", Opt_TemplateHaskell, checkTemplateHaskellOk ), ( "QuasiQuotes", Opt_QuasiQuotes, nop ), - ( "Generics", Opt_Generics, nop ), + ( "Generics", Opt_Generics, + \ _ -> deprecate "it does nothing; look into -XDefaultSignatures and -XDeriveGeneric for generic programming support." ), ( "ImplicitPrelude", Opt_ImplicitPrelude, nop ), ( "RecordWildCards", Opt_RecordWildCards, nop ), ( "NamedFieldPuns", Opt_RecordPuns, nop ), @@@ -1689,6 -1711,8 +1728,8 @@@ ( "DeriveFunctor", Opt_DeriveFunctor, nop ), ( "DeriveTraversable", Opt_DeriveTraversable, nop ), ( "DeriveFoldable", Opt_DeriveFoldable, nop ), + ( "DeriveGeneric", Opt_DeriveGeneric, nop ), + ( "DefaultSignatures", Opt_DefaultSignatures, nop ), ( "TypeSynonymInstances", Opt_TypeSynonymInstances, nop ), ( "FlexibleContexts", Opt_FlexibleContexts, nop ), ( "FlexibleInstances", Opt_FlexibleInstances, nop ), @@@ -1736,11 -1760,6 +1777,11 @@@ impliedFlag , (Opt_FlexibleInstances, turnOn, Opt_TypeSynonymInstances) , (Opt_FunctionalDependencies, turnOn, Opt_MultiParamTypeClasses) + , (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) @@@ -1874,6 -1893,7 +1915,7 @@@ glasgowExtsFlags = , Opt_DeriveFunctor , Opt_DeriveFoldable , Opt_DeriveTraversable + , Opt_DeriveGeneric , Opt_FlexibleContexts , Opt_FlexibleInstances , Opt_ConstrainedClassMethods @@@ -1926,13 -1946,21 +1968,21 @@@ checkTemplateHaskellOk _ = return ( type DynP = EwM (CmdLineP DynFlags) upd :: (DynFlags -> DynFlags) -> DynP () - upd f = liftEwM (do { dfs <- getCmdLineState - ; putCmdLineState $! (f dfs) }) + upd f = liftEwM (do dflags <- getCmdLineState + putCmdLineState $! f dflags) + + updM :: (DynFlags -> DynP DynFlags) -> DynP () + updM f = do dflags <- liftEwM getCmdLineState + dflags' <- f dflags + liftEwM $ putCmdLineState $! dflags' --------------- Constructor functions for OptKind ----------------- noArg :: (DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) noArg fn = NoArg (upd fn) + noArgM :: (DynFlags -> DynP DynFlags) -> OptKind (CmdLineP DynFlags) + noArgM fn = NoArg (updM fn) + noArgDF :: (DynFlags -> DynFlags) -> String -> OptKind (CmdLineP DynFlags) noArgDF fn deprec = NoArg (upd fn >> deprecate deprec) @@@ -1946,6 -1974,10 +1996,10 @@@ hasArgDF fn deprec = HasArg (\s -> do intSuffix :: (Int -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) intSuffix fn = IntSuffix (\n -> upd (fn n)) + optIntSuffixM :: (Maybe Int -> DynFlags -> DynP DynFlags) + -> OptKind (CmdLineP DynFlags) + optIntSuffixM fn = OptIntSuffix (\mi -> updM (fn mi)) + setDumpFlag :: DynFlag -> OptKind (CmdLineP DynFlags) setDumpFlag dump_flag = NoArg (setDumpFlag' dump_flag) @@@ -1993,14 -2025,13 +2047,13 @@@ forceRecompile :: DynP ( -- recompiled which probably isn't what you want forceRecompile = do { dfs <- liftEwM getCmdLineState ; when (force_recomp dfs) (setDynFlag Opt_ForceRecomp) } - where + where force_recomp dfs = isOneShot (ghcMode dfs) setVerboseCore2Core :: DynP () setVerboseCore2Core = do forceRecompile setDynFlag Opt_D_verbose_core2core upd (\dfs -> dfs { shouldDumpSimplPhase = Nothing }) - setDumpSimplPhases :: String -> DynP () setDumpSimplPhases s = do forceRecompile @@@ -2044,20 -2075,43 +2097,43 @@@ setTarget l = upd se -- not from bytecode to object-code. The idea is that -fasm/-fllvm -- can be safely used in an OPTIONS_GHC pragma. setObjTarget :: HscTarget -> DynP () - setObjTarget l = upd set + setObjTarget l = updM set where - set dfs - | isObjectTarget (hscTarget dfs) = dfs { hscTarget = l } - | otherwise = dfs - - setOptLevel :: Int -> DynFlags -> DynFlags + set dflags + | isObjectTarget (hscTarget dflags) + = case l of + HscC + | cGhcUnregisterised /= "YES" -> + do addWarn ("Compiler not unregisterised, so ignoring " ++ flag) + return dflags + HscAsm + | cGhcWithNativeCodeGen /= "YES" -> + do addWarn ("Compiler has no native codegen, so ignoring " ++ + flag) + return dflags + HscLlvm + | cGhcUnregisterised == "YES" -> + do addWarn ("Compiler unregisterised, so ignoring " ++ flag) + return dflags + | not ((arch == ArchX86_64) && (os == OSLinux || os == OSDarwin)) && + (not opt_Static || opt_PIC) + -> + do addWarn ("Ignoring " ++ flag ++ " as it is incompatible with -fPIC and -dynamic on this platform") + return dflags + _ -> return $ dflags { hscTarget = l } + | otherwise = return dflags + where platform = targetPlatform dflags + arch = platformArch platform + os = platformOS platform + flag = showHscTargetFlag l + + setOptLevel :: Int -> DynFlags -> DynP DynFlags setOptLevel n dflags | hscTarget dflags == HscInterpreted && n > 0 - = dflags - -- not in IO any more, oh well: - -- putStr "warning: -O conflicts with --interactive; -O ignored.\n" + = do addWarn "-O conflicts with --interactive; -O ignored." + return dflags | otherwise - = updOptLevel n dflags + = return (updOptLevel n dflags) -- -Odph is equivalent to @@@ -2066,7 -2120,7 +2142,7 @@@ -- -fmax-simplifier-iterations20 this is necessary sometimes -- -fsimplifier-phases=3 we use an additional simplifier phase for fusion -- - setDPHOpt :: DynFlags -> DynFlags + setDPHOpt :: DynFlags -> DynP DynFlags setDPHOpt dflags = setOptLevel 2 (dflags { maxSimplIterations = 20 , simplPhases = 3 }) @@@ -2118,7 -2172,6 +2194,6 @@@ addImportPath, addLibraryPath, addInclu addImportPath "" = upd (\s -> s{importPaths = []}) addImportPath p = upd (\s -> s{importPaths = importPaths s ++ splitPathList p}) - addLibraryPath p = upd (\s -> s{libraryPaths = libraryPaths s ++ splitPathList p}) @@@ -2222,37 -2275,6 +2297,6 @@@ setOptHpcDir arg = upd $ \ d -> d{hpcD -- The options below are not dependent on the version of gcc, only the -- platform. - machdepCCOpts :: DynFlags -> [String] -- flags for all C compilations - machdepCCOpts _ = cCcOpts ++ machdepCCOpts' - - machdepCCOpts' :: [String] -- flags for all C compilations - machdepCCOpts' - #if alpha_TARGET_ARCH - = ["-w", "-mieee" - #ifdef HAVE_THREADED_RTS_SUPPORT - , "-D_REENTRANT" - #endif - ] - -- For now, to suppress the gcc warning "call-clobbered - -- register used for global register variable", we simply - -- disable all warnings altogether using the -w flag. Oh well. - - #elif hppa_TARGET_ARCH - -- ___HPUX_SOURCE, not _HPUX_SOURCE, is #defined if -ansi! - -- (very nice, but too bad the HP /usr/include files don't agree.) - = ["-D_HPUX_SOURCE"] - - #elif i386_TARGET_ARCH - -- -fno-defer-pop : basically the same game as for m68k - -- - -- -fomit-frame-pointer : *must* in .hc files; because we're stealing - -- the fp (%ebp) for our register maps. - = if opt_Static then ["-DDONT_WANT_WIN32_DLL_SUPPORT"] else [] - - #else - = [] - #endif - picCCOpts :: DynFlags -> [String] picCCOpts _dflags #if darwin_TARGET_OS @@@ -2322,7 -2344,6 +2366,6 @@@ compilerInfo dflag ("Debug on", show debugIsOn), ("LibDir", topDir dflags), ("Global Package DB", systemPackageConfig dflags), - ("C compiler flags", show cCcOpts), ("Gcc Linker flags", show cGccLinkerOpts), ("Ld Linker flags", show cLdLinkerOpts) ] diff --combined compiler/parser/Lexer.x index d6b2322,a55a631..4ca0282 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@@ -55,7 -55,6 +55,7 @@@ module Lexer getLexState, popLexState, pushLexState, extension, bangPatEnabled, datatypeContextsEnabled, addWarning, + incrBracketDepth, decrBracketDepth, getParserBrakDepth, lexTokenStream ) where @@@ -69,7 -68,7 +69,7 @@@ import UniqF import DynFlags import Module import Ctype - import BasicTypes ( InlineSpec(..), RuleMatchInfo(..) ) + import BasicTypes ( InlineSpec(..), RuleMatchInfo(..), FractionalLit(..) ) import Util ( readRational ) import Control.Monad @@@ -326,15 -325,6 +326,15 @@@ $tab+ { warn Opt_WarnTabs (tex } <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 } } @@@ -345,11 -335,6 +345,6 @@@ { token ITcubxparen } } - <0> { - "{|" / { ifExtension genericsEnabled } { token ITocurlybar } - "|}" / { ifExtension genericsEnabled } { token ITccurlybar } - } - <0,option_prags> { \( { special IToparen } \) { special ITcparen } @@@ -551,14 -536,14 +546,14 @@@ data Toke | ITchar Char | ITstring FastString | ITinteger Integer - | ITrational Rational + | ITrational FractionalLit | ITprimchar Char | ITprimstring FastString | ITprimint Integer | ITprimword Integer - | ITprimfloat Rational - | ITprimdouble Rational + | ITprimfloat FractionalLit + | ITprimdouble FractionalLit -- Template Haskell extension tokens | ITopenExpQuote -- [| or [e| @@@ -582,13 -567,6 +577,13 @@@ | 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 @@@ -1078,9 -1056,12 +1073,12 @@@ hexadecimal = (16,hexDigit -- readRational can understand negative rationals, exponents, everything. tok_float, tok_primfloat, tok_primdouble :: String -> Token - tok_float str = ITrational $! readRational str - tok_primfloat str = ITprimfloat $! readRational str - tok_primdouble str = ITprimdouble $! readRational str + tok_float str = ITrational $! readFractionalLit str + tok_primfloat str = ITprimfloat $! readFractionalLit str + tok_primdouble str = ITprimdouble $! readFractionalLit str + + readFractionalLit :: String -> FractionalLit + readFractionalLit str = (FL $! str) $! readRational str -- ----------------------------------------------------------------------------- -- Layout processing @@@ -1542,8 -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 @@@ -1610,13 -1590,6 +1608,13 @@@ setExts f = P $ \s -> POk s{ extsBitma 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 @@@ -1776,8 -1749,10 +1774,10 @@@ setAlrExpectingOCurly b = P $ \s -> PO -- -fglasgow-exts or -XParallelArrays) are represented by a bitmap stored in an unboxed -- integer - genericsBit :: Int - genericsBit = 0 -- {| and |} + -- The "genericsBit" is now unused, available for others + -- genericsBit :: Int + -- genericsBit = 0 -- {|, |} and "generic" + ffiBit :: Int ffiBit = 1 parrBit :: Int @@@ -1825,19 -1800,13 +1825,17 @@@ relaxedLayoutBit :: In relaxedLayoutBit = 24 nondecreasingIndentationBit :: Int nondecreasingIndentationBit = 25 +hetMetBit :: Int +hetMetBit = 31 always :: Int -> Bool always _ = True - genericsEnabled :: Int -> Bool - genericsEnabled flags = testBit flags genericsBit 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 @@@ -1885,7 -1854,7 +1883,7 @@@ pragState dynflags buf loc = (mkPState mkPState :: DynFlags -> StringBuffer -> SrcLoc -> PState mkPState flags buf loc = PState { - buffer = buf, + buffer = buf, dflags = flags, messages = emptyMessages, last_loc = mkSrcSpan loc loc, @@@ -1899,39 -1868,37 +1897,39 @@@ 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 - .|. explicitForallBit `setBitIf` xopt Opt_ExplicitForAll flags - .|. bangPatBit `setBitIf` xopt Opt_BangPatterns flags - .|. tyFamBit `setBitIf` xopt Opt_TypeFamilies flags - .|. haddockBit `setBitIf` dopt Opt_Haddock flags - .|. magicHashBit `setBitIf` xopt Opt_MagicHash flags - .|. kindSigsBit `setBitIf` xopt Opt_KindSignatures flags - .|. recursiveDoBit `setBitIf` xopt Opt_RecursiveDo flags - .|. recBit `setBitIf` xopt Opt_DoRec flags - .|. recBit `setBitIf` xopt Opt_Arrows flags - .|. unicodeSyntaxBit `setBitIf` xopt Opt_UnicodeSyntax flags - .|. unboxedTuplesBit `setBitIf` xopt Opt_UnboxedTuples flags + bitmap = 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 + .|. explicitForallBit `setBitIf` xopt Opt_ExplicitForAll flags + .|. bangPatBit `setBitIf` xopt Opt_BangPatterns flags + .|. tyFamBit `setBitIf` xopt Opt_TypeFamilies flags + .|. haddockBit `setBitIf` dopt Opt_Haddock flags + .|. magicHashBit `setBitIf` xopt Opt_MagicHash flags + .|. kindSigsBit `setBitIf` xopt Opt_KindSignatures flags + .|. recursiveDoBit `setBitIf` xopt Opt_RecursiveDo flags + .|. recBit `setBitIf` xopt Opt_DoRec flags + .|. recBit `setBitIf` xopt Opt_Arrows flags + .|. unicodeSyntaxBit `setBitIf` xopt Opt_UnicodeSyntax flags + .|. unboxedTuplesBit `setBitIf` xopt Opt_UnboxedTuples flags .|. datatypeContextsBit `setBitIf` xopt Opt_DatatypeContexts flags .|. transformComprehensionsBit `setBitIf` xopt Opt_TransformListComp flags + .|. transformComprehensionsBit `setBitIf` xopt Opt_MonadComprehensions flags .|. rawTokenStreamBit `setBitIf` dopt Opt_KeepRawTokenStream flags .|. alternativeLayoutRuleBit `setBitIf` xopt Opt_AlternativeLayoutRule flags - .|. relaxedLayoutBit `setBitIf` xopt Opt_RelaxedLayout flags + .|. relaxedLayoutBit `setBitIf` xopt Opt_RelaxedLayout flags .|. nondecreasingIndentationBit `setBitIf` xopt Opt_NondecreasingIndentation flags -- setBitIf :: Int -> Bool -> Int b `setBitIf` cond | cond = bit b - | otherwise = 0 + | otherwise = 0 addWarning :: DynFlag -> SrcSpan -> SDoc -> P () addWarning option srcspan warning diff --combined compiler/parser/Parser.y.pp index 26bb4e7,102f989..a71323f --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@@ -39,7 -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, @@@ -306,11 -306,6 +306,11 @@@ incorrect '#)' { L _ ITcubxparen } '(|' { L _ IToparenbar } '|)' { L _ ITcparenbar } + '<[' { L _ ITopenBrak } + ']>' { L _ ITcloseBrak } + '~~' { L _ ITescape } + '~~$' { L _ ITescapeDollar } + '%%' { L _ ITdoublePercent } ';' { L _ ITsemi } ',' { L _ ITcomma } '`' { L _ ITbackquote } @@@ -476,7 -471,7 +476,7 @@@ export :: { LIE RdrName | oqtycon '(' ')' { LL (IEThingWith (unLoc $1) []) } | oqtycon '(' qcnames ')' { LL (IEThingWith (unLoc $1) (reverse $3)) } | 'module' modid { LL (IEModuleContents (unLoc $2)) } - + | '<[' incdepth export decdepth ']>' { $3 } qcnames :: { [RdrName] } : qcnames ',' qcname_ext { unLoc $3 : $1 } | qcname_ext { [unLoc $1] } @@@ -726,6 -721,11 +726,11 @@@ decl_cls :: { Located (OrdList (LHsDec decl_cls : at_decl_cls { LL (unitOL (L1 (TyClD (unLoc $1)))) } | decl { $1 } + -- A 'default' signature used with the generic-programming extension + | 'default' infixexp '::' sigtypedoc + {% do { (TypeSig l ty) <- checkValSig $2 $4 + ; return (LL $ unitOL (LL $ SigD (GenericSig l ty))) } } + decls_cls :: { Located (OrdList (LHsDecl RdrName)) } -- Reversed : decls_cls ';' decl_cls { LL (unLoc $1 `appOL` unLoc $3) } | decls_cls ';' { LL (unLoc $1) } @@@ -1020,7 -1020,6 +1025,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) } @@@ -1028,8 -1027,6 +1033,6 @@@ | '$(' exp ')' { LL $ mkHsSpliceTy $2 } | TH_ID_SPLICE { LL $ mkHsSpliceTy $ L1 $ HsVar $ mkUnqual varName (getTH_ID_SPLICE $1) } - -- Generics - | INTEGER { L1 (HsNumTy (getINTEGER $1)) } -- An inst_type is what occurs in the head of an instance decl -- e.g. (Foo a, Gaz b) => Wibble a b @@@ -1224,7 -1221,6 +1227,7 @@@ decl :: { Located (OrdList (LHsDecl Rd | 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) } @@@ -1239,10 -1235,11 +1242,11 @@@ gdrh :: { LGRHS RdrName : '|' guardquals '=' exp { sL (comb2 $1 $>) $ GRHS (unLoc $2) $4 } 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 - + : + -- See Note [Declaration/signature overlap] for why we need infixexp here + infixexp '::' sigtypedoc + {% do s <- checkValSig $1 $3 + ; return (LL $ unitOL (LL $ SigD s)) } | 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)))) @@@ -1267,10 -1264,6 +1271,10 @@@ quasiquote :: { Located (HsQuasiQuote R ; 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 } @@@ -1278,7 -1271,6 +1282,7 @@@ | 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 } @@@ -1296,14 -1288,9 +1300,9 @@@ exp10 :: { LHsExpr RdrName | 'case' exp 'of' altslist { LL $ HsCase $2 (mkMatchGroup (unLoc $4)) } | '-' fexp { LL $ NegApp $2 noSyntaxExpr } - | 'do' stmtlist {% let loc = comb2 $1 $2 in - checkDo loc (unLoc $2) >>= \ (stmts,body) -> - return (L loc (mkHsDo DoExpr stmts body)) } - | 'mdo' stmtlist {% let loc = comb2 $1 $2 in - checkDo loc (unLoc $2) >>= \ (stmts,body) -> - return (L loc (mkHsDo MDoExpr - [L loc (mkRecStmt stmts)] - body)) } + | 'do' stmtlist { L (comb2 $1 $2) (mkHsDo DoExpr (unLoc $2)) } + | 'mdo' stmtlist { L (comb2 $1 $2) (mkHsDo MDoExpr (unLoc $2)) } + | scc_annot exp { LL $ if opt_SccProfilingOn then HsSCC (unLoc $1) $2 else HsPar $2 } @@@ -1409,11 -1396,6 +1408,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 -} { [] } @@@ -1483,7 -1465,10 +1482,10 @@@ list :: { LHsExpr RdrName | texp ',' exp '..' { LL $ ArithSeq noPostTcExpr (FromThen $1 $3) } | texp '..' exp { LL $ ArithSeq noPostTcExpr (FromTo $1 $3) } | texp ',' exp '..' exp { LL $ ArithSeq noPostTcExpr (FromThenTo $1 $3 $5) } - | texp '|' flattenedpquals { sL (comb2 $1 $>) $ mkHsDo ListComp (unLoc $3) $1 } + | texp '|' flattenedpquals + {% checkMonadComp >>= \ ctxt -> + return (sL (comb2 $1 $>) $ + mkHsComp ctxt (unLoc $3) $1) } lexps :: { Located [LHsExpr RdrName] } : lexps ',' texp { LL (((:) $! $3) $! unLoc $1) } @@@ -1498,7 -1483,7 +1500,7 @@@ flattenedpquals :: { Located [LStmt Rdr -- We just had one thing in our "parallel" list so -- we simply return that thing directly - qss -> L1 [L1 $ ParStmt [(qs, undefined) | qs <- qss]] + qss -> L1 [L1 $ ParStmt [(qs, undefined) | qs <- qss] noSyntaxExpr noSyntaxExpr noSyntaxExpr] -- We actually found some actual parallel lists so -- we wrap them into as a ParStmt } @@@ -1519,8 -1504,7 +1521,7 @@@ squals :: { Located [LStmt RdrName] } - -- It is possible to enable bracketing (associating) qualifier lists by uncommenting the lines with {| |} -- above. Due to a lack of consensus on the syntax, this feature is not being used until we get user - -- demand. Note that the {| |} symbols are reused from -XGenerics and hence if you want to compile - -- a program that makes use of this temporary syntax you must supply that flag to GHC + -- demand. transformqual :: { Located ([LStmt RdrName] -> Stmt RdrName) } -- Function is applied to a list of stmts *in order* @@@ -1555,7 -1539,7 +1556,7 @@@ parr :: { LHsExpr RdrName (reverse (unLoc $1)) } | texp '..' exp { LL $ PArrSeq noPostTcExpr (FromTo $1 $3) } | texp ',' exp '..' exp { LL $ PArrSeq noPostTcExpr (FromThenTo $1 $3 $5) } - | texp '|' flattenedpquals { LL $ mkHsDo PArrComp (unLoc $3) $1 } + | texp '|' flattenedpquals { LL $ mkHsComp PArrComp (unLoc $3) $1 } -- We are reusing `lexps' and `flattenedpquals' from the list case. @@@ -1845,7 -1829,7 +1846,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") } @@@ -1870,10 -1854,9 +1871,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 --combined compiler/parser/RdrHsSyn.lhs index 49036d9,a943344..0e265e9 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@@ -40,8 -40,7 +40,7 @@@ module RdrHsSyn checkPattern, -- HsExp -> P HsPat bang_RDR, checkPatterns, -- SrcLoc -> [HsExp] -> P [HsPat] - checkDo, -- [Stmt] -> P [Stmt] - checkMDo, -- [Stmt] -> P [Stmt] + checkMonadComp, -- P (HsStmtContext RdrName) checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl checkValSig, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl checkDoAndIfThenElse, @@@ -54,6 -53,7 +53,7 @@@ import Class ( FunDep import TypeRep ( Kind ) import RdrName ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc, isRdrDataCon, isUnqual, getRdrName, setRdrNameSpace ) + import Name ( Name ) import BasicTypes ( maxPrecedence, Activation(..), RuleMatchInfo, InlinePragma(..), InlineSpec(..) ) import Lexer @@@ -122,13 -122,11 +122,12 @@@ extract_lty (L loc ty) ac 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 (extract_tv loc ecn acc) HsTupleTy _ tys -> extract_ltys tys acc HsFunTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc) HsPredTy p -> extract_pred p acc HsOpTy ty1 (L loc tv) ty2 -> extract_tv loc tv (extract_lty ty1 (extract_lty ty2 acc)) HsParTy ty -> extract_lty ty acc - HsNumTy {} -> acc HsCoreTy {} -> acc -- The type is closed HsQuasiQuoteTy {} -> acc -- Quasi quotes mention no type variables HsSpliceTy {} -> acc -- Type splices mention no type variables @@@ -153,8 -151,7 +152,7 @@@ extractGenericPatTyVars bind get (L _ (FunBind { fun_matches = MatchGroup ms _ })) acc = foldr (get_m.unLoc) acc ms get _ acc = acc - get_m (Match (L _ (TypePat ty) : _) _ _) acc = extract_lty ty acc - get_m _ acc = acc + get_m _ acc = acc \end{code} @@@ -612,34 -609,6 +610,6 @@@ checkPred (L spn ty check loc _ _ = parseErrorSDoc loc (text "malformed class assertion:" <+> ppr ty) - --------------------------------------------------------------------------- - -- Checking statements in a do-expression - -- We parse do { e1 ; e2 ; } - -- as [ExprStmt e1, ExprStmt e2] - -- checkDo (a) checks that the last thing is an ExprStmt - -- (b) returns it separately - -- same comments apply for mdo as well - - checkDo, checkMDo :: SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName) - - checkDo = checkDoMDo "a " "'do'" - checkMDo = checkDoMDo "an " "'mdo'" - - checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName) - checkDoMDo _ nm loc [] = parseErrorSDoc loc (text ("Empty " ++ nm ++ " construct")) - checkDoMDo pre nm _ ss = do - check ss - where - check [] = panic "RdrHsSyn:checkDoMDo" - check [L _ (ExprStmt e _ _)] = return ([], e) - check [L l e] = parseErrorSDoc l - (text ("The last statement in " ++ pre ++ nm ++ - " construct must be an expression:") - $$ ppr e) - check (s:ss) = do - (ss',e') <- check ss - return ((s:ss'),e') - -- ------------------------------------------------------------------------- -- Checking Patterns. @@@ -677,7 -646,6 +647,7 @@@ checkAPat :: DynFlags -> SrcSpan -> HsE checkAPat dynflags loc e0 = case e0 of EWildPat -> return (WildPat placeHolderType) HsVar x -> return (VarPat x) + HsHetMetBrak _ p -> checkAPat dynflags loc (unLoc p) HsLit l -> return (LitPat l) -- Overloaded numeric patterns (e.g. f 0 x = x) @@@ -734,8 -702,6 +704,6 @@@ -> do fs <- mapM checkPatField fs return (ConPatIn c (RecCon (HsRecFields fs dd))) HsQuasiQuoteE q -> return (QuasiQuotePat q) - -- Generics - HsType ty -> return (TypePat ty) _ -> patFail loc e0 placeHolderPunRhs :: LHsExpr RdrName @@@ -806,8 -772,6 +774,8 @@@ checkValSi :: 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) @@@ -816,17 -780,20 +784,20 @@@ checkValSig lhs@(L l _) t ppr lhs <+> text "::" <+> ppr ty) $$ text hint) where - hint = if looks_like_foreign lhs + hint = if foreign_RDR `looks_like` lhs then "Perhaps you meant to use -XForeignFunctionInterface?" - else "Should be of form :: " + else if default_RDR `looks_like` lhs + then "Perhaps you meant to use -XDefaultSignatures?" + else "Should be of form :: " -- A common error is to forget the ForeignFunctionInterface flag -- so check for that, and suggest. cf Trac #3805 -- Sadly 'foreign import' still barfs 'parse error' because 'import' is a keyword - looks_like_foreign (L _ (HsVar v)) = v == foreign_RDR - looks_like_foreign (L _ (HsApp lhs _)) = looks_like_foreign lhs - looks_like_foreign _ = False + looks_like s (L _ (HsVar v)) = v == s + looks_like s (L _ (HsApp lhs _)) = looks_like s lhs + looks_like _ _ = False foreign_RDR = mkUnqual varName (fsLit "foreign") + default_RDR = mkUnqual varName (fsLit "default") checkDoAndIfThenElse :: LHsExpr RdrName -> Bool @@@ -916,6 -883,20 +887,20 @@@ isFunLhs e = go e [ _ -> return Nothing } go _ _ = return Nothing + + --------------------------------------------------------------------------- + -- Check for monad comprehensions + -- + -- If the flag MonadComprehensions is set, return a `MonadComp' context, + -- otherwise use the usual `ListComp' context + + checkMonadComp :: P (HsStmtContext Name) + checkMonadComp = do + pState <- getPState + return $ if xopt Opt_MonadComprehensions (dflags pState) + then MonadComp + else ListComp + --------------------------------------------------------------------------- -- Miscellaneous utilities diff --combined compiler/prelude/PrelNames.lhs index 76ce5ce,101780d..aa5de15 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@@ -94,7 -94,7 +94,7 @@@ isUnboundName name = name `hasKey` unbo %* * %************************************************************************ - This section tells what the compiler knows about the assocation of + This section tells what the compiler knows about the association of names with uniques. These ones are the *non* wired-in ones. The wired in ones are defined in TysWiredIn etc. @@@ -160,6 -160,7 +160,7 @@@ basicKnownKeyName -- Monad stuff thenIOName, bindIOName, returnIOName, failIOName, failMName, bindMName, thenMName, returnMName, + fmapName, -- MonadRec stuff mfixName, @@@ -212,32 -213,6 +213,32 @@@ -- Other classes randomClassName, randomGenClassName, monadPlusClassName, + -- Code types + hetmet_brak_name, hetmet_esc_name, hetmet_csp_name, hetmet_flatten_name, hetmet_unflatten_name, hetmet_flattened_id_name, + hetmet_guest_integer_literal_name, hetmet_guest_string_literal_name, + hetmet_guest_char_literal_name, + hetmet_PGArrow_name, + hetmet_PGArrow_unit_name, + hetmet_PGArrow_tensor_name, + hetmet_PGArrow_exponent_name, + hetmet_pga_id_name, + hetmet_pga_comp_name, + hetmet_pga_first_name, + hetmet_pga_second_name, + hetmet_pga_cancell_name, + hetmet_pga_cancelr_name, + hetmet_pga_uncancell_name, + hetmet_pga_uncancelr_name, + hetmet_pga_assoc_name, + hetmet_pga_unassoc_name, + hetmet_pga_copy_name, + hetmet_pga_drop_name, + hetmet_pga_swap_name, + hetmet_pga_applyl_name, + hetmet_pga_applyr_name, + hetmet_pga_curryl_name, + hetmet_pga_curryr_name, + -- Annotation type checking toAnnotationWrapperName @@@ -247,10 -222,27 +248,27 @@@ -- dotnet interop , objectTyConName, marshalObjectName, unmarshalObjectName , marshalStringName, unmarshalStringName, checkDotnetResName + + -- Generics + , genClassName, gen1ClassName + , datatypeClassName, constructorClassName, selectorClassName + + -- Monad comprehensions + , guardMName + , liftMName + , groupMName + , mzipName ] genericTyConNames :: [Name] - genericTyConNames = [crossTyConName, plusTyConName, genUnitTyConName] + genericTyConNames = [ + v1TyConName, u1TyConName, par1TyConName, rec1TyConName, + k1TyConName, m1TyConName, sumTyConName, prodTyConName, + compTyConName, rTyConName, pTyConName, dTyConName, + cTyConName, sTyConName, rec0TyConName, par0TyConName, + d1TyConName, c1TyConName, s1TyConName, noSelTyConName, + repTyConName, rep1TyConName + ] -- Know names from the DPH package which vary depending on the selected DPH backend. -- @@@ -282,17 -274,15 +300,18 @@@ pRELUDE = mkBaseModule_ pRELUDE_NAM gHC_PRIM, gHC_TYPES, gHC_UNIT, gHC_ORDERING, gHC_GENERICS, gHC_MAGIC, - gHC_CLASSES, gHC_BASE, gHC_ENUM, + gHC_CLASSES, gHC_BASE, gHC_ENUM, gHC_CSTRING, gHC_SHOW, gHC_READ, gHC_NUM, gHC_INTEGER, gHC_INTEGER_TYPE, gHC_LIST, + gHC_HETMET_CODETYPES, + gHC_HETMET_PRIVATE, + gHC_HETMET_GARROW, 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_FLOAT, gHC_TOP_HANDLER, sYSTEM_IO, dYNAMIC, tYPEABLE, gENERICS, - dOTNET, rEAD_PREC, lEX, gHC_INT, gHC_WORD, mONAD, mONAD_FIX, aRROW, cONTROL_APPLICATIVE, - gHC_DESUGAR, rANDOM, gHC_EXTS, cONTROL_EXCEPTION_BASE :: Module + dOTNET, rEAD_PREC, lEX, gHC_INT, gHC_WORD, mONAD, mONAD_FIX, mONAD_GROUP, mONAD_ZIP, + aRROW, cONTROL_APPLICATIVE, gHC_DESUGAR, rANDOM, gHC_EXTS, + cONTROL_EXCEPTION_BASE :: Module gHC_PRIM = mkPrimModule (fsLit "GHC.Prim") -- Primitive types and values gHC_TYPES = mkPrimModule (fsLit "GHC.Types") @@@ -300,6 -290,7 +319,7 @@@ gHC_UNIT = mkPrimModule (fsLit "GHC.Uni gHC_ORDERING = mkPrimModule (fsLit "GHC.Ordering") gHC_GENERICS = mkPrimModule (fsLit "GHC.Generics") gHC_MAGIC = mkPrimModule (fsLit "GHC.Magic") + gHC_CSTRING = mkPrimModule (fsLit "GHC.CString") gHC_CLASSES = mkBaseModule (fsLit "GHC.Classes") gHC_BASE = mkBaseModule (fsLit "GHC.Base") @@@ -309,9 -300,6 +329,9 @@@ gHC_READ = mkBaseModule (fsLit "GHC.Rea gHC_NUM = mkBaseModule (fsLit "GHC.Num") gHC_INTEGER = mkIntegerModule (fsLit "GHC.Integer") gHC_INTEGER_TYPE= mkIntegerModule (fsLit "GHC.Integer.Type") +gHC_HETMET_CODETYPES = mkBaseModule (fsLit "GHC.HetMet.CodeTypes") +gHC_HETMET_PRIVATE = mkBaseModule (fsLit "GHC.HetMet.Private") +gHC_HETMET_GARROW = mkBaseModule (fsLit "GHC.HetMet.GArrow") gHC_LIST = mkBaseModule (fsLit "GHC.List") gHC_TUPLE = mkPrimModule (fsLit "GHC.Tuple") dATA_TUPLE = mkBaseModule (fsLit "Data.Tuple") @@@ -343,6 -331,8 +363,8 @@@ gHC_INT = mkBaseModule (fsLit "GHC.Int gHC_WORD = mkBaseModule (fsLit "GHC.Word") mONAD = mkBaseModule (fsLit "Control.Monad") mONAD_FIX = mkBaseModule (fsLit "Control.Monad.Fix") + mONAD_GROUP = mkBaseModule (fsLit "Control.Monad.Group") + mONAD_ZIP = mkBaseModule (fsLit "Control.Monad.Zip") aRROW = mkBaseModule (fsLit "Control.Arrow") cONTROL_APPLICATIVE = mkBaseModule (fsLit "Control.Applicative") gHC_DESUGAR = mkBaseModule (fsLit "GHC.Desugar") @@@ -557,12 -547,59 +579,59 @@@ mkTyConRep_RDR = varQual_RDR tYPEABLE ( undefined_RDR :: RdrName undefined_RDR = varQual_RDR gHC_ERR (fsLit "undefined") + error_RDR :: RdrName + error_RDR = varQual_RDR gHC_ERR (fsLit "error") + + -- Old Generics (constructors and functions) crossDataCon_RDR, inlDataCon_RDR, inrDataCon_RDR, genUnitDataCon_RDR :: RdrName crossDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit ":*:") inlDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Inl") inrDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Inr") genUnitDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Unit") + -- Generics (constructors and functions) + u1DataCon_RDR, par1DataCon_RDR, rec1DataCon_RDR, + k1DataCon_RDR, m1DataCon_RDR, l1DataCon_RDR, r1DataCon_RDR, + prodDataCon_RDR, comp1DataCon_RDR, from_RDR, from1_RDR, + to_RDR, to1_RDR, datatypeName_RDR, moduleName_RDR, conName_RDR, + conFixity_RDR, conIsRecord_RDR, + noArityDataCon_RDR, arityDataCon_RDR, selName_RDR, + prefixDataCon_RDR, infixDataCon_RDR, leftAssocDataCon_RDR, + rightAssocDataCon_RDR, notAssocDataCon_RDR :: RdrName + + u1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "U1") + par1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Par1") + rec1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Rec1") + k1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "K1") + m1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "M1") + + l1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "L1") + r1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "R1") + + prodDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit ":*:") + comp1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Comp1") + + from_RDR = varQual_RDR gHC_GENERICS (fsLit "from") + from1_RDR = varQual_RDR gHC_GENERICS (fsLit "from1") + to_RDR = varQual_RDR gHC_GENERICS (fsLit "to") + to1_RDR = varQual_RDR gHC_GENERICS (fsLit "to1") + + datatypeName_RDR = varQual_RDR gHC_GENERICS (fsLit "datatypeName") + moduleName_RDR = varQual_RDR gHC_GENERICS (fsLit "moduleName") + selName_RDR = varQual_RDR gHC_GENERICS (fsLit "selName") + conName_RDR = varQual_RDR gHC_GENERICS (fsLit "conName") + conFixity_RDR = varQual_RDR gHC_GENERICS (fsLit "conFixity") + conIsRecord_RDR = varQual_RDR gHC_GENERICS (fsLit "conIsRecord") + + noArityDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "NoArity") + arityDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Arity") + prefixDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Prefix") + infixDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Infix") + leftAssocDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "LeftAssociative") + rightAssocDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "RightAssociative") + notAssocDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "NotAssociative") + + fmap_RDR, pure_RDR, ap_RDR, foldable_foldr_RDR, traverse_RDR :: RdrName fmap_RDR = varQual_RDR gHC_BASE (fsLit "fmap") pure_RDR = varQual_RDR cONTROL_APPLICATIVE (fsLit "pure") @@@ -608,19 -645,48 +677,48 @@@ eitherTyConName = tcQual dATA_EITHE leftDataConName = conName dATA_EITHER (fsLit "Left") leftDataConKey rightDataConName = conName dATA_EITHER (fsLit "Right") rightDataConKey - -- Generics - crossTyConName, plusTyConName, genUnitTyConName :: Name - crossTyConName = tcQual gHC_GENERICS (fsLit ":*:") crossTyConKey - plusTyConName = tcQual gHC_GENERICS (fsLit ":+:") plusTyConKey - genUnitTyConName = tcQual gHC_GENERICS (fsLit "Unit") genUnitTyConKey + -- Generics (types) + v1TyConName, u1TyConName, par1TyConName, rec1TyConName, + k1TyConName, m1TyConName, sumTyConName, prodTyConName, + compTyConName, rTyConName, pTyConName, dTyConName, + cTyConName, sTyConName, rec0TyConName, par0TyConName, + d1TyConName, c1TyConName, s1TyConName, noSelTyConName, + repTyConName, rep1TyConName :: Name + + v1TyConName = tcQual gHC_GENERICS (fsLit "V1") v1TyConKey + u1TyConName = tcQual gHC_GENERICS (fsLit "U1") u1TyConKey + par1TyConName = tcQual gHC_GENERICS (fsLit "Par1") par1TyConKey + rec1TyConName = tcQual gHC_GENERICS (fsLit "Rec1") rec1TyConKey + k1TyConName = tcQual gHC_GENERICS (fsLit "K1") k1TyConKey + m1TyConName = tcQual gHC_GENERICS (fsLit "M1") m1TyConKey + + sumTyConName = tcQual gHC_GENERICS (fsLit ":+:") sumTyConKey + prodTyConName = tcQual gHC_GENERICS (fsLit ":*:") prodTyConKey + compTyConName = tcQual gHC_GENERICS (fsLit ":.:") compTyConKey + + rTyConName = tcQual gHC_GENERICS (fsLit "R") rTyConKey + pTyConName = tcQual gHC_GENERICS (fsLit "P") pTyConKey + dTyConName = tcQual gHC_GENERICS (fsLit "D") dTyConKey + cTyConName = tcQual gHC_GENERICS (fsLit "C") cTyConKey + sTyConName = tcQual gHC_GENERICS (fsLit "S") sTyConKey + + rec0TyConName = tcQual gHC_GENERICS (fsLit "Rec0") rec0TyConKey + par0TyConName = tcQual gHC_GENERICS (fsLit "Par0") par0TyConKey + d1TyConName = tcQual gHC_GENERICS (fsLit "D1") d1TyConKey + c1TyConName = tcQual gHC_GENERICS (fsLit "C1") c1TyConKey + s1TyConName = tcQual gHC_GENERICS (fsLit "S1") s1TyConKey + noSelTyConName = tcQual gHC_GENERICS (fsLit "NoSelector") noSelTyConKey + + repTyConName = tcQual gHC_GENERICS (fsLit "Rep") repTyConKey + rep1TyConName = tcQual gHC_GENERICS (fsLit "Rep1") rep1TyConKey -- Base strings Strings unpackCStringName, unpackCStringAppendName, unpackCStringFoldrName, unpackCStringUtf8Name, eqStringName, stringTyConName :: Name - unpackCStringName = varQual gHC_BASE (fsLit "unpackCString#") unpackCStringIdKey - unpackCStringAppendName = varQual gHC_BASE (fsLit "unpackAppendCString#") unpackCStringAppendIdKey - unpackCStringFoldrName = varQual gHC_BASE (fsLit "unpackFoldrCString#") unpackCStringFoldrIdKey - unpackCStringUtf8Name = varQual gHC_BASE (fsLit "unpackCStringUtf8#") unpackCStringUtf8IdKey + unpackCStringName = varQual gHC_CSTRING (fsLit "unpackCString#") unpackCStringIdKey + unpackCStringAppendName = varQual gHC_CSTRING (fsLit "unpackAppendCString#") unpackCStringAppendIdKey + unpackCStringFoldrName = varQual gHC_CSTRING (fsLit "unpackFoldrCString#") unpackCStringFoldrIdKey + unpackCStringUtf8Name = varQual gHC_CSTRING (fsLit "unpackCStringUtf8#") unpackCStringUtf8IdKey eqStringName = varQual gHC_BASE (fsLit "eqString") eqStringIdKey stringTyConName = tcQual gHC_BASE (fsLit "String") stringTyConKey @@@ -629,12 -695,13 +727,13 @@@ inlineIdName :: Nam inlineIdName = varQual gHC_MAGIC (fsLit "inline") inlineIdKey -- Base classes (Eq, Ord, Functor) - eqClassName, eqName, ordClassName, geName, functorClassName :: Name + fmapName, eqClassName, eqName, ordClassName, geName, functorClassName :: Name eqClassName = clsQual gHC_CLASSES (fsLit "Eq") eqClassKey eqName = methName gHC_CLASSES (fsLit "==") eqClassOpKey ordClassName = clsQual gHC_CLASSES (fsLit "Ord") ordClassKey geName = methName gHC_CLASSES (fsLit ">=") geClassOpKey functorClassName = clsQual gHC_BASE (fsLit "Functor") functorClassKey + fmapName = methName gHC_BASE (fsLit "fmap") fmapClassOpKey -- Class Monad monadClassName, thenMName, bindMName, returnMName, failMName :: Name @@@ -787,6 -854,16 +886,16 @@@ showClassName = clsQual gHC_SHOW (fsL readClassName :: Name readClassName = clsQual gHC_READ (fsLit "Read") readClassKey + -- Classes Generic and Generic1, Datatype, Constructor and Selector + genClassName, gen1ClassName, datatypeClassName, constructorClassName, + selectorClassName :: Name + genClassName = clsQual gHC_GENERICS (fsLit "Generic") genClassKey + gen1ClassName = clsQual gHC_GENERICS (fsLit "Generic1") gen1ClassKey + + datatypeClassName = clsQual gHC_GENERICS (fsLit "Datatype") datatypeClassKey + constructorClassName = clsQual gHC_GENERICS (fsLit "Constructor") constructorClassKey + selectorClassName = clsQual gHC_GENERICS (fsLit "Selector") selectorClassKey + -- parallel array types and functions enumFromToPName, enumFromThenToPName, nullPName, lengthPName, singletonPName, replicatePName, mapPName, filterPName, @@@ -807,62 -884,6 +916,62 @@@ toPName pkg = varQual (gHC_ emptyPName pkg = varQual (gHC_PARR pkg) (fsLit "emptyP") emptyPIdKey appPName pkg = varQual (gHC_PARR pkg) (fsLit "+:+") appPIdKey +-- code type things +hetmet_brak_name, hetmet_esc_name, hetmet_csp_name, hetmet_flatten_name, hetmet_unflatten_name, hetmet_flattened_id_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_flatten_name = varQual gHC_HETMET_CODETYPES (fsLit "pga_flatten") hetmet_flatten_key +hetmet_unflatten_name = varQual gHC_HETMET_CODETYPES (fsLit "pga_unflatten") hetmet_unflatten_key +hetmet_flattened_id_name = varQual gHC_HETMET_CODETYPES (fsLit "pga_flattened_id") hetmet_flattened_id_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 + +hetmet_PGArrow_name :: Name +hetmet_PGArrow_name = tcQual gHC_HETMET_PRIVATE (fsLit "PGArrow") hetmet_PGArrow_key +hetmet_PGArrow_unit_name :: Name +hetmet_PGArrow_unit_name = tcQual gHC_HETMET_GARROW (fsLit "GArrowUnit") hetmet_PGArrow_unit_key +hetmet_PGArrow_tensor_name :: Name +hetmet_PGArrow_tensor_name = tcQual gHC_HETMET_GARROW (fsLit "GArrowTensor") hetmet_PGArrow_tensor_key +hetmet_PGArrow_exponent_name :: Name +hetmet_PGArrow_exponent_name = tcQual gHC_HETMET_GARROW (fsLit "GArrowExponent") hetmet_PGArrow_exponent_key +hetmet_pga_id_name :: Name +hetmet_pga_id_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_id") hetmet_pga_id_key +hetmet_pga_comp_name :: Name +hetmet_pga_comp_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_comp") hetmet_pga_comp_key +hetmet_pga_first_name :: Name +hetmet_pga_first_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_first") hetmet_pga_first_key +hetmet_pga_second_name :: Name +hetmet_pga_second_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_second") hetmet_pga_second_key +hetmet_pga_cancell_name :: Name +hetmet_pga_cancell_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_cancell") hetmet_pga_cancell_key +hetmet_pga_cancelr_name :: Name +hetmet_pga_cancelr_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_cancelr") hetmet_pga_cancelr_key +hetmet_pga_uncancell_name :: Name +hetmet_pga_uncancell_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_uncancell") hetmet_pga_uncancell_key +hetmet_pga_uncancelr_name :: Name +hetmet_pga_uncancelr_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_uncancelr") hetmet_pga_uncancelr_key +hetmet_pga_assoc_name :: Name +hetmet_pga_assoc_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_assoc") hetmet_pga_assoc_key +hetmet_pga_unassoc_name :: Name +hetmet_pga_unassoc_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_unassoc") hetmet_pga_unassoc_key +hetmet_pga_copy_name :: Name +hetmet_pga_copy_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_copy") hetmet_pga_copy_key +hetmet_pga_drop_name :: Name +hetmet_pga_drop_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_drop") hetmet_pga_drop_key +hetmet_pga_swap_name :: Name +hetmet_pga_swap_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_swap") hetmet_pga_swap_key +hetmet_pga_applyl_name :: Name +hetmet_pga_applyl_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_applyl") hetmet_pga_applyl_key +hetmet_pga_applyr_name :: Name +hetmet_pga_applyr_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_applyr") hetmet_pga_applyr_key +hetmet_pga_curryl_name :: Name +hetmet_pga_curryl_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_curryl") hetmet_pga_curryl_key +hetmet_pga_curryr_name :: Name +hetmet_pga_curryr_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_curryr") hetmet_pga_curryr_key + -- IO things ioTyConName, ioDataConName, thenIOName, bindIOName, returnIOName, failIOName :: Name @@@ -922,6 -943,14 +1031,14 @@@ appAName = varQual aRROW (fsLit "app choiceAName = varQual aRROW (fsLit "|||") choiceAIdKey loopAName = varQual aRROW (fsLit "loop") loopAIdKey + -- Monad comprehensions + guardMName, liftMName, groupMName, mzipName :: Name + guardMName = varQual mONAD (fsLit "guard") guardMIdKey + liftMName = varQual mONAD (fsLit "liftM") liftMIdKey + groupMName = varQual mONAD_GROUP (fsLit "mgroupWith") groupMIdKey + mzipName = varQual mONAD_ZIP (fsLit "mzip") mzipIdKey + + -- Annotation type checking toAnnotationWrapperName :: Name toAnnotationWrapperName = varQual gHC_DESUGAR (fsLit "toAnnotationWrapper") toAnnotationWrapperIdKey @@@ -1032,6 -1061,15 +1149,15 @@@ applicativeClassKey, foldableClassKey, applicativeClassKey = mkPreludeClassUnique 34 foldableClassKey = mkPreludeClassUnique 35 traversableClassKey = mkPreludeClassUnique 36 + + genClassKey, gen1ClassKey, datatypeClassKey, constructorClassKey, + selectorClassKey :: Unique + genClassKey = mkPreludeClassUnique 37 + gen1ClassKey = mkPreludeClassUnique 38 + + datatypeClassKey = mkPreludeClassUnique 39 + constructorClassKey = mkPreludeClassUnique 40 + selectorClassKey = mkPreludeClassUnique 41 \end{code} %************************************************************************ @@@ -1091,11 -1129,12 +1217,12 @@@ statePrimTyConKey, stableNamePrimTyConK word32PrimTyConKey, word32TyConKey, word64PrimTyConKey, word64TyConKey, liftedConKey, unliftedConKey, anyBoxConKey, kindConKey, boxityConKey, typeConKey, threadIdPrimTyConKey, bcoPrimTyConKey, ptrTyConKey, - funPtrTyConKey, tVarPrimTyConKey :: Unique + funPtrTyConKey, tVarPrimTyConKey, eqPredPrimTyConKey :: Unique statePrimTyConKey = mkPreludeTyConUnique 50 stableNamePrimTyConKey = mkPreludeTyConUnique 51 - stableNameTyConKey = mkPreludeTyConUnique 52 - mutVarPrimTyConKey = mkPreludeTyConUnique 55 + stableNameTyConKey = mkPreludeTyConUnique 52 + eqPredPrimTyConKey = mkPreludeTyConUnique 53 + mutVarPrimTyConKey = mkPreludeTyConUnique 55 ioTyConKey = mkPreludeTyConUnique 56 wordPrimTyConKey = mkPreludeTyConUnique 58 wordTyConKey = mkPreludeTyConUnique 59 @@@ -1117,12 -1156,6 +1244,6 @@@ ptrTyConKey = mkPreludeTyConUnique 7 funPtrTyConKey = mkPreludeTyConUnique 75 tVarPrimTyConKey = mkPreludeTyConUnique 76 - -- Generic Type Constructors - crossTyConKey, plusTyConKey, genUnitTyConKey :: Unique - crossTyConKey = mkPreludeTyConUnique 79 - plusTyConKey = mkPreludeTyConUnique 80 - genUnitTyConKey = mkPreludeTyConUnique 81 - -- Parallel array type constructor parrTyConKey :: Unique parrTyConKey = mkPreludeTyConUnique 82 @@@ -1135,9 -1168,8 +1256,8 @@@ eitherTyConKey :: Uniqu eitherTyConKey = mkPreludeTyConUnique 84 -- Super Kinds constructors - tySuperKindTyConKey, coSuperKindTyConKey :: Unique + tySuperKindTyConKey :: Unique tySuperKindTyConKey = mkPreludeTyConUnique 85 - coSuperKindTyConKey = mkPreludeTyConUnique 86 -- Kind constructors liftedTypeKindTyConKey, openTypeKindTyConKey, unliftedTypeKindTyConKey, @@@ -1174,9 -1206,40 +1294,41 @@@ opaqueTyConKe stringTyConKey :: Unique stringTyConKey = mkPreludeTyConUnique 134 - -- Heterogeneous Metaprogramming code type constructor - hetMetCodeTypeTyConKey :: Unique - hetMetCodeTypeTyConKey = mkPreludeTyConUnique 135 + -- Generics (Unique keys) + v1TyConKey, u1TyConKey, par1TyConKey, rec1TyConKey, + k1TyConKey, m1TyConKey, sumTyConKey, prodTyConKey, + compTyConKey, rTyConKey, pTyConKey, dTyConKey, + cTyConKey, sTyConKey, rec0TyConKey, par0TyConKey, + d1TyConKey, c1TyConKey, s1TyConKey, noSelTyConKey, + repTyConKey, rep1TyConKey :: Unique + + v1TyConKey = mkPreludeTyConUnique 135 + u1TyConKey = mkPreludeTyConUnique 136 + par1TyConKey = mkPreludeTyConUnique 137 + rec1TyConKey = mkPreludeTyConUnique 138 + k1TyConKey = mkPreludeTyConUnique 139 + m1TyConKey = mkPreludeTyConUnique 140 + + sumTyConKey = mkPreludeTyConUnique 141 + prodTyConKey = mkPreludeTyConUnique 142 + compTyConKey = mkPreludeTyConUnique 143 + + rTyConKey = mkPreludeTyConUnique 144 + pTyConKey = mkPreludeTyConUnique 145 + dTyConKey = mkPreludeTyConUnique 146 + cTyConKey = mkPreludeTyConUnique 147 + sTyConKey = mkPreludeTyConUnique 148 + + rec0TyConKey = mkPreludeTyConUnique 149 + par0TyConKey = mkPreludeTyConUnique 150 + d1TyConKey = mkPreludeTyConUnique 151 + c1TyConKey = mkPreludeTyConUnique 152 + s1TyConKey = mkPreludeTyConUnique 153 + noSelTyConKey = mkPreludeTyConUnique 154 + + repTyConKey = mkPreludeTyConUnique 155 + rep1TyConKey = mkPreludeTyConUnique 156 ++>>>>>>> 18691d440f90a3dff4ef538091c886af505e5cf5 ---------------- Template Haskell ------------------- -- USES TyConUniques 200-299 @@@ -1225,10 -1288,6 +1377,10 @@@ parrDataConKey = mkPreludeDataConUni leftDataConKey, rightDataConKey :: Unique leftDataConKey = mkPreludeDataConUnique 25 rightDataConKey = mkPreludeDataConUnique 26 + +-- Data constructor for Heterogeneous Metaprogramming code types +hetMetCodeTypeDataConKey :: Unique +hetMetCodeTypeDataConKey = mkPreludeDataConUnique 27 \end{code} %************************************************************************ @@@ -1334,6 -1393,9 +1486,9 @@@ mapIdKey = mkPreludeMiscIdUnique groupWithIdKey = mkPreludeMiscIdUnique 70 dollarIdKey = mkPreludeMiscIdUnique 71 + coercionTokenIdKey :: Unique + coercionTokenIdKey = mkPreludeMiscIdUnique 72 + -- Parallel array functions singletonPIdKey, nullPIdKey, lengthPIdKey, replicatePIdKey, mapPIdKey, filterPIdKey, zipPIdKey, crossMapPIdKey, indexPIdKey, toPIdKey, @@@ -1376,7 -1438,8 +1531,8 @@@ unboundKey = mkPreludeMiscIdUniq fromIntegerClassOpKey, minusClassOpKey, fromRationalClassOpKey, enumFromClassOpKey, enumFromThenClassOpKey, enumFromToClassOpKey, enumFromThenToClassOpKey, eqClassOpKey, geClassOpKey, negateClassOpKey, - failMClassOpKey, bindMClassOpKey, thenMClassOpKey, returnMClassOpKey + failMClassOpKey, bindMClassOpKey, thenMClassOpKey, returnMClassOpKey, + fmapClassOpKey :: Unique fromIntegerClassOpKey = mkPreludeMiscIdUnique 102 minusClassOpKey = mkPreludeMiscIdUnique 103 @@@ -1391,6 -1454,7 +1547,7 @@@ negateClassOpKey = mkPreludeMiscI failMClassOpKey = mkPreludeMiscIdUnique 112 bindMClassOpKey = mkPreludeMiscIdUnique 113 -- (>>=) thenMClassOpKey = mkPreludeMiscIdUnique 114 -- (>>) + fmapClassOpKey = mkPreludeMiscIdUnique 115 returnMClassOpKey = mkPreludeMiscIdUnique 117 -- Recursive do notation @@@ -1421,62 -1485,13 +1578,72 @@@ realToFracIdKey = mkPreludeMiscIdU toIntegerClassOpKey = mkPreludeMiscIdUnique 129 toRationalClassOpKey = mkPreludeMiscIdUnique 130 + -- Monad comprehensions + guardMIdKey, liftMIdKey, groupMIdKey, mzipIdKey :: Unique + guardMIdKey = mkPreludeMiscIdUnique 131 + liftMIdKey = mkPreludeMiscIdUnique 132 + groupMIdKey = mkPreludeMiscIdUnique 133 + mzipIdKey = mkPreludeMiscIdUnique 134 + +-- code types - hetmet_brak_key, hetmet_esc_key, hetmet_csp_key, hetmet_flatten_key, hetmet_unflatten_key, hetmet_flattened_id_key :: Unique - hetmet_brak_key = mkPreludeMiscIdUnique 131 - hetmet_esc_key = mkPreludeMiscIdUnique 132 - hetmet_csp_key = mkPreludeMiscIdUnique 133 ++hetMetCodeTypeTyConKey :: Unique ++hetMetCodeTypeTyConKey = mkPreludeTyConUnique 135 ++ +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_PGArrow_key :: Unique +hetmet_PGArrow_key = mkPreludeMiscIdUnique 137 +hetmet_pga_id_key :: Unique +hetmet_pga_id_key = mkPreludeMiscIdUnique 138 +hetmet_pga_comp_key :: Unique +hetmet_pga_comp_key = mkPreludeMiscIdUnique 139 +hetmet_pga_first_key :: Unique +hetmet_pga_first_key = mkPreludeMiscIdUnique 140 +hetmet_pga_second_key :: Unique +hetmet_pga_second_key = mkPreludeMiscIdUnique 141 +hetmet_pga_cancell_key :: Unique +hetmet_pga_cancell_key = mkPreludeMiscIdUnique 142 +hetmet_pga_cancelr_key :: Unique +hetmet_pga_cancelr_key = mkPreludeMiscIdUnique 143 +hetmet_pga_uncancell_key :: Unique +hetmet_pga_uncancell_key = mkPreludeMiscIdUnique 144 +hetmet_pga_uncancelr_key :: Unique +hetmet_pga_uncancelr_key = mkPreludeMiscIdUnique 145 +hetmet_pga_assoc_key :: Unique +hetmet_pga_assoc_key = mkPreludeMiscIdUnique 146 +hetmet_pga_unassoc_key :: Unique +hetmet_pga_unassoc_key = mkPreludeMiscIdUnique 147 +hetmet_pga_copy_key :: Unique +hetmet_pga_copy_key = mkPreludeMiscIdUnique 148 +hetmet_pga_drop_key :: Unique +hetmet_pga_drop_key = mkPreludeMiscIdUnique 149 +hetmet_pga_swap_key :: Unique +hetmet_pga_swap_key = mkPreludeMiscIdUnique 150 +hetmet_pga_applyl_key :: Unique +hetmet_pga_applyl_key = mkPreludeMiscIdUnique 151 +hetmet_pga_applyr_key :: Unique +hetmet_pga_applyr_key = mkPreludeMiscIdUnique 152 +hetmet_pga_curryl_key :: Unique +hetmet_pga_curryl_key = mkPreludeMiscIdUnique 153 +hetmet_pga_curryr_key :: Unique +hetmet_pga_curryr_key = mkPreludeMiscIdUnique 154 +hetmet_flatten_key = mkPreludeMiscIdUnique 155 +hetmet_unflatten_key = mkPreludeMiscIdUnique 156 +hetmet_flattened_id_key = mkPreludeMiscIdUnique 157 +hetmet_PGArrow_unit_key :: Unique +hetmet_PGArrow_unit_key = mkPreludeMiscIdUnique 158 +hetmet_PGArrow_tensor_key :: Unique +hetmet_PGArrow_tensor_key = mkPreludeMiscIdUnique 159 +hetmet_PGArrow_exponent_key :: Unique +hetmet_PGArrow_exponent_key = mkPreludeMiscIdUnique 160 + ++hetmet_brak_key, hetmet_esc_key, hetmet_csp_key, hetmet_flatten_key, hetmet_unflatten_key, hetmet_flattened_id_key :: Unique ++hetmet_brak_key = mkPreludeMiscIdUnique 161 ++hetmet_esc_key = mkPreludeMiscIdUnique 162 ++hetmet_csp_key = mkPreludeMiscIdUnique 163 + ---------------- Template Haskell ------------------- -- USES IdUniques 200-499 @@@ -1492,7 -1507,7 +1659,7 @@@ \begin{code} numericTyKeys :: [Unique] -numericTyKeys = +numericTyKeys = [ wordTyConKey , intTyConKey , integerTyConKey diff --combined compiler/prelude/TysPrim.lhs index a5d9335,d0495d7..4c70bcb --- a/compiler/prelude/TysPrim.lhs +++ b/compiler/prelude/TysPrim.lhs @@@ -10,11 -10,26 +10,26 @@@ -- They are all, therefore, wired-in TyCons. C.f module TysWiredIn module TysPrim( alphaTyVars, betaTyVars, alphaTyVar, betaTyVar, gammaTyVar, deltaTyVar, - alphaTy, betaTy, gammaTy, deltaTy, + alphaTy, betaTy, gammaTy, deltaTy, ecTyVars, openAlphaTy, openBetaTy, openAlphaTyVar, openBetaTyVar, openAlphaTyVars, argAlphaTy, argAlphaTyVar, argBetaTy, argBetaTyVar, - primTyCons, + -- Kind constructors... + tySuperKindTyCon, tySuperKind, + liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon, + argTypeKindTyCon, ubxTupleKindTyCon, + + tySuperKindTyConName, liftedTypeKindTyConName, + openTypeKindTyConName, unliftedTypeKindTyConName, + ubxTupleKindTyConName, argTypeKindTyConName, + + -- Kinds + liftedTypeKind, unliftedTypeKind, openTypeKind, + argTypeKind, ubxTupleKind, + mkArrowKind, mkArrowKinds, isCoercionKind, + + funTyCon, funTyConName, + primTyCons, charPrimTyCon, charPrimTy, intPrimTyCon, intPrimTy, @@@ -44,7 -59,9 +59,9 @@@ word32PrimTyCon, word32PrimTy, int64PrimTyCon, int64PrimTy, - word64PrimTyCon, word64PrimTy, + word64PrimTyCon, word64PrimTy, + + eqPredPrimTyCon, -- ty1 ~ ty2 -- * Any anyTyCon, anyTyConOfKind, anyTypeOfKind @@@ -54,12 -71,9 +71,11 @@@ import Var ( TyVar, mkTyVar ) import Name ( Name, BuiltInSyntax(..), mkInternalName, mkWiredInName ) - import OccName ( mkTcOcc ) - import OccName ( mkTyVarOccFS, mkTcOccFS ) - import TyCon ( TyCon, mkPrimTyCon, mkLiftedPrimTyCon, mkAnyTyCon ) + import OccName ( mkTcOcc,mkTyVarOccFS, mkTcOccFS ) + import TyCon + import TypeRep +import Type - import TypeRep ( ecKind ) +import Coercion import SrcLoc import Unique ( mkAlphaTyVarUnique ) import PrelNames @@@ -103,6 -117,7 +119,7 @@@ primTyCon , word32PrimTyCon , word64PrimTyCon , anyTyCon + , eqPredPrimTyCon ] mkPrimTc :: FastString -> Unique -> TyCon -> Name @@@ -112,7 -127,7 +129,7 @@@ mkPrimTc fs unique tyco (ATyCon tycon) -- Relevant TyCon UserSyntax -- None are built-in syntax - charPrimTyConName, intPrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, realWorldTyConName, arrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName :: Name + charPrimTyConName, intPrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, realWorldTyConName, arrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, eqPredPrimTyConName :: Name charPrimTyConName = mkPrimTc (fsLit "Char#") charPrimTyConKey charPrimTyCon intPrimTyConName = mkPrimTc (fsLit "Int#") intPrimTyConKey intPrimTyCon int32PrimTyConName = mkPrimTc (fsLit "Int32#") int32PrimTyConKey int32PrimTyCon @@@ -123,8 -138,9 +140,9 @@@ word64PrimTyConName = mkPrimTc addrPrimTyConName = mkPrimTc (fsLit "Addr#") addrPrimTyConKey addrPrimTyCon floatPrimTyConName = mkPrimTc (fsLit "Float#") floatPrimTyConKey floatPrimTyCon doublePrimTyConName = mkPrimTc (fsLit "Double#") doublePrimTyConKey doublePrimTyCon - statePrimTyConName = mkPrimTc (fsLit "State#") statePrimTyConKey statePrimTyCon - realWorldTyConName = mkPrimTc (fsLit "RealWorld") realWorldTyConKey realWorldTyCon + statePrimTyConName = mkPrimTc (fsLit "State#") statePrimTyConKey statePrimTyCon + eqPredPrimTyConName = mkPrimTc (fsLit "~") eqPredPrimTyConKey eqPredPrimTyCon + realWorldTyConName = mkPrimTc (fsLit "RealWorld") realWorldTyConKey realWorldTyCon arrayPrimTyConName = mkPrimTc (fsLit "Array#") arrayPrimTyConKey arrayPrimTyCon byteArrayPrimTyConName = mkPrimTc (fsLit "ByteArray#") byteArrayPrimTyConKey byteArrayPrimTyCon mutableArrayPrimTyConName = mkPrimTc (fsLit "MutableArray#") mutableArrayPrimTyConKey mutableArrayPrimTyCon @@@ -159,9 -175,6 +177,9 @@@ tyVarList kind = [ mkTyVar (mkInternalN where c = chr (u-2 + ord 'a') ] +ecTyVars :: [TyVar] +ecTyVars = tyVarList ecKind + alphaTyVars :: [TyVar] alphaTyVars = tyVarList liftedTypeKind @@@ -197,109 -210,95 +215,95 @@@ argBetaTy = mkTyVarTy argBetaTyVa %************************************************************************ %* * - Any + FunTyCon %* * %************************************************************************ - Note [Any types] - ~~~~~~~~~~~~~~~~ - The type constructor Any::* has these properties - - * It is defined in module GHC.Prim, and exported so that it is - available to users. For this reason it's treated like any other - primitive type: - - has a fixed unique, anyTyConKey, - - lives in the global name cache - - built with TyCon.PrimTyCon - - * It is lifted, and hence represented by a pointer - - * It is inhabited by at least one value, namely bottom - - * You can unsafely coerce any lifted type to Ayny, and back. - - * It does not claim to be a *data* type, and that's important for - the code generator, because the code gen may *enter* a data value - but never enters a function value. - - * It is used to instantiate otherwise un-constrained type variables of kind * - For example length Any [] - See Note [Strangely-kinded void TyCons] - - In addition, we have a potentially-infinite family of types, one for - each kind /other than/ *, needed to instantiate otherwise - un-constrained type variables of kinds other than *. This is a bit - like tuples; there is a potentially-infinite family. They have slightly - different characteristics to Any::*: - - * They are built with TyCon.AnyTyCon - * They have non-user-writable names like "Any(*->*)" - * They are not exported by GHC.Prim - * They are uninhabited (of course; not kind *) - * They have a unique derived from their OccName (see Note [Uniques of Any]) - * Their Names do not live in the global name cache - - Note [Uniques of Any] - ~~~~~~~~~~~~~~~~~~~~~ - Although Any(*->*), say, doesn't have a binding site, it still needs - to have a Unique. Unlike tuples (which are also an infinite family) - there is no convenient way to index them, so we use the Unique from - their OccName instead. That should be unique, - - both wrt each other, because their strings differ - - - and wrt any other Name, because Names get uniques with - various 'char' tags, but the OccName of Any will - get a Unique built with mkTcOccUnique, which has a particular 'char' - tag; see Unique.mkTcOccUnique! - - Note [Strangely-kinded void TyCons] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - See Trac #959 for more examples + \begin{code} + funTyConName :: Name + funTyConName = mkPrimTyConName (fsLit "(->)") funTyConKey funTyCon + + funTyCon :: TyCon + funTyCon = mkFunTyCon funTyConName (mkArrowKinds [argTypeKind, openTypeKind] liftedTypeKind) + -- You might think that (->) should have type (?? -> ? -> *), and you'd be right + -- But if we do that we get kind errors when saying + -- instance Control.Arrow (->) + -- becuase the expected kind is (*->*->*). The trouble is that the + -- expected/actual stuff in the unifier does not go contra-variant, whereas + -- the kind sub-typing does. Sigh. It really only matters if you use (->) in + -- a prefix way, thus: (->) Int# Int#. And this is unusual. + -- because they are never in scope in the source + \end{code} - When the type checker finds a type variable with no binding, which - means it can be instantiated with an arbitrary type, it usually - instantiates it to Void. Eg. - length [] - ===> - length Any (Nil Any) + %************************************************************************ + %* * + Kinds + %* * + %************************************************************************ - But in really obscure programs, the type variable might have a kind - other than *, so we need to invent a suitably-kinded type. + \begin{code} + -- | See "Type#kind_subtyping" for details of the distinction between the 'Kind' 'TyCon's + tySuperKindTyCon, liftedTypeKindTyCon, + openTypeKindTyCon, unliftedTypeKindTyCon, + ubxTupleKindTyCon, argTypeKindTyCon + :: TyCon + tySuperKindTyConName, liftedTypeKindTyConName, + openTypeKindTyConName, unliftedTypeKindTyConName, + ubxTupleKindTyConName, argTypeKindTyConName + :: Name + + tySuperKindTyCon = mkSuperKindTyCon tySuperKindTyConName + liftedTypeKindTyCon = mkKindTyCon liftedTypeKindTyConName tySuperKind + openTypeKindTyCon = mkKindTyCon openTypeKindTyConName tySuperKind + unliftedTypeKindTyCon = mkKindTyCon unliftedTypeKindTyConName tySuperKind + ubxTupleKindTyCon = mkKindTyCon ubxTupleKindTyConName tySuperKind + argTypeKindTyCon = mkKindTyCon argTypeKindTyConName tySuperKind + + -------------------------- + -- ... and now their names + + tySuperKindTyConName = mkPrimTyConName (fsLit "BOX") tySuperKindTyConKey tySuperKindTyCon + liftedTypeKindTyConName = mkPrimTyConName (fsLit "*") liftedTypeKindTyConKey liftedTypeKindTyCon + openTypeKindTyConName = mkPrimTyConName (fsLit "?") openTypeKindTyConKey openTypeKindTyCon + unliftedTypeKindTyConName = mkPrimTyConName (fsLit "#") unliftedTypeKindTyConKey unliftedTypeKindTyCon + ubxTupleKindTyConName = mkPrimTyConName (fsLit "(#)") ubxTupleKindTyConKey ubxTupleKindTyCon + argTypeKindTyConName = mkPrimTyConName (fsLit "??") argTypeKindTyConKey argTypeKindTyCon + + mkPrimTyConName :: FastString -> Unique -> TyCon -> Name + mkPrimTyConName occ key tycon = mkWiredInName gHC_PRIM (mkTcOccFS occ) + key + (ATyCon tycon) + BuiltInSyntax + -- All of the super kinds and kinds are defined in Prim and use BuiltInSyntax, + -- because they are never in scope in the source + \end{code} - This commit uses - Any for kind * - Any(*->*) for kind *->* - etc \begin{code} - anyTyConName :: Name - anyTyConName = mkPrimTc (fsLit "Any") anyTyConKey anyTyCon + kindTyConType :: TyCon -> Type + kindTyConType kind = TyConApp kind [] - anyTyCon :: TyCon - anyTyCon = mkLiftedPrimTyCon anyTyConName liftedTypeKind 0 PtrRep + -- | See "Type#kind_subtyping" for details of the distinction between these 'Kind's + liftedTypeKind, unliftedTypeKind, openTypeKind, argTypeKind, ubxTupleKind :: Kind - anyTypeOfKind :: Kind -> Type - anyTypeOfKind kind = mkTyConApp (anyTyConOfKind kind) [] + liftedTypeKind = kindTyConType liftedTypeKindTyCon + unliftedTypeKind = kindTyConType unliftedTypeKindTyCon + openTypeKind = kindTyConType openTypeKindTyCon + argTypeKind = kindTyConType argTypeKindTyCon + ubxTupleKind = kindTyConType ubxTupleKindTyCon - anyTyConOfKind :: Kind -> TyCon - -- Map all superkinds of liftedTypeKind to liftedTypeKind - anyTyConOfKind kind - | liftedTypeKind `isSubKind` kind = anyTyCon - | otherwise = tycon - where - -- Derive the name from the kind, thus: - -- Any(*->*), Any(*->*->*) - -- These are names that can't be written by the user, - -- and are not allocated in the global name cache - str = "Any" ++ showSDoc (pprParendKind kind) + -- | Given two kinds @k1@ and @k2@, creates the 'Kind' @k1 -> k2@ + mkArrowKind :: Kind -> Kind -> Kind + mkArrowKind k1 k2 = FunTy k1 k2 - occ = mkTcOcc str - uniq = getUnique occ -- See Note [Uniques of Any] - name = mkWiredInName gHC_PRIM occ uniq (ATyCon tycon) UserSyntax - tycon = mkAnyTyCon name kind - \end{code} + -- | Iterated application of 'mkArrowKind' + mkArrowKinds :: [Kind] -> Kind -> Kind + mkArrowKinds arg_kinds result_kind = foldr mkArrowKind result_kind arg_kinds + tySuperKind :: SuperKind + tySuperKind = kindTyConType tySuperKindTyCon + \end{code} %************************************************************************ %* * @@@ -380,6 -379,22 +384,22 @@@ doublePrimTyCon = pcPrimTyCon0 doublePr %* * %************************************************************************ + Note [The (~) TyCon) + ~~~~~~~~~~~~~~~~~~~~ + There is a perfectly ordinary type constructor (~) that represents the type + of coercions (which, remember, are values). For example + Refl Int :: Int ~ Int + + Atcually it is not quite "perfectly ordinary" because it is kind-polymorphic: + Refl Maybe :: Maybe ~ Maybe + + So the true kind of (~) :: forall k. k -> k -> #. But we don't have + polymorphic kinds (yet). However, (~) really only appears saturated in + which case there is no problem in finding the kind of (ty1 ~ ty2). So + we check that in CoreLint (and, in an assertion, in Kind.typeKind). + + Note [The State# TyCon] + ~~~~~~~~~~~~~~~~~~~~~~~ State# is the primitive, unlifted type of states. It has one type parameter, thus State# RealWorld @@@ -392,8 -407,13 +412,13 @@@ keep different state threads separate \begin{code} mkStatePrimTy :: Type -> Type mkStatePrimTy ty = mkTyConApp statePrimTyCon [ty] - statePrimTyCon :: TyCon + + statePrimTyCon :: TyCon -- See Note [The State# TyCon] statePrimTyCon = pcPrimTyCon statePrimTyConName 1 VoidRep + + eqPredPrimTyCon :: TyCon -- The representation type for equality predicates + -- See Note [The (~) TyCon] + eqPredPrimTyCon = pcPrimTyCon eqPredPrimTyConName 2 VoidRep \end{code} RealWorld is deeply magical. It is *primitive*, but it is not @@@ -412,7 -432,6 +437,6 @@@ realWorldStatePrimTy = mkStatePrimTy re Note: the ``state-pairing'' types are not truly primitive, so they are defined in \tr{TysWiredIn.lhs}, not here. - %************************************************************************ %* * \subsection[TysPrim-arrays]{The primitive array types} @@@ -555,3 -574,110 +579,110 @@@ threadIdPrimTy = mkTyConTy threadIdP threadIdPrimTyCon :: TyCon threadIdPrimTyCon = pcPrimTyCon0 threadIdPrimTyConName PtrRep \end{code} + + + + %************************************************************************ + %* * + Any + %* * + %************************************************************************ + + Note [Any types] + ~~~~~~~~~~~~~~~~ + The type constructor Any::* has these properties + + * It is defined in module GHC.Prim, and exported so that it is + available to users. For this reason it's treated like any other + primitive type: + - has a fixed unique, anyTyConKey, + - lives in the global name cache + - built with TyCon.PrimTyCon + + * It is lifted, and hence represented by a pointer + + * It is inhabited by at least one value, namely bottom + + * You can unsafely coerce any lifted type to Ayny, and back. + + * It does not claim to be a *data* type, and that's important for + the code generator, because the code gen may *enter* a data value + but never enters a function value. + + * It is used to instantiate otherwise un-constrained type variables of kind * + For example length Any [] + See Note [Strangely-kinded void TyCons] + + In addition, we have a potentially-infinite family of types, one for + each kind /other than/ *, needed to instantiate otherwise + un-constrained type variables of kinds other than *. This is a bit + like tuples; there is a potentially-infinite family. They have slightly + different characteristics to Any::*: + + * They are built with TyCon.AnyTyCon + * They have non-user-writable names like "Any(*->*)" + * They are not exported by GHC.Prim + * They are uninhabited (of course; not kind *) + * They have a unique derived from their OccName (see Note [Uniques of Any]) + * Their Names do not live in the global name cache + + Note [Uniques of Any] + ~~~~~~~~~~~~~~~~~~~~~ + Although Any(*->*), say, doesn't have a binding site, it still needs + to have a Unique. Unlike tuples (which are also an infinite family) + there is no convenient way to index them, so we use the Unique from + their OccName instead. That should be unique, + - both wrt each other, because their strings differ + + - and wrt any other Name, because Names get uniques with + various 'char' tags, but the OccName of Any will + get a Unique built with mkTcOccUnique, which has a particular 'char' + tag; see Unique.mkTcOccUnique! + + Note [Strangely-kinded void TyCons] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + See Trac #959 for more examples + + When the type checker finds a type variable with no binding, which + means it can be instantiated with an arbitrary type, it usually + instantiates it to Void. Eg. + + length [] + ===> + length Any (Nil Any) + + But in really obscure programs, the type variable might have a kind + other than *, so we need to invent a suitably-kinded type. + + This commit uses + Any for kind * + Any(*->*) for kind *->* + etc + + \begin{code} + anyTyConName :: Name + anyTyConName = mkPrimTc (fsLit "Any") anyTyConKey anyTyCon + + anyTyCon :: TyCon + anyTyCon = mkLiftedPrimTyCon anyTyConName liftedTypeKind 0 PtrRep + + anyTypeOfKind :: Kind -> Type + anyTypeOfKind kind = mkTyConApp (anyTyConOfKind kind) [] + + anyTyConOfKind :: Kind -> TyCon + -- Map all superkinds of liftedTypeKind to liftedTypeKind + anyTyConOfKind kind + | isLiftedTypeKind kind = anyTyCon + | otherwise = tycon + where + -- Derive the name from the kind, thus: + -- Any(*->*), Any(*->*->*) + -- These are names that can't be written by the user, + -- and are not allocated in the global name cache + str = "Any" ++ showSDoc (pprParendKind kind) + + occ = mkTcOcc str + uniq = getUnique occ -- See Note [Uniques of Any] + name = mkWiredInName gHC_PRIM occ uniq (ATyCon tycon) UserSyntax + tycon = mkAnyTyCon name kind + \end{code} diff --combined compiler/prelude/TysWiredIn.lhs index 2f1b637,5a80067..bc45028 --- a/compiler/prelude/TysWiredIn.lhs +++ b/compiler/prelude/TysWiredIn.lhs @@@ -47,12 -47,6 +47,12 @@@ module TysWiredIn -- * Unit unitTy, + -- * Heterogeneous Metaprogramming + mkHetMetCodeTypeTy, + hetMetCodeTypeTyConName, + hetMetCodeTypeTyCon, isHetMetCodeTypeTyCon, + hetMetCodeTypeTyCon_RDR, + -- * Parallel arrays mkPArrTy, parrTyCon, parrFakeCon, isPArrTyCon, isPArrFakeCon, @@@ -70,23 -64,14 +70,14 @@@ import TysPri -- others: import Constants ( mAX_TUPLE_SIZE ) import Module ( Module ) + import DataCon ( DataCon, mkDataCon, dataConWorkId, dataConSourceArity ) + import Var + import TyCon + import TypeRep import RdrName import Name - import DataCon ( DataCon, mkDataCon, dataConWorkId, dataConSourceArity ) - import Var - import TyCon ( TyCon, AlgTyConRhs(DataTyCon), tyConDataCons, - mkTupleTyCon, mkAlgTyCon, tyConName, - TyConParent(NoParentTyCon) ) - - import BasicTypes ( Arity, RecFlag(..), Boxity(..), isBoxed, HsBang(..) ) - - import Type ( Type, mkTyConTy, mkTyConApp, mkTyVarTy, mkTyVarTys, - TyThing(..) ) - import Coercion ( unsafeCoercionTyCon, symCoercionTyCon, - transCoercionTyCon, leftCoercionTyCon, - rightCoercionTyCon, instCoercionTyCon ) - import TypeRep ( mkArrowKinds, liftedTypeKind, ubxTupleKind ) - import Unique ( incrUnique, mkTupleTyConUnique, + import BasicTypes ( Arity, RecFlag(..), Boxity(..), isBoxed, HsBang(..) ) + import Unique ( incrUnique, mkTupleTyConUnique, mkTupleDataConUnique, mkPArrDataConUnique ) import Data.Array import FastString @@@ -130,13 -115,6 +121,7 @@@ wiredInTyCons = [ unitTyCon -- Not trea , intTyCon , listTyCon , parrTyCon + , hetMetCodeTypeTyCon - , unsafeCoercionTyCon - , symCoercionTyCon - , transCoercionTyCon - , leftCoercionTyCon - , rightCoercionTyCon - , instCoercionTyCon ] \end{code} @@@ -181,14 -159,8 +166,14 @@@ parrTyConName = mkWiredInTyConName 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 @@@ -198,7 -170,6 +183,7 @@@ intDataCon_RDR = nameRdrName intDataCon listTyCon_RDR = nameRdrName listTyConName consDataCon_RDR = nameRdrName consDataConName parrTyCon_RDR = nameRdrName parrTyConName +hetMetCodeTypeTyCon_RDR = nameRdrName hetMetCodeTypeTyConName \end{code} @@@ -225,7 -196,6 +210,6 @@@ pcTyCon is_enum is_rec name tyvars con (DataTyCon cons is_enum) NoParentTyCon is_rec - True -- All the wired-in tycons have generics False -- Not in GADT syntax pcDataCon :: Name -> [TyVar] -> [Type] -> TyCon -> DataCon @@@ -290,7 -260,7 +274,7 @@@ unboxedTupleArr = listArray (0,mAX_TUPL mk_tuple :: Boxity -> Int -> (TyCon,DataCon) mk_tuple boxity arity = (tycon, tuple_con) where - tycon = mkTupleTyCon tc_name tc_kind arity tyvars tuple_con boxity gen_info + tycon = mkTupleTyCon tc_name tc_kind arity tyvars tuple_con boxity modu = mkTupleModule boxity arity tc_name = mkWiredInName modu (mkTupleOcc tcName boxity arity) tc_uniq (ATyCon tycon) BuiltInSyntax @@@ -307,8 -277,6 +291,6 @@@ (ADataCon tuple_con) BuiltInSyntax tc_uniq = mkTupleTyConUnique boxity arity dc_uniq = mkTupleDataConUnique boxity arity - gen_info = True -- Tuples all have generics.. - -- hmm: that's a *lot* of code unitTyCon :: TyCon unitTyCon = tupleTyCon Boxed 0 @@@ -624,30 -592,3 +606,29 @@@ mkPArrFakeCon arity = data_co isPArrFakeCon :: DataCon -> Bool 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] + +ecTyVar = head ecTyVars + +-- | Represents the type constructor of box types +hetMetCodeTypeTyCon :: TyCon +hetMetCodeTypeTyCon = pcNonRecDataTyCon hetMetCodeTypeTyConName [ecTyVar, 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 --combined compiler/rename/RnExpr.lhs index 1b7eef0,88e0462..9b1f08e --- a/compiler/rename/RnExpr.lhs +++ b/compiler/rename/RnExpr.lhs @@@ -25,7 -25,7 +25,7 @@@ import RnBinds ( rnLocalBindsAndThen 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,14 -34,13 +34,14 @@@ import DynFlag import BasicTypes ( FixityDirection(..) ) import PrelNames +import Var ( TyVar, varName ) import Name import NameSet import RdrName import LoadIface ( loadInterfaceForName ) import UniqSet import Data.List - import Util ( isSingleton ) + import Util ( isSingleton, snocView ) import ListSetOps ( removeDups ) import Outputable import SrcLoc @@@ -85,13 -84,6 +85,13 @@@ rnExprs ls = rnExprs' ls emptyUniqSe 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 @@@ -165,21 -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 @@@ -247,10 -224,9 +247,9 @@@ rnExpr (HsLet binds expr rnLExpr expr `thenM` \ (expr',fvExpr) -> return (HsLet binds' expr', fvExpr) - rnExpr (HsDo do_or_lc stmts body _) - = do { ((stmts', body'), fvs) <- rnStmts do_or_lc stmts $ \ _ -> - rnLExpr body - ; return (HsDo do_or_lc stmts' body' placeHolderType, fvs) } + rnExpr (HsDo do_or_lc stmts _) + = do { ((stmts', _), fvs) <- rnStmts do_or_lc stmts (\ _ -> return ((), emptyFVs)) + ; return ( HsDo do_or_lc stmts' placeHolderType, fvs ) } rnExpr (ExplicitList _ exps) = rnExprs exps `thenM` \ (exps', fvs) -> @@@ -464,9 -440,9 +463,9 @@@ convertOpFormsCmd (HsIf f exp c1 c2 convertOpFormsCmd (HsLet binds cmd) = HsLet binds (convertOpFormsLCmd cmd) - convertOpFormsCmd (HsDo ctxt stmts body ty) - = HsDo ctxt (map (fmap convertOpFormsStmt) stmts) - (convertOpFormsLCmd body) ty + convertOpFormsCmd (HsDo DoExpr stmts ty) + = HsDo ArrowExpr (map (fmap convertOpFormsStmt) stmts) ty + -- Mark the HsDo as begin the body of an arrow command -- Anything else is unchanged. This includes HsArrForm (already done), -- things with no sub-commands, and illegal commands (which will be @@@ -476,8 -452,8 +475,8 @@@ convertOpFormsCmd c = convertOpFormsStmt :: StmtLR id id -> StmtLR id id convertOpFormsStmt (BindStmt pat cmd _ _) = BindStmt pat (convertOpFormsLCmd cmd) noSyntaxExpr noSyntaxExpr - convertOpFormsStmt (ExprStmt cmd _ _) - = ExprStmt (convertOpFormsLCmd cmd) noSyntaxExpr placeHolderType + convertOpFormsStmt (ExprStmt cmd _ _ _) + = ExprStmt (convertOpFormsLCmd cmd) noSyntaxExpr noSyntaxExpr placeHolderType convertOpFormsStmt stmt@(RecStmt { recS_stmts = stmts }) = stmt { recS_stmts = map (fmap convertOpFormsStmt) stmts } convertOpFormsStmt stmt = stmt @@@ -518,14 -494,10 +517,10 @@@ methodNamesCmd (HsPar c) = methodNamesL methodNamesCmd (HsIf _ _ c1 c2) = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName - methodNamesCmd (HsLet _ c) = methodNamesLCmd c - - methodNamesCmd (HsDo _ stmts body _) - = methodNamesStmts stmts `plusFV` methodNamesLCmd body - - methodNamesCmd (HsApp c _) = methodNamesLCmd c - - methodNamesCmd (HsLam match) = methodNamesMatch match + methodNamesCmd (HsLet _ c) = methodNamesLCmd c + methodNamesCmd (HsDo _ stmts _) = methodNamesStmts stmts + methodNamesCmd (HsApp c _) = methodNamesLCmd c + methodNamesCmd (HsLam match) = methodNamesMatch match methodNamesCmd (HsCase _ matches) = methodNamesMatch matches `addOneFV` choiceAName @@@ -561,14 -533,14 +556,14 @@@ methodNamesLStmt :: Located (StmtLR Nam methodNamesLStmt = methodNamesStmt . unLoc methodNamesStmt :: StmtLR Name Name -> FreeVars - methodNamesStmt (ExprStmt cmd _ _) = methodNamesLCmd cmd + methodNamesStmt (LastStmt cmd _) = methodNamesLCmd cmd + methodNamesStmt (ExprStmt cmd _ _ _) = methodNamesLCmd cmd methodNamesStmt (BindStmt _ cmd _ _) = methodNamesLCmd cmd methodNamesStmt (RecStmt { recS_stmts = stmts }) = methodNamesStmts stmts `addOneFV` loopAName methodNamesStmt (LetStmt _) = emptyFVs - methodNamesStmt (ParStmt _) = emptyFVs - methodNamesStmt (TransformStmt {}) = emptyFVs - methodNamesStmt (GroupStmt {}) = emptyFVs - -- ParStmt, TransformStmt and GroupStmt can't occur in commands, but it's not convenient to error + methodNamesStmt (ParStmt _ _ _ _) = emptyFVs + methodNamesStmt (TransStmt {}) = emptyFVs + -- ParStmt and TransStmt can't occur in commands, but it's not convenient to error -- here so we just do what's convenient \end{code} @@@ -611,14 -583,16 +606,16 @@@ rnArithSeq (FromThenTo expr1 expr2 expr \begin{code} rnBracket :: HsBracket RdrName -> RnM (HsBracket Name, FreeVars) - rnBracket (VarBr n) = do { name <- lookupOccRn n - ; this_mod <- getModule - ; unless (nameIsLocalOrFrom this_mod name) $ -- Reason: deprecation checking asumes the - do { _ <- loadInterfaceForName msg name -- home interface is loaded, and this is the - ; return () } -- only way that is going to happen - ; return (VarBr name, unitFV name) } - where - msg = ptext (sLit "Need interface for Template Haskell quoted Name") + rnBracket (VarBr n) + = do { name <- lookupOccRn n + ; this_mod <- getModule + ; unless (nameIsLocalOrFrom this_mod name) $ -- Reason: deprecation checking assumes + do { _ <- loadInterfaceForName msg name -- the home interface is loaded, and + ; return () } -- this is the only way that is going + -- to happen + ; return (VarBr name, unitFV name) } + where + msg = ptext (sLit "Need interface for Template Haskell quoted Name") rnBracket (ExpBr e) = do { (e', fvs) <- rnLExpr e ; return (ExpBr e', fvs) } @@@ -648,7 -622,8 +645,8 @@@ rnBracket (DecBrL decls rnSrcDecls group -- Discard the tcg_env; it contains only extra info about fixity - ; traceRn (text "rnBracket dec" <+> (ppr (tcg_dus tcg_env) $$ ppr (duUses (tcg_dus tcg_env)))) + ; traceRn (text "rnBracket dec" <+> (ppr (tcg_dus tcg_env) $$ + ppr (duUses (tcg_dus tcg_env)))) ; return (DecBrG group', duUses (tcg_dus tcg_env)) } rnBracket (DecBrG _) = panic "rnBracket: unexpected DecBrG" @@@ -662,44 -637,74 +660,74 @@@ \begin{code} rnStmts :: HsStmtContext Name -> [LStmt RdrName] - -> ([Name] -> RnM (thing, FreeVars)) - -> RnM (([LStmt Name], thing), FreeVars) + -> ([Name] -> RnM (thing, FreeVars)) + -> RnM (([LStmt Name], thing), FreeVars) -- Variables bound by the Stmts, and mentioned in thing_inside, -- do not appear in the result FreeVars - -- - -- Renaming a single RecStmt can give a sequence of smaller Stmts - rnStmts _ [] thing_inside - = do { (res, fvs) <- thing_inside [] - ; return (([], res), fvs) } + rnStmts ctxt [] thing_inside + = do { checkEmptyStmts ctxt + ; (thing, fvs) <- thing_inside [] + ; return (([], thing), fvs) } + + rnStmts MDoExpr stmts thing_inside -- Deal with mdo + = -- Behave like do { rec { ...all but last... }; last } + do { ((stmts1, (stmts2, thing)), fvs) + <- rnStmt MDoExpr (noLoc $ mkRecStmt all_but_last) $ \ _ -> + do { last_stmt' <- checkLastStmt MDoExpr last_stmt + ; rnStmt MDoExpr last_stmt' thing_inside } + ; return (((stmts1 ++ stmts2), thing), fvs) } + where + Just (all_but_last, last_stmt) = snocView stmts + + rnStmts ctxt (lstmt@(L loc _) : lstmts) thing_inside + | null lstmts + = setSrcSpan loc $ + do { lstmt' <- checkLastStmt ctxt lstmt + ; rnStmt ctxt lstmt' thing_inside } - rnStmts ctxt (stmt@(L loc _) : stmts) thing_inside + | otherwise = do { ((stmts1, (stmts2, thing)), fvs) - <- setSrcSpan loc $ - rnStmt ctxt stmt $ \ bndrs1 -> - rnStmts ctxt stmts $ \ bndrs2 -> - thing_inside (bndrs1 ++ bndrs2) + <- setSrcSpan loc $ + do { checkStmt ctxt lstmt + ; rnStmt ctxt lstmt $ \ bndrs1 -> + rnStmts ctxt lstmts $ \ bndrs2 -> + thing_inside (bndrs1 ++ bndrs2) } ; return (((stmts1 ++ stmts2), thing), fvs) } - - rnStmt :: HsStmtContext Name -> LStmt RdrName + ---------------------- + rnStmt :: HsStmtContext Name + -> LStmt RdrName -> ([Name] -> RnM (thing, FreeVars)) -> RnM (([LStmt Name], thing), FreeVars) -- Variables bound by the Stmt, and mentioned in thing_inside, -- do not appear in the result FreeVars - rnStmt _ (L loc (ExprStmt expr _ _)) thing_inside + rnStmt ctxt (L loc (LastStmt expr _)) thing_inside = do { (expr', fv_expr) <- rnLExpr expr - ; (then_op, fvs1) <- lookupSyntaxName thenMName - ; (thing, fvs2) <- thing_inside [] - ; return (([L loc (ExprStmt expr' then_op placeHolderType)], thing), - fv_expr `plusFV` fvs1 `plusFV` fvs2) } + ; (ret_op, fvs1) <- lookupStmtName ctxt returnMName + ; (thing, fvs3) <- thing_inside [] + ; return (([L loc (LastStmt expr' ret_op)], thing), + fv_expr `plusFV` fvs1 `plusFV` fvs3) } + + rnStmt ctxt (L loc (ExprStmt expr _ _ _)) thing_inside + = do { (expr', fv_expr) <- rnLExpr expr + ; (then_op, fvs1) <- lookupStmtName ctxt thenMName + ; (guard_op, fvs2) <- if isListCompExpr ctxt + then lookupStmtName ctxt guardMName + else return (noSyntaxExpr, emptyFVs) + -- Only list/parr/monad comprehensions use 'guard' + -- Also for sub-stmts of same eg [ e | x<-xs, gd | blah ] + -- Here "gd" is a guard + ; (thing, fvs3) <- thing_inside [] + ; return (([L loc (ExprStmt expr' then_op guard_op placeHolderType)], thing), + fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } rnStmt ctxt (L loc (BindStmt pat expr _ _)) thing_inside = do { (expr', fv_expr) <- rnLExpr expr -- The binders do not scope over the expression - ; (bind_op, fvs1) <- lookupSyntaxName bindMName - ; (fail_op, fvs2) <- lookupSyntaxName failMName + ; (bind_op, fvs1) <- lookupStmtName ctxt bindMName + ; (fail_op, fvs2) <- lookupStmtName ctxt failMName ; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do { (thing, fvs3) <- thing_inside (collectPatBinders pat') ; return (([L loc (BindStmt pat' expr' bind_op fail_op)], thing), @@@ -707,15 -712,13 +735,13 @@@ -- fv_expr shouldn't really be filtered by the rnPatsAndThen -- but it does not matter because the names are unique - rnStmt ctxt (L loc (LetStmt binds)) thing_inside - = do { checkLetStmt ctxt binds - ; rnLocalBindsAndThen binds $ \binds' -> do + rnStmt _ (L loc (LetStmt binds)) thing_inside + = do { rnLocalBindsAndThen binds $ \binds' -> do { (thing, fvs) <- thing_inside (collectLocalBinders binds') ; return (([L loc (LetStmt binds')], thing), fvs) } } rnStmt ctxt (L _ (RecStmt { recS_stmts = rec_stmts })) thing_inside - = do { checkRecStmt ctxt - + = do { -- Step1: Bring all the binders of the mdo into scope -- (Remember that this also removes the binders from the -- finally-returned free-vars.) @@@ -730,9 -733,9 +756,9 @@@ { let bndrs = nameSetToList $ foldr (unionNameSets . (\(ds,_,_,_) -> ds)) emptyNameSet segs ; (thing, fvs_later) <- thing_inside bndrs - ; (return_op, fvs1) <- lookupSyntaxName returnMName - ; (mfix_op, fvs2) <- lookupSyntaxName mfixName - ; (bind_op, fvs3) <- lookupSyntaxName bindMName + ; (return_op, fvs1) <- lookupStmtName ctxt returnMName + ; (mfix_op, fvs2) <- lookupStmtName ctxt mfixName + ; (bind_op, fvs3) <- lookupStmtName ctxt bindMName ; let -- Step 2: Fill in the fwd refs. -- The segments are all singletons, but their fwd-ref @@@ -757,57 -760,51 +783,51 @@@ ; return ((rec_stmts', thing), fvs `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } } - rnStmt ctxt (L loc (ParStmt segs)) thing_inside - = do { checkParStmt ctxt - ; ((segs', thing), fvs) <- rnParallelStmts (ParStmtCtxt ctxt) segs thing_inside - ; return (([L loc (ParStmt segs')], thing), fvs) } - - rnStmt ctxt (L loc (TransformStmt stmts _ using by)) thing_inside - = do { checkTransformStmt ctxt - - ; (using', fvs1) <- rnLExpr using - - ; ((stmts', (by', used_bndrs, thing)), fvs2) - <- rnStmts (TransformStmtCtxt ctxt) stmts $ \ bndrs -> - do { (by', fvs_by) <- case by of - Nothing -> return (Nothing, emptyFVs) - Just e -> do { (e', fvs) <- rnLExpr e; return (Just e', fvs) } - ; (thing, fvs_thing) <- thing_inside bndrs - ; let fvs = fvs_by `plusFV` fvs_thing - used_bndrs = filter (`elemNameSet` fvs) bndrs - -- The paper (Fig 5) has a bug here; we must treat any free varaible of - -- the "thing inside", **or of the by-expression**, as used - ; return ((by', used_bndrs, thing), fvs) } - - ; return (([L loc (TransformStmt stmts' used_bndrs using' by')], thing), - fvs1 `plusFV` fvs2) } - - rnStmt ctxt (L loc (GroupStmt stmts _ by using)) thing_inside - = do { checkTransformStmt ctxt - - -- Rename the 'using' expression in the context before the transform is begun - ; (using', fvs1) <- case using of - Left e -> do { (e', fvs) <- rnLExpr e; return (Left e', fvs) } - Right _ -> do { (e', fvs) <- lookupSyntaxName groupWithName - ; return (Right e', fvs) } + rnStmt ctxt (L loc (ParStmt segs _ _ _)) thing_inside + = do { (mzip_op, fvs1) <- lookupStmtName ctxt mzipName + ; (bind_op, fvs2) <- lookupStmtName ctxt bindMName + ; (return_op, fvs3) <- lookupStmtName ctxt returnMName + ; ((segs', thing), fvs4) <- rnParallelStmts (ParStmtCtxt ctxt) segs thing_inside + ; return ( ([L loc (ParStmt segs' mzip_op bind_op return_op)], thing) + , fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) } + + rnStmt ctxt (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = form + , trS_using = using })) thing_inside + = do { -- Rename the 'using' expression in the context before the transform is begun + (using', fvs1) <- case form of + GroupFormB -> do { (e,fvs) <- lookupStmtName ctxt groupMName + ; return (noLoc e, fvs) } + _ -> rnLExpr using -- Rename the stmts and the 'by' expression -- Keep track of the variables mentioned in the 'by' expression ; ((stmts', (by', used_bndrs, thing)), fvs2) - <- rnStmts (TransformStmtCtxt ctxt) stmts $ \ bndrs -> + <- rnStmts (TransStmtCtxt ctxt) stmts $ \ bndrs -> do { (by', fvs_by) <- mapMaybeFvRn rnLExpr by ; (thing, fvs_thing) <- thing_inside bndrs ; let fvs = fvs_by `plusFV` fvs_thing used_bndrs = filter (`elemNameSet` fvs) bndrs + -- The paper (Fig 5) has a bug here; we must treat any free varaible + -- of the "thing inside", **or of the by-expression**, as used ; return ((by', used_bndrs, thing), fvs) } - ; let all_fvs = fvs1 `plusFV` fvs2 + -- Lookup `return`, `(>>=)` and `liftM` for monad comprehensions + ; (return_op, fvs3) <- lookupStmtName ctxt returnMName + ; (bind_op, fvs4) <- lookupStmtName ctxt bindMName + ; (fmap_op, fvs5) <- case form of + ThenForm -> return (noSyntaxExpr, emptyFVs) + _ -> lookupStmtName ctxt fmapName + + ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3 + `plusFV` fvs4 `plusFV` fvs5 bndr_map = used_bndrs `zip` used_bndrs - -- See Note [GroupStmt binder map] in HsExpr + -- See Note [TransStmt binder map] in HsExpr ; traceRn (text "rnStmt: implicitly rebound these used binders:" <+> ppr bndr_map) - ; return (([L loc (GroupStmt stmts' bndr_map by' using')], thing), all_fvs) } - + ; return (([L loc (TransStmt { trS_stmts = stmts', trS_bndrs = bndr_map + , trS_by = by', trS_using = using', trS_form = form + , trS_ret = return_op, trS_bind = bind_op + , trS_fmap = fmap_op })], thing), all_fvs) } type ParSeg id = ([LStmt id], [id]) -- The Names are bound by the Stmts @@@ -843,6 -840,27 +863,27 @@@ rnParallelStmts ctxt segs thing_insid cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2 dupErr vs = addErr (ptext (sLit "Duplicate binding in parallel list comprehension for:") <+> quotes (ppr (head vs))) + + lookupStmtName :: HsStmtContext Name -> Name -> RnM (HsExpr Name, FreeVars) + -- Like lookupSyntaxName, but ListComp/PArrComp are never rebindable + -- Neither is ArrowExpr, which has its own desugarer in DsArrows + lookupStmtName ctxt n + = case ctxt of + ListComp -> not_rebindable + PArrComp -> not_rebindable + ArrowExpr -> not_rebindable + PatGuard {} -> not_rebindable + + DoExpr -> rebindable + MDoExpr -> rebindable + MonadComp -> rebindable + GhciStmt -> rebindable -- I suppose? + + ParStmtCtxt c -> lookupStmtName c n -- Look inside to + TransStmtCtxt c -> lookupStmtName c n -- the parent context + where + rebindable = lookupSyntaxName n + not_rebindable = return (HsVar n, emptyFVs) \end{code} Note [Renaming parallel Stmts] @@@ -924,9 -942,11 +965,11 @@@ rn_rec_stmt_lhs :: MiniFixityEn -- so we don't bother to compute it accurately in the other cases -> RnM [(LStmtLR Name RdrName, FreeVars)] - rn_rec_stmt_lhs _ (L loc (ExprStmt expr a b)) = return [(L loc (ExprStmt expr a b), - -- this is actually correct - emptyFVs)] + rn_rec_stmt_lhs _ (L loc (ExprStmt expr a b c)) + = return [(L loc (ExprStmt expr a b c), emptyFVs)] + + rn_rec_stmt_lhs _ (L loc (LastStmt expr a)) + = return [(L loc (LastStmt expr a), emptyFVs)] rn_rec_stmt_lhs fix_env (L loc (BindStmt pat expr a b)) = do @@@ -949,13 -969,10 +992,10 @@@ rn_rec_stmt_lhs fix_env (L loc (LetStm rn_rec_stmt_lhs fix_env (L _ (RecStmt { recS_stmts = stmts })) -- Flatten Rec inside Rec = rn_rec_stmts_lhs fix_env stmts - rn_rec_stmt_lhs _ stmt@(L _ (ParStmt _)) -- Syntactically illegal in mdo - = pprPanic "rn_rec_stmt" (ppr stmt) - - rn_rec_stmt_lhs _ stmt@(L _ (TransformStmt {})) -- Syntactically illegal in mdo + rn_rec_stmt_lhs _ stmt@(L _ (ParStmt _ _ _ _)) -- Syntactically illegal in mdo = pprPanic "rn_rec_stmt" (ppr stmt) - rn_rec_stmt_lhs _ stmt@(L _ (GroupStmt {})) -- Syntactically illegal in mdo + rn_rec_stmt_lhs _ stmt@(L _ (TransStmt {})) -- Syntactically illegal in mdo = pprPanic "rn_rec_stmt" (ppr stmt) rn_rec_stmt_lhs _ (L _ (LetStmt EmptyLocalBinds)) @@@ -980,11 -997,17 +1020,17 @@@ rn_rec_stmt :: [Name] -> LStmtLR Name R -- Rename a Stmt that is inside a RecStmt (or mdo) -- Assumes all binders are already in scope -- Turns each stmt into a singleton Stmt - rn_rec_stmt _ (L loc (ExprStmt expr _ _)) _ + rn_rec_stmt _ (L loc (LastStmt expr _)) _ + = do { (expr', fv_expr) <- rnLExpr expr + ; (ret_op, fvs1) <- lookupSyntaxName returnMName + ; return [(emptyNameSet, fv_expr `plusFV` fvs1, emptyNameSet, + L loc (LastStmt expr' ret_op))] } + + rn_rec_stmt _ (L loc (ExprStmt expr _ _ _)) _ = rnLExpr expr `thenM` \ (expr', fvs) -> lookupSyntaxName thenMName `thenM` \ (then_op, fvs1) -> return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet, - L loc (ExprStmt expr' then_op placeHolderType))] + L loc (ExprStmt expr' then_op noSyntaxExpr placeHolderType))] rn_rec_stmt _ (L loc (BindStmt pat' expr _ _)) fv_pat = rnLExpr expr `thenM` \ (expr', fv_expr) -> @@@ -1014,11 -1037,8 +1060,8 @@@ rn_rec_stmt _ stmt@(L _ (RecStmt {})) rn_rec_stmt _ stmt@(L _ (ParStmt {})) _ -- Syntactically illegal in mdo = pprPanic "rn_rec_stmt: ParStmt" (ppr stmt) - rn_rec_stmt _ stmt@(L _ (TransformStmt {})) _ -- Syntactically illegal in mdo - = pprPanic "rn_rec_stmt: TransformStmt" (ppr stmt) - - rn_rec_stmt _ stmt@(L _ (GroupStmt {})) _ -- Syntactically illegal in mdo - = pprPanic "rn_rec_stmt: GroupStmt" (ppr stmt) + rn_rec_stmt _ stmt@(L _ (TransStmt {})) _ -- Syntactically illegal in mdo + = pprPanic "rn_rec_stmt: TransStmt" (ppr stmt) rn_rec_stmt _ (L _ (LetStmt EmptyLocalBinds)) _ = panic "rn_rec_stmt: LetStmt EmptyLocalBinds" @@@ -1164,44 -1184,151 +1207,151 @@@ program %************************************************************************ \begin{code} + checkEmptyStmts :: HsStmtContext Name -> RnM () + -- We've seen an empty sequence of Stmts... is that ok? + checkEmptyStmts ctxt + = unless (okEmpty ctxt) (addErr (emptyErr ctxt)) - ---------------------- - -- Checking when a particular Stmt is ok - checkLetStmt :: HsStmtContext Name -> HsLocalBinds RdrName -> RnM () - checkLetStmt (ParStmtCtxt _) (HsIPBinds binds) = addErr (badIpBinds (ptext (sLit "a parallel list comprehension:")) binds) - checkLetStmt _ctxt _binds = return () - -- We do not allow implicit-parameter bindings in a parallel - -- list comprehension. I'm not sure what it might mean. + okEmpty :: HsStmtContext a -> Bool + okEmpty (PatGuard {}) = True + okEmpty _ = False - --------- - checkRecStmt :: HsStmtContext Name -> RnM () - checkRecStmt MDoExpr = return () -- Recursive stmt ok in 'mdo' - checkRecStmt DoExpr = return () -- and in 'do' - checkRecStmt ctxt = addErr msg - where - msg = ptext (sLit "Illegal 'rec' stmt in") <+> pprStmtContext ctxt + emptyErr :: HsStmtContext Name -> SDoc + emptyErr (ParStmtCtxt {}) = ptext (sLit "Empty statement group in parallel comprehension") + emptyErr (TransStmtCtxt {}) = ptext (sLit "Empty statement group preceding 'group' or 'then'") + emptyErr ctxt = ptext (sLit "Empty") <+> pprStmtContext ctxt - --------- - checkParStmt :: HsStmtContext Name -> RnM () - checkParStmt _ - = do { parallel_list_comp <- xoptM Opt_ParallelListComp - ; checkErr parallel_list_comp msg } + ---------------------- + checkLastStmt :: HsStmtContext Name + -> LStmt RdrName + -> RnM (LStmt RdrName) + checkLastStmt ctxt lstmt@(L loc stmt) + = case ctxt of + ListComp -> check_comp + MonadComp -> check_comp + PArrComp -> check_comp + ArrowExpr -> check_do + DoExpr -> check_do + MDoExpr -> check_do + _ -> check_other where - msg = ptext (sLit "Illegal parallel list comprehension: use -XParallelListComp") + check_do -- Expect ExprStmt, and change it to LastStmt + = case stmt of + ExprStmt e _ _ _ -> return (L loc (mkLastStmt e)) + LastStmt {} -> return lstmt -- "Deriving" clauses may generate a + -- LastStmt directly (unlike the parser) + _ -> do { addErr (hang last_error 2 (ppr stmt)); return lstmt } + last_error = (ptext (sLit "The last statement in") <+> pprAStmtContext ctxt + <+> ptext (sLit "must be an expression")) + + check_comp -- Expect LastStmt; this should be enforced by the parser! + = case stmt of + LastStmt {} -> return lstmt + _ -> pprPanic "checkLastStmt" (ppr lstmt) + + check_other -- Behave just as if this wasn't the last stmt + = do { checkStmt ctxt lstmt; return lstmt } - --------- - checkTransformStmt :: HsStmtContext Name -> RnM () - checkTransformStmt ListComp -- Ensure we are really within a list comprehension because otherwise the - -- desugarer will break when we come to operate on a parallel array - = do { transform_list_comp <- xoptM Opt_TransformListComp - ; checkErr transform_list_comp msg } - where - msg = ptext (sLit "Illegal transform or grouping list comprehension: use -XTransformListComp") - checkTransformStmt (ParStmtCtxt ctxt) = checkTransformStmt ctxt -- Ok to nest inside a parallel comprehension - checkTransformStmt (TransformStmtCtxt ctxt) = checkTransformStmt ctxt -- Ok to nest inside a parallel comprehension - checkTransformStmt ctxt = addErr msg + -- Checking when a particular Stmt is ok + checkStmt :: HsStmtContext Name + -> LStmt RdrName + -> RnM () + checkStmt ctxt (L _ stmt) + = do { dflags <- getDOpts + ; case okStmt dflags ctxt stmt of + Nothing -> return () + Just extra -> addErr (msg $$ extra) } where - msg = ptext (sLit "Illegal transform or grouping in") <+> pprStmtContext ctxt + msg = sep [ ptext (sLit "Unexpected") <+> pprStmtCat stmt <+> ptext (sLit "statement") + , ptext (sLit "in") <+> pprAStmtContext ctxt ] + + pprStmtCat :: Stmt a -> SDoc + pprStmtCat (TransStmt {}) = ptext (sLit "transform") + pprStmtCat (LastStmt {}) = ptext (sLit "return expression") + pprStmtCat (ExprStmt {}) = ptext (sLit "exprssion") + pprStmtCat (BindStmt {}) = ptext (sLit "binding") + pprStmtCat (LetStmt {}) = ptext (sLit "let") + pprStmtCat (RecStmt {}) = ptext (sLit "rec") + pprStmtCat (ParStmt {}) = ptext (sLit "parallel") + + ------------ + isOK, notOK :: Maybe SDoc + isOK = Nothing + notOK = Just empty + + okStmt, okDoStmt, okCompStmt, okParStmt, okPArrStmt + :: DynFlags -> HsStmtContext Name + -> Stmt RdrName -> Maybe SDoc + -- Return Nothing if OK, (Just extra) if not ok + -- The "extra" is an SDoc that is appended to an generic error message + + okStmt dflags ctxt stmt + = case ctxt of + PatGuard {} -> okPatGuardStmt stmt + ParStmtCtxt ctxt -> okParStmt dflags ctxt stmt + DoExpr -> okDoStmt dflags ctxt stmt + MDoExpr -> okDoStmt dflags ctxt stmt + ArrowExpr -> okDoStmt dflags ctxt stmt + GhciStmt -> okDoStmt dflags ctxt stmt + ListComp -> okCompStmt dflags ctxt stmt + MonadComp -> okCompStmt dflags ctxt stmt + PArrComp -> okPArrStmt dflags ctxt stmt + TransStmtCtxt ctxt -> okStmt dflags ctxt stmt + + ------------- + okPatGuardStmt :: Stmt RdrName -> Maybe SDoc + okPatGuardStmt stmt + = case stmt of + ExprStmt {} -> isOK + BindStmt {} -> isOK + LetStmt {} -> isOK + _ -> notOK + + ------------- + okParStmt dflags ctxt stmt + = case stmt of + LetStmt (HsIPBinds {}) -> notOK + _ -> okStmt dflags ctxt stmt + + ---------------- + okDoStmt dflags ctxt stmt + = case stmt of + RecStmt {} + | Opt_DoRec `xopt` dflags -> isOK + | ArrowExpr <- ctxt -> isOK -- Arrows allows 'rec' + | otherwise -> Just (ptext (sLit "Use -XDoRec")) + BindStmt {} -> isOK + LetStmt {} -> isOK + ExprStmt {} -> isOK + _ -> notOK + + ---------------- + okCompStmt dflags _ stmt + = case stmt of + BindStmt {} -> isOK + LetStmt {} -> isOK + ExprStmt {} -> isOK + ParStmt {} + | Opt_ParallelListComp `xopt` dflags -> isOK + | otherwise -> Just (ptext (sLit "Use -XParallelListComp")) + TransStmt {} + | Opt_TransformListComp `xopt` dflags -> isOK + | otherwise -> Just (ptext (sLit "Use -XTransformListComp")) + RecStmt {} -> notOK + LastStmt {} -> notOK -- Should not happen (dealt with by checkLastStmt) + + ---------------- + okPArrStmt dflags _ stmt + = case stmt of + BindStmt {} -> isOK + LetStmt {} -> isOK + ExprStmt {} -> isOK + ParStmt {} + | Opt_ParallelListComp `xopt` dflags -> isOK + | otherwise -> Just (ptext (sLit "Use -XParallelListComp")) + TransStmt {} -> notOK + RecStmt {} -> notOK + LastStmt {} -> notOK -- Should not happen (dealt with by checkLastStmt) --------- checkTupleSection :: [HsTupArg RdrName] -> RnM () diff --combined compiler/rename/RnHsSyn.lhs index 535aca2,478ba32..b958f9d --- a/compiler/rename/RnHsSyn.lhs +++ b/compiler/rename/RnHsSyn.lhs @@@ -11,16 -11,14 +11,14 @@@ module RnHsSyn extractFunDepNames, extractHsCtxtTyNames, extractHsPredTyNames, -- Free variables - hsSigsFVs, hsSigFVs, conDeclFVs, bangTyFVs, - - maybeGenericMatch + hsSigsFVs, hsSigFVs, conDeclFVs, bangTyFVs ) where #include "HsVersions.h" 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,8 -38,6 +38,8 @@@ charTyCon_name, listTyCon_name, parrTyC 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) @@@ -61,7 -57,6 +59,7 @@@ extractHsTyNames t 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 @@@ -69,7 -64,6 +67,6 @@@ get (HsParTy ty) = getl ty get (HsBangTy _ ty) = getl ty get (HsRecTy flds) = extractHsTyNames_s (map cd_fld_type flds) - get (HsNumTy _) = emptyNameSet get (HsTyVar tv) = unitNameSet tv get (HsSpliceTy _ fvs _) = fvs get (HsQuasiQuoteTy {}) = emptyNameSet @@@ -123,10 -117,11 +120,11 @@@ hsSigsFVs :: [LSig Name] -> FreeVar hsSigsFVs sigs = plusFVs (map (hsSigFVs.unLoc) sigs) hsSigFVs :: Sig Name -> FreeVars - hsSigFVs (TypeSig _ ty) = extractHsTyNames ty - hsSigFVs (SpecInstSig ty) = extractHsTyNames ty - hsSigFVs (SpecSig _ ty _) = extractHsTyNames ty - hsSigFVs _ = emptyFVs + hsSigFVs (TypeSig _ ty) = extractHsTyNames ty + hsSigFVs (GenericSig _ ty) = extractHsTyNames ty + hsSigFVs (SpecInstSig ty) = extractHsTyNames ty + hsSigFVs (SpecSig _ ty _) = extractHsTyNames ty + hsSigFVs _ = emptyFVs ---------------- conDeclFVs :: LConDecl Name -> FreeVars @@@ -147,24 -142,3 +145,3 @@@ conDetailsFVs details = plusFVs (map ba bangTyFVs :: LHsType Name -> FreeVars bangTyFVs bty = extractHsTyNames (getBangType bty) \end{code} - - - %************************************************************************ - %* * - \subsection{A few functions on generic defintions - %* * - %************************************************************************ - - These functions on generics are defined over Matches Name, which is - why they are here and not in HsMatches. - - \begin{code} - maybeGenericMatch :: LMatch Name -> Maybe (HsType Name, LMatch Name) - -- Tells whether a Match is for a generic definition - -- and extract the type from a generic match and put it at the front - - maybeGenericMatch (L loc (Match (L _ (TypePat (L _ ty)) : pats) sig_ty grhss)) - = Just (ty, L loc (Match pats sig_ty grhss)) - - maybeGenericMatch _ = Nothing - \end{code} diff --combined compiler/rename/RnTypes.lhs index 8405e8c,be90d7d..31382c2 --- a/compiler/rename/RnTypes.lhs +++ b/compiler/rename/RnTypes.lhs @@@ -31,7 -31,7 +31,7 @@@ import RnEn import TcRnMonad import RdrName import PrelNames - import TypeRep ( funTyConName ) + import TysPrim ( funTyConName ) import Name import SrcLoc import NameSet @@@ -139,13 -139,6 +139,6 @@@ rnHsType doc (HsRecTy flds = do { flds' <- rnConDeclFields doc flds ; return (HsRecTy flds') } - rnHsType _ (HsNumTy i) - | i == 1 = return (HsNumTy i) - | otherwise = addErr err_msg >> return (HsNumTy i) - where - err_msg = ptext (sLit "Only unit numeric type pattern is valid") - - rnHsType doc (HsFunTy ty1 ty2) = do ty1' <- rnLHsType doc ty1 -- Might find a for-all as the arg of a function type @@@ -170,11 -163,6 +163,11 @@@ rnHsType doc (HsPArrTy ty) = d 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 --combined compiler/typecheck/TcEnv.lhs index c6789f4,96dc261..94daff0 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@@ -29,7 -29,6 +29,7 @@@ module TcEnv tcLookupId, tcLookupTyVar, getScopedTyVarBinds, getInLocalScope, wrongThingErr, pprBinders, + getHetMetLevel, tcExtendRecEnv, -- For knot-tying @@@ -212,7 -211,7 +212,7 @@@ tcLookupFamInst tycon ty } tcLookupDataFamInst :: TyCon -> [Type] -> TcM (TyCon, [Type]) - -- Find the instance of a data famliy + -- Find the instance of a data family -- Note [Looking up family instances for deriving] tcLookupDataFamInst tycon tys | not (isFamilyTyCon tycon) @@@ -406,19 -405,11 +406,19 @@@ tcExtendIdEnv ids thing_inside = tcExte 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 @@@ -427,13 -418,11 +427,13 @@@ -- 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: @@@ -443,7 -432,7 +443,7 @@@ -- 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'} @@@ -451,9 -440,7 +451,9 @@@ 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] @@@ -474,7 -461,7 +474,7 @@@ tcExtendGlobalTyVars gtv_var extra_glob \begin{code} tcExtendRules :: [LRuleDecl Id] -> TcM a -> TcM a -- Just pop the new rules into the EPS and envt resp - -- All the rules come from an interface file, not soruce + -- All the rules come from an interface file, not source -- Nevertheless, some may be for this module, if we read -- its interface instead of its source code tcExtendRules lcl_rules thing_inside @@@ -639,7 -626,7 +639,7 @@@ data InstBindings -- witness dictionary is identical to the argument -- dictionary. Hence no bindings, no pragmas. - CoercionI -- The coercion maps from newtype to the representation type + Coercion -- The coercion maps from newtype to the representation type -- (mentioning type variables bound by the forall'd iSpec variables) -- E.g. newtype instance N [a] = N1 (Tree a) -- co : N [a] ~ Tree a @@@ -653,7 -640,7 +653,7 @@@ pprInstInfo :: InstInfo a -> SDoc pprInstInfo info = hang (ptext (sLit "instance")) 2 (sep [ ifPprDebug (pprForAll tvs) - , pprThetaArrow theta, ppr tau + , pprThetaArrowTy theta, ppr tau , ptext (sLit "where")]) where (tvs, theta, tau) = tcSplitSigmaTy (idType (iDFunId info)) @@@ -694,7 -681,7 +694,7 @@@ newDFunName clas tys lo \end{code} Make a name for the representation tycon of a family instance. It's an - *external* name, like otber top-level names, and hence must be made with + *external* name, like other top-level names, and hence must be made with newGlobalBinder. \begin{code} diff --combined compiler/typecheck/TcExpr.lhs index 7d7c461,ee6a34a..8b907d2 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@@ -42,10 -42,10 +42,11 @@@ import DataCo import Name import TyCon import Type +import TypeRep import Coercion import Var import VarSet + import VarEnv import TysWiredIn import TysPrim( intPrimTy ) import PrimOp( tagToEnumKey ) @@@ -56,6 -56,7 +57,7 @@@ import SrcLo import Util import ListSetOps import Maybes + import ErrUtils import Outputable import FastString import Control.Monad @@@ -138,68 -139,17 +140,68 @@@ tcInfExpr e = tcInfer (tcEx %************************************************************************ \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 (HsApp e1 e2) res_ty = tcApp e1 [e2] res_ty +tcExpr (HsHetMetBrak _ e) res_ty = + do { (coi, [inferred_name,elt_ty]) <- matchExpectedTyConApp hetMetCodeTypeTyCon res_ty + ; fresh_ec_name <- newFlexiTyVar ecKind + ; 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 (HsLit lit) res_ty = do { let lit_ty = hsLitType lit - ; tcWrapResult (HsLit lit) lit_ty res_ty } +tcExpr (HsApp e1 e2) res_ty = tcApp e1 [e2] res_ty +tcExpr (HsLit lit) res_ty = + getHetMetLevel >>= \lev -> + case lev of + [] -> do { let lit_ty = hsLitType lit + ; tcWrapResult (HsLit lit) lit_ty res_ty } + (ec:rest) -> let n = case lit of + (HsChar c) -> hetmet_guest_char_literal_name + (HsString str) -> hetmet_guest_string_literal_name + (HsInteger i _) -> hetmet_guest_integer_literal_name + (HsInt i) -> hetmet_guest_integer_literal_name + _ -> error "literals of this sort are not allowed at depth >0" + in tcExpr (HsHetMetEsc (TyVarTy ec) placeHolderType $ noLoc $ + (HsApp (noLoc $ HsVar n) (noLoc $ HsLit lit))) res_ty + tcExpr (HsPar expr) res_ty = do { expr' <- tcMonoExprNC expr res_ty ; return (HsPar expr') } @@@ -215,18 -165,9 +217,18 @@@ tcExpr (HsCoreAnn lbl expr) res_t = do { expr' <- tcMonoExpr expr res_ty ; return (HsCoreAnn lbl expr') } -tcExpr (HsOverLit lit) res_ty - = do { lit' <- newOverloadedLit (LiteralOrigin lit) lit res_ty - ; return (HsOverLit lit') } +tcExpr (HsOverLit lit) res_ty = + getHetMetLevel >>= \lev -> + case lev of + [] -> do { lit' <- newOverloadedLit (LiteralOrigin lit) lit res_ty + ; return (HsOverLit lit') } + (ec:rest) -> let n = case lit of + (OverLit { ol_val = HsIntegral i }) -> hetmet_guest_integer_literal_name + (OverLit { ol_val = HsIsString fs }) -> hetmet_guest_string_literal_name + (OverLit { ol_val = HsFractional f }) -> error "fractional literals not allowed at depth >0" + in tcExpr (HsHetMetEsc (TyVarTy ec) placeHolderType $ noLoc $ + (HsApp (noLoc $ HsVar n) (noLoc $ HsOverLit lit))) res_ty + tcExpr (NegApp expr neg_expr) res_ty = do { neg_expr' <- tcSyntaxOp NegateOrigin neg_expr @@@ -347,8 -288,8 +349,8 @@@ tcExpr (OpApp arg1 op fix arg2) res_t ; co_res <- unifyType op_res_ty res_ty ; op_id <- tcLookupId op_name ; let op' = L loc (HsWrap (mkWpTyApps [arg2_ty, op_res_ty]) (HsVar op_id)) - ; return $ mkHsWrapCoI co_res $ - OpApp (mkLHsWrapCoI co_arg1 arg1') op' fix arg2' } + ; return $ mkHsWrapCo co_res $ + OpApp (mkLHsWrapCo co_arg1 arg1') op' fix arg2' } | otherwise = do { traceTc "Non Application rule" (ppr op) @@@ -356,8 -297,8 +358,8 @@@ ; (co_fn, arg_tys, op_res_ty) <- unifyOpFunTys op 2 op_ty ; co_res <- unifyType op_res_ty res_ty ; [arg1', arg2'] <- tcArgs op [arg1, arg2] arg_tys - ; return $ mkHsWrapCoI co_res $ - OpApp arg1' (mkLHsWrapCoI co_fn op') fix arg2' } + ; return $ mkHsWrapCo co_res $ + OpApp arg1' (mkLHsWrapCo co_fn op') fix arg2' } -- Right sections, equivalent to \ x -> x `op` expr, or -- \ x -> op x expr @@@ -367,8 -308,8 +369,8 @@@ tcExpr (SectionR op arg2) res_t ; (co_fn, [arg1_ty, arg2_ty], op_res_ty) <- unifyOpFunTys op 2 op_ty ; co_res <- unifyType (mkFunTy arg1_ty op_res_ty) res_ty ; arg2' <- tcArg op (arg2, arg2_ty, 2) - ; return $ mkHsWrapCoI co_res $ - SectionR (mkLHsWrapCoI co_fn op') arg2' } + ; return $ mkHsWrapCo co_res $ + SectionR (mkLHsWrapCo co_fn op') arg2' } tcExpr (SectionL arg1 op) res_ty = do { (op', op_ty) <- tcInferFun op @@@ -379,15 -320,15 +381,15 @@@ ; (co_fn, (arg1_ty:arg_tys), op_res_ty) <- unifyOpFunTys op n_reqd_args op_ty ; co_res <- unifyType (mkFunTys arg_tys op_res_ty) res_ty ; arg1' <- tcArg op (arg1, arg1_ty, 1) - ; return $ mkHsWrapCoI co_res $ - SectionL arg1' (mkLHsWrapCoI co_fn op') } + ; return $ mkHsWrapCo co_res $ + SectionL arg1' (mkLHsWrapCo co_fn op') } tcExpr (ExplicitTuple tup_args boxity) res_ty | all tupArgPresent tup_args = do { let tup_tc = tupleTyCon boxity (length tup_args) ; (coi, arg_tys) <- matchExpectedTyConApp tup_tc res_ty ; tup_args1 <- tcTupArgs tup_args arg_tys - ; return $ mkHsWrapCoI coi (ExplicitTuple tup_args1 boxity) } + ; return $ mkHsWrapCo coi (ExplicitTuple tup_args1 boxity) } | otherwise = -- The tup_args are a mixture of Present and Missing (for tuple sections) @@@ -406,19 -347,19 +408,19 @@@ -- Handle tuple sections where ; tup_args1 <- tcTupArgs tup_args arg_tys - ; return $ mkHsWrapCoI coi (ExplicitTuple tup_args1 boxity) } + ; return $ mkHsWrapCo coi (ExplicitTuple tup_args1 boxity) } tcExpr (ExplicitList _ exprs) res_ty = do { (coi, elt_ty) <- matchExpectedListTy res_ty ; exprs' <- mapM (tc_elt elt_ty) exprs - ; return $ mkHsWrapCoI coi (ExplicitList elt_ty exprs') } + ; return $ mkHsWrapCo coi (ExplicitList elt_ty exprs') } where tc_elt elt_ty expr = tcPolyExpr expr elt_ty tcExpr (ExplicitPArr _ exprs) res_ty -- maybe empty = do { (coi, elt_ty) <- matchExpectedPArrTy res_ty ; exprs' <- mapM (tc_elt elt_ty) exprs - ; return $ mkHsWrapCoI coi (ExplicitPArr elt_ty exprs') } + ; return $ mkHsWrapCo coi (ExplicitPArr elt_ty exprs') } where tc_elt elt_ty expr = tcPolyExpr expr elt_ty \end{code} @@@ -476,12 -417,12 +478,12 @@@ tcExpr (HsIf (Just fun) pred b1 b2) res -- and it maintains uniformity with other rebindable syntax ; return (HsIf (Just fun') pred' b1' b2') } - tcExpr (HsDo do_or_lc stmts body _) res_ty - = tcDoStmts do_or_lc stmts body res_ty + tcExpr (HsDo do_or_lc stmts _) res_ty + = tcDoStmts do_or_lc stmts res_ty tcExpr (HsProc pat cmd) res_ty = do { (pat', cmd', coi) <- tcProc pat cmd res_ty - ; return $ mkHsWrapCoI coi (HsProc pat' cmd') } + ; return $ mkHsWrapCo coi (HsProc pat' cmd') } tcExpr e@(HsArrApp _ _ _ _ _) _ = failWithTc (vcat [ptext (sLit "The arrow command"), nest 2 (ppr e), @@@ -528,7 -469,7 +530,7 @@@ tcExpr (RecordCon (L loc con_name) _ rb ; co_res <- unifyType actual_res_ty res_ty ; rbinds' <- tcRecordBinds data_con arg_tys rbinds - ; return $ mkHsWrapCoI co_res $ + ; return $ mkHsWrapCo co_res $ RecordCon (L loc con_id) con_expr rbinds' } \end{code} @@@ -664,7 -605,7 +666,7 @@@ tcExpr (RecordUpd record_expr rbinds _ -- Take apart a representative constructor con1 = ASSERT( not (null relevant_cons) ) head relevant_cons - (con1_tvs, _, _, _, _, con1_arg_tys, _) = dataConFullSig con1 + (con1_tvs, _, _, _, con1_arg_tys, _) = dataConFullSig con1 con1_flds = dataConFieldLabels con1 con1_res_ty = mkFamilyTyConApp tycon (mkTyVarTys con1_tvs) @@@ -702,10 -643,10 +704,10 @@@ ; (_, result_inst_tys, result_inst_env) <- tcInstTyVars con1_tvs ; scrut_inst_tys <- zipWithM mk_inst_ty con1_tvs result_inst_tys - ; let rec_res_ty = substTy result_inst_env con1_res_ty - con1_arg_tys' = map (substTy result_inst_env) con1_arg_tys + ; let rec_res_ty = TcType.substTy result_inst_env con1_res_ty + con1_arg_tys' = map (TcType.substTy result_inst_env) con1_arg_tys scrut_subst = zipTopTvSubst con1_tvs scrut_inst_tys - scrut_ty = substTy scrut_subst con1_res_ty + scrut_ty = TcType.substTy scrut_subst con1_res_ty ; co_res <- unifyType rec_res_ty res_ty @@@ -720,11 -661,11 +722,11 @@@ -- Step 7: make a cast for the scrutinee, in the case that it's from a type family ; let scrut_co | Just co_con <- tyConFamilyCoercion_maybe tycon - = WpCast $ mkTyConApp co_con scrut_inst_tys + = WpCast $ mkAxInstCo co_con scrut_inst_tys | otherwise = idHsWrapper -- Phew! - ; return $ mkHsWrapCoI co_res $ + ; return $ mkHsWrapCo co_res $ RecordUpd (mkLHsWrap scrut_co record_expr') rbinds' relevant_cons scrut_inst_tys result_inst_tys } where @@@ -764,7 -705,7 +766,7 @@@ tcExpr (ArithSeq _ seq@(From expr)) res ; expr' <- tcPolyExpr expr elt_ty ; enum_from <- newMethodFromName (ArithSeqOrigin seq) enumFromName elt_ty - ; return $ mkHsWrapCoI coi (ArithSeq enum_from (From expr')) } + ; return $ mkHsWrapCo coi (ArithSeq enum_from (From expr')) } tcExpr (ArithSeq _ seq@(FromThen expr1 expr2)) res_ty = do { (coi, elt_ty) <- matchExpectedListTy res_ty @@@ -772,7 -713,7 +774,7 @@@ ; expr2' <- tcPolyExpr expr2 elt_ty ; enum_from_then <- newMethodFromName (ArithSeqOrigin seq) enumFromThenName elt_ty - ; return $ mkHsWrapCoI coi + ; return $ mkHsWrapCo coi (ArithSeq enum_from_then (FromThen expr1' expr2')) } tcExpr (ArithSeq _ seq@(FromTo expr1 expr2)) res_ty @@@ -781,7 -722,7 +783,7 @@@ ; expr2' <- tcPolyExpr expr2 elt_ty ; enum_from_to <- newMethodFromName (ArithSeqOrigin seq) enumFromToName elt_ty - ; return $ mkHsWrapCoI coi + ; return $ mkHsWrapCo coi (ArithSeq enum_from_to (FromTo expr1' expr2')) } tcExpr (ArithSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty @@@ -791,7 -732,7 +793,7 @@@ ; expr3' <- tcPolyExpr expr3 elt_ty ; eft <- newMethodFromName (ArithSeqOrigin seq) enumFromThenToName elt_ty - ; return $ mkHsWrapCoI coi + ; return $ mkHsWrapCo coi (ArithSeq eft (FromThenTo expr1' expr2' expr3')) } tcExpr (PArrSeq _ seq@(FromTo expr1 expr2)) res_ty @@@ -800,7 -741,7 +802,7 @@@ ; expr2' <- tcPolyExpr expr2 elt_ty ; enum_from_to <- newMethodFromName (PArrSeqOrigin seq) (enumFromToPName basePackageId) elt_ty -- !!!FIXME: chak - ; return $ mkHsWrapCoI coi + ; return $ mkHsWrapCo coi (PArrSeq enum_from_to (FromTo expr1' expr2')) } tcExpr (PArrSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty @@@ -810,7 -751,7 +812,7 @@@ ; expr3' <- tcPolyExpr expr3 elt_ty ; eft <- newMethodFromName (PArrSeqOrigin seq) (enumFromThenToPName basePackageId) elt_ty -- !!!FIXME: chak - ; return $ mkHsWrapCoI coi + ; return $ mkHsWrapCo coi (PArrSeq eft (FromThenTo expr1' expr2' expr3')) } tcExpr (PArrSeq _ _) _ @@@ -881,15 -822,15 +883,15 @@@ tcApp fun args res_t -- Typecheck the result, thereby propagating -- info (if any) from result into the argument types -- Both actual_res_ty and res_ty are deeply skolemised - ; co_res <- addErrCtxt (funResCtxt fun) $ + ; co_res <- addErrCtxtM (funResCtxt fun actual_res_ty res_ty) $ unifyType actual_res_ty res_ty -- Typecheck the arguments ; args1 <- tcArgs fun args expected_arg_tys -- Assemble the result - ; let fun2 = mkLHsWrapCoI co_fun fun1 - app = mkLHsWrapCoI co_res (foldl mkHsApp fun2 args1) + ; let fun2 = mkLHsWrapCo co_fun fun1 + app = mkLHsWrapCo co_res (foldl mkHsApp fun2 args1) ; return (unLoc app) } @@@ -911,7 -852,7 +913,7 @@@ tcInferApp fun arg ; (co_fun, expected_arg_tys, actual_res_ty) <- matchExpectedFunTys (mk_app_msg fun) (length args) fun_tau ; args1 <- tcArgs fun args expected_arg_tys - ; let fun2 = mkLHsWrapCoI co_fun fun1 + ; let fun2 = mkLHsWrapCo co_fun fun1 app = foldl mkHsApp fun2 args1 ; return (unLoc app, actual_res_ty) } @@@ -960,7 -901,7 +962,7 @@@ tcTupArgs args ty ---------------- unifyOpFunTys :: LHsExpr Name -> Arity -> TcRhoType - -> TcM (CoercionI, [TcSigmaType], TcRhoType) + -> TcM (Coercion, [TcSigmaType], TcRhoType) -- A wrapper for matchExpectedFunTys unifyOpFunTys op arity ty = matchExpectedFunTys herald arity ty where @@@ -1022,40 -963,24 +1024,40 @@@ tcInferId n = tcInferIdWithOrig (Occurr 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 @@@ -1087,7 -1012,7 +1089,7 @@@ instantiateOuter orig i ; let theta' = substTheta subst theta ; traceTc "Instantiating" (ppr id <+> text "with" <+> (ppr tys $$ ppr theta')) ; wrap <- instCall orig tys theta' - ; return (mkHsWrap wrap (HsVar id), substTy subst tau) } + ; return (mkHsWrap wrap (HsVar id), TcType.substTy subst tau) } where (tvs, theta, tau) = tcSplitSigmaTy (idType id) \end{code} @@@ -1211,7 -1136,7 +1213,7 @@@ tcTagToEnum loc fun_name arg res_t ; let fun' = L loc (HsWrap (WpTyApp rep_ty) (HsVar fun)) rep_ty = mkTyConApp rep_tc rep_args - ; return (mkHsWrapCoI coi $ HsApp fun' arg') } + ; return (mkHsWrapCo coi $ HsApp fun' arg') } where doc1 = vcat [ ptext (sLit "Specify the type by giving a type signature") , ptext (sLit "e.g. (tagToEnum# x) :: Bool") ] @@@ -1219,18 -1144,18 +1221,18 @@@ doc3 = ptext (sLit "No family instance for this type") get_rep_ty :: TcType -> TyCon -> [TcType] - -> TcM (CoercionI, TyCon, [TcType]) + -> TcM (Coercion, TyCon, [TcType]) -- Converts a family type (eg F [a]) to its rep type (eg FList a) -- and returns a coercion between the two get_rep_ty ty tc tc_args | not (isFamilyTyCon tc) - = return (IdCo ty, tc, tc_args) + = return (mkReflCo ty, tc, tc_args) | otherwise = do { mb_fam <- tcLookupFamInst tc tc_args ; case mb_fam of Nothing -> failWithTc (tagToEnumError ty doc3) Just (rep_tc, rep_args) - -> return ( ACo (mkSymCoercion (mkTyConApp co_tc rep_args)) + -> return ( mkSymCo (mkAxInstCo co_tc rep_args) , rep_tc, rep_args ) where co_tc = expectJust "tcTagToEnum" $ @@@ -1463,9 -1388,23 +1465,23 @@@ funAppCtxt fun arg arg_n quotes (ppr fun) <> text ", namely"]) 2 (quotes (ppr arg)) - funResCtxt :: LHsExpr Name -> SDoc - funResCtxt fun - = ptext (sLit "In the return type of a call of") <+> quotes (ppr fun) + funResCtxt :: LHsExpr Name -> TcType -> TcType + -> TidyEnv -> TcM (TidyEnv, Message) + -- When we have a mis-match in the return type of a function + -- try to give a helpful message about too many/few arguments + funResCtxt fun fun_res_ty res_ty env0 + = do { fun_res' <- zonkTcType fun_res_ty + ; res' <- zonkTcType res_ty + ; let n_fun = length (fst (tcSplitFunTys fun_res')) + n_res = length (fst (tcSplitFunTys res')) + what | n_fun > n_res = ptext (sLit "few") + | otherwise = ptext (sLit "many") + extra | n_fun == n_res = empty + | otherwise = ptext (sLit "Probable cause:") <+> quotes (ppr fun) + <+> ptext (sLit "is applied to too") <+> what + <+> ptext (sLit "arguments") + msg = ptext (sLit "In the return type of a call of") <+> quotes (ppr fun) + ; return (env0, msg $$ extra) } badFieldTypes :: [(Name,TcType)] -> SDoc badFieldTypes prs diff --combined compiler/typecheck/TcHsSyn.lhs index ab7d8c2,12b50ac..4845d70 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@@ -35,6 -35,7 +35,7 @@@ import TcRnMona import PrelNames import TcType import TcMType + import Coercion import TysPrim import TysWiredIn import DataCon @@@ -43,14 -44,15 +44,15 @@@ import NameSe import Var import VarSet import VarEnv + import DynFlags( DynFlag(..) ) import Literal import BasicTypes import Maybes import SrcLoc import Bag import FastString import Outputable + -- import Data.Traversable( traverse ) \end{code} \begin{code} @@@ -119,7 -121,7 +121,7 @@@ shortCutLit (HsIntegral i) t | isIntTy ty && inIntRange i = Just (HsLit (HsInt i)) | isWordTy ty && inWordRange i = Just (mkLit wordDataCon (HsWordPrim i)) | isIntegerTy ty = Just (HsLit (HsInteger i ty)) - | otherwise = shortCutLit (HsFractional (fromInteger i)) ty + | otherwise = shortCutLit (HsFractional (integralFractionalLit i)) ty -- The 'otherwise' case is important -- Consider (3 :: Float). Syntactically it looks like an IntLit, -- so we'll call shortCutIntLit, but of course it's a float @@@ -544,22 -546,6 +546,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 -> @@@ -594,11 -580,10 +596,10 @@@ zonkExpr env (HsLet binds expr zonkLExpr new_env expr `thenM` \ new_expr -> returnM (HsLet new_binds new_expr) - zonkExpr env (HsDo do_or_lc stmts body ty) - = zonkStmts env stmts `thenM` \ (new_env, new_stmts) -> - zonkLExpr new_env body `thenM` \ new_body -> + zonkExpr env (HsDo do_or_lc stmts ty) + = zonkStmts env stmts `thenM` \ (_, new_stmts) -> zonkTcTypeToType env ty `thenM` \ new_ty -> - returnM (HsDo do_or_lc new_stmts new_body new_ty) + returnM (HsDo do_or_lc new_stmts new_ty) zonkExpr env (ExplicitList ty exprs) = zonkTcTypeToType env ty `thenM` \ new_ty -> @@@ -692,7 -677,7 +693,7 @@@ zonkCoFn env WpHole = return (env, Wp zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1 ; (env2, c2') <- zonkCoFn env1 c2 ; return (env2, WpCompose c1' c2') } - zonkCoFn env (WpCast co) = do { co' <- zonkTcTypeToType env co + zonkCoFn env (WpCast co) = do { co' <- zonkTcCoToCo env co ; return (env, WpCast co') } zonkCoFn env (WpEvLam ev) = do { (env', ev') <- zonkEvBndrX env ev ; return (env', WpEvLam ev') } @@@ -744,22 -729,26 +745,26 @@@ zonkStmts env (s:ss) = do { (env1, s' ; return (env2, s' : ss') } zonkStmt :: ZonkEnv -> Stmt TcId -> TcM (ZonkEnv, Stmt Id) - zonkStmt env (ParStmt stmts_w_bndrs) + zonkStmt env (ParStmt stmts_w_bndrs mzip_op bind_op return_op) = mappM zonk_branch stmts_w_bndrs `thenM` \ new_stmts_w_bndrs -> let new_binders = concat (map snd new_stmts_w_bndrs) env1 = extendZonkEnv env new_binders in - return (env1, ParStmt new_stmts_w_bndrs) + zonkExpr env1 mzip_op `thenM` \ new_mzip -> + zonkExpr env1 bind_op `thenM` \ new_bind -> + zonkExpr env1 return_op `thenM` \ new_return -> + return (env1, ParStmt new_stmts_w_bndrs new_mzip new_bind new_return) where zonk_branch (stmts, bndrs) = zonkStmts env stmts `thenM` \ (env1, new_stmts) -> returnM (new_stmts, zonkIdOccs env1 bndrs) zonkStmt env (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_ids = rvs , recS_ret_fn = ret_id, recS_mfix_fn = mfix_id, recS_bind_fn = bind_id - , recS_rec_rets = rets }) + , recS_rec_rets = rets, recS_ret_ty = ret_ty }) = do { new_rvs <- zonkIdBndrs env rvs ; new_lvs <- zonkIdBndrs env lvs + ; new_ret_ty <- zonkTcTypeToType env ret_ty ; new_ret_id <- zonkExpr env ret_id ; new_mfix_id <- zonkExpr env mfix_id ; new_bind_id <- zonkExpr env bind_id @@@ -772,28 -761,34 +777,34 @@@ RecStmt { recS_stmts = new_segStmts, recS_later_ids = new_lvs , recS_rec_ids = new_rvs, recS_ret_fn = new_ret_id , recS_mfix_fn = new_mfix_id, recS_bind_fn = new_bind_id - , recS_rec_rets = new_rets }) } + , recS_rec_rets = new_rets, recS_ret_ty = new_ret_ty }) } - zonkStmt env (ExprStmt expr then_op ty) + zonkStmt env (ExprStmt expr then_op guard_op ty) = zonkLExpr env expr `thenM` \ new_expr -> zonkExpr env then_op `thenM` \ new_then -> + zonkExpr env guard_op `thenM` \ new_guard -> zonkTcTypeToType env ty `thenM` \ new_ty -> - returnM (env, ExprStmt new_expr new_then new_ty) + returnM (env, ExprStmt new_expr new_then new_guard new_ty) - zonkStmt env (TransformStmt stmts binders usingExpr maybeByExpr) - = do { (env', stmts') <- zonkStmts env stmts - ; let binders' = zonkIdOccs env' binders - ; usingExpr' <- zonkLExpr env' usingExpr - ; maybeByExpr' <- zonkMaybeLExpr env' maybeByExpr - ; return (env', TransformStmt stmts' binders' usingExpr' maybeByExpr') } - - zonkStmt env (GroupStmt stmts binderMap by using) + zonkStmt env (LastStmt expr ret_op) + = zonkLExpr env expr `thenM` \ new_expr -> + zonkExpr env ret_op `thenM` \ new_ret -> + returnM (env, LastStmt new_expr new_ret) + + zonkStmt env (TransStmt { trS_stmts = stmts, trS_bndrs = binderMap + , trS_by = by, trS_form = form, trS_using = using + , trS_ret = return_op, trS_bind = bind_op, trS_fmap = liftM_op }) = do { (env', stmts') <- zonkStmts env stmts ; binderMap' <- mappM (zonkBinderMapEntry env') binderMap - ; by' <- fmapMaybeM (zonkLExpr env') by - ; using' <- fmapEitherM (zonkLExpr env) (zonkExpr env) using + ; by' <- fmapMaybeM (zonkLExpr env') by + ; using' <- zonkLExpr env using + ; return_op' <- zonkExpr env' return_op + ; bind_op' <- zonkExpr env' bind_op + ; liftM_op' <- zonkExpr env' liftM_op ; let env'' = extendZonkEnv env' (map snd binderMap') - ; return (env'', GroupStmt stmts' binderMap' by' using') } + ; return (env'', TransStmt { trS_stmts = stmts', trS_bndrs = binderMap' + , trS_by = by', trS_form = form, trS_using = using' + , trS_ret = return_op', trS_bind = bind_op', trS_fmap = liftM_op' }) } where zonkBinderMapEntry env (oldBinder, newBinder) = do let oldBinder' = zonkIdOcc env oldBinder @@@ -811,11 -806,6 +822,6 @@@ zonkStmt env (BindStmt pat expr bind_o ; new_fail <- zonkExpr env fail_op ; return (env1, BindStmt new_pat new_expr new_bind new_fail) } - zonkMaybeLExpr :: ZonkEnv -> Maybe (LHsExpr TcId) -> TcM (Maybe (LHsExpr Id)) - zonkMaybeLExpr _ Nothing = return Nothing - zonkMaybeLExpr env (Just e) = (zonkLExpr env e) >>= (return . Just) - - ------------------------------------------------------------------------- zonkRecFields :: ZonkEnv -> HsRecordBinds TcId -> TcM (HsRecordBinds TcId) zonkRecFields env (HsRecFields flds dd) @@@ -1020,7 -1010,6 +1026,6 @@@ zonkRule env (HsRule name act (vars{-:: zonk_it env v | isId v = do { v' <- zonkIdBndr env v; return (extendZonkEnv1 env v', v') } - | isCoVar v = do { v' <- zonkEvBndr env v; return (extendZonkEnv1 env v', v') } | otherwise = ASSERT( isImmutableTyVar v) return (env, v) \end{code} @@@ -1050,10 -1039,10 +1055,10 @@@ zonkVect env (HsVect v (Just e) zonkEvTerm :: ZonkEnv -> EvTerm -> TcM EvTerm zonkEvTerm env (EvId v) = ASSERT2( isId v, ppr v ) return (EvId (zonkIdOcc env v)) - zonkEvTerm env (EvCoercion co) = do { co' <- zonkTcTypeToType env co + zonkEvTerm env (EvCoercion co) = do { co' <- zonkTcCoToCo env co ; return (EvCoercion co') } zonkEvTerm env (EvCast v co) = ASSERT( isId v) - do { co' <- zonkTcTypeToType env co + do { co' <- zonkTcCoToCo env co ; return (EvCast (zonkIdOcc env v) co') } zonkEvTerm env (EvSuperClass d n) = return (EvSuperClass (zonkIdOcc env d) n) zonkEvTerm env (EvDFunApp df tys tms) @@@ -1128,4 -1117,27 +1133,27 @@@ zonkTypeZapping t zonk_unbound_tyvar tv = do { let ty = anyTypeOfKind (tyVarKind tv) ; writeMetaTyVar tv ty ; return ty } - \end{code} + + zonkTcCoToCo :: ZonkEnv -> Coercion -> TcM Coercion + zonkTcCoToCo env co + = go co + where + go (CoVarCo cv) = return (CoVarCo (zonkEvVarOcc env cv)) + go (Refl ty) = do { ty' <- zonkTcTypeToType env ty + ; return (Refl ty') } + go (TyConAppCo tc cos) = do { cos' <- mapM go cos; return (mkTyConAppCo tc cos') } + go (AxiomInstCo ax cos) = do { cos' <- mapM go cos; return (AxiomInstCo ax cos') } + go (AppCo co1 co2) = do { co1' <- go co1; co2' <- go co2 + ; return (mkAppCo co1' co2') } + go (UnsafeCo t1 t2) = do { t1' <- zonkTcTypeToType env t1 + ; t2' <- zonkTcTypeToType env t2 + ; return (mkUnsafeCo t1' t2') } + go (SymCo co) = do { co' <- go co; return (mkSymCo co') } + go (NthCo n co) = do { co' <- go co; return (mkNthCo n co') } + go (TransCo co1 co2) = do { co1' <- go co1; co2' <- go co2 + ; return (mkTransCo co1' co2') } + go (InstCo co ty) = do { co' <- go co; ty' <- zonkTcTypeToType env ty + ; return (mkInstCo co' ty') } + go (ForAllCo tv co) = ASSERT( isImmutableTyVar tv ) + do { co' <- go co; return (mkForAllCo tv co') } + \end{code} diff --combined compiler/typecheck/TcHsType.lhs index 669c61c,65f16c5..2174be3 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@@ -37,7 -37,6 +37,7 @@@ import TcMTyp import TcUnify import TcIface import TcType +import TypeRep ( ecKind ) import {- Kind parts of -} Type import Var import VarSet @@@ -45,7 -44,6 +45,6 @@@ import TyCo import Class import Name import NameSet - import PrelNames import TysWiredIn import BasicTypes import SrcLoc @@@ -366,14 -364,6 +365,11 @@@ kc_hs_type (HsPArrTy ty) = d ty' <- kcLiftedType ty return (HsPArrTy ty', liftedTypeKind) +kc_hs_type (HsModalBoxType ecn ty) = do + kc_check_hs_type (HsTyVar ecn) (EK ecKind EkUnk) + ty' <- kcLiftedType ty + return (HsModalBoxType ecn ty', liftedTypeKind) + - kc_hs_type (HsNumTy n) - = return (HsNumTy n, liftedTypeKind) - kc_hs_type (HsKindSig ty k) = do ty' <- kc_check_lhs_type ty (EK k EkKindSig) return (HsKindSig ty' k, k) @@@ -595,11 -585,6 +591,11 @@@ ds_type (HsPArrTy ty) = d checkWiredInTyCon parrTyCon return (mkPArrTy tau_ty) +ds_type (HsModalBoxType ecn ty) = do + tau_ty <- dsHsType ty + checkWiredInTyCon hetMetCodeTypeTyCon + return (mkHetMetCodeTypeTy (mkTyVar ecn ecKind) tau_ty) + ds_type (HsTupleTy boxity tys) = do tau_tys <- dsHsTypes tys checkWiredInTyCon tycon @@@ -617,11 -602,6 +613,6 @@@ ds_type (HsOpTy ty1 (L span op) ty2) = tau_ty2 <- dsHsType ty2 setSrcSpan span (ds_var_app op [tau_ty1,tau_ty2]) - ds_type (HsNumTy n) - = ASSERT(n==1) do - tc <- tcLookupTyCon genUnitTyConName - return (mkTyConApp tc []) - ds_type ty@(HsAppTy _ _) = ds_app ty [] @@@ -868,7 -848,7 +859,7 @@@ tcPatSig :: UserTypeCtx [(Name, TcType)], -- The new bit of type environment, binding -- the scoped type variables HsWrapper) -- Coercion due to unification with actual ty - -- Of shape: res_ty ~ sig_ty + -- Of shape: res_ty ~ sig_ty tcPatSig ctxt sig res_ty = do { (sig_tvs, sig_ty) <- tcHsPatSigType ctxt sig -- sig_tvs are the type variables free in 'sig', @@@ -880,8 -860,7 +871,7 @@@ -- and hence is rigid, so use it to zap the res_ty wrap <- tcSubType PatSigOrigin ctxt res_ty sig_ty ; return (sig_ty, [], wrap) - - } else do { + } else do { -- Type signature binds at least one scoped type variable -- A pattern binding cannot bind scoped type variables @@@ -904,20 -883,20 +894,20 @@@ ; checkTc (null bad_tvs) (badPatSigTvs sig_ty bad_tvs) -- Now do a subsumption check of the pattern signature against res_ty - ; sig_tvs' <- tcInstSigTyVars sig_tvs + ; sig_tvs' <- tcInstSigTyVars sig_tvs ; let sig_ty' = substTyWith sig_tvs sig_tv_tys' sig_ty sig_tv_tys' = mkTyVarTys sig_tvs' - ; wrap <- tcSubType PatSigOrigin ctxt res_ty sig_ty' + ; wrap <- tcSubType PatSigOrigin ctxt res_ty sig_ty' -- Check that each is bound to a distinct type variable, -- and one that is not already in scope - ; binds_in_scope <- getScopedTyVarBinds + ; binds_in_scope <- getScopedTyVarBinds ; let tv_binds = map tyVarName sig_tvs `zip` sig_tv_tys' ; check binds_in_scope tv_binds -- Phew! - ; return (sig_ty', tv_binds, wrap) - } } + ; return (sig_ty', tv_binds, wrap) + } } where check _ [] = return () check in_scope ((n,ty):rest) = do { check_one in_scope n ty @@@ -928,7 -907,7 +918,7 @@@ -- Must not bind to the same type variable -- as some other in-scope type variable where - dups = [n' | (n',ty') <- in_scope, tcEqType ty' ty] + dups = [n' | (n',ty') <- in_scope, eqType ty' ty] \end{code} diff --combined compiler/typecheck/TcRnMonad.lhs index deefe93,7e7f117..c86b081 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@@ -135,8 -135,7 +135,8 @@@ initTc hsc_env hsc_src keep_rn_syntax m tcl_tyvars = tvs_var, tcl_lie = lie_var, tcl_meta = meta_var, - tcl_untch = initTyVarUnique + tcl_untch = initTyVarUnique, + tcl_hetMetLevel = [] } ; } ; @@@ -407,7 -406,6 +407,6 @@@ traceRn, traceSplice :: SDoc -> TcRn ( traceRn = traceOptTcRn Opt_D_dump_rn_trace traceSplice = traceOptTcRn Opt_D_dump_splices - traceIf, traceHiDiffs :: SDoc -> TcRnIf m n () traceIf = traceOptIf Opt_D_dump_if_trace traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs @@@ -782,11 -780,6 +781,6 @@@ updCtxt :: ([ErrCtxt] -> [ErrCtxt]) -> updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) -> env { tcl_ctxt = upd ctxt }) - -- Conditionally add an error context - maybeAddErrCtxt :: Maybe Message -> TcM a -> TcM a - maybeAddErrCtxt (Just msg) thing_inside = addErrCtxt msg thing_inside - maybeAddErrCtxt Nothing thing_inside = thing_inside - popErrCtxt :: TcM a -> TcM a popErrCtxt = updCtxt (\ msgs -> case msgs of { [] -> []; (_ : ms) -> ms }) @@@ -898,6 -891,9 +892,9 @@@ add_err_tcm tidy_env err_msg loc ctx mkErrInfo :: TidyEnv -> [ErrCtxt] -> TcM SDoc -- Tidy the error info, trimming excessive contexts mkErrInfo env ctxts + | opt_PprStyle_Debug -- In -dppr-debug style the output + = return empty -- just becomes too voluminous + | otherwise = go 0 env ctxts where go :: Int -> TidyEnv -> [ErrCtxt] -> TcM SDoc @@@ -1153,7 -1149,7 +1150,7 @@@ failIfM :: Message -> IfL failIfM msg = do { env <- getLclEnv ; let full_msg = (if_loc env <> colon) $$ nest 2 msg - ; liftIO (printErrs (full_msg defaultErrStyle)) + ; liftIO (printErrs full_msg defaultErrStyle) ; failM } -------------------- @@@ -1188,7 -1184,7 +1185,7 @@@ forkM_maybe doc thing_insid ; return Nothing } }} where - print_errs sdoc = liftIO (printErrs (sdoc defaultErrStyle)) + print_errs sdoc = liftIO (printErrs sdoc defaultErrStyle) forkM :: SDoc -> IfL a -> IfL a forkM doc thing_inside diff --combined compiler/typecheck/TcRnTypes.lhs index 79f2a74,17e5dcb..d94ecd7 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@@ -40,11 -40,13 +40,13 @@@ module TcRnTypes Implication(..), CtLoc(..), ctLocSpan, ctLocOrigin, setCtLocOrigin, CtOrigin(..), EqOrigin(..), - WantedLoc, GivenLoc, pushErrCtxt, + WantedLoc, GivenLoc, GivenKind(..), pushErrCtxt, - SkolemInfo(..), + SkolemInfo(..), - CtFlavor(..), pprFlavorArising, isWanted, isGiven, isDerived, + CtFlavor(..), pprFlavorArising, isWanted, + isGivenOrSolved, isGiven_maybe, + isDerived, FlavoredEvVar, -- Pretty printing @@@ -62,6 -64,7 +64,7 @@@ import HsSyn import HscTypes import Type + import Id ( evVarPred ) import Class ( Class ) import DataCon ( DataCon, dataConUserType ) import TcType @@@ -324,6 -327,7 +327,7 @@@ data IfLclEn -- plus which bit is currently being examined if_tv_env :: UniqFM TyVar, -- Nested tyvar bindings + -- (and coercions) if_id_env :: UniqFM Id -- Nested id binding } \end{code} @@@ -373,7 -377,6 +377,7 @@@ data TcLclEnv -- Changes as we move in -- 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 @@@ -510,9 -513,7 +514,9 @@@ data TcTyThin | 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 @@@ -527,8 -528,7 +531,8 @@@ instance Outputable TcTyThing where -- 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 @@@ -643,7 -643,7 +647,7 @@@ plusImportAvail (ImportAvails { imp_mods = mods2, imp_dep_mods = dmods2, imp_dep_pkgs = dpkgs2, imp_orphs = orphs2, imp_finsts = finsts2 }) - = ImportAvails { imp_mods = plusModuleEnv_C (++) mods1 mods2, + = ImportAvails { imp_mods = plusModuleEnv_C (++) mods1 mods2, imp_dep_mods = plusUFM_C plus_mod_dep dmods1 dmods2, imp_dep_pkgs = dpkgs1 `unionLists` dpkgs2, imp_orphs = orphs1 `unionLists` orphs2, @@@ -678,7 -678,6 +682,6 @@@ instance Outputable WhereFrom wher %************************************************************************ %* * Wanted constraints - These are forced to be in TcRnTypes because TcLclEnv mentions WantedConstraints WantedConstraint mentions CtLoc @@@ -905,7 -904,7 +908,7 @@@ pprEvVarTheta :: [EvVar] -> SDo pprEvVarTheta ev_vars = pprTheta (map evVarPred ev_vars) pprEvVarWithType :: EvVar -> SDoc - pprEvVarWithType v = ppr v <+> dcolon <+> pprPred (evVarPred v) + pprEvVarWithType v = ppr v <+> dcolon <+> pprPredTy (evVarPred v) pprWantedsWithLocs :: WantedConstraints -> SDoc pprWantedsWithLocs wcs @@@ -927,35 -926,37 +930,37 @@@ pprWantedEvVar (EvVarX v _) = \begin{code} data CtFlavor - = Given GivenLoc -- We have evidence for this constraint in TcEvBinds - | Derived WantedLoc - -- We have evidence for this constraint in TcEvBinds; - -- *however* this evidence can contain wanteds, so - -- it's valid only provisionally to the solution of - -- these wanteds - | Wanted WantedLoc -- We have no evidence bindings for this constraint. - - -- data DerivedOrig = DerSC | DerInst | DerSelf - -- Deriveds are either superclasses of other wanteds or deriveds, or partially - -- solved wanteds from instances, or 'self' dictionaries containing yet wanted - -- superclasses. + = Given GivenLoc GivenKind -- We have evidence for this constraint in TcEvBinds + | Derived WantedLoc -- Derived's are just hints for unifications + | Wanted WantedLoc -- We have no evidence bindings for this constraint. + + data GivenKind + = GivenOrig -- Originates in some given, such as signature or pattern match + | GivenSolved -- Is given as result of being solved, maybe provisionally on + -- some other wanted constraints. instance Outputable CtFlavor where - ppr (Given {}) = ptext (sLit "[G]") - ppr (Wanted {}) = ptext (sLit "[W]") - ppr (Derived {}) = ptext (sLit "[D]") + ppr (Given _ GivenOrig) = ptext (sLit "[G]") + ppr (Given _ GivenSolved) = ptext (sLit "[S]") -- Print [S] for Given/Solved's + ppr (Wanted {}) = ptext (sLit "[W]") + ppr (Derived {}) = ptext (sLit "[D]") + pprFlavorArising :: CtFlavor -> SDoc - pprFlavorArising (Derived wl ) = pprArisingAt wl + pprFlavorArising (Derived wl) = pprArisingAt wl pprFlavorArising (Wanted wl) = pprArisingAt wl - pprFlavorArising (Given gl) = pprArisingAt gl + pprFlavorArising (Given gl _) = pprArisingAt gl isWanted :: CtFlavor -> Bool isWanted (Wanted {}) = True isWanted _ = False - isGiven :: CtFlavor -> Bool - isGiven (Given {}) = True - isGiven _ = False + isGivenOrSolved :: CtFlavor -> Bool + isGivenOrSolved (Given {}) = True + isGivenOrSolved _ = False + + isGiven_maybe :: CtFlavor -> Maybe GivenKind + isGiven_maybe (Given _ gk) = Just gk + isGiven_maybe _ = Nothing isDerived :: CtFlavor -> Bool isDerived (Derived {}) = True @@@ -1116,6 -1117,7 +1121,7 @@@ data CtOrigi | StandAloneDerivOrigin -- Typechecking stand-alone deriving | DefaultOrigin -- Typechecking a default decl | DoOrigin -- Arising from a do expression + | MCompOrigin -- Arising from a monad comprehension | IfOrigin -- Arising from an if statement | ProcOrigin -- Arising from a proc expression | AnnOrigin -- An annotation @@@ -1151,6 -1153,7 +1157,7 @@@ pprO DerivOrigin = ptext (sLit "the pprO StandAloneDerivOrigin = ptext (sLit "a 'deriving' declaration") pprO DefaultOrigin = ptext (sLit "a 'default' declaration") pprO DoOrigin = ptext (sLit "a do statement") + pprO MCompOrigin = ptext (sLit "a statement in a monad comprehension") pprO ProcOrigin = ptext (sLit "a proc expression") pprO (TypeEqOrigin eq) = ptext (sLit "an equality") <+> ppr eq pprO AnnOrigin = ptext (sLit "an annotation") diff --combined compiler/types/Kind.lhs index 0000000,0594f7f..32a9eac mode 000000,100644..100644 --- a/compiler/types/Kind.lhs +++ b/compiler/types/Kind.lhs @@@ -1,0 -1,235 +1,238 @@@ + % + % (c) The University of Glasgow 2006 + % + + \begin{code} + module Kind ( + -- * Main data type + Kind, typeKind, + + -- Kinds + liftedTypeKind, unliftedTypeKind, openTypeKind, + argTypeKind, ubxTupleKind, + mkArrowKind, mkArrowKinds, + + -- Kind constructors... + liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon, + argTypeKindTyCon, ubxTupleKindTyCon, ++ ecKind, + + -- Super Kinds + tySuperKind, tySuperKindTyCon, + + pprKind, pprParendKind, + + -- ** Deconstructing Kinds + kindFunResult, kindAppResult, synTyConResKind, + splitKindFunTys, splitKindFunTysN, splitKindFunTy_maybe, + + -- ** Predicates on Kinds + isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind, + isUbxTupleKind, isArgTypeKind, isKind, isTySuperKind, + isSuperKind, isCoercionKind, + isLiftedTypeKindCon, + + isSubArgTypeKind, isSubOpenTypeKind, isSubKind, defaultKind, + isSubKindCon, + + ) where + + #include "HsVersions.h" + + import TypeRep + import TysPrim + import TyCon + import Var + import PrelNames + import Outputable + \end{code} + + %************************************************************************ + %* * + Predicates over Kinds + %* * + %************************************************************************ + + \begin{code} + isTySuperKind :: SuperKind -> Bool + isTySuperKind (TyConApp kc []) = kc `hasKey` tySuperKindTyConKey + isTySuperKind _ = False + + ------------------- + -- Lastly we need a few functions on Kinds + + isLiftedTypeKindCon :: TyCon -> Bool + isLiftedTypeKindCon tc = tc `hasKey` liftedTypeKindTyConKey + \end{code} + + %************************************************************************ + %* * + The kind of a type + %* * + %************************************************************************ + + \begin{code} + typeKind :: Type -> Kind + typeKind _ty@(TyConApp tc tys) + = ASSERT2( not (tc `hasKey` eqPredPrimTyConKey) || length tys == 2, ppr _ty ) + -- Assertion checks for unsaturated application of (~) + -- See Note [The (~) TyCon] in TysPrim + kindAppResult (tyConKind tc) tys + + typeKind (PredTy pred) = predKind pred + typeKind (AppTy fun _) = kindFunResult (typeKind fun) + typeKind (ForAllTy _ ty) = typeKind ty + typeKind (TyVarTy tyvar) = tyVarKind tyvar + typeKind (FunTy _arg res) + -- Hack alert. The kind of (Int -> Int#) is liftedTypeKind (*), + -- not unliftedTypKind (#) + -- The only things that can be after a function arrow are + -- (a) types (of kind openTypeKind or its sub-kinds) + -- (b) kinds (of super-kind TY) (e.g. * -> (* -> *)) + | isTySuperKind k = k + | otherwise = ASSERT( isSubOpenTypeKind k) liftedTypeKind + where + k = typeKind res + + ------------------ + predKind :: PredType -> Kind + predKind (EqPred {}) = unliftedTypeKind -- Coercions are unlifted + predKind (ClassP {}) = liftedTypeKind -- Class and implicitPredicates are + predKind (IParam {}) = liftedTypeKind -- always represented by lifted types + \end{code} + + %************************************************************************ + %* * + Functions over Kinds + %* * + %************************************************************************ + + \begin{code} + -- | Essentially 'funResultTy' on kinds + kindFunResult :: Kind -> Kind + kindFunResult (FunTy _ res) = res + kindFunResult k = pprPanic "kindFunResult" (ppr k) + + kindAppResult :: Kind -> [arg] -> Kind + kindAppResult k [] = k + kindAppResult k (_:as) = kindAppResult (kindFunResult k) as + + -- | Essentially 'splitFunTys' on kinds + splitKindFunTys :: Kind -> ([Kind],Kind) + splitKindFunTys (FunTy a r) = case splitKindFunTys r of + (as, k) -> (a:as, k) + splitKindFunTys k = ([], k) + + splitKindFunTy_maybe :: Kind -> Maybe (Kind,Kind) + splitKindFunTy_maybe (FunTy a r) = Just (a,r) + splitKindFunTy_maybe _ = Nothing + + -- | Essentially 'splitFunTysN' on kinds + splitKindFunTysN :: Int -> Kind -> ([Kind],Kind) + splitKindFunTysN 0 k = ([], k) + splitKindFunTysN n (FunTy a r) = case splitKindFunTysN (n-1) r of + (as, k) -> (a:as, k) + splitKindFunTysN n k = pprPanic "splitKindFunTysN" (ppr n <+> ppr k) + + -- | Find the result 'Kind' of a type synonym, + -- after applying it to its 'arity' number of type variables + -- Actually this function works fine on data types too, + -- but they'd always return '*', so we never need to ask + synTyConResKind :: TyCon -> Kind + synTyConResKind tycon = kindAppResult (tyConKind tycon) (tyConTyVars tycon) + + -- | See "Type#kind_subtyping" for details of the distinction between these 'Kind's + isUbxTupleKind, isOpenTypeKind, isArgTypeKind, isUnliftedTypeKind :: Kind -> Bool + isOpenTypeKindCon, isUbxTupleKindCon, isArgTypeKindCon, + isUnliftedTypeKindCon, isSubArgTypeKindCon :: TyCon -> Bool + + isOpenTypeKindCon tc = tyConUnique tc == openTypeKindTyConKey + + isOpenTypeKind (TyConApp tc _) = isOpenTypeKindCon tc + isOpenTypeKind _ = False + + isUbxTupleKindCon tc = tyConUnique tc == ubxTupleKindTyConKey + + isUbxTupleKind (TyConApp tc _) = isUbxTupleKindCon tc + isUbxTupleKind _ = False + + isArgTypeKindCon tc = tyConUnique tc == argTypeKindTyConKey + + isArgTypeKind (TyConApp tc _) = isArgTypeKindCon tc + isArgTypeKind _ = False + + isUnliftedTypeKindCon tc = tyConUnique tc == unliftedTypeKindTyConKey + + isUnliftedTypeKind (TyConApp tc _) = isUnliftedTypeKindCon tc + isUnliftedTypeKind _ = False + + isSubOpenTypeKind :: Kind -> Bool + -- ^ True of any sub-kind of OpenTypeKind (i.e. anything except arrow) + isSubOpenTypeKind (FunTy k1 k2) = ASSERT2 ( isKind k1, text "isSubOpenTypeKind" <+> ppr k1 <+> text "::" <+> ppr (typeKind k1) ) + ASSERT2 ( isKind k2, text "isSubOpenTypeKind" <+> ppr k2 <+> text "::" <+> ppr (typeKind k2) ) + False + isSubOpenTypeKind (TyConApp kc []) = ASSERT( isKind (TyConApp kc []) ) True + isSubOpenTypeKind other = ASSERT( isKind other ) False + -- This is a conservative answer + -- It matters in the call to isSubKind in + -- checkExpectedKind. + + isSubArgTypeKindCon kc + | isUnliftedTypeKindCon kc = True + | isLiftedTypeKindCon kc = True + | isArgTypeKindCon kc = True + | otherwise = False + + isSubArgTypeKind :: Kind -> Bool + -- ^ True of any sub-kind of ArgTypeKind + isSubArgTypeKind (TyConApp kc []) = isSubArgTypeKindCon kc + isSubArgTypeKind _ = False + + -- | Is this a super-kind (i.e. a type-of-kinds)? + isSuperKind :: Type -> Bool + isSuperKind (TyConApp (skc) []) = isSuperKindTyCon skc + isSuperKind _ = False + + -- | Is this a kind (i.e. a type-of-types)? + isKind :: Kind -> Bool + isKind k = isSuperKind (typeKind k) + + isSubKind :: Kind -> Kind -> Bool + -- ^ @k1 \`isSubKind\` k2@ checks that @k1@ <: @k2@ + isSubKind (TyConApp kc1 []) (TyConApp kc2 []) = kc1 `isSubKindCon` kc2 + isSubKind (FunTy a1 r1) (FunTy a2 r2) = (a2 `isSubKind` a1) && (r1 `isSubKind` r2) + isSubKind _ _ = False + + isSubKindCon :: TyCon -> TyCon -> Bool + -- ^ @kc1 \`isSubKindCon\` kc2@ checks that @kc1@ <: @kc2@ + isSubKindCon kc1 kc2 + | isLiftedTypeKindCon kc1 && isLiftedTypeKindCon kc2 = True + | isUnliftedTypeKindCon kc1 && isUnliftedTypeKindCon kc2 = True + | isUbxTupleKindCon kc1 && isUbxTupleKindCon kc2 = True + | isOpenTypeKindCon kc2 = True + -- we already know kc1 is not a fun, its a TyCon + | isArgTypeKindCon kc2 && isSubArgTypeKindCon kc1 = True + | otherwise = False + + defaultKind :: Kind -> Kind + -- ^ Used when generalising: default kind ? and ?? to *. See "Type#kind_subtyping" for more + -- information on what that means + + -- When we generalise, we make generic type variables whose kind is + -- simple (* or *->* etc). So generic type variables (other than + -- built-in constants like 'error') always have simple kinds. This is important; + -- consider + -- f x = True + -- We want f to get type + -- f :: forall (a::*). a -> Bool + -- Not + -- f :: forall (a::??). a -> Bool + -- because that would allow a call like (f 3#) as well as (f True), + --and the calling conventions differ. This defaulting is done in TcMType.zonkTcTyVarBndr. + defaultKind k + | isSubOpenTypeKind k = liftedTypeKind + | isSubArgTypeKind k = liftedTypeKind + | otherwise = k ++ ++ecKind = liftedTypeKind `mkArrowKind` (liftedTypeKind `mkArrowKind` liftedTypeKind) + \end{code}