{-# LANGUAGE CPP, ScopedTypeVariables, MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-}{-# LANGUAGE ViewPatterns #-}moduleLanguage.Haskell.Convert(Convert ,convert )whereimportLanguage.Haskell asHSimportqualifiedLanguage.Haskell.ExtsasHSE(FieldDecl(..))importLanguage.Haskell.TH.Compat importLanguage.Haskell.TH.SyntaxasTHimportControl.ExceptionimportData.TypeableimportSystem.IO.UnsafeimportData.Maybeclass(Typeablea ,Typeableb ,Showa ,Showb )=>Convert a b whereconv ::a ->b convert::foralla b .Convert a b =>a ->b convert a =unsafePerformIO$(return$!(conv a ::b ))`Control.Exception.catch`(\(e ::SomeException)->error$msg e )wheremsg e ="Could not convert "++show(typeOfa )++" to "++show(typeOf(undefined::b ))++"\n"++showa ++"\n"++showe appT::TH.Type->[TH.Type]->TH.TypeappT =foldlAppTc mr =convert mr instanceConvert a b =>Convert [a ][b ]whereconv =mapc instanceConvert TH.Dec(HS.Decl())whereconv x =casex of#if __GLASGOW_HASKELL__ >= 800
DataDcxt n vs _con ds ->f (DataType())cxt n vs con ds NewtypeDcxt n vs _con ds ->f (NewType())cxt n vs [con ]ds wheref::DataOrNew()->Cxt->TH.Name->[TyVarBndr]->[Con]->unused ->HS.Decl()f t cxt n vs con _=DataDecl()t (Just$c cxt )(dh (c n )(c vs ))(c con )[]#else
DataDcxtnvsconds->f(DataType())cxtnvscondsNewtypeDcxtnvsconds->f(NewType())cxtnvs[con]dswheref::DataOrNew()->Cxt->TH.Name->[TyVarBndr]->[Con]->[TH.Name]->HS.Decl()ftcxtnvsconds=DataDecl()t(Just$ccxt)(dh(cn)(cvs))(ccon)[]#endif
dh name []=DHead()name dhname xs =DHApp()(dh name $initxs )(lastxs )instanceConvert TH.Cxt(HS.Context())whereconv =CxTuple().mapc instanceConvert (Maybe(HS.Context()))TH.Cxtwhereconv Nothing=[]conv(Just(CxSingle_x ))=[c x ]conv(Just(CxTuple_xs ))=mapc xs conv(Just(CxEmpty_))=[]instanceConvert TH.Name(HS.TyVarBind())whereconv =UnkindedVar().c instanceConvert TH.Name(HS.Name())whereconv x =name$if'.'`elem`x2 thenreverse$takeWhile(/='.')$reversex2 elsex2 wherex2 =showx instanceConvert TH.Name(HS.QName())whereconv x =ifx2 ==Ident()"[]"thenSpecial()$ListCon()elseUnQual()x2 wherex2 =c x instanceConvert TH.Con(HS.QualConDecl())whereconv (ForallCvs cxt x )=QualConDecl()(Just$c vs )(Just$c cxt )(c x )convx =QualConDecl()NothingNothing(c x )instanceConvert TH.Con(HS.ConDecl())whereconv (NormalCn xs )=ConDecl()(c n )(c xs )conv(RecCn xs )=RecDecl()(c n )[HSE.FieldDecl()[c x ]$c (y ,z )|(x ,y ,z )<-xs ]conv(InfixCx n y )=InfixConDecl()(c x )(c n )(c y )instanceConvert TH.StrictType(HS.Type())where#if __GLASGOW_HASKELL__ >= 800
conv (BangSourceUnpackSourceStrict,x )=TyBang()(BangedTy())(Unpack())$c x conv(BangSourceUnpack_,x )=TyBang()(NoStrictAnnot())(Unpack())$c x conv(Bang_SourceStrict,x )=TyBang()(BangedTy())(NoUnpack())$c x conv(Bang__,x )=c x #else
conv(IsStrict,x)=TyBang()(BangedTy())(NoUnpack())$cxconv(NotStrict,x)=cx#if __GLASGOW_HASKELL__ >= 704
conv(Unpacked,x)=TyBang()(BangedTy())(Unpack())$cx#endif
#endif
instanceConvert TH.Type(HS.Type())whereconv (ForallTxs cxt t )=TyForall()(Just$c xs )(Just$c cxt )(c t )conv(VarTx )=TyVar()$c x conv(ConTx )|','`elem`showx =TyTuple()Boxed[]|otherwise=TyCon()$c x conv(AppT(AppTArrowTx )y )=TyFun()(c x )(c y )conv(ArrowT)=TyCon()$Special()$FunCon()conv(AppTListTx )=TyList()$c x conv(ListT)=TyCon()$Special()$ListCon()conv(TupleT_)=TyTuple()Boxed[]conv(AppTx y )=casec x ofTyTuple_b xs ->TyTuple()b $xs ++[c y ]x ->TyApp()x $c y instanceConvert TH.Type(HS.Asst())whereconv (ConTx )=ClassA()(UnQual()$c x )[]conv(AppTx y )=casec x ofClassA_a b ->ClassA()a (b ++[c y ])instanceConvert (HS.Decl())TH.Decwhereconv (InstDecl__(fromIParen ->IRule__cxt (fromInstHead ->(nam ,typ )))ds )=instanceD (c cxt )(c $tyApp (TyCon()nam )typ )[c d |InsDecl_d <-fromMaybe[]ds ]conv(FunBind_ms @(HS.Match_nam ___:_))=FunD(c nam )(c ms )conv(PatBind_p bod ds )=ValD(c p )(c bod )(c ds )conv(TypeSig_[nam ]typ )=SigD(c nam )(c $foralls typ )#if __GLASGOW_HASKELL__ >= 800
-- ! certainly BROKEN because it ignores contextsconv(DataDecl_DataType{}ctx (fromDeclHead ->(nam ,typ ))cs ds )=DataD(c ctx )(c nam )(c typ )Nothing(c cs )[]-- (c (map fst ds))conv(DataDecl_NewType{}ctx (fromDeclHead ->(nam ,typ ))[con ]ds )=NewtypeD(c ctx )(c nam )(c typ )Nothing(c con )[]-- (c (map fst ds))#else
conv(DataDecl_DataType{}ctx(fromDeclHead->(nam,typ))csds)=DataD(cctx)(cnam)(ctyp)(ccs)[]conv(DataDecl_NewType{}ctx(fromDeclHead->(nam,typ))[con]ds)=NewtypeD(cctx)(cnam)(ctyp)(ccon)[]#endif
instanceConvert (HS.QualConDecl())TH.Conwhereconv (QualConDecl_NothingNothingcon )=c con conv(QualConDecl_vs cx con )=ForallC(c $fromMaybe[]vs )(c cx )(c con )instanceConvert (HS.ConDecl())TH.Conwhereconv (ConDecl_nam typ )=NormalC(c nam )(c typ )conv(InfixConDecl_l nam r )=InfixC(c l )(c nam )(c r )conv(RecDecl_nam fs )=RecC(c nam )(concatMapc fs )instanceConvert (HSE.FieldDecl())[TH.VarStrictType]whereconv (HSE.FieldDecl_names ty )=[(c name ,bang ,t )|let(bang ,t )=c ty ,name <-names ]instanceConvert (HS.Type())TH.StrictTypewhere#if __GLASGOW_HASKELL__ >= 800
conv (TyBang_BangedTy{}_t )=(BangNoSourceUnpackednessSourceStrict,c t )#else
conv(TyBang_BangedTy{}_t)=(IsStrict,ct)#if __GLASGOW_HASKELL__ >= 704
conv(TyBang__Unpack{}t)=(Unpacked,ct)#else
conv(TyBang__Unpack{}t)=(IsStrict,ct)#endif
#endif
#if __GLASGOW_HASKELL__ >= 800
convt =(BangNoSourceUnpackednessNoSourceStrictness,c t )#else
convt=(NotStrict,ct)#endif
instanceConvert ([HS.Name()],HS.Type())[TH.VarStrictType]whereconv (names ,bt )=[(c name ,s ,t )|name <-names ]where(s ,t )=c bt instanceConvert (HS.Asst())TH.Typewhereconv (InfixA_x y z )=c $ClassA()y [x ,z ]conv(ClassA_x y )=appT (ConT$c x )(c y )instanceConvert (HS.Type())TH.Typewhereconv (TyCon_(Special_ListCon{}))=ListTconv(TyCon_(Special_UnitCon{}))=TupleT0conv(TyParen_x )=c x conv(TyForall_x y z )=ForallT(c $fromMaybe[]x )(c y )(c z )conv(TyVar_x )=VarT$c x conv(TyCon_x )=ifx ~= "[]"thenerror"here"elseConT$c x conv(TyFun_x y )=AppT(AppTArrowT(c x ))(c y )conv(TyList_x )=AppTListT(c x )conv(TyTuple__x )=appT (TupleT(lengthx ))(c x )conv(TyApp_x y )=AppT(c x )(c y )instanceConvert (HS.Name())TH.Namewhereconv =mkName.filter(`notElem`"()").prettyPrintinstanceConvert (HS.Match())TH.Clausewhereconv (HS.Match__ps bod ds )=Clause(c ps )(c bod )(c ds )instanceConvert (HS.Rhs())TH.Bodywhereconv (UnGuardedRhs_x )=NormalB(c x )conv(GuardedRhss_x )=GuardedB(c x )instanceConvert (HS.Exp())TH.Expwhereconv (Con_(Special_UnitCon{}))=TupE[]conv(Var_x )=VarE(c x )conv(Con_x )=ConE(c x )conv(Lit_x )=LitE(c x )conv(App_x y )=AppE(c x )(c y )conv(Paren_x )=c x conv(InfixApp_x y z )=InfixE(Just$c x )(c y )(Just$c z )conv(LeftSection_x y )=InfixE(Just$c x )(c y )Nothingconv(RightSection_y z )=InfixENothing(c y )(Just$c z )conv(Lambda_x y )=LamE(c x )(c y )conv(Tuple__x )=TupE(c x )conv(If_x y z )=CondE(c x )(c y )(c z )conv(Let_x y )=LetE(c x )(c y )conv(Case_x y )=CaseE(c x )(c y )conv(Do_x )=DoE(c x )conv(EnumFrom_x )=ArithSeqE$FromR(c x )conv(EnumFromTo_x y )=ArithSeqE$FromToR(c x )(c y )conv(EnumFromThen_x y )=ArithSeqE$FromThenR(c x )(c y )conv(EnumFromThenTo_x y z )=ArithSeqE$FromThenToR(c x )(c y )(c z )conv(List_x )=ListE(c x )conv(ExpTypeSig_x y )=SigE(c x )(c y )conv(RecConstr_x y )=RecConE(c x )(c y )conv(RecUpdate_x y )=RecUpdE(c x )(c y )-- Work around bug 3395, convert to do notation insteadconv(ListComp_x y )=CompE$c $y ++[QualStmt()$Qualifier()x ]instanceConvert (HS.GuardedRhs())(TH.Guard,TH.Exp)whereconv (GuardedRhs_g x )=(conv g ,conv x )instanceConvert [HS.Stmt()]TH.Guardwhereconv xs =PatG$mapconv xs instanceConvert (HS.Binds())[TH.Dec]whereconv (BDecls_x )=c x instanceConvert (Maybe(HS.Binds()))[TH.Dec]whereconv Nothing=[]conv(Justx )=c x instanceConvert (HS.Pat())TH.Patwhereconv (PParen_x )=c x conv(PLit_Signless{}x )=LitP(c x )conv(PTuple__x )=TupP(c x )conv(PApp_x y )=ConP(c x )(c y )conv(PVar_x )=VarP(c x )conv(PInfixApp_x y z )=InfixP(c x )(c y )(c z )conv(PIrrPat_x )=TildeP(c x )conv(PAsPat_x y )=AsP(c x )(c y )conv(PWildCard{})=WildPconv(PRec_x y )=RecP(c x )(c y )conv(PList_x )=ListP(c x )conv(PatTypeSig_x y )=SigP(c x )(c y )instanceConvert (HS.Literal())TH.Litwhereconv (Char_x _)=CharLx conv(String_x _)=StringLx conv(Int_x _)=IntegerLx conv(Frac_x _)=RationalLx conv(PrimInt_x _)=IntPrimLx conv(PrimWord_x _)=WordPrimLx conv(PrimFloat_x _)=FloatPrimLx conv(PrimDouble_x _)=DoublePrimLx instanceConvert (HS.QName())TH.Namewhereconv (UnQual_x )=c x conv(Qual_m x )=c (Ident()$prettyPrintm ++"."++prettyPrintx )conv(Special_(TupleCon_Boxedi ))=Name(mkOccName$"("++replicate(i -1)','++")")NameSinstanceConvert (HS.PatField())TH.FieldPatwhereconv (PFieldPat_name pat )=(c name ,c pat )conv(PFieldPun_name )=(c name ,c $PVar()$Ident()$prettyPrintname )conv(PFieldWildcard_)=error"Can't convert PFieldWildcard"instanceConvert (HS.QOp())TH.Expwhereconv (QVarOp_x )=c $Var()x conv(QConOp_x )=c $Con()x instanceConvert (HS.Alt())TH.Matchwhereconv (Alt_x y z )=TH.Match(c x )(c y )(c z )instanceConvert (HS.Stmt())TH.Stmtwhereconv (Generator_x y )=BindS(c x )(c y )conv(LetStmt_x )=LetS(c x )conv(Qualifier_x )=NoBindS(c x )instanceConvert (HS.QualStmt())TH.Stmtwhereconv (QualStmt_x )=c x instanceConvert (HS.FieldUpdate())TH.FieldExpwhereconv (FieldUpdate_x y )=(c x ,c y )instanceConvert (HS.TyVarBind())TH.Namewhereconv (UnkindedVar_x )=c x #if __GLASGOW_HASKELL__ >= 612
instanceConvert TH.TyVarBndr(HS.TyVarBind())whereconv (PlainTVx )=UnkindedVar()$c x conv(KindedTVx y )=KindedVar()(c x )$c y #if __GLASGOW_HASKELL__ < 706
instanceConvert(TH.Kind())HS.KindwhereconvStarK=KindStarconv(ArrowKxy)=KindFn(cx)$cy#else
instanceConvert TH.Kind(HS.Kind())whereconv StarT=KindStar()conv(AppT(AppTArrowTx )y )=KindFn()(c x )(c y )#endif
#if __GLASGOW_HASKELL__ < 709
instanceConvertTH.Pred(HS.Asst())whereconv(ClassPxy)=ClassA()(UnQual()$cx)$cyconv(TH.EqualPxy)=HS.EqualP()(cx)$cyinstanceConvert(HS.Asst())TH.Predwhereconv(ClassA_xy)=ClassP(cx)$cyconv(HS.EqualP_xy)=TH.EqualP(cx)$cy#endif
instanceConvert (HS.TyVarBind())TH.TyVarBndrwhereconv (UnkindedVar_x )=PlainTV$c x conv(KindedVar_x y )=KindedTV(c x )$c y #if __GLASGOW_HASKELL__ < 706
instanceConvert(HS.Kind())TH.Kindwhereconv(KindStar_)=StarKconv(KindFn_xy)=ArrowK(cx)$cy#else
instanceConvert (HS.Kind())TH.Kindwhereconv KindStar{}=StarTconv(KindFn_x y )=AppT(AppTArrowT(c x ))(c y )#endif
#endif