[project @ 1999-04-27 17:33:49 by sof]

[ghc-hetmet.git] / ghc / compiler / typecheck / TcIfaceSig.lhs

diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs
index 9500baf..7bf4f4c 100644 (file)
--- a/ghc/compiler/typecheck/TcIfaceSig.lhs
+++ b/ghc/compiler/typecheck/TcIfaceSig.lhs
@@ -88,6 +88,7 @@ tcIdInfo unf_env name ty info info_ins
     tcPrag info (HsArity arity) = returnTc (arity `setArityInfo` info)
     tcPrag info (HsUpdate upd)  = returnTc (upd   `setUpdateInfo` info)
     tcPrag info (HsNoCafRefs)   = returnTc (NoCafRefs `setCafInfo` info)
+    tcPrag info (HsCprInfo cpr_info)     = returnTc (cpr_info `setCprInfo` info)
 
     tcPrag info (HsUnfold inline_prag maybe_expr)
        = (case maybe_expr of
@@ -106,8 +107,11 @@ tcIdInfo unf_env name ty info info_ins
          in
          returnTc info2
 
-    tcPrag info (HsStrictness strict)
-       = tcStrictness unf_env ty info strict
+    tcPrag info (HsStrictness (HsStrictnessInfo (demands,bot_result)))
+       = returnTc (StrictnessInfo demands bot_result `setStrictnessInfo` info)
+
+    tcPrag info (HsWorker nm cons)
+       = tcWorkerInfo unf_env ty info nm cons
 
     tcPrag info (HsSpecialise tyvars tys rhs)
        = tcExtendTyVarScope tyvars             $ \ tyvars' ->
@@ -133,20 +137,29 @@ tcIdInfo unf_env name ty info info_ins
 \end{code}
 
 \begin{code}
-tcStrictness unf_env ty info (HsStrictnessInfo (demands, bot_result) maybe_worker)
-  = tcWorker unf_env maybe_worker              `thenNF_Tc` \ maybe_worker_id ->
-    uniqSMToTcM (mkWrapper ty demands)         `thenNF_Tc` \ wrap_fn ->
+tcWorkerInfo unf_env ty info nm cons
+  = tcWorker unf_env (Just (nm,cons))  `thenNF_Tc` \ maybe_worker_id ->
+    -- We are relying here on cpr and strictness info always appearing 
+    -- before strictness info,  fingers crossed ....
+    let
+      demands = case strictnessInfo info of
+                       StrictnessInfo d _ -> d
+                       _                  -> []
+      cpr_info = cprInfo info
+    in 
+    uniqSMToTcM (mkWrapper ty demands cpr_info) `thenNF_Tc` \ wrap_fn ->
     let
        -- Watch out! We can't pull on maybe_worker_id too eagerly!
        info' = case maybe_worker_id of
                        Just worker_id -> setUnfoldingInfo (mkUnfolding (wrap_fn worker_id)) $
+                                          setWorkerInfo (Just worker_id) $
                                          setInlinePragInfo IWantToBeINLINEd info
 
                        Nothing        -> info
 
        has_worker = maybeToBool maybe_worker_id
     in
-    returnTc (StrictnessInfo demands bot_result has_worker  `setStrictnessInfo` info')
+    returnTc info'
 \end{code}
 
 \begin{code}