Commit 7d3f2dfc authored by Alan Zimmerman's avatar Alan Zimmerman Committed by Austin Seipp
Browse files

PostTcType replaced with TypeAnnot

Summary:
This is a first step toward allowing generic traversals of the AST without 'landmines', by removing the `panic`s located throughout `placeHolderType`, `placeHolderKind` & co.

See more on the discussion at https://www.mail-archive.com/ghc-devs@haskell.org/msg05564.html

(This also makes a corresponding update to the `haddock` submodule.)

Test Plan: `sh validate` and new tests pass.

Reviewers: austin, simonpj, goldfire

Reviewed By: austin, simonpj, goldfire

Subscribers: edsko, Fuuzetsu, thomasw, holzensp, goldfire, simonmar, relrod, ezyang, carter

Projects: #ghc

Differential Revision: https://phabricator.haskell.org/D157
parent 7bf7ca2b
...@@ -220,7 +220,7 @@ check' ((n, EqnInfo { eqn_pats = ps, eqn_rhs = MatchResult can_fail _ }) : rs) ...@@ -220,7 +220,7 @@ check' ((n, EqnInfo { eqn_pats = ps, eqn_rhs = MatchResult can_fail _ }) : rs)
= ([], unitUniqSet n) -- One eqn, which can't fail = ([], unitUniqSet n) -- One eqn, which can't fail
| first_eqn_all_vars && null rs -- One eqn, but it can fail | first_eqn_all_vars && null rs -- One eqn, but it can fail
= ([(takeList ps (repeat nlWildPat),[])], unitUniqSet n) = ([(takeList ps (repeat nlWildPatName),[])], unitUniqSet n)
| first_eqn_all_vars -- Several eqns, first can fail | first_eqn_all_vars -- Several eqns, first can fail
= (pats, addOneToUniqSet indexs n) = (pats, addOneToUniqSet indexs n)
...@@ -281,7 +281,8 @@ process_literals used_lits qs ...@@ -281,7 +281,8 @@ process_literals used_lits qs
default_eqns = ASSERT2( okGroup qs, pprGroup qs ) default_eqns = ASSERT2( okGroup qs, pprGroup qs )
[remove_var q | q <- qs, is_var (firstPatN q)] [remove_var q | q <- qs, is_var (firstPatN q)]
(pats',indexs') = check' default_eqns (pats',indexs') = check' default_eqns
pats_default = [(nlWildPat:ps,constraints) | (ps,constraints) <- (pats')] ++ pats pats_default = [(nlWildPatName:ps,constraints) |
(ps,constraints) <- (pats')] ++ pats
indexs_default = unionUniqSets indexs' indexs indexs_default = unionUniqSets indexs' indexs
\end{code} \end{code}
...@@ -326,9 +327,10 @@ nothing to do. ...@@ -326,9 +327,10 @@ nothing to do.
\begin{code} \begin{code}
first_column_only_vars :: [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet) first_column_only_vars :: [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)
first_column_only_vars qs = (map (\ (xs,ys) -> (nlWildPat:xs,ys)) pats,indexs) first_column_only_vars qs
where = (map (\ (xs,ys) -> (nlWildPatName:xs,ys)) pats,indexs)
(pats, indexs) = check' (map remove_var qs) where
(pats, indexs) = check' (map remove_var qs)
\end{code} \end{code}
This equation takes a matrix of patterns and split the equations by This equation takes a matrix of patterns and split the equations by
...@@ -400,7 +402,8 @@ remove_first_column _ _ = panic "Check.remove_first_column: Not ConPatOut" ...@@ -400,7 +402,8 @@ remove_first_column _ _ = panic "Check.remove_first_column: Not ConPatOut"
make_row_vars :: [HsLit] -> (EqnNo, EquationInfo) -> ExhaustivePat make_row_vars :: [HsLit] -> (EqnNo, EquationInfo) -> ExhaustivePat
make_row_vars used_lits (_, EqnInfo { eqn_pats = pats}) make_row_vars used_lits (_, EqnInfo { eqn_pats = pats})
= (nlVarPat new_var:takeList (tail pats) (repeat nlWildPat),[(new_var,used_lits)]) = (nlVarPat new_var:takeList (tail pats) (repeat nlWildPatName)
,[(new_var,used_lits)])
where where
new_var = hash_x new_var = hash_x
...@@ -411,7 +414,7 @@ hash_x = mkInternalName unboundKey {- doesn't matter much -} ...@@ -411,7 +414,7 @@ hash_x = mkInternalName unboundKey {- doesn't matter much -}
make_row_vars_for_constructor :: (EqnNo, EquationInfo) -> [WarningPat] make_row_vars_for_constructor :: (EqnNo, EquationInfo) -> [WarningPat]
make_row_vars_for_constructor (_, EqnInfo { eqn_pats = pats}) make_row_vars_for_constructor (_, EqnInfo { eqn_pats = pats})
= takeList (tail pats) (repeat nlWildPat) = takeList (tail pats) (repeat nlWildPatName)
compare_cons :: Pat Id -> Pat Id -> Bool compare_cons :: Pat Id -> Pat Id -> Bool
compare_cons (ConPatOut{ pat_con = L _ con1 }) (ConPatOut{ pat_con = L _ con2 }) compare_cons (ConPatOut{ pat_con = L _ con1 }) (ConPatOut{ pat_con = L _ con2 })
...@@ -594,10 +597,14 @@ make_con (ConPatOut{ pat_con = L _ (RealDataCon id) }) (lp:lq:ps, constraints) ...@@ -594,10 +597,14 @@ make_con (ConPatOut{ pat_con = L _ (RealDataCon id) }) (lp:lq:ps, constraints)
| isInfixCon id = (nlInfixConPat (getName id) lp lq : ps, constraints) | isInfixCon id = (nlInfixConPat (getName id) lp lq : ps, constraints)
where q = unLoc lq where q = unLoc lq
make_con (ConPatOut{ pat_con = L _ (RealDataCon id), pat_args = PrefixCon pats, pat_arg_tys = tys }) (ps, constraints) make_con (ConPatOut{ pat_con = L _ (RealDataCon id), pat_args = PrefixCon pats})
| isTupleTyCon tc = (noLoc (TuplePat pats_con (tupleTyConBoxity tc) tys) : rest_pats, constraints) (ps, constraints)
| isPArrFakeCon id = (noLoc (PArrPat pats_con placeHolderType) : rest_pats, constraints) | isTupleTyCon tc = (noLoc (TuplePat pats_con (tupleTyConBoxity tc) [])
| otherwise = (nlConPat name pats_con : rest_pats, constraints) : rest_pats, constraints)
| isPArrFakeCon id = (noLoc (PArrPat pats_con placeHolderType)
: rest_pats, constraints)
| otherwise = (nlConPatName name pats_con
: rest_pats, constraints)
where where
name = getName id name = getName id
(pats_con, rest_pats) = splitAtList pats ps (pats_con, rest_pats) = splitAtList pats ps
...@@ -612,11 +619,12 @@ make_con _ _ = panic "Check.make_con: Not ConPatOut" ...@@ -612,11 +619,12 @@ make_con _ _ = panic "Check.make_con: Not ConPatOut"
-- representation -- representation
make_whole_con :: DataCon -> WarningPat make_whole_con :: DataCon -> WarningPat
make_whole_con con | isInfixCon con = nlInfixConPat name nlWildPat nlWildPat make_whole_con con | isInfixCon con = nlInfixConPat name
| otherwise = nlConPat name pats nlWildPatName nlWildPatName
| otherwise = nlConPatName name pats
where where
name = getName con name = getName con
pats = [nlWildPat | _ <- dataConOrigArgTys con] pats = [nlWildPatName | _ <- dataConOrigArgTys con]
\end{code} \end{code}
------------------------------------------------------------------------ ------------------------------------------------------------------------
...@@ -745,7 +753,7 @@ tidy_con :: ConLike -> HsConPatDetails Id -> HsConPatDetails Id ...@@ -745,7 +753,7 @@ tidy_con :: ConLike -> HsConPatDetails Id -> HsConPatDetails Id
tidy_con _ (PrefixCon ps) = PrefixCon (map tidy_lpat ps) tidy_con _ (PrefixCon ps) = PrefixCon (map tidy_lpat ps)
tidy_con _ (InfixCon p1 p2) = PrefixCon [tidy_lpat p1, tidy_lpat p2] tidy_con _ (InfixCon p1 p2) = PrefixCon [tidy_lpat p1, tidy_lpat p2]
tidy_con con (RecCon (HsRecFields fs _)) tidy_con con (RecCon (HsRecFields fs _))
| null fs = PrefixCon (replicate arity nlWildPat) | null fs = PrefixCon (replicate arity nlWildPatId)
-- Special case for null patterns; maybe not a record at all -- Special case for null patterns; maybe not a record at all
| otherwise = PrefixCon (map (tidy_lpat.snd) all_pats) | otherwise = PrefixCon (map (tidy_lpat.snd) all_pats)
where where
...@@ -755,7 +763,7 @@ tidy_con con (RecCon (HsRecFields fs _)) ...@@ -755,7 +763,7 @@ tidy_con con (RecCon (HsRecFields fs _))
-- pad out all the missing fields with WildPats. -- pad out all the missing fields with WildPats.
field_pats = case con of field_pats = case con of
RealDataCon dc -> map (\ f -> (f, nlWildPat)) (dataConFieldLabels dc) RealDataCon dc -> map (\ f -> (f, nlWildPatId)) (dataConFieldLabels dc)
PatSynCon{} -> panic "Check.tidy_con: pattern synonym with record syntax" PatSynCon{} -> panic "Check.tidy_con: pattern synonym with record syntax"
all_pats = foldr (\(HsRecField id p _) acc -> insertNm (getName (unLoc id)) p acc) all_pats = foldr (\(HsRecField id p _) acc -> insertNm (getName (unLoc id)) p acc)
field_pats fs field_pats fs
......
...@@ -676,7 +676,8 @@ makes all list literals be generated via the simple route. ...@@ -676,7 +676,8 @@ makes all list literals be generated via the simple route.
\begin{code} \begin{code}
dsExplicitList :: PostTcType -> Maybe (SyntaxExpr Id) -> [LHsExpr Id] -> DsM CoreExpr dsExplicitList :: PostTc Id Type -> Maybe (SyntaxExpr Id) -> [LHsExpr Id]
-> DsM CoreExpr
-- See Note [Desugaring explicit lists] -- See Note [Desugaring explicit lists]
dsExplicitList elt_ty Nothing xs dsExplicitList elt_ty Nothing xs
= do { dflags <- getDynFlags = do { dflags <- getDynFlags
......
...@@ -280,6 +280,7 @@ Library ...@@ -280,6 +280,7 @@ Library
HsExpr HsExpr
HsImpExp HsImpExp
HsLit HsLit
PlaceHolder
HsPat HsPat
HsSyn HsSyn
HsTypes HsTypes
......
...@@ -538,6 +538,7 @@ compiler_stage2_dll0_MODULES = \ ...@@ -538,6 +538,7 @@ compiler_stage2_dll0_MODULES = \
HsExpr \ HsExpr \
HsImpExp \ HsImpExp \
HsLit \ HsLit \
PlaceHolder \
HsPat \ HsPat \
HsSyn \ HsSyn \
HsTypes \ HsTypes \
......
...@@ -140,7 +140,7 @@ cvtDec (TH.ValD pat body ds) ...@@ -140,7 +140,7 @@ cvtDec (TH.ValD pat body ds)
; ds' <- cvtLocalDecs (ptext (sLit "a where clause")) ds ; ds' <- cvtLocalDecs (ptext (sLit "a where clause")) ds
; returnL $ Hs.ValD $ ; returnL $ Hs.ValD $
PatBind { pat_lhs = pat', pat_rhs = GRHSs body' ds' PatBind { pat_lhs = pat', pat_rhs = GRHSs body' ds'
, pat_rhs_ty = void, bind_fvs = placeHolderNames , pat_rhs_ty = placeHolderType, bind_fvs = placeHolderNames
, pat_ticks = (Nothing,[]) } } , pat_ticks = (Nothing,[]) } }
cvtDec (TH.FunD nm cls) cvtDec (TH.FunD nm cls)
...@@ -181,7 +181,8 @@ cvtDec (DataD ctxt tc tvs constrs derivs) ...@@ -181,7 +181,8 @@ cvtDec (DataD ctxt tc tvs constrs derivs)
, dd_kindSig = Nothing , dd_kindSig = Nothing
, dd_cons = cons', dd_derivs = derivs' } , dd_cons = cons', dd_derivs = derivs' }
; returnL $ TyClD (DataDecl { tcdLName = tc', tcdTyVars = tvs' ; returnL $ TyClD (DataDecl { tcdLName = tc', tcdTyVars = tvs'
, tcdDataDefn = defn, tcdFVs = placeHolderNames }) } , tcdDataDefn = defn
, tcdFVs = placeHolderNames }) }
cvtDec (NewtypeD ctxt tc tvs constr derivs) cvtDec (NewtypeD ctxt tc tvs constr derivs)
= do { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs = do { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
...@@ -192,7 +193,8 @@ cvtDec (NewtypeD ctxt tc tvs constr derivs) ...@@ -192,7 +193,8 @@ cvtDec (NewtypeD ctxt tc tvs constr derivs)
, dd_kindSig = Nothing , dd_kindSig = Nothing
, dd_cons = [con'], dd_derivs = derivs' } , dd_cons = [con'], dd_derivs = derivs' }
; returnL $ TyClD (DataDecl { tcdLName = tc', tcdTyVars = tvs' ; returnL $ TyClD (DataDecl { tcdLName = tc', tcdTyVars = tvs'
, tcdDataDefn = defn, tcdFVs = placeHolderNames }) } , tcdDataDefn = defn
, tcdFVs = placeHolderNames }) }
cvtDec (ClassD ctxt cl tvs fds decs) cvtDec (ClassD ctxt cl tvs fds decs)
= do { (cxt', tc', tvs') <- cvt_tycl_hdr ctxt cl tvs = do { (cxt', tc', tvs') <- cvt_tycl_hdr ctxt cl tvs
...@@ -248,7 +250,8 @@ cvtDec (DataInstD ctxt tc tys constrs derivs) ...@@ -248,7 +250,8 @@ cvtDec (DataInstD ctxt tc tys constrs derivs)
; returnL $ InstD $ DataFamInstD ; returnL $ InstD $ DataFamInstD
{ dfid_inst = DataFamInstDecl { dfid_tycon = tc', dfid_pats = typats' { dfid_inst = DataFamInstDecl { dfid_tycon = tc', dfid_pats = typats'
, dfid_defn = defn, dfid_fvs = placeHolderNames } }} , dfid_defn = defn
, dfid_fvs = placeHolderNames } }}
cvtDec (NewtypeInstD ctxt tc tys constr derivs) cvtDec (NewtypeInstD ctxt tc tys constr derivs)
= do { (ctxt', tc', typats') <- cvt_tyinst_hdr ctxt tc tys = do { (ctxt', tc', typats') <- cvt_tyinst_hdr ctxt tc tys
...@@ -260,7 +263,8 @@ cvtDec (NewtypeInstD ctxt tc tys constr derivs) ...@@ -260,7 +263,8 @@ cvtDec (NewtypeInstD ctxt tc tys constr derivs)
, dd_cons = [con'], dd_derivs = derivs' } , dd_cons = [con'], dd_derivs = derivs' }
; returnL $ InstD $ DataFamInstD ; returnL $ InstD $ DataFamInstD
{ dfid_inst = DataFamInstDecl { dfid_tycon = tc', dfid_pats = typats' { dfid_inst = DataFamInstDecl { dfid_tycon = tc', dfid_pats = typats'
, dfid_defn = defn, dfid_fvs = placeHolderNames } }} , dfid_defn = defn
, dfid_fvs = placeHolderNames } }}
cvtDec (TySynInstD tc eqn) cvtDec (TySynInstD tc eqn)
= do { tc' <- tconNameL tc = do { tc' <- tconNameL tc
...@@ -327,7 +331,7 @@ cvt_tycl_hdr cxt tc tvs ...@@ -327,7 +331,7 @@ cvt_tycl_hdr cxt tc tvs
cvt_tyinst_hdr :: TH.Cxt -> TH.Name -> [TH.Type] cvt_tyinst_hdr :: TH.Cxt -> TH.Name -> [TH.Type]
-> CvtM ( LHsContext RdrName -> CvtM ( LHsContext RdrName
, Located RdrName , Located RdrName
, HsWithBndrs [LHsType RdrName]) , HsWithBndrs RdrName [LHsType RdrName])
cvt_tyinst_hdr cxt tc tys cvt_tyinst_hdr cxt tc tys
= do { cxt' <- cvtContext cxt = do { cxt' <- cvtContext cxt
; tc' <- tconNameL tc ; tc' <- tconNameL tc
...@@ -596,7 +600,9 @@ cvtl e = wrapL (cvt e) ...@@ -596,7 +600,9 @@ cvtl e = wrapL (cvt e)
cvt (ListE xs) cvt (ListE xs)
| Just s <- allCharLs xs = do { l' <- cvtLit (StringL s); return (HsLit l') } | Just s <- allCharLs xs = do { l' <- cvtLit (StringL s); return (HsLit l') }
-- Note [Converting strings] -- Note [Converting strings]
| otherwise = do { xs' <- mapM cvtl xs; return $ ExplicitList void Nothing xs' } | otherwise = do { xs' <- mapM cvtl xs
; return $ ExplicitList placeHolderType Nothing xs'
}
-- Infix expressions -- Infix expressions
cvt (InfixE (Just x) s (Just y)) = do { x' <- cvtl x; s' <- cvtl s; y' <- cvtl y cvt (InfixE (Just x) s (Just y)) = do { x' <- cvtl x; s' <- cvtl s; y' <- cvtl y
...@@ -734,7 +740,7 @@ cvtHsDo do_or_lc stmts ...@@ -734,7 +740,7 @@ cvtHsDo do_or_lc stmts
L loc (BodyStmt body _ _ _) -> return (L loc (mkLastStmt body)) L loc (BodyStmt body _ _ _) -> return (L loc (mkLastStmt body))
_ -> failWith (bad_last last') _ -> failWith (bad_last last')
; return $ HsDo do_or_lc (stmts'' ++ [last'']) void } ; return $ HsDo do_or_lc (stmts'' ++ [last'']) placeHolderType }
where where
bad_last stmt = vcat [ ptext (sLit "Illegal last statement of") <+> pprAStmtContext do_or_lc <> colon bad_last stmt = vcat [ ptext (sLit "Illegal last statement of") <+> pprAStmtContext do_or_lc <> colon
, nest 2 $ Outputable.ppr stmt , nest 2 $ Outputable.ppr stmt
...@@ -850,13 +856,16 @@ cvtp (ParensP p) = do { p' <- cvtPat p; return $ ParPat p' } ...@@ -850,13 +856,16 @@ cvtp (ParensP p) = do { p' <- cvtPat p; return $ ParPat p' }
cvtp (TildeP p) = do { p' <- cvtPat p; return $ LazyPat p' } cvtp (TildeP p) = do { p' <- cvtPat p; return $ LazyPat p' }
cvtp (BangP p) = do { p' <- cvtPat p; return $ BangPat p' } cvtp (BangP p) = do { p' <- cvtPat p; return $ BangPat p' }
cvtp (TH.AsP s p) = do { s' <- vNameL s; p' <- cvtPat p; return $ AsPat s' p' } cvtp (TH.AsP s p) = do { s' <- vNameL s; p' <- cvtPat p; return $ AsPat s' p' }
cvtp TH.WildP = return $ WildPat void cvtp TH.WildP = return $ WildPat placeHolderType
cvtp (RecP c fs) = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs cvtp (RecP c fs) = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs
; return $ ConPatIn c' $ Hs.RecCon (HsRecFields fs' Nothing) } ; return $ ConPatIn c'
cvtp (ListP ps) = do { ps' <- cvtPats ps; return $ ListPat ps' void Nothing } $ Hs.RecCon (HsRecFields fs' Nothing) }
cvtp (ListP ps) = do { ps' <- cvtPats ps
; return $ ListPat ps' placeHolderType Nothing }
cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t
; return $ SigPatIn p' (mkHsWithBndrs t') } ; return $ SigPatIn p' (mkHsWithBndrs t') }
cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p; return $ ViewPat e' p' void } cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p
; return $ ViewPat e' p' placeHolderType }
cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (HsRecField RdrName (LPat RdrName)) cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (HsRecField RdrName (LPat RdrName))
cvtPatFld (s,p) cvtPatFld (s,p)
...@@ -1032,9 +1041,6 @@ overloadedLit (IntegerL _) = True ...@@ -1032,9 +1041,6 @@ overloadedLit (IntegerL _) = True
overloadedLit (RationalL _) = True overloadedLit (RationalL _) = True
overloadedLit _ = False overloadedLit _ = False
void :: Type.Type
void = placeHolderType
cvtFractionalLit :: Rational -> FractionalLit cvtFractionalLit :: Rational -> FractionalLit
cvtFractionalLit r = FL { fl_text = show (fromRational r :: Double), fl_value = r } cvtFractionalLit r = FL { fl_text = show (fromRational r :: Double), fl_value = r }
......
...@@ -8,6 +8,11 @@ Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@. ...@@ -8,6 +8,11 @@ Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@.
\begin{code} \begin{code}
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
-- in module PlaceHolder
{-# LANGUAGE ConstraintKinds #-}
module HsBinds where module HsBinds where
...@@ -16,7 +21,7 @@ import {-# SOURCE #-} HsExpr ( pprExpr, LHsExpr, ...@@ -16,7 +21,7 @@ import {-# SOURCE #-} HsExpr ( pprExpr, LHsExpr,
GRHSs, pprPatBind ) GRHSs, pprPatBind )
import {-# SOURCE #-} HsPat ( LPat ) import {-# SOURCE #-} HsPat ( LPat )
import HsLit import PlaceHolder ( PostTc,PostRn,DataId )
import HsTypes import HsTypes
import PprCore () import PprCore ()
import CoreSyn import CoreSyn
...@@ -60,11 +65,13 @@ type HsLocalBinds id = HsLocalBindsLR id id ...@@ -60,11 +65,13 @@ type HsLocalBinds id = HsLocalBindsLR id id
-- | Bindings in a 'let' expression -- | Bindings in a 'let' expression
-- or a 'where' clause -- or a 'where' clause
data HsLocalBindsLR idL idR data HsLocalBindsLR idL idR
= HsValBinds (HsValBindsLR idL idR) = HsValBinds (HsValBindsLR idL idR)
| HsIPBinds (HsIPBinds idR) | HsIPBinds (HsIPBinds idR)
| EmptyLocalBinds | EmptyLocalBinds
deriving (Data, Typeable) deriving (Typeable)
deriving instance (DataId idL, DataId idR)
=> Data (HsLocalBindsLR idL idR)
type HsValBinds id = HsValBindsLR id id type HsValBinds id = HsValBindsLR id id
...@@ -83,7 +90,9 @@ data HsValBindsLR idL idR ...@@ -83,7 +90,9 @@ data HsValBindsLR idL idR
| ValBindsOut | ValBindsOut
[(RecFlag, LHsBinds idL)] [(RecFlag, LHsBinds idL)]
[LSig Name] [LSig Name]
deriving (Data, Typeable) deriving (Typeable)
deriving instance (DataId idL, DataId idR)
=> Data (HsValBindsLR idL idR)
type LHsBind id = LHsBindLR id id type LHsBind id = LHsBindLR id id
type LHsBinds id = LHsBindsLR id id type LHsBinds id = LHsBindsLR id id
...@@ -124,7 +133,8 @@ data HsBindLR idL idR ...@@ -124,7 +133,8 @@ data HsBindLR idL idR
-- type Int -> forall a'. a' -> a' -- type Int -> forall a'. a' -> a'
-- Notice that the coercion captures the free a'. -- Notice that the coercion captures the free a'.
bind_fvs :: NameSet, -- ^ After the renamer, this contains the locally-bound bind_fvs :: PostRn idL NameSet, -- ^ After the renamer, this contains
-- the locally-bound
-- free variables of this defn. -- free variables of this defn.
-- See Note [Bind free vars] -- See Note [Bind free vars]
...@@ -134,11 +144,11 @@ data HsBindLR idL idR ...@@ -134,11 +144,11 @@ data HsBindLR idL idR
-- | The pattern is never a simple variable; -- | The pattern is never a simple variable;
-- That case is done by FunBind -- That case is done by FunBind
| PatBind { | PatBind {
pat_lhs :: LPat idL, pat_lhs :: LPat idL,
pat_rhs :: GRHSs idR (LHsExpr idR), pat_rhs :: GRHSs idR (LHsExpr idR),
pat_rhs_ty :: PostTcType, -- ^ Type of the GRHSs pat_rhs_ty :: PostTc idR Type, -- ^ Type of the GRHSs
bind_fvs :: NameSet, -- ^ See Note [Bind free vars] bind_fvs :: PostRn idL NameSet, -- ^ See Note [Bind free vars]
pat_ticks :: (Maybe (Tickish Id), [Maybe (Tickish Id)]) pat_ticks :: (Maybe (Tickish Id), [Maybe (Tickish Id)])
-- ^ Tick to put on the rhs, if any, and ticks to put on -- ^ Tick to put on the rhs, if any, and ticks to put on
-- the bound variables. -- the bound variables.
...@@ -168,7 +178,10 @@ data HsBindLR idL idR ...@@ -168,7 +178,10 @@ data HsBindLR idL idR
| PatSynBind (PatSynBind idL idR) | PatSynBind (PatSynBind idL idR)
deriving (Data, Typeable) deriving (Typeable)
deriving instance (DataId idL, DataId idR)
=> Data (HsBindLR idL idR)
-- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds] -- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds]
-- --
-- Creates bindings for (polymorphic, overloaded) poly_f -- Creates bindings for (polymorphic, overloaded) poly_f
...@@ -190,16 +203,15 @@ data ABExport id ...@@ -190,16 +203,15 @@ data ABExport id
} deriving (Data, Typeable) } deriving (Data, Typeable)
data PatSynBind idL idR data PatSynBind idL idR
= PSB { psb_id :: Located idL, -- ^ Name of the pattern synonym = PSB { psb_id :: Located idL, -- ^ Name of the pattern synonym
psb_fvs :: NameSet, -- ^ See Note [Bind free vars] psb_fvs :: PostRn idR NameSet, -- ^ See Note [Bind free vars]
psb_args :: HsPatSynDetails (Located idR), -- ^ Formal parameter names psb_args :: HsPatSynDetails (Located idR), -- ^ Formal parameter names
psb_def :: LPat idR, -- ^ Right-hand side psb_def :: LPat idR, -- ^ Right-hand side
psb_dir :: HsPatSynDir idR -- ^ Directionality psb_dir :: HsPatSynDir idR -- ^ Directionality
} deriving (Data, Typeable) } deriving (Typeable)
deriving instance (DataId idL, DataId idR )
=> Data (PatSynBind idL idR)
-- | Used for the NameSet in FunBind and PatBind prior to the renamer
placeHolderNames :: NameSet
placeHolderNames = panic "placeHolderNames"
\end{code} \end{code}
Note [AbsBinds] Note [AbsBinds]
...@@ -500,7 +512,8 @@ data HsIPBinds id ...@@ -500,7 +512,8 @@ data HsIPBinds id
[LIPBind id] [LIPBind id]
TcEvBinds -- Only in typechecker output; binds TcEvBinds -- Only in typechecker output; binds
-- uses of the implicit parameters -- uses of the implicit parameters
deriving (Data, Typeable) deriving (Typeable)
deriving instance (DataId id) => Data (HsIPBinds id)
isEmptyIPBinds :: HsIPBinds id -> Bool isEmptyIPBinds :: HsIPBinds id -> Bool
isEmptyIPBinds (IPBinds is ds) = null is && isEmptyTcEvBinds ds isEmptyIPBinds (IPBinds is ds) = null is && isEmptyTcEvBinds ds
...@@ -514,7 +527,8 @@ that way until after type-checking when they are replaced with ...@@ -514,7 +527,8 @@ that way until after type-checking when they are replaced with
evidene for the implicit parameter. -} evidene for the implicit parameter. -}
data IPBind id data IPBind id
= IPBind (Either HsIPName id) (LHsExpr id) = IPBind (Either HsIPName id) (LHsExpr id)
deriving (Data, Typeable) deriving (Typeable)
deriving instance (DataId name) => Data (IPBind name)
instance (OutputableBndr id) => Outputable (HsIPBinds id) where instance (OutputableBndr id) => Outputable (HsIPBinds id) where
ppr (IPBinds bs ds) = pprDeeperList vcat (map ppr bs) ppr (IPBinds bs ds) = pprDeeperList vcat (map ppr bs)
...@@ -543,7 +557,7 @@ serves for both. ...@@ -543,7 +557,7 @@ serves for both.
type LSig name = Located (Sig name) type LSig name = Located (Sig name)
-- | Signatures and pragmas -- | Signatures and pragmas
data Sig name data Sig name
= -- | An ordinary type signature = -- | An ordinary type signature
-- @f :: Num a => a -> a@ -- @f :: Num a => a -> a@
TypeSig [Located name] (LHsType name) TypeSig [Located name] (LHsType name)
...@@ -605,7 +619,8 @@ data Sig name ...@@ -605,7 +619,8 @@ data Sig name
-- > {-# MINIMAL a | (b, c | (d | e)) #-} -- > {-# MINIMAL a | (b, c | (d | e)) #-}
| MinimalSig (BooleanFormula (Located name)) | MinimalSig (BooleanFormula (Located name))
deriving (Data, Typeable) deriving (Typeable)
deriving instance (DataId name) => Data (Sig name)
type LFixitySig name = Located (FixitySig name) type LFixitySig name = Located (FixitySig name)
...@@ -795,5 +810,6 @@ data HsPatSynDir id ...@@ -795,5 +810,6 @@ data HsPatSynDir id
= Unidirectional = Unidirectional
| ImplicitBidirectional | ImplicitBidirectional
| ExplicitBidirectional (MatchGroup id (LHsExpr id)) | ExplicitBidirectional (MatchGroup id (LHsExpr id))
deriving (Data, Typeable) deriving (Typeable)
deriving instance (DataId id) => Data (HsPatSynDir id)
\end{code} \end{code}
...@@ -6,6 +6,11 @@ ...@@ -6,6 +6,11 @@
\begin{code} \begin{code}
{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable, {-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable,
DeriveTraversable #-} DeriveTraversable #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
-- in module PlaceHolder
{-# LANGUAGE ConstraintKinds #-}
-- | Abstract syntax of global declarations. -- | Abstract syntax of global declarations.
-- --
...@@ -76,11 +81,12 @@ import HsPat ...@@ -76,11 +81,12 @@ import HsPat
import HsTypes import HsTypes
import HsDoc import HsDoc
import TyCon import TyCon
import NameSet
import Name import Name
import BasicTypes import BasicTypes
import Coercion import Coercion
import ForeignCall import ForeignCall
import PlaceHolder ( PostTc,PostRn,PlaceHolder(..),DataId )
import NameSet
-- others: -- others:
import InstEnv import InstEnv
...@@ -91,7 +97,7 @@ import SrcLoc ...@@ -91,7 +97,7 @@ import SrcLoc
import FastString import FastString
import Bag import Bag
import Data.Data hiding (TyCon) import Data.Data hiding (TyCon,Fixity)
import Data.Foldable (Foldable) import Data.Foldable (Foldable)
import Data.Traversable import Data.Traversable
import Data.Maybe import Data.Maybe
...@@ -123,7 +129,8 @@ data HsDecl id ...@@ -123,7 +129,8 @@ data HsDecl id
| DocD (DocDecl) | DocD (DocDecl)
| QuasiQuoteD (HsQuasiQuote id) | QuasiQuoteD (HsQuasiQuote id)
| RoleAnnotD (RoleAnnotDecl id) | RoleAnnotD (RoleAnnotDecl id)
deriving (Data, Typeable) deriving (Typeable)
deriving instance (DataId id) => Data (HsDecl id)
-- NB: all top-level fixity decls are contained EITHER -- NB: all top-level fixity decls are contained EITHER
...@@ -169,7 +176,8 @@ data HsGroup id ...@@ -169,7 +176,8 @@ data HsGroup id
hs_vects :: [LVectDecl id], hs_vects :: [LVectDecl id],
hs_docs :: [LDocDecl] hs_docs :: [LDocDecl]
} deriving (Data, Typeable) } deriving (Typeable)
deriving instance (DataId id) => Data (HsGroup id)
emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup a emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup a
emptyRdrGroup = emptyGroup { hs_valds = emptyValBindsIn } emptyRdrGroup = emptyGroup { hs_valds = emptyValBindsIn }
...@@ -284,12 +292,13 @@ instance OutputableBndr name => Outputable (HsGroup name) where ...@@ -284,12 +292,13 @@ instance OutputableBndr name => Outputable (HsGroup name) where
vcat_mb gap (Just d : ds) = gap $$ d $$ vcat_mb blankLine ds vcat_mb gap (Just d : ds) = gap $$ d $$ vcat_mb blankLine ds
type LSpliceDecl name = Located (SpliceDecl name) type LSpliceDecl name = Located (SpliceDecl name)
data SpliceDecl id data SpliceDecl id
= SpliceDecl -- Top level splice = SpliceDecl -- Top level splice
(Located (HsSplice id)) (Located (HsSplice id))