Big tidy-up of deriving code

[ghc-hetmet.git] / compiler / hsSyn / HsUtils.lhs

diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs
index 1839aef..b80145a 100644 (file)
--- a/compiler/hsSyn/HsUtils.lhs
+++ b/compiler/hsSyn/HsUtils.lhs
@@ -1,5 +1,5 @@
 %
-% (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
@@ -22,18 +22,18 @@ 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 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}
 
@@ -52,16 +52,18 @@ just attach noSrcSpan to everything.
 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)]
 
@@ -72,14 +74,14 @@ mkHsApp :: LHsExpr name -> LHsExpr name -> LHsExpr name
 mkHsApp e1 e2 = addCLoc e1 e2 (HsApp e1 e2)
 
 nlHsTyApp :: name -> [Type] -> LHsExpr name
-nlHsTyApp fun_id tys = noLoc (HsCoerce (mkCoTyApps tys) (HsVar fun_id))
+nlHsTyApp fun_id tys = noLoc (HsWrap (mkWpTyApps tys) (HsVar fun_id))
 
-mkLHsCoerce :: ExprCoFn -> LHsExpr id -> LHsExpr id
-mkLHsCoerce co_fn (L loc e) = L loc (mkHsCoerce co_fn e)
+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))
@@ -210,6 +212,8 @@ 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)
+
+nlHsTyConApp tycon tys  = foldl nlHsAppTy (nlHsTyVar tycon) tys
 \end{code}
 
 
@@ -224,7 +228,8 @@ nlHsFunTy a b               = noLoc (HsFunTy a b)
 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
@@ -377,15 +382,12 @@ collectl (L l pat) bndrs
     go (TuplePat pats _ _)       = foldr collectl bndrs pats
                                  
     go (ConPatIn c ps)           = foldr collectl bndrs (hsConArgs ps)
-    go (ConPatOut { pat_dicts = ds, 
-                   pat_binds = bs, pat_args = 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
@@ -394,6 +396,16 @@ collectl (L l pat) 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
@@ -416,3 +428,24 @@ 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}
+
+%************************************************************************
+%*                                                                     *
+%*     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}