+mk_con con = L loc0 $ mk_nlcon con
+ where
+ 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))