Commit a7b95beb authored by simonpj's avatar simonpj

[project @ 2002-04-11 12:03:29 by simonpj]

-------------------
	Mainly derived Read
	-------------------

This commit is a tangle of several things that somehow got wound up
together, I'm afraid.


The main course
~~~~~~~~~~~~~~~
Replace the derived-Read machinery with Koen's cunning new parser
combinator library.   The result should be
	* much smaller code sizes from derived Read
	* faster execution of derived Read

WARNING: I have not thoroughly tested this stuff; I'd be glad if you did!
	 All the hard work is done, but there may be a few nits.

The Read class gets two new methods, not exposed
in the H98 inteface of course:
  class Read a where
    readsPrec    :: Int -> ReadS a
    readList     :: ReadS [a]
    readPrec     :: ReadPrec a		-- NEW
    readListPrec :: ReadPrec [a]	-- NEW

There are the following new libraries:

  Text.ParserCombinators.ReadP		Koens combinator parser
  Text.ParserCombinators.ReadPrec	Ditto, but with precedences

  Text.Read.Lex				An emasculated lexical analyser
					that provides the functionality
					of H98 'lex'

TcGenDeriv is changed to generate code that uses the new libraries.
The built-in instances of Read (List, Maybe, tuples, etc) use the new
libraries.


Other stuff
~~~~~~~~~~~
1. Some fixes the the plumbing of external-core generation. Sigbjorn
did most of the work earlier, but this commit completes the renaming and
typechecking plumbing.

2. Runtime error-generation functions, such as GHC.Err.recSelErr,
GHC.Err.recUpdErr, etc, now take an Addr#, pointing to a UTF8-encoded
C string, instead of a Haskell string.  This makes the *calls* to these
functions easier to generate, and smaller too, which is a good thing.

In particular, it means that MkId.mkRecordSelectorId doesn't need to
be passed "unpackCStringId", which was GRUESOME; and that in turn means
that tcTypeAndClassDecls doesn't need to be passed unf_env, which is
a very worthwhile cleanup.   Win/win situation.

