X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcMonad.lhs;h=dceff864fb232890019ce1f791f05c2b3c31f034;hb=10fcd78ccde892feccda3f5eacd221c1de75feea;hp=41f0890182b354056ed786e2cf9e7bc420d7a5e8;hpb=1181f398e73359a2e6387364b4fe270d4cc78f36;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcMonad.lhs b/ghc/compiler/typecheck/TcMonad.lhs
index 41f0890..dceff86 100644
--- a/ghc/compiler/typecheck/TcMonad.lhs
+++ b/ghc/compiler/typecheck/TcMonad.lhs
@@ -1,8 +1,5 @@
 \begin{code}
 module TcMonad(
-	TcType, TcTauType, TcPredType, TcThetaType, TcRhoType,
-	TcTyVar, TcTyVarSet, TcKind,
-
 	TcM, NF_TcM, TcDown, TcEnv, 
 
 	initTc,
@@ -32,7 +29,7 @@ module TcMonad(
 	tcAddErrCtxtM, tcSetErrCtxtM,
 	tcAddErrCtxt, tcSetErrCtxt, tcPopErrCtxt,
 
-	tcNewMutVar, tcNewSigTyVar, tcReadMutVar, tcWriteMutVar, TcRef,
+	tcNewMutVar, tcReadMutVar, tcWriteMutVar, TcRef,
 	tcNewMutTyVar, tcReadMutTyVar, tcWriteMutTyVar,
 
 	InstOrigin(..), InstLoc, pprInstLoc, 
@@ -47,20 +44,20 @@ import {-# SOURCE #-} TcEnv  ( TcEnv )
 
 import HsLit		( HsOverLit )
 import RnHsSyn		( RenamedPat, RenamedArithSeqInfo, RenamedHsExpr )
-import TcType		( Type, Kind, PredType, ThetaType, TauType, RhoType )
+import TcType		( Type, Kind, TyVarDetails )
 import ErrUtils		( addShortErrLocLine, addShortWarnLocLine, ErrMsg, Message, WarnMsg )
 
 import Bag		( Bag, emptyBag, isEmptyBag,
 			  foldBag, unitBag, unionBags, snocBag )
 import Class		( Class )
 import Name		( Name )
-import Var		( Id, TyVar, newMutTyVar, newSigTyVar, readMutTyVar, writeMutTyVar )
+import Var		( Id, TyVar, newMutTyVar, readMutTyVar, writeMutTyVar )
 import VarEnv		( TidyEnv, emptyTidyEnv )
-import VarSet		( TyVarSet )
 import UniqSupply	( UniqSupply, uniqFromSupply, uniqsFromSupply, 
 			  splitUniqSupply, mkSplitUniqSupply,
 			  UniqSM, initUs_ )
 import SrcLoc		( SrcLoc, noSrcLoc )
+import BasicTypes	( IPName )
 import UniqFM		( emptyUFM )
 import Unique		( Unique )
 import CmdLineOpts
@@ -77,30 +74,6 @@ infixr 9 `thenTc`, `thenTc_`, `thenNF_Tc`, `thenNF_Tc_`
 
 %************************************************************************
 %*									*
-\subsection{Types}
-%*									*
-%************************************************************************
-
-\begin{code}
-type TcTyVar    = TyVar		-- Might be a mutable tyvar
-type TcTyVarSet = TyVarSet
-
-type TcType = Type 		-- A TcType can have mutable type variables
-	-- Invariant on ForAllTy in TcTypes:
-	-- 	forall a. T
-	-- a cannot occur inside a MutTyVar in T; that is,
-	-- T is "flattened" before quantifying over a
-
-type TcPredType     = PredType
-type TcThetaType    = ThetaType
-type TcRhoType      = RhoType
-type TcTauType      = TauType
-type TcKind         = TcType
-\end{code}
-
-
-%************************************************************************
-%*									*
 \subsection{The main monads: TcM, NF_TcM}
 %*									*
 %************************************************************************
@@ -469,11 +442,8 @@ tcWriteMutVar var val down env = writeIORef var val
 tcReadMutVar :: TcRef a -> NF_TcM a
 tcReadMutVar var down env = readIORef var
 
-tcNewMutTyVar :: Name -> Kind -> NF_TcM TyVar
-tcNewMutTyVar name kind down env = newMutTyVar name kind
-
-tcNewSigTyVar :: Name -> Kind -> NF_TcM TyVar
-tcNewSigTyVar name kind down env = newSigTyVar name kind
+tcNewMutTyVar :: Name -> Kind -> TyVarDetails -> NF_TcM TyVar
+tcNewMutTyVar name kind details down env = newMutTyVar name kind details
 
 tcReadMutTyVar :: TyVar -> NF_TcM (Maybe Type)
 tcReadMutTyVar tyvar down env = readMutTyVar tyvar
@@ -518,7 +488,8 @@ tcGetSrcLoc :: NF_TcM SrcLoc
 tcGetSrcLoc down env = return (getLoc down)
 
 tcGetInstLoc :: InstOrigin -> NF_TcM InstLoc
-tcGetInstLoc origin down env = return (origin, getLoc down, getErrCtxt down)
+tcGetInstLoc origin TcDown{tc_loc=loc, tc_ctxt=ctxt} env
+   = return (origin, loc, ctxt)
 
 tcSetErrCtxtM, tcAddErrCtxtM :: (TidyEnv -> NF_TcM (TidyEnv, Message))
 			     -> TcM a -> TcM a
@@ -619,11 +590,11 @@ popErrCtxt down = case tc_ctxt down of
 			[]     -> down
 			m : ms -> down{tc_ctxt = ms}
 
-doptsTc :: DynFlag -> TcM Bool
+doptsTc :: DynFlag -> NF_TcM Bool
 doptsTc dflag (TcDown{tc_dflags=dflags}) env_down
    = return (dopt dflag dflags)
 
-getDOptsTc :: TcM DynFlags
+getDOptsTc :: NF_TcM DynFlags
 getDOptsTc (TcDown{tc_dflags=dflags}) env_down
    = return dflags
 \end{code}
@@ -642,12 +613,7 @@ type TcError   = Message
 type TcWarning = Message
 
 ctxt_to_use ctxt | opt_PprStyle_Debug = ctxt
-		 | otherwise	      = takeAtMost 3 ctxt
-		 where
-		   takeAtMost :: Int -> [a] -> [a]
-     		   takeAtMost 0 ls = []
-     		   takeAtMost n [] = []
-     		   takeAtMost n (x:xs) = x:takeAtMost (n-1) xs
+		 | otherwise	      = take 3 ctxt
 
 arityErr kind name n m
   = hsep [ text kind, quotes (ppr name), ptext SLIT("should have"),
@@ -679,8 +645,8 @@ type InstLoc = (InstOrigin, SrcLoc, ErrCtxt)
 data InstOrigin
   = OccurrenceOf Id		-- Occurrence of an overloaded identifier
 
-  | IPOcc Name			-- Occurrence of an implicit parameter
-  | IPBind Name			-- Binding site of an implicit parameter
+  | IPOcc (IPName Name)		-- Occurrence of an implicit parameter
+  | IPBind (IPName Name)	-- Binding site of an implicit parameter
 
   | RecordUpdOrigin
 
@@ -693,6 +659,7 @@ data InstOrigin
   | PatOrigin RenamedPat
 
   | ArithSeqOrigin RenamedArithSeqInfo -- [x..], [x..y] etc
+  | PArrSeqOrigin  RenamedArithSeqInfo -- [:x..y:] and [:x,y..z:]
 
   | SignatureOrigin		-- A dict created from a type signature
   | Rank2Origin			-- A dict created when typechecking the argument
@@ -737,14 +704,20 @@ pprInstLoc (orig, locn, ctxt)
       	= hsep [ptext SLIT("use of implicit parameter"), quotes (char '?' <> ppr name)]
     pp_orig (IPBind name)
       	= hsep [ptext SLIT("binding for implicit parameter"), quotes (char '?' <> ppr name)]
+    pp_orig RecordUpdOrigin
+	= ptext SLIT("a record update")
+    pp_orig DataDeclOrigin
+	= ptext SLIT("the data type declaration")
+    pp_orig InstanceDeclOrigin
+	= ptext SLIT("the instance declaration")
     pp_orig (LiteralOrigin lit)
 	= hsep [ptext SLIT("the literal"), quotes (ppr lit)]
     pp_orig (PatOrigin pat)
 	= hsep [ptext SLIT("the pattern"), quotes (ppr pat)]
-    pp_orig (InstanceDeclOrigin)
-	=  ptext SLIT("the instance declaration")
     pp_orig (ArithSeqOrigin seq)
 	= hsep [ptext SLIT("the arithmetic sequence"), quotes (ppr seq)]
+    pp_orig (PArrSeqOrigin seq)
+	= hsep [ptext SLIT("the parallel array sequence"), quotes (ppr seq)]
     pp_orig (SignatureOrigin)
 	=  ptext SLIT("a type signature")
     pp_orig (Rank2Origin)