Remove cli/
authorJulien Moutinho <julm+hcompta@autogeree.net>
Sat, 19 Aug 2017 13:00:14 +0000 (15:00 +0200)
committerJulien Moutinho <julm+hcompta@autogeree.net>
Sat, 19 Aug 2017 13:00:14 +0000 (15:00 +0200)
81 files changed:
cli/.gitignore [deleted file]
cli/COPYING [deleted file]
cli/Hcompta/CLI/Args.hs [deleted file]
cli/Hcompta/CLI/Command.hs [deleted file]
cli/Hcompta/CLI/Command/Balance.hs [deleted file]
cli/Hcompta/CLI/Command/Diff.hs [deleted file]
cli/Hcompta/CLI/Command/GL.hs [deleted file]
cli/Hcompta/CLI/Command/HLint.hs [deleted symlink]
cli/Hcompta/CLI/Command/Journal.hs [deleted file]
cli/Hcompta/CLI/Command/Journals.hs [deleted file]
cli/Hcompta/CLI/Command/Stats.hs [deleted file]
cli/Hcompta/CLI/Command/Tags.hs [deleted file]
cli/Hcompta/CLI/Context.hs [deleted file]
cli/Hcompta/CLI/Convert.hs [deleted file]
cli/Hcompta/CLI/Env.hs [deleted file]
cli/Hcompta/CLI/Format.hs [deleted file]
cli/Hcompta/CLI/Format/HLint.hs [deleted symlink]
cli/Hcompta/CLI/Format/JCC.hs [deleted file]
cli/Hcompta/CLI/Format/Ledger.hs [deleted file]
cli/Hcompta/CLI/HLint.hs [deleted symlink]
cli/Hcompta/CLI/Lang.hs [deleted file]
cli/Hcompta/CLI/Lib/HLint.hs [deleted symlink]
cli/Hcompta/CLI/Lib/Leijen/HLint.hs [deleted symlink]
cli/Hcompta/CLI/Lib/Leijen/Table.hs [deleted file]
cli/Hcompta/CLI/Main.hs [deleted file]
cli/Hcompta/CLI/Write.hs [deleted file]
cli/Hcompta/Expr/Bool.hs [deleted file]
cli/Hcompta/Expr/Bool/HLint.hs [deleted symlink]
cli/Hcompta/Expr/Bool/Test.hs [deleted file]
cli/Hcompta/Expr/Dup.hs [deleted file]
cli/Hcompta/Expr/Dup/Test.hs [deleted file]
cli/Hcompta/Expr/Eq.hs [deleted file]
cli/Hcompta/Expr/Fun.hs [deleted file]
cli/Hcompta/Expr/Fun/HLint.hs [deleted symlink]
cli/Hcompta/Expr/Fun/Test.hs [deleted file]
cli/Hcompta/Expr/HLint.hs [deleted symlink]
cli/Hcompta/Expr/If.hs [deleted file]
cli/Hcompta/Expr/If/HLint.hs [deleted symlink]
cli/Hcompta/Expr/If/Test.hs [deleted file]
cli/Hcompta/Expr/Lit.hs [deleted file]
cli/Hcompta/Expr/Log.hs [deleted file]
cli/Hcompta/Expr/Maybe.hs [deleted file]
cli/Hcompta/Expr/Ord.hs [deleted file]
cli/Hcompta/Expr/Set.hs [deleted file]
cli/Hcompta/Expr/Trans.hs [deleted file]
cli/Hcompta/HLint.hs [deleted symlink]
cli/Hcompta/Lib/Control/HLint.hs [deleted symlink]
cli/Hcompta/Lib/Control/Monad.hs [deleted file]
cli/Hcompta/Lib/Control/Monad/Classes.hs [deleted file]
cli/Hcompta/Lib/Data/Default.hs [deleted file]
cli/Hcompta/Lib/Data/HLint.hs [deleted symlink]
cli/Hcompta/Lib/Data/Monoid.hs [deleted file]
cli/Hcompta/Lib/Data/Text.hs [deleted file]
cli/Hcompta/Lib/Data/Text/Buildable.hs [deleted file]
cli/Hcompta/Lib/Data/Text/HLint.hs [deleted symlink]
cli/Hcompta/Lib/HLint.hs [deleted symlink]
cli/Hcompta/Lib/System/File/HLint.hs [deleted symlink]
cli/Hcompta/Lib/System/File/Path.hs [deleted file]
cli/Hcompta/Lib/System/HLint.hs [deleted symlink]
cli/Hcompta/Repr/HLint.hs [deleted symlink]
cli/Hcompta/Repr/Meta.hs [deleted file]
cli/Hcompta/Repr/Test.hs [deleted file]
cli/Hcompta/Repr/Text.hs [deleted file]
cli/Hcompta/Repr/Text/HLint.hs [deleted symlink]
cli/Hcompta/Repr/Text/Test.hs [deleted file]
cli/Hcompta/Repr/Text/Write.hs [deleted file]
cli/Hcompta/Repr/Text/Write/Test.hs [deleted file]
cli/Hcompta/Repr/Tree.hs [deleted file]
cli/Hcompta/Repr/Tree/Read.hs [deleted file]
cli/Hcompta/Repr/Tree/Read/Test.hs [deleted file]
cli/Hcompta/Repr/Tree/Test.hs [deleted file]
cli/Hcompta/Test.hs [deleted file]
cli/Hcompta/Trans/Bool.hs [deleted file]
cli/Hcompta/Trans/Bool/Const.hs [deleted file]
cli/Hcompta/Trans/Bool/Const/Test.hs [deleted file]
cli/Hcompta/Trans/Bool/HLint.hs [deleted symlink]
cli/Hcompta/Trans/Bool/Test.hs [deleted file]
cli/Hcompta/Trans/HLint.hs [deleted symlink]
cli/Hcompta/Trans/Test.hs [deleted file]
cli/Setup.hs [deleted file]
cli/hcompta-cli.cabal [deleted file]

diff --git a/cli/.gitignore b/cli/.gitignore
deleted file mode 100644 (file)
index 05d4d64..0000000
+++ /dev/null
@@ -1,3 +0,0 @@
-.cabal-sandbox/
-cabal.sandbox.config
-dist/
diff --git a/cli/COPYING b/cli/COPYING
deleted file mode 100644 (file)
index 94a9ed0..0000000
+++ /dev/null
@@ -1,674 +0,0 @@
-                    GNU GENERAL PUBLIC LICENSE
-                       Version 3, 29 June 2007
-
- Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>
- Everyone is permitted to copy and distribute verbatim copies
- of this license document, but changing it is not allowed.
-
-                            Preamble
-
-  The GNU General Public License is a free, copyleft license for
-software and other kinds of works.
-
-  The licenses for most software and other practical works are designed
-to take away your freedom to share and change the works.  By contrast,
-the GNU General Public License is intended to guarantee your freedom to
-share and change all versions of a program--to make sure it remains free
-software for all its users.  We, the Free Software Foundation, use the
-GNU General Public License for most of our software; it applies also to
-any other work released this way by its authors.  You can apply it to
-your programs, too.
-
-  When we speak of free software, we are referring to freedom, not
-price.  Our General Public Licenses are designed to make sure that you
-have the freedom to distribute copies of free software (and charge for
-them if you wish), that you receive source code or can get it if you
-want it, that you can change the software or use pieces of it in new
-free programs, and that you know you can do these things.
-
-  To protect your rights, we need to prevent others from denying you
-these rights or asking you to surrender the rights.  Therefore, you have
-certain responsibilities if you distribute copies of the software, or if
-you modify it: responsibilities to respect the freedom of others.
-
-  For example, if you distribute copies of such a program, whether
-gratis or for a fee, you must pass on to the recipients the same
-freedoms that you received.  You must make sure that they, too, receive
-or can get the source code.  And you must show them these terms so they
-know their rights.
-
-  Developers that use the GNU GPL protect your rights with two steps:
-(1) assert copyright on the software, and (2) offer you this License
-giving you legal permission to copy, distribute and/or modify it.
-
-  For the developers' and authors' protection, the GPL clearly explains
-that there is no warranty for this free software.  For both users' and
-authors' sake, the GPL requires that modified versions be marked as
-changed, so that their problems will not be attributed erroneously to
-authors of previous versions.
-
-  Some devices are designed to deny users access to install or run
-modified versions of the software inside them, although the manufacturer
-can do so.  This is fundamentally incompatible with the aim of
-protecting users' freedom to change the software.  The systematic
-pattern of such abuse occurs in the area of products for individuals to
-use, which is precisely where it is most unacceptable.  Therefore, we
-have designed this version of the GPL to prohibit the practice for those
-products.  If such problems arise substantially in other domains, we
-stand ready to extend this provision to those domains in future versions
-of the GPL, as needed to protect the freedom of users.
-
-  Finally, every program is threatened constantly by software patents.
-States should not allow patents to restrict development and use of
-software on general-purpose computers, but in those that do, we wish to
-avoid the special danger that patents applied to a free program could
-make it effectively proprietary.  To prevent this, the GPL assures that
-patents cannot be used to render the program non-free.
-
-  The precise terms and conditions for copying, distribution and
-modification follow.
-
-                       TERMS AND CONDITIONS
-
-  0. Definitions.
-
-  "This License" refers to version 3 of the GNU General Public License.
-
-  "Copyright" also means copyright-like laws that apply to other kinds of
-works, such as semiconductor masks.
-
-  "The Program" refers to any copyrightable work licensed under this
-License.  Each licensee is addressed as "you".  "Licensees" and
-"recipients" may be individuals or organizations.
-
-  To "modify" a work means to copy from or adapt all or part of the work
-in a fashion requiring copyright permission, other than the making of an
-exact copy.  The resulting work is called a "modified version" of the
-earlier work or a work "based on" the earlier work.
-
-  A "covered work" means either the unmodified Program or a work based
-on the Program.
-
-  To "propagate" a work means to do anything with it that, without
-permission, would make you directly or secondarily liable for
-infringement under applicable copyright law, except executing it on a
-computer or modifying a private copy.  Propagation includes copying,
-distribution (with or without modification), making available to the
-public, and in some countries other activities as well.
-
-  To "convey" a work means any kind of propagation that enables other
-parties to make or receive copies.  Mere interaction with a user through
-a computer network, with no transfer of a copy, is not conveying.
-
-  An interactive user interface displays "Appropriate Legal Notices"
-to the extent that it includes a convenient and prominently visible
-feature that (1) displays an appropriate copyright notice, and (2)
-tells the user that there is no warranty for the work (except to the
-extent that warranties are provided), that licensees may convey the
-work under this License, and how to view a copy of this License.  If
-the interface presents a list of user commands or options, such as a
-menu, a prominent item in the list meets this criterion.
-
-  1. Source Code.
-
-  The "source code" for a work means the preferred form of the work
-for making modifications to it.  "Object code" means any non-source
-form of a work.
-
-  A "Standard Interface" means an interface that either is an official
-standard defined by a recognized standards body, or, in the case of
-interfaces specified for a particular programming language, one that
-is widely used among developers working in that language.
-
-  The "System Libraries" of an executable work include anything, other
-than the work as a whole, that (a) is included in the normal form of
-packaging a Major Component, but which is not part of that Major
-Component, and (b) serves only to enable use of the work with that
-Major Component, or to implement a Standard Interface for which an
-implementation is available to the public in source code form.  A
-"Major Component", in this context, means a major essential component
-(kernel, window system, and so on) of the specific operating system
-(if any) on which the executable work runs, or a compiler used to
-produce the work, or an object code interpreter used to run it.
-
-  The "Corresponding Source" for a work in object code form means all
-the source code needed to generate, install, and (for an executable
-work) run the object code and to modify the work, including scripts to
-control those activities.  However, it does not include the work's
-System Libraries, or general-purpose tools or generally available free
-programs which are used unmodified in performing those activities but
-which are not part of the work.  For example, Corresponding Source
-includes interface definition files associated with source files for
-the work, and the source code for shared libraries and dynamically
-linked subprograms that the work is specifically designed to require,
-such as by intimate data communication or control flow between those
-subprograms and other parts of the work.
-
-  The Corresponding Source need not include anything that users
-can regenerate automatically from other parts of the Corresponding
-Source.
-
-  The Corresponding Source for a work in source code form is that
-same work.
-
-  2. Basic Permissions.
-
-  All rights granted under this License are granted for the term of
-copyright on the Program, and are irrevocable provided the stated
-conditions are met.  This License explicitly affirms your unlimited
-permission to run the unmodified Program.  The output from running a
-covered work is covered by this License only if the output, given its
-content, constitutes a covered work.  This License acknowledges your
-rights of fair use or other equivalent, as provided by copyright law.
-
-  You may make, run and propagate covered works that you do not
-convey, without conditions so long as your license otherwise remains
-in force.  You may convey covered works to others for the sole purpose
-of having them make modifications exclusively for you, or provide you
-with facilities for running those works, provided that you comply with
-the terms of this License in conveying all material for which you do
-not control copyright.  Those thus making or running the covered works
-for you must do so exclusively on your behalf, under your direction
-and control, on terms that prohibit them from making any copies of
-your copyrighted material outside their relationship with you.
-
-  Conveying under any other circumstances is permitted solely under
-the conditions stated below.  Sublicensing is not allowed; section 10
-makes it unnecessary.
-
-  3. Protecting Users' Legal Rights From Anti-Circumvention Law.
-
-  No covered work shall be deemed part of an effective technological
-measure under any applicable law fulfilling obligations under article
-11 of the WIPO copyright treaty adopted on 20 December 1996, or
-similar laws prohibiting or restricting circumvention of such
-measures.
-
-  When you convey a covered work, you waive any legal power to forbid
-circumvention of technological measures to the extent such circumvention
-is effected by exercising rights under this License with respect to
-the covered work, and you disclaim any intention to limit operation or
-modification of the work as a means of enforcing, against the work's
-users, your or third parties' legal rights to forbid circumvention of
-technological measures.
-
-  4. Conveying Verbatim Copies.
-
-  You may convey verbatim copies of the Program's source code as you
-receive it, in any medium, provided that you conspicuously and
-appropriately publish on each copy an appropriate copyright notice;
-keep intact all notices stating that this License and any
-non-permissive terms added in accord with section 7 apply to the code;
-keep intact all notices of the absence of any warranty; and give all
-recipients a copy of this License along with the Program.
-
-  You may charge any price or no price for each copy that you convey,
-and you may offer support or warranty protection for a fee.
-
-  5. Conveying Modified Source Versions.
-
-  You may convey a work based on the Program, or the modifications to
-produce it from the Program, in the form of source code under the
-terms of section 4, provided that you also meet all of these conditions:
-
-    a) The work must carry prominent notices stating that you modified
-    it, and giving a relevant date.
-
-    b) The work must carry prominent notices stating that it is
-    released under this License and any conditions added under section
-    7.  This requirement modifies the requirement in section 4 to
-    "keep intact all notices".
-
-    c) You must license the entire work, as a whole, under this
-    License to anyone who comes into possession of a copy.  This
-    License will therefore apply, along with any applicable section 7
-    additional terms, to the whole of the work, and all its parts,
-    regardless of how they are packaged.  This License gives no
-    permission to license the work in any other way, but it does not
-    invalidate such permission if you have separately received it.
-
-    d) If the work has interactive user interfaces, each must display
-    Appropriate Legal Notices; however, if the Program has interactive
-    interfaces that do not display Appropriate Legal Notices, your
-    work need not make them do so.
-
-  A compilation of a covered work with other separate and independent
-works, which are not by their nature extensions of the covered work,
-and which are not combined with it such as to form a larger program,
-in or on a volume of a storage or distribution medium, is called an
-"aggregate" if the compilation and its resulting copyright are not
-used to limit the access or legal rights of the compilation's users
-beyond what the individual works permit.  Inclusion of a covered work
-in an aggregate does not cause this License to apply to the other
-parts of the aggregate.
-
-  6. Conveying Non-Source Forms.
-
-  You may convey a covered work in object code form under the terms
-of sections 4 and 5, provided that you also convey the
-machine-readable Corresponding Source under the terms of this License,
-in one of these ways:
-
-    a) Convey the object code in, or embodied in, a physical product
-    (including a physical distribution medium), accompanied by the
-    Corresponding Source fixed on a durable physical medium
-    customarily used for software interchange.
-
-    b) Convey the object code in, or embodied in, a physical product
-    (including a physical distribution medium), accompanied by a
-    written offer, valid for at least three years and valid for as
-    long as you offer spare parts or customer support for that product
-    model, to give anyone who possesses the object code either (1) a
-    copy of the Corresponding Source for all the software in the
-    product that is covered by this License, on a durable physical
-    medium customarily used for software interchange, for a price no
-    more than your reasonable cost of physically performing this
-    conveying of source, or (2) access to copy the
-    Corresponding Source from a network server at no charge.
-
-    c) Convey individual copies of the object code with a copy of the
-    written offer to provide the Corresponding Source.  This
-    alternative is allowed only occasionally and noncommercially, and
-    only if you received the object code with such an offer, in accord
-    with subsection 6b.
-
-    d) Convey the object code by offering access from a designated
-    place (gratis or for a charge), and offer equivalent access to the
-    Corresponding Source in the same way through the same place at no
-    further charge.  You need not require recipients to copy the
-    Corresponding Source along with the object code.  If the place to
-    copy the object code is a network server, the Corresponding Source
-    may be on a different server (operated by you or a third party)
-    that supports equivalent copying facilities, provided you maintain
-    clear directions next to the object code saying where to find the
-    Corresponding Source.  Regardless of what server hosts the
-    Corresponding Source, you remain obligated to ensure that it is
-    available for as long as needed to satisfy these requirements.
-
-    e) Convey the object code using peer-to-peer transmission, provided
-    you inform other peers where the object code and Corresponding
-    Source of the work are being offered to the general public at no
-    charge under subsection 6d.
-
-  A separable portion of the object code, whose source code is excluded
-from the Corresponding Source as a System Library, need not be
-included in conveying the object code work.
-
-  A "User Product" is either (1) a "consumer product", which means any
-tangible personal property which is normally used for personal, family,
-or household purposes, or (2) anything designed or sold for incorporation
-into a dwelling.  In determining whether a product is a consumer product,
-doubtful cases shall be resolved in favor of coverage.  For a particular
-product received by a particular user, "normally used" refers to a
-typical or common use of that class of product, regardless of the status
-of the particular user or of the way in which the particular user
-actually uses, or expects or is expected to use, the product.  A product
-is a consumer product regardless of whether the product has substantial
-commercial, industrial or non-consumer uses, unless such uses represent
-the only significant mode of use of the product.
-
-  "Installation Information" for a User Product means any methods,
-procedures, authorization keys, or other information required to install
-and execute modified versions of a covered work in that User Product from
-a modified version of its Corresponding Source.  The information must
-suffice to ensure that the continued functioning of the modified object
-code is in no case prevented or interfered with solely because
-modification has been made.
-
-  If you convey an object code work under this section in, or with, or
-specifically for use in, a User Product, and the conveying occurs as
-part of a transaction in which the right of possession and use of the
-User Product is transferred to the recipient in perpetuity or for a
-fixed term (regardless of how the transaction is characterized), the
-Corresponding Source conveyed under this section must be accompanied
-by the Installation Information.  But this requirement does not apply
-if neither you nor any third party retains the ability to install
-modified object code on the User Product (for example, the work has
-been installed in ROM).
-
-  The requirement to provide Installation Information does not include a
-requirement to continue to provide support service, warranty, or updates
-for a work that has been modified or installed by the recipient, or for
-the User Product in which it has been modified or installed.  Access to a
-network may be denied when the modification itself materially and
-adversely affects the operation of the network or violates the rules and
-protocols for communication across the network.
-
-  Corresponding Source conveyed, and Installation Information provided,
-in accord with this section must be in a format that is publicly
-documented (and with an implementation available to the public in
-source code form), and must require no special password or key for
-unpacking, reading or copying.
-
-  7. Additional Terms.
-
-  "Additional permissions" are terms that supplement the terms of this
-License by making exceptions from one or more of its conditions.
-Additional permissions that are applicable to the entire Program shall
-be treated as though they were included in this License, to the extent
-that they are valid under applicable law.  If additional permissions
-apply only to part of the Program, that part may be used separately
-under those permissions, but the entire Program remains governed by
-this License without regard to the additional permissions.
-
-  When you convey a copy of a covered work, you may at your option
-remove any additional permissions from that copy, or from any part of
-it.  (Additional permissions may be written to require their own
-removal in certain cases when you modify the work.)  You may place
-additional permissions on material, added by you to a covered work,
-for which you have or can give appropriate copyright permission.
-
-  Notwithstanding any other provision of this License, for material you
-add to a covered work, you may (if authorized by the copyright holders of
-that material) supplement the terms of this License with terms:
-
-    a) Disclaiming warranty or limiting liability differently from the
-    terms of sections 15 and 16 of this License; or
-
-    b) Requiring preservation of specified reasonable legal notices or
-    author attributions in that material or in the Appropriate Legal
-    Notices displayed by works containing it; or
-
-    c) Prohibiting misrepresentation of the origin of that material, or
-    requiring that modified versions of such material be marked in
-    reasonable ways as different from the original version; or
-
-    d) Limiting the use for publicity purposes of names of licensors or
-    authors of the material; or
-
-    e) Declining to grant rights under trademark law for use of some
-    trade names, trademarks, or service marks; or
-
-    f) Requiring indemnification of licensors and authors of that
-    material by anyone who conveys the material (or modified versions of
-    it) with contractual assumptions of liability to the recipient, for
-    any liability that these contractual assumptions directly impose on
-    those licensors and authors.
-
-  All other non-permissive additional terms are considered "further
-restrictions" within the meaning of section 10.  If the Program as you
-received it, or any part of it, contains a notice stating that it is
-governed by this License along with a term that is a further
-restriction, you may remove that term.  If a license document contains
-a further restriction but permits relicensing or conveying under this
-License, you may add to a covered work material governed by the terms
-of that license document, provided that the further restriction does
-not survive such relicensing or conveying.
-
-  If you add terms to a covered work in accord with this section, you
-must place, in the relevant source files, a statement of the
-additional terms that apply to those files, or a notice indicating
-where to find the applicable terms.
-
-  Additional terms, permissive or non-permissive, may be stated in the
-form of a separately written license, or stated as exceptions;
-the above requirements apply either way.
-
-  8. Termination.
-
-  You may not propagate or modify a covered work except as expressly
-provided under this License.  Any attempt otherwise to propagate or
-modify it is void, and will automatically terminate your rights under
-this License (including any patent licenses granted under the third
-paragraph of section 11).
-
-  However, if you cease all violation of this License, then your
-license from a particular copyright holder is reinstated (a)
-provisionally, unless and until the copyright holder explicitly and
-finally terminates your license, and (b) permanently, if the copyright
-holder fails to notify you of the violation by some reasonable means
-prior to 60 days after the cessation.
-
-  Moreover, your license from a particular copyright holder is
-reinstated permanently if the copyright holder notifies you of the
-violation by some reasonable means, this is the first time you have
-received notice of violation of this License (for any work) from that
-copyright holder, and you cure the violation prior to 30 days after
-your receipt of the notice.
-
-  Termination of your rights under this section does not terminate the
-licenses of parties who have received copies or rights from you under
-this License.  If your rights have been terminated and not permanently
-reinstated, you do not qualify to receive new licenses for the same
-material under section 10.
-
-  9. Acceptance Not Required for Having Copies.
-
-  You are not required to accept this License in order to receive or
-run a copy of the Program.  Ancillary propagation of a covered work
-occurring solely as a consequence of using peer-to-peer transmission
-to receive a copy likewise does not require acceptance.  However,
-nothing other than this License grants you permission to propagate or
-modify any covered work.  These actions infringe copyright if you do
-not accept this License.  Therefore, by modifying or propagating a
-covered work, you indicate your acceptance of this License to do so.
-
-  10. Automatic Licensing of Downstream Recipients.
-
-  Each time you convey a covered work, the recipient automatically
-receives a license from the original licensors, to run, modify and
-propagate that work, subject to this License.  You are not responsible
-for enforcing compliance by third parties with this License.
-
-  An "entity transaction" is a transaction transferring control of an
-organization, or substantially all assets of one, or subdividing an
-organization, or merging organizations.  If propagation of a covered
-work results from an entity transaction, each party to that
-transaction who receives a copy of the work also receives whatever
-licenses to the work the party's predecessor in interest had or could
-give under the previous paragraph, plus a right to possession of the
-Corresponding Source of the work from the predecessor in interest, if
-the predecessor has it or can get it with reasonable efforts.
-
-  You may not impose any further restrictions on the exercise of the
-rights granted or affirmed under this License.  For example, you may
-not impose a license fee, royalty, or other charge for exercise of
-rights granted under this License, and you may not initiate litigation
-(including a cross-claim or counterclaim in a lawsuit) alleging that
-any patent claim is infringed by making, using, selling, offering for
-sale, or importing the Program or any portion of it.
-
-  11. Patents.
-
-  A "contributor" is a copyright holder who authorizes use under this
-License of the Program or a work on which the Program is based.  The
-work thus licensed is called the contributor's "contributor version".
-
-  A contributor's "essential patent claims" are all patent claims
-owned or controlled by the contributor, whether already acquired or
-hereafter acquired, that would be infringed by some manner, permitted
-by this License, of making, using, or selling its contributor version,
-but do not include claims that would be infringed only as a
-consequence of further modification of the contributor version.  For
-purposes of this definition, "control" includes the right to grant
-patent sublicenses in a manner consistent with the requirements of
-this License.
-
-  Each contributor grants you a non-exclusive, worldwide, royalty-free
-patent license under the contributor's essential patent claims, to
-make, use, sell, offer for sale, import and otherwise run, modify and
-propagate the contents of its contributor version.
-
-  In the following three paragraphs, a "patent license" is any express
-agreement or commitment, however denominated, not to enforce a patent
-(such as an express permission to practice a patent or covenant not to
-sue for patent infringement).  To "grant" such a patent license to a
-party means to make such an agreement or commitment not to enforce a
-patent against the party.
-
-  If you convey a covered work, knowingly relying on a patent license,
-and the Corresponding Source of the work is not available for anyone
-to copy, free of charge and under the terms of this License, through a
-publicly available network server or other readily accessible means,
-then you must either (1) cause the Corresponding Source to be so
-available, or (2) arrange to deprive yourself of the benefit of the
-patent license for this particular work, or (3) arrange, in a manner
-consistent with the requirements of this License, to extend the patent
-license to downstream recipients.  "Knowingly relying" means you have
-actual knowledge that, but for the patent license, your conveying the
-covered work in a country, or your recipient's use of the covered work
-in a country, would infringe one or more identifiable patents in that
-country that you have reason to believe are valid.
-
-  If, pursuant to or in connection with a single transaction or
-arrangement, you convey, or propagate by procuring conveyance of, a
-covered work, and grant a patent license to some of the parties
-receiving the covered work authorizing them to use, propagate, modify
-or convey a specific copy of the covered work, then the patent license
-you grant is automatically extended to all recipients of the covered
-work and works based on it.
-
-  A patent license is "discriminatory" if it does not include within
-the scope of its coverage, prohibits the exercise of, or is
-conditioned on the non-exercise of one or more of the rights that are
-specifically granted under this License.  You may not convey a covered
-work if you are a party to an arrangement with a third party that is
-in the business of distributing software, under which you make payment
-to the third party based on the extent of your activity of conveying
-the work, and under which the third party grants, to any of the
-parties who would receive the covered work from you, a discriminatory
-patent license (a) in connection with copies of the covered work
-conveyed by you (or copies made from those copies), or (b) primarily
-for and in connection with specific products or compilations that
-contain the covered work, unless you entered into that arrangement,
-or that patent license was granted, prior to 28 March 2007.
-
-  Nothing in this License shall be construed as excluding or limiting
-any implied license or other defenses to infringement that may
-otherwise be available to you under applicable patent law.
-
-  12. No Surrender of Others' Freedom.
-
-  If conditions are imposed on you (whether by court order, agreement or
-otherwise) that contradict the conditions of this License, they do not
-excuse you from the conditions of this License.  If you cannot convey a
-covered work so as to satisfy simultaneously your obligations under this
-License and any other pertinent obligations, then as a consequence you may
-not convey it at all.  For example, if you agree to terms that obligate you
-to collect a royalty for further conveying from those to whom you convey
-the Program, the only way you could satisfy both those terms and this
-License would be to refrain entirely from conveying the Program.
-
-  13. Use with the GNU Affero General Public License.
-
-  Notwithstanding any other provision of this License, you have
-permission to link or combine any covered work with a work licensed
-under version 3 of the GNU Affero General Public License into a single
-combined work, and to convey the resulting work.  The terms of this
-License will continue to apply to the part which is the covered work,
-but the special requirements of the GNU Affero General Public License,
-section 13, concerning interaction through a network will apply to the
-combination as such.
-
-  14. Revised Versions of this License.
-
-  The Free Software Foundation may publish revised and/or new versions of
-the GNU General Public License from time to time.  Such new versions will
-be similar in spirit to the present version, but may differ in detail to
-address new problems or concerns.
-
-  Each version is given a distinguishing version number.  If the
-Program specifies that a certain numbered version of the GNU General
-Public License "or any later version" applies to it, you have the
-option of following the terms and conditions either of that numbered
-version or of any later version published by the Free Software
-Foundation.  If the Program does not specify a version number of the
-GNU General Public License, you may choose any version ever published
-by the Free Software Foundation.
-
-  If the Program specifies that a proxy can decide which future
-versions of the GNU General Public License can be used, that proxy's
-public statement of acceptance of a version permanently authorizes you
-to choose that version for the Program.
-
-  Later license versions may give you additional or different
-permissions.  However, no additional obligations are imposed on any
-author or copyright holder as a result of your choosing to follow a
-later version.
-
-  15. Disclaimer of Warranty.
-
-  THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY
-APPLICABLE LAW.  EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT
-HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY
-OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,
-THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
-PURPOSE.  THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM
-IS WITH YOU.  SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF
-ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
-
-  16. Limitation of Liability.
-
-  IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
-WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS
-THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY
-GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE
-USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF
-DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD
-PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),
-EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
-SUCH DAMAGES.
-
-  17. Interpretation of Sections 15 and 16.
-
-  If the disclaimer of warranty and limitation of liability provided
-above cannot be given local legal effect according to their terms,
-reviewing courts shall apply local law that most closely approximates
-an absolute waiver of all civil liability in connection with the
-Program, unless a warranty or assumption of liability accompanies a
-copy of the Program in return for a fee.
-
-                     END OF TERMS AND CONDITIONS
-
-            How to Apply These Terms to Your New Programs
-
-  If you develop a new program, and you want it to be of the greatest
-possible use to the public, the best way to achieve this is to make it
-free software which everyone can redistribute and change under these terms.
-
-  To do so, attach the following notices to the program.  It is safest
-to attach them to the start of each source file to most effectively
-state the exclusion of warranty; and each file should have at least
-the "copyright" line and a pointer to where the full notice is found.
-
-    <one line to give the program's name and a brief idea of what it does.>
-    Copyright (C) <year>  <name of author>
-
-    This program is free software: you can redistribute it and/or modify
-    it under the terms of the GNU General Public License as published by
-    the Free Software Foundation, either version 3 of the License, or
-    (at your option) any later version.
-
-    This program is distributed in the hope that it will be useful,
-    but WITHOUT ANY WARRANTY; without even the implied warranty of
-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-    GNU General Public License for more details.
-
-    You should have received a copy of the GNU General Public License
-    along with this program.  If not, see <http://www.gnu.org/licenses/>.
-
-Also add information on how to contact you by electronic and paper mail.
-
-  If the program does terminal interaction, make it output a short
-notice like this when it starts in an interactive mode:
-
-    <program>  Copyright (C) <year>  <name of author>
-    This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
-    This is free software, and you are welcome to redistribute it
-    under certain conditions; type `show c' for details.
-
-The hypothetical commands `show w' and `show c' should show the appropriate
-parts of the General Public License.  Of course, your program's commands
-might be different; for a GUI interface, you would use an "about box".
-
-  You should also get your employer (if you work as a programmer) or school,
-if any, to sign a "copyright disclaimer" for the program, if necessary.
-For more information on this, and how to apply and follow the GNU GPL, see
-<http://www.gnu.org/licenses/>.
-
-  The GNU General Public License does not permit incorporating your program
-into proprietary programs.  If your program is a subroutine library, you
-may consider it more useful to permit linking proprietary applications with
-the library.  If this is what you want to do, use the GNU Lesser General
-Public License instead of this License.  But first, please read
-<http://www.gnu.org/philosophy/why-not-lgpl.html>.
diff --git a/cli/Hcompta/CLI/Args.hs b/cli/Hcompta/CLI/Args.hs
deleted file mode 100644 (file)
index 38c2001..0000000
+++ /dev/null
@@ -1,40 +0,0 @@
-{-# LANGUAGE TupleSections #-}
-module Hcompta.CLI.Args where
-
-import           Control.Monad (Monad(..))
-import           Data.Function ((.))
-import qualified Data.List as List
-import           Data.Monoid ((<>))
-import           Data.Functor ((<$>))
-import           Data.String (String)
-import qualified Data.Text.Lazy as TL
-import           System.Console.GetOpt
-                  ( getOpt
-                  , ArgOrder(..)
-                  , OptDescr(..)
-                  )
-import           System.IO (IO)
-import qualified Text.WalderLeijen.ANSI.Text as W
-
-import           Hcompta.CLI.Context (Context)
-import qualified Hcompta.CLI.Write as Write
-
-type Options context
- = [OptDescr (context -> IO context)]
-
-parse
- :: Context
- -> (Context -> IO String)
- -> (Context -> Options c)
- -> (c, [String])
- -> IO (c, [String])
-parse c usage options (ctx, args) =
-       case getOpt RequireOrder (options c) args of
-        (parsers, cmds, []) ->
-               (, cmds) <$>
-                       List.foldl' (>>=) (return ctx) parsers
-        (_, _, errs) ->
-               usage c >>=
-               Write.fatal c .
-                       (W.vsep (W.text . TL.pack <$> errs) <>) .
-                       W.text . TL.pack
diff --git a/cli/Hcompta/CLI/Command.hs b/cli/Hcompta/CLI/Command.hs
deleted file mode 100644 (file)
index b857e17..0000000
+++ /dev/null
@@ -1,109 +0,0 @@
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TupleSections #-}
-module Hcompta.CLI.Command where
-
-import           Control.Monad (Monad(..))
-import           Data.Bool
-import           Data.List ((++))
-import           Data.Maybe (Maybe(..), fromMaybe)
-import           Data.Monoid ((<>))
-import           Data.Ord (Ord(..))
-import           Data.String (String)
-import qualified Data.Text.Lazy as TL
-import           Prelude (($), (.), Bounded(..), Enum(..), IO, unlines)
-import           System.Console.GetOpt
-                 ( ArgDescr(..)
-                 , OptDescr(..)
-                 , usageInfo )
-import           System.Environment (getProgName)
-import           System.Exit (exitSuccess)
-import qualified System.IO as IO
-import qualified Text.WalderLeijen.ANSI.Text as W
-
-import qualified Hcompta.CLI.Args as Args
--- import qualified Hcompta.CLI.Command.Balance as Command.Balance
--- import qualified Hcompta.CLI.Command.GL as Command.GL
--- import qualified Hcompta.CLI.Command.Journal as Command.Journal
-import qualified Hcompta.CLI.Command.Journals as Command.Journals
--- import qualified Hcompta.CLI.Command.Stats as Command.Stats
--- import qualified Hcompta.CLI.Command.Tags as Command.Tags
-import qualified Hcompta.CLI.Context as C
-import qualified Hcompta.CLI.Lang as Lang
-import qualified Hcompta.CLI.Write as Write
-
-usage :: C.Context -> IO String
-usage c = do
-       bin <- getProgName
-       return $ unlines
-        [ C.translate c Lang.Section_Syntax
-        , "  "++bin++" "++C.translate c Lang.Help_Synopsis
-        , ""
-        , usageInfo (C.translate c Lang.Section_Options) (options c)
-        , C.translate c Lang.Section_Commands
-        , "  [bal|balance]       "++C.translate c Lang.Help_Command_Balance
-        , "  [gl|general_ledger] "++C.translate c Lang.Help_Command_General_Ledger
-        , "  [j|journal]         "++C.translate c Lang.Help_Command_Journal
-        , "  [js|journals]       "++C.translate c Lang.Help_Command_Journals
-        , "  stats               "++C.translate c Lang.Help_Command_Stats
-        , "  tags                "++C.translate c Lang.Help_Command_Tags
-        ]
-
-options :: C.Context -> Args.Options C.Context
-options ctx =
-       [ Option "h" ["help"]
-        (NoArg (\_opts -> do
-               usage ctx >>= IO.hPutStr IO.stderr
-               exitSuccess)) $
-               C.translate ctx Lang.Help_Option_Help
-       , Option "v" ["verbosity"]
-        (OptArg (\arg c ->
-               case arg of
-                Nothing ->
-                       case C.verbosity c of
-                        v | v < maxBound -> return $ c{C.verbosity=succ v}
-                        _                -> return $ c
-                Just "error" -> return $ c{C.verbosity=C.Verbosity_Error}
-                Just "warn"  -> return $ c{C.verbosity=C.Verbosity_Warn}
-                Just "info"  -> return $ c{C.verbosity=C.Verbosity_Info}
-                Just "debug" -> return $ c{C.verbosity=C.Verbosity_Debug}
-                Just _       -> Write.fatal c Lang.Error_Option_Verbosity)
-               "error|warn|info|debug") $
-               C.translate ctx Lang.Help_Option_Verbosity
-       , Option "" ["color"]
-        (OptArg (\arg c -> do
-               color <- case arg of
-                Nothing     -> return $ Just True
-                Just "yes"  -> return $ Just True
-                Just "no"   -> return $ Just False
-                Just "auto" -> return $ Nothing
-                Just _      -> Write.fatal c Lang.Error_Option_Color
-               return $ c{C.color})
-         "[auto|yes|no]") $
-               C.translate ctx Lang.Help_Option_Color
-       , Option "" ["lang"]
-        (ReqArg (\lang c ->
-               return $ c{C.lang =
-                       fromMaybe (C.lang c) $
-                       Lang.from_Strings [lang]
-                })
-         "[xx|xx-XX]") $
-               C.translate ctx Lang.Help_Option_Lang
-       ]
-
-run :: C.Context -> String -> [String] -> IO ()
-run c cmd args =
-       case cmd of
-        -- "bal"            -> Command.Balance.run  c args
-        -- "balance"        -> Command.Balance.run  c args
-        -- "gl"             -> Command.GL.run       c args
-        -- "general_ledger" -> Command.GL.run       c args
-        -- "j"              -> Command.Journal.run  c args
-        -- "journal"        -> Command.Journal.run  c args
-        -- "js"             -> Command.Journals.run c args
-        "journals"       -> Command.Journals.run c args
-        -- "stats"          -> Command.Stats.run    c args
-        -- "tags"           -> Command.Tags.run     c args
-        _ -> usage c >>= Write.fatal c .
-               ((C.translate c (Lang.Error_Unkown_command cmd) <> W.line) <>) .
-               W.text . TL.pack
diff --git a/cli/Hcompta/CLI/Command/Balance.hs b/cli/Hcompta/CLI/Command/Balance.hs
deleted file mode 100644 (file)
index 5fef3bb..0000000
+++ /dev/null
@@ -1,1131 +0,0 @@
-{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Hcompta.CLI.Command.Balance where
-
-import           Control.Applicative ((<*), Const(..), Applicative(..))
-import           Control.Arrow (first, (+++), (&&&), (***))
-import           Control.DeepSeq (NFData)
-import           Control.Monad (Monad(..), liftM, mapM)
-import           Control.Monad.IO.Class (liftIO)
-import           Data.Bool
-import           Data.Data
-import           Data.Decimal (Decimal)
-import           Data.Either (Either(..), partitionEithers)
-import           Data.Eq (Eq(..))
-import           Data.Foldable (Foldable)
-import qualified Data.Foldable as Foldable
-import           Data.Function (($), (.), const, on)
-import           Data.Functor (Functor(..), (<$>))
-import qualified Data.List as List
--- import           Data.List.NonEmpty (NonEmpty(..))
-import           Data.Map.Strict (Map)
-import qualified Data.Map.Strict as Map
-import           Data.Maybe (Maybe(..))
-import           Data.Monoid (Monoid(..), (<>))
-import           Data.Ord (Ord(..), Ordering(..))
-import qualified Data.Strict.Maybe as Strict
-import           Data.String (String)
-import           Data.Text (Text)
-import qualified Data.Time.Clock as Time
-import           Data.TreeMap.Strict (TreeMap)
-import qualified Data.TreeMap.Strict as TreeMap
-import           Data.Tuple (fst, snd)
-import           Prelude (Bounded(..), Num(..), unlines, zipWith)
-import           Data.Function (id, flip)
-import           System.Console.GetOpt
-                 ( ArgDescr(..)
-                 , OptDescr(..)
-                 , usageInfo
-                 )
-import qualified System.Environment as Env
-import           System.Exit (exitSuccess)
-import           System.IO (IO, FilePath)
-import qualified System.IO as IO
-import qualified Text.Parsec
-import           Text.Show (Show(..))
-import           Text.WalderLeijen.ANSI.Text (ToDoc(..))
-import qualified Text.WalderLeijen.ANSI.Text as W
-
-import qualified Hcompta as H
-import qualified Hcompta.Lib.Strict as Strict
-
-import qualified Hcompta.CLI.Args as Args
-import qualified Hcompta.CLI.Context as C
-import qualified Hcompta.CLI.Env as CLI.Env
-import           Hcompta.CLI.Format (Format(..), Formats)
-import qualified Hcompta.CLI.Format as Format
-import           Hcompta.CLI.Format.JCC ()
-import           Hcompta.CLI.Format.Ledger ()
-import qualified Hcompta.CLI.Lang as Lang
-import qualified Hcompta.CLI.Lib.Leijen.Table as Leijen.Table
-import qualified Hcompta.CLI.Write as Write
-import qualified Hcompta.JCC as JCC
-import qualified Hcompta.Ledger as Ledger
-
-import qualified Text.Parsec.Error.Custom as R
-
--- type Sum = (Ledger.Unit, H.Polarized Ledger.Quantity)
-
-data Context
- =   Context
- { {-ctx_filter_transaction :: forall t.
-                             ( Filter.Transaction t
-                             , Filter.Amount_Quantity
-                               (Posting.Posting_Amount
-                               (Filter.Transaction_Posting t))
-                               ~ Filter.Amount.Quantity
-                             ) => Filter.Simplified
-                                  (Filter.Filter_Bool
-                                  (Filter.Filter_Transaction t))
- , ctx_filter_balance     :: forall b.
-                             ( Filter.Balance b
-                             , Filter.Amount_Quantity
-                               (Filter.Balance_Amount b)
-                               ~ Filter.Amount.Quantity
-                             ) => Filter.Simplified
-                                  (Filter.Filter_Bool
-                                  (Filter.Filter_Balance b))
- -- , ctx_filter_posting      :: CLI.Format.Filter_Posting
- ,-} ctx_heritage            :: Bool
- , ctx_input               :: [FilePath]
- , ctx_input_format        :: Formats
- , ctx_output              :: [(Write.Mode, FilePath)]
- , ctx_output_format       :: (Maybe Formats, Output_Format)
- , ctx_reduce_date         :: Bool
- , ctx_redundant           :: Bool
- , ctx_total_by_unit       :: Bool
- , ctx_account_equilibrium :: (JCC.Account, JCC.Account)
- } -- deriving (Show)
-
-data Output_Format
- =   Output_Format_Table
- |   Output_Format_Transaction Lang.Exercise_OC
- deriving (Eq, Show)
-
-context :: C.Context -> Context
-context c =
-       Context
-        { -- ctx_filter_transaction  = Filter.Simplified $ Right True
-        -- , ctx_filter_balance      = Filter.Simplified $ Right True
-        -- , ctx_filter_posting      = mempty
-          ctx_heritage            = True
-        , ctx_input               = []
-        , ctx_input_format        = mempty
-        , ctx_output              = []
-        , ctx_output_format       = (Nothing, Output_Format_Table)
-        , ctx_reduce_date         = True
-        , ctx_redundant           = False
-        , ctx_total_by_unit       = True
-        , ctx_account_equilibrium =
-               let e = C.translate c Lang.Account_Equilibrium
-               in (e, e)
-        }
-
-usage :: C.Context -> IO String
-usage c = do
-       bin <- Env.getProgName
-       return $ unlines $
-               [ C.translate c Lang.Section_Description
-               , "  "<>C.translate c Lang.Help_Command_Balance
-               , ""
-               , C.translate c Lang.Section_Syntax
-               , "  "<>bin<>" balance ["<>C.translate c Lang.Type_Option<>"] [...]"<>
-                                    " ["<>C.translate c Lang.Type_File_Journal<>"] [...]"
-               , ""
-               , usageInfo (C.translate c Lang.Section_Options) (options c)
-               ]
-
-options :: C.Context -> Args.Options Context
-options c =
-       [ {-Option "b" ["filter-balance"]
-        (ReqArg (\s ctx -> do
-               filter <-
-                       R.runParserT_with_Error
-                        Filter.Read.filter_balance
-                        Filter.Read.context "" s
-               case filter of
-                Left (ko::[R.Error Filter.Read.Error]) -> Write.fatal c ko
-                Right flt ->
-                       return $
-                               ctx{ctx_filter_balance =
-                                       Filter.and (ctx_filter_balance ctx) $
-                                       (Filter.simplify $
-                                               Filter.Read.get_Forall_Filter_Balance_Decimal <$> flt)
-                                }) $
-               C.translate c Lang.Type_Filter_Balance) $
-               C.translate c Lang.Help_Option_Filter_Balance
-        -}
-       {-, Option "p" ["filter-posting"]
-        (ReqArg (\s ctx -> do
-               read <- liftIO $ Filter.Read.read Filter.Read.filter_posting s
-               case read of
-                Left ko -> Write.fatal c ko
-                Right filter -> return $
-                       ctx{ctx_filter_posting =
-                               (ctx_filter_posting ctx <>) $
-                               CLI.Format.All
-                                (Filter.simplify $ Filter.Read.get_Forall_Filter_Posting_Decimal <$> filter)
-                                (Filter.simplify $ Filter.Read.get_Forall_Filter_Posting_Decimal <$> filter)
-                        }) $
-               C.translate c Lang.Type_Filter_Posting) $
-               C.translate c Lang.Help_Option_Filter_Posting
-       -}
-       {-, Option "t" ["filter-transaction"]
-        (ReqArg (\s ctx -> do
-               filter <-
-                       R.runParserT_with_Error
-                        Filter.Read.filter_transaction
-                        Filter.Read.context "" s
-               case filter of
-                Left ko -> Write.fatal c ko
-                Right flt ->
-                       return $
-                               ctx{ctx_filter_transaction =
-                                       Filter.and (ctx_filter_transaction ctx) $
-                                       (Filter.simplify $
-                                               Filter.Read.get_Forall_Filter_Transaction_Decimal <$> flt)
-                                }) $
-               C.translate c Lang.Type_Filter_Transaction) $
-               C.translate c Lang.Help_Option_Filter_Transaction
-       ,-} Option "h" ["help"]
-        (NoArg (\_ctx -> do
-               usage c >>= IO.hPutStr IO.stderr
-               exitSuccess)) $
-               C.translate c Lang.Help_Option_Help
-       , Option "i" ["input"]
-        (ReqArg (\s ctx -> do
-               return $ ctx{ctx_input=s:ctx_input ctx}) $
-               C.translate c Lang.Type_File_Journal) $
-               C.translate c Lang.Help_Option_Input
-       , Option "f" ["input-format"]
-        (OptArg (\arg ctx -> do
-               ctx_input_format <- case arg of
-                Nothing       -> return $ Format_JCC ()
-                Just "jcc"    -> return $ Format_JCC ()
-                Just "ledger" -> return $ Format_Ledger ()
-                Just _        -> Write.fatal c $
-                       W.text "--input-format option expects \"jcc\", or \"ledger\" as value"
-               return $ ctx{ctx_input_format})
-         "[jcc|ledger]")
-         "input format"
-       , Option "o" ["output"]
-        (ReqArg (\s ctx -> do
-               return $ ctx{ctx_output=(Write.Mode_Append, s):ctx_output ctx}) $
-               C.translate c Lang.Type_File) $
-               C.translate c Lang.Help_Option_Output
-       , Option "O" ["overwrite"]
-        (ReqArg (\s ctx -> do
-               return $ ctx{ctx_output=(Write.Mode_Over, s):ctx_output ctx}) $
-               C.translate c Lang.Type_File) $
-               C.translate c Lang.Help_Option_Overwrite
-       {- NOTE: not used so far.
-       , Option "" ["reduce-date"]
-        (OptArg (\arg ctx -> do
-               ctx_reduce_date <- case arg of
-                Nothing    -> return $ True
-                Just "yes" -> return $ True
-                Just "no"  -> return $ False
-                Just _     -> Write.fatal c $
-                       W.text "--reduce-date option expects \"yes\", or \"no\" as value"
-               return $ ctx{ctx_reduce_date})
-         "[yes|no]")
-        "use advanced date reducer to speed up filtering"
-       -}
-       , Option "" ["redundant"]
-        (OptArg (\arg ctx -> do
-               ctx_redundant <- case arg of
-                Nothing    -> return $ True
-                Just "yes" -> return $ True
-                Just "no"  -> return $ False
-                Just _     -> Write.fatal c Lang.Error_Option_Balance_Redundant
-               return $ ctx{ctx_redundant})
-         "[no|yes]") $
-               C.translate c Lang.Help_Option_Balance_Redundant
-       , Option "" ["heritage"]
-        (OptArg (\arg ctx -> do
-               ctx_heritage <- case arg of
-                Nothing    -> return $ True
-                Just "yes" -> return $ True
-                Just "no"  -> return $ False
-                Just _     -> Write.fatal c Lang.Error_Option_Balance_Heritage
-               return $ ctx{ctx_heritage})
-         "[yes|no]") $
-               C.translate c Lang.Help_Option_Balance_Heritage
-       , Option "" ["total"]
-        (OptArg (\arg ctx -> do
-               ctx_total_by_unit <- case arg of
-                Nothing    -> return $ True
-                Just "yes" -> return $ True
-                Just "no"  -> return $ False
-                Just _     -> Write.fatal c Lang.Error_Option_Balance_Total
-               return $ ctx{ctx_total_by_unit})
-         "[yes|no]") $
-               C.translate c Lang.Help_Option_Balance_Total
-       , Option "F" ["output-format"]
-        (ReqArg (\arg ctx -> do
-               ctx_output_format <- case arg of
-                "table"        -> return $ (Nothing                , Output_Format_Table)
-                "table.jcc"    -> return $ (Just $ Format_JCC    (), Output_Format_Table)
-                "table.ledger" -> return $ (Just $ Format_Ledger (), Output_Format_Table)
-                "open"         -> return $ (Nothing                , Output_Format_Transaction Lang.Exercise_Opening)
-                "open.jcc"     -> return $ (Just $ Format_JCC    (), Output_Format_Transaction Lang.Exercise_Opening)
-                "open.ledger"  -> return $ (Just $ Format_Ledger (), Output_Format_Transaction Lang.Exercise_Opening)
-                "close"        -> return $ (Nothing                , Output_Format_Transaction Lang.Exercise_Closing)
-                "close.jcc"    -> return $ (Just $ Format_JCC    (), Output_Format_Transaction Lang.Exercise_Closing)
-                "close.ledger" -> return $ (Just $ Format_Ledger (), Output_Format_Transaction Lang.Exercise_Closing)
-                _              -> Write.fatal c Lang.Error_Option_Balance_Format
-               return $ ctx{ctx_output_format})
-         "[table|close|open][.jcc|.ledger]") $
-               C.translate c Lang.Help_Option_Balance_Format
-       , Option "" ["eq"]
-        (ReqArg (\arg ctx -> do
-               ctx_account_equilibrium <-
-                       fmap (\e -> (e, e)) $
-                       case Text.Parsec.runParser
-                                (Ledger.read_account <* Text.Parsec.eof)
-                                () "" arg of
-                        Right acct -> return acct
-                        _          -> Write.fatal c Lang.Error_Option_Equilibrium
-               return $ ctx{ctx_account_equilibrium}) $
-               C.translate c Lang.Type_Account) $
-               C.translate c Lang.Help_Option_Equilibrium
-       , Option "" ["eq-credit"]
-        (ReqArg (\arg ctx -> do
-               ctx_account_equilibrium <-
-                       fmap (\e -> (fst $ ctx_account_equilibrium ctx, e)) $
-                       case Text.Parsec.runParser
-                                (Ledger.read_account <* Text.Parsec.eof)
-                                () "" arg of
-                        Right acct -> return acct
-                        _          -> Write.fatal c Lang.Error_Option_Equilibrium_Credit
-               return $ ctx{ctx_account_equilibrium}) $
-               C.translate c Lang.Type_Account) $
-               C.translate c Lang.Help_Option_Equilibrium_Credit
-       , Option "" ["eq-debit"]
-        (ReqArg (\arg ctx -> do
-               ctx_account_equilibrium <-
-                       fmap (\e -> (e, snd $ ctx_account_equilibrium ctx)) $
-                       case Text.Parsec.runParser
-                                (Ledger.read_account <* Text.Parsec.eof)
-                                () "" arg of
-                        Right acct -> return acct
-                        _          -> Write.fatal c Lang.Error_Option_Equilibrium_Debit
-               return $ ctx{ctx_account_equilibrium}) $
-               C.translate c Lang.Type_Account) $
-               C.translate c Lang.Help_Option_Equilibrium_Debit
-       ]
-
-run :: C.Context -> [String] -> IO ()
-run c args = do
-       (ctx, inputs) <-
-               first (\x ->
-                       case ctx_output x of
-                        [] -> x{ctx_output=[(Write.Mode_Append, "-")]}
-                        _  -> x) <$>
-               Args.parse c usage options (context c, args)
-       input_paths <- CLI.Env.paths c $ ctx_input ctx <> inputs
-       read_journals <- mapM (liftIO . journal_read ctx) input_paths
-       case partitionEithers read_journals of
-        (errs@(_:_), _journals) -> Write.fatals c errs
-        ([], (journals::[Forall_Journal_Balance_by_Account])) -> do
-               let bal_by_account =
-                       mconcat $
-                       fmap Format.journal_flatten $
-                       case fst $ ctx_output_format ctx of
-                        Just f -> Format.journal_empty f:journals
-                        Nothing -> journals
-               now <- H.date_epoch
-               with_color <- Write.with_color c IO.stdout
-               W.displayIO IO.stdout $
-                       W.renderPretty with_color 1.0 maxBound $
-                       case snd $ ctx_output_format ctx of
-                        Output_Format_Table ->
-                               toDoc () $ Leijen.Table.table_of (c, ctx) bal_by_account
-                        Output_Format_Transaction oc ->
-                               journal_equilibrium_transaction
-                                (Const bal_by_account::Const Forall_Journal_Balance_by_Account ())
-                                c ctx oc now
-               {-
-               Write.debug c $ "filter: transaction: " ++ show (ctx_filter_transaction ctx)
-               Write.debug c $ "filter: posting: " ++ show (ctx_filter_posting ctx)
-               Write.debug c $ "filter: balance: " ++ show (ctx_filter_balance ctx)
-               let sty = Write.style { Write.style_pretty = True }
-               -}
-
-instance Leijen.Table.Table_of (C.Context, Context) Forall_Journal_Balance_by_Account where
-       table_of (c, ctx) bal_by_account =
-               let lang = C.lang c in
-               let (rows_by_account, rows_by_unit) =
-                       case ctx_heritage ctx of
-                        True  -> rows_of_balance_by_account $ expand bal_by_account
-                        False -> rows_of_balance_by_account          bal_by_account in
-               zipWith id
-                [ Leijen.Table.column (Lang.translate lang Lang.Title_Debit)   Leijen.Table.Align_Right
-                , Leijen.Table.column (Lang.translate lang Lang.Title_Credit)  Leijen.Table.Align_Right
-                , Leijen.Table.column (Lang.translate lang Lang.Title_Balance) Leijen.Table.Align_Right
-                , Leijen.Table.column (Lang.translate lang Lang.Title_Account) Leijen.Table.Align_Left
-                ] $
-               rows_by_account $
-               (if ctx_total_by_unit ctx
-                then zipWith (:)
-                        [ Leijen.Table.Cell_Line '=' 0
-                        , Leijen.Table.Cell_Line '=' 0
-                        , Leijen.Table.Cell_Line '=' 0
-                        , Leijen.Table.Cell_Line ' ' 0
-                        ] . rows_by_unit
-                else id) $
-               List.repeat []
-               where
-                       expand
-                        :: Forall_Journal_Balance_by_Account
-                        -> Forall_Journal_Balance_by_Account_Expanded
-                       expand = Format.journal_wrap
-                       rows_of_balance_by_account
-                        :: ( Format.Journal_Filter Context (Const bal_by_account) ()
-                           , Format.Journal_Wrap bal_by_account Forall_Journal_Balance_by_Unit
-                           , Format.Journal_Leijen_Table_Cells (Const bal_by_account) ()
-                           )
-                        => bal_by_account
-                        -> ( [[Leijen.Table.Cell]] -> [[Leijen.Table.Cell]]
-                           , [[Leijen.Table.Cell]] -> [[Leijen.Table.Cell]] )
-                       rows_of_balance_by_account =
-                               (***) Format.journal_leijen_table_cells
-                                     Format.journal_leijen_table_cells .
-                               (&&&) id sum_by_unit .
-                               Format.journal_filter ctx .
-                               Const
-                               where
-                                       sum_by_unit
-                                        :: Format.Journal_Wrap bal_by_account Forall_Journal_Balance_by_Unit
-                                        => Const bal_by_account ()
-                                        -> Const Forall_Journal_Balance_by_Unit ()
-                                       sum_by_unit = Const . Format.journal_wrap . getConst
-
-
-
-
-
-
-
-
-
-
--- * 'H.Balance_by_Account'
-
--- ** Type 'Format_Balance_by_Account'
-
-type Format_Journal_Balance_by_Account
- = Format
-   (   JCC.Journal Balance_by_Account_JCC)
-   (Ledger.Journal Balance_by_Account_Ledger)
-
--- JCC
-type Balance_by_Account_JCC
- = H.Balance_by_Account JCC.Account_Section
-                        JCC.Unit
-                        (H.Polarized JCC.Quantity)
-instance Format.Journal (JCC.Journal Balance_by_Account_JCC) where
-       type Journal_Format   (JCC.Journal Balance_by_Account_JCC)
-        = Format_Journal_Balance_by_Account
-       journal_format = Format_JCC
-
--- Ledger
-type Balance_by_Account_Ledger
- = H.Balance_by_Account Ledger.Account_Section
-                        Ledger.Unit
-                        (H.Polarized Ledger.Quantity)
-instance Format.Journal (Ledger.Journal Balance_by_Account_Ledger) where
-       type Journal_Format   (Ledger.Journal Balance_by_Account_Ledger)
-        = Format_Journal_Balance_by_Account
-       journal_format = Format_Ledger
-
--- ** Class 'Journal_Balance_by_Account'
-
-class
- ( Format.Journal (j m)
- , Format.Journal_Format (j m) ~ Format_Journal_Balance_by_Account
- , Format.Journal_Read j
- , Format.Journal_Monoid (j m)
- , Format.Journal_Leijen_Table_Cells j m
- , Format.Journal_Wrap (j m) Forall_Journal_Balance_by_Account_Expanded
- , Format.Journal_Wrap (j m) Forall_Journal_Balance_by_Unit
- , Format.Journal_Filter Context j m
- , Journal_Equilibrium_Transaction j m
- ) => Journal_Balance_by_Account j m
-
-instance Journal_Balance_by_Account    JCC.Journal Balance_by_Account_JCC
-instance Journal_Balance_by_Account Ledger.Journal Balance_by_Account_Ledger
-
--- ** Type 'Forall_Journal_Balance_by_Account'
-
-data    Forall_Journal_Balance_by_Account
- = forall j m. Journal_Balance_by_Account  j m
- =>     Forall_Journal_Balance_by_Account (j m)
-
-instance Format.Journal Forall_Journal_Balance_by_Account where
-       type Journal_Format   Forall_Journal_Balance_by_Account = Format_Journal_Balance_by_Account
-       journal_format
-        (Forall_Journal_Balance_by_Account j) =
-               Format.journal_format j
-instance Format.Journal_Empty Forall_Journal_Balance_by_Account where
-       journal_empty f =
-               case f of
-                Format_JCC    () -> Forall_Journal_Balance_by_Account (mempty::JCC.Journal Balance_by_Account_JCC)
-                Format_Ledger () -> Forall_Journal_Balance_by_Account (mempty::Ledger.Journal Balance_by_Account_Ledger)
-instance Format.Journal_Monoid Forall_Journal_Balance_by_Account where
-       journal_flatten
-        (Forall_Journal_Balance_by_Account j) =
-               Forall_Journal_Balance_by_Account $
-               Format.journal_flatten j
-       journal_fold f (Forall_Journal_Balance_by_Account j) =
-               Format.journal_fold (f . Forall_Journal_Balance_by_Account) j
-instance Monoid Forall_Journal_Balance_by_Account where
-       mempty = Forall_Journal_Balance_by_Account (mempty::JCC.Journal Balance_by_Account_JCC)
-       mappend x y =
-               case (mappend `on` Format.journal_format) x y of
-                Format_JCC    j -> Forall_Journal_Balance_by_Account j
-                Format_Ledger j -> Forall_Journal_Balance_by_Account j
-       mconcat js =
-               case js of
-                [] -> mempty
-                j:jn -> List.foldl' mappend j jn
-
--- ** 'journal_read'
-
-type Journal_Filter_Simplified transaction
- = Filter.Simplified
-   (Filter.Filter_Bool
-   (Filter.Filter_Transaction transaction))
-type Journal_Read_Cons txn
- = txn -> Filter.Filtered (Journal_Filter_Simplified txn) txn
-journal_read
- :: Context -> FilePath
- -> IO (Either (Format.Message W.Doc) Forall_Journal_Balance_by_Account)
-journal_read ctx =
-       case ctx_input_format ctx of
-        Format_JCC () ->
-               let wrap (j::JCC.Journal Balance_by_Account_JCC)
-                        = Forall_Journal_Balance_by_Account j in
-               let cons :: Journal_Read_Cons (JCC.Charted JCC.Transaction)
-                        = Filter.Filtered (ctx_filter_transaction ctx) in
-               liftM ((+++) Format.Message wrap) .
-               Format.journal_read cons
-        Format_Ledger () ->
-               let wrap (j::Ledger.Journal Balance_by_Account_Ledger)
-                        = Forall_Journal_Balance_by_Account j in
-               let cons :: Journal_Read_Cons (Ledger.Charted Ledger.Transaction)
-                        = Filter.Filtered (ctx_filter_transaction ctx) in
-               liftM ((+++) Format.Message wrap) .
-               Format.journal_read cons
-
-{-
--- ** Type family 'Balance_by_Account'
-
-type family Balance_by_Account (j:: * -> *) m
-type instance Balance_by_Account
-   j (Balance.Expanded           as u (Polarized q))
- = j (Balance.Balance_by_Account as u (Polarized q))
-type instance Balance_by_Account
-   (Const Forall_Journal_Balance_by_Account_Expanded) ()
- = (Const Forall_Journal_Balance_by_Account         ) ()
--}
-
--- Instances 'Format.Journal_Filter'
-
-instance
- ( Functor j
- , Format.Journal_Chart j
- , as ~ Format.Journal_Account_Section j
- , Data as
- {-, Filter.Account (Account_Tags, TreeMap.Path as)-}
- , NFData as
- , Ord as
- , Show as
- , q ~ Format.Journal_Quantity j
- , Format.Journal_Quantity j ~ Decimal
- , H.Addable q
- , H.Zero q
- , H.Unit u
- ) => Format.Journal_Filter Context j (H.Balance_by_Account as u (H.Polarized q)) where
-       journal_filter ctx j =
-               case Filter.simplified $ ctx_filter_balance ctx of
-                Right True | ctx_redundant ctx -> j
-                Right True ->
-                       TreeMap.filter_with_Path_and_Node
-                        (\n _p -> is_worth n) <$> j
-                Right False -> const mempty <$> j
-                Left flt ->
-                       (<$> j) $
-                       TreeMap.map_Maybe_with_Path_and_Node
-                        (\node account (H.Balance_by_Account_Sum bal) ->
-                               (if is_worth node bal then id else const Strict.Nothing) $
-                               case Map.mapMaybeWithKey
-                                (\unit qty ->
-                                       if Filter.test flt
-                                                ( (H.chart_account_tags account (Format.journal_chart j), account)
-                                                , (unit, qty)
-                                                )
-                                       then Just qty
-                                       else Nothing
-                                ) bal of
-                                m | Map.null m -> Strict.Nothing
-                                m -> Strict.Just $ H.Balance_by_Account_Sum m
-                        )
-               where
-                       is_worth
-                        :: (Ord k0, Foldable t0, H.Addable a0, H.Zero a0)
-                        => TreeMap.Node k0 x0
-                        -> t0 (H.Polarized a0)
-                        -> Bool
-                       is_worth _node bal =
-                               ctx_redundant ctx
-                               -- NOTE: worth if no descendant
-                               -- but Account's exclusive
-                               -- has at least a non-zero Amount
-                               || Foldable.any
-                                        (not . H.quantity_null . H.depolarize)
-                                        bal
-instance Format.Journal_Filter Context (Const Forall_Journal_Balance_by_Account) () where
-       journal_filter ctx
-        (Const (Forall_Journal_Balance_by_Account j)) =
-               Const $ Forall_Journal_Balance_by_Account $
-               Format.journal_filter ctx j
-
--- Instances 'Format.Journal_Leijen_Table_Cells'
-
-instance
- ( Format.Journal_Content j
- , Journal j
- , as ~ Format.Journal_Account_Section j
- , Ord as
- , H.Addable (Format.Journal_Quantity j)
- , Leijen.Table.Cell_of_forall_param j (TreeMap.Path as)
- , Balance_by_Account_Sum amt
- , Balance_by_Account_Sum_Unit amt ~ Format.Journal_Unit j
- , Balance_by_Account_Sum_Quantity amt ~ H.Polarized (Format.Journal_Quantity j)
- ) => Format.Journal_Leijen_Table_Cells j (TreeMap as amt) where
-       journal_leijen_table_cells jnl =
-               flip (TreeMap.foldr_with_Path
-                (\account balance rows ->
-                       let H.Balance_by_Account_Sum bal = balance_by_account_sum balance in
-                       Map.foldrWithKey
-                        (\unit qty ->
-                               zipWith (:)
-                                [ cell_of $ (unit,) <$> H.polarized_positive qty
-                                , cell_of $ (unit,) <$> H.polarized_negative qty
-                                , cell_of (unit, H.depolarize qty)
-                                , cell_of account
-                                ]
-                        )
-                        rows bal
-                ))
-                (Format.journal_content jnl)
-               where
-                       cell_of :: Leijen.Table.Cell_of_forall_param j x => x -> Leijen.Table.Cell
-                       cell_of = Leijen.Table.cell_of_forall_param jnl
-instance Format.Journal_Leijen_Table_Cells (Const Forall_Journal_Balance_by_Account) () where
-       journal_leijen_table_cells
-        (Const (Forall_Journal_Balance_by_Account j)) =
-               Format.journal_leijen_table_cells j
-
--- ** Class 'Balance_by_Account_Sum'
-
--- | A class to get a 'H.Balance_Account_Sum'
---   when operating on 'H.Balance_by_Account'
---   or 'H.Balance_Expanded' 'Strict.inclusive' field.
-class Balance_by_Account_Sum amt where
-       type Balance_by_Account_Sum_Unit     amt
-       type Balance_by_Account_Sum_Quantity amt
-       balance_by_account_sum
-        :: amt -> H.Balance_by_Account_Sum (Balance_by_Account_Sum_Unit amt)
-                                           (Balance_by_Account_Sum_Quantity amt)
-instance Balance_by_Account_Sum (H.Balance_by_Account_Sum u q) where
-       type Balance_by_Account_Sum_Unit     (H.Balance_by_Account_Sum u q) = u
-       type Balance_by_Account_Sum_Quantity (H.Balance_by_Account_Sum u q) = q
-       balance_by_account_sum = id
-instance Balance_by_Account_Sum (H.Balance_by_Account_Sum_Expanded u q) where
-       type Balance_by_Account_Sum_Unit     (H.Balance_by_Account_Sum_Expanded u q) = u
-       type Balance_by_Account_Sum_Quantity (H.Balance_by_Account_Sum_Expanded u q) = q
-       balance_by_account_sum = Strict.inclusive
-
--- * 'H.Balance_Expanded'
-
--- ** Type 'Format_Journal_Balance_by_Account_Expanded'
-
-type Format_Journal_Balance_by_Account_Expanded
- = Format
-   (   JCC.Journal Balance_by_Account_Expanded_JCC)
-   (Ledger.Journal Balance_by_Account_Expanded_Ledger)
-
--- JCC
-type Balance_by_Account_Expanded_JCC
- = H.Balance_Expanded JCC.Account_Section
-                    JCC.Unit
-                    (H.Polarized JCC.Quantity)
-instance Format.Journal (JCC.Journal Balance_by_Account_Expanded_JCC) where
-       type Journal_Format   (JCC.Journal Balance_by_Account_Expanded_JCC)
-        = Format_Journal_Balance_by_Account_Expanded
-       journal_format = Format_JCC
-
--- Ledger
-type Balance_by_Account_Expanded_Ledger
- = H.Balance_Expanded Ledger.Account_Section
-                      Ledger.Unit
-                      (H.Polarized Ledger.Quantity)
-instance Format.Journal (Ledger.Journal Balance_by_Account_Expanded_Ledger) where
-       type Journal_Format   (Ledger.Journal Balance_by_Account_Expanded_Ledger)
-        = Format_Journal_Balance_by_Account_Expanded
-       journal_format = Format_Ledger
-
--- ** Class 'Journal_Balance_by_Account_Expanded'
-
-class
- ( Format.Journal (j m)
- , Format.Journal_Format (j m) ~ Format_Journal_Balance_by_Account_Expanded
- , Format.Journal_Leijen_Table_Cells j m
- , Format.Journal_Wrap (j m) Forall_Journal_Balance_by_Unit
- , Format.Journal_Filter Context j m
- ) => Journal_Balance_by_Account_Expanded j m
-
-instance Journal_Balance_by_Account_Expanded    JCC.Journal Balance_by_Account_Expanded_JCC
-instance Journal_Balance_by_Account_Expanded Ledger.Journal Balance_by_Account_Expanded_Ledger
-
--- ** Type 'Forall_Journal_Balance_by_Account_Expanded'
-
-data    Forall_Journal_Balance_by_Account_Expanded
- = forall j m. Journal_Balance_by_Account_Expanded  j m
- =>     Forall_Journal_Balance_by_Account_Expanded (j m)
-
-instance Format.Journal Forall_Journal_Balance_by_Account_Expanded where
-       type Journal_Format   Forall_Journal_Balance_by_Account_Expanded = Format_Journal_Balance_by_Account_Expanded
-       journal_format
-        (Forall_Journal_Balance_by_Account_Expanded j) =
-               Format.journal_format j
-
--- Instances 'Format.Journal_Filter'
-
-instance
- ( Functor j
- , Format.Journal_Chart j
- , as ~ Format.Journal_Account_Section j
- , Data as
- {-, Filter.Account (Account_Tags, TreeMap.Path as)-}
- , NFData as
- , Ord as
- , Show as
- , q ~ Format.Journal_Quantity j
- , Format.Journal_Quantity j ~ Decimal
- , H.Addable q
- , H.Zero q
- , H.Unit u
- ) => Format.Journal_Filter Context j (H.Balance_Expanded as u (H.Polarized q)) where
-       journal_filter ctx j =
-               case Filter.simplified $ ctx_filter_balance ctx of
-                Right True | ctx_redundant ctx -> j
-                Right True ->
-                       TreeMap.filter_with_Path_and_Node
-                        (const . is_worth) <$> j
-                Right False -> const mempty <$> j
-                Left flt ->
-                       (<$> j) $
-                       TreeMap.map_Maybe_with_Path_and_Node
-                        (\node account bal ->
-                               (if is_worth node bal then id else const Strict.Nothing) $
-                               case Map.mapMaybeWithKey
-                                (\unit qty ->
-                                       if Filter.test flt
-                                                ( (H.chart_account_tags account (Format.journal_chart j), account)
-                                                , (unit, qty)
-                                                )
-                                       then Just qty
-                                       else Nothing
-                                ) (H.unBalance_by_Account_Sum $ Strict.inclusive bal) of
-                                m | Map.null m -> Strict.Nothing
-                                m -> Strict.Just $ bal{Strict.inclusive=H.Balance_by_Account_Sum m}
-                        )
-               where
-                       is_worth node bal =
-                               let descendants = TreeMap.nodes
-                                        (TreeMap.node_descendants node) in
-                               ctx_redundant ctx
-                               -- NOTE: worth if no descendant
-                               -- but Account's inclusive
-                               -- has at least a non-zero Amount
-                               || (Map.null descendants &&
-                                       Foldable.any
-                                                (not . H.quantity_null . H.depolarize)
-                                                (H.unBalance_by_Account_Sum $ Strict.inclusive bal))
-                               -- NOTE: worth if Account's exclusive
-                               -- has at least a non-zero Amount
-                               || (Foldable.any
-                                        (not . H.quantity_null . H.depolarize)
-                                        (H.unBalance_by_Account_Sum $ Strict.exclusive bal))
-                               -- NOTE: worth if Account has at least more than
-                               -- one descendant Account whose inclusive
-                               -- has at least a non-zero Amount
-                               || Map.size
-                                        ( Map.filter
-                                                ( Strict.maybe False
-                                                        ( Foldable.any
-                                                                (not . H.quantity_null . H.depolarize)
-                                                        . H.unBalance_by_Account_Sum
-                                                        . Strict.inclusive )
-                                                . TreeMap.node_value )
-                                                descendants
-                                        ) > 1
-instance Format.Journal_Filter Context (Const Forall_Journal_Balance_by_Account_Expanded) () where
-       journal_filter ctx
-        (Const (Forall_Journal_Balance_by_Account_Expanded j)) =
-               Const $ Forall_Journal_Balance_by_Account_Expanded $
-               Format.journal_filter ctx j
-
--- Instances 'Format.Journal_Leijen_Table_Cells'
-
-instance Format.Journal_Leijen_Table_Cells (Const Forall_Journal_Balance_by_Account_Expanded) x where
-       journal_leijen_table_cells
-        (Const (Forall_Journal_Balance_by_Account_Expanded j)) =
-               Format.journal_leijen_table_cells j
-
--- Instances H.Balance_by_Account -> H.Balance_Expanded
-
-instance
- ( Functor j
- , Journal_Balance_by_Account_Expanded j (H.Balance_Expanded as u q)
- -- NOTE: constraints from H.balance_expanded
- , Ord as
- , Ord u
- , H.Addable q
- ) => Format.Journal_Wrap (j (H.Balance_by_Account as u q))
-                          Forall_Journal_Balance_by_Account_Expanded where
-       journal_wrap =
-               Forall_Journal_Balance_by_Account_Expanded .
-               fmap H.balance_expanded
-
-instance Format.Journal_Wrap Forall_Journal_Balance_by_Account
-                             Forall_Journal_Balance_by_Account_Expanded where
-       journal_wrap (Forall_Journal_Balance_by_Account j) = Format.journal_wrap j
-
-
-
-
-
-
-
-
-
-
-
--- * 'H.Balance_by_Unit'
-
-type Format_Journal_Balance_by_Unit
- = Format
-   (   JCC.Journal Balance_by_Unit_JCC)
-   (Ledger.Journal Balance_by_Unit_Ledger)
-
--- JCC
-type Balance_by_Unit_JCC
- = H.Balance_by_Unit JCC.Account
-                     JCC.Unit
-                     (H.Polarized JCC.Quantity)
-instance Format.Journal (JCC.Journal Balance_by_Unit_JCC) where
-       type Journal_Format   (JCC.Journal Balance_by_Unit_JCC)
-        = Format_Journal_Balance_by_Unit
-       journal_format = Format_JCC
-
--- Ledger
-type Balance_by_Unit_Ledger
- = H.Balance_by_Unit Ledger.Account
-                     Ledger.Unit
-                     (H.Polarized Ledger.Quantity)
-instance Format.Journal (Ledger.Journal Balance_by_Unit_Ledger) where
-       type Journal_Format   (Ledger.Journal Balance_by_Unit_Ledger)
-        = Format_Journal_Balance_by_Unit
-       journal_format = Format_Ledger
-
--- ** Class 'Journal_Balance_by_Unit'
-
-class
- ( Format.Journal (j m)
- , Format.Journal_Format (j m) ~ Format_Journal_Balance_by_Unit
- , Format.Journal_Leijen_Table_Cells j m
- -- , Journal_Equilibrium_Postings j m
- )
- => Journal_Balance_by_Unit j m
-
-instance Journal_Balance_by_Unit    JCC.Journal Balance_by_Unit_JCC
-instance Journal_Balance_by_Unit Ledger.Journal Balance_by_Unit_Ledger
-
--- ** Type 'Forall_Journal_Balance_by_Unit'
-
-data    Forall_Journal_Balance_by_Unit
- = forall j m. Journal_Balance_by_Unit  j m
- =>     Forall_Journal_Balance_by_Unit (j m)
-
-instance Format.Journal Forall_Journal_Balance_by_Unit where
-       type Journal_Format   Forall_Journal_Balance_by_Unit = Format_Journal_Balance_by_Unit
-       journal_format (Forall_Journal_Balance_by_Unit j) = Format.journal_format j
-
--- Instances H.Balance_by_Account -> H.Balance_by_Unit
-
-instance
- ( Functor j
- , Journal_Balance_by_Unit j (H.Balance_by_Unit (H.Account_Path as) u q)
- -- NOTE: constraints from H.balance_by_unit_of_by_account
- , H.Account (H.Account_Path as)
- , Ord as
- , Ord u
- , H.Addable q
- ) => Format.Journal_Wrap (j (H.Balance_by_Account as u q))
-                          Forall_Journal_Balance_by_Unit where
-       journal_wrap =
-               Forall_Journal_Balance_by_Unit .
-               fmap (flip H.balance_by_unit_of_by_account mempty)
-
-instance Format.Journal_Wrap Forall_Journal_Balance_by_Account
-                             Forall_Journal_Balance_by_Unit where
-       journal_wrap
-        (Forall_Journal_Balance_by_Account j) =
-               Format.journal_wrap j
-
--- Instances H.Balance_Expanded -> H.Balance_by_Unit
-
-instance
- ( Functor j
- , Journal_Balance_by_Unit j (H.Balance_by_Unit (H.Account_Path as) u q)
- -- NOTE: constraints from H.balance_by_unit_of_expanded
- , H.Account (H.Account_Path as)
- , Ord as
- , Ord u
- , H.Addable q
- ) => Format.Journal_Wrap (j (H.Balance_Expanded as u q))
-                          Forall_Journal_Balance_by_Unit where
-       journal_wrap =
-               Forall_Journal_Balance_by_Unit .
-               fmap (flip H.balance_by_unit_of_expanded mempty)
-
-instance Format.Journal_Wrap Forall_Journal_Balance_by_Account_Expanded
-                             Forall_Journal_Balance_by_Unit where
-       journal_wrap
-        (Forall_Journal_Balance_by_Account_Expanded j) =
-               Format.journal_wrap j
-
--- Instances 'Format.Journal_Leijen_Table_Cells'
-
-instance
- ( Format.Journal_Content j
- , Journal j
- , a ~ Format.Journal_Account j
- , H.Account a
- , u ~ Format.Journal_Unit j
- , Ord u
- , q ~ Format.Journal_Quantity j
- , H.Addable (Format.Journal_Quantity j)
- ) => Format.Journal_Leijen_Table_Cells j (H.Balance_by_Unit a u (H.Polarized q)) where
-       journal_leijen_table_cells jnl acc =
-               let H.Balance_by_Unit bal = Format.journal_content jnl in
-               Map.foldrWithKey
-                (\unit amt ->
-                       let qty = H.balance_by_unit_sum_quantity amt in
-                       zipWith (:)
-                               [ Leijen.Table.cell_of_forall_param jnl $ (unit,) <$> H.polarized_positive qty
-                               , Leijen.Table.cell_of_forall_param jnl $ (unit,) <$> H.polarized_negative qty
-                               , Leijen.Table.cell_of_forall_param jnl (unit, H.depolarize qty)
-                               , Leijen.Table.cell
-                               ]
-                ) acc bal
-instance Format.Journal_Leijen_Table_Cells (Const Forall_Journal_Balance_by_Unit) () where
-       journal_leijen_table_cells
-        (Const (Forall_Journal_Balance_by_Unit j)) =
-               Format.journal_leijen_table_cells j
-
-
-
-
-
-
-
-
-
--- * Class 'Journal'
-
-class
- ( Leijen.Table.Cell_of_forall_param j (Format.Journal_Unit j, Format.Journal_Quantity j)
- , W.ToDoc1 j [Format.Journal_Transaction j]
- ) => Journal (j:: * -> *) where
-       journal_posting
-        :: forall m. j m
-        -> H.Account_Path (Format.Journal_Account_Section j)
-        -> Map (Format.Journal_Unit j)
-               (Format.Journal_Quantity j)
-        -> [Text] -- ^ Comments
-        -> Format.Journal_Posting j
-       journal_transaction
-        :: forall m. j m
-        -> Text -- ^ Wording
-        -> (H.Date, [H.Date])
-        -> Map (H.Account_Path (Format.Journal_Account_Section j))
-               [Format.Journal_Posting j]
-        -> Format.Journal_Transaction j
-
-instance Journal JCC.Journal where
-       journal_posting _j acct
-        posting_amounts
-        posting_comments =
-               (JCC.posting acct)
-                { JCC.posting_amounts
-                , JCC.posting_comments
-                }
-       journal_transaction _j
-        transaction_wording
-        transaction_dates
-        transaction_postings =
-               JCC.transaction
-                { JCC.transaction_wording
-                , JCC.transaction_dates
-                , JCC.transaction_postings
-                }
-instance Journal Ledger.Journal where
-       journal_posting _j acct
-        posting_amounts
-        posting_comments =
-               (Ledger.posting acct)
-                { Ledger.posting_amounts
-                , Ledger.posting_comments
-                }
-       journal_transaction _j
-        transaction_wording
-        transaction_dates
-        transaction_postings =
-               Ledger.transaction
-                { Ledger.transaction_wording
-                , Ledger.transaction_dates
-                , Ledger.transaction_postings
-                }
-
-
-
-
-
-
-
-
-
-
-
-
-
--- * Class 'Journal_Equilibrium_Transaction'
-
-class Journal_Equilibrium_Transaction j m where
-       journal_equilibrium_transaction
-        :: j m
-        -> C.Context
-        -> Context
-        -> Lang.Exercise_OC
-        -> H.Date
-        -> W.Doc
-
-instance
- ( Format.Journal_Content j
- , Journal j
- , as ~ Format.Journal_Account_Section j
- , Format.Journal_Account_Section j ~ Text
- , Format.Journal_Account j ~ TreeMap.Path Text
- , Num quantity
- , quantity ~ Format.Journal_Quantity j
- , Ord unit
- , Ord quantity
- , H.Zero (Format.Journal_Quantity j)
- , H.Addable (Format.Journal_Quantity j)
- , unit ~ Format.Journal_Unit j
- ) => Journal_Equilibrium_Transaction
- j (H.Balance_by_Account as unit (H.Polarized quantity)) where
-       journal_equilibrium_transaction
-        j c ctx oc now =
-               let bal_by_account = Format.journal_content j in
-               let H.Balance_by_Unit bal_by_unit =
-                       H.balance_by_unit_of_by_account bal_by_account mempty in
-               let postings =
-                       Map.foldlWithKey
-                        (\acc unit H.Balance_by_Unit_Sum{..} ->
-                               let qty =
-                                       (case oc of
-                                        Lang.Exercise_Closing -> id
-                                        Lang.Exercise_Opening -> negate) $
-                                       H.depolarize balance_by_unit_sum_quantity in
-                               case H.quantity_sign qty of
-                                LT ->
-                                       let account = snd $ ctx_account_equilibrium ctx in
-                                       Map.insertWith mappend account
-                                        [journal_posting j account
-                                                (Map.singleton unit qty)
-                                                [ Lang.translate (C.lang c) Lang.Comment_Equilibrium ]]
-                                        acc
-                                EQ -> acc
-                                GT ->
-                                       let account = fst $ ctx_account_equilibrium ctx in
-                                       Map.insertWith mappend account
-                                        [journal_posting j account
-                                                (Map.singleton unit qty)
-                                                [ Lang.translate (C.lang c) Lang.Comment_Equilibrium ]]
-                                        acc
-                        )
-                        Map.empty
-                        bal_by_unit
-                in
-               W.toDoc1 j [
-               journal_transaction j
-                (Lang.translate (C.lang c) (Lang.Description_Exercise oc))
-                (now{Time.utctDayTime=0}, []) $
-               Map.unionWith mappend postings $
-               TreeMap.flatten_with_Path
-                (\posting_account (H.Balance_by_Account_Sum amount_by_unit) ->
-                       [ journal_posting j posting_account
-                                (flip fmap amount_by_unit $
-                                       (case oc of
-                                        Lang.Exercise_Closing -> negate
-                                        Lang.Exercise_Opening -> id)
-                                       . H.depolarize)
-                                []
-                       ]
-                )
-                bal_by_account
-                ]
-
-instance Journal_Equilibrium_Transaction (Const Forall_Journal_Balance_by_Account) () where
-       journal_equilibrium_transaction
-        (Const (Forall_Journal_Balance_by_Account j)) =
-               journal_equilibrium_transaction j
-
-{-
-instance
-  ToDoc (C.Context, Context, Date, Lang.Exercise_OC)
-        ( Forall_Journal_Balance_by_Account
-        , Forall_Journal_Balance_by_Unit ) where
-       toDoc c
-        ( Forall_Journal_Balance_by_Account bal_by_account
-        , Forall_Journal_Balance_by_Unit    bal_by_unit
-        ) =
-               toDoc c (bal_by_account, bal_by_unit)
--}
diff --git a/cli/Hcompta/CLI/Command/Diff.hs b/cli/Hcompta/CLI/Command/Diff.hs
deleted file mode 100644 (file)
index e69de29..0000000
diff --git a/cli/Hcompta/CLI/Command/GL.hs b/cli/Hcompta/CLI/Command/GL.hs
deleted file mode 100644 (file)
index a7eb535..0000000
+++ /dev/null
@@ -1,925 +0,0 @@
-{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Hcompta.CLI.Command.GL where
-
-import           Control.Applicative (Const(..), (<$>))
-import           Control.Arrow (first, (+++))
-import           Control.Monad (Monad(..), liftM, mapM)
-import           Control.Monad.IO.Class (liftIO)
-import           Data.Bool
-import           Data.Decimal (Decimal)
-import           Data.Either (Either(..), partitionEithers)
-import           Data.Foldable (Foldable(..))
-import           Data.Function (($), (.), on, id, flip)
-import           Data.Functor (Functor(..))
-import           Data.List ((++), repeat)
-import           Data.Map.Strict (Map)
-import qualified Data.Map.Strict as Map
-import           Data.Maybe (Maybe(..))
-import           Data.Monoid (Monoid(..))
-import           Data.Ord (Ord)
-import qualified Data.Sequence as Seq
-import qualified Data.Strict.Maybe as Strict
-import           Data.String (String)
-import           Data.Text (Text)
-import           Prelude (Bounded(..), unlines, zipWith)
-import           System.Console.GetOpt
-                 ( ArgDescr(..)
-                 , OptDescr(..)
-                 , usageInfo
-                 )
-import           System.Environment as Env (getProgName)
-import           System.Exit (exitSuccess)
-import qualified System.IO as IO
-import           System.IO (FilePath, IO)
-
-import qualified Hcompta.Account as Account
-import qualified Hcompta.CLI.Args as Args
-import qualified Hcompta.CLI.Context as C
-import qualified Hcompta.CLI.Env as CLI.Env
-import           Hcompta.CLI.Format.Ledger ()
-import           Hcompta.CLI.Format.JCC ()
-import qualified Hcompta.CLI.Lang as Lang
-import qualified Hcompta.CLI.Lib.Leijen.Table as Leijen.Table
-import qualified Hcompta.CLI.Write as Write
-import qualified Hcompta.Chart as Chart
-import           Hcompta.Date (Date)
-import qualified Hcompta.Filter as Filter
-import qualified Hcompta.Filter.Read as Filter.Read
-import qualified Hcompta.Format.JCC as JCC
-import qualified Hcompta.Format.Ledger as Ledger
-import qualified Hcompta.GL as GL
-import           Hcompta.Lib.Leijen (toDoc, ToDoc(..))
-import qualified Hcompta.Lib.TreeMap as TreeMap
-import           Hcompta.Polarize (Polarized)
-import qualified Hcompta.Polarize as Polarize
-import qualified Hcompta.Posting as Posting
-import qualified Hcompta.Filter.Amount as Filter.Amount
-import           Hcompta.CLI.Format (Format(..), Formats)
-import qualified Hcompta.CLI.Format as Format
-import qualified Hcompta.Lib.Leijen as W
-import qualified Hcompta.Lib.Parsec as R
-import qualified Hcompta.Unit as Unit
-import qualified Hcompta.Quantity as Quantity
-
-data Context
- =   Context
- { ctx_filter_transaction :: forall t.
-                             ( Filter.Transaction t
-                             , Filter.Amount_Quantity
-                               (Posting.Posting_Amount
-                               (Filter.Transaction_Posting t))
-                               ~ Filter.Amount.Quantity
-                             ) => Filter.Simplified
-                                  (Filter.Filter_Bool
-                                  (Filter.Filter_Transaction t))
- , ctx_filter_gl          :: forall b.
-                             ( Filter.GL b
-                             , Filter.Amount_Quantity
-                               (Filter.GL_Amount b)
-                               ~ Filter.Amount.Quantity
-                             ) => Filter.Simplified
-                                  (Filter.Filter_Bool
-                                  (Filter.Filter_GL b))
- , ctx_input              :: [FilePath]
- , ctx_input_format       :: Formats
- , ctx_output             :: [(Write.Mode, FilePath)]
- , ctx_output_format      :: Maybe Formats
-
- -- , ctx_filter_gl          :: Filter.Simplified
- --                             (Filter.Filter_Bool
- --                             (Filter.Filter_GL
- --                             ( (Account_Tags, Ledger.Account)
- --                             , Date
- --                             , (Ledger.Unit, Polarize.Polarized Ledger.Quantity)
- --                             , (Ledger.Unit, Polarize.Polarized Ledger.Quantity) )))
- -- , ctx_filter_posting     :: Filter.Simplified
- --                             (Filter.Filter_Bool
- --                             (Filter.Filter_Posting
- --                             (Ledger.Charted Ledger.Posting)))
- , ctx_reduce_date        :: Bool
- } -- deriving (Show)
-
-context :: Context
-context =
-       Context
-        { ctx_filter_gl          = Filter.Simplified $ Right True
-        -- , ctx_filter_posting     = Filter.Simplified $ Right True
-        , ctx_filter_transaction = Filter.Simplified $ Right True
-        , ctx_input              = []
-        , ctx_input_format       = mempty
-        , ctx_output             = []
-        , ctx_output_format      = mempty
-        , ctx_reduce_date        = True
-        }
-
-usage :: C.Context -> IO String
-usage c = do
-       bin <- Env.getProgName
-       return $ unlines $
-               [ C.translate c Lang.Section_Description
-               , "  "++C.translate c Lang.Help_Command_General_Ledger
-               , ""
-               , C.translate c Lang.Section_Syntax
-               , "  "++bin++" gl ["++C.translate c Lang.Type_Option++"] [...]"++
-                               " ["++C.translate c Lang.Type_File_Journal++"] [...]"
-               , ""
-               , usageInfo (C.translate c Lang.Section_Options) (options c)
-               ]
-
-options :: C.Context -> Args.Options Context
-options c =
-       [ Option "g" ["filter-gl"]
-        (ReqArg (\s ctx -> do
-               filter <-
-                       R.runParserT_with_Error
-                        Filter.Read.filter_gl
-                        Filter.Read.context "" s
-               case filter of
-                Left (ko::[R.Error Filter.Read.Error]) -> Write.fatal c ko
-                Right flt ->
-                       return $
-                               ctx{ctx_filter_gl =
-                                       Filter.and (ctx_filter_gl ctx) $
-                                       (Filter.simplify $
-                                               Filter.Read.get_Forall_Filter_GL_Decimal <$> flt)
-                                }) $
-               C.translate c Lang.Type_Filter_General_Ledger) $
-               C.translate c Lang.Help_Option_Filter_General_Ledger
-       {-, Option "p" ["filter-posting"]
-        (ReqArg (\s ctx -> do
-               ctx_filter_posting <-
-                       liftM ((ctx_filter_posting ctx <>) . Filter.simplify) $
-                       liftIO $ Filter.Read.read Filter.Read.filter_posting s
-                       >>= \f -> case f of
-                        Left  ko -> Write.fatal c $ ko
-                        Right ok -> return ok
-               return $ ctx{ctx_filter_posting}) $
-               C.translate c Lang.Type_Filter_Posting) $
-               C.translate c Lang.Help_Option_Filter_Posting
-       -}
-       , Option "t" ["filter-transaction"]
-        (ReqArg (\s ctx -> do
-               filter <-
-                       R.runParserT_with_Error
-                        Filter.Read.filter_transaction
-                        Filter.Read.context "" s
-               case filter of
-                Left ko -> Write.fatal c ko
-                Right flt ->
-                       return $
-                               ctx{ctx_filter_transaction =
-                                       Filter.and (ctx_filter_transaction ctx) $
-                                       (Filter.simplify $
-                                               Filter.Read.get_Forall_Filter_Transaction_Decimal <$> flt)
-                                }) $
-               C.translate c Lang.Type_Filter_Transaction) $
-               C.translate c Lang.Help_Option_Filter_Transaction
-       , Option "h" ["help"]
-        (NoArg (\_ctx -> do
-               usage c >>= IO.hPutStr IO.stderr
-               exitSuccess)) $
-               C.translate c Lang.Help_Option_Help
-       , Option "i" ["input"]
-        (ReqArg (\s ctx -> do
-               return $ ctx{ctx_input=s:ctx_input ctx}) $
-               C.translate c Lang.Type_File_Journal) $
-               C.translate c Lang.Help_Option_Input
-       , Option "f" ["input-format"]
-        (OptArg (\arg ctx -> do
-               ctx_input_format <- case arg of
-                Nothing       -> return $ Format_JCC ()
-                Just "jcc"    -> return $ Format_JCC ()
-                Just "ledger" -> return $ Format_Ledger ()
-                Just _        -> Write.fatal c $
-                       W.text "--input-format option expects \"jcc\", or \"ledger\" as value"
-               return $ ctx{ctx_input_format})
-         "[jcc|ledger]")
-         "input format"
-       , Option "o" ["output"]
-        (ReqArg (\s ctx -> do
-               return $ ctx{ctx_output=(Write.Mode_Append, s):ctx_output ctx}) $
-               C.translate c Lang.Type_File) $
-               C.translate c Lang.Help_Option_Output
-       , Option "F" ["output-format"]
-        (ReqArg (\arg ctx -> do
-               ctx_output_format <- case arg of
-                "jcc"    -> return $ Just $ Format_JCC ()
-                "ledger" -> return $ Just $ Format_Ledger ()
-                _        -> Write.fatal c $
-                       W.text "--output-format option expects \"jcc\", or \"ledger\" as value"
-               return $ ctx{ctx_output_format})
-         "[jcc|ledger]") $
-               "output format"
-       , Option "O" ["overwrite"]
-        (ReqArg (\s ctx -> do
-               return $ ctx{ctx_output=(Write.Mode_Over, s):ctx_output ctx}) $
-               C.translate c Lang.Type_File) $
-               C.translate c Lang.Help_Option_Overwrite
-       {- NOTE: not used so far.
-       , Option "" ["reduce-date"]
-        (OptArg (\arg c ctx -> do
-               ctx_reduce_date <- case arg of
-                Nothing    -> return $ True
-                Just "yes" -> return $ True
-                Just "no"  -> return $ False
-                Just _     -> Write.fatal c $
-                       W.text "--reduce-date option expects \"yes\", or \"no\" as value"
-               return $ ctx{ctx_reduce_date})
-         "[yes|no]")
-        "use advanced date reducer to speed up filtering"
-       -}
-       ]
-
-run :: C.Context -> [String] -> IO ()
-run c args = do
-       (ctx, inputs) <-
-               first (\x ->
-                       case ctx_output x of
-                        [] -> x{ctx_output=[(Write.Mode_Append, "-")]}
-                        _  -> x) <$>
-               Args.parse c usage options (context, args)
-       input_paths <- CLI.Env.paths c $ ctx_input ctx ++ inputs
-       read_journals <- mapM (liftIO . journal_read ctx) input_paths
-       case partitionEithers read_journals of
-        (errs@(_:_), _journals) -> Write.fatals c errs
-        ([], (journals::[Forall_Journal_GL])) -> do
-               let gl =
-                       mconcat $
-                       fmap Format.journal_flatten $
-                       case ctx_output_format ctx of
-                        Just f -> Format.journal_empty f:journals
-                        Nothing -> journals
-               with_color <- Write.with_color c IO.stdout
-               W.displayIO IO.stdout $
-                       W.renderPretty with_color 1.0 maxBound $
-                       toDoc () $ Leijen.Table.table_of (c, ctx) gl
-               {-
-               Write.debug c $ "filter: transaction: " ++ show (ctx_filter_transaction ctx)
-               Write.debug c $ "filter: posting: " ++ show (ctx_filter_posting ctx)
-               Write.debug c $ "filter: balance: " ++ show (ctx_filter_balance ctx)
-               -}
-
-instance Leijen.Table.Table_of (C.Context, Context) Forall_Journal_GL where
-       table_of (c, ctx) gl =
-               let lang = C.lang c in
-               zipWith id
-                [ Leijen.Table.column (Lang.translate lang Lang.Title_Account)         Leijen.Table.Align_Left
-                , Leijen.Table.column (Lang.translate lang Lang.Title_Date)            Leijen.Table.Align_Left
-                , Leijen.Table.column (Lang.translate lang Lang.Title_Debit)           Leijen.Table.Align_Right
-                , Leijen.Table.column (Lang.translate lang Lang.Title_Credit)          Leijen.Table.Align_Right
-                , Leijen.Table.column (Lang.translate lang Lang.Title_Running_debit)   Leijen.Table.Align_Right
-                , Leijen.Table.column (Lang.translate lang Lang.Title_Running_credit)  Leijen.Table.Align_Right
-                , Leijen.Table.column (Lang.translate lang Lang.Title_Running_balance) Leijen.Table.Align_Right
-                , Leijen.Table.column (Lang.translate lang Lang.Title_Description)     Leijen.Table.Align_Left
-                ] $
-               Format.journal_leijen_table_cells
-                (Format.journal_filter ctx $
-                       (Const::x -> Const x ()) gl) $
-               repeat []
-
-
--- * 'GL.GL'
-
--- ** Type 'Format_GL'
-
-type Format_Journal_GL
- = Format
-   (   JCC.Journal GL_JCC)
-   (Ledger.Journal GL_Ledger)
-
--- JCC
-type GL_JCC
- = GL.GL (JCC.Charted JCC.Transaction)
- -- = GL.GL JCC.Transaction
-instance Format.Journal (JCC.Journal GL_JCC) where
-       type Journal_Format   (JCC.Journal GL_JCC)
-        = Format_Journal_GL
-       journal_format = Format_JCC
-
--- Ledger
-type GL_Ledger
- -- = GL.GL Ledger.Transaction
- = GL.GL (Ledger.Charted Ledger.Transaction)
-instance Format.Journal (Ledger.Journal GL_Ledger) where
-       type Journal_Format   (Ledger.Journal GL_Ledger)
-        = Format_Journal_GL
-       journal_format = Format_Ledger
-
--- ** Class 'Journal'
-
-class
- ( Format.Journal_Read j
- , Ord (Account.Account_Section (Format.Journal_Account j))
- , Leijen.Table.Cell_of_forall_param j
-    (TreeMap.Path (Account.Account_Section
-     (GL.Posting_Account (Format.Journal_Posting j))))
- , Leijen.Table.Cell_of_forall_param j
-    (Format.Journal_Unit j, Format.Journal_Quantity j)
- , Leijen.Table.Cell_of_forall_param j
-    (TreeMap.Path (Account.Account_Section (GL.Posting_Account
-     (Chart.Charted (Format.Journal_Account j)
-      (Format.Journal_Posting j)))))
- , Polarize.Polarizable (Format.Journal_Quantity j)
- ) => Journal j
- where
-       journal_transaction_wording
-        :: forall m. j m
-        -> Format.Journal_Transaction j
-        -> Text
-       journal_posting_amounts
-        :: forall m. j m
-        -> Format.Journal_Posting j
-        -> Map (Format.Journal_Unit j)
-               (Format.Journal_Quantity j)
-       journal_posting_amounts_set
-        :: forall m. j m
-        -> Map (Format.Journal_Unit j)
-               (Format.Journal_Quantity j)
-        -> Format.Journal_Posting j
-        -> Format.Journal_Posting j
-
-instance Journal JCC.Journal
- where
-       journal_transaction_wording _j = JCC.transaction_wording
-       journal_posting_amounts     _j = JCC.posting_amounts
-       journal_posting_amounts_set _j posting_amounts p =
-               p { JCC.posting_amounts }
-instance Journal Ledger.Journal
- where
-       journal_transaction_wording _j = Ledger.transaction_wording
-       journal_posting_amounts     _j = Ledger.posting_amounts
-       journal_posting_amounts_set _j posting_amounts p =
-               p { Ledger.posting_amounts }
-
--- ** Class 'Journal_GL'
-
-class
- ( Format.Journal (j m)
- , Format.Journal_Format (j m) ~ Format_Journal_GL
- , Format.Journal_Read j
- , Format.Journal_Monoid (j m)
- , Format.Journal_Leijen_Table_Cells j m
- , Format.Journal_Filter Context j m
- ) => Journal_GL j m
-
-instance Journal_GL JCC.Journal    GL_JCC
-instance Journal_GL Ledger.Journal GL_Ledger
-
--- ** Type 'Forall_Journal_GL'
-
-data    Forall_Journal_GL
- = forall j m. Journal_GL  j m
- =>     Forall_Journal_GL (j m)
-
-instance Format.Journal Forall_Journal_GL where
-       type Journal_Format   Forall_Journal_GL = Format_Journal_GL
-       journal_format
-        (Forall_Journal_GL j) =
-               Format.journal_format j
-instance Format.Journal_Empty Forall_Journal_GL where
-       journal_empty f =
-               case f of
-                Format_JCC    () -> Forall_Journal_GL (mempty::JCC.Journal GL_JCC)
-                Format_Ledger () -> Forall_Journal_GL (mempty::Ledger.Journal GL_Ledger)
-instance Format.Journal_Monoid Forall_Journal_GL where
-       journal_flatten
-        (Forall_Journal_GL j) =
-               Forall_Journal_GL $
-               Format.journal_flatten j
-       journal_fold f (Forall_Journal_GL j) =
-               Format.journal_fold (f . Forall_Journal_GL) j
-instance Monoid Forall_Journal_GL where
-       mempty = Forall_Journal_GL (mempty::JCC.Journal GL_JCC)
-       mappend x y =
-               case (mappend `on` Format.journal_format) x y of
-                Format_JCC    j -> Forall_Journal_GL j
-                Format_Ledger j -> Forall_Journal_GL j
-       mconcat js =
-               case js of
-                [] -> mempty
-                j:jn -> foldl' mappend j jn
-
-
--- *** 'journal_read'
-
-type Journal_Filter_Simplified transaction
- = Filter.Simplified
-   (Filter.Filter_Bool
-   (Filter.Filter_Transaction transaction))
-type Journal_Read_Cons txn
- = txn -> Filter.Filtered (Journal_Filter_Simplified txn) txn
-journal_read
- :: Context -> FilePath
- -> IO (Either (Format.Message W.Doc) Forall_Journal_GL)
-journal_read ctx =
-       case ctx_input_format ctx of
-        Format_JCC () ->
-               let wrap (j::JCC.Journal GL_JCC)
-                        = Forall_Journal_GL j in
-               let cons :: Journal_Read_Cons (JCC.Charted JCC.Transaction)
-                        = Filter.Filtered (ctx_filter_transaction ctx) in
-               liftM ((+++) Format.Message wrap) .
-               Format.journal_read cons
-        Format_Ledger () ->
-               let wrap (j::Ledger.Journal GL_Ledger)
-                        = Forall_Journal_GL j in
-               let cons :: Journal_Read_Cons (Ledger.Charted Ledger.Transaction)
-                        = Filter.Filtered (ctx_filter_transaction ctx) in
-               liftM ((+++) Format.Message wrap) .
-               Format.journal_read cons
-
-
--- Instances 'Format.Journal_Filter'
-
-instance
- ( Functor j
- , Format.Journal_Chart j
- , Journal j
- , Journal_GL j (GL.GL t)
- , GL.Transaction t
- , Format.Journal_Account_Section j ~ Text
- , GL.Transaction_Posting t
-   ~ Chart.Charted (Format.Journal_Account j)
-                   (Format.Journal_Posting j)
- , GL.Posting_Quantity (GL.Transaction_Posting t)
-   ~ Map (Format.Journal_Unit j)
-         (Polarized (Format.Journal_Quantity j))
- , Format.Journal_Quantity j ~ Decimal
- , Format.Journal_Account_Section j
-   ~ Account.Account_Section (GL.Posting_Account (GL.Transaction_Posting t))
- , Ord (Format.Journal_Unit j)
- , Unit.Unit (Format.Journal_Unit j)
- ) => Format.Journal_Filter Context j (GL.GL t) where
-       journal_filter ctx j =
-               GL.GL .
-               TreeMap.map_Maybe_with_Path
-                (\acct expanded_lines ->
-                       let chart = Format.journal_chart j in
-                       case Map.mapMaybeWithKey
-                        (\date seq_lines ->
-                               case foldMap
-                                (\line@GL.GL_Line
-                                { GL.gl_line_transaction = _t
-                                , GL.gl_line_posting     = p
-                                , GL.gl_line_sum         = s
-                                } ->
-                                       Map.foldlWithKey
-                                        (\acc unit qty ->
-                                               let sqty = (Map.!) s unit in
-                                               if Filter.test (ctx_filter_gl ctx)
-                                                ( (Chart.account_tags acct chart, acct)
-                                                , date
-                                                , (unit, Polarize.polarize qty)
-                                                , (unit, sqty)
-                                                )
-                                               then (Seq.|>) acc line
-                                                { GL.gl_line_posting =
-                                                       journal_posting_amounts_set j
-                                                        (Map.singleton unit qty) <$> p
-                                                , GL.gl_line_sum = Map.singleton unit sqty
-                                                }
-                                               else acc
-                                        )
-                                        Seq.empty
-                                        (journal_posting_amounts j $ Chart.charted p)
-                                ) seq_lines
-                                of
-                                m | Seq.null m -> Nothing
-                                m -> Just m
-                        )
-                        (GL.inclusive expanded_lines)
-                        of
-                               m | Map.null m -> Strict.Nothing
-                               m -> Strict.Just m
-                ) .
-               (\(GL.Expanded gl) -> gl) .
-               GL.expanded <$> j
-instance Format.Journal_Filter Context (Const Forall_Journal_GL) () where
-       journal_filter ctx
-        (Const (Forall_Journal_GL j)) =
-               Const $ Forall_Journal_GL $
-               Format.journal_filter ctx j
-
--- Instances 'Format.Journal_Leijen_Table_Cells'
-
-instance
- ( Format.Journal_Content j
- , Journal j
- , Quantity.Addable (Format.Journal_Quantity j)
- , GL.Transaction_Posting t
-   ~ Chart.Charted (Format.Journal_Account j)
-                   (Format.Journal_Posting j)
- , Format.Journal_Transaction j ~ GL.Transaction_Line t
- , GL.Posting_Quantity (Chart.Charted (Format.Journal_Account j)
-                       (Format.Journal_Posting j))
-   ~ Map (Format.Journal_Unit j)
-         (Polarized (Format.Journal_Quantity j))
- , GL.Posting_Quantity (Format.Journal_Posting j)
-   ~ Map (Format.Journal_Unit j)
-         (Polarized (Format.Journal_Quantity j))
- -- , GL.Posting_Account t ~ Format.Journal_Account j
- -- , Leijen.Table.Cell_of_forall_param j (TreeMap.Path as)
- , Leijen.Table.Cell_of_forall_param j Date
- , Leijen.Table.Cell_of_forall_param j Text
- , Ord (Format.Journal_Unit j)
- , GL.Transaction t
- ) => Format.Journal_Leijen_Table_Cells j (GL.GL t) where
-       journal_leijen_table_cells jnl =
-               flip (TreeMap.foldr_with_Path
-                (\account ->
-                       flip $ Map.foldrWithKey
-                        (\date ->
-                               flip $ foldr
-                                (\GL.GL_Line
-                                        { GL.gl_line_transaction = t
-                                        , GL.gl_line_posting     = p
-                                        , GL.gl_line_sum         = s
-                                        } ->
-                                       flip (Map.foldrWithKey
-                                        (\unit qty ->
-                                               let ms = Map.lookup unit s in
-                                               zipWith (:)
-                                                [ cell_of account
-                                                , cell_of date
-                                                , cell_of $ (unit,) <$> Polarize.polarizable_positive qty
-                                                , cell_of $ (unit,) <$> Polarize.polarizable_negative qty
-                                                , cell_of $ (unit,) <$> (ms >>= Polarize.polarized_positive)
-                                                , cell_of $ (unit,) <$> (ms >>= Polarize.polarized_negative)
-                                                , cell_of $ (unit,) . Polarize.depolarize <$> ms
-                                                , cell_of $ journal_transaction_wording jnl t
-                                                ]
-                                        ))
-                                        (journal_posting_amounts jnl $ Chart.charted p)
-                                )
-                        )
-                )) $
-                (\(GL.GL x) -> x)
-                (Format.journal_content jnl)
-               where
-                       cell_of :: Leijen.Table.Cell_of_forall_param j x => x -> Leijen.Table.Cell
-                       cell_of = Leijen.Table.cell_of_forall_param jnl
-
-instance Format.Journal_Leijen_Table_Cells (Const Forall_Journal_GL) () where
-       journal_leijen_table_cells
-        (Const (Forall_Journal_GL j)) =
-               Format.journal_leijen_table_cells j
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-{-
--- Instances GL.GL -> GL.Expanded
-
-instance
- ( Functor j
- , Journal_GL_Expanded j (GL.Expanded t)
- -- NOTE: constraint from GL.expanded
- , GL.Transaction t
- ) => Format.Journal_Wrap (j (GL.GL t))
-                          Forall_Journal_GL_Expanded where
-       journal_wrap =
-               Forall_Journal_GL_Expanded .
-               fmap GL.expanded
-
-instance Format.Journal_Wrap Forall_Journal_GL
-                             Forall_Journal_GL_Expanded where
-       journal_wrap (Forall_Journal_GL j) = Format.journal_wrap j
--}
-{-
--- * 'GL.GL_Expanded'
-
--- ** Type 'Format_GL_Expanded'
-
-type Format_Journal_GL_Expanded
- = Format
-   (   JCC.Journal GL_Expanded_JCC)
-   (Ledger.Journal GL_Expanded_Ledger)
-
--- JCC
-type GL_Expanded_JCC
- = GL.Expanded (JCC.Charted JCC.Transaction)
-instance Format.Journal (JCC.Journal GL_Expanded_JCC) where
-       type Journal_Format   (JCC.Journal GL_Expanded_JCC)
-        = Format_Journal_GL_Expanded
-       journal_format = Format_JCC
-
--- Ledger
-type GL_Expanded_Ledger
- = GL.Expanded (Ledger.Charted Ledger.Transaction)
-instance Format.Journal (Ledger.Journal GL_Expanded_Ledger) where
-       type Journal_Format   (Ledger.Journal GL_Expanded_Ledger)
-        = Format_Journal_GL_Expanded
-       journal_format = Format_Ledger
-
--- ** Class 'Journal_GL_Expanded'
-
-class
- ( Format.Journal (j m)
- , Format.Journal_Format (j m) ~ Format_Journal_GL_Expanded
- -- , Format.Journal_Leijen_Table_Cells j m
- , Format.Journal_Filter Context j m
- ) => Journal_GL_Expanded j m where
-       journal_posting_amounts
-        :: j m
-        -> Format.Journal_Posting j
-        -> Map (Format.Journal_Unit j)
-               (Format.Journal_Quantity j)
-       journal_posting_amounts_set
-        :: j m
-        -> Map (Format.Journal_Unit j)
-               (Format.Journal_Quantity j)
-        -> Format.Journal_Posting j
-        -> Format.Journal_Posting j
-
-instance Journal_GL_Expanded    JCC.Journal GL_Expanded_JCC
- where
-       journal_posting_amounts     _j = JCC.posting_amounts
-       journal_posting_amounts_set _j posting_amounts p =
-               p { JCC.posting_amounts }
-instance Journal_GL_Expanded Ledger.Journal GL_Expanded_Ledger
- where
-       journal_posting_amounts     _j = Ledger.posting_amounts
-       journal_posting_amounts_set _j posting_amounts p =
-               p { Ledger.posting_amounts }
-
--- ** Type 'Forall_Journal_GL_Expanded'
-
-data    Forall_Journal_GL_Expanded
- = forall j m. Journal_GL_Expanded  j m
- =>     Forall_Journal_GL_Expanded (j m)
-
-instance Format.Journal Forall_Journal_GL_Expanded where
-       type Journal_Format   Forall_Journal_GL_Expanded = Format_Journal_GL_Expanded
-       journal_format
-        (Forall_Journal_GL_Expanded j) =
-               Format.journal_format j
-
--- Instances 'Format.Journal_Filter'
-
-instance
- ( Functor j
- , Format.Journal_Chart j
- , Journal_GL_Expanded j (GL.Expanded t)
- , GL.Transaction t
- , Format.Journal_Account_Section j ~ Text
- , GL.Transaction_Posting t ~ Chart.Charted (Format.Journal_Account j) (Format.Journal_Posting j)
- , GL.Posting_Quantity (GL.Transaction_Posting t)
-   ~ Map (Format.Journal_Unit j) (Polarized (Format.Journal_Quantity j))
- , Format.Journal_Quantity j ~ Decimal
- , Format.Journal_Account_Section j
-   ~ Account.Account_Section (GL.Posting_Account (GL.Transaction_Posting t))
- , Ord (Format.Journal_Unit j)
- , Unit.Unit (Format.Journal_Unit j)
- ) => Format.Journal_Filter Context j (GL.Expanded t) where
-       journal_filter ctx j =
-               GL.Expanded .
-               TreeMap.map_Maybe_with_Path
-                (\acct expanded_lines ->
-                       let chart = Format.journal_chart j in
-                       case Map.mapMaybeWithKey
-                        (\date seq_lines ->
-                               case foldMap
-                                (\line@GL.GL_Line
-                                { GL.gl_line_transaction = _t
-                                , GL.gl_line_posting     = Chart.Charted ch p
-                                , GL.gl_line_sum         = s
-                                } ->
-                                       Map.foldlWithKey
-                                        (\acc unit qty ->
-                                               let sqty = (Map.!) s unit in
-                                               if Filter.test (ctx_filter_gl ctx)
-                                                ( (Chart.account_tags acct chart, acct)
-                                                , date
-                                                , (unit, Polarize.polarize qty)
-                                                , (unit, sqty)
-                                                )
-                                               then (Seq.|>) acc line
-                                                { GL.gl_line_posting =
-                                                       Chart.Charted ch $
-                                                       journal_posting_amounts_set j
-                                                        (Map.singleton unit qty) p
-                                                , GL.gl_line_sum = Map.singleton unit sqty
-                                                }
-                                               else acc
-                                        )
-                                        Seq.empty
-                                        (journal_posting_amounts j p)
-                                ) seq_lines
-                                of
-                                m | Seq.null m -> Nothing
-                                m -> Just m
-                        )
-                        (GL.inclusive expanded_lines)
-                        of
-                               m | Map.null m -> Strict.Nothing
-                               m -> Strict.Just $ expanded_lines { GL.inclusive=m }
-                ) .
-               (\(GL.Expanded gl) -> gl) <$> j
-
-instance Format.Journal_Filter Context (Const Forall_Journal_GL_Expanded) () where
-       journal_filter ctx
-        (Const (Forall_Journal_GL_Expanded j)) =
-               Const $ Forall_Journal_GL_Expanded $
-               Format.journal_filter ctx j
--}
-
-{-
-run :: C.Context -> [String] -> IO ()
-run c args = do
-       (ctx, inputs) <-
-               first (\x ->
-                       case ctx_output x of
-                        [] -> x{ctx_output=[(Write.Mode_Append, "-")]}
-                        _  -> x) <$>
-               Args.parse c usage options (context, args)
-       read_journals <-
-               liftM partitionEithers $ do
-               CLI.Env.paths c $ ctx_input ctx ++ inputs
-               >>= do
-                       mapM $ \path -> do
-                               liftIO $ runExceptT $ Ledger.Read.file
-                                (Ledger.Read.context ( ctx_filter_transaction ctx
-                                                     , ctx_filter_posting     ctx )
-                                                     Ledger.journal)
-                                path
-                               >>= \x -> case x of
-                                Left  ko -> return $ Left (path, ko)
-                                Right ok -> return $ Right ok
-       case read_journals of
-        (errs@(_:_), _journals) ->
-               forM_ errs $ \(_path, err) -> do
-                       Write.fatal c $ err
-        ([], journals) -> do
-               Write.debug c $ "filter: transaction: " ++ show (ctx_filter_transaction ctx)
-               Write.debug c $ "filter: posting: " ++ show (ctx_filter_posting ctx)
-               Write.debug c $ "filter: gl: " ++ show (ctx_filter_gl ctx)
-               let (amount_styles, gl) = ledger_gl ctx journals
-               let lang = C.lang c
-               Write.write c Write.style (ctx_output ctx) $ do
-               toDoc () $ do
-               zipWith id
-                [ Table.column (Lang.translate lang Lang.Title_Account)         Table.Align_Left
-                , Table.column (Lang.translate lang Lang.Title_Date)            Table.Align_Left
-                , Table.column (Lang.translate lang Lang.Title_Debit)           Table.Align_Right
-                , Table.column (Lang.translate lang Lang.Title_Credit)          Table.Align_Right
-                , Table.column (Lang.translate lang Lang.Title_Running_debit)   Table.Align_Right
-                , Table.column (Lang.translate lang Lang.Title_Running_credit)  Table.Align_Right
-                , Table.column (Lang.translate lang Lang.Title_Running_balance) Table.Align_Right
-                , Table.column (Lang.translate lang Lang.Title_Description)     Table.Align_Left
-                ] $ do
-               write_gl amount_styles gl (repeat [])
--}
-
-{-
-ledger_gl
- :: Context
- -> [ Ledger.Journal (GL.GL (Ledger.Charted Ledger.Transaction)) ]
- -> ( Ledger.Amount.Styles
-    , GL (Ledger.Charted Ledger.Transaction)
-    )
-ledger_gl ctx journals =
-       let (_chart, amount_styles, gl) =
-               foldl'
-                (flip (\j ->
-                       flip mappend $
-                       ( Ledger.journal_chart j
-                       , Ledger.journal_amount_styles j
-                       , ) $
-                       Ledger.Journal.fold
-                        (\Ledger.Journal
-                                { Ledger.journal_sections=g
-                                } -> mappend g
-                        ) j mempty
-                ))
-                mempty journals in
-       (amount_styles,) $
-       GL.GL $
-       TreeMap.map_Maybe_with_Path
-        (\acct expanded_lines ->
-               case Map.mapMaybeWithKey
-                (\date seq_lines ->
-                       case foldMap
-                        (\line@GL.GL_Line
-                        { GL.gl_line_transaction = _t
-                        , GL.gl_line_posting     = Ledger.Charted c p
-                        , GL.gl_line_sum         = s
-                        } ->
-                               Map.foldlWithKey
-                                (\acc unit qty ->
-                                       let sqty = (Map.!) s unit in
-                                       if Filter.test (ctx_filter_gl ctx)
-                                        ( (Chart.account_tags acct c, acct)
-                                        , date
-                                        , (unit, Polarize.polarize qty)
-                                        , (unit, sqty)
-                                        )
-                                       then (Seq.|>) acc line
-                                        { GL.gl_line_posting = Ledger.Charted c p
-                                                { Ledger.posting_amounts = Map.singleton unit qty }
-                                        , GL.gl_line_sum = Map.singleton unit sqty
-                                        }
-                                       else acc
-                                )
-                                Seq.empty
-                                (Ledger.posting_amounts p)
-                        ) seq_lines of
-                        m | Seq.null m -> Nothing
-                        m -> Just m
-                )
-                (GL.inclusive expanded_lines) of
-                       m | Map.null m -> Strict.Nothing
-                       m -> Strict.Just m
-               ) $
-       GL.expanded gl
-
-write_gl
- :: Ledger.Amount.Styles
- -> GL (Ledger.Charted Ledger.Transaction)
- -> [[Table.Cell]]
- -> [[Table.Cell]]
-write_gl amount_styles (GL gl) =
-       flip (TreeMap.foldr_with_Path
-        (\acct ->
-               flip $ Map.foldrWithKey
-                (\date ->
-                       flip (foldr
-                        (\GL.GL_Line
-                                { GL.gl_line_transaction = Ledger.Charted _ t
-                                , GL.gl_line_posting     = Ledger.Charted _ p
-                                , GL.gl_line_sum         = s
-                                } ->
-                               flip (Map.foldrWithKey
-                                (\unit qty ->
-                                       let ms = Map.lookup unit s in
-                                       zipWith (:)
-                                               [ let ptype = Ledger.Posting_Type_Regular in
-                                                       Table.cell
-                                                        { Table.cell_content = Ledger.Write.account        ptype acct
-                                                        , Table.cell_width   = Ledger.Write.account_length ptype acct
-                                                        }
-                                               , Table.cell
-                                                { Table.cell_content = Date.Write.date        date
-                                                , Table.cell_width   = Date.Write.date_length date
-                                                }
-                                               , cell_amount unit (Polarize.polarizable_positive qty)
-                                               , cell_amount unit (Polarize.polarizable_negative qty)
-                                               , cell_amount unit (ms >>= Polarize.polarized_positive)
-                                               , cell_amount unit (ms >>= Polarize.polarized_negative)
-                                               , cell_amount unit (liftM Polarize.depolarize ms)
-                                               , let descr = Ledger.transaction_wording t in
-                                                       Table.cell
-                                                        { Table.cell_content = toDoc ()    descr
-                                                        , Table.cell_width   = Text.length descr
-                                                        }
-                                               ]
-                                ))
-                                (Ledger.posting_amounts p)
-                        ))
-                )
-        ))
-        gl
-       where
-               cell_amount :: Ledger.Unit -> Maybe Ledger.Quantity -> Table.Cell
-               cell_amount unit mq =
-                       case mq of
-                        Nothing -> Table.cell
-                        Just q ->
-                               let a  = Ledger.Amount.Amount unit q in
-                               let sa = Ledger.Amount.style amount_styles a in
-                               Table.cell
-                                { Table.cell_content = Amount.Write.amount        sa
-                                , Table.cell_width   = Amount.Write.amount_length sa
-                                }
--}
diff --git a/cli/Hcompta/CLI/Command/HLint.hs b/cli/Hcompta/CLI/Command/HLint.hs
deleted file mode 120000 (symlink)
index ab18269..0000000
+++ /dev/null
@@ -1 +0,0 @@
-../HLint.hs
\ No newline at end of file
diff --git a/cli/Hcompta/CLI/Command/Journal.hs b/cli/Hcompta/CLI/Command/Journal.hs
deleted file mode 100644 (file)
index 52926e0..0000000
+++ /dev/null
@@ -1,298 +0,0 @@
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Hcompta.CLI.Command.Journal where
-
-import           Control.Arrow ((+++))
-import           Control.Monad (Monad(..), liftM, mapM)
-import           Control.Monad.IO.Class (liftIO)
-import           Data.Bool
-import           Data.Either (Either(..), partitionEithers)
-import           Data.Foldable (Foldable(..))
-import           Data.Function (($), (.), on)
-import           Data.Functor (Functor(..), (<$>))
-import           Data.List ((++))
-import           Data.Maybe (Maybe(..))
-import           Data.Monoid (Monoid(..))
-import           Data.String (String)
-import           Prelude (Bounded(..), unlines)
-import           System.Console.GetOpt
-                 ( ArgDescr(..)
-                 , OptDescr(..)
-                 , usageInfo )
-import           System.Environment as Env (getProgName)
-import           System.Exit (exitSuccess)
-import qualified System.IO as IO
-import           System.IO (FilePath, IO)
-
-import qualified Hcompta.CLI.Args as Args
-import qualified Hcompta.CLI.Context as C
-import qualified Hcompta.CLI.Env as CLI.Env
-import qualified Hcompta.CLI.Format as Format
-import           Hcompta.CLI.Format.JCC ()
-import           Hcompta.CLI.Format.Ledger ()
-import           Hcompta.CLI.Format (Format(..), Formats)
-import qualified Hcompta.CLI.Lang as Lang
-import qualified Hcompta.CLI.Write as Write
-import qualified Hcompta.Chart as Chart
-import qualified Hcompta.Posting as Posting
-import qualified Hcompta.Filter as Filter
-import qualified Hcompta.Filter.Amount as Filter.Amount
-import qualified Hcompta.Filter.Read as Filter.Read
-import qualified Hcompta.Format.JCC as JCC
-import qualified Hcompta.Format.JCC.Write as JCC.Write
-import qualified Hcompta.Format.Ledger       as Ledger
-import qualified Hcompta.Format.Ledger.Write as Ledger
-import qualified Hcompta.Journal as Journal
--- import           Hcompta.Lib.Consable (Consable(..))
-import qualified Hcompta.Lib.Leijen as W
-import qualified Hcompta.Lib.Parsec as R
-
-data Context
- =   Context
- { ctx_input              :: [FilePath]
- , ctx_input_format       :: Formats
- , ctx_output             :: [(Write.Mode, FilePath)]
- , ctx_output_format      :: Maybe Formats
- , ctx_align              :: Bool
- , ctx_reduce_date        :: Bool
- , ctx_filter_transaction :: forall t.
-                             ( Filter.Transaction t
-                             , Filter.Amount_Quantity
-                               (Posting.Posting_Amount
-                               (Filter.Transaction_Posting t))
-                               ~ Filter.Amount.Quantity
-                             ) => Journal_Filter t
- }
-
-context :: Context
-context =
-       Context
-        { ctx_input              = []
-        , ctx_input_format       = mempty
-        , ctx_output             = []
-        , ctx_output_format      = Nothing
-        , ctx_align              = True
-        , ctx_reduce_date        = True
-        , ctx_filter_transaction = Filter.Simplified $ Right True
-        }
-
-usage :: C.Context -> IO String
-usage c = do
-       bin <- Env.getProgName
-       return $ unlines $
-               [ C.translate c Lang.Section_Description
-               , "  "++C.translate c Lang.Help_Command_Journal
-               , ""
-               , C.translate c Lang.Section_Syntax
-               , "  "++bin++" journal ["++C.translate c Lang.Type_Option++"] [...]"++
-                                    " ["++C.translate c Lang.Type_File_Journal++"] [...]"
-               , ""
-               , usageInfo (C.translate c Lang.Section_Options) (options c)
-               ]
-
-options :: C.Context -> Args.Options Context
-options c =
-       [ Option "h" ["help"]
-        (NoArg (\_ctx -> do
-               usage c >>= IO.hPutStr IO.stderr
-               exitSuccess)) $
-               C.translate c Lang.Help_Option_Help
-       , Option "i" ["input"]
-        (ReqArg (\s ctx -> do
-               return $ ctx{ctx_input=s:ctx_input ctx}) $
-               C.translate c Lang.Type_File_Journal) $
-               C.translate c Lang.Help_Option_Input
-       , Option "if" ["input-format"]
-        (OptArg (\arg ctx -> do
-               ctx_input_format <- case arg of
-                Nothing       -> return $ Format_JCC ()
-                Just "jcc"    -> return $ Format_JCC ()
-                Just "ledger" -> return $ Format_Ledger ()
-                Just _        -> Write.fatal c $
-                       W.text "--input-format option expects \"jcc\", or \"ledger\" as value"
-               return $ ctx{ctx_input_format})
-         "[jcc|ledger]")
-         "input format"
-       , Option "o" ["output"]
-        (ReqArg (\s ctx -> do
-               return $ ctx{ctx_output=(Write.Mode_Append, s):ctx_output ctx}) $
-               C.translate c Lang.Type_File) $
-               C.translate c Lang.Help_Option_Output
-       , Option "of" ["output-format"]
-        (OptArg (\arg ctx -> do
-               ctx_output_format <- case arg of
-                Nothing       -> return $ Just $ Format_JCC ()
-                Just "jcc"    -> return $ Just $ Format_JCC ()
-                Just "ledger" -> return $ Just $ Format_Ledger ()
-                Just _        -> Write.fatal c $
-                       W.text "--output-format option expects \"jcc\", or \"ledger\" as value"
-               return $ ctx{ctx_output_format})
-         "[jcc|ledger]")
-         "input format"
-       , Option "O" ["overwrite"]
-        (ReqArg (\s ctx -> do
-               return $ ctx{ctx_output=(Write.Mode_Over, s):ctx_output ctx}) $
-               C.translate c Lang.Type_File) $
-               C.translate c Lang.Help_Option_Overwrite
-       , Option "" ["align"]
-        (OptArg (\arg ctx -> do
-               ctx_align <- case arg of
-                Nothing    -> return $ True
-                Just "yes" -> return $ True
-                Just "no"  -> return $ False
-                Just _     -> Write.fatal c $
-                       W.text "--align option expects \"yes\", or \"no\" as value"
-               return $ ctx{ctx_align})
-         "[yes|no]")
-        "align output"
-       {- NOTE: not used so far.
-       , Option "" ["reduce-date"]
-        (OptArg (\arg ctx -> do
-               ctx_reduce_date <- case arg of
-                Nothing    -> return $ True
-                Just "yes" -> return $ True
-                Just "no"  -> return $ False
-                Just _     -> Write.fatal c $
-                       W.text "--reduce-date option expects \"yes\", or \"no\" as value"
-               return $ ctx{ctx_reduce_date})
-         "[yes|no]")
-        "use advanced date reducer to speed up filtering"
-       -}
-       , Option "t" ["filter-transaction"]
-        (ReqArg (\s ctx -> do
-               filter <-
-                       R.runParserT_with_Error
-                        Filter.Read.filter_transaction
-                        Filter.Read.context "" s
-               case filter of
-                Left ko -> Write.fatal c ko
-                Right flt ->
-                       return $
-                               ctx{ctx_filter_transaction =
-                                       Filter.and (ctx_filter_transaction ctx) $
-                                       (Filter.simplify $
-                                               Filter.Read.get_Forall_Filter_Transaction_Decimal <$> flt)
-                                }) $
-               C.translate c Lang.Type_Filter_Transaction) $
-               C.translate c Lang.Help_Option_Filter_Transaction
-       ]
-
-run :: C.Context -> [String] -> IO ()
-run c args = do
-       (ctx, inputs) <- Args.parse c usage options (context, args)
-       input_paths <- CLI.Env.paths c $ ctx_input ctx ++ inputs
-       read_journals <- mapM (liftIO . journal_read ctx) input_paths
-       case partitionEithers read_journals of
-        (errs@(_:_), _journals) -> Write.fatals c errs
-        ([], (journals::[Forall_Journal])) -> do
-               with_color <- Write.with_color c IO.stdout
-               W.displayIO IO.stdout $
-                       W.renderPretty with_color 1.0 maxBound $
-                       journal_write $ mconcat $
-                       Format.journal_flatten <$>
-                               case ctx_output_format ctx of
-                                Nothing -> journals
-                                Just f -> Format.journal_empty f:journals
-
--- * Type 'Format_Journal'
-
-type Format_Journal
- = Format
-   (   JCC.Journal Journal_JCC)
-   (Ledger.Journal Journal_Ledger)
-
-type Journal_JCC    = Journal.Journal (   JCC.Charted    JCC.Transaction)
-type Journal_Ledger = Journal.Journal (Ledger.Charted Ledger.Transaction)
-
--- * Class 'Journal'
-
-class Journal j where
-       journal_write :: j -> W.Doc
-
-instance Format.Journal (JCC.Journal Journal_JCC) where
-       type Journal_Format   (JCC.Journal Journal_JCC) = Format_Journal
-       journal_format = Format_JCC
-instance Journal (JCC.Journal Journal_JCC) where
-       journal_write j =
-               JCC.Write.transactions (JCC.journal_amount_styles j) $
-               fmap Chart.charted $
-               JCC.journal_content j
-
-instance Format.Journal (Ledger.Journal Journal_Ledger) where
-       type Journal_Format   (Ledger.Journal Journal_Ledger) = Format_Journal
-       journal_format = Format_Ledger
-instance Journal (Ledger.Journal Journal_Ledger) where
-       journal_write j =
-               Ledger.write_transactions (Ledger.journal_amount_styles j) $
-               fmap Chart.charted $
-               Ledger.journal_content j
-
--- * Type 'Forall_Journal'
-
-data Forall_Journal
- = forall j m. ( Journal (j m)
-               , Format.Journal (j m)
-               , Format.Journal_Read j
-               , Format.Journal_Monoid (j m)
-               , Format.Journal_Format (j m) ~ Format_Journal )
- => Forall_Journal (j m)
-
-instance Format.Journal Forall_Journal where
-       type Journal_Format   Forall_Journal = Format_Journal
-       journal_format  (Forall_Journal j) = Format.journal_format j
-instance Format.Journal_Empty Forall_Journal where
-       journal_empty f =
-               case f of
-                Format_JCC    () -> Forall_Journal (mempty::JCC.Journal Journal_JCC)
-                Format_Ledger () -> Forall_Journal (mempty::Ledger.Journal Journal_Ledger)
-
-instance Format.Journal_Monoid Forall_Journal where
-       journal_flatten (Forall_Journal j) = Forall_Journal $ Format.journal_flatten j
-       journal_fold f  (Forall_Journal j) = Format.journal_fold (f . Forall_Journal) j
-instance Journal Forall_Journal where
-       journal_write (Forall_Journal j) = journal_write j
-instance Monoid Forall_Journal where
-       mempty = Forall_Journal (mempty::JCC.Journal Journal_JCC)
-       mappend x y =
-               case (mappend `on` Format.journal_format) x y of
-                Format_JCC    j -> Forall_Journal j
-                Format_Ledger j -> Forall_Journal j
-       mconcat js =
-               case js of
-                [] -> mempty
-                j:jn -> foldl' mappend j jn
-
-type Journal_Filter transaction
- = Filter.Simplified
-   (Filter.Filter_Bool
-   (Filter.Filter_Transaction transaction))
-type Journal_Read_Cons txn
- = txn -> Filter.Filtered (Journal_Filter txn) txn
-
-journal_read
- :: Context -> FilePath
- -> IO (Either (Format.Message W.Doc) Forall_Journal)
-journal_read ctx =
-       case ctx_input_format ctx of
-        Format_JCC () ->
-               let wrap (j::JCC.Journal Journal_JCC) = Forall_Journal j in
-               let cons :: Journal_Read_Cons (JCC.Charted JCC.Transaction)
-                        = Filter.Filtered (ctx_filter_transaction ctx) in
-               liftM ((+++) Format.Message wrap) .
-               Format.journal_read cons
-        Format_Ledger () ->
-               let wrap (j::Ledger.Journal Journal_Ledger) = Forall_Journal j in
-               let cons :: Journal_Read_Cons (Ledger.Charted Ledger.Transaction)
-                        = Filter.Filtered (ctx_filter_transaction ctx) in
-               liftM ((+++) Format.Message wrap) .
-               Format.journal_read cons
diff --git a/cli/Hcompta/CLI/Command/Journals.hs b/cli/Hcompta/CLI/Command/Journals.hs
deleted file mode 100644 (file)
index 8e883f5..0000000
+++ /dev/null
@@ -1,177 +0,0 @@
-{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Hcompta.CLI.Command.Journals where
-
-import           Control.Arrow ((+++))
-import           Control.Monad (Monad(..), mapM)
-import           Control.Monad.IO.Class (liftIO)
-import           Data.Either (Either(..), partitionEithers)
-import           Data.Foldable (Foldable(..))
-import           Data.Function (($), (.), const)
-import           Data.Functor ((<$>))
-import           Data.List ((++))
-import           Data.Maybe (Maybe(..))
-import           Data.Monoid (Monoid(..), (<>))
-import           Data.String (String)
-import           Prelude (Bounded(..), FilePath, IO, unlines)
-import           System.Console.GetOpt
-                  ( ArgDescr(..)
-                  , OptDescr(..)
-                  , usageInfo )
-import qualified System.Environment as Env
-import           System.Exit (exitSuccess)
-import qualified System.IO as IO
-import           Text.Show (Show)
-
-import qualified Hcompta.CLI.Args as Args
-import qualified Hcompta.CLI.Context as C
-import qualified Hcompta.CLI.Env as CLI.Env
-
-import qualified Hcompta.CLI.Format as Format
-import           Hcompta.CLI.Format (Format(..), Formats)
-import           Hcompta.CLI.Format.Ledger ()
-import           Hcompta.CLI.Format.JCC ()
-import qualified Hcompta.CLI.Lang as Lang
-import qualified Hcompta.CLI.Write as Write
-
-
--- import qualified Hcompta.Lib.Parsec as R
-import qualified Hcompta.JCC as JCC
-import qualified Hcompta.Ledger as Ledger
-import qualified Text.WalderLeijen.ANSI.Text as W
-
-data Context
- =   Context
- { ctx_input        :: [FilePath]
- , ctx_input_format :: Formats
- } deriving (Show)
-
-context :: Context
-context =
-       Context
-        { ctx_input        = []
-        , ctx_input_format = mempty
-        }
-
-usage :: C.Context -> IO String
-usage c = do
-       bin <- Env.getProgName
-       return $ unlines $
-               [ C.translate c Lang.Section_Description
-               , "  "++C.translate c Lang.Help_Command_Journals
-               , ""
-               , C.translate c Lang.Section_Syntax
-               , "  "++bin++" journals ["++C.translate c Lang.Type_Option++"] [...]"++
-                                     " ["++C.translate c Lang.Type_File_Journal++"] [...]"
-               , ""
-               , usageInfo (C.translate c Lang.Section_Options) (options c)
-               ]
-
-options :: C.Context -> Args.Options Context
-options c =
-       [ Option "h" ["help"]
-        (NoArg (\_ctx -> do
-               usage c >>= IO.hPutStr IO.stderr
-               exitSuccess)) $
-               C.translate c Lang.Help_Option_Help
-       , Option "i" ["input"]
-        (ReqArg (\s ctx ->
-               return $ ctx{ctx_input=s:ctx_input ctx}) $
-               C.translate c Lang.Type_File_Journal) $
-               C.translate c Lang.Help_Option_Input
-       , Option "f" ["input-format"]
-        (OptArg (\arg ctx -> do
-               ctx_input_format <- case arg of
-                Nothing       -> return $ Format_JCC ()
-                Just "jcc"    -> return $ Format_JCC ()
-                Just "ledger" -> return $ Format_Ledger ()
-                Just _        -> Write.fatal c $
-                       W.text "--input-format option expects \"jcc\", or \"ledger\" as value"
-               return $ ctx{ctx_input_format})
-         "[jcc|ledger]")
-         "input format"
-       ]
-
-run :: C.Context -> [String] -> IO ()
-run c args = do
-       (ctx, inputs) <- Args.parse c usage options (context, args)
-       input_paths <- CLI.Env.paths c $ ctx_input ctx ++ inputs
-       read_journals <- mapM (liftIO . journal_read ctx) input_paths
-       case partitionEithers read_journals of
-        (errs@(_:_), _journals) -> Write.fatals c errs
-        ([], journals) -> do
-               with_color <- Write.with_color c IO.stdout
-               W.displayIO IO.stdout $
-                       W.renderPretty with_color 1.0 maxBound $
-                               W.toDoc () $
-                               mconcat journals
-
--- * Class 'Journal'
-
-class
- ( Format.Journal_Monoid (j m)
- , Format.Journal_Read j
- ) => Journal j m where
-       journal_files :: j m -> [FilePath]
-
--- JCC
-instance Journal JCC.Journal Journals_JCC where
-       journal_files = JCC.journal_files
-
--- Ledger
-instance Journal Ledger.Journal Journals_Ledger where
-       journal_files = Ledger.journal_files
-
-type Journals_JCC    = ()
-type Journals_Ledger = ()
-
--- * Type 'Journals'
-
-newtype Journals =
-       Journals [FilePath]
- deriving (Show)
-instance Monoid Journals where
-       mempty = Journals []
-       mappend (Journals x) (Journals y) =
-               Journals (mappend x y)
-       mconcat = foldl' mappend mempty
-instance W.ToDoc () Journals where
-       toDoc () (Journals files) =
-               foldr
-                (\file doc -> doc <> W.toDoc () file <> W.line)
-                W.empty files
-
-type Journal_Read_Cons txn = txn -> ()
-journal_read
- :: Context -> FilePath
- -> IO (Either (Format.Message W.Doc) Journals)
-journal_read ctx =
-       case ctx_input_format ctx of
-        Format_JCC () ->
-               let wrap (j::JCC.Journal Journals_JCC) =
-                       Format.journal_fold journals_cons j mempty in
-               let cons :: Journal_Read_Cons (JCC.Charted JCC.Transaction)
-                        = const () in
-               (((+++) Format.Message wrap) <$>) .
-               Format.journal_read cons
-        Format_Ledger () ->
-               let wrap (j::Ledger.Journal Journals_Ledger) =
-                       Format.journal_fold journals_cons j mempty in
-               let cons :: Journal_Read_Cons (Ledger.Charted Ledger.Transaction)
-                        = const () in
-               (((+++) Format.Message wrap) <$>) .
-               Format.journal_read cons
-
-journals_cons :: Journal j m => j m -> Journals -> Journals
-journals_cons j (Journals files) =
-       Journals (journal_files j ++ files)
diff --git a/cli/Hcompta/CLI/Command/Stats.hs b/cli/Hcompta/CLI/Command/Stats.hs
deleted file mode 100644 (file)
index 1cc2d84..0000000
+++ /dev/null
@@ -1,300 +0,0 @@
-{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Hcompta.CLI.Command.Stats where
-
-import           Control.Applicative (Const(..))
-import           Control.Arrow ((+++))
-import           Control.Monad (Monad(..), liftM, mapM)
-import           Control.Monad.IO.Class (liftIO)
-import           Data.Bool (Bool(..))
-import           Data.Either (Either(..), partitionEithers)
-import           Data.Foldable (Foldable(..))
-import           Data.Function (($), (.), on)
-import           Data.Functor ((<$>))
-import           Data.List ((++))
-import qualified Data.List as List
-import qualified Data.Map.Strict as Map
-import           Data.Maybe (Maybe(..))
-import           Data.Monoid (Monoid(..), (<>))
-import           Data.Text (Text)
-import           Data.String (String)
-import           Prelude (Bounded(..), Num(..), flip, unlines)
-import           System.Console.GetOpt
-                 ( ArgDescr(..)
-                 , OptDescr(..)
-                 , usageInfo )
-import           System.Environment as Env (getProgName)
-import           System.Exit (exitSuccess)
-import qualified System.IO as IO
-import           System.IO (FilePath, IO)
-
-import qualified Hcompta.Unit as Unit
-import qualified Hcompta.CLI.Args as Args
-import qualified Hcompta.CLI.Context as C
-import qualified Hcompta.CLI.Env as CLI.Env
-import           Hcompta.CLI.Format.JCC ()
-import           Hcompta.CLI.Format.Ledger ()
-import           Hcompta.CLI.Format (Format(..), Formats)
-import qualified Hcompta.CLI.Format as Format
-import qualified Hcompta.CLI.Lang as Lang
-import qualified Hcompta.CLI.Write as Write
-import qualified Hcompta.Posting as Posting
-import qualified Hcompta.Filter as Filter
-import qualified Hcompta.Filter.Read as Filter.Read
-import qualified Hcompta.Filter.Amount as Filter.Amount
-import qualified Hcompta.Format.JCC as JCC
-import qualified Hcompta.Format.Ledger as Ledger
-import qualified Hcompta.Lib.Interval as Interval
-import qualified Hcompta.Lib.Parsec as R
-import qualified Hcompta.Lib.Leijen as W
-import qualified Hcompta.Stats as Stats
-
-data Context
- =   Context
- { ctx_input              :: [FilePath]
- , ctx_input_format       :: Formats
- , ctx_filter_transaction :: forall t.
-                             ( Filter.Transaction t
-                             , Filter.Amount_Quantity
-                               (Posting.Posting_Amount
-                               (Filter.Transaction_Posting t))
-                               ~ Filter.Amount.Quantity
-                             ) => Journal_Filter t
- , ctx_output_format      :: Maybe Formats
- }
-
-context :: Context
-context =
-       Context
-        { ctx_input = []
-        , ctx_input_format       = mempty
-        , ctx_filter_transaction = Filter.Simplified $ Right True
-        , ctx_output_format      = Nothing
-        }
-
-usage :: C.Context -> IO String
-usage c = do
-       bin <- Env.getProgName
-       return $ unlines $
-               [ C.translate c Lang.Section_Description
-               , "  "++C.translate c Lang.Help_Command_Stats
-               , ""
-               , C.translate c Lang.Section_Syntax
-               , "  "++bin++" stats ["++C.translate c Lang.Type_Option++"] [...]"++
-                                  " ["++C.translate c Lang.Type_File_Journal++"] [...]"
-               , ""
-               , usageInfo (C.translate c Lang.Section_Options) (options c)
-               ]
-
-options :: C.Context -> Args.Options Context
-options c =
-       [ Option "h" ["help"]
-        (NoArg (\_ctx -> do
-               usage c >>= IO.hPutStr IO.stderr
-               exitSuccess)) $
-               C.translate c Lang.Help_Option_Help
-       , Option "i" ["input"]
-        (ReqArg (\s ctx -> do
-               return $ ctx{ctx_input=s:ctx_input ctx}) $
-               C.translate c Lang.Type_File_Journal) $
-               C.translate c Lang.Help_Option_Input
-       , Option "if" ["input-format"]
-        (OptArg (\arg ctx -> do
-               ctx_input_format <- case arg of
-                Nothing       -> return $ Format_JCC ()
-                Just "jcc"    -> return $ Format_JCC ()
-                Just "ledger" -> return $ Format_Ledger ()
-                Just _        -> Write.fatal c $
-                       W.text "--input-format option expects \"jcc\", or \"ledger\" as value"
-               return $ ctx{ctx_input_format})
-         "[jcc|ledger]")
-         "input format"
-       , Option "of" ["output-format"]
-        (OptArg (\arg ctx -> do
-               ctx_output_format <- case arg of
-                Nothing       -> return $ Just $ Format_JCC ()
-                Just "jcc"    -> return $ Just $ Format_JCC ()
-                Just "ledger" -> return $ Just $ Format_Ledger ()
-                Just _        -> Write.fatal c $
-                       W.text "--output-format option expects \"jcc\", or \"ledger\" as value"
-               return $ ctx{ctx_output_format})
-         "[jcc|ledger]")
-         "input format"
-       , Option "t" ["filter-transaction"]
-        (ReqArg (\s ctx -> do
-               filter <-
-                       R.runParserT_with_Error
-                        Filter.Read.filter_transaction
-                        Filter.Read.context "" s
-               case filter of
-                Left ko -> Write.fatal c ko
-                Right flt ->
-                       return $
-                               ctx{ctx_filter_transaction =
-                                       Filter.and (ctx_filter_transaction ctx) $
-                                       (Filter.simplify $
-                                               Filter.Read.get_Forall_Filter_Transaction_Decimal <$> flt)
-                                }) $
-               C.translate c Lang.Type_Filter_Transaction) $
-               C.translate c Lang.Help_Option_Filter_Transaction
-       ]
-
-run :: C.Context -> [String] -> IO ()
-run c args = do
-       (ctx, inputs) <- Args.parse c usage options (context, args)
-       input_paths <- CLI.Env.paths c $ ctx_input ctx ++ inputs
-       read_journals <- mapM (liftIO . journal_read ctx) input_paths
-       case partitionEithers read_journals of
-        (errs@(_:_), _journals) -> Write.fatals c errs
-        ([], (journals::[Forall_Stats])) -> do
-               with_color <- Write.with_color c IO.stdout
-               W.displayIO IO.stdout $
-                       W.renderPretty with_color 1.0 maxBound $
-                       stats_write c ctx $
-                       (Const::x -> Const x ()) $
-                       mconcat $ Format.journal_flatten <$>
-                               case ctx_output_format ctx of
-                                Nothing -> journals
-                                Just f -> Format.journal_empty f:journals
-
--- * Type 'Format_Journal'
-
-type Format_Journal
- = Format
-   (   JCC.Journal Stats_JCC)
-   (Ledger.Journal Stats_Ledger)
-
-type Stats_JCC    = Stats.Stats (   JCC.Charted    JCC.Transaction)
-type Stats_Ledger = Stats.Stats (Ledger.Charted Ledger.Transaction)
-
--- * Class 'Stats'
-
-class Stats j m where
-       stats_write :: C.Context -> Context -> j m -> W.Doc
-instance
- ( Stats.Transaction t
- , t ~ (Format.Journal_Charted j) (Format.Journal_Transaction j)
- , Stats.Posting_Unit (Stats.Transaction_Posting t) ~ Format.Journal_Unit j
- , Unit.Unit (Format.Journal_Unit j)
- , Format.Journal_Content j
- , Format.Journal_Files j
- ) => Stats j (Stats.Stats t) where
-       stats_write c _ctx j =
-               let stats = Format.journal_content j in
-               render
-               [ (Lang.Header_Accounts,) . W.toDoc () $
-                       Map.size $ Stats.stats_accounts stats
-               , (Lang.Header_Accounts_Depth,) $
-                       let depth = Stats.stats_accounts_depths stats in
-                       W.toDoc () (Interval.limit $ Interval.low  depth) <>
-                       (W.bold $ W.dullyellow "..") <>
-                       W.toDoc () (Interval.limit $ Interval.high depth)
-               , (Lang.Header_Transactions,) . W.toDoc () $
-                       Stats.stats_transactions stats
-               , (Lang.Header_Transactions_Date,) $
-                       case Stats.stats_transactions_span stats of
-                        Nothing -> W.empty
-                        Just date ->
-                               W.toDoc () (Interval.limit $ Interval.low date) <>
-                               (W.bold $ W.dullyellow "..") <>
-                               W.toDoc () (Interval.limit $ Interval.high date)
-               , (Lang.Header_Units,) . W.toDoc () $
-                       Map.size $ Map.delete Unit.unit_empty $
-                       Stats.stats_units stats
-               , (Lang.Header_Journals,) . W.toDoc () $
-                       List.length $ Format.journal_files j
-               , (Lang.Header_Tags,) . W.toDoc () $
-                       W.toDoc () (foldr (flip $ foldr (+)) 0 $
-                               Stats.stats_tags stats)
-               , (Lang.Header_Tags_Distinct,) . W.toDoc () $
-                       Map.size $ Stats.stats_tags stats
-               ]
-               where
-                       render :: Lang.Translate h [Text] => [(h, W.Doc)] -> W.Doc
-                       render =
-                               foldMap $ \(h, x) ->
-                                       W.hcat
-                                        [ W.bold $ flip foldMap
-                                                (C.translate c h::[Text]) $ \s ->
-                                                       W.dullblack (W.toDoc () s) <> W.dullyellow ":"
-                                        , W.toDoc () x
-                                        , W.line ]
-
-instance Format.Journal (JCC.Journal Stats_JCC) where
-       type Journal_Format   (JCC.Journal Stats_JCC) = Format_Journal
-       journal_format = Format_JCC
-
-instance Format.Journal (Ledger.Journal Stats_Ledger) where
-       type Journal_Format   (Ledger.Journal Stats_Ledger) = Format_Journal
-       journal_format = Format_Ledger
-
--- * Type 'Forall_Stats'
-
-data Forall_Stats
- = forall j m. ( Stats j m
-               , Format.Journal (j m)
-               , Format.Journal_Content j
-               , Format.Journal_Files j
-               , Format.Journal_Read j
-               , Format.Journal_Monoid (j m)
-               , Format.Journal_Format (j m) ~ Format_Journal )
- => Forall_Stats (j m)
-
-instance Format.Journal Forall_Stats where
-       type Journal_Format   Forall_Stats = Format_Journal
-       journal_format  (Forall_Stats j) = Format.journal_format j
-instance Format.Journal_Empty Forall_Stats where
-       journal_empty f =
-               case f of
-                Format_JCC    () -> Forall_Stats (mempty::JCC.Journal    Stats_JCC)
-                Format_Ledger () -> Forall_Stats (mempty::Ledger.Journal Stats_Ledger)
-
-instance Format.Journal_Monoid Forall_Stats where
-       journal_flatten (Forall_Stats j) = Forall_Stats $ Format.journal_flatten j
-       journal_fold f  (Forall_Stats j) = Format.journal_fold (f . Forall_Stats) j
-instance Stats (Const Forall_Stats) () where
-       stats_write c ctx (Const (Forall_Stats j)) = stats_write c ctx j
-instance Monoid Forall_Stats where
-       mempty = Forall_Stats (mempty::JCC.Journal Stats_JCC)
-       mappend x y =
-               case (mappend `on` Format.journal_format) x y of
-                Format_JCC    j -> Forall_Stats j
-                Format_Ledger j -> Forall_Stats j
-       mconcat js =
-               case js of
-                [] -> mempty
-                j:jn -> foldl' mappend j jn
-
-type Journal_Filter transaction
- = Filter.Simplified
-   (Filter.Filter_Bool
-   (Filter.Filter_Transaction transaction))
-type Journal_Read_Cons txn
- = txn -> Filter.Filtered (Journal_Filter txn) txn
-
-journal_read
- :: Context -> FilePath
- -> IO (Either (Format.Message W.Doc) Forall_Stats)
-journal_read ctx =
-       case ctx_input_format ctx of
-        Format_JCC () ->
-               let wrap (j::JCC.Journal Stats_JCC) = Forall_Stats j in
-               let cons :: Journal_Read_Cons (JCC.Charted JCC.Transaction)
-                        = Filter.Filtered (ctx_filter_transaction ctx) in
-               liftM ((+++) Format.Message wrap) .
-               Format.journal_read cons
-        Format_Ledger () ->
-               let wrap (j::Ledger.Journal Stats_Ledger) = Forall_Stats j in
-               let cons :: Journal_Read_Cons (Ledger.Charted Ledger.Transaction)
-                        = Filter.Filtered (ctx_filter_transaction ctx) in
-               liftM ((+++) Format.Message wrap) .
-               Format.journal_read cons
diff --git a/cli/Hcompta/CLI/Command/Tags.hs b/cli/Hcompta/CLI/Command/Tags.hs
deleted file mode 100644 (file)
index 9522a35..0000000
+++ /dev/null
@@ -1,314 +0,0 @@
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeFamilies #-}
-module Hcompta.CLI.Command.Tags where
-
-import           Control.DeepSeq (NFData(..))
-import           Control.Monad (Monad(..), forM_, liftM, mapM)
-import           Control.Monad.IO.Class (liftIO)
-import           Control.Monad.Trans.Except (runExceptT)
-import           Data.Bool
-import           Data.Either (Either(..), partitionEithers)
-import           Data.Foldable (Foldable(..))
-import           Data.Functor ((<$>))
-import           Data.Functor.Compose (Compose(..))
-import           Data.List ((++))
-import qualified Data.List (filter)
-import           Data.Map.Strict (Map)
-import qualified Data.Map.Strict as Data.Map
-import           Data.Maybe (Maybe(..))
-import           Data.Monoid (Monoid(..), (<>))
-import           Data.String (String)
-import           Prelude (($), (.), FilePath, Integer, IO, Num(..), flip, id, unlines)
-import           Text.Show (Show(..))
-import           System.Console.GetOpt
-                 ( ArgDescr(..)
-                 , OptDescr(..)
-                 , usageInfo )
-import           System.Environment as Env (getProgName)
-import           System.Exit (exitSuccess)
-import qualified System.IO as IO
-
-import qualified Hcompta.CLI.Args as Args
-import qualified Hcompta.CLI.Context as C
-import qualified Hcompta.CLI.Env as CLI.Env
-import           Hcompta.CLI.Format.Ledger ()
-import qualified Hcompta.CLI.Lang as Lang
-import qualified Hcompta.CLI.Write as Write
-import qualified Hcompta.Filter as Filter
-import qualified Hcompta.Filter.Read as Filter.Read
-import qualified Hcompta.Format.Ledger as Ledger
-import qualified Hcompta.Format.Ledger.Journal as Ledger.Journal
-import qualified Hcompta.Format.Ledger.Read as Ledger.Read
-import           Hcompta.Lib.Consable (Consable(..))
-import qualified Hcompta.Lib.Leijen as W
-import qualified Hcompta.Tag as Tag
-import           Hcompta.Transaction (Transaction_Tags(..))
-
-data Ctx
- =   Ctx
- { ctx_input              :: [FilePath]
- , ctx_filter_transaction :: Filter.Simplified
-                             (Filter.Filter_Bool
-                             (Filter.Filter_Transaction
-                             (Ledger.Chart_With Ledger.Transaction)))
- , ctx_filter_tag         :: Filter.Simplified
-                             Filter.Filter_Tags
- , ctx_tree               :: Bool
- } deriving (Show)
-
-nil :: Ctx
-nil =
-       Ctx
-        { ctx_input = []
-        , ctx_filter_transaction = mempty
-        , ctx_filter_tag = mempty
-        , ctx_tree = False
-        }
-
-usage :: C.Context -> IO String
-usage c = do
-       bin <- Env.getProgName
-       return $ unlines $
-               [ C.translate c Lang.Section_Description
-               , "  "++C.translate c Lang.Help_Command_Tags
-               , ""
-               , C.translate c Lang.Section_Syntax
-               , "  "++bin++" tags ["++C.translate c Lang.Type_Option++"] [...]"++
-                                 " ["++C.translate c Lang.Type_File_Journal++"] [...]"
-               , ""
-               , usageInfo (C.translate c Lang.Section_Options) (options c)
-               ]
-
-options :: C.Context -> Args.Options Ctx
-options c =
-       [ Option "h" ["help"]
-        (NoArg (\_ctx -> do
-               usage c >>= IO.hPutStr IO.stderr
-               exitSuccess)) $
-               C.translate c Lang.Help_Option_Help
-       , Option "i" ["input"]
-        (ReqArg (\s ctx -> do
-               return $ ctx{ctx_input=s:ctx_input ctx}) $
-               C.translate c Lang.Type_File_Journal) $
-               C.translate c Lang.Help_Option_Input
-       , Option "t" ["transaction-filter"]
-        (ReqArg (\s ctx -> do
-               ctx_filter_transaction <-
-                       liftM ((ctx_filter_transaction ctx <>) . Filter.simplify) $
-                       liftIO $ Filter.Read.read Filter.Read.filter_transaction s
-                       >>= \f -> case f of
-                        Left  ko -> Write.fatal c $ ko
-                        Right ok -> do
-                               Write.debug c $ "filter: transaction: " ++ show ok
-                               return ok
-               return $ ctx{ctx_filter_transaction}) $
-               C.translate c Lang.Type_Filter_Transaction) $
-               C.translate c Lang.Help_Option_Filter_Transaction
-       , Option "T" ["tag-filter"]
-        (ReqArg (\s ctx -> do
-               ctx_filter_tag <-
-                       liftM ((ctx_filter_tag ctx <>) . Filter.simplify) $
-                       liftIO $ Filter.Read.read Filter.Read.filter_tag s
-                       >>= \f -> case f of
-                        Left  ko -> Write.fatal c $ ko
-                        Right ok -> do
-                               Write.debug c $ "filter: tag: " ++ show ok
-                               return ok
-               return $ ctx{ctx_filter_tag}) $
-               C.translate c Lang.Type_Filter_Tag) $
-               C.translate c Lang.Help_Option_Filter_Tag
-       , Option "" ["tree"]
-        (OptArg (\arg ctx -> do
-               ctx_tree <- case arg of
-                Nothing    -> return $ True
-                Just "yes" -> return $ True
-                Just "no"  -> return $ False
-                Just _     -> Write.fatal c Lang.Error_Option_Tags_Tree
-               return $ ctx{ctx_tree})
-         "[no|yes]") $
-               C.translate c Lang.Help_Option_Tags_Tree
-       ]
-
-run :: C.Context -> [String] -> IO ()
-run c args = do
-       (ctx, inputs) <- Args.parse c usage options (nil, args)
-       read_journals <-
-               liftM Data.Either.partitionEithers $ do
-               CLI.Env.paths c $ ctx_input ctx ++ inputs
-               >>= do
-                       mapM $ \path -> do
-                               liftIO $ runExceptT $ Ledger.Read.file
-                                (Ledger.Read.context
-                                        ( ctx_filter_transaction ctx
-                                        , ctx_filter_tag ctx
-                                        ) Ledger.journal)
-                                path
-                               >>= \x -> case x of
-                                Left  ko -> return $ Left (path, ko)
-                                Right ok -> return $ Right ok
-       case read_journals of
-        (errs@(_:_), _journals) ->
-               forM_ errs $ \(_path, err) -> do
-                       Write.fatal c $ err
-        ([], journals) -> do
-               let files = ledger_tags ctx journals
-               Write.write c Write.style [(Write.Mode_Append, "-")] $ do
-               doc_tags c ctx files
-
-ledger_tags
- :: Ctx
- -> [ Ledger.Journal (Tags (Ledger.Chart_With Ledger.Transaction)) ]
- -> Tags (Ledger.Chart_With Ledger.Transaction)
-ledger_tags _ctx =
-       Data.Foldable.foldl'
-        (flip $ Ledger.Journal.fold
-                (\Ledger.Journal{Ledger.journal_sections=ts} ->
-                       mappend ts))
-        mempty
-
-doc_tags
- :: C.Context
- -> Ctx
- -> Tags (Ledger.Chart_With Ledger.Transaction)
- -> W.Doc
-doc_tags _context ctx =
-       (case ctx_tree ctx of
-        True ->
-               Data.Map.foldlWithKey
-                (\doc p vs ->
-                       doc <> foldMap (\s -> W.dullyellow (W.toDoc () s) <> (W.bold $ W.dullblack ":")) p <>
-                       " (" <> (W.toDoc () (Data.Map.size vs)) <> ")" <>
-                       W.nest 2 (
-                               Data.Map.foldlWithKey
-                                (\doc' v vn ->
-                                       doc' <> W.line <> W.dullred (W.toDoc () v) <>
-                                       " (" <> (W.toDoc () vn) <> ")"
-                                )
-                                W.empty vs
-                        ) <> W.line
-                )
-                W.empty
-        False ->
-               Data.Map.foldlWithKey
-                (\doc p vs ->
-                       doc <>
-                       Data.Map.foldlWithKey
-                        (\doc' v _vn ->
-                               doc' <>
-                               foldMap (\s -> W.dullyellow (W.toDoc () s) <> (W.bold $ W.dullblack ":")) p <>
-                               W.dullred (W.toDoc () v) <> W.line
-                        ) W.empty vs
-                )
-                W.empty
-        ) .
-       tags
-
--- * Requirements' interface
-
--- ** Class 'Posting'
-
-class Posting        p where
-       posting_account :: p -> Ledger.Account
-
-instance Posting Ledger.Posting where
-       posting_account = Ledger.posting_account
-
--- ** Class 'Transaction'
-
-class
- ( Posting  (Transaction_Posting  t)
- , Foldable (Transaction_Postings t)
- )
- =>    Transaction          t where
-       type Transaction_Posting  t
-       type Transaction_Postings t :: * -> *
-       -- transaction_postings      :: t -> Transaction_Postings t (Transaction_Posting t)
-       transaction_tags          :: t -> Transaction_Tags
-
-instance Transaction        Ledger.Transaction where
-       type Transaction_Posting  Ledger.Transaction = Ledger.Posting
-       type Transaction_Postings Ledger.Transaction = Compose [] (Compose (Map Ledger.Account) [])
-       transaction_tags = Ledger.transaction_tags
-
-instance Transaction        (Ledger.Chart_With Ledger.Transaction) where
-       type Transaction_Posting  (Ledger.Chart_With Ledger.Transaction) = Transaction_Posting Ledger.Transaction
-       type Transaction_Postings (Ledger.Chart_With Ledger.Transaction) = Transaction_Postings Ledger.Transaction
-       transaction_tags = transaction_tags . Ledger.with_chart
-
--- * Type 'Tags'
-
-data Transaction t => Tags t
- = Tags
- { tags :: Map Tag.Path (Map Tag.Value Integer)
- }
- deriving (Show)
-
-instance Transaction t => Monoid (Tags t) where
-       mempty = Tags mempty
-       mappend t0 t1 =
-               Tags
-                { tags = Data.Map.unionWith
-                        (Data.Map.unionWith (+))
-                        (tags t0)
-                        (tags t1)
-                }
-instance NFData t => NFData (Tags t) where
-       rnf (Tags t) = rnf t
-
-instance Transaction t
- => Consable (Filter.Simplified Filter.Filter_Tags)
-             Tags
-             t where
-       mcons f t !ts =
-               let Transaction_Tags (Tag.Tags ttags) = transaction_tags t in
-               case Filter.simplified f of
-                Right False -> ts
-                Right True  -> ts{ tags = merge ttags (tags ts) }
-                Left fT ->
-                       ts{ tags = merge
-                        (Data.Map.mapMaybeWithKey
-                                (\p vs ->
-                                       if Filter.test fT $
-                                               Tag.Tags $
-                                               Data.Map.singleton p vs
-                                       then Just $ Data.List.filter
-                                        (\v -> Filter.test fT $
-                                               Tag.Tags $
-                                               Data.Map.singleton p [v]) vs
-                                       else Nothing)
-                                ttags)
-                        (tags ts)
-                        }
-               where
-                       merge
-                        :: Map Tag.Path [Tag.Value]
-                        -> Map Tag.Path (Map Tag.Value Integer)
-                        -> Map Tag.Path (Map Tag.Value Integer)
-                       merge =
-                               Data.Map.mergeWithKey
-                                (\_k x1 x2 -> Just $
-                                       Data.Map.unionWith (+) x2 $
-                                       Data.Map.fromListWith (+) $ (, 1) <$> x1)
-                                ((Data.Map.fromListWith (+) . ((, 1) <$>)) <$>)
-                                id
-instance
- ( Filter.Transaction t
- , Transaction        t
- ) => Consable
- ( Filter.Simplified
-    (Filter.Filter_Bool
-    (Filter.Filter_Transaction t))
- ,  Filter.Simplified Filter.Filter_Tags
- )
- Tags t where
-       mcons (ft, fT) t !ts =
-               if Filter.test ft t
-               then mcons fT t ts
-               else ts
diff --git a/cli/Hcompta/CLI/Context.hs b/cli/Hcompta/CLI/Context.hs
deleted file mode 100644 (file)
index ce18d32..0000000
+++ /dev/null
@@ -1,47 +0,0 @@
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-module Hcompta.CLI.Context where
-
-import           Control.Monad (Monad(..))
-import           Data.Bool
-import           Data.String (String)
-import           Data.Eq (Eq)
-import           Data.Maybe (Maybe(..))
-import           Data.Ord (Ord)
-import           Text.Show (Show)
-import           Prelude (($), (.), Bounded(..), Enum(..), IO)
-
-import           Hcompta.CLI.Lang (Lang)
-import qualified Hcompta.CLI.Lang as Lang
-
-data App = App
-
-data Context
- =   Context
- { verbosity :: Verbosity
- , command   :: String
- , color     :: Maybe Bool
- , lang      :: Lang
- } deriving (Show)
-
-context :: IO Context
-context = do
-       lang <- Lang.from_Env
-       return $
-               Context
-                { verbosity = Verbosity_Info
-                , command   = ""
-                , color     = Nothing
-                , lang
-                }
-
-data Verbosity
- =   Verbosity_Error
- |   Verbosity_Warn
- |   Verbosity_Info
- |   Verbosity_Debug
- deriving (Bounded, Eq, Enum, Ord, Show)
-
-translate :: Lang.Translate f t => Context -> f -> t
-translate = Lang.translate . lang
diff --git a/cli/Hcompta/CLI/Convert.hs b/cli/Hcompta/CLI/Convert.hs
deleted file mode 100644 (file)
index f2a21f0..0000000
+++ /dev/null
@@ -1,462 +0,0 @@
-{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-module Hcompta.CLI.Convert where
-
-import           Control.Applicative (Const(..))
-import           Data.Bool (Bool(..), not)
-import qualified Data.Char as Char
-import           Data.Decimal (Decimal)
-import           Data.Function (($), (.), id)
-import           Data.Functor (Functor(..), (<$>))
-import qualified Data.List as List
-import           Data.List.NonEmpty (NonEmpty(..))
-import           Data.Map.Strict (Map)
-import qualified Data.Map.Strict as Map
-import           Data.Maybe (Maybe(..))
-import           Data.Monoid (Monoid(..))
-import           Data.Ord (Ord(..))
-import           Data.Sequence (Seq)
-import           Data.Text (Text)
-import qualified Data.Text as Text
-import           Data.TreeMap.Strict (TreeMap)
-import qualified Data.TreeMap.Strict as TreeMap
-
-import qualified Hcompta as H
-import qualified Hcompta.JCC as JCC
-import qualified Hcompta.Ledger as Ledger
-
-import qualified Hcompta.Lib.Strict as Strict
-
--- * Class 'Convert'
-
--- | Generic class dedicated to transform any type
---   into another one encoding more or less
---   the same data.
-class Convert from to where
-       convert :: from -> to
-
-instance Convert () () where
-       convert = id
-
--- Journal
-instance
- ( Convert ledger jcc
- , Monoid jcc
- , Monoid ledger
- )
- => Convert (Ledger.Journal ledger) (JCC.Journal jcc) where
-       convert Ledger.Journal{..} =
-               JCC.Journal
-                { JCC.journal_amount_styles = convert journal_amount_styles
-                , JCC.journal_chart = convert journal_chart
-                , JCC.journal_files
-                , JCC.journal_includes = convert <$> journal_includes
-                , JCC.journal_last_read_time
-                , JCC.journal_content = convert journal_content
-                }
-instance
- ( Convert jcc ledger
- , Monoid jcc
- , Monoid ledger
- )
- => Convert (JCC.Journal jcc) (Ledger.Journal ledger) where
-       convert JCC.Journal{..} =
-               Ledger.Journal
-                { Ledger.journal_amount_styles = convert journal_amount_styles
-                , Ledger.journal_chart = convert journal_chart
-                , Ledger.journal_files
-                , Ledger.journal_includes = convert <$> journal_includes
-                , Ledger.journal_last_read_time
-                , Ledger.journal_content = convert journal_content
-                }
-instance Convert ledger jcc
- => Convert
- (H.Journal ledger)
- (H.Journal jcc)
- where
-       convert (H.Journal j) =
-               H.Journal $
-               convert <$>
-               Map.mapKeysMonotonic convert j
-
--- Unit
-instance Convert Ledger.Unit JCC.Unit where
-       convert (Ledger.Unit u) =
-               JCC.Unit $
-               Text.map
-                (\c -> case Char.generalCategory c of
-                       Char.CurrencySymbol  -> c
-                       Char.LowercaseLetter -> c
-                       Char.ModifierLetter  -> c
-                       Char.OtherLetter     -> c
-                       Char.TitlecaseLetter -> c
-                       Char.UppercaseLetter -> c
-                       _ -> '_') u
-instance Convert JCC.Unit Ledger.Unit where
-       convert (JCC.Unit u) =
-               Ledger.Unit u
-
--- Account
-instance Convert H.Account_Anchor H.Account_Anchor where
-       convert = id
-instance Convert H.Account_Tags H.Account_Tags where
-       convert = id
-
--- Amount Style
-instance Convert Ledger.Amount_Styles JCC.Amount_Styles where
-       convert (Ledger.Amount_Styles sty) =
-               JCC.Amount_Styles $ convert sty
-instance Convert JCC.Amount_Styles Ledger.Amount_Styles where
-       convert (JCC.Amount_Styles sty) =
-               Ledger.Amount_Styles $ convert sty
-instance Convert Ledger.Amount_Style JCC.Amount_Style where
-       convert Ledger.Amount_Style{..} =
-               JCC.Amount_Style
-                { JCC.amount_style_fractioning
-                , JCC.amount_style_grouping_integral =
-                       (<$> amount_style_grouping_integral) $
-                        \(Ledger.Amount_Style_Grouping c l) ->
-                               JCC.Amount_Style_Grouping c l
-                , JCC.amount_style_grouping_fractional =
-                       (<$> amount_style_grouping_fractional) $
-                        \(Ledger.Amount_Style_Grouping c l) ->
-                               JCC.Amount_Style_Grouping c l
-                , JCC.amount_style_unit_side =
-                       (<$> amount_style_unit_side) $ \s ->
-                               case s of
-                                Ledger.Amount_Style_Side_Left  -> JCC.Amount_Style_Side_Left
-                                Ledger.Amount_Style_Side_Right -> JCC.Amount_Style_Side_Right
-                , JCC.amount_style_unit_spaced
-                }
-instance Convert JCC.Amount_Style Ledger.Amount_Style where
-       convert JCC.Amount_Style{..} =
-               Ledger.Amount_Style
-                { Ledger.amount_style_fractioning
-                , Ledger.amount_style_grouping_integral =
-                       (<$> amount_style_grouping_integral) $
-                        \(JCC.Amount_Style_Grouping c l) ->
-                               Ledger.Amount_Style_Grouping c l
-                , Ledger.amount_style_grouping_fractional =
-                       (<$> amount_style_grouping_fractional) $
-                        \(JCC.Amount_Style_Grouping c l) ->
-                               Ledger.Amount_Style_Grouping c l
-                , Ledger.amount_style_unit_side =
-                       (<$> amount_style_unit_side) $ \s ->
-                               case s of
-                                JCC.Amount_Style_Side_Left  -> Ledger.Amount_Style_Side_Left
-                                JCC.Amount_Style_Side_Right -> Ledger.Amount_Style_Side_Right
-                , Ledger.amount_style_unit_spaced
-                }
-
--- Transaction
-instance Convert Ledger.Transaction JCC.Transaction where
-       convert Ledger.Transaction{..} =
-               JCC.Transaction
-                { JCC.transaction_anchors = mempty
-                , JCC.transaction_comments =
-                       List.filter (not . Text.all Char.isSpace) $
-                       Ledger.comments_without_tags $
-                               mappend
-                                transaction_comments_before
-                                transaction_comments_after
-                , JCC.transaction_dates
-                , JCC.transaction_postings = (convert <$>) <$> transaction_postings
-                , JCC.transaction_sourcepos
-                , JCC.transaction_tags =
-                       (case transaction_code of
-                        t | Text.null t -> id
-                        t -> H.transaction_tag_cons (H.transaction_tag ("Code":|[]) t)
-                       ) $
-                       if transaction_status
-                        then H.transaction_tag_cons
-                                (H.transaction_tag ("Status":|[]) "")
-                                transaction_tags
-                        else transaction_tags
-                , JCC.transaction_wording
-                }
-instance Convert JCC.Transaction Ledger.Transaction where
-       convert JCC.Transaction{..} =
-               let H.Transaction_Tags (H.Tags tags) = transaction_tags in
-               Ledger.Transaction
-                { Ledger.transaction_code = mconcat $ Map.findWithDefault [""] ("Code":|[]) tags
-                , Ledger.transaction_comments_after = mempty
-                , Ledger.transaction_comments_before = transaction_comments
-                , Ledger.transaction_dates
-                , Ledger.transaction_postings = (convert <$>) <$> transaction_postings
-                , Ledger.transaction_sourcepos
-                , Ledger.transaction_status =
-                       case Map.lookup ("Status":|[]) tags of
-                        Nothing -> False
-                        Just _ -> True
-                , Ledger.transaction_tags =
-                       H.Transaction_Tags $ H.Tags $
-                       Map.delete ("Code":|[]) $
-                       Map.delete ("Status":|[]) $
-                       tags
-                , Ledger.transaction_wording
-                }
-
--- Posting
-instance Convert Ledger.Posting JCC.Posting where
-       convert Ledger.Posting{..} =
-               JCC.Posting
-                { JCC.posting_account
-                , JCC.posting_account_anchor = Nothing
-                , JCC.posting_amounts =
-                       convert <$>
-                       Map.mapKeysMonotonic convert posting_amounts
-                , JCC.posting_anchors = mempty
-                , JCC.posting_comments =
-                       List.filter (not . Text.all Char.isSpace) $
-                       Ledger.comments_without_tags posting_comments
-                , JCC.posting_dates
-                , JCC.posting_sourcepos
-                , JCC.posting_tags =
-                       if posting_status
-                        then H.posting_tag_cons
-                                (H.Posting_Tag $ H.tag ("Status":|[]) "")
-                                posting_tags
-                        else posting_tags
-                }
-instance Convert JCC.Posting Ledger.Posting where
-       convert JCC.Posting{..} =
-               let H.Posting_Tags (H.Tags tags) = posting_tags in
-               Ledger.Posting
-                { Ledger.posting_account
-                , Ledger.posting_amounts =
-                       convert <$>
-                       Map.mapKeysMonotonic convert posting_amounts
-                , Ledger.posting_comments
-                , Ledger.posting_dates
-                , Ledger.posting_status =
-                       case Map.lookup ("Status":|[]) tags of
-                        Nothing -> False
-                        Just _ -> True
-                , Ledger.posting_sourcepos
-                , Ledger.posting_tags =
-                       H.Posting_Tags $ H.Tags $
-                       Map.delete ("Status":|[]) $
-                       tags
-                }
-
--- Chart
-instance Convert JCC.Chart Ledger.Chart where
-       convert JCC.Chart{..} =
-               Ledger.Chart
-                { Ledger.chart_accounts = chart_accounts
-                }
-instance Convert Ledger.Chart JCC.Chart where
-       convert Ledger.Chart{..} =
-               JCC.Chart
-                { JCC.chart_accounts = chart_accounts
-                , JCC.chart_anchors  = mempty
-                }
-{-
-instance Convert (Chart.Chart x) (Chart.Chart x) where
-       convert = id
-instance
- ( Convert (Chart.Chart a0) (Chart.Chart a1)
- , Convert x y
- ) => Convert (Chart.Charted a0 x) (Chart.Charted a1 y) where
-       convert (Chart.Charted a x) =
-               Chart.Charted (convert a) (convert x)
--}
-{-
-instance Convert (Chart.Chart JCC.Account) (Chart.Chart Ledger.Account) where
-       convert Chart.Chart
-        { Chart.chart_accounts
-        , Chart.chart_anchors
-        } =
-               Chart.Chart
-                { Chart.chart_accounts = convert chart_accounts
-                , Chart.chart_anchors  = convert chart_anchors
-                }
--}
-
-instance Convert x y => Convert (JCC.Charted x) (Ledger.Charted y) where
-       convert (JCC.Charted c x) =
-               Ledger.Charted (convert c) (convert x)
-
-instance Convert x y => Convert (Ledger.Charted x) (JCC.Charted y) where
-       convert (Ledger.Charted c x) =
-               JCC.Charted (convert c) (convert x)
-
--- Balance
-instance
- ( Convert unit unit_
- , Convert quantity quantity_
- ) => Convert (H.Balance_by_Account_Sum unit quantity)
-              (H.Balance_by_Account_Sum unit_ quantity_) where
-       convert (H.Balance_by_Account_Sum m) =
-               H.Balance_by_Account_Sum $
-               convert <$>
-               Map.mapKeysMonotonic convert m
-
--- * GL
-
--- ** Class 'GL'
-class
- ( Convert (H.Account_Section (H.Posting_Account (H.Transaction_Posting x)))
-           (H.Account_Section (H.Posting_Account (H.Transaction_Posting y)))
- ) => GL x y
-instance GL    JCC.Transaction Ledger.Transaction
-instance GL Ledger.Transaction    JCC.Transaction
-
-instance GL (   JCC.Charted    JCC.Transaction)
-            (Ledger.Charted Ledger.Transaction)
-instance GL (Ledger.Charted Ledger.Transaction)
-            (JCC.Charted       JCC.Transaction)
-
-instance
- ( GL x y
- , GL_Line x y
- , H.GL_Transaction x
- , H.GL_Transaction y
- , Convert x y
- ) => Convert (H.GL x)
-              (H.GL y) where
-       convert (H.GL m)
-        = H.GL $ TreeMap.map_monotonic convert (convert <$>) m
-        -- NOTE: Date does not need to be converted,
-        -- thus avoid a useless Map.mapKeysMonotonic
-        -- from the Convert instance on Map.
-
--- *** Class 'GL_Line'
-
-class
- ( Convert (H.GL_Transaction_Line x)
-           (H.GL_Transaction_Line y)
- , Convert (H.Transaction_Posting x)
-           (H.Transaction_Posting y)
- , Convert (H.GL_Posting_Quantity (H.Transaction_Posting x))
-           (H.GL_Posting_Quantity (H.Transaction_Posting y))
- ) => GL_Line x y
-instance GL_Line    JCC.Transaction Ledger.Transaction
-instance GL_Line Ledger.Transaction    JCC.Transaction
-
-instance GL_Line (   JCC.Charted    JCC.Transaction)
-                 (Ledger.Charted Ledger.Transaction)
-instance GL_Line (Ledger.Charted Ledger.Transaction)
-                 (JCC.Charted       JCC.Transaction)
-
-instance
- ( GL_Line x y
- , H.GL_Transaction x
- , H.GL_Transaction y
- , Convert x y
- ) => Convert (H.GL_Line x)
-              (H.GL_Line y) where
-       convert H.GL_Line{..} =
-               H.GL_Line
-                { H.gl_line_transaction = convert gl_line_transaction
-                , H.gl_line_posting     = convert gl_line_posting
-                , H.gl_line_sum         = convert gl_line_sum
-                }
-
--- Class 'GL_Expanded'
-
-instance
- ( GL x y
- , GL_Line x y
- , H.GL_Transaction x
- , H.GL_Transaction y
- , Convert x y
- ) => Convert (H.GL_Expanded x)
-              (H.GL_Expanded y) where
-       convert (H.GL_Expanded m)
-        = H.GL_Expanded $ convert m
-
--- Class 'GL_Line_Expanded'
-
-instance
- Convert x y
- => Convert (Strict.Clusive x)
-            (Strict.Clusive y) where
-       convert Strict.Clusive{..} =
-               Strict.Clusive
-                { Strict.exclusive = convert exclusive
-                , Strict.inclusive = convert inclusive
-                }
-
--- Const
-instance Convert x y
- => Convert (Const x w) (Const y w_) where
-       convert (Const x) = Const $ convert x
-
--- Polarized
-instance
- Convert x y
- => Convert (H.Polarized x)
-            (H.Polarized y) where
-       convert = (convert <$>)
-
--- Date
-instance Convert H.Date H.Date where
-       convert = id
-
--- Quantity
-instance Convert Decimal Decimal where
-       convert = id
-
--- Text
-instance Convert Text Text where
-       convert = id
-
--- List
-instance Convert x y => Convert [x] [y] where
-       convert = fmap convert
-instance Convert x y => Convert (NonEmpty x) (NonEmpty y) where
-       convert = fmap convert
-
--- TreeMap
-
-instance (Convert kx ky, Convert x y, Ord kx, Ord ky)
- => Convert (TreeMap kx x) (TreeMap ky y) where
-       convert = TreeMap.map_monotonic convert convert
-
--- Map
-instance (Convert kx ky, Convert x y, Ord kx)
- => Convert (Map kx x) (Map ky y) where
-       convert = Map.mapKeysMonotonic convert . fmap convert
-
--- Seq
-instance Convert x y => Convert (Seq x) (Seq y) where
-       convert = fmap convert
-
--- * Stats
-
--- ** Class 'Stats'
-class
- ( Convert (H.Posting_Account (H.Transaction_Posting x))
-           (H.Posting_Account (H.Transaction_Posting y))
- , Convert (H.Amount_Unit (H.Posting_Amount (H.Transaction_Posting x)))
-           (H.Amount_Unit (H.Posting_Amount (H.Transaction_Posting y)))
- ) => Stats x y
-
-instance Stats    JCC.Transaction Ledger.Transaction
-instance Stats Ledger.Transaction    JCC.Transaction
-
-instance Stats (   JCC.Charted    JCC.Transaction)
-               (Ledger.Charted Ledger.Transaction)
-instance Stats (Ledger.Charted Ledger.Transaction)
-               (JCC.Charted       JCC.Transaction)
-
-instance
- ( Stats x y
- , H.Stats_Transaction x
- , H.Stats_Transaction y
- ) => Convert (H.Stats x) (H.Stats y) where
-       convert s@H.Stats{..} =
-               s
-                { H.stats_accounts = Map.mapKeysMonotonic convert stats_accounts
-                , H.stats_units    = Map.mapKeysMonotonic convert stats_units
-                }
diff --git a/cli/Hcompta/CLI/Env.hs b/cli/Hcompta/CLI/Env.hs
deleted file mode 100644 (file)
index 2c5c8e0..0000000
+++ /dev/null
@@ -1,26 +0,0 @@
-module Hcompta.CLI.Env where
-
-import           Control.Exception (tryJust)
-import           Control.Monad (Monad(..), guard)
-import           Data.Either (Either(..))
-import           Prelude (($), (.), IO)
-import           System.Environment as Env (getEnv)
-import           System.IO (FilePath)
-import           System.IO.Error (isDoesNotExistError)
-
-import qualified Hcompta.CLI.Context as C
-import qualified Hcompta.CLI.Lang as Lang
-import qualified Hcompta.CLI.Write as Write
-
--- | Return 'FilePath's containing 'Hcompta.Format.JCC.Journal's:
---
--- * either those given if any,
--- * or the one in HCOMPTA_JOURNAL environment variable if any,
-paths :: C.Context -> [FilePath] -> IO [FilePath]
-paths c [] = do
-       x <- tryJust (guard . isDoesNotExistError) $
-               Env.getEnv "HCOMPTA_JOURNAL"
-       case x of
-        Right ok -> return [ok]
-        Left  _ko -> Write.fatal c Lang.Error_No_input_file_given
-paths _c ps = return ps
diff --git a/cli/Hcompta/CLI/Format.hs b/cli/Hcompta/CLI/Format.hs
deleted file mode 100644 (file)
index 87c0763..0000000
+++ /dev/null
@@ -1,219 +0,0 @@
-{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-module Hcompta.CLI.Format where
-
-import           Control.Monad.Trans.Except (runExceptT)
-import           Data.Either (Either(..))
-import           Data.Function (($), (.))
-import           Data.Functor (Functor, (<$>))
-import           Data.Monoid (Monoid(..))
-import           System.IO (FilePath, IO)
-import           Text.Show (Show)
-import qualified Text.Parsec.Error.Custom as R
-
-import qualified Hcompta.CLI.Lang as Lang
-import qualified Text.WalderLeijen.ANSI.Text as W
-
-import qualified Hcompta.JCC as JCC
-import qualified Hcompta.Ledger as Ledger
-
-import           Hcompta.Lib.Consable (Consable)
-import qualified Hcompta.CLI.Lib.Leijen.Table as Leijen.Table
-
-import Hcompta.CLI.Convert
-
--- * Type 'Format'
-
-data Format jcc ledger
- =   Format_JCC    jcc
- |   Format_Ledger ledger
- deriving (Show)
-type Formats = Format () ()
-
-instance
- ( Convert jcc ledger
- , Convert ledger jcc
- , Monoid jcc
- , Monoid ledger
- ) => Monoid (Format jcc ledger) where
-       mempty = Format_JCC mempty
-       mappend x y =
-               case x of
-                Format_JCC xj ->
-                       Format_JCC $
-                       case y of
-                        Format_JCC    yj -> mappend xj yj
-                        Format_Ledger yj -> mappend xj (convert yj)
-                Format_Ledger xj ->
-                       Format_Ledger $
-                       case y of
-                        Format_JCC    yj -> mappend xj (convert yj)
-                        Format_Ledger yj -> mappend xj yj
-
-format :: Formats
-format = Format_JCC ()
-
--- * Type family 'Journal_Account'
-type family   Journal_Account (j:: * -> *)
-type instance Journal_Account    JCC.Journal =    JCC.Account
-type instance Journal_Account Ledger.Journal = Ledger.Account
-
--- * Type family 'Journal_Account_Section'
-type family   Journal_Account_Section (j:: * -> *)
-type instance Journal_Account_Section    JCC.Journal =    JCC.Account_Section
-type instance Journal_Account_Section Ledger.Journal = Ledger.Account_Section
-
--- * Type family 'Journal_Charted'
-type family   Journal_Charted (j:: * -> *) :: * -> *
-type instance Journal_Charted    JCC.Journal =    JCC.Charted
-type instance Journal_Charted Ledger.Journal = Ledger.Charted
-
--- * Type family 'Journal_Quantity'
-type family   Journal_Quantity (j:: * -> *)
-type instance Journal_Quantity    JCC.Journal =    JCC.Quantity
-type instance Journal_Quantity Ledger.Journal = Ledger.Quantity
-
--- * Type family 'Journal_Unit'
-type family   Journal_Unit (j:: * -> *)
-type instance Journal_Unit    JCC.Journal =    JCC.Unit
-type instance Journal_Unit Ledger.Journal = Ledger.Unit
-
--- * Type family 'Journal_Posting'
-type family   Journal_Posting (j:: * -> *)
-type instance Journal_Posting    JCC.Journal =    JCC.Posting
-type instance Journal_Posting Ledger.Journal = Ledger.Posting
-
--- * Type family 'Journal_Transaction'
-type family   Journal_Transaction (j:: * -> *)
-type instance Journal_Transaction    JCC.Journal =    JCC.Transaction
-type instance Journal_Transaction Ledger.Journal = Ledger.Transaction
-
--- * Class 'Journal'
-
-class Journal j where
-       type Journal_Format j
-       journal_format
-        :: j -> Journal_Format j
-
--- * Class 'Journal_Empty'
-
-class Journal_Empty j where
-       journal_empty :: Formats -> j
-
--- * Class 'Journal_Files'
-
-class Journal_Files j where
-       journal_files :: forall m. j m -> [FilePath]
-instance Journal_Files JCC.Journal where
-       journal_files = JCC.journal_files
-instance Journal_Files Ledger.Journal where
-       journal_files = Ledger.journal_files
-
--- * Class 'Journal_Read'
-
-class Journal_Read (j:: * -> *) where
-       type Journal_Read_Error       j
-       type Journal_Read_Transaction j
-       journal_read
-        :: forall c m. (Monoid m, Consable c m)
-        => (Journal_Read_Transaction j -> c)
-        -> FilePath
-        -> IO (Either (Journal_Read_Error j) (j m))
-instance Journal_Read JCC.Journal where
-       type Journal_Read_Error JCC.Journal
-        = [R.Error JCC.Error_Read]
-       type Journal_Read_Transaction JCC.Journal
-        = JCC.Charted JCC.Transaction
-       journal_read cons =
-               runExceptT . JCC.read_file
-                (JCC.context_read cons JCC.journal)
-instance Journal_Read Ledger.Journal where
-       type Journal_Read_Error Ledger.Journal
-        = [R.Error Ledger.Error_Read]
-       type Journal_Read_Transaction Ledger.Journal
-        = Ledger.Charted Ledger.Transaction
-       journal_read cons =
-               runExceptT . Ledger.read_file
-                (Ledger.context_read cons Ledger.journal)
-
-{-
--- * Class 'Journal_Chart'
-
-class Journal_Chart (j:: * -> *) where
-       journal_chart
-        :: forall m. j m
-        -> Chart.Chart (NonEmpty (Journal_Account_Section j))
-instance Journal_Chart JCC.Journal where
-       journal_chart = JCC.journal_chart
-instance Journal_Chart Ledger.Journal where
-       journal_chart = Ledger.journal_chart
--}
-
--- * Class 'Journal_Monoid'
-
-class Journal_Monoid j where
-       journal_flatten :: j -> j
-       journal_fold    :: (j -> a -> a) -> j -> a -> a
-instance Monoid m => Journal_Monoid (JCC.Journal m) where
-       journal_flatten = JCC.journal_flatten
-       journal_fold    = JCC.journal_fold
-instance Monoid m => Journal_Monoid (Ledger.Journal m) where
-       journal_flatten = Ledger.journal_flatten
-       journal_fold    = Ledger.journal_fold
-
--- * Class 'Journal_Filter'
-
-class Functor j => Journal_Filter context j m where
-       journal_filter
-        :: context -> j m -> j m
-
--- * Class 'Journal_Functor'
-
-class Journal_Functor x y where
-       journal_functor_map :: x -> y
-       journal_fmap :: forall j. Functor j => j x -> j y
-       journal_fmap = (journal_functor_map <$>)
-
--- * Class 'Journal_Table'
-
--- | A class to render a journal
---   into 'Leijen.Table.Cell's.
-class Journal_Leijen_Table_Cells j m where
-       journal_leijen_table_cells
-        :: j m
-        -> [[Leijen.Table.Cell]]
-        -> [[Leijen.Table.Cell]]
-
-
--- * Class 'Journal_Wrap'
-
--- | A class dedicated to transform a journal
---   to another one using existential quantification
---   to gather multiple journals under a single type,
---   by writing instances between fully monomorphic types,
---   which ease a lot meeting the requirements
---   of the constraints in the wrap type.
-class Journal_Wrap j wrap where
-       journal_wrap :: j -> wrap
-
-class Journal_Content j where
-       journal_content :: forall m. j m -> m
-instance Journal_Content JCC.Journal where
-       journal_content = JCC.journal_content
-instance Journal_Content Ledger.Journal where
-       journal_content = Ledger.journal_content
-
--- * Type 'Message'
-
--- data Journal jnl m = forall j. jnl j => Journal (j m)
-data Message w = forall msg. Lang.Translate msg w => Message msg
-instance Lang.Translate (Message W.Doc) W.Doc where
-       translate lang (Message x) = Lang.translate lang x
diff --git a/cli/Hcompta/CLI/Format/HLint.hs b/cli/Hcompta/CLI/Format/HLint.hs
deleted file mode 120000 (symlink)
index ab18269..0000000
+++ /dev/null
@@ -1 +0,0 @@
-../HLint.hs
\ No newline at end of file
diff --git a/cli/Hcompta/CLI/Format/JCC.hs b/cli/Hcompta/CLI/Format/JCC.hs
deleted file mode 100644 (file)
index d69b3a0..0000000
+++ /dev/null
@@ -1,96 +0,0 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Hcompta.CLI.Format.JCC where
-
-import           Data.Foldable (Foldable(..))
-import           Data.Function (($), (.))
-import qualified Data.List as List
-import qualified Data.Text as Text
-import qualified Data.Text.Lazy as TL
-import           Text.Show (Show(..))
-import           Text.WalderLeijen.ANSI.Text (ToDoc(..))
-import qualified Text.WalderLeijen.ANSI.Text as W
-
-import qualified Hcompta as H
-import qualified Hcompta.JCC as JCC
-
-import qualified Hcompta.CLI.Lang as Lang
-import qualified Hcompta.CLI.Lib.Leijen.Table as Leijen.Table
-
-
-instance Lang.Translate JCC.Error_Read W.Doc where
-       translate lang err =
-               case err of
-                JCC.Error_Read_date date -> toDoc lang date
-                JCC.Error_Read_transaction_not_equilibrated styles tr unit_sums ->
-                       i18n_transaction_not_equilibrated styles tr unit_sums
-                        Lang.Error_Transaction_The_following_transaction_is_not_equilibrated_because
-                JCC.Error_Read_reading_file file_path exn ->
-                       W.vsep $
-                        [ Lang.translate lang $ Lang.Error_Failed_to_read_file file_path
-                        , W.text $ TL.pack $ show exn
-                        ]
-                JCC.Error_Read_including_file file_path errs ->
-                       W.vsep $
-                        [ Lang.translate lang $ Lang.Error_Failed_to_include_file file_path
-                        , Lang.translate lang errs
-                        ]
-                JCC.Error_Read_account_anchor_unknown pos anchor ->
-                       Lang.translate lang $ Lang.Error_Account_Anchor_unknown pos anchor
-                JCC.Error_Read_account_anchor_not_unique pos anchor ->
-                       Lang.translate lang $ Lang.Error_Account_Anchor_is_not_unique pos anchor
-               where
-                       i18n_transaction_not_equilibrated styles tr unit_sums msg =
-                               W.vsep $
-                                [ Lang.translate lang msg
-                                , W.vsep $ List.map
-                                        (\(unit, H.Balance_by_Unit_Sum{..}) ->
-                                               Lang.translate lang $
-                                               Lang.Error_Transaction_JCC_Unit_sums_up_to_the_non_null_amount unit $
-                                               JCC.amount_styled styles $
-                                               JCC.Amount unit $
-                                               H.depolarize balance_by_unit_sum_quantity
-                                        ) unit_sums
-                                , W.space
-                                , JCC.write_transaction styles tr
-                                ]
-
-instance Leijen.Table.Cell_of_forall_param JCC.Journal H.Date where
-       cell_of_forall_param _ctx date =
-               Leijen.Table.cell
-                { Leijen.Table.cell_content = JCC.write_date        date
-                , Leijen.Table.cell_width   = JCC.write_date_length date
-                }
-instance Leijen.Table.Cell_of_forall_param JCC.Journal JCC.Account where
-       cell_of_forall_param _ctx account =
-               Leijen.Table.cell
-                { Leijen.Table.cell_content = JCC.write_account        account
-                , Leijen.Table.cell_width   = JCC.write_account_length account
-                }
-instance Leijen.Table.Cell_of_forall_param JCC.Journal (JCC.Unit, JCC.Quantity) where
-       cell_of_forall_param j (unit, qty) =
-               let sty = JCC.journal_amount_styles j in
-               let amt = JCC.Amount unit qty in
-               let sa  = JCC.amount_styled sty amt in
-               Leijen.Table.cell
-                { Leijen.Table.cell_content = JCC.write_amount        sa
-                , Leijen.Table.cell_width   = JCC.write_amount_length sa
-                }
-instance Leijen.Table.Cell_of_forall_param JCC.Journal JCC.Wording where
-       cell_of_forall_param _j w =
-               Leijen.Table.cell
-                { Leijen.Table.cell_content = toDoc ()    w
-                , Leijen.Table.cell_width   = Text.length w
-                }
-
-instance Foldable f => W.ToDoc1 JCC.Journal (f JCC.Transaction) where
-       toDoc1 =
-               JCC.write_transactions .
-               JCC.journal_amount_styles
diff --git a/cli/Hcompta/CLI/Format/Ledger.hs b/cli/Hcompta/CLI/Format/Ledger.hs
deleted file mode 100644 (file)
index 2efd3e0..0000000
+++ /dev/null
@@ -1,94 +0,0 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Hcompta.CLI.Format.Ledger where
-
-import           Data.Foldable (Foldable(..))
-import           Data.Function (($), (.))
-import qualified Data.List as List
-import qualified Data.Text as Text
-import qualified Data.Text.Lazy as TL
-import           Text.Show (Show(..))
-import           Text.WalderLeijen.ANSI.Text (ToDoc(..))
-import qualified Text.WalderLeijen.ANSI.Text as W
-
-import qualified Hcompta as H
-import qualified Hcompta.Ledger as Ledger
-
-import qualified Hcompta.CLI.Lang as Lang
-import qualified Hcompta.CLI.Lib.Leijen.Table as Leijen.Table
-
-instance Lang.Translate Ledger.Error_Read W.Doc where
-       translate lang err =
-               case err of
-                Ledger.Error_Read_date date -> toDoc lang date
-                Ledger.Error_Read_transaction_not_equilibrated styles tr unit_sums ->
-                       i18n_transaction_not_equilibrated styles tr unit_sums
-                        Lang.Error_Transaction_The_following_transaction_is_not_equilibrated_because
-                Ledger.Error_Read_virtual_transaction_not_equilibrated styles tr unit_sums ->
-                       i18n_transaction_not_equilibrated styles tr unit_sums
-                        Lang.Error_Transaction_The_following_virtual_transaction_is_not_equilibrated_because
-                Ledger.Error_Read_reading_file file_path exn ->
-                       W.vsep $
-                        [ Lang.translate lang $ Lang.Error_Failed_to_read_file file_path
-                        , W.text $ TL.pack $ show exn
-                        ]
-                Ledger.Error_Read_including_file file_path errs ->
-                       W.vsep $
-                        [ Lang.translate lang $ Lang.Error_Failed_to_include_file file_path
-                        , Lang.translate lang errs
-                        ]
-               where
-                       i18n_transaction_not_equilibrated styles tr unit_sums msg =
-                               W.vsep $
-                                [ Lang.translate lang msg
-                                , W.vsep $ List.map
-                                        (\(unit, H.Balance_by_Unit_Sum{..}) ->
-                                               Lang.translate lang $
-                                               Lang.Error_Transaction_Ledger_Unit_sums_up_to_the_non_null_amount unit $
-                                               Ledger.amount_styled styles $
-                                               Ledger.Amount unit $
-                                               H.depolarize balance_by_unit_sum_quantity
-                                        ) unit_sums
-                                , W.space
-                                , Ledger.write_transaction styles tr
-                                ]
-
-instance Leijen.Table.Cell_of_forall_param Ledger.Journal H.Date where
-       cell_of_forall_param _ctx date =
-               Leijen.Table.cell
-                { Leijen.Table.cell_content = Ledger.write_date        date
-                , Leijen.Table.cell_width   = Ledger.write_date_length date
-                }
-instance Leijen.Table.Cell_of_forall_param Ledger.Journal Ledger.Account where
-       cell_of_forall_param _ctx account =
-               let posting_type = Ledger.Posting_Type_Regular in
-               Leijen.Table.cell
-                { Leijen.Table.cell_content = Ledger.write_account        posting_type account
-                , Leijen.Table.cell_width   = Ledger.write_account_length posting_type account
-                }
-instance Leijen.Table.Cell_of_forall_param Ledger.Journal (Ledger.Unit, Ledger.Quantity) where
-       cell_of_forall_param j (unit, qty) =
-               let sty = Ledger.journal_amount_styles j in
-               let amt = Ledger.Amount unit qty in
-               let sa  = Ledger.amount_styled sty amt in
-               Leijen.Table.cell
-                { Leijen.Table.cell_content = Ledger.write_amount        sa
-                , Leijen.Table.cell_width   = Ledger.write_amount_length sa
-                }
-instance Leijen.Table.Cell_of_forall_param Ledger.Journal Ledger.Wording where
-       cell_of_forall_param _j w =
-               Leijen.Table.cell
-                { Leijen.Table.cell_content = toDoc ()    w
-                , Leijen.Table.cell_width   = Text.length w
-                }
-
-instance Foldable f => W.ToDoc1 Ledger.Journal (f Ledger.Transaction) where
-       toDoc1 =
-               Ledger.write_transactions .
-               Ledger.journal_amount_styles
diff --git a/cli/Hcompta/CLI/HLint.hs b/cli/Hcompta/CLI/HLint.hs
deleted file mode 120000 (symlink)
index ab18269..0000000
+++ /dev/null
@@ -1 +0,0 @@
-../HLint.hs
\ No newline at end of file
diff --git a/cli/Hcompta/CLI/Lang.hs b/cli/Hcompta/CLI/Lang.hs
deleted file mode 100644 (file)
index 7ef50d4..0000000
+++ /dev/null
@@ -1,650 +0,0 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TupleSections #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Hcompta.CLI.Lang where
-
-import qualified Data.List as List
-import           Data.Maybe (catMaybes, fromMaybe)
-import qualified Data.Text as Text
-import           Data.Text (Text)
-import qualified Data.Text.Lazy as TL
-import           Data.Monoid ((<>))
-import           Prelude hiding (error)
-import qualified System.Environment as Env
-import qualified System.IO.Memoize as IO
-import qualified Text.Parsec as Parsec
-import qualified Text.Parsec.Error as Parsec.Error
-import qualified Text.Parsec.Error.Custom as Parsec
-
-import qualified Hcompta as H
-import qualified Hcompta.Ledger as Ledger
-import qualified Hcompta.JCC as JCC
-
-import           Text.WalderLeijen.ANSI.Text (ToDoc(..))
-import qualified Text.WalderLeijen.ANSI.Text as W
-
--- * Type 'Lang'
-data Lang
- = EN
- | FR
- deriving (Show)
-
--- * Class 'Translate'
-class Translate from to where
-       translate :: Lang -> from -> to
-instance Translate e e where
-       translate _lang = id
-
--- TODO: check that this is expected behavior
---       and portability issues.
-from_Env :: IO Lang
-from_Env = do
-       io_env <- IO.once Env.getEnvironment
-       (<$> io_env) $ \env ->
-               fromMaybe EN $ from_Strings $
-                       List.concatMap
-                        ((\lang ->
-                               let short = takeWhile (/= '_') lang in
-                               if short == lang
-                               then [lang]
-                               else [lang, short])
-                        . List.takeWhile (/= '.') ) $
-                       catMaybes
-                        [ List.lookup "LC_ALL"   env
-                        , List.lookup "LC_CTYPE" env
-                        , List.lookup "LANG"     env
-                        ]
-
-from_Strings :: [String] -> Maybe Lang
-from_Strings s =
-       case s of
-        ("fr"   :_) -> Just FR
-        ("fr_FR":_) -> Just FR
-        ("en"   :_) -> Just EN
-        ("en_US":_) -> Just EN
-        (_:xs)      -> from_Strings xs
-        []          -> Nothing
-
-(#) :: ToDoc () a => a -> W.Doc
-(#) = toDoc ()
-
-instance ToDoc () Text where
-       toDoc _ = W.strict_text
-instance ToDoc () String where
-       toDoc _ = W.strict_text . Text.pack
-instance ToDoc () Int where
-       toDoc _ = W.int
-instance ToDoc () Integer where
-       toDoc _ = W.integer
-instance ToDoc () JCC.Unit where
-       toDoc _ = JCC.write_unit
-instance ToDoc () H.Account_Anchor where
-       toDoc _ = JCC.write_account_anchor
-instance ToDoc () H.Transaction_Anchor where
-       toDoc _ = JCC.write_transaction_anchor
-instance ToDoc () (JCC.Amount_Styled JCC.Amount) where
-       toDoc _ = JCC.write_amount
-instance ToDoc () Ledger.Unit where
-       toDoc _ = Ledger.write_unit
-instance ToDoc () (Ledger.Amount_Styled Ledger.Amount) where
-       toDoc _ = Ledger.write_amount
-instance ToDoc () H.Date where
-       toDoc _ = JCC.write_date
-instance ToDoc Lang JCC.Error_Read_Date where
-       toDoc FR e =
-               case e of
-                JCC.Error_Read_Date_year_or_day_is_missing ->
-                       "l’année ou le jour est manquant·e"
-                JCC.Error_Read_Date_invalid_date (year, month, day) ->
-                       "date incorrecte (année " <> (#)year <> ", mois " <> (#)month <> ", jour " <> (#)day <> ")"
-                JCC.Error_Read_Date_invalid_time_of_day (hour, minute, second) ->
-                       "heure incorrecte (heure " <> (#)hour <> ", minute " <> (#)minute <> ", seconde " <> (#)second <> ")"
-       toDoc EN e =
-               case e of
-                JCC.Error_Read_Date_year_or_day_is_missing ->
-                       "year or day is missing"
-                JCC.Error_Read_Date_invalid_date (year, month, day) ->
-                       "invalid date (year " <> (#)year <> ", month " <> (#)month <> ", day " <> (#)day <> ")"
-                JCC.Error_Read_Date_invalid_time_of_day (hour, minute, second) ->
-                       "invalid time of day (hour " <> (#)hour <> ", minute " <> (#)minute <> ", second " <> (#)second <> ")"
-instance ToDoc Lang Ledger.Error_Read_Date where
-       toDoc FR e =
-               case e of
-                Ledger.Error_Read_Date_year_or_day_is_missing ->
-                       "l’année ou le jour est manquant·e"
-                Ledger.Error_Read_Date_invalid_date (year, month, day) ->
-                       "date incorrecte (année " <> (#)year <> ", mois " <> (#)month <> ", jour " <> (#)day <> ")"
-                Ledger.Error_Read_Date_invalid_time_of_day (hour, minute, second) ->
-                       "heure incorrecte (heure " <> (#)hour <> ", minute " <> (#)minute <> ", seconde " <> (#)second <> ")"
-       toDoc EN e =
-               case e of
-                Ledger.Error_Read_Date_year_or_day_is_missing ->
-                       "year or day is missing"
-                Ledger.Error_Read_Date_invalid_date (year, month, day) ->
-                       "invalid date (year " <> (#)year <> ", month " <> (#)month <> ", day " <> (#)day <> ")"
-                Ledger.Error_Read_Date_invalid_time_of_day (hour, minute, second) ->
-                       "invalid time of day (hour " <> (#)hour <> ", minute " <> (#)minute <> ", second " <> (#)second <> ")"
-{-
-instance Translate Filter.Read.Error W.Doc where
-       translate lang@FR err =
-               case err of
-                Filter.Read.Error_Unknown -> "erreur"
-                Filter.Read.Error_Filter_Date d -> toDoc lang d
-                Filter.Read.Error_Filter_Date_Interval (l, h) ->
-                       "mauvais intervalle: (" <> toDoc () l <> ", " <> toDoc () h <> ")"
-       translate lang@EN err =
-               case err of
-                Filter.Read.Error_Unknown -> "error"
-                Filter.Read.Error_Filter_Date d -> toDoc lang d
-                Filter.Read.Error_Filter_Date_Interval (l, h) ->
-                       "wrong interval: (" <> toDoc () l <> ", " <> toDoc () h <> ")"
--}
-
--- * Type 'Account'
-
-data Account
- =   Account_Equilibrium
-instance Translate Account Ledger.Account where
-       translate EN t =
-               case t of
-                Account_Equilibrium -> Ledger.account "Equilibrium" []
-       translate FR t =
-               case t of
-                Account_Equilibrium -> Ledger.account "Équilibre" []
-
--- * Type 'Comment'
-
-data Comment
- =   Comment_Equilibrium
-instance Translate Comment Text where
-       translate EN t =
-               case t of
-                Comment_Equilibrium -> "Equilibrium posting"
-       translate FR t =
-               case t of
-                Comment_Equilibrium -> "Mouvement d’équilibre"
-
--- * Type 'Description'
-
-data Description
- =   Description_Exercise Exercise_OC
-data Exercise_OC
- =   Exercise_Opening
- |   Exercise_Closing
- deriving (Eq, Show)
-
-instance Translate Description Text where
-       translate EN t =
-               case t of
-                Description_Exercise oc ->
-                       case oc of
-                        Exercise_Opening -> "Opening balance"
-                        Exercise_Closing -> "Closing balance"
-       translate FR t =
-               case t of
-                Description_Exercise oc ->
-                       case oc of
-                        Exercise_Opening -> "Solde d’ouverture"
-                        Exercise_Closing -> "Solde de fermeture"
-
--- * Type 'Error'
-data Error
- =   Error_Account_Anchor_is_not_unique Parsec.SourcePos H.Account_Anchor
- |   Error_Account_Anchor_unknown Parsec.SourcePos H.Account_Anchor
- |   Error_Failed_to_include_file FilePath
- |   Error_Failed_to_read_file FilePath
- |   Error_No_input_file_given
- |   Error_One_command_is_required
- |   Error_Option_Balance_Format
- |   Error_Option_Balance_Heritage
- |   Error_Option_Balance_Redundant
- |   Error_Option_Balance_Total
- |   Error_Option_Color
- |   Error_Option_Equilibrium
- |   Error_Option_Equilibrium_Credit
- |   Error_Option_Equilibrium_Debit
- |   Error_Option_Tags_Tree
- |   Error_Option_Verbosity
- |   Error_Transaction_Anchor_unknown Parsec.SourcePos H.Transaction_Anchor
- |   Error_Transaction_Anchor_is_not_unique Parsec.SourcePos H.Transaction_Anchor
- |   Error_Transaction_Invalid_date Integer Int Int
- |   Error_Transaction_Invalid_time_of_day Int Int Integer
- |   Error_Transaction_The_following_transaction_is_not_equilibrated_because
- |   Error_Transaction_The_following_virtual_transaction_is_not_equilibrated_because
- |   Error_Transaction_JCC_Unit_sums_up_to_the_non_null_amount JCC.Unit (JCC.Amount_Styled JCC.Amount)
- |   Error_Transaction_Ledger_Unit_sums_up_to_the_non_null_amount Ledger.Unit (Ledger.Amount_Styled Ledger.Amount)
- |   Error_Transaction_Year_or_day_is_missing
- |   Error_Unkown_command String
-instance Translate Error W.Doc where
-       translate EN t =
-               case t of
-                Error_Account_Anchor_is_not_unique _pos anchor -> "Account anchor is not unique: " <> (#)anchor
-                Error_Account_Anchor_unknown _pos anchor -> "Account anchor unkown: " <> (#)anchor
-                Error_Failed_to_read_file path    -> "failed to read file: " <> (#)path
-                Error_Failed_to_include_file path -> "failed to include file: " <> (#)path
-                Error_No_input_file_given         ->
-                       W.vsep
-                        [ "no input file given, please use:"
-                        , "- either -i $hcompta_journal parameter"
-                        , "- or HCOMPTA_JOURNAL environment variable."
-                        ]
-                Error_One_command_is_required     -> "a COMMAND is required"
-                Error_Option_Balance_Format       -> "--format option expects \"close\", \"open\", or \"table\" as argument"
-                Error_Option_Balance_Heritage     -> "--heritage option expects \"yes\" or \"no\" as argument"
-                Error_Option_Balance_Redundant    -> "--redundant option expects \"yes\" or \"no\" as argument"
-                Error_Option_Balance_Total        -> "--total option expects \"yes\" or \"no\" as argument"
-                Error_Option_Color                -> "--color option expects \"auto\" (default), \"yes\" or \"no\" as argument"
-                Error_Option_Equilibrium          -> "--eq option expects an ACCOUNT"
-                Error_Option_Equilibrium_Credit   -> "--eq-credit option expects an ACCOUNT"
-                Error_Option_Equilibrium_Debit    -> "--eq-debit  option expects an ACCOUNT"
-                Error_Option_Tags_Tree            -> "--tree option expects \"yes\" or \"no\" as value"
-                Error_Option_Verbosity            -> "--verbosity option expects \"error\", \"warn\", \"info\" or \"debug\" as argument"
-                Error_Transaction_Anchor_is_not_unique _pos anchor -> "Transaction anchor is not unique: " <> (#)anchor
-                Error_Transaction_Anchor_unknown _pos anchor -> "Transaction anchor unknown: " <> (#)anchor
-                Error_Transaction_Invalid_date year month dom ->
-                       "invalid date (year " <> (#)year <> ", month " <> (#)month <> ", day " <> (#)dom <> ")"
-                Error_Transaction_Invalid_time_of_day hour minute second ->
-                       "invalid time of day (hour " <> (#)hour <> ", minute " <> (#)minute <> ", second " <> (#)second <> ")"
-                Error_Transaction_The_following_transaction_is_not_equilibrated_because ->
-                       "the following transaction is not equilibrated, because:"
-                Error_Transaction_The_following_virtual_transaction_is_not_equilibrated_because ->
-                       "the following virtual transaction is not equilibrated, because:"
-                Error_Transaction_JCC_Unit_sums_up_to_the_non_null_amount unit amount ->
-                       " - " <>
-                       (if Text.null $ H.unit_text unit
-                       then "empty unit"
-                       else "unit " <> (#)unit) <>
-                       " sums up to the non-null amount: " <> (#)amount
-                Error_Transaction_Ledger_Unit_sums_up_to_the_non_null_amount unit amount ->
-                       " - " <>
-                       (if Text.null $ H.unit_text unit
-                       then "empty unit"
-                       else "unit " <> (#)unit) <>
-                       " sums up to the non-null amount: " <> (#)amount
-                Error_Transaction_Year_or_day_is_missing ->
-                       "year or day is missing"
-                Error_Unkown_command cmd -> "unkown command: " <> (#)cmd
-       translate FR t =
-               case t of
-                Error_Account_Anchor_is_not_unique _pos anchor -> "Ancre de Compte non-unique : " <> (#)anchor
-                Error_Account_Anchor_unknown _pos anchor -> "Ancre de Compte inconnue : " <> (#)anchor
-                Error_Failed_to_read_file path    -> "échec de la lecture du fichier : " <> (#)path
-                Error_Failed_to_include_file path -> "échec à l’inclusion du fichier : " <> (#)path
-                Error_No_input_file_given         ->
-                       W.vsep
-                        [ "aucun fichier d’entrée indiqué, veuillez utiliser :"
-                        , " - soit le paramètre -i FICHIER_DE_JOURNAL,"
-                        , " - soit la variable d’environnement LEDGER_FILE."
-                        ]
-                Error_One_command_is_required     -> "une COMMANDE est requise"
-                Error_Option_Balance_Format       -> "le paramètre --format s’attend à \"close\", \"open\" ou \"table\" comme argument"
-                Error_Option_Balance_Heritage     -> "le paramètre --heritage s’attend à \"yes\" ou \"no\" comme argument"
-                Error_Option_Balance_Redundant    -> "le paramètre --redundant s’attend à \"yes\" ou \"no\" comme argument"
-                Error_Option_Balance_Total        -> "le paramètre --total s’attend à \"yes\" ou \"no\" comme argument"
-                Error_Option_Color                -> "le paramètre --color s’attend à \"auto\" (défaut), \"yes\" ou \"no\" comme argument"
-                Error_Option_Equilibrium          -> "le paramètre --eq s’attend à un COMPTE"
-                Error_Option_Equilibrium_Credit   -> "le paramètre --eq-credit s’attend à un COMPTE"
-                Error_Option_Equilibrium_Debit    -> "le paramètre --eq-debit s’attend à un COMPTE"
-                Error_Option_Tags_Tree            -> "le paramètre --total s’attend à \"yes\" ou \"no\" comme argument"
-                Error_Option_Verbosity            -> "le paramètre --verbosity s’attend à \"error\", \"warn\", \"info\", or \"debug\" comme argument"
-                Error_Transaction_Anchor_is_not_unique _pos anchor -> "Ancre d’Écriture non-unique : " <> (#)anchor
-                Error_Transaction_Anchor_unknown _pos anchor -> "Ancre d’Écriture inconnue : " <> (#)anchor
-                Error_Transaction_Invalid_date year month dom ->
-                       "date incorrecte (année " <> (#)year <> ", mois " <> (#)month <> ", jour " <> (#)dom <> ")"
-                Error_Transaction_Invalid_time_of_day hour minute second ->
-                       "heure incorrecte (heure " <> (#)hour <> ", minute " <> (#)minute <> ", seconde " <> (#)second <> ")"
-                Error_Transaction_The_following_transaction_is_not_equilibrated_because ->
-                       "la transaction suivante n’est pas équilibrée, car :"
-                Error_Transaction_The_following_virtual_transaction_is_not_equilibrated_because ->
-                       "la transaction virtuelle suivante n’est pas équilibrée, car :"
-                Error_Transaction_JCC_Unit_sums_up_to_the_non_null_amount unit amount ->
-                       " - l’unité " <>
-                       (if Text.null $ H.unit_text unit
-                       then "vide"
-                       else (#)unit) <>
-                       " a le solde non-nul : " <> (#)amount
-                Error_Transaction_Ledger_Unit_sums_up_to_the_non_null_amount unit amount ->
-                       " - l’unité " <>
-                       (if Text.null $ H.unit_text unit
-                       then "vide"
-                       else (#)unit) <>
-                       " a le solde non-nul : " <> (#)amount
-                Error_Transaction_Year_or_day_is_missing ->
-                       "l’année ou le jour est manquant-e"
-                Error_Unkown_command cmd -> "commande inconnue : " <> (#)cmd
-
--- * Type 'Error_Parsec'
-data Error_Parsec
- =   Error_Parsec_Expect W.Doc
- |   Error_Parsec_Message String
- |   Error_Parsec_Or
- |   Error_Parsec_Sysunexpect String
- |   Error_Parsec_Sysunexpect_EOI
- |   Error_Parsec_Unexpect W.Doc
- |   Error_Parsec_Unknown
-instance ToDoc Lang Error_Parsec where
-       toDoc EN t =
-               case t of
-                Error_Parsec_Expect doc      -> "but expect : " <> (#)doc
-                Error_Parsec_Message doc     -> (#)doc
-                Error_Parsec_Or              -> "or"
-                Error_Parsec_Sysunexpect doc -> "is written : " <> (#)doc
-                Error_Parsec_Sysunexpect_EOI -> "end of file unexpected"
-                Error_Parsec_Unexpect doc    -> "found : " <> (#)doc
-                Error_Parsec_Unknown         -> "unkown"
-       toDoc FR t =
-               case t of
-                Error_Parsec_Expect doc      -> "mais s’attend à : " <> (#)doc
-                Error_Parsec_Message doc     -> (#)doc
-                Error_Parsec_Or              -> "ou"
-                Error_Parsec_Sysunexpect doc -> "est écrit : " <> (#)doc
-                Error_Parsec_Sysunexpect_EOI -> "fin de fichier inattendue"
-                Error_Parsec_Unexpect doc    -> "trouve : " <> (#)doc
-                Error_Parsec_Unknown         -> "inconnu"
-instance Translate Parsec.SourcePos W.Doc where
-       translate EN pos = do
-               let line = Parsec.sourceLine   pos
-               let col  = Parsec.sourceColumn pos
-               case Parsec.sourceName pos of
-                ""   -> "(line " <> (#)line <> ", column " <> (#)col <> ")"
-                path -> "(line " <> (#)line <> ", column " <> (#)col <> ") in: " <> (#)path
-       translate FR pos = do
-               let line = Parsec.sourceLine   pos
-               let col  = Parsec.sourceColumn pos
-               case Parsec.sourceName pos of
-                ""   -> "(ligne " <> (#)line <> ", colonne " <> (#)col <> ")"
-                path -> "(ligne " <> (#)line <> ", colonne " <> (#)col <> ") dans : " <> (#)path
-instance Translate e W.Doc
- => Translate [Parsec.Error e] W.Doc where
-       translate lang errors =
-               W.vsep $
-               (<$> errors) $ \error ->
-                       case error of
-                        Parsec.Error_At pos errs -> W.vsep $
-                               [ translate lang pos
-                               , translate lang errs
-                               ]
-                        Parsec.Error_Parser err ->
-                               W.vsep $
-                                [ translate lang (Parsec.errorPos err)
-                                , showErrorMessages
-                                        (Parsec.Error.errorMessages err)
-                                ]
-                        Parsec.Error_Custom pos err -> W.vsep $
-                               [ translate lang pos
-                               , translate lang err
-                               ]
-               where
-                       showErrorMessages :: [Parsec.Error.Message] -> W.Doc
-                       showErrorMessages msgs
-                               | null msgs = toDoc lang $ Error_Parsec_Unknown
-                               | otherwise = W.vsep $ -- clean $
-                                       [showSysUnExpect, showUnExpect, showExpect, showMessages]
-                               where
-                                       (sysUnExpect,msgs1) = span ((Parsec.Error.SysUnExpect "") ==) msgs
-                                       (unExpect,msgs2)    = span ((Parsec.Error.UnExpect    "") ==) msgs1
-                                       (expect,messages)   = span ((Parsec.Error.Expect      "") ==) msgs2
-                                       
-                                       showExpect   = showMany (Just (toDoc lang . Error_Parsec_Expect)) expect
-                                       showUnExpect = showMany (Just (toDoc lang . Error_Parsec_Unexpect)) unExpect
-                                       showSysUnExpect
-                                        | not (null unExpect) || null sysUnExpect = W.empty
-                                        | null firstMsg = toDoc lang $ Error_Parsec_Sysunexpect_EOI
-                                        | otherwise     = toDoc lang $ Error_Parsec_Sysunexpect firstMsg
-                                               where
-                                               firstMsg = Parsec.Error.messageString (head sysUnExpect)
-                                       
-                                       showMessages = showMany Nothing messages
-                                       
-                                       -- helpers
-                                       showMany  :: (Maybe (W.Doc -> W.Doc)) -> [Parsec.Error.Message] -> W.Doc
-                                       showMany pre msgs_ =
-                                               case clean (map Parsec.Error.messageString msgs_) of
-                                                [] -> W.empty
-                                                ms ->
-                                                       case pre of
-                                                        Nothing -> commasOr ms
-                                                        Just p -> p $ commasOr ms
-                                       
-                                       commasOr :: [String] -> W.Doc
-                                       commasOr []  = W.empty
-                                       commasOr [m] = W.bold $ W.dullblack $ W.text $ TL.pack m
-                                       commasOr ms  = commaSep (init ms)
-                                                      <> (W.space <> toDoc lang Error_Parsec_Or <> W.space)
-                                                      <> W.bold (W.dullblack $ W.text $ TL.pack $ last ms)
-                                       commaSep = W.intercalate (W.comma <> W.space)
-                                                  (W.bold . W.dullblack . W.text . TL.pack)
-                                                  . clean
-                                       
-                                       clean = List.nub . filter (not . null)
-
--- * Type 'Header'
-data Header
- =   Header_Accounts
- |   Header_Accounts_Depth
- |   Header_Journals
- |   Header_Tags
- |   Header_Tags_Distinct
- |   Header_Transactions
- |   Header_Transactions_Date
- |   Header_Units
-instance Translate Header [Text] where
-       translate EN t =
-               case t of
-                Header_Accounts          -> ["Accounts"]
-                Header_Accounts_Depth    -> ["Accounts","Depth"]
-                Header_Journals          -> ["Journals"]
-                Header_Tags              -> ["Tags"]
-                Header_Tags_Distinct     -> ["Tags", "Distinct"]
-                Header_Transactions      -> ["Transactions"]
-                Header_Transactions_Date -> ["Transactions", "Date"]
-                Header_Units             -> ["Unit"]
-       translate FR t =
-               case t of
-                Header_Accounts          -> ["Comptes"]
-                Header_Accounts_Depth    -> ["Comptes","Profondeur"]
-                Header_Journals          -> ["Journaux"]
-                Header_Tags              -> ["Tags"]
-                Header_Tags_Distinct     -> ["Tags", "Distincts"]
-                Header_Transactions      -> ["Écritures"]
-                Header_Transactions_Date -> ["Écritures", "Date"]
-                Header_Units             -> ["Unités"]
-
--- * Type 'Help'
-data Help
- =   Help_Command_Balance
- |   Help_Command_General_Ledger
- |   Help_Command_Journal
- |   Help_Command_Journals
- |   Help_Command_Stats
- |   Help_Command_Tags
- |   Help_Option_Balance_Format
- |   Help_Option_Balance_Heritage
- |   Help_Option_Balance_Redundant
- |   Help_Option_Balance_Total
- |   Help_Option_Color
- |   Help_Option_Equilibrium
- |   Help_Option_Equilibrium_Credit
- |   Help_Option_Equilibrium_Debit
- |   Help_Option_Filter_Balance
- |   Help_Option_Filter_General_Ledger
- |   Help_Option_Filter_Posting
- |   Help_Option_Filter_Tag
- |   Help_Option_Filter_Transaction
- |   Help_Option_Help
- |   Help_Option_Input
- |   Help_Option_Lang
- |   Help_Option_Output
- |   Help_Option_Overwrite
- |   Help_Option_Tags_Tree
- |   Help_Option_Verbosity
- |   Help_Synopsis
-instance Translate Help String where
-       translate EN t =
-               case t of
-                Help_Command_Balance              -> "List final DEBITs, CREDITs and BALANCEs of ACCOUNTs"
-                Help_Command_General_Ledger       -> "List DEBITs, CREDITs and BALANCEs of ACCOUNTs after each TRANSACTION"
-                Help_Command_Journal              -> "List TRANSACTIONs"
-                Help_Command_Journals             -> "List JOURNAL FILEs"
-                Help_Command_Stats                -> "Show some statistics"
-                Help_Command_Tags                 -> "List TAGs"
-                Help_Option_Balance_Format        -> "Select BALANCE output format"
-                Help_Option_Balance_Heritage      -> "Propagate AMOUNTs to ascending ACCOUNTs"
-                Help_Option_Balance_Redundant     -> "Also show ACCOUNTs with null AMOUNT or the same AMOUNTs than its descending ACCOUNT"
-                Help_Option_Balance_Total         -> "Show transversal DEBIT, CREDIT, and BALANCE by UNIT"
-                Help_Option_Color                 -> "Colorize output"
-                Help_Option_Equilibrium           -> "Specify the ACCOUNT equilibrating an opening or closing BALANCE"
-                Help_Option_Equilibrium_Credit    -> "Like --eq but only when the AMOUNT is a CREDIT"
-                Help_Option_Equilibrium_Debit     -> "Like --eq but only when the AMOUNT is a DEBIT"
-                Help_Option_Filter_Balance        -> "Apply given FILTER_OF_BALANCE, multiple uses are joined with a logical AND"
-                Help_Option_Filter_General_Ledger -> "Apply given FILTER_OF_GENERAL_LEDGER, multiple uses are joined with a logical AND"
-                Help_Option_Filter_Posting        -> "Apply given FILTER_OF_POSTING, multiple uses are joined with a logical AND"
-                Help_Option_Filter_Tag            -> "Apply given FILTER_OF_TAG, multiple uses are joined with a logical AND"
-                Help_Option_Filter_Transaction    -> "Apply given FILTER_OF_TRANSACTION, multiple uses are joined with a logical AND"
-                Help_Option_Help                  -> "Show this help"
-                Help_Option_Input                 -> "Read a JOURNAL from given FILE, multiple uses merge the data"
-                Help_Option_Lang                  -> "RFC1766 / ISO 639-1 language code (fr, en-GB, etc.)"
-                Help_Option_Output                -> "Append output data to given FILE, multiple uses output to multiple FILEs"
-                Help_Option_Overwrite             -> "Overwrite given FILE with output data, multiple uses overwrite to multiple FILEs"
-                Help_Option_Tags_Tree             -> "Show TAGs as a tree"
-                Help_Option_Verbosity             -> "Set verbosity level, or increment it when used multiple times"
-                Help_Synopsis                     -> "[OPTIONS] COMMAND [COMMAND_OPTIONS]"
-       translate FR t =
-               case t of
-                Help_Command_Balance              -> "Liste les DÉBITs, CRÉDITs et SOLDEs finaux des COMPTEs"
-                Help_Command_General_Ledger       -> "Liste les DÉBITs, CRÉDITs et SOLDEs des COMPTEs après chaque ÉCRITURE"
-                Help_Command_Journal              -> "Liste les ÉCRITUREs"
-                Help_Command_Journals             -> "Liste les FICHIERs des JOURNAUX"
-                Help_Command_Stats                -> "Affiche quelques statistiques"
-                Help_Command_Tags                 -> "Liste les TAGs"
-                Help_Option_Balance_Format        -> "Sélectionne le format de BALANCE en sortie"
-                Help_Option_Balance_Heritage      -> "Propage les MONTANTs aux COMPTEs ascendants"
-                Help_Option_Balance_Redundant     -> "Affiche également les COMPTEs dont le MONTANT est nul ou qui ont les mêmes MONTANTs que leur COMPTE descendant"
-                Help_Option_Balance_Total         -> "Affiche les SOLDEs transversaux par UNITÉ"
-                Help_Option_Color                 -> "Colore la sortie"
-                Help_Option_Equilibrium           -> "Indique le COMPTE d’équilibre pour une BALANCE d’ouverture ou de fermeture"
-                Help_Option_Equilibrium_Credit    -> "Comme --eq mais seulement lorsque le MONTANT est un CRÉDIT"
-                Help_Option_Equilibrium_Debit     -> "Comme --eq mais seulement lorsque le MONTANT est un DÉBIT"
-                Help_Option_Filter_Balance        -> "Applique le FILTRE_DE_BALANCE donné, un usage multiple agit comme un ET logique"
-                Help_Option_Filter_General_Ledger -> "Applique le FILTRE_DE_GRAND_LIVRE donné, un usage multiple agit comme un ET logique"
-                Help_Option_Filter_Posting        -> "Applique le FILTRE_DE_MOUVEMENT donné, un usage multiple agit comme un ET logique"
-                Help_Option_Filter_Tag            -> "Applique le FILTRE_DE_TAG donné, un usage multiple agit comme un ET logique"
-                Help_Option_Filter_Transaction    -> "Applique le FILTRE_D’ÉCRITURE donné, un usage multiple agit comme un ET logique"
-                Help_Option_Help                  -> "Affiche cette aide"
-                Help_Option_Input                 -> "Lit un JOURNAL dans le FICHIER donné, un usage multiple fusionne les données"
-                Help_Option_Lang                  -> "Code de langue RFC1766 / ISO 639-1 language code (fr, en-GB, etc.)"
-                Help_Option_Output                -> "Ajoute la sortie au FICHIER donné, un usage multiple écrit dans plusieurs FICHIERs"
-                Help_Option_Overwrite             -> "Écrase le FICHIER donné avec la sortie, un usage multiple écrase plusieurs FICHIERs"
-                Help_Option_Tags_Tree             -> "Affiche les TAGs en arborescence"
-                Help_Option_Verbosity             -> "Indique le niveau de verbosité, ou l’incrémente lorsque utilisé plusieurs fois"
-                Help_Synopsis                     -> "[PARAMÈTRES] COMMANDE [PARAMÈTRES_DE_COMMANDE]"
-
--- * Type 'Section'
-data Section
- =   Section_Commands
- |   Section_Description
- |   Section_Syntax
- |   Section_Options
- deriving (Eq, Show)
-instance Translate Section String where
-       translate EN t =
-               case t of
-                Section_Commands    -> "COMMANDS  (use COMMAND --help for help on COMMAND)"
-                Section_Description -> "DESCRIPTION"
-                Section_Syntax      -> "SYNTAX"
-                Section_Options     -> "OPTIONS"
-       translate FR t =
-               case t of
-                Section_Commands    -> "COMMANDES  (utilisez COMMANDE --help pour une aide sur COMMANDE)"
-                Section_Description -> "DESCRIPTION"
-                Section_Syntax      -> "SYNTAXE"
-                Section_Options     -> "PARAMÈTRES"
-
--- * Type 'Title'
-data Title
- =   Title_Account
- |   Title_Balance
- |   Title_Credit
- |   Title_Date
- |   Title_Debit
- |   Title_Description
- |   Title_Running_balance
- |   Title_Running_credit
- |   Title_Running_debit
-instance Translate Title Text where
-       translate EN t =
-               case t of
-                Title_Account         -> "Account"
-                Title_Balance         -> "Balance"
-                Title_Credit          -> "Credit"
-                Title_Date            -> "Date"
-                Title_Debit           -> "Debit"
-                Title_Description     -> "Wording"
-                Title_Running_balance -> "Running balance"
-                Title_Running_credit  -> "Running credit"
-                Title_Running_debit   -> "Running debit"
-       translate FR t =
-               case t of
-                Title_Account         -> "Compte"
-                Title_Balance         -> "Solde"
-                Title_Credit          -> "Crédit"
-                Title_Date            -> "Date"
-                Title_Debit           -> "Débit"
-                Title_Description     -> "Libellé"
-                Title_Running_balance -> "Solde cumulé"
-                Title_Running_credit  -> "Crédit cumulé"
-                Title_Running_debit   -> "Débit cumulé"
-
--- * Type 'Type'
-data Type
- =   Type_Account
- |   Type_File
- |   Type_File_Journal
- |   Type_Filter_Balance
- |   Type_Filter_General_Ledger
- |   Type_Filter_Posting
- |   Type_Filter_Tag
- |   Type_Filter_Transaction
- |   Type_Option
- deriving (Eq, Show)
-instance Translate Type String where
-       translate EN t =
-               case t of
-                Type_Account               -> "ACCOUNT"
-                Type_File                  -> "FILE"
-                Type_File_Journal          -> "FILE_OF_JOURNAL"
-                Type_Filter_Balance        -> "FILTER_OF_BALANCE"
-                Type_Filter_General_Ledger -> "FILTER_OF_GENERAL_LEDGER"
-                Type_Filter_Posting        -> "FILTER_OF_POSTING"
-                Type_Filter_Tag            -> "FILTER_OF_TAG"
-                Type_Filter_Transaction    -> "FILTER_OF_TRANSACTION"
-                Type_Option                -> "OPTION"
-       translate FR t =
-               case t of
-                Type_Account               -> "COMPTE"
-                Type_File                  -> "FICHIER"
-                Type_File_Journal          -> "FICHIER_DE_JOURNAL"
-                Type_Filter_Balance        -> "FILTRE_DE_BALANCE"
-                Type_Filter_General_Ledger -> "FILTRE_DE_GRAND_LIVRE"
-                Type_Filter_Posting        -> "FILTRE_DE_MOUVEMENT"
-                Type_Filter_Tag            -> "FILTRE_DE_TAG"
-                Type_Filter_Transaction    -> "FILTRE_D’ÉCRITURE"
-                Type_Option                -> "PARAMÈTRE"
-
--- * Type 'Write'
-data Write
- =   Write_Debug
- |   Write_Error
-instance Translate Write W.Doc where
-       translate EN t =
-               case t of
-                Write_Error -> "ERROR"
-                Write_Debug -> "DEBUG"
-       translate FR t =
-               case t of
-                Write_Error -> "ERREUR"
-                Write_Debug -> "DÉBUG"
-
diff --git a/cli/Hcompta/CLI/Lib/HLint.hs b/cli/Hcompta/CLI/Lib/HLint.hs
deleted file mode 120000 (symlink)
index ab18269..0000000
+++ /dev/null
@@ -1 +0,0 @@
-../HLint.hs
\ No newline at end of file
diff --git a/cli/Hcompta/CLI/Lib/Leijen/HLint.hs b/cli/Hcompta/CLI/Lib/Leijen/HLint.hs
deleted file mode 120000 (symlink)
index ab18269..0000000
+++ /dev/null
@@ -1 +0,0 @@
-../HLint.hs
\ No newline at end of file
diff --git a/cli/Hcompta/CLI/Lib/Leijen/Table.hs b/cli/Hcompta/CLI/Lib/Leijen/Table.hs
deleted file mode 100644 (file)
index c123272..0000000
+++ /dev/null
@@ -1,148 +0,0 @@
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE Rank2Types #-}
-module Hcompta.CLI.Lib.Leijen.Table where
-
-import           Data.Bool
-import           Data.Char (Char)
-import qualified Data.Foldable as Foldable
-import qualified Data.List
-import           Data.List (map, replicate)
-import           Data.Maybe (Maybe(..), fromMaybe, maybe)
-import           Data.Monoid ((<>))
-import           Data.Ord (Ord(..))
-import           Data.Text (Text)
-import qualified Data.Text as Text
-import qualified Data.Text.Lazy as TL
-import           Prelude (($), (.), Int, Integral(..), Num(..), fromIntegral, id, zipWith)
-
-import           Text.WalderLeijen.ANSI.Text (ToDoc(..))
-import qualified Text.WalderLeijen.ANSI.Text as W
-
--- * Type 'Table'
-
-type Table = [Column]
-
--- ** Class 'Table_of'
-
-class Table_of context x where
-       table_of :: context -> x -> Table
-
--- * Type 'Column'
-
-data Column
- =   Column
- { column_title :: Text
- , column_width :: Int
- , column_align :: Align
- , column_rows  :: [Cell]
- }
-instance ToDoc () [Column] where
-       toDoc _m cols =
-               let rows = Data.List.transpose $ map column_rows cols in
-               let has_title = Foldable.any (not . Text.null . column_title) cols in
-               let titles =
-                       W.intercalate (W.bold $ W.dullblack $ W.char '|')
-                        (\col@Column{column_title} -> do
-                               let cell_width = Text.length column_title
-                               let under = W.bold $ W.dullblack $ W.char '_'
-                               let cell_content = W.enclose under under $
-                                       W.hcat $ map
-                                        (\c -> case c of { ' ' -> under; _ -> W.char c })
-                                        (Text.unpack column_title)
-                               let pad len = W.bold $ W.dullblack $
-                                       W.text $ TL.pack $ replicate len '_'
-                               align (Just pad) col
-                                Cell{cell_width, cell_content, cell_align=Just Align_Center}
-                        ) cols in
-               W.vsep (
-                       (if has_title then (:) titles else id) $
-                       map
-                        ( W.intercalate (W.space <> W.bold (W.dullblack $ W.char '|')) id
-                        . map (W.space <>)
-                        . zipWith toDoc cols
-                        ) rows
-                ) <>
-               (case cols of { [] -> W.empty; _ -> W.line })
-column :: Text -> Align -> [Cell] -> Column
-column column_title column_align column_rows =
-       Column
-        { column_title
-        , column_width = max (Text.length column_title) $
-                         Foldable.foldr (max . cell_width) 0 column_rows
-        , column_align
-        , column_rows
-        }
-
--- ** Class 'Column_of'
-
-class Column_of context x where
-       column_of :: context -> x -> Column
-
--- ** Type 'Align'
-
-data Align
- = Align_Left
- | Align_Center
- | Align_Right
-align :: Maybe (Int -> W.Doc) -> Column -> Cell -> W.Doc
-align filling
- Column{column_width, column_align}
- Cell{cell_width, cell_content, cell_align} =
-       let pad = column_width - cell_width in
-       let fill = fromMaybe (`W.fill` W.empty) filling in
-       case fromMaybe column_align cell_align of
-        Align_Left   -> cell_content <> fill pad
-        Align_Center ->
-               let half = fromInteger $ quot (toInteger pad) 2 in
-               fill half <> cell_content <> fill (pad - half)
-        Align_Right  -> fill pad <> cell_content
-align _filling
- Column{column_width}
- (Cell_Line {cell_pad}) =
-       W.bold $ W.dullblack $ W.text $
-       TL.replicate (fromIntegral column_width) $
-       TL.singleton cell_pad
-
--- * Type 'Cell'
-
-data Cell
- = Cell
-        { cell_align   :: Maybe Align
-        , cell_width   :: Int
-        , cell_content :: W.Doc
-        }
- | Cell_Line
-        { cell_pad     :: Char
-        , cell_width   :: Int
-        }
-cell :: Cell
-cell =
-       Cell
-        { cell_width   = 0
-        , cell_content = W.empty
-        , cell_align   = Nothing
-        }
-instance ToDoc Column Cell where
-       toDoc = align Nothing
-
--- ** Class 'Cell_of'
-
-class Cell_of context x where
-       cell_of :: context -> x -> Cell
-
-instance Cell_of context x => Cell_of context (Maybe x) where
-       cell_of ctx = maybe cell (cell_of ctx)
-
--- ** Class 'Cell_of_forall_param'
-
--- | A class useful when using a context of kind '*' is not wanted
---   for example in a class instance constraint
---   to keep the instance decidable (i.e. avoid UndecidableInstances).
-class Cell_of_forall_param f x where
-       cell_of_forall_param :: forall m. f m -> x -> Cell
--- instance Cell_of_forall_param f x => Cell_of (f m) x where
---     cell_of = cell_of_forall_param
-instance Cell_of_forall_param context x => Cell_of_forall_param context (Maybe x) where
-       cell_of_forall_param ctx = maybe cell (cell_of_forall_param ctx)
diff --git a/cli/Hcompta/CLI/Main.hs b/cli/Hcompta/CLI/Main.hs
deleted file mode 100644 (file)
index 9932c31..0000000
+++ /dev/null
@@ -1,29 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TupleSections #-}
-module Main (main) where
-
-import           Control.Monad (Monad(..))
-import           Data.Function ((.))
-import           Data.Monoid ((<>))
-import qualified Data.Text.Lazy as TL
-import qualified System.Environment as Env
-import           System.IO (IO)
-import qualified Text.WalderLeijen.ANSI.Text as W
-
-import qualified Hcompta.CLI.Args as Args
-import qualified Hcompta.CLI.Command as Command
-import qualified Hcompta.CLI.Context as C
-import qualified Hcompta.CLI.Lang as Lang
-import qualified Hcompta.CLI.Write as Write
-
-main :: IO ()
-main = do
-       (c, cmds) <- do
-               c <- C.context
-               Env.getArgs >>= Args.parse c Command.usage Command.options . (c,)
-       case cmds of
-        cmd:args -> Command.run c cmd args
-        [] -> Command.usage c
-               >>= Write.fatal c .
-                       ((C.translate c Lang.Error_One_command_is_required <> W.line) <>) .
-                       W.text . TL.pack
diff --git a/cli/Hcompta/CLI/Write.hs b/cli/Hcompta/CLI/Write.hs
deleted file mode 100644 (file)
index 44d73e9..0000000
+++ /dev/null
@@ -1,108 +0,0 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Hcompta.CLI.Write where
-
-import           Control.Monad (Monad(..), when)
-import           Data.Bool
-import           Data.Eq (Eq)
-import           Data.Foldable (Foldable, forM_)
-import           Data.List (concat)
-import           Data.Maybe (Maybe(..))
-import           Data.Monoid ((<>))
-import           Data.Ord (Ord(..))
-import           Data.String (String)
-import           Prelude (($), Bounded(..), IO)
-import qualified System.Console.ANSI as ANSI
-import           System.Exit (exitWith, ExitCode(..))
-import qualified System.IO as IO
-import           Text.Show (Show)
-import qualified Text.WalderLeijen.ANSI.Text as W
-
-import qualified Hcompta.CLI.Context as C
-import qualified Hcompta.CLI.Lang as Lang
-
-
-with_color :: C.Context -> IO.Handle -> IO Bool
-with_color c h =
-       case C.color c of
-        Nothing -> IO.hIsTerminalDevice h
-        Just b  -> return b
-
-debug :: C.Context -> String -> IO ()
-debug c msg =
-       case C.verbosity c of
-        v | v >= C.Verbosity_Debug -> do
-               color <- with_color c IO.stderr
-               when color $ ANSI.hSetSGR IO.stderr
-                [ANSI.SetColor ANSI.Foreground ANSI.Dull ANSI.Magenta]
-               W.hPutDoc IO.stderr $ C.translate c Lang.Write_Debug
-               when color $ ANSI.hSetSGR IO.stderr [ANSI.Reset]
-               IO.hPutStr IO.stderr $ concat [": ", msg, "\n"]
-        _ -> return ()
-
-error :: Lang.Translate msg W.Doc => C.Context -> msg -> IO ()
-error c msg =
-       case C.verbosity c of
-        v | v >= C.Verbosity_Error -> do
-               color <- with_color c IO.stderr
-               when color $ ANSI.hSetSGR IO.stderr
-                [ANSI.SetColor ANSI.Foreground ANSI.Dull ANSI.Red]
-               W.hPutDoc IO.stderr $ C.translate c Lang.Write_Error
-               when color $ ANSI.hSetSGR IO.stderr [ANSI.Reset]
-               W.hPutDoc IO.stderr $
-                       W.string ":" <> W.space <> C.translate c msg <> W.line
-        _ -> return ()
-
-fatal :: Lang.Translate msg W.Doc => C.Context -> msg -> IO a
-fatal c msg = do
-       error c msg
-       exitWith $ ExitFailure 1
-
-fatals :: Foldable f => Lang.Translate msg W.Doc => C.Context -> f msg -> IO a
-fatals c msgs = do
-       forM_ msgs $ error c
-       exitWith $ ExitFailure 1
-
-data Mode
- =   Mode_Over
- |   Mode_Append
- deriving (Eq, Show)
-data Style
- = Style
- { style_pretty :: Bool
- }
- deriving (Eq, Show)
-
-style :: Style
-style =
-       Style
-        { style_pretty = True
-        }
-
-write :: C.Context -> Style -> [(Mode, IO.FilePath)] -> W.Doc -> IO ()
-write context sty files doc = do
-       let out =
-               if style_pretty sty
-               then W.renderPretty  False 1.0 maxBound doc
-               else W.renderCompact False doc
-       let out_colored =
-               if style_pretty sty
-               then W.renderPretty  True 1.0 maxBound doc
-               else W.renderCompact True doc
-       let wrt h = do
-               color <- with_color context h
-               if color
-                then W.displayIO h out_colored
-                else W.displayIO h out
-       forM_ files $ \(mode, path) ->
-               case path of
-                "-" -> wrt IO.stdout
-                _ ->
-                       IO.withFile path
-                        (case mode of
-                                Mode_Over   -> IO.WriteMode
-                                Mode_Append -> IO.AppendMode)
-                        wrt
diff --git a/cli/Hcompta/Expr/Bool.hs b/cli/Hcompta/Expr/Bool.hs
deleted file mode 100644 (file)
index 506f78f..0000000
+++ /dev/null
@@ -1,139 +0,0 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GADTs #-}
--- {-# LANGUAGE KindSignatures #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# OPTIONS_GHC -fno-warn-tabs #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
-module Hcompta.Expr.Bool where
-
-import Data.Bool
--- import Data.Either (Either(..))
--- import Data.Function (($), (.))
--- import Data.Maybe (Maybe(..))
--- import Data.Monoid ((<>))
--- import Data.Proxy (Proxy(..))
--- import Data.String (String)
--- import Data.Type.Equality ((:~:)(Refl))
--- import Text.Show (Show(..))
-
-import Hcompta.Expr.Dup
--- import Hcompta.Expr.Fun
--- import Hcompta.Expr.Lit
-
--- * Class 'Expr_Bool'
-
--- | /Tagless-final symantics/ for usual logical boolean operators.
-class Expr_Bool repr where
-       neg :: repr Bool -> repr Bool
-       and :: repr Bool -> repr Bool -> repr Bool
-       or  :: repr Bool -> repr Bool -> repr Bool
-       xor :: repr Bool -> repr Bool -> repr Bool
-       xor x y = (x `or` y) `and` neg (x `and` y)
-
-instance -- Expr_Bool Dup
- ( Expr_Bool r1
- , Expr_Bool r2
- ) => Expr_Bool (Dup r1 r2) where
-       neg (x1 `Dup` x2)               = neg x1    `Dup` neg x2
-       and (x1 `Dup` x2) (y1 `Dup` y2) = and x1 y1 `Dup` and x2 y2
-       or  (x1 `Dup` x2) (y1 `Dup` y2) = or  x1 y1 `Dup` or  x2 y2
-
-{-
-instance -- Expr_from Tree
- ( Expr_Bool repr
- , Type_from Tree next
- , Expr_from Tree repr next (Type_Lit Bool repr next)
- ) => Expr_from Tree repr   (Type_Lit Bool repr next)
-                            (Type_Fun_Lit Bool repr next) where
-       expr_from _pty pvar ctx (Raw "And" [raw_x, raw_y]) k =
-               expr_from pvar pvar ctx raw_x $ \ty_x (x::Repr_HO repr _ctx _h_x) ->
-               expr_from pvar pvar ctx raw_y $ \ty_y (y::Repr_HO repr _ctx _h_y) ->
-                       case (ty_x, ty_y) of
-                        (  Type_Fun_Next Type_Int
-                         , Type_Fun_Next Type_Int ) ->
-                               k (Type_Fun_Next Type_Int) $ \c -> and (x c) (y c)
-                        _ -> Left "Error: And: at least one operand is not an Int"
-       expr_from _pty pvar ctx raw k =
-               expr_from (Proxy::Proxy next) pvar ctx raw k
--}
-
-{-
--- * Type 'Type_Bool'
-
--- | GADT for boolean type:
---
--- * singleton (bijective mapping between Haskell type @h@ and the GADT's terms),
--- * and extensible (through @next@).
-data Type_Bool (next:: * -> *) h where
-       Type_Bool      :: Type_Bool next Bool
-       Type_Bool_Next :: next h -> Type_Bool next h
-type Type_Fun_Lit_Bool repr next = Type_Fun repr (Type_Bool next)
-type Type_Fun_Lit_Bool_End repr  = Type_Fun_Lit_Bool repr Type_Bool_End
-
-instance -- Type_Eq
- Type_Eq next =>
- Type_Eq (Type_Bool next) where
-       type_eq Type_Bool
-               Type_Bool = Just Refl
-       type_eq (Type_Bool_Next x)
-               (Type_Bool_Next y) = x `type_eq` y
-       type_eq _ _ = Nothing
-instance -- Type_from Tree
- Type_from Tree next =>
- Type_from Tree (Type_Bool next) where
-       type_from (Tree "Bool" []) k = k Type_Bool
-       type_from raw k = type_from raw $ k . Type_Bool_Next
-instance -- From_Type String
- From_Type String next =>
- From_Type String (Type_Bool next) where
-       from_type Type_Bool = "Bool"
-       from_type (Type_Bool_Next t) = from_type t
---instance -- Show
--- From_Type String next =>
--- Show (Type_Bool next h) where
---     show = from_type
-
--- ** Type 'Type_Bool_End'
-
-data Type_Bool_End h where
-       Type_Bool_End :: Type_Bool_End ()
-
-instance -- Type_Eq
- Type_Eq Type_Bool_End where
-       type_eq Type_Bool_End
-               Type_Bool_End = Just Refl
-instance -- Type_from Tree
- Type_from Tree Type_Bool_End where
-       type_from _ k = k Type_Bool_End
-instance -- Expr_from Tree
- Show raw =>
- Expr_from raw repr Type_Bool_End (Type_Fun_Lit_Bool repr Type_Bool_End) where
-       expr_from _pty _pvar _ctx raw _k =
-               Left $ "Error: invalid: " <> show raw
-
-
-fun_lit_bool_from
- :: forall next raw repr ret.
- ( Expr_from raw repr (Type_Fun_Lit_Bool repr next) (Type_Fun_Lit_Bool repr next)
- -- , Expr_from raw repr next (Type_Fun_Lit_Bool repr next)
- , Expr_Fun repr
- , Expr_Lit repr
- , Type_from raw next
- )
- => Proxy next
- -> raw
- -> (forall h. Type_Fun_Lit_Bool repr next h -> repr h -> Either Error_Type ret)
- -> Either Error_Type ret
-fun_lit_bool_from _pty raw k =
-       expr_from
-        (Proxy::Proxy (Type_Fun_Lit_Bool repr next))
-        (Proxy::Proxy (Type_Fun_Lit_Bool repr next))
-        Context_Type_Empty raw $ \ty repr ->
-               k ty $ repr Context_Type_Empty
--}
diff --git a/cli/Hcompta/Expr/Bool/HLint.hs b/cli/Hcompta/Expr/Bool/HLint.hs
deleted file mode 120000 (symlink)
index ab18269..0000000
+++ /dev/null
@@ -1 +0,0 @@
-../HLint.hs
\ No newline at end of file
diff --git a/cli/Hcompta/Expr/Bool/Test.hs b/cli/Hcompta/Expr/Bool/Test.hs
deleted file mode 100644 (file)
index 7f9a7a1..0000000
+++ /dev/null
@@ -1,45 +0,0 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE NoMonomorphismRestriction #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
-{-# OPTIONS_GHC -fno-warn-tabs #-}
-
-module Expr.Bool.Test where
-
-import Data.Bool (Bool(..))
-import Data.Function (($))
-
-import Hcompta.Expr.Lit
-import Hcompta.Expr.Bool
-import Hcompta.Expr.Trans
-import Hcompta.Trans.Bool.Const
-import Hcompta.Repr
-
-e1 = lit True `and` lit False
-e2 = (lit True `and` lit False) `or`  (lit True `and` lit True)
-e3 = (lit True `or`  lit False) `and` (lit True `or`  lit True)
-e4 = lit True `and` neg (lit False)
-e5 = lit True `and` neg x
-e6 = x `xor` y
-e7 = (x `xor` y) `xor` z
-e8 = x `xor` (y `xor` lit True)
-
--- * Class 'Expr_Bool_Vars'
-
--- | A few boolean variables.
-class Expr_Bool_Vars repr where
-       x :: repr Bool
-       y :: repr Bool
-       z :: repr Bool
-instance -- Trans_Boo_Const
- ( Expr_Bool_Vars repr
- , Expr_Lit repr
- ) => Expr_Bool_Vars (Trans_Bool_Const repr) where
-       x = trans_lift x
-       y = trans_lift y
-       z = trans_lift z
-instance Expr_Bool_Vars Repr_Text_Write where
-       x = Repr_Text_Write $ \_p _v -> "x"
-       y = Repr_Text_Write $ \_p _v -> "y"
-       z = Repr_Text_Write $ \_p _v -> "z"
diff --git a/cli/Hcompta/Expr/Dup.hs b/cli/Hcompta/Expr/Dup.hs
deleted file mode 100644 (file)
index c693a66..0000000
+++ /dev/null
@@ -1,21 +0,0 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# OPTIONS_GHC -fno-warn-tabs #-}
-
-module Hcompta.Expr.Dup where
-
--- | Data type to duplicate an expression
--- in order to evaluate it with different interpreters.
-data Dup repr1 repr2 a
- =   Dup
- {   dup1 :: repr1 a
- ,   dup2 :: repr2 a
- }
-
-
-{-
--- * Whenever we use a value, we have to duplicate it first,
--- to leave the other copy for different interpreters
-dup_consume ev x =
-       print (ev x1) >> return x2
-       where (x1, x2) = duplicate x
--}
diff --git a/cli/Hcompta/Expr/Dup/Test.hs b/cli/Hcompta/Expr/Dup/Test.hs
deleted file mode 100644 (file)
index f7fea61..0000000
+++ /dev/null
@@ -1,20 +0,0 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE NoMonomorphismRestriction #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
-{-# OPTIONS_GHC -fno-warn-tabs #-}
-
-module Expr.Dup.Test where
-
-import Data.Bool (Bool(..))
-import Data.Function (($))
-
-import Hcompta.Expr.Lit
-import Hcompta.Expr.Bool
-import Hcompta.Expr.Fun
-
--- e1 :: (Boo repr, Lit repr) => repr Bool
-e1 = lit True `and` neg (lit True `and` lit True)
-e2 = let_val (lit True) $ \x -> lit True `and` x
-
diff --git a/cli/Hcompta/Expr/Eq.hs b/cli/Hcompta/Expr/Eq.hs
deleted file mode 100644 (file)
index 8ed0d2f..0000000
+++ /dev/null
@@ -1,17 +0,0 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# OPTIONS_GHC -fno-warn-tabs #-}
-
-module Hcompta.Expr.Eq where
-
-import Data.Bool
-import Data.Eq (Eq(..))
-
-import Hcompta.Expr.Dup
-
--- * Class 'Expr_Eq'
-
-class Expr_Eq repr where
-       eq :: Eq a => repr a -> repr a -> repr Bool
-
-instance (Expr_Eq r1, Expr_Eq r2) => Expr_Eq (Dup r1 r2) where
-       eq (x1 `Dup` x2) (y1 `Dup` y2) = eq x1 y1 `Dup` eq x2 y2
diff --git a/cli/Hcompta/Expr/Fun.hs b/cli/Hcompta/Expr/Fun.hs
deleted file mode 100644 (file)
index 5185b55..0000000
+++ /dev/null
@@ -1,128 +0,0 @@
-{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE NoImplicitPrelude #-}
--- {-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# OPTIONS_GHC -fno-warn-tabs #-}
-module Hcompta.Expr.Fun where
-
-import Control.Monad (Monad(..))
-import Control.Monad.IO.Class (MonadIO(..))
-import Data.Bool
--- import Data.Either (Either(..))
--- import Data.Eq (Eq(..))
-import Data.Function (($), (.), id)
-import Data.IORef
--- import Data.Maybe (Maybe(..))
--- import Data.Monoid ((<>))
--- import Data.Proxy (Proxy(..))
--- import Data.String (String)
--- import Data.Type.Equality ((:~:)(Refl))
--- import Text.Show (Show(..))
-
-import Hcompta.Expr.Dup
-
--- * Class 'Expr_Fun'
-
--- | /Tagless-final symantics/ for /lambda abstraction/
--- in /higher-order abstract syntax/ (HOAS),
--- and with argument @arg@ and result @res@ of functions @(->)@ inside 'repr',
--- wrapped into 'repr': to control the calling.
-class Expr_Fun repr where
-       default app        :: Monad   repr => repr (repr arg -> repr res) ->       repr arg -> repr res
-       
-       default inline     :: Monad   repr =>      (repr arg -> repr res) -> repr (repr arg -> repr res)
-       default val        :: Monad   repr =>      (repr arg -> repr res) -> repr (repr arg -> repr res)
-       default lazy       :: MonadIO repr =>      (repr arg -> repr res) -> repr (repr arg -> repr res)
-       
-       default let_inline :: Monad   repr => repr arg -> (repr arg -> repr res) -> repr res
-       default let_val    :: Monad   repr => repr arg -> (repr arg -> repr res) -> repr res
-       default let_lazy   :: MonadIO repr => repr arg -> (repr arg -> repr res) -> repr res
-       
-       app :: repr (repr arg -> repr res) -> repr arg -> repr res
-       app x y = x >>= ($ y)
-       
-       -- | /call-by-name/ lambda
-       inline :: (repr arg -> repr res) -> repr (repr arg -> repr res)
-       inline = return
-       -- | /call-by-value/ lambda
-       val :: (repr arg -> repr res) -> repr (repr arg -> repr res)
-       val f = return (>>= f . return)
-       -- | /call-by-need/ lambda (aka. /lazyness/): lazy shares its argument, no matter what.
-       lazy :: (repr arg -> repr res) -> repr (repr arg -> repr res)
-       lazy f = return ((>>= f) . expr_fun_lazy_share)
-       
-       -- | Convenient 'inline' wrapper.
-       let_inline :: repr arg -> (repr arg -> repr res) -> repr res
-       let_inline x y = inline y `app` x
-       -- | Convenient 'val' wrapper.
-       let_val :: repr arg -> (repr arg -> repr res) -> repr res
-       let_val x y = val y `app` x
-       -- | Convenient 'lazy' wrapper.
-       let_lazy :: repr arg -> (repr arg -> repr res) -> repr res
-       let_lazy x y = lazy y `app` x
-       
-       ident :: repr a -> repr a
-       ident = id
-
--- | Utility for storing arguments of 'lazy' into an 'IORef'.
-expr_fun_lazy_share :: MonadIO m => m a -> m (m a)
-expr_fun_lazy_share m = do
-       r <- liftIO $ newIORef (False, m)
-       return $ do
-               (already_evaluated, m') <- liftIO $ readIORef r
-               if already_evaluated
-                       then m'
-                       else do
-                               v <- m'
-                               liftIO $ writeIORef r (True, return v)
-                               return v
-
-instance -- Expr_Fun Dup
- ( Expr_Fun r1
- , Expr_Fun r2
- , Monad r1
- , Monad r2
- ) => Expr_Fun (Dup r1 r2) where
-       app (r1_f `Dup` r2_f) (x1 `Dup` x2) =
-               app (return $ \r1_a -> do
-                       f <- r1_f
-                       a <- r1_a
-                       dup1 $ f (r1_a `Dup` return a)) x1
-               `Dup`
-               app (return $ \r2_a -> do
-                       f <- r2_f
-                       a <- r2_a
-                       dup2 $ f (return a `Dup` r2_a)) x2
-       inline f = dup1 (inline f) `Dup` dup2 (inline f)
-       val    f = dup1 (val f)    `Dup` dup2 (val f)
-       lazy   f = dup1 (lazy f)   `Dup` dup2 (lazy f)
-       let_inline (x1 `Dup` x2) in_ =
-               let_inline x1 (\r1_a -> do
-                       a <- r1_a
-                       dup1 $ in_ $ r1_a `Dup` return a)
-               `Dup`
-               let_inline x2 (\r2_a -> do
-                       a <- r2_a
-                       dup2 $ in_ $ return a `Dup` r2_a)
-       let_val (x1 `Dup` x2) in_ =
-               let_val x1 (\r1_a -> do
-                       a <- r1_a
-                       dup1 $ in_ $ r1_a `Dup` return a)
-               `Dup`
-               let_val x2 (\r2_a -> do
-                       a <- r2_a
-                       dup2 $ in_ $ return a `Dup` r2_a)
-       let_lazy (x1 `Dup` x2) in_ =
-               let_lazy x1 (\r1_a -> do
-                       a <- r1_a
-                       dup1 $ in_ $ r1_a `Dup` return a)
-               `Dup`
-               let_lazy x2 (\r2_a -> do
-                       a <- r2_a
-                       dup2 $ in_ $ return a `Dup` r2_a)
diff --git a/cli/Hcompta/Expr/Fun/HLint.hs b/cli/Hcompta/Expr/Fun/HLint.hs
deleted file mode 120000 (symlink)
index ab18269..0000000
+++ /dev/null
@@ -1 +0,0 @@
-../HLint.hs
\ No newline at end of file
diff --git a/cli/Hcompta/Expr/Fun/Test.hs b/cli/Hcompta/Expr/Fun/Test.hs
deleted file mode 100644 (file)
index e17948b..0000000
+++ /dev/null
@@ -1,23 +0,0 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE NoMonomorphismRestriction #-}
-{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
-{-# OPTIONS_GHC -fno-warn-tabs #-}
-
-module Expr.Fun.Test where
-
-import Data.Bool (Bool(..))
-import Data.Function (($), id)
-
-import Hcompta.Expr.Lit
-import Hcompta.Expr.Bool
-import Hcompta.Expr.Fun
-
-e1 = val $ \x -> val $ \y -> (x `or` y) `and` neg (x `and` y)
-e2 = val $ \x -> val $ \y -> (x `and` neg y) `or` (neg x `and` y)
-e3 = let_val (lit True) $ \x -> x `and` x
-e4 = let_val (val $ \x -> x `and` x) $ \f -> f `app` lit True
-e5 = val $ \x0 -> val $ \x1 -> x0 `and` x1
-e6 = let_val (lit True) id `and` lit False
-e7 = val $ \f -> and (f `app` lit True) (lit False)
-e8 = val $ \f -> f `app` and (lit True) (lit False)
diff --git a/cli/Hcompta/Expr/HLint.hs b/cli/Hcompta/Expr/HLint.hs
deleted file mode 120000 (symlink)
index ab18269..0000000
+++ /dev/null
@@ -1 +0,0 @@
-../HLint.hs
\ No newline at end of file
diff --git a/cli/Hcompta/Expr/If.hs b/cli/Hcompta/Expr/If.hs
deleted file mode 100644 (file)
index 4d3b9e0..0000000
+++ /dev/null
@@ -1,37 +0,0 @@
-{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# OPTIONS_GHC -fno-warn-tabs #-}
-
-module Hcompta.Expr.If where
-
-import Control.Monad (Monad(..), when)
-import Data.Bool
-
-import Hcompta.Expr.Dup
-
--- * Class 'Expr_If'
-
-class Expr_If repr where
-       default if_   :: Monad repr => repr Bool -> repr a -> repr a -> repr a
-       default when_ :: Monad repr => repr Bool -> repr () -> repr ()
-       
-       if_ :: repr Bool -> repr a -> repr a -> repr a
-       if_ m ok ko = do
-               m' <- m
-               if m' then ok else ko
-       
-       when_ :: repr Bool -> repr () -> repr ()
-       when_ m ok = do
-               m' <- m
-               when m' ok
-
-instance -- Expr_If Dup
- ( Expr_If r1
- , Expr_If r2
- ) => Expr_If (Dup r1 r2) where
-       if_ (c1 `Dup` c2) (ok1 `Dup` ok2) (ko1 `Dup` ko2) =
-               if_ c1 ok1 ko1 `Dup`
-               if_ c2 ok2 ko2
-       when_ (c1 `Dup` c2) (ok1 `Dup` ok2) =
-               when_ c1 ok1 `Dup`
-               when_ c2 ok2
diff --git a/cli/Hcompta/Expr/If/HLint.hs b/cli/Hcompta/Expr/If/HLint.hs
deleted file mode 120000 (symlink)
index ab18269..0000000
+++ /dev/null
@@ -1 +0,0 @@
-../HLint.hs
\ No newline at end of file
diff --git a/cli/Hcompta/Expr/If/Test.hs b/cli/Hcompta/Expr/If/Test.hs
deleted file mode 100644 (file)
index 7a8a734..0000000
+++ /dev/null
@@ -1,16 +0,0 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE NoMonomorphismRestriction #-}
-{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
-{-# OPTIONS_GHC -fno-warn-tabs #-}
-
-module Expr.If.Test where
-
-import Data.Bool (Bool(..))
-
-import Hcompta.Expr.Lit
-import Hcompta.Expr.Bool
-import Hcompta.Expr.If
-
-e1 = if_ (lit True) (lit False) (lit True)
-e2 = if_ (lit True `and` lit True) (lit False) (lit True)
diff --git a/cli/Hcompta/Expr/Lit.hs b/cli/Hcompta/Expr/Lit.hs
deleted file mode 100644 (file)
index f64c80d..0000000
+++ /dev/null
@@ -1,193 +0,0 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# OPTIONS_GHC -fno-warn-tabs #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Hcompta.Expr.Lit where
-
--- import Control.Applicative (Applicative(..))
--- import Control.Monad (Monad(..))
--- import Control.Monad.Trans.State.Strict as ST
--- import Data.Bool
--- import Data.Either (Either(..))
--- import Data.Eq (Eq(..))
--- import Data.Function (($), (.))
--- import Data.Functor (Functor(..))
--- import Data.Maybe (Maybe(..))
--- import Data.Monoid ((<>))
--- import Data.Proxy (Proxy(..))
--- import Data.String (IsString(..))
--- import Data.Text (Text)
--- import qualified Data.Text as Text
-import Data.Text.Buildable (Buildable(..))
--- import Data.Type.Equality ((:~:)(Refl))
--- import GHC.Exts (IsList(..))
--- import Prelude (undefined)
--- import Text.Read (Read, reads)
-import Text.Show (Show(..))
-
--- import Hcompta.Lib.Control.Monad
--- import qualified Hcompta.Lib.Control.Monad.Classes as MC
--- import qualified Hcompta.Lib.Data.Text.Buildable as Build
-
-import Hcompta.Expr.Dup
--- import Hcompta.Expr.Fun
-
--- * Class 'Expr_Lit'
-
--- | /Tagless-final symantics/ to inject a meta-level term
--- into and object-level expression.
-class Expr_Lit repr where
-       lit :: (Buildable a, Show a) => a -> repr a
-
-instance -- Expr_Lit Dup
- ( Expr_Lit r1
- , Expr_Lit r2
- ) => Expr_Lit (Dup r1 r2) where
-       lit x = lit x `Dup` lit x
-
-{-
--- * Type 'Type_Lit'
-
--- | GADT for boolean type:
---
--- * singleton (bijective mapping between Haskell type @h@ and the GADT's terms),
--- * and extensible (through @next@).
-data Type_Lit lit (next:: * -> *) h where
-       Type_Lit      :: Type_Lit lit next lit
-       Type_Lit_Next :: next h -> Type_Lit lit next h
-type Type_Fun_Lit lit repr next = Type_Fun repr (Type_Lit lit next)
-type Type_Fun_Lit_End lit repr = Type_Fun_Lit lit repr Type_Lit_End
-
-instance -- Type_Eq
- Type_Eq next =>
- Type_Eq (Type_Lit lit next) where
-       type_eq Type_Lit
-               Type_Lit = Just Refl
-       type_eq (Type_Lit_Next x)
-               (Type_Lit_Next y) = x `type_eq` y
-       type_eq _ _ = Nothing
-instance -- Type_from Tree
- ( Type_from Tree next
- , Buildable (Type_Lit_Name lit)
- ) => Type_from Tree (Type_Lit lit next) where
-       type_from (Tree raw_lit []) k
-        | raw_lit == Build.text (Type_Lit_Name::Type_Lit_Name lit)
-        = k Type_Lit
-       type_from raw k = type_from raw $ k . Type_Lit_Next
-instance -- From_Type Text
- ( From_Type Text next
- , Buildable (Type_Lit_Name lit)
- ) => From_Type Text (Type_Lit lit next) where
-       from_type Type_Lit = Build.text (Type_Lit_Name::Type_Lit_Name lit)
-       from_type (Type_Lit_Next t) = from_type t
-instance -- Expr_from Tree
- ( Expr_Lit repr
- , Type_from Tree next
- , Expr_from Tree repr next (Type_Fun_Lit lit repr next)
- , Read lit
- , Show lit
- , Buildable lit
- , Buildable (Type_Lit_Name lit)
- ) => Expr_from Tree repr (Type_Lit lit next) (Type_Fun_Lit lit repr next) where
-       expr_from _pty _pvar _ctx (Tree lit_name [Tree raw_lit []]) k
-        | lit_name == Build.text (Type_Lit_Name::Type_Lit_Name lit) = do
-               l <- repr_lit_read raw_lit
-               k (Type_Fun_Next Type_Lit) $ \_c -> lit l
-       expr_from _pty pvar ctx raw k =
-               expr_from (Proxy::Proxy next) pvar ctx raw k
-
-repr_lit_read :: Read a => Text -> Either Error_Type a
-repr_lit_read t =
-       let s = Text.unpack t in
-       case reads s of
-        [(a, "")] -> Right a
-        _         -> Left $ "Read error: " <> s
-
-instance Monad m => Expr_Lit (ST.StateT s m) where
-       lit = return
-instance Monad m => Expr_Lit (MC.WriterT w m) where
-       lit = return
-
--- * Type 'Type_Lit_Name'
-
--- | Data type to get a name from a Haskell type-level literal type.
-data Type_Lit_Name lit = Type_Lit_Name
-instance Buildable (Type_Lit_Name Bool) where
-       build _ = "Bool"
-
--- * Type 'Type_Lit_End'
-
--- | Data type to finalize a type at 'Type_Fun_Lit'.
-data Type_Lit_End h where
-       Type_Lit_End :: Type_Lit_End ()
-
-instance -- Type_Eq
- Type_Eq Type_Lit_End where
-       type_eq Type_Lit_End
-               Type_Lit_End = Just Refl
-instance -- Type_from Tree
- Type_from Tree Type_Lit_End where
-       type_from _ k = k Type_Lit_End
-instance -- Expr_from Tree
- Buildable (Type_Lit_Name lit)
- => Expr_from Tree repr Type_Lit_End (Type_Fun_Lit lit repr Type_Lit_End) where
-       expr_from _pty _pvar _ctx raw _k =
-               Left $ "Error: invalid Type_Lit: "
-                <> Build.string (Type_Lit_Name::Type_Lit_Name lit) <> ": "
-                <> show raw
--}
-
-{-
-class Literal from to where
-       literal :: from -> to
-instance Applicative repr => Literal a (repr a) where
-       literal = pure
-instance (Applicative repr, IsString a) => Literal String (repr a) where
-       literal = pure . fromString
-instance (Applicative repr, IsString a) => Literal [String] (repr [a]) where
-       literal = pure . (fromString <$>)
-instance Applicative repr => Literal [a] (repr [a]) where
-       literal = pure
-instance Monad repr => Literal [repr a] (repr [a]) where
-       literal = sequence
-instance Literal a a where
-       literal a = a
--}
-
-{-
--- * Class 'List'
-class Monad repr => List repr where
-       list :: [repr a] -> repr [a]
-       list = sequence
-instance Monad m => List (ST.StateT s m)
-instance Monad m => List (WriterT w m)
-
-instance (Monad m, Monad (repr m)) => List (repr (m:: * -> *)) where
-       list = sequence
--}
--- instance IsList ([a])
-
-{-
--- Orphan instances for overloading
-instance (IsList a, List (repr m)) => IsList (repr (m:: * -> *) [a]) where
-       type Item (repr m [a]) = repr m a
-       fromList = list
-       toList = undefined
--}
-
-
-{- NOTE: conflicts with specific instance in Data.DList
-instance (IsList a, List repr) => IsList (repr [a]) where
-       type Item (repr [a]) = repr a
-       fromList = list
-       toList = undefined
--}
-{-
-instance (Monad repr, IsString a) => IsString (repr a) where
-       fromString = return . fromString
--}
diff --git a/cli/Hcompta/Expr/Log.hs b/cli/Hcompta/Expr/Log.hs
deleted file mode 100644 (file)
index 74adc0c..0000000
+++ /dev/null
@@ -1,101 +0,0 @@
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-{-# OPTIONS_GHC -fno-warn-tabs #-}
-module Hcompta.Expr.Log where
-
-import Control.Applicative (Applicative(..))
-import Control.Monad (Monad(..))
-import Control.Monad.Catch (MonadThrow(..), MonadCatch(..), MonadMask(..))
-import qualified Control.Monad.Classes as MC
-import qualified Control.Monad.Classes.Proxied as MC
-import qualified Control.Monad.Classes.Run as MC
-import Control.Monad.IO.Class (MonadIO(..))
-import Data.Function (($), (.))
-import Data.Functor (Functor(..))
-import Data.Int (Int)
-import Data.Monoid ((<>))
-import Data.Ord (Ord(..))
-import Data.String (IsString(..))
-import Data.Text (Text)
-import Data.Text.Buildable (Buildable(..))
-import qualified Data.Time.LocalTime as Time
-import Prelude (truncate)
-
-import Hcompta.Lib.Data.Monoid (Monoid1)
-
--- * Type 'Log'
-
-data Log a
- =   Log
- {   log_time     :: Time.ZonedTime
- ,   log_facility :: Log_Facility
- ,   log_data     :: a
- } deriving (Functor)
-instance Buildable x => Buildable (Log x) where
-       build Log{..} =
-               let Time.TimeOfDay h m s =
-                       Time.localTimeOfDay $
-                       Time.zonedTimeToLocalTime log_time in
-               "[" <> int2 h <>
-               ":" <> int2 m <>
-               ":" <> int2 (truncate s::Int) <>
-               "] " <>
-               build log_facility <> ": " <>
-               build log_data
-               where
-                       int2 i = (if i < 10 then "0" else "") <> build i
-
--- ** Type 'Log_Facility'
-data Log_Facility
- =   Debug
- |   Info
- |   Warn
-instance Buildable Log_Facility where
-       build Debug = "debug"
-       build Info  = "info"
-       build Warn  = "warn"
-
-log ::
- ( MC.MonadWriter (Log a) m
- , MonadIO m
- ) => Log_Facility -> a -> m ()
-log log_facility log_data = do
-       log_time <- liftIO Time.getZonedTime
-       MC.tell Log
-        { log_time
-        , log_facility
-        , log_data
-        }
-
--- * Type 'LogT'
-
--- | A 'Monad' transformer to handle different log data types,
--- eventually embedded (through class instances) into a single data type
--- put in the 'Monad' stack with 'MC.MonadWriter'.
-newtype LogT w m a = LogT (MC.CustomWriterT' (Log w) m m a)
- deriving
- ( Functor, Applicative, Monoid1
- , Monad, MonadIO, MonadThrow, MonadCatch, MonadMask)
-
-evalLogWith
- :: forall w m a . (Log w -> m ())
- -> LogT w m a
- -> m a
-evalLogWith tellFn a =
-       MC.reify tellFn $ \px ->
-               case a of
-                LogT (MC.CustomWriterT (MC.Proxied a')) -> a' px
-
--- ** Type 'Log_Message'
-
-newtype Log_Message = Log_Message Text
-instance Buildable Log_Message where
-       build (Log_Message x) = build x
-instance IsString Log_Message where
-       fromString = Log_Message . fromString
diff --git a/cli/Hcompta/Expr/Maybe.hs b/cli/Hcompta/Expr/Maybe.hs
deleted file mode 100644 (file)
index 51c8191..0000000
+++ /dev/null
@@ -1,66 +0,0 @@
-{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# OPTIONS_GHC -fno-warn-tabs #-}
-
-module Hcompta.Expr.Maybe where
-
-import Data.Maybe (Maybe(..))
-import Control.Monad (Monad(..))
-import Data.Function (($))
-
-import Hcompta.Expr.Dup
-
--- * Class 'Expr_Maybe'
-
-class Expr_Maybe repr where
-       default may
-        :: Monad repr
-        => repr (Maybe a)
-        -> repr b
-        -> repr ((->) (repr a) (repr b))
-        -> repr b
-       default nothing
-        :: Monad repr
-        => repr (Maybe a)
-       default just
-        :: Monad repr
-        => repr a
-        -> repr (Maybe a)
-       
-       may
-        :: repr (Maybe a)
-        -> repr b
-        -> repr ((->) (repr a) (repr b))
-        -> repr b
-       may r_m r_n r_j = do
-               m <- r_m
-               case m of
-                Nothing -> r_n
-                Just x -> do
-                       j <- r_j
-                       j (return x)
-       nothing :: repr (Maybe a)
-       nothing = return Nothing
-       just :: repr a -> repr (Maybe a)
-       just r_a = do
-               a <- r_a
-               return $ Just a
-
-instance -- Expr_Maybe Dup
- ( Expr_Maybe r1
- , Expr_Maybe r2
- , Monad r1
- , Monad r2
- ) => Expr_Maybe (Dup r1 r2) where
-       may (m1 `Dup` m2) (n1 `Dup` n2) (r1_j `Dup` r2_j) =
-               may m1 n1 (return $ \r1_a -> do
-                       j <- r1_j
-                       a <- r1_a
-                       dup1 $ j $ r1_a `Dup` return a)
-               `Dup`
-               may m2 n2 (return $ \r2_a -> do
-                       j <- r2_j
-                       a <- r2_a
-                       dup2 $ j $ return a `Dup` r2_a)
-       nothing = nothing `Dup` nothing
-       just (a1 `Dup` a2) = just (a1 `Dup` a2)
diff --git a/cli/Hcompta/Expr/Ord.hs b/cli/Hcompta/Expr/Ord.hs
deleted file mode 100644 (file)
index f59baf1..0000000
+++ /dev/null
@@ -1,37 +0,0 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# OPTIONS_GHC -fno-warn-tabs #-}
-
-module Hcompta.Expr.Ord where
-
-import Data.Bool
-import Data.Ord (Ord(..))
-
-import Hcompta.Expr.Bool
-import Hcompta.Expr.Eq
-import Hcompta.Expr.Dup
-
--- * Class 'Expr_Ord'
-
-class
- ( Expr_Bool repr
- , Expr_Eq repr
- ) => Expr_Ord repr where
-       lt :: Ord a => repr a -> repr a -> repr Bool
-       
-       le :: Ord a => repr a -> repr a -> repr Bool
-       le x y = (x `lt` y) `or` (x `eq` y)
-       
-       ge :: Ord a => repr a -> repr a -> repr Bool
-       ge x y = neg (x `lt` y)
-       
-       gt :: Ord a => repr a -> repr a -> repr Bool
-       gt x y = neg (x `le` y)
-
-instance -- Expr_Ord Dup
- ( Expr_Ord r1
- , Expr_Ord r2
- ) => Expr_Ord (Dup r1 r2) where
-       lt (x1 `Dup` x2) (y1 `Dup` y2) = lt x1 y1 `Dup` lt x2 y2
-       le (x1 `Dup` x2) (y1 `Dup` y2) = le x1 y1 `Dup` le x2 y2
-       ge (x1 `Dup` x2) (y1 `Dup` y2) = ge x1 y1 `Dup` ge x2 y2
-       gt (x1 `Dup` x2) (y1 `Dup` y2) = gt x1 y1 `Dup` gt x2 y2
diff --git a/cli/Hcompta/Expr/Set.hs b/cli/Hcompta/Expr/Set.hs
deleted file mode 100644 (file)
index 599e5b8..0000000
+++ /dev/null
@@ -1,21 +0,0 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# OPTIONS_GHC -fno-warn-tabs #-}
-
-module Hcompta.Expr.Set where
-
-import Hcompta.Expr.Dup
-
--- * Class 'Expr_Set'
-
-class Expr_Set repr where
-       complement   :: repr a -> repr a
-       intersection :: repr a -> repr a -> repr a
-       union        :: repr a -> repr a -> repr a
-
-instance -- Expr_Set Dup
- ( Expr_Set r1
- , Expr_Set r2
- ) => Expr_Set (Dup r1 r2) where
-       complement (x1 `Dup` x2) = complement x1 `Dup` complement x2
-       intersection (x1 `Dup` x2) (y1 `Dup` y2) = intersection x1 y1 `Dup` intersection x2 y2
-       union  (x1 `Dup` x2) (y1 `Dup` y2) = union  x1 y1 `Dup` union  x2 y2
diff --git a/cli/Hcompta/Expr/Trans.hs b/cli/Hcompta/Expr/Trans.hs
deleted file mode 100644 (file)
index cb76c7a..0000000
+++ /dev/null
@@ -1,24 +0,0 @@
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-
-module Hcompta.Expr.Trans where
-
-import Data.Function ((.))
-
--- |
--- * 'trans_lift' is generally not /surjective/
--- * 'trans_apply' is not /injective/
--- * 'trans_apply' . 'trans_lift' == 'id'
--- * 'trans_lift' . 'trans_apply' /= 'id'
-class Trans trans repr where
-       trans_lift  :: repr a -> trans repr a
-       trans_apply :: trans repr a -> repr a
-       
-       trans_map1 :: (repr a -> repr b) -> (trans repr a -> trans repr b)
-       trans_map1 f = trans_lift . f . trans_apply
-       
-       trans_map2
-        :: (repr a -> repr b -> repr c)
-        -> (trans repr a -> trans repr b -> trans repr c)
-       trans_map2 f e1 e2 = trans_lift (f (trans_apply e1) (trans_apply e2))
diff --git a/cli/Hcompta/HLint.hs b/cli/Hcompta/HLint.hs
deleted file mode 120000 (symlink)
index ab18269..0000000
+++ /dev/null
@@ -1 +0,0 @@
-../HLint.hs
\ No newline at end of file
diff --git a/cli/Hcompta/Lib/Control/HLint.hs b/cli/Hcompta/Lib/Control/HLint.hs
deleted file mode 120000 (symlink)
index ab18269..0000000
+++ /dev/null
@@ -1 +0,0 @@
-../HLint.hs
\ No newline at end of file
diff --git a/cli/Hcompta/Lib/Control/Monad.hs b/cli/Hcompta/Lib/Control/Monad.hs
deleted file mode 100644 (file)
index f987dd5..0000000
+++ /dev/null
@@ -1,41 +0,0 @@
-{-# OPTIONS_GHC -fno-warn-tabs #-}
-module Hcompta.Lib.Control.Monad where
-
-import Control.Applicative (Applicative(..))
-import Control.Monad (Monad(..), (=<<), liftM2, liftM3, liftM4, join)
-import Data.Bool
-import Data.Maybe (Maybe(..), maybe)
-
--- * 'Monad'ic utilities
-
--- | Perform some operation on 'Just', given the field inside the 'Just'.
-whenJust :: Applicative m => Maybe a -> (a -> m ()) -> m ()
-whenJust mg f = maybe (pure ()) f mg
-
--- | Like 'when', but where the test can be 'Monad'-ic.
-whenM :: Monad m => m Bool -> m () -> m ()
-whenM b t = ifM b t (return ())
-
--- | Like 'unless', but where the test can be 'Monad'-ic.
-unlessM :: Monad m => m Bool -> m () -> m ()
-unlessM b = ifM b (return ())
-
--- | Like @if@, but where the test can be 'Monad'-ic.
-ifM :: Monad m => m Bool -> m a -> m a -> m a
-ifM b t f = do b' <- b; if b' then t else f
-
--- | Like 'liftM' but 'join' the result of the lifted function.
-liftMJoin :: Monad m => (a -> m b) -> m a -> m b
-liftMJoin = (=<<)
-
--- | Like 'liftM2' but 'join' the result of the lifted function.
-liftM2Join :: Monad m => (a -> b -> m c) -> m a -> m b -> m c
-liftM2Join f ma mb = join (liftM2 f ma mb)
-
--- | Like 'liftM3' but 'join' the result of the lifted function.
-liftM3Join :: Monad m => (a -> b -> c -> m d) -> m a -> m b -> m c -> m d
-liftM3Join f ma mb mc = join (liftM3 f ma mb mc)
-
--- | Like 'liftM3' but 'join' the result of the lifted function.
-liftM4Join :: Monad m => (a -> b -> c -> d -> m e) -> m a -> m b -> m c -> m d -> m e
-liftM4Join f ma mb mc md = join (liftM4 f ma mb mc md)
diff --git a/cli/Hcompta/Lib/Control/Monad/Classes.hs b/cli/Hcompta/Lib/Control/Monad/Classes.hs
deleted file mode 100644 (file)
index 657c10c..0000000
+++ /dev/null
@@ -1,49 +0,0 @@
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# OPTIONS_GHC -fno-warn-tabs #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Hcompta.Lib.Control.Monad.Classes where
-
-import Control.Monad (Monad(..))
-import Control.Monad.Catch (MonadThrow(..), MonadCatch(..), MonadMask(..))
-import qualified Control.Monad.Classes.Proxied as MC
-import qualified Control.Monad.Classes.Run as MC
-import Data.Function (($))
-
--- * Type @Control.Monad.Classes.Writer.@'CustromWriterT' (orphan instances)
-
--- | Type synonym to @Control.Monad.Classes.Writer.@'MC.CustomWriterT'', /eta-reduced/.
-type WriterT w m = MC.CustomWriterT' w m m
-deriving instance (Monad m, MonadThrow m) => MonadThrow (WriterT w m)
-deriving instance (Monad m, MonadCatch m) => MonadCatch (WriterT w m)
-deriving instance (Monad m, MonadMask  m) => MonadMask  (WriterT w m)
-
--- * Type @Control.Monad.Classes.Proxied.@'MC.Proxied' (orphan instances)
-
-instance MonadThrow m => MonadThrow (MC.Proxied x m) where
-       -- throwM :: Exception e => e -> m a
-       throwM e = MC.Proxied (\_px -> throwM e)
-
-instance MonadCatch m => MonadCatch (MC.Proxied x m) where
-       -- catch :: Exception e => m a -> (e -> m a) -> m a
-       catch (MC.Proxied f) h =
-               MC.Proxied $ \px ->
-                       f px `catch` \e ->
-                               case h e of
-                                MC.Proxied f' -> f' px
-
--- newtype Proxied x m a = Proxied (forall (q :: *). R.Reifies q x => Proxy# q -> m a)
-instance (MonadCatch m, MonadMask m) => MonadMask (MC.Proxied x m) where
-       -- mask :: MonadMask m => ((forall a. m a -> m a) -> m b) -> m b
-       mask restore =
-               MC.Proxied $ \px ->
-                       mask $ \r ->
-                               case restore (\(MC.Proxied f) -> MC.Proxied $ \px' -> r (f px')) of
-                                MC.Proxied f -> f px
-       -- uninterruptibleMask :: ((forall a. IO a -> IO a) -> IO b) -> IO b
-       uninterruptibleMask restore =
-               MC.Proxied $ \px ->
-                       uninterruptibleMask $ \r ->
-                               case restore (\(MC.Proxied f) -> MC.Proxied $ \px' -> r (f px')) of
-                                MC.Proxied f -> f px
diff --git a/cli/Hcompta/Lib/Data/Default.hs b/cli/Hcompta/Lib/Data/Default.hs
deleted file mode 100644 (file)
index 7b3b11b..0000000
+++ /dev/null
@@ -1,7 +0,0 @@
-{-# OPTIONS_GHC -fno-warn-tabs #-}
-module Hcompta.Lib.Data.Default where
-
--- * Class 'Default'
-
-class Default a where
-       def :: a
diff --git a/cli/Hcompta/Lib/Data/HLint.hs b/cli/Hcompta/Lib/Data/HLint.hs
deleted file mode 120000 (symlink)
index ab18269..0000000
+++ /dev/null
@@ -1 +0,0 @@
-../HLint.hs
\ No newline at end of file
diff --git a/cli/Hcompta/Lib/Data/Monoid.hs b/cli/Hcompta/Lib/Data/Monoid.hs
deleted file mode 100644 (file)
index f03aa2f..0000000
+++ /dev/null
@@ -1,36 +0,0 @@
-{-# LANGUAGE FlexibleInstances #-}
-{-# OPTIONS_GHC -fno-warn-tabs #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Hcompta.Lib.Data.Monoid where
-
-import Control.Monad (Monad(..), liftM2)
-import Control.Monad.Trans.State.Strict as ST
-import Data.Monoid (Monoid(..))
-import qualified Hcompta.Lib.Control.Monad.Classes as MC
-import System.IO (IO)
-
--- * Class 'Monoid1' (contain orphan instances)
-
--- | 'Monoid' lifted to unary type constructor.
-class Monoid1 expr where
-       mempty1  :: Monoid a => expr a
-       mappend1 :: Monoid a => expr a -> expr a -> expr a
-instance Monoid1 IO where
-       mempty1  = mempty
-       mappend1 = mappend
-instance (Monoid1 m, Monad m) => Monoid1 (ST.StateT s m) where
-       mempty1  = mempty
-       mappend1 = mappend
-instance (Monad m, Monoid a) => Monoid (ST.StateT s m a) where
-       mempty  = return mempty
-       mappend = liftM2 mappend
-instance Monoid a => Monoid (IO a) where
-       mempty  = return mempty
-       mappend = liftM2 mappend
-instance (Monoid1 m, Monad m) => Monoid1 (MC.WriterT w m) where
-       mempty1  = mempty
-       mappend1 = mappend
-instance (Monad m, Monoid a) => Monoid (MC.WriterT w m a) where
-       mempty  = return mempty
-       mappend = liftM2 mappend
-
diff --git a/cli/Hcompta/Lib/Data/Text.hs b/cli/Hcompta/Lib/Data/Text.hs
deleted file mode 100644 (file)
index ed0fb69..0000000
+++ /dev/null
@@ -1,54 +0,0 @@
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# OPTIONS_GHC -fno-warn-tabs #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Hcompta.Lib.Data.Text where
-
-import Data.Char (Char)
-import Data.Eq (Eq(..))
-import qualified Data.List as List
-import Data.Maybe (Maybe(..))
-import Data.String (String)
-import Data.Text (Text)
-import qualified Data.Text as Text
-
--- * Class 'SplitOnChar'
-
-class SplitOnChar t where
-       splitOnChar :: Char -> t -> [t]
-instance SplitOnChar Text where
-       splitOnChar sep t =
-               case Text.uncons t of
-                Nothing -> []
-                Just (x, xs) ->
-                       if x == sep
-                       then splitOnChar sep xs
-                       else
-                               let (chunk, rest) = Text.break (== sep) t in
-                               chunk:splitOnChar sep rest
-instance SplitOnChar String where
-       splitOnChar sep t =
-               case t of
-                [] -> []
-                x:xs ->
-                       if x == sep
-                       then splitOnChar sep xs
-                       else
-                               let (chunk, rest) = List.break (== sep) t in
-                               chunk:splitOnChar sep rest
-
--- * Class 'SplitOnCharWithEmpty'
-
-class SplitOnCharWithEmpty t where
-       splitOnCharWithEmpty :: Char -> t -> [t]
-instance SplitOnCharWithEmpty Text where
-       splitOnCharWithEmpty sep t =
-               case Text.break (== sep) t of
-                (chunk, Text.uncons -> Just (_, rest)) -> chunk : splitOnCharWithEmpty sep rest
-                (chunk, _) -> [chunk]
-instance SplitOnCharWithEmpty String where
-       splitOnCharWithEmpty sep t =
-               case List.break (== sep) t of
-                (chunk, _:rest) -> chunk : splitOnCharWithEmpty sep rest
-                (chunk, []) -> [chunk]
diff --git a/cli/Hcompta/Lib/Data/Text/Buildable.hs b/cli/Hcompta/Lib/Data/Text/Buildable.hs
deleted file mode 100644 (file)
index 6315ac0..0000000
+++ /dev/null
@@ -1,61 +0,0 @@
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RankNTypes #-}
-{-# OPTIONS_GHC -fno-warn-tabs #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Hcompta.Lib.Data.Text.Buildable where
-import Data.Function (($), (.))
-import Data.Functor ((<$>))
-import Data.Foldable (Foldable(..))
-import Data.Monoid (Monoid(..), (<>))
-import qualified Data.List as List
-import Data.String (String)
-import Data.Text (Text)
-import Data.Eq (Eq(..))
-import qualified  Data.Text as Text
-import Data.Text.Buildable (Buildable(..))
-import qualified Data.Text.Lazy as TL
-import qualified Data.Text.Lazy.Builder as Build
-import Data.Text.Lazy.Builder (Builder)
-
-string :: Buildable a => a -> String
-string = TL.unpack . Build.toLazyText . build
-
-text :: Buildable a => a -> Text
-text = TL.toStrict . Build.toLazyText . build
-
-tuple :: (Foldable f, Buildable a) => f a -> Builder
-tuple f = "(" <> mconcat (List.intersperse ", " $ foldr ((:) . build) [] f) <> ")"
-
-list :: (Foldable f, Buildable a) => f a -> Builder
-list f = "[" <> mconcat (List.intersperse ", " $ foldr ((:) . build) [] f) <> "]"
-
-words :: (Foldable f, Buildable a) => f a -> Builder
-words f = mconcat (List.intersperse " " $ foldr ((:). build) [] f)
-
-words_quoted :: (Foldable f, Buildable a) => f a -> Builder
-words_quoted f =
-       mconcat (List.intersperse " " $
-               foldr ((:) . quote) [] f)
-       where quote a =
-               let t = text a in
-               if Text.any (== ' ') t
-               then "'"<>build t<>"'"
-               else build t
-
-unlines :: (Foldable f, Buildable a) => f a -> Builder
-unlines = mconcat . List.intersperse "\n" . foldr ((:) . build) []
-
-indent :: Buildable a => Builder -> a -> Builder
-indent prefix =
-       mconcat . List.intersperse "\n" .
-       ((prefix <>) . build <$>) . TL.lines .
-       Build.toLazyText . build
-
-parens :: Buildable a => a -> Builder
-parens a = "(" <> build a <> ")"
-
-{-
-instance Buildable a => Buildable [a] where
-       build = list
--}
diff --git a/cli/Hcompta/Lib/Data/Text/HLint.hs b/cli/Hcompta/Lib/Data/Text/HLint.hs
deleted file mode 120000 (symlink)
index ab18269..0000000
+++ /dev/null
@@ -1 +0,0 @@
-../HLint.hs
\ No newline at end of file
diff --git a/cli/Hcompta/Lib/HLint.hs b/cli/Hcompta/Lib/HLint.hs
deleted file mode 120000 (symlink)
index ab18269..0000000
+++ /dev/null
@@ -1 +0,0 @@
-../HLint.hs
\ No newline at end of file
diff --git a/cli/Hcompta/Lib/System/File/HLint.hs b/cli/Hcompta/Lib/System/File/HLint.hs
deleted file mode 120000 (symlink)
index ab18269..0000000
+++ /dev/null
@@ -1 +0,0 @@
-../HLint.hs
\ No newline at end of file
diff --git a/cli/Hcompta/Lib/System/File/Path.hs b/cli/Hcompta/Lib/System/File/Path.hs
deleted file mode 100644 (file)
index bd40aa2..0000000
+++ /dev/null
@@ -1,186 +0,0 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# OPTIONS_GHC -fno-warn-tabs #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
-module Hadmin.Lib.System.File.Path where
-
-import Data.Foldable (foldMap)
-import Data.Function (($), (.))
-import Data.Functor (Functor(..), (<$>))
-import qualified Data.List as List
-import Data.Maybe (Maybe(..))
-import Data.Monoid (Monoid(..), (<>))
-import Data.String (IsString(..))
-import Data.Text (Text)
-import Data.Text.Buildable (Buildable(..))
-import GHC.Exts (IsList(..))
-import Prelude (undefined)
-import qualified System.FilePath.Posix as FP
-
-import Hadmin.Lib.Data.Text
-
--- * Type 'Path'
-type Path pos a = InPos pos (InDir a)
-
--- * Type 'Position'
-data Position = Absolute | Relative
-
--- ** Type 'SPos'
--- | Singleton type for 'Position'.
-data SPos pos where
-       Abs :: SPos 'Absolute
-       Rel :: SPos 'Relative
-
--- ** Type 'IPos'
-
--- | Implicit class for 'Position'.
-class IPos pos where
-       pos :: SPos pos
-instance IPos 'Absolute where pos = Abs
-instance IPos 'Relative where pos = Rel
-
--- ** Type 'InPos'
-data InPos pos a = InPos (SPos pos) a
- deriving (Functor)
-instance Buildable a => Buildable (InPos pos a) where
-       build (InPos Abs a) = build FP.pathSeparator <> build a
-       build (InPos Rel a) = build a
-instance (IsString a, IPos pos) => IsString (InPos pos a) where
-       fromString = InPos pos . fromString
-
--- ** Type 'PosOf'
-type family PosOf x :: Position
-type instance PosOf (InPos pos a) = pos
-
--- * Type 'Dir'
-
-newtype Dir = Dir [Dir_Seg]
- deriving (Monoid)
-type Dir_Seg = Text
-type AbsDir = InPos 'Absolute Dir
-type RelDir = InPos 'Relative Dir
-instance IsString Dir where
-       fromString = Dir . (fromString <$>) . splitOnChar FP.pathSeparator
-instance IsList Dir where
-       type Item Dir = Dir_Seg
-       fromList = Dir . foldMap (splitOnChar FP.pathSeparator)
-       toList (Dir d) = toList d
-instance Buildable Dir where
-       build (Dir []) = "."
-       build (Dir p) =
-               mconcat $
-               List.intersperse
-                (build FP.pathSeparator)
-                (build <$> p)
-
-{-
-absDir :: InPos pos a -> InPos 'Absolute a
-absDir (InPos _p a) = InPos Abs a
-
-relDir :: InPos pos a -> InPos 'Relative a
-relDir (InPos _p a) = InPos Rel a
--}
-
--- ** Type 'InDir'
-data InDir a = InDir Dir a
- deriving (Functor)
-instance IsString (a -> InDir a) where
-       fromString = InDir . fromString
-instance IsString a => IsString (InDir a) where
-       fromString s =
-               case splitOnChar FP.pathSeparator s of
-                [] -> InDir (Dir []) $ fromString ""
-                l  -> InDir (Dir $ fromString <$> List.init l) $ fromString (List.last l)
-instance IsList (a -> InDir a) where
-       type Item (a -> InDir a) = Dir_Seg
-       fromList = InDir . fromList
-       toList = undefined
-instance Buildable a => Buildable (InDir a) where
-       build (InDir d a) = build d <> build FP.pathSeparator <> build a
-
--- ** Class 'Dir_Parent'
-
--- | Return the parent 'Dir' of given 'Dir'
-class Dir_Parent d where
-       type Dir_Parent_Dir d
-       dir_parent :: d -> Maybe (Dir_Parent_Dir d)
-
-instance Dir_Parent Dir where
-       type Dir_Parent_Dir Dir = Dir
-       dir_parent (Dir p) =
-               case p of
-                [] -> Nothing
-                _  -> Just $ Dir (List.init p)
-instance Dir_Parent a => Dir_Parent (InPos pos a) where
-       type Dir_Parent_Dir (InPos pos a) = InPos pos (Dir_Parent_Dir a)
-       dir_parent (InPos p a) = InPos p <$> dir_parent a
-instance Dir_Parent (InDir a) where
-       type Dir_Parent_Dir (InDir a) = Dir
-       dir_parent (InDir d _a) = Just d
-{-
-instance Dir_Parent File where
-       type Dir_Parent_Dir File = Dir
-       dir_parent (File _f) = Just $ Dir []
--}
-
--- ** Class 'Dir_Ancestors'
-
--- | Return self and parents 'Dir' of given 'Dir', in topological order.
-class Dir_Ancestors d where
-       type Dir_Ancestors_Dir d
-       dir_ancestors :: d -> [Dir_Parent_Dir d]
-
-instance Dir_Ancestors Dir where
-       type Dir_Ancestors_Dir Dir = Dir
-       dir_ancestors (Dir p) =
-               List.reverse $
-               List.foldl' (\acc seg ->
-                       case acc of
-                        [] -> [Dir [seg]]
-                        Dir d:_ -> Dir (d<>[seg]):acc
-                ) [Dir []] p
-instance Dir_Ancestors a => Dir_Ancestors (InPos pos a) where
-       type Dir_Ancestors_Dir (InPos pos a) = InPos pos (Dir_Ancestors_Dir a)
-       dir_ancestors (InPos p a) = InPos p <$> dir_ancestors a
-instance Dir_Ancestors (InDir a) where
-       type Dir_Ancestors_Dir (InDir a) = Dir
-       dir_ancestors (InDir d _a) = dir_ancestors d
-{-
-instance Dir_Ancestors File where
-       type Dir_Ancestors_Dir File = Dir
-       dir_ancestors (File _f) = [Dir []]
--}
-
--- ** Class 'Dir_Append'
-class Dir_Append p q where
-       type Dir_Append_Dir p q
-       (</>) :: p -> q -> Dir_Append_Dir p q
-instance Dir_Append (InPos p Dir) (InPos 'Relative Dir) where
-       type Dir_Append_Dir (InPos p Dir) (InPos 'Relative Dir) = InPos p Dir
-       (</>) (InPos p x) (InPos _q y) = InPos p (x <> y)
-instance Dir_Append (InPos p Dir) File where
-       type Dir_Append_Dir (InPos p Dir) File = InPos p (InDir File)
-       (</>) (InPos p d) f = InPos p (InDir d f)
-instance Dir_Append (InPos p Dir) (InPos 'Relative (InDir a)) where
-       type Dir_Append_Dir (InPos p Dir) (InPos 'Relative (InDir a)) = InPos p (InDir a)
-       (</>) (InPos p x) (InPos _q (InDir y a)) = InPos p (InDir (x <> y) a)
-
--- * Type 'File'
-newtype File = File [Text]
-instance IsString File where
-       fromString = File . (fromString <$>) . splitOnCharWithEmpty FP.extSeparator
-instance Buildable File where
-       build (File p) =
-               mconcat $
-               List.intersperse
-                (build FP.extSeparator)
-                (build <$> p)
-
-type RelFile = InPos 'Relative (InDir File)
diff --git a/cli/Hcompta/Lib/System/HLint.hs b/cli/Hcompta/Lib/System/HLint.hs
deleted file mode 120000 (symlink)
index ab18269..0000000
+++ /dev/null
@@ -1 +0,0 @@
-../HLint.hs
\ No newline at end of file
diff --git a/cli/Hcompta/Repr/HLint.hs b/cli/Hcompta/Repr/HLint.hs
deleted file mode 120000 (symlink)
index ab18269..0000000
+++ /dev/null
@@ -1 +0,0 @@
-../HLint.hs
\ No newline at end of file
diff --git a/cli/Hcompta/Repr/Meta.hs b/cli/Hcompta/Repr/Meta.hs
deleted file mode 100644 (file)
index 7db0dd8..0000000
+++ /dev/null
@@ -1,72 +0,0 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE InstanceSigs #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE NoIncoherentInstances #-}
-{-# LANGUAGE NoMonomorphismRestriction #-}
-{-# LANGUAGE OverloadedLists #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE NoUndecidableInstances #-}
-{-# OPTIONS_GHC -fno-warn-tabs #-}
-
-module Hcompta.Repr.Meta where
-
-import Control.Applicative (Applicative(..))
--- import Control.Exception.Safe (MonadThrow, MonadCatch, MonadMask)
--- import qualified Control.Exception.Safe as Exn
-import Control.Monad (Monad(..))
--- import qualified Control.Monad.Classes as MC
--- import qualified Control.Monad.Classes.Write as MC
-import Control.Monad.IO.Class (MonadIO(..))
--- import Control.Monad.Trans.Class
--- import Control.Monad.Trans.State.Strict as ST
-import Data.Bool
--- import Data.Either (Either(..))
-import Data.Eq (Eq(..))
--- import Data.Foldable (asum)
-import Data.Function (($), (.))
-import Data.Functor (Functor(..))
--- import Data.Int (Int)
--- import qualified Data.List as List
--- import Data.Maybe (Maybe(..), fromMaybe)
--- import Data.Monoid ((<>))
--- import Data.Ord (Ord(..))
--- import Data.Text (Text)
--- import qualified Data.Text as Text
--- import Data.Text.Buildable (Buildable(..))
--- import qualified Data.Text.Lazy.Builder as TL (Builder)
--- import Prelude (pred, succ)
--- import Text.Show (Show(..))
-
-import Hcompta.Expr
-import Hcompta.Lib.Control.Monad
--- import Hcompta.Lib.Data.Monoid (Monoid1)
--- import Hcompta.Lib.Data.Text as Text
-
--- * Type 'Write'
-
--- | Meta-circular /tagless-final interpreter/,
--- producing an Haskell term of type @h@.
-newtype Meta m h
- =      Meta
- {    unMeta :: m h }
- deriving (Applicative, Functor, Monad, MonadIO)
-
-run :: Meta m h -> m h
-run = unMeta
-
-instance Monad m => Expr_Lit (Meta m) where
-       lit = Meta . return
-instance Monad m => Expr_Bool (Meta m) where
-       and = liftM2Join $ \x y -> Meta $ return $ x && y
-       or  = liftM2Join $ \x y -> Meta $ return $ x || y
-       neg = liftMJoin  $ \x   -> Meta $ return $ not x
-instance Monad m => Expr_Eq (Meta m) where
-       eq = liftM2Join $ \x y -> Meta $ return $ x == y
-instance MonadIO m => Expr_Fun (Meta m)
diff --git a/cli/Hcompta/Repr/Test.hs b/cli/Hcompta/Repr/Test.hs
deleted file mode 100644 (file)
index 5cba39e..0000000
+++ /dev/null
@@ -1,12 +0,0 @@
-module Repr.Test where
-
-import Test.Tasty
-import qualified Repr.Tree.Test as Text
-import qualified Repr.Text.Test as Tree
-
-tests :: TestTree
-tests =
-       testGroup "Repr"
-        [ Text.tests
-        , Tree.tests
-        ]
diff --git a/cli/Hcompta/Repr/Text.hs b/cli/Hcompta/Repr/Text.hs
deleted file mode 100644 (file)
index 3da2d6f..0000000
+++ /dev/null
@@ -1,5 +0,0 @@
-module Hcompta.Repr.Text
- ( module Hcompta.Repr.Text.Write
- ) where
-
-import Hcompta.Repr.Text.Write
diff --git a/cli/Hcompta/Repr/Text/HLint.hs b/cli/Hcompta/Repr/Text/HLint.hs
deleted file mode 120000 (symlink)
index ab18269..0000000
+++ /dev/null
@@ -1 +0,0 @@
-../HLint.hs
\ No newline at end of file
diff --git a/cli/Hcompta/Repr/Text/Test.hs b/cli/Hcompta/Repr/Text/Test.hs
deleted file mode 100644 (file)
index 9283782..0000000
+++ /dev/null
@@ -1,10 +0,0 @@
-module Repr.Text.Test where
-
-import Test.Tasty
-import qualified Repr.Text.Write.Test as Write
-
-tests :: TestTree
-tests =
-       testGroup "Text"
-        [ Write.tests
-        ]
diff --git a/cli/Hcompta/Repr/Text/Write.hs b/cli/Hcompta/Repr/Text/Write.hs
deleted file mode 100644 (file)
index a2c4eb4..0000000
+++ /dev/null
@@ -1,160 +0,0 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE InstanceSigs #-}
--- {-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE NoIncoherentInstances #-}
-{-# LANGUAGE NoMonomorphismRestriction #-}
-{-# LANGUAGE OverloadedLists #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE NoUndecidableInstances #-}
-{-# OPTIONS_GHC -fno-warn-tabs #-}
-
-module Hcompta.Repr.Text.Write where
-
-import Data.Eq (Eq(..))
-import Data.Function (($), (.))
-import Data.Int (Int)
-import Data.Monoid ((<>))
-import Data.Ord (Ord(..))
-import Data.Text.Buildable (Buildable(..))
-import qualified Data.Text.Lazy as TL
-import qualified Data.Text.Lazy.Builder as TL
-import Prelude (pred, succ)
-import Text.Show (Show(..))
-
-import Hcompta.Expr
-
--- * Type 'Repr_Text_Write'
-
--- | /Tagless-final interpreter/
--- to evaluate an expression to a 'TL.Builder'.
-newtype Repr_Text_Write h
- =      Repr_Text_Write
- {    unRepr_Text_Write
-        :: Precedence -> Var_Depth -- inherited attributes
-        -> TL.Builder              -- synthetised attributes
- }
-{-
-data Write_Inh
- =   Write_Inh
- {   Write_Precedence :: Precedence
- ,   Write_Var_Depth  :: Var_Depth
- }
-data Write_Syn
- =   Write_Syn
- {   Write_Syn_Text :: TL.Builder
- }
--}
-type Var_Depth = Int
-
-repr_text_write :: Repr_Text_Write a -> TL.Builder
-repr_text_write x = unRepr_Text_Write x precedence_Toplevel 0
-instance Show (Repr_Text_Write a) where
-       show = TL.unpack . TL.toLazyText . repr_text_write
-
-instance Expr_Lit Repr_Text_Write where
-       lit a = Repr_Text_Write $ \_p _v -> build a
-instance Expr_Bool Repr_Text_Write where
-       and (Repr_Text_Write x) (Repr_Text_Write y) =
-               Repr_Text_Write $ \p v ->
-                       let p' = precedence_And in
-                       paren p p' $ x p' v <> " & " <> y p' v
-       or (Repr_Text_Write x) (Repr_Text_Write y) =
-               Repr_Text_Write $ \p v ->
-                       let p' = precedence_Or in
-                       paren p p'  $ x p' v <> " | " <> y p' v
-       neg (Repr_Text_Write x) =
-               Repr_Text_Write $ \p v ->
-                       let p' = precedence_Neg in
-                       paren p p' $ "!" <> x (precedence_succ p') v
-instance Expr_Fun Repr_Text_Write where
-       app (Repr_Text_Write f) (Repr_Text_Write x) = Repr_Text_Write $ \p v ->
-               let p' = precedence_App in
-               paren p p' $
-               f p' v <> " " <> x p' v
-       lazy       = repr_text_write_fun "~"
-       val        = repr_text_write_fun ""
-       inline     = repr_text_write_fun "!"
-       let_lazy   = repr_text_write_let "~"
-       let_val    = repr_text_write_let ""
-       let_inline = repr_text_write_let "!"
-
--- ** Instance 'Fun' helpers
-repr_text_write_fun :: TL.Builder -> (Repr_Text_Write a2 -> Repr_Text_Write a1) -> Repr_Text_Write a
-repr_text_write_fun mode e =
-       Repr_Text_Write $ \p v ->
-               let p' = precedence_Fun in
-               let x = "x" <> build v in
-               paren p p' $
-               "\\" <> mode <> x <> " -> " <>
-               unRepr_Text_Write (e (Repr_Text_Write $ \_p _v -> x)) p' (succ v)
-repr_text_write_let
- :: TL.Builder
- -> Repr_Text_Write a1
- -> (Repr_Text_Write a3 -> Repr_Text_Write a2)
- -> Repr_Text_Write a
-repr_text_write_let mode e in_ =
-       Repr_Text_Write $ \p v ->
-               let p' = precedence_Let in
-               let x = "x" <> build v in
-               paren p p' $
-               "let" <> mode <> " " <> x <> " = " <> unRepr_Text_Write e p (succ v) <> " in " <>
-               unRepr_Text_Write (in_ (Repr_Text_Write $ \_p _v -> x)) p (succ v)
-
-instance Expr_If Repr_Text_Write where
-       if_
-        (Repr_Text_Write cond)
-        (Repr_Text_Write ok)
-        (Repr_Text_Write ko) =
-               Repr_Text_Write $ \p v ->
-                       let p' = precedence_If in
-                       paren p p' $
-                       "if " <> cond p' v <>
-                       " then " <> ok p' v <>
-                       " else " <> ko p' v
-       when_ (Repr_Text_Write cond) (Repr_Text_Write ok) =
-               Repr_Text_Write $ \p v ->
-                       let p' = precedence_If in
-                       paren p p' $
-                       "when " <> cond p' v <>
-                       " " <> ok p' v
-
--- ** Type 'Precedence'
-
--- TODO: use an Enum?
-newtype Precedence = Precedence Int
- deriving (Eq, Ord, Show)
-precedence_pred :: Precedence -> Precedence
-precedence_pred (Precedence p) = Precedence (pred p)
-precedence_succ :: Precedence -> Precedence
-precedence_succ (Precedence p) = Precedence (succ p)
-paren :: Precedence -> Precedence -> TL.Builder -> TL.Builder
-paren prec prec' x =
-       if prec >= prec'
-        then "(" <> x <> ")"
-        else x
-
-precedence_Toplevel :: Precedence
-precedence_Toplevel  = Precedence 0
-precedence_Fun      :: Precedence
-precedence_Fun       = Precedence 1
-precedence_Let      :: Precedence
-precedence_Let       = Precedence 2
-precedence_If       :: Precedence
-precedence_If        = Precedence 3
-precedence_Or       :: Precedence
-precedence_Or        = Precedence 4
-precedence_And      :: Precedence
-precedence_And       = Precedence 5
-precedence_App      :: Precedence
-precedence_App       = Precedence 6
-precedence_Neg      :: Precedence
-precedence_Neg       = Precedence 7
-precedence_Atomic   :: Precedence
-precedence_Atomic    = Precedence 8
diff --git a/cli/Hcompta/Repr/Text/Write/Test.hs b/cli/Hcompta/Repr/Text/Write/Test.hs
deleted file mode 100644 (file)
index d47e562..0000000
+++ /dev/null
@@ -1,48 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module Repr.Text.Write.Test where
-
-import Data.Function (($))
-import Data.Text.Lazy.Builder as Build
-import qualified Data.Text.Lazy as Text
-import Test.Tasty
-import Test.Tasty.HUnit
-
-import qualified Expr.Fun.Test as Fun
-import qualified Expr.If.Test as If
-import qualified Expr.Bool.Test as Bool
-import Hcompta.Repr
-
-tests :: TestTree
-tests = testGroup "Write" $
- let (==>) expr expected =
-       testCase (Text.unpack expected) $
-       Build.toLazyText (repr_text_write expr) @?=
-       expected
-       in
- [ testGroup "Bool"
-        [ Bool.e1 ==> "True & False"
-        , Bool.e2 ==> "True & False | True & True"
-        , Bool.e3 ==> "(True | False) & (True | True)"
-        , Bool.e4 ==> "True & !False"
-        , Bool.e5 ==> "True & !x"
-        , Bool.e6 ==> "(x | y) & !(x & y)"
-        , Bool.e7 ==> "((x | y) & !(x & y) | z) & !(((x | y) & !(x & y)) & z)"
-        , Bool.e8 ==> "(x | (y | True) & !(y & True)) & !(x & ((y | True) & !(y & True)))"
-        ]
- , testGroup "Fun"
-        [ Fun.e1 ==> "\\x0 -> (\\x1 -> (x0 | x1) & !(x0 & x1))"
-        , Fun.e2 ==> "\\x0 -> (\\x1 -> x0 & !x1 | !x0 & x1)"
-        , Fun.e3 ==> "let x0 = True in x0 & x0"
-        , Fun.e4 ==> "let x0 = \\x1 -> x1 & x1 in x0 True"
-        , Fun.e5 ==> "\\x0 -> (\\x1 -> x0 & x1)"
-        , Fun.e6 ==> "(let x0 = True in x0) & False"
-        , Fun.e7 ==> "\\x0 -> x0 True & False"
-        , Fun.e8 ==> "\\x0 -> x0 (True & False)"
-        ]
- , testGroup "If"
-        [ If.e1 ==> "if True then False else True"
-        , If.e2 ==> "if True & True then False else True"
-        ]
- ]
-
diff --git a/cli/Hcompta/Repr/Tree.hs b/cli/Hcompta/Repr/Tree.hs
deleted file mode 100644 (file)
index efd0114..0000000
+++ /dev/null
@@ -1,5 +0,0 @@
-module Hcompta.Repr.Tree
- ( module Hcompta.Repr.Tree.Read
- ) where
-
-import Hcompta.Repr.Tree.Read
diff --git a/cli/Hcompta/Repr/Tree/Read.hs b/cli/Hcompta/Repr/Tree/Read.hs
deleted file mode 100644 (file)
index c70fb97..0000000
+++ /dev/null
@@ -1 +0,0 @@
-module Hcompta.Repr.Tree.Read where
diff --git a/cli/Hcompta/Repr/Tree/Read/Test.hs b/cli/Hcompta/Repr/Tree/Read/Test.hs
deleted file mode 100644 (file)
index 88f89cd..0000000
+++ /dev/null
@@ -1,80 +0,0 @@
-{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE InstanceSigs #-}
-{-# LANGUAGE KindSignatures #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE NoMonomorphismRestriction #-}
-{-# LANGUAGE NoPolyKinds #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
-
-module Repr.Tree.Read.Test where
-
-import Test.Tasty
-import Test.Tasty.HUnit
-import Control.Monad (Monad(..))
-import Control.Monad.IO.Class (MonadIO(..))
-import Control.Applicative (Applicative(..), Const(..))
-import Data.Bool (Bool(..))
-import Data.Either (Either(..))
-import Data.Eq (Eq(..))
-import Data.Function (($), (.), id)
-import Data.Functor (Functor(..), (<$>))
-import Data.Monoid ((<>))
-import Data.String (String)
-import Data.Int (Int)
-import Data.Text (Text)
-import qualified Data.Text as Text
-import Data.Text.Buildable (Buildable(..))
-import Data.Text.Lazy.Builder as Build
-import Text.Read (Read, reads)
-import Text.Show (Show(..))
-import Prelude (error, print, IO, undefined, succ)
-import GHC.Prim (Constraint)
-import Data.Proxy (Proxy(..))
-
-import Hcompta.Expr.Lit
-import Hcompta.Expr.Bool
-import Hcompta.Expr.Fun
-import Hcompta.Expr.Dup
-import qualified Expr.Dup.Test as Dup
-import Hcompta.Repr
-import Hcompta.Type
-
-tests :: TestTree
-tests = testGroup "Read" $
-       {-let (==>) (tree::Tree) expected@(text::Text) =
-               fun_lit_bool_from (Proxy::Proxy (Type_Fun_Lit_Bool_End repr)) tree $ \ty repr ->
-                       case ty of
-                        Type_Fun_Next (Type_Litkkk)
-               case  of
-                Left err -> testCase (show expected) $ "" @?= "Error: " <> err
-                Right (expr_write {-`Dup` expr_meta-}) ->
-                       testGroup (show expected)
-                        [ testCase "Text" $ Build.toLazyText (repr_text_write expr_write) @?= text
-                        -- , testCase "Meta" $ repr_meta expr_meta >>= (@?= meta)
-                        ] in
- [ Tree "And" [Tree "Bool" [Tree "True"], Tree "Bool" [Tree "False"]]
-   ==> "True & False"
- ]-}
- []
-{-
-       let (==>) tree expected@(text, meta) =
-               case fromTree tree of
-                Left err -> testCase (show expected) $ "" @?= "Error: " <> err
-                Right (expr_write `Dup` expr_meta) ->
-                       testGroup (show expected)
-                        [ testCase "text" $ Build.toLazyText (repr_text_write expr_write) @?= text
-                        , testCase "meta" $ repr_meta expr_meta >>= (@?= meta)
-                        ] in
- [ testGroup "Dup"
-        [ Dup.e1 ==> ("True & !(True & True)", False)
-        -- , Dup.e2 ==> ("", False)
-        ]
- ]
--}
-
diff --git a/cli/Hcompta/Repr/Tree/Test.hs b/cli/Hcompta/Repr/Tree/Test.hs
deleted file mode 100644 (file)
index 33b82d8..0000000
+++ /dev/null
@@ -1,10 +0,0 @@
-module Repr.Tree.Test where
-
-import Test.Tasty
-import qualified Repr.Tree.Read.Test as Read
-
-tests :: TestTree
-tests =
-       testGroup "Tree"
-        [ Read.tests
-        ]
diff --git a/cli/Hcompta/Test.hs b/cli/Hcompta/Test.hs
deleted file mode 100644 (file)
index a775a7c..0000000
+++ /dev/null
@@ -1,21 +0,0 @@
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Test where
-
-import Data.Function (($))
-import System.IO (IO)
-import Test.Tasty
-
-import qualified Repr.Test as Repr
-import qualified Trans.Test as Trans
-
-main :: IO ()
-main =
-       defaultMain $
-       testGroup "Hcompta"
-        [ Repr.tests
-        , Trans.tests
-        ]
diff --git a/cli/Hcompta/Trans/Bool.hs b/cli/Hcompta/Trans/Bool.hs
deleted file mode 100644 (file)
index 1a4db41..0000000
+++ /dev/null
@@ -1,5 +0,0 @@
-module Hcompta.Trans.Bool
- ( module Hcompta.Trans.Bool.Const
- ) where
-
-import Hcompta.Trans.Bool.Const
diff --git a/cli/Hcompta/Trans/Bool/Const.hs b/cli/Hcompta/Trans/Bool/Const.hs
deleted file mode 100644 (file)
index d531a1a..0000000
+++ /dev/null
@@ -1,57 +0,0 @@
-{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# OPTIONS_GHC -fno-warn-tabs #-}
-
-module Hcompta.Trans.Bool.Const where
-
-import Data.Bool
-import Data.Function (($))
-import Data.Text.Buildable (Buildable(..))
-import Text.Show (Show)
-
-import Hcompta.Expr.Trans
-import Hcompta.Expr.Lit
-import Hcompta.Expr.Bool
-
--- * Type 'Trans_Bool_Const'
-
--- * Annotation to propagate constants.
-data Trans_Bool_Const repr h
- =   Trans_Bool_Const_Unk (repr h)
- |   (Buildable h, Show h)
-  => Trans_Bool_Const_Lit h
-
-instance Expr_Lit repr => Trans Trans_Bool_Const repr where
-       trans_lift = Trans_Bool_Const_Unk
-       trans_apply (Trans_Bool_Const_Unk x) = x
-       trans_apply (Trans_Bool_Const_Lit x) = lit x
-
-trans_bool_const
- :: (Expr_Bool repr, Expr_Lit repr)
- => Trans_Bool_Const repr h
- ->                  repr h
-trans_bool_const = trans_apply
-
-instance Expr_Lit repr => Expr_Lit (Trans_Bool_Const repr) where
-       lit = Trans_Bool_Const_Lit
-instance Expr_Bool repr => Expr_Bool (Trans_Bool_Const repr) where
-       and (Trans_Bool_Const_Lit True) y   = y
-       and (Trans_Bool_Const_Lit False) _y = Trans_Bool_Const_Lit False
-       and x (Trans_Bool_Const_Lit True)   = x
-       and _x (Trans_Bool_Const_Lit False) = Trans_Bool_Const_Lit False
-       and (Trans_Bool_Const_Unk x)
-           (Trans_Bool_Const_Unk y)
-        =   Trans_Bool_Const_Unk $ and x y
-       
-       or (Trans_Bool_Const_Lit False) y = y
-       or (Trans_Bool_Const_Lit True) _y = Trans_Bool_Const_Lit True
-       or x (Trans_Bool_Const_Lit False) = x
-       or _x (Trans_Bool_Const_Lit True) = Trans_Bool_Const_Lit True
-       or (Trans_Bool_Const_Unk x)
-          (Trans_Bool_Const_Unk y)
-        =  Trans_Bool_Const_Unk $ or x y
-       
-       neg (Trans_Bool_Const_Unk e) = Trans_Bool_Const_Unk $ neg e
-       neg (Trans_Bool_Const_Lit x) = Trans_Bool_Const_Lit $ not x
diff --git a/cli/Hcompta/Trans/Bool/Const/Test.hs b/cli/Hcompta/Trans/Bool/Const/Test.hs
deleted file mode 100644 (file)
index ea306f0..0000000
+++ /dev/null
@@ -1,33 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
-module Trans.Bool.Const.Test where
-
-import Data.Function (($))
-import qualified Data.Text.Lazy as Text
-import Data.Text.Lazy.Builder as Build
-import Test.Tasty
-import Test.Tasty.HUnit
-
-import qualified Expr.Bool.Test as Bool
-import qualified Repr.Text.Write.Test ()
-import Hcompta.Repr
-import Hcompta.Trans
-
-tests :: TestTree
-tests = testGroup "Const" $
-       let (==>) expr expected =
-               testCase (Text.unpack expected) $
-               Build.toLazyText (repr_text_write $ trans_bool_const expr) @?=
-               expected
-        in
- [ Bool.e1 ==> "False"
- , Bool.e2 ==> "True"
- , Bool.e3 ==> "True"
- , Bool.e4 ==> "True"
- , Bool.e5 ==> "!x"
- , Bool.e6 ==> "(x | y) & !(x & y)"
- , Bool.e7 ==> "((x | y) & !(x & y) | z) & !(((x | y) & !(x & y)) & z)"
- , Bool.e8 ==> "(x | !y) & !(x & !y)"
- ]
-
diff --git a/cli/Hcompta/Trans/Bool/HLint.hs b/cli/Hcompta/Trans/Bool/HLint.hs
deleted file mode 120000 (symlink)
index ab18269..0000000
+++ /dev/null
@@ -1 +0,0 @@
-../HLint.hs
\ No newline at end of file
diff --git a/cli/Hcompta/Trans/Bool/Test.hs b/cli/Hcompta/Trans/Bool/Test.hs
deleted file mode 100644 (file)
index 1d635b4..0000000
+++ /dev/null
@@ -1,10 +0,0 @@
-module Trans.Bool.Test where
-
-import Test.Tasty
-import qualified Trans.Bool.Const.Test as Const
-
-tests :: TestTree
-tests =
-       testGroup "Bool"
-        [ Const.tests
-        ]
diff --git a/cli/Hcompta/Trans/HLint.hs b/cli/Hcompta/Trans/HLint.hs
deleted file mode 120000 (symlink)
index ab18269..0000000
+++ /dev/null
@@ -1 +0,0 @@
-../HLint.hs
\ No newline at end of file
diff --git a/cli/Hcompta/Trans/Test.hs b/cli/Hcompta/Trans/Test.hs
deleted file mode 100644 (file)
index 1d3cc1a..0000000
+++ /dev/null
@@ -1,10 +0,0 @@
-module Trans.Test where
-
-import Test.Tasty
-import qualified Trans.Bool.Test as Bool
-
-tests :: TestTree
-tests =
-       testGroup "Trans"
-        [ Bool.tests
-        ]
diff --git a/cli/Setup.hs b/cli/Setup.hs
deleted file mode 100644 (file)
index 9a994af..0000000
+++ /dev/null
@@ -1,2 +0,0 @@
-import Distribution.Simple
-main = defaultMain
diff --git a/cli/hcompta-cli.cabal b/cli/hcompta-cli.cabal
deleted file mode 100644 (file)
index e77db52..0000000
+++ /dev/null
@@ -1,225 +0,0 @@
-author: Julien Moutinho <julm+hcompta@autogeree.net>
--- bug-reports: http://bug.autogeree.net/hcompta
-build-type: Simple
-cabal-version: >= 1.8
-category: Finance
--- data-dir: data
--- data-files:
-description: Hcompta command line interface.
-extra-tmp-files:
-extra-source-files:
--- homepage: http://pad.autogeree.net/hcompta
-license: GPL-3
-license-file: COPYING
-maintainer: Julien Moutinho <julm+hcompta@autogeree.net>
-name: hcompta-cli
-stability: experimental
-synopsis: hcompta
-tested-with: GHC==7.10.3
-version: 1.201608
-
-Source-Repository head
-  location: git://git.autogeree.net/hcompta
-  type:     git
-
-Flag dev
-  Description: Turn on development settings.
-  Default:     False
-  Manual:      True
-
-Flag dump
-  Default:     False
-  Description: Dump some intermediate files.
-  Manual:      True
-
-Flag library-only
-  Description: Build only library.
-  Default:     False
-  Manual:      True
-
-Flag prof
-  Default:     False
-  Description: Turn on profiling settings.
-  Manual:      True
-
-Flag threaded
-  Default:     True
-  Description: Enable threads.
-  Manual:      True
-
-Library
-  extensions: NoImplicitPrelude
-  ghc-options: -Wall -fno-warn-tabs
-  if flag(dev)
-    cpp-options: -DDEVELOPMENT
-    ghc-options:
-  if flag(dump)
-    ghc-options: -ddump-ds -ddump-simpl -ddump-splices -ddump-stg -ddump-to-file
-  if flag(prof)
-    cpp-options: -DPROFILING
-    ghc-options: -fprof-auto
-  -- default-language: Haskell2010
-  exposed-modules:
-    Hcompta.CLI.Args
-    Hcompta.CLI.Command
-    -- Hcompta.CLI.Command.Balance
-    -- Hcompta.CLI.Command.GL
-    -- Hcompta.CLI.Command.Journal
-    Hcompta.CLI.Command.Journals
-    -- Hcompta.CLI.Command.Stats
-    -- Hcompta.CLI.Command.Tags
-    Hcompta.CLI.Context
-    Hcompta.CLI.Env
-    Hcompta.CLI.Convert
-    Hcompta.CLI.Format
-    Hcompta.CLI.Format.JCC
-    Hcompta.CLI.Format.Ledger
-    Hcompta.CLI.Lang
-    Hcompta.CLI.Write
-    Hcompta.Expr
-    Hcompta.Expr.Bool
-    Hcompta.Expr.Dup
-    Hcompta.Expr.Eq
-    Hcompta.Expr.Fun
-    Hcompta.Expr.If
-    Hcompta.Expr.Lit
-    Hcompta.Expr.Log
-    Hcompta.Expr.Maybe
-    Hcompta.Expr.Ord
-    Hcompta.Expr.Set
-    Hcompta.Expr.Trans
-    Hcompta.Repr
-    Hcompta.Repr.Meta
-    Hcompta.Repr.Text
-    Hcompta.Repr.Text.Write
-    Hcompta.Repr.Tree
-    Hcompta.Repr.Tree.Read
-    Hcompta.Trans
-    Hcompta.Trans.Bool
-    Hcompta.Trans.Bool.Const
-    Hcompta.Type
-  build-depends:
-    base >= 4.6 && < 5
-    , ansi-terminal >= 0.4 && < 0.7
-    , bytestring
-    , containers
-    , Decimal
-    , deepseq
-    -- , directory
-    , exceptions
-    , ghc-prim
-    , hcompta-jcc
-    , hcompta-ledger
-    , hcompta-lib
-    -- , HUnit
-    , io-memoize >= 1.1
-                 -- NOTE: needed for System.IO.Memoize.once
-    , monad-classes
-    , parsec
-    , parsec-error-custom
-    -- , safe >= 0.2
-    , safe-exceptions
-    , semigroups
-    , strict
-    -- , template-haskell
-    , text
-    , text-format
-    , time
-    , transformers >= 0.4 && < 0.5
-                   -- NOTE: needed for Control.Monad.Trans.Except
-    , treemap
-    , walderleijen-ansi-text
-
-Executable hcompta
-  extensions: NoImplicitPrelude
-  ghc-options: -Wall -fno-warn-tabs
-  if flag(threaded)
-    ghc-options: -threaded -rtsopts -with-rtsopts=-N
-  if flag(dev)
-    cpp-options: -DDEVELOPMENT
-    ghc-options:
-  if flag(prof)
-    cpp-options: -DPROFILING
-    ghc-options: -fprof-auto
-  if flag(library-only)
-    Buildable: False
-  main-is: Hcompta/CLI/Main.hs
-  hs-source-dirs: .
-  build-depends:
-    base >= 4.6 && < 5
-    , ansi-terminal >= 0.4 && < 0.7
-    , bytestring
-    , containers >= 0.5 && < 0.6
-                 -- NOTE: needed for Data.Map.Strict
-    , Decimal
-    , deepseq
-    -- , directory
-    , ghc-prim
-    , hcompta-jcc
-    , hcompta-ledger
-    , hcompta-lib
-    -- , HUnit
-    , io-memoize >= 1.1
-                 -- NOTE: needed for System.IO.Memoize.once
-    , parsec
-    , parsec-error-custom
-    -- , safe >= 0.2
-    , semigroups
-    , strict
-    -- , template-haskell
-    , text
-    , time
-    , transformers >= 0.4 && < 0.5
-                   -- NOTE: needed for Control.Monad.Trans.Except
-    , treemap
-    , walderleijen-ansi-text
-
-
-Test-Suite hcompta-cli-test
-  type: exitcode-stdio-1.0
-  -- default-language: Haskell2010
-  extensions: NoImplicitPrelude
-  ghc-options: -Wall -fno-warn-tabs
-               -main-is Test
-  hs-source-dirs: Hcompta
-  main-is: Test.hs
-  other-modules:
-    Repr.Test
-    Repr.Text
-    Repr.Text.Write
-    Repr.Text.Write.Test
-    Repr.Tree
-    Repr.Tree.Read
-    Repr.Tree.Read.Test
-    -- Repr.Meta
-    -- Repr.Meta.Test
-    Expr.Bool.Test
-    Expr.Dup.Test
-    Expr.Fun.Test
-    Expr.If.Test
-    Trans.Bool.Const.Test
-    Trans.Bool.Test
-    Trans.Test
-  if flag(threaded)
-    ghc-options: -threaded -rtsopts -with-rtsopts=-N
-  if flag(dev)
-    cpp-options: -DDEVELOPMENT
-    ghc-options:
-  if flag(prof)
-    cpp-options: -DPROFILING
-    ghc-options: -fprof-auto
-  build-depends:
-    base >= 4.6 && < 5
-    , containers >= 0.5 && < 0.6
-    , Decimal
-    , ghc-prim
-    , hcompta-lib
-    , hcompta-cli
-    , semigroups
-    , strict
-    , tasty >= 0.11
-    , tasty-hunit
-    , text
-    , text-format
-    , transformers >= 0.4 && < 0.5
-    , treemap