Commit 6a05ec5e authored by Dan Licata's avatar Dan Licata

View patterns, record wildcards, and record puns

This patch implements three new features:
* view patterns (syntax: expression -> pat in a pattern)
* working versions of record wildcards and record puns
See the manual for detailed descriptions.

Other minor observable changes:
* There is a check prohibiting local fixity declarations
  when the variable being fixed is not defined in the same let
* The warn-unused-binds option now reports warnings for do and mdo stmts

Implementation notes: 

* The pattern renamer is now in its own module, RnPat, and the
implementation is now in a CPS style so that the correct context is
delivered to pattern expressions.

* These features required a fairly major upheaval to the renamer.
Whereas the old version used to collect up all the bindings from a let
(or top-level, or recursive do statement, ...) and put them into scope
before renaming anything, the new version does the collection as it
renames.  This allows us to do the right thing with record wildcard
patterns (which need to be expanded to see what names should be
collected), and it allows us to implement the desired semantics for view
patterns in lets.  This change had a bunch of domino effects brought on
by fiddling with the top-level renaming.

* Prior to this patch, there was a tricky bug in mkRecordSelId in HEAD,
which did not maintain the invariant necessary for loadDecl.  See note
[Tricky iface loop] for details.
parent 62023058
......@@ -87,15 +87,20 @@ differently, as follows.
Note [Data Constructor Naming]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Each data constructor C has two, and possibly three, Names associated with it:
Each data constructor C has two, and possibly up to four, Names associated with it:
OccName Name space Used for
OccName Name space Name of
---------------------------------------------------------------------------
* The "source data con" C DataName The DataCon itself
* The "real data con" C VarName Its worker Id
* The "wrapper data con" $WC VarName Wrapper Id (optional)
Each of these three has a distinct Unique. The "source data con" name
* The "data con itself" C DataName DataCon
* The "worker data con" C VarName Id (the worker)
* The "wrapper data con" $WC VarName Id (the wrapper)
* The "newtype coercion" :CoT TcClsName TyCon
EVERY data constructor (incl for newtypes) has the former two (the
data con itself, and its worker. But only some data constructors have a
wrapper (see Note [The need for a wrapper]).
Each of these three has a distinct Unique. The "data con itself" name
appears in the output of the renamer, and names the Haskell-source
data constructor. The type checker translates it into either the wrapper Id
(if it exists) or worker Id (otherwise).
......@@ -129,6 +134,8 @@ The "wrapper Id", $WC, goes as follows
nothing for the wrapper to do. That is, if its defn would be
$wC = C
Note [The need for a wrapper]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Why might the wrapper have anything to do? Two reasons:
* Unboxing strict fields (with -funbox-strict-fields)
......@@ -152,6 +159,8 @@ Why might the wrapper have anything to do? Two reasons:
The third argument is a coerion
[a] :: [a]:=:[a]
INVARIANT: the dictionary constructor for a class
never has a wrapper.
A note about the stupid context
......
%
\%
% (c) The University of Glasgow 2006
% (c) The AQUA Project, Glasgow University, 1998
%
......@@ -498,20 +498,37 @@ gotten by appying the eq_spec to the univ_tvs of the data con.
mkRecordSelId :: TyCon -> FieldLabel -> Id
mkRecordSelId tycon field_label
-- Assumes that all fields with the same field label have the same type
| is_naughty = naughty_id
| otherwise = sel_id
= sel_id
where
is_naughty = not (tyVarsOfType field_ty `subVarSet` data_tv_set)
-- Because this function gets called by implicitTyThings, we need to
-- produce the OccName of the Id without doing any suspend type checks.
-- (see the note [Tricky iface loop]).
-- A suspended type-check is sometimes necessary to compute field_ty,
-- so we need to make sure that we suspend anything that depends on field_ty.
-- the overall result
sel_id = mkGlobalId sel_id_details field_label theType theInfo
-- check whether the type is naughty: this thunk does not get forced
-- until the type is actually needed
field_ty = dataConFieldType con1 field_label
is_naughty = not (tyVarsOfType field_ty `subVarSet` data_tv_set)
-- it's important that this doesn't force the if
(theType, theInfo) = if is_naughty
-- Escapist case here for naughty constructors
-- We give it no IdInfo, and a type of forall a.a (never looked at)
then (forall_a_a, noCafIdInfo)
-- otherwise do the real case
else (selector_ty, info)
sel_id_details = RecordSelId { sel_tycon = tycon, sel_label = field_label, sel_naughty = is_naughty }
-- For a data type family, the tycon is the *instance* TyCon
-- For a data type family, the tycon is the *instance* TyCon
-- Escapist case here for naughty constructors
-- We give it no IdInfo, and a type of forall a.a (never looked at)
naughty_id = mkGlobalId sel_id_details field_label forall_a_a noCafIdInfo
-- for naughty case
forall_a_a = mkForAllTy alphaTyVar (mkTyVarTy alphaTyVar)
-- Normal case starts here
sel_id = mkGlobalId sel_id_details field_label selector_ty info
-- real case starts here:
data_cons = tyConDataCons tycon
data_cons_w_field = filter has_field data_cons -- Can't be empty!
has_field con = field_label `elem` dataConFieldLabels con
......@@ -522,7 +539,6 @@ mkRecordSelId tycon field_label
-- only the family TyCon, not the instance TyCon
data_tv_set = tyVarsOfType data_ty
data_tvs = varSetElems data_tv_set
field_ty = dataConFieldType con1 field_label
-- *Very* tiresomely, the selectors are (unnecessarily!) overloaded over
-- just the dictionaries in the types of the constructors that contain
......
......@@ -29,6 +29,7 @@ import Name
import Unique(Unique)
import UniqFM
import Maybes
import Outputable
\end{code}
%************************************************************************
......@@ -38,7 +39,7 @@ import Maybes
%************************************************************************
\begin{code}
type NameEnv a = UniqFM a -- Domain is Name
newtype NameEnv a = A (UniqFM a) -- Domain is Name
emptyNameEnv :: NameEnv a
mkNameEnv :: [(Name,a)] -> NameEnv a
......@@ -61,26 +62,31 @@ foldNameEnv :: (a -> b -> b) -> b -> NameEnv a -> b
filterNameEnv :: (elt -> Bool) -> NameEnv elt -> NameEnv elt
mapNameEnv :: (elt1 -> elt2) -> NameEnv elt1 -> NameEnv elt2
emptyNameEnv = emptyUFM
foldNameEnv = foldUFM
mkNameEnv = listToUFM
nameEnvElts = eltsUFM
nameEnvUniqueElts = ufmToList
extendNameEnv_C = addToUFM_C
extendNameEnv_Acc = addToUFM_Acc
extendNameEnv = addToUFM
plusNameEnv = plusUFM
plusNameEnv_C = plusUFM_C
extendNameEnvList = addListToUFM
extendNameEnvList_C = addListToUFM_C
delFromNameEnv = delFromUFM
delListFromNameEnv = delListFromUFM
elemNameEnv = elemUFM
unitNameEnv = unitUFM
filterNameEnv = filterUFM
mapNameEnv = mapUFM
nameEnvElts (A x) = eltsUFM x
emptyNameEnv = A emptyUFM
unitNameEnv x y = A $ unitUFM x y
extendNameEnv (A x) y z = A $ addToUFM x y z
extendNameEnvList (A x) l = A $ addListToUFM x l
lookupNameEnv (A x) y = lookupUFM x y
mkNameEnv l = A $ listToUFM l
elemNameEnv x (A y) = elemUFM x y
foldNameEnv a b (A c) = foldUFM a b c
occEnvElts (A x) = eltsUFM x
plusNameEnv (A x) (A y) = A $ plusUFM x y
plusNameEnv_C f (A x) (A y) = A $ plusUFM_C f x y
extendNameEnv_C f (A x) y z = A $ addToUFM_C f x y z
mapNameEnv f (A x) = A $ mapUFM f x
mkNameEnv_C comb l = A $ addListToUFM_C comb emptyUFM l
nameEnvUniqueElts (A x) = ufmToList x
extendNameEnv_Acc x y (A z) a b = A $ addToUFM_Acc x y z a b
extendNameEnvList_C x (A y) z = A $ addListToUFM_C x y z
delFromNameEnv (A x) y = A $ delFromUFM x y
delListFromNameEnv (A x) y = A $ delListFromUFM x y
filterNameEnv x (A y) = A $ filterUFM x y
lookupNameEnv = lookupUFM
lookupNameEnv_NF env n = expectJust "lookupNameEnv_NF" (lookupUFM env n)
lookupNameEnv_NF env n = expectJust "lookupNameEnv_NF" (lookupNameEnv env n)
instance Outputable a => Outputable (NameEnv a) where
ppr (A x) = ppr x
\end{code}
......@@ -56,13 +56,14 @@ module OccName (
OccEnv, emptyOccEnv, unitOccEnv, extendOccEnv, mapOccEnv,
lookupOccEnv, mkOccEnv, mkOccEnv_C, extendOccEnvList, elemOccEnv,
occEnvElts, foldOccEnv, plusOccEnv, plusOccEnv_C, extendOccEnv_C,
filterOccEnv, delListFromOccEnv, delFromOccEnv,
-- The OccSet type
OccSet, emptyOccSet, unitOccSet, mkOccSet, extendOccSet,
extendOccSetList,
unionOccSets, unionManyOccSets, minusOccSet, elemOccSet, occSetElts,
foldOccSet, isEmptyOccSet, intersectOccSet, intersectsOccSet,
-- Tidying up
TidyOccEnv, emptyTidyOccEnv, tidyOccName, initTidyOccEnv,
......@@ -262,7 +263,7 @@ instance Uniquable OccName where
TvName -> 'v'
TcClsName -> 't'
type OccEnv a = UniqFM a
newtype OccEnv a = A (UniqFM a)
emptyOccEnv :: OccEnv a
unitOccEnv :: OccName -> a -> OccEnv a
......@@ -278,22 +279,30 @@ extendOccEnv_C :: (a->a->a) -> OccEnv a -> OccName -> a -> OccEnv a
plusOccEnv :: OccEnv a -> OccEnv a -> OccEnv a
plusOccEnv_C :: (a->a->a) -> OccEnv a -> OccEnv a -> OccEnv a
mapOccEnv :: (a->b) -> OccEnv a -> OccEnv b
emptyOccEnv = emptyUFM
unitOccEnv = unitUFM
extendOccEnv = addToUFM
extendOccEnvList = addListToUFM
lookupOccEnv = lookupUFM
mkOccEnv = listToUFM
elemOccEnv = elemUFM
foldOccEnv = foldUFM
occEnvElts = eltsUFM
plusOccEnv = plusUFM
plusOccEnv_C = plusUFM_C
extendOccEnv_C = addToUFM_C
mapOccEnv = mapUFM
mkOccEnv_C comb l = addListToUFM_C comb emptyOccEnv l
delFromOccEnv :: OccEnv a -> OccName -> OccEnv a
delListFromOccEnv :: OccEnv a -> [OccName] -> OccEnv a
filterOccEnv :: (elt -> Bool) -> OccEnv elt -> OccEnv elt
emptyOccEnv = A emptyUFM
unitOccEnv x y = A $ unitUFM x y
extendOccEnv (A x) y z = A $ addToUFM x y z
extendOccEnvList (A x) l = A $ addListToUFM x l
lookupOccEnv (A x) y = lookupUFM x y
mkOccEnv l = A $ listToUFM l
elemOccEnv x (A y) = elemUFM x y
foldOccEnv a b (A c) = foldUFM a b c
occEnvElts (A x) = eltsUFM x
plusOccEnv (A x) (A y) = A $ plusUFM x y
plusOccEnv_C f (A x) (A y) = A $ plusUFM_C f x y
extendOccEnv_C f (A x) y z = A $ addToUFM_C f x y z
mapOccEnv f (A x) = A $ mapUFM f x
mkOccEnv_C comb l = A $ addListToUFM_C comb emptyUFM l
delFromOccEnv (A x) y = A $ delFromUFM x y
delListFromOccEnv (A x) y = A $ delListFromUFM x y
filterOccEnv x (A y) = A $ filterUFM x y
instance Outputable a => Outputable (OccEnv a) where
ppr (A x) = ppr x
type OccSet = UniqFM OccName
......
......@@ -216,7 +216,9 @@ check' qs
| literals = split_by_literals qs
| constructors = split_by_constructor qs
| only_vars = first_column_only_vars qs
| otherwise = pprPanic "Check.check': Not implemented :-(" (ppr first_pats)
-- FIXME: hack to get view patterns through for now
| otherwise = ([([],[])],emptyUniqSet)
-- pprPanic "Check.check': Not implemented :-(" (ppr first_pats)
where
-- Note: RecPats will have been simplified to ConPats
-- at this stage.
......@@ -430,9 +432,9 @@ get_lit :: Pat id -> Maybe HsLit
-- It doesn't matter which one, because they will only be compared
-- with other HsLits gotten in the same way
get_lit (LitPat lit) = Just lit
get_lit (NPat (HsIntegral i _) mb _ _) = Just (HsIntPrim (mb_neg mb i))
get_lit (NPat (HsFractional f _) mb _ _) = Just (HsFloatPrim (mb_neg mb f))
get_lit (NPat (HsIsString s _) _ _ _) = Just (HsStringPrim s)
get_lit (NPat (HsIntegral i _ _) mb _) = Just (HsIntPrim (mb_neg mb i))
get_lit (NPat (HsFractional f _ _) mb _) = Just (HsFloatPrim (mb_neg mb f))
get_lit (NPat (HsIsString s _ _) _ _) = Just (HsStringPrim s)
get_lit other_pat = Nothing
mb_neg :: Num a => Maybe b -> a -> a
......@@ -484,7 +486,7 @@ is_con _ = False
is_lit :: Pat Id -> Bool
is_lit (LitPat _) = True
is_lit (NPat _ _ _ _) = True
is_lit (NPat _ _ _) = True
is_lit _ = False
is_var :: Pat Id -> Bool
......@@ -610,6 +612,7 @@ has_nplusk_pat :: Pat Id -> Bool
has_nplusk_pat (NPlusKPat _ _ _ _) = True
has_nplusk_pat (ParPat p) = has_nplusk_lpat p
has_nplusk_pat (AsPat _ p) = has_nplusk_lpat p
has_nplusk_pat (ViewPat _ p _) = has_nplusk_lpat p
has_nplusk_pat (SigPatOut p _ ) = has_nplusk_lpat p
has_nplusk_pat (ListPat ps _) = any has_nplusk_lpat ps
has_nplusk_pat (TuplePat ps _ _) = any has_nplusk_lpat ps
......@@ -631,6 +634,9 @@ simplify_pat (LazyPat p) = WildPat (hsLPatType p) -- For overlap and exhaus
-- purposes, a ~pat is like a wildcard
simplify_pat (BangPat p) = unLoc (simplify_lpat p)
simplify_pat (AsPat id p) = unLoc (simplify_lpat p)
simplify_pat (ViewPat expr p ty) = ViewPat expr (simplify_lpat p) ty
simplify_pat (SigPatOut p _) = unLoc (simplify_lpat p) -- I'm not sure this is right
simplify_pat pat@(ConPatOut { pat_con = L loc id, pat_args = ps })
......@@ -665,7 +671,7 @@ simplify_pat pat@(LitPat (HsString s)) =
mk_char_lit c = mkPrefixConPat charDataCon [nlLitPat (HsCharPrim c)] charTy
simplify_pat (LitPat lit) = tidyLitPat lit
simplify_pat (NPat lit mb_neg eq lit_ty) = tidyNPat lit mb_neg eq lit_ty
simplify_pat (NPat lit mb_neg eq) = tidyNPat lit mb_neg eq
simplify_pat (NPlusKPat id hslit hsexpr1 hsexpr2)
= WildPat (idType (unLoc id))
......
......@@ -637,7 +637,7 @@ bindLocals :: [Id] -> TM a -> TM a
bindLocals new_ids (TM m)
= TM $ \ env st ->
case m env{ inScope = inScope env `extendVarSetList` new_ids } st of
(r, fv, st') -> (r, fv `delListFromUFM` occs, st')
(r, fv, st') -> (r, fv `delListFromOccEnv` occs, st')
where occs = [ nameOccName (idName id) | id <- new_ids ]
isBlackListed :: SrcSpan -> TM Bool
......
......@@ -1115,7 +1115,7 @@ collectl (L l pat) bndrs
collectHsBindLocatedBinders ds
++ foldr collectl bndrs (hsConPatArgs ps)
go (LitPat _) = bndrs
go (NPat _ _ _ _) = bndrs
go (NPat _ _ _) = bndrs
go (NPlusKPat n _ _ _) = n : bndrs
go (SigPatIn pat _) = collectl pat bndrs
......
......@@ -790,7 +790,7 @@ repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [] e)] EmptyLocalBinds)))
do { xs <- repLPs ps; body <- repLE e; repLam xs body })
; wrapGenSyns ss lam }
repLambda (L _ m) = notHandled "Guarded labmdas" (pprMatch LambdaExpr m)
repLambda (L _ m) = notHandled "Guarded labmdas" (pprMatch (LambdaExpr :: HsMatchContext Name) m)
-----------------------------------------------------------------------------
......@@ -831,8 +831,8 @@ repP (ConPatIn dc details)
p2' <- repLP p2;
repPinfix p1' con_str p2' }
}
repP (NPat l Nothing _ _) = do { a <- repOverloadedLiteral l; repPlit a }
repP p@(NPat l (Just _) _ _) = notHandled "Negative overloaded patterns" (ppr p)
repP (NPat l Nothing _) = do { a <- repOverloadedLiteral l; repPlit a }
repP p@(NPat l (Just _) _) = notHandled "Negative overloaded patterns" (ppr p)
repP p@(SigPatIn {}) = notHandled "Type signatures in patterns" (ppr p)
-- The problem is to do with scoped type variables.
-- To implement them, we have to implement the scoping rules
......@@ -1277,9 +1277,9 @@ mk_string s = do string_ty <- lookupType stringTyConName
return $ HsString s
repOverloadedLiteral :: HsOverLit Name -> DsM (Core TH.Lit)
repOverloadedLiteral (HsIntegral i _) = do { lit <- mk_integer i; repLiteral lit }
repOverloadedLiteral (HsFractional f _) = do { lit <- mk_rational f; repLiteral lit }
repOverloadedLiteral (HsIsString s _) = do { lit <- mk_string s; repLiteral lit }
repOverloadedLiteral (HsIntegral i _ _) = do { lit <- mk_integer i; repLiteral lit }
repOverloadedLiteral (HsFractional f _ _) = do { lit <- mk_rational f; repLiteral lit }
repOverloadedLiteral (HsIsString s _ _) = do { lit <- mk_string s; repLiteral lit }
-- The type Rational will be in the environment, becuase
-- the smart constructor 'TH.Syntax.rationalL' uses it in its type,
-- and rationalL is sucked in when any TH stuff is used
......
......@@ -16,7 +16,7 @@
module DsMonad (
DsM, mappM, mapAndUnzipM,
initDs, initDsTc, returnDs, thenDs, listDs, fixDs, mapAndUnzipDs,
foldlDs, foldrDs,
foldlDs, foldrDs, ifOptDs,
newTyVarsDs, newLocalName,
duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId,
......@@ -130,7 +130,7 @@ listDs = sequenceM
foldlDs = foldlM
foldrDs = foldrM
mapAndUnzipDs = mapAndUnzipM
ifOptDs = ifOptM
type DsWarning = (SrcSpan, SDoc)
-- Not quite the same as a WarnMsg, we have an SDoc here
......
......@@ -25,7 +25,7 @@ module DsUtils (
cantFailMatchResult, alwaysFailMatchResult,
extractMatchResult, combineMatchResults,
adjustMatchResult, adjustMatchResultDs,
mkCoLetMatchResult, mkGuardedMatchResult,
mkCoLetMatchResult, mkViewMatchResult, mkGuardedMatchResult,
matchCanFail, mkEvalMatchResult,
mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult,
wrapBind, wrapBinds,
......@@ -319,6 +319,12 @@ seqVar var body = Case (Var var) var (exprType body)
mkCoLetMatchResult :: CoreBind -> MatchResult -> MatchResult
mkCoLetMatchResult bind = adjustMatchResult (mkDsLet bind)
-- (mkViewMatchResult var' viewExpr var mr) makes the expression
-- let var' = viewExpr var in mr
mkViewMatchResult :: Id -> CoreExpr -> Id -> MatchResult -> MatchResult
mkViewMatchResult var' viewExpr var =
adjustMatchResult (mkDsLet (NonRec var' (mkDsApp viewExpr (Var var))))
mkEvalMatchResult :: Id -> Type -> MatchResult -> MatchResult
mkEvalMatchResult var ty
= adjustMatchResult (\e -> Case (Var var) var ty [(DEFAULT, [], e)])
......
This diff is collapsed.
......@@ -90,9 +90,9 @@ dsLit (HsRat r ty)
dsOverLit :: HsOverLit Id -> DsM CoreExpr
-- Post-typechecker, the SyntaxExpr field of an OverLit contains
-- (an expression for) the literal value itself
dsOverLit (HsIntegral _ lit) = dsExpr lit
dsOverLit (HsFractional _ lit) = dsExpr lit
dsOverLit (HsIsString _ lit) = dsExpr lit
dsOverLit (HsIntegral _ lit _) = dsExpr lit
dsOverLit (HsFractional _ lit _) = dsExpr lit
dsOverLit (HsIsString _ lit _) = dsExpr lit
\end{code}
\begin{code}
......@@ -111,11 +111,11 @@ hsLitKey (HsString s) = MachStr s
hsOverLitKey :: HsOverLit a -> Bool -> Literal
-- Ditto for HsOverLit; the boolean indicates to negate
hsOverLitKey (HsIntegral i _) False = MachInt i
hsOverLitKey (HsIntegral i _) True = MachInt (-i)
hsOverLitKey (HsFractional r _) False = MachFloat r
hsOverLitKey (HsFractional r _) True = MachFloat (-r)
hsOverLitKey (HsIsString s _) False = MachStr s
hsOverLitKey (HsIntegral i _ _) False = MachInt i
hsOverLitKey (HsIntegral i _ _) True = MachInt (-i)
hsOverLitKey (HsFractional r _ _) False = MachFloat r
hsOverLitKey (HsFractional r _ _) True = MachFloat (-r)
hsOverLitKey (HsIsString s _ _) False = MachStr s
-- negated string should never happen
\end{code}
......@@ -142,36 +142,36 @@ tidyLitPat (HsString s)
tidyLitPat lit = LitPat lit
----------------
tidyNPat :: HsOverLit Id -> Maybe (SyntaxExpr Id) -> SyntaxExpr Id
-> Type -> Pat Id
tidyNPat over_lit mb_neg eq lit_ty
| isIntTy lit_ty = mk_con_pat intDataCon (HsIntPrim int_val)
| isFloatTy lit_ty = mk_con_pat floatDataCon (HsFloatPrim rat_val)
| isDoubleTy lit_ty = mk_con_pat doubleDataCon (HsDoublePrim rat_val)
tidyNPat :: HsOverLit Id -> Maybe (SyntaxExpr Id) -> SyntaxExpr Id -> Pat Id
tidyNPat over_lit mb_neg eq
| isIntTy (overLitType over_lit) = mk_con_pat intDataCon (HsIntPrim int_val)
| isFloatTy (overLitType over_lit) = mk_con_pat floatDataCon (HsFloatPrim rat_val)
| isDoubleTy (overLitType over_lit) = mk_con_pat doubleDataCon (HsDoublePrim rat_val)
-- | isStringTy lit_ty = mk_con_pat stringDataCon (HsStringPrim str_val)
| otherwise = NPat over_lit mb_neg eq lit_ty
| otherwise = NPat over_lit mb_neg eq
where
mk_con_pat :: DataCon -> HsLit -> Pat Id
mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] lit_ty)
mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] (overLitType over_lit))
neg_lit = case (mb_neg, over_lit) of
(Nothing, _) -> over_lit
(Just _, HsIntegral i s) -> HsIntegral (-i) s
(Just _, HsFractional f s) -> HsFractional (-f) s
(Just _, HsIntegral i s ty) -> HsIntegral (-i) s ty
(Just _, HsFractional f s ty) -> HsFractional (-f) s ty
int_val :: Integer
int_val = case neg_lit of
HsIntegral i _ -> i
HsFractional f _ -> panic "tidyNPat"
HsIntegral i _ _ -> i
HsFractional f _ _ -> panic "tidyNPat"
rat_val :: Rational
rat_val = case neg_lit of
HsIntegral i _ -> fromInteger i
HsFractional f _ -> f
HsIntegral i _ _ -> fromInteger i
HsFractional f _ _ -> f
str_val :: FastString
str_val = case neg_lit of
HsIsString s _ -> s
_ -> error "tidyNPat"
HsIsString s _ _ -> s
_ -> error "tidyNPat"
\end{code}
......@@ -232,7 +232,7 @@ matchNPats vars ty groups
; return (foldr1 combineMatchResults match_results) }
matchOneNPat (var:vars) ty (eqn1:eqns) -- All for the same literal
= do { let NPat lit mb_neg eq_chk _ = firstPat eqn1
= do { let NPat lit mb_neg eq_chk = firstPat eqn1
; lit_expr <- dsOverLit lit
; neg_lit <- case mb_neg of
Nothing -> return lit_expr
......
......@@ -426,9 +426,9 @@ cvtpair (PatG gs,rhs) = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs
; returnL $ GRHS gs' rhs' }
cvtOverLit :: Lit -> CvtM (HsOverLit RdrName)
cvtOverLit (IntegerL i) = do { force i; return $ mkHsIntegral i }
cvtOverLit (RationalL r) = do { force r; return $ mkHsFractional r }
cvtOverLit (StringL s) = do { let { s' = mkFastString s }; force s'; return $ mkHsIsString s' }
cvtOverLit (IntegerL i) = do { force i; return $ mkHsIntegral i placeHolderType}
cvtOverLit (RationalL r) = do { force r; return $ mkHsFractional r placeHolderType}
cvtOverLit (StringL s) = do { let { s' = mkFastString s }; force s'; return $ mkHsIsString s' placeHolderType }
-- An Integer is like an an (overloaded) '3' in a Haskell source program
-- Similarly 3.5 for fractionals
......
......@@ -46,20 +46,29 @@ import Bag
Global bindings (where clauses)
\begin{code}
data HsLocalBinds id -- Bindings in a 'let' expression
-- or a 'where' clause
= HsValBinds (HsValBinds id)
| HsIPBinds (HsIPBinds id)
-- During renaming, we need bindings where the left-hand sides
-- have been renamed but the the right-hand sides have not.
-- the ...LR datatypes are parametrized by two id types,
-- one for the left and one for the right.
-- Other than during renaming, these will be the same.
type HsLocalBinds id = HsLocalBindsLR id id
data HsLocalBindsLR idL idR -- Bindings in a 'let' expression
-- or a 'where' clause
= HsValBinds (HsValBindsLR idL idR)
| HsIPBinds (HsIPBinds idR)
| EmptyLocalBinds
data HsValBinds id -- Value bindings (not implicit parameters)
= ValBindsIn -- Before typechecking
(LHsBinds id) [LSig id] -- Not dependency analysed
type HsValBinds id = HsValBindsLR id id
data HsValBindsLR idL idR -- Value bindings (not implicit parameters)
= ValBindsIn -- Before typechecking
(LHsBindsLR idL idR) [LSig idR] -- Not dependency analysed
-- Recursive by default
| ValBindsOut -- After renaming
[(RecFlag, LHsBinds id)] -- Dependency analysed, later bindings
| ValBindsOut -- After renaming
[(RecFlag, LHsBinds idL)] -- Dependency analysed, later bindings
-- in the list may depend on earlier
-- ones.
[LSig Name]
......@@ -67,8 +76,12 @@ data HsValBinds id -- Value bindings (not implicit parameters)
type LHsBinds id = Bag (LHsBind id)
type DictBinds id = LHsBinds id -- Used for dictionary or method bindings
type LHsBind id = Located (HsBind id)
type HsBind id = HsBindLR id id
type LHsBindLR idL idR = Located (HsBindLR idL idR)
type LHsBindsLR idL idR = Bag (LHsBindLR idL idR)
data HsBind id
data HsBindLR idL idR
= FunBind { -- FunBind is used for both functions f x = e
-- and variables f = \x -> e
-- Reason 1: Special case for type inference: see TcBinds.tcMonoBinds
......@@ -80,11 +93,11 @@ data HsBind id
-- parses as a pattern binding, just like
-- (f :: a -> a) = ...
fun_id :: Located id,
fun_id :: Located idL,
fun_infix :: Bool, -- True => infix declaration
fun_matches :: MatchGroup id, -- The payload
fun_matches :: MatchGroup idR, -- The payload
fun_co_fn :: HsWrapper, -- Coercion from the type of the MatchGroup to the type of
-- the Id. Example:
......@@ -102,27 +115,30 @@ data HsBind id
-- Before renaming, and after typechecking,
-- the field is unused; it's just an error thunk
fun_tick :: Maybe (Int,[id]) -- This is the (optional) module-local tick number.
fun_tick :: Maybe (Int,[idR]) -- This is the (optional) module-local tick number.
}
| PatBind { -- The pattern is never a simple variable;
-- That case is done by FunBind
pat_lhs :: LPat id,
pat_rhs :: GRHSs id,
pat_lhs :: LPat idL,
pat_rhs :: GRHSs idR,
pat_rhs_ty :: PostTcType, -- Type of the GRHSs
bind_fvs :: NameSet -- Same as for FunBind
}
| VarBind { -- Dictionary binding and suchlike
var_id :: id, -- All VarBinds are introduced by the type checker
var_rhs :: LHsExpr id -- Located only for consistency
var_id :: idL, -- All VarBinds are introduced by the type checker
var_rhs :: LHsExpr idR -- Located only for consistency
}
| AbsBinds { -- Binds abstraction; TRANSLATION
abs_tvs :: [TyVar],
abs_tvs :: [TyVar],
abs_dicts :: [DictId],
abs_exports :: [([TyVar], id, id, [LPrag])], -- (tvs, poly_id, mono_id, prags)
abs_binds :: LHsBinds id -- The dictionary bindings and typechecked user bindings
-- AbsBinds only gets used when idL = idR after renaming,
-- but these need to be idL's for the collect... code in HsUtil to have
-- the right type
abs_exports :: [([TyVar], idL, idL, [LPrag])], -- (tvs, poly_id, mono_id, prags)
abs_binds :: LHsBinds idL -- The dictionary bindings and typechecked user bindings
-- mixed up together; you can tell the dict bindings because
-- they are all VarBinds
}
......@@ -145,12 +161,12 @@ placeHolderNames :: NameSet
placeHolderNames = panic "placeHolderNames"
------------
instance OutputableBndr id => Outputable (HsLocalBinds id) where
instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsLocalBindsLR idL idR) where
ppr (HsValBinds bs) = ppr bs
ppr (HsIPBinds bs) = ppr bs
ppr EmptyLocalBinds = empty
instance OutputableBndr id => Outputable (HsValBinds id) where
instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsValBindsLR idL idR) where
ppr (ValBindsIn binds sigs)
= pprValBindsForUser binds sigs
......@@ -169,44 +185,44 @@ instance OutputableBndr id => Outputable (HsValBinds id) where
-- 'where' include a list of HsBindGroups and we don't want
-- several groups of bindings each with braces around.
-- Sort by location before printing
pprValBindsForUser :: (OutputableBndr id1, OutputableBndr id2)
=> LHsBinds id1 -> [LSig id2] -> SDoc
pprValBindsForUser :: (OutputableBndr idL, OutputableBndr idR, OutputableBndr id2)
=> LHsBindsLR idL idR -> [LSig id2] -> SDoc
pprValBindsForUser binds sigs
= pprDeeperList vcat (map snd (sort_by_loc decls))
where
decls :: [(SrcSpan, SDoc)]
decls = [(loc, ppr sig) | L loc sig <- sigs] ++
[(loc, ppr bind) | L loc bind <- bagToList binds]
[(loc, ppr bind) | L loc bind <- bagToList binds]
sort_by_loc decls = sortLe (\(l1,_) (l2,_) -> l1 <= l2) decls
pprLHsBinds :: OutputableBndr id => LHsBinds id -> SDoc
pprLHsBinds :: (OutputableBndr idL, OutputableBndr idR) => LHsBindsLR idL idR -> SDoc
pprLHsBinds binds
| isEmptyLHsBinds binds = empty
| otherwise = lbrace <+> pprDeeperList vcat (map ppr (bagToList binds)) <+> rbrace
------------
emptyLocalBinds :: HsLocalBinds a
emptyLocalBinds :: HsLocalBindsLR a b
emptyLocalBinds = EmptyLocalBinds
isEmptyLocalBinds :: HsLocalBinds a -> Bool
isEmptyLocalBinds :: HsLocalBindsLR a b -> Bool
isEmptyLocalBinds (HsValBinds ds) = isEmptyValBinds ds
isEmptyLocalBinds (HsIPBinds ds) = isEmptyIPBinds ds
isEmptyLocalBinds EmptyLocalBinds = True
isEmptyValBinds :: HsValBinds a -> Bool
isEmptyValBinds :: HsValBindsLR a b -> Bool
isEmptyValBinds (ValBindsIn ds sigs) = isEmptyLHsBinds ds && null sigs
isEmptyValBinds (ValBindsOut ds sigs) = null ds && null sigs
emptyValBindsIn, emptyValBindsOut :: HsValBinds a
emptyValBindsIn, emptyValBindsOut :: HsValBindsLR a b
emptyValBindsIn = ValBindsIn emptyBag []
emptyValBindsOut = ValBindsOut [] []
emptyLHsBinds :: LHsBinds id
emptyLHsBinds :: LHsBindsLR idL idR
emptyLHsBinds = emptyBag
isEmptyLHsBinds :: LHsBinds id -> Bool
isEmptyLHsBinds :: LHsBindsLR idL idR -> Bool
isEmptyLHsBinds = isEmptyBag
------------
......@@ -242,10 +258,10 @@ So the desugarer tries to do a better job:
in (fm,gm)
\begin{code}
instance OutputableBndr id => Outputable (HsBind id) where
instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsBindLR idL idR) where
ppr mbind = ppr_monobind mbind
ppr_monobind :: OutputableBndr id => HsBind id -> SDoc
ppr_monobind :: (OutputableBndr idL, OutputableBndr idR) => HsBindLR idL idR -> SDoc
ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss }) = pprPatBind pat grhss
ppr_monobind (VarBind { var_id = var, var_rhs = rhs }) = ppr var <+> equals <+> pprExpr (unLoc rhs)
......@@ -339,14 +355,20 @@ instance Outputable HsWrapper where
ppr co_fn = pprHsWrapper (ptext SLIT("<>")) co_fn
pprHsWrapper :: SDoc -> HsWrapper -> SDoc
pprHsWrapper it WpHole = it
pprHsWrapper it (WpCompose f1 f2) = pprHsWrapper (pprHsWrapper it f2) f1
pprHsWrapper it (WpCo co) = sep [it, nest 2 (ptext SLIT("`cast`") <+> pprParendType co)]
pprHsWrapper it (WpApp id) = sep [it, nest 2 (ppr id)]
pprHsWrapper it (WpTyApp ty) = sep [it, ptext SLIT("@") <+> pprParendType ty]
pprHsWrapper it (WpLam id) = sep [ptext SLIT("\\") <> pprBndr LambdaBind id <> dot, it]
pprHsWrapper it (WpTyLam tv) = sep [ptext SLIT("/\\") <> pprBndr LambdaBind tv <> dot, it]
pprHsWrapper it (WpLet binds) = sep [ptext SLIT("let") <+> braces (ppr binds), it]
pprHsWrapper it wrap =
let
help it WpHole = it
help it (WpCompose f1 f2) = help (help it f2) f1
help it (WpCo co) = sep [it, nest 2 (ptext SLIT("`cast`") <+> pprParendType co)]
help it (WpApp id) = sep [it, nest 2 (ppr id)]
help it (WpTyApp ty) = sep [it, ptext SLIT("@") <+> pprParendType ty]
help it (WpLam id) = sep [ptext SLIT("\\") <> pprBndr LambdaBind id <> dot, it]
help it (WpTyLam tv) = sep [ptext SLIT("/\\") <> pprBndr LambdaBind tv <> dot, it]
help it (WpLet binds) = sep [ptext SLIT("let") <+> braces (ppr binds), it]
in
-- in debug mode, print the wrapper
-- otherwise just print what's inside
getPprStyle (\ s -> if debugStyle s then (help it wrap) else it)
(<.>) :: HsWrapper -> HsWrapper -> HsWrapper
WpHole <.> c = c
......
......@@ -94,7 +94,8 @@ noSyntaxTable = []
data HsExpr id
= HsVar id -- variable
| HsIPVar (IPName id) -- implicit parameter
| HsOverLit (HsOverLit id) -- Overloaded literals
| HsOverLit (HsOverLit id) -- Overloaded literals
| HsLit HsLit -- Simple (non-overloaded) literals
| HsLam (MatchGroup id) -- Currently always a single match
......@@ -259,6 +260,9 @@ data HsExpr id
| EAsPat (Located id) -- as pattern
(LHsExpr id)
| EViewPat (LHsExpr id) -- view pattern
(LHsExpr id)