Parse and desugar equational constraints

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

diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs
index 6a43e23..4d3224c 100644 (file)
--- a/compiler/typecheck/TcHsType.lhs
+++ b/compiler/typecheck/TcHsType.lhs
@@ -1,4 +1,5 @@
-
+%
+% (c) The University of Glasgow 2006
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
 \section[TcMonoType]{Typechecking user-specified @MonoTypes@}
@@ -23,41 +24,26 @@ module TcHsType (
 
 #include "HsVersions.h"
 
-import HsSyn           ( HsType(..), LHsType, HsTyVarBndr(..), LHsTyVarBndr, 
-                         LHsContext, HsPred(..), LHsPred )
-import RnHsSyn         ( extractHsTyVars )
+import HsSyn
+import RnHsSyn
 import TcRnMonad
-import TcEnv           ( tcExtendTyVarEnv, tcExtendKindEnvTvs, 
-                         tcLookup, tcLookupClass, tcLookupTyCon,
-                         TyThing(..), getInLocalScope, getScopedTyVarBinds,
-                         wrongThingErr
-                       )
-import TcMType         ( newKindVar, 
-                         zonkTcKindToKind, 
-                         tcInstBoxyTyVar, readFilledBox,
-                         checkValidType
-                       )
-import TcUnify         ( boxyUnify, unifyFunKind, checkExpectedKind )
-import TcIface         ( checkWiredInTyCon )
-import TcType          ( Type, PredType(..), ThetaType, BoxySigmaType,
-                         TcType, TcKind, isRigidTy,
-                         UserTypeCtxt(..), pprUserTypeCtxt,
-                         substTyWith, mkTyVarTys, tcEqType,
-                         tcIsTyVarTy, mkFunTy, mkSigmaTy, mkPredTy, 
-                         mkTyConApp, mkAppTys, typeKind )
-import {- Kind parts of -} Type                ( Kind, isLiftedTypeKind, liftedTypeKind, ubxTupleKind, 
-                         openTypeKind, argTypeKind, splitKindFunTys )
-import Var             ( TyVar, mkTyVar, tyVarName )
-import TyCon           ( TyCon, tyConKind )
-import Class           ( Class, classTyCon )
-import Name            ( Name, mkInternalName )
-import OccName         ( mkOccName, tvName )
+import TcEnv
+import TcMType
+import TcUnify
+import TcIface
+import TcType
+import {- Kind parts of -} Type
+import Var
+import TyCon
+import Class
+import Name
+import OccName
 import NameSet
-import PrelNames       ( genUnitTyConName )
-import TysWiredIn      ( mkListTy, listTyCon, mkPArrTy, parrTyCon, tupleTyCon )
-import BasicTypes      ( Boxity(..) )
-import SrcLoc          ( Located(..), unLoc, noLoc, getLoc, srcSpanStart )
-import UniqSupply      ( uniqsFromSupply )
+import PrelNames
+import TysWiredIn
+import BasicTypes
+import SrcLoc
+import UniqSupply
 import Outputable
 \end{code}
 
@@ -357,6 +343,10 @@ kc_hs_type (HsBangTy b ty)
 kc_hs_type ty@(HsSpliceTy _)
   = failWithTc (ptext SLIT("Unexpected type splice:") <+> ppr ty)
 
+-- remove the doc nodes here, no need to worry about the location since
+-- its the same for a doc node and it's child type node
+kc_hs_type (HsDocTy ty _)
+  = kc_hs_type (unLoc ty) 
 
 ---------------------------
 kcApps :: TcKind                       -- Function kind
@@ -398,13 +388,21 @@ kc_pred :: HsPred Name -> TcM (HsPred Name, TcKind)
        -- Does *not* check for a saturated
        -- application (reason: used from TcDeriv)
 kc_pred pred@(HsIParam name ty)
-  = kcHsType ty                `thenM` \ (ty', kind) ->
-    returnM (HsIParam name ty', kind)
-
+  = do { (ty', kind) <- kcHsType ty
+       ; returnM (HsIParam name ty', kind)
+       }
 kc_pred pred@(HsClassP cls tys)
-  = kcClass cls                        `thenM` \ kind ->
-    kcApps kind (ppr cls) tys  `thenM` \ (tys', res_kind) ->
-    returnM (HsClassP cls tys', res_kind)
+  = do { kind <- kcClass cls
+       ; (tys', res_kind) <- kcApps kind (ppr cls) tys
+       ; returnM (HsClassP cls tys', res_kind)
+       }
+kc_pred pred@(HsEqualP ty1 ty2)
+  = do { (ty1', kind1) <- kcHsType ty1
+       ; checkExpectedKind ty1 kind1 liftedTypeKind
+       ; (ty2', kind2) <- kcHsType ty2
+       ; checkExpectedKind ty2 kind2 liftedTypeKind
+       ; returnM (HsEqualP ty1 ty2, liftedTypeKind)
+       }
 
 ---------------------------
 kcTyVar :: Name -> TcM TcKind
@@ -544,13 +542,19 @@ dsHsLPred :: LHsPred Name -> TcM PredType
 dsHsLPred pred = dsHsPred (unLoc pred)
 
 dsHsPred pred@(HsClassP class_name tys)
-  = dsHsTypes tys                      `thenM` \ arg_tys ->
-    tcLookupClass class_name           `thenM` \ clas ->
-    returnM (ClassP clas arg_tys)
-
+  = do { arg_tys <- dsHsTypes tys
+       ; clas <- tcLookupClass class_name
+       ; returnM (ClassP clas arg_tys)
+       }
+dsHsPred pred@(HsEqualP ty1 ty2)
+  = do { arg_ty1 <- dsHsType ty1
+       ; arg_ty2 <- dsHsType ty2
+       ; returnM (EqPred arg_ty1 arg_ty2)
+       }
 dsHsPred (HsIParam name ty)
-  = dsHsType ty                                        `thenM` \ arg_ty ->
-    returnM (IParam name arg_ty)
+  = do { arg_ty <- dsHsType ty
+       ; returnM (IParam name arg_ty)
+       }
 \end{code}
 
 GADT constructor signatures
@@ -630,7 +634,8 @@ tcDataKindSig :: Maybe Kind -> TcM [TyVar]
 -- GADT decls can have a (perhaps partial) kind signature
 --     e.g.  data T :: * -> * -> * where ...
 -- This function makes up suitable (kinded) type variables for 
--- the argument kinds, and checks that the result kind is indeed *
+-- the argument kinds, and checks that the result kind is indeed *.
+-- We use it also to make up argument type variables for for data instances.
 tcDataKindSig Nothing = return []
 tcDataKindSig (Just kind)
   = do { checkTc (isLiftedTypeKind res_kind) (badKindSig kind)
@@ -809,7 +814,6 @@ pprHsSigCtxt ctxt hs_ty = vcat [ ptext SLIT("In") <+> pprUserTypeCtxt ctxt <> co
     pp_sig (FunSigCtxt n)  = pp_n_colon n
     pp_sig (ConArgCtxt n)  = pp_n_colon n
     pp_sig (ForSigCtxt n)  = pp_n_colon n
-    pp_sig (RuleSigCtxt n) = pp_n_colon n
     pp_sig other          = ppr (unLoc hs_ty)
 
     pp_n_colon n = ppr n <+> dcolon <+> ppr (unLoc hs_ty)