Add the notion of "constructor-like" Ids for rule-matching

[ghc-hetmet.git] / compiler / iface / MkIface.lhs

diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs
index 285f171..8cfc08f 100644 (file)
--- a/compiler/iface/MkIface.lhs
+++ b/compiler/iface/MkIface.lhs
@@ -67,6 +67,7 @@ import TcType
 import InstEnv
 import FamInstEnv
 import TcRnMonad
+import HsSyn
 import HscTypes
 import Finder
 import DynFlags
@@ -100,7 +101,6 @@ import Control.Monad
 import Data.List
 import Data.IORef
 import System.FilePath
-import System.Exit     ( exitWith, ExitCode(..) )
 \end{code}
 
 
@@ -116,8 +116,9 @@ mkIface :: HscEnv
        -> Maybe Fingerprint    -- The old fingerprint, if we have it
        -> ModDetails           -- The trimmed, tidied interface
        -> ModGuts              -- Usages, deprecations, etc
-       -> IO (ModIface,        -- The new one
-              Bool)            -- True <=> there was an old Iface, and the 
+       -> IO (Messages,
+               Maybe (ModIface, -- The new one
+                     Bool))    -- True <=> there was an old Iface, and the
                                 --          new one is identical, so no need
                                 --          to write it
 
@@ -134,7 +135,7 @@ mkIface hsc_env maybe_old_fingerprint mod_details
         = mkIface_ hsc_env maybe_old_fingerprint
                    this_mod is_boot used_names deps rdr_env 
                    fix_env warns hpc_info dir_imp_mods mod_details
-       
+
 -- | make an interface from the results of typechecking only.  Useful
 -- for non-optimising compilation, or where we aren't generating any
 -- object code at all ('HscNothing').
@@ -142,8 +143,7 @@ mkIfaceTc :: HscEnv
           -> Maybe Fingerprint -- The old fingerprint, if we have it
           -> ModDetails                -- gotten from mkBootModDetails, probably
           -> TcGblEnv          -- Usages, deprecations, etc
-         -> IO (ModIface,
-                Bool)
+         -> IO (Messages, Maybe (ModIface, Bool))
 mkIfaceTc hsc_env maybe_old_fingerprint mod_details
   tc_result@TcGblEnv{ tcg_mod = this_mod,
                       tcg_src = hsc_src,
@@ -214,7 +214,7 @@ mkIface_ :: HscEnv -> Maybe Fingerprint -> Module -> IsBootInterface
          -> NameEnv FixItem -> Warnings -> HpcInfo
          -> ImportedMods
          -> ModDetails
-         -> IO (ModIface, Bool)
+        -> IO (Messages, Maybe (ModIface, Bool))
 mkIface_ hsc_env maybe_old_fingerprint 
          this_mod is_boot used_names deps rdr_env fix_env src_warns hpc_info
          dir_imp_mods
@@ -305,10 +305,9 @@ mkIface_ hsc_env maybe_old_fingerprint
                                     | r <- iface_rules
                                     , isNothing (ifRuleOrph r) ]
 
-       ; when (not (isEmptyBag orph_warnings))
-              (do { printErrorsAndWarnings dflags errs_and_warns -- XXX
-                  ; when (errorsFound dflags errs_and_warns) 
-                         (exitWith (ExitFailure 1)) })
+       ; if errorsFound dflags errs_and_warns
+            then return ( errs_and_warns, Nothing )
+            else do {
 
 -- XXX ; when (dopt Opt_D_dump_hi_diffs dflags) (printDump pp_diffs)
    
@@ -322,7 +321,7 @@ mkIface_ hsc_env maybe_old_fingerprint
                 -- with the old GlobalRdrEnv (mi_globals).
         ; let final_iface = new_iface{ mi_globals = Just rdr_env }
 
-       ; return (final_iface, no_change_at_all) }
+       ; return (errs_and_warns, Just (final_iface, no_change_at_all)) }}
   where
      r1 `le_rule`     r2 = ifRuleName      r1    <=    ifRuleName      r2
      i1 `le_inst`     i2 = ifDFun          i1 `le_occ` ifDFun          i2  