3.  GHC now faithfully translates do-notation using ">>" for statements
with no binding, just as the report says.  While I was there I tidied
up HsDo to take a list of Ids instead of 3 (but now 4) separate Ids.
Saves a bit of code here and there.  Also introduced Inst.newMethodFromName
to package a common idiom.
parent 9c73e25f
......@@ -25,10 +25,11 @@ module MkId (
-- And some particular Ids; see below for why they are wired in
wiredInIds, ghcPrimIds,
unsafeCoerceId, realWorldPrimId, voidArgId, nullAddrId, seqId,
eRROR_ID, eRROR_CSTRING_ID, rEC_SEL_ERROR_ID, pAT_ERROR_ID,
rEC_CON_ERROR_ID, rEC_UPD_ERROR_ID, iRREFUT_PAT_ERROR_ID,
mkRuntimeErrorApp,
rEC_CON_ERROR_ID, iRREFUT_PAT_ERROR_ID, rUNTIME_ERROR_ID,
nON_EXHAUSTIVE_GUARDS_ERROR_ID, nO_METHOD_BINDING_ERROR_ID,
aBSENT_ERROR_ID, pAR_ERROR_ID
pAT_ERROR_ID
) where
#include "HsVersions.h"
......@@ -115,16 +116,12 @@ wiredInIds
-- error-reporting functions that they have an 'open'
-- result type. -- sof 1/99]
aBSENT_ERROR_ID,
eRROR_ID,
eRROR_CSTRING_ID,
rUNTIME_ERROR_ID,
iRREFUT_PAT_ERROR_ID,
nON_EXHAUSTIVE_GUARDS_ERROR_ID,
nO_METHOD_BINDING_ERROR_ID,
pAR_ERROR_ID,
pAT_ERROR_ID,
rEC_CON_ERROR_ID,
rEC_UPD_ERROR_ID
rEC_CON_ERROR_ID
] ++ ghcPrimIds
-- These Ids are exported from GHC.Prim
......@@ -390,7 +387,7 @@ Similarly for newtypes
unN = /\a -> \n:N -> coerce (a->a) n
\begin{code}
mkRecordSelId tycon field_label unpack_id unpackUtf8_id
mkRecordSelId tycon field_label
-- Assumes that all fields with the same field label have the same type
--
-- Annoyingly, we have to pass in the unpackCString# Id, because
......@@ -512,17 +509,7 @@ mkRecordSelId tycon field_label unpack_id unpackUtf8_id
maybe_the_arg_id = assocMaybe (field_lbls `zip` arg_ids) field_label
field_lbls = dataConFieldLabels data_con
error_expr = mkApps (Var rEC_SEL_ERROR_ID) [Type field_tau, err_string]
err_string
| all safeChar full_msg
= App (Var unpack_id) (Lit (MachStr (_PK_ full_msg)))
| otherwise
= App (Var unpackUtf8_id) (Lit (MachStr (_PK_ (stringToUtf8 (map ord full_msg)))))
where
safeChar c = c >= '\1' && c <= '\xFF'
-- TODO: Putting this Unicode stuff here is ugly. Find a better
-- generic place to make string literals. This logic is repeated
-- in DsUtils.
error_expr = mkRuntimeErrorApp rEC_SEL_ERROR_ID field_tau full_msg
full_msg = showSDoc (sep [text "No match in record selector", ppr sel_id])
......@@ -911,33 +898,30 @@ not know to be a bottoming Id. It is used in the @_par_@ and @_seq_@
templates, but we don't ever expect to generate code for it.
\begin{code}
eRROR_ID
= pc_bottoming_Id errorIdKey pREL_ERR FSLIT("error") errorTy
eRROR_CSTRING_ID
= pc_bottoming_Id errorCStringIdKey pREL_ERR FSLIT("errorCString")
(mkSigmaTy [openAlphaTyVar] [] (mkFunTy addrPrimTy openAlphaTy))
pAT_ERROR_ID
= generic_ERROR_ID patErrorIdKey FSLIT("patError")
rEC_SEL_ERROR_ID
= generic_ERROR_ID recSelErrIdKey FSLIT("recSelError")
rEC_CON_ERROR_ID
= generic_ERROR_ID recConErrorIdKey FSLIT("recConError")
rEC_UPD_ERROR_ID
= generic_ERROR_ID recUpdErrorIdKey FSLIT("recUpdError")
iRREFUT_PAT_ERROR_ID
= generic_ERROR_ID irrefutPatErrorIdKey FSLIT("irrefutPatError")
nON_EXHAUSTIVE_GUARDS_ERROR_ID
= generic_ERROR_ID nonExhaustiveGuardsErrorIdKey FSLIT("nonExhaustiveGuardsError")
nO_METHOD_BINDING_ERROR_ID
= generic_ERROR_ID noMethodBindingErrorIdKey FSLIT("noMethodBindingError")
aBSENT_ERROR_ID
= pc_bottoming_Id absentErrorIdKey pREL_ERR FSLIT("absentErr")
(mkSigmaTy [openAlphaTyVar] [] openAlphaTy)
pAR_ERROR_ID
= pcMiscPrelId parErrorIdKey pREL_ERR FSLIT("parError")
(mkSigmaTy [openAlphaTyVar] [] openAlphaTy) noCafNoTyGenIdInfo
mkRuntimeErrorApp
:: Id -- Should be of type (forall a. Addr# -> a)
-- where Addr# points to a UTF8 encoded string
-> Type -- The type to instantiate 'a'
-> String -- The string to print
-> CoreExpr
mkRuntimeErrorApp err_id res_ty err_msg
= mkApps (Var err_id) [Type res_ty, err_string]
where
err_string = Lit (MachStr (_PK_ (stringToUtf8 err_msg)))
rEC_SEL_ERROR_ID = mkRuntimeErrorId recSelErrIdKey FSLIT("recSelError")
rUNTIME_ERROR_ID = mkRuntimeErrorId runtimeErrorIdKey FSLIT("runtimeError")
iRREFUT_PAT_ERROR_ID = mkRuntimeErrorId irrefutPatErrorIdKey FSLIT("irrefutPatError")
rEC_CON_ERROR_ID = mkRuntimeErrorId recConErrorIdKey FSLIT("recConError")
nON_EXHAUSTIVE_GUARDS_ERROR_ID = mkRuntimeErrorId nonExhaustiveGuardsErrorIdKey FSLIT("nonExhaustiveGuardsError")
pAT_ERROR_ID = mkRuntimeErrorId patErrorIdKey FSLIT("patError")
nO_METHOD_BINDING_ERROR_ID = mkRuntimeErrorId noMethodBindingErrorIdKey FSLIT("noMethodBindingError")
-- The runtime error Ids take a UTF8-encoded string as argument
mkRuntimeErrorId key name = pc_bottoming_Id key pREL_ERR name runtimeErrorTy
runtimeErrorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTy addrPrimTy openAlphaTy)
\end{code}
......
......@@ -6,7 +6,7 @@
\begin{code}
module CoreUtils (
-- Construction
mkNote, mkInlineMe, mkSCC, mkCoerce,
mkNote, mkInlineMe, mkSCC, mkCoerce, mkCoerce2,
bindNonRec, needsCaseBinding,
mkIfThenElse, mkAltExpr, mkPiType, mkPiTypes,
......@@ -152,7 +152,7 @@ mkNote removes redundant coercions, and SCCs where possible
\begin{code}
mkNote :: Note -> CoreExpr -> CoreExpr
mkNote (Coerce to_ty from_ty) expr = mkCoerce to_ty from_ty expr
mkNote (Coerce to_ty from_ty) expr = mkCoerce2 to_ty from_ty expr
mkNote (SCC cc) expr = mkSCC cc expr
mkNote InlineMe expr = mkInlineMe expr
mkNote note expr = Note note expr
......@@ -193,13 +193,15 @@ mkInlineMe e = Note InlineMe e
\begin{code}
mkCoerce :: Type -> Type -> CoreExpr -> CoreExpr
mkCoerce :: Type -> CoreExpr -> CoreExpr
mkCoerce to_ty expr = mkCoerce2 to_ty (exprType expr) expr
mkCoerce to_ty from_ty (Note (Coerce to_ty2 from_ty2) expr)
mkCoerce2 :: Type -> Type -> CoreExpr -> CoreExpr
mkCoerce2 to_ty from_ty (Note (Coerce to_ty2 from_ty2) expr)
= ASSERT( from_ty `eqType` to_ty2 )
mkCoerce to_ty from_ty2 expr
mkCoerce2 to_ty from_ty2 expr
mkCoerce to_ty from_ty expr
mkCoerce2 to_ty from_ty expr
| to_ty `eqType` from_ty = expr
| otherwise = ASSERT( from_ty `eqType` exprType expr )
Note (Coerce to_ty from_ty) expr
......@@ -629,7 +631,7 @@ exprIsConApp_maybe (Note (Coerce to_ty from_ty) expr)
arity = tyConArity tc
val_args = drop arity args
to_arg_tys = dataConArgTys dc tc_arg_tys
mk_coerce ty arg = mkCoerce ty (exprType arg) arg
mk_coerce ty arg = mkCoerce ty arg
new_val_args = zipWith mk_coerce to_arg_tys val_args
in
ASSERT( all isTypeArg (take arity args) )
......@@ -869,7 +871,7 @@ eta_expand n us expr ty
; Nothing ->
case splitNewType_maybe ty of {
Just ty' -> mkCoerce ty ty' (eta_expand n us (mkCoerce ty' ty expr) ty') ;
Just ty' -> mkCoerce2 ty ty' (eta_expand n us (mkCoerce2 ty' ty expr) ty') ;
Nothing -> pprTrace "Bad eta expand" (ppr expr $$ ppr ty) expr
}}}
\end{code}
......
......@@ -72,7 +72,7 @@ collect_tdefs _ tdefs = tdefs
make_cdef :: DataCon -> C.Cdef
make_cdef dcon = C.Constr dcon_name existentials tys
where
dcon_name = make_con_qid (idName (dataConWorkId dcon))
dcon_name = make_con_qid (dataConName dcon)
existentials = map make_tbind ex_tyvars
ex_tyvars = dataConExistentialTyVars dcon
tys = map make_ty (dataConRepArgTys dcon)
......@@ -93,7 +93,8 @@ make_vdef b =
make_exp :: CoreExpr -> C.Exp
make_exp (Var v) =
case globalIdDetails v of
DataConId _ -> C.Dcon (make_con_qid (Var.varName v))
-- a DataConId represents the Id of a worker, which is a varName. -- sof 4/02
-- DataConId _ -> C.Dcon (make_con_qid (Var.varName v))
FCallId (CCall (CCallSpec (StaticTarget nm) _ _)) -> C.External (_UNPK_ nm) (make_ty (varType v))
FCallId _ -> error "MkExternalCore died: can't handle non-static-C foreign call"
_ -> C.Var (make_var_qid (Var.varName v))
......@@ -113,7 +114,10 @@ make_exp _ = error "MkExternalCore died: make_exp"
make_alt :: CoreAlt -> C.Alt
make_alt (DataAlt dcon, vs, e) =
C.Acon (make_con_qid (idName (dataConWorkId dcon))) (map make_tbind tbs) (map make_vbind vbs) (make_exp e)
C.Acon (make_con_qid (dataConName dcon))
(map make_tbind tbs)
(map make_vbind vbs)
(make_exp e)
where (tbs,vbs) = span isTyVar vs
make_alt (LitAlt l,_,e) = C.Alit (make_lit l) (make_exp e)
make_alt (DEFAULT,[],e) = C.Adefault (make_exp e)
......@@ -157,6 +161,9 @@ make_kind _ = error "MkExternalCore died: make_kind"
{- Use encoded strings.
Also, adjust casing to work around some badly-chosen internal names. -}
make_id :: Bool -> Name -> C.Id
make_id is_var nm = (occNameString . nameOccName) nm
{- SIMON thinks this stuff isn't necessary
make_id is_var nm =
case n of
'Z':cs | is_var -> 'z':cs
......@@ -165,6 +172,7 @@ make_id is_var nm =
c:cs | isLower c && (not is_var) -> 'Z':'d':n
_ -> n
where n = (occNameString . nameOccName) nm
-}
make_var_id :: Name -> C.Id
make_var_id = make_id True
......
......@@ -60,7 +60,6 @@ deSugar dflags pcs hst mod_name unqual
tc_binds = all_binds,
tc_insts = insts,
tc_rules = rules,
-- tc_cbinds = core_binds,
tc_fords = fo_decls})
= do { showPass dflags "Desugar"
; us <- mkSplitUniqSupply 'd'
......@@ -71,12 +70,6 @@ deSugar dflags pcs hst mod_name unqual
(ds_binds, ds_rules, foreign_stuff) = ds_result
{-
addCoreBinds ls =
case core_binds of
[] -> ls
cs -> (Rec cs) : ls
-}
mod_details = ModDetails { md_types = type_env,
md_insts = insts,
md_rules = ds_rules,
......@@ -165,20 +158,19 @@ ppr_ds_rules rules
Simplest thing in the world, desugaring External Core:
\begin{code}
deSugarCore :: TypeEnv -> [TypecheckedCoreBind]
deSugarCore :: (TypeEnv, [TypecheckedCoreBind], [TypecheckedRuleDecl])
-> IO (ModDetails, (SDoc, SDoc, [FAST_STRING], [CoreBndr]))
deSugarCore type_env cs = do
let
mod_details
= ModDetails { md_types = type_env
, md_insts = []
, md_rules = []
, md_binds = [Rec (map (\ (lhs,_,rhs) -> (lhs,rhs)) cs)]
}
deSugarCore (type_env, pairs, rules)
= return (mod_details, no_foreign_stuff)
where
mod_details = ModDetails { md_types = type_env
, md_insts = []
, md_rules = ds_rules
, md_binds = ds_binds }
ds_binds = [Rec pairs]
ds_rules = [(fun,rule) | IfaceRuleOut fun rule <- rules]
no_foreign_stuff = (empty,empty,[],[])
return (mod_details, no_foreign_stuff)
\end{code}
......
......@@ -18,7 +18,7 @@ import CoreSyn
import DsMonad
import CoreUtils ( exprType, mkCoerce )
import CoreUtils ( exprType, mkCoerce2 )
import Id ( Id, mkWildId, idType )
import MkId ( mkFCallId, realWorldPrimId, mkPrimOpId )
import Maybes ( maybeToBool )
......@@ -150,7 +150,7 @@ unboxArg arg
-- Recursive newtypes
| Just rep_ty <- splitNewType_maybe arg_ty
= unboxArg (mkCoerce rep_ty arg_ty arg)
= unboxArg (mkCoerce2 rep_ty arg_ty arg)
-- Booleans
| Just (tc,_) <- splitTyConApp_maybe arg_ty,
......@@ -328,7 +328,7 @@ resultWrapper result_ty
= let
(maybe_ty, wrapper) = resultWrapper rep_ty
in
(maybe_ty, \e -> mkCoerce result_ty rep_ty (wrapper e))
(maybe_ty, \e -> mkCoerce2 result_ty rep_ty (wrapper e))
-- Data types with a single constructor, which has a single arg
| Just (tycon, tycon_arg_tys, data_con, data_con_arg_tys) <- splitProductType_maybe result_ty,
......
......@@ -265,18 +265,18 @@ dsExpr (HsWith expr binds is_with)
-- 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 (HsDoOut ListComp stmts return_id then_id fail_id result_ty src_loc)
dsExpr (HsDoOut ListComp stmts _ result_ty src_loc)
= -- Special case for list comprehensions
putSrcLocDs src_loc $
dsListComp stmts elt_ty
where
(_, [elt_ty]) = tcSplitTyConApp result_ty
dsExpr (HsDoOut DoExpr stmts return_id then_id fail_id result_ty src_loc)
dsExpr (HsDoOut DoExpr stmts ids result_ty src_loc)
= putSrcLocDs src_loc $
dsDo DoExpr stmts return_id then_id fail_id result_ty
dsDo DoExpr stmts ids result_ty
dsExpr (HsDoOut PArrComp stmts return_id then_id fail_id result_ty src_loc)
dsExpr (HsDoOut PArrComp stmts _ result_ty src_loc)
= -- Special case for array comprehensions
putSrcLocDs src_loc $
dsPArrComp stmts elt_ty
......@@ -556,13 +556,11 @@ Basically does the translation given in the Haskell~1.3 report:
\begin{code}
dsDo :: HsDoContext
-> [TypecheckedStmt]
-> Id -- id for: return m
-> Id -- id for: (>>=) m
-> Id -- id for: fail m
-> [Id] -- id for: [return,fail,>>=,>>]
-> Type -- Element type; the whole expression has type (m t)
-> DsM CoreExpr
dsDo do_or_lc stmts return_id then_id fail_id result_ty
dsDo do_or_lc stmts ids@[return_id, fail_id, bind_id, then_id] result_ty
= let
(_, b_ty) = tcSplitAppTy result_ty -- result_ty must be of the form (m b)
is_do = case do_or_lc of
......@@ -583,9 +581,7 @@ dsDo do_or_lc stmts return_id then_id fail_id result_ty
| is_do -- Do expression
= do_expr expr locn `thenDs` \ expr2 ->
go stmts `thenDs` \ rest ->
newSysLocalDs a_ty `thenDs` \ ignored_result_id ->
returnDs (mkApps (Var then_id) [Type a_ty, Type b_ty, expr2,
Lam ignored_result_id rest])
returnDs (mkApps (Var then_id) [Type a_ty, Type b_ty, expr2, rest])
| otherwise -- List comprehension
= do_expr expr locn `thenDs` \ expr2 ->
......@@ -610,8 +606,7 @@ dsDo do_or_lc stmts return_id then_id fail_id result_ty
(HsLit (HsString (_PK_ msg)))
msg = "Pattern match failure in do expression, " ++ showSDoc (ppr locn)
main_match = mkSimpleMatch [pat]
(HsDoOut do_or_lc stmts return_id then_id
fail_id result_ty locn)
(HsDoOut do_or_lc stmts ids result_ty locn)
result_ty locn
the_matches
| failureFreePat pat = [main_match]
......@@ -621,7 +616,7 @@ dsDo do_or_lc stmts return_id then_id fail_id result_ty
]
in
matchWrapper (DoCtxt do_or_lc) the_matches `thenDs` \ (binders, matching_code) ->
returnDs (mkApps (Var then_id) [Type a_ty, Type b_ty, expr2,
returnDs (mkApps (Var bind_id) [Type a_ty, Type b_ty, expr2,
mkLams binders matching_code])
in
go stmts
......
......@@ -38,7 +38,7 @@ import CoreSyn
import DsMonad
import CoreUtils ( exprType, mkIfThenElse )
import CoreUtils ( exprType, mkIfThenElse, mkCoerce )
import PrelInfo ( iRREFUT_PAT_ERROR_ID )
import MkId ( mkReboxingAlt, mkNewTypeBody )
import Id ( idType, Id, mkWildId )
......@@ -62,7 +62,7 @@ import PrelNames ( unpackCStringName, unpackCStringUtf8Name,
plusIntegerName, timesIntegerName,
lengthPName, indexPName )
import Outputable
import UnicodeUtil ( stringToUtf8 )
import UnicodeUtil ( intsToUtf8, stringToUtf8 )
import Util ( isSingleton, notNull )
\end{code}
......@@ -389,8 +389,8 @@ mkErrorAppDs err_id ty msg
= getSrcLocDs `thenDs` \ src_loc ->
let
full_msg = showSDoc (hcat [ppr src_loc, text "|", text msg])
core_msg = Lit (MachStr (_PK_ (stringToUtf8 full_msg)))
in
mkStringLit full_msg `thenDs` \ core_msg ->
returnDs (mkApps (Var err_id) [Type ty, core_msg])
\end{code}
......@@ -447,16 +447,16 @@ mkStringLitFS str
in
returnDs (mkConsExpr charTy the_char (mkNilExpr charTy))
| all safeChar chars
| all safeChar int_chars
= dsLookupGlobalValue unpackCStringName `thenDs` \ unpack_id ->
returnDs (App (Var unpack_id) (Lit (MachStr str)))
| otherwise
= dsLookupGlobalValue unpackCStringUtf8Name `thenDs` \ unpack_id ->
returnDs (App (Var unpack_id) (Lit (MachStr (_PK_ (stringToUtf8 chars)))))
returnDs (App (Var unpack_id) (Lit (MachStr (_PK_ (intsToUtf8 int_chars)))))
where
chars = _UNPK_INT_ str
int_chars = _UNPK_INT_ str
safeChar c = c >= 1 && c <= 0xFF
\end{code}
......@@ -495,17 +495,14 @@ mkSelectorBinds pat val_expr
| isSingleton binders || is_simple_pat pat
= newSysLocalDs (exprType val_expr) `thenDs` \ val_var ->
-- For the error message we don't use mkErrorAppDs to avoid
-- duplicating the string literal each time
newSysLocalDs stringTy `thenDs` \ msg_var ->
getSrcLocDs `thenDs` \ src_loc ->
let
full_msg = showSDoc (hcat [ppr src_loc, text "|", ppr pat])
in
mkStringLit full_msg `thenDs` \ core_msg ->
mapDs (mk_bind val_var msg_var) binders `thenDs` \ binds ->
-- For the error message we make one error-app, to avoid duplication.
-- But we need it at different types... so we use coerce for that
mkErrorAppDs iRREFUT_PAT_ERROR_ID
unitTy (showSDoc (ppr pat)) `thenDs` \ err_expr ->
newSysLocalDs unitTy `thenDs` \ err_var ->
mapDs (mk_bind val_var err_var) binders `thenDs` \ binds ->
returnDs ( (val_var, val_expr) :
(msg_var, core_msg) :
(err_var, err_expr) :
binds )
......@@ -524,16 +521,15 @@ mkSelectorBinds pat val_expr
local_tuple = mkTupleExpr binders
tuple_ty = exprType local_tuple
mk_bind scrut_var msg_var bndr_var
-- (mk_bind sv bv) generates
-- bv = case sv of { pat -> bv; other -> error-msg }
mk_bind scrut_var err_var bndr_var
-- (mk_bind sv err_var) generates
-- bv = case sv of { pat -> bv; other -> coerce (type-of-bv) err_var }
-- Remember, pat binds bv
= matchSimply (Var scrut_var) PatBindRhs pat
(Var bndr_var) error_expr `thenDs` \ rhs_expr ->
returnDs (bndr_var, rhs_expr)
where
binder_ty = idType bndr_var
error_expr = mkApps (Var iRREFUT_PAT_ERROR_ID) [Type binder_ty, Var msg_var]
error_expr = mkCoerce (idType bndr_var) (Var err_var)
is_simple_pat (TuplePat ps Boxed) = all is_triv_pat ps
is_simple_pat (ConPat _ _ _ _ ps) = all is_triv_pat ps
......
......@@ -18,7 +18,7 @@ module HsDecls (
hsDeclName, instDeclName,
tyClDeclName, tyClDeclNames, tyClDeclSysNames, tyClDeclTyVars,
isClassDecl, isSynDecl, isDataDecl, isIfaceSigDecl, isCoreDecl,
countTyClDecls,
isTypeOrClassDecl, countTyClDecls,
mkClassDeclSysNames, isSourceInstDecl, ifaceRuleDeclName,
getClassDeclSysNames, conDetailsTys,
collectRuleBndrSigTys
......@@ -329,6 +329,12 @@ isDataDecl other = False
isClassDecl (ClassDecl {}) = True
isClassDecl other = False
isTypeOrClassDecl (ClassDecl {}) = True
isTypeOrClassDecl (TyData {}) = True
isTypeOrClassDecl (TySynonym {}) = True
isTypeOrClassDecl (ForeignType {}) = True
isTypeOrClassDecl other = False
isCoreDecl (CoreDecl {}) = True
isCoreDecl other = False
......
......@@ -93,9 +93,8 @@ data HsExpr id pat
| HsDoOut HsDoContext
[Stmt id pat] -- "do":one or more stmts
id -- id for return
id -- id for >>=
id -- id for fail
[id] -- ids for [return,fail,>>=,>>]
-- Brutal but simple
Type -- Type of the whole expression
SrcLoc
......@@ -310,8 +309,8 @@ ppr_expr (HsWith expr binds is_with)
= sep [hang (ptext SLIT("let")) 2 (pp_ipbinds binds),
hang (ptext SLIT("in")) 2 (ppr expr)]
ppr_expr (HsDo do_or_list_comp stmts _) = pprDo do_or_list_comp stmts
ppr_expr (HsDoOut do_or_list_comp stmts _ _ _ _ _) = pprDo do_or_list_comp stmts
ppr_expr (HsDo do_or_list_comp stmts _) = pprDo do_or_list_comp stmts
ppr_expr (HsDoOut do_or_list_comp stmts _ _ _) = pprDo do_or_list_comp stmts
ppr_expr (ExplicitList _ exprs)
= brackets (fsep (punctuate comma (map ppr_expr exprs)))
......
-----------------------------------------------------------------------------
-- $Id: DriverPhases.hs,v 1.18 2002/04/05 15:18:26 sof Exp $
-- $Id: DriverPhases.hs,v 1.19 2002/04/11 12:03:33 simonpj Exp $
--
-- GHC Driver
--
......@@ -19,7 +19,7 @@ module DriverPhases (
hsbootish_file, hsbootish_suffix,
objish_file, objish_suffix,
cish_file, cish_suffix,
isExtCore_file
isExtCore_file, extcoreish_suffix
) where
import DriverUtil
......
......@@ -45,6 +45,8 @@ import Config
import Panic
import Util
import ParserCoreUtils ( getCoreModuleName )
#ifdef GHCI
import Time ( getClockTime )
#endif
......@@ -514,7 +516,14 @@ run_phase Hsc basename suff input_fn output_fn
writeIORef v_HCHeader cc_injects
-- gather the imports and module name
(srcimps,imps,mod_name) <- getImportsFromFile input_fn
(srcimps,imps,mod_name) <-
if extcoreish_suffix suff
then do
-- no explicit imports in ExtCore input.
m <- getCoreModuleName input_fn
return ([], [], mkModuleName m)
else
getImportsFromFile input_fn
-- build a ModuleLocation to pass to hscMain.
(mod, location')
......
......@@ -221,7 +221,7 @@ hscRecomp ghci_mode dflags have_object
; case front_res of
Left flure -> return flure;
Right (this_mod, rdr_module,
Just (dont_discard, new_iface, rn_result),
dont_discard, new_iface,
pcs_tc, ds_details, foreign_stuff) -> do {
-------------------
-- FLATTENING
......@@ -415,23 +415,23 @@ hscCoreFrontEnd ghci_mode dflags location hst hit pcs_ch = do {
<- renameExtCore dflags hit hst pcs_ch this_mod rdr_module
; case maybe_rn_result of {
Nothing -> return (Left (HscFail pcs_ch));
Just (dont_discard, new_iface, rn_result) -> do {
Just (dont_discard, new_iface, rn_decls) -> do {
-------------------
-- TYPECHECK
-------------------
; maybe_tc_result
<- _scc_ "TypeCheck"
typecheckCoreModule dflags pcs_rn hst new_iface (rr_decls rn_result)
typecheckCoreModule dflags pcs_rn hst new_iface rn_decls
; case maybe_tc_result of {
Nothing -> return (Left (HscFail pcs_ch));
Just (pcs_tc, ty_env, core_binds) -> do {
Just (pcs_tc, tc_result) -> do {
-------------------
-- DESUGAR
-------------------
; (ds_details, foreign_stuff) <- deSugarCore ty_env core_binds
; return (Right (this_mod, rdr_module, maybe_rn_result,
; (ds_details, foreign_stuff) <- deSugarCore tc_result
; return (Right (this_mod, rdr_module, dont_discard, new_iface,
pcs_tc, ds_details, foreign_stuff))
}}}}}}
......@@ -473,7 +473,7 @@ hscFrontEnd ghci_mode dflags location hst hit pcs_ch = do {
; (ds_details, foreign_stuff)
<- _scc_ "DeSugar"
deSugar dflags pcs_tc hst this_mod print_unqual tc_result
; return (Right (this_mod, rdr_module, maybe_rn_result,
; return (Right (this_mod, rdr_module, dont_discard, new_iface,
pcs_tc, ds_details, foreign_stuff))
}}}}}}}
......
......@@ -72,9 +72,9 @@ tdefs :: { [RdrNameHsDecl] }
| tdef ';' tdefs {$1:$3}
tdef :: { RdrNameHsDecl }
: '%data' qcname tbinds '=' '{' cons1 '}'
: '%data' q_tc_name tbinds '=' '{' cons1 '}'
{ TyClD (TyData DataType [] $2 $3 (DataCons $6) Nothing [] noSrcLoc) }
| '%newtype' qcname tbinds trep
| '%newtype' q_tc_name tbinds trep
{ TyClD (TyData NewType [] $2 $3 ($4 $2 $3) Nothing [] noSrcLoc) }
trep :: { (RdrName -> [HsTyVarBndr RdrName] -> DataConDetails (ConDecl RdrName)) }
......@@ -139,7 +139,7 @@ cons1 :: { [ConDecl RdrName] }
| con ';' cons1 { $1:$3 }
con :: { ConDecl RdrName }
: qcname attbinds atys
: q_d_name attbinds atys
{ ConDecl $1 $1 $2 [] (VanillaCon (map unbangedType $3)) noSrcLoc}
atys :: { [ RdrNameHsType] }
......@@ -148,7 +148,7 @@ atys :: { [ RdrNameHsType] }
aty :: { RdrNameHsType }
: name { HsTyVar $1 }
| qcname { HsTyVar $1 }
| q_tc_name { HsTyVar $1 }
| '(' ty ')' { $2 }
......@@ -163,7 +163,7 @@ ty :: { RdrNameHsType }
aexp :: { UfExpr RdrName }
: qname { UfVar $1 }
| qcname { UfVar $1 }
| q_d_name { UfVar $1 }
| lit { UfLit $1 }
| '(' exp ')' { $2 }
......@@ -192,7 +192,7 @@ alts1 :: { [UfAlt RdrName] }
| alt ';' alts1 { $1:$3 }
alt :: { UfAlt RdrName }
: qcname attbinds vbinds '->' exp
: q_d_name attbinds vbinds '->' exp
{ {- ToDo: sort out-} (UfDataAlt $1, (map hsTyVarName $2 ++ map fst $3), $5) }
| lit '->' exp
{ (UfLitAlt $1, [], $3) }
......@@ -206,7 +206,7 @@ lit :: { Literal }
| '(' STRING '::' aty ')' { MachStr (_PK_ $2) }
name :: { RdrName }
: NAME { mkUnqual varName (_PK_ $1) }
: NAME { mkRdrUnqual (mkVarOccEncoded (_PK_ $1)) }
cname :: { String }
: CNAME { $1 }
......@@ -222,13 +222,18 @@ qname :: { RdrName }
| mname '.' NAME
{ mkIfaceOrig varName (_PK_ $1,_PK_ $3) }
qcname :: { RdrName }
-- Type constructor
q_tc_name :: { RdrName }
: mname '.' cname
{ mkIfaceOrig tcName (_PK_ $1,_PK_ $3) }
-- Data constructor
q_d_name :: { RdrName }
: mname '.' cname
{ mkIfaceOrig dataName (_PK_ $1,_PK_ $3) }
{
toUfBinder :: [RdrNameHsDecl] -> UfBinding RdrName