August 2017 - openSUSE Commits - openSUSE Mailing Lists

commit ghc-publicsuffix for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-publicsuffix for openSUSE:Factory checked in at 2017-08-31 20:58:05 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-publicsuffix (Old) and /work/SRC/openSUSE:Factory/.ghc-publicsuffix.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-publicsuffix" Thu Aug 31 20:58:05 2017 rev:2 rq:513458 version:0.20170508 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-publicsuffix/ghc-publicsuffix.changes 2017-05-09 18:08:47.117112387 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-publicsuffix.new/ghc-publicsuffix.changes 2017-08-31 20:58:05.777651733 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:06:29 UTC 2017 - psimons(a)suse.com + +- Update to version 0.20170508. + +------------------------------------------------------------------- Old: ---- publicsuffix-0.20170109.tar.gz New: ---- publicsuffix-0.20170508.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-publicsuffix.spec ++++++ --- /var/tmp/diff_new_pack.JpHktU/_old 2017-08-31 20:58:06.673525860 +0200 +++ /var/tmp/diff_new_pack.JpHktU/_new 2017-08-31 20:58:06.681524736 +0200 @@ -19,7 +19,7 @@ %global pkg_name publicsuffix %bcond_with tests Name: ghc-%{pkg_name} -Version: 0.20170109 +Version: 0.20170508 Release: 0 Summary: The publicsuffix list exposed as proper Haskell types License: MIT ++++++ publicsuffix-0.20170109.tar.gz -> publicsuffix-0.20170508.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/publicsuffix-0.20170109/publicsuffix.cabal new/publicsuffix-0.20170508/publicsuffix.cabal --- old/publicsuffix-0.20170109/publicsuffix.cabal 2017-01-09 19:22:50.000000000 +0100 +++ new/publicsuffix-0.20170508/publicsuffix.cabal 2017-05-08 23:45:00.000000000 +0200 @@ -1,5 +1,5 @@ name: publicsuffix -version: 0.20170109 +version: 0.20170508 synopsis: The publicsuffix list exposed as proper Haskell types description: diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/publicsuffix-0.20170109/src/Data/PublicSuffix/public_suffix_list.dat new/publicsuffix-0.20170508/src/Data/PublicSuffix/public_suffix_list.dat --- old/publicsuffix-0.20170109/src/Data/PublicSuffix/public_suffix_list.dat 2017-01-09 19:21:36.000000000 +0100 +++ new/publicsuffix-0.20170508/src/Data/PublicSuffix/public_suffix_list.dat 2017-05-08 23:43:22.000000000 +0200 @@ -171,7 +171,7 @@ // aq : https://en.wikipedia.org/wiki/.aq aq -// ar : https://nic.ar/normativa-vigente.xhtml +// ar : https://nic.ar/nic-argentina/normativa-vigente ar com.ar edu.ar @@ -179,6 +179,7 @@ gov.ar int.ar mil.ar +musica.ar net.ar org.ar tur.ar @@ -5280,6 +5281,9 @@ org.om pro.om +// onion : https://tools.ietf.org/html/rfc7686 +onion + // org : https://en.wikipedia.org/wiki/.org org @@ -5861,38 +5865,6 @@ // su : https://en.wikipedia.org/wiki/.su su -adygeya.su -arkhangelsk.su -balashov.su -bashkiria.su -bryansk.su -dagestan.su -grozny.su -ivanovo.su -kalmykia.su -kaluga.su -karelia.su -khakassia.su -krasnodar.su -kurgan.su -lenug.su -mordovia.su -msk.su -murmansk.su -nalchik.su -nov.su -obninsk.su -penza.su -pokrovsk.su -sochi.su -spb.su -togliatti.su -troitsk.su -tula.su -tuva.su -vladikavkaz.su -vladimir.su -vologda.su // sv : http://www.svnet.org.sv/niveldos.pdf sv @@ -6760,6 +6732,12 @@ // xn--o3cw4h ("Thai", Thai) : TH // http://www.thnic.co.th ไทย +ศึกษา.ไทย +ธุรกิจ.ไทย +รัฐบาล.ไทย +ทหาร.ไทย +เน็ต.ไทย +องค์กร.ไทย // xn--pgbs0dh ("Tunisia", Arabic) : TN // http://nic.tn @@ -6822,11 +6800,16 @@ org.zm sch.zm -// zw : https://en.wikipedia.org/wiki/.zw -*.zw +// zw : https://www.potraz.gov.zw/ +// Confirmed by registry <bmtengwa(a)potraz.gov.zw> 2017-01-25 +zw +ac.zw +co.zw +gov.zw +mil.zw +org.zw - -// List of new gTLDs imported from https://newgtlds.icann.org/newgtlds.csv on 2016-11-29T01:06:51Z +// List of new gTLDs imported from https://newgtlds.icann.org/newgtlds.csv on 2017-02-23T00:46:09Z // aaa : 2015-02-26 American Automobile Association, Inc. aaa @@ -7758,9 +7741,6 @@ // dvr : 2016-05-26 Hughes Satellite Systems Corporation dvr -// dwg : 2015-07-23 Autodesk, Inc. -dwg - // earth : 2014-12-04 Interlink Co., Ltd. earth @@ -8328,9 +8308,6 @@ // ifm : 2014-01-30 ifm electronic gmbh ifm -// iinet : 2014-07-03 Connect West Pty. Ltd. -iinet - // ikano : 2015-07-09 Ikano S.A. ikano @@ -8898,9 +8875,6 @@ // mutual : 2015-04-02 Northwestern Mutual MU TLD Registry, LLC mutual -// mutuelle : 2015-06-18 Fédération Nationale de la Mutualité Française -mutuelle - // nab : 2015-08-20 National Australia Bank Limited nab @@ -9399,6 +9373,9 @@ // rsvp : 2014-05-08 Charleston Road Registry Inc. rsvp +// rugby : 2016-12-15 World Rugby Strategic Developments Limited +rugby + // ruhr : 2013-10-02 regiodot GmbH & Co. KG ruhr @@ -9825,9 +9802,6 @@ // theatre : 2015-05-07 theatre -// theguardian : 2015-04-30 Guardian News and Media Limited -theguardian - // tiaa : 2015-07-23 Teachers Insurance and Annuity Association of America tiaa @@ -9975,7 +9949,7 @@ // verisign : 2015-08-13 VeriSign, Inc. verisign -// versicherung : 2014-03-20 dotversicherung-registry GmbH +// versicherung : 2014-03-20 versicherung // vet : 2014-03-06 @@ -10200,9 +10174,6 @@ // xn--4gbrim : 2013-10-04 Suhub Electronic Establishment موقع -// xn--4gq48lf9j : 2015-07-31 Wal-Mart Stores, Inc. -一号店 - // xn--55qw42g : 2013-11-08 China Organizational Name Administration Center 公益 @@ -10263,7 +10234,7 @@ // xn--cg4bki : 2013-09-27 SAMSUNG SDS CO., LTD 삼성 -// xn--czr694b : 2014-01-16 Dot Trademark TLD Holding Company Limted +// xn--czr694b : 2014-01-16 Dot Trademark TLD Holding Company Limited 商标 // xn--czrs0t : 2013-12-19 Wild Island, LLC @@ -10320,7 +10291,7 @@ // xn--i1b6b1a6a2e : 2013-11-14 Public Interest Registry संगठन -// xn--imr513n : 2014-12-11 Dot Trademark TLD Holding Company Limted +// xn--imr513n : 2014-12-11 Dot Trademark TLD Holding Company Limited 餐厅 // xn--io0a7i : 2013-11-14 Computer Network Information Center of Chinese Academy of Sciences （China Internet Network Information Center） @@ -10531,7 +10502,7 @@ // Submitted by Donavan Miller <donavanm(a)amazon.com> cloudfront.net -// Amazon Elastic Compute Cloud: https://aws.amazon.com/ec2/ +// Amazon Elastic Compute Cloud : https://aws.amazon.com/ec2/ // Submitted by Luke Wells <psl-maintainers(a)amazon.com> *.compute.amazonaws.com *.compute-1.amazonaws.com @@ -10550,7 +10521,7 @@ // Amazon S3 : https://aws.amazon.com/s3/ // Submitted by Luke Wells <psl-maintainers(a)amazon.com> -*.s3.amazonaws.com +s3.amazonaws.com s3-ap-northeast-1.amazonaws.com s3-ap-northeast-2.amazonaws.com s3-ap-south-1.amazonaws.com @@ -10559,6 +10530,7 @@ s3-ca-central-1.amazonaws.com s3-eu-central-1.amazonaws.com s3-eu-west-1.amazonaws.com +s3-eu-west-2.amazonaws.com s3-external-1.amazonaws.com s3-fips-us-gov-west-1.amazonaws.com s3-sa-east-1.amazonaws.com @@ -10571,6 +10543,7 @@ s3.cn-north-1.amazonaws.com.cn s3.ca-central-1.amazonaws.com s3.eu-central-1.amazonaws.com +s3.eu-west-2.amazonaws.com s3.us-east-2.amazonaws.com s3.dualstack.ap-northeast-1.amazonaws.com s3.dualstack.ap-northeast-2.amazonaws.com @@ -10580,6 +10553,7 @@ s3.dualstack.ca-central-1.amazonaws.com s3.dualstack.eu-central-1.amazonaws.com s3.dualstack.eu-west-1.amazonaws.com +s3.dualstack.eu-west-2.amazonaws.com s3.dualstack.sa-east-1.amazonaws.com s3.dualstack.us-east-1.amazonaws.com s3.dualstack.us-east-2.amazonaws.com @@ -10595,6 +10569,7 @@ s3-website.ap-south-1.amazonaws.com s3-website.ca-central-1.amazonaws.com s3-website.eu-central-1.amazonaws.com +s3-website.eu-west-2.amazonaws.com s3-website.us-east-2.amazonaws.com // Amune : https://amune.org/ @@ -10625,6 +10600,11 @@ // Submitted by Andreas Weise <a.weise(a)avm.de> myfritz.net +// AW AdvisorWebsites.com Software Inc : https://advisorwebsites.com +// Submitted by James Kennedy <domains(a)advisorwebsites.com> +*.awdev.ca +*.advisor.ws + // backplane : https://www.backplane.io // Submitted by Anthony Voutas <anthony(a)backplane.io> backplaneapp.io @@ -10641,11 +10621,20 @@ // Submitted by Axel Fontaine <axel(a)boxfuse.com> boxfuse.io +// bplaced : https://www.bplaced.net/ +// Submitted by Miroslav Bozic <security(a)bplaced.net> +square7.ch +bplaced.com +bplaced.de +square7.de +bplaced.net +square7.net + // BrowserSafetyMark // Submitted by Dave Tharp <browsersafetymark.io(a)quicinc.com> browsersafetymark.io -// callidomus: https://www.callidomus.com/ +// callidomus : https://www.callidomus.com/ // Submitted by Marcus Popp <admin(a)callidomus.com> mycd.eu @@ -10715,6 +10704,10 @@ // Submitted by Leon Rowland <leon(a)clearvox.nl> virtueeldomein.nl +// Cloud66 : https://www.cloud66.com/ +// Submitted by Khash Sajadi <khash(a)cloud66.com> +c66.me + // cloudControl : https://www.cloudcontrol.com/ // Submitted by Tobias Wilken <tw(a)cloudcontrol.com> cloudcontrolled.com @@ -10753,11 +10746,7 @@ co.nl co.no -// Commerce Guys, SAS -// Submitted by Damien Tournoud <damien(a)commerceguys.com> -*.platform.sh - -// COSIMO GmbH http://www.cosimo.de +// COSIMO GmbH : http://www.cosimo.de // Submitted by Rene Marticke <rmarticke(a)cosimo.de> dyn.cosidns.de dynamisches-dns.de @@ -10789,6 +10778,7 @@ // Daplie, Inc : https://daplie.com // Submitted by AJ ONeal <aj(a)daplie.com> daplie.me +localhost.daplie.me // Dansk.net : http://www.dansk.net/ // Submitted by Anani Voule <digital(a)digital.co.dk> @@ -11122,7 +11112,7 @@ ddnss.org // dynv6 : https://dynv6.com -// Submitted by Dominik Menke <dom(a)digineo.de> 2016-01-18 +// Submitted by Dominik Menke <dom(a)digineo.de> dynv6.net // E4YOU spol. s.r.o. : https://e4you.cz/ @@ -11197,25 +11187,121 @@ // Submitted by Michal Kralik <support(a)evennode.com> eu-1.evennode.com eu-2.evennode.com +eu-3.evennode.com us-1.evennode.com us-2.evennode.com +us-3.evennode.com + +// eDirect Corp. : https://hosting.url.com.tw/ +// Submitted by C.S. chang <cschang(a)corp.url.com.tw> +twmail.cc +twmail.net +twmail.org +mymailer.com.tw +url.tw // Facebook, Inc. // Submitted by Peter Ruibal <public-suffix(a)fb.com> apps.fbsbx.com -// Fastly Inc. http://www.fastly.com/ -// Submitted by Vladimir Vuksan <vladimir(a)fastly.com> +// FAITID : https://faitid.org/ +// Submitted by Maxim Alzoba <tech.contact(a)faitid.org> +// https://www.flexireg.net/stat_info +ru.net +adygeya.ru +bashkiria.ru +bir.ru +cbg.ru +com.ru +dagestan.ru +grozny.ru +kalmykia.ru +kustanai.ru +marine.ru +mordovia.ru +msk.ru +mytis.ru +nalchik.ru +nov.ru +pyatigorsk.ru +spb.ru +vladikavkaz.ru +vladimir.ru +abkhazia.su +adygeya.su +aktyubinsk.su +arkhangelsk.su +armenia.su +ashgabad.su +azerbaijan.su +balashov.su +bashkiria.su +bryansk.su +bukhara.su +chimkent.su +dagestan.su +east-kazakhstan.su +exnet.su +georgia.su +grozny.su +ivanovo.su +jambyl.su +kalmykia.su +kaluga.su +karacol.su +karaganda.su +karelia.su +khakassia.su +krasnodar.su +kurgan.su +kustanai.su +lenug.su +mangyshlak.su +mordovia.su +msk.su +murmansk.su +nalchik.su +navoi.su +north-kazakhstan.su +nov.su +obninsk.su +penza.su +pokrovsk.su +sochi.su +spb.su +tashkent.su +termez.su +togliatti.su +troitsk.su +tselinograd.su +tula.su +tuva.su +vladikavkaz.su +vladimir.su +vologda.su + +// Fastly Inc. : http://www.fastly.com/ +// Submitted by Fastly Security <security(a)fastly.com> +fastlylb.net +map.fastlylb.net +freetls.fastly.net +map.fastly.net +a.prod.fastly.net +global.prod.fastly.net a.ssl.fastly.net b.ssl.fastly.net global.ssl.fastly.net -a.prod.fastly.net -global.prod.fastly.net // Featherhead : https://featherhead.xyz/ // Submitted by Simon Menke <simon(a)featherhead.xyz> fhapp.xyz +// Fedora : https://fedoraproject.org/ +// submitted by Patrick Uiterwijk <puiterwijk(a)fedoraproject.org> +fedorainfracloud.org +fedorapeople.org +cloud.fedoraproject.org + // Firebase, Inc. // Submitted by Chris Raynor <chris(a)firebase.com> firebaseapp.com @@ -11379,6 +11465,10 @@ herokuapp.com herokussl.com +// Ici la Lune : http://www.icilalune.com/ +// Submitted by Simon Morvan <simon(a)icilalune.com> +moonscale.net + // iki.fi // Submitted by Hannu Aronsson <haa(a)iki.fi> iki.fi @@ -11417,6 +11507,10 @@ sp.leg.br to.leg.br +// IPiFony Systems, Inc. : https://www.ipifony.com/ +// Submitted by Matthew Hardeman <mhardeman(a)ipifony.com> +ipifony.net + // Joyent : https://www.joyent.com/ // Submitted by Brian Bennett <brian.bennett(a)joyent.com> *.triton.zone @@ -11442,6 +11536,10 @@ // Submitted by Damien Tournoud <dtournoud(a)magento.cloud> *.magentosite.cloud +// Mail.Ru Group : https://hb.cldmail.ru +// Submitted by Ilya Zaretskiy <zaretskiy(a)corp.mail.ru> +hb.cldmail.ru + // Meteor Development Group : https://www.meteor.com/hosting // Submitted by Pierre Carrier <pierre(a)meteor.com> meteorapp.com @@ -11569,6 +11667,10 @@ // Submitted by Matthew Brown <mattbrown(a)nyc.mn> nyc.mn +// Octopodal Solutions, LLC. : https://ulterius.io/ +// Submitted by Andrew Sampson <andrew(a)ulterius.io> +cya.gg + // One Fold Media : http://www.onefoldmedia.com/ // Submitted by Eddie Jones <eddie(a)onefoldmedia.com> nid.io @@ -11622,6 +11724,11 @@ // Submitted by Frédéric VANNIÈRE <f.vanniere(a)planet-work.com> on-web.fr +// Platform.sh : https://platform.sh +// Submitted by Nikola Kotur <nikola(a)platform.sh> +*.platform.sh +*.platformsh.site + // prgmr.com : https://prgmr.com/ // Submitted by Sarah Newman <owner(a)prgmr.com> xen.prgmr.com @@ -11648,6 +11755,15 @@ alpha-myqnapcloud.com myqnapcloud.com +// Quip : https://quip.com +// Submitted by Patrick Linehan <plinehan(a)quip.com> +*.quipelements.com + +// Qutheory LLC : http://qutheory.io +// Submitted by Jonas Schwartz <jonas(a)qutheory.io> +vapor.cloud +vaporcloud.io + // Rackmaze LLC : https://www.rackmaze.com // Submitted by Kirill Pertsev <kika(a)rackmaze.com> rackmaze.com @@ -11689,6 +11805,10 @@ myfirewall.org spdns.org +// SensioLabs, SAS : https://sensiolabs.com/ +// Submitted by Fabien Potencier <fabien.potencier(a)sensiolabs.com> +*.sensiosite.cloud + // Service Online LLC : http://drs.ua/ // Submitted by Serhii Bulakh <support(a)drs.ua> biz.ua @@ -11736,6 +11856,10 @@ // Submitted by Lina He <info(a)stackspace.io> stackspace.space +// Storj Labs Inc. : https://storj.io/ +// Submitted by Philip Hutchins <hostmaster(a)storj.io> +storj.farm + // Synology, Inc. : https://www.synology.com/ // Submitted by Rony Weng <ronyweng(a)synology.com> diskstation.me @@ -11751,6 +11875,7 @@ i234.me myds.me synology.me +vpnplus.to // TAIFUN Software AG : http://taifun-software.de // Submitted by Bjoern Henke <dev-server(a)taifun-software.de> @@ -11794,6 +11919,10 @@ synology-diskstation.de synology-ds.de +// Uberspace : https://uberspace.de +// Submitted by Moritz Werner <mwerner(a)jonaspasche.com> +uber.space + // UDR Limited : http://www.udr.hk.com // Submitted by registry <hostmaster(a)udr.hk.com> hk.com @@ -11817,6 +11946,10 @@ // Submitted by Yuvi Panda <yuvipanda(a)wikimedia.org> wmflabs.org +// XS4ALL Internet bv : https://www.xs4all.nl/ +// Submitted by Daniel Mostertman <unixbeheer+publicsuffix(a)xs4all.net> +xs4all.space + // Yola : https://www.yola.com/ // Submitted by Stefano Rivera <stefano(a)yola.com> yolasite.com

1 0

