X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcRnTypes.lhs;h=30dccc24379af6558fa6465f6ae86c4ad66c3a81;hp=fc781df6159b812546167e0d08cc97660ea9c41b;hb=fdf8656855d26105ff36bdd24d41827b05037b91;hpb=27310213397bb89555bb03585e057ba1b017e895

diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs
index fc781df..30dccc2 100644
--- a/compiler/typecheck/TcRnTypes.lhs
+++ b/compiler/typecheck/TcRnTypes.lhs
@@ -42,7 +42,7 @@ module TcRnTypes(
 	CtOrigin(..), EqOrigin(..), 
         WantedLoc, GivenLoc, pushErrCtxt,
 
-        SkolemInfo(..),
+	SkolemInfo(..),
 
         CtFlavor(..), pprFlavorArising, isWanted, isGiven, isDerived,
         FlavoredEvVar,
@@ -62,6 +62,7 @@ module TcRnTypes(
 import HsSyn
 import HscTypes
 import Type
+import Id	( evVarPred )
 import Class    ( Class )
 import DataCon  ( DataCon, dataConUserType )
 import TcType
@@ -260,9 +261,10 @@ data TcGblEnv
 	tcg_warns     :: Warnings,	    -- ...Warnings and deprecations
 	tcg_anns      :: [Annotation],      -- ...Annotations
 	tcg_insts     :: [Instance],	    -- ...Instances
-	tcg_fam_insts :: [FamInst],	    -- ...Family instances
-	tcg_rules     :: [LRuleDecl Id],    -- ...Rules
-	tcg_fords     :: [LForeignDecl Id], -- ...Foreign import & exports
+        tcg_fam_insts :: [FamInst],         -- ...Family instances
+        tcg_rules     :: [LRuleDecl Id],    -- ...Rules
+        tcg_fords     :: [LForeignDecl Id], -- ...Foreign import & exports
+        tcg_vects     :: [LVectDecl Id],    -- ...Vectorisation declarations
 
 	tcg_doc_hdr   :: Maybe LHsDocString, -- ^ Maybe Haddock header docs
         tcg_hpc       :: AnyHpcUsage,        -- ^ @True@ if any part of the
@@ -323,6 +325,7 @@ data IfLclEnv
 		-- plus which bit is currently being examined
 
 	if_tv_env  :: UniqFM TyVar,	-- Nested tyvar bindings
+		      	     		-- (and coercions)
 	if_id_env  :: UniqFM Id		-- Nested id binding
     }
 \end{code}
@@ -673,7 +676,6 @@ instance Outputable WhereFrom where
 %************************************************************************
 %*									*
 		Wanted constraints
-
      These are forced to be in TcRnTypes because
      	   TcLclEnv mentions WantedConstraints
 	   WantedConstraint mentions CtLoc
@@ -714,10 +716,10 @@ andWC (WC { wc_flat = f1, wc_impl = i1, wc_insol = n1 })
        , wc_insol = n1 `unionBags` n2 }
 
 addFlats :: WantedConstraints -> Bag WantedEvVar -> WantedConstraints
-addFlats wc wevs = wc { wc_flat = wevs `unionBags` wc_flat wc }
+addFlats wc wevs = wc { wc_flat = wc_flat wc `unionBags` wevs }
 
 addImplics :: WantedConstraints -> Bag Implication -> WantedConstraints
-addImplics wc implic = wc { wc_impl = implic `unionBags` wc_impl wc }
+addImplics wc implic = wc { wc_impl = wc_impl wc `unionBags` implic }
 
 instance Outputable WantedConstraints where
   ppr (WC {wc_flat = f, wc_impl = i, wc_insol = n})
@@ -792,8 +794,8 @@ data Implication
                                  --   which is also the location of all the
                                  --   given evidence variables
 
-      ic_wanted  :: WantedConstraints, -- The wanted
-      ic_insol  :: Bool,               -- True iff insolubleWC ic_wantted is true
+      ic_wanted :: WantedConstraints,  -- The wanted
+      ic_insol  :: Bool,               -- True iff insolubleWC ic_wanted is true
 
       ic_binds  :: EvBindsVar   -- Points to the place to fill in the
                                 -- abstraction and bindings
@@ -883,11 +885,12 @@ wantedToFlavored (EvVarX v wl) = EvVarX v (Wanted wl)
 
 keepWanted :: Bag FlavoredEvVar -> Bag WantedEvVar
 keepWanted flevs
-  = foldlBag keep_wanted emptyBag flevs
+  = foldrBag keep_wanted emptyBag flevs
+    -- Important: use fold*r*Bag to preserve the order of the evidence variables.
   where
-    keep_wanted :: Bag WantedEvVar -> FlavoredEvVar -> Bag WantedEvVar
-    keep_wanted r (EvVarX ev (Wanted wloc)) = consBag (EvVarX ev wloc) r
-    keep_wanted r _ = r
+    keep_wanted :: FlavoredEvVar -> Bag WantedEvVar -> Bag WantedEvVar
+    keep_wanted (EvVarX ev (Wanted wloc)) r = consBag (EvVarX ev wloc) r
+    keep_wanted _                         r = r
 \end{code}
 
 
@@ -899,7 +902,7 @@ pprEvVarTheta :: [EvVar] -> SDoc
 pprEvVarTheta ev_vars = pprTheta (map evVarPred ev_vars)
                               
 pprEvVarWithType :: EvVar -> SDoc
-pprEvVarWithType v = ppr v <+> dcolon <+> pprPred (evVarPred v)
+pprEvVarWithType v = ppr v <+> dcolon <+> pprPredTy (evVarPred v)
 
 pprWantedsWithLocs :: WantedConstraints -> SDoc
 pprWantedsWithLocs wcs
@@ -935,10 +938,9 @@ data CtFlavor
 -- superclasses. 
 
 instance Outputable CtFlavor where
-  ppr (Given _)    = ptext (sLit "[Given]")
-  ppr (Wanted _)   = ptext (sLit "[Wanted]")
-  ppr (Derived {}) = ptext (sLit "[Derived]") 
-
+  ppr (Given {})   = ptext (sLit "[G]")
+  ppr (Wanted {})  = ptext (sLit "[W]")
+  ppr (Derived {}) = ptext (sLit "[D]") 
 pprFlavorArising :: CtFlavor -> SDoc
 pprFlavorArising (Derived wl )  = pprArisingAt wl
 pprFlavorArising (Wanted  wl)   = pprArisingAt wl