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
mkSimpleMatch :: [LPat id] -> LHsExpr id -> LMatch id
mkSimpleMatch pats rhs
= L loc $
- Match pats Nothing (GRHSs (unguardedRHS rhs) [])
+ 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)
mkHsDictLam [] expr = expr
mkHsDictLam dicts expr = L (getLoc expr) (DictLam dicts expr)
-mkHsLet :: LHsBinds name -> LHsExpr name -> LHsExpr name
-mkHsLet binds 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 [HsBindGroup binds [] Recursive] 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 pat expr
= mkSimpleMatch [pat] expr
-glueBindsOnGRHSs :: HsBindGroup id -> GRHSs id -> GRHSs id
--- gaw 2004
-glueBindsOnGRHSs binds1 (GRHSs grhss binds2)
- = GRHSs grhss (binds1 : binds2)
-
+-------------------------------
-- 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}
nlTuplePat pats box = noLoc (TuplePat pats box)
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)
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}
mkVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> LHsBind RdrName
-mkVarBind loc var rhs = mk_easy_FunBind loc var [] emptyLHsBinds rhs
+mkVarBind loc var rhs = mk_easy_FunBind loc var [] rhs
+------------
mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName]
- -> LHsBinds RdrName -> LHsExpr RdrName
- -> LHsBind RdrName
+ -> LHsExpr RdrName -> LHsBind RdrName
-mk_easy_FunBind loc fun pats binds expr
- = L loc (FunBind (L loc fun) False{-not infix-}
- (mkMatchGroup [mk_easy_Match pats binds expr]))
-
-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 (FunBind (L loc fun) False{-not infix-} matches placeHolderNames)
+ where
+ matches = mkMatchGroup [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-}
- (mkMatchGroup [mkMatch p e [] | (p,e) <-pats_and_exprs]))
+ = L loc (FunBind (L loc fun) False{-not infix-} matches placeHolderNames)
+ where
+ matches = mkMatchGroup [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
--- gaw 2004
(GRHSs (unguardedRHS expr) binds))
where
paren p = case p of
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 _ _ _) 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
-- ++ 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}
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)
+collectSigTysFromHsBinds :: LHsBinds name -> [LHsType name]
+collectSigTysFromHsBinds binds = concatMap collectSigTysFromHsBind (bagToList binds)
collectSigTysFromHsBind :: LHsBind name -> [LHsType name]
collectSigTysFromHsBind bind
= go (unLoc bind)
where
- go (PatBind pat _ _)
+ go (PatBind pat _ _ _)
= collectSigTysFromPat pat
- go (FunBind f _ (MatchGroup ms _))
+ go (FunBind f _ (MatchGroup ms _) _)
= [sig | L _ (Match [] (Just sig) _) <- 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 out_bind = panic "collectSigTysFromHsBind"
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-collectStmtsBinders :: [LStmt id] -> [Located id]
-collectStmtsBinders = concatMap collectLStmtBinders
+collectLStmtsBinders :: [LStmt id] -> [Located id]
+collectLStmtsBinders = concatMap collectLStmtBinders
+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) = collectGroupBinders binds
-collectStmtBinders (ExprStmt _ _) = []
-collectStmtBinders (ResultStmt _) = []
-collectStmtBinders (RecStmt ss _ _ _) = collectStmtsBinders ss
-collectStmtBinders other = panic "collectStmtBinders"
+collectStmtBinders (BindStmt pat _ _ _) = collectLocatedPatBinders pat
+collectStmtBinders (LetStmt binds) = collectLocalBinders binds
+collectStmtBinders (ExprStmt _ _ _) = []
+collectStmtBinders (RecStmt ss _ _ _ _) = collectLStmtsBinders ss
+collectStmtBinders other = panic "collectStmtBinders"
\end{code}
collectLocatedPatsBinders pats = foldr collectl [] pats
---------------------
-collectl (L l (VarPat var)) bndrs = L l var : bndrs
-collectl (L l (VarPatOut var bs)) bndrs = L l var : collectHsBindLocatedBinders bs
- ++ bndrs
-collectl (L l pat) bndrs = collect pat bndrs
-
----------------------
-collect (WildPat _) bndrs = bndrs
-collect (LazyPat pat) bndrs = collectl pat bndrs
-collect (AsPat a pat) bndrs = a : collectl pat bndrs
-collect (ParPat pat) bndrs = collectl pat bndrs
-
-collect (ListPat pats _) bndrs = foldr collectl bndrs pats
-collect (PArrPat pats _) bndrs = foldr collectl bndrs pats
-collect (TuplePat pats _) bndrs = foldr collectl bndrs pats
-
-collect (ConPatIn c ps) bndrs = foldr collectl bndrs (hsConArgs ps)
-collect (ConPatOut c _ ds bs ps _) bndrs = map noLoc ds
- ++ collectHsBindLocatedBinders bs
- ++ foldr collectl bndrs (hsConArgs ps)
-collect (LitPat _) bndrs = bndrs
-collect (NPatIn _ _) bndrs = bndrs
-collect (NPatOut _ _ _) bndrs = bndrs
-
-collect (NPlusKPatIn n _ _) bndrs = n : bndrs
-collect (NPlusKPatOut n _ _ _) bndrs = n : bndrs
-
-collect (SigPatIn pat _) bndrs = collectl pat bndrs
-collect (SigPatOut pat _) bndrs = collectl pat bndrs
-collect (TypePat ty) bndrs = bndrs
-collect (DictPat ids1 ids2) bndrs = map noLoc ids1 ++ map noLoc ids2
- ++ bndrs
+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}
projects / ghc-hetmet.git / blobdiff