commit ghc-proxied for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-proxied for openSUSE:Factory checked in at 2017-08-31 20:58:03 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-proxied (Old) and /work/SRC/openSUSE:Factory/.ghc-proxied.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-proxied" Thu Aug 31 20:58:03 2017 rev:2 rq:513457 version:0.3 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-proxied/ghc-proxied.changes 2016-11-15 17:57:09.000000000 +0100 +++ /work/SRC/openSUSE:Factory/.ghc-proxied.new/ghc-proxied.changes 2017-08-31 20:58:04.725799520 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:07:02 UTC 2017 - psimons(a)suse.com + +- Update to version 0.3. + +------------------------------------------------------------------- Old: ---- proxied-0.2.tar.gz New: ---- proxied-0.3.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-proxied.spec ++++++ --- /var/tmp/diff_new_pack.VtArbQ/_old 2017-08-31 20:58:05.401704554 +0200 +++ /var/tmp/diff_new_pack.VtArbQ/_new 2017-08-31 20:58:05.405703992 +0200 @@ -1,7 +1,7 @@ # # spec file for package ghc-proxied # -# Copyright (c) 2016 SUSE LINUX GmbH, Nuernberg, Germany. +# Copyright (c) 2017 SUSE LINUX GmbH, Nuernberg, Germany. # # All modifications and additions to the file contributed by third parties # remain the property of their copyright owners, unless otherwise agreed @@ -18,20 +18,16 @@ %global pkg_name proxied Name: ghc-%{pkg_name} -Version: 0.2 +Version: 0.3 Release: 0 Summary: Make functions consume Proxy instead of undefined License: BSD-3-Clause -Group: System/Libraries +Group: Development/Languages/Other Url: https://hackage.haskell.org/package/%{pkg_name} Source0: https://hackage.haskell.org/package/%{pkg_name}-%{version}/%{pkg_name}-%{ve… BuildRequires: ghc-Cabal-devel -# Begin cabal-rpm deps: -BuildRequires: ghc-generic-deriving-devel BuildRequires: ghc-rpm-macros -BuildRequires: ghc-tagged-devel BuildRoot: %{_tmppath}/%{name}-%{version}-build -# End cabal-rpm deps %description 'proxied' is a simple library that exports a function to convert constant @@ -70,15 +66,12 @@ %prep %setup -q -n %{pkg_name}-%{version} - %build %ghc_lib_build - %install %ghc_lib_install - %post devel %ghc_pkg_recache ++++++ proxied-0.2.tar.gz -> proxied-0.3.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/proxied-0.2/CHANGELOG.md new/proxied-0.3/CHANGELOG.md --- old/proxied-0.2/CHANGELOG.md 2016-04-17 00:57:59.000000000 +0200 +++ new/proxied-0.3/CHANGELOG.md 2017-04-04 16:04:59.000000000 +0200 @@ -1,3 +1,14 @@ +## 0.3 +* Update for GHC 8.2 + * Since `typeRep#`, `typeNatTypeRep`, and `typeSymbolTypeRep` are no longer + exported from `base`, `theTypeRep#`, `theTypeNatTypeRep`, and + `theTypeSymbolTypeRep` are now synonyms for `theTypeRep` + * Happily, the new type signature for `GHC.OverloadedLabels.fromLabel` is now + exactly the same as `theFromLabel`, so the latter is now a synonym for the + former +* Use explicit kind variable binders in `Data.Proxyless` +* Use explicit `forall`s in `Data.Proxied` for consistency + ## 0.2 * Added the `Data.Proxyless` module * Added `proxyHashed` to `Data.Proxied` diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/proxied-0.2/LICENSE new/proxied-0.3/LICENSE --- old/proxied-0.2/LICENSE 2016-04-17 00:57:59.000000000 +0200 +++ new/proxied-0.3/LICENSE 2017-04-04 16:04:59.000000000 +0200 @@ -1,4 +1,4 @@ -Copyright (c) 2016, Ryan Scott +Copyright (c) 2016-2017, Ryan Scott All rights reserved. diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/proxied-0.2/README.md new/proxied-0.3/README.md --- old/proxied-0.2/README.md 2016-04-17 00:57:59.000000000 +0200 +++ new/proxied-0.3/README.md 2017-04-04 16:04:59.000000000 +0200 @@ -19,4 +19,4 @@ `Proxy`, however, does not carry any of the error-throwing risks of `undefined`, so it is much more preferable to take `Proxy` as an argument to a constant function instead of `undefined`. Unfortunately, `Proxy` was included in `base` until GHC 7.8, so many of `base`'s typeclasses still contain constant functions that aren't amenable to passing `Proxy`. `proxied` addresses this issue by providing variants of those typeclass functions that take an explicit `proxy` value. -This library also contains the "Data.Proxyless" module, which works in the opposite direction. That is, one can take functions which take `Proxy` (or `undefined`) as an argument and convert them to functions which take no arguments. This trick relies on the `-XTypeApplications` extension, so it is only available with GHC 8.0 or later. +This library also contains the `Data.Proxyless` module, which works in the opposite direction. That is, one can take functions which take `Proxy` (or `undefined`) as an argument and convert them to functions which take no arguments. This trick relies on the `-XTypeApplications` extension, so it is only available with GHC 8.0 or later. diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/proxied-0.2/proxied.cabal new/proxied-0.3/proxied.cabal --- old/proxied-0.2/proxied.cabal 2016-04-17 00:57:59.000000000 +0200 +++ new/proxied-0.3/proxied.cabal 2017-04-04 16:04:59.000000000 +0200 @@ -1,5 +1,5 @@ name: proxied -version: 0.2 +version: 0.3 synopsis: Make functions consume Proxy instead of undefined description: @proxied@ is a simple library that exports a function to convert constant functions to ones that take a @proxy@ @@ -34,7 +34,7 @@ author: Ryan Scott maintainer: Ryan Scott <ryan.gl.scott(a)gmail.com> stability: Provisional -copyright: (C) 2016 Ryan Scott +copyright: (C) 2016-2017 Ryan Scott category: Data build-type: Simple tested-with: GHC == 7.0.4 @@ -43,7 +43,8 @@ , GHC == 7.6.3 , GHC == 7.8.4 , GHC == 7.10.3 - , GHC == 8.0.1 + , GHC == 8.0.2 + , GHC == 8.2.1 extra-source-files: CHANGELOG.md, README.md cabal-version: >=1.10 @@ -56,8 +57,10 @@ if impl(ghc >= 8.0) exposed-modules: Data.Proxyless build-depends: base >= 4.3 && < 5 - , generic-deriving >= 1.10.1 && < 2 - , tagged >= 0.4.4 && < 1 + if !impl(ghc >= 7.6) + build-depends: generic-deriving >= 1.10.1 && < 2 + if !impl(ghc >= 7.8) + build-depends: tagged >= 0.4.4 && < 1 hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/proxied-0.2/src/Data/Proxied.hs new/proxied-0.3/src/Data/Proxied.hs --- old/proxied-0.2/src/Data/Proxied.hs 2016-04-17 00:57:59.000000000 +0200 +++ new/proxied-0.3/src/Data/Proxied.hs 2017-04-04 16:04:59.000000000 +0200 @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MagicHash #-} +{-# LANGUAGE ScopedTypeVariables #-} #if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} @@ -14,7 +15,7 @@ {-| Module: Data.Proxied -Copyright: (C) 2016 Ryan Scott +Copyright: (C) 2016-2017 Ryan Scott License: BSD-style (see the file LICENSE) Maintainer: Ryan Scott Stability: Provisional @@ -81,8 +82,12 @@ import Foreign.Storable (Storable(..)) +#if MIN_VERSION_base(4,6,0) +import GHC.Generics +#else import Generics.Deriving.Base import Generics.Deriving.Instances () +#endif #if MIN_VERSION_base(4,7,0) import Data.Bits (FiniteBits(..)) @@ -93,7 +98,7 @@ -- | Converts a constant function to one that takes a @proxy@ argument. -- -- /Since: 0.1/ -proxied :: (a -> b) -> proxy a -> b +proxied :: forall proxy a b. (a -> b) -> proxy a -> b proxied f _ = f undefined #if MIN_VERSION_base(4,7,0) @@ -101,7 +106,7 @@ -- This function is only available with @base-4.7@ or later. -- -- /Since: 0.2/ -proxyHashed :: (a -> b) -> Proxy# a -> b +proxyHashed :: forall a b. (a -> b) -> Proxy# a -> b proxyHashed f _ = f undefined #endif @@ -110,7 +115,7 @@ -- but it's here for symmetry.) -- -- /Since: 0.1/ -unproxied :: (Proxy a -> b) -> a -> b +unproxied :: forall a b. (Proxy a -> b) -> a -> b unproxied f _ = f Proxy ------------------------------------------------------------------------------- @@ -120,13 +125,13 @@ -- | @'bitSizeProxied' = 'proxied' 'bitSize'@ -- -- /Since: 0.1/ -bitSizeProxied :: Bits a => proxy a -> Int +bitSizeProxied :: forall proxy a. Bits a => proxy a -> Int bitSizeProxied = proxied bitSize -- | @'isSignedProxied' = 'proxied' 'isSigned'@ -- -- /Since: 0.1/ -isSignedProxied :: Bits a => proxy a -> Bool +isSignedProxied :: forall proxy a. Bits a => proxy a -> Bool isSignedProxied = proxied isSigned #if MIN_VERSION_base(4,7,0) @@ -135,7 +140,7 @@ -- This function is only available with @base-4.7@ or later. -- -- /Since: 0.1/ -bitSizeMaybeProxied :: Bits a => proxy a -> Maybe Int +bitSizeMaybeProxied :: forall proxy a. Bits a => proxy a -> Maybe Int bitSizeMaybeProxied = proxied bitSizeMaybe -- | @'finiteBitSizeProxied' = 'proxied' 'finiteBitSize'@ @@ -143,7 +148,7 @@ -- This function is only available with @base-4.7@ or later. -- -- /Since: 0.1/ -finiteBitSizeProxied :: FiniteBits a => proxy a -> Int +finiteBitSizeProxied :: forall proxy a. FiniteBits a => proxy a -> Int finiteBitSizeProxied = proxied finiteBitSize #endif @@ -154,7 +159,7 @@ -- | @'dataTypeOfProxied' = 'proxied' 'dataTypeOf'@ -- -- /Since: 0.1/ -dataTypeOfProxied :: Data a => proxy a -> DataType +dataTypeOfProxied :: forall proxy a. Data a => proxy a -> DataType dataTypeOfProxied = proxied dataTypeOf ------------------------------------------------------------------------------- @@ -166,7 +171,13 @@ -- On @base-4.7@ and later, this is identical to 'typeRep'. -- -- /Since: 0.1/ -typeOfProxied :: Typeable a => proxy a -> TypeRep +typeOfProxied :: forall proxy +#if MIN_VERSION_base(4,7,0) + (a :: k) +#else + a +#endif + . Typeable a => proxy a -> TypeRep #if MIN_VERSION_base(4,7,0) typeOfProxied = typeRep #else @@ -180,29 +191,33 @@ -- | @'sizeOfProxied' = 'proxied' 'sizeOf'@ -- -- /Since: 0.1/ -sizeOfProxied :: Storable a => proxy a -> Int +sizeOfProxied :: forall proxy a. Storable a => proxy a -> Int sizeOfProxied = proxied sizeOf -- | @'alignmentProxied' = 'proxied' 'alignment'@ -- -- /Since: 0.1/ -alignmentProxied :: Storable a => proxy a -> Int +alignmentProxied :: forall proxy a. Storable a => proxy a -> Int alignmentProxied = proxied alignment ------------------------------------------------------------------------------- -- GHC.Generics ------------------------------------------------------------------------------- -#if MIN_VERSION_base(4,9,0) -# define T_TYPE(t) (t :: k -> (* -> *) -> * -> *) +#define GENERIC_FORALL(t,letter) forall proxy T_TYPE(t) letter f a + +#if MIN_VERSION_base(4,10,0) +# define T_TYPE(t) (t :: k1 -> (k2 -> *) -> k2 -> *) +#elif MIN_VERSION_base(4,9,0) +# define T_TYPE(t) (t :: k1 -> (* -> *) -> k2 -> *) #else -# define T_TYPE(t) (t :: * -> (* -> *) -> * -> *) +# define T_TYPE(t) (t :: * -> (* -> *) -> * -> *) #endif -- | @'datatypeNameProxied' = 'proxied' 'datatypeName'@ -- -- /Since: 0.1/ -datatypeNameProxied :: Datatype d +datatypeNameProxied :: GENERIC_FORALL(t,d). Datatype d => proxy (T_TYPE(t) d f a) -> [Char] datatypeNameProxied = proxied datatypeName @@ -210,7 +225,7 @@ -- | @'moduleNameProxied' = 'proxied' 'moduleName'@ -- -- /Since: 0.1/ -moduleNameProxied :: Datatype d +moduleNameProxied :: GENERIC_FORALL(t,d). Datatype d => proxy (T_TYPE(t) d f a) -> [Char] moduleNameProxied = proxied moduleName @@ -221,7 +236,7 @@ -- This function is only available with @base-4.7@ or later. -- -- /Since: 0.1/ -isNewtypeProxied :: Datatype d +isNewtypeProxied :: GENERIC_FORALL(t,d). Datatype d => proxy (T_TYPE(t) d f a) -> Bool isNewtypeProxied = proxied isNewtype @@ -233,7 +248,7 @@ -- This function is only avaiable with @base-4.9@ or later. -- -- /Since: 0.1/ -packageNameProxied :: Datatype d +packageNameProxied :: GENERIC_FORALL(t,d). Datatype d => proxy (T_TYPE(t) d f a) -> [Char] packageNameProxied = proxied packageName @@ -242,7 +257,7 @@ -- | @'conNameProxied' = 'proxied' 'conName'@ -- -- /Since: 0.1/ -conNameProxied :: Constructor c +conNameProxied :: GENERIC_FORALL(t,c). Constructor c => proxy (T_TYPE(t) c f a) -> [Char] conNameProxied = proxied conName @@ -250,7 +265,7 @@ -- | @'conFixityProxied' = 'proxied' 'conFixity'@ -- -- /Since: 0.1/ -conFixityProxied :: Constructor c +conFixityProxied :: GENERIC_FORALL(t,c). Constructor c => proxy (T_TYPE(t) c f a) -> Fixity conFixityProxied = proxied conFixity @@ -258,7 +273,7 @@ -- | @'conIsRecordProxied' = 'proxied' 'conIsRecord'@ -- -- /Since: 0.1/ -conIsRecordProxied :: Constructor c +conIsRecordProxied :: GENERIC_FORALL(t,c). Constructor c => proxy (T_TYPE(t) c f a) -> Bool conIsRecordProxied = proxied conIsRecord @@ -266,7 +281,7 @@ -- | @'selNameProxied' = 'proxied' 'selName'@ -- -- /Since: 0.1/ -selNameProxied :: Selector s +selNameProxied :: GENERIC_FORALL(t,s). Selector s => proxy (T_TYPE(t) s f a) -> [Char] selNameProxied = proxied selName @@ -277,7 +292,7 @@ -- This function is only available with @base-4.9@ or later. -- -- /Since: 0.1/ -selSourceUnpackednessProxied :: Selector s +selSourceUnpackednessProxied :: GENERIC_FORALL(t,s). Selector s => proxy (T_TYPE(t) s f a) -> SourceUnpackedness selSourceUnpackednessProxied = proxied selSourceUnpackedness @@ -287,7 +302,7 @@ -- This function is only available with @base-4.9@ or later. -- -- /Since: 0.1/ -selSourceStrictnessProxied :: Selector s +selSourceStrictnessProxied :: GENERIC_FORALL(t,s). Selector s => proxy (T_TYPE(t) s f a) -> SourceStrictness selSourceStrictnessProxied = proxied selSourceStrictness @@ -297,7 +312,7 @@ -- This function is only available with @base-4.9@ or later. -- -- /Since: 0.1/ -selDecidedStrictnessProxied :: Selector s +selDecidedStrictnessProxied :: GENERIC_FORALL(t,s). Selector s => proxy (T_TYPE(t) s f a) -> DecidedStrictness selDecidedStrictnessProxied = proxied selDecidedStrictness @@ -310,19 +325,19 @@ -- | @'floatRadixProxied' = 'proxied' 'floatRadix'@ -- -- /Since: 0.1/ -floatRadixProxied :: RealFloat a => proxy a -> Integer +floatRadixProxied :: forall proxy a. RealFloat a => proxy a -> Integer floatRadixProxied = proxied floatRadix -- | @'floatDigitsProxied' = 'proxied' 'floatDigits'@ -- -- /Since: 0.1/ -floatDigitsProxied :: RealFloat a => proxy a -> Int +floatDigitsProxied :: forall proxy a. RealFloat a => proxy a -> Int floatDigitsProxied = proxied floatDigits -- | @'floatRangeProxied' = 'proxied' 'floatRange'@ -- -- /Since: 0.1/ -floatRangeProxied :: RealFloat a => proxy a -> (Int, Int) +floatRangeProxied :: forall proxy a. RealFloat a => proxy a -> (Int, Int) floatRangeProxied = proxied floatRange ------------------------------------------------------------------------------- @@ -335,6 +350,6 @@ -- This function is only available with @base-4.7@ or later. -- -- /Since: 0.1/ -parseFormatProxied :: PrintfArg a => proxy a -> ModifierParser +parseFormatProxied :: forall proxy a. PrintfArg a => proxy a -> ModifierParser parseFormatProxied = proxied parseFormat #endif diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/proxied-0.2/src/Data/Proxyless.hs new/proxied-0.3/src/Data/Proxyless.hs --- old/proxied-0.2/src/Data/Proxyless.hs 2016-04-17 00:57:59.000000000 +0200 +++ new/proxied-0.3/src/Data/Proxyless.hs 2017-04-04 16:04:59.000000000 +0200 @@ -1,19 +1,23 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE Trustworthy #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeInType #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ViewPatterns #-} - {-# OPTIONS_GHC -Wno-deprecations #-} + +#if __GLASGOW_HASKELL__ == 800 \ + && __GLASGOW_HASKELL_PATCHLEVEL1__ == 1 {-# OPTIONS_GHC -Wno-type-defaults #-} -- Needed due to GHC Trac #11947 +#endif {-| Module: Data.Proxyless -Copyright: (C) 2016 Ryan Scott +Copyright: (C) 2016-2017 Ryan Scott License: BSD-style (see the file LICENSE) Maintainer: Ryan Scott Stability: Provisional @@ -80,10 +84,13 @@ ) where import Data.Bits (Bits(..), FiniteBits(..)) -import Data.Data hiding (Fixity) +import Data.Data (Data(dataTypeOf), DataType) import Data.Proxy (Proxy(..)) import Data.Type.Equality ((:~:)) -import Data.Typeable.Internal (Typeable(..), typeNatTypeRep, typeSymbolTypeRep) +import Data.Typeable (Typeable, TypeRep, typeRep) +#if !(MIN_VERSION_base(4,10,0)) +import Data.Typeable.Internal (typeRep#, typeNatTypeRep, typeSymbolTypeRep) +#endif import Foreign.Storable (Storable(..)) @@ -98,14 +105,14 @@ -- doesn't require an argument. -- -- /Since: 0.2/ -proxyless :: forall a b. (Proxy a -> b) -> b +proxyless :: forall k (a :: k) b. (Proxy a -> b) -> b proxyless f = f Proxy -- | Converts a constant function that takes a 'Proxy#' argument to one that -- doesn't require an argument. -- -- /Since: 0.2/ -proxyHashless :: forall a b. (Proxy# a -> b) -> b +proxyHashless :: forall k (a :: k) b. (Proxy# a -> b) -> b proxyHashless f = f proxy# -- | Converts a constant function that takes an 'undefined' argument to one that @@ -159,27 +166,48 @@ -- | @'theTypeNatTypeRep' = 'proxyHashless' 'typeNatTypeRep'@ -- +-- Note that in @base-4.10@ and later, 'theTypeNatTypeRep' is simply a synonym +-- for 'theTypeRep', as 'typeNatTypeRep' is no longer exported. +-- -- /Since: 0.2/ theTypeNatTypeRep :: forall a. KnownNat a => TypeRep -theTypeNatTypeRep = proxyHashless @a typeNatTypeRep +#if MIN_VERSION_base(4,10,0) +theTypeNatTypeRep = theTypeRep @_ @a +#else +theTypeNatTypeRep = proxyHashless @_ @a typeNatTypeRep +#endif -- | @'theTypeRep' = 'proxyless' 'typeRep'@ -- -- /Since: 0.2/ -theTypeRep :: forall a. Typeable a => TypeRep -theTypeRep = proxyless @a typeRep +theTypeRep :: forall k (a :: k). Typeable a => TypeRep +theTypeRep = proxyless @_ @a typeRep -- | @'theTypeRep#' = 'proxyHashless' 'typeRep#'@ -- +-- Note that in @base-4.10@ and later, 'theTypeRep#' is simply a synonym for +-- 'theTypeRep', as 'typeRep#' is no longer exported. +-- -- /Since: 0.2/ -theTypeRep# :: forall a. Typeable a => TypeRep -theTypeRep# = proxyHashless @a typeRep# +theTypeRep# :: forall k (a :: k). Typeable a => TypeRep +#if MIN_VERSION_base(4,10,0) +theTypeRep# = theTypeRep @k @a +#else +theTypeRep# = proxyHashless @_ @a typeRep# +#endif -- | @'theTypeSymbolTypeRep' = 'proxyHashless' 'typeSymbolTypeRep'@ -- +-- Note that in @base-4.10@ and later, 'theTypeSymbolTypeRep' is simply a +-- synonym for 'theTypeRep', as 'typeSymbolTypeRep' is no longer exported. +-- -- /Since: 0.2/ theTypeSymbolTypeRep :: forall a. KnownSymbol a => TypeRep -theTypeSymbolTypeRep = proxyHashless @a typeSymbolTypeRep +#if MIN_VERSION_base(4,10,0) +theTypeSymbolTypeRep = theTypeRep @_ @a +#else +theTypeSymbolTypeRep = proxyHashless @_ @a typeSymbolTypeRep +#endif ------------------------------------------------------------------------------- -- Foreign.Storable @@ -204,78 +232,85 @@ -- | @'theDatatypeName' = 'datatypeName' 'undefined'@ -- -- /Since: 0.2/ -theDatatypeName :: forall d. Datatype d => [Char] +theDatatypeName :: forall k (d :: k). Datatype d => [Char] theDatatypeName = datatypeName @d undefined -- | @'theModuleName' = 'moduleName' 'undefined'@ -- -- /Since: 0.2/ -theModuleName :: forall d. Datatype d => [Char] +theModuleName :: forall k (d :: k). Datatype d => [Char] theModuleName = moduleName @d undefined -- | @'theIsNewtype' = 'isNewtype' 'undefined'@ -- -- /Since: 0.2/ -theIsNewtype :: forall d. Datatype d => Bool +theIsNewtype :: forall k (d :: k). Datatype d => Bool theIsNewtype = isNewtype @d undefined -- | @'thePackageName' = 'packageName' 'undefined'@ -- -- /Since: 0.2/ -thePackageName :: forall d. Datatype d => [Char] +thePackageName :: forall k (d :: k). Datatype d => [Char] thePackageName = packageName @d undefined -- | @'theConName' = 'conName' 'undefined'@ -- -- /Since: 0.2/ -theConName :: forall c. Constructor c => [Char] +theConName :: forall k (c :: k). Constructor c => [Char] theConName = conName @c undefined -- | @'theConFixity' = 'conFixity' 'undefined'@ -- -- /Since: 0.2/ -theConFixity :: forall c. Constructor c => Fixity +theConFixity :: forall k (c :: k). Constructor c => Fixity theConFixity = conFixity @c undefined -- | @'theConIsRecord' = 'conIsRecord' 'undefined'@ -- -- /Since: 0.2/ -theConIsRecord :: forall c. Constructor c => Bool +theConIsRecord :: forall k (c :: k). Constructor c => Bool theConIsRecord = conIsRecord @c undefined -- | @'theSelName' = 'selName' 'undefined'@ -- -- /Since: 0.2/ -theSelName :: forall s. Selector s => [Char] +theSelName :: forall k (s :: k). Selector s => [Char] theSelName = selName @s undefined -- | @'theSelSourceUnpackedness' = 'selSourceUnpackedness' 'undefined'@ -- -- /Since: 0.2/ -theSelSourceUnpackedness :: forall s. Selector s => SourceUnpackedness +theSelSourceUnpackedness :: forall k (s :: k). Selector s => SourceUnpackedness theSelSourceUnpackedness = selSourceUnpackedness @s undefined -- | @'theSelSourceStrictness' = 'selSourceStrictness' 'undefined'@ -- -- /Since: 0.2/ -theSelSourceStrictness :: forall s. Selector s => SourceStrictness +theSelSourceStrictness :: forall k (s :: k). Selector s => SourceStrictness theSelSourceStrictness = selSourceStrictness @s undefined -- | @'theSelDecidedStrictness' = 'selDecidedStrictness' 'undefined'@ -- -- /Since: 0.2/ -theSelDecidedStrictness :: forall s. Selector s => DecidedStrictness +theSelDecidedStrictness :: forall k (s :: k). Selector s => DecidedStrictness theSelDecidedStrictness = selDecidedStrictness @s undefined ------------------------------------------------------------------------------- -- GHC.Generics ------------------------------------------------------------------------------- --- | @'theFromLabel' = 'proxyHashless' 'fromLabel'@ +-- | In @base-4.10@ and later, this is simply a synonym for 'fromLabel'. +-- In @base-4.9@, 'theFromLabel' is defined as: +-- +-- @'theFromLabel' = 'proxyHashless' 'fromLabel'@ -- -- /Since: 0.2/ theFromLabel :: forall x a. IsLabel x a => a -theFromLabel = proxyHashless @x fromLabel +#if MIN_VERSION_base(4,10,0) +theFromLabel = fromLabel @x +#else +theFromLabel = proxyHashless @_ @x fromLabel +#endif ------------------------------------------------------------------------------- -- GHC.TypeLits @@ -285,13 +320,13 @@ -- -- /Since: 0.2/ theNatVal :: forall n. KnownNat n => Integer -theNatVal = proxyless @n natVal +theNatVal = proxyless @_ @n natVal -- | @`theNatVal'` = 'proxyHashless' `natVal'`@ -- -- /Since: 0.2/ theNatVal' :: forall n. KnownNat n => Integer -theNatVal' = proxyHashless @n natVal' +theNatVal' = proxyHashless @_ @n natVal' -- | @'theSameNat' = 'sameNat' 'Proxy' 'Proxy'@ -- @@ -309,25 +344,25 @@ -- -- /Since: 0.2/ theSomeNat :: forall n. KnownNat n => SomeNat -theSomeNat = proxyless @n SomeNat +theSomeNat = proxyless @_ @n SomeNat -- | @'theSomeSymbol' = 'proxyless' 'SomeSymbol'@ -- -- /Since: 0.2/ theSomeSymbol :: forall n. KnownSymbol n => SomeSymbol -theSomeSymbol = proxyless @n SomeSymbol +theSomeSymbol = proxyless @_ @n SomeSymbol -- | @'theSymbolVal' = 'proxyless' 'symbolVal'@ -- -- /Since: 0.2/ theSymbolVal :: forall n. KnownSymbol n => String -theSymbolVal = proxyless @n symbolVal +theSymbolVal = proxyless @_ @n symbolVal -- | @`theSymbolVal'` = 'proxyHashless' `symbolVal'`@ -- -- /Since: 0.2/ theSymbolVal' :: forall n. KnownSymbol n => String -theSymbolVal' = proxyHashless @n symbolVal' +theSymbolVal' = proxyHashless @_ @n symbolVal' ------------------------------------------------------------------------------- -- Prelude

