X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcBinds.lhs;h=7a7edb42cfa6a8c0f24c43ee15a4e3a3abd78ee7;hb=0cffd31b0f25c2a31ed6eff2c0c0b1b1a8a8d507;hp=a71da2e711bbab05d6665b11e399575a05c02180;hpb=e6ca2d4ac1e3d86bd93e5884fbae03151c708862;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs
index a71da2e..7a7edb4 100644
--- a/compiler/typecheck/TcBinds.lhs
+++ b/compiler/typecheck/TcBinds.lhs
@@ -7,7 +7,7 @@
 \begin{code}
 module TcBinds ( tcLocalBinds, tcTopBinds, 
                  tcHsBootSigs, tcMonoBinds, tcPolyBinds,
-                 TcPragFun, tcSpecPrag, tcPrags, mkPragFun, 
+                 TcPragFun, tcPrags, mkPragFun, 
                  TcSigInfo(..), TcSigFun, mkTcSigFun,
                  badBootDeclErr ) where
 
@@ -423,21 +423,24 @@ pragSigCtxt prag = hang (ptext (sLit "In the pragma")) 2 (ppr prag)
 tcPrag :: TcId -> Sig Name -> TcM Prag
 -- Pre-condition: the poly_id is zonked
 -- Reason: required by tcSubExp
-tcPrag poly_id (SpecSig _ hs_ty inl) = tcSpecPrag poly_id hs_ty inl
-tcPrag poly_id (SpecInstSig hs_ty)   = tcSpecPrag poly_id hs_ty defaultInlineSpec
-tcPrag _       (InlineSig _ inl)     = return (InlinePrag inl)
-tcPrag _       sig	             = pprPanic "tcPrag" (ppr sig)
-
-
-tcSpecPrag :: TcId -> LHsType Name -> InlineSpec -> TcM Prag
-tcSpecPrag poly_id hs_ty inl
+-- Most of the work of specialisation is done by 
+-- the desugarer, guided by the SpecPrag
+tcPrag poly_id (SpecSig _ hs_ty inl) 
   = do  { let name = idName poly_id
         ; spec_ty <- tcHsSigType (FunSigCtxt name) hs_ty
         ; co_fn <- tcSubExp (SpecPragOrigin name) (idType poly_id) spec_ty
         ; return (SpecPrag (mkHsWrap co_fn (HsVar poly_id)) spec_ty inl) }
-        -- Most of the work of specialisation is done by 
-        -- the desugarer, guided by the SpecPrag
-  
+tcPrag poly_id (SpecInstSig hs_ty)
+  = do  { let name = idName poly_id
+        ; (tyvars, theta, tau) <- tcHsInstHead hs_ty	
+        ; let spec_ty = mkSigmaTy tyvars theta tau
+        ; co_fn <- tcSubExp (SpecPragOrigin name) (idType poly_id) spec_ty
+        ; return (SpecPrag (mkHsWrap co_fn (HsVar poly_id)) spec_ty defaultInlineSpec) }
+
+tcPrag _  (InlineSig _ inl) = return (InlinePrag inl)
+tcPrag _  sig	            = pprPanic "tcPrag" (ppr sig)
+
+
 --------------
 -- If typechecking the binds fails, then return with each
 -- signature-less binder given type (forall a.a), to minimise