@@ -1117,8 +1116,8 @@ checkDependencies hsc_env summary iface
    orM = foldr f (return False)
     where f m rest = do b <- m; if b then return True else rest
 
-   dep_missing (L _ mod) = do
-     find_res <- liftIO $ findImportedModule hsc_env mod Nothing
+   dep_missing (L _ (ImportDecl (L _ mod) pkg _ _ _ _)) = do
+     find_res <- liftIO $ findImportedModule hsc_env mod pkg
      case find_res of
         Found _ mod
           | pkg == this_pkg
@@ -1272,9 +1271,10 @@ tyThingToIfaceDecl :: TyThing -> IfaceDecl
 -- Reason: Iface stuff uses OccNames, and the conversion here does
 --        not do tidying on the way
 tyThingToIfaceDecl (AnId id)
-  = IfaceId { ifName   = getOccName id,
-             ifType   = toIfaceType (idType id),
-             ifIdInfo = info }
+  = IfaceId { ifName      = getOccName id,
+             ifType      = toIfaceType (idType id),
+             ifIdDetails = toIfaceIdDetails (idDetails id),
+             ifIdInfo    = info }
   where
     info = case toIfaceIdInfo (idInfo id) of
                []    -> NoInfo
@@ -1352,6 +1352,7 @@ tyThingToIfaceDecl (ATyCon tycon)
     ifaceConDecl data_con 
        = IfCon   { ifConOcc     = getOccName (dataConName data_con),
                    ifConInfix   = dataConIsInfix data_con,
+                   ifConWrapper = isJust (dataConWrapId_maybe data_con),
                    ifConUnivTvs = toIfaceTvBndrs (dataConUnivTyVars data_con),
                    ifConExTvs   = toIfaceTvBndrs (dataConExTyVars data_con),
                    ifConEqSpec  = to_eq_spec (dataConEqSpec data_con),
@@ -1439,10 +1440,17 @@ toIfaceLetBndr id  = IfLetBndr (occNameFS (getOccName id))
        -- See Note [IdInfo on nested let-bindings] in IfaceSyn
     id_info = idInfo id
     inline_prag = inlinePragInfo id_info
-    prag_info | isAlwaysActive inline_prag = NoInfo
-             | otherwise                  = HasInfo [HsInline inline_prag]
+    prag_info | isDefaultInlinePragma inline_prag = NoInfo
+             | otherwise                         = HasInfo [HsInline inline_prag]
 
 --------------------------
+toIfaceIdDetails :: IdDetails -> IfaceIdDetails
+toIfaceIdDetails VanillaId                     = IfVanillaId
+toIfaceIdDetails DFunId                        = IfVanillaId               
+toIfaceIdDetails (RecSelId { sel_naughty = n }) = IfRecSelId n
+toIfaceIdDetails other                         = pprTrace "toIfaceIdDetails" (ppr other) 
+                                                  IfVanillaId   -- Unexpected
+
 toIfaceIdInfo :: IdInfo -> [IfaceInfoItem]
 toIfaceIdInfo id_info
   = catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo, 
@@ -1487,11 +1495,13 @@ toIfaceIdInfo id_info
                                        
     ------------  Inline prag  --------------
     inline_prag = inlinePragInfo id_info
-    inline_hsinfo | isAlwaysActive inline_prag     = Nothing
-                 | no_unfolding && not has_worker = Nothing
+    inline_hsinfo | isDefaultInlinePragma inline_prag = Nothing
+                 | no_unfolding && not has_worker 
+                      && isFunLike (inlinePragmaRuleMatchInfo inline_prag)
+                                                      = Nothing
                        -- If the iface file give no unfolding info, we 
                        -- don't need to say when inlining is OK!
-                 | otherwise                      = Just (HsInline inline_prag)
+                 | otherwise                         = Just (HsInline inline_prag)
 
 --------------------------
 coreRuleToIfaceRule :: Module -> CoreRule -> IfaceRule