1 0

commit ghc-prometheus-metrics-ghc for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-prometheus-metrics-ghc for openSUSE:Factory checked in at 2017-08-31 20:58:01 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-prometheus-metrics-ghc (Old) and /work/SRC/openSUSE:Factory/.ghc-prometheus-metrics-ghc.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-prometheus-metrics-ghc" Thu Aug 31 20:58:01 2017 rev:3 rq:513456 version:0.2.0 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-prometheus-metrics-ghc/ghc-prometheus-metrics-ghc.changes 2017-06-04 01:55:07.988005513 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-prometheus-metrics-ghc.new/ghc-prometheus-metrics-ghc.changes 2017-08-31 20:58:01.458258620 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:08:11 UTC 2017 - psimons(a)suse.com + +- Update to version 0.2.0. + +------------------------------------------------------------------- Old: ---- prometheus-metrics-ghc-0.1.1.tar.gz New: ---- prometheus-metrics-ghc-0.2.0.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-prometheus-metrics-ghc.spec ++++++ --- /var/tmp/diff_new_pack.fEGy0q/_old 2017-08-31 20:58:02.638092850 +0200 +++ /var/tmp/diff_new_pack.fEGy0q/_new 2017-08-31 20:58:02.654090602 +0200 @@ -19,7 +19,7 @@ %global pkg_name prometheus-metrics-ghc %bcond_with tests Name: ghc-%{pkg_name} -Version: 0.1.1 +Version: 0.2.0 Release: 0 Summary: Metrics exposing GHC runtime information for use with prometheus-client License: Apache-2.0 ++++++ prometheus-metrics-ghc-0.1.1.tar.gz -> prometheus-metrics-ghc-0.2.0.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/prometheus-metrics-ghc-0.1.1/prometheus-metrics-ghc.cabal new/prometheus-metrics-ghc-0.2.0/prometheus-metrics-ghc.cabal --- old/prometheus-metrics-ghc-0.1.1/prometheus-metrics-ghc.cabal 2017-04-30 23:30:12.000000000 +0200 +++ new/prometheus-metrics-ghc-0.2.0/prometheus-metrics-ghc.cabal 2017-07-03 00:06:02.000000000 +0200 @@ -1,5 +1,5 @@ name: prometheus-metrics-ghc -version: 0.1.1 +version: 0.2.0 synopsis: Metrics exposing GHC runtime information for use with prometheus-client. description:

1 0

commit ghc-prometheus-client for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-prometheus-client for openSUSE:Factory checked in at 2017-08-31 20:57:58 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-prometheus-client (Old) and /work/SRC/openSUSE:Factory/.ghc-prometheus-client.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-prometheus-client" Thu Aug 31 20:57:58 2017 rev:3 rq:513455 version:0.2.0 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-prometheus-client/ghc-prometheus-client.changes 2017-06-04 01:55:06.444223618 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-prometheus-client.new/ghc-prometheus-client.changes 2017-08-31 20:57:59.454540149 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:06:35 UTC 2017 - psimons(a)suse.com + +- Update to version 0.2.0. + +------------------------------------------------------------------- Old: ---- prometheus-client-0.1.1.tar.gz New: ---- prometheus-client-0.2.0.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-prometheus-client.spec ++++++ --- /var/tmp/diff_new_pack.2NBGvc/_old 2017-08-31 20:58:00.366412027 +0200 +++ /var/tmp/diff_new_pack.2NBGvc/_new 2017-08-31 20:58:00.378410342 +0200 @@ -19,7 +19,7 @@ %global pkg_name prometheus-client %bcond_with tests Name: ghc-%{pkg_name} -Version: 0.1.1 +Version: 0.2.0 Release: 0 Summary: Haskell client library for http://prometheus.io License: Apache-2.0 @@ -29,11 +29,11 @@ BuildRequires: ghc-Cabal-devel BuildRequires: ghc-atomic-primops-devel BuildRequires: ghc-bytestring-devel +BuildRequires: ghc-clock-devel BuildRequires: ghc-containers-devel BuildRequires: ghc-mtl-devel BuildRequires: ghc-rpm-macros BuildRequires: ghc-stm-devel -BuildRequires: ghc-time-devel BuildRequires: ghc-transformers-devel BuildRequires: ghc-utf8-string-devel BuildRoot: %{_tmppath}/%{name}-%{version}-build ++++++ prometheus-client-0.1.1.tar.gz -> prometheus-client-0.2.0.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/prometheus-client-0.1.1/prometheus-client.cabal new/prometheus-client-0.2.0/prometheus-client.cabal --- old/prometheus-client-0.1.1/prometheus-client.cabal 2017-04-30 23:30:12.000000000 +0200 +++ new/prometheus-client-0.2.0/prometheus-client.cabal 2017-07-03 00:06:02.000000000 +0200 @@ -1,5 +1,5 @@ name: prometheus-client -version: 0.1.1 +version: 0.2.0 synopsis: Haskell client library for http://prometheus.io. description: Haskell client library for http://prometheus.io. homepage: https://github.com/fimad/prometheus-haskell @@ -28,6 +28,8 @@ , Prometheus.Metric , Prometheus.Metric.Counter , Prometheus.Metric.Gauge + , Prometheus.Metric.Histogram + , Prometheus.Metric.Observer , Prometheus.Metric.Summary , Prometheus.Metric.Vector , Prometheus.MonadMonitor @@ -36,11 +38,11 @@ atomic-primops >=0.4 , base >=4.7 && <5 , bytestring >=0.9 + , clock , containers , mtl >=2 , stm >=2.3 , transformers - , time , utf8-string ghc-options: -Wall @@ -66,11 +68,11 @@ , base >=4.7 && <5 , bytestring , containers + , clock , hspec , mtl , random-shuffle , stm - , time , transformers , utf8-string ghc-options: -Wall diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/prometheus-client-0.1.1/src/Prometheus/Metric/Counter.hs new/prometheus-client-0.2.0/src/Prometheus/Metric/Counter.hs --- old/prometheus-client-0.1.1/src/Prometheus/Metric/Counter.hs 2017-04-30 00:58:18.000000000 +0200 +++ new/prometheus-client-0.2.0/src/Prometheus/Metric/Counter.hs 2017-07-02 23:55:13.000000000 +0200 @@ -10,10 +10,10 @@ import Prometheus.Info import Prometheus.Metric +import Prometheus.Metric.Observer (timeAction) import Prometheus.MonadMonitor import Control.Monad (unless) -import Data.Time.Clock (diffUTCTime, getCurrentTime) import qualified Data.Atomics as Atomics import qualified Data.ByteString.UTF8 as BS import qualified Data.IORef as IORef @@ -60,10 +60,8 @@ -- | Add the duration of an IO action (in seconds) to a counter. addDurationToCounter :: IO a -> Metric Counter -> IO a addDurationToCounter io metric = do - start <- getCurrentTime - result <- io - end <- getCurrentTime - addCounter (fromRational $ toRational $ end `diffUTCTime` start) metric + (result, duration) <- timeAction io + _ <- addCounter duration metric return result -- | Retrieves the current value of a counter metric. diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/prometheus-client-0.1.1/src/Prometheus/Metric/Gauge.hs new/prometheus-client-0.2.0/src/Prometheus/Metric/Gauge.hs --- old/prometheus-client-0.1.1/src/Prometheus/Metric/Gauge.hs 2015-06-10 08:20:46.000000000 +0200 +++ new/prometheus-client-0.2.0/src/Prometheus/Metric/Gauge.hs 2017-07-02 23:55:13.000000000 +0200 @@ -12,9 +12,9 @@ import Prometheus.Info import Prometheus.Metric +import Prometheus.Metric.Observer (timeAction) import Prometheus.MonadMonitor -import Data.Time.Clock (diffUTCTime, getCurrentTime) import qualified Data.Atomics as Atomics import qualified Data.ByteString.UTF8 as BS import qualified Data.IORef as IORef @@ -68,10 +68,8 @@ -- | Sets a gauge metric to the duration in seconds of an IO action. setGaugeToDuration :: IO a -> Metric Gauge -> IO a setGaugeToDuration io metric = do - start <- getCurrentTime - result <- io - end <- getCurrentTime - setGauge (fromRational $ toRational $ end `diffUTCTime` start) metric + (result, duration) <- timeAction io + setGauge duration metric return result collectGauge :: Info -> IORef.IORef Double -> IO [SampleGroup] diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/prometheus-client-0.1.1/src/Prometheus/Metric/Histogram.hs new/prometheus-client-0.2.0/src/Prometheus/Metric/Histogram.hs --- old/prometheus-client-0.1.1/src/Prometheus/Metric/Histogram.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/prometheus-client-0.2.0/src/Prometheus/Metric/Histogram.hs 2017-07-02 23:55:13.000000000 +0200 @@ -0,0 +1,140 @@ +module Prometheus.Metric.Histogram ( + Histogram +, histogram +, defaultBuckets +, exponentialBuckets +, linearBuckets + +-- * Exported for testing +, BucketCounts(..) +, insert +, emptyCounts +, getHistogram +) where + +import Prometheus.Info +import Prometheus.Metric +import Prometheus.Metric.Observer +import Prometheus.MonadMonitor + +import Control.Applicative ((<$>)) +import qualified Control.Concurrent.STM as STM +import qualified Data.ByteString.UTF8 as BS +import qualified Data.Map.Strict as Map +import Numeric (showFFloat) + +-- | A histogram. Counts the number of observations that fall within the +-- specified buckets. +newtype Histogram = MkHistogram (STM.TVar BucketCounts) + +-- | Create a new 'Histogram' metric with a given name, help string, and +-- list of buckets. Panics if the list of buckets is not strictly increasing. +-- A good default list of buckets is 'defaultBuckets'. You can also create +-- buckets with 'linearBuckets' or 'exponentialBuckets'. +histogram :: Info -> [Bucket] -> IO (Metric Histogram) +histogram info buckets = do + countsTVar <- STM.newTVarIO (emptyCounts buckets) + return Metric { + handle = MkHistogram countsTVar + , collect = collectHistogram info countsTVar + } + +-- | Upper-bound for a histogram bucket. +type Bucket = Double + +-- | Current state of a histogram. +data BucketCounts = BucketCounts { + -- | The sum of all the observations. + histTotal :: !Double + -- | The number of observations that have been made. +, histCount :: !Int + -- | Counts for each bucket. The key is the upper-bound, + -- value is the number of observations less-than-or-equal-to + -- that upper bound, but greater than the next lowest upper bound. +, histCountsPerBucket :: Map.Map Bucket Int +} deriving (Show, Eq, Ord) + +emptyCounts :: [Bucket] -> BucketCounts +emptyCounts buckets + | isStrictlyIncreasing buckets = BucketCounts 0 0 $ Map.fromList (zip buckets (repeat 0)) + | otherwise = error ("Histogram buckets must be in increasing order, got: " ++ show buckets) + where + isStrictlyIncreasing xs = and (zipWith (<) xs (tail xs)) + +instance Observer Histogram where + -- | Add a new observation to a histogram metric. + observe v h = withHistogram h (insert v) + +-- | Transform the contents of a histogram. +withHistogram :: MonadMonitor m + => Metric Histogram -> (BucketCounts -> BucketCounts) -> m () +withHistogram Metric {handle = MkHistogram bucketCounts} f = + doIO $ STM.atomically $ STM.modifyTVar' bucketCounts f + +-- | Retries a map of upper bounds to counts of values observed that are +-- less-than-or-equal-to that upper bound, but greater than any other upper +-- bound in the map. +getHistogram :: Metric Histogram -> IO (Map.Map Bucket Int) +getHistogram Metric {handle = MkHistogram bucketsTVar} = + histCountsPerBucket <$> STM.atomically (STM.readTVar bucketsTVar) + +-- | Record an observation. +insert :: Double -> BucketCounts -> BucketCounts +insert value BucketCounts { histTotal = total, histCount = count, histCountsPerBucket = counts } = + BucketCounts (total + value) (count + 1) incCounts + where + incCounts = + case Map.lookupGE value counts of + Nothing -> counts + Just (upperBound, _) -> Map.adjust (+1) upperBound counts + +-- | Collect the current state of a histogram. +collectHistogram :: Info -> STM.TVar BucketCounts -> IO [SampleGroup] +collectHistogram info bucketCounts = STM.atomically $ do + BucketCounts total count counts <- STM.readTVar bucketCounts + let sumSample = Sample (name ++ "_sum") [] (bsShow total) + let countSample = Sample (name ++ "_count") [] (bsShow count) + let infSample = Sample name [(bucketLabel, "+Inf")] (bsShow count) + let samples = map toSample (cumulativeSum (Map.toAscList counts)) + return [SampleGroup info HistogramType $ samples ++ [infSample, sumSample, countSample]] + where + toSample (upperBound, count') = + Sample name [(bucketLabel, formatFloat upperBound)] $ bsShow count' + name = metricName info + + -- We don't particularly want scientific notation, so force regular + -- numeric representation instead. + formatFloat x = showFFloat Nothing x "" + + cumulativeSum xs = zip (map fst xs) (scanl1 (+) (map snd xs)) + + bsShow :: Show s => s -> BS.ByteString + bsShow = BS.fromString . show + +-- | The label that defines the upper bound of a bucket of a histogram. @"le"@ +-- is short for "less than or equal to". +bucketLabel :: String +bucketLabel = "le" + +-- | The default Histogram buckets. These are tailored to measure the response +-- time (in seconds) of a network service. You will almost certainly need to +-- customize them for your particular use case. +defaultBuckets :: [Double] +defaultBuckets = [0.005, 0.01, 0.025, 0.05, 0.1, 0.25, 0.5, 1, 2.5, 5, 10] + +-- | Create @count@ buckets, each @width@ wide, where the lowest bucket has an +-- upper bound of @start@. Use this to create buckets for 'histogram'. +linearBuckets :: Bucket -> Double -> Int -> [Bucket] +linearBuckets start width count + | count <= 0 = error ("Must provide a positive number of linear buckets, got: " ++ show count) + | otherwise = take count (iterate (width+) start) + +-- | Create @count@ buckets, where the lowest bucket has an upper bound of @start@ +-- and each bucket's upper bound is @factor@ times the previous bucket's upper bound. +-- Use this to create buckets for 'histogram'. +exponentialBuckets :: Bucket -> Double -> Int -> [Bucket] +exponentialBuckets start factor count + | count <= 0 = error ("Must provide a positive number of exponential buckets, got: " ++ show count) + | factor <= 1 = error ("Exponential buckets must have factor greater than 1 to ensure upper bounds are monotonically increasing, got: " ++ show factor) + | start <= 0 = error ("Exponential buckets must have positive number for start bucket to ensure upper bounds are monotonically increasing, got: " ++ show start) + | otherwise = take count (iterate (factor*) start) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/prometheus-client-0.1.1/src/Prometheus/Metric/Observer.hs new/prometheus-client-0.2.0/src/Prometheus/Metric/Observer.hs --- old/prometheus-client-0.1.1/src/Prometheus/Metric/Observer.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/prometheus-client-0.2.0/src/Prometheus/Metric/Observer.hs 2017-07-02 23:55:13.000000000 +0200 @@ -0,0 +1,36 @@ +module Prometheus.Metric.Observer ( + Observer(..) +, observeDuration +, timeAction +) where + +import Data.Ratio ((%)) +import Prometheus.Metric +import Prometheus.MonadMonitor + +import System.Clock (Clock(..), diffTimeSpec, getTime, toNanoSecs) + +-- | Interface shared by 'Summary' and 'Histogram'. +class Observer metric where + -- | Observe that a particular floating point value has occurred. + -- For example, observe that this request took 0.23s. + observe :: MonadMonitor m => Double -> Metric metric -> m () + +-- | Adds the duration in seconds of an IO action as an observation to an +-- observer metric. +observeDuration :: Observer metric => IO a -> Metric metric -> IO a +observeDuration io metric = do + (result, duration) <- timeAction io + observe duration metric + return result + + +-- | Evaluate @io@ and return its result as well as how long it took to evaluate, +-- in seconds. +timeAction :: IO a -> IO (a, Double) +timeAction io = do + start <- getTime Monotonic + result <- io + end <- getTime Monotonic + let duration = toNanoSecs (end `diffTimeSpec` start) % 1000000000 + return (result, fromRational duration) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/prometheus-client-0.1.1/src/Prometheus/Metric/Summary.hs new/prometheus-client-0.2.0/src/Prometheus/Metric/Summary.hs --- old/prometheus-client-0.1.1/src/Prometheus/Metric/Summary.hs 2015-06-10 08:23:32.000000000 +0200 +++ new/prometheus-client-0.2.0/src/Prometheus/Metric/Summary.hs 2017-07-02 23:55:13.000000000 +0200 @@ -19,10 +19,10 @@ import Prometheus.Info import Prometheus.Metric +import Prometheus.Metric.Observer import Prometheus.MonadMonitor import Data.Int (Int64) -import Data.Time.Clock (diffUTCTime, getCurrentTime) import Data.Foldable (foldr') import qualified Control.Concurrent.STM as STM import qualified Data.ByteString.UTF8 as BS @@ -48,19 +48,9 @@ STM.modifyTVar' valueTVar compress STM.modifyTVar' valueTVar f --- | Adds a new observation to a summary metric. -observe :: MonadMonitor m => Double -> Metric Summary -> m () -observe v s = withSummary s (insert v) - --- | Adds the duration in seconds of an IO action as an observation to a summary --- metric. -observeDuration :: IO a -> Metric Summary -> IO a -observeDuration io metric = do - start <- getCurrentTime - result <- io - end <- getCurrentTime - observe (fromRational $ toRational $ end `diffUTCTime` start) metric - return result +instance Observer Summary where + -- | Adds a new observation to a summary metric. + observe v s = withSummary s (insert v) -- | Retrieves a list of tuples containing a quantile and its associated value. getSummary :: Metric Summary -> IO [(Rational, Double)] diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/prometheus-client-0.1.1/src/Prometheus.hs new/prometheus-client-0.2.0/src/Prometheus.hs --- old/prometheus-client-0.1.1/src/Prometheus.hs 2017-04-30 00:58:18.000000000 +0200 +++ new/prometheus-client-0.2.0/src/Prometheus.hs 2017-07-02 23:55:13.000000000 +0200 @@ -72,11 +72,26 @@ , setGaugeToDuration , getGauge --- ** Summary +-- ** Summaries and histograms -- --- | A summary captures observations of a floating point value over time and --- summarizes the observations as a count, sum, and rank estimations. A typical --- use case for summaries is measuring HTTP request latency. +-- | An 'Observer' is a generic metric that captures observations of a +-- floating point value over time. Different implementations can store +-- and summarise these value in different ways. +-- +-- The two main observers are summaries and histograms. A 'Summary' allows you +-- to get a precise estimate of a particular quantile, but cannot be meaningfully +-- aggregated across processes. A 'Histogram' packs requests into user-supplied +-- buckets, which /can/ be aggregated meaningfully, but provide much less precise +-- information on particular quantiles. + +, Observer(..) +, observeDuration + +-- *** Summary +-- +-- | A summary is an 'Observer' that summarizes the observations as a count, +-- sum, and rank estimations. A typical use case for summaries is measuring +-- HTTP request latency. -- -- >>> mySummary <- summary (Info "my_summary" "") defaultQuantiles -- >>> observe 0 mySummary @@ -87,10 +102,26 @@ , Quantile , summary , defaultQuantiles -, observe -, observeDuration , getSummary +-- *** Histogram +-- +-- | A histogram captures observations of a floating point value over time +-- and stores those observations in a user-supplied histogram. A typical use case +-- for histograms is measuring HTTP request latency. Histograms are unlike +-- summaries in that they can be meaningfully aggregated across processes. +-- +-- >>> myHistogram <- histogram (Info "my_histogram" "") defaultBuckets +-- >>> observe 0 myHistogram +-- >>> getHistogram myHistogram +-- fromList [(5.0e-3,1),(1.0e-2,0),(2.5e-2,0),(5.0e-2,0),(0.1,0),(0.25,0),(0.5,0),(1.0,0),(2.5,0),(5.0,0),(10.0,0)] +, Histogram +, histogram +, defaultBuckets +, exponentialBuckets +, linearBuckets +, getHistogram + -- ** Vector -- -- | A vector models a collection of metrics that share the same name but are @@ -223,6 +254,8 @@ import Prometheus.Metric import Prometheus.Metric.Counter import Prometheus.Metric.Gauge +import Prometheus.Metric.Histogram +import Prometheus.Metric.Observer import Prometheus.Metric.Summary import Prometheus.Metric.Vector import Prometheus.MonadMonitor

