Trim imports

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

diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index 3155e09..f827117 100644 (file)
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -17,6 +17,7 @@ import HsTypes
 import BasicTypes
 import HscTypes
 import BuildTyCl
+import TcUnify
 import TcRnMonad
 import TcEnv
 import TcTyDecls
@@ -262,11 +263,19 @@ tcFamInstDecl1 (decl@TySynonym {tcdLName = L loc tc_name})
        ; -- (1) kind check the right-hand side of the type equation
        ; k_rhs <- kcCheckHsType (tcdSynRhs decl) resKind
 
+         -- we need at least as many type parameters as the family declaration
+         -- specified 
+       ; let famArity = tyConArity family
+       ; checkTc (length k_typats >= famArity) $ tooFewParmsErr famArity
+
          -- (2) type check type equation
        ; tcTyVarBndrs k_tvs $ \t_tvs -> do {  -- turn kinded into proper tyvars
        ; t_typats <- mappM tcHsKindedType k_typats
        ; t_rhs    <- tcHsKindedType k_rhs
 
+         -- all parameters in excess of the family arity must be variables
+       ; checkTc (all isTyVarTy $ drop famArity t_typats) $ excessParmVarErr
+
          -- (3) check that 
          --     - left-hand side contains no type family applications
          --       (vanilla synonyms are fine, though)
@@ -298,7 +307,7 @@ tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name,
             k_cons = tcdCons k_decl
 
          -- result kind must be '*' (otherwise, we have too few patterns)
-       ; checkTc (isLiftedTypeKind resKind) $ tooFewParmsErr tc_name
+       ; checkTc (isLiftedTypeKind resKind) $ tooFewParmsErr (tyConArity family)
 
          -- (2) type check indexed data type declaration
        ; tcTyVarBndrs k_tvs $ \t_tvs -> do {  -- turn kinded into proper tyvars
@@ -535,18 +544,15 @@ kcTyClDecl decl@(TyData {})
     kcTyClDeclBody decl        $
       kcDataDecl decl
 
-kcTyClDecl decl@(TyFamily {tcdKind = kind})
-  = kcTyClDeclBody decl $ \ tvs' ->
-      return (decl {tcdTyVars = tvs', 
-                   tcdKind = kind `mplus` Just liftedTypeKind})
-                   -- default result kind is '*'
+kcTyClDecl decl@(TyFamily {})
+  = kcFamilyDecl [] decl      -- the empty list signals a toplevel decl      
 
 kcTyClDecl decl@(ClassDecl {tcdCtxt = ctxt, tcdSigs = sigs, tcdATs = ats})
   = kcTyClDeclBody decl        $ \ tvs' ->
     do { is_boot <- tcIsHsBoot
        ; ctxt' <- kcHsContext ctxt     
-       ; ats'  <- mappM (wrapLocM kcTyClDecl) ats
-       ; sigs' <- mappM (wrapLocM kc_sig    ) sigs
+       ; ats'  <- mappM (wrapLocM (kcFamilyDecl tvs')) ats
+       ; sigs' <- mappM (wrapLocM kc_sig) sigs
        ; return (decl {tcdTyVars = tvs', tcdCtxt = ctxt', tcdSigs = sigs',
                        tcdATs = ats'}) }
   where
@@ -598,11 +604,15 @@ kcDataDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons})
         return (ConDecl name expl ex_tvs' ex_ctxt' details' res' Nothing)
 
     kc_con_details (PrefixCon btys) 
-       = do { btys' <- mappM kc_larg_ty btys ; return (PrefixCon btys') }
+       = do { btys' <- mappM kc_larg_ty btys 
+             ; return (PrefixCon btys') }
     kc_con_details (InfixCon bty1 bty2) 
-       = do { bty1' <- kc_larg_ty bty1; bty2' <- kc_larg_ty bty2; return (InfixCon bty1' bty2') }
+       = do { bty1' <- kc_larg_ty bty1
+             ; bty2' <- kc_larg_ty bty2
+             ; return (InfixCon bty1' bty2') }
     kc_con_details (RecCon fields) 
-       = do { fields' <- mappM kc_field fields; return (RecCon fields') }
+       = do { fields' <- mappM kc_field fields
+             ; return (RecCon fields') }
 
     kc_field (ConDeclField fld bty d) = do { bty' <- kc_larg_ty bty
                                           ; return (ConDeclField fld bty' d) }
@@ -613,6 +623,25 @@ kcDataDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons})
        -- Can't allow an unlifted type for newtypes, because we're effectively
        -- going to remove the constructor while coercing it to a lifted type.
        -- And newtypes can't be bang'd
+
+-- Kind check a family declaration or type family default declaration.
+--
+kcFamilyDecl :: [LHsTyVarBndr Name]  -- tyvars of enclosing class decl if any
+             -> TyClDecl Name -> TcM (TyClDecl Name)
+kcFamilyDecl classTvs decl@(TyFamily {tcdKind = kind})
+  = kcTyClDeclBody decl $ \tvs' ->
+    do { mapM_ unifyClassParmKinds tvs'
+       ; return (decl {tcdTyVars = tvs', 
+                      tcdKind = kind `mplus` Just liftedTypeKind})
+                      -- default result kind is '*'
+       }
+  where
+    unifyClassParmKinds (L _ (KindedTyVar n k))
+      | Just classParmKind <- lookup n classTyKinds = unifyKind k classParmKind
+      | otherwise                                   = return ()
+    classTyKinds = [(n, k) | L _ (KindedTyVar n k) <- classTvs]
+kcFamilyDecl _ decl@(TySynonym {})              -- type family defaults
+  = panic "TcTyClsDecls.kcFamilyDecl: not implemented yet"
 \end{code}
 
 
@@ -1187,7 +1216,7 @@ badDataConTyCon data_con
 
 badGadtDecl tc_name
   = vcat [ ptext SLIT("Illegal generalised algebraic data declaration for") <+> quotes (ppr tc_name)
-        , nest 2 (parens $ ptext SLIT("Use -X=GADT to allow GADTs")) ]
+        , nest 2 (parens $ ptext SLIT("Use -XGADTs to allow GADTs")) ]
 
 badStupidTheta tc_name
   = ptext SLIT("A data type declared in GADT style cannot have a context:") <+> quotes (ppr tc_name)
@@ -1220,7 +1249,7 @@ badSigTyDecl tc_name
 badFamInstDecl tc_name
   = vcat [ ptext SLIT("Illegal family instance for") <+>
           quotes (ppr tc_name)
-        , nest 2 (parens $ ptext SLIT("Use -X=TypeFamilies to allow indexed type families")) ]
+        , nest 2 (parens $ ptext SLIT("Use -XTypeFamilies to allow indexed type families")) ]
 
 badGadtIdxTyDecl tc_name
   = vcat [ ptext SLIT("Illegal generalised algebraic data declaration for") <+>
@@ -1231,9 +1260,12 @@ tooManyParmsErr tc_name
   = ptext SLIT("Family instance has too many parameters:") <+> 
     quotes (ppr tc_name)
 
-tooFewParmsErr tc_name
-  = ptext SLIT("Family instance has too few parameters:") <+> 
-    quotes (ppr tc_name)
+tooFewParmsErr arity
+  = ptext SLIT("Family instance has too few parameters; expected") <+> 
+    ppr arity
+
+excessParmVarErr
+  = ptext SLIT("Additional instance parameters must be variables")
 
 badBootFamInstDeclErr = 
   ptext SLIT("Illegal family instance in hs-boot file")