-- 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
; 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
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]
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 []
; tvs2 <- collect t2
; return $ tvs1 ++ tvs2
}
+ collect (SigT (VarT tv) ki) = return [KindedTV tv ki]
+ collect (SigT ty _) = collect ty
---------------------------------------------------
-- Data types
cvt (DoE ss) = cvtHsDo DoExpr ss
cvt (CompE ss) = cvtHsDo ListComp ss
cvt (ArithSeqE dd) = do { dd' <- cvtDD dd; return $ ArithSeq noPostTcExpr dd' }
- cvt (ListE xs) = do { xs' <- mapM cvtl xs; return $ ExplicitList void xs' }
+ cvt (ListE xs)
+ | Just s <- allCharLs xs = do { l' <- cvtLit (StringL s); return (HsLit l') }
+ -- Note [Converting strings]
+ | otherwise = do { xs' <- mapM cvtl xs; return $ ExplicitList void xs' }
cvt (InfixE (Just x) s (Just y)) = do { x' <- cvtl x; s' <- cvtl s; y' <- cvtl y
; e' <- returnL $ OpApp x' s' undefined y'
; return $ HsPar e' }
-- An Integer is like an (overloaded) '3' in a Haskell source program
-- Similarly 3.5 for fractionals
+{- Note [Converting strings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we get (ListE [CharL 'x', CharL 'y']) we'd like to convert to
+a string literal for "xy". Of course, we might hope to get
+(LitE (StringL "xy")), but not always, and allCharLs fails quickly
+if it isn't a literal string
+-}
+
+allCharLs :: [TH.Exp] -> Maybe String
+-- Note [Converting strings]
+allCharLs (LitE (CharL c) : xs)
+ | Just cs <- allCharLs xs = Just (c:cs)
+allCharLs [] = Just []
+allCharLs _ = Nothing
+
cvtLit :: Lit -> CvtM HsLit
cvtLit (IntPrimL i) = do { force i; return $ HsIntPrim i }
cvtLit (WordPrimL w) = do { force w; return $ HsWordPrim w }
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
-----------------------------------------------------------
-- 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' }
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
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)
+
-----------------------------------------------------------
mk_mod :: TH.ModName -> ModuleName
mk_mod mod = mkModuleName (TH.modString mod)
-mk_pkg :: TH.ModName -> PackageId
+mk_pkg :: TH.PkgName -> PackageId
mk_pkg pkg = stringToPackageId (TH.pkgString pkg)
mk_uniq :: Int# -> Unique
projects / ghc-hetmet.git / blobdiff