1 0

commit ghc-postgresql-binary for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-postgresql-binary for openSUSE:Factory checked in at 2017-08-31 20:57:56 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-postgresql-binary (Old) and /work/SRC/openSUSE:Factory/.ghc-postgresql-binary.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-postgresql-binary" Thu Aug 31 20:57:56 2017 rev:3 rq:513452 version:0.12.1 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-postgresql-binary/ghc-postgresql-binary.changes 2017-03-12 20:04:16.775383235 +0100 +++ /work/SRC/openSUSE:Factory/.ghc-postgresql-binary.new/ghc-postgresql-binary.changes 2017-08-31 20:57:57.610799199 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:08:11 UTC 2017 - psimons(a)suse.com + +- Update to version 0.12.1. + +------------------------------------------------------------------- Old: ---- postgresql-binary-0.9.3.tar.gz New: ---- postgresql-binary-0.12.1.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-postgresql-binary.spec ++++++ --- /var/tmp/diff_new_pack.d9OWpx/_old 2017-08-31 20:57:58.654652535 +0200 +++ /var/tmp/diff_new_pack.d9OWpx/_new 2017-08-31 20:57:58.658651973 +0200 @@ -19,7 +19,7 @@ %global pkg_name postgresql-binary %bcond_with tests Name: ghc-%{pkg_name} -Version: 0.9.3 +Version: 0.12.1 Release: 0 Summary: Encoders and decoders for the PostgreSQL's binary format License: MIT @@ -31,14 +31,17 @@ BuildRequires: ghc-base-prelude-devel BuildRequires: ghc-binary-parser-devel BuildRequires: ghc-bytestring-devel -BuildRequires: ghc-foldl-devel +BuildRequires: ghc-bytestring-strict-builder-devel +BuildRequires: ghc-containers-devel BuildRequires: ghc-loch-th-devel +BuildRequires: ghc-network-ip-devel BuildRequires: ghc-placeholders-devel BuildRequires: ghc-rpm-macros BuildRequires: ghc-scientific-devel BuildRequires: ghc-text-devel BuildRequires: ghc-time-devel BuildRequires: ghc-transformers-devel +BuildRequires: ghc-unordered-containers-devel BuildRequires: ghc-uuid-devel BuildRequires: ghc-vector-devel BuildRoot: %{_tmppath}/%{name}-%{version}-build ++++++ postgresql-binary-0.9.3.tar.gz -> postgresql-binary-0.12.1.tar.gz ++++++ ++++ 3448 lines of diff (skipped)

1 0

commit ghc-pipes-misc for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-pipes-misc for openSUSE:Factory checked in at 2017-08-31 20:57:53 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-pipes-misc (Old) and /work/SRC/openSUSE:Factory/.ghc-pipes-misc.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-pipes-misc" Thu Aug 31 20:57:53 2017 rev:2 rq:513451 version:0.3.0.0 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-pipes-misc/ghc-pipes-misc.changes 2017-04-14 13:35:44.108231364 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-pipes-misc.new/ghc-pipes-misc.changes 2017-08-31 20:57:55.731063308 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:08:15 UTC 2017 - psimons(a)suse.com + +- Update to version 0.3.0.0. + +------------------------------------------------------------------- Old: ---- pipes-misc-0.2.5.0.tar.gz New: ---- pipes-misc-0.3.0.0.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-pipes-misc.spec ++++++ --- /var/tmp/diff_new_pack.gqOGQy/_old 2017-08-31 20:57:56.906898099 +0200 +++ /var/tmp/diff_new_pack.gqOGQy/_new 2017-08-31 20:57:56.926895290 +0200 @@ -19,7 +19,7 @@ %global pkg_name pipes-misc %bcond_with tests Name: ghc-%{pkg_name} -Version: 0.2.5.0 +Version: 0.3.0.0 Release: 0 Summary: Miscellaneous utilities for pipes, required by glazier-tutorial License: BSD-3-Clause ++++++ pipes-misc-0.2.5.0.tar.gz -> pipes-misc-0.3.0.0.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/pipes-misc-0.2.5.0/pipes-misc.cabal new/pipes-misc-0.3.0.0/pipes-misc.cabal --- old/pipes-misc-0.2.5.0/pipes-misc.cabal 2017-02-17 11:23:18.000000000 +0100 +++ new/pipes-misc-0.3.0.0/pipes-misc.cabal 2017-02-22 22:15:26.000000000 +0100 @@ -1,5 +1,5 @@ name: pipes-misc -version: 0.2.5.0 +version: 0.3.0.0 synopsis: Miscellaneous utilities for pipes, required by glazier-tutorial description: Please see README.md homepage: https://github.com/louispan/pipes-misc#readme diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/pipes-misc-0.2.5.0/src/Pipes/Misc/Concurrent.hs new/pipes-misc-0.3.0.0/src/Pipes/Misc/Concurrent.hs --- old/pipes-misc-0.2.5.0/src/Pipes/Misc/Concurrent.hs 2017-02-14 12:46:50.000000000 +0100 +++ new/pipes-misc-0.3.0.0/src/Pipes/Misc/Concurrent.hs 2017-02-22 23:06:32.000000000 +0100 @@ -6,12 +6,14 @@ import Control.Concurrent import Control.Concurrent.STM import Control.Monad -import Control.Monad.Trans.Class +import Control.Monad.Morph import Control.Monad.Trans.Except import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Reader import qualified Data.List.NonEmpty as NE import qualified Pipes as P import qualified Pipes.Concurrent as PC +import qualified Pipes.Prelude as PP -- | Like Pipes.Concurrent.fromInput, but stays in STM. -- Using @hoist atomically@ to convert to IO monad seems to work. @@ -77,3 +79,12 @@ Nothing -> Left ys -- return successful reads so far Just x' -> Right $ x' NE.<| ys {-# INLINABLE batch #-} + +-- | Combine a 'Pipes.Concurrent.Input' and a 'ReaderT a STM r' into a 'Pipes.Producer' of the result r. +-- That is, given a input of messages, and something that executes the messages to produce a result r, +-- combine them to get a Producer of the executed results. +execInput + :: (MonadTrans t, Monad (t STM)) + => PC.Input a -> ReaderT a (t STM) b -> P.Producer' b (t STM) () +execInput input m = hoist lift (fromInputSTM input) P.>-> PP.mapM (runReaderT m) +{-# INLINABLE execInput #-} diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/pipes-misc-0.2.5.0/src/Pipes/Misc/State/Lazy.hs new/pipes-misc-0.3.0.0/src/Pipes/Misc/State/Lazy.hs --- old/pipes-misc-0.2.5.0/src/Pipes/Misc/State/Lazy.hs 2017-02-17 11:22:53.000000000 +0100 +++ new/pipes-misc-0.3.0.0/src/Pipes/Misc/State/Lazy.hs 2017-02-22 22:05:02.000000000 +0100 @@ -2,14 +2,10 @@ module Pipes.Misc.State.Lazy where -import Control.Concurrent.STM import Control.Lens -import Control.Monad.Morph import Control.Monad.Reader import Control.Monad.State.Lazy import qualified Pipes as P -import qualified Pipes.Concurrent as PC -import qualified Pipes.Misc.Concurrent as PM import qualified Pipes.Prelude as PP -- | Store the output of the pipe into a MonadState. @@ -43,21 +39,3 @@ f s pure a {-# INLINABLE onState #-} - --- | Converts a 'Glazier.Gadget' into a 'Pipes.Pipe' -rsPipe :: (Monad m, MonadTrans t, MonadState s (t m)) => ReaderT a (StateT s m) b -> P.Pipe a b (t m) r -rsPipe m = forever $ do - a <- P.await - s <- get - -- This is the only line that is different between the Strict and Lazy version - ~(c, s') <- lift . lift $ runStateT (runReaderT m a) s - put s' - P.yield c -{-# INLINABLE rsPipe #-} - --- | Convert a 'Pipes.Concurrent.Input' and a 'Glazier.Gadget' into a stateful 'Pipes.Producer' of commands to interpret. -rsProducer :: - (MonadState s (t STM), MonadTrans t) => - PC.Input a -> ReaderT a (StateT s STM) c -> P.Producer' c (t STM) () -rsProducer input m = hoist lift (PM.fromInputSTM input) P.>-> rsPipe m -{-# INLINABLE rsProducer #-} diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/pipes-misc-0.2.5.0/src/Pipes/Misc/State/Strict.hs new/pipes-misc-0.3.0.0/src/Pipes/Misc/State/Strict.hs --- old/pipes-misc-0.2.5.0/src/Pipes/Misc/State/Strict.hs 2017-02-17 11:23:02.000000000 +0100 +++ new/pipes-misc-0.3.0.0/src/Pipes/Misc/State/Strict.hs 2017-02-22 22:05:17.000000000 +0100 @@ -2,14 +2,9 @@ module Pipes.Misc.State.Strict where -import Control.Concurrent.STM import Control.Lens -import Control.Monad.Morph -import Control.Monad.Reader import Control.Monad.State.Strict import qualified Pipes as P -import qualified Pipes.Concurrent as PC -import qualified Pipes.Misc.Concurrent as PM import qualified Pipes.Prelude as PP -- | Store the output of the pipe into a MonadState. @@ -43,21 +38,3 @@ f s pure a {-# INLINABLE onState #-} - --- | Converts a 'Glazier.Gadget' into a 'Pipes.Pipe' -rsPipe :: (Monad m, MonadTrans t, MonadState s (t m)) => ReaderT a (StateT s m) b -> P.Pipe a b (t m) r -rsPipe m = forever $ do - a <- P.await - s <- get - -- This is the only line that is different between the Strict and Lazy version - (c, s') <- lift . lift $ runStateT (runReaderT m a) s - put s' - P.yield c -{-# INLINABLE rsPipe #-} - --- | Convert a 'Pipes.Concurrent.Input' and a 'Glazier.Gadget' into a stateful 'Pipes.Producer' of commands to interpret. -rsProducer :: - (MonadState s (t STM), MonadTrans t) => - PC.Input a -> ReaderT a (StateT s STM) b -> P.Producer' b (t STM) () -rsProducer input m = hoist lift (PM.fromInputSTM input) P.>-> rsPipe m -{-# INLINABLE rsProducer #-}

1 0

