Remove the distinction between data and newtype families

[ghc-hetmet.git] / compiler / rename / RnSource.lhs

diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs
index 75af8fd..6d90eaa 100644 (file)
--- a/compiler/rename/RnSource.lhs
+++ b/compiler/rename/RnSource.lhs
@@ -6,7 +6,7 @@
 \begin{code}
 module RnSource ( 
        rnSrcDecls, addTcgDUs, 
-       rnTyClDecls, checkModDeprec,
+       rnTyClDecls, 
        rnSplice, checkTH
     ) where
 
@@ -23,7 +23,7 @@ import RnTypes                ( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext )
 import RnBinds         ( rnTopBinds, rnMethodBinds, renameSigs, mkSigTvFn )
 import RnEnv           ( lookupLocalDataTcNames,
                          lookupLocatedTopBndrRn, lookupLocatedOccRn,
-                         lookupOccRn, lookupTopBndrRn, newLocalsRn, 
+                         lookupOccRn, newLocalsRn, 
                          bindLocatedLocalsFV, bindPatSigTyVarsFV,
                          bindTyVarsRn, extendTyVarEnvFVRn,
                          bindLocalNames, checkDupNames, mapFvRn
@@ -31,8 +31,7 @@ import RnEnv          ( lookupLocalDataTcNames,
 import RnHsDoc          ( rnHsDoc, rnMbLHsDoc )
 import TcRnMonad
 
-import HscTypes                ( FixityEnv, FixItem(..),
-                         Deprecations, Deprecs(..), DeprecTxt, plusDeprecs )
+import HscTypes                ( FixityEnv, FixItem(..), Deprecations, Deprecs(..), plusDeprecs )
 import Class           ( FunDep )
 import Name            ( Name, nameOccName )
 import NameSet
@@ -42,7 +41,7 @@ import Outputable
 import SrcLoc          ( Located(..), unLoc, noLoc )
 import DynFlags        ( DynFlag(..) )
 import Maybes          ( seqMaybe )
-import Maybe            ( isNothing, isJust )
+import Maybe            ( isNothing )
 import Monad           ( liftM, when )
 import BasicTypes       ( Boxity(..) )
 \end{code}
@@ -102,21 +101,14 @@ rnSrcDecls (HsGroup { hs_valds  = val_decls,
                -- means we'll only report a declaration as unused if it isn't
                -- mentioned at all.  Ah well.
        traceRn (text "Start rnTyClDecls") ;
-       (rn_tycl_decls,    src_fvs1)
-          <- mapFvRn (wrapLocFstM rnTyClDecl) tycl_decls ;
-       traceRn (text "finish rnTyClDecls") ;
-       (rn_inst_decls,    src_fvs2)
-          <- mapFvRn (wrapLocFstM rnSrcInstDecl) inst_decls ;
-       (rn_deriv_decls,    src_fvs_deriv)
-          <- mapFvRn (wrapLocFstM rnSrcDerivDecl) deriv_decls ;
-       (rn_rule_decls,    src_fvs3)
-          <- mapFvRn (wrapLocFstM rnHsRuleDecl) rule_decls ;
-       (rn_foreign_decls, src_fvs4)
-          <- mapFvRn (wrapLocFstM rnHsForeignDecl) foreign_decls ;
-       (rn_default_decls, src_fvs5)
-          <- mapFvRn (wrapLocFstM rnDefaultDecl) default_decls ;
-
-  -- Haddock docs
+       (rn_tycl_decls,    src_fvs1) <- rnList rnTyClDecl      tycl_decls ;
+       (rn_inst_decls,    src_fvs2) <- rnList rnSrcInstDecl   inst_decls ;
+       (rn_rule_decls,    src_fvs3) <- rnList rnHsRuleDecl    rule_decls ;
+       (rn_foreign_decls, src_fvs4) <- rnList rnHsForeignDecl foreign_decls ;
+       (rn_default_decls, src_fvs5) <- rnList rnDefaultDecl   default_decls ;
+       (rn_deriv_decls,   src_fvs6) <- rnList rnSrcDerivDecl  deriv_decls ;
+
+  -- Haddock docs; no free vars
        rn_docs <- mapM (wrapLocM rnDocDecl) docs ;
 
        let {
@@ -131,7 +123,7 @@ rnSrcDecls (HsGroup { hs_valds  = val_decls,
                                hs_ruleds = rn_rule_decls,
             hs_docs   = rn_docs } ;
 
-          other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs_deriv, src_fvs3, 
+          other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs6, src_fvs3, 
                                src_fvs4, src_fvs5] ;
           src_dus = bind_dus `plusDU` usesOnly other_fvs 
                -- Note: src_dus will contain *uses* for locally-defined types
@@ -147,12 +139,15 @@ rnSrcDecls (HsGroup { hs_valds  = val_decls,
     }}}
 
 rnTyClDecls :: [LTyClDecl RdrName] -> RnM [LTyClDecl Name]
-rnTyClDecls tycl_decls = do 
-  (decls', fvs) <- mapFvRn (wrapLocFstM rnTyClDecl) tycl_decls
-  return decls'
+-- Used for external core
+rnTyClDecls tycl_decls = do  (decls', fvs) <- rnList rnTyClDecl tycl_decls
+                            return decls'
 
 addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv 
 addTcgDUs tcg_env dus = tcg_env { tcg_dus = tcg_dus tcg_env `plusDU` dus }
+
+rnList :: (a -> RnM (b, FreeVars)) -> [Located a] -> RnM ([Located b], FreeVars)
+rnList f xs = mapFvRn (wrapLocFstM f) xs
 \end{code}
 
 
@@ -254,11 +249,6 @@ rnSrcDeprecDecls decls
    rn_deprec (Deprecation rdr_name txt)
      = lookupLocalDataTcNames rdr_name `thenM` \ names ->
        returnM [(name, (nameOccName name, txt)) | name <- names]
-
-checkModDeprec :: Maybe DeprecTxt -> Deprecations
--- Check for a module deprecation; done once at top level
-checkModDeprec Nothing    = NoDeprecs
-checkModDeprec (Just txt) = DeprecAll txt
 \end{code}
 
 %*********************************************************
@@ -368,8 +358,7 @@ Renaming of the associated types in instances.
 
 \begin{code}
 rnATInsts :: [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars)
-rnATInsts atDecls = 
-  mapFvRn (wrapLocFstM rnATInst) atDecls
+rnATInsts atDecls = rnList rnATInst atDecls
   where
     rnATInst tydecl@TyData     {} = rnTyClDecl tydecl
     rnATInst tydecl@TySynonym  {} = rnTyClDecl tydecl
@@ -808,8 +797,8 @@ rnFamily (tydecl@TyFamily {tcdFlavour = flavour,
                    emptyFVs) 
          } }
       where
-        isDataFlavour (DataFamily _) = True
-       isDataFlavour _              = False
+        isDataFlavour DataFamily = True
+       isDataFlavour _          = False
 
 family_doc tycon = text "In the family declaration for" <+> quotes (ppr tycon)
 needOneIdx = text "Type family declarations requires at least one type index"