import Var ( Id )
import Type ( Type )
import DataCon ( DataCon, dataConWrapId, dataConSourceArity )
-import BasicTypes ( RecFlag(..) )
-import OccName ( mkVarOcc )
+import OccName ( mkVarOccFS )
import Name ( Name )
+import BasicTypes ( RecFlag(..) )
import SrcLoc
import FastString ( mkFastString )
import Outputable
mkHsPar :: LHsExpr id -> LHsExpr id
mkHsPar e = L (getLoc e) (HsPar e)
-mkSimpleMatch :: [LPat id] -> LHsExpr id -> Type -> LMatch id
-mkSimpleMatch pats rhs rhs_ty
- = addCLoc (head pats) rhs $
- Match pats Nothing (GRHSs (unguardedRHS rhs) [] rhs_ty)
+-- gaw 2004
+mkSimpleMatch :: [LPat id] -> LHsExpr id -> LMatch id
+mkSimpleMatch pats rhs
+ = L loc $
+ Match pats Nothing (GRHSs (unguardedRHS rhs) emptyLocalBinds)
+ where
+ loc = case pats of
+ [] -> getLoc rhs
+ (pat:_) -> combineSrcSpans (getLoc pat) (getLoc rhs)
unguardedRHS :: LHsExpr id -> [LGRHS id]
-unguardedRHS rhs@(L loc _) = [L loc (GRHS [L loc (ResultStmt rhs)])]
+unguardedRHS rhs@(L loc _) = [L loc (GRHS [] rhs)]
mkHsAppTy :: LHsType name -> LHsType name -> LHsType name
mkHsAppTy t1 t2 = addCLoc t1 t2 (HsAppTy t1 t2)
mkHsTyApp expr [] = expr
mkHsTyApp expr tys = L (getLoc expr) (TyApp expr tys)
+mkHsDictApp :: LHsExpr name -> [name] -> LHsExpr name
mkHsDictApp expr [] = expr
mkHsDictApp expr dict_vars = L (getLoc expr) (DictApp expr dict_vars)
+mkHsCoerce :: ExprCoFn -> HsExpr id -> HsExpr id
+mkHsCoerce co_fn e | isIdCoercion co_fn = e
+ | otherwise = HsCoerce co_fn e
+
mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id
-mkHsLam pats body = mkHsPar (L (getLoc match) (HsLam match))
+mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches))
where
- match = mkSimpleMatch pats body placeHolderType
+ matches = mkMatchGroup [mkSimpleMatch pats body]
+
+mkMatchGroup :: [LMatch id] -> MatchGroup id
+mkMatchGroup matches = MatchGroup matches placeHolderType
mkHsTyLam [] expr = expr
mkHsTyLam tyvars expr = L (getLoc expr) (TyLam tyvars expr)
mkHsDictLam [] expr = expr
mkHsDictLam dicts expr = L (getLoc expr) (DictLam dicts expr)
-mkHsLet :: Bag (LHsBind name) -> LHsExpr name -> LHsExpr name
-mkHsLet binds expr
- | isEmptyBag binds = expr
- | otherwise = L (getLoc expr) (HsLet [HsBindGroup binds [] Recursive] expr)
+mkHsDictLet :: LHsBinds Id -> LHsExpr Id -> LHsExpr Id
+-- Used for the dictionary bindings gotten from TcSimplify
+-- We make them recursive to be on the safe side
+mkHsDictLet binds expr
+ | isEmptyLHsBinds binds = expr
+ | otherwise = L (getLoc expr) (HsLet (HsValBinds val_binds) expr)
+ where
+ val_binds = ValBindsOut [(Recursive, binds)] []
mkHsConApp :: DataCon -> [Type] -> [HsExpr Id] -> LHsExpr Id
-- Used for constructing dictinoary terms etc, so no locations
mkSimpleHsAlt :: LPat id -> LHsExpr id -> LMatch id
-- A simple lambda with a single pattern, no binds, no guards; pre-typechecking
mkSimpleHsAlt pat expr
- = mkSimpleMatch [pat] expr placeHolderType
-
-glueBindsOnGRHSs :: HsBindGroup id -> GRHSs id -> GRHSs id
-glueBindsOnGRHSs binds1 (GRHSs grhss binds2 ty)
- = GRHSs grhss (binds1 : binds2) ty
+ = mkSimpleMatch [pat] expr
+-------------------------------
-- These are the bits of syntax that contain rebindable names
-- See RnEnv.lookupSyntaxName
-mkHsIntegral i = HsIntegral i placeHolderName
-mkHsFractional f = HsFractional f placeHolderName
-mkNPlusKPat n k = NPlusKPatIn n k placeHolderName
-mkHsDo ctxt stmts = HsDo ctxt stmts [] placeHolderType
+mkHsIntegral i = HsIntegral i noSyntaxExpr
+mkHsFractional f = HsFractional f noSyntaxExpr
+mkHsDo ctxt stmts body = HsDo ctxt stmts body placeHolderType
+mkNPat lit neg = NPat lit neg noSyntaxExpr placeHolderType
+mkNPlusKPat id lit = NPlusKPat id lit noSyntaxExpr noSyntaxExpr
+
+mkExprStmt expr = ExprStmt expr noSyntaxExpr placeHolderType
+mkBindStmt pat expr = BindStmt pat expr noSyntaxExpr noSyntaxExpr
+mkRecStmt stmts = RecStmt stmts [] [] [] emptyLHsBinds
+
+-------------------------------
--- A useful function for building @OpApps@. The operator is always a
-- variable, and we don't know the fixity yet.
mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar op)) (error "mkOpApp:fixity") e2
mkHsSplice e = HsSplice unqualSplice e
-unqualSplice = mkRdrUnqual (mkVarOcc FSLIT("splice"))
+unqualSplice = mkRdrUnqual (mkVarOccFS FSLIT("splice"))
-- A name (uniquified later) to
-- identify the splice
mkHsString s = HsString (mkFastString s)
+
+-------------
+userHsTyVarBndrs :: [Located name] -> [Located (HsTyVarBndr name)]
+userHsTyVarBndrs bndrs = [ L loc (UserTyVar v) | L loc v <- bndrs ]
\end{code}
nlWildConPat :: DataCon -> LPat RdrName
nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con))
- (PrefixCon (nOfThem (dataConSourceArity con) wildPat)))
+ (PrefixCon (nOfThem (dataConSourceArity con) nlWildPat)))
-nlTuplePat pats box = noLoc (TuplePat pats box)
-wildPat = noLoc (WildPat placeHolderType) -- Pre-typechecking
+nlTuplePat pats box = noLoc (TuplePat pats box placeHolderType)
+nlWildPat = noLoc (WildPat placeHolderType) -- Pre-typechecking
-nlHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id
-nlHsDo ctxt stmts = noLoc (mkHsDo ctxt stmts)
+nlHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> LHsExpr id
+nlHsDo ctxt stmts body = noLoc (mkHsDo ctxt stmts body)
nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2)
-nlHsLam match = noLoc (HsLam match)
+nlHsLam match = noLoc (HsLam (mkMatchGroup [match]))
nlHsPar e = noLoc (HsPar e)
nlHsIf cond true false = noLoc (HsIf cond true false)
-nlHsCase expr matches = noLoc (HsCase expr matches)
+nlHsCase expr matches = noLoc (HsCase expr (mkMatchGroup matches))
nlTuple exprs box = noLoc (ExplicitTuple exprs box)
nlList exprs = noLoc (ExplicitList placeHolderType exprs)
nlHsAppTy f t = noLoc (HsAppTy f t)
nlHsTyVar x = noLoc (HsTyVar x)
nlHsFunTy a b = noLoc (HsFunTy a b)
-
-nlExprStmt expr = noLoc (ExprStmt expr placeHolderType)
-nlBindStmt pat expr = noLoc (BindStmt pat expr)
-nlLetStmt binds = noLoc (LetStmt binds)
-nlResultStmt expr = noLoc (ResultStmt expr)
-nlParStmt stuff = noLoc (ParStmt stuff)
\end{code}
%************************************************************************
\begin{code}
+mkFunBind :: Located id -> [LMatch id] -> HsBind id
+-- Not infix, with place holders for coercion and free vars
+mkFunBind fn ms = FunBind { fun_id = fn, fun_infix = False, fun_matches = mkMatchGroup ms,
+ fun_co_fn = idCoercion, bind_fvs = placeHolderNames }
+
+
mkVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> LHsBind RdrName
-mkVarBind loc var rhs = mk_easy_FunBind loc var [] emptyBag rhs
+mkVarBind loc var rhs = mk_easy_FunBind loc var [] rhs
+------------
mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName]
- -> LHsBinds RdrName -> LHsExpr RdrName
- -> LHsBind RdrName
-
-mk_easy_FunBind loc fun pats binds expr
- = L loc (FunBind (L loc fun) False{-not infix-}
- [mk_easy_Match pats binds expr])
+ -> LHsExpr RdrName -> LHsBind RdrName
-mk_easy_Match pats binds expr
- = mkMatch pats expr [HsBindGroup binds [] Recursive]
- -- The renamer expects everything in its input to be a
- -- "recursive" MonoBinds, and it is its job to sort things out
- -- from there.
+mk_easy_FunBind loc fun pats expr
+ = L loc $ mkFunBind (L loc fun) [mkMatch pats expr emptyLocalBinds]
-mk_FunBind :: SrcSpan
- -> RdrName
- -> [([LPat RdrName], LHsExpr RdrName)]
- -> LHsBind RdrName
+------------
+mk_FunBind :: SrcSpan -> RdrName
+ -> [([LPat RdrName], LHsExpr RdrName)]
+ -> LHsBind RdrName
mk_FunBind loc fun [] = panic "TcGenDeriv:mk_FunBind"
mk_FunBind loc fun pats_and_exprs
- = L loc (FunBind (L loc fun) False{-not infix-}
- [mkMatch p e [] | (p,e) <-pats_and_exprs])
+ = L loc $ mkFunBind (L loc fun) matches
+ where
+ matches = [mkMatch p e emptyLocalBinds | (p,e) <-pats_and_exprs]
-mkMatch :: [LPat id] -> LHsExpr id -> [HsBindGroup id] -> LMatch id
+------------
+mkMatch :: [LPat id] -> LHsExpr id -> HsLocalBinds id -> LMatch id
mkMatch pats expr binds
= noLoc (Match (map paren pats) Nothing
- (GRHSs (unguardedRHS expr) binds placeHolderType))
+ (GRHSs (unguardedRHS expr) binds))
where
paren p = case p of
L _ (VarPat _) -> p
it should return [x, y, f, a, b] (remember, order important).
\begin{code}
-collectGroupBinders :: [HsBindGroup name] -> [Located name]
-collectGroupBinders groups = foldr collect_group [] groups
- where
- collect_group (HsBindGroup bag sigs is_rec) acc
- = foldrBag (collectAcc . unLoc) acc bag
- collect_group (HsIPBinds _) acc = acc
-
+collectLocalBinders :: HsLocalBinds name -> [Located name]
+collectLocalBinders (HsValBinds val_binds) = collectHsValBinders val_binds
+collectLocalBinders (HsIPBinds _) = []
+collectLocalBinders EmptyLocalBinds = []
+
+collectHsValBinders :: HsValBinds name -> [Located name]
+collectHsValBinders (ValBindsIn binds sigs) = collectHsBindLocatedBinders binds
+collectHsValBinders (ValBindsOut binds sigs) = foldr collect_one [] binds
+ where
+ collect_one (_,binds) acc = foldrBag (collectAcc . unLoc) acc binds
collectAcc :: HsBind name -> [Located name] -> [Located name]
-collectAcc (PatBind pat _) acc = collectLocatedPatBinders pat ++ acc
-collectAcc (FunBind f _ _) acc = f : acc
-collectAcc (VarBind f _) acc = noLoc f : acc
-collectAcc (AbsBinds _ _ dbinds _ binds) acc
- = [noLoc dp | (_,dp,_) <- dbinds] ++ acc
+collectAcc (PatBind { pat_lhs = p }) acc = collectLocatedPatBinders p ++ acc
+collectAcc (FunBind { fun_id = f }) acc = f : acc
+collectAcc (VarBind { var_id = f }) acc = noLoc f : acc
+collectAcc (AbsBinds { abs_exports = dbinds, abs_binds = binds }) acc
+ = [noLoc dp | (_,dp,_,_) <- dbinds] ++ acc
-- ++ foldr collectAcc acc binds
-- I don't think we want the binders from the nested binds
-- The only time we collect binders from a typechecked
-- binding (hence see AbsBinds) is in zonking in TcHsSyn
-collectHsBindBinders :: Bag (LHsBind name) -> [name]
+collectHsBindBinders :: LHsBinds name -> [name]
collectHsBindBinders binds = map unLoc (collectHsBindLocatedBinders binds)
-collectHsBindLocatedBinders :: Bag (LHsBind name) -> [Located name]
+collectHsBindLocatedBinders :: LHsBinds name -> [Located name]
collectHsBindLocatedBinders binds = foldrBag (collectAcc . unLoc) [] binds
\end{code}
%************************************************************************
%* *
- Getting pattern signatures out of bindings
+ Getting binders from statements
%* *
%************************************************************************
-Get all the pattern type signatures out of a bunch of bindings
-
\begin{code}
-collectSigTysFromHsBinds :: [LHsBind name] -> [LHsType name]
-collectSigTysFromHsBinds binds = concat (map collectSigTysFromHsBind binds)
+collectLStmtsBinders :: [LStmt id] -> [Located id]
+collectLStmtsBinders = concatMap collectLStmtBinders
-collectSigTysFromHsBind :: LHsBind name -> [LHsType name]
-collectSigTysFromHsBind bind
- = go (unLoc bind)
- where
- go (PatBind pat _) = collectSigTysFromPat pat
- go (FunBind f _ ms) = go_matches (map unLoc ms)
-
- -- A binding like x :: a = f y
- -- is parsed as FunMonoBind, but for this purpose we
- -- want to treat it as a pattern binding
- go_matches [] = []
- go_matches (Match [] (Just sig) _ : matches) = sig : go_matches matches
- go_matches (match : matches) = go_matches matches
+collectStmtsBinders :: [Stmt id] -> [Located id]
+collectStmtsBinders = concatMap collectStmtBinders
+
+collectLStmtBinders :: LStmt id -> [Located id]
+collectLStmtBinders = collectStmtBinders . unLoc
+
+collectStmtBinders :: Stmt id -> [Located id]
+ -- Id Binders for a Stmt... [but what about pattern-sig type vars]?
+collectStmtBinders (BindStmt pat _ _ _) = collectLocatedPatBinders pat
+collectStmtBinders (LetStmt binds) = collectLocalBinders binds
+collectStmtBinders (ExprStmt _ _ _) = []
+collectStmtBinders (RecStmt ss _ _ _ _) = collectLStmtsBinders ss
+collectStmtBinders other = panic "collectStmtBinders"
\end{code}
+
%************************************************************************
%* *
- Getting binders from statements
+%* Gathering stuff out of patterns
%* *
%************************************************************************
+This function @collectPatBinders@ works with the ``collectBinders''
+functions for @HsBinds@, etc. The order in which the binders are
+collected is important; see @HsBinds.lhs@.
+
+It collects the bounds *value* variables in renamed patterns; type variables
+are *not* collected.
+
\begin{code}
-collectStmtsBinders :: [LStmt id] -> [Located id]
-collectStmtsBinders = concatMap collectLStmtBinders
+collectPatBinders :: LPat a -> [a]
+collectPatBinders pat = map unLoc (collectLocatedPatBinders pat)
-collectLStmtBinders = collectStmtBinders . unLoc
+collectLocatedPatBinders :: LPat a -> [Located a]
+collectLocatedPatBinders pat = collectl pat []
-collectStmtBinders :: Stmt id -> [Located id]
- -- Id Binders for a Stmt... [but what about pattern-sig type vars]?
-collectStmtBinders (BindStmt pat _) = collectLocatedPatBinders pat
-collectStmtBinders (LetStmt binds) = collectGroupBinders binds
-collectStmtBinders (ExprStmt _ _) = []
-collectStmtBinders (ResultStmt _) = []
-collectStmtBinders (RecStmt ss _ _ _) = collectStmtsBinders ss
-collectStmtBinders other = panic "collectStmtBinders"
+collectPatsBinders :: [LPat a] -> [a]
+collectPatsBinders pats = map unLoc (collectLocatedPatsBinders pats)
+
+collectLocatedPatsBinders :: [LPat a] -> [Located a]
+collectLocatedPatsBinders pats = foldr collectl [] pats
+
+---------------------
+collectl (L l pat) bndrs
+ = go pat
+ where
+ go (VarPat var) = L l var : bndrs
+ go (VarPatOut var bs) = L l var : collectHsBindLocatedBinders bs
+ ++ bndrs
+ go (WildPat _) = bndrs
+ go (LazyPat pat) = collectl pat bndrs
+ go (AsPat a pat) = a : collectl pat bndrs
+ go (ParPat pat) = collectl pat bndrs
+
+ go (ListPat pats _) = foldr collectl bndrs pats
+ go (PArrPat pats _) = foldr collectl bndrs pats
+ go (TuplePat pats _ _) = foldr collectl bndrs pats
+
+ go (ConPatIn c ps) = foldr collectl bndrs (hsConArgs ps)
+ go (ConPatOut c _ ds bs ps _) = map noLoc ds
+ ++ collectHsBindLocatedBinders bs
+ ++ foldr collectl bndrs (hsConArgs ps)
+ go (LitPat _) = bndrs
+ go (NPat _ _ _ _) = bndrs
+ go (NPlusKPat n _ _ _) = n : bndrs
+
+ go (SigPatIn pat _) = collectl pat bndrs
+ go (SigPatOut pat _) = collectl pat bndrs
+ go (TypePat ty) = bndrs
+ go (DictPat ids1 ids2) = map noLoc ids1 ++ map noLoc ids2
+ ++ bndrs
+\end{code}
+
+\begin{code}
+collectSigTysFromPats :: [InPat name] -> [LHsType name]
+collectSigTysFromPats pats = foldr collect_lpat [] pats
+
+collectSigTysFromPat :: InPat name -> [LHsType name]
+collectSigTysFromPat pat = collect_lpat pat []
+
+collect_lpat pat acc = collect_pat (unLoc pat) acc
+
+collect_pat (SigPatIn pat ty) acc = collect_lpat pat (ty:acc)
+collect_pat (TypePat ty) acc = ty:acc
+
+collect_pat (LazyPat pat) acc = collect_lpat pat acc
+collect_pat (AsPat a pat) acc = collect_lpat pat acc
+collect_pat (ParPat pat) acc = collect_lpat pat acc
+collect_pat (ListPat pats _) acc = foldr collect_lpat acc pats
+collect_pat (PArrPat pats _) acc = foldr collect_lpat acc pats
+collect_pat (TuplePat pats _ _) acc = foldr collect_lpat acc pats
+collect_pat (ConPatIn c ps) acc = foldr collect_lpat acc (hsConArgs ps)
+collect_pat other acc = acc -- Literals, vars, wildcard
\end{code}
projects / ghc-hetmet.git / blobdiff