%
-% (c) The University of Glasgow, 1992-2003
+% (c) The University of Glasgow, 1992-2006
%
Here we collect a variety of helper functions that construct or
\begin{code}
module HsUtils where
-#include "HsVersions.h"
-
import HsBinds
import HsExpr
import HsPat
import HsTypes
import HsLit
-import RdrName ( RdrName, getRdrName, mkRdrUnqual )
-import Var ( Id )
-import Type ( Type )
-import DataCon ( DataCon, dataConWrapId, dataConSourceArity )
-import OccName ( mkVarOccFS )
-import Name ( Name )
-import BasicTypes ( RecFlag(..) )
+import RdrName
+import Var
+import Coercion
+import Type
+import DataCon
+import Name
+import BasicTypes
import SrcLoc
-import FastString ( mkFastString )
+import FastString
import Outputable
-import Util ( nOfThem )
+import Util
import Bag
\end{code}
mkHsPar :: LHsExpr id -> LHsExpr id
mkHsPar e = L (getLoc e) (HsPar e)
--- gaw 2004
mkSimpleMatch :: [LPat id] -> LHsExpr id -> LMatch id
mkSimpleMatch pats rhs
= L loc $
- Match pats Nothing (GRHSs (unguardedRHS rhs) emptyLocalBinds)
+ Match pats Nothing (unguardedGRHSs rhs)
where
loc = case pats of
[] -> getLoc rhs
(pat:_) -> combineSrcSpans (getLoc pat) (getLoc rhs)
+unguardedGRHSs :: LHsExpr id -> GRHSs id
+unguardedGRHSs rhs = GRHSs (unguardedRHS rhs) emptyLocalBinds
+
unguardedRHS :: LHsExpr id -> [LGRHS id]
unguardedRHS rhs@(L loc _) = [L loc (GRHS [] rhs)]
mkHsApp :: LHsExpr name -> LHsExpr name -> LHsExpr name
mkHsApp e1 e2 = addCLoc e1 e2 (HsApp e1 e2)
-mkHsTyApp :: LHsExpr name -> [Type] -> LHsExpr name
-mkHsTyApp expr [] = expr
-mkHsTyApp expr tys = L (getLoc expr) (TyApp expr tys)
+nlHsTyApp :: name -> [Type] -> LHsExpr name
+nlHsTyApp fun_id tys = noLoc (HsWrap (mkWpTyApps tys) (HsVar fun_id))
+
+mkLHsWrap :: HsWrapper -> LHsExpr id -> LHsExpr id
+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
-mkHsDictApp :: LHsExpr name -> [name] -> LHsExpr name
-mkHsDictApp expr [] = expr
-mkHsDictApp expr dict_vars = L (getLoc expr) (DictApp expr dict_vars)
+mkHsWrapCoI :: CoercionI -> HsExpr id -> HsExpr id
+mkHsWrapCoI IdCo e = e
+mkHsWrapCoI (ACo co) e = mkHsWrap (WpCast co) e
-mkHsCoerce :: ExprCoFn -> HsExpr id -> HsExpr id
-mkHsCoerce co_fn e | isIdCoercion co_fn = e
- | otherwise = HsCoerce co_fn e
+coiToHsWrapper :: CoercionI -> HsWrapper
+coiToHsWrapper IdCo = idHsWrapper
+coiToHsWrapper (ACo co) = WpCast co
mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id
mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches))
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)
-
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
val_binds = ValBindsOut [(Recursive, binds)] []
mkHsConApp :: DataCon -> [Type] -> [HsExpr Id] -> LHsExpr Id
--- Used for constructing dictinoary terms etc, so no locations
+-- Used for constructing dictionary terms etc, so no locations
mkHsConApp data_con tys args
- = foldl mk_app (noLoc (HsVar (dataConWrapId data_con)) `mkHsTyApp` tys) args
+ = foldl mk_app (nlHsTyApp (dataConWrapId data_con) tys) args
where
mk_app f a = noLoc (HsApp f (noLoc a))
-- These are the bits of syntax that contain rebindable names
-- See RnEnv.lookupSyntaxName
-mkHsIntegral i = HsIntegral i noSyntaxExpr
-mkHsFractional f = HsFractional f noSyntaxExpr
+mkHsIntegral :: Integer -> PostTcType -> HsOverLit id
+mkHsFractional :: Rational -> PostTcType -> HsOverLit id
+mkHsIsString :: FastString -> PostTcType -> HsOverLit id
+mkHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> HsExpr id
+
+mkNPat :: HsOverLit id -> Maybe (SyntaxExpr id) -> Pat id
+mkNPlusKPat :: Located id -> HsOverLit id -> Pat id
+
+mkTransformStmt :: [LStmt idL] -> LHsExpr idR -> StmtLR idL idR
+mkTransformByStmt :: [LStmt idL] -> LHsExpr idR -> LHsExpr idR -> StmtLR idL idR
+
+mkGroupUsingStmt :: [LStmt idL] -> LHsExpr idR -> StmtLR idL idR
+mkGroupByStmt :: [LStmt idL] -> LHsExpr idR -> StmtLR idL idR
+mkGroupByUsingStmt :: [LStmt idL] -> LHsExpr idR -> LHsExpr idR -> StmtLR idL idR
+
+mkExprStmt :: LHsExpr idR -> StmtLR idL idR
+mkBindStmt :: LPat idL -> LHsExpr idR -> StmtLR idL idR
+mkRecStmt :: [LStmtLR idL idR] -> StmtLR idL idR
+
+
+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;
+
mkHsDo ctxt stmts body = HsDo ctxt stmts body placeHolderType
-mkNPat lit neg = NPat lit neg noSyntaxExpr placeHolderType
+mkNPat lit neg = NPat lit neg noSyntaxExpr
mkNPlusKPat id lit = NPlusKPat id lit noSyntaxExpr noSyntaxExpr
+mkTransformStmt stmts usingExpr = TransformStmt (stmts, []) usingExpr Nothing
+mkTransformByStmt stmts usingExpr byExpr = TransformStmt (stmts, []) usingExpr (Just byExpr)
+
+mkGroupUsingStmt stmts usingExpr = GroupStmt (stmts, []) (GroupByNothing usingExpr)
+mkGroupByStmt stmts byExpr = GroupStmt (stmts, []) (GroupBySomething (Right noSyntaxExpr) byExpr)
+mkGroupByUsingStmt stmts byExpr usingExpr = GroupStmt (stmts, []) (GroupBySomething (Left usingExpr) byExpr)
+
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 :: LHsExpr id -> id -> LHsExpr id -> HsExpr id
mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar op)) (error "mkOpApp:fixity") e2
+mkHsSplice :: LHsExpr RdrName -> HsSplice RdrName
mkHsSplice e = HsSplice unqualSplice e
-unqualSplice = mkRdrUnqual (mkVarOccFS FSLIT("splice"))
+unqualSplice :: RdrName
+unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice"))
-- A name (uniquified later) to
-- identify the splice
+mkHsQuasiQuote :: RdrName -> SrcSpan -> FastString -> HsQuasiQuote RdrName
+mkHsQuasiQuote quoter span quote = HsQuasiQuote unqualQuasiQuote quoter span quote
+
+unqualQuasiQuote :: RdrName
+unqualQuasiQuote = mkRdrUnqual (mkVarOccFS (fsLit "quasiquote"))
+ -- A name (uniquified later) to
+ -- identify the quasi-quote
+
+mkHsString :: String -> HsLit
mkHsString s = HsString (mkFastString s)
-------------
nlHsApp :: LHsExpr id -> LHsExpr id -> LHsExpr id
nlHsApp f x = noLoc (HsApp f x)
+nlHsIntLit :: Integer -> LHsExpr id
nlHsIntLit n = noLoc (HsLit (HsInt n))
nlHsApps :: id -> [LHsExpr id] -> LHsExpr id
nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con))
(PrefixCon (nOfThem (dataConSourceArity con) nlWildPat)))
+nlTuplePat :: [LPat id] -> Boxity -> LPat id
nlTuplePat pats box = noLoc (TuplePat pats box placeHolderType)
+
+nlWildPat :: LPat id
nlWildPat = noLoc (WildPat placeHolderType) -- Pre-typechecking
nlHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> LHsExpr id
nlHsDo ctxt stmts body = noLoc (mkHsDo ctxt stmts body)
+nlHsOpApp :: LHsExpr id -> id -> LHsExpr id -> LHsExpr id
nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2)
+nlHsLam :: LMatch id -> LHsExpr id
+nlHsPar :: LHsExpr id -> LHsExpr id
+nlHsIf :: LHsExpr id -> LHsExpr id -> LHsExpr id -> LHsExpr id
+nlHsCase :: LHsExpr id -> [LMatch id] -> LHsExpr id
+nlTuple :: [LHsExpr id] -> Boxity -> LHsExpr id
+nlList :: [LHsExpr id] -> LHsExpr id
+
nlHsLam match = noLoc (HsLam (mkMatchGroup [match]))
nlHsPar e = noLoc (HsPar e)
nlHsIf cond true false = noLoc (HsIf cond true false)
nlTuple exprs box = noLoc (ExplicitTuple exprs box)
nlList exprs = noLoc (ExplicitList placeHolderType exprs)
+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)
+
+nlHsTyConApp :: name -> [LHsType name] -> LHsType name
+nlHsTyConApp tycon tys = foldl nlHsAppTy (nlHsTyVar tycon) tys
\end{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 }
+ fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames,
+ fun_tick = Nothing }
-mkVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> LHsBind RdrName
+mkVarBind :: SrcSpan -> id -> LHsExpr id -> LHsBind id
mkVarBind loc var rhs = mk_easy_FunBind loc var [] rhs
------------
-mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName]
- -> LHsExpr RdrName -> LHsBind RdrName
+mk_easy_FunBind :: SrcSpan -> id -> [LPat id]
+ -> LHsExpr id -> LHsBind id
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 -> id
+ -> [([LPat id], LHsExpr id)]
+ -> LHsBind id
-mk_FunBind loc fun [] = panic "TcGenDeriv:mk_FunBind"
+mk_FunBind _ _ [] = panic "TcGenDeriv:mk_FunBind"
mk_FunBind loc fun pats_and_exprs
= L loc $ mkFunBind (L loc fun) matches
where
it should return [x, y, f, a, b] (remember, order important).
\begin{code}
-collectLocalBinders :: HsLocalBinds name -> [Located name]
+collectLocalBinders :: HsLocalBindsLR idL idR -> [Located idL]
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
+collectHsValBinders :: HsValBindsLR idL idR -> [Located idL]
+collectHsValBinders (ValBindsIn binds _) = collectHsBindLocatedBinders binds
+collectHsValBinders (ValBindsOut binds _) = foldr collect_one [] binds
where
collect_one (_,binds) acc = foldrBag (collectAcc . unLoc) acc binds
-collectAcc :: HsBind name -> [Located name] -> [Located name]
+collectAcc :: HsBindLR idL idR -> [Located idL] -> [Located idL]
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
+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 :: LHsBinds name -> [name]
+collectHsBindBinders :: LHsBindsLR idL idR -> [idL]
collectHsBindBinders binds = map unLoc (collectHsBindLocatedBinders binds)
-collectHsBindLocatedBinders :: LHsBinds name -> [Located name]
+collectHsBindLocatedBinders :: LHsBindsLR idL idR -> [Located idL]
collectHsBindLocatedBinders binds = foldrBag (collectAcc . unLoc) [] binds
\end{code}
%************************************************************************
\begin{code}
-collectLStmtsBinders :: [LStmt id] -> [Located id]
+collectLStmtsBinders :: [LStmtLR idL idR] -> [Located idL]
collectLStmtsBinders = concatMap collectLStmtBinders
-collectStmtsBinders :: [Stmt id] -> [Located id]
+collectStmtsBinders :: [StmtLR idL idR] -> [Located idL]
collectStmtsBinders = concatMap collectStmtBinders
-collectLStmtBinders :: LStmt id -> [Located id]
+collectLStmtBinders :: LStmtLR idL idR -> [Located idL]
collectLStmtBinders = collectStmtBinders . unLoc
-collectStmtBinders :: Stmt id -> [Located id]
+collectStmtBinders :: StmtLR idL idR -> [Located idL]
-- 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"
+collectStmtBinders (ExprStmt _ _ _) = []
+collectStmtBinders (ParStmt xs) = collectLStmtsBinders
+ $ concatMap fst xs
+collectStmtBinders (TransformStmt (stmts, _) _ _) = collectLStmtsBinders stmts
+collectStmtBinders (GroupStmt (stmts, _) _) = collectLStmtsBinders stmts
+collectStmtBinders (RecStmt ss _ _ _ _) = collectLStmtsBinders ss
\end{code}
collectLocatedPatsBinders pats = foldr collectl [] pats
---------------------
+collectl :: LPat name -> [Located name] -> [Located name]
collectl (L l pat) bndrs
= go pat
where
go (LazyPat pat) = collectl pat bndrs
go (BangPat pat) = collectl pat bndrs
go (AsPat a pat) = a : collectl pat bndrs
+ go (ViewPat _ pat _) = 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 (ConPatIn _ ps) = foldr collectl bndrs (hsConPatArgs ps)
+ go (ConPatOut {pat_args=ps}) = foldr collectl bndrs (hsConPatArgs ps)
+ -- See Note [Dictionary binders in ConPatOut]
go (LitPat _) = bndrs
- go (NPat _ _ _ _) = 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
- go (CoPat _ pat ty) = collectl (noLoc pat) bndrs
+ go (QuasiQuotePat _) = bndrs
+ go (TypePat _) = bndrs
+ go (CoPat _ pat _) = collectl (noLoc pat) bndrs
\end{code}
+Note [Dictionary binders in ConPatOut]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Do *not* gather (a) dictionary and (b) dictionary bindings as binders
+of a ConPatOut pattern. For most calls it doesn't matter, because
+it's pre-typechecker and there are no ConPatOuts. But it does matter
+more in the desugarer; for example, DsUtils.mkSelectorBinds uses
+collectPatBinders. In a lazy pattern, for example f ~(C x y) = ...,
+we want to generate bindings for x,y but not for dictionaries bound by
+C. (The type checker ensures they would not be used.)
+
+Desugaring of arrow case expressions needs these bindings (see DsArrows
+and arrowcase1), but SPJ (Jan 2007) says it's safer for it to use its
+own pat-binder-collector:
+
+Here's the problem. Consider
+
+data T a where
+ C :: Num a => a -> Int -> T a
+
+f ~(C (n+1) m) = (n,m)
+
+Here, the pattern (C (n+1)) binds a hidden dictionary (d::Num a),
+and *also* uses that dictionary to match the (n+1) pattern. Yet, the
+variables bound by the lazy pattern are n,m, *not* the dictionary d.
+So in mkSelectorBinds in DsUtils, we want just m,n as the variables bound.
+
\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 :: InPat name -> [LHsType name] -> [LHsType name]
collect_lpat pat acc = collect_pat (unLoc pat) acc
+collect_pat :: Pat name -> [LHsType name] -> [LHsType name]
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 (BangPat pat) acc = collect_lpat pat acc
-collect_pat (AsPat a pat) acc = collect_lpat pat acc
+collect_pat (AsPat _ 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
+collect_pat (ConPatIn _ ps) acc = foldr collect_lpat acc (hsConPatArgs ps)
+collect_pat _ acc = acc -- Literals, vars, wildcard
\end{code}
projects / ghc-hetmet.git / blobdiff