diff options
44 files changed, 1227 insertions, 689 deletions
diff --git a/compiler/deSugar/Check.lhs b/compiler/deSugar/Check.lhs index e07a70fc65..3e6912f20e 100644 --- a/compiler/deSugar/Check.lhs +++ b/compiler/deSugar/Check.lhs @@ -220,7 +220,7 @@ check' ((n, EqnInfo { eqn_pats = ps, eqn_rhs = MatchResult can_fail _ }) : rs) = ([], unitUniqSet n) -- One eqn, which can't 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 = (pats, addOneToUniqSet indexs n) @@ -281,7 +281,8 @@ process_literals used_lits qs default_eqns = ASSERT2( okGroup qs, pprGroup qs ) [remove_var q | q <- qs, is_var (firstPatN q)] (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 \end{code} @@ -326,9 +327,10 @@ nothing to do. \begin{code} first_column_only_vars :: [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet) -first_column_only_vars qs = (map (\ (xs,ys) -> (nlWildPat:xs,ys)) pats,indexs) - where - (pats, indexs) = check' (map remove_var qs) +first_column_only_vars qs + = (map (\ (xs,ys) -> (nlWildPatName:xs,ys)) pats,indexs) + where + (pats, indexs) = check' (map remove_var qs) \end{code} 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" make_row_vars :: [HsLit] -> (EqnNo, EquationInfo) -> ExhaustivePat 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 new_var = hash_x @@ -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 (_, EqnInfo { eqn_pats = pats}) - = takeList (tail pats) (repeat nlWildPat) + = takeList (tail pats) (repeat nlWildPatName) compare_cons :: Pat Id -> Pat Id -> Bool 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) | isInfixCon id = (nlInfixConPat (getName id) lp lq : ps, constraints) where q = unLoc lq -make_con (ConPatOut{ pat_con = L _ (RealDataCon id), pat_args = PrefixCon pats, pat_arg_tys = tys }) (ps, constraints) - | isTupleTyCon tc = (noLoc (TuplePat pats_con (tupleTyConBoxity tc) tys) : rest_pats, constraints) - | isPArrFakeCon id = (noLoc (PArrPat pats_con placeHolderType) : rest_pats, constraints) - | otherwise = (nlConPat name pats_con : rest_pats, constraints) +make_con (ConPatOut{ pat_con = L _ (RealDataCon id), pat_args = PrefixCon pats}) + (ps, constraints) + | isTupleTyCon tc = (noLoc (TuplePat pats_con (tupleTyConBoxity tc) []) + : rest_pats, constraints) + | isPArrFakeCon id = (noLoc (PArrPat pats_con placeHolderType) + : rest_pats, constraints) + | otherwise = (nlConPatName name pats_con + : rest_pats, constraints) where name = getName id (pats_con, rest_pats) = splitAtList pats ps @@ -612,11 +619,12 @@ make_con _ _ = panic "Check.make_con: Not ConPatOut" -- representation make_whole_con :: DataCon -> WarningPat -make_whole_con con | isInfixCon con = nlInfixConPat name nlWildPat nlWildPat - | otherwise = nlConPat name pats +make_whole_con con | isInfixCon con = nlInfixConPat name + nlWildPatName nlWildPatName + | otherwise = nlConPatName name pats where name = getName con - pats = [nlWildPat | _ <- dataConOrigArgTys con] + pats = [nlWildPatName | _ <- dataConOrigArgTys con] \end{code} ------------------------------------------------------------------------ @@ -745,7 +753,7 @@ tidy_con :: ConLike -> HsConPatDetails Id -> HsConPatDetails Id tidy_con _ (PrefixCon ps) = PrefixCon (map tidy_lpat ps) tidy_con _ (InfixCon p1 p2) = PrefixCon [tidy_lpat p1, tidy_lpat p2] 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 | otherwise = PrefixCon (map (tidy_lpat.snd) all_pats) where @@ -755,7 +763,7 @@ tidy_con con (RecCon (HsRecFields fs _)) -- pad out all the missing fields with WildPats. 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" all_pats = foldr (\(HsRecField id p _) acc -> insertNm (getName (unLoc id)) p acc) field_pats fs diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index 2a2d733995..7b18b2e2b3 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@ -676,7 +676,8 @@ makes all list literals be generated via the simple route. \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] dsExplicitList elt_ty Nothing xs = do { dflags <- getDynFlags diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 31220e4940..a0be3d926b 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -280,6 +280,7 @@ Library HsExpr HsImpExp HsLit + PlaceHolder HsPat HsSyn HsTypes diff --git a/compiler/ghc.mk b/compiler/ghc.mk index d23d1fe5b6..05c935f889 100644 --- a/compiler/ghc.mk +++ b/compiler/ghc.mk @@ -538,6 +538,7 @@ compiler_stage2_dll0_MODULES = \ HsExpr \ HsImpExp \ HsLit \ + PlaceHolder \ HsPat \ HsSyn \ HsTypes \ diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index d722a402e0..7b841d5edc 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -140,7 +140,7 @@ cvtDec (TH.ValD pat body ds) ; ds' <- cvtLocalDecs (ptext (sLit "a where clause")) ds ; returnL $ Hs.ValD $ 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,[]) } } cvtDec (TH.FunD nm cls) @@ -181,7 +181,8 @@ cvtDec (DataD ctxt tc tvs constrs derivs) , dd_kindSig = Nothing , dd_cons = cons', dd_derivs = derivs' } ; returnL $ TyClD (DataDecl { tcdLName = tc', tcdTyVars = tvs' - , tcdDataDefn = defn, tcdFVs = placeHolderNames }) } + , tcdDataDefn = defn + , tcdFVs = placeHolderNames }) } cvtDec (NewtypeD ctxt tc tvs constr derivs) = do { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs @@ -192,7 +193,8 @@ cvtDec (NewtypeD ctxt tc tvs constr derivs) , dd_kindSig = Nothing , dd_cons = [con'], dd_derivs = derivs' } ; returnL $ TyClD (DataDecl { tcdLName = tc', tcdTyVars = tvs' - , tcdDataDefn = defn, tcdFVs = placeHolderNames }) } + , tcdDataDefn = defn + , tcdFVs = placeHolderNames }) } cvtDec (ClassD ctxt cl tvs fds decs) = do { (cxt', tc', tvs') <- cvt_tycl_hdr ctxt cl tvs @@ -248,7 +250,8 @@ cvtDec (DataInstD ctxt tc tys constrs derivs) ; returnL $ InstD $ DataFamInstD { 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) = do { (ctxt', tc', typats') <- cvt_tyinst_hdr ctxt tc tys @@ -260,7 +263,8 @@ cvtDec (NewtypeInstD ctxt tc tys constr derivs) , dd_cons = [con'], dd_derivs = derivs' } ; returnL $ InstD $ DataFamInstD { 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) = do { tc' <- tconNameL tc @@ -327,7 +331,7 @@ cvt_tycl_hdr cxt tc tvs cvt_tyinst_hdr :: TH.Cxt -> TH.Name -> [TH.Type] -> CvtM ( LHsContext RdrName , Located RdrName - , HsWithBndrs [LHsType RdrName]) + , HsWithBndrs RdrName [LHsType RdrName]) cvt_tyinst_hdr cxt tc tys = do { cxt' <- cvtContext cxt ; tc' <- tconNameL tc @@ -596,7 +600,9 @@ cvtl e = wrapL (cvt e) cvt (ListE xs) | Just s <- allCharLs xs = do { l' <- cvtLit (StringL s); return (HsLit l') } -- 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 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 L loc (BodyStmt body _ _ _) -> return (L loc (mkLastStmt body)) _ -> failWith (bad_last last') - ; return $ HsDo do_or_lc (stmts'' ++ [last'']) void } + ; return $ HsDo do_or_lc (stmts'' ++ [last'']) placeHolderType } where bad_last stmt = vcat [ ptext (sLit "Illegal last statement of") <+> pprAStmtContext do_or_lc <> colon , nest 2 $ Outputable.ppr stmt @@ -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 (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.WildP = return $ WildPat void +cvtp TH.WildP = return $ WildPat placeHolderType cvtp (RecP c fs) = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs - ; return $ ConPatIn c' $ Hs.RecCon (HsRecFields fs' Nothing) } -cvtp (ListP ps) = do { ps' <- cvtPats ps; return $ ListPat ps' void Nothing } + ; return $ ConPatIn c' + $ 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 ; 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 (s,p) @@ -1032,9 +1041,6 @@ overloadedLit (IntegerL _) = True overloadedLit (RationalL _) = True overloadedLit _ = False -void :: Type.Type -void = placeHolderType - cvtFractionalLit :: Rational -> FractionalLit cvtFractionalLit r = FL { fl_text = show (fromRational r :: Double), fl_value = r } diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs index 04a72225f1..e0176a52a0 100644 --- a/compiler/hsSyn/HsBinds.lhs +++ b/compiler/hsSyn/HsBinds.lhs @@ -8,6 +8,11 @@ Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@. \begin{code} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] + -- in module PlaceHolder +{-# LANGUAGE ConstraintKinds #-} module HsBinds where @@ -16,7 +21,7 @@ import {-# SOURCE #-} HsExpr ( pprExpr, LHsExpr, GRHSs, pprPatBind ) import {-# SOURCE #-} HsPat ( LPat ) -import HsLit +import PlaceHolder ( PostTc,PostRn,DataId ) import HsTypes import PprCore () import CoreSyn @@ -60,11 +65,13 @@ type HsLocalBinds id = HsLocalBindsLR id id -- | Bindings in a 'let' expression -- or a 'where' clause -data HsLocalBindsLR idL idR +data HsLocalBindsLR idL idR = HsValBinds (HsValBindsLR idL idR) | HsIPBinds (HsIPBinds idR) | EmptyLocalBinds - deriving (Data, Typeable) + deriving (Typeable) +deriving instance (DataId idL, DataId idR) + => Data (HsLocalBindsLR idL idR) type HsValBinds id = HsValBindsLR id id @@ -83,7 +90,9 @@ data HsValBindsLR idL idR | ValBindsOut [(RecFlag, LHsBinds idL)] [LSig Name] - deriving (Data, Typeable) + deriving (Typeable) +deriving instance (DataId idL, DataId idR) + => Data (HsValBindsLR idL idR) type LHsBind id = LHsBindLR id id type LHsBinds id = LHsBindsLR id id @@ -124,7 +133,8 @@ data HsBindLR idL idR -- type Int -> forall a'. a' -> 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. -- See Note [Bind free vars] @@ -134,11 +144,11 @@ data HsBindLR idL idR -- | The pattern is never a simple variable; -- That case is done by FunBind - | PatBind { + | PatBind { pat_lhs :: LPat idL, pat_rhs :: GRHSs idR (LHsExpr idR), - pat_rhs_ty :: PostTcType, -- ^ Type of the GRHSs - bind_fvs :: NameSet, -- ^ See Note [Bind free vars] + pat_rhs_ty :: PostTc idR Type, -- ^ Type of the GRHSs + bind_fvs :: PostRn idL NameSet, -- ^ See Note [Bind free vars] pat_ticks :: (Maybe (Tickish Id), [Maybe (Tickish Id)]) -- ^ Tick to put on the rhs, if any, and ticks to put on -- the bound variables. @@ -168,7 +178,10 @@ data HsBindLR 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] -- -- Creates bindings for (polymorphic, overloaded) poly_f @@ -190,16 +203,15 @@ data ABExport id } deriving (Data, Typeable) data PatSynBind idL idR - = PSB { psb_id :: Located idL, -- ^ Name of the pattern synonym - psb_fvs :: NameSet, -- ^ See Note [Bind free vars] + = PSB { psb_id :: Located idL, -- ^ Name of the pattern synonym + psb_fvs :: PostRn idR NameSet, -- ^ See Note [Bind free vars] psb_args :: HsPatSynDetails (Located idR), -- ^ Formal parameter names psb_def :: LPat idR, -- ^ Right-hand side 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} Note [AbsBinds] @@ -500,7 +512,8 @@ data HsIPBinds id [LIPBind id] TcEvBinds -- Only in typechecker output; binds -- uses of the implicit parameters - deriving (Data, Typeable) + deriving (Typeable) +deriving instance (DataId id) => Data (HsIPBinds id) isEmptyIPBinds :: HsIPBinds id -> Bool isEmptyIPBinds (IPBinds is ds) = null is && isEmptyTcEvBinds ds @@ -514,7 +527,8 @@ that way until after type-checking when they are replaced with evidene for the implicit parameter. -} data IPBind 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 ppr (IPBinds bs ds) = pprDeeperList vcat (map ppr bs) @@ -543,7 +557,7 @@ serves for both. type LSig name = Located (Sig name) -- | Signatures and pragmas -data Sig name +data Sig name = -- | An ordinary type signature -- @f :: Num a => a -> a@ TypeSig [Located name] (LHsType name) @@ -605,7 +619,8 @@ data Sig name -- > {-# MINIMAL a | (b, c | (d | e)) #-} | MinimalSig (BooleanFormula (Located name)) - deriving (Data, Typeable) + deriving (Typeable) +deriving instance (DataId name) => Data (Sig name) type LFixitySig name = Located (FixitySig name) @@ -795,5 +810,6 @@ data HsPatSynDir id = Unidirectional | ImplicitBidirectional | ExplicitBidirectional (MatchGroup id (LHsExpr id)) - deriving (Data, Typeable) + deriving (Typeable) +deriving instance (DataId id) => Data (HsPatSynDir id) \end{code} diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs index 9680c89e9b..f584372385 100644 --- a/compiler/hsSyn/HsDecls.lhs +++ b/compiler/hsSyn/HsDecls.lhs @@ -6,6 +6,11 @@ \begin{code} {-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] + -- in module PlaceHolder +{-# LANGUAGE ConstraintKinds #-} -- | Abstract syntax of global declarations. -- @@ -76,11 +81,12 @@ import HsPat import HsTypes import HsDoc import TyCon -import NameSet import Name import BasicTypes import Coercion import ForeignCall +import PlaceHolder ( PostTc,PostRn,PlaceHolder(..),DataId ) +import NameSet -- others: import InstEnv @@ -91,7 +97,7 @@ import SrcLoc import FastString import Bag -import Data.Data hiding (TyCon) +import Data.Data hiding (TyCon,Fixity) import Data.Foldable (Foldable) import Data.Traversable import Data.Maybe @@ -123,7 +129,8 @@ data HsDecl id | DocD (DocDecl) | QuasiQuoteD (HsQuasiQuote 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 @@ -169,7 +176,8 @@ data HsGroup id hs_vects :: [LVectDecl id], hs_docs :: [LDocDecl] - } deriving (Data, Typeable) + } deriving (Typeable) +deriving instance (DataId id) => Data (HsGroup id) emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup a emptyRdrGroup = emptyGroup { hs_valds = emptyValBindsIn } @@ -284,12 +292,13 @@ instance OutputableBndr name => Outputable (HsGroup name) where vcat_mb gap (Just d : ds) = gap $$ d $$ vcat_mb blankLine ds type LSpliceDecl name = Located (SpliceDecl name) -data SpliceDecl id +data SpliceDecl id = SpliceDecl -- Top level splice (Located (HsSplice id)) HsExplicitFlag -- Explicit <=> $(f x y) -- Implicit <=> f x y, i.e. a naked top level expression - deriving (Data, Typeable) + deriving (Typeable) +deriving instance (DataId id) => Data (SpliceDecl id) instance OutputableBndr name => Outputable (SpliceDecl name) where ppr (SpliceDecl (L _ e) _) = pprUntypedSplice e @@ -453,7 +462,7 @@ data TyClDecl name , tcdTyVars :: LHsTyVarBndrs name -- ^ Type variables; for an associated type -- these include outer binders , tcdRhs :: LHsType name -- ^ RHS of type declaration - , tcdFVs :: NameSet } + , tcdFVs :: PostRn name NameSet } | -- | @data@ declaration DataDecl { tcdLName :: Located name -- ^ Type constructor @@ -465,7 +474,7 @@ data TyClDecl name -- Here the type decl for 'f' includes 'a' -- in its tcdTyVars , tcdDataDefn :: HsDataDefn name - , tcdFVs :: NameSet } + , tcdFVs :: PostRn name NameSet } | ClassDecl { tcdCtxt :: LHsContext name, -- ^ Context... tcdLName :: Located name, -- ^ Name of the class @@ -476,10 +485,11 @@ data TyClDecl name tcdATs :: [LFamilyDecl name], -- ^ Associated types; ie tcdATDefs :: [LTyFamDefltEqn name], -- ^ Associated type defaults tcdDocs :: [LDocDecl], -- ^ Haddock docs - tcdFVs :: NameSet + tcdFVs :: PostRn name NameSet } - - deriving (Data, Typeable) + + deriving (Typeable) +deriving instance (DataId id) => Data (TyClDecl id) -- This is used in TcTyClsDecls to represent -- strongly connected components of decls @@ -489,7 +499,8 @@ data TyClDecl name data TyClGroup name = TyClGroup { group_tyclds :: [LTyClDecl name] , group_roles :: [LRoleAnnotDecl name] } - deriving (Data, Typeable) + deriving (Typeable) +deriving instance (DataId id) => Data (TyClGroup id) tyClGroupConcat :: [TyClGroup name] -> [LTyClDecl name] tyClGroupConcat = concatMap group_tyclds @@ -503,7 +514,8 @@ data FamilyDecl name = FamilyDecl , fdLName :: Located name -- type constructor , fdTyVars :: LHsTyVarBndrs name -- type variables , fdKindSig :: Maybe (LHsKind name) } -- result kind - deriving( Data, Typeable ) + deriving( Typeable ) +deriving instance (DataId id) => Data (FamilyDecl id) data FamilyInfo name = DataFamily @@ -511,7 +523,8 @@ data FamilyInfo name -- this list might be empty, if we're in an hs-boot file and the user -- said "type family Foo x where .." | ClosedTypeFamily [LTyFamInstEqn name] - deriving( Data, Typeable ) + deriving( Typeable ) +deriving instance (DataId name) => Data (FamilyInfo name) \end{code} @@ -789,7 +802,8 @@ data HsDataDefn name -- The payload of a data type defn -- Typically the foralls and ty args are empty, but they -- are non-empty for the newtype-deriving case } - deriving( Data, Typeable ) + deriving( Typeable ) +deriving instance (DataId id) => Data (HsDataDefn id) data NewOrData = NewType -- ^ @newtype Blah ...@ @@ -842,12 +856,13 @@ data ConDecl name , con_doc :: Maybe LHsDocString -- ^ A possible Haddock comment. - , con_old_rec :: Bool + , con_old_rec :: Bool -- ^ TEMPORARY field; True <=> user has employed now-deprecated syntax for -- GADT-style record decl C { blah } :: T a b -- Remove this when we no longer parse this stuff, and hence do not -- need to report decprecated use - } deriving (Data, Typeable) + } deriving (Typeable) +deriving instance (DataId name) => Data (ConDecl name) type HsConDeclDetails name = HsConDetails (LBangType name) [ConDeclField name] @@ -964,7 +979,7 @@ It is parameterised over its tfe_pats field: type LTyFamInstEqn name = Located (TyFamInstEqn name) type LTyFamDefltEqn name = Located (TyFamDefltEqn name) -type HsTyPats name = HsWithBndrs [LHsType name] +type HsTyPats name = HsWithBndrs name [LHsType name] -- ^ Type patterns (with kind and type bndrs) -- See Note [Family instance declaration binders] @@ -979,14 +994,16 @@ data TyFamEqn name pats { tfe_tycon :: Located name , tfe_pats :: pats , tfe_rhs :: LHsType name } - deriving( Typeable, Data ) + deriving( Typeable ) +deriving instance (DataId name, Data pats) => Data (TyFamEqn name pats) type LTyFamInstDecl name = Located (TyFamInstDecl name) data TyFamInstDecl name = TyFamInstDecl { tfid_eqn :: LTyFamInstEqn name - , tfid_fvs :: NameSet } - deriving( Typeable, Data ) + , tfid_fvs :: PostRn name NameSet } + deriving( Typeable ) +deriving instance (DataId name) => Data (TyFamInstDecl name) ----------------- Data family instances ------------- @@ -996,8 +1013,10 @@ data DataFamInstDecl name { dfid_tycon :: Located name , dfid_pats :: HsTyPats name -- LHS , dfid_defn :: HsDataDefn name -- RHS - , dfid_fvs :: NameSet } -- Rree vars for dependency analysis - deriving( Typeable, Data ) + , dfid_fvs :: PostRn name NameSet } -- Rree vars for + -- dependency analysis + deriving( Typeable ) +deriving instance (DataId name) => Data (DataFamInstDecl name) ----------------- Class instances ------------- @@ -1014,7 +1033,8 @@ data ClsInstDecl name , cid_datafam_insts :: [LDataFamInstDecl name] -- Data family instances , cid_overlap_mode :: Maybe OverlapMode } - deriving (Data, Typeable) + deriving (Typeable) +deriving instance (DataId id) => Data (ClsInstDecl id) ----------------- Instances of all kinds ------------- @@ -1027,7 +1047,8 @@ data InstDecl name -- Both class and family instances { dfid_inst :: DataFamInstDecl name } | TyFamInstD -- type family instance { tfid_inst :: TyFamInstDecl name } - deriving (Data, Typeable) + deriving (Typeable) +deriving instance (DataId id) => Data (InstDecl id) \end{code} Note [Family instance declaration binders] @@ -1148,7 +1169,8 @@ type LDerivDecl name = Located (DerivDecl name) data DerivDecl name = DerivDecl { deriv_type :: LHsType name , deriv_overlap_mode :: Maybe OverlapMode } - deriving (Data, Typeable) + deriving (Typeable) +deriving instance (DataId name) => Data (DerivDecl name) instance (OutputableBndr name) => Outputable (DerivDecl name) where ppr (DerivDecl ty o) @@ -1170,7 +1192,8 @@ type LDefaultDecl name = Located (DefaultDecl name) data DefaultDecl name = DefaultDecl [LHsType name] - deriving (Data, Typeable) + deriving (Typeable) +deriving instance (DataId name) => Data (DefaultDecl name) instance (OutputableBndr name) => Outputable (DefaultDecl name) where @@ -1198,13 +1221,14 @@ type LForeignDecl name = Located (ForeignDecl name) data ForeignDecl name = ForeignImport (Located name) -- defines this name (LHsType name) -- sig_ty - Coercion -- rep_ty ~ sig_ty + (PostTc name Coercion) -- rep_ty ~ sig_ty ForeignImport | ForeignExport (Located name) -- uses this name (LHsType name) -- sig_ty - Coercion -- sig_ty ~ rep_ty + (PostTc name Coercion) -- sig_ty ~ rep_ty ForeignExport - deriving (Data, Typeable) + deriving (Typeable) +deriving instance (DataId name) => Data (ForeignDecl name) {- In both ForeignImport and ForeignExport: sig_ty is the type given in the Haskell code @@ -1214,13 +1238,11 @@ data ForeignDecl name such as Int and IO that we know how to make foreign calls with. -} -noForeignImportCoercionYet :: Coercion -noForeignImportCoercionYet - = panic "ForeignImport coercion evaluated before typechecking" +noForeignImportCoercionYet :: PlaceHolder +noForeignImportCoercionYet = PlaceHolder -noForeignExportCoercionYet :: Coercion -noForeignExportCoercionYet - = panic "ForeignExport coercion evaluated before typechecking" +noForeignExportCoercionYet :: PlaceHolder +noForeignExportCoercionYet = PlaceHolder -- Specification Of an imported external entity in dependence on the calling -- convention @@ -1311,17 +1333,19 @@ data RuleDecl name Activation [RuleBndr name] -- Forall'd vars; after typechecking this includes tyvars (Located (HsExpr name)) -- LHS - NameSet -- Free-vars from the LHS + (PostRn name NameSet) -- Free-vars from the LHS (Located (HsExpr name)) -- RHS - NameSet -- Free-vars from the RHS - deriving (Data, Typeable) + (PostRn name NameSet) -- Free-vars from the RHS + deriving (Typeable) +deriving instance (DataId name) => Data (RuleDecl name) data RuleBndr name = RuleBndr (Located name) - | RuleBndrSig (Located name) (HsWithBndrs (LHsType name)) - deriving (Data, Typeable) + | RuleBndrSig (Located name) (HsWithBndrs name (LHsType name)) + deriving (Typeable) +deriving instance (DataId name) => Data (RuleBndr name) -collectRuleBndrSigTys :: [RuleBndr name] -> [HsWithBndrs (LHsType name)] +collectRuleBndrSigTys :: [RuleBndr name] -> [HsWithBndrs name (LHsType name)] collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ ty <- bndrs] instance OutputableBndr name => Outputable (RuleDecl name) where @@ -1379,7 +1403,8 @@ data VectDecl name (LHsType name) | HsVectInstOut -- post type-checking (always SCALAR) !!!FIXME: should be superfluous now ClsInst - deriving (Data, Typeable) + deriving (Typeable) +deriving instance (DataId name) => Data (VectDecl name) lvectDeclName :: NamedThing name => LVectDecl name -> Name lvectDeclName (L _ (HsVect (L _ name) _)) = getName name @@ -1487,10 +1512,11 @@ instance OutputableBndr name => Outputable (WarnDecl name) where type LAnnDecl name = Located (AnnDecl name) data AnnDecl name = HsAnnotation (AnnProvenance name) (Located (HsExpr name)) - deriving (Data, Typeable) + deriving (Typeable) +deriving instance (DataId name) => Data (AnnDecl name) instance (OutputableBndr name) => Outputable (AnnDecl name) where - ppr (HsAnnotation provenance expr) + ppr (HsAnnotation provenance expr) = hsep [text "{-#", pprAnnProvenance provenance, pprExpr (unLoc expr), text "#-}"] diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs index 69b6df64ec..c61e0c719c 100644 --- a/compiler/hsSyn/HsExpr.lhs +++ b/compiler/hsSyn/HsExpr.lhs @@ -4,6 +4,11 @@ % \begin{code} {-# LANGUAGE CPP, DeriveDataTypeable, ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] + -- in module PlaceHolder +{-# LANGUAGE ConstraintKinds #-} -- | Abstract Haskell syntax for expressions. module HsExpr where @@ -14,6 +19,7 @@ module HsExpr where import HsDecls import HsPat import HsLit +import PlaceHolder ( PostTc,PostRn,DataId ) import HsTypes import HsBinds @@ -30,12 +36,12 @@ import Util import StaticFlags( opt_PprStyle_Debug ) import Outputable import FastString +import Type -- libraries: import Data.Data hiding (Fixity) \end{code} - %************************************************************************ %* * \subsection{Expressions proper} @@ -127,7 +133,7 @@ data HsExpr id | HsLam (MatchGroup id (LHsExpr id)) -- ^ Lambda abstraction. Currently always a single match - | HsLamCase PostTcType (MatchGroup id (LHsExpr id)) -- ^ Lambda-case + | HsLamCase (PostTc id Type) (MatchGroup id (LHsExpr id)) -- ^ Lambda-case | HsApp (LHsExpr id) (LHsExpr id) -- ^ Application @@ -139,7 +145,7 @@ data HsExpr id | OpApp (LHsExpr id) -- left operand (LHsExpr id) -- operator - Fixity -- Renamer adds fixity; bottom until then + (PostRn id Fixity) -- Renamer adds fixity; bottom until then (LHsExpr id) -- right operand -- | Negation operator. Contains the negated expression and the name @@ -170,7 +176,7 @@ data HsExpr id (LHsExpr id) -- else part -- | Multi-way if - | HsMultiIf PostTcType [LGRHS id (LHsExpr id)] + | HsMultiIf (PostTc id Type) [LGRHS id (LHsExpr id)] -- | let(rec) | HsLet (HsLocalBinds id) @@ -180,17 +186,17 @@ data HsExpr id -- because in this context we never use -- the PatGuard or ParStmt variant [ExprLStmt id] -- "do":one or more stmts - PostTcType -- Type of the whole expression + (PostTc id Type) -- Type of the whole expression -- | Syntactic list: [a,b,c,...] - | ExplicitList - PostTcType -- Gives type of components of list + | ExplicitList + (PostTc id Type) -- Gives type of components of list (Maybe (SyntaxExpr id)) -- For OverloadedLists, the fromListN witness [LHsExpr id] -- | Syntactic parallel array: [:e1, ..., en:] - | ExplicitPArr - PostTcType -- type of elements of the parallel array + | ExplicitPArr + (PostTc id Type) -- type of elements of the parallel array [LHsExpr id] -- | Record construction @@ -207,8 +213,8 @@ data HsExpr id [DataCon] -- Filled in by the type checker to the -- _non-empty_ list of DataCons that have -- all the upd'd fields - [PostTcType] -- Argument types of *input* record type - [PostTcType] -- and *output* record type + [PostTc id Type] -- Argument types of *input* record type + [PostTc id Type] -- and *output* record type -- For a type family, the arg types are of the *instance* tycon, -- not the family tycon @@ -274,22 +280,22 @@ data HsExpr id -- The following are commands, not expressions proper -- They are only used in the parsing stage and are removed -- immediately in parser.RdrHsSyn.checkCommand - | HsArrApp -- Arrow tail, or arrow application (f -< arg) - (LHsExpr id) -- arrow expression, f - (LHsExpr id) -- input expression, arg - PostTcType -- type of the arrow expressions f, - -- of the form a t t', where arg :: t - HsArrAppType -- higher-order (-<<) or first-order (-<) - Bool -- True => right-to-left (f -< arg) - -- False => left-to-right (arg >- f) - - | HsArrForm -- Command formation, (| e cmd1 .. cmdn |) - (LHsExpr id) -- the operator - -- after type-checking, a type abstraction to be - -- applied to the type of the local environment tuple - (Maybe Fixity) -- fixity (filled in by the renamer), for forms that - -- were converted from OpApp's by the renamer - [LHsCmdTop id] -- argument commands + | HsArrApp -- Arrow tail, or arrow application (f -< arg) + (LHsExpr id) -- arrow expression, f + (LHsExpr id) -- input expression, arg + (PostTc id Type) -- type of the arrow expressions f, + -- of the form a t t', where arg :: t + HsArrAppType -- higher-order (-<<) or first-order (-<) + Bool -- True => right-to-left (f -< arg) + -- False => left-to-right (arg >- f) + + | HsArrForm -- Command formation, (| e cmd1 .. cmdn |) + (LHsExpr id) -- the operator + -- after type-checking, a type abstraction to be + -- applied to the type of the local environment tuple + (Maybe Fixity) -- fixity (filled in by the renamer), for forms that + -- were converted from OpApp's by the renamer + [LHsCmdTop id] -- argument commands --------------------------------------- -- Haskell program coverage (Hpc) Support @@ -329,15 +335,17 @@ data HsExpr id | HsWrap HsWrapper -- TRANSLATION (HsExpr id) | HsUnboundVar RdrName - deriving (Data, Typeable) + deriving (Typeable) +deriving instance (DataId id) => Data (HsExpr id) -- | HsTupArg is used for tuple sections -- (,a,) is represented by ExplicitTuple [Mising ty1, Present a, Missing ty3] -- Which in turn stands for (\x:ty1 \y:ty2. (x,a,y)) data HsTupArg id - = Present (LHsExpr id) -- ^ The argument - | Missing PostTcType -- ^ The argument is missing, but this is its type - deriving (Data, Typeable) + = Present (LHsExpr id) -- ^ The argument + | Missing (PostTc id Type) -- ^ The argument is missing, but this is its type + deriving (Typeable) +deriving instance (DataId id) => Data (HsTupArg id) tupArgPresent :: HsTupArg id -> Bool tupArgPresent (Present {}) = True @@ -716,22 +724,22 @@ We re-use HsExpr to represent these. type LHsCmd id = Located (HsCmd id) data HsCmd id - = HsCmdArrApp -- Arrow tail, or arrow application (f -< arg) - (LHsExpr id) -- arrow expression, f - (LHsExpr id) -- input expression, arg - PostTcType -- type of the arrow expressions f, - -- of the form a t t', where arg :: t - HsArrAppType -- higher-order (-<<) or first-order (-<) - Bool -- True => right-to-left (f -< arg) - -- False => left-to-right (arg >- f) - - | HsCmdArrForm -- Command formation, (| e cmd1 .. cmdn |) - (LHsExpr id) -- the operator - -- after type-checking, a type abstraction to be - -- applied to the type of the local environment tuple - (Maybe Fixity) -- fixity (filled in by the renamer), for forms that - -- were converted from OpApp's by the renamer - [LHsCmdTop id] -- argument commands + = HsCmdArrApp -- Arrow tail, or arrow application (f -< arg) + (LHsExpr id) -- arrow expression, f + (LHsExpr id) -- input expression, arg + (PostTc id Type) -- type of the arrow expressions f, + -- of the form a t t', where arg :: t + HsArrAppType -- higher-order (-<<) or first-order (-<) + Bool -- True => right-to-left (f -< arg) + -- False => left-to-right (arg >- f) + + | HsCmdArrForm -- Command formation, (| e cmd1 .. cmdn |) + (LHsExpr id) -- the operator + -- after type-checking, a type abstraction to be + -- applied to the type of the local environment tuple + (Maybe Fixity) -- fixity (filled in by the renamer), for forms that + -- were converted from OpApp's by the renamer + [LHsCmdTop id] -- argument commands | HsCmdApp (LHsCmd id) (LHsExpr id) @@ -752,14 +760,14 @@ data HsCmd id (LHsCmd id) | HsCmdDo [CmdLStmt id] - PostTcType -- Type of the whole expression + (PostTc id Type) -- Type of the whole expression | HsCmdCast TcCoercion -- A simpler version of HsWrap in HsExpr (HsCmd id) -- If cmd :: arg1 --> res -- co :: arg1 ~ arg2 -- Then (HsCmdCast co cmd) :: arg2 --> res - - deriving (Data, Typeable) + deriving (Typeable) +deriving instance (DataId id) => Data (HsCmd id) data HsArrAppType = HsHigherOrderApp | HsFirstOrderApp deriving (Data, Typeable) @@ -775,10 +783,11 @@ type LHsCmdTop id = Located (HsCmdTop id) data HsCmdTop id = HsCmdTop (LHsCmd id) - PostTcType -- Nested tuple of inputs on the command's stack - PostTcType -- return type of the command + (PostTc id Type) -- Nested tuple of inputs on the command's stack + (PostTc id Type) -- return type of the command (CmdSyntaxTable id) -- See Note [CmdSyntaxTable] - deriving (Data, Typeable) + deriving (Typeable) +deriving instance (DataId id) => Data (HsCmdTop id) \end{code} @@ -906,13 +915,14 @@ patterns in each equation. \begin{code} data MatchGroup id body = MG { mg_alts :: [LMatch id body] -- The alternatives - , mg_arg_tys :: [PostTcType] -- Types of the arguments, t1..tn - , mg_res_ty :: PostTcType -- Type of the result, tr + , mg_arg_tys :: [PostTc id Type] -- Types of the arguments, t1..tn + , mg_res_ty :: PostTc id Type -- Type of the result, tr , mg_origin :: Origin } -- The type is the type of the entire group -- t1 -> ... -> tn -> tr -- where there are n patterns - deriving (Data, Typeable) + deriving (Typeable) +deriving instance (Data body,DataId id) => Data (MatchGroup id body) type LMatch id body = Located (Match id body) @@ -922,7 +932,8 @@ data Match id body (Maybe (LHsType id)) -- A type signature for the result of the match -- Nothing after typechecking (GRHSs id body) - deriving (Data, Typeable) + deriving (Typeable) +deriving instance (Data body,DataId id) => Data (Match id body) isEmptyMatchGroup :: MatchGroup id body -> Bool isEmptyMatchGroup (MG { mg_alts = ms }) = null ms @@ -942,14 +953,16 @@ data GRHSs id body = GRHSs { grhssGRHSs :: [LGRHS id body], -- ^ Guarded RHSs grhssLocalBinds :: (HsLocalBinds id) -- ^ The where clause - } deriving (Data, Typeable) + } deriving (Typeable) +deriving instance (Data body,DataId id) => Data (GRHSs id body) type LGRHS id body = Located (GRHS id body) -- | Guarded Right Hand Side. data GRHS id body = GRHS [GuardLStmt id] -- Guards body -- Right hand side - deriving (Data, Typeable) + deriving (Typeable) +deriving instance (Data body,DataId id) => Data (GRHS id body) \end{code} We know the list must have at least one @Match@ in it. @@ -1066,11 +1079,11 @@ data StmtLR idL idR body -- body should always be (LHs**** idR) -- The fail operator is noSyntaxExpr -- if the pattern match can't fail - | BodyStmt body -- See Note [BodyStmt] - (SyntaxExpr idR) -- The (>>) operator - (SyntaxExpr idR) -- The `guard` operator; used only in MonadComp - -- See notes [Monad Comprehensions] - PostTcType -- Element type of the RHS (used for arrows) + | BodyStmt body -- See Note [BodyStmt] + (SyntaxExpr idR) -- The (>>) operator + (SyntaxExpr idR) -- The `guard` operator; used only in MonadComp + -- See notes [Monad Comprehensions] + (PostTc idR Type) -- Element type of the RHS (used for arrows) | LetStmt (HsLocalBindsLR idL idR) @@ -1131,11 +1144,14 @@ data StmtLR idL idR body -- body should always be (LHs**** idR) -- the returned thing has to be *monomorphic*, -- so they may be type applications - , recS_ret_ty :: PostTcType -- The type of of do { stmts; return (a,b,c) } - -- With rebindable syntax the type might not - -- be quite as simple as (m (tya, tyb, tyc)). + , recS_ret_ty :: PostTc idR Type -- The type of + -- do { stmts; return (a,b,c) } + -- With rebindable syntax the type might not + -- be quite as simple as (m (tya, tyb, tyc)). } - deriving (Data, Typeable) + deriving (Typeable) +deriving instance (Data body, DataId idL, DataId idR) + => Data (StmtLR idL idR body) data TransForm -- The 'f' below is the 'using' function, 'e' is the by function = ThenForm -- then f or then f by e (depending on trS_by) @@ -1147,7 +1163,8 @@ data ParStmtBlock idL idR [ExprLStmt idL] [idR] -- The variables to be returned (SyntaxExpr idR) -- The return operator - deriving( Data, Typeable ) + deriving( Typeable ) +deriving instance (DataId idL, DataId idR) => Data (ParStmtBlock idL idR) \end{code} Note [The type of bind in Stmts] @@ -1373,7 +1390,8 @@ pprQuals quals = interpp'SP quals data HsSplice id = HsSplice -- $z or $(f 4) id -- The id is just a unique name to (LHsExpr id) -- identify this splice point - deriving (Data, Typeable) + deriving (Typeable) +deriving instance (DataId id) => Data (HsSplice id) instance OutputableBndr id => Outputable (HsSplice id) where ppr (HsSplice n e) = angleBrackets (ppr n <> comma <+> ppr e) @@ -1406,7 +1424,8 @@ data HsBracket id = ExpBr (LHsExpr id) -- [| expr |] | VarBr Bool id -- True: 'x, False: ''T -- (The Bool flag is used only in pprHsBracket) | TExpBr (LHsExpr id) -- [|| expr ||] - deriving (Data, Typeable) + deriving (Typeable) +deriving instance (DataId id) => Data (HsBracket id) isTypedBracket :: HsBracket id -> Bool isTypedBracket (TExpBr {}) = True @@ -1457,7 +1476,8 @@ data ArithSeqInfo id | FromThenTo (LHsExpr id) (LHsExpr id) (LHsExpr id) - deriving (Data, Typeable) + deriving (Typeable) +deriving instance (DataId id) => Data (ArithSeqInfo id) \end{code} \begin{code} diff --git a/compiler/hsSyn/HsExpr.lhs-boot b/compiler/hsSyn/HsExpr.lhs-boot index 027fd7e0a0..387a83ebb7 100644 --- a/compiler/hsSyn/HsExpr.lhs-boot +++ b/compiler/hsSyn/HsExpr.lhs-boot @@ -1,13 +1,28 @@ \begin{code} {-# LANGUAGE CPP, KindSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] + -- in module PlaceHolder +{-# LANGUAGE ConstraintKinds #-} +#if __GLASGOW_HASKELL__ > 706 +{-# LANGUAGE RoleAnnotations #-} +#endif + module HsExpr where import SrcLoc ( Located ) import Outputable ( SDoc, OutputableBndr, Outputable ) import {-# SOURCE #-} HsPat ( LPat ) +import PlaceHolder ( DataId ) +import Data.Data hiding ( Fixity ) -import Data.Data - +#if __GLASGOW_HASKELL__ > 706 +type role HsExpr nominal +type role HsCmd nominal +type role MatchGroup nominal representational +type role GRHSs nominal representational +type role HsSplice nominal +#endif data HsExpr (i :: *) data HsCmd (i :: *) data HsSplice (i :: *) @@ -27,11 +42,11 @@ instance Typeable2 MatchGroup instance Typeable2 GRHSs #endif -instance Data i => Data (HsSplice i) -instance Data i => Data (HsExpr i) -instance Data i => Data (HsCmd i) -instance (Data i, Data body) => Data (MatchGroup i body) -instance (Data i, Data body) => Data (GRHSs i body) +instance (DataId id) => Data (HsSplice id) +instance (DataId id) => Data (HsExpr id) +instance (DataId id) => Data (HsCmd id) +instance (Data body,DataId id) => Data (MatchGroup id body) +instance (Data body,DataId id) => Data (GRHSs id body) instance OutputableBndr id => Outputable (HsExpr id) instance OutputableBndr id => Outputable (HsCmd id) diff --git a/compiler/hsSyn/HsLit.lhs b/compiler/hsSyn/HsLit.lhs index a766e40a9d..db6e126594 100644 --- a/compiler/hsSyn/HsLit.lhs +++ b/compiler/hsSyn/HsLit.lhs @@ -6,40 +6,32 @@ \begin{code} {-# LANGUAGE CPP, DeriveDataTypeable #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] + -- in module PlaceHolder +{-# LANGUAGE ConstraintKinds #-} + module HsLit where #include "HsVersions.h" import {-# SOURCE #-} HsExpr( SyntaxExpr, pprExpr ) import BasicTypes ( FractionalLit(..) ) -import Type ( Type, Kind ) +import Type ( Type ) import Outputable import FastString +import PlaceHolder ( PostTc,PostRn,DataId ) import Data.ByteString (ByteString) -import Data.Data +import Data.Data hiding ( Fixity ) \end{code} -%************************************************************************ -%* * -\subsection{Annotating the syntax} -%* * -%************************************************************************ -\begin{code} -type PostTcKind = Kind -type PostTcType = Type -- Used for slots in the abstract syntax - -- where we want to keep slot for a type - -- to be added by the type checker...but - -- before typechecking it's just bogus - -placeHolderType :: PostTcType -- Used before typechecking -placeHolderType = panic "Evaluated the place holder for a PostTcType" -placeHolderKind :: PostTcKind -- Used before typechecking -placeHolderKind = panic "Evaluated the place holder for a PostTcKind" -\end{code} %************************************************************************ %* * @@ -50,22 +42,24 @@ placeHolderKind = panic "Evaluated the place holder for a PostTcKind" \begin{code} data HsLit - = HsChar Char -- Character - | HsCharPrim Char -- Unboxed character - | HsString FastString -- String - | HsStringPrim ByteString -- Packed bytes - | HsInt Integer -- Genuinely an Int; arises from TcGenDeriv, - -- and from TRANSLATION - | HsIntPrim Integer -- literal Int# - | HsWordPrim Integer -- literal Word# - | HsInt64Prim Integer -- literal Int64# - | HsWord64Prim Integer -- literal Word64# - | HsInteger Integer Type -- Genuinely an integer; arises only from TRANSLATION - -- (overloaded literals are done with HsOverLit) - | HsRat FractionalLit Type -- Genuinely a rational; arises only from TRANSLATION - -- (overloaded literals are done with HsOverLit) - | HsFloatPrim FractionalLit -- Unboxed Float - | HsDoublePrim FractionalLit -- Unboxed Double + = HsChar Char -- Character + | HsCharPrim Char -- Unboxed character + | HsString FastString -- String + | HsStringPrim ByteString -- Packed bytes + | HsInt Integer -- Genuinely an Int; arises from + -- TcGenDeriv, and from TRANSLATION + | HsIntPrim Integer -- literal Int# + | HsWordPrim Integer -- literal Word# + | HsInt64Prim Integer -- literal Int64# + | HsWord64Prim Integer -- literal Word64# + | HsInteger Integer Type -- Genuinely an integer; arises only from + -- TRANSLATION (overloaded literals are + -- done with HsOverLit) + | HsRat FractionalLit Type -- Genuinely a rational; arises only from + -- TRANSLATION (overloaded literals are + -- done with HsOverLit) + | HsFloatPrim FractionalLit -- Unboxed Float + | HsDoublePrim FractionalLit -- Unboxed Double deriving (Data, Typeable) instance Eq HsLit where @@ -87,10 +81,11 @@ instance Eq HsLit where data HsOverLit id -- An overloaded literal = OverLit { ol_val :: OverLitVal, - ol_rebindable :: Bool, -- Note [ol_rebindable] - ol_witness :: SyntaxExpr id, -- Note [Overloaded literal witnesses] - ol_type :: PostTcType } - deriving (Data, Typeable) + ol_rebindable :: PostRn id Bool, -- Note [ol_rebindable] + ol_witness :: SyntaxExpr id, -- Note [Overloaded literal witnesses] + ol_type :: PostTc id Type } + deriving (Typeable) +deriving instance (DataId id) => Data (HsOverLit id) data OverLitVal = HsIntegral !Integer -- Integer-looking literals; @@ -98,7 +93,7 @@ data OverLitVal | HsIsString !FastString -- String-looking literals deriving (Data, Typeable) -overLitType :: HsOverLit a -> Type +overLitType :: HsOverLit a -> PostTc a Type overLitType = ol_type \end{code} diff --git a/compiler/hsSyn/HsPat.lhs b/compiler/hsSyn/HsPat.lhs index 4b8fcdaae7..bbd37bc426 100644 --- a/compiler/hsSyn/HsPat.lhs +++ b/compiler/hsSyn/HsPat.lhs @@ -6,6 +6,12 @@ \begin{code} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] + -- in module PlaceHolder +{-# LANGUAGE ConstraintKinds #-} module HsPat ( Pat(..), InPat, OutPat, LPat, @@ -28,6 +34,7 @@ import {-# SOURCE #-} HsExpr (SyntaxExpr, LHsExpr, HsSplice, pprLExpr -- friends: import HsBinds import HsLit +import PlaceHolder ( PostTc,DataId ) import HsTypes import TcEvidence import BasicTypes @@ -43,7 +50,7 @@ import Type import SrcLoc import FastString -- libraries: -import Data.Data hiding (TyCon) +import Data.Data hiding (TyCon,Fixity) import Data.Maybe \end{code} @@ -56,7 +63,7 @@ type LPat id = Located (Pat id) data Pat id = ------------ Simple patterns --------------- - WildPat PostTcType -- Wild card + WildPat (PostTc id Type) -- Wild card -- The sole reason for a type on a WildPat is to -- support hsPatType :: Pat Id -> Type @@ -69,17 +76,17 @@ data Pat id ------------ Lists, tuples, arrays --------------- | ListPat [LPat id] -- Syntactic list - PostTcType -- The type of the elements - (Maybe (PostTcType, SyntaxExpr id)) -- For rebindable syntax + (PostTc id Type) -- The type of the elements + (Maybe (PostTc id Type, SyntaxExpr id)) -- For rebindable syntax -- For OverloadedLists a Just (ty,fn) gives -- overall type of the pattern, and the toList -- function to convert the scrutinee to a list value - | TuplePat [LPat id] -- Tuple sub-patterns - Boxity -- UnitPat is TuplePat [] - [PostTcType] -- [] before typechecker, filled in afterwards with - -- the types of the tuple components - -- You might think that the PostTcType was redundant, because we can + | TuplePat [LPat id] -- Tuple sub-patterns + Boxity -- UnitPat is TuplePat [] + [PostTc id Type] -- [] before typechecker, filled in afterwards + -- with the types of the tuple components + -- You might think that the PostTc id Type was redundant, because we can -- get the pattern type by getting the types of the sub-patterns. -- But it's essential -- data T a where @@ -96,7 +103,7 @@ data Pat id -- will be wrapped in CoPats, no?) | PArrPat [LPat id] -- Syntactic parallel array - PostTcType -- The type of the elements + (PostTc id Type) -- The type of the elements ------------ Constructor patterns --------------- | ConPatIn (Located id) @@ -121,7 +128,7 @@ data Pat id ------------ View patterns --------------- | ViewPat (LHsExpr id) (LPat id) - PostTcType -- The overall type of the pattern + (PostTc id Type) -- The overall type of the pattern -- (= the argument type of the view function) -- for hsPatType. @@ -149,8 +156,9 @@ data Pat id (SyntaxExpr id) -- Name of '-' (see RnEnv.lookupSyntaxName) ------------ Pattern type signatures --------------- - | SigPatIn (LPat id) -- Pattern with a type signature - (HsWithBndrs (LHsType id)) -- Signature can bind both kind and type vars + | SigPatIn (LPat id) -- Pattern with a type signature + (HsWithBndrs id (LHsType id)) -- Signature can bind both + -- kind and type vars | SigPatOut (LPat id) -- Pattern with a type signature Type @@ -162,7 +170,8 @@ data Pat id Type -- Type of whole pattern, t1 -- During desugaring a (CoPat co pat) turns into a cast with 'co' on -- the scrutinee, followed by a match on 'pat' - deriving (Data, Typeable) + deriving (Typeable) +deriving instance (DataId id) => Data (Pat id) \end{code} HsConDetails is use for patterns/expressions *and* for data type declarations diff --git a/compiler/hsSyn/HsPat.lhs-boot b/compiler/hsSyn/HsPat.lhs-boot index 0e7a0e0762..cb8cb0a5bc 100644 --- a/compiler/hsSyn/HsPat.lhs-boot +++ b/compiler/hsSyn/HsPat.lhs-boot @@ -1,12 +1,23 @@ \begin{code} {-# LANGUAGE CPP, KindSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] + -- in module PlaceHolder +{-# LANGUAGE ConstraintKinds #-} +#if __GLASGOW_HASKELL__ > 706 +{-# LANGUAGE RoleAnnotations #-} +#endif module HsPat where import SrcLoc( Located ) -import Data.Data +import Data.Data hiding (Fixity) import Outputable +import PlaceHolder ( DataId ) +#if __GLASGOW_HASKELL__ > 706 +type role Pat nominal +#endif data Pat (i :: *) type LPat i = Located (Pat i) @@ -16,6 +27,6 @@ instance Typeable Pat instance Typeable1 Pat #endif -instance Data i => Data (Pat i) +instance (DataId id) => Data (Pat id) instance (OutputableBndr name) => Outputable (Pat name) \end{code} diff --git a/compiler/hsSyn/HsSyn.lhs b/compiler/hsSyn/HsSyn.lhs index 72cbac1487..7aecfea40b 100644 --- a/compiler/hsSyn/HsSyn.lhs +++ b/compiler/hsSyn/HsSyn.lhs @@ -10,6 +10,11 @@ therefore, is almost nothing but re-exporting. \begin{code} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] + -- in module PlaceHolder +{-# LANGUAGE ConstraintKinds #-} module HsSyn ( module HsBinds, @@ -21,6 +26,7 @@ module HsSyn ( module HsTypes, module HsUtils, module HsDoc, + module PlaceHolder, Fixity, HsModule(..) @@ -32,6 +38,7 @@ import HsBinds import HsExpr import HsImpExp import HsLit +import PlaceHolder import HsPat import HsTypes import BasicTypes ( Fixity, WarningTxt ) @@ -75,7 +82,8 @@ data HsModule name -- ^ reason\/explanation for warning/deprecation of this module hsmodHaddockModHeader :: Maybe LHsDocString -- ^ Haddock module info and description, unparsed - } deriving (Data, Typeable) + } deriving (Typeable) +deriving instance (DataId name) => Data (HsModule name) \end{code} diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs index 0cf8455bad..fdd613a6d0 100644 --- a/compiler/hsSyn/HsTypes.lhs +++ b/compiler/hsSyn/HsTypes.lhs @@ -7,6 +7,13 @@ HsTypes: Abstract syntax: user-defined types \begin{code} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] + -- in module PlaceHolder +{-# LANGUAGE ConstraintKinds #-} module HsTypes ( HsType(..), LHsType, HsKind, LHsKind, @@ -40,7 +47,7 @@ module HsTypes ( import {-# SOURCE #-} HsExpr ( HsSplice, pprUntypedSplice ) -import HsLit +import PlaceHolder ( PostTc,PostRn,DataId,PlaceHolder(..) ) import Name( Name ) import RdrName( RdrName ) @@ -54,7 +61,7 @@ import StaticFlags import Outputable import FastString -import Data.Data +import Data.Data hiding ( Fixity ) \end{code} @@ -131,17 +138,18 @@ type LHsKind name = Located (HsKind name) type LHsTyVarBndr name = Located (HsTyVarBndr name) -data LHsTyVarBndrs name +data LHsTyVarBndrs name = HsQTvs { hsq_kvs :: [Name] -- Kind variables , hsq_tvs :: [LHsTyVarBndr name] -- Type variables -- See Note [HsForAllTy tyvar binders] } - deriving( Data, Typeable ) + deriving( Typeable ) +deriving instance (DataId name) => Data (LHsTyVarBndrs name) mkHsQTvs :: [LHsTyVarBndr RdrName] -> LHsTyVarBndrs RdrName -- Just at RdrName because in the Name variant we should know just -- what the kind-variable binders are; and we don't --- We put an empty list (rather than a panic) for the kind vars so +-- We put an empty list (rather than a panic) for the kind vars so -- that the pretty printer works ok on them. mkHsQTvs tvs = HsQTvs { hsq_kvs = [], hsq_tvs = tvs } @@ -151,16 +159,18 @@ emptyHsQTvs = HsQTvs { hsq_kvs = [], hsq_tvs = [] } hsQTvBndrs :: LHsTyVarBndrs name -> [LHsTyVarBndr name] hsQTvBndrs = hsq_tvs -data HsWithBndrs thing - = HsWB { hswb_cts :: thing -- Main payload (type or list of types) - , hswb_kvs :: [Name] -- Kind vars - , hswb_tvs :: [Name] -- Type vars - } - deriving (Data, Typeable) +data HsWithBndrs name thing + = HsWB { hswb_cts :: thing -- Main payload (type or list of types) + , hswb_kvs :: PostRn name [Name] -- Kind vars + , hswb_tvs :: PostRn name [Name] -- Type vars + } + deriving (Typeable) +deriving instance (Data name, Data thing, Data (PostRn name [Name])) + => Data (HsWithBndrs name thing) -mkHsWithBndrs :: thing -> HsWithBndrs thing -mkHsWithBndrs x = HsWB { hswb_cts = x, hswb_kvs = panic "mkHsTyWithBndrs:kvs" - , hswb_tvs = panic "mkHsTyWithBndrs:tvs" } +mkHsWithBndrs :: thing -> HsWithBndrs RdrName thing +mkHsWithBndrs x = HsWB { hswb_cts = x, hswb_kvs = PlaceHolder + , hswb_tvs = PlaceHolder } -- | These names are used early on to store the names of implicit @@ -186,7 +196,8 @@ data HsTyVarBndr name | KindedTyVar name (LHsKind name) -- The user-supplied kind signature - deriving (Data, Typeable) + deriving (Typeable) +deriving instance (DataId name) => Data (HsTyVarBndr name) -- | Does this 'HsTyVarBndr' come with an explicit kind annotation? isHsKindedTyVar :: HsTyVarBndr name -> Bool @@ -239,7 +250,7 @@ data HsType name | HsQuasiQuoteTy (HsQuasiQuote name) | HsSpliceTy (HsSplice name) - PostTcKind + (PostTc name Kind) | HsDocTy (LHsType name) LHsDocString -- A documented type @@ -249,18 +260,19 @@ data HsType name | HsCoreTy Type -- An escape hatch for tunnelling a *closed* -- Core Type through HsSyn. - | HsExplicitListTy -- A promoted explicit list - PostTcKind -- See Note [Promoted lists and tuples] + | HsExplicitListTy -- A promoted explicit list + (PostTc name Kind) -- See Note [Promoted lists and tuples] [LHsType name] - | HsExplicitTupleTy -- A promoted explicit tuple - [PostTcKind] -- See Note [Promoted lists and tuples] + | HsExplicitTupleTy -- A promoted explicit tuple + [PostTc name Kind] -- See Note [Promoted lists and tuples] [LHsType name] | HsTyLit HsTyLit -- A promoted numeric literal. | HsWrapTy HsTyWrapper (HsType name) -- only in typechecker output - deriving (Data, Typeable) + deriving (Typeable) +deriving instance (DataId name) => Data (HsType name) data HsTyLit @@ -380,7 +392,8 @@ data ConDeclField name -- Record fields have Haddoc docs on them = ConDeclField { cd_fld_name :: Located name, cd_fld_type :: LBangType name, cd_fld_doc :: Maybe LHsDocString } - deriving (Data, Typeable) + deriving (Typeable) +deriving instance (DataId name) => Data (ConDeclField name) ----------------------- -- Combine adjacent for-alls. @@ -565,7 +578,7 @@ instance (OutputableBndr name) => Outputable (HsTyVarBndr name) where ppr (UserTyVar n) = ppr n ppr (KindedTyVar n k) = parens $ hsep [ppr n, dcolon, ppr k] -instance (Outputable thing) => Outputable (HsWithBndrs thing) where +instance (Outputable thing) => Outputable (HsWithBndrs name thing) where ppr (HsWB { hswb_cts = ty }) = ppr ty pprHsForAll :: OutputableBndr name => HsExplicitFlag -> LHsTyVarBndrs name -> LHsContext name -> SDoc diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index 5d4d22fae2..4b5bdb4d66 100644 --- a/compiler/hsSyn/HsUtils.lhs +++ b/compiler/hsSyn/HsUtils.lhs @@ -1,4 +1,3 @@ -> {-# LANGUAGE ScopedTypeVariables #-} % % (c) The University of Glasgow, 1992-2006 @@ -8,11 +7,11 @@ Here we collect a variety of helper functions that construct or analyse HsSyn. All these functions deal with generic HsSyn; functions which deal with the instantiated versions are located elsewhere: - Parameterised by Module + Parameterised by Module ---------------- ------------- - RdrName parser/RdrHsSyn - Name rename/RnHsSyn - Id typecheck/TcHsSyn + RdrName parser/RdrHsSyn + Name rename/RnHsSyn + Id typecheck/TcHsSyn \begin{code} {-# LANGUAGE CPP #-} @@ -22,18 +21,20 @@ which deal with the instantiated versions are located elsewhere: -- detab the module (please do the detabbing in a separate patch). See -- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces -- for details +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} module HsUtils( -- Terms mkHsPar, mkHsApp, mkHsConApp, mkSimpleHsAlt, - mkSimpleMatch, unguardedGRHSs, unguardedRHS, - mkMatchGroup, mkMatch, mkHsLam, mkHsIf, + mkSimpleMatch, unguardedGRHSs, unguardedRHS, + mkMatchGroup, mkMatchGroupName, mkMatch, mkHsLam, mkHsIf, mkHsWrap, mkLHsWrap, mkHsWrapCo, mkLHsWrapCo, coToHsWrapper, mkHsDictLet, mkHsLams, mkHsOpApp, mkHsDo, mkHsComp, mkHsWrapPat, mkHsWrapPatCo, mkLHsPar, mkHsCmdCast, - nlHsTyApp, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsIntLit, nlHsVarApps, + nlHsTyApp, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsIntLit, nlHsVarApps, nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList, mkLHsTupleExpr, mkLHsVarTuple, missingTupArg, toHsType, toHsKind, @@ -42,27 +43,28 @@ module HsUtils( mkFunBind, mkVarBind, mkHsVarBind, mk_easy_FunBind, mkTopFunBind, mkPatSynBind, -- Literals - mkHsIntegral, mkHsFractional, mkHsIsString, mkHsString, + mkHsIntegral, mkHsFractional, mkHsIsString, mkHsString, -- Patterns - mkNPat, mkNPlusKPat, nlVarPat, nlLitPat, nlConVarPat, nlConPat, nlInfixConPat, - nlNullaryConPat, nlWildConPat, nlWildPat, nlTuplePat, mkParPat, + mkNPat, mkNPlusKPat, nlVarPat, nlLitPat, nlConVarPat, nlConPat, + nlConPatName, nlInfixConPat, nlNullaryConPat, nlWildConPat, nlWildPat, + nlWildPatName, nlWildPatId, nlTuplePat, mkParPat, -- Types mkHsAppTy, userHsTyVarBndrs, - nlHsAppTy, nlHsTyVar, nlHsFunTy, nlHsTyConApp, + nlHsAppTy, nlHsTyVar, nlHsFunTy, nlHsTyConApp, -- Stmts mkTransformStmt, mkTransformByStmt, mkBodyStmt, mkBindStmt, mkLastStmt, - emptyTransStmt, mkGroupUsingStmt, mkGroupByUsingStmt, - emptyRecStmt, mkRecStmt, + emptyTransStmt, mkGroupUsingStmt, mkGroupByUsingStmt, + emptyRecStmt, emptyRecStmtName, emptyRecStmtId, mkRecStmt, -- Template Haskell mkHsSpliceTy, mkHsSpliceE, mkHsSpliceTE, mkHsSplice, mkHsQuasiQuote, unqualQuasiQuote, -- Flags - noRebindableInfo, + noRebindableInfo, -- Collecting binders collectLocalBinders, collectHsValBinders, collectHsBindListBinders, @@ -71,9 +73,9 @@ module HsUtils( collectLStmtsBinders, collectStmtsBinders, collectLStmtBinders, collectStmtBinders, - hsLTyClDeclBinders, hsTyClDeclsBinders, + hsLTyClDeclBinders, hsTyClDeclsBinders, hsForeignDeclsBinders, hsGroupBinders, hsDataFamInstBinders, - + -- Collecting implicit binders lStmtsImplicits, hsValBindsImplicits, lPatImplicits ) where @@ -84,8 +86,9 @@ import HsDecls import HsBinds import HsExpr import HsPat -import HsTypes +import HsTypes import HsLit +import PlaceHolder import TcEvidence import RdrName @@ -110,9 +113,9 @@ import Data.List %************************************************************************ -%* * - Some useful helpers for constructing syntax -%* * +%* * + Some useful helpers for constructing syntax +%* * %************************************************************************ These functions attempt to construct a not-completely-useless SrcSpan @@ -124,13 +127,13 @@ mkHsPar :: LHsExpr id -> LHsExpr id mkHsPar e = L (getLoc e) (HsPar e) mkSimpleMatch :: [LPat id] -> Located (body id) -> LMatch id (Located (body id)) -mkSimpleMatch pats rhs +mkSimpleMatch pats rhs = L loc $ Match pats Nothing (unguardedGRHSs rhs) where loc = case pats of - [] -> getLoc rhs - (pat:_) -> combineSrcSpans (getLoc pat) (getLoc rhs) + [] -> getLoc rhs + (pat:_) -> combineSrcSpans (getLoc pat) (getLoc rhs) unguardedGRHSs :: Located (body id) -> GRHSs id (Located (body id)) unguardedGRHSs rhs = GRHSs (unguardedRHS rhs) emptyLocalBinds @@ -138,8 +141,17 @@ unguardedGRHSs rhs = GRHSs (unguardedRHS rhs) emptyLocalBinds unguardedRHS :: Located (body id) -> [LGRHS id (Located (body id))] unguardedRHS rhs@(L loc _) = [L loc (GRHS [] rhs)] -mkMatchGroup :: Origin -> [LMatch id (Located (body id))] -> MatchGroup id (Located (body id)) -mkMatchGroup origin matches = MG { mg_alts = matches, mg_arg_tys = [], mg_res_ty = placeHolderType, mg_origin = origin } +mkMatchGroup :: Origin -> [LMatch RdrName (Located (body RdrName))] + -> MatchGroup RdrName (Located (body RdrName)) +mkMatchGroup origin matches = MG { mg_alts = matches, mg_arg_tys = [] + , mg_res_ty = placeHolderType + , mg_origin = origin } + +mkMatchGroupName :: Origin -> [LMatch Name (Located (body Name))] + -> MatchGroup Name (Located (body Name)) +mkMatchGroupName origin matches = MG { mg_alts = matches, mg_arg_tys = [] + , mg_res_ty = placeHolderType + , mg_origin = origin } mkHsAppTy :: LHsType name -> LHsType name -> LHsType name mkHsAppTy t1 t2 = addCLoc t1 t2 (HsAppTy t1 t2) @@ -147,24 +159,25 @@ mkHsAppTy t1 t2 = addCLoc t1 t2 (HsAppTy t1 t2) mkHsApp :: LHsExpr name -> LHsExpr name -> LHsExpr name mkHsApp e1 e2 = addCLoc e1 e2 (HsApp e1 e2) -mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id +mkHsLam :: [LPat RdrName] -> LHsExpr RdrName -> LHsExpr RdrName mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches)) - where + where matches = mkMatchGroup Generated [mkSimpleMatch pats body] mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr Id -> LHsExpr Id -mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars <.> mkWpLams dicts) expr +mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars + <.> mkWpLams dicts) expr mkHsConApp :: DataCon -> [Type] -> [HsExpr Id] -> LHsExpr Id --- Used for constructing dictionary terms etc, so no locations -mkHsConApp data_con tys args +-- Used for constructing dictionary terms etc, so no locations +mkHsConApp data_con tys args = foldl mk_app (nlHsTyApp (dataConWrapId data_con) tys) args where mk_app f a = noLoc (HsApp f (noLoc a)) mkSimpleHsAlt :: LPat id -> (Located (body id)) -> LMatch id (Located (body id)) -- A simple lambda with a single pattern, no binds, no guards; pre-typechecking -mkSimpleHsAlt pat expr +mkSimpleHsAlt pat expr = mkSimpleMatch [pat] expr nlHsTyApp :: name -> [Type] -> LHsExpr name @@ -186,29 +199,33 @@ mkParPat lp@(L loc p) | hsPatNeedsParens p = L loc (ParPat lp) -- These are the bits of syntax that contain rebindable names -- See RnEnv.lookupSyntaxName -mkHsIntegral :: Integer -> PostTcType -> HsOverLit id -mkHsFractional :: FractionalLit -> PostTcType -> HsOverLit id -mkHsIsString :: FastString -> PostTcType -> HsOverLit id -mkHsDo :: HsStmtContext Name -> [ExprLStmt id] -> HsExpr id -mkHsComp :: HsStmtContext Name -> [ExprLStmt id] -> LHsExpr id -> HsExpr id +mkHsIntegral :: Integer -> PostTc RdrName Type -> HsOverLit RdrName +mkHsFractional :: FractionalLit -> PostTc RdrName Type -> HsOverLit RdrName +mkHsIsString :: FastString -> PostTc RdrName Type -> HsOverLit RdrName +mkHsDo :: HsStmtContext Name -> [ExprLStmt RdrName] -> HsExpr RdrName +mkHsComp :: HsStmtContext Name -> [ExprLStmt RdrName] -> LHsExpr RdrName + -> HsExpr RdrName mkNPat :: HsOverLit id -> Maybe (SyntaxExpr id) -> Pat id mkNPlusKPat :: Located id -> HsOverLit id -> Pat id mkLastStmt :: Located (bodyR idR) -> StmtLR idL idR (Located (bodyR idR)) -mkBodyStmt :: Located (bodyR idR) -> StmtLR idL idR (Located (bodyR idR)) +mkBodyStmt :: Located (bodyR RdrName) + -> StmtLR idL RdrName (Located (bodyR RdrName)) mkBindStmt :: LPat idL -> Located (bodyR idR) -> StmtLR idL idR (Located (bodyR idR)) -emptyRecStmt :: StmtLR idL idR bodyR -mkRecStmt :: [LStmtLR idL idR bodyR] -> StmtLR idL idR bodyR +emptyRecStmt :: StmtLR idL RdrName bodyR +emptyRecStmtName :: StmtLR Name Name bodyR +emptyRecStmtId :: StmtLR Id Id bodyR +mkRecStmt :: [LStmtLR idL RdrName bodyR] -> StmtLR idL RdrName bodyR mkHsIntegral i = OverLit (HsIntegral i) noRebindableInfo noSyntaxExpr mkHsFractional f = OverLit (HsFractional f) noRebindableInfo noSyntaxExpr mkHsIsString s = OverLit (HsIsString s) noRebindableInfo noSyntaxExpr -noRebindableInfo :: Bool -noRebindableInfo = error "noRebindableInfo" -- Just another placeholder; +noRebindableInfo :: PlaceHolder +noRebindableInfo = PlaceHolder -- Just another placeholder; mkHsDo ctxt stmts = HsDo ctxt stmts placeHolderType mkHsComp ctxt stmts expr = mkHsDo ctxt (stmts ++ [last_stmt]) @@ -232,7 +249,7 @@ mkGroupByUsingStmt :: [ExprLStmt idL] -> LHsExpr idR -> LHsExpr idR emptyTransStmt :: StmtLR idL idR (LHsExpr idR) emptyTransStmt = TransStmt { trS_form = panic "emptyTransStmt: form" - , trS_stmts = [], trS_bndrs = [] + , trS_stmts = [], trS_bndrs = [] , trS_by = Nothing, trS_using = noLoc noSyntaxExpr , trS_ret = noSyntaxExpr, trS_bind = noSyntaxExpr , trS_fmap = noSyntaxExpr } @@ -245,12 +262,22 @@ mkLastStmt body = LastStmt body noSyntaxExpr mkBodyStmt body = BodyStmt body noSyntaxExpr noSyntaxExpr placeHolderType mkBindStmt pat body = BindStmt pat body noSyntaxExpr noSyntaxExpr -emptyRecStmt = RecStmt { recS_stmts = [], recS_later_ids = [], recS_rec_ids = [] - , recS_ret_fn = noSyntaxExpr, recS_mfix_fn = noSyntaxExpr - , recS_bind_fn = noSyntaxExpr, recS_later_rets = [] - , recS_rec_rets = [], recS_ret_ty = placeHolderType } -mkRecStmt stmts = emptyRecStmt { recS_stmts = stmts } +emptyRecStmt' :: forall idL idR body. + PostTc idR Type -> StmtLR idL idR body +emptyRecStmt' tyVal = + RecStmt + { recS_stmts = [], recS_later_ids = [] + , recS_rec_ids = [] + , recS_ret_fn = noSyntaxExpr + , recS_mfix_fn = noSyntaxExpr + , recS_bind_fn = noSyntaxExpr, recS_later_rets = [] + , recS_rec_rets = [], recS_ret_ty = tyVal } + +emptyRecStmt = emptyRecStmt' placeHolderType +emptyRecStmtName = emptyRecStmt' placeHolderType +emptyRecStmtId = emptyRecStmt' placeHolderTypeTc +mkRecStmt stmts = emptyRecStmt { recS_stmts = stmts } ------------------------------- --- A useful function for building @OpApps@. The operator is always a @@ -272,16 +299,16 @@ mkHsSpliceTy e = HsSpliceTy (mkHsSplice e) placeHolderKind unqualSplice :: RdrName unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice")) - -- A name (uniquified later) to - -- identify the splice + -- A name (uniquified later) to + -- identify the splice mkHsQuasiQuote :: RdrName -> SrcSpan -> FastString -> HsQuasiQuote RdrName mkHsQuasiQuote quoter span quote = HsQuasiQuote quoter span quote unqualQuasiQuote :: RdrName unqualQuasiQuote = mkRdrUnqual (mkVarOccFS (fsLit "quasiquote")) - -- A name (uniquified later) to - -- identify the quasi-quote + -- A name (uniquified later) to + -- identify the quasi-quote mkHsString :: String -> HsLit mkHsString s = HsString (mkFastString s) @@ -294,9 +321,9 @@ userHsTyVarBndrs loc bndrs = [ L loc (UserTyVar v) | v <- bndrs ] %************************************************************************ -%* * - Constructing syntax with no location info -%* * +%* * + Constructing syntax with no location info +%* * %************************************************************************ \begin{code} @@ -320,44 +347,56 @@ nlHsIntLit n = noLoc (HsLit (HsInt n)) nlHsApps :: id -> [LHsExpr id] -> LHsExpr id nlHsApps f xs = foldl nlHsApp (nlHsVar f) xs - + nlHsVarApps :: id -> [id] -> LHsExpr id nlHsVarApps f xs = noLoc (foldl mk (HsVar f) (map HsVar xs)) - where - mk f a = HsApp (noLoc f) (noLoc a) + where + mk f a = HsApp (noLoc f) (noLoc a) -nlConVarPat :: id -> [id] -> LPat id +nlConVarPat :: RdrName -> [RdrName] -> LPat RdrName nlConVarPat con vars = nlConPat con (map nlVarPat vars) nlInfixConPat :: id -> LPat id -> LPat id -> LPat id nlInfixConPat con l r = noLoc (ConPatIn (noLoc con) (InfixCon l r)) -nlConPat :: id -> [LPat id] -> LPat id +nlConPat :: RdrName -> [LPat RdrName] -> LPat RdrName nlConPat con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats)) +nlConPatName :: Name -> [LPat Name] -> LPat Name +nlConPatName con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats)) + nlNullaryConPat :: id -> LPat id nlNullaryConPat con = noLoc (ConPatIn (noLoc con) (PrefixCon [])) nlWildConPat :: DataCon -> LPat RdrName nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con)) - (PrefixCon (nOfThem (dataConSourceArity con) nlWildPat))) + (PrefixCon (nOfThem (dataConSourceArity con) + nlWildPat))) -nlWildPat :: LPat id -nlWildPat = noLoc (WildPat placeHolderType) -- Pre-typechecking +nlWildPat :: LPat RdrName +nlWildPat = noLoc (WildPat placeHolderType ) -- Pre-typechecking -nlHsDo :: HsStmtContext Name -> [LStmt id (LHsExpr id)] -> LHsExpr id +nlWildPatName :: LPat Name +nlWildPatName = noLoc (WildPat placeHolderType ) -- Pre-typechecking + +nlWildPatId :: LPat Id +nlWildPatId = noLoc (WildPat placeHolderTypeTc ) -- Post-typechecking + +nlHsDo :: HsStmtContext Name -> [LStmt RdrName (LHsExpr RdrName)] + -> LHsExpr RdrName nlHsDo ctxt stmts = noLoc (mkHsDo ctxt stmts) nlHsOpApp :: LHsExpr id -> id -> LHsExpr id -> LHsExpr id nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2) -nlHsLam :: LMatch id (LHsExpr id) -> LHsExpr id +nlHsLam :: LMatch RdrName (LHsExpr RdrName) -> LHsExpr RdrName nlHsPar :: LHsExpr id -> LHsExpr id nlHsIf :: LHsExpr id -> LHsExpr id -> LHsExpr id -> LHsExpr id -nlHsCase :: LHsExpr id -> [LMatch id (LHsExpr id)] -> LHsExpr id -nlList :: [LHsExpr id] -> LHsExpr id +nlHsCase :: LHsExpr RdrName -> [LMatch RdrName (LHsExpr RdrName)] + -> LHsExpr RdrName +nlList :: [LHsExpr RdrName] -> LHsExpr RdrName -nlHsLam match = noLoc (HsLam (mkMatchGroup Generated [match])) +nlHsLam match = noLoc (HsLam (mkMatchGroup Generated [match])) nlHsPar e = noLoc (HsPar e) nlHsIf cond true false = noLoc (mkHsIf cond true false) nlHsCase expr matches = noLoc (HsCase expr (mkMatchGroup Generated matches)) @@ -367,9 +406,9 @@ nlHsAppTy :: LHsType name -> LHsType name -> LHsType name nlHsTyVar :: name -> LHsType name nlHsFunTy :: LHsType name -> LHsType name -> LHsType name -nlHsAppTy f t = noLoc (HsAppTy f t) -nlHsTyVar x = noLoc (HsTyVar x) -nlHsFunTy a b = noLoc (HsFunTy a b) +nlHsAppTy f t = noLoc (HsAppTy f t) +nlHsTyVar x = noLoc (HsTyVar x) +nlHsFunTy a b = noLoc (HsFunTy a b) nlHsTyConApp :: name -> [LHsType name] -> LHsType name nlHsTyConApp tycon tys = foldl nlHsAppTy (nlHsTyVar tycon) tys @@ -390,15 +429,15 @@ mkLHsVarTuple ids = mkLHsTupleExpr (map nlHsVar ids) nlTuplePat :: [LPat id] -> Boxity -> LPat id nlTuplePat pats box = noLoc (TuplePat pats box []) -missingTupArg :: HsTupArg a +missingTupArg :: HsTupArg RdrName missingTupArg = Missing placeHolderType \end{code} %************************************************************************ -%* * +%* * Converting a Type to an HsType RdrName -%* * +%* * %************************************************************************ This is needed to implement GeneralizedNewtypeDeriving. @@ -422,7 +461,7 @@ toHsType ty to_hs_type (TyVarTy tv) = nlHsTyVar (getRdrName tv) to_hs_type (AppTy t1 t2) = nlHsAppTy (toHsType t1) (toHsType t2) to_hs_type (TyConApp tc args) = nlHsTyConApp (getRdrName tc) (map toHsType args') - where + where args' = filterOut isKind args -- Source-language types have _implicit_ kind arguments, -- so we must remove them here (Trac #8563) @@ -446,7 +485,7 @@ mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e) mkHsWrap :: HsWrapper -> HsExpr id -> HsExpr id mkHsWrap co_fn e | isIdHsWrapper co_fn = e - | otherwise = HsWrap co_fn e + | otherwise = HsWrap co_fn e mkHsWrapCo :: TcCoercion -> HsExpr id -> HsExpr id mkHsWrapCo co e = mkHsWrap (coToHsWrapper co) e @@ -464,7 +503,7 @@ coToHsWrapper co | isTcReflCo co = idHsWrapper mkHsWrapPat :: HsWrapper -> Pat id -> Type -> Pat id mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p - | otherwise = CoPat co_fn p ty + | otherwise = CoPat co_fn p ty mkHsWrapPatCo :: TcCoercion -> Pat id -> Type -> Pat id mkHsWrapPatCo co pat ty | isTcReflCo co = pat @@ -475,13 +514,14 @@ mkHsDictLet ev_binds expr = mkLHsWrap (mkWpLet ev_binds) expr \end{code} l %************************************************************************ -%* * - Bindings; with a location at the top -%* * +%* * + Bindings; with a location at the top +%* * %************************************************************************ \begin{code} -mkFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)] -> HsBind RdrName +mkFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)] + -> HsBind RdrName -- Not infix, with place holders for coercion and free vars mkFunBind fn ms = FunBind { fun_id = fn, fun_infix = False , fun_matches = mkMatchGroup Generated ms @@ -489,12 +529,14 @@ mkFunBind fn ms = FunBind { fun_id = fn, fun_infix = False , bind_fvs = placeHolderNames , fun_tick = Nothing } -mkTopFunBind :: Origin -> Located Name -> [LMatch Name (LHsExpr Name)] -> HsBind Name +mkTopFunBind :: Origin -> Located Name -> [LMatch Name (LHsExpr Name)] + -> HsBind Name -- In Name-land, with empty bind_fvs mkTopFunBind origin fn ms = FunBind { fun_id = fn, fun_infix = False - , fun_matches = mkMatchGroup origin ms + , fun_matches = mkMatchGroupName origin ms , fun_co_fn = idHsWrapper - , bind_fvs = emptyNameSet -- NB: closed binding + , bind_fvs = emptyNameSet -- NB: closed + -- binding , fun_tick = Nothing } mkHsVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> LHsBind RdrName @@ -502,9 +544,10 @@ mkHsVarBind loc var rhs = mk_easy_FunBind loc var [] rhs mkVarBind :: id -> LHsExpr id -> LHsBind id mkVarBind var rhs = L (getLoc rhs) $ - VarBind { var_id = var, var_rhs = rhs, var_inline = False } + VarBind { var_id = var, var_rhs = rhs, var_inline = False } -mkPatSynBind :: Located RdrName -> HsPatSynDetails (Located RdrName) -> LPat RdrName -> HsPatSynDir RdrName -> HsBind RdrName +mkPatSynBind :: Located RdrName -> HsPatSynDetails (Located RdrName) + -> LPat RdrName -> HsPatSynDir RdrName -> HsBind RdrName mkPatSynBind name details lpat dir = PatSynBind psb where psb = PSB{ psb_id = name @@ -515,25 +558,25 @@ mkPatSynBind name details lpat dir = PatSynBind psb ------------ mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName] - -> LHsExpr RdrName -> LHsBind RdrName + -> LHsExpr RdrName -> LHsBind RdrName mk_easy_FunBind loc fun pats expr = L loc $ mkFunBind (L loc fun) [mkMatch pats expr emptyLocalBinds] ------------ mkMatch :: [LPat id] -> LHsExpr id -> HsLocalBinds id -> LMatch id (LHsExpr id) mkMatch pats expr binds - = noLoc (Match (map paren pats) Nothing - (GRHSs (unguardedRHS expr) binds)) + = noLoc (Match (map paren pats) Nothing + (GRHSs (unguardedRHS expr) binds)) where - paren lp@(L l p) | hsPatNeedsParens p = L l (ParPat lp) - | otherwise = lp + paren lp@(L l p) | hsPatNeedsParens p = L l (ParPat lp) + | otherwise = lp \end{code} %************************************************************************ -%* * - Collecting binders -%* * +%* * + Collecting binders +%* * %************************************************************************ Get all the binders in some HsBindGroups, IN THE ORDER OF APPEARANCE. eg. @@ -574,11 +617,11 @@ collect_bind (PatBind { pat_lhs = p }) acc = collect_lpat p acc collect_bind (FunBind { fun_id = L _ f }) acc = f : acc collect_bind (VarBind { var_id = f }) acc = f : acc collect_bind (AbsBinds { abs_exports = dbinds, abs_binds = _binds }) acc - = map abe_poly dbinds ++ acc - -- ++ foldr collect_bind acc binds - -- I don't think we want the binders from the nested binds - -- The only time we collect binders from a typechecked - -- binding (hence see AbsBinds) is in zonking in TcHsSyn + = map abe_poly dbinds ++ acc + -- ++ foldr collect_bind acc binds + -- I don't think we want the binders from the nested binds + -- The only time we collect binders from a typechecked + -- binding (hence see AbsBinds) is in zonking in TcHsSyn collect_bind (PatSynBind (PSB { psb_id = L _ ps })) acc = ps : acc collectHsBindsBinders :: LHsBindsLR idL idR -> [idL] @@ -595,7 +638,7 @@ collectMethodBinders :: LHsBindsLR RdrName idR -> [Located RdrName] collectMethodBinders binds = foldrBag (get . unLoc) [] binds where get (FunBind { fun_id = f }) fs = f : fs - get _ fs = fs + get _ fs = fs -- Someone else complains about non-FunBinds ----------------- Statements -------------------------- @@ -632,27 +675,27 @@ collect_lpat :: LPat name -> [name] -> [name] collect_lpat (L _ pat) bndrs = go pat where - go (VarPat var) = var : bndrs - go (WildPat _) = bndrs - go (LazyPat pat) = collect_lpat pat bndrs - go (BangPat pat) = collect_lpat pat bndrs - go (AsPat (L _ a) pat) = a : collect_lpat pat bndrs + go (VarPat var) = var : bndrs + go (WildPat _) = bndrs + go (LazyPat pat) = collect_lpat pat bndrs + go (BangPat pat) = collect_lpat pat bndrs + go (AsPat (L _ a) pat) = a : collect_lpat pat bndrs go (ViewPat _ pat _) = collect_lpat pat bndrs - go (ParPat pat) = collect_lpat pat bndrs - + go (ParPat pat) = collect_lpat pat bndrs + go (ListPat pats _ _) = foldr collect_lpat bndrs pats - go (PArrPat pats _) = foldr collect_lpat bndrs pats - go (TuplePat pats _ _) = foldr collect_lpat bndrs pats - + go (PArrPat pats _) = foldr collect_lpat bndrs pats + go (TuplePat pats _ _) = foldr collect_lpat bndrs pats + go (ConPatIn _ ps) = foldr collect_lpat bndrs (hsConPatArgs ps) go (ConPatOut {pat_args=ps}) = foldr collect_lpat bndrs (hsConPatArgs ps) - -- See Note [Dictionary binders in ConPatOut] - go (LitPat _) = bndrs - go (NPat _ _ _) = bndrs + -- See Note [Dictionary binders in ConPatOut] + go (LitPat _) = bndrs + go (NPat _ _ _) = bndrs go (NPlusKPat (L _ n) _ _ _) = n : bndrs - - go (SigPatIn pat _) = collect_lpat pat bndrs - go (SigPatOut pat _) = collect_lpat pat bndrs + + go (SigPatIn pat _) = collect_lpat pat bndrs + go (SigPatOut pat _) = collect_lpat pat bndrs go (SplicePat _) = bndrs go (QuasiQuotePat _) = bndrs go (CoPat _ pat _) = go pat @@ -698,7 +741,7 @@ hsForeignDeclsBinders foreign_decls = [n | L _ (ForeignImport (L _ n) _ _ _) <- foreign_decls] hsTyClDeclsBinders :: [TyClGroup Name] -> [Located (InstDecl Name)] -> [Name] --- We need to look at instance declarations too, +-- We need to look at instance declarations too, -- because their associated types may bind data constructors hsTyClDeclsBinders tycl_decls inst_decls = map unLoc (concatMap (concatMap hsLTyClDeclBinders . group_tyclds) tycl_decls ++ @@ -774,16 +817,16 @@ hsConDeclsBinders cons = go id cons Note [Binders in family instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In a type or data family instance declaration, the type +In a type or data family instance declaration, the type constructor is an *occurrence* not a binding site type instance T Int = Int -> Int -- No binders data instance S Bool = S1 | S2 -- Binders are S1,S2 %************************************************************************ -%* * - Collecting binders the user did not write -%* * +%* * + Collecting binders the user did not write +%* * %************************************************************************ The job of this family of functions is to run through binding sites and find the set of all Names @@ -798,7 +841,7 @@ lStmtsImplicits = hs_lstmts where hs_lstmts :: [LStmtLR Name idR (Located (body idR))] -> NameSet hs_lstmts = foldr (\stmt rest -> unionNameSets (hs_stmt (unLoc stmt)) rest) emptyNameSet - + hs_stmt (BindStmt pat _ _ _) = lPatImplicits pat hs_stmt (LetStmt binds) = hs_local_binds binds hs_stmt (BodyStmt {}) = emptyNameSet @@ -806,7 +849,7 @@ lStmtsImplicits = hs_lstmts hs_stmt (ParStmt xs _ _) = hs_lstmts [s | ParStmtBlock ss _ _ <- xs, s <- ss] hs_stmt (TransStmt { trS_stmts = stmts }) = hs_lstmts stmts hs_stmt (RecStmt { recS_stmts = ss }) = hs_lstmts ss - + hs_local_binds (HsValBinds val_binds) = hsValBindsImplicits val_binds hs_local_binds (HsIPBinds _) = emptyNameSet hs_local_binds EmptyLocalBinds = emptyNameSet @@ -814,7 +857,7 @@ lStmtsImplicits = hs_lstmts hsValBindsImplicits :: HsValBindsLR Name idR -> NameSet hsValBindsImplicits (ValBindsOut binds _) = foldr (unionNameSets . lhsBindsImplicits . snd) emptyNameSet binds -hsValBindsImplicits (ValBindsIn binds _) +hsValBindsImplicits (ValBindsIn binds _) = lhsBindsImplicits binds lhsBindsImplicits :: LHsBindsLR Name idR -> NameSet @@ -827,9 +870,9 @@ lPatImplicits :: LPat Name -> NameSet lPatImplicits = hs_lpat where hs_lpat (L _ pat) = hs_pat pat - + hs_lpats = foldr (\pat rest -> hs_lpat pat `unionNameSets` rest) emptyNameSet - + hs_pat (LazyPat pat) = hs_lpat pat hs_pat (BangPat pat) = hs_lpat pat hs_pat (AsPat _ pat) = hs_lpat pat @@ -842,12 +885,12 @@ lPatImplicits = hs_lpat hs_pat (SigPatIn pat _) = hs_lpat pat hs_pat (SigPatOut pat _) = hs_lpat pat hs_pat (CoPat _ pat _) = hs_pat pat - + hs_pat (ConPatIn _ ps) = details ps hs_pat (ConPatOut {pat_args=ps}) = details ps - + hs_pat _ = emptyNameSet - + details (PrefixCon ps) = hs_lpats ps details (RecCon fs) = hs_lpats explicit `unionNameSets` mkNameSet (collectPatsBinders implicit) where (explicit, implicit) = partitionEithers [if pat_explicit then Left pat else Right pat diff --git a/compiler/hsSyn/PlaceHolder.hs b/compiler/hsSyn/PlaceHolder.hs new file mode 100644 index 0000000000..5c536e7dd1 --- /dev/null +++ b/compiler/hsSyn/PlaceHolder.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ConstraintKinds #-} + +module PlaceHolder where + +import Type ( Type ) +import Outputable +import Name +import NameSet +import RdrName +import Var +import Coercion + +import Data.Data hiding ( Fixity ) +import BasicTypes (Fixity) + + +{- +%************************************************************************ +%* * +\subsection{Annotating the syntax} +%* * +%************************************************************************ +-} + +-- | used as place holder in PostTc and PostRn values +data PlaceHolder = PlaceHolder + deriving (Data,Typeable) + +-- | Types that are not defined until after type checking +type family PostTc it ty :: * -- Note [Pass sensitive types] +type instance PostTc Id ty = ty +type instance PostTc Name ty = PlaceHolder +type instance PostTc RdrName ty = PlaceHolder + +-- | Types that are not defined until after renaming +type family PostRn id ty :: * -- Note [Pass sensitive types] +type instance PostRn Id ty = ty +type instance PostRn Name ty = ty +type instance PostRn RdrName ty = PlaceHolder + +placeHolderKind :: PlaceHolder +placeHolderKind = PlaceHolder + +placeHolderFixity :: PlaceHolder +placeHolderFixity = PlaceHolder + +placeHolderType :: PlaceHolder +placeHolderType = PlaceHolder + +placeHolderTypeTc :: Type +placeHolderTypeTc = panic "Evaluated the place holder for a PostTcType" + +placeHolderNames :: PlaceHolder +placeHolderNames = PlaceHolder + +placeHolderNamesTc :: NameSet +placeHolderNamesTc = emptyNameSet + +{- + +Note [Pass sensitive types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Since the same AST types are re-used through parsing,renaming and type +checking there are naturally some places in the AST that do not have +any meaningful value prior to the pass they are assigned a value. + +Historically these have been filled in with place holder values of the form + + panic "error message" + +This has meant the AST is difficult to traverse using standed generic +programming techniques. The problem is addressed by introducing +pass-specific data types, implemented as a pair of open type families, +one for PostTc and one for PostRn. These are then explicitly populated +with a PlaceHolder value when they do not yet have meaning. + +Since the required bootstrap compiler at this stage does not have +closed type families, an open type family had to be used, which +unfortunately forces the requirement for UndecidableInstances. + +In terms of actual usage, we have the following + + PostTc id Kind + PostTc id Type + + PostRn id Fixity + PostRn id NameSet + +TcId and Var are synonyms for Id +-} + +type DataId id = + ( Data id + , Data (PostRn id NameSet) + , Data (PostRn id Fixity) + , Data (PostRn id Bool) + , Data (PostRn id [Name]) + + , Data (PostTc id Type) + , Data (PostTc id Coercion) + ) diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 72dfc88fa6..db7cb10854 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -1203,10 +1203,12 @@ atype :: { LHsType RdrName } -- see Note [Promotion] for the followings | SIMPLEQUOTE qcon { LL $ HsTyVar $ unLoc $2 } | SIMPLEQUOTE '(' ctype ',' comma_types1 ')' { LL $ HsExplicitTupleTy [] ($3 : $5) } - | SIMPLEQUOTE '[' comma_types0 ']' { LL $ HsExplicitListTy placeHolderKind $3 } - | SIMPLEQUOTE var { LL $ HsTyVar $ unLoc $2 } + | SIMPLEQUOTE '[' comma_types0 ']' { LL $ HsExplicitListTy + placeHolderKind $3 } + | SIMPLEQUOTE var { LL $ HsTyVar $ unLoc $2 } - | '[' ctype ',' comma_types1 ']' { LL $ HsExplicitListTy placeHolderKind ($2 : $4) } + | '[' ctype ',' comma_types1 ']' { LL $ HsExplicitListTy + placeHolderKind ($2 : $4) } | INTEGER {% mkTyLit $ LL $ HsNumTy $ getINTEGER $1 } | STRING {% mkTyLit $ LL $ HsStrTy $ getSTRING $1 } @@ -1437,7 +1439,9 @@ decl_no_th :: { Located (OrdList (LHsDecl RdrName)) } pat <- checkPattern empty e; return $ LL $ unitOL $ LL $ ValD $ PatBind pat (unLoc $3) - placeHolderType placeHolderNames (Nothing,[]) } } + placeHolderType + placeHolderNames + (Nothing,[]) } } -- Turn it all into an expression so that -- checkPattern can check that bangs are enabled @@ -1513,16 +1517,20 @@ quasiquote :: { Located (HsQuasiQuote RdrName) } in sL (getLoc $1) (mkHsQuasiQuote quoterId (RealSrcSpan quoteSpan) quote) } exp :: { LHsExpr RdrName } - : infixexp '::' sigtype { LL $ ExprWithTySig $1 $3 } - | infixexp '-<' exp { LL $ HsArrApp $1 $3 placeHolderType HsFirstOrderApp True } - | infixexp '>-' exp { LL $ HsArrApp $3 $1 placeHolderType HsFirstOrderApp False } - | infixexp '-<<' exp { LL $ HsArrApp $1 $3 placeHolderType HsHigherOrderApp True } - | infixexp '>>-' exp { LL $ HsArrApp $3 $1 placeHolderType HsHigherOrderApp False} - | infixexp { $1 } + : infixexp '::' sigtype { LL $ ExprWithTySig $1 $3 } + | infixexp '-<' exp { LL $ HsArrApp $1 $3 placeHolderType + HsFirstOrderApp True } + | infixexp '>-' exp { LL $ HsArrApp $3 $1 placeHolderType + HsFirstOrderApp False } + | infixexp '-<<' exp { LL $ HsArrApp $1 $3 placeHolderType + HsHigherOrderApp True } + | infixexp '>>-' exp { LL $ HsArrApp $3 $1 placeHolderType + HsHigherOrderApp False} + | infixexp { $1 } infixexp :: { LHsExpr RdrName } - : exp10 { $1 } - | infixexp qop exp10 { LL (OpApp $1 $2 (panic "fixity") $3) } + : exp10 { $1 } + | infixexp qop exp10 { LL (OpApp $1 $2 placeHolderFixity $3) } exp10 :: { LHsExpr RdrName } : '\\' apat apats opt_asig '->' exp @@ -1536,7 +1544,9 @@ exp10 :: { LHsExpr RdrName } {% checkDoAndIfThenElse $2 $3 $5 $6 $8 >> return (LL $ mkHsIf $2 $5 $8) } | 'if' ifgdpats {% hintMultiWayIf (getLoc $1) >> - return (LL $ HsMultiIf placeHolderType (reverse $ unLoc $2)) } + return (LL $ HsMultiIf + placeHolderType + (reverse $ unLoc $2)) } | 'case' exp 'of' altslist { LL $ HsCase $2 (mkMatchGroup FromSource (unLoc $4)) } | '-' fexp { LL $ NegApp $2 noSyntaxExpr } @@ -1556,7 +1566,7 @@ exp10 :: { LHsExpr RdrName } {% checkPattern empty $2 >>= \ p -> checkCommand $4 >>= \ cmd -> return (LL $ HsProc p (LL $ HsCmdTop cmd placeHolderType - placeHolderType undefined)) } + placeHolderType [])) } -- TODO: is LL right here? | '{-# CORE' STRING '#-}' exp { LL $ HsCoreAnn (getSTRING $2) $4 } @@ -1603,9 +1613,12 @@ aexp2 :: { LHsExpr RdrName } | literal { L1 (HsLit $! unLoc $1) } -- This will enable overloaded strings permanently. Normally the renamer turns HsString -- into HsOverLit when -foverloaded-strings is on. --- | STRING { sL (getLoc $1) (HsOverLit $! mkHsIsString (getSTRING $1) placeHolderType) } - | INTEGER { sL (getLoc $1) (HsOverLit $! mkHsIntegral (getINTEGER $1) placeHolderType) } - | RATIONAL { sL (getLoc $1) (HsOverLit $! mkHsFractional (getRATIONAL $1) placeHolderType) } +-- | STRING { sL (getLoc $1) (HsOverLit $! mkHsIsString +-- (getSTRING $1) placeHolderType) } + | INTEGER { sL (getLoc $1) (HsOverLit $! mkHsIntegral + (getINTEGER $1) placeHolderType) } + | RATIONAL { sL (getLoc $1) (HsOverLit $! mkHsFractional + (getRATIONAL $1) placeHolderType) } -- N.B.: sections get parsed by these next two productions. -- This allows you to write, e.g., '(+ 3, 4 -)', which isn't @@ -1655,7 +1668,8 @@ cmdargs :: { [LHsCmdTop RdrName] } acmd :: { LHsCmdTop RdrName } : aexp2 {% checkCommand $1 >>= \ cmd -> - return (L1 $ HsCmdTop cmd placeHolderType placeHolderType undefined) } + return (L1 $ HsCmdTop cmd + placeHolderType placeHolderType []) } cvtopbody :: { [LHsDecl RdrName] } : '{' cvtopdecls0 '}' { $2 } @@ -1713,8 +1727,9 @@ tup_tail :: { [HsTupArg RdrName] } -- avoiding another shift/reduce-conflict. list :: { LHsExpr RdrName } - : texp { L1 $ ExplicitList placeHolderType Nothing [$1] } - | lexps { L1 $ ExplicitList placeHolderType Nothing (reverse (unLoc $1)) } + : texp { L1 $ ExplicitList placeHolderType Nothing [$1] } + | lexps { L1 $ ExplicitList placeHolderType Nothing + (reverse (unLoc $1)) } | texp '..' { LL $ ArithSeq noPostTcExpr Nothing (From $1) } | texp ',' exp '..' { LL $ ArithSeq noPostTcExpr Nothing (FromThen $1 $3) } | texp '..' exp { LL $ ArithSeq noPostTcExpr Nothing (FromTo $1 $3) } @@ -1737,7 +1752,8 @@ flattenedpquals :: { Located [LStmt RdrName (LHsExpr RdrName)] } -- We just had one thing in our "parallel" list so -- we simply return that thing directly - qss -> L1 [L1 $ ParStmt [ParStmtBlock qs undefined noSyntaxExpr | qs <- qss] + qss -> L1 [L1 $ ParStmt [ParStmtBlock qs [] noSyntaxExpr | + qs <- qss] noSyntaxExpr noSyntaxExpr] -- We actually found some actual parallel lists so -- we wrap them into as a ParStmt diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 2f95116d5e..6cac513b13 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -5,6 +5,7 @@ Functions over HsSyn specialised to RdrName. \begin{code} {-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} module RdrHsSyn ( mkHsOpApp, @@ -720,7 +721,8 @@ checkAPat msg loc e0 = do ELazyPat e -> checkLPat msg e >>= (return . LazyPat) EAsPat n e -> checkLPat msg e >>= (return . AsPat n) -- view pattern is well-formed if the pattern is - EViewPat expr patE -> checkLPat msg patE >>= (return . (\p -> ViewPat expr p placeHolderType)) + EViewPat expr patE -> checkLPat msg patE >>= + (return . (\p -> ViewPat expr p placeHolderType)) ExprWithTySig e t -> do e <- checkLPat msg e -- Pattern signatures are parsed as sigtypes, -- but they aren't explicit forall points. Hence @@ -817,7 +819,8 @@ checkFunBind msg lhs_loc fun is_infix pats opt_sig (L rhs_span grhss) -- The span of the match covers the entire equation. -- That isn't quite right, but it'll do for now. -makeFunBind :: Located id -> Bool -> [LMatch id (LHsExpr id)] -> HsBind id +makeFunBind :: Located RdrName -> Bool -> [LMatch RdrName (LHsExpr RdrName)] + -> HsBind RdrName -- Like HsUtils.mkFunBind, but we need to be able to set the fixity too makeFunBind fn is_infix ms = FunBind { fun_id = fn, fun_infix = is_infix, fun_matches = mkMatchGroup FromSource ms, @@ -995,13 +998,13 @@ checkCmd _ (HsLet lb e) = checkCmd _ (HsDo DoExpr stmts ty) = mapM checkCmdLStmt stmts >>= (\ss -> return $ HsCmdDo ss ty) -checkCmd _ (OpApp eLeft op fixity eRight) = do +checkCmd _ (OpApp eLeft op _fixity eRight) = do -- OpApp becomes a HsCmdArrForm with a (Just fixity) in it c1 <- checkCommand eLeft c2 <- checkCommand eRight let arg1 = L (getLoc c1) $ HsCmdTop c1 placeHolderType placeHolderType [] arg2 = L (getLoc c2) $ HsCmdTop c2 placeHolderType placeHolderType [] - return $ HsCmdArrForm op (Just fixity) [arg1, arg2] + return $ HsCmdArrForm op Nothing [arg1, arg2] checkCmd l e = cmdFail l e diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs index 0f9f44aed6..dfbde13ded 100644 --- a/compiler/rename/RnBinds.lhs +++ b/compiler/rename/RnBinds.lhs @@ -46,14 +46,14 @@ import NameEnv import NameSet import RdrName ( RdrName, rdrNameOcc ) import SrcLoc -import ListSetOps ( findDupsEq ) -import BasicTypes ( RecFlag(..) ) -import Digraph ( SCC(..) ) +import ListSetOps ( findDupsEq ) +import BasicTypes ( RecFlag(..) ) +import Digraph ( SCC(..) ) import Bag import Outputable import FastString -import Data.List ( partition, sort ) -import Maybes ( orElse ) +import Data.List ( partition, sort ) +import Maybes ( orElse ) import Control.Monad import Data.Traversable ( traverse ) \end{code} @@ -66,7 +66,7 @@ in where-clauses which are all apparently mutually recursive, but which may not really depend upon each other. For example, in the top level program \begin{verbatim} f x = y where a = x - y = x + y = x \end{verbatim} the definitions of @a@ and @y@ do not depend on each other at all. Unfortunately, the typechecker cannot always check such definitions. @@ -86,9 +86,9 @@ within one @MonoBinds@, so that unique-Int plumbing is done explicitly %************************************************************************ -%* * -%* naming conventions * -%* * +%* * +%* naming conventions * +%* * %************************************************************************ \subsection[name-conventions]{Name conventions} @@ -113,9 +113,9 @@ a set of variables free in @Exp@ is written @fvExp@ \end{itemize} %************************************************************************ -%* * +%* * %* analysing polymorphic bindings (HsBindGroup, HsBind) -%* * +%* * %************************************************************************ \subsubsection[dep-HsBinds]{Polymorphic bindings} @@ -154,48 +154,48 @@ union of those in the previous set plus those of the newest binding after the defined variables of the previous set have been removed. @rnMethodBinds@ deals only with the declarations in class and -instance declarations. It expects only to see @FunMonoBind@s, and +instance declarations. It expects only to see @FunMonoBind@s, and it expects the global environment to contain bindings for the binders (which are all class operations). %************************************************************************ -%* * +%* * \subsubsection{ Top-level bindings} -%* * +%* * %************************************************************************ \begin{code} -- for top-level bindings, we need to make top-level names, -- so we have a different entry point than for local bindings rnTopBindsLHS :: MiniFixityEnv - -> HsValBinds RdrName + -> HsValBinds RdrName -> RnM (HsValBindsLR Name RdrName) rnTopBindsLHS fix_env binds = rnValBindsLHS (topRecNameMaker fix_env) binds -rnTopBindsRHS :: NameSet -> HsValBindsLR Name RdrName +rnTopBindsRHS :: NameSet -> HsValBindsLR Name RdrName -> RnM (HsValBinds Name, DefUses) rnTopBindsRHS bound_names binds = do { is_boot <- tcIsHsBoot - ; if is_boot + ; if is_boot then rnTopBindsBoot binds else rnValBindsRHS (TopSigCtxt bound_names False) binds } rnTopBindsBoot :: HsValBindsLR Name RdrName -> RnM (HsValBinds Name, DefUses) --- A hs-boot file has no bindings. +-- A hs-boot file has no bindings. -- Return a single HsBindGroup with empty binds and renamed signatures rnTopBindsBoot (ValBindsIn mbinds sigs) - = do { checkErr (isEmptyLHsBinds mbinds) (bindsInHsBootFile mbinds) - ; (sigs', fvs) <- renameSigs HsBootCtxt sigs - ; return (ValBindsOut [] sigs', usesOnly fvs) } + = do { checkErr (isEmptyLHsBinds mbinds) (bindsInHsBootFile mbinds) + ; (sigs', fvs) <- renameSigs HsBootCtxt sigs + ; return (ValBindsOut [] sigs', usesOnly fvs) } rnTopBindsBoot b = pprPanic "rnTopBindsBoot" (ppr b) \end{code} %********************************************************* -%* * - HsLocalBinds -%* * +%* * + HsLocalBinds +%* * %********************************************************* \begin{code} @@ -203,13 +203,13 @@ rnLocalBindsAndThen :: HsLocalBinds RdrName -> (HsLocalBinds Name -> RnM (result, FreeVars)) -> RnM (result, FreeVars) -- This version (a) assumes that the binding vars are *not* already in scope --- (b) removes the binders from the free vars of the thing inside +-- (b) removes the binders from the free vars of the thing inside -- The parser doesn't produce ThenBinds rnLocalBindsAndThen EmptyLocalBinds thing_inside = thing_inside EmptyLocalBinds rnLocalBindsAndThen (HsValBinds val_binds) thing_inside - = rnLocalValBindsAndThen val_binds $ \ val_binds' -> + = rnLocalValBindsAndThen val_binds $ \ val_binds' -> thing_inside (HsValBinds val_binds') rnLocalBindsAndThen (HsIPBinds binds) thing_inside = do @@ -230,38 +230,38 @@ rnIPBind (IPBind ~(Left n) expr) = do %************************************************************************ -%* * - ValBinds -%* * +%* * + ValBinds +%* * %************************************************************************ \begin{code} --- Renaming local binding gropus +-- Renaming local binding groups -- Does duplicate/shadow check rnLocalValBindsLHS :: MiniFixityEnv -> HsValBinds RdrName -> RnM ([Name], HsValBindsLR Name RdrName) -rnLocalValBindsLHS fix_env binds - = do { binds' <- rnValBindsLHS (localRecNameMaker fix_env) binds +rnLocalValBindsLHS fix_env binds + = do { binds' <- rnValBindsLHS (localRecNameMaker fix_env) binds -- Check for duplicates and shadowing - -- Must do this *after* renaming the patterns - -- See Note [Collect binders only after renaming] in HsUtils + -- Must do this *after* renaming the patterns + -- See Note [Collect binders only after renaming] in HsUtils -- We need to check for dups here because we - -- don't don't bind all of the variables from the ValBinds at once - -- with bindLocatedLocals any more. - -- - -- Note that we don't want to do this at the top level, since - -- sorting out duplicates and shadowing there happens elsewhere. - -- The behavior is even different. For example, - -- import A(f) - -- f = ... - -- should not produce a shadowing warning (but it will produce - -- an ambiguity warning if you use f), but - -- import A(f) - -- g = let f = ... in f - -- should. + -- don't don't bind all of the variables from the ValBinds at once + -- with bindLocatedLocals any more. + -- + -- Note that we don't want to do this at the top level, since + -- sorting out duplicates and shadowing there happens elsewhere. + -- The behavior is even different. For example, + -- import A(f) + -- f = ... + -- should not produce a shadowing warning (but it will produce + -- an ambiguity warning if you use f), but + -- import A(f) + -- g = let f = ... in f + -- should. ; let bound_names = collectHsValBinders binds' ; envs <- getRdrEnvs ; checkDupAndShadowedNames envs bound_names @@ -271,7 +271,7 @@ rnLocalValBindsLHS fix_env binds -- renames the left-hand sides -- generic version used both at the top level and for local binds -- does some error checking, but not what gets done elsewhere at the top level -rnValBindsLHS :: NameMaker +rnValBindsLHS :: NameMaker -> HsValBinds RdrName -> RnM (HsValBindsLR Name RdrName) rnValBindsLHS topP (ValBindsIn mbinds sigs) @@ -287,7 +287,7 @@ rnValBindsLHS _ b = pprPanic "rnValBindsLHSFromDoc" (ppr b) -- Assumes the LHS vars are in scope -- -- Does not bind the local fixity declarations -rnValBindsRHS :: HsSigCtxt +rnValBindsRHS :: HsSigCtxt -> HsValBindsLR Name RdrName -> RnM (HsValBinds Name, DefUses) @@ -299,9 +299,9 @@ rnValBindsRHS ctxt (ValBindsIn mbinds sigs) where valbind' = ValBindsOut anal_binds sigs' valbind'_dus = anal_dus `plusDU` usesOnly sig_fvs - -- Put the sig uses *after* the bindings - -- so that the binders are removed from - -- the uses in the sigs + -- Put the sig uses *after* the bindings + -- so that the binders are removed from + -- the uses in the sigs } rnValBindsRHS _ b = pprPanic "rnValBindsRHS" (ppr b) @@ -319,7 +319,7 @@ rnLocalValBindsRHS bound_names binds = rnValBindsRHS (LocalBindCtxt bound_names) binds -- for local binds --- wrapper that does both the left- and right-hand sides +-- wrapper that does both the left- and right-hand sides -- -- here there are no local fixity decls passed in; -- the local fixity decls come from the ValBinds sigs @@ -327,58 +327,61 @@ rnLocalValBindsAndThen :: HsValBinds RdrName -> (HsValBinds Name -> RnM (result, FreeVars)) -> RnM (result, FreeVars) rnLocalValBindsAndThen binds@(ValBindsIn _ sigs) thing_inside - = do { -- (A) Create the local fixity environment - new_fixities <- makeMiniFixityEnv [L loc sig | L loc (FixSig sig) <- sigs] + = do { -- (A) Create the local fixity environment + new_fixities <- makeMiniFixityEnv [L loc sig + | L loc (FixSig sig) <- sigs] - -- (B) Rename the LHSes - ; (bound_names, new_lhs) <- rnLocalValBindsLHS new_fixities binds + -- (B) Rename the LHSes + ; (bound_names, new_lhs) <- rnLocalValBindsLHS new_fixities binds - -- ...and bring them (and their fixities) into scope - ; bindLocalNamesFV bound_names $ + -- ...and bring them (and their fixities) into scope + ; bindLocalNamesFV bound_names $ addLocalFixities new_fixities bound_names $ do - { -- (C) Do the RHS and thing inside - (binds', dus) <- rnLocalValBindsRHS (mkNameSet bound_names) new_lhs + { -- (C) Do the RHS and thing inside + (binds', dus) <- rnLocalValBindsRHS (mkNameSet bound_names) new_lhs ; (result, result_fvs) <- thing_inside binds' - -- Report unused bindings based on the (accurate) - -- findUses. E.g. - -- let x = x in 3 - -- should report 'x' unused - ; let real_uses = findUses dus result_fvs - -- Insert fake uses for variables introduced implicitly by wildcards (#4404) - implicit_uses = hsValBindsImplicits binds' - ; warnUnusedLocalBinds bound_names (real_uses `unionNameSets` implicit_uses) - - ; let - -- The variables "used" in the val binds are: + -- Report unused bindings based on the (accurate) + -- findUses. E.g. + -- let x = x in 3 + -- should report 'x' unused + ; let real_uses = findUses dus result_fvs + -- Insert fake uses for variables introduced implicitly by + -- wildcards (#4404) + implicit_uses = hsValBindsImplicits binds' + ; warnUnusedLocalBinds bound_names + (real_uses `unionNameSets` implicit_uses) + + ; let + -- The variables "used" in the val binds are: -- (1) the uses of the binds (allUses) -- (2) the FVs of the thing-inside all_uses = allUses dus `plusFV` result_fvs - -- Note [Unused binding hack] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- Note that *in contrast* to the above reporting of - -- unused bindings, (1) above uses duUses to return *all* - -- the uses, even if the binding is unused. Otherwise consider: - -- x = 3 - -- y = let p = x in 'x' -- NB: p not used + -- Note [Unused binding hack] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- Note that *in contrast* to the above reporting of + -- unused bindings, (1) above uses duUses to return *all* + -- the uses, even if the binding is unused. Otherwise consider: + -- x = 3 + -- y = let p = x in 'x' -- NB: p not used -- If we don't "see" the dependency of 'y' on 'x', we may put the -- bindings in the wrong order, and the type checker will complain -- that x isn't in scope - -- - -- But note that this means we won't report 'x' as unused, - -- whereas we would if we had { x = 3; p = x; y = 'x' } + -- + -- But note that this means we won't report 'x' as unused, + -- whereas we would if we had { x = 3; p = x; y = 'x' } - ; return (result, all_uses) }} - -- The bound names are pruned out of all_uses - -- by the bindLocalNamesFV call above + ; return (result, all_uses) }} + -- The bound names are pruned out of all_uses + -- by the bindLocalNamesFV call above rnLocalValBindsAndThen bs _ = pprPanic "rnLocalValBindsAndThen" (ppr bs) -- Process the fixity declarations, making a FastString -> (Located Fixity) map -- (We keep the location around for reporting duplicate fixity declarations.) --- +-- -- Checks for duplicates, but not that only locally defined things are fixed. -- Note: for local fixity declarations, duplicates would also be checked in -- check_sigs below. But we also use this function at the top level. @@ -398,7 +401,7 @@ makeMiniFixityEnv decls = foldlM add_one emptyFsEnv decls case lookupFsEnv env fs of Nothing -> return $ extendFsEnv env fs fix_item Just (L loc' _) -> do - { setSrcSpan loc $ + { setSrcSpan loc $ addErrAt name_loc (dupFixityDecl loc' name) ; return env} } @@ -406,14 +409,14 @@ makeMiniFixityEnv decls = foldlM add_one emptyFsEnv decls dupFixityDecl :: SrcSpan -> RdrName -> SDoc dupFixityDecl loc rdr_name = vcat [ptext (sLit "Multiple fixity declarations for") <+> quotes (ppr rdr_name), - ptext (sLit "also at ") <+> ppr loc] + ptext (sLit "also at ") <+> ppr loc] --------------------- -- renaming a single bind rnBindLHS :: NameMaker - -> SDoc + -> SDoc -> HsBind RdrName -- returns the renamed left-hand side, -- and the FreeVars *of the LHS* @@ -431,7 +434,8 @@ rnBindLHS name_maker _ bind@(PatBind { pat_lhs = pat }) rnBindLHS name_maker _ bind@(FunBind { fun_id = name@(L nameLoc _) }) = do { newname <- applyNameMaker name_maker name - ; return (bind { fun_id = L nameLoc newname }) } + ; return (bind { fun_id = L nameLoc newname + , bind_fvs = placeHolderNamesTc }) } rnBindLHS name_maker _ (PatSynBind psb@PSB{ psb_id = rdrname@(L nameLoc _) }) = do { unless (isTopRecNameMaker name_maker) $ @@ -447,7 +451,7 @@ rnBindLHS name_maker _ (PatSynBind psb@PSB{ psb_id = rdrname@(L nameLoc _) }) rnBindLHS _ _ b = pprPanic "rnBindHS" (ppr b) -rnLBind :: (Name -> [Name]) -- Signature tyvar function +rnLBind :: (Name -> [Name]) -- Signature tyvar function -> LHsBindLR Name RdrName -> RnM (LHsBind Name, [Name], Uses) rnLBind sig_fn (L loc bind) @@ -456,25 +460,26 @@ rnLBind sig_fn (L loc bind) ; return (L loc bind', bndrs, dus) } -- assumes the left-hands-side vars are in scope -rnBind :: (Name -> [Name]) -- Signature tyvar function +rnBind :: (Name -> [Name]) -- Signature tyvar function -> HsBindLR Name RdrName -> RnM (HsBind Name, [Name], Uses) rnBind _ bind@(PatBind { pat_lhs = pat - , pat_rhs = grhss + , pat_rhs = grhss -- pat fvs were stored in bind_fvs -- after processing the LHS , bind_fvs = pat_fvs }) - = do { mod <- getModule + = do { mod <- getModule ; (grhss', rhs_fvs) <- rnGRHSs PatBindRhs rnLExpr grhss - -- No scoped type variables for pattern bindings - ; let all_fvs = pat_fvs `plusFV` rhs_fvs + -- No scoped type variables for pattern bindings + ; let all_fvs = pat_fvs `plusFV` rhs_fvs fvs' = filterNameSet (nameIsLocalOrFrom mod) all_fvs - -- Keep locally-defined Names - -- As well as dependency analysis, we need these for the - -- MonoLocalBinds test in TcBinds.decideGeneralisationPlan + -- Keep locally-defined Names + -- As well as dependency analysis, we need these for the + -- MonoLocalBinds test in TcBinds.decideGeneralisationPlan bndrs = collectPatBinders pat - bind' = bind { pat_rhs = grhss', bind_fvs = fvs' } + bind' = bind { pat_rhs = grhss', + pat_rhs_ty = placeHolderType, bind_fvs = fvs' } is_wild_pat = case pat of L _ (WildPat {}) -> True L _ (BangPat (L _ (WildPat {}))) -> True -- #9127 @@ -489,30 +494,31 @@ rnBind _ bind@(PatBind { pat_lhs = pat when (null bndrs && not is_wild_pat) $ addWarn $ unusedPatBindWarn bind' - ; fvs' `seq` -- See Note [Free-variable space leak] + ; fvs' `seq` -- See Note [Free-variable space leak] return (bind', bndrs, all_fvs) } -rnBind sig_fn bind@(FunBind { fun_id = name - , fun_infix = is_infix - , fun_matches = matches }) +rnBind sig_fn bind@(FunBind { fun_id = name + , fun_infix = is_infix + , fun_matches = matches }) -- invariant: no free vars here when it's a FunBind - = do { let plain_name = unLoc name + = do { let plain_name = unLoc name - ; (matches', rhs_fvs) <- bindSigTyVarsFV (sig_fn plain_name) $ - -- bindSigTyVars tests for Opt_ScopedTyVars - rnMatchGroup (FunRhs plain_name is_infix) rnLExpr matches - ; when is_infix $ checkPrecMatch plain_name matches' + ; (matches', rhs_fvs) <- bindSigTyVarsFV (sig_fn plain_name) $ + -- bindSigTyVars tests for Opt_ScopedTyVars + rnMatchGroup (FunRhs plain_name is_infix) + rnLExpr matches + ; when is_infix $ checkPrecMatch plain_name matches' ; mod <- getModule ; let fvs' = filterNameSet (nameIsLocalOrFrom mod) rhs_fvs - -- Keep locally-defined Names - -- As well as dependency analysis, we need these for the - -- MonoLocalBinds test in TcBinds.decideGeneralisationPlan + -- Keep locally-defined Names + -- As well as dependency analysis, we need these for the + -- MonoLocalBinds test in TcBinds.decideGeneralisationPlan - ; fvs' `seq` -- See Note [Free-variable space leak] + ; fvs' `seq` -- See Note [Free-variable space leak] return (bind { fun_matches = matches' - , bind_fvs = fvs' }, - [plain_name], rhs_fvs) + , bind_fvs = fvs' }, + [plain_name], rhs_fvs) } rnBind sig_fn (PatSynBind bind) @@ -534,7 +540,7 @@ and we don't want to retain the list bound_names. This showed up in trac ticket #1136. -} -rnPatSynBind :: (Name -> [Name]) -- Signature tyvar function +rnPatSynBind :: (Name -> [Name]) -- Signature tyvar function -> PatSynBind Name RdrName -> RnM (PatSynBind Name Name, [Name], Uses) rnPatSynBind _sig_fn bind@(PSB { psb_id = L _ name @@ -542,7 +548,7 @@ rnPatSynBind _sig_fn bind@(PSB { psb_id = L _ name , psb_def = pat , psb_dir = dir }) -- invariant: no free vars here when it's a FunBind - = do { pattern_synonym_ok <- xoptM Opt_PatternSynonyms + = do { pattern_synonym_ok <- xoptM Opt_PatternSynonyms ; unless pattern_synonym_ok (addErr patternSynonymErr) ; ((pat', details'), fvs1) <- rnPat PatSyn pat $ \pat' -> do @@ -571,9 +577,9 @@ rnPatSynBind _sig_fn bind@(PSB { psb_id = L _ name ; mod <- getModule ; let fvs = fvs1 `plusFV` fvs2 fvs' = filterNameSet (nameIsLocalOrFrom mod) fvs - -- Keep locally-defined Names - -- As well as dependency analysis, we need these for the - -- MonoLocalBinds test in TcBinds.decideGeneralisationPlan + -- Keep locally-defined Names + -- As well as dependency analysis, we need these for the + -- MonoLocalBinds test in TcBinds.decideGeneralisationPlan ; let bind' = bind{ psb_args = details' , psb_def = pat' @@ -624,8 +630,8 @@ P' which is unsound and rejected). --------------------- depAnalBinds :: Bag (LHsBind Name, [Name], Uses) - -> ([(RecFlag, LHsBinds Name)], DefUses) --- Dependency analysis; this is important so that + -> ([(RecFlag, LHsBinds Name)], DefUses) +-- Dependency analysis; this is important so that -- unused-binding reporting is accurate depAnalBinds binds_w_dus = (map get_binds sccs, map get_du sccs) @@ -639,21 +645,21 @@ depAnalBinds binds_w_dus get_du (AcyclicSCC (_, bndrs, uses)) = (Just (mkNameSet bndrs), uses) get_du (CyclicSCC binds_w_dus) = (Just defs, uses) - where - defs = mkNameSet [b | (_,bs,_) <- binds_w_dus, b <- bs] - uses = unionManyNameSets [u | (_,_,u) <- binds_w_dus] + where + defs = mkNameSet [b | (_,bs,_) <- binds_w_dus, b <- bs] + uses = unionManyNameSets [u | (_,_,u) <- binds_w_dus] --------------------- -- Bind the top-level forall'd type variables in the sigs. --- E.g f :: a -> a --- f = rhs --- The 'a' scopes over the rhs +-- E.g f :: a -> a +-- f = rhs +-- The 'a' scopes over the rhs -- -- NB: there'll usually be just one (for a function binding) -- but if there are many, one may shadow the rest; too bad! --- e.g x :: [a] -> [a] --- y :: [(a,a)] -> a --- (x,y) = e +-- e.g x :: [a] -> [a] +-- y :: [(a,a)] -> a +-- (x,y) = e -- In e, 'a' will be in scope, and it'll be the one from 'y'! mkSigTvFn :: [LSig Name] -> (Name -> [Name]) @@ -664,11 +670,11 @@ mkSigTvFn sigs where env :: NameEnv [Name] env = mkNameEnv [ (name, hsLKiTyVarNames ltvs) -- Kind variables and type variables - | L _ (TypeSig names - (L _ (HsForAllTy Explicit ltvs _ _))) <- sigs + | L _ (TypeSig names + (L _ (HsForAllTy Explicit ltvs _ _))) <- sigs , (L _ name) <- names] - -- Note the pattern-match on "Explicit"; we only bind - -- type variables from signatures with an explicit top-level for-all + -- Note the pattern-match on "Explicit"; we only bind + -- type variables from signatures with an explicit top-level for-all \end{code} @@ -678,8 +684,8 @@ declaration. Like @rnBinds@ but without dependency analysis. NOTA BENE: we record each {\em binder} of a method-bind group as a free variable. That's crucial when dealing with an instance decl: \begin{verbatim} - instance Foo (T a) where - op x = ... + instance Foo (T a) where + op x = ... \end{verbatim} This might be the {\em sole} occurrence of @op@ for an imported class @Foo@, and unless @op@ occurs we won't treat the type signature of @op@ in the class @@ -688,48 +694,50 @@ in many ways the @op@ in an instance decl is just like an occurrence, not a binder. \begin{code} -rnMethodBinds :: Name -- Class name - -> (Name -> [Name]) -- Signature tyvar function - -> LHsBinds RdrName - -> RnM (LHsBinds Name, FreeVars) +rnMethodBinds :: Name -- Class name + -> (Name -> [Name]) -- Signature tyvar function + -> LHsBinds RdrName + -> RnM (LHsBinds Name, FreeVars) rnMethodBinds cls sig_fn binds = do { checkDupRdrNames meth_names - -- Check that the same method is not given twice in the - -- same instance decl instance C T where - -- f x = ... - -- g y = ... - -- f x = ... - -- We must use checkDupRdrNames because the Name of the - -- method is the Name of the class selector, whose SrcSpan - -- points to the class declaration; and we use rnMethodBinds - -- for instance decls too + -- Check that the same method is not given twice in the + -- same instance decl instance C T where + -- f x = ... + -- g y = ... + -- f x = ... + -- We must use checkDupRdrNames because the Name of the + -- method is the Name of the class selector, whose SrcSpan + -- points to the class declaration; and we use rnMethodBinds + -- for instance decls too ; foldlM do_one (emptyBag, emptyFVs) (bagToList binds) } - where + where meth_names = collectMethodBinders binds do_one (binds,fvs) bind = do { (bind', fvs_bind) <- rnMethodBind cls sig_fn bind - ; return (binds `unionBags` bind', fvs_bind `plusFV` fvs) } + ; return (binds `unionBags` bind', fvs_bind `plusFV` fvs) } rnMethodBind :: Name - -> (Name -> [Name]) - -> LHsBindLR RdrName RdrName - -> RnM (Bag (LHsBindLR Name Name), FreeVars) -rnMethodBind cls sig_fn - (L loc bind@(FunBind { fun_id = name, fun_infix = is_infix - , fun_matches = MG { mg_alts = matches, mg_origin = origin } })) + -> (Name -> [Name]) + -> LHsBindLR RdrName RdrName + -> RnM (Bag (LHsBindLR Name Name), FreeVars) +rnMethodBind cls sig_fn + (L loc bind@(FunBind { fun_id = name, fun_infix = is_infix + , fun_matches = MG { mg_alts = matches + , mg_origin = origin } })) = setSrcSpan loc $ do sel_name <- wrapLocM (lookupInstDeclBndr cls (ptext (sLit "method"))) name let plain_name = unLoc sel_name -- We use the selector name as the binder (new_matches, fvs) <- bindSigTyVarsFV (sig_fn plain_name) $ - mapFvRn (rnMatch (FunRhs plain_name is_infix) rnLExpr) matches - let new_group = mkMatchGroup origin new_matches + mapFvRn (rnMatch (FunRhs plain_name is_infix) rnLExpr) + matches + let new_group = mkMatchGroupName origin new_matches when is_infix $ checkPrecMatch plain_name new_group - return (unitBag (L loc (bind { fun_id = sel_name + return (unitBag (L loc (bind { fun_id = sel_name , fun_matches = new_group , bind_fvs = fvs })), fvs `addOneFV` plain_name) @@ -746,9 +754,9 @@ rnMethodBind _ _ b = pprPanic "rnMethodBind" (ppr b) %************************************************************************ -%* * +%* * \subsubsection[dep-Sigs]{Signatures (and user-pragmas for values)} -%* * +%* * %************************************************************************ @renameSigs@ checks for: @@ -761,28 +769,28 @@ At the moment we don't gather free-var info from the types in signatures. We'd only need this if we wanted to report unused tyvars. \begin{code} -renameSigs :: HsSigCtxt - -> [LSig RdrName] - -> RnM ([LSig Name], FreeVars) +renameSigs :: HsSigCtxt + -> [LSig RdrName] + -> RnM ([LSig Name], FreeVars) -- Renames the signatures and performs error checks -renameSigs ctxt sigs - = do { mapM_ dupSigDeclErr (findDupSigs sigs) +renameSigs ctxt sigs + = do { mapM_ dupSigDeclErr (findDupSigs sigs) - ; checkDupMinimalSigs sigs + ; checkDupMinimalSigs sigs - ; (sigs', sig_fvs) <- mapFvRn (wrapLocFstM (renameSig ctxt)) sigs + ; (sigs', sig_fvs) <- mapFvRn (wrapLocFstM (renameSig ctxt)) sigs - ; let (good_sigs, bad_sigs) = partition (okHsSig ctxt) sigs' - ; mapM_ misplacedSigErr bad_sigs -- Misplaced + ; let (good_sigs, bad_sigs) = partition (okHsSig ctxt) sigs' + ; mapM_ misplacedSigErr bad_sigs -- Misplaced - ; return (good_sigs, sig_fvs) } + ; return (good_sigs, sig_fvs) } ---------------------- -- We use lookupSigOccRn in the signatures, which is a little bit unsatisfactory -- because this won't work for: --- instance Foo T where --- {-# INLINE op #-} --- Baz.op = ... +-- instance Foo T where +-- {-# INLINE op #-} +-- Baz.op = ... -- We'll just rename the INLINE prag to refer to whatever other 'op' -- is in scope. (I'm assuming that Baz.op isn't in scope unqualified.) -- Doesn't seem worth much trouble to sort this. @@ -790,49 +798,49 @@ renameSigs ctxt sigs renameSig :: HsSigCtxt -> Sig RdrName -> RnM (Sig Name, FreeVars) -- FixitySig is renamed elsewhere. renameSig _ (IdSig x) - = return (IdSig x, emptyFVs) -- Actually this never occurs + = return (IdSig x, emptyFVs) -- Actually this never occurs renameSig ctxt sig@(TypeSig vs ty) - = do { new_vs <- mapM (lookupSigOccRn ctxt sig) vs - ; (new_ty, fvs) <- rnHsSigType (ppr_sig_bndrs vs) ty - ; return (TypeSig new_vs new_ty, fvs) } + = do { new_vs <- mapM (lookupSigOccRn ctxt sig) vs + ; (new_ty, fvs) <- rnHsSigType (ppr_sig_bndrs vs) ty + ; return (TypeSig new_vs new_ty, fvs) } renameSig ctxt sig@(GenericSig vs ty) - = do { defaultSigs_on <- xoptM Opt_DefaultSignatures + = do { defaultSigs_on <- xoptM Opt_DefaultSignatures ; unless defaultSigs_on (addErr (defaultSigErr sig)) ; new_v <- mapM (lookupSigOccRn ctxt sig) vs - ; (new_ty, fvs) <- rnHsSigType (ppr_sig_bndrs vs) ty - ; return (GenericSig new_v new_ty, fvs) } + ; (new_ty, fvs) <- rnHsSigType (ppr_sig_bndrs vs) ty + ; return (GenericSig new_v new_ty, fvs) } renameSig _ (SpecInstSig ty) - = do { (new_ty, fvs) <- rnLHsType SpecInstSigCtx ty - ; return (SpecInstSig new_ty,fvs) } + = do { (new_ty, fvs) <- rnLHsType SpecInstSigCtx ty + ; return (SpecInstSig new_ty,fvs) } -- {-# SPECIALISE #-} pragmas can refer to imported Ids -- so, in the top-level case (when mb_names is Nothing) -- we use lookupOccRn. If there's both an imported and a local 'f' -- then the SPECIALISE pragma is ambiguous, unlike all other signatures renameSig ctxt sig@(SpecSig v ty inl) - = do { new_v <- case ctxt of + = do { new_v <- case ctxt of TopSigCtxt {} -> lookupLocatedOccRn v _ -> lookupSigOccRn ctxt sig v - ; (new_ty, fvs) <- rnHsSigType (quotes (ppr v)) ty - ; return (SpecSig new_v new_ty inl, fvs) } + ; (new_ty, fvs) <- rnHsSigType (quotes (ppr v)) ty + ; return (SpecSig new_v new_ty inl, fvs) } renameSig ctxt sig@(InlineSig v s) - = do { new_v <- lookupSigOccRn ctxt sig v - ; return (InlineSig new_v s, emptyFVs) } + = do { new_v <- lookupSigOccRn ctxt sig v + ; return (InlineSig new_v s, emptyFVs) } renameSig ctxt sig@(FixSig (FixitySig v f)) - = do { new_v <- lookupSigOccRn ctxt sig v - ; return (FixSig (FixitySig new_v f), emptyFVs) } + = do { new_v <- lookupSigOccRn ctxt sig v + ; return (FixSig (FixitySig new_v f), emptyFVs) } renameSig ctxt sig@(MinimalSig bf) = do new_bf <- traverse (lookupSigOccRn ctxt sig) bf return (MinimalSig new_bf, emptyFVs) renameSig ctxt sig@(PatSynSig v args ty prov req) - = do v' <- lookupSigOccRn ctxt sig v + = do v' <- lookupSigOccRn ctxt sig v let doc = quotes (ppr v) rn_type = rnHsSigType doc (ty', fvs1) <- rn_type ty @@ -853,7 +861,7 @@ ppr_sig_bndrs :: [Located RdrName] -> SDoc ppr_sig_bndrs bs = quotes (pprWithCommas ppr bs) okHsSig :: HsSigCtxt -> LSig a -> Bool -okHsSig ctxt (L _ sig) +okHsSig ctxt (L _ sig) = case (sig, ctxt) of (GenericSig {}, ClsDeclCtxt {}) -> True (GenericSig {}, _) -> False @@ -886,13 +894,13 @@ okHsSig ctxt (L _ sig) ------------------- findDupSigs :: [LSig RdrName] -> [[(Located RdrName, Sig RdrName)]] --- Check for duplicates on RdrName version, +-- Check for duplicates on RdrName version, -- because renamed version has unboundName for -- not-in-scope binders, which gives bogus dup-sig errors --- NB: in a class decl, a 'generic' sig is not considered +-- NB: in a class decl, a 'generic' sig is not considered -- equal to an ordinary sig, so we allow, say --- class C a where --- op :: a -> a +-- class C a where +-- op :: a -> a -- default op :: Eq a => a -> a findDupSigs sigs = findDupsEq matching_sig (concatMap (expand_sig . unLoc) sigs) @@ -920,9 +928,9 @@ checkDupMinimalSigs sigs %************************************************************************ -%* * +%* * \subsection{Match} -%* * +%* * %************************************************************************ \begin{code} @@ -930,11 +938,11 @@ rnMatchGroup :: Outputable (body RdrName) => HsMatchContext Name -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) -> MatchGroup RdrName (Located (body RdrName)) -> RnM (MatchGroup Name (Located (body Name)), FreeVars) -rnMatchGroup ctxt rnBody (MG { mg_alts = ms, mg_origin = origin }) +rnMatchGroup ctxt rnBody (MG { mg_alts = ms, mg_origin = origin }) = do { empty_case_ok <- xoptM Opt_EmptyCase ; when (null ms && not empty_case_ok) (addErr (emptyCaseErr ctxt)) ; (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt rnBody) ms - ; return (mkMatchGroup origin new_ms, ms_fvs) } + ; return (mkMatchGroupName origin new_ms, ms_fvs) } rnMatch :: Outputable (body RdrName) => HsMatchContext Name -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) @@ -942,22 +950,22 @@ rnMatch :: Outputable (body RdrName) => HsMatchContext Name -> RnM (LMatch Name (Located (body Name)), FreeVars) rnMatch ctxt rnBody = wrapLocFstM (rnMatch' ctxt rnBody) -rnMatch' :: Outputable (body RdrName) => HsMatchContext Name +rnMatch' :: Outputable (body RdrName) => HsMatchContext Name -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) -> Match RdrName (Located (body RdrName)) -> RnM (Match Name (Located (body Name)), FreeVars) rnMatch' ctxt rnBody match@(Match pats maybe_rhs_sig grhss) - = do { -- Result type signatures are no longer supported - case maybe_rhs_sig of - Nothing -> return () - Just (L loc ty) -> addErrAt loc (resSigErr ctxt match ty) + = do { -- Result type signatures are no longer supported + case maybe_rhs_sig of + Nothing -> return () + Just (L loc ty) -> addErrAt loc (resSigErr ctxt match ty) - -- Now the main event - -- note that there are no local ficity decls for matches - ; rnPats ctxt pats $ \ pats' -> do - { (grhss', grhss_fvs) <- rnGRHSs ctxt rnBody grhss + -- Now the main event + -- note that there are no local ficity decls for matches + ; rnPats ctxt pats $ \ pats' -> do + { (grhss', grhss_fvs) <- rnGRHSs ctxt rnBody grhss - ; return (Match pats' Nothing grhss', grhss_fvs) }} + ; return (Match pats' Nothing grhss', grhss_fvs) }} emptyCaseErr :: HsMatchContext Name -> SDoc emptyCaseErr ctxt = hang (ptext (sLit "Empty list of alternatives in") <+> pp_ctxt) @@ -967,71 +975,73 @@ emptyCaseErr ctxt = hang (ptext (sLit "Empty list of alternatives in") <+> pp_ct CaseAlt -> ptext (sLit "case expression") LambdaExpr -> ptext (sLit "\\case expression") _ -> ptext (sLit "(unexpected)") <+> pprMatchContextNoun ctxt - -resSigErr :: Outputable body => HsMatchContext Name -> Match RdrName body -> HsType RdrName -> SDoc + +resSigErr :: Outputable body + => HsMatchContext Name -> Match RdrName body -> HsType RdrName -> SDoc resSigErr ctxt match ty = vcat [ ptext (sLit "Illegal result type signature") <+> quotes (ppr ty) - , nest 2 $ ptext (sLit "Result signatures are no longer supported in pattern matches") - , pprMatchInCtxt ctxt match ] + , nest 2 $ ptext (sLit + "Result signatures are no longer supported in pattern matches") + , pprMatchInCtxt ctxt match ] \end{code} %************************************************************************ -%* * +%* * \subsubsection{Guarded right-hand sides (GRHSs)} -%* * +%* * %************************************************************************ \begin{code} -rnGRHSs :: HsMatchContext Name +rnGRHSs :: HsMatchContext Name -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) -> GRHSs RdrName (Located (body RdrName)) -> RnM (GRHSs Name (Located (body Name)), FreeVars) rnGRHSs ctxt rnBody (GRHSs grhss binds) - = rnLocalBindsAndThen binds $ \ binds' -> do + = rnLocalBindsAndThen binds $ \ binds' -> do (grhss', fvGRHSs) <- mapFvRn (rnGRHS ctxt rnBody) grhss return (GRHSs grhss' binds', fvGRHSs) -rnGRHS :: HsMatchContext Name +rnGRHS :: HsMatchContext Name -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) -> LGRHS RdrName (Located (body RdrName)) -> RnM (LGRHS Name (Located (body Name)), FreeVars) rnGRHS ctxt rnBody = wrapLocFstM (rnGRHS' ctxt rnBody) -rnGRHS' :: HsMatchContext Name +rnGRHS' :: HsMatchContext Name -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) -> GRHS RdrName (Located (body RdrName)) -> RnM (GRHS Name (Located (body Name)), FreeVars) rnGRHS' ctxt rnBody (GRHS guards rhs) - = do { pattern_guards_allowed <- xoptM Opt_PatternGuards + = do { pattern_guards_allowed <- xoptM Opt_PatternGuards ; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) rnLExpr guards $ \ _ -> - rnBody rhs + rnBody rhs - ; unless (pattern_guards_allowed || is_standard_guard guards') - (addWarn (nonStdGuardErr guards')) + ; unless (pattern_guards_allowed || is_standard_guard guards') + (addWarn (nonStdGuardErr guards')) - ; return (GRHS guards' rhs', fvs) } + ; return (GRHS guards' rhs', fvs) } where - -- Standard Haskell 1.4 guards are just a single boolean - -- expression, rather than a list of qualifiers as in the - -- Glasgow extension + -- Standard Haskell 1.4 guards are just a single boolean + -- expression, rather than a list of qualifiers as in the + -- Glasgow extension is_standard_guard [] = True is_standard_guard [L _ (BodyStmt _ _ _ _)] = True is_standard_guard _ = False \end{code} %************************************************************************ -%* * +%* * \subsection{Error messages} -%* * +%* * %************************************************************************ \begin{code} dupSigDeclErr :: [(Located RdrName, Sig RdrName)] -> RnM () dupSigDeclErr pairs@((L loc name, sig) : _) = addErrAt loc $ - vcat [ ptext (sLit "Duplicate") <+> what_it_is + vcat [ ptext (sLit "Duplicate") <+> what_it_is <> ptext (sLit "s for") <+> quotes (ppr name) , ptext (sLit "at") <+> vcat (map ppr $ sort $ map (getLoc . fst) pairs) ] where diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs index 4e5076ab1f..2872b480c2 100644 --- a/compiler/rename/RnExpr.lhs +++ b/compiler/rename/RnExpr.lhs @@ -207,9 +207,10 @@ rnExpr (HsLam matches) = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLExpr matches ; return (HsLam matches', fvMatch) } -rnExpr (HsLamCase arg matches) +rnExpr (HsLamCase _arg matches) = do { (matches', fvs_ms) <- rnMatchGroup CaseAlt rnLExpr matches - ; return (HsLamCase arg matches', fvs_ms) } + -- ; return (HsLamCase arg matches', fvs_ms) } + ; return (HsLamCase placeHolderType matches', fvs_ms) } rnExpr (HsCase expr matches) = do { (new_expr, e_fvs) <- rnLExpr expr @@ -231,7 +232,8 @@ rnExpr (ExplicitList _ _ exps) ; if opt_OverloadedLists then do { ; (from_list_n_name, fvs') <- lookupSyntaxName fromListNName - ; return (ExplicitList placeHolderType (Just from_list_n_name) exps', fvs `plusFV` fvs') } + ; return (ExplicitList placeHolderType (Just from_list_n_name) exps' + , fvs `plusFV` fvs') } else return (ExplicitList placeHolderType Nothing exps', fvs) } @@ -273,9 +275,10 @@ rnExpr (HsIf _ p b1 b2) ; (mb_ite, fvITE) <- lookupIfThenElse ; return (HsIf mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) } -rnExpr (HsMultiIf ty alts) +rnExpr (HsMultiIf _ty alts) = do { (alts', fvs) <- mapFvRn (rnGRHS IfAlt rnLExpr) alts - ; return (HsMultiIf ty alts', fvs) } + -- ; return (HsMultiIf ty alts', fvs) } + ; return (HsMultiIf placeHolderType alts', fvs) } rnExpr (HsType a) = do { (t, fvT) <- rnLHsType HsTypeCtx a @@ -404,7 +407,8 @@ rnCmdTop = wrapLocFstM rnCmdTop' -- Generate the rebindable syntax for the monad ; (cmd_names', cmd_fvs) <- lookupSyntaxNames cmd_names - ; return (HsCmdTop cmd' placeHolderType placeHolderType (cmd_names `zip` cmd_names'), + ; return (HsCmdTop cmd' placeHolderType placeHolderType + (cmd_names `zip` cmd_names'), fvCmd `plusFV` cmd_fvs) } rnLCmd :: LHsCmd RdrName -> RnM (LHsCmd Name, FreeVars) @@ -677,9 +681,9 @@ rnStmt ctxt rnBody (L _ (RecStmt { recS_stmts = rec_stmts })) thing_inside = do { (return_op, fvs1) <- lookupStmtName ctxt returnMName ; (mfix_op, fvs2) <- lookupStmtName ctxt mfixName ; (bind_op, fvs3) <- lookupStmtName ctxt bindMName - ; let empty_rec_stmt = emptyRecStmt { recS_ret_fn = return_op - , recS_mfix_fn = mfix_op - , recS_bind_fn = bind_op } + ; let empty_rec_stmt = emptyRecStmtName { recS_ret_fn = return_op + , recS_mfix_fn = mfix_op + , recS_bind_fn = bind_op } -- Step1: Bring all the binders of the mdo into scope -- (Remember that this also removes the binders from the diff --git a/compiler/rename/RnPat.lhs b/compiler/rename/RnPat.lhs index a3f34b2c58..aa41361655 100644 --- a/compiler/rename/RnPat.lhs +++ b/compiler/rename/RnPat.lhs @@ -205,7 +205,8 @@ matchNameMaker ctxt = LamMk report_unused StmtCtxt GhciStmtCtxt -> False _ -> True -rnHsSigCps :: HsWithBndrs (LHsType RdrName) -> CpsRn (HsWithBndrs (LHsType Name)) +rnHsSigCps :: HsWithBndrs RdrName (LHsType RdrName) + -> CpsRn (HsWithBndrs Name (LHsType Name)) rnHsSigCps sig = CpsRn (rnHsBndrSig PatCtx sig) @@ -401,14 +402,16 @@ rnPatAndThen mk (AsPat rdr pat) ; pat' <- rnLPatAndThen mk pat ; return (AsPat (L (nameSrcSpan new_name) new_name) pat') } -rnPatAndThen mk p@(ViewPat expr pat ty) +rnPatAndThen mk p@(ViewPat expr pat _ty) = do { liftCps $ do { vp_flag <- xoptM Opt_ViewPatterns ; checkErr vp_flag (badViewPat p) } -- Because of the way we're arranging the recursive calls, -- this will be in the right context ; expr' <- liftCpsFV $ rnLExpr expr ; pat' <- rnLPatAndThen mk pat - ; return (ViewPat expr' pat' ty) } + -- Note: at this point the PreTcType in ty can only be a placeHolder + -- ; return (ViewPat expr' pat' ty) } + ; return (ViewPat expr' pat' placeHolderType) } rnPatAndThen mk (ConPatIn con stuff) -- rnConPatAndThen takes care of reconstructing the pattern @@ -423,8 +426,9 @@ rnPatAndThen mk (ListPat pats _ _) = do { opt_OverloadedLists <- liftCps $ xoptM Opt_OverloadedLists ; pats' <- rnLPatsAndThen mk pats ; case opt_OverloadedLists of - True -> do { (to_list_name,_) <- liftCps $ lookupSyntaxName toListName - ; return (ListPat pats' placeHolderType (Just (placeHolderType, to_list_name)))} + True -> do { (to_list_name,_) <- liftCps $ lookupSyntaxName toListName + ; return (ListPat pats' placeHolderType + (Just (placeHolderType, to_list_name)))} False -> return (ListPat pats' placeHolderType Nothing) } rnPatAndThen mk (PArrPat pats _) @@ -709,7 +713,8 @@ rnOverLit origLit HsVar v -> v /= std_name _ -> panic "rnOverLit" ; return (lit { ol_witness = from_thing_name - , ol_rebindable = rebindable }, fvs) } + , ol_rebindable = rebindable + , ol_type = placeHolderType }, fvs) } \end{code} %************************************************************************ diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index a3bd38a3ec..2dc71db001 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -515,7 +515,8 @@ rnFamInstDecl :: HsDocContext -> [LHsType RdrName] -> rhs -> (HsDocContext -> rhs -> RnM (rhs', FreeVars)) - -> RnM (Located Name, HsWithBndrs [LHsType Name], rhs', FreeVars) + -> RnM (Located Name, HsWithBndrs Name [LHsType Name], rhs', + FreeVars) rnFamInstDecl doc mb_cls tycon pats payload rnPayload = do { tycon' <- lookupFamInstName (fmap fst mb_cls) tycon ; let loc = case pats of diff --git a/compiler/rename/RnSplice.lhs b/compiler/rename/RnSplice.lhs index 3c0c145e6b..c7b962e5c8 100644 --- a/compiler/rename/RnSplice.lhs +++ b/compiler/rename/RnSplice.lhs @@ -14,6 +14,7 @@ import NameSet import HsSyn import RdrName import TcRnMonad +import Kind #ifdef GHCI import Control.Monad ( unless, when ) @@ -46,7 +47,8 @@ rnBracket e _ = failTH e "Template Haskell bracket" rnTopSpliceDecls :: HsSplice RdrName -> RnM ([LHsDecl RdrName], FreeVars) rnTopSpliceDecls e = failTH e "Template Haskell top splice" -rnSpliceType :: HsSplice RdrName -> PostTcKind -> RnM (HsType Name, FreeVars) +rnSpliceType :: HsSplice RdrName -> PostTc Name Kind + -> RnM (HsType Name, FreeVars) rnSpliceType e _ = failTH e "Template Haskell type splice" rnSpliceExpr :: Bool -> HsSplice RdrName -> RnM (HsExpr Name, FreeVars) @@ -169,7 +171,8 @@ rnSpliceExpr is_typed splice ; return (unLoc lexpr3, fvs) } ---------------------- -rnSpliceType :: HsSplice RdrName -> PostTcKind -> RnM (HsType Name, FreeVars) +rnSpliceType :: HsSplice RdrName -> PostTc Name Kind + -> RnM (HsType Name, FreeVars) rnSpliceType splice k = rnSpliceGen False run_type_splice pend_type_splice splice where diff --git a/compiler/rename/RnSplice.lhs-boot b/compiler/rename/RnSplice.lhs-boot index 5f417ae7fc..45a2a104c5 100644 --- a/compiler/rename/RnSplice.lhs-boot +++ b/compiler/rename/RnSplice.lhs-boot @@ -6,8 +6,11 @@ import TcRnMonad import RdrName import Name import NameSet +import Kind -rnSpliceType :: HsSplice RdrName -> PostTcKind -> RnM (HsType Name, FreeVars) + +rnSpliceType :: HsSplice RdrName -> PostTc Name Kind + -> RnM (HsType Name, FreeVars) rnSplicePat :: HsSplice RdrName -> RnM (Pat Name, FreeVars) rnSpliceDecl :: SpliceDecl RdrName -> RnM (SpliceDecl Name, FreeVars) \end{code} diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs index 2f9bfdd653..49eaa11fd5 100644 --- a/compiler/rename/RnTypes.lhs +++ b/compiler/rename/RnTypes.lhs @@ -417,8 +417,8 @@ newTyVarNameRn mb_assoc rdr_env loc rdr -------------------------------- rnHsBndrSig :: HsDocContext - -> HsWithBndrs (LHsType RdrName) - -> (HsWithBndrs (LHsType Name) -> RnM (a, FreeVars)) + -> HsWithBndrs RdrName (LHsType RdrName) + -> (HsWithBndrs Name (LHsType Name) -> RnM (a, FreeVars)) -> RnM (a, FreeVars) rnHsBndrSig doc (HsWB { hswb_cts = ty@(L loc _) }) thing_inside = do { sig_ok <- xoptM Opt_ScopedTypeVariables @@ -677,7 +677,8 @@ mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsCmdArrForm op1 (Just fix1) [a11,a12])) _ | associate_right = do new_c <- mkOpFormRn a12 op2 fix2 a2 return (HsCmdArrForm op1 (Just fix1) - [a11, L loc (HsCmdTop (L loc new_c) placeHolderType placeHolderType [])]) + [a11, L loc (HsCmdTop (L loc new_c) + placeHolderType placeHolderType [])]) -- TODO: locs are wrong where (nofix_error, associate_right) = compareFixity fix1 fix2 diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs index a27c0bd0f6..de2f26af85 100644 --- a/compiler/typecheck/Inst.lhs +++ b/compiler/typecheck/Inst.lhs @@ -34,8 +34,8 @@ module Inst ( #include "HsVersions.h" -import {-# SOURCE #-} TcExpr( tcPolyExpr, tcSyntaxOp ) -import {-# SOURCE #-} TcUnify( unifyType ) +import {-# SOURCE #-} TcExpr( tcPolyExpr, tcSyntaxOp ) +import {-# SOURCE #-} TcUnify( unifyType ) import FastString import HsSyn @@ -271,7 +271,8 @@ newOverloadedLit' dflags orig -- Reason: If we do, tcSimplify will call lookupInst, which -- will call tcSyntaxName, which does unification, -- which tcSimplify doesn't like - = return (lit { ol_witness = expr, ol_type = res_ty }) + = return (lit { ol_witness = expr, ol_type = res_ty + , ol_rebindable = rebindable }) | otherwise = do { hs_lit <- mkOverLit val @@ -282,7 +283,8 @@ newOverloadedLit' dflags orig -- whereas res_ty might be openTypeKind. This was a bug in 6.2.2 -- However this'll be picked up by tcSyntaxOp if necessary ; let witness = HsApp (noLoc fi') (noLoc (HsLit hs_lit)) - ; return (lit { ol_witness = witness, ol_type = res_ty }) } + ; return (lit { ol_witness = witness, ol_type = res_ty + , ol_rebindable = rebindable }) } ------------ mkOverLit :: OverLitVal -> TcM HsLit diff --git a/compiler/typecheck/TcArrows.lhs b/compiler/typecheck/TcArrows.lhs index eab8941956..a879e16e78 100644 --- a/compiler/typecheck/TcArrows.lhs +++ b/compiler/typecheck/TcArrows.lhs @@ -381,10 +381,12 @@ tcArrDoStmt env ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names ; let ret_table = zip tup_ids tup_rets ; let later_rets = [r | i <- later_ids, (j, r) <- ret_table, i == j] - ; return (emptyRecStmt { recS_stmts = stmts', recS_later_ids = later_ids - , recS_later_rets = later_rets - , recS_rec_ids = rec_ids, recS_rec_rets = rec_rets - , recS_ret_ty = res_ty }, thing) + ; return (emptyRecStmtId { recS_stmts = stmts' + , recS_later_ids = later_ids + , recS_later_rets = later_rets + , recS_rec_ids = rec_ids + , recS_rec_rets = rec_rets + , recS_ret_ty = res_ty }, thing) }} tcArrDoStmt _ _ stmt _ _ diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index 9db4125f4b..6feab9e728 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -1169,7 +1169,8 @@ tcRhs (TcFunBind (_,_,mono_id) loc inf matches) ; return (FunBind { fun_id = L loc mono_id, fun_infix = inf , fun_matches = matches' , fun_co_fn = co_fn - , bind_fvs = placeHolderNames, fun_tick = Nothing }) } + , bind_fvs = placeHolderNamesTc + , fun_tick = Nothing }) } tcRhs (TcPatBind infos pat' grhss pat_ty) = tcExtendIdBndrs [ TcIdBndr mono_id NotTopLevel | (_,_,mono_id) <- infos ] $ @@ -1178,7 +1179,7 @@ tcRhs (TcPatBind infos pat' grhss pat_ty) ; grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $ tcGRHSsPat grhss pat_ty ; return (PatBind { pat_lhs = pat', pat_rhs = grhss', pat_rhs_ty = pat_ty - , bind_fvs = placeHolderNames + , bind_fvs = placeHolderNamesTc , pat_ticks = (Nothing,[]) }) } diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs index 2967630da1..9802fb015d 100644 --- a/compiler/typecheck/TcGenDeriv.lhs +++ b/compiler/typecheck/TcGenDeriv.lhs @@ -12,6 +12,7 @@ This is where we do all the grimy bindings' generation. \begin{code} {-# LANGUAGE CPP, ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} module TcGenDeriv ( BagDerivStuff, DerivStuff(..), @@ -1747,7 +1748,8 @@ foldDataConArgs ft con -- the Just will match and a::* -- Make a HsLam using a fresh variable from a State monad -mkSimpleLam :: (LHsExpr id -> State [id] (LHsExpr id)) -> State [id] (LHsExpr id) +mkSimpleLam :: (LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName)) + -> State [RdrName] (LHsExpr RdrName) -- (mkSimpleLam fn) returns (\x. fn(x)) mkSimpleLam lam = do (n:names) <- get @@ -1755,7 +1757,9 @@ mkSimpleLam lam = do body <- lam (nlHsVar n) return (mkHsLam [nlVarPat n] body) -mkSimpleLam2 :: (LHsExpr id -> LHsExpr id -> State [id] (LHsExpr id)) -> State [id] (LHsExpr id) +mkSimpleLam2 :: (LHsExpr RdrName -> LHsExpr RdrName + -> State [RdrName] (LHsExpr RdrName)) + -> State [RdrName] (LHsExpr RdrName) mkSimpleLam2 lam = do (n1:n2:names) <- get put names diff --git a/compiler/typecheck/TcGenGenerics.lhs b/compiler/typecheck/TcGenGenerics.lhs index d4c3934053..acdd654603 100644 --- a/compiler/typecheck/TcGenGenerics.lhs +++ b/compiler/typecheck/TcGenGenerics.lhs @@ -7,7 +7,7 @@ The deriving code for the Generic class \begin{code} {-# LANGUAGE CPP, ScopedTypeVariables #-} - +{-# LANGUAGE FlexibleContexts #-} module TcGenGenerics (canDoGenerics, canDoGenerics1, GenericKind(..), diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index 39c0acf2a6..c4ed2a60b7 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -14,7 +14,7 @@ -- for details module TcHsType ( - tcHsSigType, tcHsSigTypeNC, tcHsDeriv, tcHsVectInst, + tcHsSigType, tcHsSigTypeNC, tcHsDeriv, tcHsVectInst, tcHsInstHead, UserTypeCtxt(..), @@ -1233,8 +1233,8 @@ Historical note: \begin{code} tcHsPatSigType :: UserTypeCtxt - -> HsWithBndrs (LHsType Name) -- The type signature - -> TcM ( Type -- The signature + -> HsWithBndrs Name (LHsType Name) -- The type signature + -> TcM ( Type -- The signature , [(Name, TcTyVar)] ) -- The new bit of type environment, binding -- the scoped type variables -- Used for type-checking type signatures in @@ -1263,7 +1263,7 @@ tcHsPatSigType ctxt (HsWB { hswb_cts = hs_ty, hswb_kvs = sig_kvs, hswb_tvs = sig _ -> newSigTyVar name kind -- See Note [Unifying SigTvs] tcPatSig :: UserTypeCtxt - -> HsWithBndrs (LHsType Name) + -> HsWithBndrs Name (LHsType Name) -> TcSigmaType -> TcM (TcType, -- The type to use for "inside" the signature [(Name, TcTyVar)], -- The new bit of type environment, binding diff --git a/compiler/typecheck/TcPatSyn.lhs b/compiler/typecheck/TcPatSyn.lhs index b5fbc295f5..6ae3ba0153 100644 --- a/compiler/typecheck/TcPatSyn.lhs +++ b/compiler/typecheck/TcPatSyn.lhs @@ -215,7 +215,7 @@ tcPatSynWrapper PSB{ psb_id = L loc name, psb_def = lpat, psb_dir = dir, psb_arg , fun_infix = False , fun_matches = mg , fun_co_fn = idHsWrapper - , bind_fvs = placeHolderNames + , bind_fvs = placeHolderNamesTc , fun_tick = Nothing }} where args = map unLoc $ case details of diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index cd27e9d044..9898b46066 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -1385,7 +1385,8 @@ tcUserStmt rdr_stmt@(L loc _) ; return stuff } where print_v = L loc $ BodyStmt (nlHsApp (nlHsVar printName) (nlHsVar v)) - (HsVar thenIOName) noSyntaxExpr placeHolderType + (HsVar thenIOName) noSyntaxExpr + placeHolderType -- | Typecheck the statements given and then return the results of the -- statement in the form 'IO [()]'. diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 6dcbaffef8..3c6aedb429 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -996,9 +996,9 @@ famTyConShape fam_tc , tyConKind fam_tc ) tc_fam_ty_pats :: FamTyConShape - -> HsWithBndrs [LHsType Name] -- Patterns - -> (TcKind -> TcM ()) -- Kind checker for RHS - -- result is ignored + -> HsWithBndrs Name [LHsType Name] -- Patterns + -> (TcKind -> TcM ()) -- Kind checker for RHS + -- result is ignored -> TcM ([Kind], [Type], Kind) -- Check the type patterns of a type or data family instance -- type instance F <pat1> <pat2> = <type> @@ -1045,8 +1045,8 @@ tc_fam_ty_pats (name, arity, kind) -- See Note [tc_fam_ty_pats vs tcFamTyPats] tcFamTyPats :: FamTyConShape - -> HsWithBndrs [LHsType Name] -- patterns - -> (TcKind -> TcM ()) -- kind-checker for RHS + -> HsWithBndrs Name [LHsType Name] -- patterns + -> (TcKind -> TcM ()) -- kind-checker for RHS -> ([TKVar] -- Kind and type variables -> [TcType] -- Kind and type arguments -> Kind -> TcM a) diff --git a/testsuite/tests/ghc-api/landmines/.gitignore b/testsuite/tests/ghc-api/landmines/.gitignore new file mode 100644 index 0000000000..1452e78bbd --- /dev/null +++ b/testsuite/tests/ghc-api/landmines/.gitignore @@ -0,0 +1,5 @@ +landmines +*.hi +*.o +*.run.* +*.normalised diff --git a/testsuite/tests/ghc-api/landmines/Makefile b/testsuite/tests/ghc-api/landmines/Makefile new file mode 100644 index 0000000000..3197647a49 --- /dev/null +++ b/testsuite/tests/ghc-api/landmines/Makefile @@ -0,0 +1,13 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +clean: + rm -f *.o *.hi + +landmines: clean + '$(TEST_HC)' $(TEST_HC_OPTS) --make -v0 -package ghc landmines + ./landmines "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" + + +.PHONY: clean diff --git a/testsuite/tests/ghc-api/landmines/MineFixity.hs b/testsuite/tests/ghc-api/landmines/MineFixity.hs new file mode 100644 index 0000000000..a735ee6aaf --- /dev/null +++ b/testsuite/tests/ghc-api/landmines/MineFixity.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeOperators #-} +{- + +Exercising avoidance of known landmines. + +We need one each of + + PostTc id Kind + PostTc id Type + + PostRn id Fixity + PostRn id NameSet + + +-} +module MineFixity where + +infixl 3 `foo` + +foo = undefined diff --git a/testsuite/tests/ghc-api/landmines/MineKind.hs b/testsuite/tests/ghc-api/landmines/MineKind.hs new file mode 100644 index 0000000000..c97a996c66 --- /dev/null +++ b/testsuite/tests/ghc-api/landmines/MineKind.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeOperators #-} +{- + +Exercising avoidance of known landmines. + +We need one each of + + PostTc id Kind + PostTc id Type + + PostRn id Fixity + PostRn id NameSet + + +-} +module MineKind where + +data HList :: [*] -> * where + HNil :: HList '[] + HCons :: a -> HList t -> HList (a ': t) + +data Tuple :: (*,*) -> * where + Tuple :: a -> b -> Tuple '(a,b) diff --git a/testsuite/tests/ghc-api/landmines/MineNames.hs b/testsuite/tests/ghc-api/landmines/MineNames.hs new file mode 100644 index 0000000000..af5362fc37 --- /dev/null +++ b/testsuite/tests/ghc-api/landmines/MineNames.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeOperators #-} +{- + +Exercising avoidance of known landmines. + +We need one each of + + PostTc id Kind + PostTc id Type + + PostRn id Fixity + PostRn id NameSet + + +-} +module MineNames where + +foo :: Int +foo = 1 diff --git a/testsuite/tests/ghc-api/landmines/MineType.hs b/testsuite/tests/ghc-api/landmines/MineType.hs new file mode 100644 index 0000000000..142d7c9af7 --- /dev/null +++ b/testsuite/tests/ghc-api/landmines/MineType.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeOperators #-} +{- + +Exercising avoidance of known landmines. + +We need one each of + + PostTc id Kind + PostTc id Type + + PostRn id Fixity + PostRn id NameSet + + +-} +module MineType where + +foo = undefined diff --git a/testsuite/tests/ghc-api/landmines/all.T b/testsuite/tests/ghc-api/landmines/all.T new file mode 100644 index 0000000000..b03a97f0ae --- /dev/null +++ b/testsuite/tests/ghc-api/landmines/all.T @@ -0,0 +1,2 @@ +test('landmines', normal, run_command, ['$MAKE -s --no-print-directory landmines']) + diff --git a/testsuite/tests/ghc-api/landmines/landmines.hs b/testsuite/tests/ghc-api/landmines/landmines.hs new file mode 100644 index 0000000000..9b058fa8a8 --- /dev/null +++ b/testsuite/tests/ghc-api/landmines/landmines.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE RankNTypes #-} + +-- This program must be called with GHC's libdir as the single command line +-- argument. +module Main where + +-- import Data.Generics +import Data.Data +import System.IO +import GHC +import MonadUtils +import Outputable +import Bag (filterBag,isEmptyBag) +import System.Directory (removeFile) +import System.Environment( getArgs ) + +main::IO() +main = do + [libdir] <- getArgs + testOneFile libdir "MineFixity" + testOneFile libdir "MineKind" + testOneFile libdir "MineNames" + testOneFile libdir "MineType" + + +testOneFile libdir fileName = do + (p,r,ts) <- runGhc (Just libdir) $ do + dflags <- getSessionDynFlags + setSessionDynFlags dflags + let mn =mkModuleName fileName + addTarget Target { targetId = TargetModule mn + , targetAllowObjCode = True + , targetContents = Nothing } + load LoadAllTargets + modSum <- getModSummary mn + p <- parseModule modSum + t <- typecheckModule p + d <- desugarModule t + l <- loadModule d + let ts=typecheckedSource l + r =renamedSource l + -- liftIO (putStr (showSDocDebug (ppr ts))) + return (pm_parsed_source p,r,ts) + let pCount = gq p + rCount = gq r + tsCount = gq ts + + print (pCount,rCount,tsCount) + where + gq ast = length $ everything (++) ([] `mkQ` worker) ast + + worker (s@(RealSrcSpan _)) = [s] + worker _ = [] + +-- --------------------------------------------------------------------- + +-- Copied from syb for the test + + +-- | Generic queries of type \"r\", +-- i.e., take any \"a\" and return an \"r\" +-- +type GenericQ r = forall a. Data a => a -> r + + +-- | Make a generic query; +-- start from a type-specific case; +-- return a constant otherwise +-- +mkQ :: ( Typeable a + , Typeable b + ) + => r + -> (b -> r) + -> a + -> r +(r `mkQ` br) a = case cast a of + Just b -> br b + Nothing -> r + + + +-- | Summarise all nodes in top-down, left-to-right order +everything :: (r -> r -> r) -> GenericQ r -> GenericQ r + +-- Apply f to x to summarise top-level node; +-- use gmapQ to recurse into immediate subterms; +-- use ordinary foldl to reduce list of intermediate results + +everything k f x = foldl k (f x) (gmapQ (everything k f) x) diff --git a/testsuite/tests/ghc-api/landmines/landmines.stdout b/testsuite/tests/ghc-api/landmines/landmines.stdout new file mode 100644 index 0000000000..5d9fd71ea2 --- /dev/null +++ b/testsuite/tests/ghc-api/landmines/landmines.stdout @@ -0,0 +1,4 @@ +(9,9,6) +(46,42,0) +(11,10,6) +(7,7,6) diff --git a/utils/haddock b/utils/haddock -Subproject eee52f697233f99e23c1d8183511229fb93e3f3 +Subproject aacaa91951b16f22e3ad54412974b81c32230a8 |