commit ghc-persistent for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-persistent for openSUSE:Factory checked in at 2017-08-31 20:57:51 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-persistent (Old) and /work/SRC/openSUSE:Factory/.ghc-persistent.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-persistent" Thu Aug 31 20:57:51 2017 rev:8 rq:513449 version:2.7.0 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-persistent/ghc-persistent.changes 2017-04-11 09:43:03.230959323 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-persistent.new/ghc-persistent.changes 2017-08-31 20:57:52.371535331 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:07:37 UTC 2017 - psimons(a)suse.com + +- Update to version 2.7.0. + +------------------------------------------------------------------- Old: ---- persistent-2.6.1.tar.gz New: ---- persistent-2.7.0.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-persistent.spec ++++++ --- /var/tmp/diff_new_pack.tIXxDr/_old 2017-08-31 20:57:53.123429689 +0200 +++ /var/tmp/diff_new_pack.tIXxDr/_new 2017-08-31 20:57:53.127429126 +0200 @@ -19,7 +19,7 @@ %global pkg_name persistent %bcond_with tests Name: ghc-%{pkg_name} -Version: 2.6.1 +Version: 2.7.0 Release: 0 Summary: Type-safe, multi-backend data serialization License: MIT ++++++ persistent-2.6.1.tar.gz -> persistent-2.7.0.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistent-2.6.1/ChangeLog.md new/persistent-2.7.0/ChangeLog.md --- old/persistent-2.6.1/ChangeLog.md 2017-03-06 13:58:44.000000000 +0100 +++ new/persistent-2.7.0/ChangeLog.md 2017-04-10 20:11:23.000000000 +0200 @@ -1,3 +1,9 @@ +## 2.7.0 + +* Fix upsert behavior [#613](https://github.com/yesodweb/persistent/issues/613) +* Atomic upsert query fixed for arithmatic operations [#662](https://github.com/yesodweb/persistent/issues/662) +* Haddock and test coverage improved for upsert + ## 2.6.1 * Fix edge case for `\<-. [Nothing]` diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistent-2.6.1/Database/Persist/Class/PersistUnique.hs new/persistent-2.7.0/Database/Persist/Class/PersistUnique.hs --- old/persistent-2.6.1/Database/Persist/Class/PersistUnique.hs 2017-03-01 07:48:55.000000000 +0100 +++ new/persistent-2.7.0/Database/Persist/Class/PersistUnique.hs 2017-04-10 20:00:24.000000000 +0200 @@ -1,18 +1,19 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies, FlexibleContexts, ConstraintKinds #-} + module Database.Persist.Class.PersistUnique - ( PersistUniqueRead (..) - , PersistUniqueWrite (..) - , getByValue - , insertBy - , replaceUnique - , checkUnique - , onlyUnique - ) where + (PersistUniqueRead(..) + ,PersistUniqueWrite(..) + ,getByValue + ,insertBy + ,replaceUnique + ,checkUnique + ,onlyUnique) + where import Database.Persist.Types import Control.Exception (throwIO) -import Control.Monad (liftM, when) +import Control.Monad (liftM) import Control.Monad.IO.Class (liftIO, MonadIO) import Data.List ((\\)) import Control.Monad.Trans.Reader (ReaderT) @@ -36,9 +37,12 @@ -- you must manually place a unique index on a field to have a uniqueness -- constraint. -- -class (PersistCore backend, PersistStoreRead backend) => PersistUniqueRead backend where +class (PersistCore backend, PersistStoreRead backend) => + PersistUniqueRead backend where -- | Get a record by unique key, if available. Returns also the identifier. - getBy :: (MonadIO m, PersistRecordBackend record backend) => Unique record -> ReaderT backend m (Maybe (Entity record)) + getBy + :: (MonadIO m, PersistRecordBackend record backend) + => Unique record -> ReaderT backend m (Maybe (Entity record)) -- | Some functions in this module ('insertUnique', 'insertBy', and -- 'replaceUnique') first query the unique indexes to check for @@ -49,72 +53,71 @@ -- determing the column of failure; -- -- * an exception will automatically abort the current SQL transaction. -class (PersistUniqueRead backend, PersistStoreWrite backend) => PersistUniqueWrite backend where - +class (PersistUniqueRead backend, PersistStoreWrite backend) => + PersistUniqueWrite backend where -- | Delete a specific record by unique key. Does nothing if no record -- matches. - deleteBy :: (MonadIO m, PersistRecordBackend record backend) => Unique record -> ReaderT backend m () - + deleteBy + :: (MonadIO m, PersistRecordBackend record backend) + => Unique record -> ReaderT backend m () -- | Like 'insert', but returns 'Nothing' when the record -- couldn't be inserted because of a uniqueness constraint. - insertUnique :: (MonadIO m, PersistRecordBackend record backend) => record -> ReaderT backend m (Maybe (Key record)) + insertUnique + :: (MonadIO m, PersistRecordBackend record backend) + => record -> ReaderT backend m (Maybe (Key record)) insertUnique datum = do conflict <- checkUnique datum case conflict of - Nothing -> Just `liftM` insert datum - Just _ -> return Nothing - + Nothing -> Just `liftM` insert datum + Just _ -> return Nothing -- | Update based on a uniqueness constraint or insert: -- -- * insert the new record if it does not exist; - -- * update the existing record that matches the uniqueness contraint. + -- * If the record exists (matched via it's uniqueness constraint), then update the existing record with the parameters which is passed on as list to the function. -- -- Throws an exception if there is more than 1 uniqueness contraint. - upsert :: (MonadIO m, PersistRecordBackend record backend) - => record -- ^ new record to insert - -> [Update record] - -- ^ updates to perform if the record already exists (leaving - -- this empty is the equivalent of performing a 'repsert' on a - -- unique key) - -> ReaderT backend m (Entity record) - -- ^ the record in the database after the operation + upsert + :: (MonadIO m, PersistRecordBackend record backend) + => record -- ^ new record to insert + -> [Update record] -- ^ updates to perform if the record already exists (leaving + -- this empty is the equivalent of performing a 'repsert' on a + -- unique key) + -> ReaderT backend m (Entity record) -- ^ the record in the database after the operation upsert record updates = do uniqueKey <- onlyUnique record upsertBy uniqueKey record updates - -- | Update based on a given uniqueness constraint or insert: -- -- * insert the new record if it does not exist; -- * update the existing record that matches the given uniqueness contraint. - upsertBy :: (MonadIO m, PersistRecordBackend record backend) - => Unique record -- ^ uniqueness constraint to find by - -> record -- ^ new record to insert - -> [Update record] - -- ^ updates to perform if the record already exists (leaving - -- this empty is the equivalent of performing a 'repsert' on a - -- unique key) - -> ReaderT backend m (Entity record) - -- ^ the record in the database after the operation + upsertBy + :: (MonadIO m, PersistRecordBackend record backend) + => Unique record -- ^ uniqueness constraint to find by + -> record -- ^ new record to insert + -> [Update record] -- ^ updates to perform if the record already exists (leaving + -- this empty is the equivalent of performing a 'repsert' on a + -- unique key) + -> ReaderT backend m (Entity record) -- ^ the record in the database after the operation upsertBy uniqueKey record updates = do - mExists <- getBy uniqueKey - k <- case mExists of - Just (Entity k _) -> do - when (null updates) (replace k record) - return k - Nothing -> insert record - Entity k `liftM` updateGet k updates - + mrecord <- getBy uniqueKey + maybe (insertEntity record) (`updateGetEntity` updates) mrecord + where + updateGetEntity (Entity k _) upds = + (Entity k) `liftM` (updateGet k upds) -- | Insert a value, checking for conflicts with any unique constraints. If a -- duplicate exists in the database, it is returned as 'Left'. Otherwise, the -- new 'Key is returned as 'Right'. -insertBy :: (MonadIO m, PersistUniqueWrite backend, PersistRecordBackend record backend) - => record -> ReaderT backend m (Either (Entity record) (Key record)) +insertBy + :: (MonadIO m + ,PersistUniqueWrite backend + ,PersistRecordBackend record backend) + => record -> ReaderT backend m (Either (Entity record) (Key record)) insertBy val = do res <- getByValue val case res of - Nothing -> Right `liftM` insert val - Just z -> return $ Left z + Nothing -> Right `liftM` insert val + Just z -> return $ Left z -- | Insert a value, checking for conflicts with any unique constraints. If a -- duplicate exists in the database, it is left untouched. The key of the @@ -128,24 +131,37 @@ Just (Entity key _) -> return key -- | Return the single unique key for a record. -onlyUnique :: (MonadIO m, PersistUniqueWrite backend, PersistRecordBackend record backend) - => record -> ReaderT backend m (Unique record) -onlyUnique record = case onlyUniqueEither record of - Right u -> return u - Left us -> requireUniques record us >>= liftIO . throwIO . OnlyUniqueException . show . length - -onlyUniqueEither :: (PersistEntity record) => record -> Either [Unique record] (Unique record) -onlyUniqueEither record = case persistUniqueKeys record of - [u] -> Right u - us -> Left us +onlyUnique + :: (MonadIO m + ,PersistUniqueWrite backend + ,PersistRecordBackend record backend) + => record -> ReaderT backend m (Unique record) +onlyUnique record = + case onlyUniqueEither record of + Right u -> return u + Left us -> + requireUniques record us >>= + liftIO . throwIO . OnlyUniqueException . show . length + +onlyUniqueEither + :: (PersistEntity record) + => record -> Either [Unique record] (Unique record) +onlyUniqueEither record = + case persistUniqueKeys record of + [u] -> Right u + us -> Left us -- | A modification of 'getBy', which takes the 'PersistEntity' itself instead -- of a 'Unique' record. Returns a record matching /one/ of the unique keys. This -- function makes the most sense on entities with a single 'Unique' -- constructor. -getByValue :: (MonadIO m, PersistUniqueRead backend, PersistRecordBackend record backend) - => record -> ReaderT backend m (Maybe (Entity record)) -getByValue record = checkUniques =<< requireUniques record (persistUniqueKeys record) +getByValue + :: (MonadIO m + ,PersistUniqueRead backend + ,PersistRecordBackend record backend) + => record -> ReaderT backend m (Maybe (Entity record)) +getByValue record = + checkUniques =<< requireUniques record (persistUniqueKeys record) where checkUniques [] = return Nothing checkUniques (x:xs) = do @@ -154,14 +170,19 @@ Nothing -> checkUniques xs Just z -> return $ Just z -requireUniques :: (MonadIO m, PersistEntity record) => record -> [Unique record] -> m [Unique record] +requireUniques + :: (MonadIO m, PersistEntity record) + => record -> [Unique record] -> m [Unique record] requireUniques record [] = liftIO $ throwIO $ userError errorMsg where errorMsg = "getByValue: " `Data.Monoid.mappend` unpack (recordName record) `mappend` " does not have any Unique" + requireUniques _ xs = return xs -- TODO: expose this to users -recordName :: (PersistEntity record) => record -> Text +recordName + :: (PersistEntity record) + => record -> Text recordName = unHaskellName . entityHaskell . entityDef . Just -- | Attempt to replace the record of the given key with the given new record. @@ -172,16 +193,21 @@ -- If uniqueness is violated, return a 'Just' with the 'Unique' violation -- -- Since 1.2.2.0 -replaceUnique :: (MonadIO m, Eq record, Eq (Unique record), PersistRecordBackend record backend, PersistUniqueWrite backend) - => Key record -> record -> ReaderT backend m (Maybe (Unique record)) +replaceUnique + :: (MonadIO m + ,Eq record + ,Eq (Unique record) + ,PersistRecordBackend record backend + ,PersistUniqueWrite backend) + => Key record -> record -> ReaderT backend m (Maybe (Unique record)) replaceUnique key datumNew = getJust key >>= replaceOriginal where uniqueKeysNew = persistUniqueKeys datumNew replaceOriginal original = do conflict <- checkUniqueKeys changedKeys case conflict of - Nothing -> replace key datumNew >> return Nothing - (Just conflictingKey) -> return $ Just conflictingKey + Nothing -> replace key datumNew >> return Nothing + (Just conflictingKey) -> return $ Just conflictingKey where changedKeys = uniqueKeysNew \\ uniqueKeysOriginal uniqueKeysOriginal = persistUniqueKeys original @@ -191,12 +217,19 @@ -- -- Returns 'Nothing' if the entity would be unique, and could thus safely be inserted. -- on a conflict returns the conflicting key -checkUnique :: (MonadIO m, PersistRecordBackend record backend, PersistUniqueRead backend) - => record -> ReaderT backend m (Maybe (Unique record)) +checkUnique + :: (MonadIO m + ,PersistRecordBackend record backend + ,PersistUniqueRead backend) + => record -> ReaderT backend m (Maybe (Unique record)) checkUnique = checkUniqueKeys . persistUniqueKeys -checkUniqueKeys :: (MonadIO m, PersistEntity record, PersistUniqueRead backend, PersistRecordBackend record backend) - => [Unique record] -> ReaderT backend m (Maybe (Unique record)) +checkUniqueKeys + :: (MonadIO m + ,PersistEntity record + ,PersistUniqueRead backend + ,PersistRecordBackend record backend) + => [Unique record] -> ReaderT backend m (Maybe (Unique record)) checkUniqueKeys [] = return Nothing checkUniqueKeys (x:xs) = do y <- getBy x diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistent-2.6.1/Database/Persist/Sql/Orphan/PersistUnique.hs new/persistent-2.7.0/Database/Persist/Sql/Orphan/PersistUnique.hs --- old/persistent-2.6.1/Database/Persist/Sql/Orphan/PersistUnique.hs 2017-03-01 07:48:55.000000000 +0100 +++ new/persistent-2.7.0/Database/Persist/Sql/Orphan/PersistUnique.hs 2017-04-10 19:42:16.000000000 +0200 @@ -1,8 +1,11 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Database.Persist.Sql.Orphan.PersistUnique () where +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Database.Persist.Sql.Orphan.PersistUnique + () + where import Control.Exception (throwIO) import Control.Monad.IO.Class (liftIO, MonadIO) @@ -17,15 +20,24 @@ import qualified Data.Conduit.List as CL import Control.Monad.Trans.Reader (ask, withReaderT) -defaultUpsert :: (MonadIO m, PersistEntity record, PersistUniqueWrite backend - , PersistEntityBackend record ~ BaseBackend backend) - => record -> [Update record] -> ReaderT backend m (Entity record) +defaultUpsert + :: (MonadIO m + ,PersistEntity record + ,PersistUniqueWrite backend + ,PersistEntityBackend record ~ BaseBackend backend) + => record -> [Update record] -> ReaderT backend m (Entity record) defaultUpsert record updates = do - uniqueKey <- onlyUnique record - upsertBy uniqueKey record updates + uniqueKey <- onlyUnique record + upsertBy uniqueKey record updates -instance PersistUniqueWrite SqlBackend where +escape :: DBName -> T.Text +escape (DBName s) = T.pack $ '"' : escapeQuote (T.unpack s) ++ "\"" + where + escapeQuote "" = "" + escapeQuote ('"':xs) = "\"\"" ++ escapeQuote xs + escapeQuote (x:xs) = x : escapeQuote xs +instance PersistUniqueWrite SqlBackend where upsert record updates = do conn <- ask uniqueKey <- onlyUnique record @@ -38,10 +50,10 @@ vals = (map toPersistValue $ toPersistFields record) ++ (map updatePersistValue updates) ++ (unqs uniqueKey) go'' n Assign = n <> "=?" - go'' n Add = T.concat [n, "=", n, "+?"] - go'' n Subtract = T.concat [n, "=", n, "-?"] - go'' n Multiply = T.concat [n, "=", n, "*?"] - go'' n Divide = T.concat [n, "=", n, "/?"] + go'' n Add = T.concat [n, "=", escape (entityDB t) <> ".", n, "+?"] + go'' n Subtract = T.concat [n, "=", escape (entityDB t) <> ".", n, "-?"] + go'' n Multiply = T.concat [n, "=", escape (entityDB t) <> ".", n, "*?"] + go'' n Divide = T.concat [n, "=", escape (entityDB t) <> ".", n, "/?"] go'' _ (BackendSpecificUpdate up) = error $ T.unpack $ "BackendSpecificUpdate" `Data.Monoid.mappend` up `mappend` "not supported" go' (x, pu) = go'' (connEscapeName conn x) pu @@ -63,54 +75,62 @@ t = entityDef $ dummyFromUnique uniq go = map snd . persistUniqueToFieldNames go' conn x = connEscapeName conn x `mappend` "=?" - sql conn = T.concat - [ "DELETE FROM " - , connEscapeName conn $ entityDB t - , " WHERE " - , T.intercalate " AND " $ map (go' conn) $ go uniq - ] + sql conn = + T.concat + [ "DELETE FROM " + , connEscapeName conn $ entityDB t + , " WHERE " + , T.intercalate " AND " $ map (go' conn) $ go uniq] + instance PersistUniqueWrite SqlWriteBackend where deleteBy uniq = withReaderT persistBackend $ deleteBy uniq instance PersistUniqueRead SqlBackend where getBy uniq = do conn <- ask - let sql = T.concat - [ "SELECT " - , T.intercalate "," $ dbColumns conn t - , " FROM " - , connEscapeName conn $ entityDB t - , " WHERE " - , sqlClause conn - ] + let sql = + T.concat + [ "SELECT " + , T.intercalate "," $ dbColumns conn t + , " FROM " + , connEscapeName conn $ entityDB t + , " WHERE " + , sqlClause conn] uvals = persistUniqueToValues uniq - withRawQuery sql uvals $ do - row <- CL.head - case row of - Nothing -> return Nothing - Just [] -> error "getBy: empty row" - Just vals -> case parseEntityValues t vals of - Left err -> liftIO $ throwIO $ PersistMarshalError err - Right r -> return $ Just r + withRawQuery sql uvals $ + do row <- CL.head + case row of + Nothing -> return Nothing + Just [] -> error "getBy: empty row" + Just vals -> + case parseEntityValues t vals of + Left err -> + liftIO $ throwIO $ PersistMarshalError err + Right r -> return $ Just r where sqlClause conn = T.intercalate " AND " $ map (go conn) $ toFieldNames' uniq go conn x = connEscapeName conn x `mappend` "=?" t = entityDef $ dummyFromUnique uniq toFieldNames' = map snd . persistUniqueToFieldNames + instance PersistUniqueRead SqlReadBackend where getBy uniq = withReaderT persistBackend $ getBy uniq + instance PersistUniqueRead SqlWriteBackend where getBy uniq = withReaderT persistBackend $ getBy uniq dummyFromUnique :: Unique v -> Maybe v dummyFromUnique _ = Nothing - -updateFieldDef :: PersistEntity v => Update v -> FieldDef +updateFieldDef + :: PersistEntity v + => Update v -> FieldDef updateFieldDef (Update f _ _) = persistFieldDef f -updateFieldDef (BackendUpdate {}) = error "updateFieldDef did not expect BackendUpdate" +updateFieldDef (BackendUpdate{}) = + error "updateFieldDef did not expect BackendUpdate" updatePersistValue :: Update v -> PersistValue updatePersistValue (Update _ v _) = toPersistValue v -updatePersistValue (BackendUpdate {}) = error "updatePersistValue did not expect BackendUpdate" +updatePersistValue (BackendUpdate{}) = + error "updatePersistValue did not expect BackendUpdate" diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistent-2.6.1/persistent.cabal new/persistent-2.7.0/persistent.cabal --- old/persistent-2.6.1/persistent.cabal 2017-03-03 10:45:56.000000000 +0100 +++ new/persistent-2.7.0/persistent.cabal 2017-04-10 20:12:20.000000000 +0200 @@ -1,5 +1,5 @@ name: persistent -version: 2.6.1 +version: 2.7.0 license: MIT license-file: LICENSE author: Michael Snoyman <michael(a)snoyman.com>

1 0

commit ghc-persistable-types-HDBC-pg for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-persistable-types-HDBC-pg for openSUSE:Factory checked in at 2017-08-31 20:57:49 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-persistable-types-HDBC-pg (Old) and /work/SRC/openSUSE:Factory/.ghc-persistable-types-HDBC-pg.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-persistable-types-HDBC-pg" Thu Aug 31 20:57:49 2017 rev:2 rq:513448 version:0.0.1.5 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-persistable-types-HDBC-pg/ghc-persistable-types-HDBC-pg.changes 2017-02-03 17:39:36.112559199 +0100 +++ /work/SRC/openSUSE:Factory/.ghc-persistable-types-HDBC-pg.new/ghc-persistable-types-HDBC-pg.changes 2017-08-31 20:57:50.307825289 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:08:00 UTC 2017 - psimons(a)suse.com + +- Update to version 0.0.1.5. + +------------------------------------------------------------------- Old: ---- persistable-types-HDBC-pg-0.0.1.4.tar.gz New: ---- persistable-types-HDBC-pg-0.0.1.5.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-persistable-types-HDBC-pg.spec ++++++ --- /var/tmp/diff_new_pack.zFwlze/_old 2017-08-31 20:57:51.135708969 +0200 +++ /var/tmp/diff_new_pack.zFwlze/_new 2017-08-31 20:57:51.135708969 +0200 @@ -1,7 +1,7 @@ # # spec file for package ghc-persistable-types-HDBC-pg # -# Copyright (c) 2016 SUSE LINUX GmbH, Nuernberg, Germany. +# Copyright (c) 2017 SUSE LINUX GmbH, Nuernberg, Germany. # # All modifications and additions to the file contributed by third parties # remain the property of their copyright owners, unless otherwise agreed @@ -18,15 +18,14 @@ %global pkg_name persistable-types-HDBC-pg Name: ghc-%{pkg_name} -Version: 0.0.1.4 +Version: 0.0.1.5 Release: 0 Summary: HDBC and Relational-Record instances of PostgreSQL extended types License: BSD-3-Clause -Group: System/Libraries +Group: Development/Languages/Other Url: https://hackage.haskell.org/package/%{pkg_name} Source0: https://hackage.haskell.org/package/%{pkg_name}-%{version}/%{pkg_name}-%{ve… BuildRequires: ghc-Cabal-devel -# Begin cabal-rpm deps: BuildRequires: ghc-HDBC-devel BuildRequires: ghc-bytestring-devel BuildRequires: ghc-convertible-devel @@ -35,7 +34,6 @@ BuildRequires: ghc-rpm-macros BuildRequires: ghc-text-postgresql-devel BuildRoot: %{_tmppath}/%{name}-%{version}-build -# End cabal-rpm deps %description This package contains HDBC Convertible instances and Relational-Record @@ -57,15 +55,12 @@ %prep %setup -q -n %{pkg_name}-%{version} - %build %ghc_lib_build - %install %ghc_lib_install - %post devel %ghc_pkg_recache ++++++ persistable-types-HDBC-pg-0.0.1.4.tar.gz -> persistable-types-HDBC-pg-0.0.1.5.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistable-types-HDBC-pg-0.0.1.4/persistable-types-HDBC-pg.cabal new/persistable-types-HDBC-pg-0.0.1.5/persistable-types-HDBC-pg.cabal --- old/persistable-types-HDBC-pg-0.0.1.4/persistable-types-HDBC-pg.cabal 2016-06-19 09:16:51.000000000 +0200 +++ new/persistable-types-HDBC-pg-0.0.1.5/persistable-types-HDBC-pg.cabal 2017-07-17 13:47:54.000000000 +0200 @@ -1,5 +1,5 @@ name: persistable-types-HDBC-pg -version: 0.0.1.4 +version: 0.0.1.5 synopsis: HDBC and Relational-Record instances of PostgreSQL extended types description: This package contains HDBC Convertible instances and Relational-Record persistable instances of PostgreSQL extended types @@ -9,11 +9,12 @@ license-file: LICENSE author: Kei Hibino maintainer: ex8k.hibino(a)gmail.com -copyright: Copyright (c) 2015 Kei Hibino +copyright: Copyright (c) 2015-2017 Kei Hibino category: Database build-type: Simple cabal-version: >=1.10 -tested-with: GHC == 8.0.1 +tested-with: GHC == 8.2.1 + , GHC == 8.0.1, GHC == 8.0.2 , GHC == 7.10.1, GHC == 7.10.2, GHC == 7.10.3 , GHC == 7.8.1, GHC == 7.8.2, GHC == 7.8.3, GHC == 7.8.4 , GHC == 7.6.1, GHC == 7.6.2, GHC == 7.6.3

1 0

