X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FhsSyn%2FConvert.lhs;h=9eb1e9a9aaab847e4ed0b1eb5aa534203ec7e28e;hb=b5a73581d0c03b9d44a77706b5973d74074aa6c1;hp=60080ee5b00853412edf92d51b899d826492962b;hpb=283e858564bb7979e59dcf00e852c2039aff231c;p=ghc-hetmet.git diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index 60080ee..9eb1e9a 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -143,8 +143,8 @@ cvtTop (ClassD ctxt cl tvs fds decs) -- no docs in TH ^^ } where - isFamilyD (FamilyD _ _ _) = True - isFamilyD _ = False + isFamilyD (FamilyD _ _ _ _) = True + isFamilyD _ = False cvtTop (InstanceD ctxt ty decs) = do { let (ats, bind_sig_decs) = partition isFamInstD decs @@ -173,10 +173,10 @@ cvtTop (PragmaD 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 @@ -207,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] @@ -235,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 [] @@ -245,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 @@ -628,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 @@ -643,11 +646,18 @@ 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 :: TH.Cxt -> CvtM (LHsContext RdrName) cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' } @@ -674,27 +684,42 @@ cvtPredTy ty 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 @@ -706,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) + -----------------------------------------------------------