X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FhsSyn%2FConvert.lhs;h=9eb1e9a9aaab847e4ed0b1eb5aa534203ec7e28e;hb=ea84860ef56d72da1f4c63d661b7ad333109237d;hp=b48d361ad603aefa344235f765e16cb1947bb3d7;hpb=5e5a08eb37f5513cecb47101a97fdaf09c4be040;p=ghc-hetmet.git diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index b48d361..9eb1e9a 100644 --- 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 @@ -143,16 +143,16 @@ cvtTop (ClassD ctxt cl tvs fds decs) -- no docs in TH ^^ } where - isFamilyD (FamilyD _ _ _) = True - isFamilyD _ = False + 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,12 +163,20 @@ 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) +cvtTop (FamilyD flav tc tvs kind) = do { (_, tc', tvs', _) <- cvt_tycl_hdr [] tc tvs - ; returnL $ TyClD (TyFamily (cvtFamFlavour flav) tc' tvs' Nothing) - -- FIXME: kinds + ; let kind' = fmap cvtKind kind + ; returnL $ TyClD (TyFamily (cvtFamFlavour flav) tc' tvs' kind') } where cvtFamFlavour TypeFam = TypeFamily @@ -199,7 +207,7 @@ unTyClD :: LHsDecl a -> LTyClDecl a unTyClD (L l (TyClD d)) = L l d unTyClD _ = panic "Convert.unTyClD: internal error" -cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.Name] +cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr] -> CvtM ( LHsContext RdrName , Located RdrName , [LHsTyVarBndr RdrName] @@ -227,7 +235,7 @@ cvt_tyinst_hdr cxt tc tys where collect (ForallT _ _ _) = failWith $ text "Forall type not allowed as type parameter" - collect (VarT tv) = return [tv] + collect (VarT tv) = return [PlainTV tv] collect (ConT _) = return [] collect (TupleT _) = return [] collect ArrowT = return [] @@ -237,6 +245,8 @@ cvt_tyinst_hdr cxt tc tys ; tvs2 <- collect t2 ; return $ tvs1 ++ tvs2 } + collect (SigT (VarT tv) ki) = return [KindedTV tv ki] + collect (SigT ty _) = collect ty --------------------------------------------------- -- Data types @@ -370,6 +380,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 +416,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) @@ -582,6 +630,7 @@ cvtp (ConP s ps) = do { s' <- cNameL s; ps' <- cvtPats ps; return $ ConPatI cvtp (InfixP p1 s p2) = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2 ; return $ ConPatIn s' (InfixCon p1' p2') } cvtp (TildeP p) = do { p' <- cvtPat p; return $ LazyPat p' } +cvtp (BangP p) = do { p' <- cvtPat p; return $ BangPat p' } cvtp (TH.AsP s p) = do { s' <- vNameL s; p' <- cvtPat p; return $ AsPat s' p' } cvtp TH.WildP = return $ WildPat void cvtp (RecP c fs) = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs @@ -597,45 +646,80 @@ cvtPatFld (s,p) ----------------------------------------------------------- -- Types and type variables -cvtTvs :: [TH.Name] -> CvtM [LHsTyVarBndr RdrName] +cvtTvs :: [TH.TyVarBndr] -> CvtM [LHsTyVarBndr RdrName] cvtTvs tvs = mapM cvt_tv tvs -cvt_tv :: TH.Name -> CvtM (LHsTyVarBndr RdrName) -cvt_tv tv = do { tv' <- tName tv; returnL $ UserTyVar tv' } +cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr RdrName) +cvt_tv (TH.PlainTV nm) + = do { nm' <- tName nm + ; returnL $ UserTyVar nm' + } +cvt_tv (TH.KindedTV nm ki) + = do { nm' <- tName nm + ; returnL $ KindedTyVar nm' (cvtKind ki) + } -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 - ; case head_ty of - TupleT n | length tys' == n -- Saturated - -> if n==1 then return (head tys') -- Singleton tuples treated - -- like nothing (ie just parens) - else returnL (HsTupleTy Boxed tys') - | n == 1 -> failWith (ptext (sLit "Illegal 1-tuple type constructor")) - | otherwise -> mk_apps (HsTyVar (getRdrName (tupleTyCon Boxed n))) tys' - ArrowT | [x',y'] <- tys' -> returnL (HsFunTy x' y') - | otherwise -> mk_apps (HsTyVar (getRdrName funTyCon)) tys' - ListT | [x'] <- tys' -> returnL (HsListTy x') - | otherwise -> mk_apps (HsTyVar (getRdrName listTyCon)) tys' - VarT nm -> do { nm' <- tName nm; mk_apps (HsTyVar nm') tys' } - ConT nm -> do { nm' <- tconName nm; mk_apps (HsTyVar nm') tys' } - - ForallT tvs cxt ty | null tys' -> do { tvs' <- cvtTvs tvs - ; cxt' <- cvtContext cxt - ; ty' <- cvtType ty - ; returnL $ mkExplicitHsForAllTy tvs' cxt' ty' } - _ -> failWith (ptext (sLit "Malformed type") <+> text (show ty)) - } +cvtType ty + = do { (head_ty, tys') <- split_ty_app ty + ; case head_ty of + TupleT n + | length tys' == n -- Saturated + -> if n==1 then return (head tys') -- Singleton tuples treated + -- like nothing (ie just parens) + else returnL (HsTupleTy Boxed tys') + | n == 1 + -> failWith (ptext (sLit "Illegal 1-tuple type constructor")) + | otherwise + -> mk_apps (HsTyVar (getRdrName (tupleTyCon Boxed n))) tys' + ArrowT + | [x',y'] <- tys' -> returnL (HsFunTy x' y') + | otherwise -> mk_apps (HsTyVar (getRdrName funTyCon)) tys' + ListT + | [x'] <- tys' -> returnL (HsListTy x') + | otherwise -> mk_apps (HsTyVar (getRdrName listTyCon)) tys' + VarT nm -> do { nm' <- tName nm; mk_apps (HsTyVar nm') tys' } + ConT nm -> do { nm' <- tconName nm; mk_apps (HsTyVar nm') tys' } + + ForallT tvs cxt ty + | null tys' + -> do { tvs' <- cvtTvs tvs + ; cxt' <- cvtContext cxt + ; ty' <- cvtType ty + ; returnL $ mkExplicitHsForAllTy tvs' cxt' ty' + } + + SigT ty ki + -> do { ty' <- cvtType ty + ; mk_apps (HsKindSig ty' (cvtKind ki)) tys' + } + + _ -> failWith (ptext (sLit "Malformed type") <+> text (show ty)) + } where mk_apps head_ty [] = returnL head_ty mk_apps head_ty (ty:tys) = do { head_ty' <- returnL head_ty @@ -647,6 +731,10 @@ split_ty_app ty = go ty [] go (AppT f a) as' = do { a' <- cvtType a; go f (a':as') } go f as = return (f,as) +cvtKind :: TH.Kind -> Type.Kind +cvtKind StarK = liftedTypeKind +cvtKind (ArrowK k1 k2) = mkArrowKind (cvtKind k1) (cvtKind k2) + ----------------------------------------------------------- @@ -697,6 +785,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