commit ghc-persistable-record for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-persistable-record for openSUSE:Factory checked in at 2017-08-31 20:57:47 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-persistable-record (Old) and /work/SRC/openSUSE:Factory/.ghc-persistable-record.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-persistable-record" Thu Aug 31 20:57:47 2017 rev:4 rq:513447 version:0.5.1.1 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-persistable-record/ghc-persistable-record.changes 2017-03-14 10:05:44.223258660 +0100 +++ /work/SRC/openSUSE:Factory/.ghc-persistable-record.new/ghc-persistable-record.changes 2017-08-31 20:57:48.344101199 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:08:05 UTC 2017 - psimons(a)suse.com + +- Update to version 0.5.1.1. + +------------------------------------------------------------------- Old: ---- persistable-record-0.4.1.1.tar.gz New: ---- persistable-record-0.5.1.1.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-persistable-record.spec ++++++ --- /var/tmp/diff_new_pack.Adt3jq/_old 2017-08-31 20:57:49.243974763 +0200 +++ /var/tmp/diff_new_pack.Adt3jq/_new 2017-08-31 20:57:49.247974202 +0200 @@ -19,7 +19,7 @@ %global pkg_name persistable-record %bcond_with tests Name: ghc-%{pkg_name} -Version: 0.4.1.1 +Version: 0.5.1.1 Release: 0 Summary: Binding between SQL database values and haskell records License: BSD-3-Clause @@ -80,5 +80,6 @@ %files devel -f %{name}-devel.files %defattr(-,root,root,-) +%doc ChangeLog.md %changelog ++++++ persistable-record-0.4.1.1.tar.gz -> persistable-record-0.5.1.1.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistable-record-0.4.1.1/ChangeLog.md new/persistable-record-0.5.1.1/ChangeLog.md --- old/persistable-record-0.4.1.1/ChangeLog.md 1970-01-01 01:00:00.000000000 +0100 +++ new/persistable-record-0.5.1.1/ChangeLog.md 2017-07-20 17:31:36.000000000 +0200 @@ -0,0 +1,54 @@ + + +## 0.5.1.1 + +- Update this changelog. + +## 0.5.1.0 + +- add class dependency from ToSql to PersistableWidth. + +## 0.5.0.2 + +- add tested-with 8.2.1. + +## 0.5.0.1 + +- Use Haskell implementation test instead of flag test in .cabal + +## 0.5.0.0 + +- Add generic instances of FromSql, ToSql and PersistableWidth. + +## 0.4.1.1 + +- Tested with GHC 8.0.2 +- Add a small test set. + +## 0.4.1.0 + +- Export columnName of NameConfig. + +## 0.4.0.3 + +- Drop an unreferenced definition. + +## 0.4.0.2 + +- Add tested-with. + +## 0.4.0.1 + +- Apply th-data-compat. + +## 0.4.0.0 + +- Divide PersistableValue interface to FromSql and ToSql. + +## 0.3.0.0 + +- Add symbol name configurations of templates. + +## 0.2.0.0 + +- TH quotation of derive class names. diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistable-record-0.4.1.1/persistable-record.cabal new/persistable-record-0.5.1.1/persistable-record.cabal --- old/persistable-record-0.4.1.1/persistable-record.cabal 2017-02-19 08:43:07.000000000 +0100 +++ new/persistable-record-0.5.1.1/persistable-record.cabal 2017-07-20 17:31:36.000000000 +0200 @@ -1,5 +1,5 @@ name: persistable-record -version: 0.4.1.1 +version: 0.5.1.1 synopsis: Binding between SQL database values and haskell records. description: This package contiains types to represent table constraints and interfaces to bind between SQL database values and Haskell records. @@ -12,22 +12,28 @@ category: Database build-type: Simple cabal-version: >=1.10 -tested-with: GHC == 8.0.1, GHC == 8.0.2 +tested-with: GHC == 8.2.1 + , GHC == 8.0.1, GHC == 8.0.2 , GHC == 7.10.1, GHC == 7.10.2, GHC == 7.10.3 , GHC == 7.8.1, GHC == 7.8.2, GHC == 7.8.3, GHC == 7.8.4 , GHC == 7.6.1, GHC == 7.6.2, GHC == 7.6.3 , GHC == 7.4.1, GHC == 7.4.2 +extra-source-files: ChangeLog.md library exposed-modules: Database.Record.FromSql Database.Record.ToSql Database.Record.Persistable + Database.Record.TupleInstances Database.Record.Instances Database.Record.KeyConstraint Database.Record Database.Record.TH + other-modules: + Database.Record.InternalTH + build-depends: base <5 , template-haskell , th-data-compat @@ -36,6 +42,9 @@ , transformers , dlist , names-th + if impl(ghc == 7.4.*) + build-depends: ghc-prim == 0.2.* + hs-source-dirs: src ghc-options: -Wall default-language: Haskell2010 @@ -44,9 +53,12 @@ build-depends: base <5 , quickcheck-simple , persistable-record + if impl(ghc == 7.4.*) + build-depends: ghc-prim == 0.2.* type: exitcode-stdio-1.0 main-is: nestedEq.hs + other-modules: Model hs-source-dirs: test ghc-options: -Wall default-language: Haskell2010 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistable-record-0.4.1.1/src/Database/Record/FromSql.hs new/persistable-record-0.5.1.1/src/Database/Record/FromSql.hs --- old/persistable-record-0.4.1.1/src/Database/Record/FromSql.hs 2017-02-19 08:43:07.000000000 +0100 +++ new/persistable-record-0.5.1.1/src/Database/Record/FromSql.hs 2017-07-20 17:31:36.000000000 +0200 @@ -1,10 +1,12 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DefaultSignatures #-} -- | -- Module : Database.Record.FromSql --- Copyright : 2013 Kei Hibino +-- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino(a)gmail.com @@ -12,35 +14,39 @@ -- Portability : unknown -- -- This module defines interfaces --- from list of SQL type into Haskell type. +-- from list of database value type into Haskell type. + module Database.Record.FromSql ( - -- * Conversion from list of SQL type into record type - -- $recordFromSql + -- * Conversion from list of database value type into record type RecordFromSql, runTakeRecord, runToRecord, createRecordFromSql, (<&>), maybeRecord, - -- * Inference rules of 'RecordFromSql' conversion + -- * Derivation rules of 'RecordFromSql' conversion FromSql (recordFromSql), takeRecord, toRecord, valueRecordFromSql, ) where +import GHC.Generics (Generic, Rep, U1 (..), K1 (..), M1 (..), (:*:)(..), to) +import Control.Applicative ((<$>), Applicative (pure, (<*>))) +import Control.Monad (liftM, ap) + import Database.Record.Persistable (PersistableType) import qualified Database.Record.Persistable as Persistable import Database.Record.KeyConstraint (HasColumnConstraint(columnConstraint), ColumnConstraint, NotNull, index) -import Control.Monad (liftM, ap) -import Control.Applicative ((<$>), Applicative(pure, (<*>))) - -{- $recordFromSql -Structure of 'RecordFromSql' 'q' 'a' is similar to parser. -While running 'RecordFromSql' behavior is the same as parser -which parse list of SQL type ['q'] stream. +{- | +'RecordFromSql' 'q' 'a' is data-type wrapping function +to convert from list of database value type (to receive from database) ['q'] into Haskell type 'a' + +This structure is similar to parser. +While running 'RecordFromSql' behavior is the same as non-fail-able parser +which parse list of database value type ['q'] stream. So, 'RecordFromSql' 'q' is 'Monad' and 'Applicative' instance like parser monad. When, you have data constructor and objects like below. @@ -65,25 +71,23 @@ myRecord = MyRecord \<$\> foo \<*\> bar \<*\> baz @ -} - --- | Proof object type to convert from sql value type 'q' list into Haskell type 'a'. newtype RecordFromSql q a = RecordFromSql ([q] -> (a, [q])) --- | Run 'RecordFromSql' proof object. --- Convert from list of SQL type ['q'] into Haskell type 'a' and rest of list ['q']. -runTakeRecord :: RecordFromSql q a -- ^ Proof object which has capability to convert - -> [q] -- ^ list of SQL type +-- | Run 'RecordFromSql' parser function object. +-- Convert from list of database value type ['q'] into Haskell type 'a' and rest of list ['q']. +runTakeRecord :: RecordFromSql q a -- ^ parser function object which has capability to convert + -> [q] -- ^ list of database value type -> (a, [q]) -- ^ Haskell type and rest of list runTakeRecord (RecordFromSql f) = f --- | Axiom of 'RecordFromSql' for SQL type 'q' and Haskell type 'a' +-- | Axiom of 'RecordFromSql' for database value type 'q' and Haskell type 'a' createRecordFromSql :: ([q] -> (a, [q])) -- ^ Convert function body - -> RecordFromSql q a -- ^ Result proof object + -> RecordFromSql q a -- ^ Result parser function object createRecordFromSql = RecordFromSql --- | Run 'RecordFromSql' proof object. Convert from list of SQL type ['q'] into Haskell type 'a'. -runToRecord :: RecordFromSql q a -- ^ Proof object which has capability to convert - -> [q] -- ^ list of SQL type +-- | Run 'RecordFromSql' parser function object. Convert from list of database value type ['q'] into Haskell type 'a'. +runToRecord :: RecordFromSql q a -- ^ parser function object which has capability to convert + -> [q] -- ^ list of database value type -> a -- ^ Haskell type runToRecord r = fst . runTakeRecord r @@ -104,14 +108,14 @@ pure = return (<*>) = ap --- | Derivation rule of 'RecordFromSql' proof object for Haskell tuple (,) type. +-- | Derivation rule of 'RecordFromSql' parser function object for Haskell tuple (,) type. (<&>) :: RecordFromSql q a -> RecordFromSql q b -> RecordFromSql q (a, b) a <&> b = (,) <$> a <*> b infixl 4 <&> --- | Derivation rule of 'RecordFromSql' proof object for Haskell 'Maybe' type. +-- | Derivation rule of 'RecordFromSql' parser function object for Haskell 'Maybe' type. maybeRecord :: PersistableType q => RecordFromSql q a -> ColumnConstraint NotNull a @@ -122,38 +126,67 @@ | otherwise = (Nothing, vals') where (a, vals') = runTakeRecord rec vals +{- | +'FromSql' 'q' 'a' is implicit rule to derive 'RecordFromSql' 'q' 'a' record parser function against type 'a'. + +Generic programming (<https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_ext…>) +with default signature is available for 'FromSql' class, +so you can make instance like below: + +@ + \{\-\# LANGUAGE DeriveGeneric \#\-\} + import GHC.Generics (Generic) + import Database.HDBC (SqlValue) + -- + data Foo = Foo { ... } deriving Generic + instance FromSql SqlValue Foo +@ --- | Inference rule interface for 'RecordFromSql' proof object. +-} class FromSql q a where - -- | 'RecordFromSql' proof object. + -- | 'RecordFromSql' 'q' 'a' record parser function. recordFromSql :: RecordFromSql q a --- | Inference rule of 'RecordFromSql' proof object which can convert --- from list of SQL type ['q'] into Haskell tuple ('a', 'b') type. -instance (FromSql q a, FromSql q b) => FromSql q (a, b) where - recordFromSql = recordFromSql <&> recordFromSql + default recordFromSql :: (Generic a, GFromSql q (Rep a)) => RecordFromSql q a + recordFromSql = to <$> gFromSql + + +class GFromSql q f where + gFromSql :: RecordFromSql q (f a) + +instance GFromSql q U1 where + gFromSql = createRecordFromSql $ (,) U1 + +instance (GFromSql q a, GFromSql q b) => GFromSql q (a :*: b) where + gFromSql = (:*:) <$> gFromSql <*> gFromSql + +instance GFromSql q a => GFromSql q (M1 i c a) where + gFromSql = M1 <$> gFromSql + +instance FromSql q a => GFromSql q (K1 i a) where + gFromSql = K1 <$> recordFromSql + --- | Inference rule of 'RecordFromSql' proof object which can convert --- from list of SQL type ['q'] into Haskell 'Maybe' type. +-- | Implicit derivation rule of 'RecordFromSql' parser function object which can convert +-- from list of database value type ['q'] into Haskell 'Maybe' type. instance (HasColumnConstraint NotNull a, FromSql q a, PersistableType q) => FromSql q (Maybe a) where recordFromSql = maybeRecord recordFromSql columnConstraint --- | Inference rule of 'RecordFromSql' proof object which can convert --- from /empty/ list of SQL type ['q'] into Haskell unit () type. -instance FromSql q () where - recordFromSql = RecordFromSql (\qs -> ((), qs)) +-- | Implicit derivation rule of 'RecordFromSql' parser function object which can convert +-- from /empty/ list of database value type ['q'] into Haskell unit () type. +instance FromSql q () -- default generic instance --- | Run inferred 'RecordFromSql' proof object. --- Convert from list of SQL type ['q'] into haskell type 'a' and rest of list ['q']. +-- | Run implicit 'RecordFromSql' parser function object. +-- Convert from list of database value type ['q'] into haskell type 'a' and rest of list ['q']. takeRecord :: FromSql q a => [q] -> (a, [q]) takeRecord = runTakeRecord recordFromSql --- | Run inferred 'RecordFromSql' proof object. --- Convert from list of SQL type ['q'] into haskell type 'a'. +-- | Run implicit 'RecordFromSql' parser function object. +-- Convert from list of database value type ['q'] into haskell type 'a'. toRecord :: FromSql q a => [q] -> a toRecord = runToRecord recordFromSql --- | Derivation rule of 'RecordFromSql' proof object for value convert function. +-- | Derivation rule of 'RecordFromSql' parser function object for value convert function. valueRecordFromSql :: (q -> a) -> RecordFromSql q a valueRecordFromSql d = createRecordFromSql $ \qs -> (d $ head qs, tail qs) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistable-record-0.4.1.1/src/Database/Record/InternalTH.hs new/persistable-record-0.5.1.1/src/Database/Record/InternalTH.hs --- old/persistable-record-0.4.1.1/src/Database/Record/InternalTH.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/persistable-record-0.5.1.1/src/Database/Record/InternalTH.hs 2017-07-20 17:31:36.000000000 +0200 @@ -0,0 +1,45 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ConstraintKinds #-} + +module Database.Record.InternalTH ( + defineTupleInstances + ) where + +import Control.Applicative ((<$>)) +import Data.List (foldl') +import Language.Haskell.TH + (Q, mkName, Name, + conT, varT, tupleT, appT, classP, + Dec, instanceD, ) + +import Database.Record.Persistable (PersistableWidth) +import Database.Record.FromSql (FromSql) +import Database.Record.ToSql (ToSql) + + +persistableWidth :: Int -> Q [Dec] +persistableWidth n = do + let vs = [ varT . mkName $ "a" ++ show i | i <- [1 .. n] ] + (:[]) <$> instanceD + -- in template-haskell 2.8 or older, Pred is not Type + (mapM (classP ''PersistableWidth . (:[])) vs) + [t| PersistableWidth $(foldl' appT (tupleT n) vs) |] + [] + +tupleInstance2 :: Int -> Name -> Q [Dec] +tupleInstance2 n clazz = do + let vs = [ varT . mkName $ "a" ++ show i | i <- [1 .. n] ] + q = varT $ mkName "q" + (:[]) <$> instanceD + -- in template-haskell 2.8 or older, Pred is not Type + (mapM (\v -> classP clazz [q, v]) vs) + [t| $(conT clazz) $q $(foldl' appT (tupleT n) vs) |] + [] + +-- | Template to define tuple instances of persistable-record classes. +defineTupleInstances :: Int -> Q [Dec] +defineTupleInstances n = + concat <$> sequence + [ persistableWidth n + , tupleInstance2 n ''FromSql + , tupleInstance2 n ''ToSql ] diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistable-record-0.4.1.1/src/Database/Record/Persistable.hs new/persistable-record-0.5.1.1/src/Database/Record/Persistable.hs --- old/persistable-record-0.4.1.1/src/Database/Record/Persistable.hs 2017-02-19 08:43:07.000000000 +0100 +++ new/persistable-record-0.5.1.1/src/Database/Record/Persistable.hs 2017-07-20 17:31:36.000000000 +0200 @@ -1,100 +1,176 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DefaultSignatures #-} -- | -- Module : Database.Record.Persistable --- Copyright : 2013 Kei Hibino +-- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino(a)gmail.com -- Stability : experimental -- Portability : unknown -- --- This module defines interfaces --- between Haskell type and list of SQL type. +-- This module defines proposition interfaces +-- for database value type and record type width. module Database.Record.Persistable ( - -- * Specify SQL type + -- * Specify database value type PersistableSqlType, runPersistableNullValue, unsafePersistableSqlTypeFromNull, -- * Specify record width PersistableRecordWidth, runPersistableRecordWidth, unsafePersistableRecordWidth, unsafeValueWidth, (<&>), maybeWidth, - -- * Inference rules for proof objects - + -- * Implicit derivation rules, database value type and record type width PersistableType(..), sqlNullValue, - PersistableWidth (..), derivedWidth + PersistableWidth (..), derivedWidth, + + -- * low-level interfaces + GFieldWidthList, + ProductConst, getProductConst, + genericFieldOffsets, ) where +import GHC.Generics (Generic, Rep, U1 (..), K1 (..), M1 (..), (:*:)(..), to) +import Control.Applicative ((<$>), pure, (<*>), Const (..)) +import Data.Monoid (Monoid, Sum (..)) +import Data.Array (Array, listArray, bounds, (!)) +import Data.DList (DList) +import qualified Data.DList as DList + --- | Proof object to specify type 'q' is SQL type +-- | Proposition to specify type 'q' is database value type, contains null value newtype PersistableSqlType q = PersistableSqlType q --- | Null value of SQL type 'q'. +-- | Null value of database value type 'q'. runPersistableNullValue :: PersistableSqlType q -> q runPersistableNullValue (PersistableSqlType q) = q --- | Unsafely generate 'PersistableSqlType' proof object from specified SQL null value which type is 'q'. -unsafePersistableSqlTypeFromNull :: q -- ^ SQL null value of SQL type 'q' +-- | Unsafely specify 'PersistableSqlType' axiom from specified database null value which type is 'q'. +unsafePersistableSqlTypeFromNull :: q -- ^ null value of database value type 'q' -> PersistableSqlType q -- ^ Result proof object unsafePersistableSqlTypeFromNull = PersistableSqlType --- | Proof object to specify width of Haskell type 'a' --- when converting to SQL type list. -newtype PersistableRecordWidth a = - PersistableRecordWidth Int +-- | Restricted in product isomorphism record type b +newtype ProductConst a b = + ProductConst { unPC :: Const a b } + +-- | extract constant value of 'ProductConst'. +getProductConst :: ProductConst a b -> a +getProductConst = getConst . unPC +{-# INLINE getProductConst #-} + +-- | Proposition to specify width of Haskell type 'a'. +-- The width is length of database value list which is converted from Haskell type 'a'. +type PersistableRecordWidth a = ProductConst (Sum Int) a + +-- unsafely map PersistableRecordWidth +pmap :: Monoid e => (a -> b) -> ProductConst e a -> ProductConst e b +f `pmap` prw = ProductConst $ f <$> unPC prw + +-- unsafely ap PersistableRecordWidth +pap :: Monoid e => ProductConst e (a -> b) -> ProductConst e a -> ProductConst e b +wf `pap` prw = ProductConst $ unPC wf <*> unPC prw + -- | Get width 'Int' value of record type 'a'. runPersistableRecordWidth :: PersistableRecordWidth a -> Int -runPersistableRecordWidth (PersistableRecordWidth w) = w +runPersistableRecordWidth = getSum . getConst . unPC +{-# INLINE runPersistableRecordWidth #-} + +instance Show a => Show (ProductConst a b) where + show = ("PC " ++) . show . getConst . unPC --- | Unsafely generate 'PersistableRecordWidth' proof object from specified width of Haskell type 'a'. +-- | Unsafely specify 'PersistableRecordWidth' axiom from specified width of Haskell type 'a'. unsafePersistableRecordWidth :: Int -- ^ Specify width of Haskell type 'a' -> PersistableRecordWidth a -- ^ Result proof object -unsafePersistableRecordWidth = PersistableRecordWidth +unsafePersistableRecordWidth = ProductConst . Const . Sum +{-# INLINE unsafePersistableRecordWidth #-} --- | Unsafely generate 'PersistableRecordWidth' proof object for Haskell type 'a' which is single column type. +-- | Unsafely specify 'PersistableRecordWidth' axiom for Haskell type 'a' which is single column type. unsafeValueWidth :: PersistableRecordWidth a unsafeValueWidth = unsafePersistableRecordWidth 1 +{-# INLINE unsafeValueWidth #-} -- | Derivation rule of 'PersistableRecordWidth' for tuple (,) type. (<&>) :: PersistableRecordWidth a -> PersistableRecordWidth b -> PersistableRecordWidth (a, b) -a <&> b = PersistableRecordWidth $ runPersistableRecordWidth a + runPersistableRecordWidth b +a <&> b = (,) `pmap` a `pap` b -- | Derivation rule of 'PersistableRecordWidth' from from Haskell type 'a' into for Haskell type 'Maybe' 'a'. maybeWidth :: PersistableRecordWidth a -> PersistableRecordWidth (Maybe a) -maybeWidth = PersistableRecordWidth . runPersistableRecordWidth +maybeWidth = pmap Just --- | Axiom of 'PersistableRecordWidth' for Haskell unit () type. -voidWidth :: PersistableRecordWidth () -voidWidth = unsafePersistableRecordWidth 0 - --- | Interface of inference rule for 'PersistableSqlType' proof object +-- | Interface of derivation rule for 'PersistableSqlType'. class Eq q => PersistableType q where persistableType :: PersistableSqlType q --- | Inferred Null value of SQL type. +-- | Implicitly derived null value of database value type. sqlNullValue :: PersistableType q => q sqlNullValue = runPersistableNullValue persistableType --- | Interface of inference rule for 'PersistableRecordWidth' proof object +{- | +'PersistableWidth' 'a' is implicit rule to derive 'PersistableRecordWidth' 'a' width proposition for type 'a'. + +Generic programming (<https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_ext…>) +with default signature is available for 'PersistableWidth' class, +so you can make instance like below: + +@ + \{\-\# LANGUAGE DeriveGeneric \#\-\} + import GHC.Generics (Generic) + -- + data Foo = Foo { ... } deriving Generic + instance PersistableWidth Foo +@ + +-} class PersistableWidth a where persistableWidth :: PersistableRecordWidth a --- | Inference rule of 'PersistableRecordWidth' proof object for tuple ('a', 'b') type. -instance (PersistableWidth a, PersistableWidth b) => PersistableWidth (a, b) where - persistableWidth = persistableWidth <&> persistableWidth + default persistableWidth :: (Generic a, GFieldWidthList (Rep a)) => PersistableRecordWidth a + persistableWidth = pmapConst (Sum . lastA) genericFieldOffsets + where + lastA a = a ! (snd $ bounds a) + + +pmapConst :: (a -> b) -> ProductConst a c -> ProductConst b c +pmapConst f = ProductConst . Const . f . getConst . unPC + +-- | Generic width value list of record fields. +class GFieldWidthList f where + gFieldWidthList :: ProductConst (DList Int) (f a) + +instance GFieldWidthList U1 where + gFieldWidthList = ProductConst $ pure U1 + +instance (GFieldWidthList a, GFieldWidthList b) => GFieldWidthList (a :*: b) where + gFieldWidthList = (:*:) `pmap` gFieldWidthList `pap` gFieldWidthList + +instance GFieldWidthList a => GFieldWidthList (M1 i c a) where + gFieldWidthList = M1 `pmap` gFieldWidthList + +instance PersistableWidth a => GFieldWidthList (K1 i a) where + gFieldWidthList = K1 `pmap` pmapConst (pure . getSum) persistableWidth + +offsets :: [Int] -> Array Int Int +offsets ws = listArray (0, length ws) $ scanl (+) 0 ws + +-- | Generic offset array of record fields. +genericFieldOffsets :: (Generic a, GFieldWidthList (Rep a)) => ProductConst (Array Int Int) a +genericFieldOffsets = pmapConst (offsets . DList.toList) $ to `pmap` gFieldWidthList + -- | Inference rule of 'PersistableRecordWidth' proof object for 'Maybe' type. instance PersistableWidth a => PersistableWidth (Maybe a) where persistableWidth = maybeWidth persistableWidth -- | Inference rule of 'PersistableRecordWidth' for Haskell unit () type. Derive from axiom. -instance PersistableWidth () where - persistableWidth = voidWidth +instance PersistableWidth () -- default generic instance -- | Pass type parameter and inferred width value. derivedWidth :: PersistableWidth a => (PersistableRecordWidth a, Int) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistable-record-0.4.1.1/src/Database/Record/TH.hs new/persistable-record-0.5.1.1/src/Database/Record/TH.hs --- old/persistable-record-0.4.1.1/src/Database/Record/TH.hs 2017-02-19 08:43:07.000000000 +0100 +++ new/persistable-record-0.5.1.1/src/Database/Record/TH.hs 2017-07-20 17:31:36.000000000 +0200 @@ -4,7 +4,7 @@ -- | -- Module : Database.Record.TH --- Copyright : 2013 Kei Hibino +-- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino(a)gmail.com @@ -18,9 +18,6 @@ defineRecord, defineRecordWithConfig, - -- * Deriving class symbols - derivingEq, derivingShow, derivingRead, derivingData, derivingTypeable, - -- * Table constraint specified by key defineHasColumnConstraintInstance, defineHasPrimaryConstraintInstanceDerived, @@ -31,70 +28,60 @@ defineRecordType, defineRecordTypeWithConfig, - -- * Function declarations depending on SQL type - makeRecordPersistableWithSqlType, - makeRecordPersistableWithSqlTypeWithConfig, - makeRecordPersistableWithSqlTypeDefault, - -- * Function declarations against defined record types - makeRecordPersistableWithSqlTypeFromDefined, - makeRecordPersistableWithSqlTypeDefaultFromDefined, defineColumnOffsets, recordWidthTemplate, - defineRecordParser, - defineRecordPrinter, - - definePersistableInstance, - -- * Reify reifyRecordType, - -- * Templates about record type name + -- * Templates about record name NameConfig, defaultNameConfig, recordTypeName, columnName, - recordType, + recordTemplate, columnOffsetsVarNameDefault, - persistableFunctionNamesDefault, - -- * Not nullable single column type - deriveNotNullType - ) where + deriveNotNullType, + -- * Template for tuple types + defineTupleInstances, + ) where -import Control.Applicative (pure, (<*>)) -import Data.List (foldl') -import Data.Array (Array, listArray, (!)) -import Data.Data (Data, Typeable) +import GHC.Generics (Generic) +import Data.Array (Array) import Language.Haskell.TH.Name.CamelCase (ConName(conName), VarName(varName), conCamelcaseName, varCamelcaseName, varNameWithPrefix, - toTypeCon, toDataCon, toVarExp) -import Language.Haskell.TH.Lib.Extra (integralE, simpleValD) + toTypeCon, toDataCon, ) +import Language.Haskell.TH.Lib.Extra (integralE, simpleValD, reportWarning) import Language.Haskell.TH.Compat.Data (dataD', unDataD) import Language.Haskell.TH - (Q, newName, nameBase, reify, Info(TyConI), Name, + (Q, nameBase, reify, Info(TyConI), Name, TypeQ, conT, Con (NormalC, RecC), - Dec, sigD, valD, - ExpQ, Exp(ConE), conE, varE, lamE, listE, sigE, - varP, conP, normalB, recC, + Dec, + ExpQ, conE, listE, sigE, + recC, cxt, varStrictType, strictType, isStrict) +import Control.Arrow ((&&&)) + import Database.Record (HasColumnConstraint(columnConstraint), Primary, NotNull, HasKeyConstraint(keyConstraint), derivedCompositePrimary, PersistableRecordWidth, PersistableWidth(persistableWidth), - FromSql(recordFromSql), RecordFromSql, - ToSql(recordToSql), RecordToSql, wrapToSql, putRecord, putEmpty) + FromSql, ToSql, ) import Database.Record.KeyConstraint (unsafeSpecifyColumnConstraint, unsafeSpecifyNotNullValue, unsafeSpecifyKeyConstraint) -import Database.Record.Persistable (unsafePersistableRecordWidth, runPersistableRecordWidth) +import Database.Record.Persistable + (runPersistableRecordWidth, + ProductConst, getProductConst, genericFieldOffsets) import qualified Database.Record.Persistable as Persistable +import Database.Record.InternalTH (defineTupleInstances) -- | 'NameConfig' type to customize names of expanded record templates. @@ -119,12 +106,12 @@ , columnName = const varCamelcaseName } --- | Record type constructor template from SQL table name 'String'. -recordType :: NameConfig -- ^ name rule config - -> String -- ^ Schema name string in SQL - -> String -- ^ Table name string in SQL - -> TypeQ -- ^ Record type constructor -recordType config scm = toTypeCon . recordTypeName config scm +-- | Record constructor templates from SQL table name 'String'. +recordTemplate :: NameConfig -- ^ name rule config + -> String -- ^ Schema name string in SQL + -> String -- ^ Table name string in SQL + -> (TypeQ, ExpQ) -- ^ Record type and data constructor +recordTemplate config scm = (toTypeCon &&& toDataCon) . recordTypeName config scm -- | Variable expression of record column offset array. columnOffsetsVarNameDefault :: Name -- ^ Table type name @@ -170,31 +157,6 @@ defineHasNotNullKeyInstance = defineHasColumnConstraintInstance [t| NotNull |] -{-# DEPRECATED derivingEq "Use TH quasi-quotation like ''Eq instead of this." #-} --- | Name to specify deriving 'Eq' -derivingEq :: Name -derivingEq = ''Eq - -{-# DEPRECATED derivingShow "Use TH quasi-quotation like ''Show instead of this." #-} --- | Name to specify deriving 'Show' -derivingShow :: Name -derivingShow = ''Show - -{-# DEPRECATED derivingRead "Use TH quasi-quotation like ''Read instead of this." #-} --- | Name to specify deriving 'Read' -derivingRead :: Name -derivingRead = ''Read - -{-# DEPRECATED derivingData "Use TH quasi-quotation like ''Data instead of this." #-} --- | Name to specify deriving 'Data' -derivingData :: Name -derivingData = ''Data - -{-# DEPRECATED derivingTypeable "Use TH quasi-quotation like ''Typeable instead of this." #-} --- | Name to specify deriving 'Typeable' -derivingTypeable :: Name -derivingTypeable = ''Typeable - -- | Record type width expression template. recordWidthTemplate :: TypeQ -- ^ Record type constructor. -> ExpQ -- ^ Expression to get record width. @@ -211,10 +173,8 @@ let ofsVar = columnOffsetsVarNameDefault $ conName typeName' widthIxE = integralE $ length tys ar <- simpleValD (varName ofsVar) [t| Array Int Int |] - [| listArray (0 :: Int, $widthIxE) $ - scanl (+) (0 :: Int) $(listE $ map recordWidthTemplate tys) |] - pw <- [d| instance PersistableWidth $(toTypeCon typeName') where - persistableWidth = unsafePersistableRecordWidth $ $(toVarExp ofsVar) ! $widthIxE + [| getProductConst (genericFieldOffsets :: ProductConst (Array Int Int) $(toTypeCon typeName')) |] + pw <- [d| instance PersistableWidth $(toTypeCon typeName') |] return $ ar ++ pw @@ -226,9 +186,14 @@ defineRecordType typeName' columns derives = do let typeName = conName typeName' fld (n, tq) = varStrictType (varName n) (strictType isStrict tq) - rec <- dataD' (cxt []) typeName [] [recC typeName (map fld columns)] derives + derives1 <- if (''Generic `notElem` derives) + then do reportWarning "HRR needs Generic instance, please add ''Generic manually." + return $ ''Generic : derives + {- DROP this hack in future version ups. -} + else return derives + rec' <- dataD' (cxt []) typeName [] [recC typeName (map fld columns)] derives1 offs <- defineColumnOffsets typeName' [ty | (_, ty) <- columns] - return $ rec : offs + return $ rec' : offs -- | Record type declaration template with configured names. defineRecordTypeWithConfig :: NameConfig -> String -> String -> [(String, TypeQ)] -> [Name] -> Q [Dec] @@ -238,79 +203,6 @@ [ (columnName config schema n, t) | (n, t) <- columns ] --- | Record parser template. -defineRecordParser :: TypeQ -- ^ SQL value type. - -> VarName -- ^ Name of record parser. - -> (TypeQ, ExpQ) -- ^ Record type constructor and data constructor. - -> Int -- ^ Count of record columns. - -> Q [Dec] -- ^ Declaration of record construct function from SQL values. -defineRecordParser sqlValType name' (tyCon, dataCon) width = do - let name = varName name' - sig <- sigD name [t| RecordFromSql $sqlValType $tyCon |] - var <- valD (varP name) - (normalB - (foldl' (\a x -> [| $a <*> $x |]) [| pure $dataCon |] - $ replicate width [| recordFromSql |]) - ) - [] - return [sig, var] - -dataConInfo :: Exp -> Q Name -dataConInfo = d where - d (ConE n) = return n - d e = fail $ "Not record data constructor: " ++ show e - --- | Record printer template. -defineRecordPrinter :: TypeQ -- ^ SQL value type. - -> VarName -- ^ Name of record printer. - -> (TypeQ, ExpQ) -- ^ Record type constructor and data constructor. - -> Int -- ^ Count of record columns. - -> Q [Dec] -- ^ Declaration of record construct function from SQL values. -defineRecordPrinter sqlValType name' (tyCon, dataCon) width = do - let name = varName name' - sig <- sigD name [t| RecordToSql $sqlValType $tyCon |] - names <- mapM (newName . ('f':) . show) [1 .. width] - dcn <- dataCon >>= dataConInfo - var <- valD (varP name) - (normalB [| wrapToSql - $(lamE - [ conP dcn [ varP n | n <- names ] ] - (foldr (\a x -> [| $a >> $x |]) [| putEmpty () |] - [ [| putRecord $(varE n) |] | n <- names ])) |]) - [] - return [sig, var] - --- | Record parser and printer instance templates for converting --- between list of SQL type and Haskell record type. -definePersistableInstance :: TypeQ -- ^ SQL value type. - -> TypeQ -- ^ Record type constructor. - -> VarName -- ^ Record parser name. - -> VarName -- ^ Record printer name. - -> Int -- ^ Count of record columns. - -> Q [Dec] -- ^ Instance declarations for 'Persistable'. -definePersistableInstance sqlType typeCon parserName printerName _width = do - [d| instance FromSql $sqlType $typeCon where - recordFromSql = $(toVarExp parserName) - - instance ToSql $sqlType $typeCon where - recordToSql = $(toVarExp printerName) - |] - --- | All templates depending on SQL value type. -makeRecordPersistableWithSqlType :: TypeQ -- ^ SQL value type. - -> (VarName, VarName) -- ^ Constructor function name and decompose function name. - -> (TypeQ, ExpQ) -- ^ Record type constructor and data constructor. - -> Int -- ^ Count of record columns. - -> Q [Dec] -- ^ Result declarations. -makeRecordPersistableWithSqlType - sqlValueType - (cF, dF) conPair@(tyCon, _) - width = do - fromSQL <- defineRecordParser sqlValueType cF conPair width - toSQL <- defineRecordPrinter sqlValueType dF conPair width - instSQL <- definePersistableInstance sqlValueType tyCon cF dF width - return $ fromSQL ++ toSQL ++ instSQL - -- | Default name of record construction function from SQL table name. fromSqlNameDefault :: String -> VarName fromSqlNameDefault = (`varNameWithPrefix` "fromSqlOf") @@ -319,29 +211,6 @@ toSqlNameDefault :: String -> VarName toSqlNameDefault = (`varNameWithPrefix` "toSqlOf") --- | All templates depending on SQL value type with configured names. -makeRecordPersistableWithSqlTypeWithConfig :: TypeQ -- ^ SQL value type - -> NameConfig -- ^ name rule config - -> String -- ^ Schema name of database - -> String -- ^ Table name of database - -> Int -- ^ Count of record columns - -> Q [Dec] -- ^ Result declarations -makeRecordPersistableWithSqlTypeWithConfig sqlValueType config schema table width = - makeRecordPersistableWithSqlType - sqlValueType - (persistableFunctionNamesDefault . conName . conCamelcaseName $ table) - (recordType config schema table, toDataCon . recordTypeName config schema $ table) - width - --- | All templates depending on SQL value type with default names. -makeRecordPersistableWithSqlTypeDefault :: TypeQ -- ^ SQL value type - -> String -- ^ Schema name - -> String -- ^ Table name - -> Int -- ^ Count of record columns - -> Q [Dec] -- ^ Result declarations -makeRecordPersistableWithSqlTypeDefault sqlValueType = - makeRecordPersistableWithSqlTypeWithConfig sqlValueType defaultNameConfig - recordInfo' :: Info -> Maybe ((TypeQ, ExpQ), (Maybe [Name], [TypeQ])) recordInfo' = d where d (TyConI tcon) = do @@ -362,41 +231,29 @@ return (recordInfo' tyConInfo) --- | Generate persistable function symbol names using default rule. -persistableFunctionNamesDefault :: Name -> (VarName, VarName) -persistableFunctionNamesDefault recTypeName = (fromSqlNameDefault bn, toSqlNameDefault bn) where - bn = nameBase recTypeName - --- | All templates depending on SQL value type. Defined record type information is used. -makeRecordPersistableWithSqlTypeFromDefined :: TypeQ -- ^ SQL value type - -> (VarName, VarName) -- ^ Constructor function name and decompose function name - -> Name -- ^ Record type constructor name - -> Q [Dec] -- ^ Result declarations -makeRecordPersistableWithSqlTypeFromDefined sqlValueType fnames recTypeName = do - (conPair, (_, cts)) <- reifyRecordType recTypeName - makeRecordPersistableWithSqlType sqlValueType fnames conPair $ length cts - --- | All templates depending on SQL value type with default names. Defined record type information is used. -makeRecordPersistableWithSqlTypeDefaultFromDefined :: TypeQ -- ^ SQL value type - -> Name -- ^ Record type constructor name - -> Q [Dec] -- ^ Result declarations -makeRecordPersistableWithSqlTypeDefaultFromDefined sqlValueType recTypeName = - makeRecordPersistableWithSqlTypeFromDefined sqlValueType (persistableFunctionNamesDefault recTypeName) recTypeName +-- | Record parser and printer instance templates for converting +-- between list of SQL type and Haskell record type. +definePersistableInstance :: TypeQ -- ^ SQL value type. + -> TypeQ -- ^ Record type constructor. + -> Q [Dec] -- ^ Instance declarations. +definePersistableInstance sqlType typeCon = do + [d| instance FromSql $sqlType $typeCon + instance ToSql $sqlType $typeCon + |] -- | All templates for record type. defineRecord :: TypeQ -- ^ SQL value type - -> (VarName, VarName) -- ^ Constructor function name and decompose function name -> ConName -- ^ Record type name -> [(VarName, TypeQ)] -- ^ Column schema -> [Name] -- ^ Record derivings -> Q [Dec] -- ^ Result declarations defineRecord sqlValueType - fnames tyC + tyC columns drvs = do typ <- defineRecordType tyC columns drvs - withSql <- makeRecordPersistableWithSqlType sqlValueType fnames (toTypeCon tyC, toDataCon tyC) $ length columns + withSql <- definePersistableInstance sqlValueType $ toTypeCon tyC return $ typ ++ withSql -- | All templates for record type with configured names. @@ -409,7 +266,8 @@ -> Q [Dec] -- ^ Result declarations defineRecordWithConfig sqlValueType config schema table columns derives = do typ <- defineRecordTypeWithConfig config schema table columns derives - withSql <- makeRecordPersistableWithSqlTypeWithConfig sqlValueType config schema table $ length columns + withSql <- definePersistableInstance sqlValueType . fst $ recordTemplate config schema table + return $ typ ++ withSql diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistable-record-0.4.1.1/src/Database/Record/ToSql.hs new/persistable-record-0.5.1.1/src/Database/Record/ToSql.hs --- old/persistable-record-0.4.1.1/src/Database/Record/ToSql.hs 2017-02-19 08:43:07.000000000 +0100 +++ new/persistable-record-0.5.1.1/src/Database/Record/ToSql.hs 2017-07-20 17:31:36.000000000 +0200 @@ -1,10 +1,12 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DefaultSignatures #-} -- | -- Module : Database.Record.ToSql --- Copyright : 2013 Kei Hibino +-- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino(a)gmail.com @@ -12,29 +14,30 @@ -- Portability : unknown -- -- This module defines interfaces --- from Haskell type into list of SQL type. +-- from Haskell type into list of database value type. module Database.Record.ToSql ( - -- * Conversion from record type into list of SQL type + -- * Conversion from record type into list of database value type ToSqlM, RecordToSql, runFromRecord, createRecordToSql, (<&>), - -- * Inference rules of 'RecordToSql' conversion + -- * Derivation rules of 'RecordToSql' conversion ToSql (recordToSql), putRecord, putEmpty, fromRecord, wrapToSql, valueRecordToSql, -- * Make parameter list for updating with key - updateValuesByUnique', updateValuesByUnique, updateValuesByPrimary, + updateValuesByUnique', untypedUpdateValuesIndex, unsafeUpdateValuesWithIndexes ) where +import GHC.Generics (Generic, Rep, U1 (..), K1 (..), M1 (..), (:*:)(..), from) import Data.Array (listArray, (!)) import Data.Set (toList, fromList, (\\)) import Control.Monad.Trans.Writer (Writer, execWriter, tell) @@ -48,13 +51,20 @@ (Primary, Unique, KeyConstraint, HasKeyConstraint(keyConstraint), unique, indexes) --- | Context type to convert SQL type list. +-- | Context type to convert into database value list. type ToSqlM q a = Writer (DList q) a runToSqlM :: ToSqlM q a -> [q] runToSqlM = DList.toList . execWriter --- | Proof object type to convert from Haskell type 'a' into list of SQL type ['q']. +{- | +'RecordToSql' 'q' 'a' is data-type wrapping function +to convert from Haskell type 'a' into list of database value type (to send to database) ['q']. + +This structure is similar to printer. +While running 'RecordToSql' behavior is the same as list printer. +which appends list of database value type ['q'] stream. +-} newtype RecordToSql q a = RecordToSql (a -> ToSqlM q ()) runRecordToSql :: RecordToSql q a -> a -> ToSqlM q () @@ -64,24 +74,33 @@ wrapToSql :: (a -> ToSqlM q ()) -> RecordToSql q a wrapToSql = RecordToSql --- | Run 'RecordToSql' proof object. Convert from Haskell type 'a' into list of SQL type ['q']. -runFromRecord :: RecordToSql q a -- ^ Proof object which has capability to convert +-- | Run 'RecordToSql' printer function object. Convert from Haskell type 'a' into list of database value type ['q']. +runFromRecord :: RecordToSql q a -- ^ printer function object which has capability to convert -> a -- ^ Haskell type - -> [q] -- ^ list of SQL type + -> [q] -- ^ list of database value runFromRecord r = runToSqlM . runRecordToSql r --- | Axiom of 'RecordToSql' for SQL type 'q' and Haksell type 'a'. +-- | Axiom of 'RecordToSql' for database value type 'q' and Haksell type 'a'. createRecordToSql :: (a -> [q]) -- ^ Convert function body - -> RecordToSql q a -- ^ Result proof object + -> RecordToSql q a -- ^ Result printer function object createRecordToSql f = wrapToSql $ tell . DList.fromList . f --- | Derivation rule of 'RecordToSql' proof object for Haskell tuple (,) type. -(<&>) :: RecordToSql q a -> RecordToSql q b -> RecordToSql q (a, b) -ra <&> rb = RecordToSql $ \(a, b) -> do +-- unsafely map record +mapToSql :: (a -> b) -> RecordToSql q b -> RecordToSql q a +mapToSql f x = wrapToSql $ runRecordToSql x . f + +-- unsafely put product record +productToSql :: (c -> (a -> b -> ToSqlM q ()) -> ToSqlM q ()) + -> RecordToSql q a -> RecordToSql q b -> RecordToSql q c +productToSql run ra rb = wrapToSql $ \c -> run c $ \a b -> do runRecordToSql ra a runRecordToSql rb b --- | Derivation rule of 'RecordToSql' proof object for Haskell 'Maybe' type. +-- | Derivation rule of 'RecordToSql' printer function object for Haskell tuple (,) type. +(<&>) :: RecordToSql q a -> RecordToSql q b -> RecordToSql q (a, b) +(<&>) = productToSql $ flip uncurry + +-- | Derivation rule of 'RecordToSql' printer function object for Haskell 'Maybe' type. maybeRecord :: PersistableSqlType q -> PersistableRecordWidth a -> RecordToSql q a -> RecordToSql q (Maybe a) maybeRecord qt w ra = wrapToSql d where d (Just r) = runRecordToSql ra r @@ -89,29 +108,85 @@ infixl 4 <&> +{- | +'ToSql' 'q' 'a' is implicit rule to derive 'RecordToSql' 'q' 'a' record printer function for type 'a'. --- | Inference rule interface for 'RecordToSql' proof object. -class ToSql q a where - -- | Infer 'RecordToSql' proof object. +Generic programming (<https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_ext…>) +with default signature is available for 'ToSql' class, +so you can make instance like below: + +@ + \{\-\# LANGUAGE DeriveGeneric \#\-\} + import GHC.Generics (Generic) + import Database.HDBC (SqlValue) + -- + data Foo = Foo { ... } deriving Generic + instance ToSql SqlValue Foo +@ + +To make instances of 'ToSql' manually, +'ToSql' 'q' 'a' and 'RecordToSql' 'q 'a' are composable with monadic context. +When, you have data constructor and objects like below. + +@ + data MyRecord = MyRecord Foo Bar Baz +@ + +@ + instance ToSql SqlValue Foo where + ... + instance ToSql SqlValue Bar where + ... + instance ToSql SqlValue Baz where + ... +@ + +You can get composed 'ToSql' implicit rule like below. + +@ + instance ToSql SqlValue MyRecord where + recordToSql = + recordToSql = wrapToSql $ \\ (MyRecord x y z) -> do + putRecord x + putRecord y + putRecord z +@ + +-} +class PersistableWidth a => ToSql q a where + -- | Derived 'RecordToSql' printer function object. recordToSql :: RecordToSql q a --- | Inference rule of 'RecordToSql' proof object which can convert --- from Haskell tuple ('a', 'b') type into list of SQL type ['q']. -instance (ToSql q a, ToSql q b) => ToSql q (a, b) where - recordToSql = recordToSql <&> recordToSql - --- | Inference rule of 'RecordToSql' proof object which can convert --- from Haskell 'Maybe' type into list of SQL type ['q']. -instance (PersistableType q, PersistableWidth a, ToSql q a) => ToSql q (Maybe a) where + default recordToSql :: (Generic a, GToSql q (Rep a)) => RecordToSql q a + recordToSql = from `mapToSql` gToSql + +class GToSql q f where + gToSql :: RecordToSql q (f a) + +instance GToSql q U1 where + gToSql = wrapToSql $ \U1 -> tell DList.empty + +instance (GToSql q a, GToSql q b) => GToSql q (a :*: b) where + gToSql = productToSql (\ (a:*:b) f -> f a b) gToSql gToSql + +instance GToSql q a => GToSql q (M1 i c a) where + gToSql = (\(M1 a) -> a) `mapToSql` gToSql + +instance ToSql q a => GToSql q (K1 i a) where + gToSql = (\(K1 a) -> a) `mapToSql` recordToSql + + +-- | Implicit derivation rule of 'RecordToSql' printer function object which can convert +-- from Haskell 'Maybe' type into list of database value type ['q']. +instance (PersistableType q, ToSql q a) => ToSql q (Maybe a) where recordToSql = maybeRecord persistableType persistableWidth recordToSql --- | Inference rule of 'RecordToSql' proof object which can convert --- from Haskell unit () type into /empty/ list of SQL type ['q']. -instance ToSql q () where - recordToSql = wrapToSql $ \() -> tell DList.empty +-- | Implicit derivation rule of 'RecordToSql' printer function object which can convert +-- from Haskell unit () type into /empty/ list of database value type ['q']. +instance ToSql q () -- default generic instance --- | Run inferred 'RecordToSql' proof object. --- Context to convert haskell record type 'a' into SQL type 'q' list. +-- | Run implicit 'RecordToSql' printer function object. +-- Context to convert haskell record type 'a' into lib of database value type ['q']. putRecord :: ToSql q a => a -> ToSqlM q () putRecord = runRecordToSql recordToSql @@ -119,19 +194,21 @@ putEmpty :: () -> ToSqlM q () putEmpty = putRecord --- | Run inferred 'RecordToSql' proof object. --- Convert from haskell type 'a' into list of SQL type ['q']. +-- | Run implicit 'RecordToSql' printer function object. +-- Convert from haskell type 'a' into list of database value type ['q']. fromRecord :: ToSql q a => a -> [q] fromRecord = runToSqlM . putRecord --- | Derivation rule of 'RecordToSql' proof object for value convert function. +-- | Derivation rule of 'RecordToSql' printer function object for value convert function. valueRecordToSql :: (a -> q) -> RecordToSql q a valueRecordToSql = createRecordToSql . ((:[]) .) -- | Make untyped indexes to update column from key indexes and record width. -- Expected by update form like -- --- /UPDATE <table> SET c0 = ?, c1 = ?, ..., cn = ? WHERE key0 = ? AND key1 = ? AND key2 = ? ... / +-- @ +-- UPDATE /table/ SET /c0/ = ?, /c1/ = ?, /c2/ = ? ... WHERE /key0/ = ? AND /key1/ = ? AND key2 = ? ... +-- @ untypedUpdateValuesIndex :: [Int] -- ^ Key indexes -> Int -- ^ Record width -> [Int] -- ^ Indexes to update other than key @@ -140,11 +217,13 @@ otherThanKey = toList $ fromList [0 .. maxIx] \\ fromList key -- | Unsafely specify key indexes to convert from Haskell type `ra` --- into SQL value `q` list expected by update form like +-- into database value `q` list expected by update form like -- --- /UPDATE <table> SET c0 = ?, c1 = ?, ..., cn = ? WHERE key0 = ? AND key1 = ? AND key2 = ? ... / +-- @ +-- UPDATE /table/ SET /c0/ = ?, /c1/ = ?, /c2/ = ? ... WHERE /key0/ = ? AND /key1/ = ? AND /key2/ = ? ... +-- @ -- --- using 'RecordToSql' proof object. +-- using 'RecordToSql' printer function object. unsafeUpdateValuesWithIndexes :: RecordToSql q ra -> [Int] -> ra @@ -156,25 +235,27 @@ valsA = listArray (0, width - 1) vals otherThanKey = untypedUpdateValuesIndex key width --- | Convert from Haskell type `ra` into SQL value `q` list expected by update form like +-- | Convert from Haskell type `ra` into database value `q` list expected by update form like -- --- /UPDATE <table> SET c0 = ?, c1 = ?, ..., cn = ? WHERE key0 = ? AND key1 = ? AND key2 = ? ... / +-- @ +-- UPDATE /table/ SET /c0/ = ?, /c1/ = ?, /c2/ = ? ... WHERE /key0/ = ? AND /key1/ = ? AND /key2/ = ? ... +-- @ -- --- using 'RecordToSql' proof object. +-- using 'RecordToSql' printer function object. updateValuesByUnique' :: RecordToSql q ra - -> KeyConstraint Unique ra -- ^ Unique key table constraint proof object. + -> KeyConstraint Unique ra -- ^ Unique key table constraint printer function object. -> ra -> [q] updateValuesByUnique' pr uk = unsafeUpdateValuesWithIndexes pr (indexes uk) --- | Convert like 'updateValuesByUnique'' using inferred 'RecordToSql' proof object. +-- | Convert like 'updateValuesByUnique'' using implicit 'RecordToSql' printer function object. updateValuesByUnique :: ToSql q ra - => KeyConstraint Unique ra -- ^ Unique key table constraint proof object. + => KeyConstraint Unique ra -- ^ Unique key table constraint printer function object. -> ra -> [q] updateValuesByUnique = updateValuesByUnique' recordToSql --- | Convert like 'updateValuesByUnique'' using inferred 'RecordToSql' and 'ColumnConstraint' proof objects. +-- | Convert like 'updateValuesByUnique'' using implicit 'RecordToSql' and 'ColumnConstraint'. updateValuesByPrimary :: (HasKeyConstraint Primary ra, ToSql q ra) => ra -> [q] updateValuesByPrimary = updateValuesByUnique (unique keyConstraint) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistable-record-0.4.1.1/src/Database/Record/TupleInstances.hs new/persistable-record-0.5.1.1/src/Database/Record/TupleInstances.hs --- old/persistable-record-0.4.1.1/src/Database/Record/TupleInstances.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/persistable-record-0.5.1.1/src/Database/Record/TupleInstances.hs 2017-07-20 17:31:36.000000000 +0200 @@ -0,0 +1,13 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} + +module Database.Record.TupleInstances () where + +import Control.Applicative ((<$>)) + +import Database.Record.InternalTH (defineTupleInstances) + + +$(concat <$> mapM defineTupleInstances [2..7]) +-- Generic instances of tuple types are generated from 2 to 7 in GHC.Generics. diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistable-record-0.4.1.1/src/Database/Record.hs new/persistable-record-0.5.1.1/src/Database/Record.hs --- old/persistable-record-0.4.1.1/src/Database/Record.hs 2017-02-19 08:43:07.000000000 +0100 +++ new/persistable-record-0.5.1.1/src/Database/Record.hs 2017-07-20 17:31:36.000000000 +0200 @@ -48,6 +48,7 @@ (ToSqlM, RecordToSql, ToSql(..), valueRecordToSql, runFromRecord, wrapToSql, putRecord, putEmpty, fromRecord, updateValuesByUnique, updateValuesByPrimary) +import Database.Record.TupleInstances () {- $concepts On most drivers for SQL database, diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistable-record-0.4.1.1/test/Model.hs new/persistable-record-0.5.1.1/test/Model.hs --- old/persistable-record-0.4.1.1/test/Model.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/persistable-record-0.5.1.1/test/Model.hs 2017-07-20 17:31:36.000000000 +0200 @@ -0,0 +1,74 @@ +{-# OPTIONS -fno-warn-orphans #-} +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} +{-# LANGUAGE DeriveGeneric #-} +module Model where + +import GHC.Generics (Generic) + +import Database.Record + (PersistableType (..), PersistableWidth (..), + FromSql (..), valueRecordFromSql, + ToSql (..), valueRecordToSql) +import Database.Record.KeyConstraint (HasColumnConstraint (..), NotNull, unsafeSpecifyColumnConstraint) +import Database.Record.Persistable (unsafePersistableSqlTypeFromNull, unsafeValueWidth, ) + + +instance PersistableType String where + persistableType = unsafePersistableSqlTypeFromNull "<null>" + + +instance PersistableWidth String where + persistableWidth = unsafeValueWidth + +instance PersistableWidth Int where + persistableWidth = unsafeValueWidth + +instance FromSql String String where + recordFromSql = valueRecordFromSql id + +instance FromSql String Int where + recordFromSql = valueRecordFromSql read + +instance ToSql String String where + recordToSql = valueRecordToSql id + +instance ToSql String Int where + recordToSql = valueRecordToSql show + + +data User = + User + { uid :: Int + , uname :: String + , note :: String + } deriving (Eq, Show, Generic) + +data Group = + Group + { gid :: Int + , gname :: String + } deriving (Eq, Show, Generic) + +data Membership = + Membership + { user :: User + , group :: Maybe Group + } deriving (Eq, Show, Generic) + +instance HasColumnConstraint NotNull User where + columnConstraint = unsafeSpecifyColumnConstraint 0 + +instance HasColumnConstraint NotNull Group where + columnConstraint = unsafeSpecifyColumnConstraint 0 + +instance PersistableWidth User +instance PersistableWidth Group +instance PersistableWidth Membership + +instance FromSql String User +instance FromSql String Group +instance FromSql String Membership + +instance ToSql String User +instance ToSql String Group +instance ToSql String Membership diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistable-record-0.4.1.1/test/nestedEq.hs new/persistable-record-0.5.1.1/test/nestedEq.hs --- old/persistable-record-0.4.1.1/test/nestedEq.hs 2017-02-19 08:43:07.000000000 +0100 +++ new/persistable-record-0.5.1.1/test/nestedEq.hs 2017-07-20 17:31:36.000000000 +0200 @@ -1,67 +1,60 @@ {-# OPTIONS -fno-warn-orphans #-} {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} -import Control.Applicative ((<$>), (<*>)) import Test.QuickCheck.Simple (defaultMain, eqTest) -import Database.Record - (PersistableType (..), - FromSql (..), valueRecordFromSql, toRecord, - ToSql (..), valueRecordToSql) -import Database.Record.Persistable (unsafePersistableSqlTypeFromNull) +import Database.Record (toRecord, fromRecord, persistableWidth, PersistableRecordWidth) +import Database.Record.Persistable (runPersistableRecordWidth) +import Model (User (..), Group (..), Membership (..)) -instance PersistableType String where - persistableType = unsafePersistableSqlTypeFromNull "<null>" - - -instance FromSql String String where - recordFromSql = valueRecordFromSql id - -instance FromSql String Int where - recordFromSql = valueRecordFromSql read - -instance ToSql String String where - recordToSql = valueRecordToSql id - -instance ToSql String Int where - recordToSql = valueRecordToSql show - - -data User = - User - { uid :: Int - , uname :: String - , note :: String - } deriving (Eq, Show) - -data Group = - Group - { gid :: Int - , gname :: String - } deriving (Eq, Show) - -data Membership = - Membership - { user :: User - , group :: Group - } deriving (Eq, Show) - -instance FromSql String User where - recordFromSql = User <$> recordFromSql <*> recordFromSql <*> recordFromSql - -instance FromSql String Group where - recordFromSql = Group <$> recordFromSql <*> recordFromSql - -instance FromSql String Membership where - recordFromSql = Membership <$> recordFromSql <*> recordFromSql main :: IO () main = defaultMain [ eqTest - "nestedEq" + "toRecord just" + (Membership { user = User { uid = 1, uname = "Kei Hibino", note = "HRR developer" } + , group = Just $ Group { gid = 1, gname = "Haskellers" } + } ) + (toRecord ["1", "Kei Hibino", "HRR developer", "1", "Haskellers"]) + , eqTest + "toRecord nothing" (Membership { user = User { uid = 1, uname = "Kei Hibino", note = "HRR developer" } - , group = Group { gid = 1, gname = "Haskellers" } + , group = Nothing } ) - (toRecord ["1", "Kei Hibino", "HRR developer", "1", "Haskellers"]) ] + (toRecord ["1", "Kei Hibino", "HRR developer", "<null>", "<null>"]) + , eqTest + "fromRecord just" + (fromRecord $ Membership { user = User { uid = 1, uname = "Kei Hibino", note = "HRR developer" } + , group = Just $ Group { gid = 1, gname = "Haskellers" } + } ) + ["1", "Kei Hibino", "HRR developer", "1", "Haskellers"] + , eqTest + "fromRecord note" + (fromRecord $ Membership { user = User { uid = 1, uname = "Kei Hibino", note = "HRR developer" } + , group = Nothing + } ) + ["1", "Kei Hibino", "HRR developer", "<null>", "<null>"] + + , eqTest + "toRecord pair" + (User { uid = 1, uname = "Kei Hibino", note = "HRR developer" }, + Just $ Group { gid = 1, gname = "Haskellers" }) + (toRecord ["1", "Kei Hibino", "HRR developer", "1", "Haskellers"]) + , eqTest + "fromRecord pair" + (fromRecord $ (User { uid = 1, uname = "Kei Hibino", note = "HRR developer" }, + Just $ Group { gid = 1, gname = "Haskellers" })) + ["1", "Kei Hibino", "HRR developer", "1", "Haskellers"] + , eqTest + "width pair" + (runPersistableRecordWidth (persistableWidth :: PersistableRecordWidth User) + + runPersistableRecordWidth (persistableWidth :: PersistableRecordWidth Group)) + (runPersistableRecordWidth (persistableWidth :: PersistableRecordWidth (User, Group))) + , eqTest + "width record" + (runPersistableRecordWidth (persistableWidth :: PersistableRecordWidth User) + + runPersistableRecordWidth (persistableWidth :: PersistableRecordWidth (Maybe Group))) + (runPersistableRecordWidth (persistableWidth :: PersistableRecordWidth Membership)) + ]

