summaryrefslogtreecommitdiff
path: root/ghc/compiler/hsSyn
diff options
context:
space:
mode:
Diffstat (limited to 'ghc/compiler/hsSyn')
-rw-r--r--ghc/compiler/hsSyn/HsBinds.lhs99
-rw-r--r--ghc/compiler/hsSyn/HsCore.lhs4
-rw-r--r--ghc/compiler/hsSyn/HsDecls.lhs198
-rw-r--r--ghc/compiler/hsSyn/HsExpr.hi-boot4
-rw-r--r--ghc/compiler/hsSyn/HsExpr.lhs172
-rw-r--r--ghc/compiler/hsSyn/HsImpExp.lhs10
-rw-r--r--ghc/compiler/hsSyn/HsMatches.hi-boot14
-rw-r--r--ghc/compiler/hsSyn/HsMatches.lhs148
-rw-r--r--ghc/compiler/hsSyn/HsPat.lhs103
-rw-r--r--ghc/compiler/hsSyn/HsSyn.lhs44
-rw-r--r--ghc/compiler/hsSyn/HsTypes.lhs6
11 files changed, 407 insertions, 395 deletions
diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs
index a9729e6934..372f7ea23f 100644
--- a/ghc/compiler/hsSyn/HsBinds.lhs
+++ b/ghc/compiler/hsSyn/HsBinds.lhs
@@ -11,7 +11,7 @@ module HsBinds where
#include "HsVersions.h"
import {-# SOURCE #-} HsExpr ( pprExpr, HsExpr )
-import {-# SOURCE #-} HsMatches ( pprMatches, Match, pprGRHSsAndBinds, GRHSsAndBinds )
+import {-# SOURCE #-} HsMatches ( pprMatches, Match, pprGRHSs, GRHSs )
-- friends:
import HsTypes ( HsType )
@@ -21,11 +21,11 @@ import PprCore () -- Instances for Outputable
--others:
import Id ( Id )
import Name ( OccName, NamedThing(..) )
-import BasicTypes ( RecFlag(..) )
+import BasicTypes ( RecFlag(..), Fixity )
import Outputable
import Bag
import SrcLoc ( SrcLoc )
-import Var ( GenTyVar )
+import Var ( TyVar )
\end{code}
%************************************************************************
@@ -43,19 +43,19 @@ grammar.
Collections of bindings, created by dependency analysis and translation:
\begin{code}
-data HsBinds flexi id pat -- binders and bindees
+data HsBinds id pat -- binders and bindees
= EmptyBinds
- | ThenBinds (HsBinds flexi id pat)
- (HsBinds flexi id pat)
+ | ThenBinds (HsBinds id pat)
+ (HsBinds id pat)
- | MonoBind (MonoBinds flexi id pat)
+ | MonoBind (MonoBinds id pat)
[Sig id] -- Empty on typechecker output
RecFlag
\end{code}
\begin{code}
-nullBinds :: HsBinds flexi id pat -> Bool
+nullBinds :: HsBinds id pat -> Bool
nullBinds EmptyBinds = True
nullBinds (ThenBinds b1 b2) = nullBinds b1 && nullBinds b2
@@ -64,7 +64,7 @@ nullBinds (MonoBind b _ _) = nullMonoBinds b
\begin{code}
instance (Outputable pat, NamedThing id, Outputable id) =>
- Outputable (HsBinds flexi id pat) where
+ Outputable (HsBinds id pat) where
ppr binds = ppr_binds binds
ppr_binds EmptyBinds = empty
@@ -90,32 +90,32 @@ ppr_binds (MonoBind bind sigs is_rec)
Global bindings (where clauses)
\begin{code}
-data MonoBinds flexi id pat
+data MonoBinds id pat
= EmptyMonoBinds
- | AndMonoBinds (MonoBinds flexi id pat)
- (MonoBinds flexi id pat)
+ | AndMonoBinds (MonoBinds id pat)
+ (MonoBinds id pat)
| PatMonoBind pat
- (GRHSsAndBinds flexi id pat)
+ (GRHSs id pat)
SrcLoc
| FunMonoBind id
Bool -- True => infix declaration
- [Match flexi id pat] -- must have at least one Match
+ [Match id pat]
SrcLoc
| VarMonoBind id -- TRANSLATION
- (HsExpr flexi id pat)
+ (HsExpr id pat)
| CoreMonoBind id -- TRANSLATION
CoreExpr -- No zonking; this is a final CoreExpr with Ids and Types!
| AbsBinds -- Binds abstraction; TRANSLATION
- [GenTyVar flexi] -- Type variables
+ [TyVar] -- Type variables
[id] -- Dicts
- [([GenTyVar flexi], id, id)] -- (type variables, polymorphic, momonmorphic) triples
- (MonoBinds flexi id pat) -- The "business end"
+ [([TyVar], id, id)] -- (type variables, polymorphic, momonmorphic) triples
+ (MonoBinds id pat) -- The "business end"
-- Creates bindings for *new* (polymorphic, overloaded) locals
-- in terms of *old* (monomorphic, non-overloaded) ones.
@@ -150,24 +150,24 @@ So the desugarer tries to do a better job:
in (fm,gm)
\begin{code}
-nullMonoBinds :: MonoBinds flexi id pat -> Bool
+nullMonoBinds :: MonoBinds id pat -> Bool
nullMonoBinds EmptyMonoBinds = True
nullMonoBinds (AndMonoBinds bs1 bs2) = nullMonoBinds bs1 && nullMonoBinds bs2
nullMonoBinds other_monobind = False
-andMonoBinds :: MonoBinds flexi id pat -> MonoBinds flexi id pat -> MonoBinds flexi id pat
+andMonoBinds :: MonoBinds id pat -> MonoBinds id pat -> MonoBinds id pat
andMonoBinds EmptyMonoBinds mb = mb
andMonoBinds mb EmptyMonoBinds = mb
andMonoBinds mb1 mb2 = AndMonoBinds mb1 mb2
-andMonoBindList :: [MonoBinds flexi id pat] -> MonoBinds flexi id pat
+andMonoBindList :: [MonoBinds id pat] -> MonoBinds id pat
andMonoBindList binds = foldr AndMonoBinds EmptyMonoBinds binds
\end{code}
\begin{code}
instance (NamedThing id, Outputable id, Outputable pat) =>
- Outputable (MonoBinds flexi id pat) where
+ Outputable (MonoBinds id pat) where
ppr mbind = ppr_monobind mbind
@@ -175,8 +175,8 @@ ppr_monobind EmptyMonoBinds = empty
ppr_monobind (AndMonoBinds binds1 binds2)
= ($$) (ppr_monobind binds1) (ppr_monobind binds2)
-ppr_monobind (PatMonoBind pat grhss_n_binds locn)
- = sep [ppr pat, nest 4 (pprGRHSsAndBinds False grhss_n_binds)]
+ppr_monobind (PatMonoBind pat grhss locn)
+ = sep [ppr pat, nest 4 (pprGRHSs False grhss)]
ppr_monobind (FunMonoBind fun inf matches locn)
= pprMatches (False, ppr fun) matches
@@ -213,25 +213,30 @@ data Sig name
(HsType name)
SrcLoc
- | ClassOpSig name -- Selector name
- (Maybe name) -- Default-method name (if any)
+ | ClassOpSig name -- Selector name
+ (Maybe name) -- Default-method name (if any)
(HsType name)
SrcLoc
| SpecSig name -- specialise a function or datatype ...
- (HsType name) -- ... to these types
+ (HsType name) -- ... to these types
(Maybe name) -- ... maybe using this as the code for it
SrcLoc
- | InlineSig name -- INLINE f
+ | InlineSig name -- INLINE f
SrcLoc
- | NoInlineSig name -- NOINLINE f
+ | NoInlineSig name -- NOINLINE f
SrcLoc
- | SpecInstSig (HsType name) -- (Class tys); should be a specialisation of the
- -- current instance decl
+ | SpecInstSig (HsType name) -- (Class tys); should be a specialisation of the
+ -- current instance decl
SrcLoc
+
+ | FixSig (FixitySig name) -- Fixity declaration
+
+
+data FixitySig name = FixitySig name Fixity SrcLoc
\end{code}
\begin{code}
@@ -239,29 +244,37 @@ sigsForMe :: (name -> Bool) -> [Sig name] -> [Sig name]
sigsForMe f sigs
= filter sig_for_me sigs
where
- sig_for_me (Sig n _ _) = f n
- sig_for_me (ClassOpSig n _ _ _) = f n
- sig_for_me (SpecSig n _ _ _) = f n
- sig_for_me (InlineSig n _) = f n
- sig_for_me (NoInlineSig n _) = f n
- sig_for_me (SpecInstSig _ _) = False
+ sig_for_me (Sig n _ _) = f n
+ sig_for_me (ClassOpSig n _ _ _) = f n
+ sig_for_me (SpecSig n _ _ _) = f n
+ sig_for_me (InlineSig n _) = f n
+ sig_for_me (NoInlineSig n _) = f n
+ sig_for_me (SpecInstSig _ _) = False
+ sig_for_me (FixSig (FixitySig n _ _)) = f n
+
+nonFixitySigs :: [Sig name] -> [Sig name]
+nonFixitySigs sigs = filter not_fix sigs
+ where
+ not_fix (FixSig _) = False
+ not_fix other = True
\end{code}
\begin{code}
instance (NamedThing name, Outputable name) => Outputable (Sig name) where
ppr sig = ppr_sig sig
+instance Outputable name => Outputable (FixitySig name) where
+ ppr (FixitySig name fixity loc) = sep [ppr fixity, ppr name]
+
ppr_sig (Sig var ty _)
- = sep [ppr var <+> ptext SLIT("::"),
- nest 4 (ppr ty)]
+ = sep [ppr var <+> dcolon, nest 4 (ppr ty)]
ppr_sig (ClassOpSig var _ ty _)
- = sep [ppr (getOccName var) <+> ptext SLIT("::"),
- nest 4 (ppr ty)]
+ = sep [ppr (getOccName var) <+> dcolon, nest 4 (ppr ty)]
ppr_sig (SpecSig var ty using _)
- = sep [ hsep [text "{-# SPECIALIZE", ppr var, ptext SLIT("::")],
+ = sep [ hsep [text "{-# SPECIALIZE", ppr var, dcolon],
nest 4 (hsep [ppr ty, pp_using using, text "#-}"])
]
where
@@ -276,5 +289,7 @@ ppr_sig (NoInlineSig var _)
ppr_sig (SpecInstSig ty _)
= hsep [text "{-# SPECIALIZE instance", ppr ty, text "#-}"]
+
+ppr_sig (FixSig fix_sig) = ppr fix_sig
\end{code}
diff --git a/ghc/compiler/hsSyn/HsCore.lhs b/ghc/compiler/hsSyn/HsCore.lhs
index 24cbda2ae2..e887f7e4b8 100644
--- a/ghc/compiler/hsSyn/HsCore.lhs
+++ b/ghc/compiler/hsSyn/HsCore.lhs
@@ -122,7 +122,7 @@ instance Outputable name => Outputable (UfCon name) where
after = if is_casm then text "'' " else space
instance Outputable name => Outputable (UfBinder name) where
- ppr (UfValBinder name ty) = hsep [ppr name, ptext SLIT("::"), ppr ty]
- ppr (UfTyBinder name kind) = hsep [ppr name, ptext SLIT("::"), ppr kind]
+ ppr (UfValBinder name ty) = hsep [ppr name, dcolon, ppr ty]
+ ppr (UfTyBinder name kind) = hsep [ppr name, dcolon, ppr kind]
\end{code}
diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs
index 5789d7824f..2e10554ccc 100644
--- a/ghc/compiler/hsSyn/HsDecls.lhs
+++ b/ghc/compiler/hsSyn/HsDecls.lhs
@@ -3,16 +3,23 @@
%
\section[HsDecls]{Abstract syntax: global declarations}
-Definitions for: @FixityDecl@, @TyDecl@ and @ConDecl@, @ClassDecl@,
+Definitions for: @TyDecl@ and @ConDecl@, @ClassDecl@,
@InstDecl@, @DefaultDecl@ and @ForeignDecl@.
\begin{code}
-module HsDecls where
+module HsDecls (
+ HsDecl(..), TyClDecl(..), InstDecl(..),
+ DefaultDecl(..), ForeignDecl(..), ForKind(..),
+ ExtName(..), isDynamic,
+ ConDecl(..), ConDetails(..), BangType(..),
+ IfaceSig(..), SpecDataSig(..), HsIdInfo(..), HsStrictnessInfo(..),
+ hsDeclName, tyClDeclName, isClassDecl, isSynDecl, isDataDecl, countTyClDecls
+ ) where
#include "HsVersions.h"
-- friends:
-import HsBinds ( HsBinds, MonoBinds, Sig, nullMonoBinds )
+import HsBinds ( HsBinds, MonoBinds, Sig, FixitySig(..), nullMonoBinds )
import HsPragmas ( DataPragmas, ClassPragmas )
import HsTypes
import HsCore ( UfExpr )
@@ -36,75 +43,85 @@ import Util
%************************************************************************
\begin{code}
-data HsDecl flexi name pat
- = TyD (TyDecl name)
- | ClD (ClassDecl flexi name pat)
- | InstD (InstDecl flexi name pat)
+data HsDecl name pat
+ = TyClD (TyClDecl name pat)
+ | InstD (InstDecl name pat)
| DefD (DefaultDecl name)
- | ValD (HsBinds flexi name pat)
- | SigD (IfaceSig name)
+ | ValD (HsBinds name pat)
| ForD (ForeignDecl name)
+ | SigD (IfaceSig name)
+ | FixD (FixitySig name)
+
+-- NB: all top-level fixity decls are contained EITHER
+-- EITHER FixDs
+-- OR in the ClassDecls in TyClDs
+--
+-- The former covers
+-- a) data constructors
+-- b) class methods (but they can be also done in the
+-- signatures of class decls)
+-- c) imported functions (that have an IfacSig)
+-- d) top level decls
+--
+-- The latter is for class methods only
+
+-- It's a bit wierd that the fixity decls in the ValD
+-- cover all the classops and imported decls too, but it's convenient
+-- For a start, it means we don't need a FixD
\end{code}
\begin{code}
#ifdef DEBUG
hsDeclName :: (NamedThing name, Outputable name, Outputable pat)
- => HsDecl flexi name pat -> name
+ => HsDecl name pat -> name
#endif
-hsDeclName (TyD (TyData _ _ name _ _ _ _ _)) = name
-hsDeclName (TyD (TySynonym name _ _ _)) = name
-hsDeclName (ClD (ClassDecl _ name _ _ _ _ _ _ _)) = name
-hsDeclName (SigD (IfaceSig name _ _ _)) = name
-hsDeclName (InstD (InstDecl _ _ _ (Just name) _)) = name
-hsDeclName (ForD (ForeignDecl name _ _ _ _ _)) = name
+hsDeclName (TyClD decl) = tyClDeclName decl
+hsDeclName (SigD (IfaceSig name _ _ _)) = name
+hsDeclName (InstD (InstDecl _ _ _ (Just name) _)) = name
+hsDeclName (ForD (ForeignDecl name _ _ _ _ _)) = name
+hsDeclName (FixD (FixitySig name _ _)) = name
-- Others don't make sense
#ifdef DEBUG
hsDeclName x = pprPanic "HsDecls.hsDeclName" (ppr x)
#endif
+
+tyClDeclName :: TyClDecl name pat -> name
+tyClDeclName (TyData _ _ name _ _ _ _ _) = name
+tyClDeclName (TySynonym name _ _ _) = name
+tyClDeclName (ClassDecl _ name _ _ _ _ _ _ _) = name
\end{code}
\begin{code}
instance (NamedThing name, Outputable name, Outputable pat)
- => Outputable (HsDecl flexi name pat) where
+ => Outputable (HsDecl name pat) where
- ppr (TyD td) = ppr td
- ppr (ClD cd) = ppr cd
+ ppr (TyClD dcl) = ppr dcl
ppr (SigD sig) = ppr sig
ppr (ValD binds) = ppr binds
ppr (DefD def) = ppr def
ppr (InstD inst) = ppr inst
ppr (ForD fd) = ppr fd
+ ppr (FixD fd) = ppr fd
+
+{- Why do we need ordering on decls?
#ifdef DEBUG
-- hsDeclName needs more context when DEBUG is on
instance (NamedThing name, Outputable name, Outputable pat, Eq name)
- => Eq (HsDecl flex name pat) where
+ => Eq (HsDecl name pat) where
d1 == d2 = hsDeclName d1 == hsDeclName d2
instance (NamedThing name, Outputable name, Outputable pat, Ord name)
- => Ord (HsDecl flex name pat) where
+ => Ord (HsDecl name pat) where
d1 `compare` d2 = hsDeclName d1 `compare` hsDeclName d2
#else
-instance (Eq name) => Eq (HsDecl flex name pat) where
+instance (Eq name) => Eq (HsDecl name pat) where
d1 == d2 = hsDeclName d1 == hsDeclName d2
-instance (Ord name) => Ord (HsDecl flexi name pat) where
+instance (Ord name) => Ord (HsDecl name pat) where
d1 `compare` d2 = hsDeclName d1 `compare` hsDeclName d2
#endif
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection[FixityDecl]{A fixity declaration}
-%* *
-%************************************************************************
-
-\begin{code}
-data FixityDecl name = FixityDecl name Fixity SrcLoc
-
-instance Outputable name => Outputable (FixityDecl name) where
- ppr (FixityDecl name fixity loc) = sep [ppr fixity, ppr name]
+-}
\end{code}
@@ -115,7 +132,7 @@ instance Outputable name => Outputable (FixityDecl name) where
%************************************************************************
\begin{code}
-data TyDecl name
+data TyClDecl name pat
= TyData NewOrData
(Context name) -- context
name -- type constructor
@@ -133,11 +150,41 @@ data TyDecl name
(HsType name) -- synonym expansion
SrcLoc
+ | ClassDecl (Context name) -- context...
+ name -- name of the class
+ [HsTyVar name] -- the class type variables
+ [Sig name] -- methods' signatures
+ (MonoBinds name pat) -- default methods
+ (ClassPragmas name)
+ name name -- The names of the tycon and datacon for this class
+ -- These are filled in by the renamer
+ SrcLoc
\end{code}
\begin{code}
-instance (NamedThing name, Outputable name)
- => Outputable (TyDecl name) where
+countTyClDecls :: [TyClDecl name pat] -> (Int, Int, Int, Int)
+ -- class, data, newtype, synonym decls
+countTyClDecls decls
+ = (length [() | ClassDecl _ _ _ _ _ _ _ _ _ <- decls],
+ length [() | TyData DataType _ _ _ _ _ _ _ <- decls],
+ length [() | TyData NewType _ _ _ _ _ _ _ <- decls],
+ length [() | TySynonym _ _ _ _ <- decls])
+
+isDataDecl, isSynDecl, isClassDecl :: TyClDecl name pat -> Bool
+
+isSynDecl (TySynonym _ _ _ _) = True
+isSynDecl other = False
+
+isDataDecl (TyData _ _ _ _ _ _ _ _) = True
+isDataDecl other = False
+
+isClassDecl (ClassDecl _ _ _ _ _ _ _ _ _) = True
+isClassDecl other = False
+\end{code}
+
+\begin{code}
+instance (NamedThing name, Outputable name, Outputable pat)
+ => Outputable (TyClDecl name pat) where
ppr (TySynonym tycon tyvars mono_ty src_loc)
= hang (pp_decl_head SLIT("type") empty tycon tyvars)
@@ -153,13 +200,27 @@ instance (NamedThing name, Outputable name)
NewType -> SLIT("newtype")
DataType -> SLIT("data")
+ ppr (ClassDecl context clas tyvars sigs methods pragmas _ _ src_loc)
+ | null sigs -- No "where" part
+ = top_matter
+
+ | otherwise -- Laid out
+ = sep [hsep [top_matter, ptext SLIT("where {")],
+ nest 4 (vcat [sep (map ppr_sig sigs),
+ ppr methods,
+ char '}'])]
+ where
+ top_matter = hsep [ptext SLIT("class"), pprContext context,
+ ppr clas, hsep (map (ppr) tyvars)]
+ ppr_sig sig = ppr sig <> semi
+
+
pp_decl_head str pp_context tycon tyvars
= hsep [ptext str, pp_context, ppr tycon,
interppSP tyvars, ptext SLIT("=")]
-pp_condecls [] = empty -- Curious!
-pp_condecls (c:cs)
- = sep (ppr c : map (\ c -> (<>) (ptext SLIT("| ")) (ppr c)) cs)
+pp_condecls [] = empty -- Curious!
+pp_condecls (c:cs) = sep (ppr c : map (\ c -> ptext SLIT("|") <+> ppr c) cs)
pp_tydecl pp_head pp_decl_rhs derivings
= hang pp_head 4 (sep [
@@ -241,50 +302,13 @@ ppr_con_details con (RecCon fields)
= ppr con <+> braces (hsep (punctuate comma (map ppr_field fields)))
where
ppr_field (ns, ty) = hsep (map (ppr) ns) <+>
- ptext SLIT("::") <+>
+ dcolon <+>
ppr_bang ty
ppr_bang (Banged ty) = ptext SLIT("!") <> pprParendHsType ty
ppr_bang (Unbanged ty) = pprParendHsType ty
\end{code}
-%************************************************************************
-%* *
-\subsection[ClassDecl]{A class declaration}
-%* *
-%************************************************************************
-
-\begin{code}
-data ClassDecl flexi name pat
- = ClassDecl (Context name) -- context...
- name -- name of the class
- [HsTyVar name] -- the class type variables
- [Sig name] -- methods' signatures
- (MonoBinds flexi name pat) -- default methods
- (ClassPragmas name)
- name name -- The names of the tycon and datacon for this class
- -- These are filled in by the renamer
- SrcLoc
-\end{code}
-
-\begin{code}
-instance (NamedThing name, Outputable name, Outputable pat)
- => Outputable (ClassDecl flexi name pat) where
-
- ppr (ClassDecl context clas tyvars sigs methods pragmas _ _ src_loc)
- | null sigs -- No "where" part
- = top_matter
-
- | otherwise -- Laid out
- = sep [hsep [top_matter, ptext SLIT("where {")],
- nest 4 (vcat [sep (map ppr_sig sigs),
- ppr methods,
- char '}'])]
- where
- top_matter = hsep [ptext SLIT("class"), pprContext context,
- ppr clas, hsep (map (ppr) tyvars)]
- ppr_sig sig = ppr sig <> semi
-\end{code}
%************************************************************************
%* *
@@ -293,12 +317,12 @@ instance (NamedThing name, Outputable name, Outputable pat)
%************************************************************************
\begin{code}
-data InstDecl flexi name pat
+data InstDecl name pat
= InstDecl (HsType name) -- Context => Class Instance-type
-- Using a polytype means that the renamer conveniently
-- figures out the quantified type variables for us.
- (MonoBinds flexi name pat)
+ (MonoBinds name pat)
[Sig name] -- User-supplied pragmatic info
@@ -309,7 +333,7 @@ data InstDecl flexi name pat
\begin{code}
instance (NamedThing name, Outputable name, Outputable pat)
- => Outputable (InstDecl flexi name pat) where
+ => Outputable (InstDecl name pat) where
ppr (InstDecl inst_ty binds uprags dfun_name src_loc)
= getPprStyle $ \ sty ->
@@ -365,7 +389,7 @@ instance (NamedThing name, Outputable name)
ppr (ForeignDecl nm imp_exp ty ext_name cconv src_loc)
= ptext SLIT("foreign") <+> ppr_imp_exp <+> pprCallConv cconv <+>
- ppr ext_name <+> ppr_unsafe <+> ppr nm <+> ptext SLIT("::") <+> ppr ty
+ ppr ext_name <+> ppr_unsafe <+> ppr nm <+> dcolon <+> ppr ty
where
(ppr_imp_exp, ppr_unsafe) =
case imp_exp of
@@ -412,7 +436,7 @@ data IfaceSig name
instance (NamedThing name, Outputable name) => Outputable (IfaceSig name) where
ppr (IfaceSig var ty _ _)
- = hang (hsep [ppr var, ptext SLIT("::")])
+ = hang (hsep [ppr var, dcolon])
4 (ppr ty)
data HsIdInfo name
@@ -425,7 +449,7 @@ data HsIdInfo name
data HsStrictnessInfo name
- = HsStrictnessInfo [Demand]
+ = HsStrictnessInfo ([Demand], Bool)
(Maybe (name, [name])) -- Worker, if any
-- and needed constructors
| HsBottom
diff --git a/ghc/compiler/hsSyn/HsExpr.hi-boot b/ghc/compiler/hsSyn/HsExpr.hi-boot
index 82447a0a2e..64b4a2fc97 100644
--- a/ghc/compiler/hsSyn/HsExpr.hi-boot
+++ b/ghc/compiler/hsSyn/HsExpr.hi-boot
@@ -2,5 +2,5 @@ _interface_ HsExpr 1
_exports_
HsExpr HsExpr pprExpr;
_declarations_
-1 data HsExpr f i p;
-1 pprExpr _:_ _forall_ [i p f] {Name.NamedThing i, Outputable.Outputable i, Outputable.Outputable p} => HsExpr.HsExpr f i p -> Outputable.SDoc ;;
+1 data HsExpr i p;
+1 pprExpr _:_ _forall_ [i p] {Name.NamedThing i, Outputable.Outputable i, Outputable.Outputable p} => HsExpr.HsExpr i p -> Outputable.SDoc ;;
diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs
index 6a07e4cf7c..d1ba9015f9 100644
--- a/ghc/compiler/hsSyn/HsExpr.lhs
+++ b/ghc/compiler/hsSyn/HsExpr.lhs
@@ -17,11 +17,11 @@ import BasicTypes ( Fixity(..), FixityDirection(..) )
import HsTypes ( HsType )
-- others:
-import Name ( Name, NamedThing(..), isLexSym, occNameString )
+import Name ( Name, NamedThing(..), isSymOcc )
import Outputable
import PprType ( pprType, pprParendType )
-import Type ( GenType )
-import Var ( GenTyVar, Id )
+import Type ( Type )
+import Var ( TyVar, Id )
import DataCon ( DataCon )
import SrcLoc ( SrcLoc )
\end{code}
@@ -33,15 +33,15 @@ import SrcLoc ( SrcLoc )
%************************************************************************
\begin{code}
-data HsExpr flexi id pat
+data HsExpr id pat
= HsVar id -- variable
| HsLit HsLit -- literal
| HsLitOut HsLit -- TRANSLATION
- (GenType flexi) -- (with its type)
+ Type -- (with its type)
- | HsLam (Match flexi id pat) -- lambda
- | HsApp (HsExpr flexi id pat) -- application
- (HsExpr flexi id pat)
+ | HsLam (Match id pat) -- lambda
+ | HsApp (HsExpr id pat) -- application
+ (HsExpr id pat)
-- Operator applications:
-- NB Bracketed ops such as (+) come out as Vars.
@@ -49,95 +49,95 @@ data HsExpr flexi id pat
-- NB We need an expr for the operator in an OpApp/Section since
-- the typechecker may need to apply the operator to a few types.
- | OpApp (HsExpr flexi id pat) -- left operand
- (HsExpr flexi id pat) -- operator
+ | OpApp (HsExpr id pat) -- left operand
+ (HsExpr id pat) -- operator
Fixity -- Renamer adds fixity; bottom until then
- (HsExpr flexi id pat) -- right operand
+ (HsExpr id pat) -- right operand
-- We preserve prefix negation and parenthesis for the precedence parser.
-- They are eventually removed by the type checker.
- | NegApp (HsExpr flexi id pat) -- negated expr
- (HsExpr flexi id pat) -- the negate id (in a HsVar)
+ | NegApp (HsExpr id pat) -- negated expr
+ (HsExpr id pat) -- the negate id (in a HsVar)
- | HsPar (HsExpr flexi id pat) -- parenthesised expr
+ | HsPar (HsExpr id pat) -- parenthesised expr
- | SectionL (HsExpr flexi id pat) -- operand
- (HsExpr flexi id pat) -- operator
- | SectionR (HsExpr flexi id pat) -- operator
- (HsExpr flexi id pat) -- operand
+ | SectionL (HsExpr id pat) -- operand
+ (HsExpr id pat) -- operator
+ | SectionR (HsExpr id pat) -- operator
+ (HsExpr id pat) -- operand
- | HsCase (HsExpr flexi id pat)
- [Match flexi id pat] -- must have at least one Match
+ | HsCase (HsExpr id pat)
+ [Match id pat]
SrcLoc
- | HsIf (HsExpr flexi id pat) -- predicate
- (HsExpr flexi id pat) -- then part
- (HsExpr flexi id pat) -- else part
+ | HsIf (HsExpr id pat) -- predicate
+ (HsExpr id pat) -- then part
+ (HsExpr id pat) -- else part
SrcLoc
- | HsLet (HsBinds flexi id pat) -- let(rec)
- (HsExpr flexi id pat)
+ | HsLet (HsBinds id pat) -- let(rec)
+ (HsExpr id pat)
| HsDo StmtCtxt
- [Stmt flexi id pat] -- "do":one or more stmts
+ [Stmt id pat] -- "do":one or more stmts
SrcLoc
| HsDoOut StmtCtxt
- [Stmt flexi id pat] -- "do":one or more stmts
- id -- id for return
- id -- id for >>=
+ [Stmt id pat] -- "do":one or more stmts
+ id -- id for return
+ id -- id for >>=
id -- id for zero
- (GenType flexi) -- Type of the whole expression
+ Type -- Type of the whole expression
SrcLoc
| ExplicitList -- syntactic list
- [HsExpr flexi id pat]
+ [HsExpr id pat]
| ExplicitListOut -- TRANSLATION
- (GenType flexi) -- Gives type of components of list
- [HsExpr flexi id pat]
+ Type -- Gives type of components of list
+ [HsExpr id pat]
| ExplicitTuple -- tuple
- [HsExpr flexi id pat]
+ [HsExpr id pat]
-- NB: Unit is ExplicitTuple []
-- for tuples, we can get the types
-- direct from the components
Bool -- boxed?
| HsCon DataCon -- TRANSLATION; a saturated constructor application
- [GenType flexi]
- [HsExpr flexi id pat]
+ [Type]
+ [HsExpr id pat]
-- Record construction
| RecordCon id -- The constructor
- (HsRecordBinds flexi id pat)
+ (HsRecordBinds id pat)
| RecordConOut DataCon
- (HsExpr flexi id pat) -- Data con Id applied to type args
- (HsRecordBinds flexi id pat)
+ (HsExpr id pat) -- Data con Id applied to type args
+ (HsRecordBinds id pat)
-- Record update
- | RecordUpd (HsExpr flexi id pat)
- (HsRecordBinds flexi id pat)
+ | RecordUpd (HsExpr id pat)
+ (HsRecordBinds id pat)
- | RecordUpdOut (HsExpr flexi id pat) -- TRANSLATION
- (GenType flexi) -- Type of *result* record (may differ from
+ | RecordUpdOut (HsExpr id pat) -- TRANSLATION
+ Type -- Type of *result* record (may differ from
-- type of input record)
[id] -- Dicts needed for construction
- (HsRecordBinds flexi id pat)
+ (HsRecordBinds id pat)
- | ExprWithTySig -- signature binding
- (HsExpr flexi id pat)
+ | ExprWithTySig -- signature binding
+ (HsExpr id pat)
(HsType id)
- | ArithSeqIn -- arithmetic sequence
- (ArithSeqInfo flexi id pat)
+ | ArithSeqIn -- arithmetic sequence
+ (ArithSeqInfo id pat)
| ArithSeqOut
- (HsExpr flexi id pat) -- (typechecked, of course)
- (ArithSeqInfo flexi id pat)
+ (HsExpr id pat) -- (typechecked, of course)
+ (ArithSeqInfo id pat)
| CCall FAST_STRING -- call into the C world; string is
- [HsExpr flexi id pat] -- the C function; exprs are the
+ [HsExpr id pat] -- the C function; exprs are the
-- arguments to pass.
Bool -- True <=> might cause Haskell
-- garbage-collection (must generate
@@ -146,33 +146,33 @@ data HsExpr flexi id pat
-- NOTE: this CCall is the *boxed*
-- version; the desugarer will convert
-- it into the unboxed "ccall#".
- (GenType flexi) -- The result type; will be *bottom*
+ Type -- The result type; will be *bottom*
-- until the typechecker gets ahold of it
| HsSCC FAST_STRING -- "set cost centre" (_scc_) annotation
- (HsExpr flexi id pat) -- expr whose cost is to be measured
+ (HsExpr id pat) -- expr whose cost is to be measured
\end{code}
Everything from here on appears only in typechecker output.
\begin{code}
| TyLam -- TRANSLATION
- [GenTyVar flexi]
- (HsExpr flexi id pat)
+ [TyVar]
+ (HsExpr id pat)
| TyApp -- TRANSLATION
- (HsExpr flexi id pat) -- generated by Spec
- [GenType flexi]
+ (HsExpr id pat) -- generated by Spec
+ [Type]
-- DictLam and DictApp are "inverses"
| DictLam
[id]
- (HsExpr flexi id pat)
+ (HsExpr id pat)
| DictApp
- (HsExpr flexi id pat)
+ (HsExpr id pat)
[id]
-type HsRecordBinds flexi id pat
- = [(id, HsExpr flexi id pat, Bool)]
+type HsRecordBinds id pat
+ = [(id, HsExpr id pat, Bool)]
-- True <=> source code used "punning",
-- i.e. {op1, op2} rather than {op1=e1, op2=e2}
\end{code}
@@ -185,13 +185,13 @@ A @Dictionary@, unless of length 0 or 1, becomes a tuple. A
\begin{code}
instance (NamedThing id, Outputable id, Outputable pat) =>
- Outputable (HsExpr flexi id pat) where
+ Outputable (HsExpr id pat) where
ppr expr = pprExpr expr
\end{code}
\begin{code}
pprExpr :: (NamedThing id, Outputable id, Outputable pat)
- => HsExpr flexi id pat -> SDoc
+ => HsExpr id pat -> SDoc
pprExpr e = pprDeeper (ppr_expr e)
pprBinds b = pprDeeper (ppr b)
@@ -202,7 +202,7 @@ ppr_expr (HsLit lit) = ppr lit
ppr_expr (HsLitOut lit _) = ppr lit
ppr_expr (HsLam match)
- = hsep [char '\\', nest 2 (pprMatch True match)]
+ = hsep [char '\\', nest 2 (pprMatch (True,empty) match)]
ppr_expr expr@(HsApp e1 e2)
= let (fun, args) = collect_args expr [] in
@@ -225,8 +225,8 @@ ppr_expr (OpApp e1 op fixity e2)
pp_infixly v
= sep [pp_e1, hsep [pp_v, pp_e2]]
where
- pp_v | isLexSym (occNameString (getOccName v)) = ppr v
- | otherwise = char '`' <> ppr v <> char '`'
+ pp_v | isSymOcc (getOccName v) = ppr v
+ | otherwise = char '`' <> ppr v <> char '`'
ppr_expr (NegApp e _)
= char '-' <+> pprParendExpr e
@@ -305,7 +305,7 @@ ppr_expr (RecordUpdOut aexp _ _ rbinds)
= pp_rbinds (pprParendExpr aexp) rbinds
ppr_expr (ExprWithTySig expr sig)
- = hang (nest 2 (ppr_expr expr) <+> ptext SLIT("::"))
+ = hang (nest 2 (ppr_expr expr) <+> dcolon)
4 (ppr sig)
ppr_expr (ArithSeqIn info)
@@ -349,7 +349,7 @@ ppr_expr (DictApp expr dnames)
Parenthesize unless very simple:
\begin{code}
pprParendExpr :: (NamedThing id, Outputable id, Outputable pat)
- => HsExpr flexi id pat -> SDoc
+ => HsExpr id pat -> SDoc
pprParendExpr expr
= let
@@ -377,7 +377,7 @@ pprParendExpr expr
\begin{code}
pp_rbinds :: (NamedThing id, Outputable id, Outputable pat)
=> SDoc
- -> HsRecordBinds flexi id pat -> SDoc
+ -> HsRecordBinds id pat -> SDoc
pp_rbinds thing rbinds
= hang thing
@@ -418,25 +418,25 @@ pprDo ListComp stmts
\end{code}
\begin{code}
-data Stmt flexi id pat
+data Stmt id pat
= BindStmt pat
- (HsExpr flexi id pat)
+ (HsExpr id pat)
SrcLoc
- | LetStmt (HsBinds flexi id pat)
+ | LetStmt (HsBinds id pat)
- | GuardStmt (HsExpr flexi id pat) -- List comps only
+ | GuardStmt (HsExpr id pat) -- List comps only
SrcLoc
- | ExprStmt (HsExpr flexi id pat) -- Do stmts; and guarded things at the end
+ | ExprStmt (HsExpr id pat) -- Do stmts; and guarded things at the end
SrcLoc
- | ReturnStmt (HsExpr flexi id pat) -- List comps only, at the end
+ | ReturnStmt (HsExpr id pat) -- List comps only, at the end
\end{code}
\begin{code}
instance (NamedThing id, Outputable id, Outputable pat) =>
- Outputable (Stmt flexi id pat) where
+ Outputable (Stmt id pat) where
ppr stmt = pprStmt stmt
pprStmt (BindStmt pat expr _)
@@ -458,20 +458,20 @@ pprStmt (ReturnStmt expr)
%************************************************************************
\begin{code}
-data ArithSeqInfo flexi id pat
- = From (HsExpr flexi id pat)
- | FromThen (HsExpr flexi id pat)
- (HsExpr flexi id pat)
- | FromTo (HsExpr flexi id pat)
- (HsExpr flexi id pat)
- | FromThenTo (HsExpr flexi id pat)
- (HsExpr flexi id pat)
- (HsExpr flexi id pat)
+data ArithSeqInfo id pat
+ = From (HsExpr id pat)
+ | FromThen (HsExpr id pat)
+ (HsExpr id pat)
+ | FromTo (HsExpr id pat)
+ (HsExpr id pat)
+ | FromThenTo (HsExpr id pat)
+ (HsExpr id pat)
+ (HsExpr id pat)
\end{code}
\begin{code}
instance (NamedThing id, Outputable id, Outputable pat) =>
- Outputable (ArithSeqInfo flexi id pat) where
+ Outputable (ArithSeqInfo id pat) where
ppr (From e1) = hcat [ppr e1, pp_dotdot]
ppr (FromThen e1 e2) = hcat [ppr e1, comma, space, ppr e2, pp_dotdot]
ppr (FromTo e1 e3) = hcat [ppr e1, pp_dotdot, ppr e3]
diff --git a/ghc/compiler/hsSyn/HsImpExp.lhs b/ghc/compiler/hsSyn/HsImpExp.lhs
index 9083d9e18c..84dcfce862 100644
--- a/ghc/compiler/hsSyn/HsImpExp.lhs
+++ b/ghc/compiler/hsSyn/HsImpExp.lhs
@@ -8,8 +8,8 @@ module HsImpExp where
#include "HsVersions.h"
-import BasicTypes ( Module, IfaceFlavour(..) )
-import Name ( NamedThing )
+import BasicTypes ( IfaceFlavour(..) )
+import Name ( Module, NamedThing, pprModule )
import Outputable
import SrcLoc ( SrcLoc )
\end{code}
@@ -36,7 +36,7 @@ data ImportDecl name
instance (NamedThing name, Outputable name) => Outputable (ImportDecl name) where
ppr (ImportDecl mod qual as_source as spec _)
= hang (hsep [ptext SLIT("import"), pp_src as_source,
- pp_qual qual, ptext mod, pp_as as])
+ pp_qual qual, pprModule mod, pp_as as])
4 (pp_spec spec)
where
pp_src HiFile = empty
@@ -46,7 +46,7 @@ instance (NamedThing name, Outputable name) => Outputable (ImportDecl name) wher
pp_qual True = ptext SLIT("qualified")
pp_as Nothing = empty
- pp_as (Just a) = ptext SLIT("as ") <+> ptext a
+ pp_as (Just a) = ptext SLIT("as ") <+> pprModule a
pp_spec Nothing = empty
pp_spec (Just (False, spec))
@@ -86,6 +86,6 @@ instance (NamedThing name, Outputable name) => Outputable (IE name) where
ppr (IEThingWith thing withs)
= ppr thing <> parens (fsep (punctuate comma (map ppr withs)))
ppr (IEModuleContents mod)
- = ptext SLIT("module") <+> ptext mod
+ = ptext SLIT("module") <+> pprModule mod
\end{code}
diff --git a/ghc/compiler/hsSyn/HsMatches.hi-boot b/ghc/compiler/hsSyn/HsMatches.hi-boot
index b783d025c9..b470ced76d 100644
--- a/ghc/compiler/hsSyn/HsMatches.hi-boot
+++ b/ghc/compiler/hsSyn/HsMatches.hi-boot
@@ -1,9 +1,9 @@
-_interface_ HsMatches 1
+_interface_ HsMatches 2
_exports_
-HsMatches Match GRHSsAndBinds pprMatch pprMatches pprGRHSsAndBinds ;
+HsMatches Match GRHSs pprMatch pprMatches pprGRHSs ;
_declarations_
-1 data Match a b c ;
-1 data GRHSsAndBinds a b c ;
-1 pprGRHSsAndBinds _:_ _forall_ [i p f] {Name.NamedThing i, Outputable.Outputable i, Outputable.Outputable p} => PrelBase.Bool -> HsMatches.GRHSsAndBinds f i p -> Outputable.SDoc ;;
-1 pprMatch _:_ _forall_ [i p f] {Name.NamedThing i, Outputable.Outputable i, Outputable.Outputable p} => PrelBase.Bool -> HsMatches.Match f i p -> Outputable.SDoc ;;
-1 pprMatches _:_ _forall_ [i p f] {Name.NamedThing i, Outputable.Outputable i, Outputable.Outputable p} => (PrelBase.Bool, Outputable.SDoc) -> [HsMatches.Match f i p] -> Outputable.SDoc ;;
+1 data Match a b ;
+1 data GRHSs a b ;
+1 pprGRHSs _:_ _forall_ [i p] {Name.NamedThing i, Outputable.Outputable i, Outputable.Outputable p} => PrelBase.Bool -> HsMatches.GRHSs i p -> Outputable.SDoc ;;
+1 pprMatch _:_ _forall_ [i p] {Name.NamedThing i, Outputable.Outputable i, Outputable.Outputable p} => (PrelBase.Bool, Outputable.SDoc) -> HsMatches.Match i p -> Outputable.SDoc ;;
+1 pprMatches _:_ _forall_ [i p] {Name.NamedThing i, Outputable.Outputable i, Outputable.Outputable p} => (PrelBase.Bool, Outputable.SDoc) -> [HsMatches.Match i p] -> Outputable.SDoc ;;
diff --git a/ghc/compiler/hsSyn/HsMatches.lhs b/ghc/compiler/hsSyn/HsMatches.lhs
index c09fff192e..7fe648d25e 100644
--- a/ghc/compiler/hsSyn/HsMatches.lhs
+++ b/ghc/compiler/hsSyn/HsMatches.lhs
@@ -3,7 +3,7 @@
%
\section[HsMatches]{Abstract syntax: matches and guarded right-hand-sides}
-The @Match@, @GRHSsAndBinds@ and @GRHS@ datatypes.
+The @Match@, @GRHSs@ and @GRHS@ datatypes.
\begin{code}
module HsMatches where
@@ -12,10 +12,11 @@ module HsMatches where
-- Friends
import HsExpr ( HsExpr, Stmt(..) )
-import HsBinds ( HsBinds, nullBinds )
+import HsBinds ( HsBinds(..), nullBinds )
+import HsTypes ( HsTyVar, HsType )
-- Others
-import Type ( GenType )
+import Type ( Type )
import SrcLoc ( SrcLoc )
import Outputable
import Name ( NamedThing )
@@ -23,7 +24,7 @@ import Name ( NamedThing )
%************************************************************************
%* *
-\subsection{@Match@, @GRHSsAndBinds@, and @GRHS@ datatypes}
+\subsection{@Match@, @GRHSs@, and @GRHS@ datatypes}
%* *
%************************************************************************
@@ -37,46 +38,38 @@ g ((x:ys),y) = y+1,
then \tr{g} has two @Match@es: @(x,y) = y@ and @((x:ys),y) = y+1@.
It is always the case that each element of an @[Match]@ list has the
-same number of @PatMatch@s inside it. This corresponds to saying that
+same number of @pats@s inside it. This corresponds to saying that
a function defined by pattern matching must have the same number of
patterns in each equation.
\begin{code}
-data Match flexi id pat
- = PatMatch pat
- (Match flexi id pat)
- | GRHSMatch (GRHSsAndBinds flexi id pat)
-
- | SimpleMatch (HsExpr flexi id pat) -- Used in translations
-\end{code}
-
-Sets of guarded right hand sides (GRHSs). In:
-\begin{verbatim}
-f (x,y) | x==True = y
- | otherwise = y*2
-\end{verbatim}
-a guarded right hand side is either
-@(x==True = y)@, or @(otherwise = y*2)@.
-
-For each match, there may be several guarded right hand
-sides, as the definition of @f@ shows.
-
-\begin{code}
-data GRHSsAndBinds flexi id pat
- = GRHSsAndBindsIn [GRHS flexi id pat] -- at least one GRHS
- (HsBinds flexi id pat)
-
- | GRHSsAndBindsOut [GRHS flexi id pat] -- at least one GRHS
- (HsBinds flexi id pat)
- (GenType flexi)
-
-data GRHS flexi id pat
- = GRHS [Stmt flexi id pat] -- The RHS is the final ExprStmt
- -- I considered using a RetunStmt, but
- -- it printed 'wrong' in error messages
- SrcLoc
-
-unguardedRHS :: (HsExpr flexi id pat) -> SrcLoc -> [GRHS flexi id pat]
+data Match id pat
+ = Match
+ [HsTyVar id] -- Tyvars wrt which this match is universally quantified
+ -- emtpy after typechecking
+ [pat] -- The patterns
+ (Maybe (HsType id)) -- A type signature for the result of the match
+ -- Nothing after typechecking
+
+ (GRHSs id pat)
+
+-- GRHSs are used both for pattern bindings and for Matches
+data GRHSs id pat
+ = GRHSs [GRHS id pat] -- Guarded RHSs
+ (HsBinds id pat) -- The where clause
+ (Maybe Type) -- Just rhs_ty after type checking
+
+data GRHS id pat
+ = GRHS [Stmt id pat] -- The RHS is the final ExprStmt
+ -- I considered using a RetunStmt, but
+ -- it printed 'wrong' in error messages
+ SrcLoc
+
+mkSimpleMatch :: [pat] -> HsExpr id pat -> Maybe Type -> SrcLoc -> Match id pat
+mkSimpleMatch pats rhs maybe_rhs_ty locn
+ = Match [] pats Nothing (GRHSs (unguardedRHS rhs locn) EmptyBinds maybe_rhs_ty)
+
+unguardedRHS :: HsExpr id pat -> SrcLoc -> [GRHS id pat]
unguardedRHS rhs loc = [GRHS [ExprStmt rhs loc] loc]
\end{code}
@@ -85,9 +78,8 @@ source-location gotten from the GRHS inside.
THis is something of a nuisance, but no more.
\begin{code}
-getMatchLoc :: Match flexi id pat -> SrcLoc
-getMatchLoc (PatMatch _ m) = getMatchLoc m
-getMatchLoc (GRHSMatch (GRHSsAndBindsIn (GRHS _ loc : _) _)) = loc
+getMatchLoc :: Match id pat -> SrcLoc
+getMatchLoc (Match _ _ _ (GRHSs (GRHS _ loc : _) _ _)) = loc
\end{code}
%************************************************************************
@@ -99,59 +91,35 @@ getMatchLoc (GRHSMatch (GRHSsAndBindsIn (GRHS _ loc : _) _)) = loc
We know the list must have at least one @Match@ in it.
\begin{code}
pprMatches :: (NamedThing id, Outputable id, Outputable pat)
- => (Bool, SDoc) -> [Match flexi id pat] -> SDoc
-
-pprMatches print_info@(is_case, name) [match]
- = if is_case then
- pprMatch is_case match
- else
- name <+> (pprMatch is_case match)
+ => (Bool, SDoc) -> [Match id pat] -> SDoc
+pprMatches print_info matches = vcat (map (pprMatch print_info) matches)
-pprMatches print_info (match1 : rest)
- = ($$) (pprMatches print_info [match1])
- (pprMatches print_info rest)
----------------------------------------------
pprMatch :: (NamedThing id, Outputable id, Outputable pat)
- => Bool -> Match flexi id pat -> SDoc
-
-pprMatch is_case first_match
- = sep [(sep (map (ppr) row_of_pats)),
- grhss_etc_stuff]
- where
- (row_of_pats, grhss_etc_stuff) = ppr_match is_case first_match
-
- ppr_match is_case (PatMatch pat match)
- = (pat:pats, grhss_stuff)
- where
- (pats, grhss_stuff) = ppr_match is_case match
-
- ppr_match is_case (GRHSMatch grhss_n_binds)
- = ([], pprGRHSsAndBinds is_case grhss_n_binds)
-
- ppr_match is_case (SimpleMatch expr)
- = ([], text (if is_case then "->" else "=") <+> ppr expr)
-
-----------------------------------------------------------
-
-pprGRHSsAndBinds :: (NamedThing id, Outputable id, Outputable pat)
- => Bool -> GRHSsAndBinds flexi id pat -> SDoc
-
-pprGRHSsAndBinds is_case (GRHSsAndBindsIn grhss binds)
- = ($$) (vcat (map (pprGRHS is_case) grhss))
- (if (nullBinds binds)
- then empty
- else vcat [ text "where", nest 4 (pprDeeper (ppr binds)) ])
+ => (Bool, SDoc) -> Match id pat -> SDoc
+pprMatch print_info@(is_case, name) (Match _ pats maybe_ty grhss)
+ = maybe_name <+> sep [sep (map ppr pats),
+ ppr_maybe_ty,
+ nest 2 (pprGRHSs is_case grhss)]
+ where
+ maybe_name | is_case = empty
+ | otherwise = name
+ ppr_maybe_ty = case maybe_ty of
+ Just ty -> dcolon <+> ppr ty
+ Nothing -> empty
+
+
+pprGRHSs :: (NamedThing id, Outputable id, Outputable pat)
+ => Bool -> GRHSs id pat -> SDoc
+pprGRHSs is_case (GRHSs grhss binds maybe_ty)
+ = vcat (map (pprGRHS is_case) grhss)
+ $$
+ (if nullBinds binds then empty
+ else text "where" $$ nest 4 (pprDeeper (ppr binds)))
-pprGRHSsAndBinds is_case (GRHSsAndBindsOut grhss binds ty)
- = ($$) (vcat (map (pprGRHS is_case) grhss))
- (if (nullBinds binds)
- then empty
- else vcat [text "where", nest 4 (pprDeeper (ppr binds)) ])
----------------------------------------------
pprGRHS :: (NamedThing id, Outputable id, Outputable pat)
- => Bool -> GRHS flexi id pat -> SDoc
+ => Bool -> GRHS id pat -> SDoc
pprGRHS is_case (GRHS [ExprStmt expr _] locn)
= text (if is_case then "->" else "=") <+> pprDeeper (ppr expr)
diff --git a/ghc/compiler/hsSyn/HsPat.lhs b/ghc/compiler/hsSyn/HsPat.lhs
index 409e95962c..d115306a3a 100644
--- a/ghc/compiler/hsSyn/HsPat.lhs
+++ b/ghc/compiler/hsSyn/HsPat.lhs
@@ -9,10 +9,10 @@ module HsPat (
OutPat(..),
irrefutablePat, irrefutablePats,
- failureFreePat,
+ failureFreePat, isWildPat,
patsAreAllCons, isConPat,
patsAreAllLits, isLitPat,
- collectPatBinders
+ collectPatBinders, collectPatsBinders
) where
#include "HsVersions.h"
@@ -20,15 +20,16 @@ module HsPat (
-- friends:
import HsBasic ( HsLit )
import HsExpr ( HsExpr )
+import HsTypes ( HsType )
import BasicTypes ( Fixity )
-- others:
-import Var ( Id, GenTyVar )
+import Var ( Id, TyVar )
import DataCon ( DataCon, dataConTyCon )
import Maybes ( maybeToBool )
import Outputable
import TyCon ( maybeTyConSingleCon )
-import Type ( GenType )
+import Type ( Type )
\end{code}
Patterns come in distinct before- and after-typechecking flavo(u)rs.
@@ -40,6 +41,8 @@ data InPat name
| LazyPatIn (InPat name) -- lazy pattern
| AsPatIn name -- as pattern
(InPat name)
+ | SigPatIn (InPat name)
+ (HsType name)
| ConPatIn name -- constructed type
[InPat name]
| ConOpPatIn (InPat name)
@@ -62,49 +65,49 @@ data InPat name
| RecPatIn name -- record
[(name, InPat name, Bool)] -- True <=> source used punning
-data OutPat flexi id
- = WildPat (GenType flexi) -- wild card
+data OutPat id
+ = WildPat Type -- wild card
- | VarPat id -- variable (type is in the Id)
+ | VarPat id -- variable (type is in the Id)
- | LazyPat (OutPat flexi id) -- lazy pattern
+ | LazyPat (OutPat id) -- lazy pattern
- | AsPat id -- as pattern
- (OutPat flexi id)
+ | AsPat id -- as pattern
+ (OutPat id)
- | ListPat -- syntactic list
- (GenType flexi) -- the type of the elements
- [OutPat flexi id]
+ | ListPat -- syntactic list
+ Type -- the type of the elements
+ [OutPat id]
- | TuplePat [OutPat flexi id] -- tuple
+ | TuplePat [OutPat id] -- tuple
Bool -- boxed?
-- UnitPat is TuplePat []
| ConPat DataCon
- (GenType flexi) -- the type of the pattern
- [GenTyVar flexi] -- Existentially bound type variables
+ Type -- the type of the pattern
+ [TyVar] -- Existentially bound type variables
[id] -- Ditto dictionaries
- [OutPat flexi id]
+ [OutPat id]
-- ConOpPats are only used on the input side
| RecPat DataCon -- record constructor
- (GenType flexi) -- the type of the pattern
- [GenTyVar flexi] -- Existentially bound type variables
+ Type -- the type of the pattern
+ [TyVar] -- Existentially bound type variables
[id] -- Ditto dictionaries
- [(Id, OutPat flexi id, Bool)] -- True <=> source used punning
+ [(Id, OutPat id, Bool)] -- True <=> source used punning
| LitPat -- Used for *non-overloaded* literal patterns:
-- Int#, Char#, Int, Char, String, etc.
HsLit
- (GenType flexi) -- type of pattern
+ Type -- type of pattern
| NPat -- Used for *overloaded* literal patterns
HsLit -- the literal is retained so that
-- the desugarer can readily identify
-- equations with identical literal-patterns
- (GenType flexi) -- type of pattern, t
- (HsExpr flexi id (OutPat flexi id))
+ Type -- type of pattern, t
+ (HsExpr id (OutPat id))
-- of type t -> Bool; detects match
| NPlusKPat id
@@ -112,9 +115,9 @@ data OutPat flexi id
-- (This could be an Integer, but then
-- it's harder to partitionEqnsByLit
-- in the desugarer.)
- (GenType flexi) -- Type of pattern, t
- (HsExpr flexi id (OutPat flexi id)) -- Of type t -> Bool; detects match
- (HsExpr flexi id (OutPat flexi id)) -- Of type t -> t; subtracts k
+ Type -- Type of pattern, t
+ (HsExpr id (OutPat id)) -- Of type t -> Bool; detects match
+ (HsExpr id (OutPat id)) -- Of type t -> t; subtracts k
| DictPat -- Used when destructing Dictionaries with an explicit case
[id] -- superclass dicts
@@ -135,6 +138,7 @@ pprInPat :: (Outputable name) => InPat name -> SDoc
pprInPat (WildPatIn) = char '_'
pprInPat (VarPatIn var) = ppr var
pprInPat (LitPatIn s) = ppr s
+pprInPat (SigPatIn pat ty) = ppr pat <+> dcolon <+> ppr ty
pprInPat (LazyPatIn pat) = char '~' <> ppr pat
pprInPat (AsPatIn name pat) = parens (hcat [ppr name, char '@', ppr pat])
@@ -178,7 +182,7 @@ pprInPat (RecPatIn con rpats)
\end{code}
\begin{code}
-instance (Outputable id) => Outputable (OutPat flexi id) where
+instance (Outputable id) => Outputable (OutPat id) where
ppr = pprOutPat
\end{code}
@@ -249,7 +253,7 @@ patterns are treated specially, of course.
The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are.
\begin{code}
-irrefutablePats :: [OutPat a b] -> Bool
+irrefutablePats :: [OutPat id] -> Bool
irrefutablePats pat_list = all irrefutablePat pat_list
irrefutablePat (AsPat _ pat) = irrefutablePat pat
@@ -259,7 +263,7 @@ irrefutablePat (LazyPat _) = True
irrefutablePat (DictPat ds ms) = (length ds + length ms) <= 1
irrefutablePat other = False
-failureFreePat :: OutPat a b -> Bool
+failureFreePat :: OutPat id -> Bool
failureFreePat (WildPat _) = True
failureFreePat (VarPat _) = True
@@ -276,7 +280,10 @@ only_con con = maybeToBool (maybeTyConSingleCon (dataConTyCon con))
\end{code}
\begin{code}
-patsAreAllCons :: [OutPat a b] -> Bool
+isWildPat (WildPat _) = True
+isWildPat other = False
+
+patsAreAllCons :: [OutPat id] -> Bool
patsAreAllCons pat_list = all isConPat pat_list
isConPat (AsPat _ pat) = isConPat pat
@@ -287,7 +294,7 @@ isConPat (RecPat _ _ _ _ _) = True
isConPat (DictPat ds ms) = (length ds + length ms) > 1
isConPat other = False
-patsAreAllLits :: [OutPat a b] -> Bool
+patsAreAllLits :: [OutPat id] -> Bool
patsAreAllLits pat_list = all isLitPat pat_list
isLitPat (AsPat _ pat) = isLitPat pat
@@ -300,20 +307,26 @@ isLitPat other = False
This function @collectPatBinders@ works with the ``collectBinders''
functions for @HsBinds@, etc. The order in which the binders are
collected is important; see @HsBinds.lhs@.
+
\begin{code}
collectPatBinders :: InPat a -> [a]
-
-collectPatBinders WildPatIn = []
-collectPatBinders (VarPatIn var) = [var]
-collectPatBinders (LitPatIn _) = []
-collectPatBinders (LazyPatIn pat) = collectPatBinders pat
-collectPatBinders (AsPatIn a pat) = a : collectPatBinders pat
-collectPatBinders (NPlusKPatIn n _) = [n]
-collectPatBinders (ConPatIn c pats) = concat (map collectPatBinders pats)
-collectPatBinders (ConOpPatIn p1 c f p2) = collectPatBinders p1 ++ collectPatBinders p2
-collectPatBinders (NegPatIn pat) = collectPatBinders pat
-collectPatBinders (ParPatIn pat) = collectPatBinders pat
-collectPatBinders (ListPatIn pats) = concat (map collectPatBinders pats)
-collectPatBinders (TuplePatIn pats _) = concat (map collectPatBinders pats)
-collectPatBinders (RecPatIn c fields) = concat (map (\ (f,pat,_) -> collectPatBinders pat) fields)
+collectPatBinders pat = collect pat []
+
+collectPatsBinders :: [InPat a] -> [a]
+collectPatsBinders pats = foldr collect [] pats
+
+collect WildPatIn bndrs = bndrs
+collect (VarPatIn var) bndrs = var : bndrs
+collect (LitPatIn _) bndrs = bndrs
+collect (SigPatIn pat _) bndrs = collect pat bndrs
+collect (LazyPatIn pat) bndrs = collect pat bndrs
+collect (AsPatIn a pat) bndrs = a : collect pat bndrs
+collect (NPlusKPatIn n _) bndrs = n : bndrs
+collect (ConPatIn c pats) bndrs = foldr collect bndrs pats
+collect (ConOpPatIn p1 c f p2) bndrs = collect p1 (collect p2 bndrs)
+collect (NegPatIn pat) bndrs = collect pat bndrs
+collect (ParPatIn pat) bndrs = collect pat bndrs
+collect (ListPatIn pats) bndrs = foldr collect bndrs pats
+collect (TuplePatIn pats _) bndrs = foldr collect bndrs pats
+collect (RecPatIn c fields) bndrs = foldr (\ (f,pat,_) bndrs -> collect pat bndrs) bndrs fields
\end{code}
diff --git a/ghc/compiler/hsSyn/HsSyn.lhs b/ghc/compiler/hsSyn/HsSyn.lhs
index 2f7ec5111d..fb63e87008 100644
--- a/ghc/compiler/hsSyn/HsSyn.lhs
+++ b/ghc/compiler/hsSyn/HsSyn.lhs
@@ -30,14 +30,8 @@ module HsSyn (
#include "HsVersions.h"
-- friends:
+import HsDecls
import HsBinds
-import HsDecls ( HsDecl(..), TyDecl(..), InstDecl(..), ClassDecl(..),
- DefaultDecl(..), ForeignDecl(..), ForKind(..),
- ExtName(..), isDynamic, FixityDecl(..),
- ConDecl(..), ConDetails(..), BangType(..),
- IfaceSig(..), SpecDataSig(..),
- hsDeclName
- )
import HsExpr
import HsImpExp
import HsBasic
@@ -45,18 +39,18 @@ import HsMatches
import HsPat
import HsTypes
import HsCore
-import BasicTypes ( Fixity, Version, NewOrData, IfaceFlavour, Module )
+import BasicTypes ( Fixity, Version, NewOrData, IfaceFlavour )
-- others:
import Outputable
import SrcLoc ( SrcLoc )
import Bag
-import Name ( NamedThing )
+import Name ( Module, NamedThing, pprModule )
\end{code}
All we actually declare here is the top-level structure for a module.
\begin{code}
-data HsModule flexi name pat
+data HsModule name pat
= HsModule
Module -- module name
(Maybe Version) -- source interface version number
@@ -67,27 +61,25 @@ data HsModule flexi name pat
-- imported interfaces early on, adding that
-- info to TyDecls/etc; so this list is
-- often empty, downstream.
- [FixityDecl name]
- [HsDecl flexi name pat] -- Type, class, value, and interface signature decls
+ [HsDecl name pat] -- Type, class, value, and interface signature decls
SrcLoc
\end{code}
\begin{code}
instance (NamedThing name, Outputable name, Outputable pat)
- => Outputable (HsModule flexi name pat) where
+ => Outputable (HsModule name pat) where
- ppr (HsModule name iface_version exports imports fixities
+ ppr (HsModule name iface_version exports imports
decls src_loc)
= vcat [
case exports of
- Nothing -> hsep [ptext SLIT("module"), ptext name, ptext SLIT("where")]
+ Nothing -> hsep [ptext SLIT("module"), pprModule name, ptext SLIT("where")]
Just es -> vcat [
- hsep [ptext SLIT("module"), ptext name, lparen],
+ hsep [ptext SLIT("module"), pprModule name, lparen],
nest 8 (interpp'SP es),
nest 4 (ptext SLIT(") where"))
],
pp_nonnull imports,
- pp_nonnull fixities,
pp_nonnull decls
]
where
@@ -119,19 +111,19 @@ where
it should return @[x, y, f, a, b]@ (remember, order important).
\begin{code}
-collectTopBinders :: HsBinds flexi name (InPat name) -> Bag (name,SrcLoc)
+collectTopBinders :: HsBinds name (InPat name) -> Bag (name,SrcLoc)
collectTopBinders EmptyBinds = emptyBag
collectTopBinders (MonoBind b _ _) = collectMonoBinders b
collectTopBinders (ThenBinds b1 b2)
= collectTopBinders b1 `unionBags` collectTopBinders b2
-collectMonoBinders :: MonoBinds flexi name (InPat name) -> Bag (name,SrcLoc)
-collectMonoBinders EmptyMonoBinds = emptyBag
-collectMonoBinders (PatMonoBind pat grhss_w_binds loc) = listToBag (map (\v->(v,loc)) (collectPatBinders pat))
-collectMonoBinders (FunMonoBind f _ matches loc) = unitBag (f,loc)
-collectMonoBinders (VarMonoBind v expr) = error "collectMonoBinders"
-collectMonoBinders (CoreMonoBind v expr) = error "collectMonoBinders"
-collectMonoBinders (AndMonoBinds bs1 bs2)
- = collectMonoBinders bs1 `unionBags` collectMonoBinders bs2
+collectMonoBinders :: MonoBinds name (InPat name) -> Bag (name,SrcLoc)
+collectMonoBinders EmptyMonoBinds = emptyBag
+collectMonoBinders (PatMonoBind pat _ loc) = listToBag (map (\v->(v,loc)) (collectPatBinders pat))
+collectMonoBinders (FunMonoBind f _ matches loc) = unitBag (f,loc)
+collectMonoBinders (VarMonoBind v expr) = error "collectMonoBinders"
+collectMonoBinders (CoreMonoBind v expr) = error "collectMonoBinders"
+collectMonoBinders (AndMonoBinds bs1 bs2) = collectMonoBinders bs1 `unionBags`
+ collectMonoBinders bs2
\end{code}
diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs
index e64c34ae34..3f7237ec38 100644
--- a/ghc/compiler/hsSyn/HsTypes.lhs
+++ b/ghc/compiler/hsSyn/HsTypes.lhs
@@ -24,7 +24,7 @@ module HsTypes (
import Type ( Kind )
import PprType ( {- instance Outputable Kind -} )
import Outputable
-import Util ( thenCmp, cmpList, panic )
+import Util ( thenCmp, cmpList )
\end{code}
This is the syntax for types as seen in type signatures.
@@ -90,7 +90,7 @@ instance (Outputable name) => Outputable (HsType name) where
instance (Outputable name) => Outputable (HsTyVar name) where
ppr (UserTyVar name) = ppr name
- ppr (IfaceTyVar name kind) = hsep [ppr name, ptext SLIT("::"), ppr kind]
+ ppr (IfaceTyVar name kind) = hsep [ppr name, dcolon, ppr kind]
pprForAll [] = empty
pprForAll tvs = ptext SLIT("forall") <+> interppSP tvs <> ptext SLIT(".")
@@ -101,7 +101,7 @@ pprContext context = parens (hsep (punctuate comma (map pprClassAssertion contex
pprClassAssertion :: (Outputable name) => ClassAssertion name -> SDoc
pprClassAssertion (clas, tys)
- = ppr clas <+> hsep (map ppr tys)
+ = ppr clas <+> hsep (map pprParendHsType tys)
\end{code}
\begin{code}
View Lorry Controller Status