New syntax for GADT-style record declarations, and associated refactoring

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

diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs
index b7cbc1e..a63c2ce 100644 (file)
--- a/compiler/typecheck/TcHsType.lhs
+++ b/compiler/typecheck/TcHsType.lhs
@@ -6,7 +6,7 @@
 
 \begin{code}
 module TcHsType (
 
 \begin{code}
 module TcHsType (

-       tcHsSigType, tcHsDeriv, 
+       tcHsSigType, tcHsSigTypeNC, tcHsDeriv, 

        tcHsInstHead, tcHsQuantifiedType,
        UserTypeCtxt(..), 
 
        tcHsInstHead, tcHsQuantifiedType,
        UserTypeCtxt(..), 
 

@@ -25,6 +25,10 @@ module TcHsType (
 
 #include "HsVersions.h"
 
 
 #include "HsVersions.h"
 

+#ifdef GHCI    /* Only if bootstrapped */
+import {-# SOURCE #-}  TcSplice( kcSpliceType )
+#endif
+

 import HsSyn
 import RnHsSyn
 import TcRnMonad
 import HsSyn
 import RnHsSyn
 import TcRnMonad

@@ -136,14 +140,19 @@ the TyCon being defined.
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}

-tcHsSigType :: UserTypeCtxt -> LHsType Name -> TcM Type
+tcHsSigType, tcHsSigTypeNC :: UserTypeCtxt -> LHsType Name -> TcM Type

   -- Do kind checking, and hoist for-alls to the top
   -- NB: it's important that the foralls that come from the top-level
   --    HsForAllTy in hs_ty occur *first* in the returned type.
   --     See Note [Scoped] with TcSigInfo
 tcHsSigType ctxt hs_ty 
   = addErrCtxt (pprHsSigCtxt ctxt hs_ty) $
   -- Do kind checking, and hoist for-alls to the top
   -- NB: it's important that the foralls that come from the top-level
   --    HsForAllTy in hs_ty occur *first* in the returned type.
   --     See Note [Scoped] with TcSigInfo
 tcHsSigType ctxt hs_ty 
   = addErrCtxt (pprHsSigCtxt ctxt hs_ty) $

-    do { kinded_ty <- kcTypeType hs_ty
+    tcHsSigTypeNC ctxt hs_ty
+
+tcHsSigTypeNC ctxt hs_ty
+  = do { (kinded_ty, _kind) <- kc_lhs_type hs_ty
+         -- The kind is checked by checkValidType, and isn't necessarily
+         -- of kind * in a Template Haskell quote eg [t| Maybe |]

        ; ty <- tcHsKindedType kinded_ty
        ; checkValidType ctxt ty        
        ; return ty }
        ; ty <- tcHsKindedType kinded_ty
        ; checkValidType ctxt ty        
        ; return ty }

@@ -395,12 +404,20 @@ kc_hs_type (HsForAllTy exp tv_names context ty)
 
        ; return (HsForAllTy exp tv_names' ctxt' ty', liftedTypeKind) }
 
 
        ; return (HsForAllTy exp tv_names' ctxt' ty', liftedTypeKind) }
 

-kc_hs_type (HsBangTy b ty) = do
-    (ty', kind) <- kc_lhs_type ty
-    return (HsBangTy b ty', kind)
+kc_hs_type (HsBangTy b ty)
+  = do { (ty', kind) <- kc_lhs_type ty
+       ; return (HsBangTy b ty', kind) }

 
 

-kc_hs_type ty@(HsSpliceTy _)
-  = failWithTc (ptext (sLit "Unexpected type splice:") <+> ppr ty)
+kc_hs_type ty@(HsRecTy _)
+  = failWithTc (ptext (sLit "Unexpected record type") <+> ppr ty)
+      -- Record types (which only show up temporarily in constructor signatures) 
+      -- should have been removed by now
+
+#ifdef GHCI    /* Only if bootstrapped */
+kc_hs_type (HsSpliceTy sp) = kcSpliceType sp
+#else
+kc_hs_type ty@(HsSpliceTy _) = failWithTc (ptext (sLit "Unexpected type splice:") <+> ppr ty)
+#endif

 
 -- 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
 
 -- 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

@@ -542,9 +559,12 @@ ds_type ty@(HsTyVar _)
 ds_type (HsParTy ty)           -- Remove the parentheses markers
   = dsHsType ty
 
 ds_type (HsParTy ty)           -- Remove the parentheses markers
   = dsHsType ty
 

-ds_type ty@(HsBangTy _ _)      -- No bangs should be here
+ds_type ty@(HsBangTy {})    -- No bangs should be here

   = failWithTc (ptext (sLit "Unexpected strictness annotation:") <+> ppr ty)
 
   = failWithTc (ptext (sLit "Unexpected strictness annotation:") <+> ppr ty)
 

+ds_type ty@(HsRecTy {})            -- No bangs should be here
+  = failWithTc (ptext (sLit "Unexpected record type:") <+> ppr ty)
+

 ds_type (HsKindSig ty _)
   = dsHsType ty        -- Kind checking done already
 
 ds_type (HsKindSig ty _)
   = dsHsType ty        -- Kind checking done already