import SrcLoc
import Type
import TysWiredIn
-import BasicTypes
+import BasicTypes as Hs
import ForeignCall
import Char
import List
-- 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'')
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
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
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
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)
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 :: 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
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)
+
-----------------------------------------------------------
| 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
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