1 0

commit ghc-pagination for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-pagination for openSUSE:Factory checked in at 2017-08-31 20:57:44 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-pagination (Old) and /work/SRC/openSUSE:Factory/.ghc-pagination.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-pagination" Thu Aug 31 20:57:44 2017 rev:2 rq:513445 version:0.2.0 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-pagination/ghc-pagination.changes 2017-04-12 18:08:12.609881544 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-pagination.new/ghc-pagination.changes 2017-08-31 20:57:45.820455778 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:07:03 UTC 2017 - psimons(a)suse.com + +- Update to version 0.2.0. + +------------------------------------------------------------------- Old: ---- pagination-0.1.1.tar.gz New: ---- pagination-0.2.0.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-pagination.spec ++++++ --- /var/tmp/diff_new_pack.iDoobH/_old 2017-08-31 20:57:46.908302933 +0200 +++ /var/tmp/diff_new_pack.iDoobH/_new 2017-08-31 20:57:46.932299561 +0200 @@ -19,7 +19,7 @@ %global pkg_name pagination %bcond_with tests Name: ghc-%{pkg_name} -Version: 0.1.1 +Version: 0.2.0 Release: 0 Summary: Framework-agnostic pagination boilerplate License: BSD-3-Clause ++++++ pagination-0.1.1.tar.gz -> pagination-0.2.0.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/pagination-0.1.1/CHANGELOG.md new/pagination-0.2.0/CHANGELOG.md --- old/pagination-0.1.1/CHANGELOG.md 2016-09-24 21:27:34.000000000 +0200 +++ new/pagination-0.2.0/CHANGELOG.md 2017-05-23 08:57:39.000000000 +0200 @@ -1,3 +1,10 @@ +## Pagination 0.2.0 + +* Drop the `Applicative` instance of `Paginated` as it may lead to confusing + results in certain cases. + +* Improved documentation and metadata. + ## Pagination 0.1.1 * Relax constraint of `paginate`. We only need `Functor` here, not `Monad`. diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/pagination-0.1.1/Data/Pagination.hs new/pagination-0.2.0/Data/Pagination.hs --- old/pagination-0.1.1/Data/Pagination.hs 2016-09-24 21:25:27.000000000 +0200 +++ new/pagination-0.2.0/Data/Pagination.hs 2017-05-23 08:55:15.000000000 +0200 @@ -1,15 +1,16 @@ -- | -- Module : Data.Pagination --- Copyright : © 2016 Mark Karpov +-- Copyright : © 2016–2017 Mark Karpov -- License : BSD 3 clause -- --- Maintainer : Mark Karpov <markkarpov(a)openmailbox.org> +-- Maintainer : Mark Karpov <markkarpov92(a)gmail.com> -- Stability : experimental -- Portability : portable -- -- Framework-agnostic pagination boilerplate. {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE RecordWildCards #-} @@ -48,15 +49,14 @@ ---------------------------------------------------------------------------- -- Pagination settings --- | The data type represents settings that are required to organize data in --- paginated form. +-- | Settings that are required to organize data in paginated form. data Pagination = Pagination Natural Natural deriving (Eq, Show, Data, Typeable, Generic) instance NFData Pagination --- | Create a 'Pagination' value. Throws 'PaginationException'. +-- | Create a 'Pagination' value. May throw 'PaginationException'. mkPagination :: MonadThrow m => Natural -- ^ Page size @@ -71,35 +71,26 @@ pageSize :: Pagination -> Natural pageSize (Pagination size _) = size -{-# INLINE pageSize #-} -- | Get page index from a 'Pagination'. pageIndex :: Pagination -> Natural pageIndex (Pagination _ index) = index -{-# INLINE pageIndex #-} ---------------------------------------------------------------------------- -- Paginated data --- | Data in paginated form. +-- | Data in the paginated form. data Paginated a = Paginated { pgItems :: [a] , pgPagination :: Pagination , pgPagesTotal :: Natural , pgItemsTotal :: Natural - } deriving (Eq, Show, Data, Typeable, Generic) + } deriving (Eq, Show, Data, Typeable, Generic, Functor) instance NFData a => NFData (Paginated a) -instance Functor Paginated where - fmap f p@Paginated {..} = p { pgItems = fmap f pgItems } - -instance Applicative Paginated where - pure x = Paginated [x] (Pagination 1 1) 1 1 - f <*> p = p { pgItems = pgItems f <*> pgItems p } - instance Foldable Paginated where foldr f x = foldr f x . pgItems @@ -134,47 +125,41 @@ paginatedItems :: Paginated a -> [a] paginatedItems = pgItems -{-# INLINE paginatedItems #-} --- | Get 'Pagination' parameters that were used to create this paginated result. +-- | Get 'Pagination' parameters that were used to create this paginated +-- result. paginatedPagination :: Paginated a -> Pagination paginatedPagination = pgPagination -{-# INLINE paginatedPagination #-} --- | Get total number of pages in this collection. +-- | Get the total number of pages in this collection. paginatedPagesTotal :: Paginated a -> Natural paginatedPagesTotal = pgPagesTotal -{-# INLINE paginatedPagesTotal #-} --- | Get total number of items in this collection. +-- | Get the total number of items in this collection. paginatedItemsTotal :: Paginated a -> Natural paginatedItemsTotal = pgItemsTotal -{-# INLINE paginatedItemsTotal #-} -- | Test whether there are other pages. hasOtherPages :: Paginated a -> Bool hasOtherPages Paginated {..} = pgPagesTotal > 1 -{-# INLINE hasOtherPages #-} -- | Is there previous page? hasPrevPage :: Paginated a -> Bool hasPrevPage Paginated {..} = pageIndex pgPagination > 1 -{-# INLINE hasPrevPage #-} -- | Is there next page? hasNextPage :: Paginated a -> Bool hasNextPage Paginated {..} = pageIndex pgPagination < pgPagesTotal -{-# INLINE hasNextPage #-} --- | Get range of pages to show before and after current page. This does not --- necessarily include the first and the last pages (they are supposed to be --- shown in all cases). Result of the function is always sorted. +-- | Get range of pages to show before and after the current page. This does +-- not necessarily include the first and the last pages (they are supposed +-- to be shown in all cases). Result of the function is always sorted. pageRange :: Paginated a -- ^ Paginated data @@ -197,7 +182,6 @@ -> Natural -- ^ Number of pages to show before and after -> Bool backwardEllip p n = NE.head (pageRange p n) > 2 -{-# INLINE backwardEllip #-} -- | Forward ellipsis appears when page range (pages around current page to -- jump to) has gap between its end and the last page. @@ -207,7 +191,6 @@ -> Natural -- ^ Number of pages to show before and after -> Bool -- ^ Do we have forward ellipsis? forwardEllip p@Paginated {..} n = NE.last (pageRange p n) < pred pgPagesTotal -{-# INLINE forwardEllip #-} ---------------------------------------------------------------------------- -- Exceptions diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/pagination-0.1.1/LICENSE.md new/pagination-0.2.0/LICENSE.md --- old/pagination-0.1.1/LICENSE.md 2016-01-03 14:37:56.000000000 +0100 +++ new/pagination-0.2.0/LICENSE.md 2017-01-27 21:19:23.000000000 +0100 @@ -1,4 +1,4 @@ -Copyright © 2016 Mark Karpov +Copyright © 2016–2017 Mark Karpov All rights reserved. diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/pagination-0.1.1/README.md new/pagination-0.2.0/README.md --- old/pagination-0.1.1/README.md 2016-09-19 15:15:13.000000000 +0200 +++ new/pagination-0.2.0/README.md 2017-01-27 21:19:23.000000000 +0100 @@ -11,6 +11,6 @@ ## License -Copyright © 2016 Mark Karpov +Copyright © 2016–2017 Mark Karpov Distributed under BSD 3 clause license. diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/pagination-0.1.1/pagination.cabal new/pagination-0.2.0/pagination.cabal --- old/pagination-0.1.1/pagination.cabal 2016-09-24 21:28:35.000000000 +0200 +++ new/pagination-0.2.0/pagination.cabal 2017-05-23 09:11:07.000000000 +0200 @@ -1,42 +1,11 @@ --- --- Cabal configuration for ‘pagination’ package. --- --- Copyright © 2016 Mark Karpov <markkarpov(a)openmailbox.org> --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- --- * 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. --- --- * Neither the name Mark Karpov nor the names of contributors may be used --- to endorse or promote products derived from this software without --- specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “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 COPYRIGHT HOLDERS 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. - name: pagination -version: 0.1.1 +version: 0.2.0 cabal-version: >= 1.10 +tested-with: GHC==7.10.3, GHC==8.0.2, GHC==8.2.1 license: BSD3 license-file: LICENSE.md -author: Mark Karpov <markkarpov(a)openmailbox.org> -maintainer: Mark Karpov <markkarpov(a)openmailbox.org> +author: Mark Karpov <markkarpov92(a)gmail.com> +maintainer: Mark Karpov <markkarpov92(a)gmail.com> homepage: https://github.com/mrkkrp/pagination bug-reports: https://github.com/mrkkrp/pagination/issues category: Data @@ -78,7 +47,7 @@ , QuickCheck >= 2.4 && < 3.0 , exceptions >= 0.6 && < 0.9 , hspec >= 2.0 && < 3.0 - , pagination >= 0.1.1 + , pagination if !impl(ghc >= 8.0) build-depends: semigroups == 0.18.* diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/pagination-0.1.1/tests/Main.hs new/pagination-0.2.0/tests/Main.hs --- old/pagination-0.1.1/tests/Main.hs 2016-07-13 22:44:03.000000000 +0200 +++ new/pagination-0.2.0/tests/Main.hs 2017-05-23 08:57:09.000000000 +0200 @@ -1,35 +1,3 @@ --- --- Tests for the ‘pagination’ package. --- --- Copyright © 2016 Mark Karpov <markkarpov(a)openmailbox.org> --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- --- * 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. --- --- * Neither the name Mark Karpov nor the names of contributors may be used --- to endorse or promote products derived from this software without --- specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “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 COPYRIGHT HOLDERS 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. - {-# LANGUAGE RankNTypes #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -72,17 +40,6 @@ let f :: Int -> Int f = (+ 1) in paginatedItems (f <$> r) === (f <$> paginatedItems r) - describe "Applicative instance of Paginated" $ do - it "constructs the right pure Paginated value" $ do - p <- mkPagination 1 1 - r <- paginate p 1 ((\_ _ -> return [1]) :: Int -> Int -> IO [Int]) - pure (1 :: Int) `shouldBe` r - it "the (<*>) operator works like with lists" $ - property $ \r0 r1 -> - let f :: Int -> Int -> Int - f = (*) - in paginatedItems (f <$> r0 <*> r1) === - (f <$> paginatedItems r0 <*> paginatedItems r1) describe "Foldable instance of Paginated" $ it "foldr works like with lists" $ property $ \p n ->

1 0