lapack-ffi-tools (empty) → 0.0
raw patch · 12 files changed
+2116/−0 lines, 12 filesdep +basedep +bytestringdep +cassavasetup-changed
Dependencies added: base, bytestring, cassava, containers, explicit-exception, filepath, non-empty, optparse-applicative, parsec, pathtype, transformers, unordered-containers, utility-ht, vector
Files
- LICENSE +27/−0
- Setup.lhs +3/−0
- data/blas.csv +58/−0
- data/lapack.csv +493/−0
- lapack-ffi-tools.cabal +87/−0
- src/CreateBinding.hs +424/−0
- src/CreateCSV.hs +32/−0
- src/MainAll.hs +365/−0
- src/MainSingle.hs +30/−0
- src/Parser/Combinator.hs +58/−0
- src/Parser/Signature.hs +289/−0
- src/Type.hs +250/−0
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) Henning Thielemann 2016++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.+3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF+SUCH DAMAGE.
+ Setup.lhs view
@@ -0,0 +1,3 @@+#! /usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ data/blas.csv view
@@ -0,0 +1,58 @@+Name,Float,Double,ComplexFloat,ComplexDouble,Miscellaneous+asum,sasum.f,dasum.f,,,+axpy,saxpy.f,daxpy.f,caxpy.f,zaxpy.f,+cabs1,,,scabs1.f,dcabs1.f,+casum,,,scasum.f,dzasum.f,+cnrm2,,,scnrm2.f,dznrm2.f,+copy,scopy.f,dcopy.f,ccopy.f,zcopy.f,+dot,sdot.f,ddot.f,,,+dotc,,,cdotc.f,zdotc.f,+dotu,,,cdotu.f,zdotu.f,+dsdot,sdsdot.f,,,,+gbmv,sgbmv.f,dgbmv.f,cgbmv.f,zgbmv.f,+gemm,sgemm.f,dgemm.f,cgemm.f,zgemm.f,+gemv,sgemv.f,dgemv.f,cgemv.f,zgemv.f,+ger,sger.f,dger.f,,,+gerc,,,cgerc.f,zgerc.f,+geru,,,cgeru.f,zgeru.f,+hbmv,,,chbmv.f,zhbmv.f,+hemm,,,chemm.f,zhemm.f,+hemv,,,chemv.f,zhemv.f,+her,,,cher.f,zher.f,+her2,,,cher2.f,zher2.f,+her2k,,,cher2k.f,zher2k.f,+herk,,,cherk.f,zherk.f,+hpmv,,,chpmv.f,zhpmv.f,+hpr,,,chpr.f,zhpr.f,+hpr2,,,chpr2.f,zhpr2.f,+iamax,isamax.f,idamax.f,icamax.f,izamax.f,+nrm2,snrm2.f,dnrm2.f,,,+rot,srot.f,drot.f,,,+rotg,srotg.f,drotg.f,crotg.f,zrotg.f,+rotm,srotm.f,drotm.f,,,+rotmg,srotmg.f,drotmg.f,,,+rrot,,,csrot.f,zdrot.f,+rscal,,,csscal.f,zdscal.f,+sbmv,ssbmv.f,dsbmv.f,,,+scal,sscal.f,dscal.f,cscal.f,zscal.f,+sdot,,dsdot.f,,,+spmv,sspmv.f,dspmv.f,,,+spr,sspr.f,dspr.f,,,+spr2,sspr2.f,dspr2.f,,,+swap,sswap.f,dswap.f,cswap.f,zswap.f,+symm,ssymm.f,dsymm.f,csymm.f,zsymm.f,+symv,ssymv.f,dsymv.f,,,+syr,ssyr.f,dsyr.f,,,+syr2,ssyr2.f,dsyr2.f,,,+syr2k,ssyr2k.f,dsyr2k.f,csyr2k.f,zsyr2k.f,+syrk,ssyrk.f,dsyrk.f,csyrk.f,zsyrk.f,+tbmv,stbmv.f,dtbmv.f,ctbmv.f,ztbmv.f,+tbsv,stbsv.f,dtbsv.f,ctbsv.f,ztbsv.f,+tpmv,stpmv.f,dtpmv.f,ctpmv.f,ztpmv.f,+tpsv,stpsv.f,dtpsv.f,ctpsv.f,ztpsv.f,+trmm,strmm.f,dtrmm.f,ctrmm.f,ztrmm.f,+trmv,strmv.f,dtrmv.f,ctrmv.f,ztrmv.f,+trsm,strsm.f,dtrsm.f,ctrsm.f,ztrsm.f,+trsv,strsv.f,dtrsv.f,ctrsv.f,ztrsv.f,+lsame,,,,,lsame.f+xerbla,,,,,xerbla.f
+ data/lapack.csv view
@@ -0,0 +1,493 @@+Name,Float,Double,ComplexFloat,ComplexDouble,Miscellaneous+bbcsd,sbbcsd.f,dbbcsd.f,cbbcsd.f,zbbcsd.f,+bdsdc,sbdsdc.f,dbdsdc.f,,,+bdsqr,sbdsqr.f,dbdsqr.f,cbdsqr.f,zbdsqr.f,+cgesv,,,,zcgesv.f,+cposv,,,,zcposv.f,+disna,sdisna.f,ddisna.f,,,+gbbrd,sgbbrd.f,dgbbrd.f,cgbbrd.f,zgbbrd.f,+gbcon,sgbcon.f,dgbcon.f,cgbcon.f,zgbcon.f,+gbequ,sgbequ.f,dgbequ.f,cgbequ.f,zgbequ.f,+gbequb,sgbequb.f,dgbequb.f,cgbequb.f,zgbequb.f,+gbrfs,sgbrfs.f,dgbrfs.f,cgbrfs.f,zgbrfs.f,+gbsv,sgbsv.f,dgbsv.f,cgbsv.f,zgbsv.f,+gbsvx,sgbsvx.f,dgbsvx.f,cgbsvx.f,zgbsvx.f,+gbtf2,sgbtf2.f,dgbtf2.f,cgbtf2.f,zgbtf2.f,+gbtrf,sgbtrf.f,dgbtrf.f,cgbtrf.f,zgbtrf.f,+gbtrs,sgbtrs.f,dgbtrs.f,cgbtrs.f,zgbtrs.f,+gebak,sgebak.f,dgebak.f,cgebak.f,zgebak.f,+gebal,sgebal.f,dgebal.f,cgebal.f,zgebal.f,+gebd2,sgebd2.f,dgebd2.f,cgebd2.f,zgebd2.f,+gebrd,sgebrd.f,dgebrd.f,cgebrd.f,zgebrd.f,+gecon,sgecon.f,dgecon.f,cgecon.f,zgecon.f,+geequ,sgeequ.f,dgeequ.f,cgeequ.f,zgeequ.f,+geequb,sgeequb.f,dgeequb.f,cgeequb.f,zgeequb.f,+gees,sgees.f,dgees.f,cgees.f,zgees.f,+geesx,sgeesx.f,dgeesx.f,cgeesx.f,zgeesx.f,+geev,sgeev.f,dgeev.f,cgeev.f,zgeev.f,+geevx,sgeevx.f,dgeevx.f,cgeevx.f,zgeevx.f,+gehd2,sgehd2.f,dgehd2.f,cgehd2.f,zgehd2.f,+gehrd,sgehrd.f,dgehrd.f,cgehrd.f,zgehrd.f,+gejsv,sgejsv.f,dgejsv.f,,,+gelq2,sgelq2.f,dgelq2.f,cgelq2.f,zgelq2.f,+gelqf,sgelqf.f,dgelqf.f,cgelqf.f,zgelqf.f,+gels,sgels.f,dgels.f,cgels.f,zgels.f,+gelsd,sgelsd.f,dgelsd.f,cgelsd.f,zgelsd.f,+gelss,sgelss.f,dgelss.f,cgelss.f,zgelss.f,+gelsy,sgelsy.f,dgelsy.f,cgelsy.f,zgelsy.f,+geql2,sgeql2.f,dgeql2.f,cgeql2.f,zgeql2.f,+geqlf,sgeqlf.f,dgeqlf.f,cgeqlf.f,zgeqlf.f,+geqp3,sgeqp3.f,dgeqp3.f,cgeqp3.f,zgeqp3.f,+geqr2,sgeqr2.f,dgeqr2.f,cgeqr2.f,zgeqr2.f,+geqr2p,sgeqr2p.f,dgeqr2p.f,cgeqr2p.f,zgeqr2p.f,+geqrf,sgeqrf.f,dgeqrf.f,cgeqrf.f,zgeqrf.f,+geqrfp,sgeqrfp.f,dgeqrfp.f,cgeqrfp.f,zgeqrfp.f,+gerfs,sgerfs.f,dgerfs.f,cgerfs.f,zgerfs.f,+gerq2,sgerq2.f,dgerq2.f,cgerq2.f,zgerq2.f,+gerqf,sgerqf.f,dgerqf.f,cgerqf.f,zgerqf.f,+gesc2,sgesc2.f,dgesc2.f,cgesc2.f,zgesc2.f,+gesdd,sgesdd.f,dgesdd.f,cgesdd.f,zgesdd.f,+gesv,sgesv.f,dgesv.f,cgesv.f,zgesv.f,+gesvd,sgesvd.f,dgesvd.f,cgesvd.f,zgesvd.f,+gesvj,sgesvj.f,dgesvj.f,,,+gesvx,sgesvx.f,dgesvx.f,cgesvx.f,zgesvx.f,+getc2,sgetc2.f,dgetc2.f,cgetc2.f,zgetc2.f,+getf2,sgetf2.f,dgetf2.f,cgetf2.f,zgetf2.f,+getrf,sgetrf.f,dgetrf.f,cgetrf.f,zgetrf.f,+getri,sgetri.f,dgetri.f,cgetri.f,zgetri.f,+getrs,sgetrs.f,dgetrs.f,cgetrs.f,zgetrs.f,+ggbak,sggbak.f,dggbak.f,cggbak.f,zggbak.f,+ggbal,sggbal.f,dggbal.f,cggbal.f,zggbal.f,+gges,sgges.f,dgges.f,cgges.f,zgges.f,+ggesx,sggesx.f,dggesx.f,cggesx.f,zggesx.f,+ggev,sggev.f,dggev.f,cggev.f,zggev.f,+ggevx,sggevx.f,dggevx.f,cggevx.f,zggevx.f,+ggglm,sggglm.f,dggglm.f,cggglm.f,zggglm.f,+gghrd,sgghrd.f,dgghrd.f,cgghrd.f,zgghrd.f,+gglse,sgglse.f,dgglse.f,cgglse.f,zgglse.f,+ggqrf,sggqrf.f,dggqrf.f,cggqrf.f,zggqrf.f,+ggrqf,sggrqf.f,dggrqf.f,cggrqf.f,zggrqf.f,+gsvj0,sgsvj0.f,dgsvj0.f,,,+gsvj1,sgsvj1.f,dgsvj1.f,,,+gtcon,sgtcon.f,dgtcon.f,cgtcon.f,zgtcon.f,+gtrfs,sgtrfs.f,dgtrfs.f,cgtrfs.f,zgtrfs.f,+gtsv,sgtsv.f,dgtsv.f,cgtsv.f,zgtsv.f,+gtsvx,sgtsvx.f,dgtsvx.f,cgtsvx.f,zgtsvx.f,+gttrf,sgttrf.f,dgttrf.f,cgttrf.f,zgttrf.f,+gttrs,sgttrs.f,dgttrs.f,cgttrs.f,zgttrs.f,+gtts2,sgtts2.f,dgtts2.f,cgtts2.f,zgtts2.f,+hbev,,,chbev.f,zhbev.f,+hbevd,,,chbevd.f,zhbevd.f,+hbevx,,,chbevx.f,zhbevx.f,+hbgst,,,chbgst.f,zhbgst.f,+hbgv,,,chbgv.f,zhbgv.f,+hbgvd,,,chbgvd.f,zhbgvd.f,+hbgvx,,,chbgvx.f,zhbgvx.f,+hbtrd,,,chbtrd.f,zhbtrd.f,+hecon,,,checon.f,zhecon.f,+heequb,,,cheequb.f,zheequb.f,+heev,,,cheev.f,zheev.f,+heevd,,,cheevd.f,zheevd.f,+heevr,,,cheevr.f,zheevr.f,+heevx,,,cheevx.f,zheevx.f,+hegs2,,,chegs2.f,zhegs2.f,+hegst,,,chegst.f,zhegst.f,+hegv,,,chegv.f,zhegv.f,+hegvd,,,chegvd.f,zhegvd.f,+hegvx,,,chegvx.f,zhegvx.f,+herfs,,,cherfs.f,zherfs.f,+hesv,,,chesv.f,zhesv.f,+hesvx,,,chesvx.f,zhesvx.f,+heswapr,,,cheswapr.f,zheswapr.f,+hetd2,,,chetd2.f,zhetd2.f,+hetf2,,,chetf2.f,zhetf2.f,+hetrd,,,chetrd.f,zhetrd.f,+hetrf,,,chetrf.f,zhetrf.f,+hetri,,,chetri.f,zhetri.f,+hetri2,,,chetri2.f,zhetri2.f,+hetri2x,,,chetri2x.f,zhetri2x.f,+hetrs,,,chetrs.f,zhetrs.f,+hetrs2,,,chetrs2.f,zhetrs2.f,+hfrk,,,chfrk.f,zhfrk.f,+hgeqz,shgeqz.f,dhgeqz.f,chgeqz.f,zhgeqz.f,+hpcon,,,chpcon.f,zhpcon.f,+hpev,,,chpev.f,zhpev.f,+hpevd,,,chpevd.f,zhpevd.f,+hpevx,,,chpevx.f,zhpevx.f,+hpgst,,,chpgst.f,zhpgst.f,+hpgv,,,chpgv.f,zhpgv.f,+hpgvd,,,chpgvd.f,zhpgvd.f,+hpgvx,,,chpgvx.f,zhpgvx.f,+hprfs,,,chprfs.f,zhprfs.f,+hpsv,,,chpsv.f,zhpsv.f,+hpsvx,,,chpsvx.f,zhpsvx.f,+hptrd,,,chptrd.f,zhptrd.f,+hptrf,,,chptrf.f,zhptrf.f,+hptri,,,chptri.f,zhptri.f,+hptrs,,,chptrs.f,zhptrs.f,+hsein,shsein.f,dhsein.f,chsein.f,zhsein.f,+hseqr,shseqr.f,dhseqr.f,chseqr.f,zhseqr.f,+ilalc,ilaslc.f,iladlc.f,ilaclc.f,ilazlc.f,+ilalr,ilaslr.f,iladlr.f,ilaclr.f,ilazlr.f,+imax1,,,icmax1.f,izmax1.f,+isnan,sisnan.f,disnan.f,,,+labad,slabad.f,dlabad.f,,,+labrd,slabrd.f,dlabrd.f,clabrd.f,zlabrd.f,+lacgv,,,clacgv.f,zlacgv.f,+lacn2,slacn2.f,dlacn2.f,clacn2.f,zlacn2.f,+lacon,slacon.f,dlacon.f,clacon.f,zlacon.f,+lacp2,,,clacp2.f,zlacp2.f,+lacpy,slacpy.f,dlacpy.f,clacpy.f,zlacpy.f,+lacrm,,,clacrm.f,zlacrm.f,+lacrt,,,clacrt.f,zlacrt.f,+ladiv,sladiv.f,dladiv.f,cladiv.f,zladiv.f,+lae2,slae2.f,dlae2.f,,,+laebz,slaebz.f,dlaebz.f,,,+laed0,slaed0.f,dlaed0.f,claed0.f,zlaed0.f,+laed1,slaed1.f,dlaed1.f,,,+laed2,slaed2.f,dlaed2.f,,,+laed3,slaed3.f,dlaed3.f,,,+laed4,slaed4.f,dlaed4.f,,,+laed5,slaed5.f,dlaed5.f,,,+laed6,slaed6.f,dlaed6.f,,,+laed7,slaed7.f,dlaed7.f,claed7.f,zlaed7.f,+laed8,slaed8.f,dlaed8.f,claed8.f,zlaed8.f,+laed9,slaed9.f,dlaed9.f,,,+laeda,slaeda.f,dlaeda.f,,,+laein,slaein.f,dlaein.f,claein.f,zlaein.f,+laesy,,,claesy.f,zlaesy.f,+laev2,slaev2.f,dlaev2.f,claev2.f,zlaev2.f,+laexc,slaexc.f,dlaexc.f,,,+lag2,slag2.f,dlag2.f,,,+lag2c,,,,zlag2c.f,+lag2d,slag2d.f,,,,+lag2s,,dlag2s.f,,,+lag2z,,,clag2z.f,,+lags2,slags2.f,dlags2.f,clags2.f,zlags2.f,+lagtf,slagtf.f,dlagtf.f,,,+lagtm,slagtm.f,dlagtm.f,clagtm.f,zlagtm.f,+lagts,slagts.f,dlagts.f,,,+lagv2,slagv2.f,dlagv2.f,,,+lahef,,,clahef.f,zlahef.f,+lahqr,slahqr.f,dlahqr.f,clahqr.f,zlahqr.f,+lahr2,slahr2.f,dlahr2.f,clahr2.f,zlahr2.f,+laic1,slaic1.f,dlaic1.f,claic1.f,zlaic1.f,+laisnan,slaisnan.f,dlaisnan.f,,,+laln2,slaln2.f,dlaln2.f,,,+lals0,slals0.f,dlals0.f,clals0.f,zlals0.f,+lalsa,slalsa.f,dlalsa.f,clalsa.f,zlalsa.f,+lalsd,slalsd.f,dlalsd.f,clalsd.f,zlalsd.f,+lamrg,slamrg.f,dlamrg.f,,,+laneg,slaneg.f,dlaneg.f,,,+langb,slangb.f,dlangb.f,clangb.f,zlangb.f,+lange,slange.f,dlange.f,clange.f,zlange.f,+langt,slangt.f,dlangt.f,clangt.f,zlangt.f,+lanhb,,,clanhb.f,zlanhb.f,+lanhe,,,clanhe.f,zlanhe.f,+lanhf,,,clanhf.f,zlanhf.f,+lanhp,,,clanhp.f,zlanhp.f,+lanhs,slanhs.f,dlanhs.f,clanhs.f,zlanhs.f,+lanht,,,clanht.f,zlanht.f,+lansb,slansb.f,dlansb.f,clansb.f,zlansb.f,+lansf,slansf.f,dlansf.f,,,+lansp,slansp.f,dlansp.f,clansp.f,zlansp.f,+lanst,slanst.f,dlanst.f,,,+lansy,slansy.f,dlansy.f,clansy.f,zlansy.f,+lantb,slantb.f,dlantb.f,clantb.f,zlantb.f,+lantp,slantp.f,dlantp.f,clantp.f,zlantp.f,+lantr,slantr.f,dlantr.f,clantr.f,zlantr.f,+lanv2,slanv2.f,dlanv2.f,,,+lapll,slapll.f,dlapll.f,clapll.f,zlapll.f,+lapmr,slapmr.f,dlapmr.f,clapmr.f,zlapmr.f,+lapmt,slapmt.f,dlapmt.f,clapmt.f,zlapmt.f,+lapy2,slapy2.f,dlapy2.f,,,+lapy3,slapy3.f,dlapy3.f,,,+laqgb,slaqgb.f,dlaqgb.f,claqgb.f,zlaqgb.f,+laqge,slaqge.f,dlaqge.f,claqge.f,zlaqge.f,+laqhb,,,claqhb.f,zlaqhb.f,+laqhe,,,claqhe.f,zlaqhe.f,+laqhp,,,claqhp.f,zlaqhp.f,+laqp2,slaqp2.f,dlaqp2.f,claqp2.f,zlaqp2.f,+laqps,slaqps.f,dlaqps.f,claqps.f,zlaqps.f,+laqr0,slaqr0.f,dlaqr0.f,claqr0.f,zlaqr0.f,+laqr1,slaqr1.f,dlaqr1.f,claqr1.f,zlaqr1.f,+laqr2,slaqr2.f,dlaqr2.f,claqr2.f,zlaqr2.f,+laqr3,slaqr3.f,dlaqr3.f,claqr3.f,zlaqr3.f,+laqr4,slaqr4.f,dlaqr4.f,claqr4.f,zlaqr4.f,+laqr5,slaqr5.f,dlaqr5.f,claqr5.f,zlaqr5.f,+laqsb,slaqsb.f,dlaqsb.f,claqsb.f,zlaqsb.f,+laqsp,slaqsp.f,dlaqsp.f,claqsp.f,zlaqsp.f,+laqsy,slaqsy.f,dlaqsy.f,claqsy.f,zlaqsy.f,+laqtr,slaqtr.f,dlaqtr.f,,,+lar1v,slar1v.f,dlar1v.f,clar1v.f,zlar1v.f,+lar2v,slar2v.f,dlar2v.f,clar2v.f,zlar2v.f,+larcm,,,clarcm.f,zlarcm.f,+larf,slarf.f,dlarf.f,clarf.f,zlarf.f,+larfb,slarfb.f,dlarfb.f,clarfb.f,zlarfb.f,+larfg,slarfg.f,dlarfg.f,clarfg.f,zlarfg.f,+larfgp,slarfgp.f,dlarfgp.f,clarfgp.f,zlarfgp.f,+larft,slarft.f,dlarft.f,clarft.f,zlarft.f,+larfx,slarfx.f,dlarfx.f,clarfx.f,zlarfx.f,+largv,slargv.f,dlargv.f,clargv.f,zlargv.f,+larnv,slarnv.f,dlarnv.f,clarnv.f,zlarnv.f,+larra,slarra.f,dlarra.f,,,+larrb,slarrb.f,dlarrb.f,,,+larrc,slarrc.f,dlarrc.f,,,+larrd,slarrd.f,dlarrd.f,,,+larre,slarre.f,dlarre.f,,,+larrf,slarrf.f,dlarrf.f,,,+larrj,slarrj.f,dlarrj.f,,,+larrk,slarrk.f,dlarrk.f,,,+larrr,slarrr.f,dlarrr.f,,,+larrv,slarrv.f,dlarrv.f,clarrv.f,zlarrv.f,+lartg,slartg.f,dlartg.f,clartg.f,zlartg.f,+lartgp,slartgp.f,dlartgp.f,,,+lartgs,slartgs.f,dlartgs.f,,,+lartv,slartv.f,dlartv.f,clartv.f,zlartv.f,+laruv,slaruv.f,dlaruv.f,,,+larz,slarz.f,dlarz.f,clarz.f,zlarz.f,+larzb,slarzb.f,dlarzb.f,clarzb.f,zlarzb.f,+larzt,slarzt.f,dlarzt.f,clarzt.f,zlarzt.f,+las2,slas2.f,dlas2.f,,,+lascl,slascl.f,dlascl.f,clascl.f,zlascl.f,+lasd0,slasd0.f,dlasd0.f,,,+lasd1,slasd1.f,dlasd1.f,,,+lasd2,slasd2.f,dlasd2.f,,,+lasd3,slasd3.f,dlasd3.f,,,+lasd4,slasd4.f,dlasd4.f,,,+lasd5,slasd5.f,dlasd5.f,,,+lasd6,slasd6.f,dlasd6.f,,,+lasd7,slasd7.f,dlasd7.f,,,+lasd8,slasd8.f,dlasd8.f,,,+lasda,slasda.f,dlasda.f,,,+lasdq,slasdq.f,dlasdq.f,,,+lasdt,slasdt.f,,,,+lasdt,,dlasdt.f,,,+laset,slaset.f,dlaset.f,claset.f,zlaset.f,+lasq1,slasq1.f,dlasq1.f,,,+lasq2,slasq2.f,dlasq2.f,,,+lasq4,slasq4.f,dlasq4.f,,,+lasq5,slasq5.f,dlasq5.f,,,+lasq6,slasq6.f,dlasq6.f,,,+lasr,slasr.f,dlasr.f,clasr.f,zlasr.f,+lasrt,slasrt.f,dlasrt.f,,,+lassq,slassq.f,dlassq.f,classq.f,zlassq.f,+lasv2,slasv2.f,dlasv2.f,,,+laswp,slaswp.f,dlaswp.f,claswp.f,zlaswp.f,+lasy2,slasy2.f,dlasy2.f,,,+lasyf,slasyf.f,dlasyf.f,clasyf.f,zlasyf.f,+lat2c,,,,zlat2c.f,+lat2s,,dlat2s.f,,,+latbs,slatbs.f,dlatbs.f,clatbs.f,zlatbs.f,+latdf,slatdf.f,dlatdf.f,clatdf.f,zlatdf.f,+latps,slatps.f,dlatps.f,clatps.f,zlatps.f,+latrd,slatrd.f,dlatrd.f,clatrd.f,zlatrd.f,+latrs,slatrs.f,dlatrs.f,clatrs.f,zlatrs.f,+latrz,slatrz.f,dlatrz.f,clatrz.f,zlatrz.f,+lauu2,slauu2.f,dlauu2.f,clauu2.f,zlauu2.f,+lauum,slauum.f,dlauum.f,clauum.f,zlauum.f,+opgtr,sopgtr.f,dopgtr.f,,,+opmtr,sopmtr.f,dopmtr.f,,,+orbdb,sorbdb.f,dorbdb.f,,,+orcsd,sorcsd.f,dorcsd.f,,,+org2l,sorg2l.f,dorg2l.f,,,+org2r,sorg2r.f,dorg2r.f,,,+orgbr,sorgbr.f,dorgbr.f,,,+orghr,sorghr.f,dorghr.f,,,+orgl2,sorgl2.f,dorgl2.f,,,+orglq,sorglq.f,dorglq.f,,,+orgql,sorgql.f,dorgql.f,,,+orgqr,sorgqr.f,dorgqr.f,,,+orgr2,sorgr2.f,dorgr2.f,,,+orgrq,sorgrq.f,dorgrq.f,,,+orgtr,sorgtr.f,dorgtr.f,,,+orm2l,sorm2l.f,dorm2l.f,,,+orm2r,sorm2r.f,dorm2r.f,,,+ormbr,sormbr.f,dormbr.f,,,+ormhr,sormhr.f,dormhr.f,,,+orml2,sorml2.f,dorml2.f,,,+ormlq,sormlq.f,dormlq.f,,,+ormql,sormql.f,dormql.f,,,+ormqr,sormqr.f,dormqr.f,,,+ormr2,sormr2.f,dormr2.f,,,+ormr3,sormr3.f,dormr3.f,,,+ormrq,sormrq.f,dormrq.f,,,+ormrz,sormrz.f,dormrz.f,,,+ormtr,sormtr.f,dormtr.f,,,+pbcon,spbcon.f,dpbcon.f,cpbcon.f,zpbcon.f,+pbequ,spbequ.f,dpbequ.f,cpbequ.f,zpbequ.f,+pbrfs,spbrfs.f,dpbrfs.f,cpbrfs.f,zpbrfs.f,+pbstf,spbstf.f,dpbstf.f,cpbstf.f,zpbstf.f,+pbsv,spbsv.f,dpbsv.f,cpbsv.f,zpbsv.f,+pbsvx,spbsvx.f,dpbsvx.f,cpbsvx.f,zpbsvx.f,+pbtf2,spbtf2.f,dpbtf2.f,cpbtf2.f,zpbtf2.f,+pbtrf,spbtrf.f,dpbtrf.f,cpbtrf.f,zpbtrf.f,+pbtrs,spbtrs.f,dpbtrs.f,cpbtrs.f,zpbtrs.f,+pftrf,spftrf.f,dpftrf.f,cpftrf.f,zpftrf.f,+pftri,spftri.f,dpftri.f,cpftri.f,zpftri.f,+pftrs,spftrs.f,dpftrs.f,cpftrs.f,zpftrs.f,+pocon,spocon.f,dpocon.f,cpocon.f,zpocon.f,+poequ,spoequ.f,dpoequ.f,cpoequ.f,zpoequ.f,+poequb,spoequb.f,dpoequb.f,cpoequb.f,zpoequb.f,+porfs,sporfs.f,dporfs.f,cporfs.f,zporfs.f,+posv,sposv.f,dposv.f,cposv.f,zposv.f,+posvx,sposvx.f,dposvx.f,cposvx.f,zposvx.f,+potf2,spotf2.f,dpotf2.f,cpotf2.f,zpotf2.f,+potrf,spotrf.f,dpotrf.f,cpotrf.f,zpotrf.f,+potri,spotri.f,dpotri.f,cpotri.f,zpotri.f,+potrs,spotrs.f,dpotrs.f,cpotrs.f,zpotrs.f,+ppcon,sppcon.f,dppcon.f,cppcon.f,zppcon.f,+ppequ,sppequ.f,dppequ.f,cppequ.f,zppequ.f,+pprfs,spprfs.f,dpprfs.f,cpprfs.f,zpprfs.f,+ppsv,sppsv.f,dppsv.f,cppsv.f,zppsv.f,+ppsvx,sppsvx.f,dppsvx.f,cppsvx.f,zppsvx.f,+pptrf,spptrf.f,dpptrf.f,cpptrf.f,zpptrf.f,+pptri,spptri.f,dpptri.f,cpptri.f,zpptri.f,+pptrs,spptrs.f,dpptrs.f,cpptrs.f,zpptrs.f,+pstf2,spstf2.f,dpstf2.f,cpstf2.f,zpstf2.f,+pstrf,spstrf.f,dpstrf.f,cpstrf.f,zpstrf.f,+ptcon,sptcon.f,dptcon.f,cptcon.f,zptcon.f,+pteqr,spteqr.f,dpteqr.f,cpteqr.f,zpteqr.f,+ptrfs,sptrfs.f,dptrfs.f,cptrfs.f,zptrfs.f,+ptsv,sptsv.f,dptsv.f,cptsv.f,zptsv.f,+ptsvx,sptsvx.f,dptsvx.f,cptsvx.f,zptsvx.f,+pttrf,spttrf.f,dpttrf.f,cpttrf.f,zpttrf.f,+pttrs,spttrs.f,dpttrs.f,cpttrs.f,zpttrs.f,+ptts2,sptts2.f,dptts2.f,cptts2.f,zptts2.f,+rot,,,crot.f,zrot.f,+rscl,srscl.f,drscl.f,csrscl.f,zdrscl.f,+sbev,ssbev.f,dsbev.f,,,+sbevd,ssbevd.f,dsbevd.f,,,+sbevx,ssbevx.f,dsbevx.f,,,+sbgst,ssbgst.f,dsbgst.f,,,+sbgv,ssbgv.f,dsbgv.f,,,+sbgvd,ssbgvd.f,dsbgvd.f,,,+sbgvx,ssbgvx.f,dsbgvx.f,,,+sbtrd,ssbtrd.f,dsbtrd.f,,,+sfrk,ssfrk.f,dsfrk.f,,,+sgesv,,dsgesv.f,,,+spcon,sspcon.f,dspcon.f,cspcon.f,zspcon.f,+spev,sspev.f,dspev.f,,,+spevd,sspevd.f,dspevd.f,,,+spevx,sspevx.f,dspevx.f,,,+spgst,sspgst.f,dspgst.f,,,+spgv,sspgv.f,dspgv.f,,,+spgvd,sspgvd.f,dspgvd.f,,,+spgvx,sspgvx.f,dspgvx.f,,,+spmv,,,cspmv.f,zspmv.f,+sposv,,dsposv.f,,,+spr,,,cspr.f,zspr.f,+sprfs,ssprfs.f,dsprfs.f,csprfs.f,zsprfs.f,+spsv,sspsv.f,dspsv.f,cspsv.f,zspsv.f,+spsvx,sspsvx.f,dspsvx.f,cspsvx.f,zspsvx.f,+sptrd,ssptrd.f,dsptrd.f,,,+sptrf,ssptrf.f,dsptrf.f,csptrf.f,zsptrf.f,+sptri,ssptri.f,dsptri.f,csptri.f,zsptri.f,+sptrs,ssptrs.f,dsptrs.f,csptrs.f,zsptrs.f,+stebz,sstebz.f,dstebz.f,,,+stedc,sstedc.f,dstedc.f,cstedc.f,zstedc.f,+stegr,sstegr.f,dstegr.f,cstegr.f,zstegr.f,+stein,sstein.f,dstein.f,cstein.f,zstein.f,+stemr,sstemr.f,dstemr.f,cstemr.f,zstemr.f,+steqr,ssteqr.f,dsteqr.f,csteqr.f,zsteqr.f,+sterf,ssterf.f,dsterf.f,,,+stev,sstev.f,dstev.f,,,+stevd,sstevd.f,dstevd.f,,,+stevr,sstevr.f,dstevr.f,,,+stevx,sstevx.f,dstevx.f,,,+sum1,,,scsum1.f,dzsum1.f,+sycon,ssycon.f,dsycon.f,csycon.f,zsycon.f,+syconv,ssyconv.f,dsyconv.f,csyconv.f,zsyconv.f,+syequb,ssyequb.f,dsyequb.f,csyequb.f,zsyequb.f,+syev,ssyev.f,dsyev.f,,,+syevd,ssyevd.f,dsyevd.f,,,+syevr,ssyevr.f,dsyevr.f,,,+syevx,ssyevx.f,dsyevx.f,,,+sygs2,ssygs2.f,dsygs2.f,,,+sygst,ssygst.f,dsygst.f,,,+sygv,ssygv.f,dsygv.f,,,+sygvd,ssygvd.f,dsygvd.f,,,+sygvx,ssygvx.f,dsygvx.f,,,+symv,,,csymv.f,zsymv.f,+syr,,,csyr.f,zsyr.f,+syrfs,ssyrfs.f,dsyrfs.f,csyrfs.f,zsyrfs.f,+sysv,ssysv.f,dsysv.f,csysv.f,zsysv.f,+sysvx,ssysvx.f,dsysvx.f,csysvx.f,zsysvx.f,+syswapr,ssyswapr.f,dsyswapr.f,csyswapr.f,zsyswapr.f,+sytd2,ssytd2.f,dsytd2.f,,,+sytf2,ssytf2.f,dsytf2.f,csytf2.f,zsytf2.f,+sytrd,ssytrd.f,dsytrd.f,,,+sytrf,ssytrf.f,dsytrf.f,csytrf.f,zsytrf.f,+sytri,ssytri.f,dsytri.f,csytri.f,zsytri.f,+sytri2,ssytri2.f,dsytri2.f,csytri2.f,zsytri2.f,+sytri2x,ssytri2x.f,dsytri2x.f,csytri2x.f,zsytri2x.f,+sytrs,ssytrs.f,dsytrs.f,csytrs.f,zsytrs.f,+sytrs2,ssytrs2.f,dsytrs2.f,csytrs2.f,zsytrs2.f,+tbcon,stbcon.f,dtbcon.f,ctbcon.f,ztbcon.f,+tbrfs,stbrfs.f,dtbrfs.f,ctbrfs.f,ztbrfs.f,+tbtrs,stbtrs.f,dtbtrs.f,ctbtrs.f,ztbtrs.f,+tfsm,stfsm.f,dtfsm.f,ctfsm.f,ztfsm.f,+tftri,stftri.f,dtftri.f,ctftri.f,ztftri.f,+tfttp,stfttp.f,dtfttp.f,ctfttp.f,ztfttp.f,+tfttr,stfttr.f,dtfttr.f,ctfttr.f,ztfttr.f,+tgevc,stgevc.f,dtgevc.f,ctgevc.f,ztgevc.f,+tgex2,stgex2.f,dtgex2.f,ctgex2.f,ztgex2.f,+tgexc,stgexc.f,dtgexc.f,ctgexc.f,ztgexc.f,+tgsen,stgsen.f,dtgsen.f,ctgsen.f,ztgsen.f,+tgsja,stgsja.f,dtgsja.f,ctgsja.f,ztgsja.f,+tgsna,stgsna.f,dtgsna.f,ctgsna.f,ztgsna.f,+tgsy2,stgsy2.f,dtgsy2.f,ctgsy2.f,ztgsy2.f,+tgsyl,stgsyl.f,dtgsyl.f,ctgsyl.f,ztgsyl.f,+tpcon,stpcon.f,dtpcon.f,ctpcon.f,ztpcon.f,+tprfs,stprfs.f,dtprfs.f,ctprfs.f,ztprfs.f,+tptri,stptri.f,dtptri.f,ctptri.f,ztptri.f,+tptrs,stptrs.f,dtptrs.f,ctptrs.f,ztptrs.f,+tpttf,stpttf.f,dtpttf.f,ctpttf.f,ztpttf.f,+tpttr,stpttr.f,dtpttr.f,ctpttr.f,ztpttr.f,+trcon,strcon.f,dtrcon.f,ctrcon.f,ztrcon.f,+trevc,strevc.f,dtrevc.f,ctrevc.f,ztrevc.f,+trexc,strexc.f,dtrexc.f,ctrexc.f,ztrexc.f,+trrfs,strrfs.f,dtrrfs.f,ctrrfs.f,ztrrfs.f,+trsen,strsen.f,dtrsen.f,ctrsen.f,ztrsen.f,+trsna,strsna.f,dtrsna.f,ctrsna.f,ztrsna.f,+trsyl,strsyl.f,dtrsyl.f,ctrsyl.f,ztrsyl.f,+trti2,strti2.f,dtrti2.f,ctrti2.f,ztrti2.f,+trtri,strtri.f,dtrtri.f,ctrtri.f,ztrtri.f,+trtrs,strtrs.f,dtrtrs.f,ctrtrs.f,ztrtrs.f,+trttf,strttf.f,dtrttf.f,ctrttf.f,ztrttf.f,+trttp,strttp.f,dtrttp.f,ctrttp.f,ztrttp.f,+tzrzf,stzrzf.f,dtzrzf.f,ctzrzf.f,ztzrzf.f,+unbdb,,,cunbdb.f,zunbdb.f,+uncsd,,,cuncsd.f,zuncsd.f,+ung2l,,,cung2l.f,zung2l.f,+ung2r,,,cung2r.f,zung2r.f,+ungbr,,,cungbr.f,zungbr.f,+unghr,,,cunghr.f,zunghr.f,+ungl2,,,cungl2.f,zungl2.f,+unglq,,,cunglq.f,zunglq.f,+ungql,,,cungql.f,zungql.f,+ungqr,,,cungqr.f,zungqr.f,+ungr2,,,cungr2.f,zungr2.f,+ungrq,,,cungrq.f,zungrq.f,+ungtr,,,cungtr.f,zungtr.f,+unm2l,,,cunm2l.f,zunm2l.f,+unm2r,,,cunm2r.f,zunm2r.f,+unmbr,,,cunmbr.f,zunmbr.f,+unmhr,,,cunmhr.f,zunmhr.f,+unml2,,,cunml2.f,zunml2.f,+unmlq,,,cunmlq.f,zunmlq.f,+unmql,,,cunmql.f,zunmql.f,+unmqr,,,cunmqr.f,zunmqr.f,+unmr2,,,cunmr2.f,zunmr2.f,+unmr3,,,cunmr3.f,zunmr3.f,+unmrq,,,cunmrq.f,zunmrq.f,+unmrz,,,cunmrz.f,zunmrz.f,+unmtr,,,cunmtr.f,zunmtr.f,+upgtr,,,cupgtr.f,zupgtr.f,+upmtr,,,cupmtr.f,zupmtr.f,+chla_transtype,,,,,chla_transtype.f+ieeeck,,,,,ieeeck.f+ladiag,,,,,iladiag.f+laprec,,,,,ilaprec.f+latrans,,,,,ilatrans.f+lauplo,,,,,ilauplo.f
+ lapack-ffi-tools.cabal view
@@ -0,0 +1,87 @@+Name: lapack-ffi-tools+Version: 0.0+License: BSD3+License-File: LICENSE+Author: Henning Thielemann <haskell@henning-thielemann.de>+Maintainer: Henning Thielemann <haskell@henning-thielemann.de>+Homepage: http://hub.darcs.net/thielema/lapack-ffi-tools/+Category: Math+Synopsis: Generator for Haskell interface to Fortran LAPACK+Description:+ LAPACK is a package for efficient numerically robust linear algebra.+ The original implementation is written in FORTRAN.+ .+ The program in this package generates the modules+ for the packages @blas-ffi@, @blas-carray@, @lapack-ffi@, @lapack-carray@+ from the FORTRAN source files.+Tested-With: GHC==7.4.2, GHC==7.8.4+Cabal-Version: >=1.14+Build-Type: Simple+Data-Files:+ data/blas.csv+ data/lapack.csv++Source-Repository this+ Tag: 0.0+ Type: darcs+ Location: http://hub.darcs.net/thielema/lapack-ffi-tools/++Source-Repository head+ Type: darcs+ Location: http://hub.darcs.net/thielema/lapack-ffi-tools/++Executable create-lapack-ffi-single+ Build-Depends:+ parsec >=3.1 && <3.2,+ explicit-exception >=0.1.7.3 && <0.2,+ transformers >=0.3 && <0.6,+ containers >=0.4 && <0.6,+ utility-ht >=0.0.12 && <0.1,+ base >=4.5 && <4.11+ Main-Is: MainSingle.hs+ Other-Modules:+ CreateBinding+ Parser.Signature+ Parser.Combinator+ Hs-Source-Dirs: src+ Default-Language: Haskell98++ GHC-Options: -Wall -fwarn-tabs -fwarn-incomplete-record-updates -fwarn-unused-do-bind++Executable create-lapack-ffi+ Build-Depends:+ cassava >=0.4.5.1 && <0.5,+ optparse-applicative >=0.11 && <0.15,+ parsec >=3.1 && <3.2,+ explicit-exception >=0.1.7.3 && <0.2,+ transformers >=0.3 && <0.6,+ pathtype >=0.8 && <0.9,+ unordered-containers >=0.2.8 && <0.3,+ containers >=0.4 && <0.6,+ vector >=0.10 && <0.13,+ bytestring >=0.9.2.1 && <0.11,+ non-empty >=0.2 && <0.4,+ utility-ht >=0.0.14 && <0.1,+ base >=4.5 && <4.11+ Main-Is: MainAll.hs+ Other-Modules:+ CreateBinding+ Parser.Signature+ Parser.Combinator+ Type+ Hs-Source-Dirs: src+ Default-Language: Haskell98++ GHC-Options: -Wall -fwarn-tabs -fwarn-incomplete-record-updates -fwarn-unused-do-bind++Executable create-lapack-csv+ Build-Depends:+ filepath >=1.3 && <1.5,+ containers >=0.4 && <0.6,+ utility-ht >=0.0.12 && <0.1,+ base >=4.5 && <4.11+ Main-Is: CreateCSV.hs+ Hs-Source-Dirs: src+ Default-Language: Haskell98++ GHC-Options: -Wall -fwarn-tabs -fwarn-incomplete-record-updates -fwarn-unused-do-bind
+ src/CreateBinding.hs view
@@ -0,0 +1,424 @@+module CreateBinding where++import qualified Parser.Signature as Parser+import qualified Type+import Parser.Signature (Identifier)++import qualified Text.ParserCombinators.Parsec as Parsec++import qualified Control.Monad.Exception.Synchronous as ME+import qualified Control.Monad.Trans.Writer as MW+import qualified Control.Functor.HT as Func+import Control.Monad (when)++import qualified Data.Foldable as Fold+import qualified Data.List.Match as Match+import qualified Data.List.HT as ListHT+import qualified Data.List as List+import qualified Data.Map as Map+import qualified Data.Set as Set+import Data.Traversable (forM)+import Data.Tuple.HT (mapPair, mapFst, mapSnd, mapSnd3, fst3, snd3, thd3)+import Data.Map (Map)+import Data.Set (Set)+import Data.Char (toLower, isSpace, isAlpha, isAlphaNum)+import Data.Maybe (fromMaybe, mapMaybe)++import Text.Printf (printf)+++type MonoMapping = Type.Mapping String Type.Mono+data Mapping = Mapping (Maybe [String]) Bool+type RawParameter =+ (String, (Type.Mono, Mapping),+ Maybe (Parser.Direction, Type.Mono, Maybe MonoMapping))+type Parameter = (String, (Type.Mono, MonoMapping, Parser.Direction))++examineParamInfo ::+ ((Identifier, [String], Maybe Type.Mono), [Parser.ParamDecl],+ Map String (Parser.Direction, Type.Mono, Maybe MonoMapping)) ->+ ME.Exceptional String (Identifier, [RawParameter], Maybe Type.Mono)+examineParamInfo ((name, paramNames, returnType), paramDecls, paramDirs) =+ let (paramTypes,externals) =+ ListHT.unzipEithers $+ map+ (\decl ->+ case decl of+ Parser.Type typ ps -> Left (typ,ps)+ Parser.External ps -> Right ps)+ paramDecls+ externalSet :: Set String+ externalSet = Fold.foldMap Set.fromList externals+ typeMap =+ Map.fromList $+ concatMap+ (\(typ,params) -> map (\(param,dims) -> (param,(typ,dims))) params)+ paramTypes+ mapp pm param = Mapping pm $ Set.member param externalSet+ in fmap (\params -> (name, params, returnType)) $+ forM paramNames $ \param ->+ ME.fromMaybe ("no type declaration found for " ++ param) $+ fmap+ (\(typ,pm) ->+ (param, (typ, mapp pm param), Map.lookup param paramDirs)) $+ Map.lookup param typeMap++fallbackMapping :: Mapping -> MonoMapping+fallbackMapping pm =+ case pm of+ Mapping Nothing False -> Type.Scalar+ Mapping (Just dims) False -> Type.Array dims+ Mapping _ True -> Type.Function 0 Type.Integer++parameterFromRaw :: RawParameter -> Parameter+parameterFromRaw (name, (typ,dims), mdir) =+ (name,+ case mdir of+ Nothing -> (typ, fallbackMapping dims, Parser.Input)+ Just (dir, _typ, cmtDims) ->+ (typ, fromMaybe (fallbackMapping dims) cmtDims, dir))++compatibleDimension :: String -> String -> Bool+compatibleDimension x y = x == ("0:"++y++"-1") || x==y++compatibleDimensions :: [String] -> [String] -> Bool+compatibleDimensions =+ let go [] [] = True+ go ["*"] [_] = True+ go ["0:*"] [_] = True+ go (x:xs) (y:ys) = compatibleDimension x y && go xs ys+ go [] _ = False+ go _ [] = False+ trim = filter (not . isSpace)+ in \xs ys -> go (map trim xs) (map trim ys)++compatibleMapping :: Mapping -> MonoMapping -> Bool+compatibleMapping (Mapping Nothing False) Type.Scalar = True+compatibleMapping (Mapping (Just dims0) False) (Type.Array dims1) =+ compatibleDimensions dims0 dims1+compatibleMapping (Mapping Nothing True) (Type.Function _ _) = True+compatibleMapping _ _ = False++combineParamInfo :: [RawParameter] -> MW.Writer [String] [Parameter]+combineParamInfo params = do+ let (completeParams, incompleteParams) =+ ListHT.partitionMaybe (Func.mapThd3 id) params+ when (not $ null incompleteParams) $ MW.tell $ (:[]) $+ "parameters without or with ill-formatted details: " +++ List.intercalate ", " (map fst3 incompleteParams)+ let inconsistentTypes =+ filter (\(_name, typ, cmt) -> fst typ /= snd3 cmt) completeParams+ when (not $ null inconsistentTypes) $ MW.tell $ (:[]) $+ "parameters with inconsistent type definitions: " +++ List.intercalate ", " (map fst3 inconsistentTypes)+ let inconsistentDims =+ filter+ (\(_name, typ, cmt) ->+ Fold.any+ (\cmtDims -> not $ compatibleMapping (snd typ) cmtDims)+ (thd3 cmt))+ completeParams+ when (not $ null inconsistentDims) $ MW.tell $ (:[]) $+ "parameters with inconsistent dimension lists: " +++ List.intercalate ", " (map fst3 inconsistentDims)+ return $ map parameterFromRaw params++parseHeader ::+ Parsec.Parser (MW.Writer [String] (Identifier, [Parameter], Maybe Type.Mono))+parseHeader =+ fmap (Func.mapSnd3 combineParamInfo) $+ ME.switch fail return . examineParamInfo =<< Parser.header3_4+++foreignFromParameters ::+ [(name, (Type.Mono, Type.Mapping dims Type.Mono, dir))] ->+ Maybe Type.Mono -> Type.Foreign Type.Mono+foreignFromParameters params returnType =+ Type.Foreign+ (map+ (\(_name, (typ, mapping, _dir)) ->+ case mapping of+ Type.Scalar -> Type.Ptr typ+ Type.Array _ -> Type.Ptr typ+ Type.Function n param -> Type.FunPtr n param typ)+ params)+ returnType++formatForeignCall :: ((String, String), Type.Foreign Type.Mono) -> String+formatForeignCall ((haskellName, fortranName), foreignSig) =+ printf "foreign import ccall \"%s_\"\n" (map toLower fortranName) +++ printf " %s :: %s\n" haskellName (Type.formatForeign foreignSig)+++contFromType :: Type.Mono -> String+contFromType typ =+ case typ of+ Type.Logical -> "Call.bool"+ Type.Character -> "Call.char"+ Type.Integer -> "Call.cint"+ Type.RealSingle -> "Call.float"+ Type.RealDouble -> "Call.double"+ Type.ComplexSingle -> "Call.complexFloat"+ Type.ComplexDouble -> "Call.complexDouble"++isIOArray :: Parser.Direction -> Bool+isIOArray dir =+ case dir of+ Parser.InputOutput -> True+ Parser.InputWorkspace -> True+ _ -> False++contFromArrayType :: Parameter -> String+contFromArrayType (name, (typ, dims, dir)) =+ case dims of+ Type.Scalar ->+ if isInputDir dir+ then contFromType typ ++ " " ++ name+ else "Call.alloca"+ Type.Array _ ->+ (if isIOArray dir then "Call.ioarray " else "Call.array ") ++ name+ Type.Function _ _ -> "pure " ++ name++parens :: String -> String+parens expr = "("++expr++")"++parensIfNeeded :: String -> String+parensIfNeeded expr = if all isAlphaNum expr then expr else parens expr++arrayTypeFromBool :: Bool -> String+arrayTypeFromBool mutable = if mutable then "IOCArray" else "CArray"++arrayTypeFromDir :: Parser.Direction -> String+arrayTypeFromDir = arrayTypeFromBool . isIOArray++isInputDir :: Parser.Direction -> Bool+isInputDir dir =+ case dir of+ Parser.Input -> True+ Parser.InputOutput -> True+ Parser.InputWorkspace -> True+ Parser.Output -> False+ Parser.Workspace -> False++isOutput :: (Type.Mono, Type.Mapping dim Type.Mono, Parser.Direction) -> Bool+isOutput (_, dims, dir) =+ case dir of+ Parser.Input -> False+ Parser.InputOutput -> Type.isScalar dims+ Parser.InputWorkspace -> False+ Parser.Output -> True+ Parser.Workspace -> False+++parameterName :: String -> String+parameterName fortranName =+ case map toLower fortranName of+ "id" -> "id_"+ "in" -> "in_"+ "sin" -> "sin_"+ "type" -> "type_"+ haskellName -> haskellName++spanIdentifier :: String -> (String, String)+spanIdentifier str =+ case str of+ [] -> ([], str)+ c:cs ->+ if isAlpha c+ then mapFst (c:) $ span isAlphaNum cs+ else ([], str)++isIdentifier :: String -> Bool+isIdentifier str =+ case str of+ [] -> False+ c:cs -> isAlpha c && all isAlphaNum cs++sizeExpression :: String -> String -> (String, [String])+sizeExpression name =+ let c <: ~(strRem,vars) = (c:strRem, vars)+ str <++ ~(strRem,vars) = (str++strRem, vars)+ addVar var str = mapSnd (var:) $ var <++ str+ go paren str =+ case spanIdentifier str of+ ("", cs) ->+ case cs of+ "" ->+ (if null paren then "" else "{- too many closing parens -}",+ [])+ ' ':cs1 -> go paren cs1+ '/':cs1 -> "`div`" <++ go paren cs1+ '*':'*':cs1 -> "^!" <++ go paren cs1+ '(':cs1 -> '(' <: go (')':paren) cs1+ ')':cs1 ->+ case paren of+ p:ps -> p <: go ps cs1+ [] -> " {- missing closing -} )" <++ go paren cs1+ c:cs1 -> c <: go paren cs1+ ("MAX", '(':cs) -> "maximum[" <++ go (']':paren) cs+ ("max", '(':cs) -> "maximum[" <++ go (']':paren) cs+ ("MIN", '(':cs) -> "minimum[" <++ go (']':paren) cs+ ("min", '(':cs) -> "minimum[" <++ go (']':paren) cs+ ("ABS", '(':cs) -> "abs(" <++ go (')':paren) cs+ ("abs", '(':cs) -> "abs(" <++ go (')':paren) cs+ ("N", ' ':'l':'g':' ':'N':cs) -> addVar "nlgn" (go paren cs)+ (ident, cs) -> addVar (parameterName ident) (go paren cs)+ sizeName = name ++ "Size"+ in \str -> if str=="*" then (sizeName, [sizeName]) else go [] str++-- like nubBy but needs (n * log n) operations instead of (n^2)+ordnub :: (Ord a) => Set a -> [(a,b)] -> [(a,b)]+ordnub initSet xs =+ map fst $ filter snd $ zip xs $ zipWith (Set.notMember . fst) xs $+ scanl (flip Set.insert) initSet $ map fst xs+++peekOut :: Parameter -> String+peekOut (name, (typ, dims, _dir)) =+ case dims of+ Type.Scalar ->+ case typ of+ Type.Character -> printf "fmap castCCharToChar (peek %sPtr)" name+ Type.Integer -> printf "fmap fromIntegral (peek %sPtr)" name+ _ -> printf "peek %sPtr" name+ Type.Array _ -> "pure " ++ name+ Type.Function _ _ ->+ printf "error \"function %s cannot be an output\"" name++formatOutputTuple :: Type.Format typ => Type.Wrapper typ -> String+formatOutputTuple (Type.Wrapper _inputs returnType outputs) =+ let outputTuple =+ CreateBinding.parens $ List.intercalate ", " $+ map (uncurry $ Type.formatArray "CArray") outputs+ in case (returnType, outputs) of+ (Nothing, _) -> outputTuple+ (Just t, []) -> Type.format t+ -- I have not encountered this case so far+ (Just t, _) -> printf "(%s, %s)" (Type.format t) outputTuple+++formatCArrayWrapper ::+ (String, [Parameter], Maybe Type.Mono) -> (String, Type.Wrapper Type.Mono)+formatCArrayWrapper (name, params0, returnType) =+ let prepare (param,info) =+ (param,+ mapSnd3+ (Type.mapMappings (map (sizeExpression param) . reverse)) info)+ pparams = map (prepare . mapFst parameterName) params0+ params = map (mapSnd (mapSnd3 (Type.mapMapping fst))) pparams+ (inputArrays,allocArrays) =+ ListHT.partition (isInputDir . snd . snd) $+ mapMaybe+ (\(param,(_typ,mapping,dir)) -> do+ dimVars <- Type.maybeArray mapping+ return (param,(dimVars,dir)))+ pparams+ dimNames param = map (printf "%sDim%d" param) [(0::Int)..]+ allDimVars =+ concatMap+ (\(param,(dimVars,_dir)) -> zip dimVars $ dimNames param)+ inputArrays+ inputsDup =+ concatMap+ (\(param, (typ,mapping,dir)) ->+ let (dims,vars) =+ case mapping of+ Type.Scalar -> (Type.Scalar, [])+ Type.Function n paramType ->+ (Type.Function n paramType, [])+ Type.Array dimVars ->+ mapPair (Type.Array, concat) $ Func.unzip dimVars+ in if isInputDir dir+ then [(param, (typ,dims,dir))]+ else map (flip (,) (Type.Integer,Type.Scalar,Parser.Input)) vars)+ pparams+ inputVars =+ Set.fromList $+ map fst inputsDup +++ filter isIdentifier (map (fst . fst) allDimVars)+ (varSet, (assigns,checks)) =+ mapSnd (mapPair (map snd, map snd) . ListHT.partition fst) $+ List.mapAccumL+ (\set rel@((dim,_vars),_dimId) ->+ let isIdent = isIdentifier dim+ in (if isIdent then Set.insert dim set else set,+ (isIdent && Set.notMember dim set, rel)))+ Set.empty+ allDimVars+ inputs = ordnub varSet inputsDup+ usedVars =+ Set.fromList $+ concatMap+ (\((dim,vars),_dimId) ->+ if isIdentifier dim then dim:vars else vars)+ checks+ +++ map fst params+ +++ concatMap+ (\(_param,(dimVars,_dir)) -> concatMap snd dimVars)+ allocArrays+ outputs = filter (isOutput . snd) params+ wrapper =+ Type.Wrapper+ (map+ (\(_param,(typ,dims,dir)) -> (typ, dims, isIOArray dir))+ inputs)+ returnType+ (map (\(_param,(typ,dims,_dir)) -> (typ,dims)) outputs)+ in flip (,) wrapper $+ unlines $+ printf "%s ::" name :+ map+ (\(param,(typ,dims,dir)) ->+ printf " %s {- ^ %s -} ->"+ (Type.formatArray (arrayTypeFromDir dir) typ dims) param)+ inputs +++ (" IO " ++ formatOutputTuple wrapper) :+ (name ++ concatMap ((' ':) . fst) inputs ++ " = do") :+ map+ (\(param,(dimVars,dir)) ->+ let format =+ if isIOArray dir+ then " %s <- Call.sizes%d <$> getBounds %s"+ else " let %s = Call.sizes%d $ bounds %s"+ dimIdents = Match.take dimVars $ dimNames param+ in printf format+ (Type.formatTuple dimIdents) (length dimIdents) param)+ inputArrays +++ map+ (\((dim,_),dimId) ->+ let underscore = if Set.member dim usedVars then "" else "_"+ in printf " let %s%s = %s" underscore dim dimId)+ assigns +++ map+ (\((dim,vars),dimId) ->+ if Set.isSubsetOf (Set.fromList vars) inputVars+ then+ printf " Call.assert \"%s: %s == %s\" (%s == %s)"+ name dim dimId dim dimId+ else+ printf " Call.ignore \"%s: %s == %s\" %s"+ name dim dimId (dimId::String))+ checks +++ map+ (\(param,(dims,_dir)) ->+ printf " %s <- Call.newArray%d%s"+ param (length dims)+ (concatMap ((' ':) . parensIfNeeded . fst) dims))+ allocArrays +++ " evalContT $ do" :+ map+ (\param ->+ printf " %sPtr <- %s" (fst param) (contFromArrayType param))+ params +++ (" liftIO $ FFI." ++ name +++ concatMap (printf " %sPtr" . fst) params) :+ (case outputs of+ [] -> []+ [param] -> [" liftIO $ " ++ peekOut param]+ _:os ->+ printf " liftIO $ pure (%s)" (Match.replicate os ',')+ :+ map ((" <*> " ++) . peekOut) outputs) +++ []
+ src/CreateCSV.hs view
@@ -0,0 +1,32 @@+module Main where++import System.FilePath (takeBaseName)++import qualified Data.List as List+import qualified Data.Map as Map+import qualified Data.Set as Set+import Data.Map (Map)+import Data.Maybe (mapMaybe)+import Data.Foldable (foldMap)+++singleton :: FilePath -> Maybe (Map String (Map Char FilePath))+singleton "" = Nothing+singleton str@(c:cs) =+ Just $ Map.singleton (takeBaseName cs) $ Map.singleton c str++group :: [String] -> ([Char], [(String, [FilePath])])+group xs =+ let ys = Map.unionsWith Map.union $ mapMaybe singleton xs+ columns = Set.toList $ foldMap Map.keysSet ys+ emptyColumns = Map.fromList $ map (flip (,) "") columns+ in (columns,+ Map.toAscList $ fmap (Map.elems . flip Map.union emptyColumns) ys)++formatCSV :: ([Char], [(String, [FilePath])]) -> [String]+formatCSV (header, rows) =+ ("Name," ++ List.intersperse ',' header) :+ map (\(name,cells) -> List.intercalate "," $ name:cells) rows++main :: IO ()+main = interact $ unlines . formatCSV . group . lines
+ src/MainAll.hs view
@@ -0,0 +1,365 @@+module Main where++import qualified CreateBinding+import qualified Type+import Parser.Signature (Identifier(Identifier))+import CreateBinding+ (formatForeignCall, formatCArrayWrapper, parseHeader,+ foreignFromParameters, arrayTypeFromBool)++import qualified Text.ParserCombinators.Parsec as Parsec+import qualified Text.ParserCombinators.Parsec.Error as ParsecError++import qualified Options.Applicative as OP++import qualified System.IO as IO+import qualified System.Path.PartClass as PathClass+import qualified System.Path.IO as PathIO+import qualified System.Path as Path+import System.Path.Directory (createDirectoryIfMissing)+import System.Path (takeFileName, (</>))++import Text.Printf (printf)++import qualified Data.Csv as Csv+import qualified Data.HashMap.Lazy as HashMap+import qualified Data.Map as Map+import qualified Data.ByteString.Lazy.Char8 as BL+import qualified Data.ByteString.Char8 as B+import qualified Data.Vector as Vector+import qualified Data.Foldable as Fold+import qualified Data.List.HT as ListHT+import qualified Data.List as List+import Data.Traversable (for, sequenceA, traverse)+import Data.Foldable (forM_)+import Data.Vector (Vector)+import Data.ByteString (ByteString)+import Data.Map (Map)+import Data.Csv ((.:))+import Data.Tuple.HT (mapSnd, fst3, snd3, thd3)+import Data.Maybe (isNothing)+import Data.Char (toUpper)+import Data.Monoid ((<>))++import qualified Control.Monad.Exception.Synchronous as ME+import qualified Control.Monad.Trans.Writer as MW+import qualified Control.Applicative.HT as App+import qualified Control.Functor.HT as Func+import Control.Monad (when, join)+import Control.Applicative (liftA2, (<$>), (<*>))++++class Type.Unification f => Generalize f where+ formatGenericSig :: f Type.Poly -> String++instance Generalize Type.Foreign where+ formatGenericSig = Type.formatForeign++instance Generalize Type.Wrapper where+ formatGenericSig wrapper@(Type.Wrapper inputs _returnType _outputs) =+ concatMap+ (\(typ,dims,dir) ->+ printf "%s -> " (Type.formatArray (arrayTypeFromBool dir) typ dims))+ inputs +++ "IO " ++ CreateBinding.formatOutputTuple wrapper++prepareClassCall ::+ (Generalize f) =>+ (String, f Type.Poly) -> (String, String, String, Char -> String)+prepareClassCall (name, func) =+ let typeName = map toUpper name+ sig = formatGenericSig func+ newtypeDef =+ printf "newtype %s a = %s {get%s :: %s}" typeName typeName typeName sig+ in (typeName, sig, newtypeDef,+ \abbr -> printf "(%s %c.%s)" typeName abbr name)++formatClassCall ::+ (Generalize f) => Char -> Char -> (String, f Type.Poly) -> String+formatClassCall singleAbbr doubleAbbr func@(name, _) =+ let (typeName, sig, newtypeDef, typeBranch) = prepareClassCall func+ in unlines $+ "" :+ "" :+ newtypeDef :+ "" :+ printf "%s :: Class.Real a => %s" name sig :+ printf "%s = get%s $ Class.switchReal %s %s"+ name typeName (typeBranch singleAbbr) (typeBranch doubleAbbr) :+ []++formatClassCallRC :: (Generalize f) => (String, f Type.Poly) -> String+formatClassCallRC func@(name, _) =+ let (typeName, sig, newtypeDef, typeBranch) = prepareClassCall func+ in unlines $+ "" :+ "" :+ newtypeDef :+ "" :+ printf "%s :: Class.Floating a => %s" name sig :+ printf "%s = get%s $ Class.switchFloating %s %s %s %s" name typeName+ (typeBranch 'S') (typeBranch 'D') (typeBranch 'C') (typeBranch 'Z') :+ []+++insertExportList :: [String] -> String -> String+insertExportList exports modul =+ (\(prefix,suffixes) ->+ map fst prefix +++ case suffixes of+ [] -> []+ (_,suffix):_ ->+ "(\n" ++ unlines (map (printf " %s,") exports) +++ " ) " ++ suffix) $+ break (List.isPrefixOf "where" . snd) $+ zip modul (ListHT.tails modul)++writeHeader ::+ (PathClass.AbsRel ar) =>+ Path.Dir ar -> B.ByteString -> Maybe [String] -> IO (Path.File ar)+writeHeader dstDir modul mexports = do+ let makePath =+ either (ioError . userError) (return . (dstDir </>)) . Path.parse+ tmplFile <- makePath $ B.unpack modul ++ "_tmpl.hs"+ dstFile <- makePath $ B.unpack modul ++ ".hs"+ tmpl <- PathIO.readFile tmplFile+ PathIO.writeFile dstFile $+ "-- Do not edit! Automatically generated by create-lapack-ffi.\n" +++ maybe tmpl (flip insertExportList tmpl) mexports+ return dstFile++indent :: String -> String+indent = unlines . map (" " ++) . lines++formatFileError :: (PathClass.AbsRel ar) => Path.File ar -> String -> String+formatFileError path msg =+ printf "\n%s:1:1:\n%s" (Path.toString path) (indent msg)++formatParseError :: Parsec.ParseError -> String+formatParseError err =+ let source = Parsec.errorPos err+ in printf "\n%s:%d:%d:\n%s"+ (Parsec.sourceName source)+ (Parsec.sourceLine source)+ (Parsec.sourceColumn source)+ (indent $ dropWhile ('\n'==) $+ ParsecError.showErrorMessages+ "or" "unknown parse error" "expecting" "unexpected" "end of input"+ (ParsecError.errorMessages err))++printError :: String -> IO ()+printError = IO.hPutStr IO.stderr++printFileError :: (PathClass.AbsRel ar) => Path.File ar -> String -> IO ()+printFileError path msg = printError $ formatFileError path msg+++nameColumn, miscColumn, floatColumn, doubleColumn,+ complexFloatColumn, complexDoubleColumn,+ realColumn, complexColumn, genericColumn :: ByteString+nameColumn = B.pack "Name"+miscColumn = B.pack "Misc"+floatColumn = B.pack "Float"+doubleColumn = B.pack "Double"+complexFloatColumn = B.pack "ComplexFloat"+complexDoubleColumn = B.pack "ComplexDouble"++realColumn = B.pack "Real"+complexColumn = B.pack "Complex"+genericColumn = B.pack "Generic"+++data FunctionSet = FunctionSet String (Map ByteString Path.RelFile)++newtype RelFile = RelFile {getRelFile :: Maybe Path.RelFile}++instance Csv.FromField RelFile where+ parseField str =+ fmap RelFile $+ if B.null str+ then return Nothing+ else either fail (return . Just) . Path.parse . B.unpack $ str++instance Csv.FromNamedRecord FunctionSet where+ parseNamedRecord m = do+ name <- m .: nameColumn+ when (null name) $ fail "empty name"+ set <- Csv.parseNamedRecord $ HashMap.delete nameColumn m+ return $ FunctionSet name $ Map.mapMaybe getRelFile set+++type URL = String++processFunction ::+ (PathClass.AbsRel ar) =>+ (Path.File ar, Path.File ar) ->+ URL -> String -> Path.File ar ->+ IO (Maybe (Type.Foreign Type.Mono, Type.Wrapper Type.Mono))+processFunction (ffiFile, carrayFile) url haskellName srcPath = do+ content <- PathIO.readFile srcPath+ let msignature = do+ sig <-+ fmap MW.runWriter $+ ME.mapException formatParseError $ ME.fromEither $+ Parsec.parse parseHeader (Path.toString srcPath) content+ when+ (elem (thd3 $ fst sig)+ [Just Type.ComplexSingle, Just Type.ComplexDouble]) $+ ME.throw $+ formatFileError srcPath "complex function result not supported"+ return sig+ case msignature of+ ME.Exception msg -> printError msg >> return Nothing+ ME.Success ((Identifier name, params, returnType), msgs) -> do+ mapM_ (printFileError srcPath) msgs+ let haddock =+ if null url+ then "\n"+ else+ printf "\n-- | <%s>\n"+ (printf url (Path.toString $ takeFileName srcPath)+ :: String)+ let foreignSig = foreignFromParameters params returnType+ carrayWrapper <- do+ let (mono,poly) =+ formatCArrayWrapper (haskellName, params, returnType)+ PathIO.appendFile carrayFile $ haddock ++ mono+ return poly+ PathIO.appendFile ffiFile $+ haddock ++ formatForeignCall ((haskellName, name), foreignSig)+ return $ Just (foreignSig, carrayWrapper)++unifyFunctions ::+ (Type.Unification f, PathClass.AbsRel ar) =>+ String ->+ Map ByteString (Path.File ar, f Type.Mono) ->+ IO (Maybe (f Type.Poly), Maybe (f Type.Poly), Maybe (f Type.Poly))+unifyFunctions msg monoSigs = do+ let unify uni (xPath,xSig) (yPath,ySig) = do+ let m = Type.unifySignature uni xSig ySig+ when (isNothing m) $ do+ printFileError xPath ""+ printFileError yPath msg+ return m+ real <-+ fmap join $ sequenceA $+ liftA2+ (unify Type.unifyPrecision)+ (Map.lookup floatColumn monoSigs)+ (Map.lookup doubleColumn monoSigs)+ complex <-+ fmap join $ sequenceA $+ liftA2+ (unify Type.unifyPrecision)+ (Map.lookup complexFloatColumn monoSigs)+ (Map.lookup complexDoubleColumn monoSigs)+ let generic =+ join $ liftA2 (Type.unifySignature Type.unifyRealComplex) real complex+ return (real, complex, generic)+++writePolymorphic ::+ (PathClass.AbsRel ar) =>+ Path.Dir ar ->+ ByteString ->+ Vector (String, sig) ->+ ((String, sig) -> String) ->+ IO ()+writePolymorphic dir name polySigs format = do+ file <- writeHeader dir name (Just $ Fold.toList $ fmap fst polySigs)+ forM_ (Fold.toList polySigs) $ PathIO.appendFile file . format++writeUnified ::+ (PathClass.AbsRel ar, Generalize f) =>+ Path.Dir ar ->+ Vector+ (String,+ (Maybe (f Type.Poly), Maybe (f Type.Poly), Maybe (f Type.Poly))) ->+ IO ()+writeUnified dstDir unifiedSigs = do+ writePolymorphic dstDir realColumn+ (Vector.mapMaybe (Func.mapSnd fst3) unifiedSigs)+ (formatClassCall 'S' 'D')++ writePolymorphic dstDir complexColumn+ (Vector.mapMaybe (Func.mapSnd snd3) unifiedSigs)+ (formatClassCall 'C' 'Z')++ writePolymorphic dstDir genericColumn+ (Vector.mapMaybe (Func.mapSnd thd3) unifiedSigs)+ formatClassCallRC+++pathArgument ::+ (PathClass.FileDir fd) =>+ OP.Mod OP.ArgumentFields (Path.AbsRel fd) -> OP.Parser (Path.AbsRel fd)+pathArgument = OP.argument (OP.eitherReader Path.parse)++optParser ::+ OP.Parser+ (URL, (Path.AbsRelFile, Path.AbsRelDir, Path.AbsRelDir, Path.AbsRelDir))+optParser =+ App.lift2 (,)+ (OP.strOption $+ OP.long "fortran-url" <>+ OP.metavar "URL" <>+ OP.value "" <>+ OP.help "Printf template for URL of online help") $+ App.lift4 (,,,)+ (pathArgument $+ OP.metavar "CSV" <>+ OP.help "Spreadsheet containing grouped Fortran file names")+ (pathArgument $+ OP.metavar "SRCDIR" <>+ OP.help "Input directory containing Fortran files")+ (pathArgument $+ OP.metavar "FFIDIR" <>+ OP.help "Output directory for Haskell FFI modules")+ (pathArgument $+ OP.metavar "CARRAYDIR" <>+ OP.help "Output directory for Haskell CArray wrapper modules")++optionInfo :: OP.Parser a -> OP.ParserInfo a+optionInfo parser =+ OP.info+ (OP.helper <*> parser)+ (OP.fullDesc <>+ OP.progDesc+ "Automated generation of low-level and mid-level bindings for LAPACK")+++main :: IO ()+main = do+ (url, (csvFile, srcDir, ffiDir, carrayDir)) <-+ OP.execParser $ optionInfo optParser+ createDirectoryIfMissing True ffiDir+ createDirectoryIfMissing True carrayDir++ (headers, functionSets) <-+ either (ioError . userError) return . Csv.decodeByName+ =<< BL.readFile (Path.toString csvFile)++ dstFiles <-+ fmap (Map.fromList . Fold.toList) $+ for (Vector.drop 1 headers) $ \columnName ->+ fmap ((,) columnName) $+ liftA2 (,)+ (writeHeader ffiDir columnName Nothing)+ (writeHeader carrayDir columnName Nothing)++ sigs <-+ for functionSets $ \(FunctionSet name files) ->+ fmap ((,) name . Map.mapMaybe id) $+ sequenceA $+ flip Map.mapWithKey files $ \modul file -> do+ let srcPath = srcDir </> file+ fmap ((,) srcPath) <$>+ processFunction (dstFiles Map.! modul) url name srcPath++ let runUnification dstDir msg select =+ writeUnified dstDir =<<+ traverse (Func.mapSnd (unifyFunctions msg . fmap (mapSnd select))) sigs++ runUnification ffiDir "Cannot generalize FFI functions." fst+ runUnification carrayDir "Cannot generalize CArray functions." snd
+ src/MainSingle.hs view
@@ -0,0 +1,30 @@+module Main where++import qualified Type+import Parser.Signature (Identifier(Identifier))+import CreateBinding+ (Parameter, formatForeignCall, foreignFromParameters, parseHeader)++import qualified Text.ParserCombinators.Parsec as Parsec++import qualified System.IO as IO++import qualified Control.Monad.Trans.Writer as MW+import Control.Applicative ((<$>))++import Data.Char (toLower)+++foreignSig ::+ (Identifier, [Parameter], Maybe Type.Mono) ->+ ((String, String), Type.Foreign Type.Mono)+foreignSig (Identifier name, params, returnType) =+ ((map toLower name, name), foreignFromParameters params returnType)++main :: IO ()+main =+ either (IO.hPutStrLn IO.stderr . show) putStr .+ Parsec.parse+ (formatForeignCall . foreignSig . fst . MW.runWriter <$> parseHeader)+ "<stdin>"+ =<< getContents
+ src/Parser/Combinator.hs view
@@ -0,0 +1,58 @@+module Parser.Combinator where++import qualified Text.ParserCombinators.Parsec as Parsec+import Text.ParserCombinators.Parsec (Parser, (<|>))++import Control.Monad.HT (void)+import Control.Monad (liftM2)+++space :: Parser ()+space =+ void (Parsec.char ' ')+ <|>+ Parsec.try (Parsec.newline >> continue)++newline :: Parser ()+newline = do+ void Parsec.newline+ Parsec.notFollowedBy continue++continue :: Parser ()+continue = do+ Parsec.skipMany $ Parsec.char ' '+ void $ Parsec.char '$'++spaces :: Parser ()+spaces = Parsec.skipMany space++garbage :: Parser ()+garbage = Parsec.skipMany $ Parsec.noneOf "\n"++infixl 1 `followedBy`++followedBy :: Parser a -> Parser () -> Parser a+followedBy p end = do a <- p; end; return a++oneLine :: Parser a -> Parser a+oneLine p = p `followedBy` newline++lexeme :: Parser a -> Parser a+lexeme p = p `followedBy` spaces++identifier :: Parser String+identifier =+ lexeme $+ liftM2 (:) Parsec.letter (Parsec.many (Parsec.alphaNum <|> Parsec.char '_'))++commaSep :: Parser a -> Parser [a]+commaSep = flip Parsec.sepBy (lexeme $ Parsec.char ',')++commaSep1 :: Parser a -> Parser [a]+commaSep1 = flip Parsec.sepBy1 (lexeme $ Parsec.char ',')++parens :: Parser a -> Parser a+parens = Parsec.between (lexeme $ Parsec.char '(') (lexeme $ Parsec.char ')')++keyword :: String -> Parser ()+keyword str = void $ lexeme $ Parsec.string str
+ src/Parser/Signature.hs view
@@ -0,0 +1,289 @@+module Parser.Signature (+ Identifier(..), Direction(..), ParamDecl(..), header3_3, header3_4,+ ) where++import qualified Parser.Combinator as Parser+import qualified Type++import qualified Text.ParserCombinators.Parsec as Parsec+import Text.ParserCombinators.Parsec (Parser, (<|>))+import Text.Printf (printf)++import Control.Monad.HT (void)+import Control.Monad (liftM2, liftM3)+import Control.Applicative ((<$>), (<$))++import qualified Data.List as List+import qualified Data.Map as Map+import Data.Function (fix)+import Data.Maybe (catMaybes)+import Data.Map (Map)+++newtype Identifier = Identifier String++subroutine :: Parser (Identifier, [String], Maybe Type.Mono)+subroutine = do+ Parser.spaces+ Parsec.optional $ Parsec.try $ Parser.keyword "RECURSIVE"+ returnType <-+ ((Nothing <$) $ Parsec.try $ Parser.keyword "SUBROUTINE")+ <|>+ (Parser.lexeme (Just <$> typeIdent)+ `Parser.followedBy`+ Parser.keyword "FUNCTION")+ liftM3 (,,)+ (Identifier <$> Parser.identifier)+ (Parser.parens $ Parser.commaSep Parser.identifier)+ (return returnType)+++type Mapping = Type.Mapping String Type.Mono++data ParamDecl = Type Type.Mono [(String, Maybe [String])] | External [String]++typeIdent :: Parser Type.Mono+typeIdent =+ (Type.Logical <$ Parsec.string "LOGICAL")+ <|>+ (Type.Character <$+ Parsec.try+ (Parsec.string "CHARACTER" >> Parsec.optional (Parsec.string "*1")))+ <|>+ (Type.Integer <$ Parsec.string "INTEGER")+ <|>+ (Type.RealSingle <$ Parsec.string "REAL")+ <|>+ (Parser.lexeme (Parsec.string "DOUBLE") >>+ ((Type.RealDouble <$ Parsec.string "PRECISION")+ <|>+ (Type.ComplexDouble <$ Parsec.string "COMPLEX")))+ <|>+ (Parsec.string "COMPLEX" >>+ ((Type.ComplexDouble <$ Parsec.string "*16") <|> return Type.ComplexSingle))++expression :: Parser String+expression =+ fmap concat $+ Parsec.many1 $+ Parsec.many1 Parsec.alphaNum+ <|>+ fmap return (Parsec.oneOf "+-*/: ")+ <|>+ (fmap (printf "(%s)") $+ Parsec.between+ (Parser.lexeme $ Parsec.char '(') (Parser.lexeme $ Parsec.char ')')+ (List.intercalate "," <$> Parser.commaSep1 expression))++externalDecl :: Parser [String]+externalDecl =+ Parsec.try (Parsec.string "EXTERNAL")+ >>+ Parser.spaces+ >>+ Parser.commaSep1 Parser.identifier++parameterDecl :: Parser ParamDecl+parameterDecl =+ Parsec.spaces >>+ (fmap External externalDecl+ <|>+ (liftM2 Type+ (Parser.lexeme typeIdent)+ (Parser.commaSep $+ liftM2 (,)+ Parser.identifier+ (Parsec.option Nothing $+ fmap Just $ Parser.parens $ Parser.commaSep1 $+ Parser.lexeme (Parsec.string "*") <|> expression))))++data Direction = Input | Output | InputOutput | InputWorkspace | Workspace+ deriving (Eq, Show)++direction3_3 :: Parser Direction+direction3_3 = do+ dirs <- Parsec.many1 (Parsec.letter <|> Parsec.char '/' <|> Parsec.char ' ')+ case dirs of+ "input" -> return Input+ "input or output" -> return InputOutput+ "input/output" -> return InputOutput+ "input/workspace" -> return InputWorkspace+ "output" -> return Output+ "workspace" -> return Workspace+ "workspace/output" -> return Workspace+ "input/workspace/output" -> return InputOutput+ _ -> fail $ "unknown direction specification: " ++ dirs++arrayDimensions :: String -> Parser (Maybe [String])+arrayDimensions commentStart = do+ Parser.keyword "array,"+ (do+ Parser.keyword "dimension"+ (do+ dims <- Parser.parens (Parser.commaSep1 expression)+ (Nothing <$+ Parsec.try+ (Parser.keyword "if" <|>+ (Parser.keyword ('\n':commentStart) >> Parser.keyword "if")))+ <|> return (Just dims))+ <|> return Nothing)+ <|>+ return Nothing++optionalDimensions :: String -> Parser (Maybe Mapping)+optionalDimensions commentStart =+ (fmap Type.Array <$> arrayDimensions commentStart)+ <|>+ return (Just Type.Scalar)++{-+LOGICAL FUNCTION of one COMPLEX argument+-}+callback :: Parser (Int, Type.Mono, Type.Mono)+callback = do+ returnType <- Parser.lexeme typeIdent+ Parser.keyword "FUNCTION"+ Parser.keyword "of"+ let arguments n nStr argStr = do+ Parsec.try $ Parser.keyword nStr+ typ <- Parser.lexeme typeIdent+ Parser.keyword argStr+ return (n,typ)+ (n,argType) <-+ arguments 1 "one" "argument" <|>+ arguments 2 "two" "arguments" <|>+ arguments 3 "three" "arguments"+ return (n,argType,returnType)++parameterComment3_3 :: Parser (String, (Direction, Type.Mono, Maybe Mapping))+parameterComment3_3 = do+ void $ Parser.lexeme $ Parsec.char '*'+ liftM2 (,) Parser.identifier $+ liftM3 (,,)+ (Parser.parens direction3_3) (Parser.lexeme typeIdent)+ (optionalDimensions "*")+ `Parser.followedBy`+ Parser.garbage++anyComment :: Parser ()+anyComment = do+ void $ Parsec.char '*'+ Parser.garbage++commentOrBlank :: Parser ()+commentOrBlank = Parser.oneLine $ anyComment <|> return ()+++header3_3 ::+ Parser+ ((Identifier, [String], Maybe Type.Mono), [ParamDecl],+ Map String (Direction, Type.Mono, Maybe Mapping))+header3_3 = do+ prototype <- Parser.oneLine subroutine+ Parsec.skipMany commentOrBlank+ Parsec.optional $ Parsec.try $ Parser.oneLine $ do+ Parser.spaces+ Parser.keyword "IMPLICIT"+ Parser.keyword "NONE"+ Parsec.skipMany commentOrBlank+ paramTypes <-+ fix $ \loop ->+ liftM2 (:) (Parser.oneLine parameterDecl) $+ fix $ \loopCmt ->+ ([] <$ Parsec.try (Parsec.lookAhead parameterComment3_3))+ <|>+ (commentOrBlank >> loopCmt)+ <|>+ loop+ paramDirs <-+ Parsec.many $+ (Just <$> Parsec.try (Parser.oneLine parameterComment3_3))+ <|>+ (Nothing <$ commentOrBlank)+ return (prototype, paramTypes, Map.fromList $ catMaybes paramDirs)+++direction3_4 :: Parser (Bool -> Direction)+direction3_4 = do+ dirs <- Parsec.many1 (Parsec.letter <|> Parsec.char ',')+ case dirs of+ "in" -> return $ \work -> if work then InputWorkspace else Input+ "in,out" -> return $ const InputOutput+ "out" -> return $ \work -> if work then Workspace else Output+ _ -> fail $ "unknown direction specification: " ++ dirs++{-+*> \param[in,out] A+*> \verbatim+*> A is DOUBLE PRECISION array, dimension (LDA,N)+-}+parameterComment3_4 :: Parser (String, (Direction, Type.Mono, Maybe Mapping))+parameterComment3_4 = do+ let doxyCmt = void $ Parser.lexeme $ Parsec.string "*>"+ void $ Parsec.try $ doxyCmt >> Parsec.string "\\param"+ dirFromWork <-+ Parser.lexeme $+ Parsec.between (Parsec.char '[') (Parsec.char ']') direction3_4+ name <- Parser.identifier+ void $ Parsec.newline+ let dir = dirFromWork $ List.isSuffixOf "WORK" name++ doxyCmt >> Parsec.string "\\verbatim" >> void Parsec.newline++ doxyCmt+ void $ Parser.lexeme $ Parsec.string name+ void $ Parser.lexeme $ Parsec.string "is"++ (typ,dims) <-+ Parser.oneLine $+ (do+ Parsec.try $ Parser.keyword "a"+ (n,argType,returnType) <- callback+ return (returnType, Just $ Type.Function n argType))+ <|>+ (liftM2 (,) (Parser.lexeme typeIdent) (optionalDimensions "*>")+ `Parser.followedBy`+ Parser.garbage)++ return (name, (dir,typ,dims))+++header3_4 ::+ Parser+ ((Identifier, [String], Maybe Type.Mono), [ParamDecl],+ Map String (Direction, Type.Mono, Maybe Mapping))+header3_4 = do+ void $ fix $ \loop ->+ (Parsec.try $ Parser.oneLine $+ Parser.lexeme (Parsec.string "*") >> Parsec.string "Arguments:")+ <|>+ (commentOrBlank >> loop)+ void $ Parser.oneLine $+ Parser.lexeme (Parsec.string "*") >> Parsec.string "=========="+ void $ Parser.oneLine $ Parser.lexeme (Parsec.string "*")+ paramDirs <-+ Parsec.many $+ (Just <$> parameterComment3_4)+ <|>+ (Nothing <$+ Parsec.try (Parser.oneLine (Parsec.string "*>" >> Parser.garbage)))+ Parsec.skipMany commentOrBlank+ prototype <- Parser.oneLine subroutine+ Parsec.skipMany commentOrBlank+ Parsec.optional $ Parsec.try $ Parser.oneLine $ do+ Parser.spaces+ Parser.keyword "IMPLICIT" <|> Parser.keyword "implicit"+ Parser.keyword "NONE" <|> Parser.keyword "none"+ Parsec.skipMany commentOrBlank+ paramTypes <-+ fix $ \loop ->+ liftM2 (:) (Parser.oneLine parameterDecl) $+ fix $ \loopCmt ->+ (Parsec.try $ Parser.oneLine $+ [] <$ (Parser.lexeme (Parsec.string "*") >>+ Parsec.string "==================" >> Parser.garbage))+ <|>+ (commentOrBlank >> loopCmt)+ <|>+ loop+ return (prototype, paramTypes, Map.fromList $ catMaybes paramDirs)
+ src/Type.hs view
@@ -0,0 +1,250 @@+module Type where++import qualified Data.Foldable as Fold+import qualified Data.List.Match as Match+import qualified Data.List as List+import Data.Foldable (Foldable, foldMap)+import Data.Monoid (mempty, (<>))+import Data.Maybe.HT (toMaybe)+import Data.Tuple.HT (fst3)++import Control.Monad (mfilter)+import Control.Applicative (liftA2, liftA3, (<$>), (<*>))++import Text.Printf (printf)+++data+ Mono =+ Logical | Character | Integer |+ RealSingle | RealDouble | ComplexSingle | ComplexDouble+ deriving (Eq, Show)+++data Poly = Variable Var | Mono Mono+ deriving (Eq)++data Var = Real | Complex+ deriving (Eq)++isVar :: Poly -> Bool+isVar (Variable _) = True+isVar (Mono _) = False+++unifyPrecision :: Mono -> Mono -> Maybe Poly+unifyPrecision RealSingle RealDouble = Just $ Variable Real+unifyPrecision ComplexSingle ComplexDouble = Just $ Variable Complex+unifyPrecision floatType doubleType =+ toMaybe (floatType == doubleType) $ Mono floatType ++unifyRealComplex :: Poly -> Poly -> Maybe Poly+unifyRealComplex (Variable real) (Variable complex) =+ toMaybe ((real, complex) == (Real, Complex)) $ Variable Real+unifyRealComplex realType complexType =+ toMaybe (realType == complexType) realType++++class Foldable f => Unification f where+ unify :: (a -> b -> Maybe c) -> f a -> f b -> Maybe (f c)++instance Unification [] where+ unify uni as bs =+ mfilter (const $ Match.equalLength as bs) $ sequence $ zipWith uni as bs++instance Unification Maybe where+ unify uni ma mb =+ case (ma,mb) of+ (Nothing, Nothing) -> Just Nothing+ (Just a, Just b) -> Just <$> uni a b+ _ -> Nothing++unifyEq :: (a -> a -> Bool) -> a -> a -> Maybe a+unifyEq eq a b = toMaybe (eq a b) a+++data Pointer typ = Ptr typ | FunPtr Int typ typ++instance Foldable Pointer where+ foldMap f (Ptr typ) = f typ+ foldMap f (FunPtr _n param ret) = f param <> f ret++instance Unification Pointer where+ unify uni (Ptr aTyp) (Ptr bTyp) = Ptr <$> uni aTyp bTyp+ unify uni (FunPtr an aParam aReturn) (FunPtr bn bParam bReturn) =+ FunPtr+ <$> unifyEq (==) an bn <*> uni aParam bParam <*> uni aReturn bReturn+ unify _ _ _ = Nothing+++data Foreign typ = Foreign [Pointer typ] (Maybe typ)++instance Foldable Foreign where+ foldMap f (Foreign params returnType) =+ foldMap (foldMap f) params <> foldMap f returnType++instance Unification Foreign where+ unify uni (Foreign aParams aReturn) (Foreign bParams bReturn) =+ liftA2 Foreign+ (unify (unify uni) aParams bParams) (unify uni aReturn bReturn)++unifySignature ::+ (Unification f) => (a -> b -> Maybe Poly) -> f a -> f b -> Maybe (f Poly)+unifySignature uni floatSig doubleSig =+ mfilter (Fold.any isVar) $ unify uni floatSig doubleSig+++data Wrapper typ =+ Wrapper+ [(typ, Mapping String typ, Bool)] (Maybe typ) [(typ, Mapping String typ)]++instance Foldable Wrapper where+ foldMap f (Wrapper inputs returnType outputs) =+ foldMap (f.fst3) inputs <> foldMap f returnType <> foldMap (f.fst) outputs++instance Unification Wrapper where+ unify uni+ (Wrapper aInputs aReturn aOutputs) (Wrapper bInputs bReturn bOutputs) =++ liftA3 Wrapper+ (unify+ (\(aType,aDims,aMut) (bType,bDims,bMut) ->+ liftA3 (,,)+ (uni aType bType)+ (unify uni aDims bDims)+ (unifyEq (==) aMut bMut))+ aInputs bInputs)+ (unify uni aReturn bReturn)+ (unify+ (\(aType,aDims) (bType,bDims) ->+ liftA2 (,)+ (uni aType bType)+ (unify uni aDims bDims))+ aOutputs bOutputs)++++class Format typ where+ format :: typ -> String+ formatParameter :: typ -> String+++formatCallback :: Int -> Mono -> Mono -> String+formatCallback n param ret =+ concat (replicate n (formatPtr param ++ " -> "))+ +++ "IO " ++ format ret++formatTuple :: [String] -> String+formatTuple elems =+ case elems of+ [] -> "()"+ [x] -> x+ _ -> "(" ++ List.intercalate "," elems ++ ")"++formatIndex :: [String] -> String+formatIndex = formatTuple . flip Match.replicate "Int"++formatPtr :: (Format typ) => typ -> String+formatPtr typ = "Ptr " ++ format typ++formatFunPtr :: (Format typ) => Int -> typ -> typ -> String+formatFunPtr n param ret =+ printf "FunPtr (%sIO %s)"+ (concat $ replicate n $ formatPtr param ++ " -> ") (format ret)++formatArray :: (Format typ) => String -> typ -> Mapping String typ -> String+formatArray array elm mapping =+ case mapping of+ Scalar -> formatParameter elm+ Array dims -> array ++ " " ++ formatIndex dims ++ " " ++ format elm+ Function n param -> formatFunPtr n param elm++instance Format Mono where+ format typ =+ case typ of+ Logical -> "Bool"+ Character -> "CChar"+ Integer -> "CInt"+ RealSingle -> "Float"+ RealDouble -> "Double"+ ComplexSingle -> "(Complex Float)"+ ComplexDouble -> "(Complex Double)"++ formatParameter typ =+ case typ of+ Logical -> "Bool"+ Character -> "Char"+ Integer -> "Int"+ RealSingle -> "Float"+ RealDouble -> "Double"+ ComplexSingle -> "Complex Float"+ ComplexDouble -> "Complex Double"+++formatVariable :: Var -> String+formatVariable Real = "a"+formatVariable Complex = "(Complex a)"++formatVarFunPtr :: (Format typ) => Int -> typ -> Var -> String+formatVarFunPtr n param ret =+ printf "FunPtr (%sIO %s)"+ (concat $ replicate n $ formatPtr param ++ " -> ") (formatVariable ret)++instance Format Poly where+ format (Variable var) = formatVariable var+ format (Mono typ) = format typ++ formatParameter (Variable var) = formatVariable var+ formatParameter (Mono typ) = formatParameter typ+++formatForeignParam :: Format a => Pointer a -> String+formatForeignParam pointer =+ case pointer of+ Ptr typ -> formatPtr typ+ FunPtr n param ret -> formatFunPtr n param ret++formatForeign :: Format a => Foreign a -> String+formatForeign (Foreign params returnType) =+ concatMap ((++ " -> ") . formatForeignParam) params +++ "IO " ++ maybe "()" format returnType++++data Mapping dim typ = Scalar | Array [dim] | Function Int typ+ deriving (Eq)++instance Foldable (Mapping dim) where+ foldMap f m =+ case m of+ Scalar -> mempty+ Array _ -> mempty+ Function _ param -> f param++instance Unification (Mapping dim) where+ unify _uni Scalar Scalar = Just Scalar+ unify _uni (Array aDims) (Array bDims) =+ Array <$> unifyEq Match.equalLength aDims bDims+ unify uni (Function an aParam) (Function bn bParam) =+ Function <$> unifyEq (==) an bn <*> uni aParam bParam+ unify _uni _ _ = Nothing++mapMappings :: ([dim0] -> [dim1]) -> Mapping dim0 typ -> Mapping dim1 typ+mapMappings f m =+ case m of+ Scalar -> Scalar+ Array dims -> Array $ f dims+ Function n param -> Function n param++mapMapping :: (dim0 -> dim1) -> Mapping dim0 typ -> Mapping dim1 typ+mapMapping f = mapMappings (fmap f)++isScalar :: Mapping dim typ -> Bool+isScalar Scalar = True+isScalar _ = False++maybeArray :: Mapping dim typ -> Maybe [dim]+maybeArray (Array dims) = Just dims+maybeArray _ = Nothing