From c7b389309e5cdc86db9845573900b560c7a2fa05 Mon Sep 17 00:00:00 2001 From: simonmar Date: Wed, 10 Dec 2003 17:25:18 +0000 Subject: [PATCH] [project @ 2003-12-10 17:25:12 by simonmar] Cleanups: - Move the collect* functions from HsSyn into HsUtils. Check that we have a clean separation of utilties over HsSyn, with the generic versions in HsUtils, and the specific versions in RdrHsSyn, RnHsSyn and TcHsSyn as appropriate. - Remove the RdrBinding data type, which was really just a nested list with O(1) append, and use OrdList instead. This makes it much clearer that there's nothing strange going on. - Various other minor cleanups. --- ghc/compiler/hsSyn/HsBinds.lhs | 3 - ghc/compiler/hsSyn/HsSyn.lhs | 91 -------------------------- ghc/compiler/hsSyn/HsUtils.lhs | 115 +++++++++++++++++++++++++++++++-- ghc/compiler/parser/Parser.y.pp | 83 ++++++++++++------------ ghc/compiler/parser/RdrHsSyn.lhs | 103 ++++++++--------------------- ghc/compiler/prelude/PrelNames.lhs | 8 ++- ghc/compiler/rename/RnNames.lhs | 6 +- ghc/compiler/typecheck/TcRnDriver.lhs | 12 ++-- 8 files changed, 194 insertions(+), 227 deletions(-) diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs index 494ac60..efedcd6 100644 --- a/ghc/compiler/hsSyn/HsBinds.lhs +++ b/ghc/compiler/hsSyn/HsBinds.lhs @@ -62,9 +62,6 @@ instance OutputableBndr id => Outputable (HsBindGroup id) where ppr (HsIPBinds ipbinds) = vcat (map ppr ipbinds) -mkHsBindGroup :: RecFlag -> Bag (LHsBind id) -> HsBindGroup id -mkHsBindGroup is_rec mbinds = HsBindGroup mbinds [] is_rec - -- ----------------------------------------------------------------------------- -- Implicit parameter bindings diff --git a/ghc/compiler/hsSyn/HsSyn.lhs b/ghc/compiler/hsSyn/HsSyn.lhs index 7255d1b..2fc0323 100644 --- a/ghc/compiler/hsSyn/HsSyn.lhs +++ b/ghc/compiler/hsSyn/HsSyn.lhs @@ -101,94 +101,3 @@ instance (OutputableBndr name) pp_nonnull [] = empty pp_nonnull xs = vcat (map ppr xs) \end{code} - - -%************************************************************************ -%* * -\subsection{Collecting binders from @HsBinds@} -%* * -%************************************************************************ - -Get all the binders in some @MonoBinds@, IN THE ORDER OF APPEARANCE. - -These functions are here, rather than in HsBinds, to avoid a loop between HsPat and HsBinds. - -\begin{verbatim} -... -where - (x, y) = ... - f i j = ... - [a, b] = ... -\end{verbatim} -it should return @[x, y, f, a, b]@ (remember, order important). - -\begin{code} -collectGroupBinders :: [HsBindGroup name] -> [Located name] -collectGroupBinders groups = foldr collect_group [] groups - where - collect_group (HsBindGroup bag sigs is_rec) acc - = foldrBag (collectAcc . unLoc) acc bag - collect_group (HsIPBinds _) acc = acc - - -collectAcc :: HsBind name -> [Located name] -> [Located name] -collectAcc (PatBind pat _) acc = collectLocatedPatBinders pat ++ acc -collectAcc (FunBind f _ _) acc = f : acc -collectAcc (VarBind f _) acc = noLoc f : acc -collectAcc (AbsBinds _ _ dbinds _ binds) acc - = [noLoc dp | (_,dp,_) <- dbinds] ++ acc - -- ++ foldr collectAcc acc binds - -- I don't think we want the binders from the nested binds - -- The only time we collect binders from a typechecked - -- binding (hence see AbsBinds) is in zonking in TcHsSyn - -collectHsBindBinders :: Bag (LHsBind name) -> [name] -collectHsBindBinders binds = map unLoc (collectHsBindLocatedBinders binds) - -collectHsBindLocatedBinders :: Bag (LHsBind name) -> [Located name] -collectHsBindLocatedBinders binds = foldrBag (collectAcc . unLoc) [] binds -\end{code} - - -%************************************************************************ -%* * -\subsection{Getting patterns out of bindings} -%* * -%************************************************************************ - -Get all the pattern type signatures out of a bunch of bindings - -\begin{code} -collectSigTysFromHsBinds :: [LHsBind name] -> [LHsType name] -collectSigTysFromHsBinds binds = concat (map collectSigTysFromHsBind binds) - -collectSigTysFromHsBind :: LHsBind name -> [LHsType name] -collectSigTysFromHsBind bind - = go (unLoc bind) - where - go (PatBind pat _) = collectSigTysFromPat pat - go (FunBind f _ ms) = go_matches (map unLoc ms) - - -- A binding like x :: a = f y - -- is parsed as FunMonoBind, but for this purpose we - -- want to treat it as a pattern binding - go_matches [] = [] - go_matches (Match [] (Just sig) _ : matches) = sig : go_matches matches - go_matches (match : matches) = go_matches matches -\end{code} - -\begin{code} -collectStmtsBinders :: [LStmt id] -> [Located id] -collectStmtsBinders = concatMap collectLStmtBinders - -collectLStmtBinders = collectStmtBinders . unLoc - -collectStmtBinders :: Stmt id -> [Located id] - -- Id Binders for a Stmt... [but what about pattern-sig type vars]? -collectStmtBinders (BindStmt pat _) = collectLocatedPatBinders pat -collectStmtBinders (LetStmt binds) = collectGroupBinders binds -collectStmtBinders (ExprStmt _ _) = [] -collectStmtBinders (ResultStmt _) = [] -collectStmtBinders (RecStmt ss _ _ _) = collectStmtsBinders ss -collectStmtBinders other = panic "collectStmtBinders" -\end{code} diff --git a/ghc/compiler/hsSyn/HsUtils.lhs b/ghc/compiler/hsSyn/HsUtils.lhs index dac170b..789887c 100644 --- a/ghc/compiler/hsSyn/HsUtils.lhs +++ b/ghc/compiler/hsSyn/HsUtils.lhs @@ -1,9 +1,16 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% (c) The University of Glasgow, 1992-2003 % - Collects a variety of helper functions that - construct or analyse HsSyn +Here we collect a variety of helper functions that construct or +analyse HsSyn. All these functions deal with generic HsSyn; functions +which deal with the intantiated versions are located elsewhere: + + Parameterised by Module + ---------------- ------------- + RdrName parser/RdrHsSyn + Name rename/RnHsSyn + Id typecheck/TcHsSyn \begin{code} module HsUtils where @@ -33,10 +40,13 @@ import Bag %************************************************************************ %* * - Some useful helpers for constructing expressions + Some useful helpers for constructing syntax %* * %************************************************************************ +These functions attempt to construct a not-completely-useless SrcSpan +from their components, compared with the nl* functions below which +just attach noSrcSpan to everything. \begin{code} mkHsPar :: LHsExpr id -> LHsExpr id @@ -119,12 +129,10 @@ mkHsString s = HsString (mkFastString s) %************************************************************************ %* * - These ones do not pin on useful locations - Used mainly for generated code + Constructing syntax with no location info %* * %************************************************************************ - \begin{code} nlHsVar :: id -> LHsExpr id nlHsVar n = noLoc (HsVar n) @@ -239,3 +247,96 @@ mkMatch pats expr binds L l _ -> L l (ParPat p) \end{code} + +%************************************************************************ +%* * + Collecting binders from HsBindGroups and HsBinds +%* * +%************************************************************************ + +Get all the binders in some HsBindGroups, IN THE ORDER OF APPEARANCE. eg. + +... +where + (x, y) = ... + f i j = ... + [a, b] = ... + +it should return [x, y, f, a, b] (remember, order important). + +\begin{code} +collectGroupBinders :: [HsBindGroup name] -> [Located name] +collectGroupBinders groups = foldr collect_group [] groups + where + collect_group (HsBindGroup bag sigs is_rec) acc + = foldrBag (collectAcc . unLoc) acc bag + collect_group (HsIPBinds _) acc = acc + + +collectAcc :: HsBind name -> [Located name] -> [Located name] +collectAcc (PatBind pat _) acc = collectLocatedPatBinders pat ++ acc +collectAcc (FunBind f _ _) acc = f : acc +collectAcc (VarBind f _) acc = noLoc f : acc +collectAcc (AbsBinds _ _ dbinds _ binds) acc + = [noLoc dp | (_,dp,_) <- dbinds] ++ acc + -- ++ foldr collectAcc acc binds + -- I don't think we want the binders from the nested binds + -- The only time we collect binders from a typechecked + -- binding (hence see AbsBinds) is in zonking in TcHsSyn + +collectHsBindBinders :: Bag (LHsBind name) -> [name] +collectHsBindBinders binds = map unLoc (collectHsBindLocatedBinders binds) + +collectHsBindLocatedBinders :: Bag (LHsBind name) -> [Located name] +collectHsBindLocatedBinders binds = foldrBag (collectAcc . unLoc) [] binds +\end{code} + + +%************************************************************************ +%* * + Getting pattern signatures out of bindings +%* * +%************************************************************************ + +Get all the pattern type signatures out of a bunch of bindings + +\begin{code} +collectSigTysFromHsBinds :: [LHsBind name] -> [LHsType name] +collectSigTysFromHsBinds binds = concat (map collectSigTysFromHsBind binds) + +collectSigTysFromHsBind :: LHsBind name -> [LHsType name] +collectSigTysFromHsBind bind + = go (unLoc bind) + where + go (PatBind pat _) = collectSigTysFromPat pat + go (FunBind f _ ms) = go_matches (map unLoc ms) + + -- A binding like x :: a = f y + -- is parsed as FunMonoBind, but for this purpose we + -- want to treat it as a pattern binding + go_matches [] = [] + go_matches (Match [] (Just sig) _ : matches) = sig : go_matches matches + go_matches (match : matches) = go_matches matches +\end{code} + +%************************************************************************ +%* * + Getting binders from statements +%* * +%************************************************************************ + +\begin{code} +collectStmtsBinders :: [LStmt id] -> [Located id] +collectStmtsBinders = concatMap collectLStmtBinders + +collectLStmtBinders = collectStmtBinders . unLoc + +collectStmtBinders :: Stmt id -> [Located id] + -- Id Binders for a Stmt... [but what about pattern-sig type vars]? +collectStmtBinders (BindStmt pat _) = collectLocatedPatBinders pat +collectStmtBinders (LetStmt binds) = collectGroupBinders binds +collectStmtBinders (ExprStmt _ _) = [] +collectStmtBinders (ResultStmt _) = [] +collectStmtBinders (RecStmt ss _ _ _) = collectStmtsBinders ss +collectStmtBinders other = panic "collectStmtBinders" +\end{code} diff --git a/ghc/compiler/parser/Parser.y.pp b/ghc/compiler/parser/Parser.y.pp index b3d6196..4dec2de 100644 --- a/ghc/compiler/parser/Parser.y.pp +++ b/ghc/compiler/parser/Parser.y.pp @@ -33,6 +33,7 @@ import CmdLineOpts ( opt_SccProfilingOn ) import Type ( Kind, mkArrowKind, liftedTypeKind ) import BasicTypes ( Boxity(..), Fixity(..), FixityDirection(..), IPName(..), NewOrData(..), Activation(..) ) +import OrdList import Bag ( emptyBag ) import Panic @@ -419,21 +420,21 @@ ops :: { Located [Located RdrName] } ----------------------------------------------------------------------------- -- Top-Level Declarations -topdecls :: { [RdrBinding] } -- Reversed - : topdecls ';' topdecl { $3 : $1 } +topdecls :: { OrdList (LHsDecl RdrName) } -- Reversed + : topdecls ';' topdecl { $1 `appOL` $3 } | topdecls ';' { $1 } - | topdecl { [$1] } + | topdecl { $1 } -topdecl :: { RdrBinding } - : tycl_decl { RdrHsDecl (L1 (TyClD (unLoc $1))) } +topdecl :: { OrdList (LHsDecl RdrName) } + : tycl_decl { unitOL (L1 (TyClD (unLoc $1))) } | 'instance' inst_type where { let (binds,sigs) = cvBindsAndSigs (unLoc $3) - in RdrHsDecl (L (comb3 $1 $2 $3) (InstD (InstDecl $2 binds sigs))) } - | 'default' '(' comma_types0 ')' { RdrHsDecl (LL $ DefD (DefaultDecl $3)) } - | 'foreign' fdecl { RdrHsDecl (LL (unLoc $2)) } - | '{-# DEPRECATED' deprecations '#-}' { RdrBindings (reverse $2) } - | '{-# RULES' rules '#-}' { RdrBindings (reverse $2) } - | '$(' exp ')' { RdrHsDecl (LL $ SpliceD (SpliceDecl $2)) } + in unitOL (L (comb3 $1 $2 $3) (InstD (InstDecl $2 binds sigs))) } + | 'default' '(' comma_types0 ')' { unitOL (LL $ DefD (DefaultDecl $3)) } + | 'foreign' fdecl { unitOL (LL (unLoc $2)) } + | '{-# DEPRECATED' deprecations '#-}' { $2 } + | '{-# RULES' rules '#-}' { $2 } + | '$(' exp ')' { unitOL (LL $ SpliceD (SpliceDecl $2)) } | decl { unLoc $1 } tycl_decl :: { LTyClDecl RdrName } @@ -478,21 +479,21 @@ tycl_hdr :: { Located (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrNam ----------------------------------------------------------------------------- -- Nested declarations -decls :: { Located [RdrBinding] } -- Reversed - : decls ';' decl { LL (unLoc $3 : unLoc $1) } +decls :: { Located (OrdList (LHsDecl RdrName)) } -- Reversed + : decls ';' decl { LL (unLoc $1 `appOL` unLoc $3) } | decls ';' { LL (unLoc $1) } - | decl { L1 [unLoc $1] } - | {- empty -} { noLoc [] } + | decl { L1 (unLoc $1) } + | {- empty -} { noLoc nilOL } -decllist :: { Located [RdrBinding] } -- Reversed +decllist :: { Located (OrdList (LHsDecl RdrName)) } -- Reversed : '{' decls '}' { LL (unLoc $2) } | vocurly decls close { $2 } -where :: { Located [RdrBinding] } -- Reversed +where :: { Located (OrdList (LHsDecl RdrName)) } -- Reversed -- No implicit parameters : 'where' decllist { LL (unLoc $2) } - | {- empty -} { noLoc [] } + | {- empty -} { noLoc nilOL } binds :: { Located [HsBindGroup RdrName] } -- May have implicit parameters : decllist { L1 [cvBindGroup (unLoc $1)] } @@ -507,15 +508,15 @@ wherebinds :: { Located [HsBindGroup RdrName] } -- May have implicit parameters ----------------------------------------------------------------------------- -- Transformation Rules -rules :: { [RdrBinding] } -- Reversed - : rules ';' rule { $3 : $1 } +rules :: { OrdList (LHsDecl RdrName) } -- Reversed + : rules ';' rule { $1 `snocOL` $3 } | rules ';' { $1 } - | rule { [$1] } - | {- empty -} { [] } + | rule { unitOL $1 } + | {- empty -} { nilOL } -rule :: { RdrBinding } +rule :: { LHsDecl RdrName } : STRING activation rule_forall infixexp '=' exp - { RdrHsDecl (LL $ RuleD (HsRule (getSTRING $1) $2 $3 $4 $6)) } + { LL $ RuleD (HsRule (getSTRING $1) $2 $3 $4 $6) } activation :: { Activation } -- Omitted means AlwaysActive : {- empty -} { AlwaysActive } @@ -544,16 +545,17 @@ rule_var :: { RuleBndr RdrName } ----------------------------------------------------------------------------- -- Deprecations (c.f. rules) -deprecations :: { [RdrBinding] } -- Reversed - : deprecations ';' deprecation { $3 : $1 } +deprecations :: { OrdList (LHsDecl RdrName) } -- Reversed + : deprecations ';' deprecation { $1 `appOL` $3 } | deprecations ';' { $1 } - | deprecation { [$1] } - | {- empty -} { [] } + | deprecation { $1 } + | {- empty -} { nilOL } -- SUP: TEMPORARY HACK, not checking for `module Foo' -deprecation :: { RdrBinding } +deprecation :: { OrdList (LHsDecl RdrName) } : depreclist STRING - { RdrBindings [ RdrHsDecl (LL $ DeprecD (Deprecation n (getSTRING $2))) | n <- unLoc $1 ] } + { toOL [ LL $ DeprecD (Deprecation n (getSTRING $2)) + | n <- unLoc $1 ] } ----------------------------------------------------------------------------- @@ -919,10 +921,10 @@ deriving :: { Located (Maybe (LHsContext RdrName)) } We can't tell whether to reduce var to qvar until after we've read the signatures. -} -decl :: { Located RdrBinding } +decl :: { Located (OrdList (LHsDecl RdrName)) } : sigdecl { $1 } | infixexp opt_sig rhs {% do { r <- checkValDef $1 $2 (unLoc $3); - return (LL $ RdrValBinding (LL r)) } } + return (LL $ unitOL (LL $ ValD r)) } } rhs :: { Located (GRHSs RdrName) } : '=' exp wherebinds { L (comb3 $1 $2 $3) $ GRHSs (unguardedRHS $2) (unLoc $3) placeHolderType } @@ -936,23 +938,24 @@ gdrh :: { LGRHS RdrName } : '|' quals '=' exp { LL $ GRHS (reverse (L (getLoc $4) (ResultStmt $4) : unLoc $2)) } -sigdecl :: { Located RdrBinding } +sigdecl :: { Located (OrdList (LHsDecl RdrName)) } : infixexp '::' sigtype {% do s <- checkValSig $1 $3; - return (LL $ RdrHsDecl (LL $ SigD s)) } + return (LL $ unitOL (LL $ SigD s)) } -- See the above notes for why we need infixexp here | var ',' sig_vars '::' sigtype - { LL $ mkSigDecls [ LL $ Sig n $5 | n <- $1 : unLoc $3 ] } - | infix prec ops { LL $ mkSigDecls [ LL $ FixSig (FixitySig n (Fixity $2 (unLoc $1))) + { LL $ toOL [ LL $ SigD (Sig n $5) | n <- $1 : unLoc $3 ] } + | infix prec ops { LL $ toOL [ LL $ SigD (FixSig (FixitySig n (Fixity $2 (unLoc $1)))) | n <- unLoc $3 ] } | '{-# INLINE' activation qvar '#-}' - { LL $ RdrHsDecl (LL $ SigD (InlineSig True $3 $2)) } + { LL $ unitOL (LL $ SigD (InlineSig True $3 $2)) } | '{-# NOINLINE' inverse_activation qvar '#-}' - { LL $ RdrHsDecl (LL $ SigD (InlineSig False $3 $2)) } + { LL $ unitOL (LL $ SigD (InlineSig False $3 $2)) } | '{-# SPECIALISE' qvar '::' sigtypes '#-}' - { LL $ mkSigDecls [ LL $ SpecSig $2 t | t <- $4] } + { LL $ toOL [ LL $ SigD (SpecSig $2 t) + | t <- $4] } | '{-# SPECIALISE' 'instance' inst_type '#-}' - { LL $ RdrHsDecl (LL $ SigD (SpecInstSig $3)) } + { LL $ unitOL (LL $ SigD (SpecInstSig $3)) } ----------------------------------------------------------------------------- -- Expressions diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs index 3761f74..8d9e17d 100644 --- a/ghc/compiler/parser/RdrHsSyn.lhs +++ b/ghc/compiler/parser/RdrHsSyn.lhs @@ -1,23 +1,16 @@ % -% (c) The AQUA Project, Glasgow University, 1996-1998 -% -\section[RdrHsSyn]{Specialisations of the @HsSyn@ syntax for the reader} +% (c) The University of Glasgow, 1996-2003 -(Well, really, for specialisations involving @RdrName@s, even if -they are used somewhat later on in the compiler...) +Functions over HsSyn specialised to RdrName. \begin{code} module RdrHsSyn ( - RdrBinding(..), - - main_RDR_Unqual, - extractHsTyRdrTyVars, extractHsRhoRdrTyVars, extractGenericPatTyVars, mkHsOpApp, mkClassDecl, mkHsNegApp, mkHsIntegral, mkHsFractional, - mkHsDo, mkHsSplice, mkSigDecls, + mkHsDo, mkHsSplice, mkTyData, mkPrefixCon, mkRecCon, mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp mkBootIface, @@ -76,6 +69,7 @@ import Module ( ModuleName ) import SrcLoc import CStrings ( CLabelString ) import CmdLineOpts ( opt_InPackage ) +import OrdList ( OrdList, fromOL ) import Bag ( Bag, emptyBag, snocBag, consBag, foldrBag ) import Outputable import FastString @@ -84,19 +78,6 @@ import Panic import List ( isSuffixOf, nubBy ) \end{code} - -%************************************************************************ -%* * -\subsection{Type synonyms} -%* * -%************************************************************************ - -\begin{code} -main_RDR_Unqual :: RdrName -main_RDR_Unqual = mkUnqual varName FSLIT("main") - -- We definitely don't want an Orig RdrName, because - -- main might, in principle, be imported into module Main -\end{code} %************************************************************************ %* * @@ -104,7 +85,7 @@ main_RDR_Unqual = mkUnqual varName FSLIT("main") %* * %************************************************************************ -@extractHsTyRdrNames@ finds the free variables of a HsType +extractHsTyRdrNames finds the free variables of a HsType It's used when making the for-alls explicit. \begin{code} @@ -344,25 +325,6 @@ hsIfaceFDs fds = [ (map rdrNameOcc xs, map rdrNameOcc ys) | (xs,ys) <- fds ] \end{code} - -%************************************************************************ -%* * -\subsection[rdrBinding]{Bindings straight out of the parser} -%* * -%************************************************************************ - -\begin{code} -data RdrBinding - = -- Value bindings havn't been united with their - -- signatures yet - RdrBindings [RdrBinding] -- Convenience for parsing - - | RdrValBinding (LHsBind RdrName) - - -- The remainder all fit into the main HsDecl form - | RdrHsDecl (LHsDecl RdrName) -\end{code} - %************************************************************************ %* * \subsection[cvBinds-etc]{Converting to @HsBinds@, etc.} @@ -375,44 +337,39 @@ analyser. \begin{code} -cvTopDecls :: [RdrBinding] -> [LHsDecl RdrName] --- Incoming bindings are in reverse order; result is in ordinary order --- (a) flatten RdrBindings --- (b) Group together bindings for a single function -cvTopDecls decls - = go [] decls +-- | Groups together bindings for a single function +cvTopDecls :: OrdList (LHsDecl RdrName) -> [LHsDecl RdrName] +cvTopDecls decls = go (fromOL decls) where - go :: [LHsDecl RdrName] -> [RdrBinding] -> [LHsDecl RdrName] - go acc [] = acc - go acc (RdrBindings ds1 : ds2) = go (go acc ds1) ds2 - go acc (RdrHsDecl d : ds) = go (d : acc) ds - go acc (RdrValBinding b : ds) = go (L l (ValD b') : acc) ds' - where - (L l b', ds') = getMonoBind b ds - -cvBindGroup :: [RdrBinding] -> HsBindGroup RdrName + go :: [LHsDecl RdrName] -> [LHsDecl RdrName] + go [] = [] + go (L l (ValD b) : ds) = L l' (ValD b') : go ds' + where (L l' b', ds') = getMonoBind (L l b) ds + go (d : ds) = d : go ds + +cvBindGroup :: OrdList (LHsDecl RdrName) -> HsBindGroup RdrName cvBindGroup binding = case (cvBindsAndSigs binding) of { (mbs, sigs) -> HsBindGroup mbs sigs Recursive -- just one big group for now } -cvBindsAndSigs :: [RdrBinding] -> (Bag (LHsBind RdrName), [LSig RdrName]) --- Input bindings are in *reverse* order, --- and contain just value bindings and signatures -cvBindsAndSigs fb - = go (emptyBag, []) fb +cvBindsAndSigs :: OrdList (LHsDecl RdrName) + -> (Bag (LHsBind RdrName), [LSig RdrName]) +-- Input decls contain just value bindings and signatures +cvBindsAndSigs fb = go (fromOL fb) where - go acc [] = acc - go acc (RdrBindings ds1 : ds2) = go (go acc ds1) ds2 - go (bs, ss) (RdrHsDecl (L l (SigD s)) : ds) = go (bs, L l s : ss) ds - go (bs, ss) (RdrValBinding b : ds) = go (b' `consBag` bs, ss) ds' - where - (b',ds') = getMonoBind b ds + go [] = (emptyBag, []) + go (L l (SigD s) : ds) = (bs, L l s : ss) + where (bs,ss) = go ds + go (L l (ValD b) : ds) = (b' `consBag` bs, ss) + where (b',ds') = getMonoBind (L l b) ds + (bs,ss) = go ds' ----------------------------------------------------------------------------- -- Group function bindings into equation groups -getMonoBind :: LHsBind RdrName -> [RdrBinding] -> (LHsBind RdrName, [RdrBinding]) +getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName] + -> (LHsBind RdrName, [LHsDecl RdrName]) -- Suppose (b',ds') = getMonoBind b ds -- ds is a *reversed* list of parsed bindings -- b is a MonoBinds that has just been read off the front @@ -427,7 +384,7 @@ getMonoBind (L loc (FunBind lf@(L _ f) inf mtchs)) binds | has_args mtchs = go mtchs loc binds where - go mtchs1 loc1 (RdrValBinding (L loc2 (FunBind f2 inf2 mtchs2)) : binds) + go mtchs1 loc1 (L loc2 (ValD (FunBind f2 inf2 mtchs2)) : binds) | f == unLoc f2 = go (mtchs2 ++ mtchs1) loc binds -- Remember binds is reversed, so glue mtchs2 on the front -- and use loc2 as the final location @@ -796,10 +753,6 @@ checkValSig (L l (HsVar v)) ty | isUnqual v = return (Sig (L l v) ty) checkValSig (L l other) ty = parseError l "Type signature given for an expression" -mkSigDecls :: [LSig RdrName] -> RdrBinding -mkSigDecls sigs = RdrBindings [RdrHsDecl (L l (SigD sig)) | L l sig <- sigs] - - -- A variable binding is parsed as a FunBind. isFunLhs :: LHsExpr RdrName -> [LHsExpr RdrName] diff --git a/ghc/compiler/prelude/PrelNames.lhs b/ghc/compiler/prelude/PrelNames.lhs index f9453ca..f719c4e 100644 --- a/ghc/compiler/prelude/PrelNames.lhs +++ b/ghc/compiler/prelude/PrelNames.lhs @@ -53,7 +53,7 @@ import Module ( Module, mkBasePkgModule, mkHomeModule, mkModuleName ) import OccName ( dataName, tcName, clsName, varName, mkOccFS ) -import RdrName ( RdrName, nameRdrName, mkOrig, rdrNameOcc ) +import RdrName ( RdrName, nameRdrName, mkOrig, rdrNameOcc, mkUnqual ) import Unique ( Unique, Uniquable(..), hasKey, mkPreludeMiscIdUnique, mkPreludeDataConUnique, mkPreludeTyConUnique, mkPreludeClassUnique, @@ -63,8 +63,6 @@ import BasicTypes ( Boxity(..), Arity ) import Name ( Name, mkInternalName, mkExternalName, nameUnique, nameModule ) import SrcLoc ( noSrcLoc ) import FastString - - \end{code} @@ -345,6 +343,10 @@ mkTupleModule Unboxed _ = gHC_PRIM %************************************************************************ \begin{code} +main_RDR_Unqual = mkUnqual varName FSLIT("main") + -- We definitely don't want an Orig RdrName, because + -- main might, in principle, be imported into module Main + eq_RDR = nameRdrName eqName ge_RDR = nameRdrName geName ne_RDR = varQual_RDR pREL_BASE_Name FSLIT("/=") diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index eb3d1b0..3abf465 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -16,14 +16,14 @@ import HsSyn ( IE(..), ieName, ImportDecl(..), LImportDecl, ForeignDecl(..), HsGroup(..), collectGroupBinders, tyClDeclNames ) -import RdrHsSyn ( main_RDR_Unqual ) import RnEnv import IfaceEnv ( lookupOrig, newGlobalBinder ) import LoadIface ( loadSrcInterface ) import TcRnMonad import FiniteMap -import PrelNames ( pRELUDE_Name, isBuiltInSyntaxName, isUnboundName ) +import PrelNames ( pRELUDE_Name, isBuiltInSyntaxName, isUnboundName, + main_RDR_Unqual ) import Module ( Module, ModuleName, moduleName, mkPackageModule, moduleNameUserString, isHomeModule, unitModuleEnvByName, unitModuleEnv, @@ -46,7 +46,7 @@ import RdrName ( RdrName, rdrNameOcc, setRdrNameSpace, isLocalGRE, pprNameProvenance ) import Outputable import Maybes ( isJust, isNothing, catMaybes, mapCatMaybes ) -import SrcLoc ( noSrcLoc, Located(..), mkGeneralSrcSpan, srcSpanStart, +import SrcLoc ( noSrcLoc, Located(..), mkGeneralSrcSpan, unLoc, noLoc ) import ListSetOps ( removeDups ) import Util ( sortLt, notNull ) diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs index 03b2e46..7b0a63d 100644 --- a/ghc/compiler/typecheck/TcRnDriver.lhs +++ b/ghc/compiler/typecheck/TcRnDriver.lhs @@ -22,9 +22,10 @@ import {-# SOURCE #-} TcSplice ( tcSpliceDecls ) import CmdLineOpts ( DynFlag(..), opt_PprStyle_Debug, dopt ) import DriverState ( v_MainModIs, v_MainFunIs ) import HsSyn -import RdrHsSyn ( findSplice, main_RDR_Unqual ) +import RdrHsSyn ( findSplice ) -import PrelNames ( runIOName, rootMainName, mAIN_Name ) +import PrelNames ( runIOName, rootMainName, mAIN_Name, + main_RDR_Unqual ) import RdrName ( RdrName, mkRdrUnqual, emptyGlobalRdrEnv, plusGlobalRdrEnv ) import TcHsSyn ( zonkTopDecls ) @@ -56,7 +57,7 @@ import OccName ( mkVarOcc ) import Name ( Name, isExternalName, getSrcLoc, getOccName ) import NameSet import TyCon ( tyConHasGenerics ) -import SrcLoc ( srcLocSpan, Located(..), noLoc, unLoc ) +import SrcLoc ( srcLocSpan, Located(..), noLoc ) import Outputable import HscTypes ( ModGuts(..), HscEnv(..), GhciMode(..), noDependencies, @@ -93,7 +94,7 @@ import Id ( Id, isImplicitId ) import MkId ( unsafeCoerceId ) import TysWiredIn ( mkListTy, unitTy ) import IdInfo ( GlobalIdDetails(..) ) -import SrcLoc ( interactiveSrcLoc ) +import SrcLoc ( interactiveSrcLoc, unLoc ) import Var ( setGlobalIdDetails ) import Name ( nameOccName, nameModuleName ) import NameEnv ( delListFromNameEnv ) @@ -104,12 +105,13 @@ import HscTypes ( InteractiveContext(..), TyThing(..), availNames, icPrintUnqual, ModIface(..), ModDetails(..) ) import BasicTypes ( RecFlag(..), Fixity ) +import Bag ( unitBag ) import Panic ( ghcError, GhcException(..) ) #endif import FastString ( mkFastString ) import Util ( sortLt ) -import Bag ( unionBags, snocBag, unitBag ) +import Bag ( unionBags, snocBag ) import Maybe ( isJust ) \end{code} -- 1.7.10.4