X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FhsSyn%2FConvert.lhs;h=dcef02f798eb30fa15a5756eaa9e7a66a238cacc;hb=7836349556deef66f1b1d06fe8e9c7c0b841f0d0;hp=d392be24e3973d88f79d5b38de17f927ee040470;hpb=70249b050422f2abba670e5fdb3c5853ceeb662c;p=ghc-hetmet.git

diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs
index d392be2..dcef02f 100644
--- a/compiler/hsSyn/Convert.lhs
+++ b/compiler/hsSyn/Convert.lhs
@@ -7,7 +7,8 @@ This module converts Template Haskell syntax into HsSyn
 
 \begin{code}
 module Convert( convertToHsExpr, convertToPat, convertToHsDecls,
-                convertToHsType, thRdrNameGuesses ) where
+                convertToHsType, convertToHsPred,
+                thRdrNameGuesses ) where
 
 import HsSyn as Hs
 import qualified Class
@@ -58,6 +59,10 @@ convertToHsType :: SrcSpan -> TH.Type -> Either Message (LHsType RdrName)
 convertToHsType loc t
   = initCvt loc $ wrapMsg "type" t $ cvtType t
 
+convertToHsPred :: SrcSpan -> TH.Pred -> Either Message (LHsPred RdrName)
+convertToHsPred loc t
+  = initCvt loc $ wrapMsg "type" t $ cvtPred t
+
 -------------------------------------------------------------------
 newtype CvtM a = CvtM { unCvtM :: SrcSpan -> Either Message a }
 	-- Push down the source location;
@@ -370,6 +375,7 @@ cvtForD (ImportF callconv safety from nm ty)
                      Unsafe     -> PlayRisky
                      Safe       -> PlaySafe False
                      Threadsafe -> PlaySafe True
+                     Interruptible -> PlayInterruptible
 
 cvtForD (ExportF callconv as nm ty)
   = do	{ nm' <- vNameL nm
@@ -400,7 +406,7 @@ cvtInlineSpec Nothing
   = defaultInlinePragma
 cvtInlineSpec (Just (TH.InlineSpec inline conlike opt_activation)) 
   = InlinePragma { inl_act = opt_activation', inl_rule = matchinfo
-                 , inl_inline = inline, inl_sat = Nothing }
+                 , inl_inline = inl_spec, inl_sat = Nothing }
   where
     matchinfo       = cvtRuleMatchInfo conlike
     opt_activation' = cvtActivation opt_activation
@@ -408,6 +414,10 @@ cvtInlineSpec (Just (TH.InlineSpec inline conlike opt_activation))
     cvtRuleMatchInfo False = FunLike
     cvtRuleMatchInfo True  = ConLike
 
+    inl_spec | inline    = Inline
+             | otherwise = NoInline
+ 	     -- Currently we have no way to say Inlinable
+
     cvtActivation Nothing | inline      = AlwaysActive
                           | otherwise   = NeverActive
     cvtActivation (Just (False, phase)) = ActiveBefore phase
@@ -454,8 +464,8 @@ cvtl e = wrapL (cvt e)
 			    ; return $ HsLam (mkMatchGroup [mkSimpleMatch ps' e']) }
     cvt (TupE [e])     = cvt e	-- Singleton tuples treated like nothing (just parens)
     cvt (TupE es)      = do { es' <- mapM cvtl es; return $ ExplicitTuple (map Present es') Boxed }
-    cvt (CondE x y z)  = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z
-			    ; return $ HsIf x' y' z' }
+    cvt (CondE x y z)  = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z;
+			    ; return $ HsIf (Just noSyntaxExpr) x' y' z' }
     cvt (LetE ds e)    = do { ds' <- cvtLocalDecs (ptext (sLit "a let expression")) ds
                             ; e' <- cvtl e; return $ HsLet ds' e' }
     cvt (CaseE e ms)   
@@ -627,6 +637,7 @@ cvtp (RecP c fs)      = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs
 		  	   ; return $ ConPatIn c' $ Hs.RecCon (HsRecFields fs' Nothing) }
 cvtp (ListP ps)       = do { ps' <- cvtPats ps; return $ ListPat ps' void }
 cvtp (SigP p t)       = do { p' <- cvtPat p; t' <- cvtType t; return $ SigPatIn p' t' }
+cvtp (ViewP e p)      = do { e' <- cvtl e; p' <- cvtPat p; return $ ViewPat e' p' void }
 
 cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (HsRecField RdrName (LPat RdrName))
 cvtPatFld (s,p)