Template Haskell: support for INLINE and SPECIALISE pragmas

[ghc-hetmet.git] / compiler / hsSyn / Convert.lhs

diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs
index b48d361..60080ee 100644 (file)
--- a/compiler/hsSyn/Convert.lhs
+++ b/compiler/hsSyn/Convert.lhs
@@ -20,7 +20,7 @@ import OccName
 import SrcLoc
 import Type
 import TysWiredIn
-import BasicTypes
+import BasicTypes as Hs
 import ForeignCall
 import Char
 import List
@@ -146,13 +146,13 @@ cvtTop (ClassD ctxt cl tvs fds decs)
     isFamilyD (FamilyD _ _ _) = True
     isFamilyD _               = False
 
-cvtTop (InstanceD tys ty decs)
+cvtTop (InstanceD ctxt ty decs)
   = do         { let (ats, bind_sig_decs) = partition isFamInstD decs
         ; (binds', sigs') <- cvtBindsAndSigs bind_sig_decs
         ; ats' <- mapM cvtTop ats
         ; let ats'' = map unTyClD ats'
-       ; ctxt' <- cvtContext tys
-       ; L loc pred' <- cvtPred ty
+       ; ctxt' <- cvtContext ctxt
+       ; L loc pred' <- cvtPredTy ty
        ; inst_ty' <- returnL $ 
                         mkImplicitHsForAllTy ctxt' (L loc (HsPredTy pred'))
        ; returnL $ InstD (InstDecl inst_ty' binds' sigs' ats'')
@@ -163,7 +163,15 @@ cvtTop (InstanceD tys ty decs)
     isFamInstD (TySynInstD _ _ _)       = True
     isFamInstD _                        = False
 
-cvtTop (ForeignD ford) = do { ford' <- cvtForD ford; returnL $ ForD ford' }
+cvtTop (ForeignD ford) 
+  = do { ford' <- cvtForD ford
+       ; returnL $ ForD ford' 
+       }
+
+cvtTop (PragmaD prag)
+  = do { prag' <- cvtPragmaD prag
+       ; returnL $ Hs.SigD prag'
+       }
 
 cvtTop (FamilyD flav tc tvs)
   = do { (_, tc', tvs', _) <- cvt_tycl_hdr [] tc tvs
@@ -370,6 +378,35 @@ lex_ccall_impent xs = case span is_valid xs of
     where is_valid :: Char -> Bool
           is_valid c = isAscii c && (isAlphaNum c || c `elem` "._")
 
+------------------------------------------
+--              Pragmas
+------------------------------------------
+
+cvtPragmaD :: Pragma -> CvtM (Sig RdrName)
+cvtPragmaD (InlineP nm ispec)
+  = do { nm'    <- vNameL nm
+       ; return $ InlineSig nm' (cvtInlineSpec (Just ispec))
+       }
+cvtPragmaD (SpecialiseP nm ty opt_ispec)
+  = do { nm'    <- vNameL nm
+       ; ty'    <- cvtType ty
+       ; return $ SpecSig nm' ty' (cvtInlineSpec opt_ispec)
+       }
+
+cvtInlineSpec :: Maybe TH.InlineSpec -> Hs.InlineSpec
+cvtInlineSpec Nothing 
+  = defaultInlineSpec
+cvtInlineSpec (Just (TH.InlineSpec inline conlike opt_activation)) 
+  = mkInlineSpec opt_activation' matchinfo inline
+  where
+    matchinfo       = cvtRuleMatchInfo conlike
+    opt_activation' = fmap cvtActivation opt_activation
+
+    cvtRuleMatchInfo False = FunLike
+    cvtRuleMatchInfo True  = ConLike
+
+    cvtActivation (False, phase) = ActiveBefore phase
+    cvtActivation (True , phase) = ActiveAfter  phase
 
 ---------------------------------------------------
 --             Declarations
@@ -377,22 +414,31 @@ lex_ccall_impent xs = case span is_valid xs of
 
 cvtDecs :: [TH.Dec] -> CvtM (HsLocalBinds RdrName)
 cvtDecs [] = return EmptyLocalBinds
-cvtDecs ds = do { (binds,sigs) <- cvtBindsAndSigs ds
+cvtDecs ds = do { (binds, sigs) <- cvtBindsAndSigs ds
                ; return (HsValBinds (ValBindsIn binds sigs)) }
 
 cvtBindsAndSigs :: [TH.Dec] -> CvtM (Bag (LHsBind RdrName), [LSig RdrName])
 cvtBindsAndSigs ds 
-  = do { binds' <- mapM cvtBind binds; sigs' <- mapM cvtSig sigs
+  = do { binds' <- mapM cvtBind binds
+       ; sigs' <- mapM cvtSig sigs
        ; return (listToBag binds', sigs') }
   where 
     (sigs, binds) = partition is_sig ds
 
-    is_sig (TH.SigD _ _) = True
-    is_sig _             = False
+    is_sig (TH.SigD _ _)  = True
+    is_sig (TH.PragmaD _) = True
+    is_sig _              = False
 
 cvtSig :: TH.Dec -> CvtM (LSig RdrName)
 cvtSig (TH.SigD nm ty)
-  = do { nm' <- vNameL nm; ty' <- cvtType ty; returnL (Hs.TypeSig nm' ty') }
+  = do { nm' <- vNameL nm
+       ; ty' <- cvtType ty
+       ; returnL (Hs.TypeSig nm' ty') 
+       }
+cvtSig (TH.PragmaD prag)
+  = do { prag' <- cvtPragmaD prag
+       ; returnL prag'
+       }
 cvtSig _ = panic "Convert.cvtSig: Signature expected"
 
 cvtBind :: TH.Dec -> CvtM (LHsBind RdrName)
@@ -603,16 +649,29 @@ cvtTvs tvs = mapM cvt_tv tvs
 cvt_tv :: TH.Name -> CvtM (LHsTyVarBndr RdrName)
 cvt_tv tv = do { tv' <- tName tv; returnL $ UserTyVar tv' }
 
-cvtContext :: Cxt -> CvtM (LHsContext RdrName)
+cvtContext :: TH.Cxt -> CvtM (LHsContext RdrName)
 cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' }
 
-cvtPred :: TH.Type -> CvtM (LHsPred RdrName)
-cvtPred ty 
+cvtPred :: TH.Pred -> CvtM (LHsPred RdrName)
+cvtPred (TH.ClassP cla tys)
+  = do { cla' <- if isVarName cla then tName cla else tconName cla
+       ; tys' <- mapM cvtType tys
+       ; returnL $ HsClassP cla' tys'
+       }
+cvtPred (TH.EqualP ty1 ty2)
+  = do { ty1' <- cvtType ty1
+       ; ty2' <- cvtType ty2
+       ; returnL $ HsEqualP ty1' ty2'
+       }
+
+cvtPredTy :: TH.Type -> CvtM (LHsPred RdrName)
+cvtPredTy ty 
   = do { (head, tys') <- split_ty_app ty
        ; case head of
            ConT tc -> do { tc' <- tconName tc; returnL $ HsClassP tc' tys' }
            VarT tv -> do { tv' <- tName tv;    returnL $ HsClassP tv' tys' }
-           _       -> failWith (ptext (sLit "Malformed predicate") <+> text (TH.pprint ty)) }
+           _       -> failWith (ptext (sLit "Malformed predicate") <+> 
+                       text (TH.pprint ty)) }
 
 cvtType :: TH.Type -> CvtM (LHsType RdrName)
 cvtType ty = do { (head_ty, tys') <- split_ty_app ty
@@ -697,6 +756,14 @@ okOcc ns str@(c:_)
   | OccName.isVarNameSpace ns = startsVarId c || startsVarSym c
   | otherwise                = startsConId c || startsConSym c || str == "[]"
 
+-- Determine the name space of a name in a type
+--
+isVarName :: TH.Name -> Bool
+isVarName (TH.Name occ _)
+  = case TH.occString occ of
+      ""    -> False
+      (c:_) -> startsVarId c || startsVarSym c
+
 badOcc :: OccName.NameSpace -> String -> SDoc
 badOcc ctxt_ns occ 
   = ptext (sLit "Illegal") <+> pprNameSpace ctxt_ns