typecheck/TcSimplify.lhs \
typecheck/TcTyClsDecls.lhs \
typecheck/TcTyDecls.lhs \
-typecheck/Typecheck.lhs \
typecheck/Unify.lhs
/*
utils/Util.lhs
#define MAIN_SRCS_LHS \
-main/MainMonad.lhs \
main/CmdLineOpts.lhs \
main/ErrUtils.lhs \
-main/Main.lhs
-
-/*
main/MkIface.lhs \
-*/
+main/Main.lhs
#define VBASICSRCS_LHS \
prelude/PrelMods.lhs \
compile(main/CmdLineOpts,lhs,if_ghc(-fvia-C))
compile(main/ErrUtils,lhs,)
compile(main/Main,lhs,if_ghc(-fvia-C))
-compile(main/MainMonad,lhs,)
compile(main/MkIface,lhs,)
#if GhcWithNativeCodeGen == YES
compile(typecheck/TcSimplify,lhs,)
compile(typecheck/TcTyClsDecls,lhs,)
compile(typecheck/TcTyDecls,lhs,)
-compile(typecheck/Typecheck,lhs,)
compile(typecheck/Unify,lhs,)
compile(types/Class,lhs,)
import TyLoop -- for paranoia checking
import Bag
-import Class ( getClassOpString, Class(..), GenClass, ClassOp(..), GenClassOp )
+import Class ( classOpString, Class(..), GenClass, ClassOp(..), GenClassOp )
import CStrings ( identToC, cSEP )
import IdInfo
import Maybes ( maybeToBool )
MethodSelId clas op ->
case (moduleNamePair clas) of { (c_mod, c_name) ->
- case (getClassOpString op) of { op_name ->
+ case (classOpString op) of { op_name ->
if isPreludeDefined clas
then [op_name]
else [c_mod, c_name, op_name]
DefaultMethodId clas op _ ->
case (moduleNamePair clas) of { (c_mod, c_name) ->
- case (getClassOpString op) of { op_name ->
+ case (classOpString op) of { op_name ->
if isPreludeDefined clas
then [SLIT("defm"), op_name]
else [SLIT("defm"), c_mod, c_name, op_name] }}
ConstMethodId c ty o _ _ ->
case (moduleNamePair c) of { (c_mod, c_name) ->
case (getTypeString ty) of { ty_bits ->
- case (getClassOpString o) of { o_name ->
+ case (classOpString o) of { o_name ->
case (if isPreludeDefined c
then [c_name]
else [c_mod, c_name]) of { c_bits ->
\begin{code}
mkSuperDictSelId u c sc ty info = Id u ty (SuperDictSelId c sc) NoPragmaInfo info
-mkMethodSelId u c op ty info = Id u ty (MethodSelId c op) NoPragmaInfo info
+mkMethodSelId u c op ty info = Id u ty (MethodSelId c op) NoPragmaInfo info
mkDefaultMethodId u c op gen ty info = Id u ty (DefaultMethodId c op gen) NoPragmaInfo info
mkDictFunId u c ity full_ty from_here mod info
{- LATER:
get (MethodSelId c op) = case (moduleOf (origName c)) of -- ToDo; better ???
- mod -> (mod, getClassOpString op)
+ mod -> (mod, classOpString op)
get (SpecId unspec ty_maybes _)
= BIND moduleNamePair unspec _TO_ (mod, unspec_nm) ->
mkTupNameStr,
NamedThing(..), -- class
- ExportFlag(..), isExported,
+ ExportFlag(..),
+ isExported{-overloaded-}, exportFlagOn{-not-},
nameUnique,
nameOccName,
+ nameOrigName,
nameExportFlag,
nameSrcLoc,
nameImportFlag,
| ExportAbs -- export abstractly (tycons/classes only)
| NotExported
-isExported a
- = case (getExportFlag a) of
- NotExported -> False
- _ -> True
+exportFlagOn NotExported = False
+exportFlagOn _ = True
+
+isExported a = exportFlagOn (getExportFlag a)
#ifdef USE_ATTACK_PRAGMAS
{-# SPECIALIZE isExported :: Class -> Bool #-}
comparison.]
\begin{code}
-a `ltLexical` b
- = case (moduleNamePair a) of { (a_mod, a_name) ->
- case (moduleNamePair b) of { (b_mod, b_name) ->
- if isLocallyDefined a || isLocallyDefined b then
- a_name < b_name -- can't compare module names
- else
- case _CMP_STRING_ a_mod b_mod of
- LT_ -> True
- EQ_ -> a_name < b_name
- GT__ -> False
- }}
+a `ltLexical` b = origName a < origName b
#ifdef USE_ATTACK_PRAGMAS
{-# SPECIALIZE ltLexical :: Class -> Class -> Bool #-}
\end{code}
\begin{code}
-mkSplitUniqSupply :: Char -> PrimIO UniqSupply
+mkSplitUniqSupply :: Char -> IO UniqSupply
splitUniqSupply :: UniqSupply -> (UniqSupply, UniqSupply)
getUnique :: UniqSupply -> Unique
mk_unique = _ccall_ genSymZh `thenPrimIO` \ (W# u#) ->
returnPrimIO (MkInt (w2i (mask# `or#` u#)))
in
- mk_supply#
+ mk_supply# `thenPrimIO` \ s ->
+ return s
splitUniqSupply (MkSplitUniqSupply _ s1 s2) = (s1, s2)
\end{code}
recUpdErrorIdKey,
irrefutPatErrorIdKey,
nonExhaustiveGuardsErrorIdKey,
+ noDefaultMethodErrorIdKey,
+ nonExplicitMethodErrorIdKey,
primIoTyConKey,
ratioDataConKey,
ratioTyConKey,
recUpdErrorIdKey = mkPreludeMiscIdUnique 30
irrefutPatErrorIdKey = mkPreludeMiscIdUnique 31
nonExhaustiveGuardsErrorIdKey = mkPreludeMiscIdUnique 32
+noDefaultMethodErrorIdKey = mkPreludeMiscIdUnique 33
+nonExplicitMethodErrorIdKey = mkPreludeMiscIdUnique 34
#ifdef GRAN
-parLocalIdKey = mkPreludeMiscIdUnique 33
-parGlobalIdKey = mkPreludeMiscIdUnique 34
-noFollowIdKey = mkPreludeMiscIdUnique 35
-copyableIdKey = mkPreludeMiscIdUnique 36
+parLocalIdKey = mkPreludeMiscIdUnique 35
+parGlobalIdKey = mkPreludeMiscIdUnique 36
+noFollowIdKey = mkPreludeMiscIdUnique 37
+copyableIdKey = mkPreludeMiscIdUnique 38
#endif
\end{code}
Nothing -> addErrL (mkTyAppMsg SLIT("Illegal") ty arg_ty e) `seqL` returnL Nothing
Just (tyvar,body) ->
- if (tyVarKind tyvar `isSubKindOf` typeKind arg_ty) then
+ let
+ tyvar_kind = tyVarKind tyvar
+ argty_kind = typeKind arg_ty
+ in
+ if (tyvar_kind `isSubKindOf` argty_kind
+ || argty_kind `isSubKindOf` tyvar_kind) then
returnL(Just(instantiateTy [(tyvar,arg_ty)] body))
else
- pprTrace "lintCoreArg:kinds:" (ppCat [ppr PprDebug (tyVarKind tyvar), ppr PprDebug (typeKind arg_ty)]) $
+ pprTrace "lintCoreArg:kinds:" (ppCat [ppr PprDebug tyvar_kind, ppr PprDebug argty_kind]) $
addErrL (mkTyAppMsg SLIT("Kinds not right in") ty arg_ty e) `seqL` returnL Nothing
lintCoreArg _ e ty (UsageArg u)
size_alg_alt (con,args,rhs) = size_up rhs
-- Don't charge for args, so that wrappers look cheap
- (tycon, _, _) = getAppDataTyCon scrut_ty
+ (tycon, _, _) = _trace "getAppDataTyCon.CoreUnfold" $ getAppDataTyCon scrut_ty
size_up_alts _ (PrimAlts alts deflt)
= foldr (addSize . size_prim_alt) (size_up_deflt deflt) alts
substCoreExpr, substCoreBindings
, mkCoreIfThenElse
- , escErrorMsg -- ToDo: kill
, argToExpr
, unTagBinders, unTagBindersAlts
, manifestlyWHNF, manifestlyBottom
\end{code}
\begin{code}
-applyTypeToArgs = panic "applyTypeToArgs"
+applyTypeToArgs op_ty args
+ = foldl applyTy op_ty [ ty | TyArg ty <- args ]
\end{code}
%************************************************************************
NoDefault )
\end{code}
-\begin{code}
-{- OLD:
-mkErrorApp :: Id -> Type -> Id -> String -> CoreExpr
-
-mkErrorApp err_fun ty str_var error_msg
- = Let (NonRec str_var (Lit (NoRepStr (_PK_ error_msg)))) (
- mkApp (Var err_fun) [] [ty] [VarArg str_var])
--}
-
-escErrorMsg = panic "CoreUtils.escErrorMsg: To Die"
-{- OLD:
-escErrorMsg [] = []
-escErrorMsg ('%':xs) = '%' : '%' : escErrorMsg xs
-escErrorMsg (x:xs) = x : escErrorMsg xs
--}
-\end{code}
-
For making @Apps@ and @Lets@, we must take appropriate evasive
action if the thing being bound has unboxed type. @mkCoApp@ requires
a name supply to do its work.
import CoreSyn
import CostCentre ( showCostCentre )
-import Id ( idType, getIdInfo, getIdStrictness,
+import Id ( idType, getIdInfo, getIdStrictness, isTupleCon,
nullIdEnv, DataCon(..), GenId{-instances-}
)
import IdInfo ( ppIdInfo, StrictnessInfo(..) )
= ppAboves [ ppAboves (map ppr_alt alts), ppr_default pe deflt ]
where
ppr_alt (con, params, expr)
- = ppHang (ppCat [ppr_con con (pCon pe con),
- ppInterleave ppSP (map (pMinBndr pe) params),
- ppStr "->"])
+ = ppHang (if isTupleCon con then
+ ppCat [ppParens (ppInterleave ppComma (map (pMinBndr pe) params)),
+ ppStr "->"]
+ else
+ ppCat [ppr_con con (pCon pe con),
+ ppInterleave ppSP (map (pMinBndr pe) params),
+ ppStr "->"]
+ )
4 (ppr_expr pe expr)
where
ppr_con con pp_con
tyVarsOfType, tyVarsOfTypes
)
import TyVar ( tyVarSetToList, GenTyVar{-instance Eq-} )
-import Util ( isIn, panic )
+import Util ( isIn, panic, pprTrace{-ToDo:rm-} )
+import PprCore--ToDo:rm
+import PprType--ToDo:rm
+import Usage--ToDo:rm
+import Unique--ToDo:rm
isDictTy = panic "DsBinds.isDictTy"
\end{code}
-- we can just use the rhs directly
else
-}
+ pprTrace "dsMonoBinds:PatMonoBind:" (ppr PprDebug body_expr) $
+
mkSelectorBinds tyvars pat
[(binder, binder_subst binder) | binder <- pat_binders]
body_expr
let rbinds' = panic "dsExpr:RecordUpdOut:rbinds'" in
let
record_ty = coreExprType record_expr'
- (tycon, inst_tys, cons) = getAppDataTyCon record_ty
+ (tycon, inst_tys, cons) = _trace "getAppDataTyCon.DsExpr" $ getAppDataTyCon record_ty
cons_to_upd = filter has_all_fields cons
-- initial_args are passed to every constructor
import CoreUtils ( coreExprType, mkCoreIfThenElse )
import PprStyle ( PprStyle(..) )
-import PprType ( pprType{-ToDo:rm-} )
import PrelInfo ( stringTy, iRREFUT_PAT_ERROR_ID )
import Pretty ( ppShow )
import Id ( idType, dataConArgTys, mkTupleCon,
+ pprId{-ToDo:rm-},
DataCon(..), DictVar(..), Id(..), GenId )
import Literal ( Literal(..) )
import TyCon ( mkTupleTyCon )
)
import UniqSet ( mkUniqSet, minusUniqSet, uniqSetToList, UniqSet(..) )
import Util ( panic, assertPanic, pprTrace{-ToDo:rm-} )
+import PprCore{-ToDo:rm-}
+import PprType--ToDo:rm
+import Pretty--ToDo:rm
+import TyVar--ToDo:rm
+import Unique--ToDo:rm
+import Usage--ToDo:rm
splitDictType = panic "DsUtils.splitDictType"
\end{code}
\begin{code}
mkTupleBind tyvars dicts local_global_prs tuple_expr
- = newSysLocalDs tuple_var_ty `thenDs` \ tuple_var ->
+ = pprTrace "mkTupleBind:\n" (ppAboves [ppCat (map (pprId PprShowAll) locals), ppCat (map (pprId PprShowAll) globals), {-ppr PprDebug local_tuple, pprType PprDebug res_ty,-} ppr PprDebug tuple_expr]) $
+
+ newSysLocalDs tuple_var_ty `thenDs` \ tuple_var ->
zipWithDs (mk_selector (Var tuple_var))
local_global_prs
pats = map mk_pat tagged_arg_tys
-- Boring stuff to find the arg-tys of the constructor
- (_, inst_tys, _) = getAppDataTyCon pat_ty
+ (_, inst_tys, _) = _trace "getAppDataTyCon.Match" $ getAppDataTyCon pat_ty
con_arg_tys' = dataConArgTys con_id inst_tys
tagged_arg_tys = con_arg_tys' `zip` allFieldLabelTags
-- friends:
import HsLoop ( nullMonoBinds, MonoBinds, Sig )
import HsPragmas ( DataPragmas, ClassPragmas,
- InstancePragmas, ClassOpPragmas )
+ InstancePragmas, ClassOpPragmas
+ )
import HsTypes
-- others:
SrcLoc
data BangType name
- = Banged (MonoType name)
- | Unbanged (MonoType name)
+ = Banged (PolyType name) -- PolyType: to allow Haskell extensions
+ | Unbanged (PolyType name) -- (MonoType only needed for straight Haskell)
\end{code}
\begin{code}
where
pp_field (n, ty) = ppCat [ppr sty n, ppPStr SLIT("::"), ppr_bang sty ty]
-ppr_bang sty (Banged ty) = ppBeside (ppChar '!') (pprParendMonoType sty ty)
-ppr_bang sty (Unbanged ty) = pprParendMonoType sty ty
+ppr_bang sty (Banged ty) = ppBeside (ppChar '!') (pprParendPolyType sty ty)
+ppr_bang sty (Unbanged ty) = pprParendPolyType sty ty
\end{code}
%************************************************************************
Context(..), ClassAssertion(..)
#ifdef COMPILING_GHC
+ , pprParendPolyType
, pprParendMonoType, pprContext
, extractMonoTyNames, extractCtxtTyNames
, cmpPolyType, cmpMonoType, cmpContext
instance (Outputable name) => Outputable (PolyType name) where
ppr sty (HsPreForAllTy ctxt ty)
= print_it sty ppNil ctxt ty
+ ppr sty (HsForAllTy [] ctxt ty)
+ = print_it sty ppNil ctxt ty
ppr sty (HsForAllTy tvs ctxt ty)
= print_it sty
(ppBesides [ppStr "_forall_ ", interppSP sty tvs, ppStr " => "])
= ppCat [ifnotPprForUser sty pp_forall, -- print foralls unless PprForUser
pprContext sty ctxt, ppr sty ty]
+pprParendPolyType :: Outputable name => PprStyle -> PolyType name -> Pretty
+pprParendPolyType sty ty = ppr sty ty -- ToDo: more later
+
instance (Outputable name) => Outputable (MonoType name) where
ppr = pprMonoType
opt_ProduceS = lookup_str "-S="
opt_ProduceHi = lookup_str "-hifile="
opt_ProduceHu = lookup_str "-hufile="
+opt_MyHi = lookup_str "-myhifile=" -- the ones produced last time
+opt_MyHu = lookup_str "-myhufile=" -- for this module
opt_EnsureSplittableC = lookup_str "-fglobalise-toplev-names="
opt_UnfoldingUseThreshold = lookup_int "-funfolding-use-threshold"
opt_UnfoldingCreationThreshold = lookup_int "-funfolding-creation-threshold"
opt_NoImplicitPrelude = lookup SLIT("-fno-implicit-prelude")
opt_IgnoreIfacePragmas = lookup SLIT("-fignore-interface-pragmas")
+opt_HuSuffix = case (lookup_str "-husuffix=") of { Nothing -> ".hu" ; Just x -> x }
opt_HiSuffix = case (lookup_str "-hisuffix=") of { Nothing -> ".hi" ; Just x -> x }
opt_SysHiSuffix = case (lookup_str "-syshisuffix=") of { Nothing -> ".hi" ; Just x -> x }
addErrLoc,
addShortErrLocLine,
dontAddErrLoc,
- pprBagOfErrors
+ pprBagOfErrors,
+ ghcExit
) where
import Ubiq{-uitous-}
= let pretties = map ( \ e -> e sty ) (bagToList bag_of_errors) in
ppAboves (map (\ p -> ppAbove ppSP p) pretties)
\end{code}
+
+\begin{code}
+ghcExit :: Int -> IO ()
+
+ghcExit val
+ = if val /= 0
+ then error "Compilation had errors\n"
+ else return ()
+\end{code}
import Ubiq{-uitous-}
-import PreludeGlaST ( thenPrimIO, _FILE{-instances-} ) -- ToDo: STOP using this...
+import PreludeGlaST ( thenPrimIO, fopen, fclose, _FILE{-instance CCallable-} )
-import MainMonad
import HsSyn
import ReadPrefix ( rdModule )
import Rename ( renameModule )
-import Typecheck ( typecheckModule, InstInfo )
+import MkIface -- several functions
+import TcModule ( typecheckModule )
import Desugar ( deSugar, DsMatchContext, pprDsWarnings )
import SimplCore ( core2core )
import CoreToStg ( topCoreBindsToStg )
import AbsCUtils ( flattenAbsC )
import Bag ( emptyBag, isEmptyBag )
import CmdLineOpts
-import ErrUtils ( pprBagOfErrors )
+import ErrUtils ( pprBagOfErrors, ghcExit )
import Maybes ( maybeToBool, MaybeErr(..) )
import PrelInfo ( builtinNameInfo )
import RdrHsSyn ( getRawExportees )
import Specialise ( SpecialiseData(..) )
import StgSyn ( pprPlainStgBinding, GenStgBinding )
+import TcInstUtil ( InstInfo )
+import UniqSupply ( mkSplitUniqSupply )
import PprAbsC ( dumpRealC, writeRealC )
import PprCore ( pprCoreBinding )
import RnHsSyn ( RnName ) -- instances
import TyVar ( GenTyVar ) -- instances
import Unique ( Unique ) -- instances
-
-{-
---import MkIface ( mkInterface )
--}
-
\end{code}
\begin{code}
main
- = readMn stdin `thenMn` \ input_pgm ->
+ = hGetContents stdin >>= \ input_pgm ->
let
cmd_line_info = classifyOpts
in
\end{code}
\begin{code}
-doIt :: ([CoreToDo], [StgToDo]) -> String -> MainIO ()
+doIt :: ([CoreToDo], [StgToDo]) -> String -> IO ()
doIt (core_cmds, stg_cmds) input_pgm
- = doDump opt_Verbose "Glasgow Haskell Compiler, version 1.3-xx" ""
- `thenMn_`
+ = doDump opt_Verbose "Glasgow Haskell Compiler, version 1.01, for Haskell 1.3" "" >>
-- ******* READER
- show_pass "Reader" `thenMn_`
- rdModule `thenMn`
-
- \ (mod_name, rdr_module) ->
+ show_pass "Reader" >>
+ rdModule >>= \ (mod_name, rdr_module) ->
- let
- -- reader things used much later
- ds_mod_name = mod_name
- if_mod_name = mod_name
- co_mod_name = mod_name
- st_mod_name = mod_name
- cc_mod_name = mod_name
- in
doDump opt_D_dump_rdr "Reader:"
- (pp_show (ppr pprStyle rdr_module)) `thenMn_`
+ (pp_show (ppr pprStyle rdr_module)) >>
doDump opt_D_source_stats "\nSource Statistics:"
- (pp_show (ppSourceStats rdr_module)) `thenMn_`
+ (pp_show (ppSourceStats rdr_module)) >>
-- UniqueSupplies for later use (these are the only lower case uniques)
- getSplitUniqSupplyMn 'r' `thenMn` \ rn_uniqs -> -- renamer
- getSplitUniqSupplyMn 't' `thenMn` \ tc_uniqs -> -- typechecker
- getSplitUniqSupplyMn 'd' `thenMn` \ ds_uniqs -> -- desugarer
- getSplitUniqSupplyMn 's' `thenMn` \ sm_uniqs -> -- core-to-core simplifier
- getSplitUniqSupplyMn 'c' `thenMn` \ c2s_uniqs -> -- core-to-stg
- getSplitUniqSupplyMn 'g' `thenMn` \ st_uniqs -> -- stg-to-stg passes
- getSplitUniqSupplyMn 'f' `thenMn` \ fl_uniqs -> -- absC flattener
- getSplitUniqSupplyMn 'n' `thenMn` \ ncg_uniqs -> -- native-code generator
+ mkSplitUniqSupply 'r' >>= \ rn_uniqs -> -- renamer
+ mkSplitUniqSupply 't' >>= \ tc_uniqs -> -- typechecker
+ mkSplitUniqSupply 'd' >>= \ ds_uniqs -> -- desugarer
+ mkSplitUniqSupply 's' >>= \ sm_uniqs -> -- core-to-core simplifier
+ mkSplitUniqSupply 'c' >>= \ c2s_uniqs -> -- core-to-stg
+ mkSplitUniqSupply 'g' >>= \ st_uniqs -> -- stg-to-stg passes
+ mkSplitUniqSupply 'f' >>= \ fl_uniqs -> -- absC flattener
+ mkSplitUniqSupply 'n' >>= \ ncg_uniqs -> -- native-code generator
-- ******* RENAMER
- show_pass "Renamer" `thenMn_`
+ show_pass "Renamer" >>
case builtinNameInfo
of { (wiredin_fm, key_fm, idinfo_fm) ->
- renameModule wiredin_fm key_fm rn_uniqs rdr_module `thenMn`
+ renameModule wiredin_fm key_fm rn_uniqs rdr_module >>=
\ (rn_mod, rn_env, import_names,
version_info, instance_modules,
rn_errs_bag, rn_warns_bag) ->
if (not (isEmptyBag rn_errs_bag)) then
- writeMn stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle rn_errs_bag))
- `thenMn_` writeMn stderr "\n" `thenMn_`
- writeMn stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle rn_warns_bag))
- `thenMn_` writeMn stderr "\n" `thenMn_`
- exitMn 1
+ hPutStr stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle rn_errs_bag))
+ >> hPutStr stderr "\n" >>
+ hPutStr stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle rn_warns_bag))
+ >> hPutStr stderr "\n" >>
+ ghcExit 1
else -- No renaming errors ...
(if (isEmptyBag rn_warns_bag) then
- returnMn ()
+ return ()
else
- writeMn stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle rn_warns_bag))
- `thenMn_` writeMn stderr "\n"
- ) `thenMn_`
+ hPutStr stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle rn_warns_bag))
+ >> hPutStr stderr "\n"
+ ) >>
doDump opt_D_dump_rn "Renamer:"
- (pp_show (ppr pprStyle rn_mod)) `thenMn_`
-
--- exitMn 0
-{- LATER ... -}
+ (pp_show (ppr pprStyle rn_mod)) >>
+
+ -- Safely past renaming: we can start the interface file:
+ -- (the iface file is produced incrementally, as we have
+ -- the information that we need...; we use "iface<blah>")
+ -- "endIface" finishes the job.
+ startIface mod_name >>= \ if_handle ->
+ ifaceVersions if_handle version_info >>
+ ifaceExportList if_handle rn_mod >>
+ ifaceFixities if_handle rn_mod >>
+ ifaceInstanceModules if_handle instance_modules >>
-- ******* TYPECHECKER
- show_pass "TypeCheck" `thenMn_`
+ show_pass "TypeCheck" >>
case (case (typecheckModule tc_uniqs {-idinfo_fm-} rn_env rn_mod) of
Succeeded (stuff, warns)
-> (emptyBag, warns, stuff)
of { (tc_errs_bag, tc_warns_bag, tc_results) ->
if (not (isEmptyBag tc_errs_bag)) then
- writeMn stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle tc_errs_bag))
- `thenMn_` writeMn stderr "\n" `thenMn_`
- writeMn stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle tc_warns_bag))
- `thenMn_` writeMn stderr "\n" `thenMn_`
- exitMn 1
+ hPutStr stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle tc_errs_bag))
+ >> hPutStr stderr "\n" >>
+ hPutStr stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle tc_warns_bag))
+ >> hPutStr stderr "\n" >>
+ ghcExit 1
else ( -- No typechecking errors ...
(if (isEmptyBag tc_warns_bag) then
- returnMn ()
+ return ()
else
- writeMn stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle tc_warns_bag))
- `thenMn_` writeMn stderr "\n"
- ) `thenMn_`
+ hPutStr stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle tc_warns_bag))
+ >> hPutStr stderr "\n"
+ ) >>
case tc_results
of { (typechecked_quint@(recsel_binds, class_binds, inst_binds, val_binds, const_binds),
- interface_stuff@(_,_,_,_,_), -- @-pat just for strictness...
+ interface_stuff,
(local_tycons,local_classes), pragma_tycon_specs, ddump_deriv) ->
doDump opt_D_dump_tc "Typechecked:"
ppr pprStyle class_binds,
ppr pprStyle inst_binds,
ppAboves (map (\ (i,e) -> ppr pprStyle (VarMonoBind i e)) const_binds),
- ppr pprStyle val_binds])) `thenMn_`
+ ppr pprStyle val_binds])) >>
doDump opt_D_dump_deriv "Derived instances:"
- (pp_show (ddump_deriv pprStyle)) `thenMn_`
+ (pp_show (ddump_deriv pprStyle)) >>
+
+ -- OK, now do the interface stuff that relies on typechecker output:
+ ifaceDecls if_handle interface_stuff >>
+ ifaceInstances if_handle interface_stuff >>
-- ******* DESUGARER
- show_pass "DeSugar" `thenMn_`
+ show_pass "DeSugar" >>
let
(desugared,ds_warnings)
- = deSugar ds_uniqs ds_mod_name typechecked_quint
+ = deSugar ds_uniqs mod_name typechecked_quint
in
(if isEmptyBag ds_warnings then
- returnMn ()
+ return ()
else
- writeMn stderr (ppShow pprCols (pprDsWarnings pprErrorsStyle ds_warnings))
- `thenMn_` writeMn stderr "\n"
- ) `thenMn_`
+ hPutStr stderr (ppShow pprCols (pprDsWarnings pprErrorsStyle ds_warnings))
+ >> hPutStr stderr "\n"
+ ) >>
doDump opt_D_dump_ds "Desugared:" (pp_show (ppAboves
(map (pprCoreBinding pprStyle) desugared)))
- `thenMn_`
+ >>
-- ******* CORE-TO-CORE SIMPLIFICATION (NB: I/O op)
- core2core core_cmds co_mod_name pprStyle
+ core2core core_cmds mod_name pprStyle
sm_uniqs local_tycons pragma_tycon_specs desugared
- `thenMn`
+ >>=
\ (simplified, inlinings_env,
SpecData _ _ _ gen_tycons all_tycon_specs _ _ _) ->
doDump opt_D_dump_simpl "Simplified:" (pp_show (ppAboves
(map (pprCoreBinding pprStyle) simplified)))
- `thenMn_`
+ >>
-- ******* STG-TO-STG SIMPLIFICATION
- show_pass "Core2Stg" `thenMn_`
+ show_pass "Core2Stg" >>
let
stg_binds = topCoreBindsToStg c2s_uniqs simplified
in
- show_pass "Stg2Stg" `thenMn_`
- stg2stg stg_cmds st_mod_name pprStyle st_uniqs stg_binds
- `thenMn`
+ show_pass "Stg2Stg" >>
+ stg2stg stg_cmds mod_name pprStyle st_uniqs stg_binds
+ >>=
\ (stg_binds2, cost_centre_info) ->
doDump opt_D_dump_stg "STG syntax:"
(pp_show (ppAboves (map (pprPlainStgBinding pprStyle) stg_binds2)))
- `thenMn_`
-
-{- LATER ...
- -- ******* INTERFACE GENERATION (needs STG output)
-{- let
- mod_name = "_TestName_"
- export_list_fns = (\ x -> False, \ x -> False)
- inlinings_env = nullIdEnv
- fixities = []
- if_global_ids = []
- if_ce = nullCE
- if_tce = nullTCE
- if_inst_info = emptyBag
- in
--}
+ >>
- show_pass "Interface" `thenMn_`
- let
- mod_interface
- = mkInterface if_mod_name export_list_fns
- inlinings_env all_tycon_specs
- interface_stuff
- stg_binds2
- in
- doOutput opt_ProduceHi ( \ file ->
- ppAppendFile file 1000{-pprCols-} mod_interface )
- `thenMn_`
--}
+ -- We are definitely done w/ interface-file stuff at this point:
+ -- (See comments near call to "startIface".)
+ endIface if_handle >>
-- ******* "ABSTRACT", THEN "FLAT", THEN *REAL* C!
- show_pass "CodeGen" `thenMn_`
+ show_pass "CodeGen" >>
let
- abstractC = codeGen cc_mod_name -- module name for CC labelling
+ abstractC = codeGen mod_name -- module name for CC labelling
cost_centre_info
import_names -- import names for CC registering
gen_tycons -- type constructors generated locally
flat_abstractC = flattenAbsC fl_uniqs abstractC
in
doDump opt_D_dump_absC "Abstract C:"
- (dumpRealC abstractC) `thenMn_`
+ (dumpRealC abstractC) >>
doDump opt_D_dump_flatC "Flat Abstract C:"
- (dumpRealC flat_abstractC) `thenMn_`
+ (dumpRealC flat_abstractC) >>
-- You can have C (c_output) or assembly-language (ncg_output),
-- but not both. [Allowing for both gives a space leak on
#endif
in
- doDump opt_D_dump_asm "" ncg_output_d `thenMn_`
- doOutput opt_ProduceS ncg_output_w `thenMn_`
-
- doDump opt_D_dump_realC "" c_output_d `thenMn_`
- doOutput opt_ProduceC c_output_w `thenMn_`
-
- exitMn 0
- } ) }
+ doDump opt_D_dump_asm "" ncg_output_d >>
+ doOutput opt_ProduceS ncg_output_w >>
-{- LATER -}
+ doDump opt_D_dump_realC "" c_output_d >>
+ doOutput opt_ProduceC c_output_w >>
- }
+ ghcExit 0
+ } ) } }
where
-------------------------------------------------------------
-- ****** printing styles and column width:
show_pass
= if opt_D_show_passes
- then \ what -> writeMn stderr ("*** "++what++":\n")
- else \ what -> returnMn ()
+ then \ what -> hPutStr stderr ("*** "++what++":\n")
+ else \ what -> return ()
doOutput switch io_action
= case switch of
- Nothing -> returnMn ()
+ Nothing -> return ()
Just fname ->
fopen fname "a+" `thenPrimIO` \ file ->
if (file == ``NULL'') then
error ("doOutput: failed to open:"++fname)
else
- io_action file `thenMn` \ () ->
+ io_action file >>= \ () ->
fclose file `thenPrimIO` \ status ->
if status == 0
- then returnMn ()
+ then return ()
else error ("doOutput: closed failed: "{-++show status++" "-}++fname)
doDump switch hdr string
= if switch
- then writeMn stderr hdr `thenMn_`
- writeMn stderr ('\n': string) `thenMn_`
- writeMn stderr "\n"
- else returnMn ()
+ then hPutStr stderr hdr >>
+ hPutStr stderr ('\n': string) >>
+ hPutStr stderr "\n"
+ else return ()
ppSourceStats (HsModule name version exports imports fixities typedecls typesigs
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
-%
-\section[MainMonad]{I/O monad used in @Main@ module of the compiler}
-
-\begin{code}
-#include "HsVersions.h"
-
-module MainMonad (
- MainIO(..),
- returnMn,
- thenMn,
- thenMn_,
--- foldlMn, INLINEd at its two (important) uses...
- readMn,
- writeMn,
- getArgsMn,
- getSplitUniqSupplyMn,
- exitMn,
- fopen, fclose, fwrite, _FILE(..),
-
- UniqSupply
- IF_ATTACK_PRAGMAS(COMMA getArgsPrimIO)
- IF_ATTACK_PRAGMAS(COMMA appendFilePrimIO)
- IF_ATTACK_PRAGMAS(COMMA appendChanPrimIO)
- IF_ATTACK_PRAGMAS(COMMA readChanPrimIO)
- IF_ATTACK_PRAGMAS(COMMA mkSplitUniqSupply) -- profiling only, really
- ) where
-
-#if __HASKELL1__ >= 3
-import LibSystem
-#endif
-
-import PreludeGlaST
-
-import Ubiq{-uitous-}
-
-import UniqSupply ( mkSplitUniqSupply, UniqSupply )
-
-infixr 9 `thenMn` -- right-associative, please
-infixr 9 `thenMn_`
-\end{code}
-
-A value of type @MainIO a@ represents an I/O-performing computation
-returning a value of type @a@. It is a function from the whole list
-of responses-to-the-rest-of-the-program, to a triple consisting of:
-\begin{enumerate}
-\item
-the value of type @a@;
-\item
-a function which prefixes the requests for the computation to
-the front of a supplied list of requests; using a function here
-avoids an expensive append operation in @thenMn@;
-\item
-the depleted list of responses.
-\end{enumerate}
-
-\begin{code}
-returnMn :: a -> MainIO a
-thenMn :: MainIO a -> (a -> MainIO b) -> MainIO b
-thenMn_ :: MainIO a -> MainIO b -> MainIO b
-
-#if __HASKELL1__ < 3
-readMn :: String{-channel-} -> MainIO String
-writeMn :: String{-channel-} -> String -> MainIO ()
-#else
-readMn :: Handle -> MainIO String
-writeMn :: Handle -> String -> MainIO ()
-#endif
-
-getArgsMn :: MainIO [String]
-getSplitUniqSupplyMn
- :: Char -> MainIO UniqSupply
-exitMn :: Int -> MainIO ()
-
-{-# INLINE returnMn #-}
-{-# INLINE thenMn #-}
-{-# INLINE thenMn_ #-}
-
-exitMn val
- = if val /= 0
- then error "Compilation had errors\n"
- else returnMn ()
-
-#if __HASKELL1__ < 3
-
-type MainIO a = PrimIO a
-
-returnMn = returnPrimIO
-thenMn = thenPrimIO
-thenMn_ = seqPrimIO
-
-readMn chan = readChanPrimIO chan
-writeMn chan str = appendChanPrimIO chan str
-getArgsMn = getArgsPrimIO
-
-getSplitUniqSupplyMn char = mkSplitUniqSupply char
-
-#else {- 1.3 -}
-
-type MainIO a = IO a
-
-returnMn = return
-thenMn = (>>=)
-thenMn_ = (>>)
-
-readMn chan = hGetContents chan
-writeMn chan str = hPutStr chan str
-getArgsMn = getArgs
-
-getSplitUniqSupplyMn char
- = mkSplitUniqSupply char `thenPrimIO` \ us ->
- return us
-
-#endif {- 1.3 -}
-\end{code}
\begin{code}
#include "HsVersions.h"
-module MkIface ( mkInterface ) where
-
-import PrelInfo ( mkLiftTy, pRELUDE_BUILTIN )
-import HsSyn ( FixityDecl(..), RenamedFixityDecl(..), MonoBinds,
- RenamedMonoBinds(..), Name, RenamedPat(..), Sig
+module MkIface {-( mkInterface )-} where
+
+import Ubiq{-uitous-}
+
+import Bag ( emptyBag, snocBag, bagToList )
+import Class ( GenClass{-instance NamedThing-} )
+import CmdLineOpts ( opt_ProduceHi )
+import HsSyn
+import Id ( GenId{-instance NamedThing/Outputable-} )
+import Name ( nameOrigName, exportFlagOn, nameExportFlag, ExportFlag(..),
+ ltLexical, isExported,
+ RdrName{-instance Outputable-}
)
-import Type
-import Bag
-import FiniteMap
-import Id
-import IdInfo -- plenty from here
-import Maybes ( catMaybes, Maybe(..) )
-import Outputable
-import Pretty
-import StgSyn
-import TcInstDcls ( InstInfo(..) )
-import Util
+import PprStyle ( PprStyle(..) )
+import PprType ( TyCon{-instance Outputable-}, GenClass{-ditto-} )
+import Pretty -- quite a bit
+import RnHsSyn ( RenamedHsModule(..), RnName{-instance NamedThing-} )
+import RnIfaces ( VersionInfo(..) )
+import TcModule ( TcIfaceInfo(..) )
+import TcInstUtil ( InstInfo )
+import TyCon ( TyCon{-instance NamedThing-} )
+import Util ( sortLt, assertPanic )
+
+ppSemid x = ppBeside (ppr PprInterface x) ppSemi -- micro util
+\end{code}
+
+We have a function @startIface@ to open the output file and put
+(something like) ``interface Foo N'' in it. It gives back a handle
+for subsequent additions to the interface file.
+
+We then have one-function-per-block-of-interface-stuff, e.g.,
+@ifaceExportList@ produces the @__exports__@ section; it appends
+to the handle provided by @startIface@.
+
+\begin{code}
+startIface :: Module
+ -> IO (Maybe Handle) -- Nothing <=> don't do an interface
+endIface :: Maybe Handle -> IO ()
+ifaceVersions
+ :: Maybe Handle
+ -> VersionInfo
+ -> IO ()
+ifaceExportList
+ :: Maybe Handle
+ -> RenamedHsModule
+ -> IO ()
+ifaceFixities
+ :: Maybe Handle
+ -> RenamedHsModule
+ -> IO ()
+ifaceInstanceModules
+ :: Maybe Handle
+ -> [Module]
+ -> IO ()
+ifaceDecls :: Maybe Handle
+ -> TcIfaceInfo -- info produced by typechecker, for interfaces
+ -> IO ()
+ifaceInstances
+ :: Maybe Handle
+ -> TcIfaceInfo -- as above
+ -> IO ()
+--ifacePragmas
+\end{code}
+
+\begin{code}
+startIface mod
+ = case opt_ProduceHi of
+ Nothing -> return Nothing -- not producing any .hi file
+ Just fn ->
+ openFile fn WriteMode >>= \ if_hdl ->
+ hPutStr if_hdl ("interface "++ _UNPK_ mod ++" 1\n") >>
+ return (Just if_hdl)
+
+endIface Nothing = return ()
+endIface (Just if_hdl) = hPutStr if_hdl "\n" >> hClose if_hdl
\end{code}
+\begin{code}
+ifaceVersions Nothing{-no iface handle-} _ = return ()
+
+ifaceVersions (Just if_hdl) version_info
+ = hPutStr if_hdl "__versions__\nFoo(1)" -- a stub, obviously
+\end{code}
+
+\begin{code}
+ifaceInstanceModules Nothing{-no iface handle-} _ = return ()
+ifaceInstanceModules (Just _) [] = return ()
+
+ifaceInstanceModules (Just if_hdl) imods
+ = hPutStr if_hdl "\n__instance_modules__\n" >>
+ hPutStr if_hdl (ppShow 100 (ppCat (map ppPStr imods)))
+\end{code}
+
+Export list: grab the Names of things that are marked Exported, sort
+(so the interface file doesn't ``wobble'' from one compilation to the
+next...), and print. Note that the ``module'' now contains all the
+imported things that we are dealing with, thus including any entities
+that we are re-exporting from somewhere else.
+\begin{code}
+ifaceExportList Nothing{-no iface handle-} _ = return ()
+
+ifaceExportList (Just if_hdl)
+ (HsModule _ _ _ _ _ typedecls _ classdecls _ _ _ binds sigs _)
+ = let
+ name_flag_pairs :: Bag (Name, ExportFlag)
+ name_flag_pairs
+ = foldr from_ty
+ (foldr from_cls
+ (foldr from_sig
+ (from_binds binds emptyBag{-init accum-})
+ sigs)
+ classdecls)
+ typedecls
+
+ sorted_pairs = sortLt lexical_lt (bagToList name_flag_pairs)
+
+ in
+ hPutStr if_hdl "\n__exports__\n" >>
+ hPutStr if_hdl (ppShow 100 (ppAboves (map pp_pair sorted_pairs)))
+ where
+ from_ty (TyData _ n _ _ _ _ _) acc = maybe_add acc n
+ from_ty (TyNew _ n _ _ _ _ _) acc = maybe_add acc n
+ from_ty (TySynonym n _ _ _) acc = maybe_add acc n
+
+ from_cls (ClassDecl _ n _ _ _ _ _) acc = maybe_add acc n
+
+ from_sig (Sig n _ _ _) acc = maybe_add acc n
+
+ from_binds bs acc = maybe_add_list acc (collectTopLevelBinders bs)
+
+ --------------
+ maybe_add :: Bag (Name, ExportFlag) -> RnName -> Bag (Name, ExportFlag)
+
+ maybe_add acc rn
+ | exportFlagOn ef = acc `snocBag` (n, ef)
+ | otherwise = acc
+ where
+ n = getName rn
+ ef = nameExportFlag n
+
+ --------------
+ maybe_add_list acc [] = acc
+ maybe_add_list acc (n:ns) = maybe_add (maybe_add_list acc ns) n
+
+ --------------
+ lexical_lt (n1,_) (n2,_) = nameOrigName n1 < nameOrigName n2
+
+ --------------
+ pp_pair (n, ef)
+ = ppBeside (ppr PprInterface (nameOrigName n)) (pp_export ef)
+ where
+ pp_export ExportAll = ppPStr SLIT("(..)")
+ pp_export ExportAbs = ppNil
+\end{code}
+
+\begin{code}
+ifaceFixities Nothing{-no iface handle-} _ = return ()
+
+ifaceFixities (Just if_hdl) (HsModule _ _ _ _ fixities _ _ _ _ _ _ _ _ _)
+ = if null fixities then
+ return ()
+ else
+ hPutStr if_hdl "\n__fixities__\n" >>
+ hPutStr if_hdl (ppShow 100 (ppAboves (map ppSemid fixities)))
+\end{code}
+
+\begin{code}
+ifaceDecls Nothing{-no iface handle-} _ = return ()
+
+ifaceDecls (Just if_hdl) (vals, tycons, classes, _)
+ = ASSERT(not (null vals && null tycons && null classes))
+ let
+ exported_classes = filter isExported classes
+ exported_tycons = filter isExported tycons
+ exported_vals = filter isExported vals
+
+ sorted_classes = sortLt ltLexical exported_classes
+ sorted_tycons = sortLt ltLexical exported_tycons
+ sorted_vals = sortLt ltLexical exported_vals
+ in
+ hPutStr if_hdl "\n__declarations__\n" >>
+ hPutStr if_hdl (ppShow 100 (ppAboves [
+ ppAboves (map ppSemid sorted_classes),
+ ppAboves (map ppSemid sorted_tycons),
+ ppAboves (map ppSemid sorted_vals)]))
+\end{code}
+
+\begin{code}
+ifaceInstances Nothing{-no iface handle-} _ = return ()
+
+ifaceInstances (Just if_hdl) (_, _, _, insts)
+ = return ()
+{-
+ let
+ exported_classes = filter isExported classes
+ exported_tycons = filter isExported tycons
+ exported_vals = filter isExported vals
+
+ sorted_classes = sortLt ltLexical exported_classes
+ sorted_tycons = sortLt ltLexical exported_tycons
+ sorted_vals = sortLt ltLexical exported_vals
+ in
+ hPutStr if_hdl "\n__declarations__\n" >>
+ hPutStr if_hdl (ppShow 100 (ppAboves [
+ ppAboves (map ppSemid sorted_classes),
+ ppAboves (map ppSemid sorted_tycons),
+ ppAboves (map ppSemid sorted_vals)]))
+-}
+\end{code}
+
+=== ALL OLD BELOW HERE ==============
+
%************************************************************************
%* *
\subsection[main-MkIface]{Main routine for making interfaces}
\end{enumerate}
\begin{code}
+{- OLD: to the end
mkInterface :: FAST_STRING
-> (FAST_STRING -> Bool, -- is something in export list, explicitly?
FAST_STRING -> Bool) -- is a module among the "dotdot" exported modules?
better_dfun_info = getIdInfo better_dfun
better_constms = map better_id_fn constm_ids
- class_op_strs = map getClassOpString (getClassOps clas)
+ class_op_strs = map classOpString (classOps clas)
pragma_begin
= ppCat [ppPStr SLIT("\t{-# GHC_PRAGMA"), pp_modname, ppPStr SLIT("{-dfun-}"),
case [ c | (c, _) <- dfun_theta ] of { theta_classes ->
(ts, (cs `unionBags` listToBag theta_classes) `snocBag` clas)
}}
+OLD from the beginning -}
\end{code}
import Ubiq
-import MainMonad ( MainIO(..) )
import Name ( RdrName(..) )
import SrcLoc ( mkSrcLoc2, mkUnknownSrcLoc )
\end{code}
= x stuff `thenPrimIO` \ z ->
y z stuff
-initUgn :: UgnM a -> MainIO a
+initUgn :: UgnM a -> IO a
initUgn action
= action (SLIT(""),SLIT(""),mkUnknownSrcLoc) `thenPrimIO` \ result ->
return result
= generic_ERROR_ID irrefutPatErrorIdKey SLIT("irrefutPatError#")
nON_EXHAUSTIVE_GUARDS_ERROR_ID
= generic_ERROR_ID nonExhaustiveGuardsErrorIdKey SLIT("nonExhaustiveGuardsError#")
+nO_DEFAULT_METHOD_ERROR_ID
+ = generic_ERROR_ID noDefaultMethodErrorIdKey SLIT("noDefaultMethodError#")
+nO_EXPLICIT_METHOD_ERROR_ID
+ = generic_ERROR_ID nonExplicitMethodErrorIdKey SLIT("noExplicitMethodError#")
aBSENT_ERROR_ID
= pc_bottoming_Id absentErrorIdKey pRELUDE_BUILTIN SLIT("absent#")
primOpInfo (CCallOp _ _ _ arg_tys result_ty)
= AlgResult SLIT("ccall#") [] arg_tys result_tycon tys_applied
where
- (result_tycon, tys_applied, _) = getAppDataTyCon result_ty
+ (result_tycon, tys_applied, _) = _trace "getAppDataTyCon.PrimOp" $ getAppDataTyCon result_ty
\end{code}
%************************************************************************
import PrefixToHs
import CmdLineOpts ( opt_CompilingPrelude )
-import ErrUtils ( addErrLoc )
+import ErrUtils ( addErrLoc, ghcExit )
import FiniteMap ( elemFM, FiniteMap )
-import MainMonad ( writeMn, exitMn, MainIO(..) )
import Name ( RdrName(..), isRdrLexCon )
import PprStyle ( PprStyle(..) )
import PrelMods ( fromPrelude )
%************************************************************************
\begin{code}
-rdModule :: MainIO (Module, -- this module's name
- RdrNameHsModule) -- the main goods
+rdModule :: IO (Module, -- this module's name
+ RdrNameHsModule) -- the main goods
rdModule
= _ccall_ hspmain `thenPrimIO` \ pt -> -- call the Yacc parser!
(\sty -> ppInterleave ppSP (map (ppr sty) (lpat:lpats)))
msg = ppShow 100 (err PprForUser)
in
- ioToUgnM (writeMn stderr msg) `thenUgn` \ _ ->
- ioToUgnM (exitMn 1) `thenUgn` \ _ ->
+ ioToUgnM (hPutStr stderr msg) `thenUgn` \ _ ->
+ ioToUgnM (ghcExit 1) `thenUgn` \ _ ->
returnUgn (error "ReadPrefix")
) `thenUgn` \ (n, arg_pats) ->
wlkBangType :: U_ttype -> UgnM (BangType RdrName)
-wlkBangType (U_tbang bty) = wlkMonoType bty `thenUgn` \ ty -> returnUgn (Banged ty)
-wlkBangType uty = wlkMonoType uty `thenUgn` \ ty -> returnUgn (Unbanged ty)
-
+wlkBangType (U_tbang bty) = wlkMonoType bty `thenUgn` \ ty ->
+ returnUgn (Banged (HsPreForAllTy [] ty))
+wlkBangType uty = wlkMonoType uty `thenUgn` \ ty ->
+ returnUgn (Unbanged (HsPreForAllTy [] ty))
\end{code}
%************************************************************************
| { emptyFM }
fixes :: { FixitiesMap }
-fixes : fix { case $1 of (k,v) -> unitFM k v }
- | fixes SEMI fix { case $3 of (k,v) -> addToFM $1 k v }
+fixes : fix { case $1 of (k,v) -> unitFM k v }
+ | fixes fix { case $2 of (k,v) -> addToFM $1 k v }
fix :: { (FAST_STRING, RdrNameFixityDecl) }
-fix : INFIXL INTEGER qop { (de_qual $3, InfixL $3 (fromInteger $2)) }
- | INFIXR INTEGER qop { (de_qual $3, InfixR $3 (fromInteger $2)) }
- | INFIX INTEGER qop { (de_qual $3, InfixN $3 (fromInteger $2))
+fix : INFIXL INTEGER qop SEMI { (de_qual $3, InfixL $3 (fromInteger $2)) }
+ | INFIXR INTEGER qop SEMI { (de_qual $3, InfixR $3 (fromInteger $2)) }
+ | INFIX INTEGER qop SEMI { (de_qual $3, InfixN $3 (fromInteger $2))
--------------------------------------------------------------------------
}
decls_part : DECLARATIONS_PART topdecls { $2 }
topdecls :: { (LocalTyDefsMap, LocalValDefsMap) }
-topdecls : topdecl { $1 }
- | topdecls SEMI topdecl { case $1 of { (ts1, vs1) ->
- case $3 of { (ts2, vs2) ->
- (plusFM ts1 ts2, plusFM vs1 vs2)}}
- }
+topdecls : topdecl { $1 }
+ | topdecls topdecl { case $1 of { (ts1, vs1) ->
+ case $2 of { (ts2, vs2) ->
+ (plusFM ts1 ts2, plusFM vs1 vs2)}}
+ }
topdecl :: { (LocalTyDefsMap, LocalValDefsMap) }
-topdecl : typed { ($1, emptyFM) }
- | datad { $1 }
- | newtd { $1 }
- | classd { $1 }
+topdecl : typed SEMI { ($1, emptyFM) }
+ | datad SEMI { $1 }
+ | newtd SEMI { $1 }
+ | classd SEMI { $1 }
| decl { case $1 of { (n, Sig qn ty _ loc) ->
(emptyFM, unitFM n (ValSig qn loc ty)) }
}
| { [] }
decls :: { [(FAST_STRING, RdrNameSig)] }
-decls : decl { [$1] }
- | decls SEMI decl { $1 ++ [$3] }
+decls : decl { [$1] }
+ | decls decl { $1 ++ [$2] }
decl :: { (FAST_STRING, RdrNameSig) }
-decl : var DCOLON ctype { (de_qual $1, Sig $1 $3 noGenPragmas mkIfaceSrcLoc) }
+decl : var DCOLON ctype SEMI { (de_qual $1, Sig $1 $3 noGenPragmas mkIfaceSrcLoc) }
context :: { RdrNameContext }
context : OPAREN context_list CPAREN { reverse $2 }
| btyconapp batype { case $1 of (tc,tys) -> (tc, tys ++ [$2]) }
bbtype :: { RdrNameBangType }
-bbtype : btype { Unbanged $1 }
- | BANG atype { Banged $2 }
+bbtype : btype { Unbanged (HsPreForAllTy [] $1) }
+ | BANG atype { Banged (HsPreForAllTy [] $2) }
batype :: { RdrNameBangType }
-batype : atype { Unbanged $1 }
- | BANG atype { Banged $2 }
+batype : atype { Unbanged (HsPreForAllTy [] $1) }
+ | BANG atype { Banged (HsPreForAllTy [] $2) }
batypes :: { [RdrNameBangType] }
batypes : batype { [$1] }
| fields COMMA field { $1 ++ [$3] }
field :: { ([RdrName], RdrNameBangType) }
-field : var DCOLON type { ([$1], Unbanged $3) }
- | var DCOLON BANG atype { ([$1], Banged $4) }
+field : var DCOLON type { ([$1], Unbanged (HsPreForAllTy [] $3)) }
+ | var DCOLON BANG atype { ([$1], Banged (HsPreForAllTy [] $4)) }
constr1 :: { (RdrName, RdrNameMonoType) }
constr1 : gtycon atype { ($1, $2) }
instdecls :: { Bag RdrIfaceInst }
instdecls : instd { unitBag $1 }
- | instdecls SEMI instd { $1 `snocBag` $3 }
+ | instdecls instd { $1 `snocBag` $2 }
instd :: { RdrIfaceInst }
-instd : INSTANCE context DARROW gtycon restrict_inst { mk_inst $2 $4 $5 }
- | INSTANCE gtycon general_inst { mk_inst [] $2 $3 }
+instd : INSTANCE context DARROW gtycon restrict_inst SEMI { mk_inst $2 $4 $5 }
+ | INSTANCE gtycon general_inst SEMI { mk_inst [] $2 $3 }
restrict_inst :: { RdrNameMonoType }
restrict_inst : gtycon { MonoTyApp $1 [] }
import RnSource ( rnSource )
import RnIfaces ( findHiFiles, rnIfaces, finalIfaceInfo, VersionInfo(..) )
import RnUtils ( RnEnv(..), extendGlobalRnEnv, emptyRnEnv, multipleOccWarn )
-import MainMonad
import Bag ( isEmptyBag, unionBags, unionManyBags, bagToList, listToBag )
import CmdLineOpts ( opt_HiDirList, opt_SysHiDirList )
renameModule b_names b_keys us
input@(HsModule mod _ _ imports _ _ _ _ _ _ _ _ _ _)
- = pprTrace "builtins:\n" (case b_names of { (builtin_ids, builtin_tcs) ->
- ppAboves [ ppCat (map ppPStr (keysFM builtin_ids))
- , ppCat (map ppPStr (keysFM builtin_tcs))
- , ppCat (map ppPStr (keysFM b_keys))
- ]}) $
+ = --pprTrace "builtins:\n" (case b_names of { (builtin_ids, builtin_tcs) ->
+ -- ppAboves [ ppCat (map ppPStr (keysFM builtin_ids))
+ -- , ppCat (map ppPStr (keysFM builtin_tcs))
+ -- , ppCat (map ppPStr (keysFM b_keys))
+ -- ]}) $
findHiFiles opt_HiDirList opt_SysHiDirList >>= \ hi_files ->
newVar (emptyFM, hi_files){-init iface cache-} `thenPrimIO` \ iface_cache ->
returnRn (new_names, new_ty)
rn_mono_ty = rnMonoType tv_env
+ rn_poly_ty = rnPolyType tv_env
rn_bang_ty (Banged ty)
- = rn_mono_ty ty `thenRn` \ new_ty ->
+ = rn_poly_ty ty `thenRn` \ new_ty ->
returnRn (Banged new_ty)
rn_bang_ty (Unbanged ty)
- = rn_mono_ty ty `thenRn` \ new_ty ->
+ = rn_poly_ty ty `thenRn` \ new_ty ->
returnRn (Unbanged new_ty)
\end{code}
import CoreSyn
import CoreUnfold
import CoreUtils ( substCoreBindings, manifestlyWHNF )
+import ErrUtils ( ghcExit )
import FloatIn ( floatInwards )
import FloatOut ( floatOutwards )
import FoldrBuildWW ( mkFoldrBuildWW )
import IdInfo ( mkUnfolding )
import LiberateCase ( liberateCase )
import MagicUFs ( MagicUnfoldingFun )
-import MainMonad ( writeMn, exitMn, thenMn, thenMn_, returnMn,
- MainIO(..)
- )
import Maybes ( maybeToBool )
import Outputable ( Outputable(..){-instance * (,) -} )
import PprCore ( pprCoreBinding, GenCoreExpr{-instance Outputable-} )
-> [TyCon] -- local data tycons and tycon specialisations
-> FiniteMap TyCon [(Bool, [Maybe Type])]
-> [CoreBinding] -- input...
- -> MainIO
+ -> IO
([CoreBinding], -- results: program, plus...
IdEnv UnfoldingDetails, -- unfoldings to be exported from here
SpecialiseData) -- specialisation data
= BSCC("Core2Core")
if null core_todos then -- very rare, I suspect...
-- well, we still must do some renumbering
- returnMn (
+ return (
(substCoreBindings nullIdEnv nullTyVarEnv binds us,
nullIdEnv,
init_specdata)
)
else
(if do_verbose_core2core then
- writeMn stderr "VERBOSE CORE-TO-CORE:\n"
- else returnMn ()) `thenMn_`
+ hPutStr stderr "VERBOSE CORE-TO-CORE:\n"
+ else return ()) >>
-- better do the main business
foldl_mn do_core_pass
(binds, us, nullIdEnv, init_specdata, zeroSimplCount)
core_todos
- `thenMn` \ (processed_binds, _, inline_env, spec_data, simpl_stats) ->
+ >>= \ (processed_binds, _, inline_env, spec_data, simpl_stats) ->
(if opt_D_simplifier_stats
- then writeMn stderr ("\nSimplifier Stats:\n")
- `thenMn_`
- writeMn stderr (showSimplCount simpl_stats)
- `thenMn_`
- writeMn stderr "\n"
- else returnMn ()
- ) `thenMn_`
-
- returnMn (processed_binds, inline_env, spec_data)
+ then hPutStr stderr ("\nSimplifier Stats:\n")
+ >>
+ hPutStr stderr (showSimplCount simpl_stats)
+ >>
+ hPutStr stderr "\n"
+ else return ()
+ ) >>
+
+ return (processed_binds, inline_env, spec_data)
ESCC
where
init_specdata = initSpecData local_tycons tycon_specs
CoreDoSimplify simpl_sw_chkr
-> BSCC("CoreSimplify")
begin_pass ("Simplify" ++ if switchIsOn simpl_sw_chkr SimplDoFoldrBuild
- then " (foldr/build)" else "") `thenMn_`
+ then " (foldr/build)" else "") >>
case (simplifyPgm binds simpl_sw_chkr simpl_stats us1) of
(p, it_cnt, simpl_stats2)
-> end_pass False us2 p inline_env spec_data simpl_stats2
CoreDoFoldrBuildWorkerWrapper
-> BSCC("CoreDoFoldrBuildWorkerWrapper")
- begin_pass "FBWW" `thenMn_`
+ begin_pass "FBWW" >>
case (mkFoldrBuildWW us1 binds) of { binds2 ->
end_pass False us2 binds2 inline_env spec_data simpl_stats "FBWW"
} ESCC
CoreDoFoldrBuildWWAnal
-> BSCC("CoreDoFoldrBuildWWAnal")
- begin_pass "AnalFBWW" `thenMn_`
+ begin_pass "AnalFBWW" >>
case (analFBWW binds) of { binds2 ->
end_pass False us2 binds2 inline_env spec_data simpl_stats "AnalFBWW"
} ESCC
CoreLiberateCase
-> BSCC("LiberateCase")
- begin_pass "LiberateCase" `thenMn_`
+ begin_pass "LiberateCase" >>
case (liberateCase lib_case_threshold binds) of { binds2 ->
end_pass False us2 binds2 inline_env spec_data simpl_stats "LiberateCase"
} ESCC
CoreDoCalcInlinings1 -- avoid inlinings w/ cost-centres
-> BSCC("CoreInlinings1")
- begin_pass "CalcInlinings" `thenMn_`
+ begin_pass "CalcInlinings" >>
case (calcInlinings False inline_env binds) of { inline_env2 ->
end_pass False us2 binds inline_env2 spec_data simpl_stats "CalcInlinings"
} ESCC
CoreDoCalcInlinings2 -- allow inlinings w/ cost-centres
-> BSCC("CoreInlinings2")
- begin_pass "CalcInlinings" `thenMn_`
+ begin_pass "CalcInlinings" >>
case (calcInlinings True inline_env binds) of { inline_env2 ->
end_pass False us2 binds inline_env2 spec_data simpl_stats "CalcInlinings"
} ESCC
CoreDoFloatInwards
-> BSCC("FloatInwards")
- begin_pass "FloatIn" `thenMn_`
+ begin_pass "FloatIn" >>
case (floatInwards binds) of { binds2 ->
end_pass False us2 binds2 inline_env spec_data simpl_stats "FloatIn"
} ESCC
CoreDoFullLaziness
-> BSCC("CoreFloating")
- begin_pass "FloatOut" `thenMn_`
+ begin_pass "FloatOut" >>
case (floatOutwards us1 binds) of { binds2 ->
end_pass False us2 binds2 inline_env spec_data simpl_stats "FloatOut"
} ESCC
CoreDoStaticArgs
-> BSCC("CoreStaticArgs")
- begin_pass "StaticArgs" `thenMn_`
+ begin_pass "StaticArgs" >>
case (doStaticArgs binds us1) of { binds2 ->
end_pass False us2 binds2 inline_env spec_data simpl_stats "StaticArgs"
-- Binds really should be dependency-analysed for static-
CoreDoStrictness
-> BSCC("CoreStranal")
- begin_pass "StrAnal" `thenMn_`
+ begin_pass "StrAnal" >>
case (saWwTopBinds us1 binds) of { binds2 ->
end_pass False us2 binds2 inline_env spec_data simpl_stats "StrAnal"
} ESCC
CoreDoSpecialising
-> BSCC("Specialise")
- begin_pass "Specialise" `thenMn_`
+ begin_pass "Specialise" >>
case (specProgram us1 binds spec_data) of {
(p, spec_data2@(SpecData _ spec_noerrs _ _ _
spec_errs spec_warn spec_tyerrs)) ->
-- if we got errors, we die straight away
(if not spec_noerrs ||
(opt_ShowImportSpecs && not (isEmptyBag spec_warn)) then
- writeMn stderr (ppShow 1000 {-pprCols-}
+ hPutStr stderr (ppShow 1000 {-pprCols-}
(pprSpecErrs module_name spec_errs spec_warn spec_tyerrs))
- `thenMn_` writeMn stderr "\n"
+ >> hPutStr stderr "\n"
else
- returnMn ()) `thenMn_`
+ return ()) >>
(if not spec_noerrs then -- Stop here if specialisation errors occured
- exitMn 1
+ ghcExit 1
else
- returnMn ()) `thenMn_`
+ return ()) >>
end_pass False us2 p inline_env spec_data2 simpl_stats "Specialise"
}
-> error "ERROR: CoreDoDeforest: not built into compiler\n"
#else
-> BSCC("Deforestation")
- begin_pass "Deforestation" `thenMn_`
+ begin_pass "Deforestation" >>
case (deforestProgram binds us1) of { binds2 ->
end_pass False us2 binds2 inline_env spec_data simpl_stats "Deforestation"
}
CoreDoAutoCostCentres
-> BSCC("AutoSCCs")
- begin_pass "AutoSCCs" `thenMn_`
+ begin_pass "AutoSCCs" >>
case (addAutoCostCentres module_name binds) of { binds2 ->
end_pass False us2 binds2 inline_env spec_data simpl_stats "AutoSCCs"
}
begin_pass
= if opt_D_show_passes
- then \ what -> writeMn stderr ("*** Core2Core: "++what++"\n")
- else \ what -> returnMn ()
+ then \ what -> hPutStr stderr ("*** Core2Core: "++what++"\n")
+ else \ what -> return ()
end_pass print us2 binds2 inline_env2
spec_data2@(SpecData spec_done _ _ _ _ _ _ _)
(if (do_verbose_core2core && not print) ||
(print && not do_verbose_core2core)
then
- writeMn stderr ("\n*** "++what++":\n")
- `thenMn_`
- writeMn stderr (ppShow 1000
+ hPutStr stderr ("\n*** "++what++":\n")
+ >>
+ hPutStr stderr (ppShow 1000
(ppAboves (map (pprCoreBinding ppr_style) binds2)))
- `thenMn_`
- writeMn stderr "\n"
+ >>
+ hPutStr stderr "\n"
else
- returnMn ()) `thenMn_`
+ return ()) >>
let
linted_binds = core_linter what spec_done binds2
in
- returnMn
+ return
(linted_binds, -- processed binds, possibly run thru CoreLint
us2, -- UniqueSupply for the next guy
inline_env2, -- possibly-updated inline env
)
-- here so it can be inlined...
-foldl_mn f z [] = returnMn z
-foldl_mn f z (x:xs) = f z x `thenMn` \ zz ->
+foldl_mn f z [] = return z
+foldl_mn f z (x:xs) = f z x >>= \ zz ->
foldl_mn f zz xs
\end{code}
-> ASSERT( null args )
returnSmpl (Lit lit)
- ConForm con args
+ ConForm con con_args
-- Always inline constructors.
-- See comments before completeLetBinding
-> ASSERT( null args )
- returnSmpl (Con con args)
+ returnSmpl (Con con con_args)
GenForm txt_occ form_summary template guidance
-> considerUnfolding env var args
growIdEnvList, isNullIdEnv, IdEnv(..),
GenId{-instance Eq/Outputable -}
)
-import MainMonad ( writeMn, thenMn_, thenMn, returnMn, MainIO(..) )
import Maybes ( maybeToBool )
import Name ( isExported )
import PprType ( GenType{-instance Outputable-} )
-> PprStyle -- printing style (for debugging only)
-> UniqSupply -- a name supply
-> [StgBinding] -- input...
- -> MainIO
+ -> IO
([StgBinding], -- output program...
([CostCentre], -- local cost-centres that need to be decl'd
[CostCentre])) -- "extern" cost-centres
case (splitUniqSupply us) of { (us4now, us4later) ->
(if do_verbose_stg2stg then
- writeMn stderr "VERBOSE STG-TO-STG:\n" `thenMn_`
- writeMn stderr (ppShow 1000
+ hPutStr stderr "VERBOSE STG-TO-STG:\n" >>
+ hPutStr stderr (ppShow 1000
(ppAbove (ppStr ("*** Core2Stg:"))
(ppAboves (map (ppr ppr_style) (setStgVarInfo False binds)))
))
- else returnMn ()) `thenMn_`
+ else return ()) >>
-- Do the main business!
foldl_mn do_stg_pass (binds, us4now, ([],[])) stg_todos
- `thenMn` \ (processed_binds, _, cost_centres) ->
+ >>= \ (processed_binds, _, cost_centres) ->
-- Do essential wind-up: part (a) is SatStgRhs
-- Not optional, because correct arity information is used by
then no_ind_binds
else snd (unlocaliseStgBinds unlocal_tag nullIdEnv no_ind_binds)
in
- returnMn (setStgVarInfo do_let_no_escapes binds_to_mangle, cost_centres)
+ return (setStgVarInfo do_let_no_escapes binds_to_mangle, cost_centres)
}}
ESCC
where
end_pass us2 what ccs binds2
= -- report verbosely, if required
(if do_verbose_stg2stg then
- writeMn stderr (ppShow 1000
+ hPutStr stderr (ppShow 1000
(ppAbove (ppStr ("*** "++what++":"))
(ppAboves (map (ppr ppr_style) binds2))
))
- else returnMn ()) `thenMn_`
+ else return ()) >>
let
linted_binds = stg_linter what binds2
in
- returnMn (linted_binds, us2, ccs)
+ return (linted_binds, us2, ccs)
-- return: processed binds
-- UniqueSupply for the next guy to use
-- cost-centres to be declared/registered (specialised)
-- add to description of what's happened (reverse order)
-- here so it can be inlined...
-foldl_mn f z [] = returnMn z
-foldl_mn f z (x:xs) = f z x `thenMn` \ zz ->
+foldl_mn f z [] = return z
+foldl_mn f z (x:xs) = f z x >>= \ zz ->
foldl_mn f zz xs
\end{code}
import Ubiq{-uitous-}
import Bag ( isEmptyBag, bagToList )
-import Class ( getClassOpString, GenClass{-instance NamedThing-} )
+import Class ( classOpString, GenClass{-instance NamedThing-} )
import FiniteMap ( emptyFM, addListToFM_C, plusFM_C, keysFM,
lookupWithDefaultFM
)
= let
Just (cls, clsty, clsop) = const_method_maybe
(_, cls_str) = moduleNamePair cls
- clsop_str = getClassOpString clsop
+ clsop_str = classOpString clsop
in
ppCat [pp_mod,
ppStr "{-# SPECIALIZE",
= let
Just (cls, clsop, _) = default_method_maybe
(_, cls_str) = moduleNamePair cls
- clsop_str = getClassOpString clsop
+ clsop_str = classOpString clsop
in
ppCat [pp_mod,
ppStr "{- instance",
tcInstType, tcInstTcType, zonkTcType )
import Bag ( emptyBag, unitBag, unionBags, unionManyBags, listToBag, consBag )
-import Class ( Class(..), GenClass, ClassInstEnv(..), getClassInstEnv )
+import Class ( Class(..), GenClass, ClassInstEnv(..), classInstEnv )
import Id ( GenId, idType, mkInstId )
import MatchEnv ( lookupMEnv, insertMEnv )
import Name ( mkLocalName, getLocalName, Name )
-> [(Class, TcType s)]
-> NF_TcM s (LIE s, [TcIdOcc s])
newDicts orig theta
- = tcGetSrcLoc `thenNF_Tc` \ loc ->
- tcGetUniques (length theta) `thenNF_Tc` \ new_uniqs ->
- let
+ = tcGetSrcLoc `thenNF_Tc` \ loc ->
+ tcGetUniques (length theta) `thenNF_Tc` \ new_uniqs ->
+ let
mk_dict u (clas, ty) = Dict u clas ty orig loc
dicts = zipWithEqual mk_dict new_uniqs theta
- in
- returnNF_Tc (listToBag dicts, map instToId dicts)
+ in
+ returnNF_Tc (listToBag dicts, map instToId dicts)
newDictsAtLoc orig loc theta -- Local function, similar to newDicts,
-- but with slightly different interface
- = tcGetUniques (length theta) `thenNF_Tc` \ new_uniqs ->
- let
+ = tcGetUniques (length theta) `thenNF_Tc` \ new_uniqs ->
+ let
mk_dict u (clas, ty) = Dict u clas ty orig loc
dicts = zipWithEqual mk_dict new_uniqs theta
- in
- returnNF_Tc (dicts, map instToId dicts)
+ in
+ returnNF_Tc (dicts, map instToId dicts)
newMethod :: InstOrigin s
-> TcIdOcc s
-> [TcType s]
-> NF_TcM s (LIE s, TcIdOcc s)
newMethod orig id tys
- = -- Get the Id type and instantiate it at the specified types
- (case id of
- RealId id -> let (tyvars, rho) = splitForAllTy (idType id)
- in tcInstType (tyvars `zipEqual` tys) rho
- TcId id -> let (tyvars, rho) = splitForAllTy (idType id)
- in tcInstTcType (tyvars `zipEqual` tys) rho
- ) `thenNF_Tc` \ rho_ty ->
-
- -- Our friend does the rest
- newMethodWithGivenTy orig id tys rho_ty
+ = -- Get the Id type and instantiate it at the specified types
+ (case id of
+ RealId id -> let (tyvars, rho) = splitForAllTy (idType id)
+ in tcInstType (tyvars `zipEqual` tys) rho
+ TcId id -> let (tyvars, rho) = splitForAllTy (idType id)
+ in tcInstTcType (tyvars `zipEqual` tys) rho
+ ) `thenNF_Tc` \ rho_ty ->
+ -- Our friend does the rest
+ newMethodWithGivenTy orig id tys rho_ty
newMethodWithGivenTy orig id tys rho_ty
- = tcGetSrcLoc `thenNF_Tc` \ loc ->
- tcGetUnique `thenNF_Tc` \ new_uniq ->
- let
+ = tcGetSrcLoc `thenNF_Tc` \ loc ->
+ tcGetUnique `thenNF_Tc` \ new_uniq ->
+ let
meth_inst = Method new_uniq id tys rho_ty orig loc
- in
- returnNF_Tc (unitLIE meth_inst, instToId meth_inst)
+ in
+ returnNF_Tc (unitLIE meth_inst, instToId meth_inst)
newMethodAtLoc :: InstOrigin s -> SrcLoc -> Id -> [TcType s] -> NF_TcM s (Inst s, TcIdOcc s)
newMethodAtLoc orig loc real_id tys -- Local function, similar to newMethod but with
-- slightly different interface
- = -- Get the Id type and instantiate it at the specified types
- let
- (tyvars,rho) = splitForAllTy (idType real_id)
- in
- tcInstType (tyvars `zipEqual` tys) rho `thenNF_Tc` \ rho_ty ->
- tcGetUnique `thenNF_Tc` \ new_uniq ->
- let
+ = -- Get the Id type and instantiate it at the specified types
+ let
+ (tyvars,rho) = splitForAllTy (idType real_id)
+ in
+ tcInstType (tyvars `zipEqual` tys) rho `thenNF_Tc` \ rho_ty ->
+ tcGetUnique `thenNF_Tc` \ new_uniq ->
+ let
meth_inst = Method new_uniq (RealId real_id) tys rho_ty orig loc
- in
- returnNF_Tc (meth_inst, instToId meth_inst)
+ in
+ returnNF_Tc (meth_inst, instToId meth_inst)
newOverloadedLit :: InstOrigin s
-> OverloadedLit
-> TcType s
-> NF_TcM s (LIE s, TcIdOcc s)
newOverloadedLit orig lit ty
- = tcGetSrcLoc `thenNF_Tc` \ loc ->
- tcGetUnique `thenNF_Tc` \ new_uniq ->
- let
+ = tcGetSrcLoc `thenNF_Tc` \ loc ->
+ tcGetUnique `thenNF_Tc` \ new_uniq ->
+ let
lit_inst = LitInst new_uniq lit ty orig loc
- in
- returnNF_Tc (unitLIE lit_inst, instToId lit_inst)
+ in
+ returnNF_Tc (unitLIE lit_inst, instToId lit_inst)
\end{code}
lookupClassInstAtSimpleType :: Class -> Type -> Maybe Id
lookupClassInstAtSimpleType clas ty
- = case (lookupMEnv matchTy (getClassInstEnv clas) ty) of
+ = case (lookupMEnv matchTy (classInstEnv clas) ty) of
Nothing -> Nothing
Just (dfun,_) -> ASSERT( null tyvars && null theta )
Just dfun
mkInstSpecEnv clas inst_ty inst_tvs inst_theta
= mkSpecEnv (catMaybes (map maybe_spec_info matches))
where
- matches = matchMEnv matchTy (getClassInstEnv clas) inst_ty
+ matches = matchMEnv matchTy (classInstEnv clas) inst_ty
maybe_spec_info (_, match_info, MkInstTemplate dfun _ [])
= Just (SpecInfo (map (assocMaybe match_info) inst_tvs) (length inst_theta) dfun)
= fst (inst_mapper clas)
get_inst_env clas (InstanceSpecOrigin inst_mapper _ _)
= fst (inst_mapper clas)
-get_inst_env clas other_orig = getClassInstEnv clas
+get_inst_env clas other_orig = classInstEnv clas
pprOrigin :: PprStyle -> InstOrigin s -> Pretty
import TcKind ( TcKind )
import Bag ( foldBag )
-import Class ( GenClass, mkClass, mkClassOp, getClassBigSig,
- getClassOps, getClassOpString, getClassOpLocalType )
-import CoreUtils ( escErrorMsg )
+import Class ( GenClass, mkClass, mkClassOp, classBigSig,
+ classOps, classOpString, classOpLocalType,
+ classOpTagByString
+ )
import Id ( mkSuperDictSelId, mkMethodSelId, mkDefaultMethodId,
idType )
import IdInfo ( noIdInfo )
import Name ( isLocallyDefined, moduleNamePair, getLocalName )
-import PrelVals ( pAT_ERROR_ID )
+import PrelVals ( nO_DEFAULT_METHOD_ERROR_ID )
import PprStyle
import Pretty
import PprType ( GenType, GenTyVar, GenClassOp )
`thenTc` \ sig_stuff ->
-- MAKE THE CLASS OBJECT ITSELF
- tcGetUnique `thenNF_Tc` \ uniq ->
+-- BOGUS:
+-- tcGetUnique `thenNF_Tc` \ uniq ->
let
(ops, op_sel_ids, defm_ids) = unzip3 sig_stuff
- clas = mkClass uniq (getName class_name) rec_tyvar
+ clas = mkClass (uniqueOf class_name) (getName class_name) rec_tyvar
scs sc_sel_ids ops op_sel_ids defm_ids
rec_class_inst_env
in
full_theta = (rec_clas, mkTyVarTy rec_clas_tyvar) : theta
global_ty = mkSigmaTy full_tyvars full_theta tau
local_ty = mkSigmaTy tyvars theta tau
- class_op = mkClassOp (getLocalName op_name)
- (panic "(getTagFromClassOpName op_name)TcClassDecl"{-(getTagFromClassOpName op_name)-})
+ class_op_nm = getLocalName op_name
+ class_op = mkClassOp class_op_nm
+ (classOpTagByString rec_clas{-yeeps!-} class_op_nm)
local_ty
in
tcLookupClass class_name `thenNF_Tc` \ (_, clas) ->
let
(tyvar, scs, sc_sel_ids, ops, op_sel_ids, defm_ids)
- = getClassBigSig clas
+ = classBigSig clas
in
tcInstSigTyVars [tyvar] `thenNF_Tc` \ ([clas_tyvar], _, _) ->
-- Make new Ids for the components of the dictionary
let
clas_tyvar_ty = mkTyVarTy clas_tc_tyvar
- mk_op_ty = tcInstType [(clas_tyvar, clas_tyvar_ty)] . getClassOpLocalType
+ mk_op_ty = tcInstType [(clas_tyvar, clas_tyvar_ty)] . classOpLocalType
in
mapNF_Tc mk_op_ty ops `thenNF_Tc` \ op_tys ->
- newLocalIds (map getClassOpString ops) op_tys `thenNF_Tc` \ method_ids ->
+ newLocalIds (map classOpString ops) op_tys `thenNF_Tc` \ method_ids ->
newDicts ClassDeclOrigin
[ (super_clas, clas_tyvar_ty)
= -- Deal with the method declarations themselves
mapNF_Tc unZonkId default_method_ids `thenNF_Tc` \ tc_defm_ids ->
processInstBinds
+ clas
(makeClassDeclDefaultMethodRhs clas default_method_ids)
[] -- No tyvars in scope for "this inst decl"
emptyLIE -- No insts available
returnNF_Tc (mkHsTyLam tyvars (
mkHsDictLam dict_ids (
- HsApp (mkHsTyApp (HsVar (RealId pAT_ERROR_ID)) [tau])
+ HsApp (mkHsTyApp (HsVar (RealId nO_DEFAULT_METHOD_ERROR_ID)) [tau])
(HsLitOut (HsString (_PK_ error_msg)) stringTy))))
where
(clas_mod, clas_name) = moduleNamePair clas
method_id = method_ids !! (tag-1)
- class_op = (getClassOps clas) !! (tag-1)
-
- error_msg = "%D" -- => No default method for \"
- ++ unencoded_part_of_msg
+ class_op = (classOps clas) !! (tag-1)
- unencoded_part_of_msg = escErrorMsg (
- _UNPK_ clas_mod ++ "." ++ _UNPK_ clas_name ++ "."
- ++ (ppShow 80 (ppr PprForUser class_op))
- ++ "\"" )
+ error_msg = _UNPK_ clas_mod ++ "." ++ _UNPK_ clas_name ++ "."
+ ++ (ppShow 80 (ppr PprForUser class_op))
+ ++ "\""
\end{code}
import RnBinds ( rnMethodBinds, rnTopBinds )
import Bag ( emptyBag{-ToDo:rm-}, Bag, isEmptyBag, unionBags, listToBag )
-import Class ( GenClass, getClassKey )
+import Class ( GenClass, classKey )
import CmdLineOpts ( opt_CompilingPrelude )
import ErrUtils ( pprBagOfErrors, addErrLoc, Error(..) )
import Id ( dataConSig, dataConArity )
chk_out :: [(Class, TyCon)] -> (Class, TyCon) -> TcM s ()
chk_out whole_deriving_list this_one@(clas, tycon)
= let
- clas_key = getClassKey clas
+ clas_key = classKey clas
in
-- Are things OK for deriving Enum (if appropriate)?
(if from_here then mbinds else EmptyMonoBinds)
from_here modname locn [])
where
- clas_key = getClassKey clas
+ clas_key = classKey clas
clas_Name
= let (mod, nm) = moduleNamePair clas in
ClassName clas_key (mkPreludeCoreName mod nm) []
where
is_in_eqns clas_key tycon [] = False
is_in_eqns clas_key tycon ((c,t,_,_):eqns)
- = (clas_key == getClassKey c && tycon == t)
+ = (clas_key == classKey c && tycon == t)
|| is_in_eqns clas_key tycon eqns
\end{code}
import TyVar ( mkTyVar, tyVarKind, unionTyVarSets, emptyTyVarSet )
import Type ( tyVarsOfTypes )
import TyCon ( TyCon, Arity(..), tyConKind, synTyConArity )
-import Class ( Class(..), GenClass, getClassSig )
+import Class ( Class(..), GenClass, classSig )
import TcMonad
newTyVarTy, zonkTcTyVars, zonkTcType )
import TcKind ( TcKind )
-import Class ( Class(..), getClassSig )
+import Class ( Class(..), classSig )
import FieldLabel ( fieldLabelName )
import Id ( Id(..), GenId, idType, dataConFieldLabels, dataConSig )
import Kind ( Kind, mkBoxedTypeKind, mkTypeKind, mkArrowKind )
-- Check that the field names are plausible
zonkTcType record_ty `thenNF_Tc` \ record_ty' ->
let
- (tycon, inst_tys, data_cons) = getAppDataTyCon record_ty'
+ (tycon, inst_tys, data_cons) = _trace "getAppDataTyCon.TcExpr" $ getAppDataTyCon record_ty'
-- The record binds are non-empty (syntax); so at least one field
-- label will have been unified with record_ty by tcRecordBinds;
-- field labels must be of data type; hencd the getAppDataTyCon must succeed.
opt_OmitDefaultInstanceMethods,
opt_SpecialiseOverloaded )
import Class ( GenClass, GenClassOp,
- isCcallishClass, getClassBigSig,
- getClassOps, getClassOpLocalType )
-import CoreUtils ( escErrorMsg )
+ isCcallishClass, classBigSig,
+ classOps, classOpLocalType,
+ classOpTagByString
+ )
import Id ( GenId, idType, isDefaultMethodId_maybe )
import ListSetOps ( minusList )
import Maybes ( maybeToBool, expectJust )
import Name ( getLocalName, origName, nameOf )
-import PrelInfo ( pAT_ERROR_ID )
+import PrelVals ( nO_EXPLICIT_METHOD_ERROR_ID )
import PrelMods ( pRELUDE )
import PprType ( GenType, GenTyVar, GenClass, GenClassOp, TyCon,
pprParendGenType
let
(class_tyvar,
super_classes, sc_sel_ids,
- class_ops, op_sel_ids, defm_ids) = getClassBigSig clas
+ class_ops, op_sel_ids, defm_ids) = classBigSig clas
in
tcInstType tenv inst_ty `thenNF_Tc` \ inst_ty' ->
tcInstTheta tenv dfun_theta `thenNF_Tc` \ dfun_theta' ->
else
makeInstanceDeclDefaultMethodExpr origin meth_ids defm_ids inst_ty' this_dict_id
in
- processInstBinds mk_method_expr inst_tyvars' avail_insts meth_ids monobinds
+ processInstBinds clas mk_method_expr inst_tyvars' avail_insts meth_ids monobinds
`thenTc` \ (insts_needed, method_mbinds) ->
let
-- Create the dict and method binds
`thenNF_Tc_`
returnNF_Tc (mkHsTyLam op_tyvars (
mkHsDictLam op_dicts (
- HsApp (mkHsTyApp (HsVar (RealId pAT_ERROR_ID)) [op_tau])
+ HsApp (mkHsTyApp (HsVar (RealId nO_EXPLICIT_METHOD_ERROR_ID)) [op_tau])
(HsLitOut (HsString (_PK_ error_msg)) stringTy))))
where
idx = tag - 1
meth_id = meth_ids !! idx
- clas_op = (getClassOps clas) !! idx
+ clas_op = (classOps clas) !! idx
defm_id = defm_ids !! idx
(op_tyvars,op_theta,op_tau) = splitSigmaTy (tcIdType meth_id)
Just (_, _, err_defm_ok) = isDefaultMethodId_maybe defm_id
- error_msg = "%E" -- => No explicit method for \"
- ++ escErrorMsg error_str
-
mod_str = case inst_mod of { Nothing -> pRELUDE; Just m -> m }
- error_str = _UNPK_ mod_str ++ "." ++ _UNPK_ clas_name ++ "."
+ error_msg = _UNPK_ mod_str ++ "." ++ _UNPK_ clas_name ++ "."
++ (ppShow 80 (ppr PprForUser inst_ty)) ++ "."
++ (ppShow 80 (ppr PprForUser clas_op)) ++ "\""
\begin{code}
processInstBinds
- :: (Int -> NF_TcM s (TcExpr s)) -- Function to make default method
+ :: Class
+ -> (Int -> NF_TcM s (TcExpr s)) -- Function to make default method
-> [TcTyVar s] -- Tyvars for this instance decl
-> LIE s -- available Insts
-> [TcIdOcc s] -- Local method ids in tag order
-> TcM s (LIE s, -- These are required
TcMonoBinds s)
-processInstBinds mk_default_method_rhs inst_tyvars avail_insts method_ids monobinds
+processInstBinds clas mk_default_method_rhs inst_tyvars avail_insts method_ids monobinds
=
-- Process the explicitly-given method bindings
- processInstBinds1 inst_tyvars avail_insts method_ids monobinds
+ processInstBinds1 clas inst_tyvars avail_insts method_ids monobinds
`thenTc` \ (tags, insts_needed_in_methods, method_binds) ->
-- Find the methods not handled, and make default method bindings for them.
\begin{code}
processInstBinds1
- :: [TcTyVar s] -- Tyvars for this instance decl
+ :: Class
+ -> [TcTyVar s] -- Tyvars for this instance decl
-> LIE s -- available Insts
-> [TcIdOcc s] -- Local method ids in tag order (instance tyvars are free),
-> RenamedMonoBinds
LIE s, -- These are required
TcMonoBinds s)
-processInstBinds1 inst_tyvars avail_insts method_ids EmptyMonoBinds
+processInstBinds1 clas inst_tyvars avail_insts method_ids EmptyMonoBinds
= returnTc ([], emptyLIE, EmptyMonoBinds)
-processInstBinds1 inst_tyvars avail_insts method_ids (AndMonoBinds mb1 mb2)
- = processInstBinds1 inst_tyvars avail_insts method_ids mb1
+processInstBinds1 clas inst_tyvars avail_insts method_ids (AndMonoBinds mb1 mb2)
+ = processInstBinds1 clas inst_tyvars avail_insts method_ids mb1
`thenTc` \ (op_tags1,dicts1,method_binds1) ->
- processInstBinds1 inst_tyvars avail_insts method_ids mb2
+ processInstBinds1 clas inst_tyvars avail_insts method_ids mb2
`thenTc` \ (op_tags2,dicts2,method_binds2) ->
returnTc (op_tags1 ++ op_tags2,
dicts1 `unionBags` dicts2,
\end{code}
\begin{code}
-processInstBinds1 inst_tyvars avail_insts method_ids mbind
+processInstBinds1 clas inst_tyvars avail_insts method_ids mbind
=
-- Find what class op is being defined here. The complication is
-- that we could have a PatMonoBind or a FunMonoBind. If the
tcAddSrcLoc locn $
-- Make a method id for the method
- let tag = panic "processInstBinds1:getTagFromClassOpName"{-getTagFromClassOpName op-}
+ let
+ tag = classOpTagByString clas occ
method_id = method_ids !! (tag-1)
method_ty = tcIdType method_id
import Bag ( bagToList )
import Class ( GenClass, GenClassOp, ClassInstEnv(..),
- getClassBigSig, getClassOps, getClassOpLocalType )
+ classBigSig, classOps, classOpLocalType )
import CoreSyn ( GenCoreExpr(..), mkValLam, mkTyApp )
import Id ( GenId, mkDictFunId, mkConstMethodId, mkSysLocal )
import MatchEnv ( nullMEnv, insertMEnv )
returnTc (dfun_id, dfun_theta, const_meth_ids)
where
- (class_tyvar, super_classes, _, class_ops, _, _) = getClassBigSig clas
+ (class_tyvar, super_classes, _, class_ops, _, _) = classBigSig clas
tenv = [(class_tyvar, inst_ty)]
super_class_theta = super_classes `zip` (repeat inst_ty)
from_here inst_mod id_info)
)
where
- op_ty = getClassOpLocalType op
+ op_ty = classOpLocalType op
meth_ty = mkForAllTys inst_tyvars (instantiateTy tenv op_ty)
{- LATER
inline_me = isIn "mkInstanceRelatedIds" op ops_to_inline
buildInstanceEnv inst_infos@((InstInfo clas _ _ _ _ _ _ _ _ _ _ _) : _)
= foldlTc addClassInstance
- (nullMEnv, [(op, nullSpecEnv) | op <- getClassOps clas])
+ (nullMEnv, [(op, nullSpecEnv) | op <- classOps clas])
inst_infos
`thenTc` \ (class_inst_env, op_inst_envs) ->
returnTc (clas, (class_inst_env,
Failed (tys', rhs') -> panic "TcInstDecls:add_const_meth"
Succeeded spec_env' -> spec_env' )
where
- (local_tyvars, _) = splitForAllTy (getClassOpLocalType op)
+ (local_tyvars, _) = splitForAllTy (classOpLocalType op)
local_tyvar_tys = mkTyVarTys local_tyvars
rhs = mkValLam [dict] (mkTyApp (mkTyApp (Var meth_id)
(mkTyVarTys inst_tyvars))
#include "HsVersions.h"
module TcModule (
- tcModule
+ typecheckModule,
+ TcResults(..),
+ TcResultBinds(..),
+ TcIfaceInfo(..),
+ TcLocalTyConsAndClasses(..),
+ TcSpecialiseRequests(..),
+ TcDDumpDeriv(..)
) where
-import Ubiq
+import Ubiq{-uitous-}
import HsSyn ( HsModule(..), HsBinds(..), Bind, HsExpr,
TyDecl, SpecDataSig, ClassDecl, InstDecl,
import Bag ( listToBag )
import Class ( GenClass )
+import ErrUtils ( Warning(..), Error(..) )
import Id ( GenId, isDataCon, isMethodSelId, idType )
import Maybes ( catMaybes )
import Name ( isExported, isLocallyDefined )
import Unique ( iOTyConKey, mainIdKey, mainPrimIOIdKey )
import Util
-
import FiniteMap ( emptyFM )
tycon_specs = emptyFM
-
-
\end{code}
+Outside-world interface:
\begin{code}
-tcModule :: RnEnv -- for renaming derivings
- -> RenamedHsModule -- input
- -> TcM s ((TypecheckedHsBinds, -- record selector binds
- TypecheckedHsBinds, -- binds from class decls; does NOT
- -- include default-methods bindings
- TypecheckedHsBinds, -- binds from instance decls; INCLUDES
- -- class default-methods binds
- TypecheckedHsBinds, -- binds from value decls
-
- [(Id, TypecheckedHsExpr)]), -- constant instance binds
-
- ([RenamedFixityDecl], [Id], [TyCon], [Class], Bag InstInfo),
- -- things for the interface generator
-
- ([TyCon], [Class]),
- -- environments of info from this module only
-
- FiniteMap TyCon [(Bool, [Maybe Type])],
- -- source tycon specialisation requests
+-- Convenient type synonyms first:
+type TcResults
+ = (TcResultBinds,
+ TcIfaceInfo,
+ TcLocalTyConsAndClasses,
+ TcSpecialiseRequests,
+ TcDDumpDeriv)
+
+type TcResultBinds
+ = (TypecheckedHsBinds, -- record selector binds
+ TypecheckedHsBinds, -- binds from class decls; does NOT
+ -- include default-methods bindings
+ TypecheckedHsBinds, -- binds from instance decls; INCLUDES
+ -- class default-methods binds
+ TypecheckedHsBinds, -- binds from value decls
+
+ [(Id, TypecheckedHsExpr)]) -- constant instance binds
+
+type TcIfaceInfo -- things for the interface generator
+ = ([Id], [TyCon], [Class], Bag InstInfo)
+
+type TcLocalTyConsAndClasses -- things defined in this module
+ = ([TyCon], [Class])
+ -- not sure the classes are used at all (ToDo)
+
+type TcSpecialiseRequests
+ = FiniteMap TyCon [(Bool, [Maybe Type])]
+ -- source tycon specialisation requests
+
+type TcDDumpDeriv
+ = PprStyle -> Pretty
+
+---------------
+typecheckModule
+ :: UniqSupply
+ -> RnEnv -- for renaming derivings
+ -> RenamedHsModule
+ -> MaybeErr
+ (TcResults, -- if all goes well...
+ Bag Warning) -- (we can still get warnings)
+ (Bag Error, -- if we had errors...
+ Bag Warning)
+
+typecheckModule us rn_env mod
+ = initTc us (tcModule rn_env mod)
+\end{code}
- PprStyle -> Pretty) -- -ddump-deriving info
+The internal monster:
+\begin{code}
+tcModule :: RnEnv -- for renaming derivings
+ -> RenamedHsModule -- input
+ -> TcM s TcResults -- output
tcModule rn_env
(HsModule mod_name verion exports imports fixities
(record_binds', cls_binds', inst_binds', val_binds', const_insts'),
-- the next collection is just for mkInterface
- (fixities, exported_ids', tycons, classes, inst_info),
+ (exported_ids', tycons, classes, inst_info),
(local_tycons, local_classes),
clas = lookupCE rec_ce c
super_clas = lookupCE rec_ce sc
in
- returnB_Tc (getSuperDictSelId clas super_clas)
+ returnB_Tc (classSuperDictSelId clas super_clas)
tc_uf_Id lve (ClassOpUfId c op_name)
= let
clas = lookupCE rec_ce c
op = lookup_class_op clas op_name
in
- returnB_Tc (getClassOpId clas op)
+ returnB_Tc (classOpId clas op)
tc_uf_Id lve (DefaultMethodUfId c op_name)
= let
clas = lookupCE rec_ce c
op = lookup_class_op clas op_name
in
- returnB_Tc (getDefaultMethodId clas op)
+ returnB_Tc (classDefaultMethodId clas op)
tc_uf_Id lve uf_id@(DictFunUfId c ty)
= tc_uf_type nullTVE ty `thenB_Tc` \ new_ty ->
---------------
lookup_class_op clas (ClassOpName _ _ _ tag)
- = getClassOps clas !! (tag - 1)
+ = classOps clas !! (tag - 1)
---------------------------------------------------------------------
tc_uf_type :: TVE -> UnfoldingType Name -> Baby_TcM Type
import Bag ( Bag, unitBag, listToBag, foldBag, filterBag, emptyBag, bagToList,
snocBag, consBag, unionBags, isEmptyBag )
import Class ( isNumericClass, isStandardClass, isCcallishClass,
- isSuperClassOf, getSuperDictSelId )
+ isSuperClassOf, classSuperDictSelId
+ )
import Id ( GenId )
import Maybes ( expectJust, firstJust, catMaybes, seqMaybe, maybeToBool, Maybe(..) )
import Outputable ( Outputable(..){-instance * []-} )
-import PprType ( GenType, GenTyVar )
+import PprStyle--ToDo:rm
+import PprType ( GenType, GenTyVar, GenClass{-instance Outputable;ToDo:rm-} )
import Pretty
import SrcLoc ( mkUnknownSrcLoc )
import Util
-> [(Class, TauType)] -- Simplify this
-> TcM s ()
-tcSimplifyCheckThetas = panic "tcSimplifyCheckThetas"
+tcSimplifyCheckThetas x y = _trace "tcSimplifyCheckThetas: does nothing" $
+ returnTc ()
{- LATER
tcSimplifyCheckThetas origin theta
let
mk_bind (dict,clas) dict_sub@(Dict _ dict_sub_class ty _ _)
= ((dict_sub, dict_sub_class),
- (instToId dict, DictApp (TyApp (HsVar (RealId (getSuperDictSelId dict_sub_class
+ (instToId dict, DictApp (TyApp (HsVar (RealId (classSuperDictSelId dict_sub_class
clas)))
[ty])
[instToId dict_sub]))
isStandardNumericDefaultable :: [Class] -> Bool
isStandardNumericDefaultable classes
- | any isNumericClass classes && all isStandardClass classes
- = True
-
-isStandardNumericDefaultable classes
- | all isCcallishClass classes
- = True
-
-isStandardNumericDefaultable classes
- = False
+ = --pprTrace "isStdNumeric:\n" (ppAboves [ppCat (map (ppr PprDebug) classes), ppCat (map (ppr PprDebug . isNumericClass) classes), ppCat (map (ppr PprDebug . isStandardClass) classes), ppCat (map (ppr PprDebug . isCcallishClass) classes)]) $
+ (any isNumericClass classes && all isStandardClass classes)
+ || (all isCcallishClass classes)
\end{code}
import TcTyDecls ( tcTyDecl, mkDataBinds )
import Bag
-import Class ( Class(..), getClassSelIds )
+import Class ( Class(..), classSelIds )
import Digraph ( findSCCs, SCC(..) )
import Name ( getSrcLoc )
import PprStyle
tcSetEnv final_env $
tcExtendGlobalValEnv (concat data_ids_s) $
- tcExtendGlobalValEnv (concat (map getClassSelIds classes)) $
+ tcExtendGlobalValEnv (concat (map classSelIds classes)) $
tcGetEnv `thenNF_Tc` \ really_final_env ->
returnTc (really_final_env, foldr ThenBinds EmptyBinds binds)
get_con (RecConDecl _ nbtys _)
= unionManyUniqSets (map (get_bty.snd) nbtys)
- get_bty (Banged ty) = get_ty ty
- get_bty (Unbanged ty) = get_ty ty
+ get_bty (Banged ty) = get_pty ty
+ get_bty (Unbanged ty) = get_pty ty
get_ty (MonoTyVar tv)
= emptyUniqSet
TcHsBinds(..), TcIdOcc(..)
)
import Inst ( newDicts, InstOrigin(..), Inst )
-import TcMonoType ( tcMonoTypeKind, tcMonoType, tcContext )
+import TcMonoType ( tcMonoTypeKind, tcMonoType, tcPolyType, tcContext )
import TcType ( tcInstTyVars, tcInstType, tcInstId )
import TcEnv ( tcLookupTyCon, tcLookupTyVar, tcLookupClass,
newLocalId, newLocalIds
returnTc data_con
tcField (field_label_names, bty)
- = tcMonoType (get_ty bty) `thenTc` \ field_ty ->
+ = tcPolyType (get_pty bty) `thenTc` \ field_ty ->
returnTc [(name, field_ty, get_strictness bty) | name <- field_label_names]
tcDataCon tycon tyvars ctxt name btys src_loc
= tcAddSrcLoc src_loc $
let
stricts = map get_strictness btys
- tys = map get_ty btys
+ tys = map get_pty btys
in
- mapTc tcMonoType tys `thenTc` \ arg_tys ->
+ mapTc tcPolyType tys `thenTc` \ arg_tys ->
let
data_con = mkDataCon (getName name)
stricts
arg_tyvars = tyVarsOfTypes arg_tys
in_arg_tys (clas,ty) = getTyVar "tcDataCon" ty `elementOfTyVarSet` arg_tyvars
-get_strictness (Banged ty) = MarkedStrict
-get_strictness (Unbanged ty) = NotMarkedStrict
+get_strictness (Banged _) = MarkedStrict
+get_strictness (Unbanged _) = NotMarkedStrict
-get_ty (Banged ty) = ty
-get_ty (Unbanged ty) = ty
+get_pty (Banged ty) = ty
+get_pty (Unbanged ty) = ty
\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
-%
-\section[Typecheck]{Outside-world interfaces to the typechecker}
-
-\begin{code}
-#include "HsVersions.h"
-
-module Typecheck (
- typecheckModule, InstInfo
- ) where
-
-import Ubiq
-import TcMonad
-import TcModule ( tcModule )
-import TcInstUtil ( InstInfo )
-
-import HsSyn
-import RnHsSyn
-import TcHsSyn
-
-import ErrUtils ( Warning(..), Error(..) )
-import Pretty
-import RnUtils ( RnEnv(..) )
-import Maybes ( MaybeErr(..) )
-\end{code}
-
-The typechecker stuff lives inside a complicated world of @TcM@
-monadery.
-
-ToDo: Interfaces for interpreter ...
- Typecheck an expression
- Typecheck an interface
-
-\begin{code}
-typecheckModule
- :: UniqSupply -- name supply in
- -> RnEnv -- renamer env (for doing derivings)
- -> RenamedHsModule -- input module
-
- -> -- OUTPUTS ...
- MaybeErr
- -- SUCCESS ...
- (((TypecheckedHsBinds, -- record selector definitions
- TypecheckedHsBinds, -- binds from class decls; does NOT
- -- include default-methods bindings
- TypecheckedHsBinds, -- binds from instance decls; INCLUDES
- -- class default-methods binds
- TypecheckedHsBinds, -- binds from value decls
-
- [(Id, TypecheckedHsExpr)] -- constant instance binds
- ),
-
- ([RenamedFixityDecl], [Id], [TyCon], [Class], Bag InstInfo),
- -- things for the interface generator
-
- ([TyCon], [Class]),
- -- environments of info from this module only
-
- FiniteMap TyCon [(Bool, [Maybe Type])],
- -- source tycon specialisation requests
-
- PprStyle->Pretty), -- stuff to print for -ddump-deriving
-
- Bag Warning) -- pretty-print this to get warnings
-
- -- FAILURE ...
- (Bag Error, -- pretty-print this to get errors
- Bag Warning) -- pretty-print this to get warnings
-
-typecheckModule us rn_env mod
- = initTc us (tcModule rn_env mod)
-\end{code}
GenClass(..), Class(..),
mkClass,
- getClassKey, getClassOps, getClassSelIds,
- getSuperDictSelId, getClassOpId, getDefaultMethodId,
- getClassSig, getClassBigSig, getClassInstEnv,
+ classKey, classOps, classSelIds,
+ classSuperDictSelId, classOpId, classDefaultMethodId,
+ classSig, classBigSig, classInstEnv,
isSuperClassOf,
+ classOpTagByString,
derivableClassKeys, cCallishClassKeys,
isNumericClass, isStandardClass, isCcallishClass,
GenClassOp(..), ClassOp(..),
mkClassOp,
- getClassOpTag, getClassOpString,
- getClassOpLocalType,
+ classOpTag, classOpString,
+ classOpLocalType,
ClassInstEnv(..)
-
- -- and to make the interface self-sufficient...
) where
CHK_Ubiq() -- debugging consistency check
import Usage ( GenUsage, Usage(..), UVar(..) )
import Maybes ( assocMaybe, Maybe )
---import Name ( Name )
import Unique -- Keys for built-in classes
---import Outputable ( Outputable(..), NamedThing(..), ExportFlag )
-import Pretty ( Pretty(..), PrettyRep )
+import Pretty ( Pretty(..), ppCat{-ToDo:rm-}, ppPStr{-ditto-} )
import PprStyle ( PprStyle )
import SrcLoc ( SrcLoc )
import Util
The rest of these functions are just simple selectors.
\begin{code}
-getClassKey (Class key _ _ _ _ _ _ _ _ _) = key
-getClassOps (Class _ _ _ _ _ ops _ _ _ _) = ops
-getClassSelIds (Class _ _ _ _ _ _ sels _ _ _) = sels
-
-getClassOpId (Class _ _ _ _ _ ops op_ids _ _ _) op
- = op_ids !! (getClassOpTag op - 1)
-getDefaultMethodId (Class _ _ _ _ _ ops _ defm_ids _ _) op
- = defm_ids !! (getClassOpTag op - 1)
-getSuperDictSelId (Class _ _ _ scs scsel_ids _ _ _ _ _) super_clas
- = assoc "getSuperDictSelId" (scs `zip` scsel_ids) super_clas
-
-getClassSig :: GenClass t u -> (t, [GenClass t u], [GenClassOp (GenType t u)])
-getClassSig (Class _ _ tyvar super_classes _ ops _ _ _ _)
+classKey (Class key _ _ _ _ _ _ _ _ _) = key
+classOps (Class _ _ _ _ _ ops _ _ _ _) = ops
+classSelIds (Class _ _ _ _ _ _ sels _ _ _) = sels
+
+classOpId (Class _ _ _ _ _ ops op_ids _ _ _) op
+ = op_ids !! (classOpTag op - 1)
+classDefaultMethodId (Class _ _ _ _ _ ops _ defm_ids _ _) op
+ = defm_ids !! (classOpTag op - 1)
+classSuperDictSelId (Class _ _ _ scs scsel_ids _ _ _ _ _) super_clas
+ = assoc "classSuperDictSelId" (scs `zip` scsel_ids) super_clas
+
+classSig :: GenClass t u -> (t, [GenClass t u], [GenClassOp (GenType t u)])
+classSig (Class _ _ tyvar super_classes _ ops _ _ _ _)
= (tyvar, super_classes, ops)
-getClassBigSig (Class _ _ tyvar super_classes sdsels ops sels defms _ _)
+classBigSig (Class _ _ tyvar super_classes sdsels ops sels defms _ _)
= (tyvar, super_classes, sdsels, ops, sels, defms)
-getClassInstEnv (Class _ _ _ _ _ _ _ _ inst_env _) = inst_env
+classInstEnv (Class _ _ _ _ _ _ _ _ inst_env _) = inst_env
\end{code}
@a `isSuperClassOf` b@ returns @Nothing@ if @a@ is not a superclass of
\begin{code}
isNumericClass, isStandardClass :: Class -> Bool
-isNumericClass (Class key _ _ _ _ _ _ _ _ _) = key `is_elem` numericClassKeys
+isNumericClass (Class key _ _ _ _ _ _ _ _ _) = --pprTrace "isNum:" (ppCat (map pprUnique (key : numericClassKeys ))) $
+ key `is_elem` numericClassKeys
isStandardClass (Class key _ _ _ _ _ _ _ _ _) = key `is_elem` standardClassKeys
isCcallishClass (Class key _ _ _ _ _ _ _ _ _) = key `is_elem` cCallishClassKeys
is_elem = isIn "is_X_Class"
mkClassOp :: FAST_STRING -> Int -> ty -> GenClassOp ty
mkClassOp name tag ty = ClassOp name tag ty
-getClassOpTag :: GenClassOp ty -> Int
-getClassOpTag (ClassOp _ tag _) = tag
+classOpTag :: GenClassOp ty -> Int
+classOpTag (ClassOp _ tag _) = tag
+
+classOpString :: GenClassOp ty -> FAST_STRING
+classOpString (ClassOp str _ _) = str
+
+classOpLocalType :: GenClassOp ty -> ty {-SigmaType-}
+classOpLocalType (ClassOp _ _ ty) = ty
+\end{code}
-getClassOpString :: GenClassOp ty -> FAST_STRING
-getClassOpString (ClassOp str _ _) = str
+Rather unsavoury ways of getting ClassOp tags:
+\begin{code}
+classOpTagByString :: Class -> FAST_STRING -> Int
-getClassOpLocalType :: GenClassOp ty -> ty {-SigmaType-}
-getClassOpLocalType (ClassOp _ _ ty) = ty
+classOpTagByString clas op
+ = go (map classOpString (classOps clas)) 1
+ where
+ go (n:ns) tag = if n == op
+ then tag
+ else go ns (tag+1)
+#ifdef DEBUG
+ go [] tag = pprPanic "classOpTagByString:" (ppCat (ppPStr op : map (ppPStr . classOpString) (classOps clas)))
+#endif
\end{code}
%************************************************************************
-- isDataTyCon returns False for @newtype@.
-- Not sure about this decision yet.
isDataTyCon (DataTyCon _ _ _ _ _ _ _ DataType) = True
+isDataTyCon (TupleTyCon _ _ _) = True
isDataTyCon other = False
isSynTyCon (SynTyCon _ _ _ _ _ _) = True
\begin{code}
tyConDerivings :: TyCon -> [Class]
tyConDerivings (DataTyCon _ _ _ _ _ _ derivs _) = derivs
-tyConDerivings other = []
+tyConDerivings other = []
\end{code}
\begin{code}
_tagCmp a b = case (a `cmp` b) of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
instance Uniquable TyCon where
- uniqueOf (DataTyCon u _ _ _ _ _ _ _) = u
- uniqueOf (PrimTyCon u _ _) = u
- uniqueOf (SynTyCon u _ _ _ _ _) = u
- uniqueOf tc@(SpecTyCon _ _) = panic "uniqueOf:SpecTyCon"
- uniqueOf tc = uniqueOf (getName tc)
+ uniqueOf (DataTyCon u _ _ _ _ _ _ _) = u
+ uniqueOf (TupleTyCon u _ _) = u
+ uniqueOf (PrimTyCon u _ _) = u
+ uniqueOf (SynTyCon u _ _ _ _ _) = u
+ uniqueOf tc@(SpecTyCon _ _) = panic "uniqueOf:SpecTyCon"
+ uniqueOf tc = uniqueOf (getName tc)
\end{code}
\begin{code}
--import Util ( pprPanic )
-- friends:
-import Class ( getClassSig, getClassOpLocalType, GenClass{-instances-} )
+import Class ( classSig, classOpLocalType, GenClass{-instances-} )
import Kind ( mkBoxedTypeKind, resultKind )
import TyCon ( mkFunTyCon, mkTupleTyCon, isFunTyCon, isPrimTyCon, isDataTyCon, isSynTyCon, tyConArity,
tyConKind, tyConDataCons, getSynTyConDefn, TyCon )
-- CCallable, CReturnable (and anything else
-- *really weird* that the user writes).
where
- (tyvar, super_classes, ops) = getClassSig clas
+ (tyvar, super_classes, ops) = classSig clas
super_dict_tys = map mk_super_ty super_classes
class_op_tys = map mk_op_ty ops
all_arg_tys = super_dict_tys ++ class_op_tys
mk_super_ty sc = DictTy sc ty usageOmega
- mk_op_ty op = instantiateTy [(tyvar,ty)] (getClassOpLocalType op)
+ mk_op_ty op = instantiateTy [(tyvar,ty)] (classOpLocalType op)
expandTy ty = ty
\end{code}
projects / ghc-hetmet.git / commitdiff