[commit: ghc] : Eliminate some dodgy const fmaps with traverses (3b675a8)

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : 

http://hackage.haskell.org/trac/ghc/changeset/3b675a8d2fd888a65955f19458690885e64787ce

>---------------------------------------------------------------

commit 3b675a8d2fd888a65955f19458690885e64787ce
Author: Max Bolingbroke <[email protected]>
Date:   Wed Jul 27 21:57:55 2011 +0100

    Eliminate some dodgy const fmaps with traverses

>---------------------------------------------------------------

 compiler/supercompile/Supercompile/Core/Syntax.hs  |   10 ++++++++--
 .../supercompile/Supercompile/Drive/Process.hs     |    5 +++--
 .../supercompile/Supercompile/Evaluator/Syntax.hs  |    9 ++++++---
 3 files changed, 17 insertions(+), 7 deletions(-)

diff --git a/compiler/supercompile/Supercompile/Core/Syntax.hs b/compiler/supercompile/Supercompile/Core/Syntax.hs
index 1cd4e48..b2d22a0 100644
--- a/compiler/supercompile/Supercompile/Core/Syntax.hs
+++ b/compiler/supercompile/Supercompile/Core/Syntax.hs
@@ -17,6 +17,8 @@ import Type     (Type, mkTyVarTy)
 import Coercion (Coercion, mkReflCo)
 import PrimOp   (PrimOp)
 
+import Data.Traversable (Traversable(traverse))
+
 
 data AltCon = DataAlt DataCon [TyVar] [Id] | LiteralAlt Literal | DefaultAlt
             deriving (Eq, Show)
@@ -139,8 +141,12 @@ pPrintPrecApps :: (Outputable a, Outputable b) => Rational -> a -> [b] -> SDoc
 pPrintPrecApps prec e1 es2 = prettyParen (not (null es2) && prec >= appPrec) $ pPrintPrec opPrec e1 <+> hsep (map (pPrintPrec appPrec) es2)
 
 
-termToValue :: Copointed ann => ann (TermF ann) -> Maybe (ann (ValueF ann))
-termToValue e = case extract e of Value v -> Just (fmap (const v) e); _ -> Nothing
+termToValue :: Traversable ann => ann (TermF ann) -> Maybe (ann (ValueF ann))
+termToValue anned_e = traverse termToValue' anned_e
+
+termToValue' :: TermF ann -> Maybe (ValueF ann)
+termToValue' (Value v) = Just v
+termToValue' _         = Nothing
 
 termIsValue :: Copointed ann => ann (TermF ann) -> Bool
 termIsValue = isValue . extract
diff --git a/compiler/supercompile/Supercompile/Drive/Process.hs b/compiler/supercompile/Supercompile/Drive/Process.hs
index 64e6764..f542560 100644
--- a/compiler/supercompile/Supercompile/Drive/Process.hs
+++ b/compiler/supercompile/Supercompile/Drive/Process.hs
@@ -36,6 +36,7 @@ import FastString (mkFastString)
 import CoreUtils  (mkPiTypes)
 
 import qualified Data.Foldable as Foldable
+import Data.Traversable (Traversable(traverse))
 import qualified Data.Map as M
 import Data.Monoid
 import Data.Ord
@@ -247,9 +248,9 @@ speculate speculated (stats, (deeds, Heap h ids, k, in_e)) = (M.keysSet h, (stat
                   Stop (_old_state, rb) -> (no_change, rb)
                   Continue hist -> case reduce state of
                       (extra_stats, (deeds, Heap h_speculated_ok' ids, [], qa))
-                        | Answer a <- annee qa
+                        | Just a <- traverse qaToAnswer qa
                         , let h_unspeculated = h_speculated_ok' M.\\ h_speculated_ok
-                              in_e' = annedAnswerToAnnedTerm (mkInScopeSet (annedFreeVars qa)) (fmap (const a) qa)
+                              in_e' = annedAnswerToAnnedTerm (mkInScopeSet (annedFreeVars a)) a
                         -> ((stats `mappend` extra_stats, deeds, M.insert x' (internallyBound in_e') h_speculated_ok, h_speculated_failure, ids), speculateManyMap hist h_unspeculated)
                       _ -> (no_change, speculation_failure)
                 where state = normalise (deeds, Heap h_speculated_ok ids, [], in_e)
diff --git a/compiler/supercompile/Supercompile/Evaluator/Syntax.hs b/compiler/supercompile/Supercompile/Evaluator/Syntax.hs
index 686bac5..ed39a01 100644
--- a/compiler/supercompile/Supercompile/Evaluator/Syntax.hs
+++ b/compiler/supercompile/Supercompile/Evaluator/Syntax.hs
@@ -123,6 +123,9 @@ qaToAnnedTerm' :: InScopeSet -> QA -> TermF Anned
 qaToAnnedTerm' _   (Question x) = Var x
 qaToAnnedTerm' iss (Answer a)   = answerToAnnedTerm' iss a
 
+qaToAnswer :: QA -> Maybe Answer
+qaToAnswer qa = case qa of Answer a -> Just a; Question _ -> Nothing
+
 
 type UnnormalisedState = (Deeds, Heap, Stack, In AnnedTerm)
 type State = (Deeds, Heap, Stack, Anned QA)
@@ -234,9 +237,9 @@ stackFrameType kf hole_ty = case tagee kf of
     CastIt co                     -> pSnd (coercionKind co)
 
 qaType :: Anned QA -> Type
-qaType qa = case annee qa of
-    Question x' -> idType x'
-    Answer a    -> answerType (fmap (const a) qa)
+qaType anned_qa = case traverse (\qa -> case qa of Question x' -> Left (idType x'); Answer a -> Right a) anned_qa of
+    Left q_ty     -> q_ty
+    Right anned_a -> answerType anned_a
 
 answerType :: Anned Answer -> Type
 answerType a = case annee a of