%
-% (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
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 HsDecls
+
+import RdrName
+import Var
+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))
-mkHsDictApp :: LHsExpr name -> [name] -> LHsExpr name
-mkHsDictApp expr [] = expr
-mkHsDictApp expr dict_vars = L (getLoc expr) (DictApp expr dict_vars)
+mkLHsWrap :: HsWrapper -> LHsExpr id -> LHsExpr id
+mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e)
-mkHsCoerce :: ExprCoFn -> HsExpr id -> HsExpr id
-mkHsCoerce co_fn e | isIdCoercion co_fn = e
- | otherwise = HsCoerce co_fn e
+mkHsWrap :: HsWrapper -> HsExpr id -> HsExpr id
+mkHsWrap co_fn e | isIdHsWrapper co_fn = e
+ | otherwise = HsWrap co_fn e
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
mkHsConApp :: DataCon -> [Type] -> [HsExpr Id] -> LHsExpr Id
-- Used for constructing dictinoary 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))
nlHsAppTy f t = noLoc (HsAppTy f t)
nlHsTyVar x = noLoc (HsTyVar x)
nlHsFunTy a b = noLoc (HsFunTy a b)
+
+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
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 (ConPatOut {pat_args=ps}) = foldr collectl bndrs (hsConArgs ps)
+ -- See Note [Dictionary binders in ConPatOut]
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 (CoPat _ pat ty) = 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.)
+
\begin{code}
collectSigTysFromPats :: [InPat name] -> [LHsType name]
collectSigTysFromPats pats = foldr collect_lpat [] pats
collect_pat (ConPatIn c ps) acc = foldr collect_lpat acc (hsConArgs ps)
collect_pat other acc = acc -- Literals, vars, wildcard
\end{code}
+
+%************************************************************************
+%* *
+%* Getting the main binder name of a top declaration
+%* *
+%************************************************************************
+
+\begin{code}
+
+getMainDeclBinder :: HsDecl name -> Maybe name
+getMainDeclBinder (TyClD d) = Just (tcdName d)
+getMainDeclBinder (ValD d)
+ = case collectAcc d [] of
+ [] -> Nothing -- see rn003
+ (name:_) -> Just (unLoc name)
+getMainDeclBinder (SigD d) = sigNameNoLoc d
+getMainDeclBinder (ForD (ForeignImport name _ _)) = Just (unLoc name)
+getMainDeclBinder (ForD (ForeignExport name _ _)) = Just (unLoc name)
+getMainDeclBinder _ = Nothing
+
+\end{code}
projects / ghc-hetmet.git / blobdiff