├── .dir-locals.el ├── .gitignore ├── .travis.yml ├── LICENSE ├── Main.hs ├── Makefile ├── README.org ├── default.nix ├── nh ├── nh.cabal ├── nh.org ├── out ├── port.org ├── shell.nix ├── src └── NH │ ├── Config.hs │ ├── Derivation.hs │ ├── Emission.hs │ ├── FS.hs │ ├── Github.hs │ ├── Logic.hs │ ├── MRecord.hs │ ├── Misc.hs │ ├── Nix.hs │ ├── PKGDB.hs │ └── Types.hs ├── suite.sh └── tests └── packages.nix /.dir-locals.el: -------------------------------------------------------------------------------- 1 | ((nil . ((dante-target . "exe:nha") 2 | ))) 3 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | \#* 3 | .\#* 4 | .~* 5 | *.o 6 | *.o_p 7 | *.hi 8 | *.dyn* 9 | *.swp 10 | *.cache 11 | *.ejc.* 12 | *.csv 13 | *.pk3 14 | *.wav 15 | *.pdf 16 | *.shc 17 | *.json 18 | *.graphml 19 | *.eventlog 20 | 21 | /dist/ 22 | /cabal-dev/ 23 | /.cabal-sandbox/ 24 | /.stack-work/ 25 | /tests/.nh 26 | /tests/overrides.nix 27 | /tests/pkgdb 28 | 29 | nohup.out 30 | 31 | Attic.hs 32 | port.org 33 | 34 | /packages.nix 35 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: nix 2 | sudo: false 3 | script: nix-shell -p nix-prefetch-scripts --run "./suite.sh --trace" 4 | matrix: 5 | include: 6 | - os: linux 7 | dist: trusty 8 | env: PATH=$PATH:.:.. 9 | notifications: 10 | email: 11 | on_success: never 12 | on_failure: change 13 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | GNU AFFERO GENERAL PUBLIC LICENSE 2 | Version 3, 19 November 2007 3 | 4 | Copyright (C) 2007 Free Software Foundation, Inc. 5 | Everyone is permitted to copy and distribute verbatim copies 6 | of this license document, but changing it is not allowed. 7 | 8 | Preamble 9 | 10 | The GNU Affero General Public License is a free, copyleft license for 11 | software and other kinds of works, specifically designed to ensure 12 | cooperation with the community in the case of network server software. 13 | 14 | The licenses for most software and other practical works are designed 15 | to take away your freedom to share and change the works. By contrast, 16 | our General Public Licenses are intended to guarantee your freedom to 17 | share and change all versions of a program--to make sure it remains free 18 | software for all its users. 19 | 20 | When we speak of free software, we are referring to freedom, not 21 | price. Our General Public Licenses are designed to make sure that you 22 | have the freedom to distribute copies of free software (and charge for 23 | them if you wish), that you receive source code or can get it if you 24 | want it, that you can change the software or use pieces of it in new 25 | free programs, and that you know you can do these things. 26 | 27 | Developers that use our General Public Licenses protect your rights 28 | with two steps: (1) assert copyright on the software, and (2) offer 29 | you this License which gives you legal permission to copy, distribute 30 | and/or modify the software. 31 | 32 | A secondary benefit of defending all users' freedom is that 33 | improvements made in alternate versions of the program, if they 34 | receive widespread use, become available for other developers to 35 | incorporate. Many developers of free software are heartened and 36 | encouraged by the resulting cooperation. However, in the case of 37 | software used on network servers, this result may fail to come about. 38 | The GNU General Public License permits making a modified version and 39 | letting the public access it on a server without ever releasing its 40 | source code to the public. 41 | 42 | The GNU Affero General Public License is designed specifically to 43 | ensure that, in such cases, the modified source code becomes available 44 | to the community. It requires the operator of a network server to 45 | provide the source code of the modified version running there to the 46 | users of that server. Therefore, public use of a modified version, on 47 | a publicly accessible server, gives the public access to the source 48 | code of the modified version. 49 | 50 | An older license, called the Affero General Public License and 51 | published by Affero, was designed to accomplish similar goals. This is 52 | a different license, not a version of the Affero GPL, but Affero has 53 | released a new version of the Affero GPL which permits relicensing under 54 | this license. 55 | 56 | The precise terms and conditions for copying, distribution and 57 | modification follow. 58 | 59 | TERMS AND CONDITIONS 60 | 61 | 0. Definitions. 62 | 63 | "This License" refers to version 3 of the GNU Affero General Public License. 64 | 65 | "Copyright" also means copyright-like laws that apply to other kinds of 66 | works, such as semiconductor masks. 67 | 68 | "The Program" refers to any copyrightable work licensed under this 69 | License. Each licensee is addressed as "you". "Licensees" and 70 | "recipients" may be individuals or organizations. 71 | 72 | To "modify" a work means to copy from or adapt all or part of the work 73 | in a fashion requiring copyright permission, other than the making of an 74 | exact copy. The resulting work is called a "modified version" of the 75 | earlier work or a work "based on" the earlier work. 76 | 77 | A "covered work" means either the unmodified Program or a work based 78 | on the Program. 79 | 80 | To "propagate" a work means to do anything with it that, without 81 | permission, would make you directly or secondarily liable for 82 | infringement under applicable copyright law, except executing it on a 83 | computer or modifying a private copy. Propagation includes copying, 84 | distribution (with or without modification), making available to the 85 | public, and in some countries other activities as well. 86 | 87 | To "convey" a work means any kind of propagation that enables other 88 | parties to make or receive copies. Mere interaction with a user through 89 | a computer network, with no transfer of a copy, is not conveying. 90 | 91 | An interactive user interface displays "Appropriate Legal Notices" 92 | to the extent that it includes a convenient and prominently visible 93 | feature that (1) displays an appropriate copyright notice, and (2) 94 | tells the user that there is no warranty for the work (except to the 95 | extent that warranties are provided), that licensees may convey the 96 | work under this License, and how to view a copy of this License. If 97 | the interface presents a list of user commands or options, such as a 98 | menu, a prominent item in the list meets this criterion. 99 | 100 | 1. Source Code. 101 | 102 | The "source code" for a work means the preferred form of the work 103 | for making modifications to it. "Object code" means any non-source 104 | form of a work. 105 | 106 | A "Standard Interface" means an interface that either is an official 107 | standard defined by a recognized standards body, or, in the case of 108 | interfaces specified for a particular programming language, one that 109 | is widely used among developers working in that language. 110 | 111 | The "System Libraries" of an executable work include anything, other 112 | than the work as a whole, that (a) is included in the normal form of 113 | packaging a Major Component, but which is not part of that Major 114 | Component, and (b) serves only to enable use of the work with that 115 | Major Component, or to implement a Standard Interface for which an 116 | implementation is available to the public in source code form. A 117 | "Major Component", in this context, means a major essential component 118 | (kernel, window system, and so on) of the specific operating system 119 | (if any) on which the executable work runs, or a compiler used to 120 | produce the work, or an object code interpreter used to run it. 121 | 122 | The "Corresponding Source" for a work in object code form means all 123 | the source code needed to generate, install, and (for an executable 124 | work) run the object code and to modify the work, including scripts to 125 | control those activities. However, it does not include the work's 126 | System Libraries, or general-purpose tools or generally available free 127 | programs which are used unmodified in performing those activities but 128 | which are not part of the work. For example, Corresponding Source 129 | includes interface definition files associated with source files for 130 | the work, and the source code for shared libraries and dynamically 131 | linked subprograms that the work is specifically designed to require, 132 | such as by intimate data communication or control flow between those 133 | subprograms and other parts of the work. 134 | 135 | The Corresponding Source need not include anything that users 136 | can regenerate automatically from other parts of the Corresponding 137 | Source. 138 | 139 | The Corresponding Source for a work in source code form is that 140 | same work. 141 | 142 | 2. Basic Permissions. 143 | 144 | All rights granted under this License are granted for the term of 145 | copyright on the Program, and are irrevocable provided the stated 146 | conditions are met. This License explicitly affirms your unlimited 147 | permission to run the unmodified Program. The output from running a 148 | covered work is covered by this License only if the output, given its 149 | content, constitutes a covered work. This License acknowledges your 150 | rights of fair use or other equivalent, as provided by copyright law. 151 | 152 | You may make, run and propagate covered works that you do not 153 | convey, without conditions so long as your license otherwise remains 154 | in force. You may convey covered works to others for the sole purpose 155 | of having them make modifications exclusively for you, or provide you 156 | with facilities for running those works, provided that you comply with 157 | the terms of this License in conveying all material for which you do 158 | not control copyright. Those thus making or running the covered works 159 | for you must do so exclusively on your behalf, under your direction 160 | and control, on terms that prohibit them from making any copies of 161 | your copyrighted material outside their relationship with you. 162 | 163 | Conveying under any other circumstances is permitted solely under 164 | the conditions stated below. Sublicensing is not allowed; section 10 165 | makes it unnecessary. 166 | 167 | 3. Protecting Users' Legal Rights From Anti-Circumvention Law. 168 | 169 | No covered work shall be deemed part of an effective technological 170 | measure under any applicable law fulfilling obligations under article 171 | 11 of the WIPO copyright treaty adopted on 20 December 1996, or 172 | similar laws prohibiting or restricting circumvention of such 173 | measures. 174 | 175 | When you convey a covered work, you waive any legal power to forbid 176 | circumvention of technological measures to the extent such circumvention 177 | is effected by exercising rights under this License with respect to 178 | the covered work, and you disclaim any intention to limit operation or 179 | modification of the work as a means of enforcing, against the work's 180 | users, your or third parties' legal rights to forbid circumvention of 181 | technological measures. 182 | 183 | 4. Conveying Verbatim Copies. 184 | 185 | You may convey verbatim copies of the Program's source code as you 186 | receive it, in any medium, provided that you conspicuously and 187 | appropriately publish on each copy an appropriate copyright notice; 188 | keep intact all notices stating that this License and any 189 | non-permissive terms added in accord with section 7 apply to the code; 190 | keep intact all notices of the absence of any warranty; and give all 191 | recipients a copy of this License along with the Program. 192 | 193 | You may charge any price or no price for each copy that you convey, 194 | and you may offer support or warranty protection for a fee. 195 | 196 | 5. Conveying Modified Source Versions. 197 | 198 | You may convey a work based on the Program, or the modifications to 199 | produce it from the Program, in the form of source code under the 200 | terms of section 4, provided that you also meet all of these conditions: 201 | 202 | a) The work must carry prominent notices stating that you modified 203 | it, and giving a relevant date. 204 | 205 | b) The work must carry prominent notices stating that it is 206 | released under this License and any conditions added under section 207 | 7. This requirement modifies the requirement in section 4 to 208 | "keep intact all notices". 209 | 210 | c) You must license the entire work, as a whole, under this 211 | License to anyone who comes into possession of a copy. This 212 | License will therefore apply, along with any applicable section 7 213 | additional terms, to the whole of the work, and all its parts, 214 | regardless of how they are packaged. This License gives no 215 | permission to license the work in any other way, but it does not 216 | invalidate such permission if you have separately received it. 217 | 218 | d) If the work has interactive user interfaces, each must display 219 | Appropriate Legal Notices; however, if the Program has interactive 220 | interfaces that do not display Appropriate Legal Notices, your 221 | work need not make them do so. 222 | 223 | A compilation of a covered work with other separate and independent 224 | works, which are not by their nature extensions of the covered work, 225 | and which are not combined with it such as to form a larger program, 226 | in or on a volume of a storage or distribution medium, is called an 227 | "aggregate" if the compilation and its resulting copyright are not 228 | used to limit the access or legal rights of the compilation's users 229 | beyond what the individual works permit. Inclusion of a covered work 230 | in an aggregate does not cause this License to apply to the other 231 | parts of the aggregate. 232 | 233 | 6. Conveying Non-Source Forms. 234 | 235 | You may convey a covered work in object code form under the terms 236 | of sections 4 and 5, provided that you also convey the 237 | machine-readable Corresponding Source under the terms of this License, 238 | in one of these ways: 239 | 240 | a) Convey the object code in, or embodied in, a physical product 241 | (including a physical distribution medium), accompanied by the 242 | Corresponding Source fixed on a durable physical medium 243 | customarily used for software interchange. 244 | 245 | b) Convey the object code in, or embodied in, a physical product 246 | (including a physical distribution medium), accompanied by a 247 | written offer, valid for at least three years and valid for as 248 | long as you offer spare parts or customer support for that product 249 | model, to give anyone who possesses the object code either (1) a 250 | copy of the Corresponding Source for all the software in the 251 | product that is covered by this License, on a durable physical 252 | medium customarily used for software interchange, for a price no 253 | more than your reasonable cost of physically performing this 254 | conveying of source, or (2) access to copy the 255 | Corresponding Source from a network server at no charge. 256 | 257 | c) Convey individual copies of the object code with a copy of the 258 | written offer to provide the Corresponding Source. This 259 | alternative is allowed only occasionally and noncommercially, and 260 | only if you received the object code with such an offer, in accord 261 | with subsection 6b. 262 | 263 | d) Convey the object code by offering access from a designated 264 | place (gratis or for a charge), and offer equivalent access to the 265 | Corresponding Source in the same way through the same place at no 266 | further charge. You need not require recipients to copy the 267 | Corresponding Source along with the object code. If the place to 268 | copy the object code is a network server, the Corresponding Source 269 | may be on a different server (operated by you or a third party) 270 | that supports equivalent copying facilities, provided you maintain 271 | clear directions next to the object code saying where to find the 272 | Corresponding Source. Regardless of what server hosts the 273 | Corresponding Source, you remain obligated to ensure that it is 274 | available for as long as needed to satisfy these requirements. 275 | 276 | e) Convey the object code using peer-to-peer transmission, provided 277 | you inform other peers where the object code and Corresponding 278 | Source of the work are being offered to the general public at no 279 | charge under subsection 6d. 280 | 281 | A separable portion of the object code, whose source code is excluded 282 | from the Corresponding Source as a System Library, need not be 283 | included in conveying the object code work. 284 | 285 | A "User Product" is either (1) a "consumer product", which means any 286 | tangible personal property which is normally used for personal, family, 287 | or household purposes, or (2) anything designed or sold for incorporation 288 | into a dwelling. In determining whether a product is a consumer product, 289 | doubtful cases shall be resolved in favor of coverage. For a particular 290 | product received by a particular user, "normally used" refers to a 291 | typical or common use of that class of product, regardless of the status 292 | of the particular user or of the way in which the particular user 293 | actually uses, or expects or is expected to use, the product. A product 294 | is a consumer product regardless of whether the product has substantial 295 | commercial, industrial or non-consumer uses, unless such uses represent 296 | the only significant mode of use of the product. 297 | 298 | "Installation Information" for a User Product means any methods, 299 | procedures, authorization keys, or other information required to install 300 | and execute modified versions of a covered work in that User Product from 301 | a modified version of its Corresponding Source. The information must 302 | suffice to ensure that the continued functioning of the modified object 303 | code is in no case prevented or interfered with solely because 304 | modification has been made. 305 | 306 | If you convey an object code work under this section in, or with, or 307 | specifically for use in, a User Product, and the conveying occurs as 308 | part of a transaction in which the right of possession and use of the 309 | User Product is transferred to the recipient in perpetuity or for a 310 | fixed term (regardless of how the transaction is characterized), the 311 | Corresponding Source conveyed under this section must be accompanied 312 | by the Installation Information. But this requirement does not apply 313 | if neither you nor any third party retains the ability to install 314 | modified object code on the User Product (for example, the work has 315 | been installed in ROM). 316 | 317 | The requirement to provide Installation Information does not include a 318 | requirement to continue to provide support service, warranty, or updates 319 | for a work that has been modified or installed by the recipient, or for 320 | the User Product in which it has been modified or installed. Access to a 321 | network may be denied when the modification itself materially and 322 | adversely affects the operation of the network or violates the rules and 323 | protocols for communication across the network. 324 | 325 | Corresponding Source conveyed, and Installation Information provided, 326 | in accord with this section must be in a format that is publicly 327 | documented (and with an implementation available to the public in 328 | source code form), and must require no special password or key for 329 | unpacking, reading or copying. 330 | 331 | 7. Additional Terms. 332 | 333 | "Additional permissions" are terms that supplement the terms of this 334 | License by making exceptions from one or more of its conditions. 335 | Additional permissions that are applicable to the entire Program shall 336 | be treated as though they were included in this License, to the extent 337 | that they are valid under applicable law. If additional permissions 338 | apply only to part of the Program, that part may be used separately 339 | under those permissions, but the entire Program remains governed by 340 | this License without regard to the additional permissions. 341 | 342 | When you convey a copy of a covered work, you may at your option 343 | remove any additional permissions from that copy, or from any part of 344 | it. (Additional permissions may be written to require their own 345 | removal in certain cases when you modify the work.) You may place 346 | additional permissions on material, added by you to a covered work, 347 | for which you have or can give appropriate copyright permission. 348 | 349 | Notwithstanding any other provision of this License, for material you 350 | add to a covered work, you may (if authorized by the copyright holders of 351 | that material) supplement the terms of this License with terms: 352 | 353 | a) Disclaiming warranty or limiting liability differently from the 354 | terms of sections 15 and 16 of this License; or 355 | 356 | b) Requiring preservation of specified reasonable legal notices or 357 | author attributions in that material or in the Appropriate Legal 358 | Notices displayed by works containing it; or 359 | 360 | c) Prohibiting misrepresentation of the origin of that material, or 361 | requiring that modified versions of such material be marked in 362 | reasonable ways as different from the original version; or 363 | 364 | d) Limiting the use for publicity purposes of names of licensors or 365 | authors of the material; or 366 | 367 | e) Declining to grant rights under trademark law for use of some 368 | trade names, trademarks, or service marks; or 369 | 370 | f) Requiring indemnification of licensors and authors of that 371 | material by anyone who conveys the material (or modified versions of 372 | it) with contractual assumptions of liability to the recipient, for 373 | any liability that these contractual assumptions directly impose on 374 | those licensors and authors. 375 | 376 | All other non-permissive additional terms are considered "further 377 | restrictions" within the meaning of section 10. If the Program as you 378 | received it, or any part of it, contains a notice stating that it is 379 | governed by this License along with a term that is a further 380 | restriction, you may remove that term. If a license document contains 381 | a further restriction but permits relicensing or conveying under this 382 | License, you may add to a covered work material governed by the terms 383 | of that license document, provided that the further restriction does 384 | not survive such relicensing or conveying. 385 | 386 | If you add terms to a covered work in accord with this section, you 387 | must place, in the relevant source files, a statement of the 388 | additional terms that apply to those files, or a notice indicating 389 | where to find the applicable terms. 390 | 391 | Additional terms, permissive or non-permissive, may be stated in the 392 | form of a separately written license, or stated as exceptions; 393 | the above requirements apply either way. 394 | 395 | 8. Termination. 396 | 397 | You may not propagate or modify a covered work except as expressly 398 | provided under this License. Any attempt otherwise to propagate or 399 | modify it is void, and will automatically terminate your rights under 400 | this License (including any patent licenses granted under the third 401 | paragraph of section 11). 402 | 403 | However, if you cease all violation of this License, then your 404 | license from a particular copyright holder is reinstated (a) 405 | provisionally, unless and until the copyright holder explicitly and 406 | finally terminates your license, and (b) permanently, if the copyright 407 | holder fails to notify you of the violation by some reasonable means 408 | prior to 60 days after the cessation. 409 | 410 | Moreover, your license from a particular copyright holder is 411 | reinstated permanently if the copyright holder notifies you of the 412 | violation by some reasonable means, this is the first time you have 413 | received notice of violation of this License (for any work) from that 414 | copyright holder, and you cure the violation prior to 30 days after 415 | your receipt of the notice. 416 | 417 | Termination of your rights under this section does not terminate the 418 | licenses of parties who have received copies or rights from you under 419 | this License. If your rights have been terminated and not permanently 420 | reinstated, you do not qualify to receive new licenses for the same 421 | material under section 10. 422 | 423 | 9. Acceptance Not Required for Having Copies. 424 | 425 | You are not required to accept this License in order to receive or 426 | run a copy of the Program. Ancillary propagation of a covered work 427 | occurring solely as a consequence of using peer-to-peer transmission 428 | to receive a copy likewise does not require acceptance. However, 429 | nothing other than this License grants you permission to propagate or 430 | modify any covered work. These actions infringe copyright if you do 431 | not accept this License. Therefore, by modifying or propagating a 432 | covered work, you indicate your acceptance of this License to do so. 433 | 434 | 10. Automatic Licensing of Downstream Recipients. 435 | 436 | Each time you convey a covered work, the recipient automatically 437 | receives a license from the original licensors, to run, modify and 438 | propagate that work, subject to this License. You are not responsible 439 | for enforcing compliance by third parties with this License. 440 | 441 | An "entity transaction" is a transaction transferring control of an 442 | organization, or substantially all assets of one, or subdividing an 443 | organization, or merging organizations. If propagation of a covered 444 | work results from an entity transaction, each party to that 445 | transaction who receives a copy of the work also receives whatever 446 | licenses to the work the party's predecessor in interest had or could 447 | give under the previous paragraph, plus a right to possession of the 448 | Corresponding Source of the work from the predecessor in interest, if 449 | the predecessor has it or can get it with reasonable efforts. 450 | 451 | You may not impose any further restrictions on the exercise of the 452 | rights granted or affirmed under this License. For example, you may 453 | not impose a license fee, royalty, or other charge for exercise of 454 | rights granted under this License, and you may not initiate litigation 455 | (including a cross-claim or counterclaim in a lawsuit) alleging that 456 | any patent claim is infringed by making, using, selling, offering for 457 | sale, or importing the Program or any portion of it. 458 | 459 | 11. Patents. 460 | 461 | A "contributor" is a copyright holder who authorizes use under this 462 | License of the Program or a work on which the Program is based. The 463 | work thus licensed is called the contributor's "contributor version". 464 | 465 | A contributor's "essential patent claims" are all patent claims 466 | owned or controlled by the contributor, whether already acquired or 467 | hereafter acquired, that would be infringed by some manner, permitted 468 | by this License, of making, using, or selling its contributor version, 469 | but do not include claims that would be infringed only as a 470 | consequence of further modification of the contributor version. For 471 | purposes of this definition, "control" includes the right to grant 472 | patent sublicenses in a manner consistent with the requirements of 473 | this License. 474 | 475 | Each contributor grants you a non-exclusive, worldwide, royalty-free 476 | patent license under the contributor's essential patent claims, to 477 | make, use, sell, offer for sale, import and otherwise run, modify and 478 | propagate the contents of its contributor version. 479 | 480 | In the following three paragraphs, a "patent license" is any express 481 | agreement or commitment, however denominated, not to enforce a patent 482 | (such as an express permission to practice a patent or covenant not to 483 | sue for patent infringement). To "grant" such a patent license to a 484 | party means to make such an agreement or commitment not to enforce a 485 | patent against the party. 486 | 487 | If you convey a covered work, knowingly relying on a patent license, 488 | and the Corresponding Source of the work is not available for anyone 489 | to copy, free of charge and under the terms of this License, through a 490 | publicly available network server or other readily accessible means, 491 | then you must either (1) cause the Corresponding Source to be so 492 | available, or (2) arrange to deprive yourself of the benefit of the 493 | patent license for this particular work, or (3) arrange, in a manner 494 | consistent with the requirements of this License, to extend the patent 495 | license to downstream recipients. "Knowingly relying" means you have 496 | actual knowledge that, but for the patent license, your conveying the 497 | covered work in a country, or your recipient's use of the covered work 498 | in a country, would infringe one or more identifiable patents in that 499 | country that you have reason to believe are valid. 500 | 501 | If, pursuant to or in connection with a single transaction or 502 | arrangement, you convey, or propagate by procuring conveyance of, a 503 | covered work, and grant a patent license to some of the parties 504 | receiving the covered work authorizing them to use, propagate, modify 505 | or convey a specific copy of the covered work, then the patent license 506 | you grant is automatically extended to all recipients of the covered 507 | work and works based on it. 508 | 509 | A patent license is "discriminatory" if it does not include within 510 | the scope of its coverage, prohibits the exercise of, or is 511 | conditioned on the non-exercise of one or more of the rights that are 512 | specifically granted under this License. You may not convey a covered 513 | work if you are a party to an arrangement with a third party that is 514 | in the business of distributing software, under which you make payment 515 | to the third party based on the extent of your activity of conveying 516 | the work, and under which the third party grants, to any of the 517 | parties who would receive the covered work from you, a discriminatory 518 | patent license (a) in connection with copies of the covered work 519 | conveyed by you (or copies made from those copies), or (b) primarily 520 | for and in connection with specific products or compilations that 521 | contain the covered work, unless you entered into that arrangement, 522 | or that patent license was granted, prior to 28 March 2007. 523 | 524 | Nothing in this License shall be construed as excluding or limiting 525 | any implied license or other defenses to infringement that may 526 | otherwise be available to you under applicable patent law. 527 | 528 | 12. No Surrender of Others' Freedom. 529 | 530 | If conditions are imposed on you (whether by court order, agreement or 531 | otherwise) that contradict the conditions of this License, they do not 532 | excuse you from the conditions of this License. If you cannot convey a 533 | covered work so as to satisfy simultaneously your obligations under this 534 | License and any other pertinent obligations, then as a consequence you may 535 | not convey it at all. For example, if you agree to terms that obligate you 536 | to collect a royalty for further conveying from those to whom you convey 537 | the Program, the only way you could satisfy both those terms and this 538 | License would be to refrain entirely from conveying the Program. 539 | 540 | 13. Remote Network Interaction; Use with the GNU General Public License. 541 | 542 | Notwithstanding any other provision of this License, if you modify the 543 | Program, your modified version must prominently offer all users 544 | interacting with it remotely through a computer network (if your version 545 | supports such interaction) an opportunity to receive the Corresponding 546 | Source of your version by providing access to the Corresponding Source 547 | from a network server at no charge, through some standard or customary 548 | means of facilitating copying of software. This Corresponding Source 549 | shall include the Corresponding Source for any work covered by version 3 550 | of the GNU General Public License that is incorporated pursuant to the 551 | following paragraph. 552 | 553 | Notwithstanding any other provision of this License, you have 554 | permission to link or combine any covered work with a work licensed 555 | under version 3 of the GNU General Public License into a single 556 | combined work, and to convey the resulting work. The terms of this 557 | License will continue to apply to the part which is the covered work, 558 | but the work with which it is combined will remain governed by version 559 | 3 of the GNU General Public License. 560 | 561 | 14. Revised Versions of this License. 562 | 563 | The Free Software Foundation may publish revised and/or new versions of 564 | the GNU Affero General Public License from time to time. Such new versions 565 | will be similar in spirit to the present version, but may differ in detail to 566 | address new problems or concerns. 567 | 568 | Each version is given a distinguishing version number. If the 569 | Program specifies that a certain numbered version of the GNU Affero General 570 | Public License "or any later version" applies to it, you have the 571 | option of following the terms and conditions either of that numbered 572 | version or of any later version published by the Free Software 573 | Foundation. If the Program does not specify a version number of the 574 | GNU Affero General Public License, you may choose any version ever published 575 | by the Free Software Foundation. 576 | 577 | If the Program specifies that a proxy can decide which future 578 | versions of the GNU Affero General Public License can be used, that proxy's 579 | public statement of acceptance of a version permanently authorizes you 580 | to choose that version for the Program. 581 | 582 | Later license versions may give you additional or different 583 | permissions. However, no additional obligations are imposed on any 584 | author or copyright holder as a result of your choosing to follow a 585 | later version. 586 | 587 | 15. Disclaimer of Warranty. 588 | 589 | THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY 590 | APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT 591 | HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY 592 | OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, 593 | THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 594 | PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM 595 | IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF 596 | ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 597 | 598 | 16. Limitation of Liability. 599 | 600 | IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING 601 | WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS 602 | THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY 603 | GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE 604 | USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF 605 | DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD 606 | PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), 607 | EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF 608 | SUCH DAMAGES. 609 | 610 | 17. Interpretation of Sections 15 and 16. 611 | 612 | If the disclaimer of warranty and limitation of liability provided 613 | above cannot be given local legal effect according to their terms, 614 | reviewing courts shall apply local law that most closely approximates 615 | an absolute waiver of all civil liability in connection with the 616 | Program, unless a warranty or assumption of liability accompanies a 617 | copy of the Program in return for a fee. 618 | 619 | END OF TERMS AND CONDITIONS 620 | 621 | How to Apply These Terms to Your New Programs 622 | 623 | If you develop a new program, and you want it to be of the greatest 624 | possible use to the public, the best way to achieve this is to make it 625 | free software which everyone can redistribute and change under these terms. 626 | 627 | To do so, attach the following notices to the program. It is safest 628 | to attach them to the start of each source file to most effectively 629 | state the exclusion of warranty; and each file should have at least 630 | the "copyright" line and a pointer to where the full notice is found. 631 | 632 | 633 | Copyright (C) 634 | 635 | This program is free software: you can redistribute it and/or modify 636 | it under the terms of the GNU Affero General Public License as published by 637 | the Free Software Foundation, either version 3 of the License, or 638 | (at your option) any later version. 639 | 640 | This program is distributed in the hope that it will be useful, 641 | but WITHOUT ANY WARRANTY; without even the implied warranty of 642 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 643 | GNU Affero General Public License for more details. 644 | 645 | You should have received a copy of the GNU Affero General Public License 646 | along with this program. If not, see . 647 | 648 | Also add information on how to contact you by electronic and paper mail. 649 | 650 | If your software can interact with users remotely through a computer 651 | network, you should also make sure that it provides a way for users to 652 | get its source. For example, if your program is a web application, its 653 | interface could display a "Source" link that leads users to an archive 654 | of the code. There are many ways you could offer source, and different 655 | solutions will be better for different programs; see section 13 for the 656 | specific requirements. 657 | 658 | You should also get your employer (if you work as a programmer) or school, 659 | if any, to sign a "copyright disclaimer" for the program, if necessary. 660 | For more information on this, and how to apply and follow the GNU AGPL, see 661 | . 662 | -------------------------------------------------------------------------------- /Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# LANGUAGE RecordWildCards #-} 6 | {-# LANGUAGE RecursiveDo #-} 7 | {-# LANGUAGE UnicodeSyntax #-} 8 | 9 | module Main 10 | where 11 | 12 | import GHC.Stack 13 | 14 | import Control.Monad (forM_, unless) 15 | import Control.Monad.Plus (partial) 16 | import Control.Monad.IO.Class 17 | 18 | import qualified Data.Aeson as AE 19 | import Data.Char 20 | import qualified Data.Default.Class as DD 21 | import Data.Foldable 22 | import qualified Data.List as L 23 | import Data.Maybe 24 | import qualified Data.Map as Map 25 | import qualified Data.Set as Set 26 | import Data.Set.Lens 27 | import Data.String 28 | import Data.Text (pack, unpack) 29 | import qualified Data.Text as T 30 | import Data.Text.Format hiding (print) 31 | 32 | import Language.Nix.PrettyPrinting hiding ((<>), empty) 33 | import qualified Language.Nix.PrettyPrinting as Nix 34 | 35 | import qualified Network.HTTP.Req as HTTP 36 | import Network.HTTP.Req (Url, Scheme(..), (/:)) 37 | 38 | import qualified Nix.Parser as Nix 39 | import qualified Nix.Pretty as Nix 40 | import qualified Nix.Expr as Nix 41 | 42 | import qualified Options.Applicative as O 43 | import Options.Applicative 44 | 45 | import Prelude.Unicode 46 | 47 | import qualified System.Environment as Sys 48 | import qualified System.IO as Sys 49 | import qualified System.IO.Temp as Sys 50 | 51 | import qualified Text.PrettyPrint.ANSI.Leijen as PP 52 | import Text.Printf 53 | 54 | import Data.Hourglass 55 | 56 | -- import Control.Exception ( bracket ) 57 | import Control.Lens hiding (argument) 58 | -- import Control.Monad ( when ) 59 | -- import Data.Maybe ( fromMaybe, isJust ) 60 | -- import Data.Monoid ( (<>) ) 61 | -- import qualified Data.Set as Set 62 | -- import Data.String 63 | -- import Data.Time 64 | import qualified Distribution.Compat.ReadP as P 65 | import Distribution.Compiler 66 | import Distribution.Nixpkgs.Fetch 67 | import Distribution.Nixpkgs.Haskell 68 | import Distribution.Nixpkgs.Haskell.BuildInfo 69 | import Distribution.Nixpkgs.Haskell.FromCabal 70 | import Distribution.Nixpkgs.Haskell.FromCabal.Flags 71 | import qualified Distribution.Nixpkgs.Haskell.FromCabal.PostProcess as PP (pkg) 72 | import qualified Distribution.Nixpkgs.Haskell.Hackage as DB 73 | import qualified Distribution.Nixpkgs.Haskell.PackageSourceSpec as Nixpkgs 74 | import Distribution.Nixpkgs.Haskell.PackageSourceSpec hiding (Package) 75 | import Distribution.Nixpkgs.Meta 76 | import Distribution.PackageDescription ( mkFlagName, FlagAssignment, FlagName, unFlagName, unFlagAssignment, mkFlagAssignment ) 77 | import Distribution.Package ( packageId, packageName, packageVersion ) 78 | import Distribution.Simple.Utils ( lowercase ) 79 | import Distribution.System 80 | import Distribution.Text 81 | import Language.Nix 82 | -- import Paths_cabal2nix ( version ) 83 | -- import System.Environment ( getArgs ) 84 | -- import System.IO ( hFlush, hPutStrLn, stdout, stderr ) 85 | import qualified Text.PrettyPrint.ANSI.Leijen as P2 86 | import Text.PrettyPrint.HughesPJClass ( Doc, Pretty(..), text, vcat, hcat, semi ) 87 | import qualified Turtle as SH 88 | 89 | -- #if MIN_VERSION_base(4,11,0) 90 | -- import Distribution.PackageDescription ( unFlagAssignment, mkFlagAssignment ) 91 | 92 | import NH.Config (Config(..)) 93 | import qualified NH.Config as CFG 94 | import NH.Derivation 95 | import NH.Emission 96 | import NH.Misc 97 | import NH.Nix 98 | import qualified NH.FS as PKGDB hiding (open) 99 | import qualified NH.PKGDB as PKGDB 100 | import NH.Types 101 | 102 | import NH.MRecord 103 | import qualified NH.PKGDB as P 104 | import NH.PKGDB hiding (parse, path) 105 | 106 | 107 | data Cmd 108 | = DumpConfig 109 | | InternDef SrcSpec 110 | | EmitDef (Maybe Attr) 111 | | EmitGHCConfig 112 | deriving (Show) 113 | 114 | data Options = Options 115 | { oCompiler ∷ CompilerId 116 | , oSystem ∷ Platform 117 | } deriving Show 118 | 119 | instance Semigroup Options where 120 | _ <> r = r 121 | instance Monoid Options where 122 | mempty = Options { oCompiler = buildCompilerId 123 | , oSystem = buildPlatform } 124 | 125 | optionsParser ∷ O.Parser Options 126 | optionsParser = Options 127 | <$> (option (readP parse) 128 | (long "compiler" <> help "compiler to use when evaluating the Cabal file" <> value buildCompilerId <> showDefaultWith display)) 129 | <*> (option (readP parsePlatform) 130 | (long "system" <> help "target system to use when evaluating the Cabal file" <> value buildPlatform <> showDefaultWith display)) 131 | where 132 | readP :: P.ReadP a a -> ReadM a 133 | readP p = eitherReader $ \s -> case [ r' | (r',"") <- P.readP_to_S p s ] of 134 | (r:_) -> Right r 135 | _ -> Left ("invalid value " ++ show s) 136 | 137 | parsePlatform :: P.ReadP r Platform 138 | parsePlatform = do arch <- P.choice [P.string "i686" >> return I386, P.string "x86_64" >> return X86_64] 139 | _ <- P.char '-' 140 | os <- P.choice [P.string "linux" >> return Linux, P.string "darwin" >> return OSX] 141 | return (Platform arch os) 142 | 143 | commandParser ∷ O.Parser Cmd 144 | commandParser = subparser 145 | ( command "dump-config" 146 | (flip info (progDesc "Dump the configuration") 147 | (pure DumpConfig 148 | <**> helper)) 149 | <> command "intern-definition" 150 | (flip info (progDesc "Intern a Cabal package from Hackage/Github") 151 | (InternDef 152 | <$> subparser 153 | ( command "hackage" 154 | (flip info (progDesc "Obtain properties of a Hackage package ATTR") 155 | (SSHackage 156 | <$> argument str (metavar "ATTR") 157 | <*> optional (argument str (metavar "SUBDIR")) 158 | <**> helper)) 159 | <> command "github" 160 | (flip info (progDesc "Obtain properties of a Github package") 161 | (SSGithub 162 | <$> argument str (metavar "ATTR") 163 | <*> argument str (metavar "USER") 164 | <*> argument str (metavar "REPO") 165 | <*> optional (argument str (metavar "SUBDIR")) 166 | <*> (fromMaybe "master" <$> optional (argument str (metavar "GITREF"))) 167 | <**> helper))) 168 | <**> helper)) 169 | <> command "emit-definition" 170 | (flip info (progDesc "Emit a full package definition (as previously interned)") 171 | (EmitDef 172 | <$> optional (argument str (metavar "ATTR")) 173 | <**> helper)) 174 | <> command "ghc-config" 175 | (flip info (progDesc "Emit a Nix GHC configuration from PKGDB") 176 | (pure EmitGHCConfig 177 | <**> helper)) 178 | ) 179 | 180 | 181 | 182 | main ∷ IO () 183 | main = do 184 | (,) options command ← execParser $ 185 | info ((,) <$> optionsParser <*> commandParser 186 | <**> helper) $ 187 | fullDesc <> progDesc "Perform advanced queries for nh" 188 | <> header "nh - Nix Haskell tooling" 189 | withFull $ execute options command 190 | 191 | withFull ∷ (Config → PKGDB → IO a) → IO a 192 | withFull action = do 193 | cfPath ← CFG.findConfig 194 | -- putStrLn $ unpack $ "Found config at: " <> cfPath 195 | cfg@Config{..} ← CFG.readConfigOldStyle cfPath 196 | db@PKGDB{..} ← PKGDB.open _cPKGDB <&> 197 | fromMaybe (error $ printf "Config %s specifies malformed PKGDB at: %s" cfPath _cPKGDB) 198 | action cfg db 199 | 200 | getDB ∷ IO PKGDB 201 | getDB = withFull (\_→pure) 202 | 203 | 204 | 205 | run ∷ Cmd → IO () 206 | run = withFull ∘ execute mempty 207 | 208 | with ∷ (PKGDB → IO a) → IO a 209 | with action = withFull $ const action 210 | 211 | 212 | type CmdRunner = Options → Cmd → Config → PKGDB → IO () 213 | execute ∷ CmdRunner 214 | execute opts DumpConfig cfg@Config{..} PKGDB{..} = do 215 | print cfg 216 | print opts 217 | echoT $ "Config at: " <> _cConfig 218 | echoT $ "PKGDB at: " <> fromPKGDBPath pkgdbPath 219 | execute opts@Options{..} (InternDef sspec) cfg db = do 220 | drv ← getDerivation oCompiler oSystem sspec 221 | let pk = internDerivation drv sspec 222 | store (db, fromAttr $ ssAttr sspec) pk 223 | pk' ← recover (db, fromAttr $ ssAttr sspec) 224 | -- print pk 225 | -- putStrLn "-------------------------------" 226 | -- print pk' 227 | -- putStrLn "===============================" 228 | unless (pk ≡ pk') $ do 229 | putStrLn "FATAL: package roundtrip error:" 230 | let pp = pPrint pk 231 | pp' = pPrint pk' 232 | if (show pp ≢ show pp') 233 | then do 234 | putStrLn " --- 1. Just imported:" 235 | print $ pp 236 | putStrLn " --- 2. After round-trip via PKGDB:" 237 | print $ pp' 238 | else do 239 | putStrLn " --- 1. Just imported:" 240 | print $ pkMeta pk 241 | putStrLn " --- 2. After round-trip via PKGDB:" 242 | print $ pkMeta pk' 243 | execute opts (EmitDef mattr) cfg db = do 244 | attrs ← case mattr of 245 | Just attr → pure [attr] 246 | Nothing → PKGDB.listFulldefns db -- XXX: switch to status-based set construction 247 | forM_ attrs $ 248 | \attr→ do 249 | pk ∷ Package ← recover (db, fromAttr attr) 250 | print $ nest 2 $ vcat 251 | [ text (unpack $ fromAttr attr) <+> equals 252 | , pPrint pk <> semi ] 253 | -- print $ text (unpack $ fromAttr attr) <+> equals <+> pPrint fulldef 254 | execute opts (EmitGHCConfig) cfg db = do 255 | opNames ← listOverPackages db 256 | overs ← readOverPackages db 257 | let doc = withTarget ToNixpkgs $ nest 2 $ vcat $ filter (≢ mempty) $ ($+$ "") ∘ pPrint <$> Map.elems overs 258 | text = pack $ show doc 259 | print doc 260 | SH.writeTextFile "out" text 261 | SH.shell "diff -uN --color /home/deepfire/nixpkgs/pkgs/development/haskell-modules/configuration-ghc-8.4.x.nix out" mempty 262 | pure () 263 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | all: 2 | ghci -isrc Main.hs 3 | -------------------------------------------------------------------------------- /README.org: -------------------------------------------------------------------------------- 1 | * nh: manage Nix Haskell override sets 2 | *** What 3 | 4 | [[https://travis-ci.org/deepfire/nh/][https://api.travis-ci.org/deepfire/nh.svg?branch=master]] 5 | 6 | Manage a set of Nix [[https://github.com/NixOS/nixpkgs/blob/master/pkgs/development/haskell-modules/configuration-ghc-8.4.x.nix][Haskell package overrides]], somewhat automatically. 7 | 8 | Put another way, it aids definition and validation of properties of every override in a set: 9 | - validity (/whether it breaks things/) 10 | - necessity (/whether it's needed to keep things working, along with a proof/) 11 | - actuality (/whether the override status is up to date with the upstream, Hackage and Nixpkgs/) 12 | 13 | Definitions are managed somewhat conveniently, like: 14 | 15 | : nh hackage foo 1.2.14 16 | : nh hackage foo # Pull the latest one 17 | : nh upstream bar 18 | : nh upstream bar ghc-8.4 19 | : nh unmerged bar concerned-citizen PR-number 20 | 21 | *** Brutal, no-nonsense introduction 22 | 23 | 1. Init a package DB: 24 | 25 | : nh init 26 | 27 | ..which will ask you to create a config file first -- follow the 28 | instuctions. 29 | 30 | 2. Add overrides: 31 | 32 | : nh hackage lens # easy: there's a Hackage release, get the latest 33 | 34 | : nh import microlens-th # import metadata for microlens-th from Hackage cabal file 35 | : nh upstream microlens-th master # Fetch the tip of upstream's master (any refspec goes) 36 | : nh chdir microlens-th microlens-th # -- in case the Cabal metadata was wrong 37 | : nh set-issue microlens-th 222 # Specify the relevant upstream issue ID 38 | 39 | : nh set-upstream hedgehog hedgehogqa 40 | : nh unmerged hedgehog gwils 134 [GIT-REV] # the third argument to "unmerged" is the Github PR # 41 | 42 | 3. Observe the changes: 43 | 44 | : nh show lens 45 | : nh show microlens-th 46 | : nh show hedgehog 47 | 48 | ..and you always can generate =overrides.nix= from the very latest package 49 | database -- although it happens transparently most of the time: 50 | 51 | : nh apply 52 | : nh override lens # ..to see the individual override 53 | 54 | The =--disable-ghc-configuration= switch will position your override set as 55 | a /replacement/ to the global, version-specific GHC configuration. 56 | 57 | If you set =TARGET_NIXPKGS= in the =.nh= configuration file to a non-empty 58 | value, =nh= will emit non-local overrides directly into the Nixpkgs GHC 59 | configuration for the selected GHC version. 60 | 61 | 4. Validate if the overridden packages build now: 62 | 63 | : nh acme # Build all defined overrides 64 | : nh build NAME.. # ..as an alternative. 65 | 66 | ..and.. 67 | 68 | : nh progress # ..to watch progress in another terminal 69 | 70 | 5. See what the audit tool thinks about the situation: 71 | 72 | : nh audit --skip-acme [NAME..] # Defaults to everything, once more 73 | # --skip-acme, because we already did that part. 74 | 75 | It should complain, at the very least because the =trim= part was not run, 76 | and so there's no proof that any of the overrides are necessary. 77 | 78 | Note that the =nt audit= subcommand provides suggestions, that can be 79 | auto-executed when the =--auto-fix= option is supplied. 80 | 81 | 6. Let's try trimming the set: 82 | 83 | : nh trim [NAME..] 84 | 85 | That would take a while, and also it won't do anything to the recorded 86 | overrides -- it merely collected information, as an intermediate step. 87 | 88 | Let's execute on that information, then: 89 | 90 | : nh execute-trims 91 | 92 | 7. Audit again: 93 | 94 | : nh audit 95 | 96 | ..and this is probably going to fail, because the trim is often over-eager. 97 | So, some of the overrides need to be reintroduced, and the 98 | figuring-out-what-and-why part is manual (albeit assisted). Thankfully, we 99 | can record the manually-collected information in the database (which would 100 | prevent trimming of this override in the future): 101 | 102 | : nh set-explanation broken-attribute doCheck "....." 103 | 104 | Rinse, repeat -- and remember that individual attributes can be rebuilt 105 | using =nh baseline= or =nh build=. 106 | 107 | Also, explanations (aka proofs of override) can be shown per-override with: 108 | 109 | : nh explain happy src 110 | 111 | Finally: look at =suite.sh= for inspiration. 112 | 113 | *** Overview: lifecycle of fixes 114 | 115 | First, we describe the general flow of fixes, to establish a terminology. 116 | 117 | 1. Fixes are generally born on a third-party Github repo, and they are 118 | expected to be submitted upstream via pull request. 119 | 2. The PR gets merged upstream. 120 | 3. Upstream cuts a release, bumping the package version in the cabal file. 121 | 4. Upstream performs a Hackage upload. 122 | 5. Nixpkgs imports Hackage, adding a versioned =package-attribute_1_2_1_0=. 123 | 6. Nixpkgs promotest the versioned =package-attribute_1_2_1_0= to 124 | =package-attribute=, which completes the cycle. 125 | 126 | 7. Nixpkgs also supports non-source tweaks (jailbreaking out of restrictive 127 | version bounds, test and Haddock generation disables). 128 | 129 | *** Overview: above lifecycle, seen by =nh= 130 | 131 | =nh= maps the above into a /status/, per attribute: 132 | 133 | - unmerged :: phases #1 134 | - upstreamed :: phases #2 and #3 135 | - hackaged :: phase #4 136 | - shadowed :: phase #5 (/after shadow attributes -- those shadowing non-versioned ones/) 137 | - config :: not-really-phase #7 138 | 139 | *** Key points 140 | 141 | 1. =nh= tracks the aforementioned attribute status and content of the 142 | attribute overrides in a /package database/ (aka *PKGDB*). This is just a 143 | file-system directory -- but it's better to version it in Git, to be able 144 | to recover, when =nh= goes off-rails and breaks overrides. 145 | 146 | 2. The result is delivered in the form of a Nix file defining a GHC package 147 | set override (customarily called =overrides.nix=). 148 | 149 | This trivially-structured, generated file is then supposed to be imported 150 | into another, static Nix file called =packages.nix=, which then forms a 151 | proper GHC package set. That one can be passed to =nix-build=. 152 | 153 | 3. The major package DB operations that =nh= provides are: 154 | 155 | - acme :: Build every attribute in the override set using a proxy, 156 | that depends on everything overridden (really, acme). 157 | - trim :: Try to remove overrides, one by one, and record the results 158 | of those attempts in the package DB -- trying to deducing 159 | whether these overrides are necessary. It is a heuristic. 160 | - execute-trims :: Modify the package DB in accordance with the /trim/ step. 161 | This effectively removes any overrides that weren't found 162 | necessary. This is also error-prone (more things are 163 | sometimes removed than is feasible). 164 | - audit :: Verify every attribute against a set of status-dependent 165 | invariants, that ensure: 166 | - the override necessity (along with the existence of proof), and 167 | - the override being up-to-date. 168 | 169 | 4. =nh= keeps as much build information as possible, and that includes store 170 | derivation links, store source links, override expressions and build logs 171 | for every build attempt that takes place. In particular every attribute 172 | build attempt happens in three phases, handled separately: 173 | - attribute instantiation 174 | - dependency pre-build 175 | - build of the attribute itself 176 | 177 | * Appendix: Example workflow of importing existing overrides 178 | #+BEGIN_SRC sh 179 | $ nh x hackage funcmp 1.9 180 | downloading ‘http://hackage.haskell.org/package/funcmp-1.9.tar.gz’... [0/0 KiB, 0.0 KiB/s] 181 | path is ‘/nix/store/akhnn03wfi3jlx2rqgwjdz07qpz983iz-funcmp-1.9.tar.gz’ 182 | - 1d5appkjhajb9ndv2gwnfz8lw2w53v8baajzmrhg26ihzj1bkch8 183 | - https://hackage.haskell.org/package/funcmp-1.9 184 | 185 | $ nh set-explanation funcmp src 186 | funcmp.def/meta.src.explanation: Needed for (<>) in prelude 187 | 188 | $ nh jailbreak deepseq-generics 189 | 190 | $ nh set-explanation deepseq-generics jailbreak 191 | deepseq-generics.def/meta.jailbreak.explanation: https://github.com/haskell-hvr/deepseq-generics/pull/4 192 | 193 | $ nh import securemem # this fetches metadata like repoName, upstream, chdir etc. 194 | 195 | $ nh unmerged securemem shlevy 12 6168d90b00bfc6a559d3b9160732343644ef60fb 196 | - 06dhx1z44j5gshpdlsb4aryr3g4was3x4c2sgv1px8j57zrvlypx 197 | - https://github.com/vincenthz/hs-securemem/commit/6168d90b00bfc6a559d3b9160732343644ef60fb 198 | #+END_SRC 199 | * Appendix: Structure of the package database 200 | 201 | - def :: definitions 202 | - meta :: non-override metadata 203 | - over :: overrides 204 | - hackage, github :: src-specific information, per-attribute-override 205 | - cache :: override cache, per-attribute 206 | - build :: build output information: logs, expressions, derivations 207 | 208 | * Appendix: help 209 | 210 | #+BEGIN_SRC 211 | Usage: nh [--cls] [--nixpkgs] [--trace] [--debug] [--quiet] SUBCMD [SUBARGS..] 212 | 213 | NOTE: if --nixpkgs is passed, non-local overrides instead serve as definition 214 | for /home/deepfire/nixpkgs/pkgs/development/haskell-modules/configuration-ghc-8.4.x.nix 215 | 216 | 217 | PKGDB: 218 | 219 | forall-defined-edit TYPE FIELD 220 | Interactively edit all FIELD definitions of TYPE 221 | 222 | Metadata (non-override): 223 | 224 | ls-meta ATTR List attribute's metadata (as opposed to overrides 225 | meta ATTR META Print a single metadata entry of an attribute 226 | set-meta ATTR META VAL Set a single metadata entry of an attribute 227 | edit-meta ATTR META Edit the current attribute's meta value using readline 228 | disable ATTR[.OVER] Disable all/single overrides for an attribute 229 | enable ATTR[.OVER] Re-enable previously disabled overrides 230 | with-disabled-attrs ATTR.. 231 | Disable all listed attribute overrides and pause; Re-enable on exit or newline in stdin 232 | ls-disabled List all disabled attributes 233 | set-explanation ATTR OVER VAL 234 | Manually supply explanation for an override's existence 235 | set-erdeps ATTR 'ATTR..' Set attribute's essential rev-deps that must keep working 236 | chdir ATTR SUBDIR Change directory before build; "" removes the override 237 | local ATTR Mark ATTR as local: not subject for Nixpkgs GHC configuration 238 | nonlocal ATTR Remove marking of ATTR as local 239 | 240 | Override manipulation (low level): 241 | 242 | remove ATTR[.OVER] Remove specified overrides 243 | ls-over ATTR List attribute's overrides 244 | ls-input-overs ATTR List attribute's input overrides 245 | get ATTR OVER Get an attribute's override value 246 | set ATTR OVER VAL Set an attribute's override value; "" removes the override 247 | edit ATTR OVER Edit the current attribute's value using readline 248 | set-input-over ATTR INPUT VAL 249 | Set ATTR's override for INPUT 250 | edit ATTR OVER Edit the current attribute's value using readline 251 | check ATTR Disable an existing dontCheck override 252 | dontCheck ATTR Disable tests 253 | haddock ATTR Disable an existing dontHaddock override 254 | dontHaddock ATTR Disable Haddock generation 255 | jailbreak ATTR Turn on jailbreaking 256 | dontJailbreak ATTR Disable an existing jailbreak override 257 | {library,executable,test}Haskell ATTR [ATTR..] 258 | Specify extra *HaskellDepends; "" removes the override 259 | add-patch ATTR SHA256 URL Add a patch to ATTR 260 | 261 | Status: 262 | 263 | status ATTR Print status of a single attribute 264 | ls-shadowed List all attributes with status 'shadowed' 265 | ls-hackaged ...'hackaged' 266 | ls-upstreamed ...'upstreamed' 267 | ls-unmerged ...'unmerged' 268 | ls-config ...'config' 269 | 270 | Nix-level inferences: 271 | 272 | drv ATTR Store derivation for a single override 273 | pprint-drv ATTR Pretty-print ATTR's derivation (requires nix-derivation-pretty) 274 | src ATTR Store source derivation for a single override 275 | src-drv ATTR Store source derivation of ATTR 276 | src-url ATTR Source URL of ATTR 277 | inputs ATTR ATTR's store inputs 278 | deps | refs | references ATTR 279 | ATTR's store drv dependencies 280 | rdeps | referrers ATTR ATTR's store reverse drv dependencies 281 | realise-drv ATTR Realise ATTR's derivation 282 | drv-pprint STORE-DRV Pretty-print a Nix-stored .drv file 283 | src-drv ATTR Store source derivation of ATTR 284 | src-drv-url STORE-DRV Source URL of a Nix-stored source-.drv file 285 | drv-inputs STORE-DRV Store inputs for a Nix-stored .drv file 286 | drv-refs | drv-references STORE-DRV 287 | Store .drv references for a Nix-stored .drv file 288 | deriver-of STORE-PATH Store .drv for a Nix store path. Will fail if built non-locally 289 | 290 | PKGDB emission to Nix overrides: 291 | 292 | over | override | show-override ATTR 293 | Print the attribute's override defined by PKGDB 294 | apply [--reuse-cache] Apply all overrides via /home/deepfire/overrides.nix 295 | cache [--require-descs] Regenerate override cache 296 | show-cache ATTR Print the cached text of attribute's override (DEBUG) 297 | 298 | General: 299 | 300 | ls [REGEX] List all overridden attributes 301 | info ATTR Overview of an attribute's PKGDB 302 | overview [ATTR..] List overridden attributes, grouped by status + relevant info 303 | 304 | Hackage: 305 | 306 | import ATTR Scrape ATTR's Cabal file from Hackage for some properties 307 | cabal ATTR Print the latest released cabal file for ATTR 308 | hackage ATTR [RELEASE=upstream-latest] 309 | Override to a Hackage release 310 | 311 | Github: 312 | 313 | github ATTR [REF] Override ATTR to its latest upstream Github commit 314 | unmerged ATTR USER PR# [REV=HEAD] 315 | Override to a 3rd-party Github commit 316 | upstream ATTR [REV=HEAD] Override to an upstream Github commit 317 | set-upstream ATTR GITHUB-USER 318 | Specify an attribute's Github upstream username 319 | edit-upstream ATTR Edit an attribute's Github upstream username 320 | set-pr ATTR PR# Set the PR# of an attribute's Github override 321 | set-issue ATTR ISSUE# Set the Issue# of an attribute's Github override 322 | set-repoName ATTR REPO Set an attribute's Github repository name 323 | edit-repoName ATTR Edit an attribute's Github repository name 324 | 325 | Build & results: 326 | 327 | instantiate [--reuse-cache] [ATTR..] 328 | Instantiate overridden attrs (or specified subset) 329 | acme [--reuse-cache] Build everything at once, collecting all failures 330 | build [COMMON-OPTS] ATTR Build a single attribute with current overrides 331 | log ATTR [OVER=baseline] Obtain trim build logs for a single override 332 | failure ATTR [OVER=baseline] 333 | Obtain trim failure kind of an override 334 | failure-log ATTR [OVER=baseline] 335 | Obtain trim failure log of an override 336 | failure-type ATTR [OVER=baseline] 337 | Obtain trim failure type of an override 338 | proof ATTR [OVER] Print an override's proof of necessity. When OVER is empty, print context. 339 | 340 | Override database maintenance: 341 | 342 | trim [--reuse-cache] [ATTR..] 343 | Suggest a reduction to the override set (or specified subset) 344 | trim-override ATTR OVER Attempt trimming a specific override of a given attribute 345 | show-trims Show the trim suggestion 346 | execute-trims Execute the suggestion 347 | audit [--autofix] [--autoonly] [--skip-acme] [--reuse-{overrides,cache}] [ATTR..] 348 | Sanity check the overridden attrs (or specified subset). --autofix applies suggestions 349 | extra-validation-attributes 350 | Edit the set of attributes validated regardless of being overridden 351 | edit-fixed-content Edit the static part of the GHC configuration 352 | 353 | Nix shell: 354 | 355 | shell Nix shell with up-to-date overrides (shell.nix required) 356 | shell-for ATTR Nix shell for building ATTR 357 | cabal-shell Nix shell from a cabal file (nothing else required) 358 | clone-upstream-fixer-shell 359 | Nix shell from a cabal file (nothing else required) 360 | try-fix ATTR Push the current commit and try the fix 361 | find-module NAME Convenience alias for 'ghc-pkg find-module NAME' 362 | list-packages ... Convenience alias for 'ghc-pkg list ... 363 | describe-package ATTR Convenience alias for 'ghc-pkg describe ATTR 364 | package-modules ATTR List ATTR's exposed modules 365 | phases ATTR Print ATTR's build phases 366 | 367 | Miscellanea: 368 | 369 | eval BASH-EXPR Passthrough, to execute anything defined. 370 | loop-hunter Detect attribute loops: nix-shell 2>&1 | nh loop-hunter 371 | ls-builds List active builds 372 | progress [LOG] Live summary of new, complete and failing builds 373 | watch Observe the current build, as it hits the logs.. 374 | ghc Shell with current GHC 375 | prefetch-ghc GITREV Prefetch a GHC revision 376 | less-ghc-config [NEEDLE] Run less on the Nixpkgs GHC configuration 377 | git OPTIONS.. ARGS.. Run git inside controlled Nixpkgs 378 | nixpkgs-diff [(base-head|base-master|head-master] [REF] 379 | Diff of current GHC configuration 380 | 381 | #+END_SRC 382 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, aeson, ansi-wl-pprint, base, base-unicode-symbols 2 | , basement, Cabal, cabal2nix, containers, control-bool 3 | , data-default-class, data-fix, directory, distribution-nixpkgs 4 | , filepath, foundation, foundation-edge, generics-sop, github 5 | , hashable, hnix, hourglass, language-nix, lens, monadplus 6 | , optparse-applicative, parsers, pretty, protolude, req, semigroups 7 | , stdenv, temporary, text, text-format, trifecta, turtle 8 | , unordered-containers 9 | }: 10 | mkDerivation { 11 | pname = "nh"; 12 | version = "0.0.1"; 13 | src = ./.; 14 | isLibrary = true; 15 | isExecutable = true; 16 | libraryHaskellDepends = [ 17 | aeson ansi-wl-pprint base base-unicode-symbols basement Cabal 18 | cabal2nix containers control-bool data-default-class data-fix 19 | directory distribution-nixpkgs filepath foundation foundation-edge 20 | generics-sop github hashable hnix hourglass language-nix lens monadplus 21 | optparse-applicative parsers pretty protolude req semigroups 22 | temporary text text-format trifecta turtle unordered-containers 23 | ]; 24 | executableHaskellDepends = [ 25 | aeson ansi-wl-pprint base base-unicode-symbols basement Cabal 26 | cabal2nix containers control-bool data-default-class monadplus 27 | distribution-nixpkgs foundation foundation-edge generics-sop github 28 | hashable hnix hourglass language-nix lens optparse-applicative 29 | pretty protolude req temporary text text-format turtle 30 | unordered-containers 31 | ]; 32 | description = "Nix/Haskell tooling"; 33 | license = stdenv.lib.licenses.agpl3; 34 | } 35 | -------------------------------------------------------------------------------- /nh.cabal: -------------------------------------------------------------------------------- 1 | name: nh 2 | version: 0.0.1 3 | synopsis: Nix/Haskell tooling 4 | license: AGPL-3 5 | license-file: LICENSE 6 | author: Kosyrev Serge 7 | maintainer: kosyrev.serge@protonmail.com 8 | category: Database 9 | build-type: Simple 10 | 11 | extra-source-files: README.org 12 | cabal-version: >=1.10 13 | 14 | library 15 | hs-source-dirs: src 16 | default-language: Haskell2010 17 | 18 | exposed-modules: NH.Config 19 | , NH.Derivation 20 | , NH.Emission 21 | , NH.FS 22 | , NH.Github 23 | , NH.Logic 24 | , NH.Misc 25 | , NH.Nix 26 | , NH.PKGDB 27 | , NH.Types 28 | 29 | build-depends: base 30 | , basement 31 | , foundation 32 | , foundation-edge 33 | 34 | , aeson 35 | , ansi-wl-pprint 36 | , base-unicode-symbols 37 | , Cabal 38 | , cabal2nix 39 | , containers 40 | , control-bool 41 | , data-default-class 42 | , data-fix 43 | , directory 44 | , distribution-nixpkgs 45 | , filepath 46 | , github 47 | , generics-sop 48 | , hashable 49 | , hnix 50 | , hourglass 51 | , language-nix 52 | , lens 53 | , monadplus 54 | , optparse-applicative 55 | , parsers 56 | , pretty 57 | , protolude 58 | , protolude 59 | , req 60 | , semigroups 61 | , temporary 62 | , text 63 | , text-format 64 | , trifecta 65 | , turtle 66 | , unordered-containers 67 | 68 | executable nha 69 | hs-source-dirs: . 70 | main-is: Main.hs 71 | default-language: Haskell2010 72 | build-depends: base 73 | , basement 74 | , foundation 75 | , foundation-edge 76 | 77 | , aeson 78 | , ansi-wl-pprint 79 | , base-unicode-symbols 80 | , Cabal 81 | , cabal2nix 82 | , containers 83 | , control-bool 84 | , data-default-class 85 | , distribution-nixpkgs 86 | , generics-sop 87 | , github 88 | , hashable 89 | , hnix 90 | , hourglass 91 | , language-nix 92 | , lens 93 | , monadplus 94 | , nh 95 | , optparse-applicative 96 | , pretty 97 | , protolude 98 | , req 99 | , temporary 100 | , text 101 | , text-format 102 | , turtle 103 | , unordered-containers 104 | -------------------------------------------------------------------------------- /out: -------------------------------------------------------------------------------- 1 | { pkgs, haskellLib, super, self }: 2 | 3 | with haskellLib; 4 | 5 | self: super: { 6 | HTTP = overrideCabal super.HTTP (drv: {; 7 | doCheck = true; 8 | }) 9 | 10 | adjunctions = overrideCabal super.adjunctions (drv: {; 11 | jailbreak = true; 12 | }) 13 | 14 | async = overrideCabal super.async (drv: {; 15 | jailbreak = true; 16 | }) 17 | 18 | bindings-GLFW = overrideCabal super.bindings-GLFW (drv: {; 19 | jailbreak = true; 20 | }) 21 | 22 | blaze-builder = overrideCabal super.blaze-builder (drv: {; 23 | src = fetchFromGithub { 24 | owner = "bgamari"; 25 | repo = "blaze-builder"; 26 | rev = "b7195f160795a081adbb9013810d843f1ba5e062"; 27 | sha256 = "1g351fdpsvn2lbqiy9bg2s0wwrdccb8q1zh7gvpsx5nnj24b1c00"; 28 | }; 29 | jailbreak = true; 30 | }) 31 | 32 | boxes = overrideCabal super.boxes_0_1_5 (drv: {; 33 | version = "0.1.5"; 34 | sha256 = "1hsnmw95i58d4bkpxby3ddsj1cawypw4mdyb18m393s5i8p7iq9q"; 35 | }) 36 | 37 | bv = overrideCabal super.bv_0_5 (drv: {; 38 | version = "0.5"; 39 | sha256 = "1nkvqwqcjl57p6ir0sllb54vbj6q0l3s3w7z3z2svxjq2ymqk884"; 40 | }) 41 | 42 | bytestring-trie = overrideCabal super.bytestring-trie (drv: {; 43 | src = fetchFromGithub { 44 | owner = "RyanGlScott"; 45 | repo = "bytestring-trie"; 46 | rev = "e0ae0cb1ad40dedd560090d69cc36f9760797e29"; 47 | sha256 = "1jkdchvrca7dgpij5k4h1dy4qr1rli3fzbsqajwxmx9865rgiksl"; 48 | }; 49 | doCheck = true; 50 | }) 51 | 52 | cabal2nix = super.cabal2nix; 53 | 54 | constraints = overrideCabal super.constraints_0_10 (drv: {; 55 | version = "0.10"; 56 | sha256 = "1ii6j62xihxwb85akvy8cdd73g9qr7rd5zl37h4925y2acpbh962"; 57 | }) 58 | 59 | deepseq-generics = overrideCabal super.deepseq-generics (drv: {; 60 | jailbreak = true; 61 | }) 62 | 63 | deriving-compat = overrideCabal super.deriving-compat_0_4_1 (drv: {; 64 | version = "0.4.1"; 65 | sha256 = "0lzcbnvzcnrrvr61mrqdx4i8fylknf4jwrpncxr9lhpxgp4fqqk4"; 66 | }) 67 | 68 | dhall = overrideCabal super.dhall (drv: {; 69 | jailbreak = true; 70 | }) 71 | 72 | dhall-json = super.dhall-json; 73 | 74 | doctest = overrideCabal super.doctest_0_14_1 (drv: {; 75 | version = "0.14.1"; 76 | sha256 = "1phnrsh2gjls54mlpqhfjs0x003jbrsz1sijy107mbg2gnck9cfj"; 77 | doCheck = true; 78 | }) 79 | 80 | either = overrideCabal super.either_5 (drv: {; 81 | version = "5"; 82 | sha256 = "087lrgvyns9jfgi95rr2lliivxf7fsd4d0hzqzk80kx385vf5kkm"; 83 | }) 84 | 85 | exception-transformers = overrideCabal super.exception-transformers (drv: {; 86 | jailbreak = true; 87 | }) 88 | 89 | free = overrideCabal super.free_5_0_1 (drv: {; 90 | version = "5.0.1"; 91 | sha256 = "16b29r9f9j7wpd99zbspkxq22rm6r2shqv1isa1ipqfbzn9bap5p"; 92 | }) 93 | 94 | funcmp = overrideCabal super.funcmp_1_9 (drv: {; 95 | version = "1.9"; 96 | sha256 = "1d5appkjhajb9ndv2gwnfz8lw2w53v8baajzmrhg26ihzj1bkch8"; 97 | }) 98 | 99 | generics-sop = super.generics-sop; 100 | 101 | github = overrideCabal super.github (drv: {; 102 | jailbreak = true; 103 | }) 104 | 105 | hackage-db = overrideCabal super.hackage-db_2_0_1 (drv: {; 106 | version = "2.0.1"; 107 | sha256 = "13ggj72i8dxwh3qwznnqxbr00nvsbapyyhzx5zybfacddnpw3aph"; 108 | }) 109 | 110 | hackage-security = overrideCabal super.hackage-security (drv: {; 111 | src = fetchFromGithub { 112 | owner = "haskell"; 113 | repo = "hackage-security"; 114 | rev = "21519f4f572b9547485285ebe44c152e1230fd76"; 115 | sha256 = "1ijwmps4pzyhsxfhc8mrnc3ldjvpisnmr457vvhgymwhdrr95k0z"; 116 | }; 117 | jailbreak = true; 118 | }) 119 | 120 | haddock-library = overrideCabal super.haddock-library_1_5_0_1 (drv: {; 121 | version = "1.5.0.1"; 122 | sha256 = "1cmbg8l5xrwpliclwy3l057raypjqy0hsg1h1743ahaj8gq10b7z"; 123 | doCheck = true; 124 | doHaddock = true; 125 | }) 126 | 127 | haddock-library_1_5_0_1 = overrideCabal super.haddock-library_1_5_0_1 (drv: {; 128 | doCheck = true; 129 | doHaddock = true; 130 | }) 131 | 132 | hashable-time = overrideCabal super.hashable-time (drv: {; 133 | jailbreak = true; 134 | }) 135 | 136 | hashtables = super.hashtables; 137 | 138 | haskell-gi = super.haskell-gi; 139 | 140 | haskell-src-exts = overrideCabal super.haskell-src-exts_1_20_2 (drv: {; 141 | version = "1.20.2"; 142 | sha256 = "1sm3z4v1p5yffg01ldgavz71s3bvfhjfa13k428rk14bpkl8crlz"; 143 | }) 144 | 145 | haskell-src-meta = overrideCabal super.haskell-src-meta (drv: {; 146 | jailbreak = true; 147 | }) 148 | 149 | hnix = overrideCabal super.hnix_0_4_0 (drv: {; 150 | version = "0.4.0"; 151 | sha256 = "0rgx97ckv5zvly6x76h7nncswfw0ik4bhnlj8n5bpl4rqzd7d4fd"; 152 | jailbreak = true; 153 | }) 154 | 155 | hpack = super.hpack; 156 | 157 | hspec = overrideCabal super.hspec_2_4_8 (drv: {; 158 | version = "2.4.8"; 159 | sha256 = "18pddkfz661b1nr1nziq8cnmlzxiqzzmrcrk3iwn476vi3bf1m4l"; 160 | doCheck = true; 161 | }) 162 | 163 | hspec-core = overrideCabal super.hspec-core_2_4_8 (drv: {; 164 | version = "2.4.8"; 165 | sha256 = "02zr6n7mqdncvf1braf38zjdplaxrkg11x9k8717k4yg57585ji4"; 166 | doCheck = true; 167 | }) 168 | 169 | hspec-discover = overrideCabal super.hspec-discover_2_4_8 (drv: {; 170 | version = "2.4.8"; 171 | sha256 = "0llwdfpjgfpi7dr8caw0fldb9maqznmqh4awkvx72bz538gqmlka"; 172 | }) 173 | 174 | http-api-data = overrideCabal super.http-api-data (drv: {; 175 | src = fetchFromGithub { 176 | owner = "fizruk"; 177 | repo = "http-api-data"; 178 | rev = "83aac9540f4a304927c601c5db12f4dc2bf93816"; 179 | sha256 = "14hy13szr09vsisxi25a4qfajqjwznvn222bqk55dcdlnrgf0zi9"; 180 | }; 181 | jailbreak = true; 182 | }) 183 | 184 | kan-extensions = overrideCabal super.kan-extensions (drv: {; 185 | jailbreak = true; 186 | }) 187 | 188 | keys = overrideCabal super.keys (drv: {; 189 | jailbreak = true; 190 | }) 191 | 192 | lambdacube-compiler = super.lambdacube-compiler; 193 | 194 | lambdacube-gl = overrideCabal super.lambdacube-gl (drv: {; 195 | jailbreak = true; 196 | }) 197 | 198 | lambdacube-ir = super.lambdacube-ir; 199 | 200 | lens = overrideCabal super.lens_4_16 (drv: {; 201 | version = "4.16"; 202 | sha256 = "16wz3s62zmnmis7xs9jahyc7b75090b96ayk98c3gvzmpg7bx54z"; 203 | }) 204 | 205 | lifted-async = overrideCabal super.lifted-async (drv: {; 206 | jailbreak = true; 207 | }) 208 | 209 | monadplus = super.monadplus; 210 | 211 | newtype-generics = overrideCabal super.newtype-generics (drv: {; 212 | jailbreak = true; 213 | }) 214 | 215 | nh = super.nh; 216 | 217 | protolude = overrideCabal super.protolude (drv: {; 218 | jailbreak = true; 219 | }) 220 | 221 | rapid = overrideCabal super.rapid (drv: {; 222 | jailbreak = true; 223 | }) 224 | 225 | reflex = overrideCabal super.reflex (drv: {; 226 | src = fetchFromGithub { 227 | owner = "deepfire"; 228 | repo = "reflex"; 229 | rev = "4fb50139db45a37493b91973eeaad9885b4c63ca"; 230 | sha256 = "0i7pp6cw394m2vbwcqv9z5ngdarp01sabqr1jkkgchxdkkii94nx"; 231 | }; 232 | jailbreak = true; 233 | doHaddock = true; 234 | }) 235 | 236 | regex-tdfa = overrideCabal super.regex-tdfa_1_2_3 (drv: {; 237 | version = "1.2.3"; 238 | sha256 = "1n80ssz9k73s444b4hda6fhp1vyzg0fc5fvz0309fi9dh6xpxcc9"; 239 | }) 240 | 241 | resolv = overrideCabal super.resolv (drv: {; 242 | doCheck = true; 243 | }) 244 | 245 | semigroupoids = overrideCabal super.semigroupoids_5_2_2 (drv: {; 246 | version = "5.2.2"; 247 | sha256 = "17i96y4iqj8clcs090lf6k0ij3j16nj14vsfwz0mm9nd6i4gbpp4"; 248 | }) 249 | 250 | setlocale = overrideCabal super.setlocale (drv: {; 251 | jailbreak = true; 252 | }) 253 | 254 | simple-reflect = super.simple-reflect; 255 | 256 | singletons = super.singletons; 257 | 258 | stylish-cabal = overrideCabal super.stylish-cabal (drv: {; 259 | doHaddock = true; 260 | }) 261 | 262 | tasty = super.tasty; 263 | 264 | tasty-expected-failure = overrideCabal super.tasty-expected-failure (drv: {; 265 | jailbreak = true; 266 | }) 267 | 268 | tasty-hedgehog = overrideCabal super.tasty-hedgehog (drv: {; 269 | jailbreak = true; 270 | }) 271 | 272 | test-framework = overrideCabal super.test-framework_0_8_2_0 (drv: {; 273 | version = "0.8.2.0"; 274 | sha256 = "1hhacrzam6b8f10hyldmjw8pb7frdxh04rfg3farxcxwbnhwgbpm"; 275 | doCheck = true; 276 | }) 277 | 278 | text-format = super.text-format; 279 | 280 | text-lens = overrideCabal super.text-lens (drv: {; 281 | jailbreak = true; 282 | doCheck = true; 283 | }) 284 | 285 | th-desugar = super.th-desugar; 286 | 287 | tree-diff = overrideCabal super.tree-diff (drv: {; 288 | jailbreak = true; 289 | }) 290 | 291 | turtle = super.turtle; 292 | 293 | unordered-containers = overrideCabal super.unordered-containers_0_2_9_0 (drv: {; 294 | version = "0.2.9.0"; 295 | sha256 = "0l4264p0av12cc6i8gls13q8y27x12z2ar4x34n3x59y99fcnc37"; 296 | }) 297 | 298 | vector-algorithms = overrideCabal super.vector-algorithms (drv: {; 299 | doCheck = true; 300 | }) 301 | 302 | wavefront = overrideCabal super.wavefront (drv: {; 303 | jailbreak = true; 304 | }) 305 | 306 | websockets = super.websockets; 307 | 308 | wl-pprint-text = super.wl-pprint-text; 309 | 310 | } -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | { nixpkgs ? import {} 2 | , pkgs ? nixpkgs.pkgs, haskell ? pkgs.haskell 3 | , compiler ? "ghc841" 4 | , ghcOrig ? pkgs.haskell.packages."${compiler}" 5 | , tools ? false 6 | , intero ? tools 7 | }: 8 | let 9 | 10 | ghc = import ./packages.nix { inherit nixpkgs pkgs haskell compiler ghcOrig; }; 11 | default = import ./.; 12 | drv = ghc.callPackage default {}; 13 | drv' = haskell.lib.overrideCabal 14 | drv 15 | (old: { 16 | libraryHaskellDepends = 17 | [ ghc.cabal-install ]; 18 | }); 19 | in 20 | drv'.env 21 | -------------------------------------------------------------------------------- /src/NH/Config.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | {-# LANGUAGE TemplateHaskell #-} 6 | {-# LANGUAGE UnicodeSyntax #-} 7 | module NH.Config 8 | where 9 | 10 | import Control.Lens 11 | import Control.Lens.TH 12 | import Control.Monad (when) 13 | import Data.Maybe 14 | import Data.Text (Text, pack, unpack) 15 | import qualified Data.Text as T 16 | import qualified Options.Applicative as O 17 | import Options.Applicative hiding (disabled) 18 | import Prelude.Unicode 19 | import qualified System.Directory as Sys 20 | import qualified System.FilePath as Sys 21 | import qualified Text.Parser.Char as P 22 | import qualified Text.Parser.Combinators as P 23 | import qualified Text.Parser.Token as P 24 | import qualified Text.Trifecta.Parser as P 25 | 26 | import Debug.Trace 27 | 28 | import NH.Types 29 | import NH.FS 30 | import NH.Misc 31 | 32 | 33 | -- * Constants 34 | acmeAttr ∷ Attr 35 | acmeAttr = "nh-acme-grand-total-attribute" 36 | 37 | configName ∷ Text 38 | configName = ".nh2" 39 | 40 | 41 | data Config = Config 42 | { _cConfig ∷ Text 43 | , _cGHCVer ∷ GHCVer 44 | , _cGHCConfig ∷ Text 45 | , _cGHCOverrides ∷ Text 46 | , _cGHCPackages ∷ Text 47 | , _cPKGDB ∷ Text 48 | , _cGithubUser ∷ GithubUser 49 | , _cTargetNixpkgs ∷ Flag Local 50 | } deriving (Show) 51 | makeLenses 'Config 52 | 53 | instance Semigroup Config where 54 | _ <> r = r 55 | 56 | instance Monoid Config where 57 | mempty = Config 58 | { _cConfig = ".nh2" 59 | , _cGHCVer = "841" 60 | , _cGHCConfig = "configuration-ghc-8.4.x.nix" 61 | , _cGHCOverrides = "overrides.nix" 62 | , _cGHCPackages = "packages.nix" 63 | , _cPKGDB = "pkgdb" 64 | , _cGithubUser = "nobody" 65 | , _cTargetNixpkgs = disabled 66 | } 67 | 68 | 69 | -- This is for backward compat 70 | readConfigOldStyle ∷ Text → IO Config 71 | readConfigOldStyle path = do 72 | kvs ← P.parseFromFile readShellAssignments (unpack path) <&> 73 | fromMaybe (error "Failed to parse config file.") 74 | let setSingleField ∷ Text → Config → Text → Config 75 | setSingleField "TARGET_NIXPKGS" x v = x & cTargetNixpkgs .~ fromBool (v ≢ "") 76 | setSingleField "PKGDB" x v = x & cPKGDB .~ v 77 | setSingleField "GHC" x v = x & cGHCVer .~ GHCVer v 78 | setSingleField "GHC_CONFIG" x v = x & cGHCConfig .~ v 79 | setSingleField "GITHUB_USER" x v = x & cGithubUser .~ GithubUser v 80 | -- XXX: the following is a bit too silent 81 | setSingleField smth x v = x -- flip trace x $ "Ignoring config field: " <> T.unpack smth 82 | pure $ foldl (\cfg (k,v)→ setSingleField k cfg v) mempty kvs 83 | & cConfig .~ path 84 | & cGHCOverrides .~ pack (Sys.takeDirectory $ unpack path) <> "/overrides.nix" 85 | & cGHCPackages .~ pack (Sys.takeDirectory $ unpack path) <> "/packages.nix" 86 | 87 | readShellAssignment ∷ (Monad p, P.TokenParsing p) ⇒ p (T.Text, T.Text) 88 | readShellAssignment = do 89 | P.whiteSpace 90 | key ← P.some $ P.alphaNum <|> P.oneOf "_." 91 | P.char '=' 92 | P.optional $ P.char '"' 93 | val ← P.many $ P.noneOf "\"\t\n\r" 94 | P.optional $ P.char '"' 95 | pure (T.pack key, T.pack val) 96 | 97 | readShellAssignments ∷ (Monad p, P.TokenParsing p) ⇒ p [(T.Text, T.Text)] 98 | readShellAssignments = do 99 | lines' ← P.sepEndBy readShellAssignment (P.newline) 100 | P.whiteSpace 101 | P.eof 102 | pure lines' 103 | 104 | 105 | findConfig ∷ IO Text 106 | findConfig = loop "." 107 | where 108 | loop cur = do 109 | let fullPath = cur <> "/" <> T.unpack configName 110 | (∃) ← Sys.doesFileExist fullPath 111 | if (∃) 112 | then pure $ T.pack fullPath 113 | else do 114 | when (cur ≡ "/") $ 115 | errorConfigMissingAndSuggestAction 116 | -- putStrLn $ "Not found config at: " <> fullPath 117 | parent ← Sys.canonicalizePath $ cur <> "/.." 118 | loop parent 119 | 120 | errorConfigMissingAndSuggestAction ∷ a 121 | errorConfigMissingAndSuggestAction = error $ unlines 122 | [ "ERROR: the .nh configuration file is present neither in the working directory," 123 | , " nor in the containing hierarchy." 124 | , "" 125 | , "Consider the following: cat > .nh" 126 | , "" 127 | , "$(emit_nh_config /home/user/configuration-ghc84x)" 128 | , "" 129 | , "Don't have packages.nix? cat > packages.nix" 130 | , "" 131 | , "$(emit_packages_nix)" 132 | , "" 133 | ] 134 | -------------------------------------------------------------------------------- /src/NH/Derivation.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# LANGUAGE RecordWildCards #-} 6 | {-# LANGUAGE UnicodeSyntax #-} 7 | 8 | module NH.Derivation 9 | ( getDerivation 10 | , internDerivation 11 | -- * 12 | , drvFieldsPkgSet 13 | , drvFieldType 14 | , drvFieldNixName 15 | ) 16 | where 17 | 18 | import Control.Monad (forM_, unless) 19 | import Control.Monad.Plus (partial) 20 | import Control.Monad.IO.Class 21 | 22 | import qualified Data.Aeson as AE 23 | import Data.Char 24 | import qualified Data.Default.Class as DD 25 | import Data.Foldable 26 | import qualified Data.List as L 27 | import Data.Maybe 28 | import qualified Data.Map as Map 29 | import qualified Data.Set as Set 30 | import Data.Set.Lens 31 | import Data.String 32 | import Data.Text (pack, unpack) 33 | import qualified Data.Text as T 34 | import Data.Text.Format hiding (print) 35 | 36 | import Language.Nix.PrettyPrinting hiding ((<>), empty) 37 | import qualified Language.Nix.PrettyPrinting as Nix 38 | 39 | import qualified Network.HTTP.Req as HTTP 40 | import Network.HTTP.Req (Url, Scheme(..), (/:)) 41 | 42 | import qualified Nix.Parser as Nix 43 | import qualified Nix.Pretty as Nix 44 | import qualified Nix.Expr as Nix 45 | 46 | import qualified Options.Applicative as O 47 | import Options.Applicative 48 | 49 | import Prelude.Unicode 50 | 51 | import qualified System.Environment as Sys 52 | import qualified System.IO as Sys 53 | import qualified System.IO.Temp as Sys 54 | 55 | import qualified Text.PrettyPrint.ANSI.Leijen as PP 56 | import Text.Printf 57 | 58 | import Data.Hourglass 59 | 60 | -- import Control.Exception ( bracket ) 61 | import Control.Lens hiding (argument) 62 | -- import Control.Monad ( when ) 63 | -- import Data.Maybe ( fromMaybe, isJust ) 64 | -- import Data.Monoid ( (<>) ) 65 | -- import qualified Data.Set as Set 66 | -- import Data.String 67 | -- import Data.Time 68 | import qualified Distribution.Compat.ReadP as P 69 | import Distribution.Compiler 70 | import Distribution.Nixpkgs.Fetch 71 | import Distribution.Nixpkgs.Haskell 72 | import Distribution.Nixpkgs.Haskell.BuildInfo 73 | import Distribution.Nixpkgs.Haskell.FromCabal 74 | import Distribution.Nixpkgs.Haskell.FromCabal.Flags 75 | import qualified Distribution.Nixpkgs.Haskell.FromCabal.PostProcess as PP (pkg) 76 | import qualified Distribution.Nixpkgs.Haskell.Hackage as DB 77 | import qualified Distribution.Nixpkgs.Haskell.PackageSourceSpec as Nixpkgs 78 | import Distribution.Nixpkgs.Haskell.PackageSourceSpec hiding (Package) 79 | import Distribution.Nixpkgs.Meta 80 | import Distribution.PackageDescription ( mkFlagName, FlagAssignment, FlagName, unFlagName, unFlagAssignment, mkFlagAssignment ) 81 | import Distribution.Package ( packageId, packageName, packageVersion ) 82 | import Distribution.Simple.Utils ( lowercase ) 83 | import Distribution.System 84 | import Distribution.Text 85 | import Language.Nix 86 | -- import Paths_cabal2nix ( version ) 87 | -- import System.Environment ( getArgs ) 88 | -- import System.IO ( hFlush, hPutStrLn, stdout, stderr ) 89 | import qualified Text.PrettyPrint.ANSI.Leijen as P2 90 | import Text.PrettyPrint.HughesPJClass ( Doc, Pretty(..), text, vcat, hcat, semi ) 91 | 92 | -- #if MIN_VERSION_base(4,11,0) 93 | -- import Distribution.PackageDescription ( unFlagAssignment, mkFlagAssignment ) 94 | 95 | import NH.Config (Config(..)) 96 | import qualified NH.Config as CFG 97 | import NH.Misc 98 | import NH.Nix 99 | import NH.Types 100 | 101 | import NH.MRecord 102 | 103 | 104 | 105 | drvFieldType ∷ DrvField → NixType 106 | drvFieldType DFdrvparams = NTList NTVar 107 | drvFieldType DFpname = NTStr 108 | drvFieldType DFversion = NTStr 109 | drvFieldType DFsrcUrl = NTStr 110 | drvFieldType DFsrcSha256 = NTStr -- nixhash 111 | drvFieldType DFsrcRev = NTStr 112 | drvFieldType DFsubpath = NTStr 113 | drvFieldType DFrevision = NTInt 114 | drvFieldType DFeditedCabalFile = NTStr -- nixhash 115 | drvFieldType DFconfigureFlags = NTList NTStr 116 | drvFieldType DFisLibrary = NTBool 117 | drvFieldType DFisExecutable = NTBool 118 | drvFieldType DFenableSeparateDataOutput = NTBool 119 | drvFieldType _ = NTList NTVar 120 | 121 | 122 | 123 | internDerivation ∷ Derivation → SrcSpec → Package 124 | internDerivation drv sspec = 125 | let SSGithub{..} = case sspec of 126 | x@SSGithub{..} → x 127 | _ → error "Non-Github imports not supported." 128 | 129 | meAttrName = Nothing -- only applies to versioned Nixpkgs attrs 130 | meChdir = if drvFieldIsNondefault drv DFsubpath 131 | then Just (T.pack $ drv^.subpath) else Nothing 132 | meDisable = KeepOverride 133 | meErdeps = mempty 134 | meEssentialRevDeps = [] -- initially not tracked 135 | meExplanation = mempty 136 | meLocal = ToLocal 137 | meRepoName = if fromRepoName ssRepoName ≢ fromAttr ssAttr 138 | then Just ssRepoName 139 | else Nothing 140 | meTargets = ToLocal 141 | pkMeta = Meta{..} 142 | 143 | upRepoName = ssRepoName 144 | upUser = ssUser 145 | upIssue = Nothing 146 | upPr = Nothing 147 | upTimestamp = Nothing -- XXX: loss 148 | pkUpstream = Upstream{..} 149 | 150 | ghRev = GitRef $ pack $ derivRevision $ drv^.src 151 | srNixHash = NixHash $ pack $ derivHash $ drv^.src 152 | ghRepoName = ssRepoName 153 | ghUser = ssUser -- XXX: assumption 154 | pkSrc = Github{..} 155 | 156 | nonDefaultDrvFields = piecewiseDerivation drv 157 | ovDrvFields = Map.fromList $ flip filter nonDefaultDrvFields $ 158 | \(k, _)→ Set.member k drvFieldsForOverrides 159 | ovDoCheck = DoCheck 160 | ovDoHaddock = DoHaddock 161 | ovInputs = mempty 162 | ovJailbreak = DontJailbreak 163 | ovRevision = KeepRevision 164 | ovSrc = Just pkSrc 165 | ovPatches = mempty 166 | pkOver = Overrides{..} 167 | 168 | dmDescription = showDocOneLine ∘ flip pprintField DFmetaSectionDescription <$> 169 | partial (flip drvFieldIsNondefault DFmetaSectionDescription) drv 170 | dmLicense = showDocOneLine $ pprintField drv DFmetaSectionLicense 171 | dmHomepage = Nothing 172 | dmPlatforms = Nothing 173 | dmMaintainers = Nothing 174 | pkDrvMeta = DrvMeta{..} 175 | 176 | pkAttr = ssAttr 177 | -- * Pass-through fields. 178 | pkDrvFields = Map.fromList $ flip filter nonDefaultDrvFields $ 179 | \(k, _)→ not $ any (Set.member k) drvPkgExclusionSets 180 | in Package{..} 181 | 182 | 183 | -- * Cabal2nix URLs 184 | (//) ∷ T.Text → T.Text → T.Text 185 | x // y = x<>"/"<>y 186 | 187 | attrC2NUrl ∷ SrcSpec → URL 188 | attrC2NUrl (SSGithub attr user repo ref msub) = URL $ "https://github.com"//fromUser user//fromRepoName repo 189 | attrC2NUrl (SSHackage attr msub) = URL $ "cabal://"<>fromAttr attr 190 | 191 | 192 | getDerivation ∷ CompilerId → Platform → SrcSpec → IO Derivation 193 | getDerivation oCompiler oSystem sspec = do 194 | let optHpack = False 195 | optHackageDb = Nothing 196 | optHackageSnapshot = Nothing 197 | optUrl = T.unpack $ fromURL $ attrC2NUrl sspec 198 | optRevision = Nothing 199 | optSha256 = Nothing 200 | optSubpath = T.unpack ∘ fromDir <$> ssDir sspec 201 | optSystem = oSystem 202 | optCompiler = oCompiler 203 | optExtraArgs = [] 204 | opts = ImportOptions{..} 205 | package ← getPackage optHpack optHackageDb optHackageSnapshot $ 206 | Source optUrl (fromMaybe "" optRevision) (maybe UnknownHash Guess optSha256) (fromMaybe "" optSubpath) 207 | pure $ packageDerivation opts package 208 | 209 | 210 | data ImportOptions = ImportOptions 211 | { optCompiler ∷ CompilerId 212 | , optSystem ∷ Platform 213 | , optSubpath ∷ Maybe FilePath 214 | , optExtraArgs ∷ [String] 215 | } 216 | 217 | packageDerivation ∷ ImportOptions → Nixpkgs.Package → Derivation 218 | packageDerivation ImportOptions{..} pkg = do 219 | let 220 | withHpackOverrides :: Derivation -> Derivation 221 | withHpackOverrides = if pkgRanHpack pkg then hpackOverrides else id 222 | 223 | hpackOverrides :: Derivation -> Derivation 224 | hpackOverrides = over phaseOverrides (<> "preConfigure = \"hpack\";") 225 | . set (libraryDepends . tool . contains (PP.pkg "hpack")) True 226 | 227 | flags :: FlagAssignment 228 | flags = configureCabalFlags (packageId (pkgCabal pkg)) 229 | 230 | deriv :: Derivation 231 | deriv = withHpackOverrides $ fromGenericPackageDescription (const True) 232 | (\i -> Just (binding # (i, path # [i]))) 233 | optSystem 234 | (unknownCompilerInfo optCompiler NoAbiTag) 235 | flags 236 | [] 237 | (pkgCabal pkg) 238 | & src .~ pkgSource pkg 239 | & subpath .~ fromMaybe "." optSubpath 240 | & extraFunctionArgs %~ Set.union (Set.fromList ("inherit stdenv":map (fromString . ("inherit " ++)) optExtraArgs)) 241 | deriv 242 | 243 | 244 | 245 | -- 246 | -- * Field-wise 'Derivation' 247 | -- 248 | nestedPrefixes ∷ [(T.Text, Field)] 249 | nestedPrefixes = 250 | [("src", "src") 251 | ,("metaSection", "meta") 252 | ] 253 | 254 | drvFieldNestPrefix ∷ DrvField → Maybe (T.Text, Field) 255 | drvFieldNestPrefix df = 256 | let s = pack $ drop 2 $ show df 257 | in flip find nestedPrefixes (flip T.isPrefixOf s ∘ fst) 258 | 259 | drvFieldNixName ∷ DrvField → T.Text 260 | drvFieldNixName df = 261 | let s = pack $ drop 2 $ show df 262 | detitle x = T.toLower (T.take 1 x) <> T.drop 1 x 263 | in case drvFieldNestPrefix df of 264 | Nothing → s 265 | Just (pfx, _) → detitle $ T.drop (T.length pfx) s 266 | 267 | isHackagePackage ∷ Derivation → Bool 268 | isHackagePackage drv = "mirror://hackage/" `L.isPrefixOf` derivUrl (drv^.src) 269 | 270 | piecewiseDerivation ∷ Derivation → [(DrvField, DFValue)] 271 | piecewiseDerivation drv = 272 | [ (,) field $ DFValue field (pprintField drv field) 273 | | field ← every 274 | , drvFieldIsNondefault drv field ] 275 | 276 | drvFieldsPkgSet = Set.difference (Set.fromList every) $ foldl (<>) mempty drvPkgExclusionSets 277 | drvFieldsPkgSet, drvFieldsForDrvMeta, drvFieldsForOverrides, drvFieldsForSrc ∷ Set.Set DrvField 278 | drvPkgExclusionSets@[drvFieldsForDrvMeta, drvFieldsForOverrides, drvFieldsForSrc] = Set.fromList <$> [ 279 | [ DFmetaSectionHomepage 280 | , DFmetaSectionDescription 281 | , DFmetaSectionLicense 282 | , DFmetaSectionPlatforms 283 | , DFmetaSectionMaintainers 284 | ], 285 | [ DFsubpath 286 | 287 | , DFrevision 288 | , DFeditedCabalFile 289 | 290 | , DFdoHaddock 291 | , DFjailbreak 292 | , DFdoCheck 293 | ], 294 | [ DFsrcUrl 295 | , DFsrcSha256 296 | , DFsrcRev 297 | ] 298 | ] 299 | 300 | 301 | -- | Whether a 'Derivation's field needs to be a part of Nix derivation. 302 | drvFieldIsNondefault ∷ Derivation → DrvField → Bool 303 | drvFieldIsNondefault drv DFdrvparams = False 304 | drvFieldIsNondefault drv DFpname = True 305 | drvFieldIsNondefault drv DFversion = True 306 | drvFieldIsNondefault drv DFsrcUrl = True 307 | drvFieldIsNondefault drv DFsrcSha256 = True 308 | drvFieldIsNondefault drv DFsrcRev = True 309 | drvFieldIsNondefault drv DFsubpath = drv^.subpath /= "." 310 | 311 | drvFieldIsNondefault drv DFrevision = drv^.revision > 0 312 | drvFieldIsNondefault drv DFeditedCabalFile = not (null (drv^.editedCabalFile)) && drv^.revision > 0 313 | 314 | drvFieldIsNondefault drv DFconfigureFlags = not (Set.null (drv^.configureFlags)) ∧ not (null (unFlagAssignment (drv^.cabalFlags))) 315 | 316 | drvFieldIsNondefault drv DFisLibrary = not (drv^.isLibrary) || drv^.isExecutable 317 | drvFieldIsNondefault drv DFisExecutable = not (drv^.isLibrary) || drv^.isExecutable 318 | drvFieldIsNondefault drv DFenableSeparateDataOutput = drv^.enableSeparateDataOutput 319 | 320 | drvFieldIsNondefault drv DFsetupHaskellDepends = drv^.setupDepends.haskell /= mempty 321 | drvFieldIsNondefault drv DFlibraryHaskellDepends = drv^.libraryDepends.haskell /= mempty 322 | drvFieldIsNondefault drv DFexecutableHaskellDepends = drv^.executableDepends.haskell /= mempty 323 | drvFieldIsNondefault drv DFtestHaskellDepends = drv^.testDepends.haskell /= mempty 324 | drvFieldIsNondefault drv DFbenchmarkHaskellDepends = drv^.benchmarkDepends.haskell /= mempty 325 | 326 | drvFieldIsNondefault drv DFsetupSystemDepends = drv^.setupDepends.system /= mempty 327 | drvFieldIsNondefault drv DFlibrarySystemDepends = drv^.libraryDepends.system /= mempty 328 | drvFieldIsNondefault drv DFexecutableSystemDepends = drv^.executableDepends.system /= mempty 329 | drvFieldIsNondefault drv DFtestSystemDepends = drv^.testDepends.system /= mempty 330 | drvFieldIsNondefault drv DFbenchmarkSystemDepends = drv^.benchmarkDepends.system /= mempty 331 | 332 | drvFieldIsNondefault drv DFsetupPkgconfigDepends = drv^.setupDepends.pkgconfig /= mempty 333 | drvFieldIsNondefault drv DFlibraryPkgconfigDepends = drv^.libraryDepends.pkgconfig /= mempty 334 | drvFieldIsNondefault drv DFexecutablePkgconfigDepends = drv^.executableDepends.pkgconfig /= mempty 335 | drvFieldIsNondefault drv DFtestPkgconfigDepends = drv^.testDepends.pkgconfig /= mempty 336 | drvFieldIsNondefault drv DFbenchmarkPkgconfigDepends = drv^.benchmarkDepends.pkgconfig /= mempty 337 | 338 | drvFieldIsNondefault drv DFsetupToolDepends = drv^.setupDepends.tool /= mempty 339 | drvFieldIsNondefault drv DFlibraryToolDepends = drv^.libraryDepends.tool /= mempty 340 | drvFieldIsNondefault drv DFexecutableToolDepends = drv^.executableDepends.tool /= mempty 341 | drvFieldIsNondefault drv DFtestToolDepends = drv^.testDepends.tool /= mempty 342 | drvFieldIsNondefault drv DFbenchmarkToolDepends = drv^.benchmarkDepends.tool /= mempty 343 | 344 | drvFieldIsNondefault drv DFenableLibraryProfiling = drv^.enableLibraryProfiling 345 | drvFieldIsNondefault drv DFenableExecutableProfiling = drv^.enableExecutableProfiling 346 | drvFieldIsNondefault drv DFenableSplitObjs = not (drv^.enableSplitObjs) 347 | 348 | drvFieldIsNondefault drv DFdoHaddock = not (drv^.runHaddock) 349 | drvFieldIsNondefault drv DFjailbreak = drv^.jailbreak 350 | drvFieldIsNondefault drv DFdoCheck = not (drv^.doCheck) 351 | 352 | drvFieldIsNondefault drv DFtestTarget = not (null (drv^.testTarget)) 353 | drvFieldIsNondefault drv DFhyperlinkSource = not (drv^.hyperlinkSource) 354 | drvFieldIsNondefault drv DFphaseOverrides = not (null (drv^.phaseOverrides)) 355 | 356 | drvFieldIsNondefault drv DFmetaSectionHomepage = not (null (drv^.metaSection.homepage)) 357 | drvFieldIsNondefault drv DFmetaSectionDescription = not (null (drv^.metaSection.description)) 358 | drvFieldIsNondefault drv DFmetaSectionLicense = True 359 | drvFieldIsNondefault drv DFmetaSectionPlatforms = drv^.metaSection.platforms /= allKnownPlatforms 360 | drvFieldIsNondefault drv DFmetaSectionMaintainers = False -- not (Set.null (drv^.metaSection.maintainers)) 361 | 362 | 363 | -- | Field-wise pretty-printing of 'Derivation'. 364 | pprintField ∷ Derivation → DrvField → Doc 365 | pprintField drv DFdrvparams = funargs (map text ("mkDerivation" : Set.toAscList inputs)) 366 | where inputs ∷ Set.Set String 367 | inputs = Set.unions [ Set.map (view (localName . ident)) (drv^.extraFunctionArgs) 368 | , setOf (dependencies . each . folded . localName . ident) drv 369 | , Set.fromList ["fetch" ++ derivKind (drv^.src) | derivKind (drv^.src) /= "" && not (isHackagePackage drv)] 370 | ] 371 | pprintField drv DFpname = doubleQuotes $ disp $ packageName $ drv^.pkgid 372 | pprintField drv DFversion = doubleQuotes $ disp $ packageVersion $ drv^.pkgid 373 | -- XXX: the src attribute handling is butchered, beware 374 | pprintField drv DFsrcUrl = pPrint $ derivUrl $ drv^.src 375 | pprintField drv DFsrcSha256 = pPrint $ derivHash $ drv^.src 376 | pprintField drv DFsrcRev = pPrint $ derivRevision $ drv^.src 377 | pprintField drv DFsubpath = postUnpack 378 | where postUnpack = string $ "sourceRoot+=/" ++ (drv^.subpath) ++ "; echo source root reset to $sourceRoot" 379 | pprintField drv DFrevision = doubleQuotes $ int $ drv^.revision 380 | pprintField drv DFeditedCabalFile = string $ drv^.editedCabalFile 381 | pprintField drv DFconfigureFlags = listattr "configureFlags" Nix.empty $ map (show . show) renderedFlags 382 | where renderedFlags = [ text "-f" <> (if enable then Nix.empty else char '-') <> text (unFlagName f) 383 | #if MIN_VERSION_base(4,11,0) 384 | | (f, enable) <- unFlagAssignment $ drv^.cabalFlags ] 385 | #else 386 | | (f, enable) <- _cabalFlags ] 387 | #endif 388 | ++ map text (toAscList $ drv^.configureFlags) 389 | pprintField drv DFisLibrary = bool $ drv^.isLibrary 390 | pprintField drv DFisExecutable = bool $ drv^.isExecutable 391 | pprintField drv DFenableSeparateDataOutput = bool $ drv^.enableSeparateDataOutput 392 | 393 | pprintField drv DFsetupHaskellDepends = pprintSet $ setOf (haskell.folded.localName.ident) (drv^.setupDepends) 394 | pprintField drv DFlibraryHaskellDepends = pprintSet $ setOf (haskell.folded.localName.ident) (drv^.libraryDepends) 395 | pprintField drv DFexecutableHaskellDepends = pprintSet $ setOf (haskell.folded.localName.ident) (drv^.executableDepends) 396 | pprintField drv DFtestHaskellDepends = pprintSet $ setOf (haskell.folded.localName.ident) (drv^.testDepends) 397 | pprintField drv DFbenchmarkHaskellDepends = pprintSet $ setOf (haskell.folded.localName.ident) (drv^.benchmarkDepends) 398 | 399 | pprintField drv DFsetupSystemDepends = pprintSet $ setOf (system.folded.localName.ident) (drv^.setupDepends) 400 | pprintField drv DFlibrarySystemDepends = pprintSet $ setOf (system.folded.localName.ident) (drv^.libraryDepends) 401 | pprintField drv DFexecutableSystemDepends = pprintSet $ setOf (system.folded.localName.ident) (drv^.executableDepends) 402 | pprintField drv DFtestSystemDepends = pprintSet $ setOf (system.folded.localName.ident) (drv^.testDepends) 403 | pprintField drv DFbenchmarkSystemDepends = pprintSet $ setOf (system.folded.localName.ident) (drv^.benchmarkDepends) 404 | 405 | pprintField drv DFsetupPkgconfigDepends = pprintSet $ setOf (pkgconfig.folded.localName.ident) (drv^.setupDepends) 406 | pprintField drv DFlibraryPkgconfigDepends = pprintSet $ setOf (pkgconfig.folded.localName.ident) (drv^.libraryDepends) 407 | pprintField drv DFexecutablePkgconfigDepends = pprintSet $ setOf (pkgconfig.folded.localName.ident) (drv^.executableDepends) 408 | pprintField drv DFtestPkgconfigDepends = pprintSet $ setOf (pkgconfig.folded.localName.ident) (drv^.testDepends) 409 | pprintField drv DFbenchmarkPkgconfigDepends = pprintSet $ setOf (pkgconfig.folded.localName.ident) (drv^.benchmarkDepends) 410 | 411 | pprintField drv DFsetupToolDepends = pprintSet $ setOf (tool.folded.localName.ident) (drv^.setupDepends) 412 | pprintField drv DFlibraryToolDepends = pprintSet $ setOf (tool.folded.localName.ident) (drv^.libraryDepends) 413 | pprintField drv DFexecutableToolDepends = pprintSet $ setOf (tool.folded.localName.ident) (drv^.executableDepends) 414 | pprintField drv DFtestToolDepends = pprintSet $ setOf (tool.folded.localName.ident) (drv^.testDepends) 415 | pprintField drv DFbenchmarkToolDepends = pprintSet $ setOf (tool.folded.localName.ident) (drv^.benchmarkDepends) 416 | 417 | pprintField drv DFenableLibraryProfiling = bool $ drv^.enableLibraryProfiling 418 | pprintField drv DFenableExecutableProfiling = bool $ drv^.enableExecutableProfiling 419 | pprintField drv DFenableSplitObjs = bool $ drv^.enableSplitObjs 420 | pprintField drv DFdoHaddock = bool $ drv^.runHaddock 421 | pprintField drv DFjailbreak = bool $ drv^.jailbreak 422 | pprintField drv DFdoCheck = bool $ drv^.doCheck 423 | pprintField drv DFtestTarget = string $ drv^.testTarget 424 | pprintField drv DFhyperlinkSource = bool $ drv^.hyperlinkSource 425 | pprintField drv DFphaseOverrides = vcat $ (map text . lines) (drv^.phaseOverrides) 426 | 427 | pprintField drv DFmetaSectionHomepage = pPrint $ drv^.metaSection.homepage 428 | pprintField drv DFmetaSectionDescription = pPrint $ drv^.metaSection.description 429 | pprintField drv DFmetaSectionLicense = pPrint $ drv^.metaSection.license 430 | pprintField drv DFmetaSectionPlatforms = renderPlatforms "platforms" $ drv^.metaSection.platforms 431 | where 432 | -- Stolen from distribution-nixpkgs/src/Distribution/Nixpkgs/Meta.hs 433 | renderPlatforms ∷ String → Set.Set Platform → Doc 434 | renderPlatforms field ps 435 | | Set.null ps = sep [ text field <+> equals <+> text "stdenv.lib.platforms.none" Nix.<> semi ] 436 | | otherwise = sep [ text field <+> equals <+> lbrack 437 | , nest 2 $ fsep $ map text (toAscList (Set.map fromCabalPlatform ps)) 438 | , rbrack Nix.<> semi 439 | ] 440 | -- Stolen from distribution-nixpkgs/src/Distribution/Nixpkgs/Meta.hs 441 | fromCabalPlatform ∷ Platform → String 442 | fromCabalPlatform (Platform I386 Linux) = "\"i686-linux\"" 443 | fromCabalPlatform (Platform X86_64 Linux) = "\"x86_64-linux\"" 444 | fromCabalPlatform (Platform X86_64 OSX) = "\"x86_64-darwin\"" 445 | fromCabalPlatform p = error ("fromCabalPlatform: invalid Nix platform" ++ show p) 446 | pprintField drv DFmetaSectionMaintainers = (⊥) 447 | 448 | pprintSet ∷ Set.Set String → Doc 449 | pprintSet xs = fsep $ map text $ toAscList xs 450 | 451 | bool :: Bool -> Doc 452 | bool True = text "true" 453 | bool False = text "false" 454 | -------------------------------------------------------------------------------- /src/NH/Emission.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE GADTs #-} 7 | {-# LANGUAGE KindSignatures #-} 8 | {-# LANGUAGE LambdaCase #-} 9 | {-# LANGUAGE MultiParamTypeClasses #-} 10 | {-# LANGUAGE NamedFieldPuns #-} 11 | {-# LANGUAGE NoMonomorphismRestriction #-} 12 | {-# LANGUAGE OverloadedStrings #-} 13 | {-# LANGUAGE PackageImports #-} 14 | {-# LANGUAGE PartialTypeSignatures #-} 15 | {-# LANGUAGE RankNTypes #-} 16 | {-# LANGUAGE RecordWildCards #-} 17 | {-# LANGUAGE StandaloneDeriving #-} 18 | {-# LANGUAGE ScopedTypeVariables #-} 19 | {-# LANGUAGE TupleSections #-} 20 | {-# LANGUAGE TypeApplications #-} 21 | {-# LANGUAGE TypeFamilies #-} 22 | {-# LANGUAGE TypeInType #-} 23 | {-# LANGUAGE TypeOperators #-} 24 | {-# LANGUAGE UnicodeSyntax #-} 25 | {-# LANGUAGE UndecidableInstances #-} 26 | {-# LANGUAGE UndecidableSuperClasses #-} 27 | {-# LANGUAGE ViewPatterns #-} 28 | module NH.Emission 29 | where 30 | 31 | import Control.Exception 32 | import Control.Lens ((<&>)) 33 | import Control.Monad (foldM, forM, forM_, join, liftM, when) 34 | import Data.Coerce (Coercible, coerce) 35 | import Data.Foldable 36 | import Data.Functor.Identity 37 | import Data.Function ((&)) 38 | import Data.Hourglass (Seconds(..)) 39 | import Data.Hourglass.Epoch 40 | import qualified Data.List as L 41 | import Data.Map (Map) 42 | import qualified Data.Map as Map 43 | import Data.Maybe 44 | import Data.Set (Set) 45 | import qualified Data.Set as Set 46 | import Data.Text (Text, pack, unpack, toLower, toUpper, drop, take, length, isSuffixOf) 47 | import qualified Data.Text as T 48 | import qualified Data.Text.IO as Sys 49 | import qualified GHC.Types as Type 50 | import Prelude hiding (take, drop, length) 51 | import qualified Prelude as P 52 | import Prelude.Unicode 53 | import qualified System.Directory as Sys 54 | import qualified System.IO.Temp as Sys 55 | import qualified System.FilePath as Sys 56 | import Text.Printf 57 | 58 | import Data.Proxy 59 | import GHC.Generics (Generic) 60 | import qualified GHC.Generics as GHC 61 | import Generics.SOP (Rep, NS(..), NP(..), SOP(..), POP(..), I(..), K(..), Code, All, All2 62 | ,HasDatatypeInfo(..), DatatypeInfo(..), FieldName(..), FieldInfo(..), ConstructorInfo(..), SListI 63 | ,from, to, hcollapse, hcliftA2, hliftA, hcliftA, unI, hsequence, hcpure, hpure) 64 | import qualified Generics.SOP as SOP 65 | 66 | import Language.Nix.PrettyPrinting hiding ((<>), empty, Text) 67 | import Text.PrettyPrint.HughesPJClass ( Doc, Pretty(..), Style(..), Mode(..) 68 | , renderStyle, fsep, text, sep, fsep, lbrack, rbrack, lbrace, rbrace, lparen, rparen, empty 69 | , vcat, nest, doubleQuotes, semi, (<+>), ($+$), maybeParens) 70 | 71 | import qualified Language.Nix.PrettyPrinting as Nix 72 | 73 | import NH.Types 74 | import NH.Config 75 | import NH.FS 76 | import NH.Logic 77 | import NH.Misc 78 | import NH.MRecord 79 | import NH.Nix 80 | 81 | 82 | 83 | withTarget ∷ Flag Local → Doc → Doc 84 | withTarget ToNixpkgs body = funargs (text <$> ["pkgs", "haskellLib", "super", "self"]) $+$ "" $+$ 85 | text "with haskellLib;" $+$ "" $+$ 86 | text "self: super:" <+> lbrace $+$ 87 | body $+$ 88 | rbrace 89 | withTarget ToLocal body = funargs (text <$> ["pkgs", "haskellLib"]) $+$ "" $+$ 90 | text "with haskellLib; with self;" <+> lbrace $+$ 91 | body $+$ 92 | rbrace 93 | 94 | instance Pretty OverPackage where 95 | pPrint o@OverPackage{opAttr 96 | ,opMeta=opMeta@Meta{..} 97 | ,opOver=opOver@Overrides{..} 98 | ,opNixpkgs 99 | } = 100 | let attrStr = unpack ∘ fromAttr 101 | attrDoc = text ∘ attrStr 102 | ovEmpty = opOver ≡ mempty 103 | ovJustSrc = not ovEmpty ∧ opOver { ovSrc=Nothing } ≡ mempty 104 | (shadowed, baseAttr) = case (isJust ovSrc, overShadowed o) of 105 | (True, Just shadow) → (,) True shadow 106 | _ → (,) False opAttr 107 | status = overStatus o 108 | generalExpl = statusExplanation status 109 | srcExpl = mempty -- XXX "emit_explanation src ${attr} | prefix_lines \" ## \"" 110 | inputOver = if ovInputs ≡ mempty then mempty else 111 | vcat 112 | [ text ".override" <+> lbrace 113 | , nest 2 $ vcat $ Map.toList ovInputs <&> 114 | \(Attr from, Attr to) → attr (unpack from) (text $ unpack to) 115 | , rbrace <> semi] 116 | 117 | in if meDisable ≡ DisableOverride ∨ ovEmpty then mempty else 118 | if opOver ≡ mempty ∨ (ovJustSrc ∧ not shadowed) 119 | then (if ovJustSrc then srcExpl else mempty) 120 | $+$ 121 | attr (attrStr opAttr) ("super." <> attrDoc baseAttr <> inputOver) 122 | -- else attr (attrStr opAttr) $ (maybeParens (ovInputs ≢ mempty) $ sep $ 123 | else vcat $ -- XXX inputs need parens: 124 | [ attr (attrStr opAttr) (("overrideCabal super."<>attrDoc baseAttr) <+> "(drv: {") 125 | , nest 2 ∘ vcat $ 126 | mapFields @Override -- for p in "src doCheck doHaddock jailbreak editedCabalFile revision postPatch ${EXTRA_PROPS_HANDLED_EXTRAED} patches" 127 | (\fieldName fieldVal→ vcat ∘ concat $ flip mapOverride fieldVal $ 128 | \leaf→ if overrideEnabled leaf 129 | then emitOverride (Field fieldName) mempty leaf 130 | else []) 131 | opOver 132 | , "})" <> inputOver 133 | ] 134 | 135 | ovAssign ∷ Field → Doc → Doc 136 | ovAssign (Field fi) = attr (unpack ∘ fromField $ toField (Proxy @OverPackage) fi) 137 | 138 | ovAssign1 ∷ Field → Doc → [Doc] 139 | ovAssign1 f = (:[]) ∘ ovAssign f 140 | 141 | class Override a where 142 | overrideEnabled ∷ a → Bool 143 | emitOverride ∷ Field → Doc → a → [Doc] 144 | 145 | instance Override Src where 146 | overrideEnabled _ = True 147 | emitOverride fi p Github{..} = ovAssign1 fi $ emitBlock' (p <+> "fetchFromGithub") 148 | [ attr "owner" ∘ string ∘ unpack $ fromUser ghUser 149 | , attr "repo" ∘ string ∘ unpack $ fromRepoName ghRepoName 150 | , attr "rev" ∘ string ∘ unpack $ fromRef ghRev 151 | , attr "sha256" ∘ string ∘ unpack $ fromNixHash srNixHash 152 | ] 153 | emitOverride _ p Hackage{..} = 154 | [ (attr "version" ∘ string ∘ unpack $ fromRelease haRelease) 155 | , (attr "sha256" ∘ string ∘ unpack $ fromNixHash srNixHash) 156 | ] 157 | 158 | instance Override a ⇒ Override (Maybe a) where 159 | overrideEnabled = isJust 160 | emitOverride _ _ Nothing = [] 161 | emitOverride f p (Just x) = emitOverride f p x 162 | instance CFlag (a ∷ Flags) ⇒ Override (Flag a) where 163 | overrideEnabled = toBool 164 | emitOverride f _ (toBool → True) = ovAssign1 f "true" 165 | emitOverride _ _ _ = [] 166 | instance Override DFValue where 167 | overrideEnabled = (≢ mempty) ∘ dfDoc 168 | emitOverride f _ x = ovAssign1 f $ dfDoc x 169 | instance Override [Patch] where 170 | overrideEnabled = (≢ mempty) 171 | emitOverride f p ps = ovAssign1 f $ 172 | emitList' (p <+> "(drv.patches or []) ++") $ 173 | [ lparen <> emitBlock' "pkgs.fetchpatch" 174 | [ attr "url" $ text $ unpack paUrl 175 | , attr "sha256" $ text $ unpack paSha256 176 | ] <> rparen 177 | | Patch{..} ← ps ] 178 | instance (Eq k, Eq v, Ord k) ⇒ Override (Map k v) where 179 | overrideEnabled = (≢ mempty) 180 | emitOverride "ovDrvFields" _ m = [] 181 | emitOverride "ovInputs" p m = [] 182 | 183 | class MapOverride a where 184 | type OverElem a ∷ Type.Type 185 | mapOverride ∷ (OverElem a → b) → a → [b] 186 | 187 | instance {-# OVERLAPPABLE #-} MapOverride a where 188 | type OverElem a = a 189 | mapOverride f a = [f a] 190 | 191 | emitNest ∷ Doc → Doc → Doc → [Doc] → Doc 192 | emitNest l r pre body = foldl ($+$) mempty 193 | [ pre <+> l 194 | , nest 2 $ vcat $ body 195 | , r ] 196 | 197 | emitBlock', emitList' ∷ Doc → [Doc] → Doc 198 | emitBlock' = emitNest lbrace rbrace 199 | emitList' = emitNest lbrack rbrack 200 | 201 | emitBlock, emitList ∷ [Doc] → Doc 202 | emitBlock = emitBlock' mempty 203 | emitList = emitList' mempty 204 | 205 | 206 | 207 | instance Pretty Package where 208 | pPrint fd@Package{pkAttr 209 | ,pkUpstream=Upstream{..} 210 | ,pkMeta=pkMeta@Meta{..} 211 | ,pkOver=Overrides{ovSrc=movSrc@(Just Github{..}),ovDrvFields} 212 | ,pkDrvMeta=DrvMeta{..} 213 | ,pkDrvFields} = 214 | vcat 215 | [ text "with pkgs;" <+> text "with self;" <+> text "mkDerivation" <+> lbrace 216 | , text " " 217 | , nest 2 $ vcat $ 218 | [ attr "pname" ∘ string ∘ unpack $ fromAttr pkAttr 219 | , attr "version" $ pkgDrvFieldMand fd DFversion ] 220 | <> emitOverride "" ("src" <+> equals) (fromJust movSrc) <> 221 | [ maybeAttr "postUnpack" (meChdir <&> (\cd→ string ("sourceRoot+=/" <> unpack cd <> "; echo source root reset to $sourceRoot"))) 222 | , maybeAttr "configureFlags" $ pkgDrvField fd DFconfigureFlags 223 | , maybeAttr "isLibrary" $ pkgDrvField fd DFisLibrary 224 | , maybeAttr "isExecutable" $ pkgDrvField fd DFisExecutable 225 | , maybeAttr "enableSeparateDataOutput" $ pkgDrvField fd DFenableSeparateDataOutput 226 | 227 | , maybeAttr' "setupHaskellDepends" $ pkgDrvField fd DFsetupHaskellDepends 228 | , maybeAttr' "libraryHaskellDepends" $ pkgDrvField fd DFlibraryHaskellDepends 229 | , maybeAttr' "executableHaskellDepends" $ pkgDrvField fd DFexecutableHaskellDepends 230 | , maybeAttr' "testHaskellDepends" $ pkgDrvField fd DFtestHaskellDepends 231 | , maybeAttr' "benchmarkHaskellDepends" $ pkgDrvField fd DFbenchmarkHaskellDepends 232 | 233 | , maybeAttr' "setupSystemDepends" $ pkgDrvField fd DFsetupSystemDepends 234 | , maybeAttr' "librarySystemDepends" $ pkgDrvField fd DFlibrarySystemDepends 235 | , maybeAttr' "executableSystemDepends" $ pkgDrvField fd DFexecutableSystemDepends 236 | , maybeAttr' "testSystemDepends" $ pkgDrvField fd DFtestSystemDepends 237 | , maybeAttr' "benchmarkSystemDepends" $ pkgDrvField fd DFbenchmarkSystemDepends 238 | 239 | , maybeAttr' "setupPkgconfigDepends" $ pkgDrvField fd DFsetupPkgconfigDepends 240 | , maybeAttr' "libraryPkgconfigDepends" $ pkgDrvField fd DFlibraryPkgconfigDepends 241 | , maybeAttr' "executablePkgconfigDepends" $ pkgDrvField fd DFexecutablePkgconfigDepends 242 | , maybeAttr' "testPkgconfigDepends" $ pkgDrvField fd DFtestPkgconfigDepends 243 | , maybeAttr' "benchmarkPkgconfigDepends" $ pkgDrvField fd DFbenchmarkPkgconfigDepends 244 | 245 | , maybeAttr' "setupToolDepends" $ pkgDrvField fd DFsetupToolDepends 246 | , maybeAttr' "libraryToolDepends" $ pkgDrvField fd DFlibraryToolDepends 247 | , maybeAttr' "executableToolDepends" $ pkgDrvField fd DFexecutableToolDepends 248 | , maybeAttr' "testToolDepends" $ pkgDrvField fd DFtestToolDepends 249 | , maybeAttr' "benchmarkToolDepends" $ pkgDrvField fd DFbenchmarkToolDepends 250 | 251 | , maybeAttr "enableLibraryProfiling" $ pkgDrvField fd DFenableLibraryProfiling 252 | , maybeAttr "enableExecutableProfiling" $ pkgDrvField fd DFenableExecutableProfiling 253 | , maybeAttr "enableSplitObjs" $ pkgDrvField fd DFenableSplitObjs 254 | , maybeAttr "doHaddock" $ Nothing -- Over{..} 255 | , maybeAttr "jailbreak" $ Nothing -- Over{..} 256 | , maybeAttr "doCheck" $ Nothing -- Over{..} 257 | , maybeAttr "testTarget" $ pkgDrvField fd DFtestTarget 258 | , maybeAttr "hyperlinkSource" $ pkgDrvField fd DFhyperlinkSource 259 | -- XXX: not really sure how to handle this 260 | -- , maybeAttr "phaseOverrides" $ (vcat ∘ (map text . lines) <$> pkgDrvField ed DFphaseOverrides) 261 | , maybeAttr "homepage" $ text ∘ unpack <$> dmHomepage 262 | , maybeAttr "description" $ text ∘ unpack <$> dmDescription 263 | , attr "license" $ text $ unpack dmLicense 264 | , maybeAttr "platforms" $ text ∘ unpack <$> dmPlatforms 265 | , maybeAttr "maintainers" $ text ∘ unpack <$> dmMaintainers 266 | ] 267 | , rbrace 268 | ] 269 | pPrint _ = error "Cannot pretty-print a package with no Github specified." 270 | 271 | 272 | -- 273 | -- * Aux code for emission 274 | -- 275 | pkgDrvField ∷ Package → DrvField → Maybe Doc 276 | pkgDrvField Package{..} fname = dfDoc <$> Map.lookup fname pkDrvFields 277 | 278 | pkgDrvFieldOpt ∷ Package → DrvField → Doc 279 | pkgDrvFieldOpt fd fname = pkgDrvField fd fname & 280 | fromMaybe empty 281 | 282 | pkgDrvFieldMand ∷ Package → DrvField → Doc 283 | pkgDrvFieldMand fd fname = pkgDrvField fd fname & 284 | (errNothing $ printf "Missing definition passfield '%s'." $ show fname) 285 | 286 | maybeAttr ∷ Field → Maybe Doc → Doc 287 | maybeAttr _ Nothing = empty 288 | maybeAttr (Field field) (Just doc) = attr (unpack field) doc 289 | 290 | maybeAttr' ∷ Field → Maybe Doc → Doc 291 | maybeAttr' _ Nothing = empty 292 | maybeAttr' (Field field) (Just doc) = vcat 293 | [ text (unpack field) <+> equals <+> lbrack 294 | , nest 2 doc 295 | , rbrack <> semi ] 296 | -------------------------------------------------------------------------------- /src/NH/FS.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE GADTs #-} 7 | {-# LANGUAGE KindSignatures #-} 8 | {-# LANGUAGE LambdaCase #-} 9 | {-# LANGUAGE MultiParamTypeClasses #-} 10 | {-# LANGUAGE NamedFieldPuns #-} 11 | {-# LANGUAGE NoMonomorphismRestriction #-} 12 | {-# LANGUAGE OverloadedStrings #-} 13 | {-# LANGUAGE PackageImports #-} 14 | {-# LANGUAGE PartialTypeSignatures #-} 15 | {-# LANGUAGE RankNTypes #-} 16 | {-# LANGUAGE RecordWildCards #-} 17 | {-# LANGUAGE RecursiveDo #-} 18 | {-# LANGUAGE StandaloneDeriving #-} 19 | {-# LANGUAGE ScopedTypeVariables #-} 20 | {-# LANGUAGE TupleSections #-} 21 | {-# LANGUAGE TypeApplications #-} 22 | {-# LANGUAGE TypeFamilies #-} 23 | {-# LANGUAGE TypeInType #-} 24 | {-# LANGUAGE TypeOperators #-} 25 | {-# LANGUAGE UnicodeSyntax #-} 26 | {-# LANGUAGE UndecidableInstances #-} 27 | {-# LANGUAGE UndecidableSuperClasses #-} 28 | {-# LANGUAGE ViewPatterns #-} 29 | {-# LANGUAGE OverloadedStrings #-} 30 | {-# LANGUAGE RecordWildCards #-} 31 | {-# LANGUAGE UnicodeSyntax #-} 32 | 33 | module NH.FS 34 | ( init, validate 35 | , PKGDBSpec(..) 36 | , list, listCtx, listField', listField 37 | , has 38 | , read 39 | , write, rm 40 | ) 41 | where 42 | 43 | import GHC.Stack 44 | 45 | import Control.Exception 46 | import Control.Lens ((<&>)) 47 | import Control.Monad (foldM, forM, forM_, join, liftM, when) 48 | import Data.Coerce (Coercible, coerce) 49 | import Data.Functor.Identity 50 | import Data.Function ((&)) 51 | import Data.Hourglass (Seconds(..)) 52 | import Data.Hourglass.Epoch 53 | import qualified Data.List as L 54 | import Data.Map (Map) 55 | import qualified Data.Map as Map 56 | import Data.Maybe 57 | import Data.Set (Set) 58 | import qualified Data.Set as Set 59 | import Data.Text (Text, pack, unpack, toLower, toUpper, drop, take, length, isSuffixOf, isPrefixOf) 60 | import qualified Data.Text as T 61 | import qualified Data.Text.IO as Sys 62 | import qualified GHC.Types as Type 63 | import Prelude hiding (read, take, drop, init, length) 64 | import qualified Prelude as P 65 | import Prelude.Unicode 66 | import qualified System.Directory as Sys 67 | import qualified System.IO.Temp as Sys 68 | import qualified System.FilePath as Sys 69 | import Text.Printf 70 | 71 | import Data.Proxy 72 | import GHC.Generics (Generic) 73 | import qualified GHC.Generics as GHC 74 | import Generics.SOP (Rep, NS(..), NP(..), SOP(..), POP(..), I(..), K(..), Code, All, All2 75 | ,HasDatatypeInfo(..), DatatypeInfo(..), FieldName(..), FieldInfo(..), ConstructorInfo(..), SListI 76 | ,from, to, hcollapse, hcliftA2, hliftA, hcliftA, unI, hsequence, hcpure, hpure) 77 | import qualified Generics.SOP as SOP 78 | 79 | import Language.Nix.PrettyPrinting hiding ((<>), empty, Text) 80 | import Text.PrettyPrint.HughesPJClass ( Doc, Pretty(..), Style(..), Mode(..) 81 | , renderStyle, fsep, text, sep, fsep, lbrack, rbrack, lbrace, rbrace, empty 82 | , vcat, nest, doubleQuotes, (<+>), semi) 83 | import qualified Text.Read as R 84 | import qualified Debug.Trace as DBG 85 | 86 | import NH.MRecord 87 | import NH.Types 88 | import NH.Misc 89 | import qualified NH.Nix as Nix 90 | 91 | 92 | 93 | () ∷ Text → Text → Text 94 | l r = l <> T.singleton Sys.pathSeparator <> r 95 | 96 | (<.>) ∷ Text → Text → Text 97 | l <.> r = l <> T.singleton '.' <> r 98 | 99 | 100 | 101 | init ∷ [CName] → Text → IO PKGDB 102 | init allCNames path = Sys.withSystemTempDirectory "nh-temp" $ 103 | \(( "new") ∘ pack → assyPath) → do 104 | initDBat $ unpack path 105 | -- Unfortunately, the create-then-rename trick is useless, 106 | -- as /tmp is often on a different filesystem from the target. 107 | -- And so the move is neither atomic, neither supported by renamePath. 108 | -- 109 | -- Sys.renamePath (unpack assyPath) (unpack pkgdbPath) 110 | pkgdbNixpkgs ← Nix.getNixpkgs 111 | let pkgdbPath = PKGDBPath path 112 | pure PKGDB{..} 113 | where 114 | initDBat dir = do 115 | -- Yes, the below check isn't atomic, so is an integrity risk. 116 | -- Unfortunately, see above message. 117 | Sys.doesPathExist dir >>= flip when 118 | (error$printf "Cannot init PKGDB at busy path: %s" dir) 119 | Sys.createDirectory dir 120 | forM_ allCNames $ \(CName cn)→ 121 | Sys.createDirectory $ dir Sys. unpack cn 122 | 123 | newtype PKGDBSpec = FSDBPath { fromFSDBPath ∷ Text } 124 | 125 | validate ∷ [CName] → PKGDBSpec → IO Bool 126 | validate allCNames (FSDBPath path) = 127 | foldM (\acc sub→ (acc ∧) <$> Sys.doesDirectoryExist (unpack $ path sub)) 128 | True (fromCName <$> allCNames) 129 | 130 | cnPath ∷ PKGDB → CName → Text 131 | cnPath PKGDB{pkgdbPath=(PKGDBPath path)} (CName cn) = path cn 132 | 133 | path ∷ CName → CtxName → Field → PKGDB → Text 134 | path cn (CtxName en) (Field fi) db = 135 | cnPath db cn en <.> fi 136 | 137 | read ∷ CName → CtxName → Field → PKGDB → IO (Maybe Text) 138 | read cn en fi db = do 139 | let p = unpack $ path cn en fi db 140 | (∃) ← Sys.doesFileExist p 141 | if (∃) 142 | then Just <$> Sys.readFile p 143 | else do 144 | -- putStrLn $ "missing field: "<>show ty<>"/"<>unpack (fromField fi)<>" at " <>show p 145 | pure Nothing 146 | 147 | parse ∷ SimpleToken a ⇒ CName → CtxName → Field → PKGDB → IO (Maybe a) 148 | parse cn en fi db = do 149 | join ∘ (diagReadCaseInsensitive <$>) <$> read cn en fi db 150 | 151 | has ∷ CName → CtxName → Field → PKGDB → IO Bool 152 | has cn en fi db = do 153 | let p = unpack $ path cn en fi db 154 | Sys.doesFileExist p 155 | 156 | rm ∷ CName → CtxName → Field → PKGDB → IO () 157 | rm cn en fi db = removeFileIfExists $ path cn en fi db 158 | 159 | write ∷ CName → CtxName → Field → Maybe Text → PKGDB → IO () 160 | write cn en fi mval db = do 161 | let fpath = unpack $ path cn en fi db 162 | fileExists ← Sys.doesFileExist fpath 163 | case (fileExists, mval) of 164 | (False, Nothing) → pure () 165 | (True, Nothing) → Sys.removeFile fpath 166 | (_, Just v) → do 167 | dirExists ← Sys.doesDirectoryExist $ unpack $ cnPath db cn 168 | if dirExists 169 | then Sys.writeFile fpath v 170 | else errorT $ "Malformed PKGDB: structural subdir doesn't exist: " <> cnPath db cn 171 | 172 | listCName ∷ CName → PKGDB → IO [Text] 173 | listCName cn db = do 174 | (T.pack <$>) <$> Sys.listDirectory (unpack $ cnPath db cn) 175 | 176 | list ∷ CName → PKGDB → IO (Set CtxName) 177 | list cn db = do 178 | fulls ← listCName cn db 179 | let split = T.splitOn "." <$> fulls 180 | names = (!! 0) <$> split 181 | pure $ CtxName <$> (Set.delete "" $ Set.fromList names) 182 | 183 | listCtx ∷ CName → CtxName → PKGDB → IO [Text] 184 | listCtx cn (CtxName en) db = listCName cn db <&> 185 | (drop (length en + 1) <$>) ∘ filter (T.isPrefixOf (en <> ".")) 186 | 187 | listField' ∷ CName → CtxName → Field → PKGDB → IO [Text] 188 | listField' cn en (Field f) db = 189 | filter (T.isPrefixOf (f <> ".")) <$> listCtx cn en db 190 | 191 | listField ∷ CName → CtxName → Field → PKGDB → IO [Text] 192 | listField cn en fi@(Field f) = 193 | ((drop (length f + 1) <$>) <$>) ∘ listField' cn en fi 194 | 195 | 196 | 197 | data MetaF 198 | = MSuppressShadow 199 | | MDisable 200 | | MChdir 201 | | MRepoName 202 | | MExplanation Field 203 | | MERDeps 204 | deriving (Eq, Show) 205 | 206 | -- metaPath ∷ Attr → MetaF → PKGDB → Text 207 | -- metaPath at mf db = 208 | -- path cnMeta (attrCtx at) (metaField mf) db 209 | -- where metaField ∷ MetaF → Field 210 | -- metaField MRepoName = Field "repoName" 211 | -- metaField (MExplanation (Field x)) = Field $ x <> ".explanation" 212 | -- metaField x = Field $ lowerShowT x 213 | -------------------------------------------------------------------------------- /src/NH/Github.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | {-# LANGUAGE UnicodeSyntax #-} 4 | module NH.Github 5 | where 6 | 7 | import Data.Char 8 | import Data.Foldable 9 | import qualified Data.List as L 10 | import Data.Maybe 11 | import Data.String 12 | import Data.Text (pack, unpack) 13 | import qualified Data.Text as T 14 | import Data.Text.Format hiding (print) 15 | 16 | import NH.Types 17 | import NH.Config 18 | 19 | 20 | 21 | githubURLComponents ∷ URL → (GithubUser, Repo) 22 | githubURLComponents (URL text) = 23 | let pieces = T.splitOn "/" text 24 | in (,) 25 | (GithubUser $ pieces !! 3) 26 | (Repo $ pieces !! 4) 27 | -------------------------------------------------------------------------------- /src/NH/Logic.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE GADTs #-} 7 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 8 | {-# LANGUAGE KindSignatures #-} 9 | {-# LANGUAGE LambdaCase #-} 10 | {-# LANGUAGE MultiParamTypeClasses #-} 11 | {-# LANGUAGE NamedFieldPuns #-} 12 | {-# LANGUAGE NoMonomorphismRestriction #-} 13 | {-# LANGUAGE OverloadedStrings #-} 14 | {-# LANGUAGE PackageImports #-} 15 | {-# LANGUAGE PartialTypeSignatures #-} 16 | {-# LANGUAGE RankNTypes #-} 17 | {-# LANGUAGE RecordWildCards #-} 18 | {-# LANGUAGE StandaloneDeriving #-} 19 | {-# LANGUAGE ScopedTypeVariables #-} 20 | {-# LANGUAGE TupleSections #-} 21 | {-# LANGUAGE TypeApplications #-} 22 | {-# LANGUAGE TypeFamilies #-} 23 | {-# LANGUAGE TypeInType #-} 24 | {-# LANGUAGE TypeOperators #-} 25 | {-# LANGUAGE UnicodeSyntax #-} 26 | {-# LANGUAGE UndecidableInstances #-} 27 | {-# LANGUAGE UndecidableSuperClasses #-} 28 | {-# LANGUAGE ViewPatterns #-} 29 | module NH.Logic 30 | where 31 | 32 | import Control.Exception 33 | import Control.Lens ((<&>)) 34 | import Control.Monad (foldM, forM, forM_, join, liftM, when) 35 | import Data.Coerce (Coercible, coerce) 36 | import Data.Functor.Identity 37 | import Data.Function ((&)) 38 | import Data.Hourglass (Seconds(..)) 39 | import Data.Hourglass.Epoch 40 | import qualified Data.List as L 41 | import Data.Map (Map) 42 | import qualified Data.Map as Map 43 | import Data.Maybe 44 | import Data.Set (Set) 45 | import qualified Data.Set as Set 46 | import Data.Text (Text, pack, unpack, toLower, toUpper, drop, take, length, isSuffixOf, isPrefixOf) 47 | import qualified Data.Text as T 48 | import qualified Data.Text.IO as Sys 49 | import qualified GHC.Types as Type 50 | import Prelude hiding (read, take, drop, length) 51 | import qualified Prelude as P 52 | import Prelude.Unicode 53 | import qualified System.Directory as Sys 54 | import qualified System.IO.Temp as Sys 55 | import qualified System.FilePath as Sys 56 | import Text.Printf 57 | 58 | import Data.Proxy 59 | import GHC.Generics (Generic) 60 | import qualified GHC.Generics as GHC 61 | import Generics.SOP (Rep, NS(..), NP(..), SOP(..), POP(..), I(..), K(..), Code, All, All2 62 | ,HasDatatypeInfo(..), DatatypeInfo(..), FieldName(..), FieldInfo(..), ConstructorInfo(..), SListI 63 | ,from, to, hcollapse, hcliftA2, hliftA, hcliftA, unI, hsequence, hcpure, hpure) 64 | import qualified Generics.SOP as SOP 65 | 66 | import Language.Nix.PrettyPrinting hiding ((<>), empty, Text) 67 | import Text.PrettyPrint.HughesPJClass ( Doc, Pretty(..), Style(..), Mode(..) 68 | , renderStyle, fsep, text, sep, fsep, lbrack, rbrack, lbrace, rbrace, empty 69 | , vcat, nest, doubleQuotes, (<+>), semi) 70 | import qualified Text.Read as R 71 | import qualified Debug.Trace as DBG 72 | 73 | import NH.Types 74 | import NH.Config 75 | import NH.Derivation as Drv 76 | import qualified NH.FS as FS 77 | import NH.FS hiding (open, init) 78 | import NH.Misc 79 | import NH.MRecord 80 | import NH.Nix 81 | import NH.PKGDB 82 | 83 | 84 | 85 | attrRepoName ∷ Attr → Meta → RepoName 86 | attrRepoName (Attr name) Meta{..} = RepoName name 87 | 88 | 89 | 90 | overShadowed ∷ OverPackage → Maybe Attr 91 | overShadowed OverPackage{opOver=Overrides{ovSrc=Just Hackage{..}}, ..} = 92 | attrShadowedAt opAttr haRelease opNixpkgs 93 | overShadowed _ = Nothing 94 | 95 | overStatus ∷ OverPackage → Status 96 | overStatus op@OverPackage{opOver=opOver@Overrides{..}, ..} = do 97 | case (ovSrc, opUpstream) of 98 | (Just Hackage{..}, _) → 99 | if isJust $ overShadowed op 100 | then StShadowed 101 | else StHackaged 102 | (Just Github{..}, Just Upstream{..}) → 103 | case (opOver ≡ mempty, upUser ≡ ghUser) of 104 | (True, _) → StConfig 105 | (_, True) → StUpstreamed 106 | (_, False) → StUnmerged 107 | (Just Github{..}, Nothing) → 108 | error $ printf "Malformed package '%s': source overridden, but no upstream associated." (unpack $ fromAttr opAttr) 109 | (Nothing, _) → 110 | if opOver ≡ mempty 111 | then StConfig 112 | else StDefault 113 | 114 | statusExplanation ∷ Status → Text 115 | statusExplanation StShadowed = "Needs bump to a versioned attribute" 116 | statusExplanation StHackaged = "On Hackage, awaiting for import" 117 | statusExplanation StUpstreamed = "Upstreamed, awaiting a Hackage release" 118 | statusExplanation StUnmerged = "Unmerged. PR: $(url upstream-pull-request ${attr})" 119 | statusExplanation StConfig = "Non-source change" 120 | -------------------------------------------------------------------------------- /src/NH/MRecord.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE ConstraintKinds #-} 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE DefaultSignatures #-} 5 | {-# LANGUAGE DeriveGeneric #-} 6 | {-# LANGUAGE FlexibleContexts #-} 7 | {-# LANGUAGE FlexibleInstances #-} 8 | {-# LANGUAGE GADTs #-} 9 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 10 | {-# LANGUAGE KindSignatures #-} 11 | {-# LANGUAGE LambdaCase #-} 12 | {-# LANGUAGE MultiParamTypeClasses #-} 13 | {-# LANGUAGE NamedFieldPuns #-} 14 | {-# LANGUAGE NoMonomorphismRestriction #-} 15 | {-# LANGUAGE OverloadedStrings #-} 16 | {-# LANGUAGE PackageImports #-} 17 | {-# LANGUAGE PartialTypeSignatures #-} 18 | {-# LANGUAGE RankNTypes #-} 19 | {-# LANGUAGE RecordWildCards #-} 20 | {-# LANGUAGE StandaloneDeriving #-} 21 | {-# LANGUAGE ScopedTypeVariables #-} 22 | {-# LANGUAGE TupleSections #-} 23 | {-# LANGUAGE TypeApplications #-} 24 | {-# LANGUAGE TypeFamilies #-} 25 | {-# LANGUAGE TypeInType #-} 26 | {-# LANGUAGE TypeOperators #-} 27 | {-# LANGUAGE UnicodeSyntax #-} 28 | {-# LANGUAGE UndecidableInstances #-} 29 | {-# LANGUAGE UndecidableSuperClasses #-} 30 | {-# LANGUAGE ViewPatterns #-} 31 | module NH.MRecord 32 | where 33 | 34 | import Control.Exception 35 | import Control.Lens ((<&>)) 36 | import Control.Monad (foldM, forM, forM_, join, liftM, when) 37 | import Data.Functor.Identity 38 | import Data.Function ((&)) 39 | import Data.Bool 40 | import qualified Data.List as L 41 | import Data.Map (Map) 42 | import qualified Data.Map as Map 43 | import Data.Maybe 44 | import Data.Set (Set) 45 | import qualified Data.Set as Set 46 | import Data.String 47 | import Data.Text (Text, pack, unpack, toLower, toUpper, drop, take, length, isSuffixOf) 48 | import qualified Data.Text as T 49 | import Data.Typeable 50 | import qualified GHC.Types as Type 51 | import Prelude hiding (read, take, drop, length) 52 | import Prelude.Unicode 53 | import Text.Printf 54 | 55 | import Data.Proxy 56 | import GHC.Generics (Generic) 57 | import qualified GHC.Generics as GHC 58 | import GHC.Stack 59 | import Generics.SOP (Rep, NS(..), NP(..), SOP(..), POP(..), I(..), K(..), Code, All, All2 60 | ,HasDatatypeInfo(..), DatatypeInfo(..), FieldName(..), FieldInfo(..), ConstructorInfo(..), SListI 61 | ,from, to, hcollapse, hcliftA2, hliftA, hcliftA, unI, hsequence, hcpure, hpure) 62 | import qualified Generics.SOP as SOP 63 | import qualified Generics.SOP.NS as SOP 64 | 65 | import Debug.Trace (trace) 66 | 67 | 68 | 69 | data NConstructorInfo xs where 70 | NC ∷ ConstructorInfo xs → Int → NConstructorInfo xs 71 | 72 | enumerate ∷ SListI xs ⇒ NP ConstructorInfo xs → NP NConstructorInfo xs 73 | enumerate cs = SOP.hliftA2 (\c (K n)→ NC c n) cs (fromJust $ SOP.fromList $ L.take (SOP.lengthSList cs) [0..]) 74 | 75 | mapFields ∷ ∀ cst a c xs. (SOP.Generic a, SOP.HasDatatypeInfo a, Code a ~ '[xs], All cst xs) 76 | ⇒ (∀ b . cst b ⇒ Text → b → c) → a → [c] 77 | mapFields f x = case datatypeInfo (Proxy ∷ Proxy a) of 78 | (ADT _ _ ((Record _ fi) :* Nil)) → 79 | hcollapse $ hcliftA2 (Proxy ∷ Proxy cst) 80 | (\(FieldInfo fi) (I val)→ 81 | K $ f (pack fi) val) 82 | (fi ∷ NP FieldInfo xs) 83 | (SOP.unZ ∘ SOP.unSOP $ from x) 84 | _ → error "Non-ADTs/non-Records/sums not supported." 85 | 86 | data A = A { a ∷ String, b ∷ Int } deriving (Show, GHC.Generic) 87 | instance SOP.Generic A 88 | instance SOP.HasDatatypeInfo A 89 | x = mapFields @Show (\fi val→ fi<>": "<>pack (show val)) $ A "a" 1 90 | 91 | -- mapFields ∷ ∀ cst a c xs. (SOP.Generic a, SOP.HasDatatypeInfo a, Code a ~ '[xs], All cst xs) 92 | -- ⇒ (∀ b . cst b ⇒ b → c) → a → [c] 93 | -- mapFields f x = case datatypeInfo (Proxy ∷ Proxy a) of 94 | -- info@(ADT _ _ ((Record _ _) :* Nil)) → 95 | -- hcollapse $ hcliftA (Proxy ∷ Proxy cst) (\(I x)→ K $ f x) (SOP.unZ ∘ SOP.unSOP $ from x) 96 | -- _ → error "Non-ADTs/non-Records/sums not supported." 97 | 98 | 99 | 100 | type family ConsCtx ctx ∷ Type.Type 101 | 102 | class Ctx ctx where 103 | errCtxDesc ∷ ctx → ConsCtx ctx → Field → Text 104 | dropField ∷ ctx → ConsCtx ctx → Field → IO () 105 | --hasField ∷ ctx → ConsCtx ctx → Field → IO Bool -- useless for presenceByField 106 | listFields ∷ ctx → ConsCtx ctx → IO [Field] 107 | -- * 108 | errCtxDesc _ _ (Field f) = "field '"<>f<>"'" 109 | 110 | class Record a where 111 | prefixChars ∷ Proxy a → Int 112 | nameMap ∷ Proxy a → [(Text, Text)] 113 | toField ∷ Proxy a → Text → Field 114 | -- * 115 | nameMap = const [] 116 | toField r x = --trace (T.unpack x <> "→" <> T.unpack (maybeRemap $ dropDetitle (prefixChars r) x)) $ 117 | Field $ maybeRemap $ dropDetitle (prefixChars r) x 118 | where maybeRemap x = maybe x id (lookup x $ nameMap r) 119 | dropDetitle ∷ Int → Text → Text 120 | dropDetitle n (drop 2 → x) = toLower (take 1 x) <> drop 1 x 121 | 122 | 123 | 124 | newtype Field = Field { fromField ∷ Text } deriving (Eq, IsString, Ord, Show) 125 | 126 | type ADTChoiceT = Int 127 | type ADTChoice m xss = m ADTChoiceT 128 | -- type ADTChoice m xss = m (NS (K ()) xss) 129 | type ADTChoiceIO xss = ADTChoice IO xss 130 | 131 | class (SOP.Generic a, SOP.HasDatatypeInfo a, Ctx ctx, Record a) ⇒ CtxRecord ctx a where 132 | consCtx ∷ ctx → Proxy a → Text → ADTChoiceT → ConsCtx ctx 133 | -- * Defaulted methods 134 | presence ∷ ctx → Proxy a → IO Bool 135 | --presenceByField ∷ ctx → Proxy a → IO (Maybe Field) -- not clear how to implement generically -- what constructor to look at? 136 | restoreChoice ∷ HasCallStack 137 | ⇒ ctx → Proxy a → ADTChoiceIO xss 138 | saveChoice ∷ ctx → a → IO () 139 | ctxSwitch ∷ HasCallStack 140 | ⇒ Proxy a → ctx → IO ctx 141 | -- * Method defaults 142 | presence _ p = pure True 143 | restoreChoice _ _ = pure 0 144 | saveChoice _ _ = pure () 145 | ctxSwitch to ctx = pure ctx 146 | 147 | 148 | 149 | class Interpret a where 150 | -- XXX: sadly unused 151 | fromText ∷ Text → a 152 | toText ∷ a → Text 153 | 154 | class ReadField ctx a where 155 | readField ∷ HasCallStack ⇒ ctx → ConsCtx ctx → Field → IO (Maybe a) 156 | default readField ∷ (CtxRecord ctx a, Code a ~ xss, All2 (RestoreField ctx) xss, HasCallStack, Typeable a) 157 | ⇒ ctx → ConsCtx ctx → Field → IO (Maybe a) 158 | readField ctx _ _ = do 159 | let p = Proxy ∷ Proxy a 160 | newCtx ← ctxSwitch p ctx 161 | bool (pure Nothing) (Just <$> recover newCtx) =<< presence newCtx p 162 | 163 | class WriteField ctx a where 164 | writeField ∷ HasCallStack ⇒ ctx → ConsCtx ctx → Field → a → IO () 165 | default writeField ∷ (CtxRecord ctx a, Code a ~ xss, All2 (StoreField ctx) xss, HasCallStack) 166 | ⇒ ctx → ConsCtx ctx → Field → a → IO () 167 | writeField ctx _ _ x = store ctx x 168 | 169 | class Ctx ctx ⇒ 170 | RestoreField ctx a where 171 | restoreField ∷ HasCallStack ⇒ ctx → ConsCtx ctx → Field → IO a 172 | 173 | class StoreField ctx a where 174 | storeField ∷ HasCallStack ⇒ ctx → ConsCtx ctx → Field → a → IO () 175 | 176 | 177 | 178 | fieldError ∷ HasCallStack ⇒ Ctx ctx ⇒ ctx → ConsCtx ctx → Field → Text → b 179 | fieldError ctx cc field mesg = error $ unpack $ errCtxDesc ctx cc field <> ": " <> mesg 180 | 181 | 182 | 183 | instance {-# OVERLAPPABLE #-} (Ctx ctx, WriteField ctx a) ⇒ StoreField ctx a where 184 | storeField ctx cc fi x = writeField ctx cc fi x 185 | 186 | instance {-# OVERLAPPABLE #-} (Ctx ctx, ReadField ctx a) ⇒ RestoreField ctx a where 187 | restoreField ctx cc fi = trace ("restoreFi→readFi "<>unpack (fromField fi)) $ readField ctx cc fi 188 | <&> fromMaybe (fieldError ctx cc fi "mandatory field absent") 189 | 190 | instance (Ctx ctx, WriteField ctx a) ⇒ StoreField ctx (Maybe a) where 191 | storeField ctx cc fi Nothing = dropField ctx cc fi 192 | storeField ctx cc fi (Just x) = writeField ctx cc fi x 193 | 194 | instance (Ctx ctx, ReadField ctx a) ⇒ RestoreField ctx (Maybe a) where 195 | restoreField a b fi = trace ("restoreFi Maybe→readFi "<>unpack (fromField fi)) $ readField a b fi 196 | 197 | 198 | 199 | -- to ∷ Generic a => SOP I (Code a) → a 200 | -- SOP ∷ NS (NP f) xss → SOP f xss 201 | -- S ∷ NS a xs → NS a (x : xs) 202 | -- Z ∷ a x → NS a (x : xs) 203 | -- hcpure ∷ (AllN h c xs, HPure h) 204 | -- ⇒ proxy c → (forall a. c a ⇒ f a) → h f xs 205 | -- hsequence ∷ (SListIN h xs, SListIN (Prod h) xs, HSequence h, Applicative f) 206 | -- ⇒ h f xs → f (h I xs) 207 | -- hcollapse ∷ (SListIN h xs, HCollapse h) 208 | -- ⇒ h (K a) xs → CollapseTo h a 209 | -- hcliftA2 ∷ (AllN (Prod h) c xs, HAp h, HAp (Prod h)) 210 | -- ⇒ proxy c → (forall a. c a ⇒ f a → f' a → f'' a) 211 | -- → Prod h f xs → h f' xs → h f'' xs 212 | -- hcliftA ∷ (AllN (Prod h) c xs, HAp h) 213 | -- ⇒ proxy c → (forall a. c a ⇒ f a → f' a) → h f xs → h f' xs 214 | 215 | recover ∷ ∀ a ctx xss. (CtxRecord ctx a, HasDatatypeInfo a, Code a ~ xss, All2 (RestoreField ctx) xss, HasCallStack) 216 | ⇒ ctx → IO a 217 | recover ctx = do 218 | to <$> (hsequence =<< 219 | -- XXXXXXXXXXXXXXXXXXXX: so, here's the theory: 220 | -- a successful state loop needs an unobscured constructor to be returned, 221 | -- but this choice action does obscure it perfectly 222 | -- ... 223 | (!!) (SOP.apInjs_POP $ trace "SOP.apInjs_POP ← recover'" $ recover' p ctx (datatypeInfo p)) <$> pure 0 224 | -- XXXXXXXXXXXXXXXXXXXX: just pick 0'th: not much help 225 | --(trace "fmap ← restoreChoice" $ restoreChoice ctx p) 226 | ) 227 | -- indexNPbyNS (SOP.apInjs'_POP $ recover' p ctx $ datatypeInfo p) <$> (pure $ S(Z(K()))) 228 | where 229 | p = Proxy ∷ Proxy a 230 | indexNPbyNS ∷ SListI xss ⇒ NP (K (SOP f yss)) xss → NS (K ()) xss → SOP f yss 231 | indexNPbyNS np ns = hcollapse $ SOP.hliftA2 (\x (K ()) → x) np ns 232 | 233 | recover' ∷ ∀ a ctx xss. (CtxRecord ctx a, All2 (RestoreField ctx) xss, All SListI xss, HasCallStack) 234 | ⇒ Proxy a → ctx → DatatypeInfo xss → POP IO xss 235 | recover' proxy ctx (ADT _ name cs) = POP $ hcliftA (pAllRFields (Proxy ∷ Proxy ctx)) (recoverFor proxy ctx (pack name)) $ enumerate cs 236 | recover' _ _ _ = error "Non-ADTs not supported." 237 | 238 | recoverFor ∷ ∀ a ctx xs. (CtxRecord ctx a, All (RestoreField ctx) xs, HasCallStack) 239 | ⇒ Proxy a → ctx → Text → NConstructorInfo xs → NP IO xs 240 | recoverFor proxy ctx _ (NC (Record consName fis) consNr) = withNames proxy ctx (pack consName) consNr $ hliftA (K ∘ pack ∘ SOP.fieldName) fis 241 | recoverFor _ _ name _ = error $ printf "Non-Record (plain Constructor, Infix) ADTs not supported: type %s." (unpack name) 242 | 243 | withNames ∷ ∀ a ctx xs. (CtxRecord ctx a, All (RestoreField ctx) xs, SListI xs, HasCallStack) 244 | ⇒ Proxy a → ctx → Text → Int → NP (K Text) xs → NP IO xs 245 | withNames p ctx consName consNr (fs ∷ NP (K Text) xs) = hcliftA (pRField (Proxy ∷ Proxy ctx)) aux fs 246 | where 247 | aux ∷ RestoreField ctx f ⇒ K Text f → IO f 248 | aux (K "") = error "Empty field names not supported." 249 | aux (K fi) = 250 | trace ("withNames/aux ← restoreField "<>unpack fi<>"/"<>unpack consName) $ 251 | restoreField (trace ("restoreField ← ctx fi="<>unpack fi) ctx) 252 | (trace ("restoreField ← consCtx fi="<>unpack fi) $ consCtx ctx p consName consNr) 253 | (trace ("restoreField ← toField fi="<>unpack fi) $ toField p fi) 254 | 255 | store ∷ ∀ a ctx. (CtxRecord ctx a, All2 (StoreField ctx) (Code a), HasCallStack) 256 | ⇒ ctx → a → IO () 257 | store ctx x = do 258 | let di@(ADT _ _ cs) = case datatypeInfo (Proxy ∷ Proxy a) of 259 | x@ADT{} → x 260 | _ → error "Non-ADTs not supported." 261 | sequence_ $ store' ctx x (datatypeInfo (Proxy ∷ Proxy a)) (from x) 262 | when (SOP.lengthSList cs > 1) $ 263 | saveChoice ctx x 264 | 265 | store' ∷ (CtxRecord ctx a, All2 (StoreField ctx) xss, All SListI xss, HasCallStack) 266 | ⇒ ctx → a → DatatypeInfo xss → SOP I xss → [IO ()] 267 | store' ctx x (ADT _ _ cs) = store'' ctx x (enumerate cs) 268 | 269 | store'' ∷ ∀ a ctx xss. (CtxRecord ctx a, All2 (StoreField ctx) xss, All SListI xss, HasCallStack) 270 | ⇒ ctx → a → NP NConstructorInfo xss → SOP I xss → [IO ()] 271 | store'' ctx x info (SOP sop) = 272 | hcollapse $ hcliftA2 (pAllSFields (Proxy ∷ Proxy ctx)) (storeCtor ctx x) info sop 273 | 274 | storeCtor ∷ ∀ a ctx xs. (CtxRecord ctx a, All (StoreField ctx) xs, HasCallStack) 275 | ⇒ ctx → a → NConstructorInfo xs → NP I xs → K [IO ()] xs 276 | storeCtor ctx x (NC (Record consName fs) consNr) = K ∘ hcollapse ∘ hcliftA2 (pSField (Proxy ∷ Proxy ctx)) aux fs 277 | where 278 | p = Proxy ∷ Proxy a 279 | aux ∷ StoreField ctx f ⇒ FieldInfo f → I f → K (IO ()) f 280 | aux (FieldInfo fi) (I a) = K $ do 281 | storeField ctx (consCtx ctx p (pack consName) consNr) (toField p $ pack fi) a 282 | 283 | pRecord ∷ Proxy ctx → Proxy (CtxRecord ctx) 284 | pRecord _ = Proxy 285 | pRField ∷ Proxy ctx → Proxy (RestoreField ctx) 286 | pRField _ = Proxy 287 | pSField ∷ Proxy ctx → Proxy (StoreField ctx) 288 | pSField _ = Proxy 289 | pAllRFields ∷ Proxy ctx → Proxy (All (RestoreField ctx)) 290 | pAllRFields _ = Proxy 291 | pAllSFields ∷ Proxy ctx → Proxy (All (StoreField ctx)) 292 | pAllSFields _ = Proxy 293 | -------------------------------------------------------------------------------- /src/NH/Misc.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE ExistentialQuantification #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE KindSignatures #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | {-# LANGUAGE TypeInType #-} 9 | {-# LANGUAGE UnicodeSyntax #-} 10 | {-# LANGUAGE ViewPatterns #-} 11 | module NH.Misc 12 | where 13 | import Control.Applicative 14 | import Control.Monad.Plus 15 | import Data.Bool 16 | import qualified Data.Char 17 | import qualified Data.List as L 18 | import qualified Data.Map as Map 19 | import Data.Maybe (fromMaybe) 20 | import qualified Data.Text as T 21 | import Data.Text (Text, pack, unpack, take, drop, toLower, toUpper, length) 22 | import Prelude hiding (take, drop, length) 23 | import Prelude.Unicode 24 | import qualified System.Directory as Sys 25 | import qualified System.IO.Temp as Sys 26 | import qualified System.FilePath as Sys 27 | import qualified Text.Printf as T 28 | import qualified Text.Read.Lex as R 29 | import qualified Text.ParserCombinators.ReadP as R 30 | import Text.PrettyPrint.HughesPJClass (Doc, renderStyle, Mode(..), Style(..)) 31 | import qualified Turtle as Tu 32 | 33 | import GHC.Stack 34 | import qualified Debug.Trace as DBG 35 | 36 | 37 | 38 | echoT ∷ Text → IO () 39 | echoT = putStrLn ∘ unpack 40 | 41 | showT ∷ Show a ⇒ a → Text 42 | showT = pack ∘ show 43 | 44 | readT ∷ Read a ⇒ Text → a 45 | readT = read ∘ unpack 46 | 47 | lowerShowT ∷ Show a ⇒ a → Text 48 | lowerShowT = T.toLower . pack . show 49 | 50 | errorT ∷ HasCallStack ⇒ Text → a 51 | errorT = error . unpack 52 | 53 | every ∷ (Bounded a, Enum a) ⇒ [a] 54 | every = enumFromTo minBound maxBound 55 | 56 | (.:) ∷ ∀ a f g b. (b → a) → (f → g → b) → f → g → a 57 | (.:) = (.) ∘ (.) 58 | infixr 9 .: 59 | 60 | takeButLast ∷ Int → Text → Text 61 | takeButLast n t = take (length t - n) t 62 | 63 | revLookup ∷ (Eq a) ⇒ a → [(b,a)] → Maybe b 64 | revLookup i = let f (p,q) = (q,p) 65 | in lookup i ∘ map f 66 | 67 | -- from cognimeta-utils 68 | ifJust ∷ Bool → a → Maybe a 69 | ifJust = bool (const Nothing) Just 70 | 71 | -- from cognimeta-utils 72 | justIf ∷ a → Bool → Maybe a 73 | justIf = flip ifJust 74 | 75 | 76 | 77 | errNothing ∷ HasCallStack ⇒ String → Maybe a → a 78 | errNothing errMsg = fromMaybe (error errMsg) 79 | 80 | defineMaybe ∷ a → Maybe a → Maybe a 81 | defineMaybe x Nothing = Just x 82 | defineMaybe _ y = y 83 | 84 | 85 | 86 | -- XXX: factor 87 | readNames ∷ Text → [Text] 88 | readNames raw = loop [] (unpack raw) 89 | where 90 | loop acc s = 91 | case (s, R.readP_to_S R.hsLex s) of 92 | ("", _) -> reverse acc 93 | (_, (a, rem):_) -> loop (pack a:acc) rem 94 | 95 | readSequence ∷ Read a ⇒ Text → [a] 96 | readSequence raw = loop [] (unpack raw) 97 | where 98 | loop acc s = 99 | case (s, reads s) of 100 | ("", _) -> reverse acc 101 | (_, (a, rem):_) -> loop (a:acc) rem 102 | 103 | type SimpleToken a = (Bounded a, Enum a, Read a, Show a) 104 | 105 | diagReadCaseInsensitive ∷ HasCallStack ⇒ SimpleToken a ⇒ Text → Maybe a 106 | diagReadCaseInsensitive str = diagRead $ T.toLower str 107 | where mapping = Map.fromList [ (lowerShowT x, x) | x <- enumFromTo minBound maxBound ] 108 | diagRead x = Just $ flip fromMaybe (Map.lookup x mapping) 109 | (error $ T.printf ("Couldn't parse '%s' as one of: %s") 110 | str (unpack $ T.intercalate ", " $ Map.keys mapping)) 111 | 112 | 113 | 114 | newtype Desc = Desc Text deriving (Show) 115 | newtype Exec = Exec Text deriving (Show) 116 | newtype ShCmd = ShCmd Text deriving (Show) 117 | 118 | stdoutCall ∷ HasCallStack ⇒ Desc → Exec → [Text] → IO Text 119 | stdoutCall (Desc desc) (Exec cmd) args = do 120 | result ← Tu.procStrictWithErr cmd args empty 121 | pure $ case result of 122 | (Tu.ExitSuccess, out, _) → out 123 | (_, _, err) → errorT ("Failed to " <> desc <> " ('" <> cmd <> " " <> T.intercalate " " args <> "'): " <> err) 124 | 125 | stdoutCallSh ∷ HasCallStack ⇒ Desc → ShCmd → IO Text 126 | stdoutCallSh (Desc desc) (ShCmd cmd) = do 127 | result ← Tu.shellStrictWithErr cmd empty 128 | pure $ case result of 129 | (Tu.ExitSuccess, out, _) → out 130 | (_, _, err) → errorT ("Failed to " <> desc <> " ('" <> cmd <> "'): " <> err) 131 | 132 | 133 | 134 | {-# INLINE charMap #-} 135 | charMap ∷ Char → Char → Char → Char 136 | charMap from to ((≡ from) → True) = to 137 | charMap from to x = x 138 | 139 | showDocOneLine ∷ Doc → Text 140 | showDocOneLine = pack ∘ renderStyle (Style OneLineMode 1 1) 141 | 142 | 143 | 144 | -- * Flag machinery 145 | class (Bounded (Flag a), Eq (Flag a)) ⇒ CFlag a where 146 | data Flag a 147 | toBool ∷ (Flag a) → Bool 148 | toBool = (≡ enabled) 149 | fromBool ∷ Bool → (Flag a) 150 | fromBool x = if x then minBound else maxBound 151 | enabled, disabled ∷ (Flag a) 152 | enabled = minBound 153 | disabled = maxBound 154 | opposite ∷ Flag a → Flag a 155 | opposite = fromBool . not . toBool 156 | flagIf ∷ (Flag a) → b → b → b 157 | flagIf f true false = if toBool f then true else false 158 | -- XXX: most should be de-TC-ised, 159 | -- however, using TC's as poor-man's modules is so alluring.. 160 | 161 | enabledIsJust ∷ CFlag b ⇒ a → Flag b → Maybe a 162 | enabledIsJust x (toBool → True) = Just x 163 | enabledIsJust _ _ = Nothing 164 | 165 | -- flag ∷ Flag a ⇒ a → ArgName → Char → Optional HelpMessage → Parser a 166 | -- flag effect long ch help = (\case 167 | -- True → effect 168 | -- False → opposite effect) <$> switch long ch help 169 | 170 | 171 | 172 | removeFileIfExists ∷ Text → IO () 173 | removeFileIfExists fpath = 174 | Sys.doesFileExist (unpack fpath) >>= 175 | (flip when $ 176 | Sys.removeFile (unpack fpath)) 177 | -------------------------------------------------------------------------------- /src/NH/Nix.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | {-# LANGUAGE UnicodeSyntax #-} 5 | module NH.Nix 6 | where 7 | 8 | import Control.Lens hiding (argument) 9 | import Data.Foldable (find) 10 | import Data.Fix (Fix(..)) 11 | import qualified Data.List as L 12 | import qualified Data.Map as Map 13 | import Data.Set (Set) 14 | import qualified Data.Set as Set 15 | import Data.Set.Lens (setOf) 16 | import qualified Data.Text as T 17 | import Data.Text (Text, pack, unpack) 18 | import Prelude.Unicode 19 | 20 | import Nix.Eval 21 | import Nix.Expr 22 | import Nix.Parser 23 | import Nix.Pretty 24 | 25 | 26 | 27 | import NH.Misc 28 | import NH.Types 29 | 30 | 31 | 32 | data NixType 33 | = NTStr 34 | | NTPath 35 | | NTBool 36 | | NTInt 37 | | NTVar 38 | | NTList NixType 39 | | NTAttrset (Map.Map Text NixType) 40 | | NTFunction [NixType] NixType 41 | deriving (Eq, Ord, Show) 42 | 43 | 44 | 45 | internHaskellNixpkgs ∷ Text → IO Nixpkgs 46 | internHaskellNixpkgs nixpkgsPath = do 47 | nixpkgsHackagePackages ← nixpkgsHackagePackagesTopAttrs nixpkgsPath 48 | pure Nixpkgs{..} 49 | 50 | locateNixpkgs ∷ IO Text 51 | locateNixpkgs = T.stripEnd <$> stdoutCall (Desc "locate ") 52 | (Exec "nix-instantiate") ["--eval", "-E", ""] 53 | 54 | getNixpkgs ∷ IO Nixpkgs 55 | getNixpkgs = internHaskellNixpkgs =<< locateNixpkgs 56 | 57 | 58 | 59 | nixpkgsHackagePackagesTopAttrs ∷ Text → IO (Set Attr) 60 | nixpkgsHackagePackagesTopAttrs nixpkgs = do 61 | let file = nixpkgs <> "/pkgs/development/haskell-modules/hackage-packages.nix" 62 | stdoutCallSh (Desc "") (ShCmd $ "grep '\" = callPackage' "<> file <>" | sed 's/^.*\"\\(.*\\)\" = callPackage.*$/\\1/'") 63 | <&> flip Set.difference (Set.singleton "") ∘ Set.fromList ∘ (Attr <$>) ∘ T.lines 64 | 65 | nixpkgsShadows ∷ Attr → Nixpkgs → Set Attr 66 | nixpkgsShadows (Attr attr) Nixpkgs{..} = 67 | flip Set.filter nixpkgsHackagePackages $ 68 | (\(Attr x)→ T.isPrefixOf attr x ∧ x /= attr) 69 | 70 | attrDefined ∷ Attr → Nixpkgs → Bool 71 | attrDefined attr = Set.member attr ∘ nixpkgsHackagePackages 72 | 73 | attrShadowedAt ∷ Attr → Release → Nixpkgs → Maybe Attr 74 | attrShadowedAt attr release = justIf shadow ∘ (shadow `Set.member`) ∘ nixpkgsHackagePackages 75 | where shadow = attrShadow attr release 76 | 77 | attrShadow ∷ Attr → Release → Attr 78 | attrShadow (Attr a) (Release r) = Attr $ a <> "_" <> T.map (charMap '.' '_') r 79 | 80 | attrHasShadows ∷ Attr → Nixpkgs → Bool 81 | attrHasShadows attr = (≢ Set.empty) ∘ nixpkgsShadows attr 82 | 83 | -- Thatf's too slow: several seconds 84 | -- result ← parseNixFile (unpack file) 85 | -- let parse = case result of 86 | -- Success x → x 87 | -- Failure err → errorT $ "Failed to parse " <> file <> ":\n" <> showT err 88 | -- pure $ case parse of 89 | -- Fix (NAbs 90 | -- (ParamSet (FixedParamSet _) Nothing) 91 | -- (Fix (NAbs _ (Fix (NSet xs))))) 92 | -- → Set.fromList [ Attr name 93 | -- | NamedVar [DynamicKey (Plain (DoubleQuoted [Plain name]))] _ ← xs ] 94 | -- _ → errorT $ "Unexpected parsed structure in " <> file 95 | -------------------------------------------------------------------------------- /src/NH/PKGDB.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE GADTs #-} 7 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 8 | {-# LANGUAGE KindSignatures #-} 9 | {-# LANGUAGE LambdaCase #-} 10 | {-# LANGUAGE MultiParamTypeClasses #-} 11 | {-# LANGUAGE NamedFieldPuns #-} 12 | {-# LANGUAGE NoMonomorphismRestriction #-} 13 | {-# LANGUAGE OverloadedStrings #-} 14 | {-# LANGUAGE PackageImports #-} 15 | {-# LANGUAGE PartialTypeSignatures #-} 16 | {-# LANGUAGE RankNTypes #-} 17 | {-# LANGUAGE RecursiveDo #-} 18 | {-# LANGUAGE RecordWildCards #-} 19 | {-# LANGUAGE StandaloneDeriving #-} 20 | {-# LANGUAGE ScopedTypeVariables #-} 21 | {-# LANGUAGE TupleSections #-} 22 | {-# LANGUAGE TypeApplications #-} 23 | {-# LANGUAGE TypeFamilies #-} 24 | {-# LANGUAGE TypeInType #-} 25 | {-# LANGUAGE TypeOperators #-} 26 | {-# LANGUAGE UnicodeSyntax #-} 27 | {-# LANGUAGE UndecidableInstances #-} 28 | {-# LANGUAGE UndecidableSuperClasses #-} 29 | {-# LANGUAGE ViewPatterns #-} 30 | module NH.PKGDB 31 | where 32 | 33 | import Control.Exception 34 | import Control.Lens ((<&>)) 35 | import Control.Monad (foldM, forM, forM_, join, liftM, when) 36 | import Data.Coerce (Coercible, coerce) 37 | import Data.Functor.Identity 38 | import Data.Function ((&)) 39 | import Data.Hourglass (Seconds(..)) 40 | import Data.Hourglass.Epoch 41 | import qualified Data.List as L 42 | import Data.Map (Map) 43 | import qualified Data.Map as Map 44 | import Data.Maybe 45 | import Data.Set (Set) 46 | import qualified Data.Set as Set 47 | import Data.Text (Text, pack, unpack, toLower, toUpper, drop, take, length, isSuffixOf, isPrefixOf) 48 | import qualified Data.Text as T 49 | import qualified Data.Text.IO as Sys 50 | import GHC.Stack 51 | import qualified GHC.Types as Type 52 | import Prelude hiding (read, take, drop, length) 53 | import qualified Prelude as P 54 | import Prelude.Unicode 55 | import qualified System.Directory as Sys 56 | import qualified System.IO.Temp as Sys 57 | import qualified System.FilePath as Sys 58 | import Text.Printf 59 | 60 | import Data.Proxy 61 | import GHC.Generics (Generic) 62 | import qualified GHC.Generics as GHC 63 | import Generics.SOP (Rep, NS(..), NP(..), SOP(..), POP(..), I(..), K(..), Code, All, All2 64 | ,HasDatatypeInfo(..), DatatypeInfo(..), FieldName(..), FieldInfo(..), ConstructorInfo(..), SListI 65 | ,from, to, hcollapse, hcliftA2, hliftA, hcliftA, unI, hsequence, hcpure, hpure) 66 | import qualified Generics.SOP as SOP 67 | 68 | import Language.Nix.PrettyPrinting hiding ((<>), empty, Text) 69 | import Text.PrettyPrint.HughesPJClass ( Doc, Pretty(..), Style(..), Mode(..) 70 | , renderStyle, fsep, text, sep, fsep, lbrack, rbrack, lbrace, rbrace, empty 71 | , vcat, nest, doubleQuotes, (<+>), semi) 72 | import qualified Text.Read as R 73 | import qualified Debug.Trace as DBG 74 | 75 | import NH.Types 76 | import NH.Config 77 | import NH.Derivation as Drv 78 | import qualified NH.FS as FS 79 | import NH.FS hiding (open, init) 80 | import NH.Misc 81 | import NH.MRecord 82 | import NH.Nix 83 | 84 | 85 | 86 | cnDrvMeta, cnUpstream, cnGithub, cnHackage, cnMeta, cnOver, cnPkg, cnPatch, cnOverPack ∷ CName 87 | allCNames@[cnDrvMeta, cnUpstream, cnGithub, cnHackage, cnMeta, cnOver, cnPkg, cnPatch, cnOverPack] = CName <$> 88 | ["DrvMeta", "Upstream", "Github", "Hackage", "Meta", "Overrides", "Package", "Patch", "OverPackage"] 89 | 90 | deriving instance MapKey Field 91 | 92 | instance Ctx PKGCtx where 93 | errCtxDesc (_, en) cn (Field fi) = T.pack $ 94 | printf "%s:%s:%s" (unpack en) (unpack fi) (unpack $ fromCName cn) 95 | listFields (db, en) cn = (Field <$>) <$> listCtx cn (CtxName en) db 96 | dropField (db, en) cn (Field fi) = 97 | rm cn (CtxName en) (Field fi) db 98 | 99 | instance {-# OVERLAPPABLE #-} (SOP.Generic a, SOP.HasDatatypeInfo a) ⇒ Record a where 100 | prefixChars = const 2 101 | instance {-# OVERLAPPABLE #-} (SOP.Generic a, SOP.HasDatatypeInfo a) ⇒ CtxRecord PKGCtx a where 102 | consCtx _ _ n _ = CName n 103 | 104 | restoreChoiceSrc ∷ PKGCtx → IO (Maybe Int) 105 | restoreChoiceSrc ctx = do 106 | msrc ∷ Maybe Text ← restoreField ctx cnOver "src" 107 | pure $ case msrc of 108 | Just "hackage" → Just 0 -- Z ∘ K $ () 109 | Just "github" → Just 1 -- S ∘ Z ∘ K $ () 110 | _ → Nothing 111 | 112 | instance Record Src where 113 | prefixChars = const 2 114 | nameMap = const [("nixHash", "hash")] 115 | instance CtxRecord PKGCtx Src where 116 | consCtx _ _ n _ = CName n 117 | presence (db, en) _ = has cnOver (CtxName en) "src" db 118 | saveChoice (db, en) Github{..} = write' db cnOver (CtxName en) "src" (Just "github") 119 | saveChoice (db, en) Hackage{..} = write' db cnOver (CtxName en) "src" (Just "hackage") 120 | restoreChoice ctx _ = restoreChoiceSrc ctx <&> fromMaybe 121 | (fieldError ctx cnOver "src" "'src' field ⊥: cannot choose between alternatives") 122 | ctxSwitch to c@(db, _) = do 123 | horg ← restoreChoiceSrc c 124 | case horg of 125 | Just 1 → do 126 | mrepo ∷ Maybe Text ← restoreField c cnMeta "repoName" 127 | case mrepo of 128 | Just reponame → pure (db, reponame) 129 | Nothing → pure c 130 | _ → pure c 131 | -- instance CtxRecord PKGCtx PKGDB where 132 | 133 | instance CtxRecord PKGCtx Upstream where 134 | consCtx _ _ n _ = CName n 135 | presence (db, en) _ = has cnOver (CtxName en) "repoName" db 136 | instance ReadField PKGCtx DrvMeta 137 | instance ReadField PKGCtx Upstream 138 | instance ReadField PKGCtx Meta 139 | instance ReadField PKGCtx OverPackage 140 | instance ReadField PKGCtx Overrides 141 | instance ReadField PKGCtx Package 142 | instance ReadField PKGCtx Patch 143 | instance ReadField PKGCtx Src 144 | instance WriteField PKGCtx DrvMeta 145 | instance WriteField PKGCtx Upstream 146 | instance WriteField PKGCtx Meta 147 | instance WriteField PKGCtx OverPackage 148 | instance WriteField PKGCtx Overrides 149 | instance WriteField PKGCtx Package 150 | instance WriteField PKGCtx Patch 151 | instance WriteField PKGCtx Src 152 | 153 | instance RestoreField PKGCtx GHCConfStatic where 154 | -- restoreField ctx cn fi = error "restoreField GHCConfStatic" 155 | -- restoreField (db, en) cn fi = error "restoreField GHCConfStatic" 156 | restoreField ((PKGDB _ _ _), en) cn fi = error "restoreField GHCConfStatic" 157 | -- coerce ∘ fromJust <$> (error "read'" ∷ a → b → c → Field → IO (Maybe Text)) -- read' 158 | -- (error "db") --(PKGDB (error "a") (error "b") (error "c")) 159 | -- (error "cn") 160 | -- (error "cn2") --(CtxName (error "en")) 161 | -- fi 162 | -- coerce <$> read' db cn (CtxName en) 163 | --pure $ GHCConfStatic "non-fun" --error ("GHCConfStatic non lol: " <> unpack at) 164 | -- instance ReadField PKGCtx GHCConfStatic where readField (_, at) _ _ = pure $ Just $ GHCConfStatic "non-fun" --error ("GHCConfStatic non lol: " <> unpack at) 165 | instance ReadField PKGCtx PKGDBPath where readField (_, path) _ _ = pure $ Just $ PKGDBPath path 166 | 167 | instance ReadField PKGCtx Nixpkgs where 168 | readField _ _ _ = Just <$> NH.Nix.getNixpkgs 169 | instance WriteField PKGCtx Nixpkgs where writeField _ _ _ _ = pure () 170 | 171 | instance ReadField PKGCtx (ElapsedSince UnixEpoch) where readField d c f = readField d c f <&> (P.read ∘ unpack <$>) 172 | instance WriteField PKGCtx (ElapsedSince UnixEpoch) where writeField d c f = writeField d c f ∘ pack ∘ show 173 | 174 | instance WriteField PKGCtx DFValue where writeField d c f = writeField d c f ∘ showDocOneLine ∘ dfDoc 175 | 176 | 177 | -- * Basis for DB access: writes are fake, reads are real 178 | 179 | writeText ∷ PKGCtx → CName → Field → Text → IO () 180 | writeText (db, en) cn fi x = write' db cn (CtxName en) fi $ Just x 181 | 182 | instance WriteField PKGCtx Text where 183 | writeField = writeText 184 | instance ReadField PKGCtx Text where 185 | readField (db,en) cn = read' db cn (CtxName en) 186 | 187 | 188 | 189 | writeTextly ∷ Coercible a Text ⇒ PKGCtx → CName → Field → a → IO () 190 | writeTextly ctx cn fi = writeText ctx cn fi ∘ coerce 191 | 192 | readTextly ∷ Coercible a Text ⇒ PKGCtx → CName → Field → IO (Maybe a) 193 | readTextly (db,en) cn = coerce <$> read' db cn (CtxName en) 194 | 195 | instance {-# OVERLAPPABLE #-} Coercible a Text ⇒ WriteField PKGCtx a where 196 | writeField = writeTextly 197 | 198 | instance {-# OVERLAPPABLE #-} Coercible a Text ⇒ ReadField PKGCtx a where 199 | readField = readTextly 200 | 201 | 202 | 203 | instance (Coercible a Text) ⇒ WriteField PKGCtx [a] where 204 | writeField ctx cn fi [] = dropField ctx cn fi 205 | writeField ctx cn fi xs = writeText ctx cn fi $ T.intercalate " " $ coerce <$> xs 206 | 207 | instance (Coercible a Text) ⇒ ReadField PKGCtx [a] where 208 | readField (db, en) cn fi = read' db cn (CtxName en) fi <&> 209 | (defineMaybe [] ∘ (<&> (<&> coerce) ∘ readNames)) 210 | 211 | instance StoreField PKGCtx [Patch] where 212 | storeField ctx cn fi [] = pure () 213 | storeField ctx cn (Field f) xs = sequence_ 214 | [ storeField ctx cn (Field $ f <> "." <> showT i) x 215 | | (i, x) ← zip [0..] xs ] 216 | 217 | instance RestoreField PKGCtx [Patch] where 218 | restoreField ctx@(db, en) cn fi@(Field f) = do 219 | keys ← listField cn (CtxName en) fi db 220 | flip traverse keys $ restoreField ctx cn ∘ Field ∘ ((f<>".")<>) 221 | 222 | 223 | 224 | instance CFlag a ⇒ WriteField PKGCtx (Flag a) where 225 | writeField ctx cn fi x = storeField ctx cn fi $ 226 | if x ≡ enabled 227 | then Just ("true" ∷ Text) 228 | else Nothing 229 | 230 | instance CFlag a ⇒ ReadField PKGCtx (Flag a) where 231 | readField (db, en) cn fi = read' db cn (CtxName en) fi 232 | <&> \case 233 | Nothing → Just disabled 234 | Just _ → Just enabled 235 | 236 | 237 | 238 | instance (MapKey k, Ord k, ReadField PKGCtx v) ⇒ RestoreField PKGCtx (Map k v) where 239 | restoreField ctx@(db, en) cn fi@(Field f) = do 240 | keys ← listField cn (CtxName en) fi db 241 | Map.fromList <$> (forM keys 242 | -- XXX: this is an abstraction leak: 243 | (\k→ (fromKeyName k,) <$> restoreField ctx cn (Field $ f <> "." <> k))) 244 | instance (MapKey k, Ord k, WriteField PKGCtx v) ⇒ StoreField PKGCtx (Map k v) where 245 | storeField ctx@(db, en) cn fi@(Field f) xs = do 246 | all ← listField' cn (CtxName en) fi db 247 | forM_ all $ \old → do 248 | removeFileIfExists old 249 | forM_ (Map.toList xs) $ \(k, v) → do 250 | writeField ctx cn (Field $ f<>"."<>toKeyName k) v 251 | 252 | -- * XXX: This is an instance tailored to a single field of Package: 253 | -- , pkDrvFields ∷ Map DrvField DFValue -- ^ Non-overridable fields only 254 | instance {-# OVERLAPS #-} RestoreField PKGCtx (Map DrvField DFValue) where 255 | restoreField (db, en) cn (Field fi) = Map.fromList ∘ catMaybes <$> mapM (readField db en) (Set.toList Drv.drvFieldsPkgSet) 256 | where 257 | readField ∷ PKGDB → EName → DrvField → IO (Maybe (DrvField, DFValue)) 258 | -- XXX: this is an abstraction leak: 259 | readField db en df = ((df,) ∘ DFValue df ∘ parseFieldTyped (Drv.drvFieldType df) <$>) <$> read cn (CtxName en) (Field $ fi <> "." <> (Drv.drvFieldNixName df)) db 260 | parseAttributes ∷ Text → [Attr] 261 | parseAttributes raw = Attr <$> L.delete "" (T.splitOn " " raw) 262 | parseFieldTyped (NTList NTVar) raw = sep [ fsep $ text ∘ unpack ∘ fromAttr <$> parseAttributes raw ] 263 | parseFieldTyped (NTList NTStr) raw = sep [ lbrack 264 | , fsep $ text <$> readSequence raw 265 | , rbrack ] 266 | parseFieldTyped t@(NTList _) _ = error $ printf "Unsupported list type: %s" (show t) 267 | parseFieldTyped _ raw = text $ unpack raw 268 | 269 | 270 | 271 | init ∷ Text → IO PKGDB 272 | init = FS.init allCNames 273 | 274 | readDB ∷ HasCallStack ⇒ T.Text → IO PKGDB 275 | readDB path = mdo 276 | db ← recover (db, path) 277 | pure db 278 | 279 | open ∷ Text → IO (Maybe PKGDB) 280 | open path = do 281 | valid ← FS.validate allCNames (FS.FSDBPath path) 282 | if valid 283 | then Just <$> readDB path 284 | else pure Nothing 285 | 286 | read' ∷ PKGDB → CName → CtxName → Field → IO (Maybe Text) 287 | read' db cn en fi = read cn en fi db 288 | 289 | write' ∷ PKGDB → CName → CtxName → Field → Maybe Text → IO () 290 | write' db cn en fi mval = write cn en fi mval db 291 | 292 | 293 | 294 | wtest = do 295 | Just db <- open "/home/deepfire/configuration-ghc84x/" 296 | store (db, "lol" ∷ Text) $ Meta (Just $ RepoName "lol") DisableOverride Nothing [] (Just $ Attr "lol") ToLocal mempty 297 | rmeta = do 298 | Just db <- open "/home/deepfire/configuration-ghc84x/" 299 | recover (db, "hspec" ∷ Text) :: IO Meta 300 | rsrc = do 301 | Just db <- open "/home/deepfire/configuration-ghc84x/" 302 | recover (db, "hspec" ∷ Text) :: IO Src 303 | rover = do 304 | Just db <- open "/home/deepfire/configuration-ghc84x/" 305 | recover (db, "hspec" ∷ Text) :: IO Overrides 306 | 307 | 308 | 309 | listFulldefns, listOverPackages ∷ HasCallStack ⇒ PKGDB → IO [Attr] 310 | listFulldefns = ((Attr ∘ unCtxName <$>) ∘ Set.toList <$>) ∘ list cnPkg 311 | listOverPackages = ((Attr ∘ unCtxName <$>) ∘ Set.toList <$>) ∘ list cnOver 312 | 313 | readRecord ∷ (HasCallStack, Record a, All2 (RestoreField PKGCtx) (Code a), CtxRecord PKGCtx a) ⇒ PKGDB → Attr → IO (Attr, a) 314 | readRecord db at@(Attr attr) = (at,) <$> recover (db, attr) 315 | 316 | readPackages ∷ HasCallStack ⇒ PKGDB → IO (Map Attr Package) 317 | readPackages db = listFulldefns db >>= mapM (readRecord db) <&> Map.fromList 318 | 319 | readOverPackages ∷ HasCallStack ⇒ PKGDB → IO (Map Attr OverPackage) 320 | readOverPackages db = listOverPackages db >>= mapM (readRecord db) <&> Map.fromList 321 | -------------------------------------------------------------------------------- /src/NH/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DefaultSignatures #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE KindSignatures #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE TypeFamilies #-} 10 | {-# LANGUAGE UndecidableInstances #-} 11 | {-# LANGUAGE UndecidableSuperClasses #-} 12 | {-# LANGUAGE UnicodeSyntax #-} 13 | {-# LANGUAGE ViewPatterns #-} 14 | module NH.Types 15 | where 16 | 17 | import Data.Coerce (Coercible, coerce) 18 | import Data.Hourglass.Epoch 19 | import Data.Map (Map) 20 | import qualified Data.Map as Map 21 | import Data.Maybe 22 | import qualified Data.Set as Set 23 | import Data.String 24 | import Data.Text 25 | import Data.Semigroup hiding (All) 26 | import Generics.SOP (Proxy) 27 | import qualified Generics.SOP as SOP 28 | import qualified GHC.Generics as GHC 29 | import qualified GHC.Types as Type 30 | import Prelude hiding (length, drop) 31 | import Prelude.Unicode 32 | import Text.PrettyPrint.HughesPJClass (Doc(..)) 33 | 34 | import qualified Debug.Trace as DBG 35 | 36 | import NH.MRecord 37 | 38 | -- * Local 39 | import NH.Misc 40 | 41 | 42 | 43 | instance Functor Set.Set where 44 | fmap = Set.mapMonotonic 45 | 46 | 47 | 48 | newtype CtxName = CtxName { unCtxName ∷ Text } deriving (Eq, IsString, Ord, Show) 49 | newtype PKGDBPath = PKGDBPath { fromPKGDBPath ∷ Text } deriving (Eq, IsString, Ord, Show) 50 | 51 | attrCtx ∷ Attr → CtxName 52 | repoCtx ∷ RepoName → CtxName 53 | attrCtx = CtxName ∘ coerce 54 | repoCtx = CtxName ∘ coerce 55 | 56 | newtype GHCVer = GHCVer { fromGHCVer ∷ Text } deriving (Eq, IsString, Show) 57 | newtype Subdir = Subdir { fromDir ∷ Text } deriving (Eq, IsString, Show) 58 | newtype URL = URL { fromURL ∷ Text } deriving (Eq, IsString, Show) 59 | 60 | 61 | 62 | -- * Stored in PKGDB 63 | 64 | newtype Attr = Attr { fromAttr ∷ Text } deriving (Eq, IsString, Ord, Show, MapKey) 65 | newtype RepoName = RepoName { fromRepoName ∷ Text } deriving (Eq, IsString, Ord, Show) 66 | newtype Release = Release { fromRelease ∷ Text } deriving (Eq, IsString, Show) 67 | newtype GitRef = GitRef { fromRef ∷ Text } deriving (Eq, IsString, Show) 68 | newtype GithubUser = GithubUser { fromUser ∷ Text } deriving (Eq, IsString, Show) 69 | newtype GithubPR = GithubPR { fromPR ∷ Text } deriving (Eq, IsString, Show) 70 | newtype GithubIssue = GithubIssue { fromIssue ∷ Text } deriving (Eq, IsString, Show) 71 | newtype NixHash = NixHash { fromNixHash ∷ Text } deriving (Eq, IsString, Show) 72 | 73 | 74 | data Flags 75 | = Local 76 | | Disable 77 | | Jailbreak 78 | | Revision 79 | | Check 80 | | Haddock 81 | | Target 82 | 83 | instance CFlag Local where 84 | data Flag Local = ToLocal | ToNixpkgs deriving (Bounded, Eq, Ord, Show) 85 | instance CFlag Disable where 86 | data Flag Disable = DisableOverride | KeepOverride deriving (Bounded, Eq, Ord, Show) 87 | instance CFlag Jailbreak where 88 | data Flag Jailbreak = DoJailbreak | DontJailbreak deriving (Bounded, Eq, Ord, Show) 89 | instance CFlag Revision where 90 | data Flag Revision = DontRevision | KeepRevision deriving (Bounded, Eq, Ord, Show) 91 | instance CFlag Check where 92 | data Flag Check = DontCheck | DoCheck deriving (Bounded, Eq, Ord, Show) 93 | instance CFlag Haddock where 94 | data Flag Haddock = DontHaddock | DoHaddock deriving (Bounded, Eq, Ord, Show) 95 | 96 | 97 | 98 | data SrcSpec 99 | = SSGithub { ssAttr ∷ Attr, ssUser ∷ GithubUser, ssRepoName ∷ RepoName, ssDir ∷ (Maybe Subdir), ssRef ∷ GitRef } 100 | | SSHackage { ssAttr ∷ Attr, ssDir ∷ (Maybe Subdir) } 101 | deriving (Show) 102 | 103 | 104 | -- Global TODO: 105 | -- 106 | -- 1. Anomalous emission for inverted flags, like doCheck and doHaddock. 107 | -- Could be driven by significance of defaults, I guess. 108 | -- 2. db conversion 109 | -- 110 | data Nixpkgs = Nixpkgs 111 | { nixpkgsPath ∷ Text 112 | , nixpkgsHackagePackages ∷ Set.Set Attr 113 | } deriving (Eq) 114 | 115 | instance Show Nixpkgs where 116 | show Nixpkgs{..} = "#unpack nixpkgsPath<>"\">" 117 | 118 | -- | Context type for PKGDB-oriented MRecord instances: 119 | type PKGCtx = (PKGDB, EName) 120 | 121 | newtype CName = CName { fromCName ∷ Text } deriving (Eq, Ord, Show) 122 | 123 | type instance ConsCtx PKGCtx = CName 124 | 125 | newtype GHCConfStatic = GHCConfStatic { fromGHCConfStatic ∷ Text } deriving (Eq, Ord, Show) 126 | 127 | data PKGDB = PKGDB 128 | { pkgdbPath ∷ PKGDBPath 129 | , pkgdbNixpkgs ∷ Nixpkgs 130 | , pkgdbGHCConfStatic ∷ GHCConfStatic 131 | -- , pkgdbExtraAttrs ∷ [Attr] 132 | } deriving (GHC.Generic, Show) 133 | instance SOP.Generic PKGDB 134 | instance SOP.HasDatatypeInfo PKGDB 135 | 136 | data OverPackage = OverPackage 137 | { opAttr ∷ Attr 138 | , opMeta ∷ Meta 139 | , opOver ∷ Overrides 140 | , opNixpkgs ∷ Nixpkgs 141 | , opUpstream ∷ Maybe Upstream 142 | } deriving (Eq, GHC.Generic, Show) 143 | instance SOP.Generic OverPackage 144 | instance SOP.HasDatatypeInfo OverPackage 145 | 146 | data Package = Package 147 | { pkAttr ∷ Attr 148 | , pkUpstream ∷ Upstream 149 | , pkMeta ∷ Meta 150 | , pkOver ∷ Overrides -- ^ Carries overridable fields 151 | , pkDrvFields ∷ Map DrvField DFValue -- ^ Non-overridable fields only 152 | , pkDrvMeta ∷ DrvMeta 153 | } deriving (Eq, GHC.Generic, Show) 154 | instance SOP.Generic Package 155 | instance SOP.HasDatatypeInfo Package 156 | 157 | 158 | 159 | data DrvMeta = DrvMeta 160 | { dmLicense ∷ Text 161 | , dmDescription ∷ Maybe Text 162 | , dmHomepage ∷ Maybe Text 163 | , dmPlatforms ∷ Maybe Text 164 | , dmMaintainers ∷ Maybe Text 165 | } deriving (Eq, GHC.Generic, Show) 166 | instance SOP.Generic DrvMeta 167 | instance SOP.HasDatatypeInfo DrvMeta 168 | 169 | data Upstream = Upstream 170 | { upRepoName ∷ RepoName 171 | , upUser ∷ GithubUser 172 | , upPr ∷ Maybe GithubPR 173 | , upIssue ∷ Maybe GithubIssue 174 | , upTimestamp ∷ Maybe (ElapsedSince UnixEpoch) 175 | } deriving (Eq, GHC.Generic, Show) 176 | instance SOP.Generic Upstream 177 | instance SOP.HasDatatypeInfo Upstream 178 | 179 | 180 | 181 | type EName = Text 182 | 183 | data Meta = Meta 184 | { meRepoName ∷ Maybe RepoName 185 | , meDisable ∷ Flag Disable 186 | , meChdir ∷ Maybe Text 187 | , meErdeps ∷ [Attr] 188 | , meAttrName ∷ Maybe Attr -- ^ Useful for versioned shadow attributes. 189 | , meLocal ∷ Flag Local 190 | , meExplanation ∷ Map Field Text 191 | } deriving (Eq, GHC.Generic, Show) 192 | instance SOP.Generic Meta 193 | instance SOP.HasDatatypeInfo Meta 194 | 195 | data Src 196 | = Hackage 197 | { srNixHash ∷ NixHash 198 | , haRelease ∷ Release 199 | } 200 | | Github 201 | { srNixHash ∷ NixHash 202 | , ghRepoName ∷ RepoName 203 | , ghUser ∷ GithubUser 204 | , ghRev ∷ GitRef 205 | } 206 | deriving (Eq, GHC.Generic, Show) 207 | instance SOP.Generic Src 208 | instance SOP.HasDatatypeInfo Src 209 | 210 | 211 | 212 | data Overrides = Overrides 213 | { ovSrc ∷ Maybe Src 214 | , ovJailbreak ∷ Flag Jailbreak 215 | , ovRevision ∷ Flag Revision 216 | , ovDoCheck ∷ Flag Check 217 | , ovDoHaddock ∷ Flag Haddock 218 | , ovInputs ∷ Map Attr Attr 219 | , ovDrvFields ∷ Map DrvField DFValue -- ^ Overridable fields only 220 | , ovPatches ∷ [Patch] 221 | } deriving (Eq, GHC.Generic, Show) 222 | instance SOP.Generic Overrides 223 | instance SOP.HasDatatypeInfo Overrides 224 | 225 | instance Semigroup Overrides where 226 | l <> r = Overrides 227 | { ovSrc = ovSrc r 228 | , ovJailbreak = ovJailbreak r 229 | , ovRevision = ovRevision r 230 | , ovDoCheck = ovDoCheck r 231 | , ovDoHaddock = ovDoHaddock r 232 | , ovInputs = ovInputs l <> ovInputs r 233 | , ovDrvFields = ovDrvFields l <> ovDrvFields r 234 | , ovPatches = ovPatches l <> ovPatches r 235 | } 236 | 237 | instance Monoid Overrides where 238 | mempty = Overrides 239 | { ovSrc = Nothing 240 | , ovJailbreak = DontJailbreak 241 | , ovRevision = KeepRevision 242 | , ovDoCheck = DoCheck 243 | , ovDoHaddock = DoHaddock 244 | , ovInputs = mempty 245 | , ovDrvFields = mempty 246 | , ovPatches = [] 247 | } 248 | 249 | data Patch = Patch 250 | { paUrl ∷ Text 251 | , paSha256 ∷ Text 252 | } deriving (Eq, GHC.Generic, Show) 253 | instance SOP.Generic Patch 254 | instance SOP.HasDatatypeInfo Patch 255 | 256 | 257 | 258 | data Status 259 | = StFulldefn 260 | | StShadowed 261 | | StHackaged 262 | | StUpstreamed 263 | | StUnmerged 264 | | StConfig 265 | | StDefault 266 | 267 | 268 | 269 | data DrvField 270 | = DFdrvparams 271 | | DFpname 272 | | DFversion 273 | | DFsrcUrl 274 | | DFsrcSha256 275 | | DFsrcRev 276 | | DFsubpath 277 | | DFrevision 278 | | DFeditedCabalFile 279 | 280 | | DFconfigureFlags 281 | | DFisLibrary 282 | | DFisExecutable 283 | | DFenableSeparateDataOutput 284 | 285 | | DFsetupHaskellDepends 286 | | DFlibraryHaskellDepends 287 | | DFexecutableHaskellDepends 288 | | DFtestHaskellDepends 289 | | DFbenchmarkHaskellDepends 290 | 291 | | DFsetupSystemDepends 292 | | DFlibrarySystemDepends 293 | | DFexecutableSystemDepends 294 | | DFtestSystemDepends 295 | | DFbenchmarkSystemDepends 296 | 297 | | DFsetupPkgconfigDepends 298 | | DFlibraryPkgconfigDepends 299 | | DFexecutablePkgconfigDepends 300 | | DFtestPkgconfigDepends 301 | | DFbenchmarkPkgconfigDepends 302 | 303 | | DFsetupToolDepends 304 | | DFlibraryToolDepends 305 | | DFexecutableToolDepends 306 | | DFtestToolDepends 307 | | DFbenchmarkToolDepends 308 | 309 | | DFenableLibraryProfiling 310 | | DFenableExecutableProfiling 311 | | DFenableSplitObjs 312 | | DFdoHaddock 313 | | DFjailbreak 314 | | DFdoCheck 315 | | DFtestTarget 316 | | DFhyperlinkSource 317 | | DFphaseOverrides 318 | 319 | | DFmetaSectionHomepage 320 | | DFmetaSectionDescription 321 | | DFmetaSectionLicense 322 | | DFmetaSectionPlatforms 323 | | DFmetaSectionMaintainers 324 | -- | DFmetaSectionLongDescription 325 | deriving (Bounded, Enum, Eq, Ord, Read, Show) 326 | 327 | class MapKey a where 328 | toKeyName ∷ a → Text 329 | fromKeyName ∷ Text → a 330 | default toKeyName ∷ Coercible a Text ⇒ a → Text 331 | default fromKeyName ∷ Coercible Text a ⇒ Text → a 332 | toKeyName = coerce 333 | fromKeyName = coerce 334 | 335 | instance MapKey Text 336 | 337 | instance MapKey DrvField where 338 | toKeyName = drop 2 ∘ showT 339 | fromKeyName = read ∘ ("DF"<>) ∘ unpack 340 | 341 | -- | Consider possibilities for making this type redundant. 342 | data DFValue = DFValue 343 | { dfField ∷ DrvField 344 | , dfDoc ∷ Doc 345 | } deriving (Eq, Show) 346 | -------------------------------------------------------------------------------- /suite.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | set -e 4 | 5 | x() { if test -n "${TRACE}"; then echo "$@"; fi 6 | "$@" 7 | } 8 | q() { if test -n "${TRACE}"; then echo "$@"; fi 9 | "$@" >/dev/null 10 | } 11 | fail() { echo "FAIL: $1"; exit 1 12 | } 13 | pass() { echo "OK: $1" 14 | } 15 | build_should_fail() { 16 | echo 17 | nh build --reuse-cache "$1" >/dev/null 2>&1 || true 18 | local EXPFAIL="$2" 19 | local EXPFAILTY="$3" 20 | local ACTFAIL=$( nh failure "$1" || true) 21 | local ACTFAILTY=$(nh failure-type "$1" || true) 22 | 23 | if test -z "${ACTFAIL}" 24 | then fail "not failed> $1" 25 | elif test "${EXPFAIL}" != "${ACTFAIL}" 26 | then fail "wrong failure of $1> expected $EXPFAIL, yet failed as $ACTFAIL/$ACTFAILTY" 27 | elif test -n "${EXPFAILTY}" -a "${EXPFAILTY}" != "${ACTFAILTY}" 28 | then fail "misfail $1> $ACTFAIL/$ACTFAILTY -- expected $EXPFAIL/$EXPFAILTY" 29 | else pass "proper fail $1> $EXPFAIL${EXPFAILTY:+/$EXPFAILTY}" 30 | fi 31 | } 32 | build_should_pass() { 33 | echo 34 | if ! nh build "$1" 35 | then fail "did not pass> $1', $(nh failure "$1")/$(nh failure-type "$1")" 36 | else pass "proper pass> $1" 37 | fi 38 | } 39 | property_is() { 40 | echo 41 | attr="$1"; type="$2"; prop="$3"; expected="$4" 42 | actual="$(nh-def x get "$type" "$prop" "$attr" UNDEFINED)" 43 | if test "$expected" !="$actual" 44 | then fail "property $attr.$type.$prop expected> '$expected', actual '$actual'" 45 | else pass "property $attr.$type.$prop as expected> '$expected'" 46 | fi 47 | } 48 | eval_is() { 49 | echo 50 | expr="$1"; expected="$2" 51 | actual="$(nh x $expr)" 52 | if test "$expected" != "$actual" 53 | then fail "'$expr' evaluated to: '$actual', expected: '$expected'" 54 | else pass "'$expr' as expected is: '$expected'" 55 | fi 56 | } 57 | 58 | debug= 59 | pkgdb= 60 | silent= 61 | while test $# -ge 1 62 | do case "$1" 63 | in --cls ) echo -en "\ec";; 64 | --pkgdb ) pkgdb="$2"; shift;; 65 | --silent ) silent="--silent";; 66 | --trace ) TRACE="--trace";; 67 | --debug ) set -x; export NH_DEBUG="--debug";; 68 | "--"* ) fail "$0: unknown option: $1";; 69 | * ) break;; 70 | esac 71 | shift 72 | done 73 | MAYCMD="$1" 74 | if test -n "${MAYCMD}"; then shift; fi 75 | case "$MAYCMD" in 76 | x ) "$@"; exit $?;; 77 | esac 78 | 79 | ### 80 | ### main :: IO () 81 | ### 82 | cd tests 2>/dev/null || true 83 | 84 | db="${pkgdb:-$(mktemp -d /tmp/nh-test-area-XXXXXXXXX)}" 85 | atexit() { 86 | if test -z "${pkgdb}" 87 | then rm -rf ${db} 88 | fi 89 | } 90 | trap atexit EXIT 91 | 92 | cat > .nh < {} 2 | , pkgs ? nixpkgs.pkgs, haskell ? pkgs.haskell 3 | , compiler ? "ghc841" 4 | , ghcOrig ? pkgs.haskell.packages."${compiler}" 5 | }: 6 | 7 | ghcOrig.override (oldArgs: { 8 | overrides = new: old: 9 | import ./overrides.nix { inherit pkgs; self = new; super = old; haskellLib = haskell.lib; }; 10 | }) 11 | --------------------------------------------------------------------------------