- mk_con (Constr c tys)
- = ConDecl (cName c) noExistentials noContext
- (PrefixCon (map mk_arg tys)) loc0
-
- mk_arg ty = BangType NotMarkedStrict (cvtType ty)
-
- mk_derivs [] = Nothing
- mk_derivs cs = Just [HsClassP (tconName c) [] | c <- cs]
-
-cvt_top (Class ctxt cl tvs decs)
- = TyClD (mkClassDecl (cvt_context ctxt, tconName cl, cvt_tvs tvs)
- noFunDeps
- sigs (Just binds) loc0)
+ mk_nlcon con = case con of
+ NormalC c strtys
+ -> ConDecl (noLoc (cName c)) noExistentials noContext
+ (PrefixCon (map mk_arg strtys))
+ RecC c varstrtys
+ -> ConDecl (noLoc (cName c)) noExistentials noContext
+ (RecCon (map mk_id_arg varstrtys))
+ InfixC st1 c st2
+ -> ConDecl (noLoc (cName c)) noExistentials noContext
+ (InfixCon (mk_arg st1) (mk_arg st2))
+ ForallC tvs ctxt (ForallC tvs' ctxt' con')
+ -> mk_nlcon (ForallC (tvs ++ tvs') (ctxt ++ ctxt') con')
+ ForallC tvs ctxt con' -> case mk_nlcon con' of
+ ConDecl l [] (L _ []) x ->
+ ConDecl l (cvt_tvs tvs) (cvt_context ctxt) x
+ c -> panic "ForallC: Can't happen"
+ mk_arg (IsStrict, ty) = noLoc $ HsBangTy HsStrict (cvtType ty)
+ mk_arg (NotStrict, ty) = cvtType ty
+
+ mk_id_arg (i, IsStrict, ty)
+ = (noLoc (vName i), noLoc $ HsBangTy HsStrict (cvtType ty))
+ mk_id_arg (i, NotStrict, ty)
+ = (noLoc (vName i), cvtType ty)
+
+mk_derivs [] = Nothing
+mk_derivs cs = Just [noLoc $ HsPredTy $ HsClassP (tconName c) [] | c <- cs]
+
+cvt_ltop :: TH.Dec -> Either (LHsDecl RdrName) Message
+cvt_ltop d = case cvt_top d of
+ Left d -> Left (L loc0 d)
+ Right m -> Right m
+
+cvt_top :: TH.Dec -> Either (HsDecl RdrName) Message
+cvt_top d@(TH.ValD _ _ _) = Left $ Hs.ValD (unLoc (cvtd d))
+cvt_top d@(TH.FunD _ _) = Left $ Hs.ValD (unLoc (cvtd d))
+
+cvt_top (TySynD tc tvs rhs)
+ = Left $ TyClD (TySynonym (noLoc (tconName tc)) (cvt_tvs tvs) (cvtType rhs))
+
+cvt_top (DataD ctxt tc tvs constrs derivs)
+ = Left $ TyClD (mkTyData DataType
+ (noLoc (cvt_context ctxt, noLoc (tconName tc), cvt_tvs tvs))
+ Nothing (map mk_con constrs)
+ (mk_derivs derivs))
+
+cvt_top (NewtypeD ctxt tc tvs constr derivs)
+ = Left $ TyClD (mkTyData NewType
+ (noLoc (cvt_context ctxt, noLoc (tconName tc), cvt_tvs tvs))
+ Nothing [mk_con constr]
+ (mk_derivs derivs))
+
+cvt_top (ClassD ctxt cl tvs decs)
+ = Left $ TyClD (mkClassDecl (cvt_context ctxt, noLoc (tconName cl), cvt_tvs tvs)
+ noFunDeps sigs
+ binds)