packages feed

hoodle-core 0.14 → 0.15

raw patch · 75 files changed

+5535/−4292 lines, 75 filesdep +case-insensitivedep +gtk3dep +handa-gdatadep ~cairodep ~gtkdep ~hoodle-buildersetup-changed

Dependencies added: case-insensitive, gtk3, handa-gdata, hoodle-publish, http-client, http-conduit, http-types, network-uri, persistent, persistent-sqlite, persistent-template, resourcet, websockets

Dependency ranges changed: cairo, gtk, hoodle-builder, hoodle-parser, hoodle-render, hoodle-types, network

Files

− CHANGES 
@@ -1,42 +0,0 @@-0.5: 12 Dec 2011-   * First public release. basic pen operation, eraser operation, rectangular selection and file operations are implemented--0.5.1: 16 Dec 2011 -   * Use of configuration file '.hxournal'. Enable Use X Input menu. Dependency on xournal-parser and xournal-render is restricted to 0.2.0.* only-   * checking gtk+-2.0 using pkg-config--0.6: 18 Dec 2011 -   * pdf background support. Annotate PDF menu is activated. preloading pdf background images--0.6.0: 19 Dec 2011 -   * some bug fixes (temporary yet) related to automatic scrollbar disappearing. Check when new, open, annotate pdf if xournal file is not saved yet. - -0.6.1: 25 Dec 2011-   * undo/redo support, double buffer rendering while scrolling--0.6.2: 15 Jan 2012-   * layer support--0.6.3: 24 Jan 2012 -   * refine rendering while selection and scrolling. highlighter is implemented. Resizing selected strokes implemented--0.6.4: 6 Feb 2012-   * lasso selection, continuous page view. --0.6.5: 12 Feb 2012-   * pen button support, pen pressure support, using faster xoj parser --0.6.6: 28 Feb 2012 -   * scripting support, zoom in/out implemented. page functions are implemented--==================--0.7: 29 Nov 2012-   * change to Hoodle-   * new hoodle format   -   * simplify namespace to Hoodle-   * inter-process clipboard support using GtkClipboard-   * Image embedding support -   * pdf export support --
Config.hs view
@@ -54,12 +54,21 @@  config :: LocalBuildInfo -> IO (Maybe HookedBuildInfo) config bInfo = do -  (excode,out,err) <- readProcessWithExitCode "pkg-config" ["--cflags", "gtk+-2.0"] "" -  incdirs <- case excode of -    ExitSuccess -> return . extractIncDir $ out-    _ -> error $ ("failure when running pkg-config --cflags gtk+-2.0 :\n" ++ err) -    -  +  let cflags = (configConfigurationsFlags . configFlags) bInfo+      b = maybe False id (lookup (FlagName "gtk3") cflags)+  incdirs <- if b +               then do +                 (excode,out,err) <- readProcessWithExitCode "pkg-config" ["--cflags", "gtk+-3.0"] "" +                 case excode of +                   ExitSuccess -> return . extractIncDir $ out+                   _ -> error $ ("failure when running pkg-config --cflags gtk+-3.0 :\n" ++ err) +               else do +                 (excode,out,err) <- readProcessWithExitCode "pkg-config" ["--cflags", "gtk+-2.0"] "" +                 case excode of +                   ExitSuccess -> return . extractIncDir $ out+                   _ -> error $ ("failure when running pkg-config --cflags gtk+-2.0 :\n" ++ err) ++    let Just lib = library . localPkgDescr $ bInfo       buildinfo = libBuildInfo lib   let hbi = emptyBuildInfo { extraLibs = extraLibs buildinfo
LICENSE view
@@ -1,686 +1,25 @@-Copyright (C) 2011-2014 Ian-Woo Kim--Hoodle 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.--Hoodle 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.--                    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.+The following license covers this documentation, and the source code, except+where otherwise indicated. -  If the program does terminal interaction, make it output a short-notice like this when it starts in an interactive mode:+Copyright 2011-2014, Ian-Woo Kim. All rights reserved. -    <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.+Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met: -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".+* Redistributions of source code must retain the above copyright notice, this+  list of conditions and the following disclaimer. -  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/>.+* Redistributions in binary form must reproduce the above copyright notice,+  this list of conditions and the following disclaimer in the documentation+  and/or other materials provided with the distribution. -  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>.+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO+EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,+OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Setup.lhs view
@@ -6,4 +6,4 @@ >  > main :: IO () > main = defaultMainWithHooks myConfigHook-> +> -- main = defaultMain
csrc/c_initdevice.c view
@@ -2,9 +2,11 @@ #include <stdio.h> #include <string.h> -+#ifndef GTK3 #include "XInput.h"+#endif // GTK3 +#ifndef GTK3 // // Globals. //@@ -115,6 +117,7 @@ }  + void find_wacom( char* stylus_name, char* eraser_name)  {   Display *display = XOpenDisplay(NULL); @@ -136,8 +139,7 @@   }   return ;  }--+#endif // not GTK3  void initdevice ( int* core                 , int* stylus@@ -149,53 +151,54 @@ 		, char* touchname                 ) {-  // xinput_start(); -   printf("initdevice : stylusname = %s\n", stylusname );   printf("initdevice : erasername = %s\n", erasername );    printf("initdevice : touchname = %s\n", touchname );                          GList* dev_list;   GdkDevice* device;+#ifdef GTK3+  GdkDisplay* disp = gdk_display_get_default();+  GdkDeviceManager *devman = gdk_display_get_device_manager(disp);++  dev_list = gdk_device_manager_list_devices(devman, GDK_DEVICE_TYPE_SLAVE );+#else // GTK3   dev_list = gdk_devices_list();+#endif // GTK3   (*stylus) = 0;   while (dev_list != NULL) {-    // printf ("one device\n");      device = (GdkDevice *)dev_list->data;-    // printf(" %d : %s \n", device, device->name );-    if (device != gdk_device_get_core_pointer()) {-      // #ifdef ENABLE_XINPUT_BUGFIX+    // device = GPOINTER_TO_INT(dev_list->data);+    if ( gdk_device_get_source(device) != GDK_SOURCE_MOUSE ) {       gdk_device_set_axis_use(device, 0, GDK_AXIS_IGNORE);       gdk_device_set_axis_use(device, 1, GDK_AXIS_IGNORE);-      // #endif       gdk_device_set_mode(device, GDK_MODE_SCREEN); -      // printf("This is xinput device %s \n", device -> name);-      if( !strcmp (device->name, stylusname) ) {-        // printf("got stylus\n");   +      if( !strcmp (gdk_device_get_name(device), stylusname) ) {         (*stylus) = (int) device;        } -      if( !strcmp (device->name, erasername) ) { -        // printf("got eraser\n");+      if( !strcmp (gdk_device_get_name(device), erasername) ) {          (*eraser) = (int) device;       } -      if( !strcmp (device->name, touchname) ) { -        // printf("got eraser\n");+      if( !strcmp (gdk_device_get_name(device), touchname) ) {          (*touch) = (int) device;       }      }      else { -      if( !strcmp (device->name, corepointername) ) { -        // printf("got Core Pointer\n"); +      if( !strcmp (gdk_device_get_name(device), corepointername) ) {          (*core) = (int) device;        }      } -    dev_list = dev_list->next; +#ifdef GTK3+    dev_list = g_list_next(dev_list); +#else // GTK3+    dev_list = dev_list->next;+#endif // GTK3   }  } -+#ifndef GTK3 void enable_touch( char* touch_name )  {   printf("enable touch: %s\n", touch_name ) ; @@ -204,18 +207,6 @@ void disable_touch( GdkDrawable *gdkwin, char* touch_name )  {   printf("disable touch: %s\n", touch_name ); -  /* Display *dpy = XOpenDisplay(NULL); -  XIEventMask eventmask ; -  Window win = GDK_DRAWABLE_XID(gdkwin) ; -  unsigned char mask[1] = { 0 } ; --  eventmask.deviceid = 12 ; -  eventmask.make_len = sizeof(mask); -  eventmask.mask = mask ; - -  XISelectEvents (dpy,win,&eventmask,1); --  XCloseDisplay(dpy); */     }-+#endif // GTK3
csrc/c_initdevice.h view
@@ -1,11 +1,11 @@ #include <gtk/gtk.h> #include <stdio.h> -void find_wacom( char* stylus_name, char* eraser_name ) ; +// void find_wacom( char* stylus_name, char* eraser_name ) ;   void initdevice( int* core, int* stylus, int* eraser,                   char* corepointername, char* stylusname, char* erasername );  -void enable_touch( char* touch_name ) ;+// void enable_touch( char* touch_name ) ; -void disable_touch( char* touch_name ); +// void disable_touch( char* touch_name );
hoodle-core.cabal view
@@ -1,11 +1,11 @@ Name:		hoodle-core-Version:	0.14+Version:	0.15 Synopsis:	Core library for hoodle Description: 	Hoodle is a pen notetaking program written in haskell.                  hoodle-core is the core library written in haskell and                  using gtk2hs Homepage:       http://ianwookim.org/hoodle-License: 	GPL-3+License: 	BSD3 License-file:	LICENSE Author:		Ian-Woo Kim Maintainer: 	Ian-Woo Kim <ianwookim@gmail.com>@@ -16,15 +16,27 @@ data-files:     template/*.html.st                 resource/*.png                 resource/*.xml-                CHANGES                 Config.hs Source-repository head   type: git   location: http://www.github.com/wavewave/hoodle-core ++Flag Dyre+  Description:     dynamic reconfiguration support+  Default:         False++Flag Gtk3+  Description:     compile with gtk3+  Default:         False ++Flag Hub+  Description:     communication with Hub+  Default:         False+ Library   hs-source-dirs: src-  ghc-options: 	-Wall  -funbox-strict-fields -fno-warn-unused-do-bind -fno-warn-orphans +  ghc-options: 	-Wall -funbox-strict-fields -fno-warn-unused-do-bind -fno-warn-orphans    ghc-prof-options: -caf-all -auto-all    Build-Depends:   aeson>=0.7,@@ -35,31 +47,30 @@                    base64-bytestring >= 0.1,                    binary,                    bytestring >= 0.9, -                   cairo > 0.12,+                   cairo > 0.13,+                   case-insensitive,                     cereal >= 0.3.5,                    containers >= 0.4,                    configurator >= 0.2,                    coroutine-object >= 0.2, -                   dbus >= 0.10,                     Diff >= 0.3,                    directory > 1,-                   dyre >= 0.8.11,                     either >= 3.1,                     errors >= 1.3,                     filepath > 1,                     fsnotify >= 0.0.7,                     gd >= 3000.7,               -                   gtk > 0.12, -                   hoodle-builder >= 0.3,-                   hoodle-parser >= 0.3,-                   hoodle-render >= 0.4,-                   hoodle-types >= 0.3,+                   handa-gdata >= 0.6.9.3, +                   hoodle-builder >= 0.3.0,+                   hoodle-parser >= 0.3.0,+                   hoodle-publish >= 0.2,+                   hoodle-render == 0.5.*,+                   hoodle-types >= 0.3.0,+                   http-types,                    lens >= 2.5,                    monad-loops >= 0.3,                     mtl > 2,-                   network, -                   network-info, -                   network-simple >= 0.3,+                   network-uri > 2.6,                    old-locale >= 1.0,                     pango > 0.12,                    poppler >= 0.12.2.2, @@ -77,7 +88,29 @@                    unordered-containers >= 0.2,                    uuid >= 1.2.7,                     vector >= 0.10,+                   websockets,                     xournal-parser >= 0.5.0.2+  --+  if flag(dyre)+    Build-depends: dyre >= 0.8.11+  -- +  if flag(gtk3) +    Build-depends: gtk3 > 0.13 +  else +    Build-depends: gtk > 0.13+  -- +  if flag(hub)+    Build-depends: +                   dbus >= 0.10, +                   http-client,+                   http-conduit,+                   network > 2.6, +                   network-info, +                   network-simple >= 0.3,+                   persistent,+                   persistent-sqlite,+                   persistent-template,+                   resourcet    Exposed-Modules:                     Hoodle.Accessor@@ -86,6 +119,7 @@                    Hoodle.Coroutine.Commit                    Hoodle.Coroutine.ContextMenu                    Hoodle.Coroutine.Default+                   Hoodle.Coroutine.Default.Menu                    Hoodle.Coroutine.Dialog                    Hoodle.Coroutine.Draw                    Hoodle.Coroutine.Eraser@@ -96,7 +130,6 @@                    Hoodle.Coroutine.Link                    Hoodle.Coroutine.Minibuffer                    Hoodle.Coroutine.Mode-                   Hoodle.Coroutine.Network                    Hoodle.Coroutine.Page                    Hoodle.Coroutine.Pen                    Hoodle.Coroutine.Scroll@@ -104,6 +137,7 @@                    Hoodle.Coroutine.Select.Clipboard                    Hoodle.Coroutine.Select.ManipulateImage                    Hoodle.Coroutine.TextInput+                   Hoodle.Coroutine.LaTeX                    Hoodle.Coroutine.VerticalSpace                     Hoodle.Coroutine.Window                    Hoodle.Device@@ -145,6 +179,15 @@                    Hoodle.Widget.Dispatch                    Hoodle.Widget.Layer                     Hoodle.Widget.PanZoom+                   Hoodle.Widget.Scroll+  if flag(hub)+    Exposed-Modules: Hoodle.Coroutine.Hub+                     Hoodle.Coroutine.Hub.Common+                     Hoodle.Coroutine.HubInternal+                     Hoodle.Coroutine.Network+                     Hoodle.Coroutine.Socket+                     Hoodle.Type.Hub+                     Hoodle.Type.Synchronization   Other-Modules:                     Paths_hoodle_core   c-sources: @@ -154,5 +197,11 @@                    csrc/c_initdevice.h                    csrc/template-hsc-gtk2hs.h                    csrc/XInput.h-  cc-options:      -Wno-pointer-to-int-cast -std=gnu99 -DDEBUG +  cc-options:      -fPIC -Wno-pointer-to-int-cast -std=gnu99 -DDEBUG    extra-libraries: X11 Xi dl pthread+  if flag(dyre)+    cpp-options: -DDYRE+  if flag(gtk3)+    cpp-options: -DGTK3+  if flag(hub)+    cpp-options: -DHUB
resource/menu.xml view
@@ -28,6 +28,7 @@     </menu>     <menu action="VMA">        <menuitem action="TOGPANZOOMA" />+       <menuitem action="TOGSCRA" />        <menu action="ZOOMA" >          <menuitem action="ZMINA" />          <menuitem action="ZMOUTA" />                          @@ -64,6 +65,7 @@     <menu action="IMA">        <menuitem action="LDIMGA" />        <menuitem action="LDSVGA" />+       <menuitem action="LDIMGBKGA" />        <menuitem action="LDPREIMGA" />           <menuitem action="LDPREIMG2A" />        <menuitem action="LDPREIMG3A" />@@ -73,11 +75,13 @@        <menuitem action="EDITSRCA" />        <menuitem action="EDITNETSRCA" />        <menuitem action="TEXTFROMSRCA" />+       <menuitem action="TOGGLENETSRCA" />        <separator />         <menuitem action="LATEXA" />        <menuitem action="LATEXNETA" />        <menuitem action="COMBINELATEXA" />        <menuitem action="LATEXFROMSRCA" />+       <menuitem action="UPDATELATEXA" />        <separator />     </menu>     <menu action="PMA">@@ -157,7 +161,7 @@     <menu action="OMA">        <menuitem action="UXINPUTA" />        <menuitem action="HANDA" />-       <menuitem action="SMTHSCRA" />+       <!-- <menuitem action="SMTHSCRA" /> -->        <menuitem action="POPMENUA" />         <menuitem action="EBDIMGA" />        <menuitem action="EBDPDFA" />@@ -165,24 +169,18 @@        <menuitem action="KEEPRATIOA" />        <menuitem action="VCURSORA" />        <menuitem action="TOGCLOCKA" />-       <menuitem action="DCRDCOREA" />                        -       <menuitem action="ERSRTIPA" />                        -       <menuitem action="PRESSRSENSA" />                        -       <menuitem action="PGHILTA" />                        -       <menuitem action="MLTPGVWA" />                        -       <menuitem action="MLTPGA" />                        -       <menuitem action="BTN2MAPA" />                        -       <menuitem action="BTN3MAPA" />                        -       <separator />-       <menuitem action="ANTIALIASBMPA" />-       <menuitem action="PRGRSBKGA" />                        -       <menuitem action="PRNTPPRULEA" />                        -       <menuitem action="LFTHNDSCRBRA" />                        -       <menuitem action="SHRTNMENUA" />   -       <separator />-       <menuitem action="AUTOSAVEPREFA" />-       <menuitem action="SAVEPREFA" />+       <menuitem action="PRESSRSENSA" />+       <menu action="NEWPAGEMODEA">+         <menuitem action="NEWPAGEPLAINA" />+         <menuitem action="NEWPAGELASTA" />+         <menuitem action="NEWPAGECYCLEA" />+       </menu>        <menuitem action="RELAUNCHA" />+       <menuitem action="HUBA" />+    </menu>+    <menu action="WMA">+       <menuitem action="ADDTABA" />+       <menuitem action="CLOSETABA" />     </menu>     <menu action="HMA">        <menuitem action="ABOUTA" />
src/Hoodle/Accessor.hs view
@@ -1,11 +1,15 @@-{-# LANGUAGE TypeOperators, GADTs, ScopedTypeVariables, Rank2Types  #-}+-- {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Rank2Types  #-}  ----------------------------------------------------------------------------- -- | -- Module      : Hoodle.Accessor  -- Copyright   : (c) 2011-2014 Ian-Woo Kim ----- License     : GPL-3+-- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com> -- Stability   : experimental -- Portability : GHC@@ -15,20 +19,21 @@ module Hoodle.Accessor where  import           Control.Applicative-import           Control.Lens (Simple,Lens,view,set)+import           Control.Concurrent.STM (readTVarIO)+import           Control.Lens (Simple,Lens,view,set,(.~)) import           Control.Monad hiding (mapM_, forM_)+import           Control.Monad.IO.Class import qualified Control.Monad.State as St hiding (mapM_, forM_)-import           Control.Monad.Trans import           Data.Foldable import qualified Data.IntMap as M-import           Graphics.UI.Gtk hiding (get,set)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import qualified Graphics.UI.Gtk as Gtk -- from hoodle-platform  import           Data.Hoodle.Generic import           Data.Hoodle.Select import           Graphics.Hoodle.Render.Type -- from this package--- import           Hoodle.GUI.Menu--- import           Hoodle.GUI.Reflect import           Hoodle.ModelAction.Layer  import           Hoodle.Type import           Hoodle.Type.Alias@@ -41,6 +46,20 @@ updateXState :: (HoodleState -> MainCoroutine HoodleState) -> MainCoroutine () updateXState action = St.put =<< action =<< St.get  +-- | update unitHoodle+updateUhdl :: (UnitHoodle -> MainCoroutine UnitHoodle) -> MainCoroutine ()+updateUhdl action = do xst <- St.get+                       let uhdl = view (unitHoodles.currentUnit) xst+                       uhdl' <- action uhdl+                       St.put (set (unitHoodles.currentUnit) uhdl' xst)++-- | update unitHoodle+pureUpdateUhdl :: (UnitHoodle -> UnitHoodle) -> MainCoroutine ()+pureUpdateUhdl func = do xst <- St.get+                         let uhdl = (func . view (unitHoodles.currentUnit)) xst+                         St.put ((unitHoodles.currentUnit .~ uhdl) xst)++ -- |  getPenType :: MainCoroutine PenType  getPenType = view (penInfo.penType) <$> St.get@@ -49,16 +68,18 @@ getCurrentPageCurr :: MainCoroutine (Page EditMode)  getCurrentPageCurr = do    xstate <- St.get -  let hdlmodst = view hoodleModeState xstate-      cinfobox = view currentCanvasInfo xstate +  let uhdl = view (unitHoodles.currentUnit) xstate+      hdlmodst = view hoodleModeState uhdl+      cinfobox = view currentCanvasInfo uhdl   return $ forBoth' unboxBiAct (flip getCurrentPageFromHoodleModeState hdlmodst) cinfobox  -- |  getCurrentPageCvsId :: CanvasId -> MainCoroutine (Page EditMode)  getCurrentPageCvsId cid = do    xstate <- St.get -  let hdlmodst = view hoodleModeState xstate-      cinfobox = getCanvasInfo cid xstate +  let uhdl = view (unitHoodles.currentUnit) xstate+      hdlmodst = view hoodleModeState uhdl+      cinfobox = getCanvasInfo cid uhdl   return $ forBoth' unboxBiAct (flip getCurrentPageFromHoodleModeState hdlmodst) cinfobox  @@ -82,22 +103,22 @@ rItmsInCurrLyr = return . view gitems . getCurrentLayer =<< getCurrentPageCurr        -- |-otherCanvas :: HoodleState -> [Int] -otherCanvas = M.keys . getCanvasInfoMap +otherCanvas :: UnitHoodle -> [Int] +otherCanvas = M.keys . view cvsInfoMap    -- | apply an action to all canvases  applyActionToAllCVS :: (CanvasId -> MainCoroutine ()) -> MainCoroutine ()  applyActionToAllCVS action = do    xstate <- St.get -  let cinfoMap  = getCanvasInfoMap xstate+  let cinfoMap = view (unitHoodles.currentUnit.cvsInfoMap) xstate       keys = M.keys cinfoMap    forM_ keys action  -- | -getCanvasGeometryCvsId :: CanvasId -> HoodleState -> IO CanvasGeometry -getCanvasGeometryCvsId cid xstate = do -  let cinfobox = getCanvasInfo cid xstate+getCanvasGeometryCvsId :: CanvasId -> UnitHoodle -> IO CanvasGeometry +getCanvasGeometryCvsId cid uhdl = do +  let cinfobox = getCanvasInfo cid uhdl       cpn = PageNum . view (unboxLens currentPageNum) $ cinfobox        canvas = view (unboxLens drawArea) cinfobox       fsingle :: CanvasInfo a -> IO CanvasGeometry @@ -106,9 +127,9 @@   forBoth' unboxBiAct fsingle cinfobox  -- |-getGeometry4CurrCvs :: HoodleState -> IO CanvasGeometry -getGeometry4CurrCvs xstate = do -  let cinfobox = view currentCanvasInfo xstate+getGeometry4CurrCvs :: UnitHoodle -> IO CanvasGeometry +getGeometry4CurrCvs uhdl = do +  let cinfobox = view currentCanvasInfo uhdl       cpn = PageNum . view (unboxLens currentPageNum) $ cinfobox        canvas = view (unboxLens drawArea) cinfobox       fsingle :: CanvasInfo a -> IO CanvasGeometry @@ -116,41 +137,45 @@                 . view (viewInfo.pageArrangement)    forBoth' unboxBiAct fsingle cinfobox -  --- | update flag in HoodleState when corresponding toggle UI changed -updateFlagFromToggleUI :: String  -- ^ UI toggle button id-                       -> Simple Lens HoodleState Bool -- ^ lens for flag -                       -> MainCoroutine Bool-updateFlagFromToggleUI toggleid lensforflag = do -  xstate <- St.get -  let ui = view gtkUIManager xstate -  agr <- liftIO ( uiManagerGetActionGroups ui >>= \x ->-                    case x of -                      [] -> error "No action group? "-                      y:_ -> return y )-  togglea <- liftIO (actionGroupGetAction agr toggleid) -             >>= maybe (error "updateFlagFromToggleUI") -                       (return . castToToggleAction)-  b <- liftIO $ toggleActionGetActive togglea-  St.modify (set lensforflag b) -  return b  + + -- | set toggle UI button to the corresponding HoodleState -setToggleUIForFlag :: String -                   -> Simple Lens HoodleState Bool -- ^ lens for flag-                   -> HoodleState -                   -> IO Bool -setToggleUIForFlag toggleid lensforflag xstate = do +lensSetToggleUIForFlag :: String +                       -> Simple Lens HoodleState Bool -- ^ lens for flag+                       -> HoodleState +                       -> IO Bool +lensSetToggleUIForFlag toggleid lensforflag xstate =+  let b = view lensforflag xstate in setToggleUIForFlag toggleid b xstate++-- | set toggle UI button to the corresponding HoodleState +setToggleUIForFlag :: String -> Bool -> HoodleState -> IO Bool +setToggleUIForFlag toggleid b xstate = do    let ui = view gtkUIManager xstate -      b = view lensforflag xstate -  agr <- uiManagerGetActionGroups ui >>= \x ->+  agr <- Gtk.uiManagerGetActionGroups ui >>= \x ->            case x of               [] -> error "No action group? "              y:_ -> return y -  togglea <- actionGroupGetAction agr toggleid >>= \(Just x) -> -                return (castToToggleAction x) -  toggleActionSetActive togglea b+  togglea <- Gtk.actionGroupGetAction agr toggleid >>= \(Just x) -> +                return (Gtk.castToToggleAction x) +  Gtk.toggleActionSetActive togglea b   return b   +-- |+renderCache :: MainCoroutine RenderCache+renderCache = (view renderCacheVar <$> St.get) >>= liftIO . readTVarIO +-- |+getHoodleFilePath :: UnitHoodle -> Maybe FilePath +getHoodleFilePath = fileStore2Maybe . view (hoodleFileControl.hoodleFileName) ++-- |+fileStore2Maybe :: FileStore -> Maybe FilePath +fileStore2Maybe (LocalDir Nothing)         = Nothing+fileStore2Maybe (LocalDir (Just filename)) = Just filename+fileStore2Maybe (TempDir filename)         = Just filename++-- |+getHoodleID :: UnitHoodle -> T.Text+getHoodleID = TE.decodeUtf8 . view ghoodleID . getHoodle
src/Hoodle/Config.hs view
@@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module      : Hoodle.Config --- Copyright   : (c) 2011-2013 Ian-Woo Kim+-- Copyright   : (c) 2011-2014 Ian-Woo Kim -- -- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>@@ -62,17 +62,25 @@     (mpanzoom :: Maybe String) <- C.lookup c "PanZoomWidget"     (mlayer :: Maybe String) <- C.lookup c "LayerWidget" -    let panzoom = maybe True (parse "PanZoomWidget") mpanzoom -        layer = maybe True (parse "LayerWidget") mlayer+    let panzoom = maybe True (parseBool "PanZoomWidget") mpanzoom +        layer = maybe True (parseBool "LayerWidget") mlayer              print ("WidgetConfig =" ++ show (panzoom,layer) )     return (panzoom,layer)-  where parse msg str = case str of-                          "true" -> True-                          "false" -> False -                          _ -> error ("cannot understand " ++ msg ++ " in configfile") +parseBool :: String -> String -> Bool+parseBool msg str = case str of+                      "true" -> True+                      "false" -> False +                      _ -> error ("cannot understand " ++ msg ++ " in configfile")+          +getPenConfig :: Config -> IO Bool+getPenConfig c = do+    (mvcursor :: Maybe String) <- C.lookup c "variablecursor"+    let vcursor = maybe False (parseBool "variablecursor") mvcursor+    return vcursor+       {- getNetworkInfo :: Config -> IO (Maybe HoodleClipClientConfiguration)
src/Hoodle/Coroutine/Commit.hs view
@@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      : Hoodle.Coroutine.Commit --- Copyright   : (c) 2011-2014 Ian-Woo Kim+-- Copyright   : (c) 2011-2015 Ian-Woo Kim -- -- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>@@ -12,74 +12,73 @@  module Hoodle.Coroutine.Commit where -import Control.Lens (view,set)+import Control.Lens (view,set,(.~)) import Control.Monad.Trans import Control.Monad.State -- from this package+import Hoodle.Accessor import Hoodle.Coroutine.Draw -import Hoodle.ModelAction.File+import Hoodle.GUI.Reflect import Hoodle.ModelAction.Page import Hoodle.Type.Coroutine import Hoodle.Type.HoodleState -import Hoodle.Type.Undo +import Hoodle.Type.Undo+import Hoodle.Util  -- | save state and add the current status in undo history - commit :: HoodleState -> MainCoroutine ()  commit xstate = do +  put xstate   let ui = view gtkUIManager xstate-  liftIO $ toggleSave ui True-  let hdlmodst = view hoodleModeState xstate-      undotable = view undoTable xstate -      undotable' = addToUndo undotable hdlmodst-      xstate' = set isSaved False -                . set undoTable undotable'-                $ xstate-  put xstate' +  liftIO $ reflectUIToggle ui "SAVEA" True+  pureUpdateUhdl $ \uhdl -> +    let hdlmodst = view hoodleModeState uhdl+        undotable = view undoTable uhdl+        undotable' = addToUndo undotable hdlmodst+    in ((isSaved .~ False) . (undoTable .~ undotable')) uhdl  -- | -   commit_ :: MainCoroutine () commit_ = get >>= commit   -- | - undo :: MainCoroutine ()  undo = do      xstate <- get-    let utable = view undoTable xstate-        cache = view renderCache xstate+    let uhdl = view (unitHoodles.currentUnit) xstate+    let utable = view undoTable uhdl     case getPrevUndo utable of -      Nothing -> liftIO $ putStrLn "no undo item yet"-      Just (hdlmodst1,newtable) -> do -        hdlmodst <- liftIO $ resetHoodleModeStateBuffers cache hdlmodst1 -        put . set hoodleModeState hdlmodst-            . set undoTable newtable -            =<< (liftIO (updatePageAll hdlmodst xstate))+      Nothing -> msgShout "no undo item yet"+      Just (hdlmodst,newtable) -> do +        let cid = getCurrentCanvasId uhdl+        callRenderer_ $ resetHoodleModeStateBuffers cid hdlmodst+        updateUhdl $ \uhdl' -> do+          uhdl'' <- liftIO (updatePageAll hdlmodst uhdl')+          return $ ( (hoodleModeState .~ hdlmodst) . (undoTable .~ newtable)) uhdl''         invalidateAll         -- |       -   redo :: MainCoroutine ()  redo = do      xstate <- get-    let utable = view undoTable xstate-        cache = view renderCache xstate+    let uhdl = view (unitHoodles.currentUnit) xstate+        utable = view undoTable uhdl+        cid = getCurrentCanvasId uhdl     case getNextUndo utable of -      Nothing -> liftIO $ putStrLn "no redo item"-      Just (hdlmodst1,newtable) -> do -        hdlmodst <- liftIO $ resetHoodleModeStateBuffers cache hdlmodst1-        put . set hoodleModeState hdlmodst-            . set undoTable newtable -            =<< (liftIO (updatePageAll hdlmodst xstate))+      Nothing -> msgShout "no redo item"+      Just (hdlmodst,newtable) -> do +        callRenderer_ $ resetHoodleModeStateBuffers cid hdlmodst+        updateUhdl $ \uhdl' -> do +          uhdl'' <- liftIO (updatePageAll hdlmodst uhdl')+          let uhdl''' = ( set hoodleModeState hdlmodst+                       . set undoTable newtable ) uhdl'' +          return uhdl'''          invalidateAll   -- |           clearUndoHistory :: MainCoroutine () -clearUndoHistory = do -    xstate <- get-    put . set undoTable (emptyUndo 1) $ xstate+clearUndoHistory = pureUpdateUhdl (undoTable .~ (emptyUndo 1))
src/Hoodle/Coroutine/ContextMenu.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -5,9 +6,9 @@ ----------------------------------------------------------------------------- -- | -- Module      : Hoodle.Coroutine.ContextMenu--- Copyright   : (c) 2011-2014 Ian-Woo Kim+-- Copyright   : (c) 2011-2015 Ian-Woo Kim ----- License     : GPL-3+-- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com> -- Stability   : experimental -- Portability : GHC@@ -18,7 +19,8 @@  -- from other packages import           Control.Applicative-import           Control.Lens (view,set,(%~),(^.))+import           Control.Concurrent.STM (readTVarIO)+import           Control.Lens (view,set,(^.),(.~)) import           Control.Monad.State hiding (mapM_,forM_) import           Control.Monad.Trans.Maybe import qualified Data.ByteString.Char8 as B@@ -31,14 +33,11 @@ import qualified Data.Text as T (unpack, splitAt) import qualified Data.Text.Encoding as TE import qualified Graphics.Rendering.Cairo as Cairo--- import qualified Graphics.Rendering.Cairo.SVG as RSVG-import           Graphics.UI.Gtk hiding (get,set)+import qualified Graphics.UI.Gtk as Gtk import           System.Directory  import           System.FilePath import           System.Process -- from hoodle-platform-import           Control.Monad.Trans.Crtn.Event-import           Control.Monad.Trans.Crtn.Queue  import           Data.Hoodle.BBox import           Data.Hoodle.Generic import           Data.Hoodle.Select@@ -79,29 +78,27 @@  processContextMenu :: ContextMenuEvent -> MainCoroutine ()  processContextMenu (CMenuSaveSelectionAs ityp) = do -  xst <- get-  forM_ (getSelectedItmsFromHoodleState xst) -        (\hititms->  -           let ulbbox = (unUnion . mconcat . fmap (Union . Middle . getBBox)) hititms -           in case ulbbox of -                Middle bbox -> -                  case ityp of -                    TypSVG -> exportCurrentSelectionAsSVG hititms bbox-                    TypPDF -> exportCurrentSelectionAsPDF hititms bbox-                _ -> return () -        )+    mhititms <- getSelectedItmsFromUnitHoodle . view (unitHoodles.currentUnit) <$> get+    forM_ mhititms $ \hititms->  +      let ulbbox = (unUnion . mconcat . fmap (Union . Middle . getBBox)) hititms +      in case ulbbox of +           Middle bbox -> +             case ityp of +               TypSVG -> exportCurrentSelectionAsSVG hititms bbox+               TypPDF -> exportCurrentSelectionAsPDF hititms bbox+           _ -> return () processContextMenu CMenuCut = cutSelection processContextMenu CMenuCopy = copySelection processContextMenu CMenuDelete = deleteSelection processContextMenu (CMenuCanvasView cid pnum _x _y) = do -    xstate <- get -    let cmap =  xstate ^. cvsInfoMap -    let mcinfobox = IM.lookup cid cmap +    uhdl <- view (unitHoodles.currentUnit) <$> get +    let cmap =  uhdl ^. cvsInfoMap +        mcinfobox = IM.lookup cid cmap      case mcinfobox of -      Nothing -> liftIO $ putStrLn "error in processContextMenu"+      Nothing -> msgShout "error in processContextMenu"       Just _cinfobox -> do -        cinfobox' <- liftIO (setPage xstate pnum cid)-        put $ set cvsInfoMap (IM.adjust (const cinfobox') cid cmap) xstate +        cinfobox' <- liftIO (setPage uhdl pnum cid)+        pureUpdateUhdl (cvsInfoMap .~ IM.adjust (const cinfobox') cid cmap)         adjustScrollbarWithGeometryCvsId cid          invalidateAll  processContextMenu (CMenuRotate dir imgbbx) = rotateImage dir imgbbx@@ -113,12 +110,11 @@       hset <- xst ^. hookSet        customAutosavePage hset <*> pure pg  processContextMenu (CMenuLinkConvert nlnk) = -    either (const (return ())) action -      . hoodleModeStateEither -      . (^. hoodleModeState) =<< get +    either_ action . hoodleModeStateEither . (^. hoodleModeState) . view (unitHoodles.currentUnit)  =<< get    where action thdl = do            xst <- get -          let cache = xst ^. renderCache+          let uhdl = view (unitHoodles.currentUnit) xst+              cid = getCurrentCanvasId uhdl           case thdl ^. gselSelected of              Nothing -> return ()              Just (n,tpg) -> do @@ -135,48 +131,51 @@                       layer' = GLayer buf . TEitherAlterHitted . Right $ alist'                   return (set (glayers.selectedLayer) layer' tpg)                 Right _ -> error "processContextMenu: activelayer"-              nthdl <- liftIO $ updateTempHoodleSelectIO cache thdl ntpg n-              commit . set hoodleModeState (SelectState nthdl)-                =<< (liftIO (updatePageAll (SelectState nthdl) xst))+              nthdl <- updateTempHoodleSelectM cid thdl ntpg n+              uhdl' <- liftIO $ updatePageAll (SelectState nthdl) uhdl+              commit $ (unitHoodles.currentUnit .~ uhdl') xst               invalidateAll  processContextMenu CMenuCreateALink = -  fileChooser FileChooserActionOpen Nothing >>= mapM_ linkSelectionWithFile+  fileChooser Gtk.FileChooserActionOpen Nothing >>= mapM_ linkSelectionWithFile processContextMenu CMenuAssocWithNewFile = do   xst <- get    let msuggestedact = xst ^. hookSet >>= fileNameSuggestionHook    (msuggested :: Maybe String) <- maybe (return Nothing) (liftM Just . liftIO) msuggestedact    -  fileChooser FileChooserActionSave msuggested >>=   +  fileChooser Gtk.FileChooserActionSave msuggested >>=        mapM_ (\fp -> do                b <- liftIO (doesFileExist fp)               if b                  then okMessageBox "The file already exist!"                 else do -                  let action = mkIOaction $ \_ -> do                      -                        nhdl <- liftIO $ defaultHoodle   -                        (L.writeFile fp . builder) nhdl -                        createProcess (proc "hoodle" [fp]) -                        return (UsrEv ActionOrdered)-                  modify (tempQueue %~ enqueue action) -                  waitSomeEvent (\x -> case x of ActionOrdered -> True ; _ -> False)+                  doIOaction_ $ do                      +                    nhdl <- liftIO $ defaultHoodle   +                    (L.writeFile fp . builder) nhdl +                    createProcess (proc "hoodle" [fp])                    linkSelectionWithFile fp                    return ()           )  processContextMenu (CMenuMakeLinkToAnchor anc) = do      xst <- get     uuidbstr <- liftIO $ B.pack . show <$> nextRandom-    docidbstr <- view ghoodleID . getHoodle <$> get-    let mloc = view (hoodleFileControl.hoodleFileName) xst+    let uhdl = view (unitHoodles.currentUnit) xst +        docidbstr = (view ghoodleID . getHoodle) uhdl+        mloc = case view (hoodleFileControl.hoodleFileName) uhdl of+                 LocalDir Nothing -> Nothing+                 LocalDir (Just fp) -> Just fp+                 TempDir _ -> Nothing         loc = maybe "" B.pack mloc-    let lnk = LinkAnchor uuidbstr docidbstr loc (anchor_id anc) "" (0,0) (Dim 50 50)+        lnk = LinkAnchor uuidbstr docidbstr loc (anchor_id anc) "" (0,0) (Dim 50 50)     callRenderer $ cnstrctRItem (ItemLink lnk) >>= return . GotRItem     RenderEv (GotRItem newitem) <-       waitSomeEvent (\case RenderEv (GotRItem _) -> True; _ -> False)     insertItemAt Nothing newitem  processContextMenu (CMenuPangoConvert (x0,y0) txt) = textInput (Just (x0,y0)) txt processContextMenu (CMenuLaTeXConvert (x0,y0) txt) = laTeXInput (Just (x0,y0)) txt+#ifdef HUB processContextMenu (CMenuLaTeXConvertNetwork (x0,y0) txt) = laTeXInputNetwork (Just (x0,y0)) txt-processContextMenu (CMenuLaTeXUpdate (x0,y0) key) = runMaybeT (laTeXInputKeyword (x0,y0) key) >> return ()+#endif+processContextMenu (CMenuLaTeXUpdate (x0,y0) dim key) = runMaybeT (laTeXInputKeyword (x0,y0) (Just dim) key) >> return () processContextMenu (CMenuCropImage imgbbox) = cropImage imgbbox processContextMenu (CMenuExportHoodlet itm) = do     res <- handwritingRecognitionDialog@@ -192,15 +191,15 @@         let fp = hoodletdir </> str <.> "hdlt"         L.writeFile fp (Hoodlet.builder itm)  processContextMenu (CMenuConvertSelection itm) = do-    xstate <- get -    let pgnum = view (currentCanvasInfo . unboxLens currentPageNum) xstate +    uhdl <- view (unitHoodles.currentUnit) <$> get +    let pgnum = view (currentCanvasInfo . unboxLens currentPageNum) uhdl     deleteSelection     callRenderer $ return . GotRItem =<< cnstrctRItem itm     RenderEv (GotRItem newitem) <- waitSomeEvent (\case RenderEv (GotRItem _) -> True; _ -> False)      let BBox (x0,y0) _ = getBBox newitem     insertItemAt (Just (PageNum pgnum, PageCoord (x0,y0))) newitem processContextMenu CMenuCustom =  do-    either (const (return ())) action . hoodleModeStateEither . view hoodleModeState =<< get +    either_ action . hoodleModeStateEither . view hoodleModeState . view (unitHoodles.currentUnit) =<< get    where action thdl = do               xst <- get            forM_ (view gselSelected thdl) @@ -213,27 +212,28 @@ --  |  linkSelectionWithFile :: FilePath -> MainCoroutine ()   linkSelectionWithFile fname = do-  liftM getSelectedItmsFromHoodleState get >>=  -    mapM_ (\hititms -> -            let ulbbox = (unUnion . mconcat . fmap (Union . Middle . getBBox)) hititms -            in case ulbbox of -              Middle bbox -> do -                cache <- view renderCache <$> get -                svg <- liftIO $ makeSVGFromSelection cache hititms bbox-                uuid <- liftIO $ nextRandom-                let uuidbstr = B.pack (show uuid) -                deleteSelection -                linkInsert "simple" (uuidbstr,fname) fname (svg_render svg,bbox)  -              _ -> return () )+  uhdl <- view (unitHoodles.currentUnit) <$> get+  let cid = getCurrentCanvasId uhdl+  forM_ (getSelectedItmsFromUnitHoodle uhdl) $ \hititms -> +    let ulbbox = (unUnion . mconcat . fmap (Union . Middle . getBBox)) hititms +    in case ulbbox of +         Middle bbox -> do +           cache <- renderCache+           svg <- liftIO $ makeSVGFromSelection cache cid hititms bbox+           uuid <- liftIO $ nextRandom+           let uuidbstr = B.pack (show uuid) +           deleteSelection +           linkInsert "simple" (uuidbstr,fname) fname (svg_render svg,bbox)+         _ -> return ()              -- |  exportCurrentSelectionAsSVG :: [RItem] -> BBox -> MainCoroutine ()  exportCurrentSelectionAsSVG hititms bbox@(BBox (ulx,uly) (lrx,lry)) = -    fileChooser FileChooserActionSave Nothing >>= maybe (return ()) action +    fileChooser Gtk.FileChooserActionSave Nothing >>= mapM_ action    where      action filename = do-      cache <- view renderCache <$> get+      (cache,cid) <- (,) <$> renderCache <*> (getCurrentCanvasId . view (unitHoodles.currentUnit) <$> get)       -- this is rather temporary not to make mistake        if takeExtension filename /= ".svg"          then fileExtensionInvalid (".svg","export") @@ -242,15 +242,15 @@           liftIO $ Cairo.withSVGSurface filename (lrx-ulx) (lry-uly) $ \s ->              Cairo.renderWith s $ do                Cairo.translate (-ulx) (-uly)-              mapM_ (renderRItem cache) hititms+              mapM_ (renderRItem cache cid) hititms   exportCurrentSelectionAsPDF :: [RItem] -> BBox -> MainCoroutine ()  exportCurrentSelectionAsPDF hititms bbox@(BBox (ulx,uly) (lrx,lry)) = -    fileChooser FileChooserActionSave Nothing >>= maybe (return ()) action +    fileChooser Gtk.FileChooserActionSave Nothing >>= mapM_ action    where      action filename = do-      cache <- view renderCache <$> get+      (cache,cid) <- (,) <$> renderCache <*> (getCurrentCanvasId . view (unitHoodles.currentUnit) <$> get)       -- this is rather temporary not to make mistake        if takeExtension filename /= ".pdf"          then fileExtensionInvalid (".svg","export") @@ -259,7 +259,7 @@           liftIO $ Cairo.withPDFSurface filename (lrx-ulx) (lry-uly) $ \s ->              Cairo.renderWith s $ do                Cairo.translate (-ulx) (-uly)-              mapM_ (renderRItem cache) hititms+              mapM_ (renderRItem cache cid) hititms  -- | exportImage :: S.Image -> MainCoroutine ()@@ -267,7 +267,7 @@      runMaybeT $ do      pngbstr <- (MaybeT . return . getByteStringIfEmbeddedPNG . S.img_src) img-    fp <- MaybeT (fileChooser FileChooserActionSave Nothing)  +    fp <- MaybeT (fileChooser Gtk.FileChooserActionSave Nothing)       liftIO $ B.writeFile fp pngbstr   return () @@ -276,216 +276,218 @@ showContextMenu (pnum,(x,y)) = do      xstate <- get     when (view (settings.doesUsePopUpMenu) xstate) $ do -      let cids = IM.keys . view cvsInfoMap $ xstate-          cid = fst . view currentCanvas $ xstate -          mselitms = do lst <- getSelectedItmsFromHoodleState xstate+      let uhdl = view (unitHoodles.currentUnit) xstate+          cids = IM.keys . view cvsInfoMap $ uhdl+          cid = fst . view currentCanvas $ uhdl +          mselitms = do lst <- getSelectedItmsFromUnitHoodle uhdl                         if null lst then Nothing else Just lst -      modify (tempQueue %~ enqueue (action xstate mselitms cid cids)) +      doIOaction (action xstate mselitms cid cids)       >> waitSomeEvent (\e->case e of ContextMenuCreated -> True ; _ -> False)        >> return ()    where -    action xstate msitms cid cids  -      = Left . ActionOrder $ \evhandler -> do -          menu <- menuNew -          menuSetTitle menu "MyMenu"-          case msitms of -            Nothing -> return ()-            Just sitms -> do -              menuitem1 <- menuItemNewWithLabel "Make SVG"-              menuitem2 <- menuItemNewWithLabel "Make PDF"-              menuitem3 <- menuItemNewWithLabel "Cut"-              menuitem4 <- menuItemNewWithLabel "Copy"-              menuitem5 <- menuItemNewWithLabel "Delete"-              menuitem6 <- menuItemNewWithLabel "New File Linked Here"-              menuitem1 `on` menuItemActivate $   -                evhandler (UsrEv (GotContextMenuSignal (CMenuSaveSelectionAs TypSVG)))-              menuitem2 `on` menuItemActivate $ -                evhandler (UsrEv (GotContextMenuSignal (CMenuSaveSelectionAs TypPDF)))-              menuitem3 `on` menuItemActivate $ -                evhandler (UsrEv (GotContextMenuSignal (CMenuCut)))-              menuitem4 `on` menuItemActivate $    -                evhandler (UsrEv (GotContextMenuSignal (CMenuCopy)))-              menuitem5 `on` menuItemActivate $    -                evhandler (UsrEv (GotContextMenuSignal (CMenuDelete)))-              menuitem6 `on` menuItemActivate $ -                evhandler (UsrEv (GotContextMenuSignal (CMenuAssocWithNewFile)))-              menuAttach menu menuitem1 0 1 1 2 -              menuAttach menu menuitem2 0 1 2 3-              menuAttach menu menuitem3 1 2 0 1                     -              menuAttach menu menuitem4 1 2 1 2                     -              menuAttach menu menuitem5 1 2 2 3    -              menuAttach menu menuitem6 1 2 3 4 -              mapM_ (\mi -> menuAttach menu mi 1 2 5 6) =<< menuCreateALink evhandler sitms -              case sitms of -                sitm : [] -> do -                  menuhdlt <- menuItemNewWithLabel "Make Hoodlet"-                  menuhdlt `on` menuItemActivate $ -                    ( evhandler . UsrEv . GotContextMenuSignal -                    . CMenuExportHoodlet . rItem2Item ) sitm-                  menuAttach menu menuhdlt 0 1 8 9-                  -                  case sitm of -                    RItemLink lnkbbx _msfc -> do -                      let lnk = bbxed_content lnkbbx-                      forM_ ((urlParse . B.unpack . link_location) lnk)-                            (\urlpath -> do milnk <- menuOpenALink urlpath-                                            menuAttach menu milnk 0 1 3 4 )-                      case lnk of -                        Link _i _typ _lstr _txt _cmd _rdr _pos _dim ->  -                          convertLinkFromSimpleToDocID lnk >>=  -                            mapM_ (\link -> do -                              let LinkDocID _ uuid _ _ _ _ _ _ = link -                              menuitemcvt <- menuItemNewWithLabel ("Convert Link With ID" ++ show uuid) -                              menuitemcvt `on` menuItemActivate $-                                ( evhandler -                                  . UsrEv -                                  . GotContextMenuSignal -                                  . CMenuLinkConvert ) link-                              menuAttach menu menuitemcvt 0 1 4 5 -                            ) -                        LinkDocID i lid file txt cmd rdr pos dim -> do -                          runMaybeT $ do  -                            hset <- (MaybeT . return . view hookSet) xstate-                            f <- (MaybeT . return . lookupPathFromId) hset-                            file' <- MaybeT (f (B.unpack lid))-                            guard ((B.unpack file) /= file')-                            let link = LinkDocID -                                         i lid (B.pack file') txt cmd rdr pos dim-                            menuitemcvt <- liftIO $ menuItemNewWithLabel -                              ("Correct Path to " ++ show file') -                            liftIO (menuitemcvt `on` menuItemActivate $ -                              ( evhandler -                                . UsrEv -                                . GotContextMenuSignal -                                . CMenuLinkConvert ) link)-                            liftIO $ menuAttach menu menuitemcvt 0 1 4 5 -                          return ()-                        LinkAnchor i lid file aid bstr pos dim -> do -                          runMaybeT $ do  -                            hset <- (MaybeT . return . view hookSet) xstate-                            f <- (MaybeT . return . lookupPathFromId) hset-                            file' <- MaybeT (f (B.unpack lid))-                            guard ((B.unpack file) /= file')-                            let link = LinkAnchor i lid (B.pack file') aid bstr pos dim-                            menuitemcvt <- liftIO $ menuItemNewWithLabel -                              ("Correct Path to " ++ show file') -                            liftIO (menuitemcvt `on` menuItemActivate $ -                              ( evhandler -                                . UsrEv -                                . GotContextMenuSignal -                                . CMenuLinkConvert) link)-                            liftIO $ menuAttach menu menuitemcvt 0 1 4 5 -                          return ()--                    RItemSVG svgbbx _msfc -> do-                      let svg = bbxed_content svgbbx-                          BBox (x0,y0) _ = getBBox svgbbx-                      forM_ ((,) <$> svg_text svg <*> svg_command svg) $ \(btxt,cmd) -> do-                        let txt = TE.decodeUtf8 btxt-                        case cmd of -                          "pango" -> do -                            menuitemedt <- menuItemNewWithLabel ("Edit Text") -                            menuitemedt `on` menuItemActivate $ do -                              evhandler (UsrEv (GotContextMenuSignal (CMenuPangoConvert (x0,y0) txt)))-                            menuAttach menu menuitemedt 0 1 4 5-                            return ()-                          "latex" -> do -                            menuitemedt <- menuItemNewWithLabel ("Edit LaTeX")-                            menuitemedt `on` menuItemActivate $ do-                              evhandler (UsrEv (GotContextMenuSignal (CMenuLaTeXConvert (x0,y0) txt)))-                            menuAttach menu menuitemedt 0 1 4 5 -                            ---                            menuitemnet <- menuItemNewWithLabel ("Edit LaTeX Network")-                            menuitemnet `on` menuItemActivate $ do-                              evhandler (UsrEv (GotContextMenuSignal (CMenuLaTeXConvertNetwork (x0,y0) txt)))-                            menuAttach menu menuitemnet 0 1 5 6-                            return ()-                            -- -                            let (txth,txtt) = T.splitAt 19 txt -                            when ( txth == "embedlatex:keyword:" ) $ do-                              menuitemup <- menuItemNewWithLabel ("Update LaTeX")-                              menuitemup `on` menuItemActivate $ do-                                evhandler (UsrEv (GotContextMenuSignal (CMenuLaTeXUpdate (x0,y0) txtt)))-                              menuAttach menu menuitemup 0 1 6 7-                              return ()+    action xstate msitms cid cids evhandler = do +      menu <- Gtk.menuNew +      Gtk.menuSetTitle menu ("MyMenu" :: String)+      case msitms of +        Nothing -> return ()+        Just sitms -> do +          menuitem1 <- Gtk.menuItemNewWithLabel ("Make SVG" :: String)+          menuitem2 <- Gtk.menuItemNewWithLabel ("Make PDF" :: String)+          menuitem3 <- Gtk.menuItemNewWithLabel ("Cut" :: String)+          menuitem4 <- Gtk.menuItemNewWithLabel ("Copy" :: String)+          menuitem5 <- Gtk.menuItemNewWithLabel ("Delete" :: String)+          menuitem6 <- Gtk.menuItemNewWithLabel ("New File Linked Here" :: String)+          menuitem1 `Gtk.on` Gtk.menuItemActivate $   +            evhandler (UsrEv (GotContextMenuSignal (CMenuSaveSelectionAs TypSVG)))+          menuitem2 `Gtk.on` Gtk.menuItemActivate $ +            evhandler (UsrEv (GotContextMenuSignal (CMenuSaveSelectionAs TypPDF)))+          menuitem3 `Gtk.on` Gtk.menuItemActivate $ +            evhandler (UsrEv (GotContextMenuSignal (CMenuCut)))+          menuitem4 `Gtk.on` Gtk.menuItemActivate $    +            evhandler (UsrEv (GotContextMenuSignal (CMenuCopy)))+          menuitem5 `Gtk.on` Gtk.menuItemActivate $    +            evhandler (UsrEv (GotContextMenuSignal (CMenuDelete)))+          menuitem6 `Gtk.on` Gtk.menuItemActivate $ +            evhandler (UsrEv (GotContextMenuSignal (CMenuAssocWithNewFile)))+          Gtk.menuAttach menu menuitem1 0 1 1 2 +          Gtk.menuAttach menu menuitem2 0 1 2 3+          Gtk.menuAttach menu menuitem3 1 2 0 1                     +          Gtk.menuAttach menu menuitem4 1 2 1 2                     +          Gtk.menuAttach menu menuitem5 1 2 2 3    +          Gtk.menuAttach menu menuitem6 1 2 3 4 +          mapM_ (\mi -> Gtk.menuAttach menu mi 1 2 5 6) =<< menuCreateALink evhandler sitms +          case sitms of +            sitm : [] -> do +              menuhdlt <- Gtk.menuItemNewWithLabel ("Make Hoodlet" :: String)+              menuhdlt `Gtk.on` Gtk.menuItemActivate $ +                ( evhandler . UsrEv . GotContextMenuSignal +                . CMenuExportHoodlet . rItem2Item ) sitm+              Gtk.menuAttach menu menuhdlt 0 1 8 9 -                          _ -> return ()-                    RItemImage imgbbx _msfc -> do-                      menuitemcrop <- menuItemNewWithLabel ("Crop Image") -                      menuitemcrop `on` menuItemActivate $ do -                        (evhandler . UsrEv . GotContextMenuSignal . CMenuCropImage) imgbbx-                      menuitemrotcw <- menuItemNewWithLabel ("Rotate Image CW") -                      menuitemrotcw `on` menuItemActivate $ do -                        (evhandler . UsrEv . GotContextMenuSignal) (CMenuRotate CW imgbbx)-                      menuitemrotccw <- menuItemNewWithLabel ("Rotate Image CCW") -                      menuitemrotccw `on` menuItemActivate $ do -                        (evhandler . UsrEv . GotContextMenuSignal) (CMenuRotate CCW imgbbx)-                      menuitemexport <- menuItemNewWithLabel ("Export Image")-                      menuitemexport `on` menuItemActivate $ do-                        (evhandler . UsrEv . GotContextMenuSignal) (CMenuExport imgbbx)-                      -- -                      menuAttach menu menuitemcrop 0 1 4 5-                      menuAttach menu menuitemrotcw 0 1 5 6-                      menuAttach menu menuitemrotccw 0 1 6 7-                      menuAttach menu menuitemexport 0 1 7 8-                      -- +              case sitm of +                RItemLink lnkbbx _msfc -> do +                  let lnk = bbxed_content lnkbbx+                  forM_ ((urlParse . B.unpack . link_location) lnk)+                        (\urlpath -> do milnk <- menuOpenALink evhandler urlpath+                                        Gtk.menuAttach menu milnk 0 1 3 4 )+                  case lnk of +                    Link _i _typ _lstr _txt _cmd _rdr _pos _dim ->  +                      convertLinkFromSimpleToDocID lnk >>=  +                        mapM_ (\link -> do +                          let LinkDocID _ uuid _ _ _ _ _ _ = link +                          menuitemcvt <- Gtk.menuItemNewWithLabel ("Convert Link With ID" ++ show uuid :: String) +                          menuitemcvt `Gtk.on` Gtk.menuItemActivate $+                            ( evhandler +                              . UsrEv +                              . GotContextMenuSignal +                              . CMenuLinkConvert ) link+                          Gtk.menuAttach menu menuitemcvt 0 1 4 5 +                        ) +                    LinkDocID i lid file txt cmd rdr pos dim -> do +                      runMaybeT $ do  +                        hset <- (MaybeT . return . view hookSet) xstate+                        f <- (MaybeT . return . lookupPathFromId) hset+                        file' <- MaybeT (f (B.unpack lid))+                        guard ((B.unpack file) /= file')+                        let link = LinkDocID +                                     i lid (B.pack file') txt cmd rdr pos dim+                        menuitemcvt <- liftIO $ Gtk.menuItemNewWithLabel +                          ("Correct Path to " ++ show file' :: String) +                        liftIO (menuitemcvt `Gtk.on` Gtk.menuItemActivate $ +                          ( evhandler +                            . UsrEv +                            . GotContextMenuSignal +                            . CMenuLinkConvert ) link)+                        liftIO $ Gtk.menuAttach menu menuitemcvt 0 1 4 5                        return ()-                    RItemAnchor ancbbx _ -> do-                      menuitemmklnk <- menuItemNewWithLabel ("Link to this anchor")-                      menuitemmklnk `on` menuItemActivate $-                        ( evhandler -                        . UsrEv -                        . GotContextMenuSignal -                        . CMenuMakeLinkToAnchor -                        . bbxed_content) ancbbx-                      menuAttach menu menuitemmklnk 0 1 4 5 -                    _ -> return ()+                    LinkAnchor i lid file aid bstr pos dim -> do +                      runMaybeT $ do  +                        hset <- (MaybeT . return . view hookSet) xstate+                        f <- (MaybeT . return . lookupPathFromId) hset+                        file' <- MaybeT (f (B.unpack lid))+                        guard ((B.unpack file) /= file')+                        let link = LinkAnchor i lid (B.pack file') aid bstr pos dim+                        menuitemcvt <- liftIO $ Gtk.menuItemNewWithLabel +                          ("Correct Path to " ++ show file' :: String) +                        liftIO (menuitemcvt `Gtk.on` Gtk.menuItemActivate $ +                          ( evhandler +                            . UsrEv +                            . GotContextMenuSignal +                            . CMenuLinkConvert) link)+                        liftIO $ Gtk.menuAttach menu menuitemcvt 0 1 4 5 +                      return () -                _ -> do-                  let (links,others) = partition ((||) <$> isLinkInRItem <*> isAnchorInRItem) sitms -                  case links of -                    l : [] -> do-                      menuitemreplace <- menuItemNewWithLabel ("replace link/anchor render")-                      menuitemreplace `on` menuItemActivate $ do-                        let cache = xstate ^. renderCache-                            ulbbox = (unUnion . mconcat . fmap (Union . Middle . getBBox)) others-                        case ulbbox of -                          Middle bbox -> do-                            let BBox (x0,y0) (x1,y1) = bbox-                                dim = Dim (x1-x0) (y1-y0)-                            svg <- svg_render <$> makeSVGFromSelection cache others bbox-                            let mitm = case l of -                                  RItemLink lnkbbx _   -> (Just . ItemLink) ((bbxed_content lnkbbx) { link_render = svg, link_dim = dim })-                                  RItemAnchor ancbbx _ -> (Just . ItemAnchor) ((bbxed_content ancbbx) { anchor_render = svg, anchor_dim = dim })-                                  _ -> Nothing -                            maybe (return ()) (evhandler . UsrEv . GotContextMenuSignal . CMenuConvertSelection ) mitm-                          _ -> return ()-                      menuAttach menu menuitemreplace 0 1 8 9-                    _ -> return ()+                RItemSVG svgbbx _msfc -> do+                  let svg = bbxed_content svgbbx+                      BBox (x0,y0) (x1,y1) = getBBox svgbbx+                  forM_ ((,) <$> svg_text svg <*> svg_command svg) $ \(btxt,cmd) -> do+                    let txt = TE.decodeUtf8 btxt+                    case cmd of +                      "pango" -> do +                        menuitemedt <- Gtk.menuItemNewWithLabel ("Edit Text" :: String) +                        menuitemedt `Gtk.on` Gtk.menuItemActivate $ do +                          evhandler (UsrEv (GotContextMenuSignal (CMenuPangoConvert (x0,y0) txt)))+                        Gtk.menuAttach menu menuitemedt 0 1 4 5+                        return ()+                      "latex" -> do +                        menuitemedt <- Gtk.menuItemNewWithLabel ("Edit LaTeX" :: String)+                        menuitemedt `Gtk.on` Gtk.menuItemActivate $ do+                          evhandler (UsrEv (GotContextMenuSignal (CMenuLaTeXConvert (x0,y0) txt)))+                        Gtk.menuAttach menu menuitemedt 0 1 4 5 +                        --+#ifdef HUB+                        menuitemnet <- Gtk.menuItemNewWithLabel ("Edit LaTeX Network" :: String)+                        menuitemnet `Gtk.on` Gtk.menuItemActivate $ do+                          evhandler (UsrEv (GotContextMenuSignal (CMenuLaTeXConvertNetwork (x0,y0) txt)))+                        Gtk.menuAttach menu menuitemnet 0 1 5 6+                        return ()+#endif+                        -- +                        let (txth,txtt) = T.splitAt 19 txt +                        when ( txth == "embedlatex:keyword:" ) $ do+                          menuitemup <- Gtk.menuItemNewWithLabel ("Update LaTeX" :: String)+                          menuitemup `Gtk.on` Gtk.menuItemActivate $ do+                            evhandler (UsrEv (GotContextMenuSignal (CMenuLaTeXUpdate (x0,y0) (Dim (x1-x0) (y1-y0)) txtt)))+                          Gtk.menuAttach menu menuitemup 0 1 6 7+                          return () -          case (customContextMenuTitle =<< view hookSet xstate) of -            Nothing -> return () -            Just ttl -> do -              custommenu <- menuItemNewWithLabel ttl  -              custommenu `on` menuItemActivate $ -                evhandler (UsrEv (GotContextMenuSignal (CMenuCustom)))-              menuAttach menu custommenu 0 1 0 1 +                      _ -> return ()+                RItemImage imgbbx _msfc -> do+                  menuitemcrop <- Gtk.menuItemNewWithLabel ("Crop Image" :: String) +                  menuitemcrop `Gtk.on` Gtk.menuItemActivate $ do +                    (evhandler . UsrEv . GotContextMenuSignal . CMenuCropImage) imgbbx+                  menuitemrotcw <- Gtk.menuItemNewWithLabel ("Rotate Image CW" :: String) +                  menuitemrotcw `Gtk.on` Gtk.menuItemActivate $ do +                    (evhandler . UsrEv . GotContextMenuSignal) (CMenuRotate CW imgbbx)+                  menuitemrotccw <- Gtk.menuItemNewWithLabel ("Rotate Image CCW" :: String) +                  menuitemrotccw `Gtk.on` Gtk.menuItemActivate $ do +                    (evhandler . UsrEv . GotContextMenuSignal) (CMenuRotate CCW imgbbx)+                  menuitemexport <- Gtk.menuItemNewWithLabel ("Export Image" :: String)+                  menuitemexport `Gtk.on` Gtk.menuItemActivate $ do+                    (evhandler . UsrEv . GotContextMenuSignal) (CMenuExport imgbbx)+                  -- +                  Gtk.menuAttach menu menuitemcrop 0 1 4 5+                  Gtk.menuAttach menu menuitemrotcw 0 1 5 6+                  Gtk.menuAttach menu menuitemrotccw 0 1 6 7+                  Gtk.menuAttach menu menuitemexport 0 1 7 8+                  -- +                  return ()+                RItemAnchor ancbbx _ -> do+                  menuitemmklnk <- Gtk.menuItemNewWithLabel ("Link to this anchor" :: String)+                  menuitemmklnk `Gtk.on` Gtk.menuItemActivate $+                    ( evhandler +                    . UsrEv +                    . GotContextMenuSignal +                    . CMenuMakeLinkToAnchor +                    . bbxed_content) ancbbx+                  Gtk.menuAttach menu menuitemmklnk 0 1 4 5 +                _ -> return () -          menuitem8 <- menuItemNewWithLabel "Autosave This Page Image"-          menuitem8 `on` menuItemActivate $ -            evhandler (UsrEv (GotContextMenuSignal (CMenuAutosavePage)))-          menuAttach menu menuitem8 1 2 4 5 +            _ -> do+              let (links,others) = partition ((||) <$> isLinkInRItem <*> isAnchorInRItem) sitms +              case links of +                l : [] -> do+                  menuitemreplace <- Gtk.menuItemNewWithLabel ("replace link/anchor render" :: String)+                  menuitemreplace `Gtk.on` Gtk.menuItemActivate $ do+                    cache <- readTVarIO (xstate ^. renderCacheVar)+                    let ulbbox = (unUnion . mconcat . fmap (Union . Middle . getBBox)) others+                    case ulbbox of +                      Middle bbox -> do+                        let BBox (x0,y0) (x1,y1) = bbox+                            dim = Dim (x1-x0) (y1-y0)+                        svg <- svg_render <$> makeSVGFromSelection cache cid others bbox+                        let mitm = case l of +                              RItemLink lnkbbx _   -> (Just . ItemLink) ((bbxed_content lnkbbx) { link_render = svg, link_dim = dim })+                              RItemAnchor ancbbx _ -> (Just . ItemAnchor) ((bbxed_content ancbbx) { anchor_render = svg, anchor_dim = dim })+                              _ -> Nothing +                        maybe (return ()) (evhandler . UsrEv . GotContextMenuSignal . CMenuConvertSelection ) mitm+                      _ -> return ()+                  Gtk.menuAttach menu menuitemreplace 0 1 8 9+                _ -> return () -          runStateT (mapM_ (makeMenu evhandler menu cid) cids) 0 -          widgetShowAll menu -          menuPopup menu Nothing -          return (UsrEv ContextMenuCreated)+      case (customContextMenuTitle =<< view hookSet xstate) of +        Nothing -> return () +        Just ttl -> do +          custommenu <- Gtk.menuItemNewWithLabel ttl  +          custommenu `Gtk.on` Gtk.menuItemActivate $ +            evhandler (UsrEv (GotContextMenuSignal (CMenuCustom)))+          Gtk.menuAttach menu custommenu 0 1 0 1  +      menuitem8 <- Gtk.menuItemNewWithLabel ("Autosave This Page Image" :: String)+      menuitem8 `Gtk.on` Gtk.menuItemActivate $ +        evhandler (UsrEv (GotContextMenuSignal (CMenuAutosavePage)))+      Gtk.menuAttach menu menuitem8 1 2 4 5 ++      runStateT (mapM_ (makeMenu evhandler menu cid) cids) 0 +      Gtk.widgetShowAll menu +      Gtk.menuPopup menu Nothing +      return (UsrEv ContextMenuCreated)+     makeMenu evhdlr mn currcid cid = when (currcid /= cid) $ do        n <- get-      mi <- liftIO $ menuItemNewWithLabel ("Show here in cvs" ++ show cid)-      liftIO $ mi `on` menuItemActivate $ +      mi <- liftIO $ Gtk.menuItemNewWithLabel ("Show here in cvs" ++ show cid)+      liftIO $ mi `Gtk.on` Gtk.menuItemActivate $          evhdlr (UsrEv (GotContextMenuSignal (CMenuCanvasView cid pnum x y)))-      liftIO $ menuAttach mn mi 2 3 n (n+1) +      liftIO $ Gtk.menuAttach mn mi 2 3 n (n+1)        put (n+1)
src/Hoodle/Coroutine/Default.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-}@@ -7,9 +8,9 @@ ----------------------------------------------------------------------------- -- | -- Module      : Hoodle.Coroutine.Default --- Copyright   : (c) 2011-2014 Ian-Woo Kim+-- Copyright   : (c) 2011-2015 Ian-Woo Kim ----- License     : GPL-3+-- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com> -- Stability   : experimental -- Portability : GHC@@ -20,67 +21,53 @@  import           Control.Applicative hiding (empty) import           Control.Concurrent -import           Control.Concurrent.STM-import           Control.Lens (_1,over,view,set,at,(.~),(%~),(^.))--- import           Control.Monad.Reader hiding (mapM_)+import qualified Control.Exception as E+import           Control.Lens (over,view,set,at,(.~),(^.),_2) import           Control.Monad.State hiding (mapM_) import           Control.Monad.Trans.Reader (ReaderT(..)) import qualified Data.ByteString.Char8 as B import           Data.Foldable (mapM_) import qualified Data.IntMap as M import           Data.IORef +import qualified Data.List as L import           Data.Maybe-import           Data.Monoid ((<>))-import           Data.Sequence (Seq, (<|),(|>), empty, singleton, viewl, ViewL(..))-import qualified Data.Sequence as Seq (null)-import qualified Data.Text as T (unpack)-import           Data.Time.Clock-import           Data.UUID-import qualified Graphics.Rendering.Cairo as Cairo import qualified Graphics.UI.Gtk as Gtk hiding (get,set)-import qualified Graphics.UI.Gtk.Poppler.Document as Poppler-import qualified Graphics.UI.Gtk.Poppler.Page as Poppler import           System.Process +#ifdef HUB+import           Data.Time.Clock+import           System.Directory+#endif -- from hoodle-platform import           Control.Monad.Trans.Crtn.Driver import           Control.Monad.Trans.Crtn.Object import           Control.Monad.Trans.Crtn.Logger.Simple-import           Control.Monad.Trans.Crtn.Queue -import           Data.Hoodle.Select-import           Data.Hoodle.Simple (Dimension(..), Background(..), defaultHoodle)+import           Data.Hoodle.Simple (Dimension(..), Background(..)) import           Data.Hoodle.Generic import           Graphics.Hoodle.Render-import           Graphics.Hoodle.Render.Background+import           Graphics.Hoodle.Render.Engine import           Graphics.Hoodle.Render.Type -- from this package import           Hoodle.Accessor import           Hoodle.Coroutine.Callback-import           Hoodle.Coroutine.Commit import           Hoodle.Coroutine.ContextMenu+import           Hoodle.Coroutine.Default.Menu import           Hoodle.Coroutine.Draw import           Hoodle.Coroutine.Eraser import           Hoodle.Coroutine.File-import           Hoodle.Coroutine.HandwritingRecognition import           Hoodle.Coroutine.Highlighter-import           Hoodle.Coroutine.Layer  import           Hoodle.Coroutine.Link+import           Hoodle.Coroutine.Mode import           Hoodle.Coroutine.Page import           Hoodle.Coroutine.Pen import           Hoodle.Coroutine.Scroll import           Hoodle.Coroutine.Select-import           Hoodle.Coroutine.Select.Clipboard-import           Hoodle.Coroutine.TextInput -import           Hoodle.Coroutine.Mode import           Hoodle.Coroutine.VerticalSpace  import           Hoodle.Coroutine.Window import           Hoodle.Device import           Hoodle.GUI.Menu import           Hoodle.GUI.Reflect-import           Hoodle.ModelAction.File- import           Hoodle.ModelAction.Page import           Hoodle.ModelAction.Window -import           Hoodle.Script import           Hoodle.Script.Hook import           Hoodle.Type.Canvas import           Hoodle.Type.Coroutine@@ -88,14 +75,19 @@ import           Hoodle.Type.Event import           Hoodle.Type.HoodleState import           Hoodle.Type.PageArrangement-import           Hoodle.Type.Predefined import           Hoodle.Type.Undo import           Hoodle.Type.Window  import           Hoodle.Type.Widget-import           Hoodle.Widget.Clock+import           Hoodle.Util import           Hoodle.Widget.Dispatch -import           Hoodle.Widget.Layer import           Hoodle.Widget.PanZoom+#ifdef HUB+import           Hoodle.Coroutine.Dialog+import           Hoodle.Coroutine.HubInternal+import           Hoodle.Coroutine.Socket+import           Hoodle.Coroutine.TextInput +import           Hoodle.Type.Predefined+#endif -- import Prelude hiding (mapM_) @@ -104,143 +96,169 @@               -> Gtk.Window                -> Maybe Hook                -> Int -- ^ maxundo -              -> (Bool,Bool,Bool) -- ^ (xinputbool,usepz,uselyr)-              -> Gtk.Statusbar -- ^ status bar +              -> (Bool,Bool,Bool,Bool) -- ^ (xinputbool,usepz,uselyr,varcsr)               -> IO (EventVar,HoodleState,Gtk.UIManager,Gtk.VBox)-initCoroutine devlst window mhook maxundo (xinputbool,usepz,uselyr) stbar = do +initCoroutine devlst window mhook maxundo (xinputbool,usepz,uselyr,varcsr) = do    evar <- newEmptyMVar     putMVar evar Nothing +  let callback = eventHandler evar   st0new <- set deviceList devlst               . set rootOfRootWindow window -            . set callBack (eventHandler evar) +            . set callBack callback               <$> emptyHoodleState -  -- pdf rendering testing code-  let tvar = st0new ^. pdfRenderQueue-  --   (ui,uicompsighdlr) <- getMenuUI evar       let st1 = set gtkUIManager ui st0new       initcvs = set (canvasWidgets.widgetConfig.doesUsePanZoomWidget) usepz               . set (canvasWidgets.widgetConfig.doesUseLayerWidget) uselyr               $ defaultCvsInfoSinglePage { _canvasId = 1 }        initcvsbox = CanvasSinglePage initcvs-      st2 = set frameState (Node 1) -            . updateFromCanvasInfoAsCurrentCanvas initcvsbox -            $ st1 { _cvsInfoMap = M.empty } -  (st3,cvs,_wconf) <- constructFrame st2 (view frameState st2)-  (st4,wconf') <- eventConnect st3 (view frameState st3)-  -- testing-  -- let handler = const (putStrLn "In getFileContent, got call back")-  -- newhdl <- flip runReaderT (undefined,undefined) . cnstrctRHoodle =<< defaultHoodle-  -- let nhmodstate = ViewAppendState newhdl +      st2 = st1 # over (unitHoodles.currentUnit) ( set frameState (Node 1) +                                                 . updateFromCanvasInfoAsCurrentCanvas initcvsbox             +                                                 . set cvsInfoMap M.empty )+      uhdl2 = view (unitHoodles.currentUnit) st2+  (uhdl3,cvs,_wconf) <- constructFrame st2 uhdl2 (view frameState uhdl2)+  (uhdl4,wconf') <- eventConnect st2 uhdl3 (view frameState uhdl3)+  notebook <- Gtk.notebookNew+  statusbar <- Gtk.statusbarNew+#ifdef HUB+  let sqlinfo =  (join . fmap sqliteInfo) mhook +#endif+  let st4 = (unitHoodles.currentUnit .~ uhdl4) st2+      st5 = st4 # over (unitHoodles.currentUnit) +                       ( set undoTable (emptyUndo maxundo)  +                       . set frameState wconf' +                       . set rootWindow cvs +                       . set (hoodleFileControl.hoodleFileName) (LocalDir Nothing))+                . set (settings.doesUseXInput) xinputbool +                . set (settings.doesUseVariableCursor) varcsr+#ifdef HUB+                . set (settings.sqliteFileName) sqlinfo+#endif+                . set hookSet mhook +                . set rootNotebook notebook+                . set uiComponentSignalHandler uicompsighdlr +                . set statusBar (Just statusbar) -  let st5 = set (settings.doesUseXInput) xinputbool -          . set hookSet mhook -          . set undoTable (emptyUndo maxundo)  -          . set frameState wconf' -          . set rootWindow cvs -          . set uiComponentSignalHandler uicompsighdlr -          . set statusBar (Just stbar)-          . set (hoodleFileControl.hoodleFileName) Nothing -          -- . set hoodleModeState nhmodstate-          $ st4        vbox <- Gtk.vBoxNew False 0 -  -- -  let startingXstate = set rootContainer (Gtk.castToBox vbox) st5-  let startworld = world startingXstate . ReaderT $ -                     (\(Arg DoEvent ev) -> guiProcess ev)  +  Gtk.containerAdd window vbox+  vboxcvs <- Gtk.vBoxNew False 0 +  -- Gtk.notebookAppendPage notebook vboxcvs  ("untitled" :: T.Text)+  (_,uuid,btn) <- createTab callback notebook vboxcvs+  Gtk.containerAdd vboxcvs (view (unitHoodles.currentUnit.rootWindow) st5)++  sigid <- notebook `Gtk.on` Gtk.switchPage $ \i -> callback (UsrEv (SwitchTab i)) +  let st6 = ( (unitHoodles.currentUnit.unitUUID .~ uuid) +            . (unitHoodles.currentUnit.unitButton .~ btn)+            . (uiComponentSignalHandler.switchTabSignal .~ Just sigid)) st5+      -- st6 = st5+      startingXstate = (unitHoodles.currentUnit.rootContainer .~ Gtk.castToBox vboxcvs) st6+      startworld = world startingXstate . ReaderT $ (\(Arg DoEvent ev) -> guiProcess ev)     putMVar evar . Just $ (driver simplelogger startworld)   return (evar,startingXstate,ui,vbox) - -- | initialization according to the setting -initialize :: AllEvent -> MainCoroutine ()-initialize ev = do  +initialize :: Maybe (CanvasId,CanvasDimension) -> Bool -> AllEvent -> MainCoroutine (CanvasId, CanvasDimension)+initialize cvs isInitialized ev = do       case ev of -      UsrEv (Initialized mfname) -> do -- additional initialization goes here-        xst1 <- get-        let tvar = xst1 ^. pdfRenderQueue-        doIOaction $ \evhandler -> do -          let handler = Gtk.postGUIAsync . evhandler . SysEv . RenderCacheUpdate-          forkOn 2 $ pdfRendererMain handler tvar-          return (UsrEv ActionOrdered)-        waitSomeEvent (\case ActionOrdered -> True ; _ -> False ) -       -        getFileContent mfname--        xst2 <- get-        let hdlst = xst2 ^. hoodleModeState -            cache = xst2 ^. renderCache-        hdlst' <- liftIO $ resetHoodleModeStateBuffers cache hdlst-        put (set hoodleModeState hdlst' xst2)---        xst <- get -        let Just sbar = view statusBar xst -        cxtid <- liftIO $ Gtk.statusbarGetContextId sbar "test"-        liftIO $ Gtk.statusbarPush sbar cxtid "Hello there" -        let ui = view gtkUIManager xst-        liftIO $ toggleSave ui False-        put (set isSaved True xst) - -      _ -> do ev' <- nextevent-              initialize (UsrEv ev')-+      UsrEv (Initialized mfname) -> do +        if isInitialized +          then case cvs of+                 Nothing -> nextevent >>= initialize Nothing True . UsrEv+                 Just cvsi -> return cvsi+          else do+	    -- additional initialization goes here+	    xst1 <- get+	    let ui = xst1 ^. gtkUIManager+		cachevar = xst1 ^. renderCacheVar+		tvarpdf = xst1 ^. pdfRenderQueue+		tvargen = xst1 ^. genRenderQueue+	    doIOaction $ \evhandler -> do +	      -- let handler = Gtk.postGUIAsync . evhandler . SysEv . RenderCacheUpdate+	      forkOn 2 $ pdfRendererMain (defaultHandler evhandler) tvarpdf+	      forkIO $ E.catch (genRendererMain cachevar (defaultHandler evhandler) tvargen) (\e -> print (e :: E.SomeException)) +	      return (UsrEv ActionOrdered)+	    waitSomeEvent (\case ActionOrdered -> True ; _ -> False ) +	    getFileContent (LocalDir mfname)+	    -- +	    xst2 <- get+	    let uhdl = view (unitHoodles.currentUnit) xst2+		hdlst = uhdl ^. hoodleModeState +		cid = getCurrentCanvasId uhdl+	    callRenderer_ $ resetHoodleModeStateBuffers cid hdlst+	    pureUpdateUhdl (hoodleModeState .~ hdlst)+	    -- liftIO $ toggleSave ui False+	    liftIO $ reflectUIToggle ui "SAVEA" False+	    pureUpdateUhdl (isSaved .~ True)+            case cvs of+              Just cvsi -> return cvsi+              Nothing -> nextevent >>= initialize Nothing True . UsrEv+      UsrEv (CanvasConfigure cid w h) -> do+        nextevent >>= initialize (Just (cid,CanvasDimension (Dim w h))) isInitialized . UsrEv +      _ -> case (cvs,isInitialized) of+             (Just cvsi,True) -> return cvsi+             _ -> nextevent >>= initialize cvs isInitialized . UsrEv -- | guiProcess :: AllEvent -> MainCoroutine () guiProcess ev = do -  initialize ev-  changePage (const 0)-  xstate <- get -  reflectViewModeUI-  reflectPenModeUI-  reflectPenColorUI  -  reflectPenWidthUI-  let cinfoMap  = getCanvasInfoMap xstate--      assocs = M.toList cinfoMap -      f (cid,cinfobox) = do let canvas = getDrawAreaFromBox cinfobox-                            (w',h') <- liftIO $ Gtk.widgetGetSize canvas-                            liftIO $ print (w',h')---                            defaultEventProcess (CanvasConfigure cid---                                                (fromIntegral w') ---                                                (fromIntegral h')) -  -  mapM_ f assocs-        -  viewModeChange ToContSinglePage-  pageZoomChange FitWidth--  -- waitSomeEvent (\x -> case x of CanvasConfigure cid w h -> True ; _ -> False)-  --  startLinkReceiver-  -- main loop -  sequence_ (repeat dispatchMode)+    (cid,cdim) <- initialize Nothing False ev+    liftIO $ print (cid,cdim)+    changePage (const 0)+    reflectViewModeUI+    reflectPenModeUI+    reflectPenColorUI  +    reflectPenWidthUI+    reflectNewPageModeUI+    viewModeChange ToContSinglePage+    pageZoomChange FitWidth+#ifdef HUB+    initSqliteDB+    startLinkReceiver+    socketConnect+    syncFile+#endif+    doCanvasConfigure cid cdim+    -- main loop +    sequence_ (repeat dispatchMode)  -- |  dispatchMode :: MainCoroutine () -dispatchMode = get >>= return . hoodleModeStateEither . view hoodleModeState-                   >>= either (const viewAppendMode) (const selectMode)+dispatchMode = (view (unitHoodles.currentUnit) <$> get) +               >>= return . hoodleModeStateEither . view hoodleModeState+               >>= either (const viewAppendMode) (const selectMode)                       -- |  viewAppendMode :: MainCoroutine ()  viewAppendMode = do    r1 <- nextevent    case r1 of -    PenDown cid pbtn pcoord -> do +    PenDown cid pbtn pcoord ->        widgetCheckPen cid pcoord $ do          ptype <- getPenType          case (ptype,pbtn) of -          (PenWork,PenButton1) -> penStart cid pcoord+          (PenWork,PenButton1) -> do+            r <- penStart cid pcoord+            case r of +              Just (Just Nothing) -> do +                pureUpdateUhdl (isOneTimeSelectMode .~ YesBeforeSelect)+                modeChange ToSelectMode+                selectLassoStart PenButton3 cid pcoord+              _ -> return ()           (PenWork,PenButton2) -> eraserStart cid pcoord            (PenWork,PenButton3) -> do -            updateXState (return . set isOneTimeSelectMode YesBeforeSelect)+            pureUpdateUhdl (isOneTimeSelectMode .~ YesBeforeSelect)             modeChange ToSelectMode             selectLassoStart PenButton3 cid pcoord           (PenWork,EraserButton) -> eraserStart cid pcoord           (PenWork,_) -> return ()            (EraserWork,_)      -> eraserStart cid pcoord -          (HighlighterWork,_) -> highlighterStart cid pcoord+          (HighlighterWork,_) -> do +            r <- highlighterStart cid pcoord +            case r of +              Just (Just Nothing) -> do +                pureUpdateUhdl (isOneTimeSelectMode .~ YesBeforeSelect)+                modeChange ToSelectMode+                selectLassoStart PenButton3 cid pcoord+              _ -> return ()           (VerticalSpaceWork,PenButton1) -> verticalSpaceStart cid pcoord            (VerticalSpaceWork,_) -> return ()      TouchDown cid pcoord -> touchStart cid pcoord @@ -252,19 +270,15 @@ disableTouch = do      xst <- get      let devlst = view deviceList xst -    let b = view (settings.doesUseTouch) xst -    when b $ do         +    when (view (settings.doesUseTouch) xst) $ do                let nxst = set (settings.doesUseTouch) False xst -      doIOaction $ \_ -> do-        setToggleUIForFlag "HANDA" (settings.doesUseTouch) nxst+      doIOaction_ $ do+        lensSetToggleUIForFlag "HANDA" (settings.doesUseTouch) nxst         let touchstr = dev_touch_str devlst         -- ad hoc         when (touchstr /= "touch") $ do            readProcess "xinput" [ "disable", touchstr ] ""            return ()-        -- -        return (UsrEv ActionOrdered)-      waitSomeEvent (\x -> case x of ActionOrdered -> True ; _ -> False)       put nxst  -- |@@ -298,7 +312,8 @@ defaultEventProcess (VScrollBarMoved cid v) = vscrollBarMoved cid v defaultEventProcess (VScrollBarStart cid v) = vscrollStart cid v  defaultEventProcess PaneMoveStart = paneMoveStart -defaultEventProcess (CanvasConfigure cid w' h') = doCanvasConfigure cid (CanvasDimension (Dim w' h'))+defaultEventProcess (CanvasConfigure cid w' h') =  +    doCanvasConfigure cid (CanvasDimension (Dim w' h')) defaultEventProcess ToViewAppendMode = modeChange ToViewAppendMode defaultEventProcess ToSelectMode = modeChange ToSelectMode  defaultEventProcess ToSinglePage = viewModeChange ToSinglePage@@ -323,9 +338,9 @@     reflectPenWidthUI defaultEventProcess (BackgroundStyleChanged bsty) = do     modify (backgroundStyle .~ bsty)-    xstate <- get -    let pgnum = view (currentCanvasInfo . unboxLens currentPageNum) xstate-        hdl = getHoodle xstate +    uhdl <- view (unitHoodles.currentUnit) <$> get +    let pgnum = view (currentCanvasInfo . unboxLens currentPageNum) uhdl+        hdl = getHoodle uhdl         pgs = view gpages hdl          cpage = getPageFromGHoodleMap pgnum hdl         cbkg = view gbackground cpage@@ -347,41 +362,36 @@         npgs = set (at pgnum) (Just npage) pgs          nhdl = set gpages npgs hdl      modeChange ToViewAppendMode     -    modify (set hoodleModeState (ViewAppendState nhdl))+    pureUpdateUhdl (hoodleModeState .~ ViewAppendState nhdl)     invalidateAll +defaultEventProcess (AssignNewPageMode nmod) = modify (settings.newPageMode .~ nmod) defaultEventProcess (GotContextMenuSignal ctxtmenu) = processContextMenu ctxtmenu defaultEventProcess (GetHoodleFileInfo ref) = do -  xst <- get-  let hdl = getHoodle xst +  uhdl <- view (unitHoodles.currentUnit) <$> get+  let hdl = getHoodle uhdl       uuid = B.unpack (view ghoodleID hdl)-  case view (hoodleFileControl.hoodleFileName) xst of +  case getHoodleFilePath uhdl of      Nothing -> liftIO $ writeIORef ref Nothing     Just fp -> liftIO $ writeIORef ref (Just (uuid ++ "," ++ fp))+defaultEventProcess (GetHoodleFileInfoFromTab uuidtab ref) = do +  uhdlmap <- view (unitHoodles._2) <$> get+  let muhdl = (L.lookup uuidtab . map (\x -> (view unitUUID x,x)) . M.elems) uhdlmap+  case muhdl of +    Nothing -> liftIO $ writeIORef ref Nothing+    Just uhdl -> do +      let hdl = getHoodle uhdl+          uuid = B.unpack (view ghoodleID hdl)+      case getHoodleFilePath uhdl of +        Nothing -> liftIO $ writeIORef ref Nothing+        Just fp -> liftIO $ writeIORef ref (Just (uuid ++ "," ++ fp)) defaultEventProcess (GotLink mstr (x,y)) = gotLink mstr (x,y)    -defaultEventProcess (Sync ctime) = do -  xst <- get-  case view (hoodleFileControl.lastSavedTime) xst of -    Nothing -> return ()-    Just otime -> do -      let dtime = diffUTCTime ctime otime-      if dtime < dtime_bound * 10 -        then return () -        else do -          let ioact = mkIOaction $ \evhandler -> do -                Gtk.postGUISync (evhandler (UsrEv FileReloadOrdered))-                return (UsrEv ActionOrdered)-          modify (tempQueue %~ enqueue ioact)+ defaultEventProcess FileReloadOrdered = fileReload  defaultEventProcess (CustomKeyEvent str) = do-    liftIO $ print str     if | str == "[]:\"Super_L\"" -> do              xst <- liftM (over (settings.doesUseTouch) not) get             put xst -           let action = mkIOaction $ \_evhandler -> do -                 setToggleUIForFlag "HANDA" (settings.doesUseTouch) xst-                 return (UsrEv ActionOrdered)-           modify (tempQueue %~ enqueue action)-           waitSomeEvent (\x -> case x of ActionOrdered -> True ; _ -> False)    +           doIOaction_ $ lensSetToggleUIForFlag "HANDA" (settings.doesUseTouch) xst            toggleTouch        | str == "[]:\"1\"" -> colorfunc ColorBlack        | str == "[]:\"2\"" -> colorfunc ColorBlue @@ -402,210 +412,45 @@   where      colorfunc c = doIOaction $ \_evhandler -> return (UsrEv (PenColorChanged c))     toolfunc t = doIOaction $ \_evhandler -> return (UsrEv (AssignPenMode (Left t)))+defaultEventProcess (SwitchTab i) = switchTab i+defaultEventProcess (CloseTab uuid) = findTab uuid >>= mapM_  (\x-> switchTab x >> askIfSave closeTab)+defaultEventProcess (OpenLink urlpath mid) = openLinkAction urlpath mid+#ifdef HUB+defaultEventProcess (OpenShared uuid) = openShared uuid+defaultEventProcess (OpenTemp _uuid tmpfile) = getFileContent (TempDir tmpfile)+                                              >> canvasZoomUpdateAll +                                              >> invalidateAll+defaultEventProcess (NetworkProcess (NetworkReceived txt)) = networkReceived txt defaultEventProcess (DBusEv (ImageFileDropped fname)) = embedImage fname defaultEventProcess (DBusEv (DBusNetworkInput txt)) = dbusNetworkInput txt  defaultEventProcess (DBusEv (GoToLink (docid,anchorid))) = goToAnchorPos docid anchorid-defaultEventProcess ev = -- for debugging-                         do liftIO $ putStrLn "--- no default ---"-                            liftIO $ print ev -                            liftIO $ putStrLn "------------------"-                            return () ---- |-menuEventProcess :: MenuEvent -> MainCoroutine () -menuEventProcess MenuQuit = do -  xstate <- get-  liftIO $ putStrLn "MenuQuit called"-  if view isSaved xstate -    then liftIO $ Gtk.mainQuit-    else askQuitProgram-menuEventProcess MenuPreviousPage = changePage (\x->x-1)-menuEventProcess MenuNextPage =  changePage (+1)-menuEventProcess MenuFirstPage = changePage (const 0)-menuEventProcess MenuLastPage = do -  totalnumofpages <- (either (M.size. view gpages) (M.size . view gselAll) -                      . hoodleModeStateEither . view hoodleModeState) <$> get -  changePage (const (totalnumofpages-1))-menuEventProcess MenuNewPageBefore = newPage PageBefore -menuEventProcess MenuNewPageAfter = newPage PageAfter-menuEventProcess MenuDeletePage = deleteCurrentPage-menuEventProcess MenuExportPageSVG = exportCurrentPageAsSVG -menuEventProcess MenuNew  = askIfSave fileNew -menuEventProcess MenuAnnotatePDF = askIfSave fileAnnotatePDF-menuEventProcess MenuLoadPNGorJPG = fileLoadPNGorJPG-menuEventProcess MenuLoadSVG = fileLoadSVG-menuEventProcess MenuText = textInput (Just (100,100)) "" -menuEventProcess MenuEmbedTextSource = embedTextSource-menuEventProcess MenuEditEmbedTextSource = editEmbeddedTextSource-menuEventProcess MenuEditNetEmbedTextSource = editNetEmbeddedTextSource-menuEventProcess MenuTextFromSource = textInputFromSource (100,100)-menuEventProcess MenuLaTeX = -    laTeXInput Nothing (laTeXHeader <> "\n\n" <> laTeXFooter)-menuEventProcess MenuLaTeXNetwork = -    laTeXInputNetwork Nothing (laTeXHeader <> "\n\n" <> laTeXFooter)    -menuEventProcess MenuCombineLaTeX = combineLaTeXText -menuEventProcess MenuLaTeXFromSource = laTeXInputFromSource (100,100)-menuEventProcess MenuUndo = undo -menuEventProcess MenuRedo = redo-menuEventProcess MenuOpen = askIfSave fileOpen-menuEventProcess MenuSave = fileSave -menuEventProcess MenuSaveAs = fileSaveAs-menuEventProcess MenuReload = fileReload -menuEventProcess MenuExport = fileExport -menuEventProcess MenuStartSync = fileStartSync-menuEventProcess MenuVersionSave = fileVersionSave -menuEventProcess MenuShowRevisions = fileShowRevisions-menuEventProcess MenuShowUUID = fileShowUUID--- -menuEventProcess MenuCut = cutSelection-menuEventProcess MenuCopy = copySelection-menuEventProcess MenuPaste = pasteToSelection-menuEventProcess MenuDelete = deleteSelection-menuEventProcess MenuZoomIn = pageZoomChangeRel ZoomIn -menuEventProcess MenuZoomOut = pageZoomChangeRel ZoomOut-menuEventProcess MenuNormalSize = pageZoomChange Original  -menuEventProcess MenuPageWidth = pageZoomChange FitWidth -menuEventProcess MenuPageHeight = pageZoomChange FitHeight-menuEventProcess MenuHSplit = eitherSplit SplitHorizontal-menuEventProcess MenuVSplit = eitherSplit SplitVertical-menuEventProcess MenuDelCanvas = deleteCanvas-menuEventProcess MenuNewLayer = makeNewLayer -menuEventProcess MenuNextLayer = gotoNextLayer -menuEventProcess MenuPrevLayer = gotoPrevLayer-menuEventProcess MenuGotoLayer = startGotoLayerAt -menuEventProcess MenuDeleteLayer = deleteCurrentLayer-menuEventProcess MenuUseXInput = do -  xstate <- get -  b <- updateFlagFromToggleUI "UXINPUTA" (settings.doesUseXInput)-  let cmap = getCanvasInfoMap xstate-      canvases = map (getDrawAreaFromBox) . M.elems $ cmap -  if b-    then mapM_ (\x->liftIO $ Gtk.widgetSetExtensionEvents x [Gtk.ExtensionEventsAll]) canvases-    else mapM_ (\x->liftIO $ Gtk.widgetSetExtensionEvents x [Gtk.ExtensionEventsNone] ) canvases-menuEventProcess MenuUseTouch = toggleTouch-menuEventProcess MenuSmoothScroll = updateFlagFromToggleUI "SMTHSCRA" (settings.doesSmoothScroll) >> return ()-menuEventProcess MenuUsePopUpMenu = updateFlagFromToggleUI "POPMENUA" (settings.doesUsePopUpMenu) >> return ()-menuEventProcess MenuEmbedImage = updateFlagFromToggleUI "EBDIMGA" (settings.doesEmbedImage) >> return ()-menuEventProcess MenuEmbedPDF = updateFlagFromToggleUI "EBDPDFA" (settings.doesEmbedPDF) >> return ()-menuEventProcess MenuFollowLinks = updateFlagFromToggleUI "FLWLNKA" (settings.doesFollowLinks) >> return ()-menuEventProcess MenuKeepAspectRatio = updateFlagFromToggleUI "KEEPRATIOA" (settings.doesKeepAspectRatio) >> return ()-menuEventProcess MenuUseVariableCursor = updateFlagFromToggleUI "VCURSORA" (settings.doesUseVariableCursor) >> reflectCursor >> return ()-menuEventProcess MenuPressureSensitivity = updateFlagFromToggleUI "PRESSRSENSA" (penInfo.variableWidthPen) >> return ()  -menuEventProcess MenuRelaunch = liftIO $ relaunchApplication-menuEventProcess MenuColorPicker = colorPick -menuEventProcess MenuFullScreen = fullScreen-menuEventProcess MenuAddLink = addLink-menuEventProcess MenuAddAnchor = addAnchor-menuEventProcess MenuListAnchors = listAnchors-menuEventProcess MenuEmbedPredefinedImage = embedPredefinedImage -menuEventProcess MenuEmbedPredefinedImage2 = embedPredefinedImage2 -menuEventProcess MenuEmbedPredefinedImage3 = embedPredefinedImage3 -menuEventProcess MenuApplyToAllPages = do -    xstate <- get -    let bsty = view backgroundStyle xstate -    let hdl = getHoodle xstate -        pgs = view gpages hdl -        changeBkg cpage = -          let cbkg = view gbackground cpage-              nbkg -                | isRBkgSmpl cbkg = cbkg { rbkg_style = convertBackgroundStyleToByteString bsty }-                | otherwise = cbkg -          in set gbackground nbkg cpage -        npgs = fmap changeBkg pgs -        nhdl = set gpages npgs hdl -    modeChange ToViewAppendMode     -    modify (set hoodleModeState (ViewAppendState nhdl))-    invalidateAll -menuEventProcess MenuEmbedAllPDFBkg = embedAllPDFBackground-menuEventProcess MenuTogglePanZoomWidget = (togglePanZoom . view (currentCanvas._1)) =<< get -menuEventProcess MenuToggleLayerWidget = (toggleLayer . view (currentCanvas._1)) =<< get -menuEventProcess MenuToggleClockWidget = (toggleClock . view (currentCanvas._1)) =<< get-menuEventProcess MenuHandwritingRecognitionDialog = -    handwritingRecognitionDialog >>= mapM_ (\(b,txt) -> when b $ embedHoodlet (T.unpack txt)) -menuEventProcess m = liftIO $ putStrLn $ "not implemented " ++ show m ----- | -colorPick :: MainCoroutine () -colorPick = do mc <- colorPickerBox "Pen Color" -               maybe (return ())  -                     (\c->modify (penInfo.currentTool.penColor .~ c)) -                     mc ---- | -colorConvert :: Gtk.Color -> PenColor -colorConvert (Gtk.Color r g b) = ColorRGBA (realToFrac r/65536.0) (realToFrac g/65536.0) (realToFrac b/65536.0) 1.0 ---- | -colorPickerBox :: String -> MainCoroutine (Maybe PenColor) -colorPickerBox msg = do -   xst <- get -   let pcolor = view ( penInfo.currentTool.penColor) xst   -   modify (tempQueue %~ enqueue (action pcolor)) >> go -  where -    action pcolor = -      mkIOaction $ -               \_evhandler -> do -                 dialog <- Gtk.colorSelectionDialogNew msg-                 csel <- Gtk.colorSelectionDialogGetColor dialog-                 let (r,g,b,_a) =  convertPenColorToRGBA pcolor -                     color = Gtk.Color (floor (r*65535.0)) (floor (g*65535.0)) (floor (b*65535.0))-                -                 Gtk.colorSelectionSetCurrentColor csel color-                 res <- Gtk.dialogRun dialog -                 mc <- case res of -                         Gtk.ResponseOk -> do -                              clrsel <- Gtk.colorSelectionDialogGetColor dialog -                              clr <- Gtk.colorSelectionGetCurrentColor clrsel     -                              return (Just (colorConvert clr))-                         _ -> return Nothing -                 Gtk.widgetDestroy dialog -                 return (UsrEv (ColorChosen mc))-    go = do r <- nextevent                   -            case r of -              ColorChosen mc -> return mc -              UpdateCanvas cid -> -- this is temporary-                invalidateInBBox Nothing Efficient cid >> go-              _ -> go ---pdfRendererMain :: ((UUID,(Double,Cairo.Surface))->IO ()) -> TVar (Seq (UUID,PDFCommand)) -> IO () -pdfRendererMain handler tvar = forever $ do     -    -- putStrLn "pdfRenderMain called"-    p <- atomically $ do -      lst' <- readTVar tvar-      case viewl lst' of-        EmptyL -> retry-        p :< ps -> do -          writeTVar tvar ps -          return p -    pdfWorker handler p--pdfWorker :: ((UUID,(Double,Cairo.Surface))->IO ()) -> (UUID,PDFCommand) -> IO ()-pdfWorker _handler (_,GetDocFromFile fp tmvar) = do-    -- putStrLn "pdfWorker : GetDocFromFile"-    mdoc <- popplerGetDocFromFile fp-    atomically $ putTMVar tmvar mdoc -pdfWorker _handler (_,GetDocFromDataURI str tmvar) = do-    -- putStrLn "pdfWorker : GetDocFromDataURI"-    mdoc <- popplerGetDocFromDataURI str-    atomically $ putTMVar tmvar mdoc-pdfWorker _handler (_,GetPageFromDoc doc pn tmvar) = do-    -- putStrLn "pdfWorker : GetPageFromDoc"-    mpg <- popplerGetPageFromDoc doc pn-    atomically $ putTMVar tmvar mpg-pdfWorker handler (uuid,RenderPageScaled page (Dim ow oh) (Dim w h)) = do-    -- putStrLn "pdfWorker : RenderPageScaled"-    let s = w / ow-    sfc <- Cairo.createImageSurface Cairo.FormatARGB32 (floor w) (floor h)-    Cairo.renderWith sfc $ do   -      Cairo.setSourceRGBA 1 1 1 1-      Cairo.rectangle 0 0 w h -      Cairo.fill-      Cairo.scale s s-      Poppler.pageRender page -    handler (uuid,(s,sfc))--+defaultEventProcess (DisconnectedHub tokfile (ofile,file) hinfo) = do+    b <- okCancelMessageBox "authentication failure! do you want to start from the beginning?"+    when b $ do+      r' :: Either E.SomeException () <- liftIO (E.try (removeFile tokfile))+      case r' of +        Left _ ->  msgShout "DisconnectedHub" >>  return ()+        Right _ -> uploadWork (ofile,file) hinfo+defaultEventProcess (Sync ctime) = do +  xst <- get+  case view (unitHoodles.currentUnit.hoodleFileControl.lastSavedTime) xst of +    Nothing -> return ()+    Just otime -> do +      let dtime = diffUTCTime ctime otime+      if dtime < dtime_bound * 10 +        then return () +        else +          doIOaction $ \evhandler -> do +            Gtk.postGUISync (evhandler (UsrEv FileReloadOrdered))+            return (UsrEv ActionOrdered)+defaultEventProcess (SyncInfoUpdated uhdluuid fstat) = updateSyncInfo uhdluuid fstat+defaultEventProcess (SyncFileFinished fstat) = updateSyncInfoAll fstat+defaultEventProcess (FileSyncFromHub uhdluuid fstat) = fileSyncFromHub uhdluuid fstat+defaultEventProcess (GotSyncEvent isforced fileuuid uhdluuid) = gotSyncEvent isforced fileuuid uhdluuid+#endif +defaultEventProcess ev = -- for debugging+                         do msgShout "--- no default ---"+                            msgShout (show ev)+                            msgShout "------------------"
+ src/Hoodle/Coroutine/Default/Menu.hs view
@@ -0,0 +1,239 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++-----------------------------------------------------------------------------+-- |+-- Module      : Hoodle.Coroutine.Default.Menu+-- Copyright   : (c) 2014, 2015 Ian-Woo Kim+--+-- License     : BSD3+-- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability   : experimental+-- Portability : GHC+--+-----------------------------------------------------------------------------++module Hoodle.Coroutine.Default.Menu where++import           Control.Applicative+import           Control.Lens (_1,view,set,(.~))+import           Control.Monad.IO.Class+import           Control.Monad.State hiding (mapM_)+import           Data.Foldable (mapM_)+import qualified Data.IntMap as M+import           Data.Monoid+import qualified Data.Text as T+import qualified Graphics.UI.Gtk as Gtk+--+import           Data.Hoodle.Generic+import           Data.Hoodle.Select+import           Graphics.Hoodle.Render.Type+--+import           Hoodle.Accessor+import           Hoodle.Coroutine.Commit+import           Hoodle.Coroutine.Draw+import           Hoodle.Coroutine.File+import           Hoodle.Coroutine.HandwritingRecognition+import           Hoodle.Coroutine.LaTeX+import           Hoodle.Coroutine.Layer+import           Hoodle.Coroutine.Link+import           Hoodle.Coroutine.Mode+import           Hoodle.Coroutine.Page+import           Hoodle.Coroutine.Select.Clipboard+import           Hoodle.Coroutine.TextInput+import           Hoodle.Coroutine.Window+import           Hoodle.GUI.Reflect+import           Hoodle.Type.Canvas+import           Hoodle.Type.Coroutine+import           Hoodle.Type.Enum+import           Hoodle.Type.Event+import           Hoodle.Type.HoodleState+import           Hoodle.Type.PageArrangement+import           Hoodle.Type.Window+import           Hoodle.Widget.Clock+import           Hoodle.Widget.Layer+import           Hoodle.Widget.PanZoom+import           Hoodle.Widget.Scroll+#ifdef HUB+import           Hoodle.Coroutine.Hub+#endif+#ifdef DYRE+import           Hoodle.Script+#endif+--+import Prelude hiding (mapM_)++++-- |+menuEventProcess :: MenuEvent -> MainCoroutine () +menuEventProcess MenuQuit = do +    xstate <- get+    if view (unitHoodles.currentUnit.isSaved) xstate +      then liftIO $ Gtk.mainQuit+      else askQuitProgram+menuEventProcess MenuPreviousPage = changePage (\x->x-1)+menuEventProcess MenuNextPage =  changePage (+1)+menuEventProcess MenuFirstPage = changePage (const 0)+menuEventProcess MenuLastPage = do +    totalnumofpages <- (either (M.size. view gpages) (M.size . view gselAll) +                        . hoodleModeStateEither . view (unitHoodles.currentUnit.hoodleModeState)) <$> get +    changePage (const (totalnumofpages-1))+menuEventProcess MenuNewPageBefore = newPage Nothing PageBefore +menuEventProcess MenuNewPageAfter = newPage Nothing PageAfter+menuEventProcess MenuDeletePage = deleteCurrentPage+menuEventProcess MenuExportPageSVG = exportCurrentPageAsSVG +menuEventProcess MenuNew  = addTab (LocalDir Nothing) -- askIfSave fileNew +menuEventProcess MenuAnnotatePDF = askIfSave fileAnnotatePDF+menuEventProcess MenuLoadPNGorJPG = fileLoadPNGorJPG+menuEventProcess MenuLoadSVG = fileLoadSVG+menuEventProcess MenuLoadImageBackground = fileLoadImageBackground+menuEventProcess MenuText = textInput (Just (100,100)) "" +menuEventProcess MenuEmbedTextSource = embedTextSource+menuEventProcess MenuEditEmbedTextSource = editEmbeddedTextSource+menuEventProcess MenuTextFromSource = textInputFromSource (100,100)+menuEventProcess MenuLaTeX = +    laTeXInput Nothing (laTeXHeader <> "\n\n" <> laTeXFooter)+menuEventProcess MenuCombineLaTeX = combineLaTeXText +menuEventProcess MenuLaTeXFromSource = laTeXInputFromSource (100,100)+-- menuEventProcess MenuUpdateLaTeX = updateLaTeX+menuEventProcess MenuUndo = undo +menuEventProcess MenuRedo = redo+menuEventProcess MenuOpen = askIfSave fileOpen+menuEventProcess MenuSave = fileSave +menuEventProcess MenuSaveAs = fileSaveAs+menuEventProcess MenuReload = fileReload +menuEventProcess MenuExport = fileExport +-- menuEventProcess MenuStartSync = fileStartSync+menuEventProcess MenuVersionSave = fileVersionSave +menuEventProcess MenuShowRevisions = fileShowRevisions+menuEventProcess MenuShowUUID = fileShowUUID+-- +menuEventProcess MenuCut = cutSelection+menuEventProcess MenuCopy = copySelection+menuEventProcess MenuPaste = pasteToSelection+menuEventProcess MenuDelete = deleteSelection+menuEventProcess MenuZoomIn = pageZoomChangeRel ZoomIn +menuEventProcess MenuZoomOut = pageZoomChangeRel ZoomOut+menuEventProcess MenuNormalSize = pageZoomChange Original  +menuEventProcess MenuPageWidth = pageZoomChange FitWidth +menuEventProcess MenuPageHeight = pageZoomChange FitHeight+menuEventProcess MenuHSplit = eitherSplit SplitHorizontal+menuEventProcess MenuVSplit = eitherSplit SplitVertical+menuEventProcess MenuDelCanvas = deleteCanvas+menuEventProcess MenuNewLayer = makeNewLayer +menuEventProcess MenuNextLayer = gotoNextLayer +menuEventProcess MenuPrevLayer = gotoPrevLayer+menuEventProcess MenuGotoLayer = startGotoLayerAt +menuEventProcess MenuDeleteLayer = deleteCurrentLayer+menuEventProcess MenuUseXInput = do +    uhdl <- view (unitHoodles.currentUnit) <$> get +    let cmap = view cvsInfoMap uhdl+        canvases = map (getDrawAreaFromBox) . M.elems $ cmap +    updateFlagFromToggleUI "UXINPUTA" (settings.doesUseXInput) >>= \b -> +#ifdef GTK3      +      return ()+#else+      if b+        then mapM_ (\x->liftIO $ Gtk.widgetSetExtensionEvents x [Gtk.ExtensionEventsAll]) canvases+        else mapM_ (\x->liftIO $ Gtk.widgetSetExtensionEvents x [Gtk.ExtensionEventsNone] ) canvases+#endif+menuEventProcess MenuUseTouch = toggleTouch+menuEventProcess MenuUsePopUpMenu = updateFlagFromToggleUI "POPMENUA" (settings.doesUsePopUpMenu) >> return ()+menuEventProcess MenuEmbedImage = updateFlagFromToggleUI "EBDIMGA" (settings.doesEmbedImage) >> return ()+menuEventProcess MenuEmbedPDF = updateFlagFromToggleUI "EBDPDFA" (settings.doesEmbedPDF) >> return ()+menuEventProcess MenuFollowLinks = updateFlagFromToggleUI "FLWLNKA" (settings.doesFollowLinks) >> return ()+menuEventProcess MenuKeepAspectRatio = updateFlagFromToggleUI "KEEPRATIOA" (settings.doesKeepAspectRatio) >> return ()+menuEventProcess MenuUseVariableCursor = updateFlagFromToggleUI "VCURSORA" (settings.doesUseVariableCursor) >> reflectCursor True >> return ()+menuEventProcess MenuPressureSensitivity = updateFlagFromToggleUI "PRESSRSENSA" (penInfo.variableWidthPen) >> return ()  +#ifdef DYRE+menuEventProcess MenuRelaunch = liftIO $ relaunchApplication+#endif+menuEventProcess MenuColorPicker = colorPick +menuEventProcess MenuFullScreen = fullScreen+menuEventProcess MenuAddLink = addLink+menuEventProcess MenuAddAnchor = addAnchor+menuEventProcess MenuListAnchors = listAnchors+menuEventProcess MenuEmbedPredefinedImage = embedPredefinedImage +menuEventProcess MenuEmbedPredefinedImage2 = embedPredefinedImage2 +menuEventProcess MenuEmbedPredefinedImage3 = embedPredefinedImage3 +menuEventProcess MenuApplyToAllPages = do +    xst <- get +    let bsty = view backgroundStyle xst+        uhdl = view (unitHoodles.currentUnit) xst+        hdl = getHoodle uhdl+        pgs = view gpages hdl +        changeBkg cpage = +          let cbkg = view gbackground cpage+              nbkg +                | isRBkgSmpl cbkg = cbkg { rbkg_style = convertBackgroundStyleToByteString bsty }+                | otherwise = cbkg +          in set gbackground nbkg cpage +        npgs = fmap changeBkg pgs +        nhdl = set gpages npgs hdl +    modeChange ToViewAppendMode     +    pureUpdateUhdl (const ((hoodleModeState .~ ViewAppendState nhdl) uhdl))+    invalidateAll +menuEventProcess MenuEmbedAllPDFBkg = embedAllPDFBackground+menuEventProcess MenuTogglePanZoomWidget = togglePanZoom . view (unitHoodles.currentUnit.currentCanvas._1) =<< get +menuEventProcess MenuToggleLayerWidget = toggleLayer . view (unitHoodles.currentUnit.currentCanvas._1) =<< get +menuEventProcess MenuToggleClockWidget = toggleClock . view (unitHoodles.currentUnit.currentCanvas._1) =<< get+menuEventProcess MenuToggleScrollWidget = toggleScroll . view (unitHoodles.currentUnit.currentCanvas._1) =<< get+menuEventProcess MenuHandwritingRecognitionDialog = +    handwritingRecognitionDialog >>= mapM_ (\(b,txt) -> when b $ embedHoodlet (T.unpack txt)) +menuEventProcess MenuAddTab = addTab (LocalDir Nothing)+-- menuEventProcess MenuNextTab = nextTab+menuEventProcess MenuCloseTab = closeTab+#ifdef HUB+menuEventProcess MenuEditNetEmbedTextSource = editNetEmbeddedTextSource+menuEventProcess MenuToggleNetworkEditSource = toggleNetworkEditSource+menuEventProcess MenuLaTeXNetwork = +    laTeXInputNetwork Nothing (laTeXHeader <> "\n\n" <> laTeXFooter)+menuEventProcess MenuHub = hubUpload+-- menuEventProcess MenuHubSocket = socketConnect+#endif+menuEventProcess m = liftIO $ putStrLn $ "not implemented " ++ show m ++-- | +colorPick :: MainCoroutine () +colorPick = colorPickerBox "Pen Color" >>= mapM_ (\c->modify (penInfo.currentTool.penColor .~ c))++-- | +colorConvert :: Gtk.Color -> PenColor +colorConvert (Gtk.Color r g b) = ColorRGBA (realToFrac r/65536.0) (realToFrac g/65536.0) (realToFrac b/65536.0) 1.0 +-- | +colorPickerBox :: String -> MainCoroutine (Maybe PenColor) +colorPickerBox msg = do +#ifdef GTK3 +    -- color selection dialog is incomplete in gtk3+    return Nothing+#else+    xst <- get +    let pcolor = view (penInfo.currentTool.penColor) xst   +    doIOaction (action pcolor) >> go+  where +    action pcolor _evhandler = do +      dialog <- Gtk.colorSelectionDialogNew msg+      csel <- Gtk.colorSelectionDialogGetColor dialog+      let (r,g,b,_a) =  convertPenColorToRGBA pcolor +          color = Gtk.Color (floor (r*65535.0)) (floor (g*65535.0)) (floor (b*65535.0))++      Gtk.colorSelectionSetCurrentColor csel color+      res <- Gtk.dialogRun dialog +      mc <- case res of +              Gtk.ResponseOk -> do +                   clrsel <- Gtk.colorSelectionDialogGetColor dialog +                   clr <- Gtk.colorSelectionGetCurrentColor clrsel     +                   return (Just (colorConvert clr))+              _ -> return Nothing +      Gtk.widgetDestroy dialog +      return (UsrEv (ColorChosen mc))+    go = do r <- nextevent                   +            case r of +              ColorChosen mc -> return mc +              UpdateCanvas cid -> -- this is temporary+                invalidateInBBox Nothing Efficient cid >> go+              _ -> go +#endif
src/Hoodle/Coroutine/Dialog.hs view
@@ -1,9 +1,10 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-}  ----------------------------------------------------------------------------- -- | -- Module      : Hoodle.Coroutine.Dialog--- Copyright   : (c) 2013 Ian-Woo Kim+-- Copyright   : (c) 2013,2014 Ian-Woo Kim -- -- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>@@ -14,14 +15,15 @@  module Hoodle.Coroutine.Dialog where -import           Control.Lens ((%~),view)+import           Control.Applicative ((<$>),(<*>))+import           Control.Lens (view) import           Control.Monad.Loops import           Control.Monad.State-import           Graphics.UI.Gtk hiding (get,set)+import qualified Data.Foldable as F+import qualified Data.Text as T+import qualified Graphics.UI.Gtk as Gtk import           System.Directory (getCurrentDirectory) -- -import           Control.Monad.Trans.Crtn.Queue--- import           Hoodle.Coroutine.Draw import qualified Hoodle.Script.Coroutine as S import           Hoodle.Type.Coroutine@@ -32,47 +34,152 @@  -- | okMessageBox :: String -> MainCoroutine () -okMessageBox msg = modify (tempQueue %~ enqueue action) -                   >> waitSomeEvent (\case GotOk -> True ; _ -> False) -                   >> return () +okMessageBox msg = action >> waitSomeEvent (\case GotOk -> True ; _ -> False) >> return ()    where -    action = mkIOaction $ +    action = doIOaction $                 \_evhandler -> do -                 dialog <- messageDialogNew Nothing [DialogModal]-                   MessageQuestion ButtonsOk msg -                 _res <- dialogRun dialog -                 widgetDestroy dialog +                 dialog <- Gtk.messageDialogNew Nothing [Gtk.DialogModal]+                   Gtk.MessageQuestion Gtk.ButtonsOk msg +                 _res <- Gtk.dialogRun dialog +                 Gtk.widgetDestroy dialog                   return (UsrEv GotOk) + -- |  okCancelMessageBox :: String -> MainCoroutine Bool -okCancelMessageBox msg = modify (tempQueue %~ enqueue action) -                         >> waitSomeEvent p >>= return . q+okCancelMessageBox msg = action >> waitSomeEvent p >>= return . q   where      p (OkCancel _) = True      p _ = False      q (OkCancel b) = b      q _ = False -    action = mkIOaction $ +    action = doIOaction $                 \_evhandler -> do -                 dialog <- messageDialogNew Nothing [DialogModal]-                   MessageQuestion ButtonsOkCancel msg -                 res <- dialogRun dialog +                 dialog <- Gtk.messageDialogNew Nothing [Gtk.DialogModal]+                   Gtk.MessageQuestion Gtk.ButtonsOkCancel msg +                 res <- Gtk.dialogRun dialog                   let b = case res of -                           ResponseOk -> True+                           Gtk.ResponseOk -> True                            _ -> False-                 widgetDestroy dialog +                 Gtk.widgetDestroy dialog                   return (UsrEv (OkCancel b)) ++-- | single line text input : almost abandoned now+textInputDialog :: String -> MainCoroutine (Maybe String) +textInputDialog msg = do +    doIOaction $ \_evhandler -> do +                   dialog <- Gtk.messageDialogNew Nothing [Gtk.DialogModal]+                     Gtk.MessageQuestion Gtk.ButtonsOkCancel msg+#ifdef GTK3+                   vbox <- fmap Gtk.castToContainer (Gtk.dialogGetContentArea dialog)+                   txtvw <- Gtk.textViewNew+                   Gtk.containerAdd vbox txtvw  +#else +                   vbox <- Gtk.dialogGetUpper dialog+                   txtvw <- Gtk.textViewNew+                   Gtk.boxPackStart vbox txtvw Gtk.PackGrow 0 +#endif+                   Gtk.widgetShowAll dialog+                   res <- Gtk.dialogRun dialog +                   case res of +                     Gtk.ResponseOk -> do +                       buf <- Gtk.textViewGetBuffer txtvw +                       (istart,iend) <- (,) <$> Gtk.textBufferGetStartIter buf+                                            <*> Gtk.textBufferGetEndIter buf+                       l <- Gtk.textBufferGetText buf istart iend True+                       Gtk.widgetDestroy dialog+                       return (UsrEv (TextInput (Just l)))+                     _ -> do +                       Gtk.widgetDestroy dialog+                       return (UsrEv (TextInput Nothing))+    TextInput input <- waitSomeEvent (\case TextInput _ -> True ; _ -> False)+    return input +++ -- | -fileChooser :: FileChooserAction -> Maybe String -> MainCoroutine (Maybe FilePath) +keywordDialog :: [T.Text] -> MainCoroutine (Maybe T.Text)+keywordDialog keylst = do+    doIOaction (keywordDialog' keylst)+    keywordLoop++-- |+keywordDialog' :: [T.Text] -> (AllEvent -> IO ()) -> IO AllEvent+keywordDialog' keys = \_evhandler -> do+    dialog <- Gtk.dialogNew+#ifdef GTK3+    upper <- fmap Gtk.castToContainer (Gtk.dialogGetContentArea dialog)+    vbox <- Gtk.vBoxNew False 0 +    Gtk.containerAdd upper vbox+#else+    vbox <- Gtk.dialogGetUpper dialog+#endif+    hbox <- Gtk.hBoxNew False 0+    Gtk.boxPackStart vbox hbox Gtk.PackNatural 0+    _btnOk <- Gtk.dialogAddButton dialog ("Ok" :: String) Gtk.ResponseOk+    _btnCancel <- Gtk.dialogAddButton dialog ("Cancel" :: String) Gtk.ResponseCancel+    cbx <- Gtk.comboBoxNewText +    klst <- mapM (Gtk.comboBoxAppendText cbx) keys+    when ((not.null) klst) $ +      Gtk.comboBoxSetActive cbx (head klst)+    Gtk.boxPackStart hbox cbx Gtk.PackGrow 2+    Gtk.widgetShowAll dialog+    res <- Gtk.dialogRun dialog+    Gtk.widgetDestroy dialog+    case res of +      Gtk.ResponseOk -> do+        keystr <- Gtk.comboBoxGetActiveText cbx+        (return . UsrEv . Keyword) keystr+      Gtk.ResponseCancel -> return (UsrEv (Keyword Nothing))+      _ -> return (UsrEv (Keyword Nothing))++-- | main event loop for keyword dialog+keywordLoop :: MainCoroutine (Maybe T.Text)+keywordLoop = waitSomeEvent (\case Keyword _ -> True ; _ -> False ) >>= \(Keyword x) -> return x+++-- |+longTextMessageBox :: String -> MainCoroutine () +longTextMessageBox msg = action+                         >> waitSomeEvent (\case GotOk -> True ; _ -> False) +                         >> return () +  where +    action = doIOaction $ +               \_evhandler -> do +                 dialog <- Gtk.dialogNew++#ifdef GTK3+                 upper <- fmap Gtk.castToContainer (Gtk.dialogGetContentArea dialog)+                 vbox <- Gtk.vBoxNew False 0 +                 Gtk.containerAdd upper vbox+#else+                 vbox <- Gtk.dialogGetUpper dialog+#endif+                 hbox <- Gtk.hBoxNew False 0+                 txtbuf <- Gtk.textBufferNew Nothing+                 Gtk.textBufferSetText txtbuf msg+                 txtview <- Gtk.textViewNewWithBuffer txtbuf+                 vadj <- Gtk.textViewGetVadjustment txtview+                 vscr <- Gtk.vScrollbarNew vadj+                 Gtk.widgetSetSizeRequest txtview 400 700+                 Gtk.boxPackEnd hbox vscr Gtk.PackNatural 0 +                 Gtk.boxPackStart hbox txtview Gtk.PackGrow 0+                 Gtk.boxPackStart vbox hbox Gtk.PackGrow 0+                 _btnOk <- Gtk.dialogAddButton dialog ("Ok" :: String) Gtk.ResponseOk+                 Gtk.widgetShowAll dialog+                 _res <- Gtk.dialogRun dialog +                 Gtk.widgetDestroy dialog +                 return (UsrEv GotOk)++-- | +fileChooser :: Gtk.FileChooserAction -> Maybe String -> MainCoroutine (Maybe FilePath)  fileChooser choosertyp mfname = do      mrecentfolder <- S.recentFolderHook      xst <- get      let rtrwin = view rootOfRootWindow xst -    liftIO $ widgetQueueDraw rtrwin -        -    modify (tempQueue %~ enqueue (action rtrwin mrecentfolder)) >> go +    liftIO $ Gtk.widgetQueueDraw rtrwin +    doIOaction (action rtrwin mrecentfolder) >> go   where      go = do r <- nextevent                                case r of @@ -80,22 +187,22 @@               UpdateCanvas cid -> -- this is temporary                                   invalidateInBBox Nothing Efficient cid >> go                 _ -> go -    action win mrf = mkIOaction $ \_evhandler -> do -      dialog <- fileChooserDialogNew Nothing (Just win) choosertyp -                  [ ("OK", ResponseOk) -                  , ("Cancel", ResponseCancel) ]+    action win mrf _evhandler = do +      dialog <- Gtk.fileChooserDialogNew Nothing (Just win) choosertyp +                  [ ("OK", Gtk.ResponseOk) +                  , ("Cancel", Gtk.ResponseCancel) ]       case mrf of -        Just rf -> fileChooserSetCurrentFolder dialog rf -        Nothing -> getCurrentDirectory >>= fileChooserSetCurrentFolder dialog -      maybe (return ()) (fileChooserSetCurrentName dialog) mfname +        Just rf -> Gtk.fileChooserSetCurrentFolder dialog rf +        Nothing -> getCurrentDirectory >>= Gtk.fileChooserSetCurrentFolder dialog +      F.mapM_ (Gtk.fileChooserSetCurrentName dialog) mfname        --   !!!!!! really hackish solution !!!!!!-      whileM_ (liftM (>0) eventsPending) (mainIterationDo False)+      whileM_ (liftM (>0) Gtk.eventsPending) (Gtk.mainIterationDo False)       -      res <- dialogRun dialog+      res <- Gtk.dialogRun dialog       mr <- case res of -              ResponseDeleteEvent -> return Nothing-              ResponseOk ->  fileChooserGetFilename dialog -              ResponseCancel -> return Nothing +              Gtk.ResponseDeleteEvent -> return Nothing+              Gtk.ResponseOk ->  Gtk.fileChooserGetFilename dialog +              Gtk.ResponseCancel -> return Nothing                _ -> putStrLn "??? in fileOpen" >> return Nothing -      widgetDestroy dialog+      Gtk.widgetDestroy dialog       return (UsrEv (FileChosen mr))
src/Hoodle/Coroutine/Draw.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-}@@ -7,9 +8,9 @@ ----------------------------------------------------------------------------- -- | -- Module      : Hoodle.Coroutine.Draw --- Copyright   : (c) 2011-2014 Ian-Woo Kim+-- Copyright   : (c) 2011-2015 Ian-Woo Kim ----- License     : GPL-3+-- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com> -- Stability   : experimental -- Portability : GHC@@ -20,9 +21,8 @@  -- from other packages import           Control.Applicative-import           Control.Concurrent--- import           Control.Concurrent.STM-import           Control.Lens (view,set,(^.),(%~))+import           Control.Concurrent.STM (atomically, modifyTVar')+import           Control.Lens import           Control.Monad import           Control.Monad.State import           Control.Monad.Trans.Reader (runReaderT)@@ -31,13 +31,14 @@ import           Data.Time.Clock import           Data.Time.LocalTime import qualified Graphics.Rendering.Cairo as Cairo-import           Graphics.UI.Gtk hiding (get,set)+import qualified Graphics.UI.Gtk as Gtk -- from hoodle-platform import           Control.Monad.Trans.Crtn import           Control.Monad.Trans.Crtn.Object import           Control.Monad.Trans.Crtn.Queue import           Data.Hoodle.BBox-import           Graphics.Hoodle.Render.Type.Renderer+import           Graphics.Hoodle.Render.Type+-- import           Graphics.Hoodle.Render.Type.Renderer -- from this package import           Hoodle.Accessor import           Hoodle.Type.Alias@@ -48,18 +49,19 @@ import           Hoodle.Type.PageArrangement import           Hoodle.Type.HoodleState import           Hoodle.Type.Widget+import           Hoodle.Util import           Hoodle.View.Draw--- import           Hoodle.Widget.Clock --   --- | +-- | all event nextevent :: MainCoroutine UserEvent  nextevent = do Arg DoEvent ev <- request (Res DoEvent ())                case ev of                  SysEv sev -> sysevent sev >> nextevent                   UsrEv uev -> return uev  +-- | system event  sysevent :: SystemEvent -> MainCoroutine ()  sysevent ClockUpdateEvent = do    utctime <- liftIO $ getCurrentTime @@ -69,29 +71,44 @@       (h,m,s) :: (Int,Int,Int) =          (,,) <$> (\x->todHour x `mod` 12) <*> todMin <*> (floor . todSec)          $ ltimeofday-  -- liftIO $ print (h,m,s)   xst <- get -  let cinfo = view currentCanvasInfo xst+  let uhdl = view (unitHoodles.currentUnit) xst+      cinfo = view currentCanvasInfo uhdl       cwgts = view (unboxLens canvasWidgets) cinfo          nwgts = set (clockWidgetConfig.clockWidgetTime) (h,m,s) cwgts       ncinfo = set (unboxLens canvasWidgets) nwgts cinfo-  put . set currentCanvasInfo ncinfo $ xst -              +  pureUpdateUhdl (const ((currentCanvasInfo .~ ncinfo) uhdl))   when (view (widgetConfig.doesUseClockWidget) cwgts) $ do -    let cid = getCurrentCanvasId xst+    let cid = getCurrentCanvasId uhdl     modify (tempQueue %~ enqueue (Right (UsrEv (UpdateCanvasEfficient cid))))-    -- invalidateInBBox Nothing Efficient cid    sysevent (RenderCacheUpdate (uuid, ssfc)) = do-  -- liftIO $ putStrLn "RenderCacheUpdate"-  modify (renderCache %~ HM.insert uuid ssfc)+  cachevar <- view renderCacheVar <$> get+  liftIO $ atomically $ modifyTVar' cachevar (HM.insert uuid ssfc)    b <- ( ^. doesNotInvalidate ) <$> get   when (not b) $ invalidateAll-  --  -- invalidateInBBox Nothing Efficient cid   -sysevent ev = liftIO $ print ev -+sysevent ev = msgShout (show ev) +-- | update flag in HoodleState when corresponding toggle UI changed +updateFlagFromToggleUI :: String  -- ^ UI toggle button id+                       -> Simple Lens HoodleState Bool -- ^ lens for flag +                       -> MainCoroutine Bool+updateFlagFromToggleUI toggleid lensforflag = do +  xstate <- get +  let ui = view gtkUIManager xstate +  doIOaction $ \_ -> do+    agr <- Gtk.uiManagerGetActionGroups ui >>= \x ->+             case x of +               [] -> error "No action group? "+               y:_ -> return y +    togglea <- Gtk.actionGroupGetAction agr toggleid +                 >>= maybe (error "updateFlagFromToggleUI") +                           (return . Gtk.castToToggleAction)+    b <- Gtk.toggleActionGetActive togglea+    return (UsrEv (UIEv (UIGetFlag b)))+  UIEv (UIGetFlag b) <- +    waitSomeEvent (\case UIEv (UIGetFlag _) -> True ; _ -> False) +  modify (set lensforflag b) >> return b +   -- | data DrawingFunctionSet =    DrawingFunctionSet { singleEditDraw :: DrawingFunction SinglePage EditMode@@ -108,46 +125,48 @@                   -> DrawingFunction ContinuousPage SelectMode                   -> MainCoroutine ()  invalidateGeneral cid mbbox flag drawf drawfsel drawcont drawcontsel = do -    xst <- get -    unboxBiAct (fsingle xst) (fcont xst) . getCanvasInfo cid $ xst+    xst <- get+    let uhdl = view (unitHoodles.currentUnit) xst+    cache <- renderCache+    unboxBiAct (fsingle cache uhdl) (fcont cache uhdl) . getCanvasInfo cid $ uhdl   where -    fsingle :: HoodleState -> CanvasInfo SinglePage -> MainCoroutine () -    fsingle xstate cvsInfo = do +    fsingle :: RenderCache -> UnitHoodle -> CanvasInfo SinglePage -> MainCoroutine () +    fsingle cache uhdl cvsInfo = do        let cpn = PageNum . view currentPageNum $ cvsInfo -	  isCurrentCvs = cid == getCurrentCanvasId xstate-	  epage = getCurrentPageEitherFromHoodleModeState cvsInfo (view hoodleModeState xstate)+	  isCurrentCvs = cid == getCurrentCanvasId uhdl+	  epage = getCurrentPageEitherFromHoodleModeState cvsInfo (view hoodleModeState uhdl)+          cvsid = view canvasId cvsInfo 	  cvs = view drawArea cvsInfo 	  msfc = view mDrawSurface cvsInfo -	  cache = view renderCache xstate       case epage of  	Left page -> do  -	  liftIO (unSinglePageDraw drawf cache isCurrentCvs (cvs,msfc) (cpn,page)+	  liftIO (unSinglePageDraw drawf cache cvsid isCurrentCvs (cvs,msfc) (cpn,page) 		  <$> view viewInfo <*> pure mbbox <*> pure flag $ cvsInfo ) 	  return () 	Right tpage -> do -	  liftIO (unSinglePageDraw drawfsel cache isCurrentCvs (cvs,msfc) (cpn,tpage)+	  liftIO (unSinglePageDraw drawfsel cache cvsid isCurrentCvs (cvs,msfc) (cpn,tpage) 		  <$> view viewInfo <*> pure mbbox <*> pure flag $ cvsInfo ) 	  return ()-    fcont :: HoodleState -> CanvasInfo ContinuousPage -> MainCoroutine () -    fcont xstate cvsInfo = do -      let hdlmodst = view hoodleModeState xstate -	  isCurrentCvs = cid == getCurrentCanvasId xstate-	  cache = view renderCache xstate+    fcont :: RenderCache -> UnitHoodle -> CanvasInfo ContinuousPage -> MainCoroutine () +    fcont cache uhdl cvsInfo = do +      let hdlmodst = view hoodleModeState uhdl +	  isCurrentCvs = cid == getCurrentCanvasId uhdl       case hdlmodst of  	ViewAppendState hdl -> do   	  hdl' <- liftIO (unContPageDraw drawcont cache isCurrentCvs cvsInfo mbbox hdl flag)-	  put (set hoodleModeState (ViewAppendState hdl') xstate)+          pureUpdateUhdl (const ((hoodleModeState .~ ViewAppendState hdl') uhdl)) 	SelectState thdl -> do  	  thdl' <- liftIO (unContPageDraw drawcontsel cache isCurrentCvs cvsInfo mbbox thdl flag)-	  put (set hoodleModeState (SelectState thdl') xstate) +          pureUpdateUhdl (const ((hoodleModeState .~ SelectState thdl') uhdl))            -- |           invalidateOther :: MainCoroutine ()  invalidateOther = do -  xstate <- get-  let currCvsId = getCurrentCanvasId xstate-      cinfoMap  = getCanvasInfoMap xstate+  xst <- get+  let uhdl = view (unitHoodles.currentUnit) xst+      currCvsId = getCurrentCanvasId uhdl+      cinfoMap  = view cvsInfoMap uhdl       keys = M.keys cinfoMap    mapM_ invalidate (filter (/=currCvsId) keys)   @@ -160,10 +179,11 @@                     -> DrawFlag                      -> CanvasId -> MainCoroutine () invalidateInBBox mbbox flag cid = do -  xst <- get -  geometry <- liftIO $ getCanvasGeometryCvsId cid xst -  invalidateGeneral cid mbbox flag -    (drawSinglePage geometry) (drawSinglePageSel geometry) (drawContHoodle geometry) (drawContHoodleSel geometry)+    xst <- get +    let uhdl = view (unitHoodles.currentUnit) xst+    geometry <- liftIO $ getCanvasGeometryCvsId cid uhdl+    invalidateGeneral cid mbbox flag +      (drawSinglePage geometry) (drawSinglePageSel geometry) (drawContHoodle geometry) (drawContHoodleSel geometry)  -- |  invalidateAllInBBox :: Maybe BBox -- ^ desktop coordinate @@ -173,26 +193,35 @@  -- |  invalidateAll :: MainCoroutine () -invalidateAll = invalidateAllInBBox Nothing Clear -- >> liftIO (putStrLn "The SLOW invalidateAll Called")+invalidateAll = invalidateAllInBBox Nothing Clear   -- | Invalidate Current canvas invalidateCurrent :: MainCoroutine () -invalidateCurrent = invalidate . getCurrentCanvasId =<< get+invalidateCurrent = invalidate . getCurrentCanvasId . view (unitHoodles.currentUnit) =<< get         -- | Drawing temporary gadgets invalidateTemp :: CanvasId -> Cairo.Surface -> Cairo.Render () -> MainCoroutine () invalidateTemp cid tempsurface rndr = do      xst <- get -    forBoth' unboxBiAct (fsingle xst) . getCanvasInfo cid $ xst +    let uhdl = view (unitHoodles.currentUnit) xst+    forBoth' unboxBiAct (fsingle uhdl) . getCanvasInfo cid $ uhdl   where -    fsingle :: HoodleState -> CanvasInfo a -> MainCoroutine ()   -    fsingle xstate cvsInfo = do +    fsingle :: UnitHoodle -> CanvasInfo a -> MainCoroutine ()   +    fsingle uhdl cvsInfo = do        let canvas = view drawArea cvsInfo           pnum = PageNum . view currentPageNum $ cvsInfo -      geometry <- liftIO $ getCanvasGeometryCvsId cid xstate-      win <- liftIO $ widgetGetDrawWindow canvas+      geometry <- liftIO $ getCanvasGeometryCvsId cid uhdl+#ifdef GTK3          +      Just win <- liftIO $ Gtk.widgetGetWindow canvas+#else+      win <- liftIO $ Gtk.widgetGetDrawWindow canvas+#endif        let xformfunc = cairoXform4PageCoordinate (mkXform4Page geometry pnum)-      liftIO $ renderWithDrawable win $ do   +#ifdef GTK3              +      liftIO $ Gtk.renderWithDrawWindow win $ do +#else +      liftIO $ Gtk.renderWithDrawable win $ do   +#endif                  Cairo.setSourceSurface tempsurface 0 0                   Cairo.setOperator Cairo.OperatorSource                   Cairo.paint @@ -207,15 +236,24 @@                        -> MainCoroutine () invalidateTempBasePage cid tempsurface pnum rndr = do      xst <- get -    forBoth' unboxBiAct (fsingle xst) . getCanvasInfo cid $ xst +    let uhdl = view (unitHoodles.currentUnit) xst+    forBoth' unboxBiAct (fsingle uhdl) . getCanvasInfo cid $ uhdl   where -    fsingle :: HoodleState -> CanvasInfo a -> MainCoroutine ()-    fsingle xstate cvsInfo = do +    fsingle :: UnitHoodle -> CanvasInfo a -> MainCoroutine ()+    fsingle uhdl cvsInfo = do        let canvas = view drawArea cvsInfo-      geometry <- liftIO $ getCanvasGeometryCvsId cid xstate-      win <- liftIO $ widgetGetDrawWindow canvas+      geometry <- liftIO $ getCanvasGeometryCvsId cid uhdl+#ifdef GTK3          +      Just win <- liftIO $ Gtk.widgetGetWindow canvas+#else+      win <- liftIO $ Gtk.widgetGetDrawWindow canvas+#endif       let xformfunc = cairoXform4PageCoordinate (mkXform4Page geometry pnum)-      liftIO $ renderWithDrawable win $ do   +#ifdef GTK3              +      liftIO $ Gtk.renderWithDrawWindow win $ do   +#else +      liftIO $ Gtk.renderWithDrawable win $ do   +#endif                  Cairo.setSourceSurface tempsurface 0 0                   Cairo.setOperator Cairo.OperatorSource                   Cairo.paint @@ -232,14 +270,29 @@         invalidateInBBox Nothing Efficient cid >> waitSomeEvent p         _ -> if  p r then return r else waitSomeEvent p   +-- | +doIOaction_ :: IO a -> MainCoroutine ()+doIOaction_ action = do doIOaction $ \_ -> action >> return (UsrEv ActionOrdered)+                        waitSomeEvent (\case ActionOrdered -> True; _ -> False );+                        return () +defaultHandler :: (AllEvent -> IO ()) -> RendererEvent -> IO ()+defaultHandler evhandler (SurfaceUpdate s) = +    Gtk.postGUIAsync . evhandler . SysEv . RenderCacheUpdate $ s+defaultHandler evhandler (FinishCommandFor sfcid) =  +    Gtk.postGUIAsync . evhandler . UsrEv . RenderEv . FinishCommand $ sfcid+++-- | order rendering routine callRenderer :: Renderer RenderEvent -> MainCoroutine () callRenderer action = do-    tvar <- (^. pdfRenderQueue) <$> get  +    (tvarpdf,tvargen,tvarcache) <- ((,,)<$>(^. pdfRenderQueue)<*>(^. genRenderQueue)<*>(^. renderCacheVar))<$>get       doIOaction $ \evhandler -> do-      let handler = postGUIAsync . evhandler . SysEv . RenderCacheUpdate-      UsrEv . RenderEv <$> runReaderT action (handler,tvar)-+      -- let handler (SurfaceUpdate s) = +      --       Gtk.postGUIAsync . evhandler . SysEv . RenderCacheUpdate $ s+      --     handler (FinishCommandFor sfcid) =+      --       Gtk.postGUIAsync . evhandler . UsrEv . RenderEv . FinishCommand $ sfcid+      UsrEv . RenderEv <$> runReaderT action (RendererState (defaultHandler evhandler) tvarpdf tvargen tvarcache)  callRenderer_ :: Renderer a -> MainCoroutine () callRenderer_ action = do
src/Hoodle/Coroutine/Eraser.hs view
@@ -1,9 +1,9 @@ ----------------------------------------------------------------------------- -- | -- Module      : Hoodle.Coroutine.Eraser --- Copyright   : (c) 2011-2014 Ian-Woo Kim+-- Copyright   : (c) 2011-2015 Ian-Woo Kim ----- License     : GPL-3+-- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com> -- Stability   : experimental -- Portability : GHC@@ -13,10 +13,9 @@ module Hoodle.Coroutine.Eraser where  import qualified Data.IntMap as IM-import           Control.Lens (view,set,over)+import           Control.Lens (view,set,over,(.~)) import           Control.Monad.State  import qualified Control.Monad.State as St--- import Graphics.UI.Gtk hiding (get,set,disconnect) --  import Data.Hoodle.Generic import Graphics.Hoodle.Render@@ -43,9 +42,9 @@ -- | eraserStart :: CanvasId                 -> PointerCoord -               -> MainCoroutine () -eraserStart cid = commonPenStart eraserAction cid  -  where eraserAction _cinfo pnum geometry (x,y) = do +               -> MainCoroutine ()+eraserStart cid = commonPenStart eraserAction cid  >=> const (return ())+  where eraserAction _cinfo pnum geometry (x,y) _ = do            itms <- rItmsInCurrLyr           eraserProcess cid pnum geometry itms (x,y) @@ -60,7 +59,7 @@ eraserProcess cid pnum geometry itms (x0,y0) = do      r <- nextevent      xst <- get-    forBoth' unboxBiAct (f r xst) . getCanvasInfo cid $ xst +    forBoth' unboxBiAct (f r xst) . getCanvasInfo cid . view (unitHoodles.currentUnit) $ xst    where      f :: UserEvent -> HoodleState -> CanvasInfo a -> MainCoroutine ()     f r xstate cvsInfo = penMoveAndUpOnly r pnum geometry defact @@ -75,19 +74,18 @@       if hitState          then do            page <- getCurrentPageCvsId cid -          let currhdl     = unView . view hoodleModeState $ xstate -              dim         = view gdimension page+          let uhdl = view (unitHoodles.currentUnit) xstate+              currhdl     = unView . view hoodleModeState $ uhdl               pgnum       = view currentPageNum cvsInfo               currlayer   = getCurrentLayer page-              cache       = view renderCache xstate-          let (newitms,maybebbox) = St.runState (eraseHitted hittestitem) Nothing-          newlayerbbox <- liftIO . updateLayerBuf cache dim maybebbox -                          . set gitems newitms $ currlayer +          let (newitms,_maybebbox) = St.runState (eraseHitted hittestitem) Nothing+              newlayerbbox = set gitems newitms currlayer+          callRenderer_ $ updateLayerBuf cid newlayerbbox           let newpagebbox = adjustCurrentLayer newlayerbbox page                newhdlbbox = over gpages (IM.adjust (const newpagebbox) pgnum) currhdl               newhdlmodst = ViewAppendState newhdlbbox-          commit . set hoodleModeState newhdlmodst -            =<< (liftIO (updatePageAll newhdlmodst xstate))+          uhdl' <- liftIO (updatePageAll newhdlmodst uhdl)+          commit $ (unitHoodles.currentUnit .~ ((hoodleModeState .~ newhdlmodst) uhdl')) xstate           invalidateInBBox Nothing Efficient cid            nitms <- rItmsInCurrLyr           eraserProcess cid pnum geometry nitms (x,y)
src/Hoodle/Coroutine/File.hs view
@@ -6,9 +6,9 @@ ----------------------------------------------------------------------------- -- | -- Module      : Hoodle.Coroutine.File --- Copyright   : (c) 2011-2014 Ian-Woo Kim+-- Copyright   : (c) 2011-2015 Ian-Woo Kim ----- License     : GPL-3+-- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com> -- Stability   : experimental -- Portability : GHC@@ -18,34 +18,34 @@ module Hoodle.Coroutine.File where  -- from other packages-import           Control.Applicative ((<$>),(<*>))-import           Control.Concurrent-import           Control.Lens (view,set,over,(%~), (.~))+import           Control.Applicative+import           Control.Lens (at,view,set,over,(.~)) import           Control.Monad.State hiding (mapM,mapM_,forM_) import           Control.Monad.Trans.Either import           Control.Monad.Trans.Maybe (MaybeT(..))--- import           Control.Monad.Trans.Reader (runReaderT)-import           Data.Attoparsec (parseOnly)+import           Data.Attoparsec.ByteString.Char8 (parseOnly) import           Data.ByteString.Char8 as B (pack,unpack,readFile) import qualified Data.ByteString.Lazy as L import           Data.Digest.Pure.MD5 (md5) import           Data.Foldable (mapM_,forM_) import qualified Data.List as List  import           Data.Maybe-import qualified Data.IntMap as IM import           Data.Time.Clock-import           Filesystem.Path.CurrentOS (decodeString, encodeString) import qualified Graphics.Rendering.Cairo as Cairo-import qualified Graphics.UI.Gtk as Gtk -- hiding (get,set)+import qualified Graphics.UI.Gtk as Gtk  import           System.Directory import           System.FilePath-import qualified System.FSNotify as FS import           System.IO (hClose, hFileSize, openFile, IOMode(..)) import           System.Process +#ifdef HUB+import           Control.Concurrent+import qualified Control.Exception as E+import           Control.Monad.Trans.Reader+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+#endif -- from hoodle-platform import           Control.Monad.Trans.Crtn-import           Control.Monad.Trans.Crtn.Queue --- import           Data.Hoodle.BBox import           Data.Hoodle.Generic import           Data.Hoodle.Simple import           Data.Hoodle.Select@@ -54,49 +54,55 @@ import           Graphics.Hoodle.Render.Item import           Graphics.Hoodle.Render.Type import           Graphics.Hoodle.Render.Type.HitTest +import           Hoodle.Publish.PDF (renderHoodleToPDF) import           Text.Hoodle.Builder  import           Text.Hoodle.Migrate.FromXournal import qualified Text.Hoodlet.Parse.Attoparsec as Hoodlet import qualified Text.Xournal.Parse.Conduit as XP--- import qualified Text.Hoodlet.Parse.Attoparsec as Hoodlet -- from this package  import           Hoodle.Accessor import           Hoodle.Coroutine.Dialog import           Hoodle.Coroutine.Draw import           Hoodle.Coroutine.Commit+import           Hoodle.Coroutine.Layer import           Hoodle.Coroutine.Minibuffer import           Hoodle.Coroutine.Mode  import           Hoodle.Coroutine.Page import           Hoodle.Coroutine.Scroll+import           Hoodle.Coroutine.Select.Clipboard import           Hoodle.Coroutine.TextInput--- import           Hoodle.Coroutine.Window+import           Hoodle.GUI.Reflect import           Hoodle.ModelAction.File import           Hoodle.ModelAction.Layer  import           Hoodle.ModelAction.Page import           Hoodle.ModelAction.Select--- import           Hoodle.ModelAction.Select.Transform import           Hoodle.ModelAction.Window import qualified Hoodle.Script.Coroutine as S import           Hoodle.Script.Hook import           Hoodle.Type.Canvas import           Hoodle.Type.Coroutine+import           Hoodle.Type.Enum import           Hoodle.Type.Event hiding (TypSVG) import           Hoodle.Type.HoodleState import           Hoodle.Type.PageArrangement import           Hoodle.Util+#ifdef HUB+import           Hoodle.Coroutine.Hub+import           Hoodle.Coroutine.Hub.Common+import           Hoodle.Coroutine.HubInternal+import           Hoodle.Type.Hub+import           Hoodle.Type.Synchronization+#endif -- import Prelude hiding (readFile,concat,mapM,mapM_)  -- |  askIfSave :: MainCoroutine () -> MainCoroutine ()  askIfSave action = do -    xstate <- get -    if not (view isSaved xstate)-      then do  -        b <- okCancelMessageBox "Current canvas is not saved yet. Will you proceed without save?" -        case b of -          True -> action -          False -> return () +    uhdl <- view (unitHoodles.currentUnit) <$> get +    if not (view isSaved uhdl)+      then +        okCancelMessageBox "Current canvas is not saved yet. Will you proceed without save?" >>= flip when action       else action   -- | @@ -110,9 +116,9 @@       else action   --- | get file content from xournal file and update xournal state -getFileContent :: Maybe FilePath -> MainCoroutine ()-getFileContent (Just fname) = do +-- | get file content from xournal file and update hoodle state +getFileContent :: FileStore -> MainCoroutine ()+getFileContent store@(LocalDir (Just fname)) = do      xstate <- get     let ext = takeExtension fname     case ext of @@ -124,39 +130,75 @@           Right h -> do              constructNewHoodleStateFromHoodle h             ctime <- liftIO $ getCurrentTime-            modify ( hoodleFileControl.hoodleFileName .~ Just fname )-            modify ( hoodleFileControl.lastSavedTime  .~ Just ctime )+#ifdef HUB+            -- let uhdluuid = view (unitHoodles.currentUnit.unitUUID) xstate+            msqlfile <- view (settings.sqliteFileName) <$> get+            let fileuuidbstr = view hoodleID h+                fileuuidtxt = TE.decodeUtf8 fileuuidbstr+            liftIO $ print fileuuidtxt+            mfstat <- case msqlfile of+              Nothing -> return Nothing+              Just sqlfile -> liftIO (getLastSyncStatus sqlfile fileuuidtxt)+            let mmd5 = fileSyncStatusMd5 <$> mfstat+#else +            let mmd5 = Nothing +#endif    +            pureUpdateUhdl ( (hoodleFileControl.hoodleFileName .~ store)+                           . (hoodleFileControl.lastSavedTime  .~ Just ctime) +                           . (hoodleFileControl.syncMD5History .~ maybeToList mmd5)  )             commit_       ".xoj" -> do            liftIO (XP.parseXojFile fname) >>= \x -> case x of  -            Left str -> liftIO $ putStrLn $ "file reading error : " ++ str +            Left str -> msgShout $ "file reading error : " ++ str              Right xojcontent -> do                hdlcontent <- liftIO $ mkHoodleFromXournal xojcontent                constructNewHoodleStateFromHoodle hdlcontent               ctime <- liftIO $ getCurrentTime -              modify ( hoodleFileControl.hoodleFileName .~ Just fname )-              modify ( hoodleFileControl.lastSavedTime  .~ Just ctime ) +              pureUpdateUhdl ( (hoodleFileControl.hoodleFileName .~ LocalDir Nothing)+                             . (hoodleFileControl.lastSavedTime  .~ Just ctime) )               commit_       ".pdf" -> do          let doesembed = view (settings.doesEmbedPDF) xstate         mhdl <- liftIO $ makeNewHoodleWithPDF doesembed fname          case mhdl of -          Nothing -> getFileContent Nothing+          Nothing -> getFileContent (LocalDir Nothing)           Just hdl -> do              constructNewHoodleStateFromHoodle hdl-            modify ( hoodleFileControl.hoodleFileName .~ Nothing)+            pureUpdateUhdl (hoodleFileControl.hoodleFileName .~ LocalDir Nothing)             commit_-      _ -> getFileContent Nothing    +      _ -> getFileContent (LocalDir Nothing)     xstate' <- get-    doIOaction $ \evhandler -> do -      Gtk.postGUIAsync (setTitleFromFileName xstate')-      return (UsrEv ActionOrdered)-    ActionOrdered <- waitSomeEvent (\case ActionOrdered -> True ; _ -> False )-    return ()-getFileContent Nothing = do+    doIOaction_ $ Gtk.postGUIAsync (setTitleFromFileName xstate')+getFileContent (LocalDir Nothing) = do     constructNewHoodleStateFromHoodle =<< liftIO defaultHoodle -    modify ( hoodleFileControl.hoodleFileName .~ Nothing ) +    pureUpdateUhdl (hoodleFileControl.hoodleFileName .~ LocalDir Nothing)      commit_ +#ifdef HUB+getFileContent store@(TempDir fname) = do +    -- xstate <- get+    -- let uhdluuid = view (unitHoodles.currentUnit.unitUUID) xstate+    let ext = takeExtension fname+    when (ext == ".hdl") $ do+      bstr <- liftIO $ B.readFile fname+      r <- liftIO $ checkVersionAndMigrate bstr +      case r of +        Left err -> liftIO $ putStrLn err+        Right h -> do +          constructNewHoodleStateFromHoodle h+          ctime <- liftIO $ getCurrentTime+          let -- fileuuidbstr = view hoodleID h+              -- fileuuidtxt = TE.decodeUtf8 fileuuidbstr+              md5txt = T.pack . show . md5 . L.fromStrict $ bstr+          pureUpdateUhdl ( (hoodleFileControl.hoodleFileName .~ store)+                         . (hoodleFileControl.lastSavedTime  .~ Just ctime) +                         . (hoodleFileControl.syncMD5History .~ [md5txt] ) +                         )+          commit_+          xstate' <- get+          doIOaction_ $ Gtk.postGUIAsync (setTitleFromFileName xstate')+#else+getFileContent _ = return ()+#endif   -- |@@ -164,32 +206,35 @@ constructNewHoodleStateFromHoodle hdl' = do      callRenderer $ cnstrctRHoodle hdl' >>= return . GotRHoodle     RenderEv (GotRHoodle rhdl) <- waitSomeEvent (\case RenderEv (GotRHoodle _) -> True; _ -> False)-    modify (hoodleModeState .~ ViewAppendState rhdl)-+    pureUpdateUhdl (hoodleModeState .~ ViewAppendState rhdl) --- | +-- | deprecated fileNew :: MainCoroutine () -fileNew = do  -    getFileContent Nothing-    xstate' <- get -    ncvsinfo <- liftIO $ setPage xstate' 0 (getCurrentCanvasId xstate')-    xstate'' <- return $ over currentCanvasInfo (const ncvsinfo) xstate'-    liftIO $ setTitleFromFileName xstate''-    commit xstate'' +fileNew = do +    getFileContent (LocalDir Nothing)+    updateUhdl $ \uhdl -> do+      ncvsinfo <- liftIO $ setPage uhdl 0 (getCurrentCanvasId uhdl)+      return $ (currentCanvasInfo .~ ncvsinfo) uhdl+    xst <- get+    liftIO (setTitleFromFileName xst)+    commit_     invalidateAll   -- |  fileSave :: MainCoroutine () fileSave = do -    xstate <- get -    case view (hoodleFileControl.hoodleFileName) xstate of+    uhdl <- view (unitHoodles.currentUnit) <$> get+    case getHoodleFilePath uhdl of       Nothing -> fileSaveAs        Just filename -> do              -- this is rather temporary not to make mistake          if takeExtension filename == ".hdl"            then do -             put =<< (liftIO (saveHoodle xstate))-             (S.afterSaveHook filename . rHoodle2Hoodle . getHoodle) xstate+             updateUhdl $ liftIO . saveHoodle . const uhdl +             (S.afterSaveHook filename . rHoodle2Hoodle . getHoodle) uhdl+#ifdef HUB+             hubUpload+#endif           else fileExtensionInvalid (".hdl","save") >> fileSaveAs   -- | interleaving a monadic action between each pair of subsequent actions@@ -199,63 +244,16 @@ sequence1_ i (a:as) = a >> i >> sequence1_ i as   -- | -renderjob :: RenderCache -> RHoodle -> FilePath -> IO () -renderjob cache h ofp = do -  let p = maybe (error "renderjob") id $ IM.lookup 0 (view gpages h)  -  let Dim width height = view gdimension p  -  let rf x = cairoRenderOption (RBkgDrawPDF,DrawFull) cache (x,Nothing :: Maybe Xform4Page) >> return () -  Cairo.withPDFSurface ofp width height $ \s -> Cairo.renderWith s $  -    (sequence1_ Cairo.showPage . map rf . IM.elems . view gpages ) h ---- |  fileExport :: MainCoroutine () fileExport = fileChooser Gtk.FileChooserActionSave Nothing >>= maybe (return ()) action    where -    action filename = +    action filename = do       -- this is rather temporary not to make mistake        if takeExtension filename /= ".pdf" -      then fileExtensionInvalid (".pdf","export") >> fileExport -      else do      -        xstate <- get -        let hdl = getHoodle xstate -            cache = view renderCache xstate-        liftIO (renderjob cache hdl filename) ---- | -fileStartSync :: MainCoroutine ()-fileStartSync = do -  xst <- get -  let mf = (,) <$> view (hoodleFileControl.hoodleFileName) xst <*> view (hoodleFileControl.lastSavedTime) xst -  maybe (return ()) (\(filename,lasttime) -> action filename lasttime) mf  -  where  -    action filename _lasttime  = do -      let ioact = mkIOaction $ \evhandler ->do -            forkIO $ do -              FS.withManager $ \wm -> do -                origfile <- canonicalizePath filename -                let (filedir,_) = splitFileName origfile-                print filedir -                _ <- FS.watchDir wm (decodeString filedir) (const True) $ \ev -> do-                  let mchangedfile = case ev of -                        FS.Added fp _ -> Just (encodeString fp)-                        FS.Modified fp _ -> Just (encodeString fp)-                        FS.Removed _fp _ -> Nothing -                  print mchangedfile -                  case mchangedfile of -                    Nothing -> return ()-                    Just changedfile -> do                       -                      let changedfilename = takeFileName changedfile -                          changedfile' = (filedir </> changedfilename)-                      if changedfile' == origfile -                        then do -                          ctime <- getCurrentTime -                          evhandler (UsrEv (Sync ctime))-                        else return () --                let sec = 1000000-                forever (threadDelay (100 * sec))-            return (UsrEv ActionOrdered)-      modify (tempQueue %~ enqueue ioact) +        then fileExtensionInvalid (".pdf","export") >> fileExport +        else do      +          hdl <- rHoodle2Hoodle . getHoodle . view (unitHoodles.currentUnit) <$> get+          liftIO (renderHoodleToPDF hdl filename)   -- | need to be merged with ContextMenuEventSVG exportCurrentPageAsSVG :: MainCoroutine ()@@ -266,25 +264,27 @@       if takeExtension filename /= ".svg"        then fileExtensionInvalid (".svg","export") >> exportCurrentPageAsSVG        else do-        cache <- view renderCache <$> get+        cvsid <- getCurrentCanvasId . view (unitHoodles.currentUnit) <$> get+        cache <- renderCache         cpg <- getCurrentPageCurr         let Dim w h = view gdimension cpg          liftIO $ Cairo.withSVGSurface filename w h $ \s -> Cairo.renderWith s $ -         cairoRenderOption (InBBoxOption Nothing) cache (InBBox cpg,Nothing :: Maybe Xform4Page) >> return ()+         cairoRenderOption (InBBoxOption Nothing) cache cvsid (InBBox cpg,Nothing :: Maybe Xform4Page) >> return ()  -- | -fileLoad :: FilePath -> MainCoroutine () -fileLoad filename = do-    getFileContent (Just filename)-    xstate <- get -    ncvsinfo <- liftIO $ setPage xstate 0 (getCurrentCanvasId xstate)-    xstateNew <- return $ over currentCanvasInfo (const ncvsinfo) xstate-    put . set isSaved True $ xstateNew -    let ui = view gtkUIManager xstateNew-    liftIO $ toggleSave ui False-    liftIO $ setTitleFromFileName xstateNew  +fileLoad :: FileStore -> MainCoroutine () +fileLoad filestore = do+    getFileContent filestore+    updateUhdl $ \uhdl -> do +      ncvsinfo <- liftIO $ setPage uhdl 0 (getCurrentCanvasId uhdl)+      return . (currentCanvasInfo .~ ncvsinfo) . (isSaved .~ True) $ uhdl+    xst <- get +    let ui = view gtkUIManager xst+    liftIO $ reflectUIToggle ui "SAVEA" False+    liftIO $ setTitleFromFileName xst     clearUndoHistory      modeChange ToViewAppendMode +    canvasZoomUpdateAll     resetHoodleBuffers      invalidateAll      applyActionToAllCVS adjustScrollbarWithGeometryCvsId@@ -292,78 +292,75 @@ -- |  resetHoodleBuffers :: MainCoroutine ()  resetHoodleBuffers = do -    liftIO $ putStrLn "resetHoodleBuffers called"-    xst <- get -    nhdlst <- liftIO $ resetHoodleModeStateBuffers  -                         (view renderCache xst)-                         (view hoodleModeState xst)-    let nxst = set hoodleModeState nhdlst xst-    put nxst     +    updateUhdl $ \uhdl -> do +      let hdlst = view hoodleModeState uhdl+          cvsid = getCurrentCanvasId uhdl+      callRenderer_ $ resetHoodleModeStateBuffers cvsid hdlst+      return . (hoodleModeState .~ hdlst) $ uhdl + -- | main coroutine for open a file  fileOpen :: MainCoroutine () fileOpen = do      mfilename <- fileChooser Gtk.FileChooserActionOpen Nothing-    forM_ mfilename fileLoad +    forM_ mfilename (fileLoad . LocalDir . Just)  -- | main coroutine for save as  fileSaveAs :: MainCoroutine ()  fileSaveAs = do -    xstate <- get -    let hdl = (rHoodle2Hoodle . getHoodle) xstate-    maybe (defSaveAsAction xstate hdl) (\f -> liftIO (f hdl))-          (hookSaveAsAction xstate) +    hdl <- (rHoodle2Hoodle . getHoodle . view (unitHoodles.currentUnit)) <$> get+    maybe (defSaveAsAction hdl) (\f -> liftIO (f hdl)) =<< hookSaveAsAction   where -    hookSaveAsAction xstate = do -      hset <- view hookSet xstate-      saveAsHook hset-    defSaveAsAction xstate hdl = do -        let msuggestedact = view hookSet xstate >>= fileNameSuggestionHook -        (msuggested :: Maybe String) <- maybe (return Nothing) (liftM Just . liftIO) msuggestedact +    hookSaveAsAction = (saveAsHook <=< view hookSet) <$> get+    msuggestedact = (fileNameSuggestionHook <=< view hookSet) <$> get+    defSaveAsAction hdl = do +        (msuggested :: Maybe String) <- maybe (return Nothing) (liftM Just . liftIO) =<< msuggestedact          mr <- fileChooser Gtk.FileChooserActionSave msuggested -        maybe (return ()) (action xstate hdl) mr -      where action xst' hd filename = +        maybe (return ()) (action hdl) mr +      where action hd filename =                if takeExtension filename /= ".hdl"                then fileExtensionInvalid (".hdl","save")               else do -                askIfOverwrite filename $ do -                  let ntitle = B.pack . snd . splitFileName $ filename -                      (hdlmodst',hdl') = case view hoodleModeState xst' of-                         ViewAppendState hdlmap -> -                           if view gtitle hdlmap == "untitled"-                             then ( ViewAppendState . set gtitle ntitle-                                    $ hdlmap-                                  , (set title ntitle hd))-                             else (ViewAppendState hdlmap,hd)-                         SelectState thdl -> -                           if view gselTitle thdl == "untitled"-                             then ( SelectState $ set gselTitle ntitle thdl -                                  , set title ntitle hd)  -                             else (SelectState thdl,hd)-                      xstateNew = set (hoodleFileControl.hoodleFileName) (Just filename) -                                . set hoodleModeState hdlmodst' $ xst'-                  liftIO . L.writeFile filename . builder $ hdl'-                  put . set isSaved True $ xstateNew    -                  let ui = view gtkUIManager xstateNew-                  liftIO $ toggleSave ui False-                  liftIO $ setTitleFromFileName xstateNew -                  S.afterSaveHook filename hdl'-          +                askIfOverwrite filename $ do+                  updateUhdl $ \uhdl -> do+                    let ntitle = B.pack . snd . splitFileName $ filename +                        (hdlmodst',hdl') = case view hoodleModeState uhdl of+                           ViewAppendState hdlmap -> +                             if view gtitle hdlmap == "untitled"+                               then ( ViewAppendState . set gtitle ntitle+                                      $ hdlmap+                                    , (set title ntitle hd))+                               else (ViewAppendState hdlmap,hd)+                           SelectState thdl -> +                             if view gselTitle thdl == "untitled"+                               then ( SelectState $ set gselTitle ntitle thdl +                                    , set title ntitle hd)  +                               else (SelectState thdl,hd)+                    liftIO . L.writeFile filename . builder $ hdl'+                    return . (hoodleFileControl.hoodleFileName .~ LocalDir (Just filename))+                           . (hoodleModeState .~ hdlmodst') +                           . (isSaved .~ True)+                           $ uhdl+                xst <- get+                let ui = view gtkUIManager xst+                    hdl'' = (rHoodle2Hoodle . getHoodle . view (unitHoodles.currentUnit)) xst+                liftIO $ reflectUIToggle ui "SAVEA" False+                liftIO $ setTitleFromFileName xst+                S.afterSaveHook filename hdl''+#ifdef HUB+                hubUpload          +#endif  -- | main coroutine for open a file  fileReload :: MainCoroutine ()-fileReload = do -    xstate <- get-    case view (hoodleFileControl.hoodleFileName) xstate of -      Nothing -> return () -      Just filename -> do-        if not (view isSaved xstate) -          then do-            b <- okCancelMessageBox "Discard changes and reload the file?" -            case b of -              True -> fileLoad filename -              False -> return ()-          else fileLoad filename+fileReload = do+    uhdl <- view (unitHoodles.currentUnit) <$> get+    let filestore = view (hoodleFileControl.hoodleFileName) uhdl+    if not (view isSaved uhdl) +      then do+        b <- okCancelMessageBox "Discard changes and reload the file?" +        when b (fileLoad filestore)+      else fileLoad filestore  -- |  fileExtensionInvalid :: (String,String) -> MainCoroutine ()@@ -387,11 +384,10 @@       mhdl <- liftIO $ makeNewHoodleWithPDF doesembed filename        flip (maybe warning) mhdl $ \hdl -> do          constructNewHoodleStateFromHoodle hdl-        modify ( hoodleFileControl.hoodleFileName .~ Nothing)+        pureUpdateUhdl (hoodleFileControl.hoodleFileName .~ LocalDir Nothing)         commit_                 setTitleFromFileName_          canvasZoomUpdateAll-        -- invalidateAll           -- | set frame title according to file name@@ -427,11 +423,45 @@ fileLoadPNGorJPG = do      fileChooser Gtk.FileChooserActionOpen Nothing >>= maybe (return ()) embedImage ++-- | +fileLoadImageBackground :: MainCoroutine ()+fileLoadImageBackground = do +    fileChooser Gtk.FileChooserActionOpen Nothing >>= maybe (return ()) action+  where +    action filename = do +      xst <- get+      let fDoesEmbedImg = view (settings.doesEmbedImage) xst+          uhdl = view (unitHoodles.currentUnit) xst+          hdl = getHoodle uhdl+          Dim pw _ph = (view gdimension . fromJust . view (gpages.at 0)) hdl ++      itm <- if fDoesEmbedImg +               then checkEmbedImageSize filename +                    >>= maybe (liftIO $ makeNewItemImage True filename) +                              (liftIO . makeNewItemImage True)+               else liftIO (makeNewItemImage False filename)+      let ItemImage img = itm+          Dim w h = img_dim img+          ratio = h/w +          ndim = Dim pw (pw*ratio)+          img' = img { img_dim = ndim }+      changePage (const 0)+      newPage (Just ndim) PageBefore+      callRenderer $ cnstrctRItem (ItemImage img') >>= return . GotRItem +      RenderEv (GotRItem nitm) <- waitSomeEvent (\case RenderEv (GotRItem _) -> True ; _ -> False)+      insertItemAt (Just (PageNum 0, PageCoord (0,0))) nitm+      modeChange ToViewAppendMode+      makeNewLayer++ embedImage :: FilePath -> MainCoroutine () embedImage filename = do  -    xst <- get +    xst <- get+    let fDoesEmbedImg = view (settings.doesEmbedImage) xst+        uhdl = view (unitHoodles.currentUnit) xst     nitm <- -      if view (settings.doesEmbedImage) xst+      if fDoesEmbedImg          then do             mf <- checkEmbedImageSize filename            --@@ -445,7 +475,7 @@           RenderEv (GotRItem r) <- waitSomeEvent (\case RenderEv (GotRItem _) -> True ; _ -> False )           return r -    let cpn = view (currentCanvasInfo . unboxLens currentPageNum) xst+    let cpn = view (currentCanvasInfo . unboxLens currentPageNum) uhdl     my <- autoPosText      let mpos = (\y->(PageNum cpn,PageCoord (50,y)))<$>my       insertItemAt mpos nitm @@ -457,11 +487,12 @@     fileChooser Gtk.FileChooserActionOpen Nothing >>= maybe (return ()) action    where      action filename = do -      xstate <- get -      liftIO $ putStrLn filename +      xst <- get        bstr <- liftIO $ B.readFile filename -      let pgnum = view (currentCanvasInfo . unboxLens currentPageNum) xstate-          hdl = getHoodle xstate +      let uhdl = view (unitHoodles.currentUnit) xst+          cvsid = getCurrentCanvasId uhdl+          pgnum = view (currentCanvasInfo . unboxLens currentPageNum) uhdl+          hdl = getHoodle uhdl           currpage = getPageFromGHoodleMap pgnum hdl           currlayer = getCurrentLayer currpage       --@@ -472,14 +503,14 @@       let otheritems = view gitems currlayer         let ntpg = makePageSelectMode currpage (otheritems :- (Hitted [newitem]) :- Empty)         modeChange ToSelectMode -      nxstate <- get -      let cache = view renderCache nxstate-      thdl <- case view hoodleModeState nxstate of-                SelectState thdl' -> return thdl'-                _ -> (lift . EitherT . return . Left . Other) "fileLoadSVG"-      nthdl <- liftIO $ updateTempHoodleSelectIO cache thdl ntpg pgnum -      put ( ( set hoodleModeState (SelectState nthdl) -            . set isOneTimeSelectMode YesAfterSelect) nxstate)+      updateUhdl $ \uhdl' -> do+        thdl <- case view hoodleModeState uhdl' of+                  SelectState thdl' -> return thdl'+                  _ -> (lift . EitherT . return . Left . Other) "fileLoadSVG"+        nthdl <- updateTempHoodleSelectM cvsid thdl ntpg pgnum +        return . (hoodleModeState .~ SelectState nthdl)+               . (isOneTimeSelectMode .~ YesAfterSelect) $ uhdl'+      commit_       invalidateAll   -- |@@ -487,7 +518,7 @@ askQuitProgram = do      b <- okCancelMessageBox "Current canvas is not saved yet. Will you close hoodle?"      case b of -      True -> liftIO Gtk.mainQuit+      True -> doIOaction_ $ Gtk.postGUIAsync Gtk.mainQuit >> return (UsrEv ActionOrdered)       False -> return ()    -- | @@ -517,11 +548,10 @@ -- |  embedAllPDFBackground :: MainCoroutine ()  embedAllPDFBackground = do -  xst <- get -  let hdl = getHoodle xst+  hdl <- (rHoodle2Hoodle  . getHoodle . view (unitHoodles.currentUnit)) <$> get   nhdl <- liftIO . embedPDFInHoodle $ hdl-  modeChange ToViewAppendMode-  commit (set hoodleModeState (ViewAppendState nhdl) xst)+  constructNewHoodleStateFromHoodle nhdl+  commit_   invalidateAll       -- | embed an item from hoodlet using hoodlet identifier@@ -547,11 +577,11 @@     return (md5str,name)   -mkRevisionPdfFile :: RenderCache -> RHoodle -> String -> IO ()-mkRevisionPdfFile cache hdl fname = do +mkRevisionPdfFile :: Hoodle -> String -> IO ()+mkRevisionPdfFile hdl fname = do      hdir <- getHomeDirectory     tempfile <- mkTmpFile "pdf"-    renderjob cache hdl tempfile +    renderHoodleToPDF hdl tempfile      let nfilename = fname <.> "pdf"         vcsdir = hdir </> ".hoodle.d" </> "vcs"     b <- doesDirectoryExist vcsdir @@ -561,67 +591,73 @@ -- |  fileVersionSave :: MainCoroutine ()  fileVersionSave = do -    rhdl <- getHoodle <$> get -    cache <- view renderCache <$> get-    let hdl = rHoodle2Hoodle rhdl+    hdl <- rHoodle2Hoodle . getHoodle . view (unitHoodles.currentUnit) <$> get     rmini <- minibufDialog "Commit Message:"     case rmini of        Right [] -> return ()       Right strks' -> do         doIOaction $ \_evhandler -> do            (md5str,fname) <- mkRevisionHdlFile hdl-          mkRevisionPdfFile cache rhdl fname+          mkRevisionPdfFile hdl fname           return (UsrEv (GotRevisionInk md5str strks'))         r <- waitSomeEvent (\case GotRevisionInk _ _ -> True ; _ -> False )         let GotRevisionInk md5str strks = r                       nrev = RevisionInk (B.pack md5str) strks-        modify (\xst -> let hdlmodst = view hoodleModeState xst -                        in case hdlmodst of -                             ViewAppendState rhdl' -> -                               let nrhdl = over grevisions (<> [nrev]) rhdl' -                               in set hoodleModeState (ViewAppendState nrhdl) xst -                             SelectState thdl -> -                               let nthdl = over gselRevisions (<> [nrev]) thdl-                               in set hoodleModeState (SelectState nthdl) xst)+        pureUpdateUhdl $ \uhdl -> +          let hdlmodst = view hoodleModeState uhdl+          in case hdlmodst of +               ViewAppendState rhdl' -> +                 let nrhdl = over grevisions (<> [nrev]) rhdl' +                 in (hoodleModeState .~ ViewAppendState nrhdl) uhdl+               SelectState thdl -> +                 let nthdl = over gselRevisions (<> [nrev]) thdl+                 in (hoodleModeState .~ SelectState nthdl) uhdl         commit_        Left () -> do -        txtstr <- maybe "" id <$> textInputDialog+        txtstr <- maybe "" id <$> textInputDialog "revision description"         doIOaction $ \_evhandler -> do            (md5str,fname) <- mkRevisionHdlFile hdl-          mkRevisionPdfFile cache rhdl fname+          mkRevisionPdfFile hdl fname           return (UsrEv (GotRevision md5str txtstr))         r <- waitSomeEvent (\case GotRevision _ _ -> True ; _ -> False )         let GotRevision md5str txtstr' = r                       nrev = Revision (B.pack md5str) (B.pack txtstr')-        modify (\xst -> let hdlmodst = view hoodleModeState xst -                        in case hdlmodst of -                             ViewAppendState rhdl' -> -                               let nrhdl = over grevisions (<> [nrev]) rhdl' -                               in set hoodleModeState (ViewAppendState nrhdl) xst -                             SelectState thdl -> -                               let nthdl = over gselRevisions (<> [nrev]) thdl-                               in set hoodleModeState (SelectState nthdl) xst)+        pureUpdateUhdl $ \uhdl -> +          let hdlmodst = view hoodleModeState uhdl+          in case hdlmodst of +               ViewAppendState rhdl' -> +                 let nrhdl = over grevisions (<> [nrev]) rhdl' +                 in (hoodleModeState .~ ViewAppendState nrhdl) uhdl+               SelectState thdl -> +                 let nthdl = over gselRevisions (<> [nrev]) thdl+                 in (hoodleModeState .~ SelectState nthdl) uhdl         commit_     showRevisionDialog :: Hoodle -> [Revision] -> MainCoroutine ()-showRevisionDialog hdl revs = -    liftM (view renderCache) get >>= \cache -> -    modify (tempQueue %~ enqueue (action cache)) -    >> waitSomeEvent (\case GotOk -> True ; _ -> False)-    >> return ()+showRevisionDialog hdl revs = do+    cvsid <- getCurrentCanvasId . view (unitHoodles.currentUnit) <$> get+    cache <- renderCache+    doIOaction (action (cache,cvsid))+    waitSomeEvent (\case GotOk -> True ; _ -> False)+    return ()   where -    action cache -       = mkIOaction $ \_evhandler -> do -               dialog <- Gtk.dialogNew-               vbox <- Gtk.dialogGetUpper dialog-               mapM_ (addOneRevisionBox cache vbox hdl) revs -               _btnOk <- Gtk.dialogAddButton dialog "Ok" Gtk.ResponseOk-               Gtk.widgetShowAll dialog-               _res <- Gtk.dialogRun dialog-               Gtk.widgetDestroy dialog-               return (UsrEv GotOk)+    action (cache,cvsid) _evhandler = do +      dialog <- Gtk.dialogNew+#ifdef GTK3+      upper <- fmap Gtk.castToContainer (Gtk.dialogGetContentArea dialog)+      vbox <- Gtk.vBoxNew False 0+      Gtk.containerAdd upper vbox +#else +      vbox <- Gtk.dialogGetUpper dialog+#endif+      mapM_ (addOneRevisionBox cache cvsid vbox hdl) revs +      _btnOk <- Gtk.dialogAddButton dialog ("Ok" :: String) Gtk.ResponseOk+      Gtk.widgetShowAll dialog+      _res <- Gtk.dialogRun dialog+      Gtk.widgetDestroy dialog+      return (UsrEv GotOk)   mkPangoText :: String -> Cairo.Render ()@@ -630,7 +666,7 @@           ctxt <- Gtk.cairoCreateContext Nothing            layout <- Gtk.layoutEmpty ctxt              fdesc <- Gtk.fontDescriptionNew -          Gtk.fontDescriptionSetFamily fdesc "Sans Mono"+          Gtk.fontDescriptionSetFamily fdesc ("Sans Mono" :: String)           Gtk.fontDescriptionSetSize fdesc 8.0            Gtk.layoutSetFontDescription layout (Just fdesc)           Gtk.layoutSetWidth layout (Just 250)@@ -643,19 +679,27 @@     layout <- liftIO $ pangordr      rdr layout -addOneRevisionBox :: RenderCache -> Gtk.VBox -> Hoodle -> Revision -> IO ()-addOneRevisionBox cache vbox hdl rev = do +addOneRevisionBox :: RenderCache -> CanvasId -> Gtk.VBox -> Hoodle -> Revision -> IO ()+addOneRevisionBox cache cvsid vbox hdl rev = do      cvs <- Gtk.drawingAreaNew      cvs `Gtk.on` Gtk.sizeRequest $ return (Gtk.Requisition 250 25)     cvs `Gtk.on` Gtk.exposeEvent $ Gtk.tryEvent $ do +#ifdef GTK3      +      Just drawwdw <- liftIO $ Gtk.widgetGetWindow cvs +#else       drawwdw <- liftIO $ Gtk.widgetGetDrawWindow cvs +#endif+#ifdef GTK3+      liftIO . Gtk.renderWithDrawWindow drawwdw $ do+#else        liftIO . Gtk.renderWithDrawable drawwdw $ do +#endif         case rev of -          RevisionInk _ strks -> Cairo.scale 0.5 0.5 >> mapM_ (cairoRender cache) strks+          RevisionInk _ strks -> Cairo.scale 0.5 0.5 >> mapM_ (cairoRender cache cvsid) strks           Revision _ txt -> mkPangoText (B.unpack txt)                 hdir <- getHomeDirectory     let vcsdir = hdir </> ".hoodle.d" </> "vcs"-    btn <- Gtk.buttonNewWithLabel "view"+    btn <- Gtk.buttonNewWithLabel ("view" :: String)     btn `Gtk.on` Gtk.buttonPressEvent $ Gtk.tryEvent $ do        files <- liftIO $ getDirectoryContents vcsdir        let fstrinit = "UUID_" ++ B.unpack (view hoodleID hdl)  @@ -675,14 +719,14 @@  fileShowRevisions :: MainCoroutine () fileShowRevisions = do -    rhdl <- liftM getHoodle get  +    rhdl <- getHoodle . view (unitHoodles.currentUnit) <$> get       let hdl = rHoodle2Hoodle rhdl     let revs = view grevisions rhdl     showRevisionDialog hdl revs     fileShowUUID :: MainCoroutine () fileShowUUID = do -    hdl <- liftM getHoodle get  +    hdl <- getHoodle . view (unitHoodles.currentUnit) <$> get       let uuidstr = view ghoodleID hdl     okMessageBox (B.unpack uuidstr)   @@ -698,7 +742,7 @@          let fp = hoodletdir </> str <.> "hdlt"          bstr <- liftIO $ B.readFile fp           case parseOnly Hoodlet.hoodlet bstr of -           Left err -> liftIO $ putStrLn err >> return Nothing+           Left err -> msgShout err >> return Nothing            Right itm -> do              --              callRenderer $ cnstrctRItem itm >>= return . GotRItem @@ -709,5 +753,45 @@        else return Nothing    -  +#ifdef HUB+-- |+syncFile :: MainCoroutine ()+syncFile = do +    liftIO (putStrLn "syncFile called")+    xst <- get+    let uhdl = view (unitHoodles.currentUnit) xst+    hdir <- liftIO $ getHomeDirectory+    let tokfile = hdir </> ".hoodle.d" </> "token.txt"+    runMaybeT $ do+      let hdlidtxt = getHoodleID uhdl +      hset <- (MaybeT . return . view hookSet) xst+      hinfo <- (MaybeT . return) (hubInfo hset)+      sqlfile <- (MaybeT . return . view (settings.sqliteFileName)) xst+      hdlfp <- MaybeT . return $ getHoodleFilePath uhdl+      mfstat <- liftIO $ getLastSyncStatus sqlfile hdlidtxt +      lift $ prepareToken hinfo tokfile +      lift $ doIOaction $ \evhandler -> do +        forkIO $ (`E.catch` (\(e :: E.SomeException)-> print e >> return ())) $ +          withHub hinfo tokfile $ \manager coojar -> do+            flip runReaderT (manager,coojar) $ do+              Just fstatServer <- sessionGetJSON (hubURL hinfo </> "sync" </> T.unpack hdlidtxt)+              let patchwork = +                    rsyncPatchWork hinfo hdlfp fstatServer $ do+                      putStrLn "Am I called?"+                      (evhandler . UsrEv . SyncFileFinished) fstatServer++              case mfstat of +                Nothing -> patchwork+                Just fstat ->  +                  if fileSyncStatusTime fstat < fileSyncStatusTime fstatServer+                  then patchwork +                  else (liftIO . Gtk.postGUIAsync . evhandler . UsrEv . SyncFileFinished) fstat+        return (UsrEv ActionOrdered)+      SyncFileFinished nfstat <- +        lift (waitSomeEvent (\case SyncFileFinished _-> True ; _ -> False ))+      liftIO $ print nfstat+      lift (updateSyncInfoAll nfstat)+      when (Just nfstat /= mfstat) (lift fileReload)+    return ()+#endif
src/Hoodle/Coroutine/HandwritingRecognition.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}@@ -16,43 +17,36 @@  module Hoodle.Coroutine.HandwritingRecognition where -import           Control.Lens (view,_1,_2,(%~))+import           Control.Lens (view,_1,_2) import           Control.Monad ((<=<),guard,when)-import           Control.Monad.State (modify) import           Control.Monad.Trans (liftIO) import           Control.Monad.Trans.Either import           Data.Aeson as A--- import           Data.Aeson.Encode--- import           Data.Aeson.Encode.Pretty-import qualified Data.Attoparsec as AP--- import           Data.Attoparsec.Number+import qualified Data.Attoparsec.ByteString.Char8 as AP import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as LB import           Data.Foldable (mapM_) import qualified Data.HashMap.Strict as HM import qualified Data.List as L (lookup) import           Data.Maybe--- import           Data.Scientific import           Data.Strict.Tuple import qualified Data.Text as T import           Data.Traversable (forM) import           Data.UUID.V4 import           Data.Vector hiding (map,head,null,(++),take,modify,mapM_,zip,forM)-import           Graphics.UI.Gtk +import qualified Graphics.UI.Gtk as Gtk import           System.Directory import           System.Exit import           System.FilePath import           System.Process -- -import           Control.Monad.Trans.Crtn.Queue import           Data.Hoodle.Simple -- from this package--- import           Hoodle.Coroutine.Dialog import           Hoodle.Coroutine.Draw (waitSomeEvent) import           Hoodle.Coroutine.Minibuffer import           Hoodle.Type.Coroutine import           Hoodle.Type.Event-import           Hoodle.Type.HoodleState+import           Hoodle.Util --  import           Prelude hiding (fst,snd,mapM_) @@ -66,7 +60,6 @@  handwritingRecognitionDialog :: MainCoroutine (Maybe (Bool,T.Text)) handwritingRecognitionDialog = do-  liftIO $ putStrLn "handwriting recognition test here"   r <- minibufDialog "test handwriting recognition"   case r of      Left err -> liftIO $ putStrLn (show err) >> return Nothing @@ -76,8 +69,7 @@       let bstr = (encode . mkAesonInk) strks       let fp = tdir </> show uuid <.> "json"       liftIO $ LB.writeFile fp bstr-      (excode,gresult,gerror) <- liftIO $ readProcessWithExitCode "curl" ["-X", "POST", "-H", "Content-Type: application/json ", "--data-ascii", "@"++fp, "http://inputtools.google.com/request?itc=en-t-i0-handwrit&app=chext" ] ""-      -- let ev0 = AP.parseOnly json (B.pack gresult)  +      (excode,gresult,gerror) <- liftIO $ readProcessWithExitCode "curl" ["-X", "POST", "-H", "Content-Type: application/json ", "--data-ascii", "@"++fp, "http://inputtools.google.com/request?itc=en-t-i0-handwrit" ] ""       case excode of          ExitSuccess -> do            r_parse <- runEitherT $ do  @@ -91,15 +83,15 @@             (return . mapMaybe f . toList) v4                  case r_parse of -            Left err -> liftIO $ putStrLn err >> return Nothing +            Left err -> msgShout ("handwritingRecognitionDialog: " ++ err) >> return Nothing              Right lst -> showRecogTextDialog lst -        _ -> liftIO $ print gerror >> return Nothing +        _ -> msgShout ("handwritingRecognitionDialog: " ++ gerror) >> return Nothing     showRecogTextDialog :: [T.Text] -> MainCoroutine (Maybe (Bool,T.Text)) showRecogTextDialog txts = do -    modify (tempQueue %~ enqueue action) +    doIOaction action     >> waitSomeEvent (\case OkCancel _ -> True                              GotRecogResult _ _ -> True                             _ -> False)@@ -107,9 +99,15 @@               GotRecogResult b txt -> return (Just (b,txt))               _ -> return Nothing   where -    action = mkIOaction $ \evhandler -> do -               dialog <- dialogNew-               vbox <- dialogGetUpper dialog+    action = \evhandler -> do +               dialog <- Gtk.dialogNew+#ifdef GTK3+               upper <- fmap Gtk.castToContainer (Gtk.dialogGetContentArea dialog)+               vbox <- Gtk.vBoxNew False 0        +               Gtk.containerAdd upper vbox+#else+               vbox <- Gtk.dialogGetUpper dialog+#endif                let txtlst' = zip [1..] txts                txtlst <- forM txtlst' $ \(n,txt) -> do                  let str = T.unpack txt @@ -122,26 +120,27 @@                          else doesFileExist (hoodletdir </> str <.> "hdlt")                        return (n,(b2,txt))                mapM_ (addOneTextBox evhandler dialog vbox) txtlst  -               _btnCancel <- dialogAddButton dialog "Cancel" ResponseCancel-               widgetShowAll dialog-               res <- dialogRun dialog-               widgetDestroy dialog+               _btnCancel <- Gtk.dialogAddButton dialog ("Cancel" :: String) Gtk.ResponseCancel+               Gtk.widgetShowAll dialog+               res <- Gtk.dialogRun dialog+               Gtk.widgetDestroy dialog                case res of -                 ResponseUser n -> case L.lookup n txtlst of+                 Gtk.ResponseUser n -> case L.lookup n txtlst of                                      Nothing -> return (UsrEv (OkCancel False))                                      Just (b,txt) -> return (UsrEv (GotRecogResult b txt))                   _ -> return (UsrEv (OkCancel False))                  -addOneTextBox :: (AllEvent -> IO ()) -> Dialog -> VBox -> (Int,(Bool,T.Text)) -> IO ()+addOneTextBox :: (AllEvent -> IO ()) -> Gtk.Dialog -> Gtk.VBox +              -> (Int,(Bool,T.Text)) -> IO () addOneTextBox _evhandler dialog vbox (n,(b,txt)) = do-  btn <- buttonNewWithLabel (T.unpack txt)+  btn <- Gtk.buttonNewWithLabel (T.unpack txt)   when b $ do -    widgetModifyBg btn StateNormal (Color 60000 60000 30000)-    widgetModifyBg btn StatePrelight (Color 63000 63000 40000)-    widgetModifyBg btn StateActive (Color 45000 45000 18000)-  btn `on` buttonPressEvent $ tryEvent $ do-    liftIO $ dialogResponse dialog (ResponseUser n)-  boxPackStart vbox btn PackNatural 0 +    Gtk.widgetModifyBg btn Gtk.StateNormal (Gtk.Color 60000 60000 30000)+    Gtk.widgetModifyBg btn Gtk.StatePrelight (Gtk.Color 63000 63000 40000)+    Gtk.widgetModifyBg btn Gtk.StateActive (Gtk.Color 45000 45000 18000)+  btn `Gtk.on` Gtk.buttonPressEvent $ Gtk.tryEvent $ do+    liftIO $ Gtk.dialogResponse dialog (Gtk.ResponseUser n)+  Gtk.boxPackStart vbox btn Gtk.PackNatural 0   mkAesonInk :: [Stroke] -> Value mkAesonInk strks =
src/Hoodle/Coroutine/Highlighter.hs view
@@ -17,11 +17,8 @@ import Hoodle.Type.Canvas import Hoodle.Coroutine.Pen  -import Control.Monad.Trans- -- |  -highlighterStart :: CanvasId -> PointerCoord -> MainCoroutine () -highlighterStart cid pcoord = do -  liftIO $ putStrLn "highlighter started"-  penStart cid pcoord+highlighterStart :: CanvasId -> PointerCoord +                 -> MainCoroutine (Maybe (Maybe (Maybe ())))+highlighterStart cid pcoord = penStart cid pcoord
+ src/Hoodle/Coroutine/Hub.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}++-----------------------------------------------------------------------------+-- |+-- Module      : Hoodle.Coroutine.Hub+-- Copyright   : (c) 2014,2015 Ian-Woo Kim+--+-- License     : BSD3+-- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability   : experimental+-- Portability : GHC+--+-----------------------------------------------------------------------------++module Hoodle.Coroutine.Hub where++import           Control.Applicative+import           Control.Lens (view)+import           Control.Monad.IO.Class+import           Control.Monad.State+import           Control.Monad.Trans.Maybe+import System.Directory+import System.FilePath (makeRelative)+--+import Hoodle.Coroutine.HubInternal+import Hoodle.Coroutine.Dialog+import Hoodle.Script.Hook+import Hoodle.Type.Coroutine+import Hoodle.Type.Hub+import Hoodle.Type.HoodleState+--++-- |+hubUpload :: MainCoroutine ()+hubUpload = do+    xst <- get+    uhdl <- view (unitHoodles.currentUnit) <$> get+    if not (view isSaved uhdl) +      then +        okMessageBox "hub action can be done only after saved" >> return ()+      else do r <- runMaybeT $ do +                     hset <- (MaybeT . return) $ view hookSet xst+                     hinfo <- (MaybeT . return) (hubInfo hset)+                     let hdir = hubFileRoot hinfo+                     (canfp,mhdlfp) <- +                          case view (hoodleFileControl.hoodleFileName) uhdl of+                             LocalDir Nothing -> MaybeT (return Nothing)+                             LocalDir (Just fp) -> do +                               canfp <- liftIO $ canonicalizePath fp+                               let relfp = makeRelative hdir canfp+                               MaybeT . return . Just $ (canfp,Just relfp)+                             TempDir fp -> do +                               canfp <- liftIO $ canonicalizePath fp+                               MaybeT . return . Just $ (canfp,Nothing)+                     lift (uploadWork (canfp,mhdlfp) hinfo)+              case r of +                Nothing -> okMessageBox "upload not successful" >> return ()+                Just _ -> return ()  +
+ src/Hoodle/Coroutine/Hub/Common.hs view
@@ -0,0 +1,123 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++-----------------------------------------------------------------------------+-- |+-- Module      : Hoodle.Coroutine.Hub.Common+-- Copyright   : (c) 2015 Ian-Woo Kim+--+-- License     : BSD3+-- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability   : experimental+-- Portability : GHC+--+-----------------------------------------------------------------------------++module Hoodle.Coroutine.Hub.Common where++import           Control.Applicative+import           Control.Monad.IO.Class+import           Control.Monad.State+import           Control.Monad.Trans.Reader+import           Control.Monad.Trans.Resource+import           Data.Aeson as AE+import qualified Data.ByteString.Lazy.Char8 as BL+import qualified Data.Foldable as F+import           Data.IORef+import           Data.Monoid ((<>))+import qualified Data.Text as T (Text,pack,unpack)+import           Data.Text.Encoding (encodeUtf8)+import           Database.Persist (getBy,entityVal)+import           Database.Persist.Sqlite (runSqlite)+import           Network+import           Network.Google.OAuth2 ( formUrl, exchangeCode, refreshTokens+                                       , OAuth2Client(..), OAuth2Tokens(..))+import           Network.HTTP.Client (GivesPopper)+import           Network.HTTP.Conduit ( CookieJar, Manager+                                      , cookieJar, createCookieJar+                                      , httpLbs, parseUrl+                                      , requestHeaders+                                      , responseBody, responseCookieJar, withManager)+import           System.Directory+import           System.Exit    (ExitCode(..))+import           System.Info (os)+import           System.Process (rawSystem)+--+--+import           Hoodle.Coroutine.Dialog+import           Hoodle.Type.Coroutine+import           Hoodle.Type.Hub+import           Hoodle.Type.Synchronization+--++-- |+streamContent :: BL.ByteString -> GivesPopper ()+streamContent lb np = do+    lbref <- newIORef lb +    np (popper lbref)+  where popper lbref = do+          lbstr <- readIORef lbref+          if (not .BL.null) lbstr+            then do +              let (lbstr1,lbstr2) = BL.splitAt 10240 lbstr+              writeIORef lbref lbstr2+              return (BL.toStrict lbstr1)+            else do+              return ""++-- |+prepareToken :: HubInfo -> FilePath -> MainCoroutine ()+prepareToken HubInfo {..} tokfile = do+    let client = OAuth2Client { clientId = T.unpack googleClientId, clientSecret = T.unpack googleClientSecret }+        permissionUrl = formUrl client ["email"]+    liftIO $ putStrLn "prepareToken"+    liftIO (doesFileExist tokfile) >>= \b -> unless b $ do       +      case os of+        "linux"  -> liftIO $ rawSystem "chromium" [permissionUrl]+        "darwin" -> liftIO $ rawSystem "open"       [permissionUrl]+        _        -> return ExitSuccess+      mauthcode <- textInputDialog "Please paste the verification code: "+      F.forM_ mauthcode $ \authcode -> do+        tokens  <- liftIO $ exchangeCode client authcode+        liftIO $ writeFile tokfile (show tokens)++-- |+withHub :: HubInfo -> FilePath +           -> (Manager -> CookieJar -> ResourceT IO a) -> IO a +withHub HubInfo {..} tokfile action = +    withSocketsDo $ withManager $ \manager -> do+      let client = OAuth2Client { clientId = T.unpack googleClientId+                                , clientSecret = T.unpack googleClientSecret }+      -- refresh token+      oldtok <- liftIO $ read <$> (readFile tokfile)+      newtok  <- liftIO $ refreshTokens client oldtok+      liftIO $ writeFile tokfile (show newtok)+      --+      accessTok <- fmap (accessToken . read) (liftIO (readFile tokfile))+      request' <- parseUrl googleAuthURL+      let request = request' +            { requestHeaders =  [ ("Authorization", encodeUtf8 $ "Bearer " <> T.pack accessTok) ]+            , cookieJar = Just (createCookieJar  [])+            }+      response <- httpLbs request manager+      let coojar = responseCookieJar response+      action manager coojar+++sessionGetJSON :: (FromJSON a) => +                  String -> ReaderT (Manager,CookieJar) (ResourceT IO) (Maybe a)+sessionGetJSON url = do+    (manager,coojar) <- ask +    req' <- lift $ parseUrl url+    let req = req' +          { requestHeaders = [ ("Accept", "application/json; charset=utf-8") ] +          , cookieJar = Just coojar }+    res <- lift $ httpLbs req manager+    return (AE.decode (responseBody res))++-- |+getLastSyncStatus :: FilePath -> T.Text -> IO (Maybe FileSyncStatus)+getLastSyncStatus fp uuidtxt = +    fmap entityVal <$> runSqlite (T.pack fp) (getBy (UniqueFileSyncStatusUUID uuidtxt))++
+ src/Hoodle/Coroutine/HubInternal.hs view
@@ -0,0 +1,315 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}++-----------------------------------------------------------------------------+-- |+-- Module      : Hoodle.Coroutine.HubInternal+-- Copyright   : (c) 2014, 2015 Ian-Woo Kim+--+-- License     : BSD3+-- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability   : experimental+-- Portability : GHC+--+-----------------------------------------------------------------------------++module Hoodle.Coroutine.HubInternal where++import           Control.Applicative+import           Control.Concurrent+import qualified Control.Exception as E+import           Control.Lens (over,view,set,_2)+import           Control.Monad.IO.Class+import           Control.Monad.State+import           Control.Monad.Trans.Maybe+import           Control.Monad.Trans.Reader+import           Control.Monad.Trans.Resource+import           Data.Aeson as AE+import qualified Data.ByteString.Base64 as B64+import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Lazy.Char8 as BL+import           Data.Digest.Pure.MD5 (md5)+import qualified Data.Foldable as F+import qualified Data.IntMap as IM+import           Data.List (find)+import qualified Data.Text as T (Text,pack,unpack)+import qualified Data.Text.Encoding as TE (encodeUtf8,decodeUtf8)+import           Data.UUID+import           Data.UUID.V4+import           Database.Persist (upsert, getBy)+import           Database.Persist.Sql (runMigration)+import           Database.Persist.Sqlite (runSqlite)+import qualified Graphics.UI.Gtk as Gtk+import           Network.HTTP.Conduit ( RequestBody(..), CookieJar, Manager+                                      , cookieJar, httpLbs, method, parseUrl+                                      , requestBody, responseBody)+import           Network.HTTP.Types (methodPut)+import           System.Directory+import           System.FilePath ((</>),(<.>),makeRelative)+import           System.Process (readProcessWithExitCode)+--+import           Data.Hoodle.Generic+import           Data.Hoodle.Simple+import           Graphics.Hoodle.Render.Type.Hoodle+import           Text.Hoodle.Builder (builder)+--+import           Hoodle.Accessor+import           Hoodle.Coroutine.Hub.Common+import           Hoodle.Script.Hook+import           Hoodle.Type.Coroutine+import           Hoodle.Type.Event+import           Hoodle.Type.Hub+import           Hoodle.Type.HoodleState+import           Hoodle.Type.Synchronization+--++         +uploadWork :: (FilePath,Maybe FilePath) -> HubInfo -> MainCoroutine ()+uploadWork (canfp,mhdlfp) hinfo@(HubInfo {..}) = do+    uhdl0 <- view (unitHoodles.currentUnit) <$> get+    let hdl = (rHoodle2Hoodle . getHoodle) uhdl0+        hdllbstr = builder hdl+        hdlbstr = BL.toStrict hdllbstr+        hdlmd5txt = T.pack (show (md5 hdllbstr))+    pureUpdateUhdl $ over (hoodleFileControl.syncMD5History) (hdlmd5txt:)+    uhdl <- view (unitHoodles.currentUnit) <$> get+    let synchist = view (hoodleFileControl.syncMD5History) uhdl+        uhdluuid = view unitUUID uhdl++    hdir <- liftIO $ getHomeDirectory+    msqlfile <- view (settings.sqliteFileName) <$> get+    let tokfile = hdir </> ".hoodle.d" </> "token.txt"+    prepareToken hinfo tokfile+    doIOaction $ \evhandler -> do +      forkIO $ (`E.catch` (\(e :: E.SomeException)-> print e >> (Gtk.postGUIAsync . evhandler . UsrEv) (DisconnectedHub tokfile (canfp,mhdlfp) hinfo) >> return ())) $ +        withHub hinfo tokfile $ \manager coojar -> do+          let uuidtxt = TE.decodeUtf8 (view hoodleID hdl)+          flip runReaderT (manager,coojar) $ do+            mfstat <- sessionGetJSON (hubURL </> "sync" </> T.unpack uuidtxt)+            liftIO $ print (mfstat :: Maybe FileSyncStatus)+            liftIO $ print synchist+            let uploading = uploadAndUpdateSync evhandler uhdluuid hinfo uuidtxt hdlbstr (canfp,mhdlfp) msqlfile+            flip (maybe uploading) ((,) <$> msqlfile <*> mfstat) $ +              \(sqlfile,fstat) -> do+                me <- runSqlite (T.pack sqlfile) $ getBy (UniqueFileSyncStatusUUID (fileSyncStatusUuid fstat))+                case me of +                  Just _ -> do +                    let remotemd5saved = fileSyncStatusMd5 fstat+                    if (remotemd5saved `elem` synchist ) || (Prelude.null synchist)+                      then uploading+                      else do +                        liftIO $ putStrLn ("uploadWork" ++ show remotemd5saved ++ "," ++ show synchist)+                        liftIO $ evhandler (UsrEv (FileSyncFromHub uhdluuid fstat))+                  Nothing -> uploading+      return (UsrEv ActionOrdered)+++uploadAndUpdateSync :: (AllEvent -> IO ()) -> UUID -> HubInfo -> T.Text -> B.ByteString  +                    -> (FilePath,Maybe FilePath) -> Maybe FilePath +                    -> ReaderT (Manager,CookieJar) (ResourceT IO) ()+uploadAndUpdateSync evhandler uhdluuid hinfo uuidtxt hdlbstr (canfp,mhdlfp) msqlfile = do+    mfrsync <- sessionGetJSON (hubURL hinfo </> "file" </> T.unpack uuidtxt) +    b64txt <- case mfrsync of +      Nothing -> (return . TE.decodeUtf8 . B64.encode) hdlbstr+      Just frsync -> liftIO $ do+        let rsyncbstr = (B64.decodeLenient . TE.encodeUtf8 . frsync_sig) frsync+        tdir <- getTemporaryDirectory+        uuid'' <- nextRandom+        let tsigfile = tdir </> show uuid'' <.> "sig"+            tdeltafile = tdir </> show uuid'' <.> "delta"+        B.writeFile tsigfile rsyncbstr+        readProcessWithExitCode "rdiff" +          ["delta", tsigfile, canfp, tdeltafile] ""+        deltabstr <- B.readFile tdeltafile +        mapM_ removeFile [tsigfile,tdeltafile]+        (return . TE.decodeUtf8 . B64.encode) deltabstr+    let filecontent = toJSON FileContent { file_uuid = uuidtxt+                                         , file_path = T.pack <$> mhdlfp +                                         , file_content = b64txt +                                         , file_rsync = mfrsync +                                         , client_uuid = T.pack (show uhdluuid)+                                         }+        filecontentbstr = encode filecontent+    (manager,coojar) <- ask+    request3' <- lift $ parseUrl (hubURL hinfo </> "file" </> T.unpack uuidtxt )+    let request3 = request3' { method = methodPut+                             , requestBody = RequestBodyStreamChunked (streamContent filecontentbstr)+                             , cookieJar = Just coojar }+    _response3 <- lift $ httpLbs request3 manager+    mfstat2 :: Maybe FileSyncStatus +      <- sessionGetJSON (hubURL hinfo </> "sync" </> T.unpack uuidtxt)+    F.forM_ ((,) <$> msqlfile <*> mfstat2) $ \(sqlfile,fstat2) -> do +      runSqlite (T.pack sqlfile) $ upsert fstat2 []+      liftIO $ evhandler (UsrEv (SyncInfoUpdated uhdluuid fstat2))+    return ()++-- | +initSqliteDB :: MainCoroutine ()+initSqliteDB = do+    msqlfile <- view (settings.sqliteFileName) <$> get+    F.forM_ msqlfile $ \sqlfile -> liftIO $ do+      runSqlite (T.pack sqlfile) $ runMigration $ migrateAll++-- | +updateSyncInfo :: UUID -> FileSyncStatus -> MainCoroutine ()+updateSyncInfo uuid fstat = do+    liftIO $ putStrLn "updateSyncInfo called"+    uhdlsMap <-  snd . view unitHoodles <$> get+    let uhdls = IM.elems uhdlsMap+    case find (\x -> view unitUUID x == uuid) uhdls of +      Nothing -> return ()+      Just uhdl -> do +        let nuhdlsMap = IM.adjust (over (hoodleFileControl.syncMD5History) (fileSyncStatusMd5 fstat :) ) (view unitKey uhdl) uhdlsMap+        modify (set (unitHoodles._2) nuhdlsMap)+++-- | +updateSyncInfoAll :: FileSyncStatus -> MainCoroutine ()+updateSyncInfoAll fstat = do+    let fileuuid = fileSyncStatusUuid fstat    +    uhdlsMap <-  snd . view unitHoodles <$> get+    let f uhdl = let fileuuid' = getHoodleID uhdl+                 in if fileuuid == fileuuid' +                    then over (hoodleFileControl.syncMD5History) (fileSyncStatusMd5 fstat :) uhdl+                    else uhdl+        nuhdlsMap = fmap f uhdlsMap+    modify (set (unitHoodles._2) nuhdlsMap)+    +-- |+fileSyncFromHub :: UUID -> FileSyncStatus -> MainCoroutine ()+fileSyncFromHub unituuid fstat = do+    liftIO $ putStrLn "fileSyncFromHub called"+    uhdlsMap <-  snd . view unitHoodles <$> get+    let uhdls = IM.elems uhdlsMap+    hdir <- liftIO $ getHomeDirectory+    let tokfile = hdir </> ".hoodle.d" </> "token.txt"+    xst <- get+    runMaybeT $ do+      uhdl <- (MaybeT . return . find (\x -> view unitUUID x == unituuid)) uhdls +      hdlfp <- MaybeT . return $ getHoodleFilePath uhdl  +      hset <- (MaybeT . return . view hookSet) xst+      hinfo <- (MaybeT . return) (hubInfo hset)+      lift $ prepareToken hinfo tokfile+      lift $ doIOaction $ \evhandler -> do +        forkIO $ (`E.catch` (\(e :: E.SomeException)-> print e >> return ())) $ +          withHub hinfo tokfile $ \manager coojar -> do+            flip runReaderT (manager,coojar) $+              rsyncPatchWork hinfo hdlfp fstat $+                (evhandler . UsrEv) (SyncInfoUpdated unituuid fstat)+        return (UsrEv ActionOrdered)+    return ()++-- |+rsyncPatchWork :: HubInfo -> FilePath -> FileSyncStatus +               -> IO ()+               -> ReaderT (Manager,CookieJar) (ResourceT IO) ()+rsyncPatchWork hinfo hdlfile fstat action = do +    (manager,coojar) <- ask+    let uuidtxt = fileSyncStatusUuid fstat+    sigtxt <- liftIO $ do +                uuid' <- nextRandom+                tdir <- getTemporaryDirectory+                let sigfile = tdir </> show uuid' <.> "sig"+                readProcessWithExitCode "rdiff" ["signature", hdlfile, sigfile] ""+                bstr <- B.readFile sigfile+                return (TE.decodeUtf8 (B64.encode bstr))+    let frsync = FileRsync uuidtxt sigtxt+        frsyncjsonbstr = (encode . toJSON) frsync+    req' <- lift $ parseUrl (hubURL hinfo </> "rsyncdown" </> T.unpack uuidtxt)+    let req = req' { cookieJar = Just coojar +                   , requestBody = RequestBodyStreamChunked (streamContent frsyncjsonbstr)+                   }+    mfcont <- lift $ AE.decode . responseBody <$> httpLbs req manager+    F.forM_ mfcont $ \fcont -> do+      let filebstr = (B64.decodeLenient . TE.encodeUtf8 . file_content) fcont +      liftIO $ do +        uuid' <- nextRandom+        tdir <- getTemporaryDirectory +        let deltafile = tdir </> show uuid' <.> "delta"+            newfile = tdir </> show uuid' <.> "hdlnew"+        B.writeFile deltafile filebstr+        readProcessWithExitCode "rdiff" ["patch", hdlfile, deltafile, newfile] ""+        md5str <- show . md5 <$> BL.readFile newfile +        when (md5str == T.unpack (fileSyncStatusMd5 fstat)) $ do+          copyFile newfile hdlfile+          mapM_ removeFile [deltafile,newfile]+          Gtk.postGUIAsync action+        +-- |+gotSyncEvent :: Bool -> UUID -> FileSyncStatus -> MainCoroutine ()+gotSyncEvent isforced unituuid fstat = do+    liftIO $ putStrLn "gotSyncEvent called"+    uhdlsMap <-  snd . view unitHoodles <$> get+    let uhdls = IM.elems uhdlsMap+    let b = maybe True (const isforced) (find (\x -> view unitUUID x == unituuid) uhdls)+    when b $ fileSyncFromHub unituuid fstat++-- |+registerFile :: UUID -> (FilePath,Hoodle) -> MainCoroutine ()+registerFile uhdluuid (fp,hdl) = do +    liftIO $ putStrLn "registerFile called"+    let hdlbstr = (BL.toStrict . builder) hdl+    hdir <- liftIO $ getHomeDirectory+    canfp <- liftIO $ canonicalizePath fp+    let mhdlfp = Just (makeRelative hdir canfp)+    xst <- get+    let fileuuidbstr = view hoodleID hdl+        fileuuidtxt = TE.decodeUtf8 fileuuidbstr+    let tokfile = hdir </> ".hoodle.d" </> "token.txt"+    runMaybeT $ do+      sqlfile <- (MaybeT . return . view (settings.sqliteFileName)) xst+      hset <- (MaybeT . return . view hookSet) xst+      hinfo <- (MaybeT . return) (hubInfo hset)+      lift $ prepareToken hinfo tokfile+      lift . doIOaction $ \evhandler -> do +        forkIO $ (`E.catch` (\(e :: E.SomeException)-> print e)) $ +          withHub hinfo tokfile $ \manager coojar -> do+            flip runReaderT (manager,coojar) $ do+              uploadAndUpdateSync evhandler uhdluuid hinfo fileuuidtxt hdlbstr (canfp,mhdlfp) (Just sqlfile)+              Just fstat <- sessionGetJSON (hubURL hinfo </> "sync" </> T.unpack fileuuidtxt)++              (liftIO . Gtk.postGUIAsync . evhandler . UsrEv) (SyncInfoUpdated uhdluuid fstat)+        return (UsrEv ActionOrdered)+    return ()    ++-- |+findUnitHoodleByHoodleID :: String ->  MainCoroutine (Maybe UnitHoodle)+findUnitHoodleByHoodleID uuidstr = do +    uhdlsMap <-  snd . view unitHoodles <$> get+    let uhdls = IM.elems uhdlsMap+        muhdl = find ((== uuidstr) . B.unpack . view ghoodleID . getHoodle) uhdls +    return muhdl +++++openShared :: UUID -> MainCoroutine ()+openShared uuid = do +    xst <- get+    hdir <- liftIO $ getHomeDirectory+    let uuidstr = show uuid+    let tokfile = hdir </> ".hoodle.d" </> "token.txt"+    tmpfile <- liftIO $ (</> uuidstr <.> "hdl" ) <$> getTemporaryDirectory +    liftIO $ writeFile tmpfile "" +    runMaybeT $ do+      hset <- (MaybeT . return . view hookSet) xst+      hinfo <- (MaybeT . return) (hubInfo hset)+      lift $ prepareToken hinfo tokfile+      lift $ doIOaction $ \evhandler -> do +        forkIO $ (`E.catch` (\(e :: E.SomeException)-> print e >> return ())) $ +          withHub hinfo tokfile $ \manager coojar -> do+            flip runReaderT (manager,coojar) $ do+              mfstat <- sessionGetJSON (hubURL hinfo </> "sync" </> uuidstr)+              case mfstat of+                Nothing -> return ()+                Just fstat -> +                  rsyncPatchWork hinfo tmpfile fstat $+                    (evhandler . UsrEv) (OpenTemp uuid tmpfile)+        return (UsrEv ActionOrdered)+    return ()++
+ src/Hoodle/Coroutine/HubInternal.hs-boot view
@@ -0,0 +1,67 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}++-----------------------------------------------------------------------------+-- |+-- Module      : Hoodle.Coroutine.HubInternal+-- Copyright   : (c) 2014 Ian-Woo Kim+--+-- License     : BSD3+-- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability   : experimental+-- Portability : GHC+--+-----------------------------------------------------------------------------++module Hoodle.Coroutine.HubInternal where++import           Control.Applicative+import qualified Control.Exception as E+import           Control.Lens (view)+import           Control.Monad (unless)+import           Control.Monad.IO.Class+import           Control.Monad.State+import           Control.Monad.Trans.Maybe+-- import           Control.Monad.Trans.State+import           Data.Aeson as AE+import qualified Data.ByteString.Base64 as B64+import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Lazy.Char8 as BL+import qualified Data.Foldable as F+import qualified Data.HashMap.Strict as H+import qualified Data.List as L+import Data.Monoid ((<>))+import Data.Text (Text,pack,unpack)+import Data.Text.Encoding (encodeUtf8,decodeUtf8)+import Data.Time.Calendar+import Data.Time.Clock+import Data.UUID.V4+import Network+import Network.Google.OAuth2 (formUrl, exchangeCode, refreshTokens,+                               OAuth2Client(..), OAuth2Tokens(..))+import Network.Google (makeRequest, doRequest)+import Network.HTTP.Conduit+import Network.HTTP.Types (methodPut)+import System.Directory+import System.Environment (getEnv)+import System.Exit    (ExitCode(..))+import System.FilePath ((</>),(<.>),makeRelative)+import System.Info (os)+import System.Process (system, rawSystem,readProcessWithExitCode)+--+-- import Data.Hoodle.Generic+import Data.Hoodle.Simple+import Graphics.Hoodle.Render.Type.Hoodle+import Text.Hoodle.Builder (builder)+--+import Hoodle.Coroutine.Draw+import Hoodle.Script.Hook+import Hoodle.Type.Coroutine+import Hoodle.Type.Event+import Hoodle.Type.Hub+import Hoodle.Type.HoodleState+import Hoodle.Util+++uploadWork :: (FilePath,FilePath) -> HubInfo -> MainCoroutine ()
+ src/Hoodle/Coroutine/LaTeX.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}++-----------------------------------------------------------------------------+-- |+-- Module      : Hoodle.Coroutine.LaTeX+-- Copyright   : (c) 2011-2014 Ian-Woo Kim+--+-- License     : BSD3+-- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability   : experimental+-- Portability : GHC+--+-----------------------------------------------------------------------------++module Hoodle.Coroutine.LaTeX where++import Control.Lens+import Control.Monad.Trans.Maybe+import Control.Monad.State+import           Data.Function (on)+import Data.List (sortBy)+import Data.Maybe+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+-- +import Data.Hoodle.Simple+--+import Hoodle.ModelAction.Text+--++hoistMaybe :: (Monad m) => Maybe a -> MaybeT m a+hoistMaybe = MaybeT . return++getLaTeXComponentsFromHdl :: Hoodle -> [(Maybe T.Text,(Int,Double,T.Text))] +getLaTeXComponentsFromHdl hdl = +    let mlatex_components = do +          (pgnum,pg) <- (zip ([1..] :: [Int]) . view pages) hdl  +          l <- view layers pg+          i <- view items l+          case i of +            ItemSVG svg -> +              runMaybeT $ do+                v <- hoistMaybe (svg_command svg)+                guard (v == "latex")+                svgtextbstr <- hoistMaybe (svg_text svg)+                let (_,y) = svg_pos svg  +                    svgtext = TE.decodeUtf8 svgtextbstr+                    mk = extractKeyword svgtext+                return (mk,(pgnum,y,svgtext))+            _ -> []+        cfunc :: (Ord a,Ord b,Ord c) => (a,b,c) -> (a,b,c) -> Ordering +        cfunc x y | view _1 x > view _1 y = GT+                  | view _1 x < view _1 y = LT+                  | otherwise = if | view _2 x > view _2 y -> GT+                                   | view _2 x < view _2 y -> LT+                                   | otherwise -> EQ+        latex_components = catMaybes  mlatex_components+        sorted = sortBy (cfunc `on` snd) latex_components +    in sorted++{- +updateLaTeX :: MainCoroutine ()+updateLaTeX = do+    rhdl <- getHoodle <$> get+    let hdl = rHoodle2Hoodle rhdl+    runMaybeT $ do +      {- txtsrc <- -} MaybeT $ return (rhdl ^. gembeddedtext)  +      -- let km = getKeywordMap txtsrc+      -- liftIO $ print km+    -- let sorted = getLaTeXComponentsFromHdl hdl+    -- liftIO $ print sorted +    return ()+-}++laTeXHeader :: T.Text+laTeXHeader = +  "\\documentclass[a4paper]{article}\n\+  \\\usepackage[affil-it]{authblk}\n\+  \\\usepackage{xeCJK}\n\+  \\\xeCJKsetup{\n\+  \  CJKspace=true,\n\+  \  CJKecglue={}\n\+  \}\n\+  \\\usepackage{setspace}\n\+  \\\onehalfspacing\n\+  \\\usepackage{fontspec}\n\+  \\\setCJKmainfont{NanumGothic}\n\+  \\\usepackage{minted}\n\+  \\\pagestyle{empty}\n\+  \\\begin{document}\n"+++-- \\\\documentclass{article}\n\+--              \\\pagestyle{empty}\n\+--              \\\begin{document}\n+                                +laTeXFooter :: T.Text+laTeXFooter = "\\end{document}\n"
src/Hoodle/Coroutine/Layer.hs view
@@ -3,9 +3,9 @@ ----------------------------------------------------------------------------- -- | -- Module      : Hoodle.Coroutine.Layer --- Copyright   : (c) 2011-2013 Ian-Woo Kim+-- Copyright   : (c) 2011-2014 Ian-Woo Kim ----- License     : GPL-3+-- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com> -- Stability   : experimental -- Portability : GHC@@ -17,10 +17,9 @@ import Control.Monad.State import qualified Data.IntMap as M import Control.Category--- import Data.Label import Control.Lens (view,set) import Data.IORef-import Graphics.UI.Gtk hiding (get,set)+import qualified Graphics.UI.Gtk as Gtk -- import Data.Hoodle.Generic import Data.Hoodle.Zipper@@ -40,32 +39,39 @@   layerAction :: (HoodleModeState -> Int -> Page EditMode -> MainCoroutine HoodleModeState) -            -> MainCoroutine HoodleState+            -> MainCoroutine UnitHoodle layerAction action = do      xst <- get -    forBoth' unboxBiAct (fsingle xst) . view currentCanvasInfo $ xst+    forBoth' unboxBiAct (fsingle xst) . view (unitHoodles.currentUnit.currentCanvasInfo) $ xst   where      fsingle xstate cvsInfo = do-      let epage = getCurrentPageEitherFromHoodleModeState cvsInfo hdlmodst+      let uhdl = view (unitHoodles.currentUnit) xstate+          epage = getCurrentPageEitherFromHoodleModeState cvsInfo hdlmodst           cpn = view currentPageNum cvsInfo-          hdlmodst = view hoodleModeState xstate+          hdlmodst = view hoodleModeState uhdl       newhdlmodst <- either (action hdlmodst cpn) (action hdlmodst cpn . hPage2RPage) epage -      return =<< (liftIO (updatePageAll newhdlmodst . set hoodleModeState newhdlmodst $ xstate))+      return =<< (liftIO (updatePageAll newhdlmodst . set hoodleModeState newhdlmodst $ uhdl))  -- |   makeNewLayer :: MainCoroutine () -makeNewLayer = layerAction newlayeraction >>= commit >> invalidateAll +makeNewLayer = do+    xst <- get+    commit . flip (set (unitHoodles.currentUnit)) xst =<< layerAction newlayeraction+    invalidateAll    where newlayeraction hdlmodst cpn page = do +          sfcid <- issueSurfaceID           let lyrzipper = view glayers page  -              emptylyr = emptyRLayer +              emptylyr = emptyRLayer sfcid               nlyrzipper = appendGoLast lyrzipper emptylyr                npage = set glayers nlyrzipper page           return . setPageMap (M.adjust (const npage) cpn . getPageMap $ hdlmodst) $ hdlmodst                    gotoNextLayer :: MainCoroutine ()-gotoNextLayer = layerAction nextlayeraction >>= put >> invalidateAll +gotoNextLayer = do+    modify . set (unitHoodles.currentUnit) =<< layerAction nextlayeraction +    invalidateAll    where nextlayeraction hdlmodst cpn page = do            let lyrzipper = view glayers page                 mlyrzipper = moveRight lyrzipper @@ -73,7 +79,9 @@           return . setPageMap (M.adjust (const npage) cpn . getPageMap $ hdlmodst) $ hdlmodst    gotoPrevLayer :: MainCoroutine ()-gotoPrevLayer = layerAction prevlayeraction >>= put >> invalidateAll +gotoPrevLayer = do+    modify . set (unitHoodles.currentUnit) =<< layerAction prevlayeraction+    invalidateAll    where prevlayeraction hdlmodst cpn page = do            let lyrzipper = view glayers page                 mlyrzipper = moveLeft lyrzipper @@ -82,7 +90,9 @@   gotoLayerAt :: Int -> MainCoroutine ()-gotoLayerAt n = layerAction gotoaction >>= put >> invalidateAll +gotoLayerAt n = do+    modify . set (unitHoodles.currentUnit) =<< layerAction gotoaction +    invalidateAll    where gotoaction hdlmodst cpn page = do            let lyrzipper = view glayers page                 mlyrzipper = moveTo n lyrzipper @@ -91,7 +101,10 @@   deleteCurrentLayer :: MainCoroutine ()-deleteCurrentLayer = layerAction deletelayeraction >>= commit >> invalidateAll +deleteCurrentLayer = do+    xst <- get+    commit . flip (set (unitHoodles.currentUnit)) xst =<< layerAction deletelayeraction+    invalidateAll    where deletelayeraction hdlmodst cpn page = do            let lyrzipper = view glayers page                 mlyrzipper = deleteCurrent lyrzipper @@ -100,27 +113,27 @@  startGotoLayerAt :: MainCoroutine () startGotoLayerAt = -    forBoth' unboxBiAct fsingle . view currentCanvasInfo =<< get+    forBoth' unboxBiAct fsingle . view (unitHoodles.currentUnit.currentCanvasInfo) =<< get   where      fsingle cvsInfo = do        xstate <- get -      let hdlmodst = view hoodleModeState xstate-      let epage = getCurrentPageEitherFromHoodleModeState cvsInfo hdlmodst+      let uhdl = view (unitHoodles.currentUnit) xstate+          hdlmodst = view hoodleModeState uhdl+          epage = getCurrentPageEitherFromHoodleModeState cvsInfo hdlmodst           page = either id (hPage2RPage) epage            lyrzipper = view glayers page           cidx = currIndex lyrzipper           len  = lengthSZ lyrzipper        lref <- liftIO $ newIORef cidx       dialog <- liftIO (layerChooseDialog lref cidx len)-      res <- liftIO $ dialogRun dialog+      res <- liftIO $ Gtk.dialogRun dialog       case res of -        ResponseDeleteEvent -> liftIO $ widgetDestroy dialog-        ResponseOk ->  do-          liftIO $ widgetDestroy dialog+        Gtk.ResponseDeleteEvent -> liftIO $ Gtk.widgetDestroy dialog+        Gtk.ResponseOk ->  do+          liftIO $ Gtk.widgetDestroy dialog           newnum <- liftIO (readIORef lref)-          -- liftIO $ putStrLn (show (newnum))           gotoLayerAt newnum-        ResponseCancel -> liftIO $ widgetDestroy dialog+        Gtk.ResponseCancel -> liftIO $ Gtk.widgetDestroy dialog         _ -> error "??? in fileOpen "        return ()
src/Hoodle/Coroutine/Link.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}@@ -8,9 +9,9 @@ ----------------------------------------------------------------------------- -- | -- Module      : Hoodle.Coroutine.Link--- Copyright   : (c) 2013, 2014 Ian-Woo Kim+-- Copyright   : (c) 2013-2015 Ian-Woo Kim ----- License     : GPL-3+-- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com> -- Stability   : experimental -- Portability : GHC@@ -20,28 +21,32 @@ module Hoodle.Coroutine.Link where  import           Control.Applicative-import           Control.Concurrent (forkIO)-import           Control.Lens (at,view,set,(%~))-import           Control.Monad (forever,void)-import           Control.Monad.State (get,put,modify,liftIO,guard,when)+import           Control.Lens (_2,at,view,set,(^.))+import           Control.Monad hiding (forM_)+import           Control.Monad.State (get,liftIO) import           Control.Monad.Trans.Maybe import qualified Data.ByteString.Char8 as B  import           Data.Foldable (forM_)+import qualified Data.IntMap as IM import qualified Data.Map as M import           Data.Maybe (mapMaybe) import           Data.Monoid (mconcat) import           Data.UUID.V4 (nextRandom) import qualified Data.Text as T import qualified Data.Text.Encoding as TE+import qualified Graphics.UI.Gtk as Gtk+import           System.Directory+import           System.FilePath +import           System.Process (createProcess, proc)+#ifdef HUB+import           Control.Concurrent (forkIO) import           DBus import           DBus.Client-import           Graphics.UI.Gtk hiding (get,set) -import           System.FilePath +#endif -- from hoodle-platform-import           Control.Monad.Trans.Crtn.Queue  import           Data.Hoodle.BBox import           Data.Hoodle.Generic-import           Data.Hoodle.Simple -- (Anchor(..),Item(..),SVG(..),pages,layers,items)+import           Data.Hoodle.Simple import           Data.Hoodle.Zipper import           Graphics.Hoodle.Render.Item  import           Graphics.Hoodle.Render.Type @@ -51,10 +56,10 @@ import           Hoodle.Accessor import           Hoodle.Coroutine.Dialog import           Hoodle.Coroutine.Draw--- import           Hoodle.Coroutine.File (insertItemAt) import           Hoodle.Coroutine.Page (changePage) import           Hoodle.Coroutine.Select.Clipboard import           Hoodle.Coroutine.TextInput +import           Hoodle.Coroutine.Window import           Hoodle.Device  import           Hoodle.ModelAction.ContextMenu import           Hoodle.ModelAction.File (makeNewItemImage)@@ -67,17 +72,49 @@ import           Hoodle.Type.PageArrangement import           Hoodle.Util  import           Hoodle.View.Coordinate+#ifdef HUB+import           Hoodle.Coroutine.File+#endif -- import Prelude hiding (mapM_) +-- | +openLinkAction :: UrlPath +               -> Maybe (T.Text,T.Text) -- ^ (docid,anchorid)+               -> MainCoroutine () +openLinkAction urlpath mid = do +    case urlpath of +      FileUrl fp -> do+        mk <- liftIO . checkPreviouslyOpenedFile fp =<< get+        case mk of +          Just k -> switchTab k >> forM_ mid (uncurry goToAnchorPos)+          Nothing -> addTab (LocalDir (Just fp)) >> +#ifdef HUB+                     syncFile >> +#endif+                     forM_ mid (uncurry goToAnchorPos)+      HttpUrl url -> liftIO $ createProcess (proc "xdg-open" [url]) >> return () ++-- |+checkPreviouslyOpenedFile :: FilePath -> HoodleState -> IO (Maybe Int)+checkPreviouslyOpenedFile fp xst = do+    cfp <- canonicalizePath fp+    lst <- filterM (checker cfp . snd) (IM.assocs (xst ^. unitHoodles._2))+    case lst of+      x:_ -> return (Just (fst x))+      _ -> return Nothing+  where checker cfp uhdl = getHoodleFilePath uhdl # +                             maybe (return False) $ \fp' -> do cfp' <- canonicalizePath fp' +                                                               return (cfp == cfp') + makeTextSVGFromStringAt :: String -                           -> CanvasId -                           -> HoodleState-                           -> CanvasCoordinate-                           -> IO (B.ByteString, BBox)-makeTextSVGFromStringAt str cid xst ccoord = do +                        -> CanvasId +                        -> UnitHoodle+                        -> CanvasCoordinate+                        -> IO (B.ByteString, BBox)+makeTextSVGFromStringAt str cid uhdl ccoord = do      rdr <- makePangoTextSVG (0,0) (T.pack str) -- for the time being, I use string  -    geometry <- getCanvasGeometryCvsId cid xst +    geometry <- getCanvasGeometryCvsId cid uhdl     let mpgcoord = (desktop2Page geometry . canvas2Desktop geometry) ccoord      return $ case mpgcoord of                 Nothing -> rdr @@ -88,11 +125,11 @@ -- |  notifyLink :: CanvasId -> PointerCoord -> MainCoroutine ()  notifyLink cid pcoord = do -    xst <- get -    (forBoth' unboxBiAct (f xst) . getCanvasInfo cid) xst +    uhdl <- view (unitHoodles.currentUnit) <$> get +    forBoth' unboxBiAct (f uhdl) (getCanvasInfo cid uhdl)   where -    f :: forall b. HoodleState -> CanvasInfo b -> MainCoroutine ()-    f xst cvsInfo = do +    f :: forall b. UnitHoodle -> CanvasInfo b -> MainCoroutine ()+    f uhdl cvsInfo = do        let cpn = PageNum . view currentPageNum $ cvsInfo           arr = view (viewInfo.pageArrangement) cvsInfo                         mnotifyitem = view notifiedItem cvsInfo@@ -102,7 +139,7 @@         case (desktop2Page geometry . device2Desktop geometry) pcoord of            Nothing -> return Nothing            Just (pnum,PageCoord (x,y)) -> do -            let hdl = getHoodle xst+            let hdl = getHoodle uhdl                 mpage = view (gpages.at (unPageNum pnum)) hdl             case mpage of               Nothing -> return Nothing@@ -113,27 +150,26 @@                     hitted = takeHitted hlnks                  case mnotifyitem of                    Nothing -> if ((not.null) hitted) -                             then Just <$> newNotify cvsInfo geometry pnum (head hitted) Nothing  +                             then Just <$> newNotify geometry pnum (head hitted) Nothing                                else return Nothing                    Just (opnum,obbx,_) -> do                     let obbx_desk = xformBBox (unDeskCoord . page2Desktop geometry . (opnum,) . PageCoord) obbx                        if pnum == opnum &&  isPointInBBox obbx (x,y)                        then return Nothing                       else if ((not.null) hitted) -                           then Just <$> newNotify cvsInfo geometry pnum (head hitted) (Just obbx_desk)+                           then Just <$> newNotify geometry pnum (head hitted) (Just obbx_desk)                            else return (Just (Nothing,obbx_desk))       forM_ mresult (\(mnewnotified,bbx_desk) -> do-                      let ncinfobox = (set (unboxLens notifiedItem) mnewnotified . getCanvasInfo cid) xst -                      put (setCanvasInfo (cid,ncinfobox) xst)+                      let ncinfobox = (set (unboxLens notifiedItem) mnewnotified . getCanvasInfo cid) uhdl +                      pureUpdateUhdl $ setCanvasInfo (cid,ncinfobox)                       invalidateInBBox (Just bbx_desk) Efficient cid )     ----                                                                                      -    newNotify :: CanvasInfo a -> CanvasGeometry -> PageNum -> RItem -> Maybe BBox +    newNotify :: CanvasGeometry -> PageNum -> RItem -> Maybe BBox                   -> MainCoroutine (Maybe (PageNum,BBox,RItem),BBox) -    newNotify _cvsInfo geometry pnum lnk mobbx_desk = do        +    newNotify geometry pnum lnk mobbx_desk = do               let bbx = getBBox lnk           bbx_desk = xformBBox (unDeskCoord . page2Desktop geometry . (pnum,) . PageCoord) bbx-          nbbx_desk = maybe bbx_desk (\obbx_desk->unionBBox bbx_desk obbx_desk) mobbx_desk-      liftIO $ print (pnum,bbx)+          nbbx_desk = maybe bbx_desk (unionBBox bbx_desk) mobbx_desk       return (Just (pnum,bbx,lnk),nbbx_desk)            @@ -141,9 +177,9 @@ gotLink :: Maybe String -> (Int,Int) -> MainCoroutine ()  gotLink mstr (x,y) = do    xst <- get -  -- liftIO $ print mstr -  let cid = getCurrentCanvasId xst-      cache = view renderCache xst+  cache <- renderCache+  let uhdl = view (unitHoodles.currentUnit) xst +      cid = getCurrentCanvasId uhdl   mr <- runMaybeT $ do      str <- (MaybeT . return) mstr      let (str1,rem1) = break (== ',') str @@ -165,17 +201,16 @@                                liftIO (makeNewItemImage isembedded file)               RenderEv (GotRItem nitm) <-                  waitSomeEvent (\case RenderEv (GotRItem _) -> True ; _ -> False )-              geometry <- liftIO $ getCanvasGeometryCvsId cid xst               +              geometry <- liftIO $ getCanvasGeometryCvsId cid uhdl                              let ccoord = CvsCoord (fromIntegral x,fromIntegral y)                   mpgcoord = (desktop2Page geometry . canvas2Desktop geometry) ccoord                insertItemAt mpgcoord nitm              else return ()           Just (HttpUrl url) -> do -          case getSelectedItmsFromHoodleState xst of     +          case getSelectedItmsFromUnitHoodle uhdl of                  Nothing -> do                uuidbstr <- liftIO $ B.pack . show <$> nextRandom              -              rdrbbx <- liftIO $ makeTextSVGFromStringAt url cid xst -                                   (CvsCoord (fromIntegral x,fromIntegral y))+              rdrbbx <- liftIO $ makeTextSVGFromStringAt url cid uhdl (CvsCoord (fromIntegral x,fromIntegral y))               linkInsert "simple" (uuidbstr,url) url rdrbbx             Just hititms -> do                b <- okCancelMessageBox ("replace selected item with link to " ++ url  ++ "?")@@ -183,24 +218,23 @@                 let ulbbox = (unUnion . mconcat . fmap (Union . Middle . getBBox)) hititms                  case ulbbox of                    Middle bbox -> do -                    svg <- liftIO $ makeSVGFromSelection cache hititms bbox+                    svg <- liftIO $ makeSVGFromSelection cache cid hititms bbox                     uuidbstr <- liftIO $ B.pack . show <$> nextRandom                     deleteSelection                      linkInsert "simple" (uuidbstr,url) url (svg_render svg,bbox)                     _ -> return ()               Just (uuidbstr,fp) -> do        let fn = takeFileName fp -      case getSelectedItmsFromHoodleState xst of     +      case getSelectedItmsFromUnitHoodle uhdl of              Nothing -> do            rdr <- liftIO (makePangoTextSVG (0,0) (T.pack fn)) -          geometry <- liftIO $ getCanvasGeometryCvsId cid xst +          geometry <- liftIO $ getCanvasGeometryCvsId cid uhdl            let ccoord = CvsCoord (fromIntegral x,fromIntegral y)               mpgcoord = (desktop2Page geometry . canvas2Desktop geometry) ccoord                rdr' = case mpgcoord of                         Nothing -> rdr                         Just (_,PageCoord (x',y')) -> -                         let bbox' = moveBBoxULCornerTo (x',y') (snd rdr) -                         in (fst rdr,bbox')+                         let bbox' = moveBBoxULCornerTo (x',y') (snd rdr) in (fst rdr,bbox')           linkInsert "simple" (uuidbstr,fp) fn rdr'          Just hititms -> do            b <- okCancelMessageBox ("replace selected item with link to " ++ fn ++ "?")@@ -208,22 +242,20 @@             let ulbbox = (unUnion . mconcat . fmap (Union . Middle . getBBox)) hititms              case ulbbox of                Middle bbox -> do -                svg <- liftIO $ makeSVGFromSelection cache hititms bbox+                svg <- liftIO $ makeSVGFromSelection cache cid hititms bbox                 uuid <- liftIO $ nextRandom                 let uuidbstr' = B.pack (show uuid)                  deleteSelection                  linkInsert "simple" (uuidbstr',fp) fn (svg_render svg,bbox)                 _ -> return ()          -  liftIO $ putStrLn "gotLink"-  liftIO $ print mstr -  liftIO $ print (x,y) + -- |  addLink :: MainCoroutine () addLink = do -    mfilename <- fileChooser FileChooserActionOpen Nothing -    modify (tempQueue %~ enqueue (action mfilename)) -    minput <- go+    mfilename <- fileChooser Gtk.FileChooserActionOpen Nothing +    doIOaction $ const (action mfilename) +    AddLink minput <- waitSomeEvent (\case AddLink _ -> True; _ -> False)     case minput of        Nothing -> return ()        Just (str,fname) -> do @@ -232,60 +264,51 @@         rdr <- liftIO (makePangoTextSVG (0,0) (T.pack str))          linkInsert "simple" (uuidbstr,fname) str rdr    where -    go = do r <- nextevent-            case r of -              AddLink minput -> return minput -              UpdateCanvas cid -> -- this is temporary -                                  (invalidateInBBox Nothing Efficient cid) >> go -              _ -> go -    action mfn = mkIOaction $ -                   \_evhandler -> do -                     dialog <- messageDialogNew Nothing [DialogModal]-                                 MessageQuestion ButtonsOkCancel "add link" -                     vbox <- dialogGetUpper dialog-                     txtvw <- textViewNew-                     boxPackStart vbox txtvw PackGrow 0 -                     widgetShowAll dialog-                     res <- dialogRun dialog +    action mfn = do  dialog <- Gtk.messageDialogNew Nothing [Gtk.DialogModal]+                                 Gtk.MessageQuestion Gtk.ButtonsOkCancel ("add link" :: String)+#ifdef GTK3                               +                     upper <- fmap Gtk.castToContainer (Gtk.dialogGetContentArea dialog)+                     vbox <- Gtk.vBoxNew False 0+                     Gtk.containerAdd upper vbox+#else+                     vbox <- Gtk.dialogGetUpper dialog+#endif+                     txtvw <- Gtk.textViewNew+                     Gtk.boxPackStart vbox txtvw Gtk.PackGrow 0 +                     Gtk.widgetShowAll dialog+                     res <- Gtk.dialogRun dialog                       case res of -                       ResponseOk -> do -                         buf <- textViewGetBuffer txtvw -                         (istart,iend) <- (,) <$> textBufferGetStartIter buf-                                              <*> textBufferGetEndIter buf-                         l <- textBufferGetText buf istart iend True-                         widgetDestroy dialog+                       Gtk.ResponseOk -> do +                         buf <- Gtk.textViewGetBuffer txtvw +                         (istart,iend) <- (,) <$> Gtk.textBufferGetStartIter buf+                                              <*> Gtk.textBufferGetEndIter buf+                         l <- Gtk.textBufferGetText buf istart iend True+                         Gtk.widgetDestroy dialog                          return (UsrEv (AddLink ((l,) <$> mfn)))-                       _ -> do -                         widgetDestroy dialog-                         return (UsrEv (AddLink Nothing))+                       _ -> Gtk.widgetDestroy dialog >> return (UsrEv (AddLink Nothing))                   -- |  listAnchors :: MainCoroutine ()-listAnchors = liftIO . print . getAnchorMap . rHoodle2Hoodle . getHoodle =<< get+listAnchors = msgShout . show . getAnchorMap . rHoodle2Hoodle . getHoodle . view (unitHoodles.currentUnit) =<< get  getAnchorMap :: Hoodle -> M.Map T.Text (Int, (Double,Double)) getAnchorMap hdl =      let pgs = view pages hdl-        itemsInPage pg = do l <- view layers pg -                            i <- view items l -                            return i+        itemsInPage pg = [i | l <- view layers pg, i <- view items l ]         anchorsWithPageNum :: [(Int,[Anchor])] -        anchorsWithPageNum = zip [0..] -                               (map (mapMaybe lookupAnchor . itemsInPage) pgs)-        anchormap = foldr (\(p,ys) m -> foldr (insertAnchor p) m ys) -                      M.empty anchorsWithPageNum-    in anchormap+        anchorsWithPageNum = zip [0..] (map (mapMaybe lookupAnchor . itemsInPage) pgs)+    in foldr (\(p,ys) m -> foldr (insertAnchor p) m ys) M.empty anchorsWithPageNum -- anchormap   where lookupAnchor (ItemAnchor a) = Just a         lookupAnchor _ = Nothing-        insertAnchor pgnum (Anchor {..}) = -          M.insert (TE.decodeUtf8 anchor_id) (pgnum,anchor_pos)  +        insertAnchor pgnum (Anchor {..}) = M.insert (TE.decodeUtf8 anchor_id) (pgnum,anchor_pos)            + -- | +#ifdef HUB startLinkReceiver :: MainCoroutine () startLinkReceiver = do -    xst <- get-    let callback = view callBack xst +    callback <- view callBack <$> get      liftIO . forkIO $ do       client <- connectSession       requestName client "org.ianwookim" []@@ -304,19 +327,18 @@               let  r = T.splitOn "," txt               case r of                  docid:anchorid:_ -> -                  (postGUISync . callback . UsrEv . DBusEv . GoToLink) +                  (Gtk.postGUISync . callback . UsrEv . DBusEv . GoToLink)                      (docid,anchorid)                  _ -> return ()             _ -> return ()           +#endif + goToAnchorPos :: T.Text -> T.Text -> MainCoroutine () goToAnchorPos docid anchorid = do -    xst <- get-    let rhdl = getHoodle xst -        hdl = rHoodle2Hoodle rhdl+    rhdl <- getHoodle . view (unitHoodles.currentUnit) <$> get+    let hdl = rHoodle2Hoodle rhdl     when (docid == (TE.decodeUtf8 . view ghoodleID) rhdl) $ do       let anchormap = getAnchorMap hdl-      forM_ (M.lookup anchorid anchormap) $ \(pgnum,(x,y))-> do-        liftIO $ print (pgnum,(x,y))-        changePage (const pgnum)+      forM_ (M.lookup anchorid anchormap) $ \(pgnum,_)-> changePage (const pgnum)
src/Hoodle/Coroutine/Minibuffer.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-}  -----------------------------------------------------------------------------@@ -15,15 +16,14 @@ module Hoodle.Coroutine.Minibuffer where   import           Control.Applicative ((<$>),(<*>))-import           Control.Lens ((%~),view)-import           Control.Monad.State (modify,get)+import           Control.Lens (view)+import           Control.Monad.State (get) import           Control.Monad.Trans (liftIO) import           Data.Foldable (Foldable(..),mapM_,forM_,toList) import           Data.Sequence (Seq,(|>),empty,singleton,viewl,ViewL(..)) import qualified Graphics.Rendering.Cairo as Cairo-import           Graphics.UI.Gtk hiding (get,set)+import qualified Graphics.UI.Gtk as Gtk -- -import           Control.Monad.Trans.Crtn.Queue (enqueue) import           Data.Hoodle.Simple import           Graphics.Hoodle.Render (renderStrk) --@@ -60,40 +60,48 @@     xst <- get     let dev = view deviceList xst      let ui = view gtkUIManager xst -    agr <- liftIO ( uiManagerGetActionGroups ui >>= \x ->+    agr <- liftIO ( Gtk.uiManagerGetActionGroups ui >>= \x ->                       case x of                          [] -> error "No action group? "                         y:_ -> return y )-    uxinputa <- liftIO (actionGroupGetAction agr "UXINPUTA" >>= \(Just x) -> -                          return (castToToggleAction x) )-    doesUseX11Ext <- liftIO $ toggleActionGetActive uxinputa-    modify (tempQueue %~ enqueue (action dev doesUseX11Ext)) +    uxinputa <- liftIO (Gtk.actionGroupGetAction agr "UXINPUTA" >>= \(Just x) -> +                          return (Gtk.castToToggleAction x) )+    doesUseX11Ext <- liftIO $ Gtk.toggleActionGetActive uxinputa+    doIOaction (action dev doesUseX11Ext)     minibufInit   where -    action dev _doesUseX11Ext = mkIOaction $ \evhandler -> do -      dialog <- dialogNew -      msgLabel <- labelNew (Just msg) -      cvs <- drawingAreaNew                           -      cvs `on` sizeRequest $ return (Requisition 500 50)-      cvs `on` exposeEvent $ tryEvent $ do-        drawwdw <- liftIO $ widgetGetDrawWindow cvs                 -        liftIO (renderWithDrawable drawwdw drawMiniBufBkg)+    action dev _doesUseX11Ext = \evhandler -> do +      dialog <- Gtk.dialogNew +      msgLabel <- Gtk.labelNew (Just msg) +      cvs <- Gtk.drawingAreaNew                           +      cvs `Gtk.on` Gtk.sizeRequest $ return (Gtk.Requisition 500 50)+      cvs `Gtk.on` Gtk.exposeEvent $ Gtk.tryEvent $ do+#ifdef GTK3        +        Just drawwdw <- liftIO $ Gtk.widgetGetWindow cvs+#else+        drawwdw <- liftIO $ Gtk.widgetGetDrawWindow cvs                 +#endif+#ifdef GTK3+        liftIO (Gtk.renderWithDrawWindow drawwdw drawMiniBufBkg)+#else+        liftIO (Gtk.renderWithDrawable drawwdw drawMiniBufBkg)+#endif         (liftIO . evhandler . UsrEv . MiniBuffer . MiniBufferInitialized) drawwdw-      cvs `on` buttonPressEvent $ tryEvent $ do +      cvs `Gtk.on` Gtk.buttonPressEvent $ Gtk.tryEvent $ do          (mbtn,mp) <- getPointer dev         forM_ mp $ \p -> do           let pbtn = maybe PenButton1 id mbtn            case pbtn of             TouchButton -> return ()             _ -> (liftIO . evhandler . UsrEv . MiniBuffer) (MiniBufferPenDown pbtn p)-      cvs `on` buttonReleaseEvent $ tryEvent $ do +      cvs `Gtk.on` Gtk.buttonReleaseEvent $ Gtk.tryEvent $ do          (mbtn,mp) <- getPointer dev         forM_ mp $ \p -> do             let pbtn = maybe PenButton1 id mbtn            case pbtn of             TouchButton -> return ()             _ -> (liftIO . evhandler . UsrEv . MiniBuffer) (MiniBufferPenUp p)-      cvs `on` motionNotifyEvent $ tryEvent $ do +      cvs `Gtk.on` Gtk.motionNotifyEvent $ Gtk.tryEvent $ do          (mbtn,mp) <- getPointer dev         forM_ mp $ \p -> do               let pbtn = maybe PenButton1 id mbtn      @@ -103,23 +111,29 @@       {- if doesUseX11Ext          then widgetSetExtensionEvents cvs [ExtensionEventsAll]         else widgetSetExtensionEvents cvs [ExtensionEventsNone] -}-      widgetAddEvents cvs [PointerMotionMask,Button1MotionMask]      +      Gtk.widgetAddEvents cvs [Gtk.PointerMotionMask,Gtk.Button1MotionMask]       ---      vbox <- dialogGetUpper dialog-      hbox <- hBoxNew False 0 -      boxPackStart hbox msgLabel PackNatural 0 -      boxPackStart vbox hbox PackNatural 0-      boxPackStart vbox cvs PackNatural 0-      _btnOk <- dialogAddButton dialog "Ok" ResponseOk-      _btnCancel <- dialogAddButton dialog "Cancel" ResponseCancel-      _btnText <- dialogAddButton dialog "TextInput" (ResponseUser 1) -      widgetShowAll dialog-      res <- dialogRun dialog -      widgetDestroy dialog +#ifdef GTK3+      upper <- fmap Gtk.castToContainer (Gtk.dialogGetContentArea dialog)+      vbox <- Gtk.vBoxNew False 0 +      Gtk.containerAdd upper vbox+#else +      vbox <- Gtk.dialogGetUpper dialog+#endif+      hbox <- Gtk.hBoxNew False 0 +      Gtk.boxPackStart hbox msgLabel Gtk.PackNatural 0 +      Gtk.boxPackStart vbox hbox Gtk.PackNatural 0+      Gtk.boxPackStart vbox cvs Gtk.PackNatural 0+      _btnOk <- Gtk.dialogAddButton dialog "Ok" Gtk.ResponseOk+      _btnCancel <- Gtk.dialogAddButton dialog "Cancel" Gtk.ResponseCancel+      _btnText <- Gtk.dialogAddButton dialog "TextInput" (Gtk.ResponseUser 1) +      Gtk.widgetShowAll dialog+      res <- Gtk.dialogRun dialog +      Gtk.widgetDestroy dialog        case res of -        ResponseOk -> return (UsrEv (OkCancel True))-        ResponseCancel -> return (UsrEv (OkCancel False))-        ResponseUser 1 -> return (UsrEv ChangeDialog)+        Gtk.ResponseOk -> return (UsrEv (OkCancel True))+        Gtk.ResponseCancel -> return (UsrEv (OkCancel False))+        Gtk.ResponseUser 1 -> return (UsrEv ChangeDialog)         _ -> return (UsrEv (OkCancel False))  minibufInit :: MainCoroutine (Either () [Stroke])@@ -135,14 +149,18 @@                minibufStart drawwdw (srcsfc,tgtsfc) empty               _ -> minibufInit) -invalidateMinibuf :: DrawWindow -> Cairo.Surface -> IO ()+invalidateMinibuf :: Gtk.DrawWindow -> Cairo.Surface -> IO () invalidateMinibuf drawwdw tgtsfc = -  renderWithDrawable drawwdw $ do +#ifdef GTK3+  Gtk.renderWithDrawWindow drawwdw $ do +#else +  Gtk.renderWithDrawable drawwdw $ do +#endif     Cairo.setSourceSurface tgtsfc 0 0      Cairo.setOperator Cairo.OperatorSource      Cairo.paint -minibufStart :: DrawWindow +minibufStart :: Gtk.DrawWindow               -> (Cairo.Surface,Cairo.Surface)  -- ^ (source, target)              -> Seq Stroke               -> MainCoroutine (Either () [Stroke])@@ -161,7 +179,7 @@         minibufStart drawwdw (srcsfc,tgtsfc) nstrks       _ -> minibufStart drawwdw (srcsfc,tgtsfc) strks       -onestroke :: DrawWindow+onestroke :: Gtk.DrawWindow           -> (Cairo.Surface,Cairo.Surface) -- ^ (source, target)           -> Seq PointerCoord            -> MainCoroutine (Seq PointerCoord)
src/Hoodle/Coroutine/Mode.hs view
@@ -5,7 +5,7 @@ -- Module      : Hoodle.Coroutine.Mode  -- Copyright   : (c) 2011-2014 Ian-Woo Kim ----- License     : GPL-3+-- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com> -- Stability   : experimental -- Portability : GHC@@ -15,10 +15,10 @@ module Hoodle.Coroutine.Mode where  import           Control.Applicative-import           Control.Lens (view,set,over)+import           Control.Lens (view,set,(.~)) import           Control.Monad.State  import qualified Data.IntMap as M-import           Graphics.UI.Gtk (adjustmentGetValue) +import qualified Graphics.UI.Gtk as Gtk (adjustmentGetValue) -- from hoodle-platform import           Data.Hoodle.BBox import           Data.Hoodle.Generic@@ -45,107 +45,109 @@ modeChange command = do      case command of        ToViewAppendMode -> updateXState select2edit >> invalidateAll -                          -- invalidateAllInBBox Nothing Efficient -- invalidateAll -      ToSelectMode     -> updateXState edit2select >> invalidateAllInBBox Nothing Efficient -- invalidateAll +      ToSelectMode     -> updateXState edit2select >> invalidateAllInBBox Nothing Efficient       _ -> return ()     reflectPenModeUI     reflectPenColorUI     reflectPenWidthUI   where select2edit xst =  -          either (noaction xst) (whenselect xst) . hoodleModeStateEither . view hoodleModeState $ xst+          either (noaction xst) (whenselect xst) . hoodleModeStateEither +          . view (unitHoodles.currentUnit.hoodleModeState) $ xst         edit2select xst = -          either (whenedit xst) (noaction xst) . hoodleModeStateEither . view hoodleModeState $ xst+          either (whenedit xst) (noaction xst) . hoodleModeStateEither +          . view (unitHoodles.currentUnit.hoodleModeState) $ xst         noaction :: HoodleState -> a -> MainCoroutine HoodleState-        noaction xstate = const (return xstate)+        noaction xst = const (return xst)         whenselect :: HoodleState -> Hoodle SelectMode -> MainCoroutine HoodleState-        whenselect xstate thdl = do +        whenselect xst thdl = do            let pages = view gselAll thdl               mselect = view gselSelected thdl-              cache = view renderCache xstate+              cid = getCurrentCanvasId (view (unitHoodles.currentUnit) xst)           npages <- maybe (return pages)                            (\(spgn,spage) -> do -                             npage <- (liftIO.updatePageBuf cache.hPage2RPage) spage  +                             let npage = hPage2RPage spage+                             callRenderer_ $ updatePageBuf cid npage                              return $ M.adjust (const npage) spgn pages )                           mselect           let nthdl = set gselAll npages . set gselSelected Nothing $ thdl  -          return . flip (set hoodleModeState) xstate -            . ViewAppendState . gSelect2GHoodle $ nthdl  +          return $ (unitHoodles.currentUnit.hoodleModeState .~ ViewAppendState (gSelect2GHoodle nthdl)) xst         whenedit :: HoodleState -> Hoodle EditMode -> MainCoroutine HoodleState   -        whenedit xstate hdl = do -          return . flip (set hoodleModeState) xstate -                          . SelectState  -                          . gHoodle2GSelect $ hdl +        whenedit xst hdl =+          return $ (unitHoodles.currentUnit.hoodleModeState .~ SelectState  (gHoodle2GSelect hdl)) xst + -- |  viewModeChange :: UserEvent -> MainCoroutine ()  viewModeChange command = do      case command of -      ToSinglePage -> updateXState cont2single >> invalidateAll -      ToContSinglePage -> updateXState single2cont >> invalidateAll +      ToSinglePage -> updateUhdl cont2single >> invalidateAll +      ToContSinglePage -> updateUhdl single2cont >> invalidateAll        _ -> return ()     adjustScrollbarWithGeometryCurrent     -  where cont2single xst =  -          unboxBiAct (noaction xst) (whencont xst) . view currentCanvasInfo $ xst-        single2cont xst = -          unboxBiAct (whensing xst) (noaction xst) . view currentCanvasInfo $ xst-        noaction :: HoodleState -> a -> MainCoroutine HoodleState  -        noaction xstate = const (return xstate)-        --------------------------------------        whencont xstate cinfo = do -          geometry <- liftIO $ getGeometry4CurrCvs xstate -          cdim <- liftIO $  return . canvasDim $ geometry -          page <- getCurrentPageCurr-          let zmode = view (viewInfo.zoomMode) cinfo-              canvas = view drawArea cinfo -              cpn = PageNum . view currentPageNum $ cinfo +  where cont2single :: UnitHoodle -> MainCoroutine UnitHoodle+        cont2single uhdl = unboxBiAct (const (return uhdl)) (cont2SingPage uhdl) . view currentCanvasInfo $ uhdl+        single2cont :: UnitHoodle -> MainCoroutine UnitHoodle+        single2cont uhdl = unboxBiAct (sing2ContPage uhdl) (const (return uhdl)) . view currentCanvasInfo $ uhdl -              pdim = PageDimension (view gdimension page)-              ViewPortBBox bbox = view (viewInfo.pageArrangement.viewPortBBox) cinfo       -              (x0,y0) = bbox_upperleft bbox -              (xpos,ypos) = maybe (0,0) (unPageCoord.snd) $ desktop2Page geometry (DeskCoord (x0,y0))  -          let arr = makeSingleArrangement zmode pdim cdim (xpos,ypos) -          let nvinfo = ViewInfo (view zoomMode (view viewInfo cinfo)) arr -              ncinfo = CanvasInfo (view canvasId cinfo)-                                  canvas-                                  (view mDrawSurface cinfo)-                                  (view scrolledWindow cinfo)-                                  nvinfo -                                  (unPageNum cpn)-                                  (view horizAdjustment cinfo)-                                  (view vertAdjustment cinfo)-                                  (view horizAdjConnId cinfo)-                                  (view vertAdjConnId cinfo)-                                  (view canvasWidgets cinfo)-                                  (view notifiedItem cinfo)-          return $ set currentCanvasInfo (CanvasSinglePage ncinfo) xstate -        --------------------------------------        whensing xstate cinfo = do -          cdim <- liftIO $  return . canvasDim =<< getGeometry4CurrCvs xstate -          let zmode = view (viewInfo.zoomMode) cinfo-              canvas = view drawArea cinfo -              cpn = PageNum . view currentPageNum $ cinfo -              (hadj,vadj) = view adjustments cinfo -          (xpos,ypos) <- liftIO $ (,) <$> adjustmentGetValue hadj <*> adjustmentGetValue vadj-          let arr = makeContinuousArrangement zmode cdim (getHoodle xstate) -                                                    (cpn, PageCoord (xpos,ypos))-          geometry <- liftIO $ makeCanvasGeometry cpn arr canvas-          let DeskCoord (nxpos,nypos) = page2Desktop geometry (cpn,PageCoord (xpos,ypos))-          let vinfo = view viewInfo cinfo -              nvinfo = ViewInfo (view zoomMode vinfo) arr -              ncinfotemp = CanvasInfo (view canvasId cinfo)-                                      (view drawArea cinfo)-                                      (view mDrawSurface cinfo)-                                      (view scrolledWindow cinfo)-                                      nvinfo -                                      (view currentPageNum cinfo)-                                      hadj -                                      vadj -                                      (view horizAdjConnId cinfo)-                                      (view vertAdjConnId cinfo)-                                      (view canvasWidgets cinfo) -                                      (view notifiedItem cinfo)-              ncpn = maybe cpn fst $ desktop2Page geometry (DeskCoord (nxpos,nypos))-              ncinfo = over currentPageNum (const (unPageNum ncpn)) ncinfotemp-          return . over currentCanvasInfo (const (CanvasContPage ncinfo)) $ xstate+cont2SingPage :: UnitHoodle -> CanvasInfo a -> MainCoroutine UnitHoodle+cont2SingPage uhdl cinfo = do+    geometry <- liftIO $ getGeometry4CurrCvs uhdl+    cdim <- liftIO $  return . canvasDim $ geometry +    page <- getCurrentPageCurr+    let zmode = view (viewInfo.zoomMode) cinfo+        canvas = view drawArea cinfo +        cpn = PageNum . view currentPageNum $ cinfo ++        pdim = PageDimension (view gdimension page)+        ViewPortBBox bbox = view (viewInfo.pageArrangement.viewPortBBox) cinfo       +        (x0,y0) = bbox_upperleft bbox +        (xpos,ypos) = maybe (0,0) (unPageCoord.snd) $ desktop2Page geometry (DeskCoord (x0,y0))  +    let arr = makeSingleArrangement zmode pdim cdim (xpos,ypos) +    let nvinfo = ViewInfo (view zoomMode (view viewInfo cinfo)) arr +        ncinfo = CanvasInfo (view canvasId cinfo)+                            canvas+                            (view mDrawSurface cinfo)+                            (view scrolledWindow cinfo)+                            nvinfo +                            (unPageNum cpn)+                            (view horizAdjustment cinfo)+                            (view vertAdjustment cinfo)+                            (view horizAdjConnId cinfo)+                            (view vertAdjConnId cinfo)+                            (view canvasWidgets cinfo)+                            (view notifiedItem cinfo)+    return $ (currentCanvasInfo .~ CanvasSinglePage ncinfo) uhdl+++sing2ContPage :: UnitHoodle -> CanvasInfo a -> MainCoroutine UnitHoodle+sing2ContPage uhdl cinfo = do+    cdim <- liftIO $  return . canvasDim =<< getGeometry4CurrCvs uhdl+    let zmode = view (viewInfo.zoomMode) cinfo+        canvas = view drawArea cinfo +        cpn = PageNum . view currentPageNum $ cinfo +        (hadj,vadj) = view adjustments cinfo +    (xpos,ypos) <- liftIO $ (,) <$> Gtk.adjustmentGetValue hadj <*> Gtk.adjustmentGetValue vadj+    let arr = makeContinuousArrangement zmode cdim (getHoodle uhdl) +                                              (cpn, PageCoord (xpos,ypos))+    geometry <- liftIO $ makeCanvasGeometry cpn arr canvas+    let DeskCoord (nxpos,nypos) = page2Desktop geometry (cpn,PageCoord (xpos,ypos))+    let vinfo = view viewInfo cinfo +        nvinfo = ViewInfo (view zoomMode vinfo) arr +        ncinfotemp = CanvasInfo (view canvasId cinfo)+                                (view drawArea cinfo)+                                (view mDrawSurface cinfo)+                                (view scrolledWindow cinfo)+                                nvinfo +                                (view currentPageNum cinfo)+                                hadj +                                vadj +                                (view horizAdjConnId cinfo)+                                (view vertAdjConnId cinfo)+                                (view canvasWidgets cinfo) +                                (view notifiedItem cinfo)+        ncpn = maybe cpn fst $ desktop2Page geometry (DeskCoord (nxpos,nypos))+        ncinfo = (currentPageNum .~ unPageNum ncpn) ncinfotemp+    return $ (currentCanvasInfo .~ CanvasContPage ncinfo) uhdl+
src/Hoodle/Coroutine/Network.hs view
@@ -7,7 +7,7 @@ ----------------------------------------------------------------------------- -- | -- Module      : Hoodle.Coroutine.Network--- Copyright   : (c) 2013 Ian-Woo Kim+-- Copyright   : (c) 2013, 2014 Ian-Woo Kim -- -- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>@@ -20,86 +20,83 @@  import           Control.Applicative import           Control.Concurrent hiding (yield)- import           Control.Lens --import           Control.Monad.State (modify,get)+import           Control.Monad+import           Control.Monad.Loops +import           Control.Monad.State (get) import           Control.Monad.Trans import           Control.Monad.Trans.Maybe (MaybeT(..)) import qualified Data.Binary as Bi  import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as LB-import qualified Data.Foldable as F (mapM_)-+-- import qualified Data.Foldable as F (mapM_)+import           Data.IORef import           Data.Monoid ((<>),mconcat) import qualified Data.Text as T import qualified Data.Text.Encoding as TE+import qualified Data.Traversable as Tr import           Data.Word-import           Graphics.UI.Gtk hiding (get,set)+import qualified Graphics.UI.Gtk as Gtk import           Network.Info import           Network.Simple.TCP- -- --import           Control.Monad.Trans.Crtn.Queue (enqueue)--- - import           Hoodle.Coroutine.Draw import           Hoodle.Script.Hook import           Hoodle.Type.Coroutine import           Hoodle.Type.Enum import           Hoodle.Type.Event-import           Hoodle.Type.HoodleState (tempQueue,hookSet)+import           Hoodle.Type.HoodleState (hookSet) --   server :: (AllEvent -> IO ()) -> HostPreference -> T.Text -> IO ()-server evhandler ip txt = do-  listen ip  "4040" $ \(lsock, _) -> -    accept lsock $ \(sock,addr) -> do -      let bstr = TE.encodeUtf8 txt-          bstr_size :: Word32 = (fromIntegral . B.length) bstr -          bstr_size_binary = (mconcat . LB.toChunks . Bi.encode) bstr_size-      -- B.putStrLn () -      putStrLn $ "TCP connection established from " ++ show addr-      send sock (bstr_size_binary <> TE.encodeUtf8 txt)-      -      mbstr <- runMaybeT $ do -        bstr' <- MaybeT (recv sock 4)-        let getsize :: B.ByteString -> Word32 -            getsize = Bi.decode . LB.fromChunks . return-            size = (fromIntegral . getsize) bstr'+server evhandler ip txtorig = do+    ref <- newIORef txtorig+    forever $ listen ip  "4040" $ \(lsock, _) -> +      accept lsock $ \(sock,addr) -> do+        txt <- readIORef ref+        let bstr = TE.encodeUtf8 txt+            bstr_size :: Word32 = (fromIntegral . B.length) bstr +            bstr_size_binary = (mconcat . LB.toChunks . Bi.encode) bstr_size+        putStrLn $ "TCP connection established from " ++ show addr+        send sock (bstr_size_binary <> TE.encodeUtf8 txt)+        unfoldM_ $ do+          mbstr <- runMaybeT $ do +            bstr' <- MaybeT (recv sock 4)+            let getsize :: B.ByteString -> Word32 +                getsize = Bi.decode . LB.fromChunks . return+                size = (fromIntegral . getsize) bstr' -            go s bs = do -              liftIO $ putStrLn ("requested size = " ++ show s)-              bstr1 <- MaybeT (recv sock s)-              let s' = B.length bstr1 -              liftIO $ putStrLn ("obtained size = " ++ show s')-              if s <= s' -                then return (bs <> bstr1)-                else go (s-s') (bs <> bstr1) -        go size B.empty -        -      -- print mbstr -      F.mapM_ (evhandler . UsrEv . NetworkProcess . NetworkReceived . TE.decodeUtf8) mbstr+                go s bs = do +                  liftIO $ putStrLn ("requested size = " ++ show s)+                  bstr1 <- MaybeT (recv sock s)+                  let s' = B.length bstr1 +                  liftIO $ putStrLn ("obtained size = " ++ show s')+                  if s <= s' +                    then return (bs <> bstr1)+                    else go (s-s') (bs <> bstr1) +            go size B.empty +          Tr.forM mbstr $ \bstr' -> do +            let txt' = TE.decodeUtf8 bstr'+            (evhandler . UsrEv . NetworkProcess . NetworkReceived) txt'+            writeIORef ref txt'+          return mbstr+        putStrLn "FINISHED" -networkTextInput :: T.Text -> MainCoroutine (Maybe T.Text)-networkTextInput txt = do ++networkTextInputBody :: T.Text -> MainCoroutine (String,ThreadId,MVar ()) -- ^ (ip address,thread id,lock)+networkTextInputBody txt = do     mipscr <- runMaybeT $ do hkset <- MaybeT (view hookSet <$> lift get)                              (MaybeT . return)  (getIPaddress hkset) -         let ipfind = do            let ipv4num (IPv4 x) = x                ismacnull (MAC a b c d e f) = a == 0 && b == 0 && c == 0                                              && d == 0 && e == 0 && f == 0 -                     ifcs <- liftIO $ getNetworkInterfaces           let ifcs2 = Prelude.filter (not . ismacnull . mac)                        . Prelude.filter (((/=) 0) . ipv4num . ipv4 ) $ ifcs           return (if Prelude.null ifcs2 then "127.0.0.1" else (show . ipv4 . head) ifcs2)      ip <- maybe ipfind liftIO mipscr -     doIOaction $ \evhandler -> do  -      -- T.putStrLn txt       done <- newEmptyMVar       tid <- forkIO (server evhandler (Host ip) txt)        (return . UsrEv . NetworkProcess) (NetworkInitialized tid done)@@ -110,23 +107,24 @@             NetworkProcess (NetworkInitialized tid done) -> return (tid,done)             _ -> go      (tid,done) <- go -    let ipdialog msg = mkIOaction $ -               \_evhandler -> do                  -                 dialog <- messageDialogNew Nothing [DialogModal]-                   MessageQuestion ButtonsOkCancel msg -                 forkIO $ do          -                   readMVar done -                   dialogResponse dialog ResponseOk-                  -                 res <- dialogRun dialog -                 let b = case res of -                           ResponseOk -> True-                           _ -> False-                 widgetDestroy dialog -                 return (UsrEv (OkCancel b))+    return (ip,tid,done) -    -    modify (tempQueue %~ enqueue (ipdialog ("networkedit " ++ ip ++ " 4040")))+networkTextInput :: T.Text -> MainCoroutine (Maybe T.Text)+networkTextInput txt = do +    (ip,tid,done) <- networkTextInputBody txt+    let ipdialog msg = \_evhandler -> do                  +          dialog <- Gtk.messageDialogNew Nothing [Gtk.DialogModal]+            Gtk.MessageQuestion Gtk.ButtonsOkCancel msg +          forkIO $ do          +            readMVar done +            Gtk.dialogResponse dialog Gtk.ResponseOk+          res <- Gtk.dialogRun dialog +          let b = case res of +                    Gtk.ResponseOk -> True+                    _ -> False+          Gtk.widgetDestroy dialog +          return (UsrEv (OkCancel b))+    doIOaction (ipdialog ("networkedit " ++ ip ++ " 4040"))     --     let actf t = do            r <- nextevent@@ -136,7 +134,7 @@             OkCancel True -> (return . Just) t             OkCancel False -> return Nothing             NetworkProcess (NetworkReceived txt') ->  do -              doIOaction $ \_ -> postGUISync (putMVar done ())+              doIOaction $ \_ -> Gtk.postGUISync (putMVar done ())                                  >> (return . UsrEv . NetworkProcess) NetworkCloseDialog               actf txt'                @@ -148,4 +146,5 @@       (return . UsrEv . NetworkProcess) NetworkClosed     --     return ntxt+
src/Hoodle/Coroutine/Page.hs view
@@ -7,9 +7,9 @@ ----------------------------------------------------------------------------- -- | -- Module      : Hoodle.Coroutine.Page --- Copyright   : (c) 2011-2014 Ian-Woo Kim+-- Copyright   : (c) 2011-2015 Ian-Woo Kim ----- License     : GPL-3+-- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com> -- Stability   : experimental -- Portability : GHC@@ -19,9 +19,8 @@ module Hoodle.Coroutine.Page where  import           Control.Applicative-import           Control.Concurrent import           Control.Concurrent.STM-import           Control.Lens (view,set,over, (.~), (^.) )+import           Control.Lens (view,set,(.~), (^.)) import           Control.Monad import           Control.Monad.State import           Control.Monad.Trans.Reader (ask)@@ -29,17 +28,11 @@ import           Data.Function (on) import qualified Data.IntMap as M import           Data.List (sortBy)-import           Data.UUID.V4-import qualified Graphics.Rendering.Cairo as Cairo-import qualified Graphics.UI.Gtk as Gtk-import qualified Graphics.UI.Gtk.Poppler.Page as PopplerPage -- from hoodle-platform import           Data.Hoodle.Generic import           Data.Hoodle.Select import           Data.Hoodle.Simple (Dimension(..)) import           Data.Hoodle.Zipper-import           Graphics.Hoodle.Render--- import           Graphics.Hoodle.Render.Background import           Graphics.Hoodle.Render.Type -- from this package import           Hoodle.Accessor@@ -50,7 +43,6 @@ import           Hoodle.Type.Alias import           Hoodle.Type.Coroutine import           Hoodle.Type.Canvas-import           Hoodle.Type.Event import           Hoodle.Type.PageArrangement import           Hoodle.Type.HoodleState import           Hoodle.Type.Enum@@ -60,35 +52,33 @@  -- | change page of current canvas using a modify function changePage :: (Int -> Int) -> MainCoroutine () -changePage modifyfn = updateXState changePageAction -                      >> adjustScrollbarWithGeometryCurrent-                      >> invalidateAllInBBox Nothing Efficient  -  where changePageAction xst = unboxBiAct (fsingle xst) (fcont xst) -                               . (^. currentCanvasInfo) $ xst-        fsingle xstate cvsInfo = do -          let xojst = view hoodleModeState $ xstate  +changePage modifyfn = (view backgroundStyle <$> get) >>= \bsty -> +                         updateUhdl (changePageAction bsty) >>+                         adjustScrollbarWithGeometryCurrent >>+                         invalidateAllInBBox Nothing Efficient  +  where changePageAction bsty uhdl = unboxBiAct (fsingle bsty uhdl) (fcont bsty uhdl) +                               . (^. currentCanvasInfo) $ uhdl+        fsingle bsty uhdl cvsInfo = do +          let xojst = view hoodleModeState $ uhdl               npgnum = modifyfn (cvsInfo ^. currentPageNum)               cid = view canvasId cvsInfo-              bsty = view backgroundStyle xstate            (b,npgnum',_,xojst') <- changePageInHoodleModeState bsty npgnum xojst-          xstate' <- liftIO $ updatePageAll xojst' xstate -          ncvsInfo <- liftIO $ setPage xstate' (PageNum npgnum') cid-          let xstatefinal = (currentCanvasInfo .~ ncvsInfo) xstate'-          when b (commit xstatefinal)-          return xstatefinal +          uhdl' <- liftIO $ updatePageAll xojst' uhdl+          ncvsInfo <- liftIO $ setPage uhdl' (PageNum npgnum') cid+          let uhdlfinal = (currentCanvasInfo .~ ncvsInfo) uhdl'+          when b $ updateUhdl (const (return uhdlfinal)) >> commit_+          return uhdlfinal          -        fcont xstate cvsInfo = do -          let xojst = view hoodleModeState xstate  +        fcont bsty uhdl cvsInfo = do +          let xojst = view hoodleModeState uhdl               npgnum = modifyfn (cvsInfo ^. currentPageNum)               cid  = cvsInfo ^. canvasId-              bsty = xstate  ^. backgroundStyle-          (b,npgnum',_selectedpage,xojst')-            <- changePageInHoodleModeState bsty npgnum xojst-          xstate' <- liftIO $ updatePageAll xojst' xstate -          ncvsInfo <- liftIO $ setPage xstate' (PageNum npgnum') cid-          xstatefinal <- return . over currentCanvasInfo (const ncvsInfo) $ xstate'-          when b (commit xstatefinal)-          return xstatefinal +          (b,npgnum',_,xojst') <- changePageInHoodleModeState bsty npgnum xojst+          uhdl' <- liftIO $ updatePageAll xojst' uhdl+          ncvsInfo <- liftIO $ setPage uhdl' (PageNum npgnum') cid+          let uhdlfinal = (currentCanvasInfo .~ ncvsInfo) uhdl'+          when b $ updateUhdl (const (return uhdlfinal)) >> commit_+          return uhdlfinal    -- | @@ -97,7 +87,7 @@                             -> HoodleModeState                              -> MainCoroutine (Bool,Int,Page EditMode,HoodleModeState) changePageInHoodleModeState bsty npgnum hdlmodst = do-    let ehdl = hoodleModeStateEither hdlmodst +    let ehdl = hoodleModeStateEither hdlmodst         pgs = either (view gpages) (view gselAll) ehdl         totnumpages = M.size pgs         lpage = maybeError' "changePage" (M.lookup (totnumpages-1) pgs)@@ -107,9 +97,8 @@           let cbkg = view gbackground lpage           nbkg <- newBkg bsty cbkg             npage <- set gbackground nbkg <$> (newPageFromOld lpage)-          geometry <- liftIO . getGeometry4CurrCvs =<< get-          callRenderer $ updateBkgCache geometry (PageNum (totnumpages-1),npage) >> return GotNone-          waitSomeEvent (\case RenderEv GotNone -> True ; _ -> False )+          geometry <- liftIO . getGeometry4CurrCvs . view (unitHoodles.currentUnit) =<< get+          callRenderer_ $ updatePageCache geometry (PageNum (totnumpages-1),npage)           let npages = M.insert totnumpages npage pgs             return  (True,totnumpages,npage,                      either (Left . set gpages npages) (Right. set gselAll npages) ehdl ) @@ -127,18 +116,19 @@                                   -> Maybe (PageNum,PageCoordinate)                                    -> MainCoroutine () canvasZoomUpdateGenRenderCvsId renderfunc cid mzmode mcoord = do -    updateXState zoomUpdateAction +    updateUhdl zoomUpdateAction      adjustScrollbarWithGeometryCvsId cid     xst <- get-    let hdl = getHoodle xst-    geometry <- liftIO (getGeometry4CurrCvs xst)-    let cpn = view (unboxLens currentPageNum) .  getCanvasInfo cid $ xst+    let uhdl = view (unitHoodles.currentUnit) xst+        hdl = getHoodle uhdl+    geometry <- liftIO (getGeometry4CurrCvs uhdl)+    let cpn = view (unboxLens currentPageNum) .  getCanvasInfo cid $ uhdl     let plst = sortBy ( compare `on` (\(n,_) -> abs (n - cpn)) ) . zip [0..] . F.toList $ hdl ^. gpages-    forM_ plst $ \(pn,pg) -> callRenderer_ (updateBkgCache geometry (PageNum pn,pg))+    forM_ plst $ \(pn,pg) -> callRenderer_ (updatePageCache geometry (PageNum pn,pg))     renderfunc-  where zoomUpdateAction xst =  -          unboxBiAct (fsingle xst) (fcont xst) . getCanvasInfo cid $ xst -        fsingle xstate cinfo = do   +  where zoomUpdateAction uhdl =  +          unboxBiAct (fsingle uhdl) (fcont uhdl) . getCanvasInfo cid $ uhdl +        fsingle uhdl cinfo = do              geometry <- liftIO $ getCvsGeomFrmCvsInfo cinfo            page <- getCurrentPageCvsId cid           let zmode = maybe (cinfo ^. viewInfo.zoomMode) id mzmode  @@ -150,13 +140,13 @@               ncinfobox = CanvasSinglePage                           . (viewInfo.pageArrangement .~ narr)                           . (viewInfo.zoomMode .~  zmode) $ cinfo-          return . modifyCanvasInfo cid (const ncinfobox) $ xstate-        fcont xstate cinfo = do   +          return . modifyCanvasInfo cid (const ncinfobox) $ uhdl+        fcont uhdl cinfo = do              geometry <- liftIO $ getCvsGeomFrmCvsInfo cinfo            let zmode = maybe (view (viewInfo.zoomMode) cinfo) id mzmode                cpn = PageNum $ view currentPageNum cinfo                cdim = canvasDim geometry -              hdl = getHoodle xstate +              hdl = getHoodle uhdl               origcoord = case mcoord of                             Just coord -> coord                              Nothing -> either (const (cpn,PageCoord (0,0))) id @@ -165,7 +155,7 @@               ncinfobox = CanvasContPage                           . (viewInfo.pageArrangement .~  narr)                           . (viewInfo.zoomMode .~ zmode) $ cinfo-          return . modifyCanvasInfo cid (const ncinfobox) $ xstate+          return . modifyCanvasInfo cid (const ncinfobox) $ uhdl  -- |  canvasZoomUpdateCvsId :: CanvasId @@ -177,7 +167,7 @@ -- |  canvasZoomUpdateBufAll :: MainCoroutine ()  canvasZoomUpdateBufAll = do -    klst <- liftM (M.keys . getCanvasInfoMap) get+    klst <- M.keys . view cvsInfoMap . view (unitHoodles.currentUnit) <$> get     mapM_ updatefunc klst    where      updatefunc cid @@ -187,14 +177,14 @@ -- | canvasZoomUpdateAll :: MainCoroutine ()  canvasZoomUpdateAll = do -  klst <- liftM (M.keys . getCanvasInfoMap) get+  klst <- M.keys . view cvsInfoMap . view (unitHoodles.currentUnit) <$> get   mapM_ (flip canvasZoomUpdateCvsId Nothing) klst    -- |  canvasZoomUpdate :: Maybe ZoomMode -> MainCoroutine ()  canvasZoomUpdate mzmode = do  -  cid <- (liftM (getCurrentCanvasId) get)+  cid <- getCurrentCanvasId . view (unitHoodles.currentUnit) <$> get   canvasZoomUpdateCvsId cid mzmode  -- |@@ -204,7 +194,7 @@ -- |  pageZoomChangeRel :: ZoomModeRel -> MainCoroutine ()  pageZoomChangeRel rzmode = do -    forBoth' unboxBiAct fsingle . view currentCanvasInfo =<< get +    forBoth' unboxBiAct fsingle . view currentCanvasInfo . view (unitHoodles.currentUnit) =<< get    where      fsingle :: CanvasInfo a -> MainCoroutine ()     fsingle cinfo = do @@ -216,42 +206,45 @@       pageZoomChange (Zoom nratio)  -- |-newPage :: AddDirection -> MainCoroutine () -newPage dir = updateXState npgBfrAct -              >> commit_ -              >> canvasZoomUpdateAll -              >> invalidateAll+newPage :: Maybe Dimension -> AddDirection -> MainCoroutine () +newPage mdim dir = (view backgroundStyle <$> get) >>= \bsty ->+                     updateUhdl (npgBfrAct bsty) >>+                     commit_                     >>+                     canvasZoomUpdateAll         >>+                     invalidateAll   where -    npgBfrAct xst = forBoth' unboxBiAct (fsimple xst) . view currentCanvasInfo $ xst-    fsimple :: HoodleState -> CanvasInfo a -> MainCoroutine HoodleState-    fsimple xstate cinfo = do -      case view hoodleModeState xstate of +    npgBfrAct bsty uhdl = forBoth' unboxBiAct (fsimple bsty uhdl) . view currentCanvasInfo $ uhdl+    fsimple :: BackgroundStyle -> UnitHoodle -> CanvasInfo a -> MainCoroutine UnitHoodle+    fsimple bsty uhdl cinfo = do +      case view hoodleModeState uhdl of          ViewAppendState hdl -> do -          let bsty = view backgroundStyle xstate -          hdl' <- addNewPageInHoodle bsty dir hdl (view currentPageNum cinfo)-          return =<< liftIO . updatePageAll (ViewAppendState hdl')-                     . set hoodleModeState  (ViewAppendState hdl') $ xstate +          hdl' <- addNewPageInHoodle mdim bsty dir hdl (view currentPageNum cinfo)+          liftIO . updatePageAll (ViewAppendState hdl')+                 . set hoodleModeState  (ViewAppendState hdl') $ uhdl         SelectState _ -> do -          liftIO $ putStrLn " not implemented yet"-          return xstate+          msgShout  "newPage: not implemented yet"+          return uhdl        -- | delete current page of current canvas deleteCurrentPage :: MainCoroutine ()           -deleteCurrentPage = do -    updateXState delpgact >> commit_ >> canvasZoomUpdateAll >> invalidateAll+deleteCurrentPage = +    updateUhdl delpgact >> +    commit_               >> +    canvasZoomUpdateAll   >> +    invalidateAll   where -    delpgact xst = forBoth' unboxBiAct (fsimple xst) . view currentCanvasInfo $ xst-    fsimple :: HoodleState -> CanvasInfo a -> MainCoroutine HoodleState-    fsimple xstate cinfo = do -      case view hoodleModeState xstate of +    delpgact uhdl = forBoth' unboxBiAct (fsimple uhdl) . view currentCanvasInfo $ uhdl+    fsimple :: UnitHoodle -> CanvasInfo a -> MainCoroutine UnitHoodle+    fsimple uhdl cinfo = do +      case view hoodleModeState uhdl of          ViewAppendState hdl -> do            hdl' <- liftIO $ deletePageInHoodle hdl                               (PageNum (view currentPageNum cinfo))-          return =<< liftIO . updatePageAll (ViewAppendState hdl')-                     . set hoodleModeState  (ViewAppendState hdl') $ xstate +          liftIO . updatePageAll (ViewAppendState hdl')+                 . set hoodleModeState  (ViewAppendState hdl') $ uhdl         SelectState _ -> do -          liftIO $ putStrLn " not implemented yet"-          return xstate+          msgShout "deleteCurrentPage: not implemented yet"+          return uhdl        -- | delete designated page deletePageInHoodle :: Hoodle EditMode -> PageNum -> IO (Hoodle EditMode)@@ -264,19 +257,20 @@   -- | -addNewPageInHoodle :: BackgroundStyle+addNewPageInHoodle :: Maybe Dimension+                   -> BackgroundStyle                    -> AddDirection                      -> Hoodle EditMode                    -> Int                     -> MainCoroutine (Hoodle EditMode)-addNewPageInHoodle bsty dir hdl cpn = do+addNewPageInHoodle mdim bsty dir hdl cpn = do     let pagelst = M.elems . view gpages $ hdl         (pagesbefore,cpage:pagesafter) = splitAt cpn pagelst         cbkg = view gbackground cpage     nbkg <- newBkg bsty cbkg-    npage <- set gbackground nbkg <$> newPageFromOld cpage-    geometry <- liftIO . getGeometry4CurrCvs =<< get-    callRenderer_ (updateBkgCache geometry (PageNum cpn,npage))+    npage <- maybe id (set gdimension) mdim . set gbackground nbkg <$> newPageFromOld cpage+    geometry <- liftIO . getGeometry4CurrCvs . view (unitHoodles.currentUnit) =<< get+    callRenderer_ (updatePageCache geometry (PageNum cpn,npage))     let npagelst = case dir of                       PageBefore -> pagesbefore ++ (npage : cpage : pagesafter)                      PageAfter -> pagesbefore ++ (cpage : npage : pagesafter)@@ -286,40 +280,85 @@  newBkg :: BackgroundStyle -> RBackground -> MainCoroutine RBackground  newBkg bsty bkg = do+    xst <- get+    let npmode = xst ^. settings.newPageMode+        rhdl = (getHoodle . view (unitHoodles.currentUnit)) xst+        mtotN = pdfNumPages <$> (rhdl ^. gembeddedpdf)       let bstystr = convertBackgroundStyleToByteString bsty -    case bkg of -      RBkgSmpl c _ _ -> RBkgSmpl c bstystr <$> liftIO nextRandom-      _              -> RBkgSmpl "white" bstystr <$> liftIO nextRandom+        defbkg = RBkgSmpl "white" bstystr <$> issueSurfaceID+    case npmode of +      NPPlain -> defbkg+      NPLast -> case bkg of +        RBkgSmpl c _ _ -> RBkgSmpl c bstystr <$> issueSurfaceID+        RBkgPDF d f n pg _ -> RBkgPDF d f n pg <$> issueSurfaceID+        RBkgEmbedPDF n pg _ -> RBkgEmbedPDF n pg <$> issueSurfaceID+      NPCycle -> +        case mtotN of+          Nothing -> defbkg+          Just totN -> do+            let n1 = maybe 1 id (xst ^. nextPdfBkgPageNum)+            case findPDFBkg rhdl n1 of+                 Nothing -> defbkg+                 Just bkg' -> issueSurfaceID >>= \i -> do+                                let n' = if n1 >= totN then 1 else (n1+1)+                                put ((nextPdfBkgPageNum .~ Just n') xst)+                                return bkg' { rbkg_surfaceid = i }  +findPDFBkg :: RHoodle -> Int -> Maybe RBackground+findPDFBkg rhdl n1 = +    let bkgs = M.elems (rhdl ^. gpages)+        pagematch n (RBkgPDF _ _ n' _ _) = n == n'+        pagematch n (RBkgEmbedPDF n' _ _) = n == n'+        pagematch _ _ = False+        matched = (filter (pagematch n1) . map (^. gbackground)) bkgs+    in case matched of +         [] -> Nothing+         b:_ -> Just b++ -- |  newPageFromOld :: Page EditMode -> MainCoroutine (Page EditMode)-newPageFromOld =-    return . ( glayers .~ (fromNonEmptyList (emptyRLayer,[])))+newPageFromOld pg = do+    sfcid <- issueSurfaceID+    return . ( glayers .~ (fromNonEmptyList (emptyRLayer sfcid,[]))) $ pg  -updateBkgCache :: CanvasGeometry -> (PageNum, Page EditMode) -> Renderer ()-updateBkgCache geometry (pnum,page) = do-  (handler,qvar) <- ask-  let dim@(Dim w h) = page ^. gdimension +updatePageCache :: CanvasGeometry -> (PageNum, Page EditMode) -> Renderer ()+updatePageCache geometry (pnum,page) = do+  let Dim w h = page ^. gdimension        CvsCoord (x0,y0) =          (desktop2Canvas geometry . page2Desktop geometry) (pnum,PageCoord (0,0))       CvsCoord (x1,y1) =          (desktop2Canvas geometry . page2Desktop geometry) (pnum,PageCoord (w,h))-      s = (x1-x0) / w -      rbkg = page ^. gbackground-      bkg = rbkg2Bkg rbkg-      uuid = rbkg_uuid rbkg +  updateBkgCache (Dim w h) (Dim (x1-x0) (y1-y0)) (page ^. gbackground) +  mapM_ (updateLayerCache (Dim w h) (Dim (x1-x0) (y1-y0))) (F.toList (page ^. glayers))+++updateBkgCache :: Dimension -> Dimension -> RBackground -> Renderer ()+updateBkgCache dimo dimv rbkg =  do+  RendererState _handler qpdf qgen _ <- ask+  let sfcid = rbkg_surfaceid rbkg    case rbkg of -    RBkgSmpl {..} -> do liftIO . forkIO $ do-                          sfc <- Cairo.createImageSurface Cairo.FormatARGB32 (floor (x1-x0)) (floor (y1-y0))-                          Cairo.renderWith sfc $ Cairo.scale s s >> renderBkg (bkg,dim)-                          handler (uuid, (s,sfc))-                        return ()-  +    RBkgSmpl {..} -> do+      cmdid <- issueGenCommandID+      (liftIO . atomically) (sendGenCommand qgen cmdid (BkgSmplScaled sfcid rbkg_color rbkg_style dimo dimv))+      return ()     _             -> F.forM_ (rbkg_popplerpage rbkg) $ \pg -> do-                       (liftIO . atomically) (sendPDFCommand uuid qvar (RenderPageScaled pg (Dim w h) (Dim (x1-x0) (y1-y0))))-                       return ()+      cmdid <- issuePDFCommandID+      (liftIO . atomically) (sendPDFCommand qpdf cmdid (RenderPageScaled sfcid pg dimo dimv))+      return ()+++updateLayerCache :: Dimension -> Dimension -> RLayer -> Renderer ()+updateLayerCache dimo dimv lyr =  do+  RendererState _ _ qgen _ <- ask+  case view gbuffer lyr of+    LyBuf sfcid -> do+      cmdid <- issueGenCommandID+      (liftIO . atomically) (sendGenCommand qgen cmdid (LayerScaled sfcid (view gitems lyr) dimo dimv))+      return ()+
src/Hoodle/Coroutine/Pen.hs view
@@ -1,11 +1,15 @@-{-# LANGUAGE Rank2Types, GADTs, ScopedTypeVariables, TupleSections #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}  ----------------------------------------------------------------------------- -- | -- Module      : Hoodle.Coroutine.Pen --- Copyright   : (c) 2011-2014 Ian-Woo Kim+-- Copyright   : (c) 2011-2015 Ian-Woo Kim ----- License     : GPL-3+-- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com> -- Stability   : experimental -- Portability : GHC@@ -16,27 +20,31 @@  -- from other packages import           Control.Applicative ((<$>),(<*>))-import           Control.Lens (view,set,at)+import           Control.Lens (at,over,set,view) import           Control.Monad hiding (mapM_,forM_) import           Control.Monad.State hiding (mapM_,forM_) -- import Control.Monad.Trans import           Data.Functor.Identity (Identity(..))-import           Data.Foldable (forM_)+import           Data.Foldable (toList) import           Data.Sequence hiding (filter)+import qualified Data.IntMap as IM import           Data.Maybe +import           Data.Ratio import           Data.Time.Clock  import qualified Graphics.Rendering.Cairo as Cairo -- from hoodle-platform import           Data.Hoodle.BBox-import           Data.Hoodle.Generic (gpages)+import           Data.Hoodle.Generic (gitems,gpages) import           Data.Hoodle.Simple (Dimension(..))-import           Graphics.Hoodle.Render (renderStrk)+import           Graphics.Hoodle.Render (renderStrk,updateLayerBuf)+import           Graphics.Hoodle.Render.Type -- from this package--- import           Hoodle.Accessor+import           Hoodle.Accessor import           Hoodle.Coroutine.Commit import           Hoodle.Coroutine.Draw import           Hoodle.Device  import           Hoodle.GUI.Reflect+import           Hoodle.ModelAction.Layer import           Hoodle.ModelAction.Page import           Hoodle.ModelAction.Pen import           Hoodle.Type.Canvas@@ -52,17 +60,40 @@ -- import Prelude hiding (mapM_) ++-- | +addPDraw :: CanvasId+         -> PenInfo +         -> RHoodle+         -> PageNum +         -> Seq (Double,Double,Double) +         -> MainCoroutine (RHoodle,BBox) -- ^ new hoodle and bbox in page coordinate+addPDraw cid pinfo hdl (PageNum pgnum) pdraw = do +    let currpage = getPageFromGHoodleMap pgnum hdl+        currlayer = getCurrentLayer currpage+        newstroke = createNewStroke pinfo pdraw         +        newstrokebbox = runIdentity (makeBBoxed newstroke)+        bbox = getBBox newstrokebbox+        newlayerbbox = over gitems (++[RItemStroke newstrokebbox]) currlayer+    callRenderer_ $ updateLayerBuf cid newlayerbbox+    let newpagebbox = adjustCurrentLayer newlayerbbox currpage +        newhdlbbox = set gpages (IM.adjust (const newpagebbox) pgnum (view gpages hdl) ) hdl +    return (newhdlbbox,bbox)++ -- | createTempRender :: CanvasGeometry -> a -> MainCoroutine (TempRender a)  createTempRender geometry x = do      xst <- get-    let cinfobox = view currentCanvasInfo xst +    cache <- renderCache+    let uhdl = view (unitHoodles.currentUnit) xst+        cinfobox = view currentCanvasInfo uhdl         mcvssfc = view (unboxLens mDrawSurface) cinfobox -        cache = view renderCache xst-    let hdl = getHoodle xst-    let Dim cw ch = unCanvasDimension . canvasDim $ geometry+        cid = getCurrentCanvasId uhdl+        hdl = getHoodle uhdl+        Dim cw ch = unCanvasDimension . canvasDim $ geometry     srcsfc <- liftIO $  -      maybe (fst <$> canvasImageSurface cache Nothing geometry hdl)+      maybe (fst <$> canvasImageSurface cache cid Nothing geometry hdl)             (\cvssfc -> do                sfc <- Cairo.createImageSurface                         Cairo.FormatARGB32 (floor cw) (floor ch) @@ -83,72 +114,76 @@ penPageSwitch :: PageNum -> MainCoroutine CanvasInfoBox  penPageSwitch pgn = do      xstate <- get-    let cibox = view currentCanvasInfo xstate     +    let uhdl = view (unitHoodles.currentUnit) xstate+        cibox = view currentCanvasInfo uhdl             ncibox = (runIdentity . forBoth unboxBiXform (return . set currentPageNum (unPageNum pgn))) cibox -    put (set currentCanvasInfo ncibox xstate) +        uhdl' = set currentCanvasInfo ncibox uhdl+    pureUpdateUhdl (const uhdl')     invalidateAllInBBox Nothing Efficient     return ncibox -        -+        -- | Common Pen Work starting point -commonPenStart :: (forall a. CanvasInfo a -> PageNum -> CanvasGeometry  -                    -> (Double,Double) -> MainCoroutine () )+commonPenStart :: forall b. +                  (forall a . CanvasInfo a -> PageNum -> CanvasGeometry  +                    -> (Double,Double) -> UTCTime -> MainCoroutine b)                -> CanvasId                 -> PointerCoord -               -> MainCoroutine ()+               -> MainCoroutine (Maybe b) commonPenStart action cid pcoord = do     oxstate <- get -    let currcid = getCurrentCanvasId oxstate+    let currcid = (getCurrentCanvasId . view (unitHoodles.currentUnit)) oxstate+    ctime <- liftIO $ getCurrentTime     when (cid /= currcid) (changeCurrentCanvasId cid >> invalidateAll)     nxstate <- get-    forBoth' unboxBiAct f . getCanvasInfo cid $ nxstate-  where f :: forall b. CanvasInfo b -> MainCoroutine ()-        f cvsInfo = do +    forBoth' unboxBiAct (f ctime) . getCanvasInfo cid . view (unitHoodles.currentUnit) $ nxstate+  where f :: forall c. UTCTime -> CanvasInfo c -> MainCoroutine (Maybe b)+        f ctime cvsInfo = do            let cpn = PageNum . view currentPageNum $ cvsInfo               arr = view (viewInfo.pageArrangement) cvsInfo                canvas = view drawArea cvsInfo           geometry <- liftIO $ makeCanvasGeometry cpn arr canvas           let pagecoord = desktop2Page geometry . device2Desktop geometry $ pcoord -          maybeFlip pagecoord (return ()) +          maybeFlip pagecoord (return Nothing)              $ \(pgn,PageCoord (x,y)) -> do                   nCvsInfo <- if (cpn /= pgn)                                 then do penPageSwitch pgn                                     -- temporary dirty fix                                         return (set currentPageNum (unPageNum pgn) cvsInfo )                                else return cvsInfo                   -                 action nCvsInfo pgn geometry (x,y) +                 Just <$> action nCvsInfo pgn geometry (x,y) ctime         -- | enter pen drawing mode penStart :: CanvasId           -> PointerCoord -         -> MainCoroutine () +         -> MainCoroutine (Maybe (Maybe (Maybe ()))) penStart cid pcoord = commonPenStart penAction cid pcoord-  where penAction :: forall b. CanvasInfo b -> PageNum -> CanvasGeometry -> (Double,Double) -> MainCoroutine ()-        penAction _cinfo pnum geometry (x,y) = do +  where penAction :: forall b. CanvasInfo b -> PageNum -> CanvasGeometry +                  -> (Double,Double) -> UTCTime +                  -> MainCoroutine (Maybe (Maybe ()))+        penAction _cinfo pnum geometry (x,y) ctime = do            xstate <- get+          let uhdl = view (unitHoodles.currentUnit) xstate           let PointerCoord _ _ _ z = pcoord -          let currhdl = getHoodle  xstate +          let currhdl = getHoodle  uhdl               pinfo = view penInfo xstate               mpage = view (gpages . at (unPageNum pnum)) currhdl -              cache = view renderCache xstate-          forM_ mpage $ \_page -> do +          maybeFlip mpage (return Nothing)  $ \_page -> do              trdr <- createTempRender geometry (empty |> (x,y,z)) -            pdraw <-penProcess cid pnum geometry trdr ((x,y),z) +            mpdraw <-penProcess cid pnum geometry trdr ((x,y),z) ctime             Cairo.surfaceFinish (tempSurfaceSrc trdr)-            Cairo.surfaceFinish (tempSurfaceTgt trdr)            -            ---            case viewl pdraw of -              EmptyL -> return ()-              (x1,_y1,_z1) :< _rest -> do -                if x1 <= 1e-3      -- this is ad hoc but.. -                  then invalidateAll-                  else do  -                    (newhdl,bbox) <- liftIO $ addPDraw cache pinfo currhdl pnum pdraw-                    commit . set hoodleModeState (ViewAppendState newhdl) -                      =<< (liftIO (updatePageAll (ViewAppendState newhdl) xstate))-                    let f = unDeskCoord . page2Desktop geometry . (pnum,) . PageCoord-                        nbbox = xformBBox f bbox -                    invalidateAllInBBox (Just nbbox) BkgEfficient +            Cairo.surfaceFinish (tempSurfaceTgt trdr)+            maybeFlip mpdraw (return (Just Nothing)) $ \pdraw -> +              case viewl pdraw of +                EmptyL -> return (Just (Just ()))+                (x1,_y1,_z1) :< _rest -> do +                  if x1 <= 1e-3      -- this is ad hoc but.. +                    then invalidateAll+                    else do  +                      (newhdl,_bbox) <- addPDraw cid pinfo currhdl pnum pdraw+                      uhdl' <- liftIO (updatePageAll (ViewAppendState newhdl) uhdl)+                      commit (set (unitHoodles.currentUnit) uhdl' xstate)+                      return ()+                  return (Just (Just ()))            -- | main pen coordinate adding process -- | now being changed@@ -157,19 +192,31 @@            -> CanvasGeometry            -> TempRender (Seq (Double,Double,Double))            -> ((Double,Double),Double) -           -> MainCoroutine (Seq (Double,Double,Double))-penProcess cid pnum geometry trdr ((x0,y0),z0) = do +           -> UTCTime+           -> MainCoroutine (Maybe (Seq (Double,Double,Double)))+penProcess cid pnum geometry trdr ((x0,y0),z0) ctime = do      r <- nextevent-    xst <- get -    forBoth' unboxBiAct (fsingle r xst) . getCanvasInfo cid $ xst+    ntime <- liftIO getCurrentTime+    let ispressandhold = +          abs (toRational (diffUTCTime ctime ntime)) > 1 % 2+        lst = (toList . tempInfo) trdr+        deltax = let xlst = map (\(x,_,_)->x) lst+                 in abs (maximum xlst - minimum xlst)+        deltay = let ylst = map (\(_,y,_)->y) lst+                 in abs (maximum ylst - minimum ylst)+    -- temporarily fix the range+    if (deltax < 20 && deltay < 20 && ispressandhold && Prelude.length lst < 20) +      then return Nothing +      else do xst <- get +              forBoth' unboxBiAct (fsingle r xst) . (getCanvasInfo cid . view (unitHoodles.currentUnit)) $ xst   where      pdraw = tempInfo trdr      fsingle :: forall b.                  UserEvent -> HoodleState -> CanvasInfo b -               -> MainCoroutine (Seq (Double,Double,Double))+               -> MainCoroutine (Maybe (Seq (Double,Double,Double)))     fsingle r xstate cvsInfo =        penMoveAndUpOnly r pnum geometry -        (penProcess cid pnum geometry trdr ((x0,y0),z0))+        (penProcess cid pnum geometry trdr ((x0,y0),z0) ctime)         (\(pcoord,(x,y)) -> do             let PointerCoord _ _ _ z = pcoord             let pinfo  = view penInfo xstate@@ -183,8 +230,8 @@            liftIO $ doubleBufferFlush tgtsfc cvsInfo            ---                                            let ntrdr = trdr { tempInfo = pdraw |> (x,y,z) }-           penProcess cid pnum geometry ntrdr ((x,y),z) )-        (\_ -> return pdraw )+           penProcess cid pnum geometry ntrdr ((x,y),z) ctime)+        (\_ -> return (Just pdraw))  -- |  skipIfNotInSamePage :: Monad m =>
src/Hoodle/Coroutine/Scroll.hs view
@@ -1,11 +1,14 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} + ----------------------------------------------------------------------------- -- | -- Module      : Hoodle.Coroutine.Scroll  -- Copyright   : (c) 2011-2014 Ian-Woo Kim ----- License     : GPL-3+-- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com> -- Stability   : experimental -- Portability : GHC@@ -18,6 +21,7 @@ import           Control.Monad import           Control.Monad.State  import           Control.Monad.Trans.Either+-- import qualified Graphics.UI.Gtk as Gtk -- from hoodle-platform import           Control.Monad.Trans.Crtn import           Data.Functor.Identity (Identity(..))@@ -36,15 +40,30 @@ import           Hoodle.View.Coordinate -- +-- |+updateCanvasInfo :: (forall a. CanvasInfo a -> CanvasInfo a) -> CanvasId -> MainCoroutine ()+updateCanvasInfo f cid = pureUpdateUhdl $ \uhdl -> +                           let cinfobox = getCanvasInfo cid uhdl+                               ncinfobox = (runIdentity . forBoth unboxBiXform (return . f)) cinfobox+                           in setCanvasInfo (cid,ncinfobox) uhdl++-- |+updateCanvasInfo2 :: (CanvasInfo SinglePage -> CanvasInfo SinglePage) +                  -> (CanvasInfo ContinuousPage -> CanvasInfo ContinuousPage)+                  -> CanvasId+                  -> MainCoroutine ()+updateCanvasInfo2 fs fc cid = +    pureUpdateUhdl $ \uhdl ->+      let cinfobox = getCanvasInfo cid uhdl+          ncinfobox = (runIdentity . unboxBiXform (return . fs) (return . fc)) cinfobox+      in setCanvasInfo (cid,ncinfobox) uhdl+ -- |  moveViewPortBy :: MainCoroutine ()->CanvasId-> ((Double,Double)->(Double,Double))                   -> MainCoroutine ()  moveViewPortBy rndr cid f = -    updateXState (return . act) >> adjustScrollbarWithGeometryCvsId cid >> rndr +    updateCanvasInfo moveact cid >> adjustScrollbarWithGeometryCvsId cid >> rndr    where     -    act xst = let cinfobox = getCanvasInfo cid xst -                  ncinfobox = (runIdentity . forBoth unboxBiXform (return . moveact)) cinfobox       -              in setCanvasInfo (cid,ncinfobox) xst     moveact :: CanvasInfo a -> CanvasInfo a      moveact cinfo =        let BBox (x0,y0) _ = @@ -60,25 +79,19 @@ adjustScrollbarWithGeometryCvsId :: CanvasId -> MainCoroutine () adjustScrollbarWithGeometryCvsId cid = do   xstate <- get-  let cinfobox = getCanvasInfo cid xstate-  geometry <- liftIO (getCanvasGeometryCvsId cid xstate)+  let uhdl = view (unitHoodles.currentUnit) xstate+      cinfobox = getCanvasInfo cid uhdl+  geometry <- liftIO (getCanvasGeometryCvsId cid uhdl)   let (hadj,vadj) = view (unboxLens adjustments) cinfobox        connidh = view (unboxLens horizAdjConnId) cinfobox        connidv = view (unboxLens vertAdjConnId) cinfobox-  liftIO $ A.adjustScrollbarWithGeometry geometry ((hadj,connidh),(vadj,connidv))  +  doIOaction_ $ A.adjustScrollbarWithGeometry geometry ((hadj,connidh),(vadj,connidv))     -- |  adjustScrollbarWithGeometryCurrent :: MainCoroutine ()-adjustScrollbarWithGeometryCurrent = adjustScrollbarWithGeometryCvsId . view (currentCanvas._1) =<<  get -{-  xstate <- get-  geometry <- liftIO . getGeometry4CurrCvs $ xstate-  let cinfobox = view currentCanvasInfo xstate-  let (hadj,vadj) = unboxGet adjustments cinfobox -      connidh = unboxGet horizAdjConnId cinfobox -      connidv = unboxGet vertAdjConnId cinfobox-  liftIO $ A.adjustScrollbarWithGeometry geometry ((hadj,connidh),(vadj,connidv))  --}+adjustScrollbarWithGeometryCurrent = adjustScrollbarWithGeometryCvsId . view (currentCanvas._1) +                                     . view (unitHoodles.currentUnit) =<< get   -- |  hscrollBarMoved :: CanvasId -> Double -> MainCoroutine ()         @@ -97,13 +110,13 @@   chkCvsIdNInvalidate cid    vscrollMove cid v         - -- |                    vscrollMove :: CanvasId -> Double -> MainCoroutine ()  vscrollMove cid v0 = do         ev <- nextevent      xst <- get -    geometry <- liftIO (getCanvasGeometryCvsId cid xst)+    let uhdl = view (unitHoodles.currentUnit) xst+    geometry <- liftIO (getCanvasGeometryCvsId cid uhdl)     case ev of       VScrollBarMoved cid' v -> do          when (cid /= cid') $ @@ -119,37 +132,25 @@       VScrollBarStart cid' v -> vscrollStart cid' v        _ -> return ()        -- -- |  smoothScroll :: CanvasId -> CanvasGeometry -> Double -> Double -> MainCoroutine () -smoothScroll cid geometry v0 v = do -    xst <- get -    let b = view (settings.doesSmoothScroll) xst -    let diff = (v - v0) -        lst'  | (diff < 20 && diff > -20) = [v]-              | (diff < 5 &&diff > -5) = []-              | otherwise = let m :: Int = floor (minimum [20, (abs diff) / 10.0])-                                delta = diff / fromIntegral m            -                            in [v0 + fromIntegral n*delta | n <- [1..m] ]-        lst | b  = lst'                     -            | otherwise = [v] +smoothScroll cid geometry _v0 v = do +    -- xst <- get +    let lst = [v]     forM_ lst $ \v' -> do -      updateXState $ return . over currentCanvasInfo  -                     (runIdentity -                    . unboxBiXform (Identity . scrollmovecanvas v) -                                   (Identity . scrollmovecanvasCont geometry v') )+      -- updateXState $ return . updater +      updateCanvasInfo2 (scrollmovecanvas v) (scrollmovecanvasCont geometry v') cid       invalidateInBBox Nothing Efficient cid -  where scrollmovecanvas vv cvsInfo = -          let BBox vm_orig _ = unViewPortBBox $ view (viewInfo.pageArrangement.viewPortBBox) cvsInfo-          in over (viewInfo.pageArrangement.viewPortBBox) -                  (apply (moveBBoxULCornerTo (fst vm_orig,vv))) cvsInfo -        -- -        scrollmovecanvasCont geom vv cvsInfo = -          let BBox vm_orig _ = unViewPortBBox $ view (viewInfo.pageArrangement.viewPortBBox) cvsInfo-              cpn = PageNum . view currentPageNum $ cvsInfo -              ncpn = maybe cpn fst $ desktop2Page geom (DeskCoord (0,vv))-          in  over currentPageNum (const (unPageNum ncpn)) -              . over (viewInfo.pageArrangement.viewPortBBox) -                       (apply (moveBBoxULCornerTo (fst vm_orig,vv))) $ cvsInfo -+  where +    scrollmovecanvas vv cvsInfo = +      let BBox vm_orig _ = unViewPortBBox $ view (viewInfo.pageArrangement.viewPortBBox) cvsInfo+      in over (viewInfo.pageArrangement.viewPortBBox) +              (apply (moveBBoxULCornerTo (fst vm_orig,vv))) cvsInfo +    -- +    scrollmovecanvasCont geom vv cvsInfo = +      let BBox vm_orig _ = unViewPortBBox $ view (viewInfo.pageArrangement.viewPortBBox) cvsInfo+          cpn = PageNum . view currentPageNum $ cvsInfo +          ncpn = maybe cpn fst $ desktop2Page geom (DeskCoord (0,vv))+      in  over currentPageNum (const (unPageNum ncpn)) +          . over (viewInfo.pageArrangement.viewPortBBox) +                   (apply (moveBBoxULCornerTo (fst vm_orig,vv))) $ cvsInfo
src/Hoodle/Coroutine/Select.hs view
@@ -3,9 +3,9 @@ ----------------------------------------------------------------------------- -- | -- Module      : Hoodle.Coroutine.Select --- Copyright   : (c) 2011-2014 Ian-Woo Kim+-- Copyright   : (c) 2011-2015 Ian-Woo Kim ----- License     : GPL-3+-- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com> -- Stability   : experimental -- Portability : GHC@@ -18,8 +18,8 @@  -- from other package  import           Control.Applicative-import           Control.Category-import           Control.Lens (view,set)+-- import           Control.Category+import           Control.Lens (view,set,(.~),(^.)) import           Control.Monad import           Control.Monad.Identity import           Control.Monad.State@@ -47,6 +47,7 @@ import           Hoodle.Coroutine.Draw import           Hoodle.Coroutine.Mode import           Hoodle.Coroutine.Pen+import           Hoodle.Coroutine.Select.Clipboard import           Hoodle.ModelAction.Layer  import           Hoodle.ModelAction.Page import           Hoodle.ModelAction.Pen@@ -62,21 +63,21 @@ import           Hoodle.View.Coordinate import           Hoodle.View.Draw -- -import           Prelude hiding ((.), id)+-- import           Prelude hiding ((.), id)  -- | For Selection mode from pen mode with 2nd pen button dealWithOneTimeSelectMode :: MainCoroutine ()  -- ^ main action                            -> MainCoroutine ()  -- ^ terminating action                           -> MainCoroutine () dealWithOneTimeSelectMode action terminator = do -  xstate <- get -  case view isOneTimeSelectMode xstate of +  uhdl <- view (unitHoodles.currentUnit) <$> get +  case view isOneTimeSelectMode uhdl of      NoOneTimeSelectMode -> action      YesBeforeSelect -> -      action >> updateXState (return . set isOneTimeSelectMode YesAfterSelect)+      action >> pureUpdateUhdl (isOneTimeSelectMode .~ YesAfterSelect)     YesAfterSelect -> do        terminator -      updateXState (return . set isOneTimeSelectMode NoOneTimeSelectMode) +      pureUpdateUhdl (isOneTimeSelectMode .~ NoOneTimeSelectMode)        modeChange ToViewAppendMode    @@ -90,20 +91,23 @@                      -> MainCoroutine () commonSelectStart typ pbtn cid = case typ of                                     SelectHandToolWork -> (\_ -> return ())-                                   _ -> commonPenStart selectaction cid-  where selectaction cinfo pnum geometry (x,y) = do+                                   _ -> commonPenStart selectaction cid >=> const (return ())++  where selectaction cinfo pnum geometry (x,y) _ = do           itms <- rItmsInCurrLyr           ctime <- liftIO $ getCurrentTime           let newSelectAction _page =                  dealWithOneTimeSelectMode                    (do tsel <- createTempRender geometry []                        case typ of -                        SelectRectangleWork -> +                        SelectRectangleWork -> do                           newSelectRectangle cid pnum geometry itms                              (x,y) ((x,y),ctime) tsel-                        SelectLassoWork -> +                          return ()+                        SelectLassoWork -> do                           newSelectLasso cinfo pnum geometry itms                               (x,y) ((x,y),ctime) (Sq.empty |> (x,y)) tsel+                          return ()                         _ -> return ()                       Cairo.surfaceFinish (tempSurfaceSrc tsel)                        showContextMenu (pnum,(x,y))@@ -111,9 +115,9 @@                   (return ())                 action (Right tpage) | hitInHandle tpage (x,y) = do                   let doesKeepRatio = case pbtn of -                                          PenButton1 -> True-                                          PenButton3 -> False-                                          _ -> False+                                      PenButton1 -> True+                                      PenButton3 -> False+                                      _ -> False                 case getULBBoxFromSelected tpage of                    Middle bbox ->                       maybe (return ()) @@ -131,8 +135,8 @@                   _ -> return ()                action (Right tpage) | otherwise = newSelectAction (hPage2RPage tpage)               action (Left page) = newSelectAction page-          xstate <- get -          let hdlmodst = view hoodleModeState xstate +          uhdl <- view (unitHoodles.currentUnit) <$> get +          let hdlmodst = view hoodleModeState uhdl            let epage = getCurrentPageEitherFromHoodleModeState cinfo hdlmodst            action epage @@ -155,13 +159,12 @@                    (prev,otime) tempselection = do       r <- nextevent     xst <- get -    forBoth' unboxBiAct (fsingle r xst) . getCanvasInfo cid $ xst+    cache <- renderCache+    forBoth' unboxBiAct (fsingle r xst cache) . getCanvasInfo cid . view (unitHoodles.currentUnit) $ xst   where -    fsingle r xstate cinfo = penMoveAndUpOnly r pnum geometry defact-                               (moveact xstate cinfo) (upact xstate cinfo)-    defact = newSelectRectangle cid pnum geometry itms orig -                         (prev,otime) tempselection -    moveact xstate _cinfo (_pcoord,(x,y)) = do +    fsingle r xstate cache cinfo = penMoveAndUpOnly r pnum geometry defact (moveact cache) (upact xstate cinfo)+    defact = newSelectRectangle cid pnum geometry itms orig (prev,otime) tempselection +    moveact cache (_pcoord,(x,y)) = do        let bbox = BBox orig (x,y)           hittestbbox = hltEmbeddedByBBox bbox itms           hitteditms = takeHitted hittestbbox@@ -171,17 +174,16 @@       when ((not.null) fitms || (not.null) sitms) $ do          let xformfunc = cairoXform4PageCoordinate (mkXform4Page geometry pnum)             ulbbox = unUnion . mconcat . fmap (Union .Middle . flip inflate 5 . getBBox) $ fitms-            cache = view renderCache xstate             xform = mkXform4Page geometry pnum             renderfunc = do                  xformfunc                case ulbbox of                  Top -> do                -                  cairoRenderOption (InBBoxOption Nothing) cache (InBBox page, Just xform) +                  cairoRenderOption (InBBoxOption Nothing) cache cid (InBBox page, Just xform)                    mapM_ renderSelectedItem hitteditms                 Middle sbbox -> do                    let redrawee = filter (do2BBoxIntersect sbbox.getBBox) hitteditms  -                  cairoRenderOption (InBBoxOption (Just sbbox)) cache (InBBox page, Just xform)+                  cairoRenderOption (InBBoxOption (Just sbbox)) cache cid (InBBox page, Just xform)                   clipBBox (Just sbbox)                   mapM_ renderSelectedItem redrawee                  Bottom -> return ()@@ -197,12 +199,13 @@       let (_,(x,y)) = runIdentity $              skipIfNotInSamePage pnum geometry pcoord                                  (return (pcoord,prev)) return-          epage = getCurrentPageEitherFromHoodleModeState cinfo (view hoodleModeState xstate)+          uhdl = view (unitHoodles.currentUnit) xstate+          epage = getCurrentPageEitherFromHoodleModeState cinfo (view hoodleModeState uhdl)           cpn = view currentPageNum cinfo            bbox = BBox orig (x,y)           hittestbbox = hltEmbeddedByBBox bbox itms           selectitms = fmapAL unNotHitted id hittestbbox-          SelectState thdl = view hoodleModeState xstate+          SelectState thdl = view hoodleModeState uhdl           newpage = case epage of                        Left pagebbox -> makePageSelectMode pagebbox selectitms                        Right tpage -> @@ -212,9 +215,10 @@                         in npage           newthdl = set gselSelected (Just (cpn,newpage)) thdl            ui = view gtkUIManager xstate-      liftIO $ toggleCutCopyDelete ui (isAnyHitted  selectitms)-      put . set hoodleModeState (SelectState newthdl) -            =<< (liftIO (updatePageAll (SelectState newthdl) xstate))+      liftIO $ toggleCutCopyDelete ui (isAnyHitted selectitms)+      uhdl' <- liftIO (updatePageAll (SelectState newthdl) uhdl)+      pureUpdateUhdl (const ((hoodleModeState .~ SelectState newthdl) uhdl'))+      commit_       invalidateAllInBBox Nothing Efficient  @@ -226,8 +230,8 @@                    -> Page SelectMode                    -> MainCoroutine ()  startMoveSelect cid pnum geometry ((x,y),ctime) tpage = do-    cache <- view renderCache <$> get-    itmimage <- liftIO $ mkItmsNImg cache tpage+    cache <- renderCache+    itmimage <- liftIO $ mkItmsNImg cache cid tpage     tsel <- createTempRender geometry itmimage      moveSelect cid pnum geometry (x,y) ((x,y),ctime) tsel      Cairo.surfaceFinish (tempSurfaceSrc tsel)@@ -246,21 +250,20 @@ moveSelect cid pnum geometry orig@(x0,y0)             (prev,otime) tempselection = do     xst <- get+    let uhdl = view (unitHoodles.currentUnit) xst     r <- nextevent -    forBoth' unboxBiAct (fsingle r xst) . getCanvasInfo cid $ xst +    forBoth' unboxBiAct (fsingle r uhdl) (getCanvasInfo cid uhdl)   where -    fsingle r xstate cinfo = -      penMoveAndUpInterPage r pnum geometry defact (moveact xstate cinfo) (upact xstate cinfo) -    defact = moveSelect cid pnum geometry orig (prev,otime) -               tempselection-    moveact _xstate _cinfo oldpgn pcpair@(newpgn,PageCoord (px,py)) = do +    fsingle r uhdl cinfo = +      penMoveAndUpInterPage r pnum geometry defact moveact (upact uhdl cinfo) +    defact = moveSelect cid pnum geometry orig (prev,otime) tempselection+    moveact oldpgn pcpair@(newpgn,PageCoord (px,py)) = do        let (x,y)              | oldpgn == newpgn = (px,py)              | otherwise =                let DeskCoord (xo,yo) = page2Desktop geometry (oldpgn,PageCoord (0,0))                   DeskCoord (xn,yn) = page2Desktop geometry pcpair                in (xn-xo,yn-yo)-             (willUpdate,(ncoord,ntime)) <- liftIO $ getNewCoordTime (prev,otime) (x,y)        when willUpdate $ do          let sfunc = offsetFunc (x-x0,y-y0)@@ -275,25 +278,25 @@         invalidateTempBasePage cid (tempSurfaceSrc tempselection) pnum            (drawTempSelectImage geometry tempselection xformmat)        moveSelect cid pnum geometry orig (ncoord,ntime) tempselection-    upact :: HoodleState -> CanvasInfo a -> PointerCoord -> MainCoroutine () -    upact xst cinfo pcoord =  +    upact :: UnitHoodle -> CanvasInfo a -> PointerCoord -> MainCoroutine () +    upact uhdl cinfo pcoord =        switchActionEnteringDiffPage pnum geometry pcoord (return ()) -        (chgaction xst cinfo) -        (ordaction xst cinfo)-    chgaction :: HoodleState -> CanvasInfo a -> PageNum -> (PageNum,PageCoordinate) -> MainCoroutine () -    chgaction xstate cinfo oldpgn (newpgn,PageCoord (x,y)) = do -      let hdlmodst@(SelectState thdl) = view hoodleModeState xstate+        (chgaction uhdl cinfo) +        (ordaction uhdl cinfo)+    chgaction :: UnitHoodle -> CanvasInfo a +              -> PageNum -> (PageNum,PageCoordinate) -> MainCoroutine () +    chgaction uhdl cinfo oldpgn (newpgn,PageCoord (x,y)) = do +      let hdlmodst@(SelectState thdl) = view hoodleModeState uhdl           epage = getCurrentPageEitherFromHoodleModeState cinfo hdlmodst-          cache = view renderCache xstate-      (xstate1,nthdl1,selecteditms) <- +          cvsid = view canvasId cinfo+      (uhdl1,nthdl1,selecteditms) <-          case epage of            Right oldtpage -> do              let itms = getSelectedItms oldtpage             let oldtpage' = deleteSelected oldtpage-            nthdl <- liftIO $ updateTempHoodleSelectIO cache thdl oldtpage' (unPageNum oldpgn)-            xst <- return . set hoodleModeState (SelectState nthdl)-                     =<< (liftIO (updatePageAll (SelectState nthdl) xstate)) -            return (xst,nthdl,itms)       +            nthdl <- updateTempHoodleSelectM cvsid thdl oldtpage' (unPageNum oldpgn)+            uhdl' <- liftIO (updatePageAll (SelectState nthdl) uhdl)+            return (uhdl',nthdl,itms)                  Left _ -> error "this is impossible, in moveSelect"        let maction = do              page <- M.lookup (unPageNum newpgn) (view gselAll nthdl1)@@ -303,35 +306,32 @@                 alist = olditms :- Hitted newitms :- Empty                  ntpage = makePageSelectMode page alist                   coroutineaction = do -                  nthdl2 <- liftIO $ updateTempHoodleSelectIO cache nthdl1 ntpage (unPageNum newpgn)  -                  let cibox = view currentCanvasInfo xstate1 -                      ncibox = (runIdentity . forBoth unboxBiXform (return . set currentPageNum (unPageNum newpgn))) -                                 cibox -                      cmap = getCanvasInfoMap xstate1 -                      cmap' = M.adjust (const ncibox) cid cmap -                      xst = maybe xstate1 id $ setCanvasInfoMap cmap' xstate1-                  return . set hoodleModeState (SelectState nthdl2)-                    =<< (liftIO (updatePageAll (SelectState nthdl2) xst)) +                  nthdl2 <- updateTempHoodleSelectM cvsid nthdl1 ntpage (unPageNum newpgn)  +                  -- let cibox = view currentCanvasInfo uhdl1 +                  --     ncibox = ( runIdentity +                  --             . forBoth unboxBiXform (return . set currentPageNum (unPageNum newpgn))) +                  --               cibox +                  liftIO (updatePageAll (SelectState nthdl2) uhdl1)             return coroutineaction-      xstate2 <- maybe (return xstate1) id maction -      commit xstate2-      -- invalidateAll +      uhdl2 <- maybe (return uhdl1) id maction+      pureUpdateUhdl (const uhdl2)+      commit_       invalidateAllInBBox Nothing Efficient     -----    ordaction xstate cinfo _pgn (_cpn,PageCoord (x,y)) = do +    ordaction uhdl cinfo _pgn (_cpn,PageCoord (x,y)) = do        let offset = (x-x0,y-y0)-          hdlmodst@(SelectState thdl) = view hoodleModeState xstate+          hdlmodst@(SelectState thdl) = view hoodleModeState uhdl           epage = getCurrentPageEitherFromHoodleModeState cinfo hdlmodst           pagenum = view currentPageNum cinfo+          cvsid = view canvasId cinfo       case epage of          Right tpage -> do            let newtpage = changeSelectionByOffset offset tpage-              cache = view renderCache xstate-          newthdl <- liftIO $ updateTempHoodleSelectIO cache thdl newtpage pagenum -          commit . set hoodleModeState (SelectState newthdl)-                 =<< (liftIO (updatePageAll (SelectState newthdl) xstate))+          newthdl <- updateTempHoodleSelectM cvsid thdl newtpage pagenum +          uhdl' <- liftIO (updatePageAll (SelectState newthdl) uhdl)+          pureUpdateUhdl (const uhdl')+          commit_          Left _ -> error "this is impossible, in moveSelect" -      -- invalidateAll        invalidateAllInBBox Nothing Efficient         @@ -347,8 +347,8 @@                   -> MainCoroutine ()  startResizeSelect doesKeepRatio handle cid pnum geometry bbox                    ((x,y),ctime) tpage = do-    cache <- view renderCache <$> get  -    itmimage <- liftIO $ mkItmsNImg cache tpage  +    cache <- renderCache+    itmimage <- liftIO $ mkItmsNImg cache cid tpage       tsel <- createTempRender geometry itmimage      resizeSelect doesKeepRatio        handle cid pnum geometry bbox ((x,y),ctime) tsel @@ -370,12 +370,12 @@ resizeSelect doesKeepRatio handle cid pnum geometry origbbox               (prev,otime) tempselection = do     xst <- get+    let uhdl = view (unitHoodles.currentUnit) xst     r <- nextevent -    forBoth' unboxBiAct (fsingle r xst) . getCanvasInfo cid $ xst+    forBoth' unboxBiAct (fsingle r uhdl) . getCanvasInfo cid $ uhdl   where-    fsingle r xstate cinfo = penMoveAndUpOnly r pnum geometry defact moveact (upact xstate cinfo)-    defact = resizeSelect doesKeepRatio handle cid pnum geometry -               origbbox (prev,otime) tempselection+    fsingle r uhdl cinfo = penMoveAndUpOnly r pnum geometry defact moveact (upact uhdl cinfo)+    defact = resizeSelect doesKeepRatio handle cid pnum geometry origbbox (prev,otime) tempselection     moveact (_pcoord,(x,y)) = do        (willUpdate,(ncoord,ntime)) <- liftIO $ getNewCoordTime (prev,otime) (x,y)        when willUpdate $ do @@ -393,20 +393,16 @@                          | otherwise -> newbbox'               else newbbox'              sfunc = scaleFromToBBox origbbox newbbox-            xform = unCvsCoord . desktop2Canvas geometry-                    . page2Desktop geometry . (,) pnum . PageCoord+            xform = unCvsCoord . desktop2Canvas geometry . page2Desktop geometry . (,) pnum . PageCoord             (c1,c2) = xform (sfunc (0,0))             (a1',a2') = xform (sfunc (1,0))             (a1,a2) = (a1'-c1,a2'-c2)             (b1',b2') = xform (sfunc (0,1))             (b1,b2) = (b1'-c1,b2'-c2)             xformmat = Mat.Matrix a1 a2 b1 b2 c1 c2 -        invalidateTemp cid (tempSurfaceSrc tempselection) -                           (drawTempSelectImage geometry tempselection -                              xformmat)-      resizeSelect doesKeepRatio handle cid pnum geometry -                   origbbox (ncoord,ntime) tempselection-    upact xstate cinfo pcoord = do +        invalidateTemp cid (tempSurfaceSrc tempselection) (drawTempSelectImage geometry tempselection xformmat)+      resizeSelect doesKeepRatio handle cid pnum geometry origbbox (ncoord,ntime) tempselection+    upact uhdl cinfo pcoord = do        let (_,(x,y)) = runIdentity $              skipIfNotInSamePage pnum geometry pcoord                                  (return (pcoord,prev)) return@@ -423,19 +419,19 @@                        | handle == HandleBR -> BBox (x0,y0) (x1,y0+(x1-x0)*r)                        | otherwise -> newbbox'             else newbbox' -          hdlmodst@(SelectState thdl) = view hoodleModeState xstate+          hdlmodst@(SelectState thdl) = view hoodleModeState uhdl           epage = getCurrentPageEitherFromHoodleModeState cinfo hdlmodst           pagenum = view currentPageNum cinfo+          cvsid = view canvasId cinfo       case epage of          Right tpage -> do            let sfunc = scaleFromToBBox origbbox newbbox               newtpage = changeSelectionBy sfunc tpage -              cache = view renderCache xstate-          newthdl <- liftIO $ updateTempHoodleSelectIO cache thdl newtpage pagenum -          commit . set hoodleModeState (SelectState newthdl)-                 =<< (liftIO (updatePageAll (SelectState newthdl) xstate))+          newthdl <- updateTempHoodleSelectM cvsid thdl newtpage pagenum +          uhdl' <- liftIO (updatePageAll (SelectState newthdl) uhdl)+          pureUpdateUhdl (const uhdl')+          commit_         Left _ -> error "this is impossible, in resizeSelect" -      -- invalidateAll       invalidateAllInBBox Nothing Efficient       return ()     @@ -443,50 +439,50 @@ -- |  selectPenColorChanged :: PenColor -> MainCoroutine ()  selectPenColorChanged pcolor = do -  xstate <- get-  let SelectState thdl = view hoodleModeState xstate -      Just (n,tpage) = view gselSelected thdl-      slayer = view (glayers.selectedLayer) tpage-  case unTEitherAlterHitted . view gitems $ slayer of -    Left _ -> return () -    Right alist -> do -      let alist' = fmapAL id -                     (Hitted . map (changeItemStrokeColor pcolor) . unHitted) alist-          newlayer = Right alist'-          newpage = set (glayers.selectedLayer) (GLayer (view gbuffer slayer) (TEitherAlterHitted newlayer)) tpage -          cache = view renderCache xstate-      newthdl <- liftIO $ updateTempHoodleSelectIO cache thdl newpage n-      commit =<< liftIO (updatePageAll (SelectState newthdl)-                        . set hoodleModeState (SelectState newthdl) $ xstate )-      -- invalidateAll -      invalidateAllInBBox Nothing Efficient+    uhdl <- view (unitHoodles.currentUnit) <$> get +    let cid = getCurrentCanvasId uhdl+        SelectState thdl = view hoodleModeState uhdl+        Just (n,tpage) = view gselSelected thdl+        slayer = view (glayers.selectedLayer) tpage+    case unTEitherAlterHitted . view gitems $ slayer of +      Left _ -> return () +      Right alist -> do +        let alist' = fmapAL id (Hitted . map (changeItemStrokeColor pcolor) . unHitted) alist+            newlayer = Right alist'+            newpage = (glayers.selectedLayer .~ (GLayer (slayer^.gbuffer) (TEitherAlterHitted newlayer))) tpage +        newthdl <- updateTempHoodleSelectM cid thdl newpage n+        uhdl' <- liftIO (updatePageAll (SelectState newthdl) uhdl)+        pureUpdateUhdl (const uhdl')+        commit_+        invalidateAllInBBox Nothing Efficient            -- |  selectPenWidthChanged :: Double -> MainCoroutine ()  selectPenWidthChanged pwidth = do -  xstate <- get-  let SelectState thdl = view hoodleModeState xstate +  xst <- get+  let uhdl = view (unitHoodles.currentUnit) xst+      cid = getCurrentCanvasId uhdl+      SelectState thdl = view hoodleModeState uhdl       Just (n,tpage) = view gselSelected thdl       slayer = view (glayers.selectedLayer) tpage-      cache = view renderCache xstate-  case unTEitherAlterHitted . view gitems $ slayer  of +  case (unTEitherAlterHitted . view gitems) slayer of      Left _ -> return ()      Right alist -> do        let alist' = fmapAL id                       (Hitted . map (changeItemStrokeWidth pwidth) . unHitted) alist           newlayer = Right alist'           newpage = set (glayers.selectedLayer) (GLayer (view gbuffer slayer) (TEitherAlterHitted newlayer)) tpage-      newthdl <- liftIO $ updateTempHoodleSelectIO cache thdl newpage n          -      commit =<< liftIO (updatePageAll (SelectState newthdl) -                         . set hoodleModeState (SelectState newthdl) $ xstate )-      -- invalidateAll +      newthdl <- updateTempHoodleSelectM cid thdl newpage n          +      uhdl' <- liftIO (updatePageAll (SelectState newthdl) uhdl)+      pureUpdateUhdl (const uhdl')+      commit_       invalidateAllInBBox Nothing Efficient   -- | main mouse pointer click entrance in lasso selection mode.  --   choose either starting new rectangular selection or move previously  --   selected selection.  selectLassoStart :: PenButton -> CanvasId -> PointerCoord -> MainCoroutine ()-selectLassoStart = commonSelectStart SelectLassoWork+selectLassoStart p cid coord = commonSelectStart SelectLassoWork p cid coord >> return ()             -- | @@ -501,23 +497,19 @@                   -> MainCoroutine () newSelectLasso cvsInfo pnum geometry itms orig (prev,otime) lasso tsel = nextevent >>= flip fsingle cvsInfo    where  -    fsingle r cinfo = penMoveAndUpOnly r pnum geometry defact-                        (moveact cinfo) (upact cinfo)+    fsingle r cinfo = penMoveAndUpOnly r pnum geometry defact (moveact cinfo) (upact cinfo)     defact = newSelectLasso cvsInfo pnum geometry itms orig                 (prev,otime) lasso tsel     moveact cinfo (_pcoord,(x,y)) = do        let nlasso = lasso |> (x,y)       (willUpdate,(ncoord,ntime)) <- liftIO $ getNewCoordTime (prev,otime) (x,y)-      when willUpdate $ do -        invalidateTemp (view canvasId cinfo) (tempSurfaceSrc tsel) (renderLasso geometry nlasso) +      when willUpdate $ invalidateTemp (view canvasId cinfo) (tempSurfaceSrc tsel) (renderLasso geometry nlasso)        newSelectLasso cinfo pnum geometry itms orig (ncoord,ntime) nlasso tsel     upact cinfo pcoord = do -      xstate <- get -      let (_,(x,y)) = runIdentity $ -            skipIfNotInSamePage pnum geometry pcoord -                                (return (pcoord,prev)) return+      uhdl <- view (unitHoodles.currentUnit) <$> get +      let (_,(x,y)) = runIdentity $ skipIfNotInSamePage pnum geometry pcoord (return (pcoord,prev)) return           nlasso = lasso |> (x,y)-          hdlmodst = view hoodleModeState xstate +          hdlmodst = view hoodleModeState uhdl           epage = getCurrentPageEitherFromHoodleModeState cinfo hdlmodst           cpn = view currentPageNum cinfo            hittestlasso1 = hltFilteredBy (hitLassoItem (nlasso |> orig)) itms@@ -530,7 +522,7 @@           selectitms              | (not.null) selecteditms1 = selectitms1              | otherwise = selectitms2-          SelectState thdl = view hoodleModeState xstate+          SelectState thdl = view hoodleModeState uhdl           newpage = case epage of                        Left pagebbox ->                          let currlayer= getCurrentLayer pagebbox@@ -544,11 +536,11 @@                             npage = set (glayers.selectedLayer) newlayer tpage                          in npage           newthdl = set gselSelected (Just (cpn,newpage)) thdl -      let ui = view gtkUIManager xstate+      ui <- view gtkUIManager <$> get       liftIO $ toggleCutCopyDelete ui (isAnyHitted  selectitms)-      put . set hoodleModeState (SelectState newthdl) -            =<< (liftIO (updatePageAll (SelectState newthdl) xstate))-      -- invalidateAll +      uhdl' <- liftIO (updatePageAll (SelectState newthdl) uhdl)+      pureUpdateUhdl (const ((hoodleModeState .~ SelectState newthdl) uhdl'))+      commit_       invalidateAllInBBox Nothing Efficient
src/Hoodle/Coroutine/Select/Clipboard.hs view
@@ -3,9 +3,9 @@ ----------------------------------------------------------------------------- -- | -- Module      : Hoodle.Coroutine.Select.Clipboard --- Copyright   : (c) 2011-2014 Ian-Woo Kim+-- Copyright   : (c) 2011-2015 Ian-Woo Kim ----- License     : GPL-3+-- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com> -- Stability   : experimental -- Portability : GHC@@ -18,14 +18,17 @@  -- from other packages import           Control.Applicative-import           Control.Lens (view,set,(%~))-import           Control.Monad.State -import           Graphics.UI.Gtk hiding (get,set)+import           Control.Lens (view,set,(.~))+import           Control.Monad.State+import           Control.Monad.Trans.Maybe+import qualified Data.Foldable as F+import           Data.Maybe (fromMaybe)+import qualified Graphics.UI.Gtk as Gtk -- from hoodle-platform -import           Control.Monad.Trans.Crtn.Queue  import           Data.Hoodle.Generic  import           Data.Hoodle.Select-import           Data.Hoodle.Simple+import           Data.Hoodle.Simple (Item(..))+import           Graphics.Hoodle.Render import           Graphics.Hoodle.Render.Item import           Graphics.Hoodle.Render.Type  import           Graphics.Hoodle.Render.Type.HitTest@@ -33,22 +36,38 @@ import           Hoodle.Accessor import           Hoodle.Coroutine.Draw import           Hoodle.Coroutine.Commit -import           Hoodle.Coroutine.Mode +import           Hoodle.Coroutine.Mode+import           Hoodle.Coroutine.Page import           Hoodle.ModelAction.Page import           Hoodle.ModelAction.Select import           Hoodle.ModelAction.Select.Transform import           Hoodle.ModelAction.Clipboard+import           Hoodle.Type.Alias import           Hoodle.Type.Canvas  import           Hoodle.Type.Coroutine import           Hoodle.Type.Event  import           Hoodle.Type.PageArrangement  import           Hoodle.Type.HoodleState ++-- |+updateTempHoodleSelectM :: CanvasId+                       -> Hoodle SelectMode +                       -> Page SelectMode +                       -> Int+                       -> MainCoroutine (Hoodle SelectMode)+updateTempHoodleSelectM cid thdl tpage pagenum = do   +  let newpage = hPage2RPage tpage+  callRenderer_ $ updatePageBuf cid newpage+  return (updateTempHoodleSelect thdl tpage pagenum)+   -- | deleteSelection :: MainCoroutine () deleteSelection = do -  xstate <- get-  case view hoodleModeState xstate of+  xst <- get+  let uhdl = view (unitHoodles.currentUnit) xst+      cid = getCurrentCanvasId uhdl+  case view hoodleModeState uhdl of     SelectState thdl -> do        let Just (n,tpage) = view gselSelected thdl           slayer = view (glayers.selectedLayer) tpage@@ -57,14 +76,11 @@         Right alist -> do            let newlayer = Left . concat . getA $ alist               newpage = set (glayers.selectedLayer) (GLayer (view gbuffer slayer) (TEitherAlterHitted newlayer)) tpage -              cache = view renderCache xstate-          newthdl <- liftIO $ updateTempHoodleSelectIO cache thdl newpage n          -          newxstate <- liftIO $ updatePageAll (SelectState newthdl) -                              . set hoodleModeState (SelectState newthdl)-                              $ xstate -          commit newxstate -          let ui = view gtkUIManager newxstate+          newthdl <- updateTempHoodleSelectM cid thdl newpage n+          newuhdl <- liftIO . updatePageAll (SelectState newthdl) $ uhdl +          let ui = view gtkUIManager xst           liftIO $ toggleCutCopyDelete ui False +          commit ((unitHoodles.currentUnit .~ newuhdl) xst)           modeChange ToViewAppendMode            invalidateAll      _ -> return ()@@ -80,53 +96,54 @@ copySelection = do      updateXState copySelectionAction >> invalidateAll    where copySelectionAction xst = -          forBoth' unboxBiAct (fsingle xst) . view currentCanvasInfo $ xst-        fsingle xstate cinfo = maybe (return xstate) id $ do  -          let hdlmodst = view hoodleModeState xstate-          let epage = getCurrentPageEitherFromHoodleModeState cinfo hdlmodst-          eitherMaybe epage `pipe` rItmsInActiveLyr -                            `pipe` (Right . liftIO . updateClipboard xstate . map rItem2Item . takeHitted)+          forBoth' unboxBiAct (fsingle xst) . view (unitHoodles.currentUnit.currentCanvasInfo) $ xst+        fsingle xst cinfo = do+            r <- runMaybeT $ do +              let uhdl = view (unitHoodles.currentUnit) xst+                  hdlmodst = view hoodleModeState uhdl+                  epage = getCurrentPageEitherFromHoodleModeState cinfo hdlmodst+              pg <- (MaybeT . return . eitherMaybe) epage+              hitted <- (MaybeT . return . eitherMaybe) (rItmsInActiveLyr pg)+              (liftIO . updateClipboard xst . map rItem2Item . takeHitted) hitted+            return (fromMaybe xst r)           where eitherMaybe (Left _) = Nothing                 eitherMaybe (Right a) = Just a -                x `pipe` a = x >>= eitherMaybe . a -                infixl 6 `pipe`  -- | getClipFromGtk :: MainCoroutine (Maybe [Item]) getClipFromGtk = do -    let action = mkIOaction $ -                   \evhandler -> do -                       hdltag <- liftIO $ atomNew "hoodle"-                       clipbd <- liftIO $ clipboardGet hdltag-                       liftIO $ clipboardRequestText clipbd (callback4Clip evhandler)-                       return (UsrEv ActionOrdered)-    modify (tempQueue %~ enqueue action) -    go -  where go = do r <- nextevent -                case r of -                  GotClipboardContent cnt' -> return cnt' -                  _ -> go +    doIOaction $ \evhandler -> do +      hdltag <- liftIO $ Gtk.atomNew "hoodle"+      clipbd <- liftIO $ Gtk.clipboardGet hdltag+      liftIO $ Gtk.clipboardRequestText clipbd (callback4Clip evhandler)+      return (UsrEv ActionOrdered)+    waitSomeEvent (\case GotClipboardContent _ -> True; _ -> False ) >>= \(GotClipboardContent cnt') -> return cnt'   -- |  pasteToSelection :: MainCoroutine ()  pasteToSelection = do -    mitms <- getClipFromGtk -    case mitms of -      Nothing -> return () -      Just itms -> do -        -- -        callRenderer $ GotRItems <$> mapM cnstrctRItem itms-        RenderEv (GotRItems ritms) <- -          waitSomeEvent (\case RenderEv (GotRItems _) -> True; _ -> False)-        ---        modeChange ToSelectMode >>updateXState (pasteAction ritms) >> invalidateAll  +    mitms <- getClipFromGtk+    F.forM_ mitms $ \itms -> do+      callRenderer $ GotRItems <$> mapM cnstrctRItem itms+      RenderEv (GotRItems ritms) <- +        waitSomeEvent (\case RenderEv (GotRItems _) -> True; _ -> False)+      xst <- get+      cache <- renderCache +      let ui = view gtkUIManager xst+      modeChange ToSelectMode +      updateUhdl (pasteAction cache ui ritms)+      commit_ +      canvasZoomUpdateAll+      invalidateAll     where -    pasteAction itms xst = forBoth' unboxBiAct (fsimple itms xst) . view currentCanvasInfo $ xst-    fsimple itms xstate cinfo = do -      geometry <- liftIO (getGeometry4CurrCvs xstate)-      let pagenum = view currentPageNum cinfo -          hdlmodst@(SelectState thdl) = view hoodleModeState xstate+    pasteAction cache ui itms uhdl = forBoth' unboxBiAct (fsimple cache ui itms uhdl) +                                     . view currentCanvasInfo $ uhdl+    fsimple _cache ui itms uhdl cinfo = do +      geometry <- liftIO (getGeometry4CurrCvs uhdl)+      let cid = view canvasId cinfo+          pagenum = view currentPageNum cinfo +          hdlmodst@(SelectState thdl) = view hoodleModeState uhdl           nclipitms = adjustItemPosition4Paste geometry (PageNum pagenum) itms           epage = getCurrentPageEitherFromHoodleModeState cinfo hdlmodst            tpage = either mkHPage id epage@@ -139,12 +156,7 @@                             :- Hitted nclipitms                              :- Empty )           tpage' = set (glayers.selectedLayer) newlayerselect tpage-          cache = view renderCache xstate-      thdl' <- liftIO $ updateTempHoodleSelectIO cache thdl tpage' pagenum -      xstate' <- liftIO $ updatePageAll (SelectState thdl') -                 . set hoodleModeState (SelectState thdl') -                 $ xstate -      commit xstate' -      let ui = view gtkUIManager xstate' +      thdl' <- updateTempHoodleSelectM cid thdl tpage' pagenum +      uhdl' <- liftIO $ updatePageAll (SelectState thdl') uhdl       liftIO $ toggleCutCopyDelete ui True-      return xstate' +      return uhdl'
src/Hoodle/Coroutine/Select/ManipulateImage.hs view
@@ -4,9 +4,9 @@ ----------------------------------------------------------------------------- -- | -- Module      : Hoodle.Coroutine.Select.ManipulateImage--- Copyright   : (c) 2013, 2014 Ian-Woo Kim+-- Copyright   : (c) 2013-2015 Ian-Woo Kim ----- License     : GPL-3+-- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com> -- Stability   : experimental -- Portability : GHC@@ -17,7 +17,7 @@  module Hoodle.Coroutine.Select.ManipulateImage where -import           Control.Lens (set, view, _2)+import           Control.Lens (set, view, _2, (.~)) import           Control.Monad (when) import           Control.Monad.State (get) import           Control.Monad.Trans (liftIO)@@ -37,6 +37,7 @@ import           Hoodle.Coroutine.Commit import           Hoodle.Coroutine.Draw import           Hoodle.Coroutine.Pen+import           Hoodle.Coroutine.Select.Clipboard import           Hoodle.Device import           Hoodle.ModelAction.Page import           Hoodle.ModelAction.Pen@@ -55,10 +56,10 @@  cropImage :: BBoxed Image -> MainCoroutine () cropImage imgbbx = do -    liftIO $ putStrLn "cropImage called"     xst <- get-    let (cid,cinfobox) = view currentCanvas xst -        hdlmodst = view hoodleModeState xst+    let uhdl = view (unitHoodles.currentUnit) xst+        (cid,cinfobox) = view currentCanvas uhdl+        hdlmodst = view hoodleModeState uhdl         epage = forBoth' unboxBiAct (flip getCurrentPageEitherFromHoodleModeState hdlmodst) cinfobox     case hdlmodst of        ViewAppendState _ -> return ()@@ -81,7 +82,8 @@               -> MainCoroutine () startCropRect cid imgbbx (thdl,tpage) pcoord0 = do      xst <- get-    geometry <- liftIO $ getGeometry4CurrCvs xst+    let uhdl = view (unitHoodles.currentUnit) xst+    geometry <- liftIO $ getGeometry4CurrCvs uhdl     forM_ ((desktop2Page geometry . device2Desktop geometry) pcoord0) $ \(p0,c0) -> do       tsel <- createTempRender geometry (p0, BBox (unPageCoord c0) (unPageCoord c0))       ctime <- liftIO $ getCurrentTime@@ -91,7 +93,7 @@       let pnum = (fst . tempInfo) tsel           img = bbxed_content imgbbx           obbox = getBBox imgbbx-          cache = view renderCache xst+          cvsid = getCurrentCanvasId uhdl       when (isBBox2InBBox1 obbox nbbox) $ do         mimg' <- liftIO $ createCroppedImage img obbox nbbox          forM_ mimg' $ \img' -> do@@ -101,8 +103,9 @@             waitSomeEvent (\case RenderEv (GotRItem _) -> True; _ -> False)           --           let ntpage = replaceSelection rimg' tpage-          nthdl <- liftIO $ updateTempHoodleSelectIO cache thdl ntpage (unPageNum pnum)-          commit . set hoodleModeState (SelectState nthdl) =<< (liftIO (updatePageAll (SelectState nthdl) xst))+          nthdl <- updateTempHoodleSelectM cvsid thdl ntpage (unPageNum pnum)+          uhdl' <- liftIO (updatePageAll (SelectState nthdl) uhdl)+          commit $ (unitHoodles.currentUnit .~ uhdl') xst         invalidateAllInBBox Nothing Efficient             return ()     @@ -156,11 +159,11 @@ rotateImage :: RotateDir -> BBoxed Image -> MainCoroutine () rotateImage dir imgbbx = do      xst <- get-    let (_cid,cinfobox) = view currentCanvas xst -        hdlmodst = view hoodleModeState xst+    let uhdl = view (unitHoodles.currentUnit) xst+    let (cid,cinfobox) = view currentCanvas uhdl+        hdlmodst = view hoodleModeState uhdl         pnum = (PageNum . forBoth' unboxBiAct (view currentPageNum)) cinfobox                 epage = forBoth' unboxBiAct (flip getCurrentPageEitherFromHoodleModeState hdlmodst) cinfobox-        cache = view renderCache xst     case hdlmodst of        ViewAppendState _ -> return ()       SelectState thdl -> do @@ -170,14 +173,13 @@             let img = bbxed_content imgbbx              mimg' <- liftIO (createRotatedImage dir img (getBBox imgbbx))             forM_ mimg' $ \img' -> do -              --               callRenderer $ return . GotRItem =<< cnstrctRItem (ItemImage img')               RenderEv (GotRItem rimg') <-                  waitSomeEvent (\case RenderEv (GotRItem _) -> True; _ -> False)-              --               let ntpage = replaceSelection rimg' tpage-              nthdl <- liftIO $ updateTempHoodleSelectIO cache thdl ntpage (unPageNum pnum)-              commit . set hoodleModeState (SelectState nthdl) =<< (liftIO (updatePageAll (SelectState nthdl) xst))+              nthdl <- updateTempHoodleSelectM cid thdl ntpage (unPageNum pnum)+              uhdl' <- liftIO (updatePageAll (SelectState nthdl) uhdl)+              commit $ (unitHoodles.currentUnit .~ uhdl') xst             invalidateAllInBBox Nothing Efficient                   return ()
+ src/Hoodle/Coroutine/Socket.hs view
@@ -0,0 +1,141 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}++-----------------------------------------------------------------------------+-- |+-- Module      : Hoodle.Coroutine.Socket+-- Copyright   : (c) 2014, 2015 Ian-Woo Kim+--+-- License     : BSD3+-- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability   : experimental+-- Portability : GHC+--+-----------------------------------------------------------------------------++module Hoodle.Coroutine.Socket where++import           Control.Applicative+import           Control.Concurrent+import qualified Control.Exception as E+import           Control.Lens (view)+import           Control.Monad.IO.Class+import           Control.Monad.State+import           Control.Monad.Trans.Either+import           Control.Monad.Trans.Maybe+import           Data.Aeson.Parser+import           Data.Aeson.Types+import qualified Data.Attoparsec.ByteString as A+import qualified Data.CaseInsensitive as CI+import           Data.Monoid ((<>))+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import           Data.Time.Clock+import qualified Graphics.UI.Gtk as Gtk+import Network.HTTP.Client.Internal (computeCookieString)+import Network.HTTP.Conduit+import qualified Network.WebSockets as WS+import System.Directory+import System.FilePath ((</>))+--+import Hoodle.Coroutine.Dialog+import Hoodle.Coroutine.Hub.Common+import Hoodle.Script.Hook+import Hoodle.Type.Coroutine+import Hoodle.Type.Event+import Hoodle.Type.Hub+import Hoodle.Type.HoodleState+import Hoodle.Type.Synchronization+import Hoodle.Util+--++data Permission = Owner | Editor | Viewer | Stranger deriving (Show,Eq,Ord,Read)++instance ToJSON Permission where+  toJSON Owner    = String "owner"+  toJSON Editor   = String "editor"+  toJSON Viewer   = String "viewer"+  toJSON Stranger = String "stranger"++instance FromJSON Permission where+  parseJSON (String t) =+    case t of+      "owner"    -> return Owner+      "editor"   -> return Editor+      "viewer"   -> return Viewer+      "stranger" -> return Stranger+      _ -> fail "error in parsing Permission"+  parseJSON _ = fail "error in parsing Permission"++data HoodleWSEvent = HWSOpen { hws_permission :: Permission+                             , hws_fileuuid   :: T.Text+                             , hws_filepath   :: T.Text }+                   | HWSSync { hws_clientuuid :: T.Text+                             , hws_filesyncstatus :: FileSyncStatus+                             } +               deriving Show++instance ToJSON HoodleWSEvent where+  toJSON HWSOpen {..} = object [ "eventType"  .= toJSON ("open" :: T.Text)+                               , "permission" .= toJSON hws_permission+                               , "fileuuid"   .= toJSON hws_fileuuid+                               , "filepath"   .= toJSON hws_filepath ]+  toJSON HWSSync {..} = object [ "eventType"  .= toJSON ("sync" :: T.Text)+                               , "clientuuid" .= toJSON hws_clientuuid+                               , "filesyncstatus"   .= toJSON hws_filesyncstatus+                               ]++instance FromJSON HoodleWSEvent where+  parseJSON (Object v) = do+      typ :: T.Text <- v .: "eventType"+      case typ of+        "open" -> HWSOpen <$> v .: "permission" <*> v .: "fileuuid" <*> v .: "filepath" +        "sync" -> HWSSync <$> v .: "clientuuid" <*> v .: "filesyncstatus"+        _ -> fail "error in parsing HoodleWSEvent"+  parseJSON _ = fail "error in parsing HoodleWSEvent"++-- |+socketConnect :: MainCoroutine ()+socketConnect = do+    xst <- get+    r <- runMaybeT $ do +      hset <- (MaybeT . return) $ view hookSet xst+      hinfo <- (MaybeT . return) (hubInfo hset)+      lift (hoodleWSStart hinfo)+    case r of +      Nothing -> okMessageBox "socket connect not successful" >> return ()+      Just _ -> return ()  +++hoodleWSStart :: HubInfo -> MainCoroutine ()+hoodleWSStart hinfo@HubInfo {..} = do+    hdir <- liftIO $ getHomeDirectory+    let tokfile = hdir </> ".hoodle.d" </> "token.txt"+    prepareToken hinfo tokfile +    doIOaction $ \evhandler -> do +      forkIO $ (`E.catch` (\(err:: E.SomeException)-> print err >> return ())) $ +        withHub hinfo tokfile $ \_manager coojar -> do+          request2' <- parseUrl ("http://" <> hubSocketURL <> ":" <> show hubSocketPort </> hubSocketPath)+          ctime <- liftIO getCurrentTime+          let (bstr,_) = computeCookieString request2' coojar ctime True+              newheaders = [(CI.mk "Cookie",bstr)] +          liftIO $ WS.runClientWith hubSocketURL hubSocketPort hubSocketPath WS.defaultConnectionOptions newheaders $ \conn -> forever $ do +            txt <- WS.receiveData conn+            runEitherT $ do+              v <- hoistEither $ A.parseOnly json (TE.encodeUtf8 txt)+              o :: HoodleWSEvent <- hoistEither $ parseEither parseJSON v+              lift $ hoodleWSDispatchEvent evhandler hinfo o +      return (UsrEv ActionOrdered)++hoodleWSDispatchEvent :: (AllEvent -> IO ()) -> HubInfo -> HoodleWSEvent -> IO ()+hoodleWSDispatchEvent evhandler HubInfo {..} HWSOpen {..} = do+    let urlpath = FileUrl (hubFileRoot </> T.unpack hws_filepath)+        uuid = read (T.unpack hws_fileuuid)+    case hws_permission of+      Owner  -> (Gtk.postGUIAsync . evhandler . UsrEv) (OpenLink urlpath Nothing)+      Editor -> (Gtk.postGUIAsync . evhandler . UsrEv) (OpenShared uuid)+      _ -> return ()+hoodleWSDispatchEvent evhandler HubInfo {..} HWSSync {..} = +    let clientuuid = read (T.unpack hws_clientuuid) +    in (Gtk.postGUIAsync . evhandler . UsrEv) (GotSyncEvent False clientuuid hws_filesyncstatus)
src/Hoodle/Coroutine/TextInput.hs view
@@ -1,14 +1,15 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TupleSections #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}  ----------------------------------------------------------------------------- -- | -- Module      : Hoodle.Coroutine.TextInput --- Copyright   : (c) 2011-2014 Ian-Woo Kim+-- Copyright   : (c) 2011-2015 Ian-Woo Kim ----- License     : GPL-3+-- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com> -- Stability   : experimental -- Portability : GHC@@ -18,18 +19,16 @@ module Hoodle.Coroutine.TextInput where  import           Control.Applicative--- import           Control.Concurrent.STM (atomically, newTVar)-import           Control.Lens (_1,_2,_3,view,set,(%~),(^.),(.~))+import qualified Control.Exception+import           Control.Lens (_2,_3,view,(%~),(^.),(.~)) import           Control.Monad.State hiding (mapM_, forM_) import           Control.Monad.Trans.Either import           Control.Monad.Trans.Maybe--- import           Data.Attoparsec-import           Data.Attoparsec.Char8+import           Data.Attoparsec.ByteString.Char8 import qualified Data.ByteString.Char8 as B  import           Data.Foldable (mapM_, forM_) import           Data.List (sortBy)-import qualified Data.Map as M-import           Data.Maybe (catMaybes)+import qualified Data.HashMap.Strict as M import           Data.Monoid ((<>)) import qualified Data.Text as T import qualified Data.Text.Encoding as TE@@ -37,12 +36,14 @@ import           Data.UUID.V4 (nextRandom) import qualified Graphics.Rendering.Cairo as Cairo import qualified Graphics.Rendering.Cairo.SVG as RSVG--- import qualified Graphics.Rendering.Pango.Cairo as Pango import qualified Graphics.UI.Gtk as Gtk import           System.Directory  import           System.Exit (ExitCode(..)) import           System.FilePath  import           System.Process (readProcessWithExitCode)+#ifdef HUB+import           Control.Concurrent (killThread)+#endif --  import           Control.Monad.Trans.Crtn import           Control.Monad.Trans.Crtn.Event @@ -61,8 +62,9 @@ import           Hoodle.Coroutine.Commit import           Hoodle.Coroutine.Dialog import           Hoodle.Coroutine.Draw +import           Hoodle.Coroutine.LaTeX import           Hoodle.Coroutine.Mode-import           Hoodle.Coroutine.Network+import           Hoodle.Coroutine.Page import           Hoodle.Coroutine.Select.Clipboard import           Hoodle.ModelAction.Layer  import           Hoodle.ModelAction.Page@@ -76,44 +78,24 @@ import           Hoodle.Type.HoodleState  import           Hoodle.Type.PageArrangement import           Hoodle.Util+#ifdef HUB+import           Hoodle.Coroutine.Network+#endif --  import Prelude hiding (readFile,mapM_)  --- | single line text input : almost abandoned now-textInputDialog :: MainCoroutine (Maybe String) -textInputDialog = do -  doIOaction $ \_evhandler -> do -                 dialog <- Gtk.messageDialogNew Nothing [Gtk.DialogModal]-                   Gtk.MessageQuestion Gtk.ButtonsOkCancel "text input"-                 vbox <- Gtk.dialogGetUpper dialog-                 txtvw <- Gtk.textViewNew-                 Gtk.boxPackStart vbox txtvw Gtk.PackGrow 0 -                 Gtk.widgetShowAll dialog-                 res <- Gtk.dialogRun dialog -                 case res of -                   Gtk.ResponseOk -> do -                     buf <- Gtk.textViewGetBuffer txtvw -                     (istart,iend) <- (,) <$> Gtk.textBufferGetStartIter buf-                                          <*> Gtk.textBufferGetEndIter buf-                     l <- Gtk.textBufferGetText buf istart iend True-                     Gtk.widgetDestroy dialog-                     return (UsrEv (TextInput (Just l)))-                   _ -> do -                     Gtk.widgetDestroy dialog-                     return (UsrEv (TextInput Nothing))-  let go = do r <- nextevent-              case r of -                TextInput input -> return input -                UpdateCanvas cid -> invalidateInBBox Nothing Efficient cid >> go -                _ -> go -  go - -- | common dialog with multiline edit input box -multiLineDialog :: T.Text -> Either (ActionOrder AllEvent) AllEvent-multiLineDialog str = mkIOaction $ \evhandler -> do+multiLineDialog :: T.Text -> (AllEvent -> IO ()) -> IO AllEvent+multiLineDialog str evhandler = do     dialog <- Gtk.dialogNew+#ifdef GTK3    +    upper <- fmap Gtk.castToContainer (Gtk.dialogGetContentArea dialog)+    vbox <- Gtk.vBoxNew False 0+    Gtk.containerAdd upper vbox+#else      vbox <- Gtk.dialogGetUpper dialog+#endif     textbuf <- Gtk.textBufferNew Nothing     Gtk.textBufferSetByteString textbuf (TE.encodeUtf8 str)     textbuf `Gtk.on` Gtk.bufferChanged $ do @@ -125,7 +107,7 @@     hscrbar <- Gtk.hScrollbarNew =<< Gtk.textViewGetHadjustment textarea      textarea `Gtk.on` Gtk.sizeRequest $ return (Gtk.Requisition 500 600)     fdesc <- Gtk.fontDescriptionNew-    Gtk.fontDescriptionSetFamily fdesc "Mono"+    Gtk.fontDescriptionSetFamily fdesc ("Mono" :: String)     Gtk.widgetModifyFont textarea (Just fdesc)     --      table <- Gtk.tableNew 2 2 False@@ -134,16 +116,20 @@     Gtk.tableAttachDefaults table hscrbar 0 1 1 2      Gtk.boxPackStart vbox table Gtk.PackNatural 0     -- -    _btnOk <- Gtk.dialogAddButton dialog "Ok" Gtk.ResponseOk-    _btnCancel <- Gtk.dialogAddButton dialog "Cancel" Gtk.ResponseCancel-    _btnNetwork <- Gtk.dialogAddButton dialog "Network" (Gtk.ResponseUser 1)+    _btnOk <- Gtk.dialogAddButton dialog ("Ok" :: String) Gtk.ResponseOk+    _btnCancel <- Gtk.dialogAddButton dialog ("Cancel" :: String) Gtk.ResponseCancel+#ifdef HUB+    _btnNetwork <- Gtk.dialogAddButton dialog ("Network" :: String) (Gtk.ResponseUser 1)+#endif     Gtk.widgetShowAll dialog     res <- Gtk.dialogRun dialog     Gtk.widgetDestroy dialog     case res of        Gtk.ResponseOk -> return (UsrEv (OkCancel True))       Gtk.ResponseCancel -> return (UsrEv (OkCancel False))+#ifdef HUB       Gtk.ResponseUser 1 -> return (UsrEv (NetworkProcess NetworkDialog))+#endif       _ -> return (UsrEv (OkCancel False))  -- | main event loop for multiline edit box@@ -155,7 +141,9 @@                           >> multiLineLoop txt       OkCancel True -> (return . Just) txt       OkCancel False -> return Nothing+#ifdef HUB       NetworkProcess NetworkDialog -> networkTextInput txt+#endif       MultiLine (MultiLineChanged txt') -> multiLineLoop txt'       _ -> multiLineLoop txt @@ -164,21 +152,21 @@ textInput mpos str = do      case mpos of        Just (x0,y0) -> do -        modify (tempQueue %~ enqueue (multiLineDialog str))  +        doIOaction (multiLineDialog str)         multiLineLoop str >>=            mapM_ (\result -> deleteSelection                             >> liftIO (makePangoTextSVG (x0,y0) result)                              >>= svgInsert (result,"pango"))-      Nothing -> liftIO $ putStrLn "textInput: not implemented"+      Nothing -> msgShout "textInput: not implemented"    -- | insert latex laTeXInput :: Maybe (Double,Double) -> T.Text -> MainCoroutine () laTeXInput mpos str = do      case mpos of        Just (x0,y0) -> do -        modify (tempQueue %~ enqueue (multiLineDialog str))  +        doIOaction (multiLineDialog str)         multiLineLoop str >>= -          mapM_ (\result -> liftIO (makeLaTeXSVG (x0,y0) result) >>= \case +          mapM_ (\result -> liftIO (makeLaTeXSVG (x0,y0) Nothing result) >>= \case                    Right r -> deleteSelection >> svgInsert (result,"latex") r                   Left err -> okMessageBox err >> laTeXInput mpos result                 )@@ -216,12 +204,13 @@   -- | +#ifdef HUB laTeXInputNetwork :: Maybe (Double,Double) -> T.Text -> MainCoroutine () laTeXInputNetwork mpos str =       case mpos of        Just (x0,y0) -> do          networkTextInput str >>=-          mapM_ (\result -> liftIO (makeLaTeXSVG (x0,y0) result) +          mapM_ (\result -> liftIO (makeLaTeXSVG (x0,y0) Nothing result)                              >>= \case Right r -> deleteSelection >> svgInsert (result,"latex") r                                       Left err -> okMessageBox err >> laTeXInput mpos result                 )@@ -230,41 +219,38 @@         autoPosText >>=           maybe (laTeXInputNetwork (Just (100,100)) str)                  (\y'->laTeXInputNetwork (Just (100,y')) str) -+#endif  dbusNetworkInput :: T.Text -> MainCoroutine () dbusNetworkInput txt = do      modeChange ToViewAppendMode          mpos <- autoPosText      let pos = maybe (100,100) (100,) mpos -    rsvg <- liftIO (makeLaTeXSVG pos txt) +    rsvg <- liftIO (makeLaTeXSVG pos Nothing txt)      case rsvg of        Right r -> deleteSelection >> svgInsert (txt,"latex") r       Left err -> okMessageBox err >> laTeXInput (Just pos) txt  -laTeXHeader :: T.Text-laTeXHeader = "\\documentclass{article}\n\-              \\\pagestyle{empty}\n\-              \\\begin{document}\n"-                                -laTeXFooter :: T.Text-laTeXFooter = "\\end{document}\n"+check :: String -> IO (ExitCode,String) -> EitherT String IO ()+check msg act = do+    er <- liftIO $ Control.Exception.try act+    case er of +      Left (Control.Exception.SomeException excp) -> left (show excp)+      Right (ecode,str) -> case ecode of ExitSuccess -> right () ; _ -> left (msg ++ ":" ++ str) -makeLaTeXSVG :: (Double,Double) -> T.Text ++makeLaTeXSVG :: (Double,Double) -> Maybe Dimension -> T.Text               -> IO (Either String (B.ByteString,BBox))-makeLaTeXSVG (x0,y0) txt = do+makeLaTeXSVG (x0,y0) mdim txt = do     cdir <- getCurrentDirectory     tdir <- getTemporaryDirectory     tfilename <- show <$> nextRandom-         setCurrentDirectory tdir-    let check msg act = liftIO act >>= \(ecode,str) -> case ecode of ExitSuccess -> right () ; _ -> left (msg ++ ":" ++ str)-             B.writeFile (tfilename <.> "tex") (TE.encodeUtf8 txt)     r <- runEitherT $ do        check "error during xelatex" $ do -        (ecode,ostr,estr) <- readProcessWithExitCode "xelatex" [tfilename <.> "tex"] ""+        (ecode,ostr,estr) <- readProcessWithExitCode "xelatex" ["-shell-escape", tfilename <.> "tex"] ""         return (ecode,ostr++estr)       check "error during pdfcrop" $ do          (ecode,ostr,estr) <- readProcessWithExitCode "pdfcrop" [tfilename <.> "pdf",tfilename ++ "_crop" <.> "pdf"] ""       @@ -274,8 +260,13 @@         return (ecode,ostr++estr)       bstr <- liftIO $ B.readFile (tfilename <.> "svg")       rsvg <- liftIO $ RSVG.svgNewFromString (B.unpack bstr) -      let (w,h) = RSVG.svgGetSize rsvg-      return (bstr,BBox (x0,y0) (x0+fromIntegral w,y0+fromIntegral h)) +      let ow, oh :: Int+          (ow,oh) = RSVG.svgGetSize rsvg+          ow', oh' :: Double+          (ow',oh') = (fromIntegral ow, fromIntegral oh)+          w, h :: Double+          (w,h) = maybe (ow',oh') (\(Dim w' _)->(w',oh'*w'/ow')) mdim +      return (bstr,BBox (x0,y0) (x0+w,y0+h))      setCurrentDirectory cdir     return r     @@ -283,9 +274,11 @@ -- | svgInsert :: (T.Text,String) -> (B.ByteString,BBox) -> MainCoroutine ()  svgInsert (txt,cmd) (svgbstr,BBox (x0,y0) (x1,y1)) = do -    xstate <- get -    let pgnum = view (unboxLens currentPageNum) . view currentCanvasInfo $ xstate-        hdl = getHoodle xstate +    xst <- get +    let uhdl = view (unitHoodles.currentUnit) xst+        cid = getCurrentCanvasId uhdl+        pgnum = view (unboxLens currentPageNum) . view currentCanvasInfo $ uhdl+        hdl = getHoodle uhdl         currpage = getPageFromGHoodleMap pgnum hdl         currlayer = getCurrentLayer currpage     --@@ -298,15 +291,15 @@     let otheritems = view gitems currlayer       let ntpg = makePageSelectMode currpage                   (otheritems :- (Hitted [newitem]) :- Empty)  -        cache = view renderCache xstate     modeChange ToSelectMode -    nxstate <- get -    thdl <- case view hoodleModeState nxstate of-              SelectState thdl' -> return thdl'-              _ -> (lift . EitherT . return . Left . Other) "svgInsert"-    nthdl <- liftIO $ updateTempHoodleSelectIO cache thdl ntpg pgnum -    put (set hoodleModeState (SelectState nthdl) nxstate)+    updateUhdl $ \nuhdl -> do+      thdl <- case view hoodleModeState nuhdl of+                SelectState thdl' -> return thdl'+                _ -> (lift . EitherT . return . Left . Other) "svgInsert"+      nthdl <- updateTempHoodleSelectM cid thdl ntpg pgnum +      return $ (hoodleModeState .~ SelectState nthdl) nuhdl     commit_+    canvasZoomUpdateAll     invalidateAll     -- |     @@ -336,8 +329,9 @@               -> (B.ByteString,BBox)                -> MainCoroutine () linkInsert _typ (uuidbstr,fname) str (svgbstr,BBox (x0,y0) (x1,y1)) = do -    xstate <- get -    let pgnum = view (currentCanvasInfo . unboxLens currentPageNum) xstate +    xst <- get +    let uhdl = view (unitHoodles.currentUnit) xst +    let pgnum = view (currentCanvasInfo . unboxLens currentPageNum) uhdl         lnk = Link uuidbstr "simple" (B.pack fname) (Just (B.pack str)) Nothing svgbstr                    (x0,y0) (Dim (x1-x0) (y1-y0))     nlnk <- liftIO $ convertLinkFromSimpleToDocID lnk >>= maybe (return lnk) return@@ -389,31 +383,12 @@ -- | combine all LaTeX texts into a text file  combineLaTeXText :: MainCoroutine () combineLaTeXText = do-    hdl <- rHoodle2Hoodle . getHoodle <$> get  -    let mlatex_components = do -          (pgnum,pg) <- (zip ([1..] :: [Int]) . view pages) hdl  -          l <- view layers pg-          i <- view items l-          case i of -            ItemSVG svg ->  -              case svg_command svg of-                Just "latex" -> do -                  let (_,y) = svg_pos svg  -                  return ((pgnum,y,) <$> svg_text svg) -                _ -> []-            _ -> []-    let cfunc :: (Ord a,Ord b,Ord c) => (a,b,c) -> (a,b,c) -> Ordering -        cfunc x y | view _1 x > view _1 y = GT-                  | view _1 x < view _1 y = LT-                  | otherwise = if | view _2 x > view _2 y -> GT-                                   | view _2 x < view _2 y -> LT-                                   | otherwise -> EQ-    let latex_components = catMaybes  mlatex_components-        sorted = sortBy cfunc latex_components -        resulttxt = (B.intercalate "%%%%%%%%%%%%\n\n%%%%%%%%%%\n" . map (view _3)) sorted+    hdl <- rHoodle2Hoodle . getHoodle . view (unitHoodles.currentUnit) <$> get  +    let sorted = getLaTeXComponentsFromHdl hdl+   +        resulttxt = (T.intercalate "%%%%%%%%%%%%\n\n%%%%%%%%%%\n" . map (view (_2._3))) sorted     mfilename <- fileChooser Gtk.FileChooserActionSave Nothing-    forM_ mfilename (\filename -> liftIO (B.writeFile filename resulttxt) >> return ())-+    forM_ mfilename (\filename -> liftIO (TIO.writeFile filename resulttxt) >> return ())   insertItemAt :: Maybe (PageNum,PageCoordinate) @@ -421,11 +396,13 @@                 -> MainCoroutine ()  insertItemAt mpcoord ritm = do      xst <- get   -    geometry <- liftIO (getGeometry4CurrCvs xst) -    let hdl = getHoodle xst +    let uhdl = view (unitHoodles.currentUnit) xst+    geometry <- liftIO (getGeometry4CurrCvs uhdl) +    let cid = getCurrentCanvasId uhdl+        hdl = getHoodle uhdl         (pgnum,mpos) = case mpcoord of            Just (PageNum n,pos) -> (n,Just pos)-          Nothing -> (view (currentCanvasInfo . unboxLens currentPageNum) xst,Nothing)+          Nothing -> (view (currentCanvasInfo . unboxLens currentPageNum) uhdl,Nothing)         (ulx,uly) = (bbox_upperleft.getBBox) ritm         nitms =            case mpos of @@ -438,14 +415,15 @@         oitms = view gitems lyr           ntpg = makePageSelectMode pg (oitms :- (Hitted nitms) :- Empty)       modeChange ToSelectMode -    nxst <- get -    let cache = view renderCache nxst-    thdl <- case view hoodleModeState nxst of-      SelectState thdl' -> return thdl'-      _ -> (lift . EitherT . return . Left . Other) "insertItemAt"-    nthdl <- liftIO $ updateTempHoodleSelectIO cache thdl ntpg pgnum -    put ( ( set hoodleModeState (SelectState nthdl) -          . set isOneTimeSelectMode YesAfterSelect) nxst)+    updateUhdl $ \uhdl' -> do +      thdl <- case view hoodleModeState uhdl' of+        SelectState thdl' -> return thdl'+        _ -> (lift . EitherT . return . Left . Other) "insertItemAt"+      nthdl <- updateTempHoodleSelectM cid thdl ntpg pgnum +      return . (hoodleModeState .~ SelectState nthdl)+             . (isOneTimeSelectMode .~ YesAfterSelect) $ uhdl' +    commit_+    canvasZoomUpdateAll     invalidateAll    embedTextSource :: MainCoroutine ()@@ -453,53 +431,59 @@     mfilename <- fileChooser Gtk.FileChooserActionOpen Nothing     forM_ mfilename $ \filename -> do        txt <- liftIO $ TIO.readFile filename-      xst <- get-      let nhdlmodst = case xst ^. hoodleModeState of-            ViewAppendState hdl -> (ViewAppendState . (gembeddedtext .~ Just txt) $ hdl)-            SelectState thdl    -> (SelectState     . (gselEmbeddedText .~ Just txt) $ thdl)-          nxst = (hoodleModeState .~ nhdlmodst) xst-      put nxst+      pureUpdateUhdl $ \uhdl ->+        let nhdlmodst = case uhdl ^. hoodleModeState of+              ViewAppendState hdl -> (ViewAppendState . (gembeddedtext .~ Just txt) $ hdl)+              SelectState thdl    -> (SelectState     . (gselEmbeddedText .~ Just txt) $ thdl)+        in (hoodleModeState .~ nhdlmodst) uhdl       commit_   -- | editEmbeddedTextSource :: MainCoroutine () editEmbeddedTextSource = do -    hdl <- getHoodle <$> get+    hdl <- getHoodle . view (unitHoodles.currentUnit) <$> get     let mtxt = hdl ^. gembeddedtext      forM_ mtxt $ \txt -> do -      modify (tempQueue %~ enqueue (multiLineDialog txt))  +      doIOaction (multiLineDialog txt)       multiLineLoop txt >>= \case          Nothing -> return ()         Just ntxt -> do -          modify $ \xst ->-            let nhdlmodst = case xst ^. hoodleModeState of-                  ViewAppendState hdl -> (ViewAppendState . (gembeddedtext .~ Just ntxt) $ hdl)+          pureUpdateUhdl $ \uhdl ->+            let nhdlmodst = case uhdl ^. hoodleModeState of+                  ViewAppendState hdl' -> (ViewAppendState . (gembeddedtext .~ Just ntxt) $ hdl')                   SelectState thdl    -> (SelectState     . (gselEmbeddedText .~ Just ntxt) $ thdl)-            in (hoodleModeState .~ nhdlmodst) xst+            in (hoodleModeState .~ nhdlmodst) uhdl           commit_ + -- |+#ifdef HUB editNetEmbeddedTextSource :: MainCoroutine () editNetEmbeddedTextSource = do -    hdl <- getHoodle <$> get+    hdl <- getHoodle . view (unitHoodles.currentUnit) <$> get     let mtxt = hdl ^. gembeddedtext      forM_ mtxt $ \txt -> do -      -- modify (tempQueue %~ enqueue (multiLineDialog txt))         networkTextInput txt >>= \case          Nothing -> return ()-        Just ntxt -> do -          modify $ \xst ->-            let nhdlmodst = case xst ^. hoodleModeState of-                  ViewAppendState hdl -> (ViewAppendState . (gembeddedtext .~ Just ntxt) $ hdl)-                  SelectState thdl    -> (SelectState     . (gselEmbeddedText .~ Just ntxt) $ thdl)-            in (hoodleModeState .~ nhdlmodst) xst-          commit_+        Just ntxt -> networkReceived ntxt+#endif +#ifdef HUB+networkReceived :: T.Text -> MainCoroutine ()+networkReceived txt = do+    pureUpdateUhdl $ \uhdl -> +      let nhdlmodst = case uhdl ^. hoodleModeState of+            ViewAppendState hdl -> (ViewAppendState . (gembeddedtext .~ Just txt) $ hdl)+            SelectState thdl    -> (SelectState     . (gselEmbeddedText .~ Just txt) $ thdl)+      in (hoodleModeState .~ nhdlmodst) uhdl+    commit_+#endif+ -- | insert text  textInputFromSource :: (Double,Double) -> MainCoroutine () textInputFromSource (x0,y0) = do     runMaybeT $ do -      txtsrc <- MaybeT $ (^. gembeddedtext) . getHoodle <$> get+      txtsrc <- MaybeT $ (^. gembeddedtext) . getHoodle . view (unitHoodles.currentUnit) <$> get       lift $ modify (tempQueue %~ enqueue linePosDialog)         (l1,l2) <- MaybeT linePosLoop       let txt = getLinesFromText (l1,l2) txtsrc@@ -510,23 +494,29 @@  -- | common dialog with line position  linePosDialog :: Either (ActionOrder AllEvent) AllEvent-linePosDialog = mkIOaction $ \evhandler -> do+linePosDialog = mkIOaction $ \_evhandler -> do     dialog <- Gtk.dialogNew+#ifdef GTK3+    upper <- fmap Gtk.castToContainer (Gtk.dialogGetContentArea dialog)+    vbox <- Gtk.vBoxNew False 0 +    Gtk.containerAdd upper vbox+#else      vbox <- Gtk.dialogGetUpper dialog+#endif      hbox <- Gtk.hBoxNew False 0     Gtk.boxPackStart vbox hbox Gtk.PackNatural 0 -    line1buf <- Gtk.entryBufferNew Nothing+    line1buf <- Gtk.entryBufferNew (Nothing :: Maybe String)     line1 <- Gtk.entryNewWithBuffer line1buf     Gtk.boxPackStart hbox line1 Gtk.PackNatural 2 -    line2buf <- Gtk.entryBufferNew Nothing+    line2buf <- Gtk.entryBufferNew (Nothing :: Maybe String)     line2 <- Gtk.entryNewWithBuffer line2buf     Gtk.boxPackStart hbox line2 Gtk.PackNatural 2     -- -    _btnOk <- Gtk.dialogAddButton dialog "Ok" Gtk.ResponseOk-    _btnCancel <- Gtk.dialogAddButton dialog "Cancel" Gtk.ResponseCancel+    _btnOk <- Gtk.dialogAddButton dialog ("Ok" :: String) Gtk.ResponseOk+    _btnCancel <- Gtk.dialogAddButton dialog ("Cancel" :: String) Gtk.ResponseCancel     Gtk.widgetShowAll dialog     res <- Gtk.dialogRun dialog     Gtk.widgetDestroy dialog@@ -551,57 +541,59 @@       _ -> linePosLoop  -- | insert text -laTeXInputKeyword :: (Double,Double) -> T.Text -> MaybeT MainCoroutine ()-laTeXInputKeyword (x0,y0) keyword = do-    txtsrc <- MaybeT $ (^. gembeddedtext) . getHoodle <$> get+laTeXInputKeyword :: (Double,Double) -> Maybe Dimension -> T.Text +                  -> MaybeT MainCoroutine ()+laTeXInputKeyword (x0,y0) mdim keyword = do+    txtsrc <- MaybeT $ (^. gembeddedtext) . getHoodle . view (unitHoodles.currentUnit) <$> get     subpart <- (MaybeT . return . M.lookup keyword . getKeywordMap) txtsrc     let subpart' = laTeXHeader <> "\n"  <> subpart <> laTeXFooter-    liftIO (makeLaTeXSVG (x0,y0) subpart') >>= \case+    liftIO (makeLaTeXSVG (x0,y0) mdim subpart') >>= \case       Right r  -> lift $ do                      deleteSelection                      svgInsert ("embedlatex:keyword:"<>keyword,"latex") r       Left err -> lift $ do-                    okMessageBox err+                    longTextMessageBox err+                    -- okMessageBox err                     return () --- | insert text +-- |  laTeXInputFromSource :: (Double,Double) -> MainCoroutine () laTeXInputFromSource (x0,y0) = do     runMaybeT $ do -      txtsrc <- MaybeT $ (^. gembeddedtext) . getHoodle <$> get-      lift $ modify (tempQueue %~ enqueue keywordDialog)  -      keyword <- MaybeT keywordLoop-      laTeXInputKeyword (x0,y0) keyword+      txtsrc <- MaybeT $ (^. gembeddedtext) . getHoodle . view (unitHoodles.currentUnit) <$> get+      let keylst = (map fst . M.toList . getKeywordMap) txtsrc+      when ((not.null) keylst) $ do +        keyword <- MaybeT (keywordDialog keylst)+        laTeXInputKeyword (x0,y0) Nothing keyword     return ()---- | common dialog with line position -keywordDialog :: Either (ActionOrder AllEvent) AllEvent-keywordDialog = mkIOaction $ \evhandler -> do-    dialog <- Gtk.dialogNew-    vbox <- Gtk.dialogGetUpper dialog-    hbox <- Gtk.hBoxNew False 0-    Gtk.boxPackStart vbox hbox Gtk.PackNatural 0-    keybuf <- Gtk.entryBufferNew Nothing-    key <- Gtk.entryNewWithBuffer keybuf-    Gtk.boxPackStart hbox key Gtk.PackNatural 2-    -- -    _btnOk <- Gtk.dialogAddButton dialog "Ok" Gtk.ResponseOk-    _btnCancel <- Gtk.dialogAddButton dialog "Cancel" Gtk.ResponseCancel-    Gtk.widgetShowAll dialog-    res <- Gtk.dialogRun dialog-    Gtk.widgetDestroy dialog-    case res of -      Gtk.ResponseOk -> do-        keystr <- T.pack <$> Gtk.get keybuf Gtk.entryBufferText-        (return . UsrEv . Keyword . Just) keystr-      Gtk.ResponseCancel -> return (UsrEv (Keyword Nothing))-      _ -> return (UsrEv (Keyword Nothing))+    +-- | +#ifdef HUB+toggleNetworkEditSource :: MainCoroutine ()+toggleNetworkEditSource = do +    xst <- get+    let uhdl = view (unitHoodles.currentUnit) xst+        hdl = getHoodle uhdl+        mtxt = hdl ^. gembeddedtext+    b <- updateFlagFromToggleUI "TOGGLENETSRCA" (settings.doesUseXInput)+    forM_ (xst ^. statusBar) $ \stbar -> +      if b +        then do+          (ip,tid,_done) <- networkTextInputBody (maybe " " id mtxt)+          doIOaction_ $ do+            let msg = ("networkedit " ++ ip ++ " 4040")+            ctxt <- Gtk.statusbarGetContextId stbar ("networkedit" :: String)+            Gtk.statusbarPush stbar ctxt msg+          (put . ((settings.networkEditSourceInfo) .~ (Just tid))) xst+        else do+          case xst ^. (settings.networkEditSourceInfo) of+            Nothing -> return ()+            Just tid -> do+              doIOaction_ $ do+                killThread tid+                ctxt <- Gtk.statusbarGetContextId stbar ("networkedit" :: String)+                Gtk.statusbarPush stbar ctxt ("Now no networkedit" :: String)+              (put . ((settings.networkEditSourceInfo) .~ Nothing)) xst+#endif+       --- | main event loop for line position dialog-keywordLoop :: MainCoroutine (Maybe T.Text)-keywordLoop = do -    r <- nextevent-    case r of -      UpdateCanvas cid -> invalidateInBBox Nothing Efficient cid >> keywordLoop-      Keyword x -> return x-      _ -> keywordLoop
src/Hoodle/Coroutine/VerticalSpace.hs view
@@ -1,9 +1,11 @@+{-# LANGUAGE CPP #-}+ ----------------------------------------------------------------------------- -- | -- Module      : Hoodle.Coroutine.VerticalSpace--- Copyright   : (c) 2013, 2014 Ian-Woo Kim+-- Copyright   : (c) 2013-2015 Ian-Woo Kim ----- License     : GPL-3+-- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com> -- Stability   : experimental -- Portability : GHC@@ -14,7 +16,7 @@  import           Control.Applicative import           Control.Category-import           Control.Lens (view,set,at)+import           Control.Lens (view,set,at,(.~)) import           Control.Monad hiding (mapM_) import           Control.Monad.State (get) import           Control.Monad.Trans (liftIO)@@ -22,16 +24,15 @@ import           Data.Monoid import           Data.Time.Clock import qualified Graphics.Rendering.Cairo as Cairo-import           Graphics.UI.Gtk hiding (get,set) +import qualified Graphics.UI.Gtk as Gtk -- from hoodle-platform import           Data.Hoodle.BBox import           Data.Hoodle.Generic import           Data.Hoodle.Simple (Dimension(..)) import           Data.Hoodle.Zipper (SeqZipper,toSeq)  import           Graphics.Hoodle.Render+import           Graphics.Hoodle.Render.Type import           Graphics.Hoodle.Render.Type.HitTest-import           Graphics.Hoodle.Render.Type.Hoodle-import           Graphics.Hoodle.Render.Type.Item  import           Graphics.Hoodle.Render.Util.HitTest -- from this package import           Hoodle.Accessor@@ -52,6 +53,7 @@ import           Hoodle.Type.Predefined  import           Hoodle.View.Coordinate import           Hoodle.View.Draw+import           Hoodle.Util -- import Prelude hiding ((.), id, concat,concatMap,mapM_) @@ -73,12 +75,12 @@     bboxabove (BBox (_,y0) _) = y0 > y   -- |-verticalSpaceStart :: CanvasId -> PointerCoord -> MainCoroutine () -verticalSpaceStart cid = commonPenStart verticalSpaceAction cid  +verticalSpaceStart :: CanvasId -> PointerCoord -> MainCoroutine ()+verticalSpaceStart cid = commonPenStart verticalSpaceAction cid >=> const (return ())   where -    verticalSpaceAction _cinfo pnum@(PageNum n) geometry (x,y) = do -      hdl <- liftM getHoodle get -      cache <- view renderCache <$> get+    verticalSpaceAction _cinfo pnum@(PageNum n) geometry (x,y) _ = do +      hdl <- getHoodle . view (unitHoodles.currentUnit) <$> get +      cache <- renderCache       cpg <- getCurrentPageCurr        let (itms,npg,hltedLayers) = splitPageByHLine y cpg            nhdl = set (gpages.at n) (Just npg) hdl @@ -86,7 +88,7 @@       case mbbx of         Nothing -> return ()            Just bbx -> do -          (sfcbkg,Dim w h) <- liftIO $ canvasImageSurface cache Nothing geometry nhdl +          (sfcbkg,Dim w h) <- liftIO $ canvasImageSurface cache cid Nothing geometry nhdl            sfcitm <- liftIO $ Cairo.createImageSurface                                 Cairo.FormatARGB32 (floor w) (floor h)           sfctot <- liftIO $ Cairo.createImageSurface @@ -94,7 +96,7 @@           liftIO $ Cairo.renderWith sfcitm $ do              Cairo.identityMatrix              cairoXform4PageCoordinate (mkXform4Page geometry pnum)-            mapM_ (renderRItem cache) itms+            mapM_ (renderRItem cache cid) itms           ctime <- liftIO getCurrentTime            verticalSpaceProcess cid geometry (bbx,hltedLayers,pnum,cpg) (x,y)              (sfcbkg,sfcitm,sfctot) ctime @@ -103,31 +105,30 @@ -- | addNewPageAndMoveBelow :: (PageNum,SeqZipper RItemHitted,BBox)                            -> MainCoroutine () -addNewPageAndMoveBelow (pnum,hltedLyrs,bbx) = -    updateXState npgBfrAct -    >> commit_ -    >> canvasZoomUpdateAll >> invalidateAll+addNewPageAndMoveBelow (pnum,hltedLyrs,bbx) = do+    bsty <- view backgroundStyle <$> get+    updateUhdl (npgact bsty) >> commit_  >> canvasZoomUpdateAll >> invalidateAll   where-    npgBfrAct xst = forBoth' unboxBiAct (fsimple xst) . view currentCanvasInfo $ xst-    fsimple :: HoodleState -> CanvasInfo a -> MainCoroutine HoodleState-    fsimple xstate _cinfo = do -      case view hoodleModeState xstate of +    npgact :: BackgroundStyle -> UnitHoodle -> MainCoroutine UnitHoodle+    npgact bsty uhdl = do +      case view hoodleModeState uhdl of          ViewAppendState hdl -> do -          let bsty = view backgroundStyle xstate -          hdl' <- addNewPageInHoodle bsty PageAfter hdl (unPageNum pnum)-          let hdl'' = moveBelowToNewPage (pnum,hltedLyrs,bbx) hdl' -              nhdlmodst = ViewAppendState hdl''-          return =<< liftIO . updatePageAll nhdlmodst-                     . set hoodleModeState nhdlmodst $ xstate +          hdl' <- addNewPageInHoodle Nothing bsty PageAfter hdl (unPageNum pnum)+          sfcid <- issueSurfaceID+          sfcid2 <- issueSurfaceID+          let nhdlmodst = ViewAppendState (moveBelowToNewPage (sfcid,sfcid2) (pnum,hltedLyrs,bbx) hdl') +          liftIO . updatePageAll nhdlmodst . (hoodleModeState .~ nhdlmodst) $ uhdl         SelectState _ -> do -          liftIO $ putStrLn " not implemented yet"-          return xstate+          msgShout "addNewPageAndMoveBelow: not implemented yet"+          return uhdl              -- |             -moveBelowToNewPage :: (PageNum,SeqZipper RItemHitted,BBox) -                      -> Hoodle EditMode-                      -> Hoodle EditMode-moveBelowToNewPage (PageNum n,hltedLayers,BBox (_,y0) _) hdl = +moveBelowToNewPage :: (SurfaceID,SurfaceID)   +                      -- ^ sfcid: old page, sfcid2: new page+                   -> (PageNum,SeqZipper RItemHitted,BBox) +                   -> Hoodle EditMode+                   -> Hoodle EditMode+moveBelowToNewPage (sfcid,sfcid2) (PageNum n,hltedLayers,BBox (_,y0) _) hdl =      let mpg = view (gpages.at n) hdl          mpg2 = view (gpages.at (n+1)) hdl      in case (,) <$> mpg <*> mpg2 of    @@ -137,15 +138,14 @@               fmap (fmapAL id                       (fmap (changeItemBy (\(x',y')->(x',y'+10-y0)))))                    hltedLayers-            nlyrs = fmap ((\x -> set gitems x emptyRLayer) +            nlyrs = fmap ((\x -> set gitems x (emptyRLayer sfcid))                            . concatMap unNotHitted                            . getA ) nhlyrs              npg = set glayers nlyrs pg -            nnlyrs = fmap ((\x -> set gitems x emptyRLayer)+            nnlyrs = fmap ((\x -> set gitems x (emptyRLayer sfcid2))                           . concatMap unHitted                           . getB ) nhlyrs             npg2 = set glayers nnlyrs pg2-                         nhdl = ( set (gpages.at (n+1)) (Just npg2)                    . set (gpages.at n) (Just npg) ) hdl          in nhdl @@ -163,18 +163,15 @@ verticalSpaceProcess cid geometry pinfo@(bbx,hltedLayers,pnum@(PageNum n),pg)                       (x0,y0) sfcs@(sfcbkg,sfcitm,sfctot) otime = do      r <- nextevent -    xst <- get-    forBoth' unboxBiAct (f r xst) . getCanvasInfo cid $ xst +    uhdl <- view (unitHoodles.currentUnit) <$> get+    forBoth' unboxBiAct (f r) . getCanvasInfo cid $ uhdl   where      Dim w h = view gdimension pg         CvsCoord (_,y0_cvs) = (desktop2Canvas geometry . page2Desktop geometry) (pnum,PageCoord (x0,y0))     --------------------------------------------------------------    f :: UserEvent -> HoodleState -> CanvasInfo a -> MainCoroutine ()-    f r xstate cvsInfo = penMoveAndUpOnly r pnum geometry defact -                           (moveact xstate cvsInfo) upact-    -------------------------------------------------------------  +    f :: UserEvent -> CanvasInfo a -> MainCoroutine ()+    f r cvsInfo = penMoveAndUpOnly r pnum geometry defact (moveact cvsInfo) upact     defact = verticalSpaceProcess cid geometry pinfo (x0,y0) sfcs otime-    -------------------------------------------------------------         upact pcoord = do        let mpgcoord = (desktop2Page geometry . device2Desktop geometry) pcoord       case mpgcoord of @@ -187,25 +184,24 @@             let BBox _ (_,by1) = bbx             if by1 + y - y0 < h                then do -                xst <- get -                let hdl = getHoodle xst -                let nhlyrs = -                      fmap (fmapAL id -                            (fmap (changeItemBy (\(x',y')->(x',y'+y-y0)))))-                                  hltedLayers-                    nlyrs = fmap -                              ((\is -> set gitems is emptyRLayer) -                                      . concat-                                      . interleave unNotHitted unHitted) -                              nhlyrs -                    npg = set glayers nlyrs pg -                    nhdl = set (gpages.at n) (Just npg) hdl -                commit (set hoodleModeState (ViewAppendState nhdl) xst)+                sfcid <- issueSurfaceID+                pureUpdateUhdl $ \uhdl -> do+                  let hdl = getHoodle uhdl+                      nhlyrs = fmap (fmapAL id (fmap (changeItemBy (\(x',y')->(x',y'+y-y0))))) hltedLayers+                      nlyrs = fmap ( (\is -> set gitems is (emptyRLayer sfcid)) +                                     . concat . interleave unNotHitted unHitted ) +                                nhlyrs +                      npg = set glayers nlyrs pg +                      nhdl = set (gpages.at n) (Just npg) hdl +                      nhdlmodst = ViewAppendState nhdl+                      nuhdl = (hoodleModeState .~ nhdlmodst) uhdl+                   in nuhdl+                commit_+                canvasZoomUpdateAll                 invalidateAll -              else do -                addNewPageAndMoveBelow (pnum,hltedLayers,bbx)+              else addNewPageAndMoveBelow (pnum,hltedLayers,bbx)     --------------------------------------------------------------    moveact _xstate cvsInfo (_,(x,y)) = +    moveact cvsInfo (_,(x,y)) =        processWithDefTimeInterval          (verticalSpaceProcess cid geometry pinfo (x0,y0) sfcs)         (\ctime -> do @@ -247,8 +243,16 @@              Cairo.paint              drawguide             let canvas = view drawArea cvsInfo -           win <- liftIO $ widgetGetDrawWindow canvas-           liftIO $ renderWithDrawable win $ do +#ifdef GTK3+           Just win <- liftIO $ Gtk.widgetGetWindow canvas+#else +           win <- liftIO $ Gtk.widgetGetDrawWindow canvas+#endif+#ifdef GTK3+           liftIO $ Gtk.renderWithDrawWindow win $ do +#else +           liftIO $ Gtk.renderWithDrawable win $ do +#endif              Cairo.setSourceSurface sfctot 0 0               Cairo.setOperator Cairo.OperatorSource               Cairo.paint
src/Hoodle/Coroutine/Window.hs view
@@ -1,11 +1,13 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-}  ----------------------------------------------------------------------------- -- | -- Module      : Hoodle.Coroutine.Window --- Copyright   : (c) 2011-2014 Ian-Woo Kim+-- Copyright   : (c) 2011-2015 Ian-Woo Kim ----- License     : GPL-3+-- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com> -- Stability   : experimental -- Portability : GHC@@ -14,16 +16,21 @@  module Hoodle.Coroutine.Window where -import           Control.Lens (view,set,over)+import           Control.Applicative+import           Control.Lens (view,set,over,(^.),(.~),_2) import           Control.Monad.State  import qualified Data.IntMap as M-import           Graphics.UI.Gtk hiding (get,set)+import qualified Data.List as L+import           Data.UUID (UUID)+import qualified Graphics.UI.Gtk as Gtk -- import           Data.Hoodle.Generic import           Data.Hoodle.Simple (Dimension(..)) -- import           Hoodle.Accessor import           Hoodle.Coroutine.Draw+import           Hoodle.Coroutine.File+import           Hoodle.Coroutine.Mode import           Hoodle.Coroutine.Page import           Hoodle.GUI.Reflect import           Hoodle.ModelAction.Page@@ -34,7 +41,9 @@ import           Hoodle.Type.Event import           Hoodle.Type.HoodleState import           Hoodle.Type.PageArrangement+import           Hoodle.Type.Undo import           Hoodle.Type.Window+import           Hoodle.Util --  -- | canvas configure with general zoom update func@@ -43,17 +52,15 @@                             -> CanvasDimension                              -> MainCoroutine ()  canvasConfigureGenUpdate updatefunc cid cdim -  = updateXState (unboxBiAct fsingle fcont . getCanvasInfo cid ) >> updatefunc -  where fsingle cinfo = do -          xstate <- get +  = updateUhdl (\uhdl -> unboxBiAct (fsingle uhdl) (fcont uhdl) (getCanvasInfo cid uhdl)) >> updatefunc +  where fsingle uhdl cinfo = do            cinfo' <- liftIO $ updateCanvasDimForSingle cdim cinfo -          return $ setCanvasInfo (cid,CanvasSinglePage cinfo') xstate-        fcont cinfo = do -          xstate <- get+          return $ setCanvasInfo (cid,CanvasSinglePage cinfo') uhdl+        fcont uhdl cinfo = do            page <- getCurrentPageCvsId cid           let pdim = PageDimension (view gdimension page)           cinfo' <- liftIO $ updateCanvasDimForContSingle pdim cdim cinfo -          return $ setCanvasInfo (cid,CanvasContPage cinfo') xstate +          return $ setCanvasInfo (cid,CanvasContPage cinfo') uhdl     -- |  doCanvasConfigure :: CanvasId -> CanvasDimension -> MainCoroutine () @@ -62,42 +69,40 @@ -- |  eitherSplit :: SplitType -> MainCoroutine ()  eitherSplit stype = do-    xstate <- get-    let cmap = getCanvasInfoMap xstate-        currcid = getCurrentCanvasId xstate+    xst <- get+    let uhdl = view (unitHoodles.currentUnit) xst+    let cmap = view cvsInfoMap uhdl+        currcid = getCurrentCanvasId uhdl         newcid = newCanvasId cmap -        fstate = view frameState xstate+        fstate = view frameState uhdl         enewfstate = splitWindow currcid (newcid,stype) fstate      case enewfstate of        Left _ -> return ()       Right fstate' -> do          cinfobox <- maybeError "eitherSplit" . M.lookup currcid $ cmap -        let rtwin = view rootWindow xstate-            rtcntr = view rootContainer xstate -            rtrwin = view rootOfRootWindow xstate -        liftIO $ containerRemove rtcntr rtwin-        (xstate'',win,fstate'') <- -          liftIO $ constructFrame' cinfobox xstate fstate'-        let xstate3 = set frameState fstate'' -                      . set rootWindow win -                      $ xstate''-        put xstate3 -        liftIO $ boxPackEnd rtcntr win PackGrow 0 -        liftIO $ widgetShowAll rtcntr  -        liftIO $ widgetQueueDraw rtrwin-        (xstate4,_wconf) <- liftIO $ eventConnect xstate3 (view frameState xstate3)-        xstate5 <- liftIO $ updatePageAll (view hoodleModeState xstate4) xstate4-        put xstate5 +        let callback = view callBack xst+            rtwin = view rootWindow uhdl+            rtcntr = view rootContainer uhdl+            rtrwin = view rootOfRootWindow xst +        liftIO $ Gtk.containerRemove rtcntr rtwin+        (uhdl',win,fstate'') <- liftIO $ constructFrame' callback cinfobox uhdl fstate'+        let uhdl'' = ((frameState .~ fstate'') . (rootWindow .~ win)) uhdl'+        let xst3 = (unitHoodles.currentUnit .~ uhdl'') xst+        put xst3 +        liftIO $ registerFrameToContainer rtrwin rtcntr win+        (uhdl3,_wconf) <- liftIO $ eventConnect xst3 uhdl'' (view frameState uhdl'')+        updateUhdl $ const (liftIO $ updatePageAll (view hoodleModeState uhdl3) uhdl3)         canvasZoomUpdateAll         invalidateAll   -- |  deleteCanvas :: MainCoroutine ()  deleteCanvas = do -    xstate <- get-    let cmap = getCanvasInfoMap xstate-        currcid = getCurrentCanvasId xstate-        fstate = view frameState xstate+    xst <- get+    let uhdl = view (unitHoodles.currentUnit) xst+        cmap = view cvsInfoMap uhdl+        currcid = getCurrentCanvasId uhdl+        fstate = view frameState uhdl         enewfstate = removeWindow currcid fstate      case enewfstate of        Left _ -> return ()@@ -105,25 +110,23 @@       Right (Just fstate') -> do          let cmap' = M.delete currcid cmap             newcurrcid = maximum (M.keys cmap')-        xstate0 <- changeCurrentCanvasId newcurrcid -        let xstate1 = maybe xstate0 id $ setCanvasInfoMap cmap' xstate0-        put xstate1-        let rtwin = view rootWindow xstate1-            rtcntr = view rootContainer xstate1 -            rtrwin = view rootOfRootWindow xstate1 -        liftIO $ containerRemove rtcntr rtwin-        (xstate'',win,fstate'') <- liftIO $ constructFrame xstate1 fstate'-        let xstate3 = set frameState fstate'' -                      . set rootWindow win -                      $ xstate''-        put xstate3-        liftIO $ boxPackEnd rtcntr win PackGrow 0 -        liftIO $ widgetShowAll rtcntr  -        liftIO $ widgetQueueDraw rtrwin-        (xstate4,_wconf) <- liftIO $ eventConnect xstate3 (view frameState xstate3)+        updateUhdl $ \_uhdl -> do+          uhdl' <- changeCurrentCanvasId newcurrcid +          maybe (return uhdl') return $ setCanvasInfoMap cmap' uhdl'+        xst1 <- get+        let uhdl1 = view (unitHoodles.currentUnit) xst1+        let rtwin = view rootWindow uhdl1+            rtcntr = view rootContainer uhdl1 +            rtrwin = view rootOfRootWindow xst1 +        liftIO $ Gtk.containerRemove rtcntr rtwin+        (uhdl2,win,fstate'') <- liftIO $ constructFrame xst1 uhdl1 fstate'+        pureUpdateUhdl (const (((frameState .~ fstate'') . (rootWindow .~ win)) uhdl2))+        xst3 <- get+        liftIO $ registerFrameToContainer rtrwin rtcntr win+        updateUhdl $ \uhdl' -> do+          (uhdl'',_wconf) <- liftIO $ eventConnect xst3 uhdl' (view frameState uhdl')+          liftIO $ updatePageAll (view hoodleModeState uhdl'') uhdl''         canvasZoomUpdateAll-        xstate5 <- liftIO $ updatePageAll (view hoodleModeState xstate4) xstate4-        put xstate5          invalidateAll               @@ -133,35 +136,116 @@     ev <- nextevent      case ev of        UpdateCanvas cid -> invalidateInBBox Nothing Efficient cid >> paneMoveStart -      PaneMoveEnd -> do -        return () -      CanvasConfigure cid w' h'-> do -        canvasConfigureGenUpdate canvasZoomUpdateBufAll cid (CanvasDimension (Dim w' h')) -        >> paneMoveStart+      PaneMoveEnd -> return () +      CanvasConfigure cid w' h'->+        canvasConfigureGenUpdate canvasZoomUpdateBufAll cid (CanvasDimension (Dim w' h')) >> paneMoveStart       _ -> paneMoveStart        - -- | not yet implemented? paneMoved :: MainCoroutine () -paneMoved = do -    liftIO $ putStrLn "pane moved called"+paneMoved = msgShout "paneMoved: not implemented"     --- |+-- | start full screen mode fullScreen :: MainCoroutine () fullScreen = do      xst <- get -    let b = view isFullScreen xst-        rwin = view rootOfRootWindow xst -    if b -      then do -        liftIO $ windowUnfullscreen rwin-        modify (over isFullScreen (const False))-      else do -        liftIO $ windowFullscreen rwin -        modify (over isFullScreen (const True))+    let rwin = view rootOfRootWindow xst +    if view isFullScreen xst +      then liftIO (Gtk.windowUnfullscreen rwin) >> modify (over isFullScreen (const False))+      else liftIO (Gtk.windowFullscreen rwin) >> modify (over isFullScreen (const True)) -           -    -  -  +-- |+addTab :: FileStore -> MainCoroutine ()+addTab filestore = do+    xst <- get+    let notebook = xst ^. rootNotebook+        callback = xst ^. callBack+        btnold = xst ^. (unitHoodles.currentUnit.unitButton)+    liftIO $ Gtk.widgetSetSensitive btnold False+    vboxcvs <- liftIO $ Gtk.vBoxNew False 0+    (tabnum,uuid,btn) <- liftIO $ createTab callback notebook vboxcvs+    let wconf = Node 1+        initcvs = defaultCvsInfoSinglePage { _canvasId = 1 }+        initcvsbox = CanvasSinglePage initcvs+        -- mfp = fileStore2Maybe filestore+    uhdl' <- (undoTable .~ emptyUndo 50)   -- (undo = 50 for the time being) +             . (frameState .~ wconf) +             . updateFromCanvasInfoAsCurrentCanvas initcvsbox+             . (cvsInfoMap .~ M.empty)+             . (isSaved .~ True)+             . (hoodleFileControl.hoodleFileName .~ filestore) +             . (unitKey .~ tabnum) +             . (unitUUID .~ uuid) +             . (unitButton .~ btn)+             <$> liftIO emptyUnitHoodle+    modify . set (unitHoodles.currentUnit) =<< (liftIO $ do+      (uhdl'',wdgt,_) <- constructFrame xst uhdl' wconf+      let uhdl3 = (rootWindow .~ wdgt) . (rootContainer .~ Gtk.castToBox vboxcvs) $ uhdl''+      (uhdl4,_wconf) <- eventConnect xst uhdl3 (view frameState uhdl3)+      registerFrameToContainer (xst^.rootOfRootWindow) (Gtk.castToBox vboxcvs) wdgt+      Gtk.widgetShowAll notebook+      return uhdl4) +    doIOaction_ $ +      blockWhile (view (uiComponentSignalHandler.switchTabSignal) xst) $+        Gtk.set notebook [Gtk.notebookPage Gtk.:= tabnum]+    getFileContent filestore+    updateUhdl $ \uhdl -> do+      liftIO (updatePageAll (view hoodleModeState uhdl) uhdl)+      unboxBiAct (sing2ContPage uhdl) (const (return uhdl)) . view currentCanvasInfo $ uhdl+    pageZoomChange FitWidth+    canvasZoomUpdateAll+    invalidateAll +    reflectCursor True++-- | +findTab :: UUID -> MainCoroutine (Maybe Int)+findTab uuid = do+    uhdlmap <- view (unitHoodles._2) <$> get+    let assoc = (map (\x -> (view unitUUID x,view unitKey x)) . M.elems) uhdlmap+    return (L.lookup uuid assoc)++-- |+switchTab :: Int -> MainCoroutine ()+switchTab tabnum = do+    xst <- get+    let notebook = view rootNotebook xst+    doIOaction_ $ Gtk.set notebook [Gtk.notebookPage Gtk.:= tabnum ]+    uhdls <- view unitHoodles <$> get++    let current = fst uhdls+    when (tabnum /= current) $ do +      let uhdl = fromJustError "switchTab"  (M.lookup tabnum (snd uhdls))+      liftIO $ Gtk.widgetSetSensitive (uhdls^.(currentUnit.unitButton)) False+      liftIO $ Gtk.widgetSetSensitive (uhdl^.unitButton) True+      modify $ (unitHoodles.currentUnit .~ uhdl)+      updateUhdl $ \uhdl' -> liftIO (updatePageAll (view hoodleModeState uhdl') uhdl')+#ifndef GTK3+      view currentCanvasInfo uhdl # +        forBoth' unboxBiAct $ \cinfo -> do+          (w,h) <- liftIO $ Gtk.widgetGetSize (cinfo^.drawArea) +          doCanvasConfigure (cinfo^.canvasId) (CanvasDimension (Dim (fromIntegral w) (fromIntegral h)))+#endif+      invalidateAll +      liftIO $ reflectUIToggle (xst ^. gtkUIManager) "SAVEA" (not (uhdl ^. isSaved))+      reflectPenModeUI+      reflectCursor True++-- |+closeTab :: MainCoroutine ()+closeTab = do +  xst <- get+  let (currk,uhdlmap) = xst ^. unitHoodles+      uhdlmap' = M.delete currk uhdlmap +      uhdllst'' = (map (\(x,y)-> (x,(unitKey .~ x) y)) . zip [0..] . M.elems) uhdlmap'+      uhdlmap'' = M.fromList uhdllst''+      sz = M.size uhdlmap+  if (sz > 1) +    then do+      let notebook = xst ^. rootNotebook+      doIOaction_ $ Gtk.notebookRemovePage notebook currk+      modify $ (unitHoodles .~ (0,uhdlmap''))+      canvasZoomUpdateAll+      switchTab 0+    else liftIO $ Gtk.mainQuit+
src/Hoodle/Device.hsc view
@@ -1,9 +1,11 @@-{-# LANGUAGE ForeignFunctionInterface, ScopedTypeVariables #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE ScopedTypeVariables #-}  ----------------------------------------------------------------------------- -- | -- Module      : Hoodle.Device --- Copyright   : (c) 2011-2013 Ian-Woo Kim+-- Copyright   : (c) 2011-2014 Ian-Woo Kim -- -- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>@@ -72,12 +74,11 @@   -> CString  -- ^ touch    -> IO () -+{- -- |  foreign import ccall "c_initdevice.h find_wacom" c_find_wacom   :: CString -> CString -> IO ()--{- +  -- |  foreign import ccall "c_initdevice.h enable_touch" c_enable_touch   :: CString -> IO ()@@ -97,9 +98,6 @@   ptouchname_detect <- newCString "touch"   -- c_find_wacom pstylusname_detect perasername_detect   (mcore,mstylus,meraser,mtouch) <- getPenDevConfig cfg -  -- putStrLn $ show mstylus -  -- putStrLn $ show meraser-  -- putStrLn $ show mtouch   with 0 $ \pcore ->      with 0 $ \pstylus ->        with 0 $ \peraser -> do @@ -217,7 +215,11 @@                      -> (Double,Double)                       -> IO (Double,Double) wacomCoordConvert canvas (x,y)= do +#ifdef GTK3  +  Just win <- widgetGetWindow canvas -- partial function for the time being +#else // GTK3   win <- widgetGetDrawWindow canvas+#endif // GTK3   (x0,y0) <- drawWindowGetOrigin win   screen <- widgetGetScreen canvas   (ws,hs) <- (,) <$> screenGetWidth screen <*> screenGetHeight screen
src/Hoodle/GUI.hs view
@@ -1,9 +1,11 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-}  ----------------------------------------------------------------------------- -- | -- Module      : Hoodle.GUI --- Copyright   : (c) 2011-2013 Ian-Woo Kim+-- Copyright   : (c) 2011-2014 Ian-Woo Kim -- -- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>@@ -16,14 +18,14 @@  import           Control.Concurrent (threadDelay, forkIO) import           Control.Exception (SomeException(..),catch)-import           Control.Lens (view)-import           Control.Monad hiding (mapM_)+import           Control.Lens+import           Control.Monad hiding (mapM_,forM_) import           Control.Monad.Trans -import           Data.Foldable (mapM_)+import           Data.Foldable (mapM_,forM_) import qualified Data.IntMap as M import           Data.IORef import           Data.Maybe-import           Graphics.UI.Gtk hiding (get,set)+import qualified Graphics.UI.Gtk as Gtk import           System.Directory import           System.Environment import           System.FilePath@@ -40,92 +42,99 @@ import           Hoodle.Type.Event import           Hoodle.Type.HoodleState  ---import           Prelude ((.),($),String,Bool(..),const,error,flip,id,map) +import           Prelude ((.),($),String,Bool(..),error,flip,id,map)   -- | startGUI :: Maybe FilePath -> Maybe Hook -> IO ()  startGUI mfname mhook = do -  initGUI-  window <- windowNew   -  windowSetDefaultSize window 800 400-  cfg <- loadConfigFile   -  devlst <- initDevice cfg -  maxundo <- getMaxUndo cfg >>= -               \mmax -> maybe (return 50) (return . id) mmax-  xinputbool <- getXInputConfig cfg -  (usepz,uselyr) <- getWidgetConfig cfg -  statusbar <- statusbarNew -  (tref,st0,ui,vbox) <- initCoroutine devlst window mhook maxundo (xinputbool,usepz,uselyr) statusbar -  setTitleFromFileName st0-  -- need for refactoring-  setToggleUIForFlag "UXINPUTA" (settings.doesUseXInput) st0 -  setToggleUIForFlag "HANDA" (settings.doesUseTouch) st0   -  setToggleUIForFlag "POPMENUA" (settings.doesUsePopUpMenu) st0 -  setToggleUIForFlag "EBDIMGA" (settings.doesEmbedImage) st0 -  setToggleUIForFlag "EBDPDFA" (settings.doesEmbedPDF) st0-  -- -  let canvases = map (getDrawAreaFromBox) . M.elems . getCanvasInfoMap $ st0-  if xinputbool-      then mapM_ (flip widgetSetExtensionEvents [ExtensionEventsAll]) canvases-      else mapM_ (flip widgetSetExtensionEvents [ExtensionEventsNone]) canvases-  -- -  menubar <- uiManagerGetWidget ui "/ui/menubar" -             >>= maybe (error "GUI.hs:no menubar") return -  toolbar1 <- uiManagerGetWidget ui "/ui/toolbar1" -              >>= maybe (error "GUI.hs:no toolbar1") return -  toolbar2 <- uiManagerGetWidget ui "/ui/toolbar2"-              >>= maybe (error "GUI.hs:no toolbar2") return -  -- -  ebox <- eventBoxNew-  label <- labelNew (Just "drag me")-  containerAdd ebox label -  dragSourceSet ebox [Button1] [ActionCopy]-  dragSourceSetIconStock ebox stockIndex-  dragSourceAddTextTargets ebox-  ebox `on` dragBegin $ \_dc -> do -      liftIO $ putStrLn "dragging"-  ebox `on` dragDataGet $ \_dc _iid _ts -> do +    Gtk.initGUI+    window <- Gtk.windowNew   +    Gtk.windowSetDefaultSize window 800 400+    cfg <- loadConfigFile   +    devlst <- initDevice cfg +    maxundo <- getMaxUndo cfg >>= maybe (return 50) (return . id)+    xinputbool <- getXInputConfig cfg +    varcsr <- getPenConfig cfg+    (usepz,uselyr) <- getWidgetConfig cfg +    (tref,st0,ui,vbox) <- initCoroutine devlst window mhook maxundo (xinputbool,usepz,uselyr,varcsr) +    setTitleFromFileName st0+    -- need for refactoring+    mapM_ (\(x,y :: Simple Lens Settings Bool) -> lensSetToggleUIForFlag x (settings.y) st0 )+      [ ("UXINPUTA", doesUseXInput) +      , ("HANDA"   , doesUseTouch)+      , ("POPMENUA", doesUsePopUpMenu)+      , ("EBDIMGA" , doesEmbedImage)+      , ("EBDPDFA" , doesEmbedPDF)+      ] +    setToggleUIForFlag "TOGGLENETSRCA" False st0+    -- +    let canvases = map (getDrawAreaFromBox) . M.elems . view (unitHoodles.currentUnit.cvsInfoMap) $ st0+#ifndef GTK3      +    if xinputbool+        then mapM_ (flip Gtk.widgetSetExtensionEvents [Gtk.ExtensionEventsAll]) canvases+        else mapM_ (flip Gtk.widgetSetExtensionEvents [Gtk.ExtensionEventsNone]) canvases+#endif+    --+    outerLayout ui vbox st0 +    window `Gtk.on` Gtk.deleteEvent $ do+      liftIO $ eventHandler tref (UsrEv (Menu MenuQuit))+      return True+    Gtk.widgetShowAll window++    forkIO $ clock (eventHandler tref)+    let mainaction = eventHandler tref (UsrEv (Initialized mfname)) >> Gtk.mainGUI +    mainaction `catch` \(_e :: SomeException) -> do +      homepath <- getEnv "HOME"+      let dir = homepath </> ".hoodle.d"+      createDirectoryIfMissing False dir+      outh <- openFile (dir </> "error.log") WriteMode +      hPutStrLn outh "error occured"+      hClose outh +    return ()+++clock :: (AllEvent -> IO ()) -> IO ()+clock evhandler = forever $ do +    threadDelay 1000000+    Gtk.postGUIAsync (evhandler (SysEv ClockUpdateEvent))++++outerLayout :: Gtk.UIManager -> Gtk.VBox -> HoodleState -> IO ()+outerLayout ui vbox xst = do +    let notebook = view rootNotebook xst+        mstatusbar = view statusBar xst+    menubar <- Gtk.uiManagerGetWidget ui "/ui/menubar" +               >>= maybe (error "GUI.hs:no menubar") return +    toolbar1 <- Gtk.uiManagerGetWidget ui "/ui/toolbar1" +                >>= maybe (error "GUI.hs:no toolbar1") return +    toolbar2 <- Gtk.uiManagerGetWidget ui "/ui/toolbar2"+                >>= maybe (error "GUI.hs:no toolbar2") return +    -- +    ebox <- Gtk.eventBoxNew+    label <- Gtk.labelNew (Just "drag me")+    Gtk.containerAdd ebox label +    Gtk.dragSourceSet ebox [Gtk.Button1] [Gtk.ActionCopy]+    Gtk.dragSourceSetIconStock ebox Gtk.stockIndex+    Gtk.dragSourceAddTextTargets ebox+    -- ebox `on` dragBegin $ \_dc -> do +    --   liftIO $ putStrLn "dragging"+    ebox `Gtk.on` Gtk.dragDataGet $ \_dc _iid _ts -> do        -- very dirty solution but..        minfo <- liftIO $ do          ref <- newIORef (Nothing :: Maybe String)-        view callBack st0 (UsrEv (GetHoodleFileInfo ref))+        view callBack xst (UsrEv (GetHoodleFileInfo ref))         readIORef ref-      mapM_ (selectionDataSetText >=> const (return ())) minfo-  ---  -- -  hbox <- hBoxNew False 0 -  boxPackStart hbox toolbar1 PackGrow 0-  boxPackStart hbox ebox PackNatural 0-  containerAdd window vbox-  boxPackStart vbox menubar PackNatural 0 -  boxPackStart vbox hbox PackNatural 0-  boxPackStart vbox toolbar2 PackNatural 0  -  boxPackEnd vbox statusbar PackNatural 0 -  boxPackStart vbox (view rootWindow st0) PackGrow 0 -  window `on` deleteEvent $ do-    liftIO $ eventHandler tref (UsrEv (Menu MenuQuit))-    return True-  widgetShowAll window-  -- -  -- this is a test for asynchronous events-  -- -  forkIO $ forever $ do -    threadDelay 1000000-    -- putStrLn "event!"-    postGUIAsync (eventHandler tref (SysEv ClockUpdateEvent))-  -  -- -  -- test end-  -- -  let mainaction = do eventHandler tref (UsrEv (Initialized mfname))-                      mainGUI -  mainaction `catch` \(_e :: SomeException) -> do -    homepath <- getEnv "HOME"-    let dir = homepath </> ".hoodle.d"-    createDirectoryIfMissing False dir-    outh <- openFile (dir </> "error.log") WriteMode -    hPutStrLn outh "error occured"-    hClose outh -  return ()+      traverse Gtk.selectionDataSetText minfo >> return () +    -- +    hbox <- Gtk.hBoxNew False 0 +    Gtk.boxPackStart hbox toolbar1 Gtk.PackGrow 0+    Gtk.boxPackStart hbox ebox Gtk.PackNatural 0+    Gtk.boxPackStart vbox menubar Gtk.PackNatural 0 +    Gtk.boxPackStart vbox hbox Gtk.PackNatural 0+    Gtk.boxPackStart vbox toolbar2 Gtk.PackNatural 0  +    forM_ mstatusbar $ \statusbar-> Gtk.boxPackEnd vbox statusbar Gtk.PackNatural 0+    --+    Gtk.boxPackStart vbox notebook Gtk.PackGrow 0
src/Hoodle/GUI/Menu.hs view
@@ -1,11 +1,13 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-}  ----------------------------------------------------------------------------- -- | -- Module      : Hoodle.GUI.Menu --- Copyright   : (c) 2011-2014 Ian-Woo Kim+-- Copyright   : (c) 2011-2015 Ian-Woo Kim ----- License     : GPL-3+-- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com> -- Stability   : experimental -- Portability : GHC@@ -19,8 +21,8 @@ -- from other packages import           Control.Lens (set) import           Control.Monad-import           Graphics.UI.Gtk hiding (set,get)-import qualified Graphics.UI.Gtk as Gtk (set)+import qualified Data.Foldable as F (forM_)+import qualified Graphics.UI.Gtk as Gtk import           System.FilePath -- from hoodle-platform  import           Data.Hoodle.Predefined @@ -34,7 +36,7 @@ justMenu = Just . Menu   -iconList :: [ (String,String) ]+iconList :: [ (String,Gtk.StockId) ] iconList = [ ("fullscreen.png" , "myfullscreen")            , ("pencil.png"     , "mypen")            , ("eraser.png"     , "myeraser")@@ -66,102 +68,108 @@            ]  -- | -viewmods :: [RadioActionEntry] -viewmods = [ RadioActionEntry "CONTA" "Continuous" Nothing Nothing Nothing 0-           , RadioActionEntry "ONEPAGEA" "One Page" Nothing Nothing Nothing 1+viewmods :: [Gtk.RadioActionEntry] +viewmods = [ Gtk.RadioActionEntry "CONTA" "Continuous" Nothing Nothing Nothing 0+           , Gtk.RadioActionEntry "ONEPAGEA" "One Page" Nothing Nothing Nothing 1            ]             -- | -pointmods :: [RadioActionEntry] -pointmods = [ RadioActionEntry "PENVERYFINEA" "Very fine" Nothing Nothing Nothing 0-            , RadioActionEntry "PENFINEA" "Fine" (Just "mythin") Nothing Nothing 1+pointmods :: [Gtk.RadioActionEntry] +pointmods = [ Gtk.RadioActionEntry "PENVERYFINEA" "Very fine" Nothing Nothing Nothing 0+            , Gtk.RadioActionEntry "PENFINEA" "Fine" (Just "mythin") Nothing Nothing 1             -            , RadioActionEntry "PENTHICKA" "Thick" (Just "mythick") Nothing Nothing 3 -            , RadioActionEntry "PENVERYTHICKA" "Very Thick" Nothing Nothing Nothing 4 -            , RadioActionEntry "PENULTRATHICKA" "Ultra Thick" Nothing Nothing Nothing 5   -            , RadioActionEntry "PENMEDIUMA" "Medium" (Just "mymedium") Nothing Nothing 2              ---             , RadioActionEntry "NOWIDTH" "Unknown" Nothing Nothing Nothing 999 +            , Gtk.RadioActionEntry "PENTHICKA" "Thick" (Just "mythick") Nothing Nothing 3 +            , Gtk.RadioActionEntry "PENVERYTHICKA" "Very Thick" Nothing Nothing Nothing 4 +            , Gtk.RadioActionEntry "PENULTRATHICKA" "Ultra Thick" Nothing Nothing Nothing 5   +            , Gtk.RadioActionEntry "PENMEDIUMA" "Medium" (Just "mymedium") Nothing Nothing 2              +--             , Gtk.RadioActionEntry "NOWIDTH" "Unknown" Nothing Nothing Nothing 999              ]              -- |  -penmods :: [RadioActionEntry] -penmods = [ RadioActionEntry "PENA"    "Pen"         (Just "mypen")         Nothing Nothing 0 -          , RadioActionEntry "ERASERA" "Eraser"      (Just "myeraser")      Nothing Nothing 1-          , RadioActionEntry "HIGHLTA" "Highlighter" (Just "myhighlighter") Nothing Nothing 2---           , RadioActionEntry "TEXTA"   "Text"        (Just "mytext")        Nothing Nothing 3 -          , RadioActionEntry "SELREGNA" "Select Region"     (Just "mylasso")        Nothing Nothing 4-          , RadioActionEntry "SELRECTA" "Select Rectangle" (Just "myrectselect")        Nothing Nothing 5-          , RadioActionEntry "VERTSPA" "Vertical Space"    (Just "mystretch")        Nothing Nothing 6+penmods :: [Gtk.RadioActionEntry] +penmods = [ Gtk.RadioActionEntry "PENA"    "Pen"         (Just "mypen")         Nothing Nothing 0 +          , Gtk.RadioActionEntry "ERASERA" "Eraser"      (Just "myeraser")      Nothing Nothing 1+          , Gtk.RadioActionEntry "HIGHLTA" "Highlighter" (Just "myhighlighter") Nothing Nothing 2+--           , Gtk.RadioActionEntry "TEXTA"   "Text"        (Just "mytext")        Nothing Nothing 3 +          , Gtk.RadioActionEntry "SELREGNA" "Select Region"     (Just "mylasso")        Nothing Nothing 4+          , Gtk.RadioActionEntry "SELRECTA" "Select Rectangle" (Just "myrectselect")        Nothing Nothing 5+          , Gtk.RadioActionEntry "VERTSPA" "Vertical Space"    (Just "mystretch")        Nothing Nothing 6           ]             ---          , RadioActionEntry "HANDA"   "Hand Tool"         (Just "myhand")        Nothing Nothing 7+--          , Gtk.RadioActionEntry "HANDA"   "Hand Tool"         (Just "myhand")        Nothing Nothing 7   -- |  -colormods :: [RadioActionEntry]-colormods = [ RadioActionEntry "BLUEA"       "Blue"       (Just "myblue")       Nothing Nothing 1-            , RadioActionEntry "REDA"        "Red"        (Just "myred")        Nothing Nothing 2-            , RadioActionEntry "GREENA"      "Green"      (Just "mygreen")      Nothing Nothing 3-            , RadioActionEntry "GRAYA"       "Gray"       (Just "mygray")       Nothing Nothing 4-            , RadioActionEntry "LIGHTBLUEA"  "Lightblue"  (Just "mylightblue")  Nothing Nothing 5     -            , RadioActionEntry "LIGHTGREENA" "Lightgreen" (Just "mylightgreen") Nothing Nothing 6-            , RadioActionEntry "MAGENTAA"    "Magenta"    (Just "mymagenta")    Nothing Nothing 7-            , RadioActionEntry "ORANGEA"     "Orange"     (Just "myorange")     Nothing Nothing 8-            , RadioActionEntry "YELLOWA"     "Yellow"     (Just "myyellow")     Nothing Nothing 9-            , RadioActionEntry "WHITEA"      "White"      (Just "mywhite")      Nothing Nothing 10-            , RadioActionEntry "BLACKA"      "Black"      (Just "myblack")      Nothing Nothing 0              ----             , RadioActionEntry "NOCOLOR"     "Unknown"    Nothing Nothing Nothing 999 +colormods :: [Gtk.RadioActionEntry]+colormods = [ Gtk.RadioActionEntry "BLUEA"       "Blue"       (Just "myblue")       Nothing Nothing 1+            , Gtk.RadioActionEntry "REDA"        "Red"        (Just "myred")        Nothing Nothing 2+            , Gtk.RadioActionEntry "GREENA"      "Green"      (Just "mygreen")      Nothing Nothing 3+            , Gtk.RadioActionEntry "GRAYA"       "Gray"       (Just "mygray")       Nothing Nothing 4+            , Gtk.RadioActionEntry "LIGHTBLUEA"  "Lightblue"  (Just "mylightblue")  Nothing Nothing 5     +            , Gtk.RadioActionEntry "LIGHTGREENA" "Lightgreen" (Just "mylightgreen") Nothing Nothing 6+            , Gtk.RadioActionEntry "MAGENTAA"    "Magenta"    (Just "mymagenta")    Nothing Nothing 7+            , Gtk.RadioActionEntry "ORANGEA"     "Orange"     (Just "myorange")     Nothing Nothing 8+            , Gtk.RadioActionEntry "YELLOWA"     "Yellow"     (Just "myyellow")     Nothing Nothing 9+            , Gtk.RadioActionEntry "WHITEA"      "White"      (Just "mywhite")      Nothing Nothing 10+            , Gtk.RadioActionEntry "BLACKA"      "Black"      (Just "myblack")      Nothing Nothing 0              +---             , Gtk.RadioActionEntry "NOCOLOR"     "Unknown"    Nothing Nothing Nothing 999              ]  -- | -bkgstyles :: [RadioActionEntry] -bkgstyles = [ RadioActionEntry "BKGGRAPHA" "Graph" Nothing Nothing Nothing 3 -            , RadioActionEntry "BKGPLAINA" "Plain" Nothing Nothing Nothing 0-            , RadioActionEntry "BKGLINEDA" "Lined" Nothing Nothing Nothing 1-            , RadioActionEntry "BKGRULEDA" "Ruled" Nothing Nothing Nothing 2 +bkgstyles :: [Gtk.RadioActionEntry] +bkgstyles = [ Gtk.RadioActionEntry "BKGGRAPHA" "Graph" Nothing Nothing Nothing 3 +            , Gtk.RadioActionEntry "BKGPLAINA" "Plain" Nothing Nothing Nothing 0+            , Gtk.RadioActionEntry "BKGLINEDA" "Lined" Nothing Nothing Nothing 1+            , Gtk.RadioActionEntry "BKGRULEDA" "Ruled" Nothing Nothing Nothing 2              ] +newpagemods :: [Gtk.RadioActionEntry] +newpagemods = [ Gtk.RadioActionEntry "NEWPAGEPLAINA" "Plain page" Nothing Nothing Nothing 0 +              , Gtk.RadioActionEntry "NEWPAGELASTA"  "Last page"  Nothing Nothing Nothing 1+              , Gtk.RadioActionEntry "NEWPAGECYCLEA" "Cycle page" Nothing Nothing Nothing 2+              ]++ -- | -iconResourceAdd :: IconFactory -> FilePath -> (FilePath, StockId) -                   -> IO ()+iconResourceAdd :: Gtk.IconFactory -> FilePath -> (FilePath, Gtk.StockId) -> IO () iconResourceAdd iconfac resdir (fp,stid) = do -  myIconSource <- iconSourceNew -  iconSourceSetFilename myIconSource (resdir </> fp)-  iconSourceSetSize myIconSource IconSizeLargeToolbar-  myIconSourceSmall <- iconSourceNew -  iconSourceSetFilename myIconSourceSmall (resdir </> fp)-  iconSourceSetSize myIconSource IconSizeMenu-  myIconSet <- iconSetNew -  iconSetAddSource myIconSet myIconSource -  iconSetAddSource myIconSet myIconSourceSmall-  iconFactoryAdd iconfac stid myIconSet+  myIconSource <- Gtk.iconSourceNew +  Gtk.iconSourceSetFilename myIconSource (resdir </> fp)+  Gtk.iconSourceSetSize myIconSource Gtk.IconSizeLargeToolbar+  myIconSourceSmall <- Gtk.iconSourceNew +  Gtk.iconSourceSetFilename myIconSourceSmall (resdir </> fp)+  Gtk.iconSourceSetSize myIconSource Gtk.IconSizeMenu+  myIconSet <- Gtk.iconSetNew +  Gtk.iconSetAddSource myIconSet myIconSource +  Gtk.iconSetAddSource myIconSet myIconSourceSmall+  Gtk.iconFactoryAdd iconfac stid myIconSet  -- |   actionNewAndRegisterRef :: EventVar                                                        -> String -> String -                           -> Maybe String -> Maybe StockId+                           -> Maybe String -> Maybe Gtk.StockId                            -> Maybe UserEvent -                           -> IO Action+                           -> IO Gtk.Action actionNewAndRegisterRef evar name label tooltip stockId myevent = do -    a <- actionNew name label tooltip stockId +    a <- Gtk.actionNew name label tooltip stockId      case myevent of        Nothing -> return a        Just ev -> do -        a `on` actionActivated $ do +        a `Gtk.on` Gtk.actionActivated $ do            eventHandler evar (UsrEv ev)         return a  -- |  -getMenuUI :: EventVar -> IO (UIManager,UIComponentSignalHandler)+getMenuUI :: EventVar -> IO (Gtk.UIManager,UIComponentSignalHandler) getMenuUI evar = do    let actionNewAndRegister = actionNewAndRegisterRef evar     -- icons   -  myiconfac <- iconFactoryNew -  iconFactoryAddDefault myiconfac +  myiconfac <- Gtk.iconFactoryNew +  Gtk.iconFactoryAddDefault myiconfac    resDir <- getDataDir >>= return . (</> "resource")    mapM_ (iconResourceAdd myiconfac resDir) iconList    fma     <- actionNewAndRegister "FMA"   "File" Nothing Nothing Nothing@@ -173,15 +181,16 @@   tma     <- actionNewAndRegister "TMA"   "Tool" Nothing Nothing Nothing   verma   <- actionNewAndRegister "VERMA" "Version" Nothing Nothing Nothing   oma     <- actionNewAndRegister "OMA"   "Option" Nothing Nothing Nothing+  wma     <- actionNewAndRegister "WMA"   "Window" Nothing Nothing Nothing   hma     <- actionNewAndRegister "HMA"   "Help" Nothing Nothing Nothing    ---------------   -- file menu --   ----------------  newa    <- actionNewAndRegister "NEWA"  "New" (Just "Just a Stub") (Just stockNew) (justMenu MenuNew)-  opena   <- actionNewAndRegister "OPENA" "Open" (Just "Just a Stub") (Just stockOpen) (justMenu MenuOpen)-  savea   <- actionNewAndRegister "SAVEA" "Save" (Just "Just a Stub") (Just stockSave) (justMenu MenuSave)-  saveasa <- actionNewAndRegister "SAVEASA" "Save As" (Just "Just a Stub") (Just stockSaveAs) (justMenu MenuSaveAs)+  newa    <- actionNewAndRegister "NEWA"  "New" (Just "Just a Stub") (Just Gtk.stockNew) (justMenu MenuNew)+  opena   <- actionNewAndRegister "OPENA" "Open" (Just "Just a Stub") (Just Gtk.stockOpen) (justMenu MenuOpen)+  savea   <- actionNewAndRegister "SAVEA" "Save" (Just "Just a Stub") (Just Gtk.stockSave) (justMenu MenuSave)+  saveasa <- actionNewAndRegister "SAVEASA" "Save As" (Just "Just a Stub") (Just Gtk.stockSaveAs) (justMenu MenuSaveAs)   printa  <- actionNewAndRegister "PRINTA" "Print" (Just "Just a Stub") Nothing (justMenu MenuPrint)   --   exporta <- actionNewAndRegister "EXPORTA" "Export to PDF" (Just "Just a Stub") Nothing (justMenu MenuExport)@@ -192,37 +201,38 @@   reloada <- actionNewAndRegister "RELOADA" "Reload File" (Just "Just a Stub") Nothing (justMenu MenuReload)   recenta <- actionNewAndRegister "RECENTA" "Recent Document" (Just "Just a Stub") Nothing (justMenu MenuRecentDocument)   ---  quita   <- actionNewAndRegister "QUITA" "Quit" (Just "Just a Stub") (Just stockQuit) (justMenu MenuQuit)+  quita   <- actionNewAndRegister "QUITA" "Quit" (Just "Just a Stub") (Just Gtk.stockQuit) (justMenu MenuQuit)    ---------------   -- edit menu --   ----------------  undoa   <- actionNewAndRegister "UNDOA"   "Undo" (Just "Just a Stub") (Just stockUndo) (justMenu MenuUndo)-  redoa   <- actionNewAndRegister "REDOA"   "Redo" (Just "Just a Stub") (Just stockRedo) (justMenu MenuRedo)-  cuta    <- actionNewAndRegister "CUTA"    "Cut" (Just "Just a Stub")  (Just stockCut) (justMenu MenuCut)-  copya   <- actionNewAndRegister "COPYA"   "Copy" (Just "Just a Stub") (Just stockCopy) (justMenu MenuCopy)-  pastea  <- actionNewAndRegister "PASTEA"  "Paste" (Just "Just a Stub") (Just stockPaste) (justMenu MenuPaste)-  deletea <- actionNewAndRegister "DELETEA" "Delete" (Just "Just a Stub") (Just stockDelete) (justMenu MenuDelete)+  undoa   <- actionNewAndRegister "UNDOA"   "Undo" (Just "Just a Stub") (Just Gtk.stockUndo) (justMenu MenuUndo)+  redoa   <- actionNewAndRegister "REDOA"   "Redo" (Just "Just a Stub") (Just Gtk.stockRedo) (justMenu MenuRedo)+  cuta    <- actionNewAndRegister "CUTA"    "Cut" (Just "Just a Stub")  (Just Gtk.stockCut) (justMenu MenuCut)+  copya   <- actionNewAndRegister "COPYA"   "Copy" (Just "Just a Stub") (Just Gtk.stockCopy) (justMenu MenuCopy)+  pastea  <- actionNewAndRegister "PASTEA"  "Paste" (Just "Just a Stub") (Just Gtk.stockPaste) (justMenu MenuPaste)+  deletea <- actionNewAndRegister "DELETEA" "Delete" (Just "Just a Stub") (Just Gtk.stockDelete) (justMenu MenuDelete)    ---------------   -- view menu --   ---------------   togpanzooma <- actionNewAndRegister "TOGPANZOOMA" "Show/Hide Zoom Widget"  (Just "Just a stub") Nothing (justMenu MenuTogglePanZoomWidget)+  togscra <- actionNewAndRegister "TOGSCRA" "Show/Hide Scroll Widget"  (Just "Just a stub") Nothing (justMenu MenuToggleScrollWidget)   --    zooma     <- actionNewAndRegister "ZOOMA"     "Zoom" (Just "Just a Stub") Nothing Nothing -- (justMenu MenuZoom)-  zmina     <- actionNewAndRegister "ZMINA"     "Zoom In" (Just "Zoom In") (Just stockZoomIn) (justMenu MenuZoomIn)-  zmouta    <- actionNewAndRegister "ZMOUTA"    "Zoom Out" (Just "Zoom Out") (Just stockZoomOut) (justMenu MenuZoomOut)-  nrmsizea  <- actionNewAndRegister "NRMSIZEA"  "Normal Size" (Just "Normal Size") (Just stockZoom100) (justMenu MenuNormalSize)-  pgwdtha   <- actionNewAndRegister "PGWDTHA" "Page Width" (Just "Page Width") (Just stockZoomFit) (justMenu MenuPageWidth)+  zmina     <- actionNewAndRegister "ZMINA"     "Zoom In" (Just "Zoom In") (Just Gtk.stockZoomIn) (justMenu MenuZoomIn)+  zmouta    <- actionNewAndRegister "ZMOUTA"    "Zoom Out" (Just "Zoom Out") (Just Gtk.stockZoomOut) (justMenu MenuZoomOut)+  nrmsizea  <- actionNewAndRegister "NRMSIZEA"  "Normal Size" (Just "Normal Size") (Just Gtk.stockZoom100) (justMenu MenuNormalSize)+  pgwdtha   <- actionNewAndRegister "PGWDTHA" "Page Width" (Just "Page Width") (Just Gtk.stockZoomFit) (justMenu MenuPageWidth)   pgheighta <- actionNewAndRegister "PGHEIGHTA" "Page Height" (Just "Page Height") Nothing (justMenu MenuPageHeight)-  setzma    <- actionNewAndRegister "SETZMA"  "Set Zoom" (Just "Set Zoom") (Just stockFind) (justMenu MenuSetZoom)+  setzma    <- actionNewAndRegister "SETZMA"  "Set Zoom" (Just "Set Zoom") (Just Gtk.stockFind) (justMenu MenuSetZoom)   --    fscra     <- actionNewAndRegister "FSCRA"     "Full Screen" (Just "Just a Stub") (Just "myfullscreen") (justMenu MenuFullScreen)   ---  fstpagea  <- actionNewAndRegister "FSTPAGEA"  "First Page" (Just "Just a Stub") (Just stockGotoFirst) (justMenu MenuFirstPage)-  prvpagea  <- actionNewAndRegister "PRVPAGEA"  "Previous Page" (Just "Just a Stub") (Just stockGoBack) (justMenu MenuPreviousPage)-  nxtpagea  <- actionNewAndRegister "NXTPAGEA"  "Next Page" (Just "Just a Stub") (Just stockGoForward) (justMenu MenuNextPage)-  lstpagea  <- actionNewAndRegister "LSTPAGEA"  "Last Page" (Just "Just a Stub") (Just stockGotoLast) (justMenu MenuLastPage)+  fstpagea  <- actionNewAndRegister "FSTPAGEA"  "First Page" (Just "Just a Stub") (Just Gtk.stockGotoFirst) (justMenu MenuFirstPage)+  prvpagea  <- actionNewAndRegister "PRVPAGEA"  "Previous Page" (Just "Just a Stub") (Just Gtk.stockGoBack) (justMenu MenuPreviousPage)+  nxtpagea  <- actionNewAndRegister "NXTPAGEA"  "Next Page" (Just "Just a Stub") (Just Gtk.stockGoForward) (justMenu MenuNextPage)+  lstpagea  <- actionNewAndRegister "LSTPAGEA"  "Last Page" (Just "Just a Stub") (Just Gtk.stockGotoLast) (justMenu MenuLastPage)   --    hsplita <- actionNewAndRegister "HSPLITA" "Clone View Horizontally" (Just "horizontal split") Nothing (justMenu MenuHSplit)   vsplita <- actionNewAndRegister "VSPLITA" "Clone View Vertically" (Just "vertical split") Nothing (justMenu MenuVSplit)@@ -240,16 +250,13 @@   gotolayera <- actionNewAndRegister "GOTOLAYERA" "Goto Layer" (Just "Just a Stub") Nothing (justMenu MenuGotoLayer)   dellyra <- actionNewAndRegister "DELLYRA" "Delete Layer"    (Just "Just a Stub") Nothing (justMenu MenuDeleteLayer) -  -- shwlayera <- actionNewAndRegister "SHWLAYERA" "Show Layer" (Just "Just a Stub") Nothing (justMenu MenuShowLayer)-  -- hidlayera <- actionNewAndRegister "HIDLAYERA" "Hide Layer" (Just "Just a Stub") Nothing (justMenu MenuHideLayer)--   -----------------  -- image menu --+  -- embed menu --   ----------------    ldpnga <- actionNewAndRegister "LDIMGA" "Load PNG or JPG Image" (Just "Just a Stub") Nothing (justMenu MenuLoadPNGorJPG)   ldsvga <- actionNewAndRegister "LDSVGA" "Load SVG Image" (Just "Just a Stub") Nothing (justMenu MenuLoadSVG)+  ldimgbkga <- actionNewAndRegister "LDIMGBKGA" "Make Title Page from Image" (Just "Just a Stub") Nothing (justMenu MenuLoadImageBackground)   ldpreimga <- actionNewAndRegister "LDPREIMGA" "Embed Predefined Image File" (Just "Just a Stub") Nothing (justMenu MenuEmbedPredefinedImage)   ldpreimg2a <- actionNewAndRegister "LDPREIMG2A" "Embed Predefined Image File 2" (Just "Just a Stub") Nothing (justMenu MenuEmbedPredefinedImage2)   ldpreimg3a <- actionNewAndRegister "LDPREIMG3A" "Embed Predefined Image File 3" (Just "Just a Stub") Nothing (justMenu MenuEmbedPredefinedImage3)@@ -257,17 +264,37 @@   texta <- actionNewAndRegister "TEXTA" "Text" (Just "Text") (Just "mytext") (justMenu MenuText)   textsrca <- actionNewAndRegister "TEXTSRCA" "Embed Text Source" (Just "Just a Stub") Nothing (justMenu MenuEmbedTextSource)   editsrca <- actionNewAndRegister "EDITSRCA" "Edit text source" (Just "Just a Stub") Nothing (justMenu MenuEditEmbedTextSource)+#ifdef HUB   editnetsrca <- actionNewAndRegister "EDITNETSRCA" "Network edit text source" (Just "Just a Stub") Nothing (justMenu MenuEditNetEmbedTextSource)-+#else+  editnetsrca <- actionNewAndRegister "EDITNETSRCA" "Network edit text source" (Just "Just a Stub") Nothing (justMenu MenuDefault)+#endif   textfromsrca <- actionNewAndRegister "TEXTFROMSRCA" "Text From Source" (Just "Just a Stub") Nothing (justMenu MenuTextFromSource) ++  togglenetsrca <- Gtk.toggleActionNew ("TOGGLENETSRCA" :: String) "Toggle network edit text source" (Just "Just a Stub") Nothing+#ifdef HUB+  togglenetsrca `Gtk.on` Gtk.actionToggled $ do+    eventHandler evar (UsrEv (Menu MenuToggleNetworkEditSource))+#else+  togglenetsrca `Gtk.on` Gtk.actionToggled $ do+    eventHandler evar (UsrEv (Menu MenuDefault))+#endif   latexa <- actionNewAndRegister "LATEXA" "LaTeX" (Just "Just a Stub") (Just "mylatex") (justMenu MenuLaTeX)+#ifdef HUB   latexneta <- actionNewAndRegister "LATEXNETA" "LaTeX Network" (Just "Just a Stub") (Just "mylatex") (justMenu MenuLaTeXNetwork)  +#else+  latexneta <- actionNewAndRegister "LATEXNETA" "LaTeX Network" (Just "Just a Stub") (Just "mylatex") (justMenu MenuDefault)  +#endif   combinelatexa <- actionNewAndRegister "COMBINELATEXA" "Combine LaTeX texts to ..." (Just "Just a Stub") Nothing (justMenu MenuCombineLaTeX)     latexfromsrca <- actionNewAndRegister "LATEXFROMSRCA" "LaTeX From Source" (Just "Just a Stub") Nothing (justMenu MenuLaTeXFromSource)   +  updatelatexa <- actionNewAndRegister "UPDATELATEXA" "Update LaTeX" (Just "Just a Stub") Nothing (justMenu MenuUpdateLaTeX)     -  -- page menu +  ---------------+  -- page menu --+  ---------------+   newpgba <- actionNewAndRegister "NEWPGBA" "New Page Before" (Just "Just a Stub") Nothing (justMenu MenuNewPageBefore)   newpgaa <- actionNewAndRegister "NEWPGAA" "New Page After"  (Just "Just a Stub") Nothing (justMenu MenuNewPageAfter)   newpgea <- actionNewAndRegister "NEWPGEA" "New Page At End" (Just "Just a Stub") Nothing (justMenu MenuNewPageAtEnd)@@ -278,26 +305,17 @@   ppstya <- actionNewAndRegister "PPSTYA"   "Paper Style" Nothing Nothing Nothing   apallpga<- actionNewAndRegister "APALLPGA" "Apply To All Pages" (Just "Just a Stub") Nothing (justMenu MenuApplyToAllPages)   embedbkgpdfa <- actionNewAndRegister "EMBEDBKGPDFA" "Embed All PDF backgroound" (Just "Just a Stub") Nothing (justMenu MenuEmbedAllPDFBkg)-  -- ldbkga  <- actionNewAndRegister "LDBKGA"  "Load Background" (Just "Just a Stub") Nothing (justMenu MenuLoadBackground)-  -- bkgscrshta <- actionNewAndRegister "BKGSCRSHTA" "Background Screenshot" (Just "Just a Stub") Nothing (justMenu MenuBackgroundScreenshot)   defppa  <- actionNewAndRegister "DEFPPA"  "Default Paper" (Just "Just a Stub") Nothing (justMenu MenuDefaultPaper)   setdefppa <- actionNewAndRegister "SETDEFPPA" "Set As Default" (Just "Just a Stub") Nothing (justMenu MenuSetAsDefaultPaper)      -- tools menu-  linka <- actionNewAndRegister "LINKA" "Add Link" (Just "Add Link") (Just stockIndex) (justMenu MenuAddLink)+  linka <- actionNewAndRegister "LINKA" "Add Link" (Just "Add Link") (Just Gtk.stockIndex) (justMenu MenuAddLink)   anchora <- actionNewAndRegister "ANCHORA" "Add Anchor" (Just "Add Anchor") Nothing (justMenu MenuAddAnchor)   listanchora <- actionNewAndRegister "LISTANCHORA" "List Anchors" (Just "List Anchors") Nothing (justMenu MenuListAnchors)--  -- shpreca   <- actionNewAndRegister "SHPRECA" "Shape Recognizer" (Just "Just a Stub") (Just "myshapes") (justMenu MenuShapeRecognizer)-  -- rulera    <- actionNewAndRegister "RULERA" "Ruler" (Just "Just a Stub") (Just "myruler") (justMenu MenuRuler)   handreca <- actionNewAndRegister "HANDRECA" "Hoodlet load via Handwriting Recognition" (Just "Just a Stub") (Just "myshapes") (justMenu MenuHandwritingRecognitionDialog)   -  -  -- selregna  <- actionNewAndRegister "SELREGNA" "Select Region" (Just "Just a Stub") (Just "mylasso") (justMenu MenuSelectRegion)-  -- selrecta  <- actionNewAndRegister "SELRECTA" "Select Rectangle" (Just "Just a Stub") (Just "myrectselect") (justMenu MenuSelectRectangle)-  -- vertspa   <- actionNewAndRegister "VERTSPA" "Vertical Space" (Just "Just a Stub") (Just "mystretch") (justMenu MenuVerticalSpace)   clra      <- actionNewAndRegister "CLRA" "Color" (Just "Just a Stub") Nothing Nothing-  clrpcka   <- actionNewAndRegister "CLRPCKA" "Color Picker.." (Just "Just a Stub") (Just stockSelectColor) (justMenu MenuColorPicker ) +  clrpcka   <- actionNewAndRegister "CLRPCKA" "Color Picker.." (Just "Just a Stub") (Just Gtk.stockSelectColor) (justMenu MenuColorPicker )    penopta   <- actionNewAndRegister "PENOPTA" "Pen Options" (Just "Just a Stub") Nothing (justMenu MenuPenOptions)   erasropta <- actionNewAndRegister "ERASROPTA" "Eraser Options" (Just "Just a Stub") Nothing (justMenu MenuEraserOptions)   hiltropta <- actionNewAndRegister "HILTROPTA" "Highlighter Options" (Just "Just a Stub") Nothing (justMenu MenuHighlighterOptions)@@ -307,9 +325,9 @@   defhiltra <- actionNewAndRegister "DEFHILTRA" "Default Highlighter" (Just "Just a Stub") Nothing (justMenu MenuDefaultHighlighter)   deftxta   <- actionNewAndRegister "DEFTXTA" "Default Text" (Just "Just a Stub") Nothing (justMenu MenuDefaultText)   setdefopta <- actionNewAndRegister "SETDEFOPTA" "Set As Default" (Just "Just a Stub") Nothing (justMenu MenuSetAsDefaultOption)-  relauncha <- actionNewAndRegister "RELAUNCHA" "Relaunch Application" (Just "Just a Stub") Nothing (justMenu MenuRelaunch)  +   ------------------   -- version menu --   ------------------@@ -323,227 +341,242 @@   -----------------     -- option menu --   ------------------  uxinputa <- toggleActionNew "UXINPUTA" "Use XInput" (Just "Just a Stub") Nothing -  uxinputa `on` actionToggled $ do +  uxinputa <- Gtk.toggleActionNew ("UXINPUTA" :: String) "Use XInput" (Just "Just a Stub") Nothing +  uxinputa `Gtk.on` Gtk.actionToggled $ do      eventHandler evar (UsrEv (Menu MenuUseXInput))   -- handa <- actionNewAndRegister "HANDA" "Use Touch" (Just "Use touch") (Just "myhand") (justMenu MenuUseTouch)    -  handa     <- toggleActionNew "HANDA" "Use Touch" (Just "Toggle touch") (Just "myhand") -  handa `on` actionToggled $ do +  handa     <- Gtk.toggleActionNew ("HANDA" :: String) "Use Touch" (Just "Toggle touch") (Just "myhand") +  handa `Gtk.on` Gtk.actionToggled $ do      eventHandler evar (UsrEv (Menu MenuUseTouch))-  smthscra <- toggleActionNew "SMTHSCRA" "Smooth Scrolling" (Just "Just a stub") Nothing-  smthscra `on` actionToggled $ do -    eventHandler evar (UsrEv (Menu MenuSmoothScroll))-  popmenua <- toggleActionNew "POPMENUA" "Use Popup Menu" (Just "Just a stub") Nothing-  popmenua `on` actionToggled $ do +  -- smthscra <- Gtk.toggleActionNew ("SMTHSCRA" :: String) "Smooth Scrolling" (Just "Just a stub") Nothing+  -- smthscra `Gtk.on` Gtk.actionToggled $ do +  --   eventHandler evar (UsrEv (Menu MenuSmoothScroll))+  popmenua <- Gtk.toggleActionNew ("POPMENUA" :: String) "Use Popup Menu" (Just "Just a stub") Nothing+  popmenua `Gtk.on` Gtk.actionToggled $ do      eventHandler evar (UsrEv (Menu MenuUsePopUpMenu))-  ebdimga <- toggleActionNew "EBDIMGA" "Embed PNG/JPG Image" (Just "Just a stub") Nothing-  ebdimga `on` actionToggled $ do +  ebdimga <- Gtk.toggleActionNew ("EBDIMGA" :: String) "Embed PNG/JPG Image" (Just "Just a stub") Nothing+  ebdimga `Gtk.on` Gtk.actionToggled $ do      eventHandler evar (UsrEv (Menu MenuEmbedImage))-  ebdpdfa <- toggleActionNew "EBDPDFA" "Embed PDF" (Just "Just a stub") Nothing-  ebdpdfa `on` actionToggled $ do +  ebdpdfa <- Gtk.toggleActionNew ("EBDPDFA" :: String) "Embed PDF" (Just "Just a stub") Nothing+  ebdpdfa `Gtk.on` Gtk.actionToggled $ do      eventHandler evar (UsrEv (Menu MenuEmbedPDF))-  flwlnka <- toggleActionNew "FLWLNKA" "Follow Links" (Just "Just a stub") Nothing-  flwlnka `on` actionToggled $ do +  flwlnka <- Gtk.toggleActionNew ("FLWLNKA" :: String) "Follow Links" (Just "Just a stub") Nothing+  flwlnka `Gtk.on` Gtk.actionToggled $ do      eventHandler evar (UsrEv (Menu MenuFollowLinks))    -  keepratioa <- toggleActionNew "KEEPRATIOA" "Keep Aspect Ratio" (Just "Just a stub") Nothing-  keepratioa `on` actionToggled $ do +  keepratioa <- Gtk.toggleActionNew ("KEEPRATIOA" :: String) "Keep Aspect Ratio" (Just "Just a stub") Nothing+  keepratioa `Gtk.on` Gtk.actionToggled $ do      eventHandler evar (UsrEv (Menu MenuKeepAspectRatio))-  vcursora <- toggleActionNew "VCURSORA" "Use Variable Cursor" (Just "Just a stub") Nothing-  vcursora `on` actionToggled $ do +  vcursora <- Gtk.toggleActionNew ("VCURSORA" :: String) "Use Variable Cursor" (Just "Just a stub") Nothing+  vcursora `Gtk.on` Gtk.actionToggled $ do      eventHandler evar (UsrEv (Menu MenuUseVariableCursor))   -- temporary implementation (later will be as submenus with toggle action. appropriate reflection)   togclocka <- actionNewAndRegister "TOGCLOCKA" "Toggle Clock Widget"  (Just "Just a stub") Nothing (justMenu MenuToggleClockWidget)     -  dcrdcorea <- actionNewAndRegister "DCRDCOREA" "Discard Core Events" (Just "Just a Stub") Nothing (justMenu MenuDiscardCoreEvents)-  ersrtipa <- actionNewAndRegister "ERSRTIPA" "Eraser Tip" (Just "Just a Stub") Nothing (justMenu MenuEraserTip)-  pressrsensa <- toggleActionNew "PRESSRSENSA" "Pressure Sensitivity" (Just "Just a Stub") Nothing -  pressrsensa `on` actionToggled $ do +  pressrsensa <- Gtk.toggleActionNew ("PRESSRSENSA" :: String) "Pressure Sensitivity" (Just "Just a Stub") Nothing +  pressrsensa `Gtk.on` Gtk.actionToggled $ do      eventHandler evar (UsrEv (Menu MenuPressureSensitivity)) +  newpagemoda <- actionNewAndRegister "NEWPAGEMODEA" "New page mode" Nothing Nothing Nothing+#ifdef DYRE+  relauncha <- actionNewAndRegister "RELAUNCHA" "Relaunch Application" (Just "Just a Stub") Nothing (justMenu MenuRelaunch)+#else+  relauncha <- actionNewAndRegister "RELAUNCHA" "Relaunch Application" (Just "Just a Stub") Nothing (justMenu MenuDefault)+#endif -  -  -  -  pghilta <- actionNewAndRegister "PGHILTA" "Page Highlight" (Just "Just a Stub") Nothing (justMenu MenuPageHighlight)-  mltpgvwa <- actionNewAndRegister "MLTPGVWA" "Multiple Page View" (Just "Just a Stub") Nothing (justMenu MenuMultiplePageView) -  mltpga <- actionNewAndRegister "MLTPGA" "Multiple Pages" (Just "Just a Stub") Nothing (justMenu MenuMultiplePages)-  btn2mapa <- actionNewAndRegister "BTN2MAPA" "Button 2 Mapping" (Just "Just a Stub") Nothing (justMenu MenuButton2Mapping)-  btn3mapa <- actionNewAndRegister "BTN3MAPA" "Button 3 Mapping" (Just "Just a Stub") Nothing (justMenu MenuButton3Mapping)-  antialiasbmpa <- actionNewAndRegister "ANTIALIASBMPA" "Antialiased Bitmaps" (Just "Just a Stub") Nothing (justMenu MenuAntialiasedBitmaps)-  prgrsbkga <- actionNewAndRegister "PRGRSBKGA" "Progressive Backgrounds" (Just "Just a Stub") Nothing (justMenu MenuProgressiveBackgrounds)-  prntpprulea <- actionNewAndRegister "PRNTPPRULEA" "Print Paper Ruling" (Just "Just a Stub") Nothing (justMenu MenuPrintPaperRuling)-  lfthndscrbra <- actionNewAndRegister "LFTHNDSCRBRA" "Left-Handed Scrollbar" (Just "Just a Stub") Nothing (justMenu MenuLeftHandedScrollbar)-  shrtnmenua <- actionNewAndRegister "SHRTNMENUA" "Shorten Menus" (Just "Just a Stub") Nothing (justMenu MenuShortenMenus)-  autosaveprefa <- actionNewAndRegister "AUTOSAVEPREFA" "Auto-Save Preferences" (Just "Just a Stub") Nothing (justMenu MenuAutoSavePreferences)-  saveprefa <- actionNewAndRegister "SAVEPREFA" "Save Preferences" (Just "Just a Stub") Nothing (justMenu MenuSavePreferences)-  +#ifdef HUB+  huba <- actionNewAndRegister "HUBA" "Hub" (Just "Just a Stub") Nothing (justMenu MenuHub)+  -- hubsocketa <- actionNewAndRegister "HUBSOCKETA" "Hub Socket" (Just "Just a Stub") Nothing (justMenu MenuHubSocket)+#else+  huba <- actionNewAndRegister "HUBA" "Hub" (Just "Just a Stub") Nothing (justMenu MenuDefault)+  -- hubsocketa <- actionNewAndRegister "HUBSOCKETA" "Hub Socket" (Just "Just a Stub") Nothing (justMenu MenuDefault)+#endif+++  -- window menu+  addtaba <- actionNewAndRegister "ADDTABA" "Add new tab" (Just "Just a Stub") Nothing (justMenu MenuAddTab)+  -- nexttaba <- actionNewAndRegister "NEXTTABA" "Go to next tab" (Just "Just a Stub") Nothing (justMenu MenuNextTab)+  closetaba <- actionNewAndRegister "CLOSETABA" "Close current tab" (Just "Just a Stub") Nothing (justMenu MenuCloseTab)+++   -- help menu    abouta <- actionNewAndRegister "ABOUTA" "About" (Just "Just a Stub") Nothing (justMenu MenuAbout)    -- others   defaulta <- actionNewAndRegister "DEFAULTA" "Default" (Just "Default") (Just "mydefault") (justMenu MenuDefault)   -  agr <- actionGroupNew "AGR"-  mapM_ (actionGroupAddAction agr) -        [fma,ema,vma,lma,ima,pma,tma,verma,oma,hma]-  mapM_ (actionGroupAddAction agr)   +  agr <- Gtk.actionGroupNew ("AGR" :: String)+  mapM_ (Gtk.actionGroupAddAction agr) +        [fma,ema,vma,lma,ima,pma,tma,verma,oma,wma,hma]+  mapM_ (Gtk.actionGroupAddAction agr)            [ undoa, redoa, cuta, copya, pastea, deletea ] -  mapM_ (\act -> actionGroupAddActionWithAccel agr act Nothing)   +  mapM_ (\act -> Gtk.actionGroupAddActionWithAccel agr act (Nothing :: Maybe String))            [ newa, annpdfa, opena, savea, saveasa         , reloada, recenta, printa, exporta, synca, versiona, showreva, showida, quita         , fscra, zooma, zmina, zmouta, nrmsizea, pgwdtha, pgheighta, setzma-        , fstpagea, prvpagea, nxtpagea, lstpagea {- , shwlayera, hidlayera -}+        , fstpagea, prvpagea, nxtpagea, lstpagea          , hsplita, vsplita, delcvsa         , newpgba, newpgaa, newpgea, delpga, expsvga, newlyra, nextlayera, prevlayera, gotolayera, dellyra, ppsizea, ppclra         , ppstya          , apallpga, embedbkgpdfa, defppa, setdefppa-        , ldpnga, ldsvga, texta, textsrca, editsrca, editnetsrca, textfromsrca-        , latexa, latexneta, combinelatexa, latexfromsrca+        , ldpnga, ldsvga, ldimgbkga, texta, textsrca, editsrca, editnetsrca, textfromsrca+        , latexa, latexneta, combinelatexa, latexfromsrca, updatelatexa         , ldpreimga, ldpreimg2a, ldpreimg3a-        , linka, anchora, listanchora, {- shpreca, rulera, -} handreca, clra, clrpcka, penopta +        , linka, anchora, listanchora, handreca, clra, clrpcka, penopta          , erasropta, hiltropta, txtfnta, defpena, defersra, defhiltra, deftxta-        , setdefopta, relauncha-        , togpanzooma, toglayera, togclocka-        , dcrdcorea, ersrtipa, pghilta, mltpgvwa-        , mltpga, btn2mapa, btn3mapa, antialiasbmpa, prgrsbkga, prntpprulea -        , lfthndscrbra, shrtnmenua, autosaveprefa, saveprefa +        , setdefopta+        , togpanzooma, togscra, toglayera, togclocka, newpagemoda, relauncha+        , huba -- , hubsocketa+        , addtaba, {- nexttaba, -} closetaba         , abouta          , defaulta                  ]      -  mapM_ (actionGroupAddAction agr) -    [ uxinputa, handa, smthscra, popmenua, ebdimga, ebdpdfa, flwlnka, keepratioa, pressrsensa-    , vcursora ]-  -- actionGroupAddRadioActions agr viewmods 0 (assignViewMode evar)+  mapM_ (Gtk.actionGroupAddAction agr) +    [ togglenetsrca, uxinputa, handa, popmenua, ebdimga, ebdpdfa, flwlnka+    , keepratioa, pressrsensa, vcursora ]+   mpgmodconnid <- -    actionGroupAddRadioActionsAndGetConnID agr viewmods 0 (assignViewMode evar) -- const (return ()))+    actionGroupAddRadioActionsAndGetConnID agr viewmods 0 (assignViewMode evar)   _mpointconnid <-      actionGroupAddRadioActionsAndGetConnID agr pointmods 0 (assignPoint evar)   mpenmodconnid <-      actionGroupAddRadioActionsAndGetConnID agr penmods   0 (assignPenMode evar)-  _mcolorconnid <-  +  mcolorconnid <-       actionGroupAddRadioActionsAndGetConnID agr colormods 0 (assignColor evar) -  actionGroupAddRadioActions agr bkgstyles 2 (assignBkgStyle evar)-  +  _mbkgstyconnid <-+    actionGroupAddRadioActionsAndGetConnID agr bkgstyles 2 (assignBkgStyle evar)+  mnpgmodconnid <- +    actionGroupAddRadioActionsAndGetConnID agr newpagemods 0 (assignNewPageMode evar)+      let disabledActions =          [ recenta, printa         , cuta, copya, deletea         ,  setzma-        {- , shwlayera, hidlayera -}         , newpgea, ppsizea, ppclra         , defppa, setdefppa-        -- , shpreca, rulera          , erasropta, hiltropta, txtfnta, defpena, defersra, defhiltra, deftxta         , setdefopta-        , dcrdcorea, ersrtipa, pghilta, mltpgvwa-        , mltpga, btn2mapa, btn3mapa, antialiasbmpa, prgrsbkga, prntpprulea -        , lfthndscrbra, shrtnmenua, autosaveprefa, saveprefa -        , abouta +        , abouta         , defaulta         +#ifndef DYRE+        , relauncha+#endif+#ifndef HUB+        , editnetsrca+        , huba+#endif         ]        enabledActions =          [ opena, savea, saveasa, reloada, versiona, showreva, showida, quita         , pastea, fstpagea, prvpagea, nxtpagea, lstpagea         , clra, penopta, zooma, nrmsizea, pgwdtha, texta  +        , newpagemoda         ]   ---  mapM_ (\x->actionSetSensitive x True) enabledActions  -  mapM_ (\x->actionSetSensitive x False) disabledActions+  mapM_ (\x->Gtk.actionSetSensitive x True) enabledActions  +  mapM_ (\x->Gtk.actionSetSensitive x False) disabledActions   --   --    -- radio actions   ---  ui <- uiManagerNew+  ui <- Gtk.uiManagerNew      uiDecl <- readFile (resDir </> "menu.xml")   -  uiManagerAddUiFromString ui uiDecl-  uiManagerInsertActionGroup ui agr 0 -  Just ra2 <- actionGroupGetAction agr "PENFINEA"-  Gtk.set (castToRadioAction ra2) [radioActionCurrentValue := 2]-  Just ra3 <- actionGroupGetAction agr "SELREGNA"-  actionSetSensitive ra3 True -  Just ra4 <- actionGroupGetAction agr "VERTSPA"-  actionSetSensitive ra4 True-  -- Just ra5 <- actionGroupGetAction agr "HANDA"-  -- actionSetSensitive ra5 False-  Just ra6 <- actionGroupGetAction agr "CONTA"-  actionSetSensitive ra6 True-  Just _ra7 <- actionGroupGetAction agr "PENA"-  actionSetSensitive ra6 True  -  Just toolbar1 <- uiManagerGetWidget ui "/ui/toolbar1"-  toolbarSetStyle (castToToolbar toolbar1) ToolbarIcons -  toolbarSetIconSize (castToToolbar toolbar1) IconSizeSmallToolbar-  Just toolbar2 <- uiManagerGetWidget ui "/ui/toolbar2"-  toolbarSetStyle (castToToolbar toolbar2) ToolbarIcons -  toolbarSetIconSize (castToToolbar toolbar2) IconSizeSmallToolbar  -  -  -- Just pendropdown <- uiManagerGetWidget ui "/ui/toolbar2/PENDROPDOWN"-  -  +  Gtk.uiManagerAddUiFromString ui uiDecl+  Gtk.uiManagerInsertActionGroup ui agr 0 +  Just ra2 <- Gtk.actionGroupGetAction agr ("PENFINEA" :: String)+  Gtk.set (Gtk.castToRadioAction ra2) [Gtk.radioActionCurrentValue Gtk.:= 2]+  Just ra3 <- Gtk.actionGroupGetAction agr ("SELREGNA" :: String)+  Gtk.actionSetSensitive ra3 True +  Just ra4 <- Gtk.actionGroupGetAction agr ("VERTSPA" :: String)+  Gtk.actionSetSensitive ra4 True+  Just ra6 <- Gtk.actionGroupGetAction agr ("CONTA" :: String)+  Gtk.actionSetSensitive ra6 True+  Just _ra7 <- Gtk.actionGroupGetAction agr ("PENA" :: String)+  Gtk.actionSetSensitive ra6 True  +  Just toolbar1 <- Gtk.uiManagerGetWidget ui ("/ui/toolbar1" :: String)+  Gtk.toolbarSetStyle (Gtk.castToToolbar toolbar1) Gtk.ToolbarIcons +#ifndef GTK3+  Gtk.toolbarSetIconSize (Gtk.castToToolbar toolbar1) Gtk.IconSizeSmallToolbar+#endif +  Just toolbar2 <- Gtk.uiManagerGetWidget ui ("/ui/toolbar2" :: String)+  Gtk.toolbarSetStyle (Gtk.castToToolbar toolbar2) Gtk.ToolbarIcons +#ifndef GTK3+  Gtk.toolbarSetIconSize (Gtk.castToToolbar toolbar2) Gtk.IconSizeSmallToolbar  +#endif +       let uicomponentsignalhandler = set penModeSignal mpenmodconnid                                   . set pageModeSignal mpgmodconnid +                                 . set penColorSignal mcolorconnid+                                 . set newPageModeSignal mnpgmodconnid                                  $ defaultUIComponentSignalHandler    return (ui,uicomponentsignalhandler)      -- |-actionGroupAddRadioActionsAndGetConnID :: ActionGroup -                                       -> [RadioActionEntry]+actionGroupAddRadioActionsAndGetConnID :: Gtk.ActionGroup +                                       -> [Gtk.RadioActionEntry]                                        -> Int  -                                       -> (RadioAction -> IO ()) -                                       -> IO (Maybe (ConnectId RadioAction))+                                       -> (Gtk.RadioAction -> IO ()) +                                       -> IO (Maybe (Gtk.ConnectId Gtk.RadioAction)) actionGroupAddRadioActionsAndGetConnID self entries _value onChange = do    mgroup <- foldM -    (\mgroup (n,RadioActionEntry name label stockId accelerator tooltip value) -> do-     action <- radioActionNew name label tooltip stockId value-     case mgroup of -       Nothing -> return () -       Just gr -> radioActionSetGroup action gr-     when (n==value) (toggleActionSetActive action True)-     actionGroupAddActionWithAccel self action accelerator+    (\mgroup (n,Gtk.RadioActionEntry name label stockId accelerator tooltip value) -> do+     action <- Gtk.radioActionNew name label tooltip stockId value+     F.forM_ mgroup $ \gr -> Gtk.radioActionSetGroup action gr+     when (n==value) (Gtk.toggleActionSetActive action True)+     Gtk.actionGroupAddActionWithAccel self action accelerator      return (Just action))     Nothing (zip [0..] entries)   case mgroup of      Nothing -> return Nothing      Just gr -> do -      connid <- (gr `on` radioActionChanged) onChange+      connid <- (gr `Gtk.on` Gtk.radioActionChanged) onChange       return (Just connid)   -- | -assignViewMode :: EventVar -> RadioAction -> IO ()+assignViewMode :: EventVar -> Gtk.RadioAction -> IO () assignViewMode evar a = viewModeToUserEvent a >>= eventHandler evar . UsrEv      -- | -assignPenMode :: EventVar -> RadioAction -> IO ()+assignPenMode :: EventVar -> Gtk.RadioAction -> IO () assignPenMode evar a = do -    v <- radioActionGetCurrentValue a+    v <- Gtk.radioActionGetCurrentValue a     eventHandler evar (UsrEv (AssignPenMode (int2PenType v)))         -- | -assignColor :: EventVar -> RadioAction -> IO () +assignColor :: EventVar -> Gtk.RadioAction -> IO ()  assignColor evar a = do -    v <- radioActionGetCurrentValue a+    v <- Gtk.radioActionGetCurrentValue a     let c = int2Color v     eventHandler evar (UsrEv (PenColorChanged c))  -- | -assignPoint :: EventVar -> RadioAction -> IO ()  +assignPoint :: EventVar -> Gtk.RadioAction -> IO ()   assignPoint evar a = do -    v <- radioActionGetCurrentValue a+    v <- Gtk.radioActionGetCurrentValue a     eventHandler evar (UsrEv (PenWidthChanged v))   -- | -assignBkgStyle :: EventVar -> RadioAction -> IO ()+assignBkgStyle :: EventVar -> Gtk.RadioAction -> IO () assignBkgStyle evar a = do -    v <- radioActionGetCurrentValue a +    v <- Gtk.radioActionGetCurrentValue a      let sty = int2BkgStyle v      eventHandler evar (UsrEv (BackgroundStyleChanged sty))  -- | +assignNewPageMode :: EventVar -> Gtk.RadioAction -> IO ()+assignNewPageMode evar a = do +    v <- Gtk.radioActionGetCurrentValue a+    eventHandler evar (UsrEv (AssignNewPageMode (int2NewPageMode v)))+++-- |  int2PenType :: Int -> Either PenType SelectType  int2PenType 0 = Left PenWork int2PenType 1 = Left EraserWork@@ -656,3 +689,17 @@ int2BkgStyle 2 = BkgStyleRuled int2BkgStyle 3 = BkgStyleGraph int2BkgStyle _ = BkgStyleRuled +++-- | +int2NewPageMode :: Int -> NewPageModeType+int2NewPageMode 0 = NPPlain+int2NewPageMode 1 = NPLast+int2NewPageMode 2 = NPCycle+int2NewPageMode _ = error "No such new page mode"++-- |+newPageMode2Int :: NewPageModeType -> Int+newPageMode2Int NPPlain = 0+newPageMode2Int NPLast  = 1+newPageMode2Int NPCycle = 2
src/Hoodle/GUI/Reflect.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -7,7 +8,7 @@ -- Module      : Hoodle.GUI.Reflect -- Copyright   : (c) 2013, 2014 Ian-Woo Kim ----- License     : GPL-3+-- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com> -- Stability   : experimental -- Portability : GHC@@ -16,85 +17,85 @@  module Hoodle.GUI.Reflect where -import           Control.Lens (view,Simple,Lens)-import           Control.Monad (liftM, when)-import qualified Control.Monad.State as St-import           Control.Monad.Trans +import           Control.Lens (view, Simple,Lens, (^.), (.~), _1,_2,_3)+import           Control.Monad.State as St import           Data.Array.MArray-import           Data.Foldable (forM_)+import qualified Data.Foldable as F (forM_,mapM_)  import qualified Data.Map as M (lookup) import           Data.Word-import           Graphics.UI.Gtk hiding (get,set)-import qualified Graphics.UI.Gtk as Gtk (set)+import qualified Graphics.UI.Gtk as Gtk ---import Hoodle.GUI.Menu -import Hoodle.Coroutine.Draw-import Hoodle.Type.Canvas-import Hoodle.Type.Coroutine-import Hoodle.Type.Enum -import Hoodle.Type.Event-import Hoodle.Type.HoodleState-import Hoodle.Type.PageArrangement-import Hoodle.Type.Predefined -import Hoodle.Util -import Hoodle.View.Coordinate+import           Hoodle.Accessor+import           Hoodle.Coroutine.Draw+import           Hoodle.GUI.Menu +import           Hoodle.Type.Canvas+import           Hoodle.Type.Coroutine+import           Hoodle.Type.Enum +import           Hoodle.Type.Event+import           Hoodle.Type.HoodleState+import           Hoodle.Type.PageArrangement+import           Hoodle.Type.Predefined +import           Hoodle.Util +import           Hoodle.View.Coordinate -- -import Debug.Trace+-- import Debug.Trace  -- | -changeCurrentCanvasId :: CanvasId -> MainCoroutine HoodleState +changeCurrentCanvasId :: CanvasId -> MainCoroutine UnitHoodle changeCurrentCanvasId cid = do -    xstate1 <- St.get-    maybe (return xstate1) -          (\xst -> do St.put xst -                      return xst)-          (setCurrentCanvasId cid xstate1)-    reflectViewModeUI-    St.get     +    xst <- St.get+    let uhdl = view (unitHoodles.currentUnit) xst+    case setCurrentCanvasId cid uhdl of+      Nothing -> return uhdl+      Just uhdl' -> do +        pureUpdateUhdl (const uhdl')+        reflectViewModeUI+        return uhdl' + -- | check current canvas id and new active canvas id and invalidate if it's  --   changed.  chkCvsIdNInvalidate :: CanvasId -> MainCoroutine ()  chkCvsIdNInvalidate cid = do -  currcid <- liftM (getCurrentCanvasId) St.get +  currcid <- liftM (getCurrentCanvasId . view (unitHoodles.currentUnit) ) St.get    when (currcid /= cid) (changeCurrentCanvasId cid >> invalidateAll) +-- | block signal for act+blockWhile :: (Gtk.GObjectClass w) => Maybe (Gtk.ConnectId w) -> IO () -> IO ()+blockWhile msig act = do+    F.mapM_ (\_ -> print "signal will be blocked") msig+    F.mapM_ Gtk.signalBlock msig >> act >> F.mapM_ Gtk.signalUnblock msig -blockWhile :: (GObjectClass w) => Maybe (ConnectId w) -> IO () -> IO ()-blockWhile msig act = -  maybe (return ()) signalBlock msig-  >> act -  >> maybe (return ()) signalUnblock msig-    -- | reflect view mode UI for current canvas info  reflectViewModeUI :: MainCoroutine () reflectViewModeUI = do      xstate <- St.get-    let cinfobox = view currentCanvasInfo xstate -        ui = view gtkUIManager xstate       +    let uhdl = view (unitHoodles.currentUnit) xstate+        cinfobox = view currentCanvasInfo uhdl+        ui = view gtkUIManager xstate     let mconnid = view (uiComponentSignalHandler.pageModeSignal) xstate-    agr <- liftIO $ uiManagerGetActionGroups ui+    agr <- liftIO $ Gtk.uiManagerGetActionGroups ui     ra1 <- maybe (error "reflectUI") return =<< -             liftIO (actionGroupGetAction (head agr) "ONEPAGEA")-    let wra1 = castToRadioAction ra1 +             liftIO (Gtk.actionGroupGetAction (head agr) "ONEPAGEA")+    let wra1 = Gtk.castToRadioAction ra1      unboxBiAct (pgmodupdate_s mconnid wra1) (pgmodupdate_c mconnid wra1) cinfobox      return ()   where pgmodupdate_s mconnid wra1 _cinfo = do           liftIO $ blockWhile mconnid $-                     Gtk.set wra1 [radioActionCurrentValue := 1 ] +                     Gtk.set wra1 [Gtk.radioActionCurrentValue Gtk.:= 1 ]          pgmodupdate_c mconnid wra1 _cinfo = do           liftIO $ blockWhile mconnid $ -                     Gtk.set wra1 [radioActionCurrentValue := 0 ] +                     Gtk.set wra1 [Gtk.radioActionCurrentValue Gtk.:= 0 ]   -- |  reflectPenModeUI :: MainCoroutine () reflectPenModeUI = do -    reflectUIComponent penModeSignal "PENA" f-    reflectCursor+    reflectUIRadio penModeSignal "PENA" f+    reflectCursor False   where      f xst = Just $-      hoodleModeStateEither (view hoodleModeState xst) #  +      hoodleModeStateEither ((view hoodleModeState . view (unitHoodles.currentUnit)) xst) #           either (\_ -> (penType2Int. Left .view (penInfo.penType)) xst)                (\_ -> (penType2Int. Right .view (selectInfo.selectType)) xst) @@ -102,8 +103,8 @@ -- |  reflectPenColorUI :: MainCoroutine ()  reflectPenColorUI = do -    reflectUIComponent penColorSignal "BLUEA" f-    reflectCursor+    reflectUIRadio penColorSignal "BLUEA" f+    reflectCursor False   where      f xst =        let mcolor = @@ -117,8 +118,8 @@ -- |  reflectPenWidthUI :: MainCoroutine ()  reflectPenWidthUI = do -    reflectUIComponent penPointSignal "PENVERYFINEA" f-    reflectCursor+    reflectUIRadio penPointSignal "PENVERYFINEA" f+    reflectCursor False   where      f xst =        case view (penInfo.penType) xst of @@ -127,103 +128,125 @@         HighlighterWork ->            let x = (Just . point2Int HighlighterWork                              . view (penInfo.penSet.currHighlighter.penWidth)) xst-              y = view (penInfo.penSet.currHighlighter.penWidth) xst-          in trace (" x= " ++ show x ++ " y = " ++ show y ) x +              -- y = view (penInfo.penSet.currHighlighter.penWidth) xst+          in x          EraserWork -> (Just . point2Int EraserWork                         . view (penInfo.penSet.currEraser.penWidth)) xst         _ -> Nothing  +-- |+reflectNewPageModeUI :: MainCoroutine ()+reflectNewPageModeUI = +    reflectUIRadio newPageModeSignal "NEWPAGEPLAINA" (Just . newPageMode2Int . (^. settings.newPageMode))+ -- | -reflectUIComponent :: Simple Lens UIComponentSignalHandler (Maybe (ConnectId RadioAction))-                   -> String -                   -> (HoodleState -> Maybe Int)   -                   -> MainCoroutine ()-reflectUIComponent lnz name f = do +reflectUIRadio :: Simple Lens UIComponentSignalHandler (Maybe (Gtk.ConnectId Gtk.RadioAction))+               -> String +               -> (HoodleState -> Maybe Int)   +               -> MainCoroutine ()+reflectUIRadio lnz name f = do      xst <- St.get      let ui = view gtkUIManager xst          mconnid = view (uiComponentSignalHandler.lnz) xst -    agr <- liftIO $ uiManagerGetActionGroups ui -    Just pma <- liftIO $ actionGroupGetAction (head agr) name -    let wpma = castToRadioAction pma +    agr <- liftIO $ Gtk.uiManagerGetActionGroups ui +    Just pma <- liftIO $ Gtk.actionGroupGetAction (head agr) name +    let wpma = Gtk.castToRadioAction pma      update xst wpma mconnid      where update xst wpma mconnid  = do            (f xst) # -            (maybe (return ()) $ \v -> do-              doIOaction $ \_evhandler -> do -                    blockWhile mconnid -                      (Gtk.set wpma [radioActionCurrentValue := v ] )-                    return (UsrEv ActionOrdered)-              go)-         where go = do r <- nextevent-                       case r of-                         ActionOrdered -> return ()-                         _ -> go +            (maybe (return ()) $ \v ->+              doIOaction_ $ blockWhile mconnid (Gtk.set wpma [Gtk.radioActionCurrentValue Gtk.:= v ] )+            ) ++-- | this function must be moved to GUI.Reflect+reflectUIToggle :: Gtk.UIManager -> String -> Bool -> IO ()+reflectUIToggle ui str b = do +    agr <- Gtk.uiManagerGetActionGroups ui >>= \x -> +      case x of+        [] -> error "No action group?"+        y:_ -> return y+    Just savea <- Gtk.actionGroupGetAction agr str -- ("SAVEA" :: String)+    Gtk.actionSetSensitive savea b+ -- | -reflectCursor :: MainCoroutine () -reflectCursor = do +reflectCursor :: Bool -> MainCoroutine () +reflectCursor isforced = do      xst <- St.get -    let useVCursor = view (settings.doesUseVariableCursor) xst -    let go = do r <- nextevent -                case r of-                  ActionOrdered -> return ()-                  _ -> go -    if useVCursor -      then -        act xst >> go -      else do -        doIOaction $ \_ -> do-          let cinfobox   = view currentCanvasInfo xst           -              canvas     = forBoth' unboxBiAct (view drawArea) cinfobox           -          win <- widgetGetDrawWindow canvas-          postGUIAsync (drawWindowSetCursor win Nothing) -          return (UsrEv ActionOrdered)-        go - where act xst = doIOaction $ \_ -> do -         let -- mcur       = view cursorInfo xst -             cinfobox   = view currentCanvasInfo xst -             canvas     = forBoth' unboxBiAct (view drawArea) cinfobox -             cpn        = PageNum $ -                            forBoth' unboxBiAct (view currentPageNum) cinfobox-             pinfo = view penInfo xst -             pcolor = view (penSet . currPen . penColor) pinfo-             pwidth = view (penSet . currPen . penWidth) pinfo -         win <- widgetGetDrawWindow canvas-         dpy <- widgetGetDisplay canvas  -         -         geometry <- -           forBoth' unboxBiAct (\c -> let arr = view (viewInfo.pageArrangement) c-                                      in makeCanvasGeometry cpn arr canvas-                               ) cinfobox-         let p2c = desktop2Canvas geometry . page2Desktop geometry-             CvsCoord (x0,_y0) = p2c (cpn, PageCoord (0,0))  -             CvsCoord (x1,_y1) = p2c (cpn, PageCoord (pwidth,pwidth))-             cursize = (x1-x0) -             (r,g,b,a) = case pcolor of  -                           ColorRGBA r' g' b' a' -> (r',g',b',a')-                           _ -> maybe (0,0,0,1) id (M.lookup pcolor penColorRGBAmap)-         pb <- pixbufNew ColorspaceRgb True 8 maxCursorWidth maxCursorHeight -         let numPixels = maxCursorWidth*maxCursorHeight-         pbData <- (pixbufGetPixels pb :: IO (PixbufData Int Word8))-         forM_ [0..numPixels-1] $ \i -> do -           let cvt :: Double -> Word8-               cvt x | x < 0.0039 = 0-                     | x > 0.996  = 255-                     | otherwise  = fromIntegral (floor (x*256-1) `mod` 256 :: Int)-           if (fromIntegral (i `mod` maxCursorWidth)) < cursize -              && (fromIntegral (i `div` maxCursorWidth)) < cursize -             then do -               writeArray pbData (4*i)   (cvt r)-               writeArray pbData (4*i+1) (cvt g)                  -               writeArray pbData (4*i+2) (cvt b)-               writeArray pbData (4*i+3) (cvt a)-             else do-               writeArray pbData (4*i)   0-               writeArray pbData (4*i+1) 0-               writeArray pbData (4*i+2) 0-               writeArray pbData (4*i+3) 0-            -         postGUIAsync . drawWindowSetCursor win . Just =<< -           cursorNewFromPixbuf dpy pb -             (floor cursize `div` 2) (floor cursize `div` 2)-         return (UsrEv ActionOrdered)+    let b = view (settings.doesUseVariableCursor) xst+        pinfo = view penInfo xst +        pcolor = view (penSet . currPen . penColor) pinfo+        pwidth = view (penSet . currPen . penWidth) pinfo +        cinfo = view cursorInfo xst+        (ccolor,cwidth,cvar) = cinfo+    when (pcolor /= ccolor || pwidth /= cwidth || b /= cvar || isforced) $ do+      msgShout "reflectCursor: change cursor"+      put . (cursorInfo._1 .~ pcolor) . (cursorInfo._2 .~ pwidth) . (cursorInfo._3 .~ b) $ xst +      doIOaction_ $ if b  +                      then varyCursor xst +                      else do let uhdl       = view (unitHoodles.currentUnit) xst+                                  cinfobox   = view currentCanvasInfo uhdl           +                                  canvas     = forBoth' unboxBiAct (view drawArea) cinfobox+#ifdef GTK3+                              Just win <- Gtk.widgetGetWindow canvas+#else+                              win <- Gtk.widgetGetDrawWindow canvas+#endif+                              Gtk.postGUIAsync (Gtk.drawWindowSetCursor win Nothing) +                              return (UsrEv ActionOrdered)+ where +   varyCursor xst = do +     putStrLn "reflectCursor : inside act"++     -- Gtk.postGUIAsync $ do +     let uhdl = view (unitHoodles.currentUnit) xst+         -- mcur       = view cursorInfo xst +         cinfobox   = view currentCanvasInfo uhdl+         canvas     = forBoth' unboxBiAct (view drawArea) cinfobox +         cpn        = PageNum $ +                        forBoth' unboxBiAct (view currentPageNum) cinfobox+         pinfo = view penInfo xst +         pcolor = view (penSet . currPen . penColor) pinfo+         pwidth = view (penSet . currPen . penWidth) pinfo +#ifdef GTK3+     Just win <- Gtk.widgetGetWindow canvas+#else+     win <- Gtk.widgetGetDrawWindow canvas+#endif+     dpy <- Gtk.widgetGetDisplay canvas  ++     geometry <- +       forBoth' unboxBiAct (\c -> let arr = view (viewInfo.pageArrangement) c+                                  in makeCanvasGeometry cpn arr canvas+                           ) cinfobox+     let p2c = desktop2Canvas geometry . page2Desktop geometry+         CvsCoord (x0,_y0) = p2c (cpn, PageCoord (0,0))  +         CvsCoord (x1,_y1) = p2c (cpn, PageCoord (pwidth,pwidth))+         cursize = (x1-x0) +         (r,g,b,a) = case pcolor of  +                       ColorRGBA r' g' b' a' -> (r',g',b',a')+                       _ -> maybe (0,0,0,1) id (M.lookup pcolor penColorRGBAmap)+     pb <- Gtk.pixbufNew Gtk.ColorspaceRgb True 8 maxCursorWidth maxCursorHeight +     let numPixels = maxCursorWidth*maxCursorHeight+     pbData <- (Gtk.pixbufGetPixels pb :: IO (Gtk.PixbufData Int Word8))+     F.forM_ [0..numPixels-1] $ \i -> do +       let cvt :: Double -> Word8+           cvt x | x < 0.0039 = 0+                 | x > 0.996  = 255+                 | otherwise  = fromIntegral (floor (x*256-1) `mod` 256 :: Int)+       if (fromIntegral (i `mod` maxCursorWidth)) < cursize +          && (fromIntegral (i `div` maxCursorWidth)) < cursize +         then do +           writeArray pbData (4*i)   (cvt r)+           writeArray pbData (4*i+1) (cvt g)                  +           writeArray pbData (4*i+2) (cvt b)+           writeArray pbData (4*i+3) (cvt a)+         else do+           writeArray pbData (4*i)   0+           writeArray pbData (4*i+1) 0+           writeArray pbData (4*i+2) 0+           writeArray pbData (4*i+3) 0++     Gtk.drawWindowSetCursor win . Just =<< +       Gtk.cursorNewFromPixbuf dpy pb (floor cursize `div` 2) (floor cursize `div` 2)+     return (UsrEv ActionOrdered)
src/Hoodle/ModelAction/Adjustment.hs view
@@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      : Hoodle.ModelAction.Adjustment --- Copyright   : (c) 2011, 2012 Ian-Woo Kim+-- Copyright   : (c) 2011,2012,2014 Ian-Woo Kim -- -- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>@@ -13,7 +13,8 @@ module Hoodle.ModelAction.Adjustment where  -- from other package-import Graphics.UI.Gtk +import qualified Data.Foldable as F (mapM_)+import qualified Graphics.UI.Gtk as Gtk -- from hoodle-platform  import Data.Hoodle.BBox (BBox(..)) import Data.Hoodle.Simple (Dimension(..))@@ -24,31 +25,30 @@ -- | adjust values, upper limit and page size according to canvas geometry   adjustScrollbarWithGeometry :: CanvasGeometry -                               -> ((Adjustment,Maybe (ConnectId Adjustment))-                                  ,(Adjustment,Maybe (ConnectId Adjustment))) +                               -> ((Gtk.Adjustment,Maybe (Gtk.ConnectId Gtk.Adjustment))+                                  ,(Gtk.Adjustment,Maybe (Gtk.ConnectId Gtk.Adjustment)))                                 -> IO () adjustScrollbarWithGeometry geometry ((hadj,mconnidh),(vadj,mconnidv)) = do    let DesktopDimension (Dim w h) = desktopDim geometry        ViewPortBBox (BBox (x0,y0) (x1,y1)) = canvasViewPort geometry        xsize = x1-x0       ysize = y1-y0 -  maybe (return ()) signalBlock mconnidh-  maybe (return ()) signalBlock mconnidv-  adjustmentSetUpper hadj w -  adjustmentSetUpper vadj h -  adjustmentSetValue hadj x0 -  adjustmentSetValue vadj y0-  adjustmentSetPageSize hadj xsize -- (min xsize w)-  adjustmentSetPageSize vadj ysize --  (min ysize h)-  adjustmentSetPageIncrement hadj (xsize*0.9)-  adjustmentSetPageIncrement vadj (ysize*0.9)-  maybe (return ()) signalUnblock mconnidh-  maybe (return ()) signalUnblock mconnidv+  F.mapM_ Gtk.signalBlock mconnidh+  F.mapM_ Gtk.signalBlock mconnidv+  Gtk.adjustmentSetUpper hadj w +  Gtk.adjustmentSetUpper vadj h +  Gtk.adjustmentSetValue hadj x0 +  Gtk.adjustmentSetValue vadj y0+  Gtk.adjustmentSetPageSize hadj xsize -- (min xsize w)+  Gtk.adjustmentSetPageSize vadj ysize --  (min ysize h)+  Gtk.adjustmentSetPageIncrement hadj (xsize*0.9)+  Gtk.adjustmentSetPageIncrement vadj (ysize*0.9)+  F.mapM_ Gtk.signalUnblock mconnidh+  F.mapM_ Gtk.signalUnblock mconnidv  -- | --setAdjustments :: ((Adjustment,Maybe (ConnectId Adjustment))-                  ,(Adjustment,Maybe (ConnectId Adjustment))) +setAdjustments :: ((Gtk.Adjustment,Maybe (Gtk.ConnectId Gtk.Adjustment))+                  ,(Gtk.Adjustment,Maybe (Gtk.ConnectId Gtk.Adjustment)))                    -> (Double,Double)                    -> (Double,Double)                   -> (Double,Double) @@ -57,18 +57,18 @@ setAdjustments ((hadj,mconnidh),(vadj,mconnidv))                 (upperx,uppery) (lowerx,lowery)                 (valuex,valuey) (pagex,pagey) = do -    maybe (return ()) signalBlock mconnidh-    maybe (return ()) signalBlock mconnidv-    adjustmentSetUpper hadj upperx -    adjustmentSetUpper vadj uppery -    adjustmentSetLower hadj lowerx-    adjustmentSetLower vadj lowery-    adjustmentSetValue hadj valuex-    adjustmentSetValue vadj valuey -    adjustmentSetPageSize hadj pagex-    adjustmentSetPageSize vadj pagey-    maybe (return ()) signalUnblock mconnidh-    maybe (return ()) signalUnblock mconnidv+    F.mapM_ Gtk.signalBlock mconnidh+    F.mapM_ Gtk.signalBlock mconnidv+    Gtk.adjustmentSetUpper hadj upperx +    Gtk.adjustmentSetUpper vadj uppery +    Gtk.adjustmentSetLower hadj lowerx+    Gtk.adjustmentSetLower vadj lowery+    Gtk.adjustmentSetValue hadj valuex+    Gtk.adjustmentSetValue vadj valuey +    Gtk.adjustmentSetPageSize hadj pagex+    Gtk.adjustmentSetPageSize vadj pagey+    F.mapM_ Gtk.signalUnblock mconnidh+    F.mapM_ Gtk.signalUnblock mconnidv
src/Hoodle/ModelAction/Clipboard.hs view
@@ -20,7 +20,7 @@ import qualified Data.ByteString.Base64 as B64  import qualified Data.ByteString.Char8 as C8 import qualified Data.Serialize as Se -import           Graphics.UI.Gtk hiding (get,set)+import qualified Graphics.UI.Gtk as Gtk -- from hoodle-platform  import           Data.Hoodle.Simple -- import           Graphics.Hoodle.Render.Type@@ -37,12 +37,10 @@   | null itms = return xstate   | otherwise = do      let ui = view gtkUIManager xstate-    hdltag <- atomNew "hoodle"-    -- tgttag <- atomNew "Stroke"-    -- seltag <- atomNew "Stroke"-    clipbd <- clipboardGet hdltag+    hdltag <- Gtk.atomNew "hoodle"+    clipbd <- Gtk.clipboardGet hdltag     let bstr = C8.unpack . B64.encode . Se.encode $ itms -    clipboardSetText clipbd bstr+    Gtk.clipboardSetText clipbd bstr     togglePaste ui True      case (view hookSet xstate) of        Nothing -> return ()
src/Hoodle/ModelAction/ContextMenu.hs view
@@ -1,11 +1,13 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}  ----------------------------------------------------------------------------- -- | -- Module      : Hoodle.ModelAction.ContextMenu--- Copyright   : (c) 2011-2014 Ian-Woo Kim+-- Copyright   : (c) 2011-2015 Ian-Woo Kim ----- License     : GPL-3+-- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com> -- Stability   : experimental -- Portability : GHC@@ -14,17 +16,20 @@  module Hoodle.ModelAction.ContextMenu where -import           Control.Concurrent (forkIO, threadDelay) import qualified Data.ByteString.Char8 as B-import           Data.Foldable (forM_) import           Data.UUID.V4-import           DBus -import           DBus.Client  import qualified Graphics.Rendering.Cairo as Cairo-import           Graphics.UI.Gtk+import qualified Graphics.UI.Gtk as Gtk import           System.Directory  import           System.FilePath +#ifdef HUB+import           Control.Concurrent (forkIO, threadDelay)+import           Control.Exception+import           Data.Foldable (forM_)+import           DBus +import           DBus.Client  import           System.Process+#endif --  import           Data.Hoodle.BBox import           Data.Hoodle.Simple@@ -35,56 +40,58 @@ import Hoodle.Util  -- |-menuOpenALink :: UrlPath -> IO MenuItem-menuOpenALink urlpath = do +menuOpenALink :: (AllEvent -> IO ()) -> UrlPath -> IO Gtk.MenuItem+menuOpenALink evhandler urlpath = do      let urlname = case urlpath of                      FileUrl fp -> fp                      HttpUrl url -> url -    menuitemlnk <- menuItemNewWithLabel ("Open "++urlname) -    menuitemlnk `on` menuItemActivate $ openLinkAction urlpath Nothing+    menuitemlnk <- Gtk.menuItemNewWithLabel ("Open "++urlname :: String) +    menuitemlnk `Gtk.on` Gtk.menuItemActivate $ evhandler (UsrEv (OpenLink urlpath Nothing))      return menuitemlnk - -- | -openLinkAction :: UrlPath +#ifdef HUB+openLinkActionDBus :: UrlPath                 -> Maybe (B.ByteString,B.ByteString) -- ^ (docid,anchorid)                -> IO () -openLinkAction urlpath mid = do-    cli <- connectSession-    case urlpath of -      FileUrl fp -> do -        putStrLn "test dbus"-        emit cli (signal "/" "org.ianwookim.hoodle" "findWindow") -                   { signalBody = [ toVariant fp] }         -        return () -      HttpUrl url -> do -        let cmdargs = [url]-        createProcess (proc "xdg-open" cmdargs)  -        return () -    forkIO $ do -      threadDelay 2000000-      forM_ mid $ \(docid,anchorid) -> do-                  print (docid,anchorid)-                  emit cli (signal "/" "org.ianwookim.hoodle" "callLink")-                             { signalBody = -                                 [ toVariant (B.unpack docid -                                              ++ "," -                                              ++ B.unpack anchorid) ] }-    return ()+openLinkActionDBus urlpath mid = do+    flip catch (\(ex :: SomeException) -> print ex ) $ do+      cli <- connectSession+      case urlpath of +        FileUrl fp -> do +          emit cli (signal "/" "org.ianwookim.hoodle" "findWindow") { signalBody = [ toVariant fp] }         +          return () +        HttpUrl url -> do +          let cmdargs = [url]+          createProcess (proc "xdg-open" cmdargs)  +          return () +      forkIO $ do +        threadDelay 2000000+        forM_ mid $ \(docid,anchorid) -> do+                    print (docid,anchorid)+                    emit cli (signal "/" "org.ianwookim.hoodle" "callLink")+                               { signalBody = +                                   [ toVariant (B.unpack docid +                                                ++ "," +                                                ++ B.unpack anchorid) ] }+      return ()+#endif++ -- | -menuCreateALink :: (AllEvent -> IO ()) -> [RItem] -> IO (Maybe MenuItem)+menuCreateALink :: (AllEvent -> IO ()) -> [RItem] -> IO (Maybe Gtk.MenuItem) menuCreateALink evhandler sitems =    if (length . filter isLinkInRItem) sitems > 0   then return Nothing -  else do mi <- menuItemNewWithLabel "Create a link to..." -          mi `on` menuItemActivate $ +  else do mi <- Gtk.menuItemNewWithLabel ("Create a link to..." :: String)+          mi `Gtk.on` Gtk.menuItemActivate $              evhandler (UsrEv (GotContextMenuSignal CMenuCreateALink))           return (Just mi)            -- |-makeSVGFromSelection :: RenderCache -> [RItem] -> BBox -> IO SVG -makeSVGFromSelection cache hititms (BBox (ulx,uly) (lrx,lry)) = do +makeSVGFromSelection :: RenderCache -> CanvasId -> [RItem] -> BBox -> IO SVG +makeSVGFromSelection cache cid hititms (BBox (ulx,uly) (lrx,lry)) = do    uuid <- nextRandom   tdir <- getTemporaryDirectory   let filename = tdir </> show uuid <.> "svg"@@ -92,7 +99,7 @@       (w,h) = (lrx-ulx,lry-uly)   Cairo.withSVGSurface filename w h $ \s -> Cairo.renderWith s $ do      Cairo.translate (-ulx) (-uly) -    mapM_ (renderRItem cache) hititms +    mapM_ (renderRItem cache cid) hititms    bstr <- B.readFile filename   let svg = SVG Nothing Nothing bstr (x,y) (Dim w h)   svg `seq` removeFile filename
src/Hoodle/ModelAction/File.hs view
@@ -5,9 +5,9 @@ ----------------------------------------------------------------------------- -- | -- Module      : Hoodle.ModelAction.File --- Copyright   : (c) 2011-2014 Ian-Woo Kim+-- Copyright   : (c) 2011-2015 Ian-Woo Kim ----- License     : GPL-3+-- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com> -- Stability   : experimental -- Portability : GHC@@ -19,16 +19,15 @@ -- from other package import           Control.Applicative import           Control.Lens (view,set)-import           Data.Attoparsec +import           Data.Attoparsec.ByteString.Char8 import           Data.ByteString.Base64  import qualified Data.ByteString.Char8 as C import qualified Data.ByteString.Lazy.Char8 as L-import qualified Data.IntMap as IM import           Data.Maybe  import           Data.Monoid ((<>)) import           Data.Time.Clock+import qualified Data.Traversable as T import           Graphics.GD.ByteString -import           Graphics.UI.Gtk hiding (get,set) import qualified Graphics.UI.Gtk.Poppler.Document as Poppler import qualified Graphics.UI.Gtk.Poppler.Page as PopplerPage import           System.Directory (canonicalizePath)@@ -36,14 +35,14 @@ import           System.IO (hClose, hFileSize, openFile, IOMode(..))  import           System.Process -- from hoodle-platform -import           Data.Hoodle.Generic import           Data.Hoodle.Simple import           Graphics.Hoodle.Render.Background-import           Graphics.Hoodle.Render.Type.Background  import           Graphics.Hoodle.Render.Type.Hoodle import           Text.Hoodle.Builder (builder) import qualified Text.Hoodle.Parse.Attoparsec as PA-import qualified Text.Hoodle.Migrate.V0_1_1_to_V0_2 as MV+import qualified Text.Hoodle.Migrate.V0_2_2_to_V0_3 as MV+-- import qualified Data.Hoodle.Simple.V0_3 as V0_3+import qualified Text.Hoodle.Migrate.V0_3_to_HEAD as MVHEAD -- from this package import           Hoodle.Type.HoodleState import           Hoodle.Util@@ -54,33 +53,56 @@   case parseOnly PA.checkHoodleVersion bstr of      Left str -> error str      Right v -> do -      if ( v <= "0.1.1" ) -        then MV.migrate bstr+      if ( v <= "0.2.2" ) +        then T.traverse MVHEAD.hoodle2Hoodle =<< (MV.migrate bstr)         else return (parseOnly PA.hoodle bstr)  -- | this is very temporary, need to be changed.     -findFirstPDFFile :: [(Int,RPage)] -> Maybe C.ByteString-findFirstPDFFile xs = let ys = (filter isJust . map f) xs -                      in if null ys then Nothing else head ys -  where f (_,p) = case view gbackground p of -                    RBkgPDF _ fi _ _ _ -> Just fi-                    _ -> Nothing +findFirstPDFFile :: [Page] -> Maybe C.ByteString+findFirstPDFFile xs = let ys = mapMaybe f xs +                      in listToMaybe ys+  where f :: Page -> Maybe C.ByteString+        f p = case page_bkg p of+                BackgroundPdf _ _ fi _ -> fi+                _ -> Nothing+       -findAllPDFPages :: [(Int,RPage)] -> [Int]+findAllPDFPages :: [Page] -> [Int] findAllPDFPages = catMaybes . map f-  where f (n,p) = case view gbackground p of -                    RBkgPDF _ _ _ _ _ -> Just n-                    _ -> Nothing +  where f p = case page_bkg p of +                     BackgroundPdf _ _ _ n -> Just n+                     _ -> Nothing -replacePDFPages :: [(Int,RPage)] -> [(Int,RPage)] +replacePDFPages :: [Page] -> [Page]  replacePDFPages xs = map f xs -  where f (n,p) = case view gbackground p of -          RBkgPDF _ _ pdfn mpdf msfc -> (n, set gbackground (RBkgEmbedPDF pdfn mpdf msfc) p)-          _ -> (n,p) +  where f p = let bkg = page_bkg p+              in case bkg of    +                   BackgroundPdf typ _ _ pdfn -> p { page_bkg = BackgroundEmbedPdf typ pdfn }+                   _ -> p          -- | -embedPDFInHoodle :: RHoodle -> IO RHoodle-embedPDFInHoodle hdl = do +embedPDFInHoodle :: Hoodle -> IO Hoodle -- RHoodle -> IO RHoodle+embedPDFInHoodle hdl = putStrLn "embedPDFInHoodle is now bugful. I do not do anything here " >> return hdl+{-    let pgsWnum = zip [0..] (hoodle_pages hdl)+        mfn = findFirstPDFFile (hoodle_pages hdl)+        allpdfpg = findAllPDFPages pgs +    case mfn of +      Nothing -> return hdl +      Just fn -> do +        let fnstr = C.unpack fn +            pglst = map show allpdfpg +            cmdargs =  [fnstr, "cat"] ++ pglst ++ ["output", "-"]+        -- print cmdargs +        (_,Just hout,_,_) <- createProcess (proc "pdftk" cmdargs) { std_out = CreatePipe } +        bstr <- C.hGetContents hout+        let ebdsrc = makeEmbeddedPdfSrcString bstr +            npgs = (IM.fromAscList . replacePDFPages pgs +    +            nhdl0 = rHoodle2Hoodle . (gpages .~ npgs) $ hdl+            nhdl1 = nhdl0 { hoodle_embeddedpdf = Just ebdsrc }+        cnstrctRHoodle nhdl1+-}+{-     let pgs = (IM.toAscList . view gpages) hdl           mfn = findFirstPDFFile pgs         allpdfpg = findAllPDFPages pgs @@ -97,7 +119,7 @@         let ebdsrc = makeEmbeddedPdfSrcString bstr              npgs = (IM.fromAscList . replacePDFPages) pgs          (return . set gembeddedpdf (Just ebdsrc) . set gpages npgs) hdl-+-}   makeEmbeddedPdfSrcString :: C.ByteString -> C.ByteString @@ -172,27 +194,18 @@                      -- | -saveHoodle :: HoodleState -> IO HoodleState -saveHoodle xstate = do -    let hdl = (rHoodle2Hoodle . getHoodle) xstate -    case view (hoodleFileControl.hoodleFileName) xstate of -      Nothing -> return xstate -      Just filename -> do -        L.writeFile filename . builder $ hdl-        ctime <- getCurrentTime -        let ui = view gtkUIManager xstate-        toggleSave ui False-        return (set isSaved True . set (hoodleFileControl.lastSavedTime) (Just ctime) $ xstate )-             --- | this function must be moved to GUI.Reflect-toggleSave :: UIManager -> Bool -> IO ()-toggleSave ui b = do -    agr <- uiManagerGetActionGroups ui >>= \x -> -      case x of-        [] -> error "No action group?"-        y:_ -> return y-    Just savea <- actionGroupGetAction agr "SAVEA"-    actionSetSensitive savea b+saveHoodle :: UnitHoodle -> IO UnitHoodle+saveHoodle uhdl = do +    let hdl = (rHoodle2Hoodle . getHoodle) uhdl +    case view (hoodleFileControl.hoodleFileName) uhdl of +      LocalDir Nothing -> return uhdl +      LocalDir (Just filename) -> action hdl filename +      TempDir filename -> action hdl filename +  where +    action hdl filename = do +      L.writeFile filename . builder $ hdl+      ctime <- getCurrentTime +      return (set isSaved True . set (hoodleFileControl.lastSavedTime) (Just ctime) $ uhdl)  -- |  makeNewItemImage :: Bool  -- ^ isEmbedded?@@ -216,7 +229,6 @@                                              (fromIntegral h * 72 / 90)                    | w >= h = Dim 300 (fromIntegral h*300/fromIntegral w)                   | otherwise = Dim (fromIntegral w*300/fromIntegral h) 300 -          -- bstr <- savePngByteString img            bstr <- C.readFile filename            let b64str = encode bstr                ebdsrc = "data:image/png;base64," <> b64str
src/Hoodle/ModelAction/Layer.hs view
@@ -1,7 +1,9 @@+{-# LANGUAGE CPP #-}+ ----------------------------------------------------------------------------- -- | -- Module      : Hoodle.ModelAction.Layer --- Copyright   : (c) 2011-2013 Ian-Woo Kim+-- Copyright   : (c) 2011-2014 Ian-Woo Kim -- -- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>@@ -16,8 +18,7 @@ import           Control.Category import           Control.Lens (view,over) import           Data.IORef-import           Graphics.UI.Gtk hiding (get,set)-import qualified Graphics.UI.Gtk as Gtk (get)+import qualified Graphics.UI.Gtk as Gtk -- from hoodle-platform  import           Data.Hoodle.Generic import           Data.Hoodle.Zipper@@ -41,23 +42,28 @@   -- | -layerChooseDialog :: IORef Int -> Int -> Int -> IO Dialog+layerChooseDialog :: IORef Int -> Int -> Int -> IO Gtk.Dialog layerChooseDialog layernumref cidx len = do -    dialog <- dialogNew -    layerentry <- entryNew-    entrySetText layerentry (show (succ cidx))-    label <- labelNew (Just (" / " ++ show len))-    hbox <- hBoxNew False 0 -    upper <- dialogGetUpper dialog-    boxPackStart upper hbox PackNatural 0 -    boxPackStart hbox layerentry PackNatural 0 -    boxPackStart hbox label PackGrow 0 -    widgetShowAll upper-    buttonOk <- dialogAddButton dialog stockOk ResponseOk-    _buttonCancel <- dialogAddButton dialog stockCancel ResponseCancel+    dialog <- Gtk.dialogNew +    layerentry <- Gtk.entryNew+    Gtk.entrySetText layerentry (show (succ cidx))+    label <- Gtk.labelNew (Just (" / " ++ show len))+    hbox <- Gtk.hBoxNew False 0 +#ifdef GTK3    +    upper <- fmap Gtk.castToContainer (Gtk.dialogGetContentArea dialog)+    Gtk.containerAdd upper hbox+#else+    upper <- Gtk.dialogGetUpper dialog+    Gtk.boxPackStart upper hbox Gtk.PackNatural 0 +#endif+    Gtk.boxPackStart hbox layerentry Gtk.PackNatural 0 +    Gtk.boxPackStart hbox label Gtk.PackGrow 0 +    Gtk.widgetShowAll upper+    buttonOk <- Gtk.dialogAddButton dialog Gtk.stockOk Gtk.ResponseOk+    _buttonCancel <- Gtk.dialogAddButton dialog Gtk.stockCancel Gtk.ResponseCancel -    buttonOk `on` buttonActivated $ do -      txt <- Gtk.get layerentry entryText+    buttonOk `Gtk.on` Gtk.buttonActivated $ do +      txt <- Gtk.get layerentry Gtk.entryText       maybe (return ()) (modifyIORef layernumref . const . pred) . maybeRead $ txt     return dialog
src/Hoodle/ModelAction/Page.hs view
@@ -4,9 +4,9 @@ ----------------------------------------------------------------------------- -- | -- Module      : Hoodle.ModelAction.Page --- Copyright   : (c) 2011-2014 Ian-Woo Kim+-- Copyright   : (c) 2011-2015 Ian-Woo Kim ----- License     : GPL-3+-- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com> -- Stability   : experimental -- Portability : GHC@@ -21,12 +21,10 @@ import           Data.Functor.Identity (Identity(..)) import qualified Data.IntMap as M import           Data.Traversable (mapM)-import           Graphics.UI.Gtk (adjustmentGetValue)+import qualified Graphics.UI.Gtk as Gtk (adjustmentGetValue) -- from hoodle-platform import           Data.Hoodle.Generic import           Data.Hoodle.Select--- import           Data.Hoodle.Zipper --- import           Graphics.Hoodle.Render.Type -- from this package import           Hoodle.Util import           Hoodle.Type.Alias@@ -52,13 +50,13 @@   . hoodleModeStateEither    -- |-updatePageAll :: HoodleModeState -> HoodleState -> IO HoodleState-updatePageAll hdlmodst xstate = do -  let cmap = getCanvasInfoMap xstate+updatePageAll :: HoodleModeState -> UnitHoodle -> IO UnitHoodle+updatePageAll hdlmodst uhdl = do +  let cmap = view cvsInfoMap uhdl   cmap' <- mapM (updatePage hdlmodst . adjustPage hdlmodst) cmap-  return $ maybe xstate id +  return $ maybe uhdl id             . setCanvasInfoMap cmap' -           . set hoodleModeState hdlmodst $ xstate+           . set hoodleModeState hdlmodst $ uhdl  -- |  adjustPage :: HoodleModeState -> CanvasInfoBox -> CanvasInfoBox  @@ -94,7 +92,7 @@         pg = getPageFromGHoodleMap pagenum hdl          pdim = PageDimension $ view gdimension pg         (hadj,vadj) = view adjustments cinfo-    (xpos,ypos) <- (,) <$> adjustmentGetValue hadj <*> adjustmentGetValue vadj +    (xpos,ypos) <- (,) <$> Gtk.adjustmentGetValue hadj <*> Gtk.adjustmentGetValue vadj      let arr = makeSingleArrangement zmode pdim cdim (xpos,ypos)         vinfo = view viewInfo cinfo          nvinfo = xfrmViewInfo (const arr) vinfo@@ -108,8 +106,8 @@         canvas = view drawArea cinfo          zmode = view (viewInfo.zoomMode) cinfo         (hadj,vadj) = view adjustments cinfo-    (xdesk,ydesk) <- (,) <$> adjustmentGetValue hadj -                         <*> adjustmentGetValue vadj +    (xdesk,ydesk) <- (,) <$> Gtk.adjustmentGetValue hadj +                         <*> Gtk.adjustmentGetValue vadj      geometry <- makeCanvasGeometry (PageNum pagenum) oarr canvas      case desktop2Page geometry (DeskCoord (xdesk,ydesk)) of       Nothing -> return (CanvasContPage cinfo)@@ -131,19 +129,19 @@     updateCvsInfoFrmHoodle hdl c  -- | -setPage :: HoodleState -> PageNum -> CanvasId -> IO CanvasInfoBox-setPage xstate pnum cid = do  -  let cinfobox =  getCanvasInfo cid xstate-  unboxBiAct (liftM CanvasSinglePage . setPageSingle xstate pnum) -             (liftM CanvasContPage . setPageCont xstate pnum)+setPage :: UnitHoodle -> PageNum -> CanvasId -> IO CanvasInfoBox+setPage uhdl pnum cid = do  +  let cinfobox =  getCanvasInfo cid uhdl+  unboxBiAct (liftM CanvasSinglePage . setPageSingle uhdl pnum) +             (liftM CanvasContPage . setPageCont uhdl pnum)              cinfobox  -- | setPageSingle : in Single Page mode   -setPageSingle :: HoodleState -> PageNum  +setPageSingle :: UnitHoodle -> PageNum                 -> CanvasInfo SinglePage               -> IO (CanvasInfo SinglePage)-setPageSingle xstate pnum cinfo = do -  let hdl = getHoodle xstate+setPageSingle uhdl pnum cinfo = do +  let hdl = getHoodle uhdl   geometry <- getCvsGeomFrmCvsInfo cinfo   let cdim = canvasDim geometry    let pg = getPageFromGHoodleMap (unPageNum pnum) hdl@@ -154,20 +152,17 @@            . set (viewInfo.pageArrangement) arr $ cinfo   -- | setPageCont : in Continuous Page mode   -setPageCont :: HoodleState -> PageNum  +setPageCont :: UnitHoodle -> PageNum               -> CanvasInfo ContinuousPage             -> IO (CanvasInfo ContinuousPage)-setPageCont xstate pnum cinfo = do -  let hdl = getHoodle xstate+setPageCont uhdl pnum cinfo = do +  let hdl = getHoodle uhdl   geometry <- getCvsGeomFrmCvsInfo cinfo   let cdim = canvasDim geometry        zmode = view (viewInfo.zoomMode) cinfo       arr = makeContinuousArrangement zmode cdim hdl (pnum,PageCoord (0,0))     return $ set currentPageNum (unPageNum pnum)            . set (viewInfo.pageArrangement) arr $ cinfo --  -  -- | need to be refactored into zoomRatioFrmRelToCurr (rename zoomRatioRelPredefined) relZoomRatio :: CanvasGeometry -> ZoomModeRel -> Double
src/Hoodle/ModelAction/Pen.hs view
@@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module      : Hoodle.ModelAction.Pen --- Copyright   : (c) 2011-2014 Ian-Woo Kim+-- Copyright   : (c) 2011-2015 Ian-Woo Kim -- -- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>@@ -14,26 +14,17 @@  module Hoodle.ModelAction.Pen where -import           Control.Lens (view,set,over)+import           Control.Lens (view) import           Control.Monad (when)-import           Control.Monad.Identity (runIdentity) import           Data.Foldable-import qualified Data.IntMap as IM import           Data.Sequence hiding (take, drop) import           Data.Strict.Tuple hiding (uncurry) import qualified Graphics.Rendering.Cairo as Cairo -- from hoodle-platform -import           Data.Hoodle.BBox-import           Data.Hoodle.Generic import           Data.Hoodle.Simple-import           Graphics.Hoodle.Render-import           Graphics.Hoodle.Render.Type -- from this package -import           Hoodle.ModelAction.Layer-import           Hoodle.ModelAction.Page import           Hoodle.Type.Canvas import           Hoodle.Type.Enum-import           Hoodle.Type.PageArrangement --  data TempRender a = TempRender { tempSurfaceSrc :: Cairo.Surface  @@ -65,7 +56,7 @@       ptool = case ptype of                    PenWork -> "pen"                    HighlighterWork -> "highlighter"-                  _ -> error "error in addPDraw"+                  _ -> error "error in createNewStroke"              newstroke =          case pvwpen of @@ -78,25 +69,4 @@                            , stroke_vwdata = map (\(x,y,z)->(x,y,pwidth*z)) . toList $ pdraw }   in newstroke  ---- | -addPDraw :: RenderCache-         -> PenInfo -         -> RHoodle-         -> PageNum -         -> Seq (Double,Double,Double) -         -> IO (RHoodle,BBox) -- ^ new hoodle and bbox in page coordinate-addPDraw cache pinfo hdl (PageNum pgnum) pdraw = do -    let currpage = getPageFromGHoodleMap pgnum hdl-        currlayer = getCurrentLayer currpage-        dim = view gdimension currpage-        newstroke = createNewStroke pinfo pdraw         -        newstrokebbox = runIdentity (makeBBoxed newstroke)-        bbox = getBBox newstrokebbox-    newlayerbbox <- updateLayerBuf cache dim (Just bbox)-                    . over gitems (++[RItemStroke newstrokebbox]) -                    $ currlayer-    let newpagebbox = adjustCurrentLayer newlayerbbox currpage -        newhdlbbox = set gpages (IM.adjust (const newpagebbox) pgnum (view gpages hdl) ) hdl -    return (newhdlbbox,bbox)
src/Hoodle/ModelAction/Select.hs view
@@ -27,7 +27,7 @@ import           Data.Time.Clock import qualified Graphics.Rendering.Cairo as Cairo import           Graphics.Rendering.Cairo.Matrix ( invert, transformPoint )-import           Graphics.UI.Gtk hiding (get,set)+import qualified Graphics.UI.Gtk as Gtk -- from hoodle-platform import           Data.Hoodle.Generic import           Data.Hoodle.BBox@@ -65,10 +65,10 @@ -- |                      scaleFromToBBox :: BBox -> BBox -> (Double,Double) -> (Double,Double) scaleFromToBBox (BBox (ox1,oy1) (ox2,oy2)) (BBox (nx1,ny1) (nx2,ny2)) (x,y) = -  let scalex = (nx2-nx1) / (ox2-ox1)-      scaley = (ny2-ny1) / (oy2-oy1) -      nx = (x-ox1)*scalex+nx1-      ny = (y-oy1)*scaley+ny1+  let sx = (nx2-nx1) / (ox2-ox1)+      sy = (ny2-ny1) / (oy2-oy1) +      nx = (x-ox1)*sx+nx1+      ny = (y-oy1)*sy+ny1   in (nx,ny)  -- |@@ -86,17 +86,13 @@   where coordtrans (x,y) = unCvsCoord . desktop2Canvas geometry . page2Desktop geometry                             $ (pnum,PageCoord (x,y)) ---       nbbox = bboxFromImage nimg---  in ImageBBox nimg nbbox-- -- | getSelectedItms :: Page SelectMode -> [RItem] getSelectedItms = either (const []) (concatMap unHitted . getB) . rItmsInActiveLyr    -- |-getSelectedItmsFromHoodleState :: HoodleState -> Maybe [RItem] -getSelectedItmsFromHoodleState xstate = -  case view hoodleModeState xstate of +getSelectedItmsFromUnitHoodle :: UnitHoodle -> Maybe [RItem] +getSelectedItmsFromUnitHoodle uhdl = +  case view hoodleModeState uhdl of      ViewAppendState _ -> Nothing      SelectState thdl -> fmap (getSelectedItms.Prelude.snd) (view gselSelected thdl)   @@ -124,30 +120,17 @@   + -- | updateTempHoodleSelect :: Hoodle SelectMode -> Page SelectMode -> Int                             -> Hoodle SelectMode  updateTempHoodleSelect thdl tpage pagenum =                   let pgs = view gselAll thdl        pgs' = M.adjust (const (hPage2RPage tpage)) pagenum pgs-  in set gselAll pgs' -     . set gselSelected (Just (pagenum,tpage))-     $ thdl -     --- |-updateTempHoodleSelectIO :: RenderCache -                         -> Hoodle SelectMode -                         -> Page SelectMode -                         -> Int-                         -> IO (Hoodle SelectMode)-updateTempHoodleSelectIO cache thdl tpage pagenum = do   -  let pgs = view gselAll thdl -  newpage <- (updatePageBuf cache . hPage2RPage) tpage-  let pgs' = M.adjust (const newpage) pagenum pgs-  return $  set gselAll pgs' -            . set gselSelected (Just (pagenum,tpage))-            $ thdl +  in set gselAll pgs' . set gselSelected (Just (pagenum,tpage)) $ thdl +   +   -- |    calculateWholeBBox :: [BBoxed Stroke] -> Maybe BBox   calculateWholeBBox = toMaybe . mconcat . map ( Union . Middle. getBBox ) @@ -181,27 +164,27 @@       -- |-toggleCutCopyDelete :: UIManager -> Bool -> IO ()+toggleCutCopyDelete :: Gtk.UIManager -> Bool -> IO () toggleCutCopyDelete ui b = do -    agr <- uiManagerGetActionGroups ui >>= \x -> +    agr <- Gtk.uiManagerGetActionGroups ui >>= \x ->        case x of         [] -> error "No action group?"         y:_ -> return y-    Just deletea <- actionGroupGetAction agr "DELETEA"-    Just copya <- actionGroupGetAction agr "COPYA"-    Just cuta <- actionGroupGetAction agr "CUTA"+    Just deletea <- Gtk.actionGroupGetAction agr "DELETEA"+    Just copya <- Gtk.actionGroupGetAction agr "COPYA"+    Just cuta <- Gtk.actionGroupGetAction agr "CUTA"     let copycutdeletea = [copya,cuta,deletea] -    mapM_ (flip actionSetSensitive b) copycutdeletea+    mapM_ (flip Gtk.actionSetSensitive b) copycutdeletea  -- |-togglePaste :: UIManager -> Bool -> IO ()+togglePaste :: Gtk.UIManager -> Bool -> IO () togglePaste ui b = do -    agr <- uiManagerGetActionGroups ui >>= \x -> +    agr <- Gtk.uiManagerGetActionGroups ui >>= \x ->        case x of         [] -> error "No action group?"         y:_ -> return y-    Just pastea <- actionGroupGetAction agr "PASTEA"-    actionSetSensitive pastea b+    Just pastea <- Gtk.actionGroupGetAction agr "PASTEA"+    Gtk.actionSetSensitive pastea b  -- | changeStrokeColor :: PenColor -> BBoxed Stroke -> BBoxed Stroke@@ -349,10 +332,10 @@   -- | -mkItmsNImg :: RenderCache -> Page SelectMode -> IO ItmsNImg-mkItmsNImg cache tpage = do +mkItmsNImg :: RenderCache -> CanvasId -> Page SelectMode -> IO ItmsNImg+mkItmsNImg cache cid tpage = do      let itms = getSelectedItms tpage-        drawselection = mapM_ (renderRItem cache) itms +        drawselection = mapM_ (renderRItem cache cid) itms          Dim cw ch = view gdimension tpage          mbbox = case getULBBoxFromSelected tpage of                    Middle bbox -> Just bbox
src/Hoodle/ModelAction/Text.hs view
@@ -5,7 +5,7 @@ -- Module      : Hoodle.ModelAction.File  -- Copyright   : (c) 2011-2014 Ian-Woo Kim ----- License     : GPL-3+-- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com> -- Stability   : experimental -- Portability : GHC@@ -17,10 +17,8 @@ import           Control.Applicative import           Data.Attoparsec.Text as A import           Data.Char (isAlphaNum)-import qualified Data.Map as M+import qualified Data.HashMap.Strict as M import qualified Data.Text as T-import qualified Data.Text.Encoding as TE-import qualified Data.Text.IO as TIO -- import Debug.Trace @@ -38,7 +36,7 @@ -}  -- | -getKeywordMap :: T.Text -> M.Map T.Text T.Text+getKeywordMap :: T.Text -> M.HashMap T.Text T.Text getKeywordMap txt = case parseOnly (many keywordContents) txt of                        Left err -> trace (show err) $ M.empty                       Right lst -> M.fromList lst@@ -69,6 +67,11 @@     txt <- T.unlines <$> manyTill oneline keywordEnd     return (k,txt) -+-- |+extractKeyword :: T.Text -> Maybe T.Text+extractKeyword txt = +    case T.unpack txt of+      'e':'m':'b':'e':'d':'l':'a':'t':'e':'x':':':'k':'e':'y':'w':'o':'r':'d':':':xs -> Just (T.pack xs)+      _ -> Nothing
src/Hoodle/ModelAction/Window.hs view
@@ -1,12 +1,13 @@-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}  ----------------------------------------------------------------------------- -- | -- Module      : Hoodle.ModelAction.Window --- Copyright   : (c) 2011-2014 Ian-Woo Kim+-- Copyright   : (c) 2011-2015 Ian-Woo Kim ----- License     : GPL-3+-- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com> -- Stability   : experimental -- Portability : GHC@@ -16,28 +17,35 @@ module Hoodle.ModelAction.Window where  -- from other packages-import           Control.Concurrent-import           Control.Concurrent.STM import           Control.Lens (view)-import           Control.Monad-import           Control.Monad.Trans +import           Control.Monad hiding (forM_)+import           Control.Monad.Trans+import           Data.Foldable (forM_) import qualified Data.IntMap as M+import           Data.IORef (newIORef, readIORef)+import           Data.Traversable (traverse)+import           Data.UUID (UUID)+import           Data.UUID.V4+#ifdef HUB+import           Control.Concurrent+import           Control.Concurrent.STM import           Data.Maybe (mapMaybe) import qualified Data.Text as T-import           DBus+import           DBus hiding (UUID) import           DBus.Client-import           Graphics.UI.Gtk hiding (get,set)-import qualified Graphics.UI.Gtk as Gtk (set)+#endif+import qualified Graphics.UI.Gtk as Gtk import           System.FilePath -- from this package import           Hoodle.Device import           Hoodle.Type.Canvas import           Hoodle.Type.Event-import           Hoodle.Type.Window import           Hoodle.Type.HoodleState+import           Hoodle.Type.Window import           Hoodle.Util --  +#ifdef HUB getDBUSEvent :: (AllEvent -> IO ()) -> TVar Bool -> IO () getDBUSEvent callback tvar = do     client <- connectSession@@ -56,243 +64,280 @@           let fps = mapMaybe fromVariant (signalBody sig) :: [T.Text]           b <- atomically (readTVar tvar)             when ((not.null) fps && b) $ do  -            (postGUISync . callback . UsrEv . DBusEv . ImageFileDropped . T.unpack . head) +            (Gtk.postGUISync . callback . UsrEv . DBusEv . ImageFileDropped . T.unpack . head)                fps             return ()         getLaTeX sig = do            let latex = mapMaybe fromVariant (signalBody sig) :: [T.Text]           b <- atomically (readTVar tvar)             when ((not.null) latex && b) $ do  -            (postGUISync . callback . UsrEv . DBusEv . DBusNetworkInput . head) +            (Gtk.postGUISync . callback . UsrEv . DBusEv . DBusNetworkInput . head)                latex             return ()+#endif  -- | set frame title according to file name setTitleFromFileName :: HoodleState -> IO ()  setTitleFromFileName xstate = do -  case view (hoodleFileControl.hoodleFileName) xstate of-    Nothing -> Gtk.set (view rootOfRootWindow xstate) -                       [ windowTitle := "untitled" ]-    Just filename -> Gtk.set (view rootOfRootWindow xstate) -                             [ windowTitle := takeFileName filename] +  case view (unitHoodles.currentUnit.hoodleFileControl.hoodleFileName) xstate of+    LocalDir Nothing         -> Gtk.set (view rootOfRootWindow xstate) +                                  [ Gtk.windowTitle Gtk.:= ("untitled" :: String) ]+    LocalDir (Just filename) -> Gtk.set (view rootOfRootWindow xstate) +                                  [ Gtk.windowTitle Gtk.:= takeFileName filename] +    TempDir  _filename       -> Gtk.set (view rootOfRootWindow xstate) +                                  [ Gtk.windowTitle Gtk.:= ("shared document" :: String)]  -- |  newCanvasId :: CanvasInfoMap -> CanvasId -newCanvasId cmap = -  let cids = M.keys cmap -  in  (maximum cids) + 1  +newCanvasId cmap = let cids = M.keys cmap in (maximum cids) + 1    -- | initialize CanvasInfo with creating windows and connect events-initCanvasInfo :: HoodleState -> CanvasId -> IO (CanvasInfo a)-initCanvasInfo xstate cid = -  minimalCanvasInfo xstate cid >>= connectDefaultEventCanvasInfo xstate+initCanvasInfo :: HoodleState -> UnitHoodle -> CanvasId -> IO (CanvasInfo a)+initCanvasInfo xstate uhdl cid = +  minimalCanvasInfo cid >>= connectDefaultEventCanvasInfo xstate uhdl     -- | only creating windows -minimalCanvasInfo :: HoodleState -> CanvasId -> IO (CanvasInfo a)-minimalCanvasInfo _xstate cid = do -    canvas <- drawingAreaNew-    scrwin <- scrolledWindowNew Nothing Nothing -    containerAdd scrwin canvas-    hadj <- adjustmentNew 0 0 500 100 200 200 -    vadj <- adjustmentNew 0 0 500 100 200 200 -    scrolledWindowSetHAdjustment scrwin hadj -    scrolledWindowSetVAdjustment scrwin vadj +minimalCanvasInfo :: CanvasId -> IO (CanvasInfo a)+minimalCanvasInfo cid = do+    canvas <- Gtk.drawingAreaNew+    scrwin <- Gtk.scrolledWindowNew Nothing Nothing +    Gtk.containerAdd scrwin canvas+    hadj <- Gtk.adjustmentNew 0 0 500 100 200 200 +    vadj <- Gtk.adjustmentNew 0 0 500 100 200 200 +    Gtk.scrolledWindowSetHAdjustment scrwin hadj +    Gtk.scrolledWindowSetVAdjustment scrwin vadj      return $ CanvasInfo cid canvas Nothing scrwin (error "no viewInfo" :: ViewInfo a) 0 hadj vadj Nothing Nothing defaultCanvasWidgets Nothing    -- | only connect events - connectDefaultEventCanvasInfo -  :: HoodleState -> CanvasInfo a -> IO (CanvasInfo a )-connectDefaultEventCanvasInfo xstate cinfo = do +  :: HoodleState -> UnitHoodle -> CanvasInfo a -> IO (CanvasInfo a )+connectDefaultEventCanvasInfo xstate _uhdl cinfo = do      let callback = view callBack xstate+        ui = view gtkUIManager xstate          dev = view deviceList xstate          canvas = _drawArea cinfo          cid = _canvasId cinfo          scrwin = _scrolledWindow cinfo         hadj = _horizAdjustment cinfo -        vadj = _vertAdjustment cinfo --    widgetSetCanFocus canvas True -    widgetGrabFocus canvas     -    -    _sizereq <- canvas `on` sizeRequest $ return (Requisition 800 400)    -    -    _keyevent <- canvas `on` keyPressEvent $ tryEvent $ do -      m <- eventModifier-      n <- eventKeyName +        vadj = _vertAdjustment cinfo+    Gtk.widgetSetCanFocus canvas True +    Gtk.widgetGrabFocus canvas     +#ifdef GTK3+    {- +#endif+    _sizereq <- canvas `Gtk.on` Gtk.sizeRequest $ return (Gtk.Requisition 800 400)+    _keyevent <- canvas `Gtk.on` Gtk.keyPressEvent $ Gtk.tryEvent $ do +      m <- Gtk.eventModifier+      n <- Gtk.eventKeyName        let keystr = show m ++ ":" ++ show n       liftIO $ (callback (UsrEv (CustomKeyEvent keystr)))-    _bpevent <- canvas `on` buttonPressEvent $ tryEvent $ do -                 liftIO $ widgetGrabFocus canvas -                 (mbtn,mp) <- getPointer dev-                 case mp of -                   Nothing -> return ()-                   Just p -> do -                     let pbtn = maybe PenButton1 id mbtn-                     case pbtn of -                       TouchButton -> liftIO (callback (UsrEv (TouchDown cid p)))-                       _ -> liftIO (callback (UsrEv (PenDown cid pbtn p)))-    _confevent <- canvas `on` configureEvent $ tryEvent $ do -                   (w,h) <- eventSize -                   liftIO $ callback (UsrEv (CanvasConfigure cid (fromIntegral w) (fromIntegral h)))-    _brevent <- canvas `on` buttonReleaseEvent $ tryEvent $ do +    _bpevent <- canvas `Gtk.on` Gtk.buttonPressEvent $ Gtk.tryEvent $ do +                 liftIO $ Gtk.widgetGrabFocus canvas                   (mbtn,mp) <- getPointer dev-                 case mp of -                   Nothing -> return () -                   Just p -> do-                     let pbtn = maybe PenButton1 id mbtn-                     case pbtn of -                       TouchButton -> (liftIO . callback . UsrEv) (TouchUp cid p)-                       _ -> (liftIO . callback . UsrEv) (PenUp cid p)-                       +                 forM_ mp $ \p -> do +                   let pbtn = maybe PenButton1 id mbtn+                   case pbtn of +                     TouchButton -> liftIO (callback (UsrEv (TouchDown cid p)))+                     _ -> liftIO (callback (UsrEv (PenDown cid pbtn p)))+    _confevent <- canvas `Gtk.on` Gtk.configureEvent $ Gtk.tryEvent $ do +                    (w,h) <- Gtk.eventSize +                    liftIO $ callback (UsrEv (CanvasConfigure cid (fromIntegral w) (fromIntegral h)))+    _brevent <- canvas `Gtk.on` Gtk.buttonReleaseEvent $ Gtk.tryEvent $ do +                  (mbtn,mp) <- getPointer dev+                  forM_ mp $ \p -> do +                    let pbtn = maybe PenButton1 id mbtn+                    case pbtn of +                      TouchButton -> (liftIO . callback . UsrEv) (TouchUp cid p)+                      _ -> (liftIO . callback . UsrEv) (PenUp cid p)+#ifdef HUB     tvar <- newTVarIO False      forkIO $ getDBUSEvent callback tvar-    _focus <- canvas `on` focusInEvent $ tryEvent $ liftIO $ do+    _focus <- canvas `Gtk.on` Gtk.focusInEvent $ Gtk.tryEvent $ liftIO $ do                 atomically (writeTVar tvar True)-                widgetGrabFocus canvas -    _focusout <- canvas `on` focusOutEvent $ tryEvent $ liftIO $ atomically (writeTVar tvar False)-    _exposeev <- canvas `on` exposeEvent $ tryEvent $ do -      liftIO $ widgetGrabFocus canvas       +                Gtk.widgetGrabFocus canvas +    _focusout <- canvas `Gtk.on` Gtk.focusOutEvent $ Gtk.tryEvent $ liftIO $ atomically (writeTVar tvar False)+#endif+++#ifdef GTK3+    _exposeev <- canvas `Gtk.on` Gtk.draw $ do +#else+    _exposeev <- canvas `Gtk.on` Gtk.exposeEvent $ Gtk.tryEvent $ do +#endif+      liftIO $ Gtk.widgetGrabFocus canvas              (liftIO . callback . UsrEv) (UpdateCanvas cid) -    canvas `on` motionNotifyEvent $ tryEvent $ do +    canvas `Gtk.on` Gtk.motionNotifyEvent $ Gtk.tryEvent $ do        (mbtn,mp) <- getPointer dev-      case mp of -        Nothing -> return ()-        Just p -> do -          let pbtn = maybe PenButton1 id mbtn      -          case pbtn of -            TouchButton -> (liftIO . callback . UsrEv) (TouchMove cid p) -            _ -> (liftIO . callback . UsrEv) (PenMove cid p)-+      forM_ mp $ \p -> do+        let pbtn = maybe PenButton1 id mbtn      +        case pbtn of +          TouchButton -> (liftIO . callback . UsrEv) (TouchMove cid p) +          _ -> (liftIO . callback . UsrEv) (PenMove cid p)     -- drag and drop setting-    dragDestSet canvas [DestDefaultMotion, DestDefaultDrop] [ActionCopy]-    dragDestAddTextTargets canvas-    canvas `on` dragDataReceived $ \_dc pos _i _ts -> do -      s <- selectionDataGetText +    Gtk.dragDestSet canvas [Gtk.DestDefaultMotion, Gtk.DestDefaultDrop] [Gtk.ActionCopy]+    Gtk.dragDestAddTextTargets canvas+    canvas `Gtk.on` Gtk.dragDataReceived $ \_dc pos _i _ts -> do +      s <- Gtk.selectionDataGetText        (liftIO . callback . UsrEv) (GotLink s pos)       -    widgetAddEvents canvas [PointerMotionMask,Button1MotionMask,KeyPressMask]      -    let ui = view gtkUIManager xstate -    agr <- liftIO ( uiManagerGetActionGroups ui >>= \x ->+    Gtk.widgetAddEvents canvas [Gtk.PointerMotionMask,Gtk.Button1MotionMask,Gtk.KeyPressMask]+    agr <- liftIO ( Gtk.uiManagerGetActionGroups ui >>= \x ->                       case x of                          [] -> error "No action group? "                         y:_ -> return y )-    uxinputa <- liftIO (actionGroupGetAction agr "UXINPUTA" >>= \(Just x) -> -                          return (castToToggleAction x) )-    b <- liftIO $ toggleActionGetActive uxinputa-    if b then widgetSetExtensionEvents canvas [ExtensionEventsAll]-         else widgetSetExtensionEvents canvas [ExtensionEventsNone]-    hadjconnid <- afterValueChanged hadj $ do -                    v <- adjustmentGetValue hadj +    uxinputa <- liftIO (Gtk.actionGroupGetAction agr ("UXINPUTA" :: String) >>= \(Just x) -> +                          return (Gtk.castToToggleAction x) )+    b <- liftIO $ Gtk.toggleActionGetActive uxinputa+#ifdef GTK3    +#else+    if b then Gtk.widgetSetExtensionEvents canvas [Gtk.ExtensionEventsAll]+         else Gtk.widgetSetExtensionEvents canvas [Gtk.ExtensionEventsNone]+#endif+    hadjconnid <- Gtk.afterValueChanged hadj $ do +                    v <- Gtk.adjustmentGetValue hadj                      (callback . UsrEv) (HScrollBarMoved cid v)-    vadjconnid <- afterValueChanged vadj $ do -                    v <- adjustmentGetValue vadj     +    vadjconnid <- Gtk.afterValueChanged vadj $ do +                    v <- Gtk.adjustmentGetValue vadj                          (callback . UsrEv) (VScrollBarMoved cid v)-    Just vscrbar <- scrolledWindowGetVScrollbar scrwin-    _bpevtvscrbar <- vscrbar `on` buttonPressEvent $ do -                      v <- liftIO $ adjustmentGetValue vadj +    Just vscrbar <- Gtk.scrolledWindowGetVScrollbar scrwin+    _bpevtvscrbar <- vscrbar `Gtk.on` Gtk.buttonPressEvent $ do +                      v <- liftIO $ Gtk.adjustmentGetValue vadj                        liftIO ((callback . UsrEv) (VScrollBarStart cid v))                       return False-    _brevtvscrbar <- vscrbar `on` buttonReleaseEvent $ do -                      v <- liftIO $ adjustmentGetValue vadj +    _brevtvscrbar <- vscrbar `Gtk.on` Gtk.buttonReleaseEvent $ do +                      v <- liftIO $ Gtk.adjustmentGetValue vadj                        liftIO ((callback . UsrEv) (VScrollBarEnd cid v))                       return False     return $ cinfo { _horizAdjConnId = Just hadjconnid                    , _vertAdjConnId = Just vadjconnid }-    --- | recreate windows from old canvas info but no event connect+#ifdef GTK3+    -}+#endif+    -- temp+    return $ cinfo      +-- | recreate windows from old canvas info but no event connect reinitCanvasInfoStage1 -  :: HoodleState -> CanvasInfo a -> IO (CanvasInfo a)-reinitCanvasInfoStage1 xstate oldcinfo = do +  :: UnitHoodle -> CanvasInfo a -> IO (CanvasInfo a)+reinitCanvasInfoStage1 _uhdl oldcinfo = do    let cid = view canvasId oldcinfo -  newcinfo <- minimalCanvasInfo xstate cid      +  newcinfo <- minimalCanvasInfo cid         return $ newcinfo { _viewInfo = _viewInfo oldcinfo                      , _currentPageNum = _currentPageNum oldcinfo                      }        -- | event connect- reinitCanvasInfoStage2 -  :: HoodleState -> CanvasInfo a -> IO (CanvasInfo a)-reinitCanvasInfoStage2 = connectDefaultEventCanvasInfo+  :: HoodleState -> UnitHoodle -> CanvasInfo a -> IO (CanvasInfo a)+reinitCanvasInfoStage2 = connectDefaultEventCanvasInfo       -- | event connecting for all windows                          -                         -eventConnect :: HoodleState -> WindowConfig -                -> IO (HoodleState,WindowConfig)-eventConnect xstate (Node cid) = do -    let cmap = getCanvasInfoMap xstate +eventConnect :: HoodleState -> UnitHoodle -> WindowConfig -> IO (UnitHoodle,WindowConfig)+eventConnect xst uhdl (Node cid) = do +    let cmap = view cvsInfoMap uhdl          cinfobox = maybeError' "eventConnect" $ M.lookup cid cmap-    ncinfobox <- forBoth unboxBiXform (reinitCanvasInfoStage2 xstate) cinfobox-    let xstate' = updateFromCanvasInfoAsCurrentCanvas ncinfobox xstate-    return (xstate', Node cid)        -eventConnect xstate (HSplit wconf1 wconf2) = do  -    (xstate',wconf1') <- eventConnect xstate wconf1 -    (xstate'',wconf2') <- eventConnect xstate' wconf2 -    return (xstate'',HSplit wconf1' wconf2')-eventConnect xstate (VSplit wconf1 wconf2) = do  -    (xstate',wconf1') <- eventConnect xstate wconf1 -    (xstate'',wconf2') <- eventConnect xstate' wconf2 -    return (xstate'',VSplit wconf1' wconf2')+    ncinfobox <- forBoth unboxBiXform (reinitCanvasInfoStage2 xst uhdl) cinfobox+    let uhdl' = updateFromCanvasInfoAsCurrentCanvas ncinfobox uhdl+    return (uhdl', Node cid)        +eventConnect xst uhdl (HSplit wconf1 wconf2) = do  +    (uhdl',wconf1') <- eventConnect xst uhdl wconf1 +    (uhdl'',wconf2') <- eventConnect xst uhdl' wconf2 +    return (uhdl'',HSplit wconf1' wconf2')+eventConnect xst uhdl (VSplit wconf1 wconf2) = do  +    (uhdl',wconf1') <- eventConnect xst uhdl wconf1 +    (uhdl'',wconf2') <- eventConnect xst uhdl' wconf2 +    return (uhdl'',VSplit wconf1' wconf2')      -- | default construct frame     --constructFrame :: HoodleState -> WindowConfig -                  -> IO (HoodleState,Widget,WindowConfig)-constructFrame hst wcfg = constructFrame' (CanvasSinglePage defaultCvsInfoSinglePage) hst wcfg --+constructFrame :: HoodleState +               -> UnitHoodle -> WindowConfig +               -> IO (UnitHoodle,Gtk.Widget,WindowConfig)+constructFrame xst uhdl wcfg = +    let callback = view callBack xst+    in constructFrame' callback (CanvasSinglePage defaultCvsInfoSinglePage) uhdl wcfg   -- | construct frames with template--constructFrame' :: CanvasInfoBox -> -                   HoodleState -> WindowConfig -                   -> IO (HoodleState,Widget,WindowConfig)-constructFrame' template oxstate (Node cid) = do -    let ocmap = getCanvasInfoMap oxstate -    (cinfobox,_cmap,xstate) <- case M.lookup cid ocmap of -      Just cinfobox' -> return (cinfobox',ocmap,oxstate)+constructFrame' :: (AllEvent -> IO ()) -> CanvasInfoBox -> UnitHoodle -> WindowConfig +                -> IO (UnitHoodle,Gtk.Widget,WindowConfig)+constructFrame' _callback template ouhdl (Node cid) = do +    let ocmap = view cvsInfoMap ouhdl+    (cinfobox,_cmap,uhdl) <- case M.lookup cid ocmap of +      Just cinfobox' -> return (cinfobox',ocmap,ouhdl)       Nothing -> do          let cinfobox' = setCanvasId cid template              cmap' = M.insert cid cinfobox' ocmap-            xstate' = maybe oxstate id (setCanvasInfoMap cmap' oxstate)-        return (cinfobox',cmap',xstate')-    ncinfobox <- forBoth unboxBiXform (reinitCanvasInfoStage1 xstate) cinfobox-    let xstate' = updateFromCanvasInfoAsCurrentCanvas ncinfobox xstate-    let scrwin = forBoth' unboxBiAct (castToWidget.view scrolledWindow) ncinfobox-    return (xstate', scrwin, Node cid)-constructFrame' template xstate (HSplit wconf1 wconf2) = do  -    (xstate',win1,wconf1') <- constructFrame' template xstate wconf1     -    (xstate'',win2,wconf2') <- constructFrame' template xstate' wconf2 -    let callback = view callBack xstate'' -    hpane' <- hPanedNew-    hpane' `on` buttonPressEvent $ do +            uhdl' = maybe ouhdl id (setCanvasInfoMap cmap' ouhdl)+        return (cinfobox',cmap',uhdl')+    ncinfobox <- forBoth unboxBiXform (reinitCanvasInfoStage1 uhdl) cinfobox+    let uhdl' = updateFromCanvasInfoAsCurrentCanvas ncinfobox uhdl+    forBoth' unboxBiAct (putStrLn <=< Gtk.widgetGetName . view drawArea) ncinfobox+    let scrwin = forBoth' unboxBiAct (Gtk.castToWidget.view scrolledWindow) ncinfobox+    return (uhdl', scrwin, Node cid)+constructFrame' callback template uhdl (HSplit wconf1 wconf2) = do  +    (uhdl',win1,wconf1') <- constructFrame' callback template uhdl wconf1+    (uhdl'',win2,wconf2') <- constructFrame' callback template uhdl' wconf2 +    hpane' <- Gtk.hPanedNew+    hpane' `Gtk.on` Gtk.buttonPressEvent $ do        liftIO ((callback . UsrEv) PaneMoveStart)       return False -    hpane' `on` buttonReleaseEvent $ do +    hpane' `Gtk.on` Gtk.buttonReleaseEvent $ do        liftIO ((callback . UsrEv) PaneMoveEnd)       return False       -    panedPack1 hpane' win1 True False-    panedPack2 hpane' win2 True False-    widgetShowAll hpane' -    return (xstate'',castToWidget hpane', HSplit wconf1' wconf2')-constructFrame' template xstate (VSplit wconf1 wconf2) = do  -    (xstate',win1,wconf1') <- constructFrame' template xstate wconf1 -    (xstate'',win2,wconf2') <- constructFrame' template xstate' wconf2 -    let callback = view callBack xstate''     -    vpane' <- vPanedNew -    vpane' `on` buttonPressEvent $ do +    Gtk.panedPack1 hpane' win1 True False+    Gtk.panedPack2 hpane' win2 True False+    Gtk.widgetShowAll hpane' +    return (uhdl'',Gtk.castToWidget hpane', HSplit wconf1' wconf2')+constructFrame' callback template uhdl (VSplit wconf1 wconf2) = do  +    (uhdl',win1,wconf1') <- constructFrame' callback template uhdl wconf1 +    (uhdl'',win2,wconf2') <- constructFrame' callback template uhdl' wconf2 +    vpane' <- Gtk.vPanedNew +    vpane' `Gtk.on` Gtk.buttonPressEvent $ do        liftIO ((callback . UsrEv) PaneMoveStart)       return False -    vpane' `on` buttonReleaseEvent $ do +    vpane' `Gtk.on` Gtk.buttonReleaseEvent $ do        liftIO ((callback . UsrEv) PaneMoveEnd)       return False -    panedPack1 vpane' win1 True False-    panedPack2 vpane' win2 True False-    widgetShowAll vpane' -    return (xstate'',castToWidget vpane', VSplit wconf1' wconf2')+    Gtk.panedPack1 vpane' win1 True False+    Gtk.panedPack2 vpane' win2 True False+    Gtk.widgetShowAll vpane' +    return (uhdl'',Gtk.castToWidget vpane', VSplit wconf1' wconf2')   +registerFrameToContainer :: Gtk.Window -> Gtk.Box -> Gtk.Widget -> IO ()+registerFrameToContainer rtrwin rtcntr win = do+    Gtk.boxPackEnd rtcntr win Gtk.PackGrow 0 +   --  Gtk.widgetShowAll rtcntr  +    Gtk.widgetShowAll rtrwin+    Gtk.widgetQueueDraw rtrwin+++createTab :: (AllEvent -> IO ()) -> Gtk.Notebook -> Gtk.VBox -> IO (Int,UUID,Gtk.Button)+createTab callback notebook vboxcvs = do+    hbox <- Gtk.hBoxNew False 0 +    ebox <- Gtk.eventBoxNew+    label <- Gtk.labelNew (Just "      " :: Maybe String)+    Gtk.containerAdd ebox label+    Gtk.dragSourceSet ebox [Gtk.Button1] [Gtk.ActionCopy]+    Gtk.dragSourceSetIconStock ebox Gtk.stockIndex+    Gtk.dragSourceAddTextTargets ebox+    button <- Gtk.buttonNewWithLabel ("X" :: String)+    -- Gtk.Gtk.widgetSetSensitive button False+    Gtk.boxPackStart hbox {- label -} ebox Gtk.PackNatural 0+    Gtk.boxPackStart hbox button Gtk.PackNatural 0 +    Gtk.widgetShowAll hbox+    mlabel <- Gtk.labelNew (Nothing :: Maybe String)+    n <- Gtk.notebookAppendPageMenu notebook vboxcvs hbox mlabel+    uuid <- nextRandom+    button `Gtk.on` Gtk.buttonActivated $ callback (UsrEv (CloseTab uuid))++    -- ebox `Gtk.on` Gtk.dragBegin $ \_dc -> do +    --   liftIO $ putStrLn "dragging"+    ebox `Gtk.on` Gtk.dragDataGet $ \_dc _iid _ts -> do+      minfo <- liftIO $ do +        ref <- newIORef (Nothing :: Maybe String)+        callback (UsrEv (GetHoodleFileInfoFromTab uuid ref))+        readIORef ref+      traverse Gtk.selectionDataSetText minfo >> return ()+    return (n,uuid,button)
src/Hoodle/Script.hs view
@@ -1,7 +1,9 @@+{-# LANGUAGE CPP #-}+ ----------------------------------------------------------------------------- -- | -- Module      : Hoodle.Script--- Copyright   : (c) 2012, 2013 Ian-Woo Kim+-- Copyright   : (c) 2012-2014 Ian-Woo Kim -- -- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>@@ -13,7 +15,9 @@ module Hoodle.Script where   import Hoodle.Script.Hook+#ifdef DYRE import Config.Dyre.Relaunch+#endif  -- |  @@ -34,10 +38,10 @@   -- | -+#ifdef DYRE relaunchApplication :: IO () relaunchApplication = do    putStrLn "relaunching hoodle!"   relaunchMaster Nothing -  +#endif
src/Hoodle/Script/Coroutine.hs view
@@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module      : Hoodle.Script.Coroutine--- Copyright   : (c) 2012, 2013 Ian-Woo Kim+-- Copyright   : (c) 2012-2015 Ian-Woo Kim -- -- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>@@ -85,3 +85,4 @@     rfilename <- hoist (H.embedPredefinedImage3Hook hset)     liftIO rfilename    return r   +
src/Hoodle/Script/Hook.hs view
@@ -1,7 +1,9 @@+{-# LANGUAGE CPP #-}+ ----------------------------------------------------------------------------- -- | -- Module      : Hoodle.Script.Hook--- Copyright   : (c) 2012, 2013 Ian-Woo Kim+-- Copyright   : (c) 2012-2015 Ian-Woo Kim -- -- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>@@ -15,6 +17,9 @@ import Data.Hoodle.Simple  import Graphics.Hoodle.Render.Type.Hoodle -- +#ifdef HUB+import Hoodle.Type.Hub+#endif  -- |  data Hook = Hook { saveAsHook :: Maybe (Hoodle -> IO ())@@ -33,6 +38,10 @@                  , warningEmbedImageSize :: Maybe Integer                  , shrinkCmd4EmbedImage :: Maybe (Double -> FilePath -> FilePath -> IO ())                    , getIPaddress :: Maybe (IO String)+#ifdef HUB+                 , hubInfo :: Maybe HubInfo+                 , sqliteInfo :: Maybe FilePath+#endif                  }   @@ -53,4 +62,8 @@                    , warningEmbedImageSize = Nothing                    , shrinkCmd4EmbedImage = Nothing                    , getIPaddress = Nothing+#ifdef HUB+                   , hubInfo = Nothing+                   , sqliteInfo = Nothing+#endif                    }
src/Hoodle/Type/Alias.hs view
@@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module      : Hoodle.Type.Alias--- Copyright   : (c) 2012, 2013 Ian-Woo Kim+-- Copyright   : (c) 2012-2014 Ian-Woo Kim -- -- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>
src/Hoodle/Type/Canvas.hs view
@@ -75,19 +75,11 @@ , xfrmCvsInfo , xfrmViewInfo , getDrawAreaFromBox--- , unboxGet--- , unboxSet , unboxLens , unboxBiAct , unboxBiXform , forBoth , forBoth'--- , unboxSelect--- , fmap4CvsInfoBox--- , insideAction4CvsInfoBox--- , insideAction4CvsInfoBoxF--- , boxAction--- , selectBox -- * others , updateCanvasDimForSingle , updateCanvasDimForContSingle@@ -98,12 +90,13 @@ import qualified Data.IntMap as M import           Data.Sequence import qualified Graphics.Rendering.Cairo as Cairo-import           Graphics.UI.Gtk hiding (get,set)+import qualified Graphics.UI.Gtk as Gtk --  import           Data.Hoodle.Simple (Dimension(..)) import           Data.Hoodle.BBox import           Data.Hoodle.Predefined  import           Graphics.Hoodle.Render.Type.Item+import           Graphics.Hoodle.Render.Type.Renderer -- import           Hoodle.Type.Enum  import           Hoodle.Type.PageArrangement@@ -112,9 +105,6 @@   -- |-type CanvasId = Int ---- | data PenDraw = PenDraw { _points :: Seq (Double,Double) }               deriving (Show) @@ -138,9 +128,7 @@ emptyPenDraw :: PenDraw emptyPenDraw = PenDraw empty - -- | default view info with single page mode- defaultViewInfoSinglePage :: ViewInfo SinglePage defaultViewInfoSinglePage =    ViewInfo { _zoomMode = Original @@ -157,20 +145,18 @@ pageArrangement :: Simple Lens (ViewInfo a) (PageArrangement a) pageArrangement = lens _pageArrangement (\f a -> f { _pageArrangement = a }) -- -- | data CanvasInfo (a :: ViewMode) =         CanvasInfo { _canvasId :: CanvasId-                  , _drawArea :: DrawingArea+                  , _drawArea :: Gtk.DrawingArea                   , _mDrawSurface :: Maybe Cairo.Surface -                  , _scrolledWindow :: ScrolledWindow+                  , _scrolledWindow :: Gtk.ScrolledWindow                   , _viewInfo :: ViewInfo a                   , _currentPageNum :: Int-                  , _horizAdjustment :: Adjustment-                  , _vertAdjustment :: Adjustment -                  , _horizAdjConnId :: Maybe (ConnectId Adjustment)-                  , _vertAdjConnId :: Maybe (ConnectId Adjustment)+                  , _horizAdjustment :: Gtk.Adjustment+                  , _vertAdjustment :: Gtk.Adjustment +                  , _horizAdjConnId :: Maybe (Gtk.ConnectId Gtk.Adjustment)+                  , _vertAdjConnId :: Maybe (Gtk.ConnectId Gtk.Adjustment)                   , _canvasWidgets :: CanvasWidgets                   , _notifiedItem :: Maybe (PageNum,BBox,RItem)                    }@@ -196,8 +182,8 @@ -- |      defaultCvsInfoSinglePage :: CanvasInfo SinglePage defaultCvsInfoSinglePage = -  CanvasInfo { _canvasId = error "cvsid"-             , _drawArea = error "DrawingArea"+  CanvasInfo { _canvasId = error "defaultCvsInfoSinglePage cvsid"+             , _drawArea = error "defaultCvsInfoSinglePage DrawingArea"              , _mDrawSurface = Nothing               , _scrolledWindow = error "ScrolledWindow"              , _viewInfo = defaultViewInfoSinglePage@@ -215,7 +201,7 @@ canvasId = lens _canvasId (\f a -> f { _canvasId = a })  -- | -drawArea :: Simple Lens (CanvasInfo a) DrawingArea+drawArea :: Simple Lens (CanvasInfo a) Gtk.DrawingArea drawArea = lens _drawArea (\f a -> f { _drawArea = a })  -- | @@ -224,7 +210,7 @@   -- | -scrolledWindow :: Simple Lens (CanvasInfo a) ScrolledWindow+scrolledWindow :: Simple Lens (CanvasInfo a) Gtk.ScrolledWindow scrolledWindow = lens _scrolledWindow (\f a -> f { _scrolledWindow = a })  -- |@@ -236,23 +222,23 @@ currentPageNum = lens _currentPageNum (\f a -> f { _currentPageNum = a })  -- | -horizAdjustment :: Simple Lens (CanvasInfo a) Adjustment +horizAdjustment :: Simple Lens (CanvasInfo a) Gtk.Adjustment  horizAdjustment = lens _horizAdjustment (\f a -> f { _horizAdjustment = a })  -- | -vertAdjustment :: Simple Lens (CanvasInfo a) Adjustment +vertAdjustment :: Simple Lens (CanvasInfo a) Gtk.Adjustment  vertAdjustment = lens _vertAdjustment (\f a -> f { _vertAdjustment = a })  -- | ConnectId for horizontal scrollbar value change event -horizAdjConnId :: Simple Lens (CanvasInfo a) (Maybe (ConnectId Adjustment))+horizAdjConnId :: Simple Lens (CanvasInfo a) (Maybe (Gtk.ConnectId Gtk.Adjustment)) horizAdjConnId = lens _horizAdjConnId (\f a -> f { _horizAdjConnId = a })  -- | ConnectId for vertical scrollbar value change event -vertAdjConnId :: Simple Lens (CanvasInfo a) (Maybe (ConnectId Adjustment))+vertAdjConnId :: Simple Lens (CanvasInfo a) (Maybe (Gtk.ConnectId Gtk.Adjustment)) vertAdjConnId = lens _vertAdjConnId (\f a -> f { _vertAdjConnId = a })  -- | composition lens-adjustments :: Simple Lens (CanvasInfo a) (Adjustment,Adjustment) +adjustments :: Simple Lens (CanvasInfo a) (Gtk.Adjustment,Gtk.Adjustment)  adjustments = lens getter setter     where getter = (,) <$> view horizAdjustment <*> view vertAdjustment          setter f (h,v) = set horizAdjustment h . set vertAdjustment v $ f@@ -270,25 +256,21 @@   CanvasSinglePage :: CanvasInfo SinglePage -> CanvasInfoBox     CanvasContPage :: CanvasInfo ContinuousPage -> CanvasInfoBox                    ---forBoth ::  -          ((CanvasInfo SinglePage -> f (CanvasInfo SinglePage))-              -> (CanvasInfo ContinuousPage -> f (CanvasInfo ContinuousPage)) -              -> (CanvasInfoBox -> f CanvasInfoBox))   -          -> (forall a. CanvasInfo a -> f (CanvasInfo a))-          -> CanvasInfoBox -> f CanvasInfoBox+forBoth :: ((CanvasInfo SinglePage -> f (CanvasInfo SinglePage))+             -> (CanvasInfo ContinuousPage -> f (CanvasInfo ContinuousPage)) +             -> (CanvasInfoBox -> f CanvasInfoBox))   +        -> (forall a. CanvasInfo a -> f (CanvasInfo a))+        -> CanvasInfoBox -> f CanvasInfoBox forBoth m f = m f f   -forBoth' ::  ((CanvasInfo SinglePage -> r)+forBoth' :: ((CanvasInfo SinglePage -> r)               -> (CanvasInfo ContinuousPage -> r)                -> (CanvasInfoBox -> r) )-          -> (forall a. CanvasInfo a -> r)-          -> CanvasInfoBox -> r+         -> (forall a. CanvasInfo a -> r)+         -> CanvasInfoBox -> r forBoth' m f = m f f  - -- | single page action and continuous page act unboxBiXform :: (Functor f) =>                  (CanvasInfo SinglePage -> f (CanvasInfo SinglePage)) @@ -318,7 +300,7 @@ unboxLens l = lens (unboxGet l) (flip (unboxSet l))   -- |-getDrawAreaFromBox :: CanvasInfoBox -> DrawingArea +getDrawAreaFromBox :: CanvasInfoBox -> Gtk.DrawingArea  getDrawAreaFromBox = view (unboxLens drawArea)  -- |@@ -338,7 +320,6 @@ penColor :: Simple Lens WidthColorStyle PenColor penColor = lens _penColor (\f a -> f { _penColor = a } ) - -- |  data PenHighlighterEraserSet = PenHighlighterEraserSet                                 { _currPen :: WidthColorStyle @@ -369,7 +350,6 @@ currVerticalSpace :: Simple Lens PenHighlighterEraserSet WidthColorStyle currVerticalSpace = lens _currVerticalSpace                        (\f a -> f { _currVerticalSpace = a } )-                       -- |  data PenInfo = PenInfo { _penType :: PenType@@ -482,5 +462,7 @@               Cairo.rectangle 0 0 w' h'                Cairo.fill              return sfc ++   return $ (set (viewInfo.pageArrangement) arr'.set mDrawSurface msfc) cinfo
src/Hoodle/Type/Coroutine.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-}@@ -9,7 +10,7 @@ -- Module      : Hoodle.Type.Coroutine  -- Copyright   : (c) 2011-2014 Ian-Woo Kim ----- License     : GPL-3+-- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com> -- Stability   : experimental -- Portability : GHC@@ -115,7 +116,6 @@ -- |  doIOaction :: ((AllEvent -> IO ()) -> IO AllEvent) -> MainCoroutine () doIOaction action = modify (tempQueue %~ enqueue (mkIOaction action))-
src/Hoodle/Type/Enum.hs view
@@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module      : Hoodle.Type.Enum --- Copyright   : (c) 2011-2013 Ian-Woo Kim+-- Copyright   : (c) 2011-2014 Ian-Woo Kim -- -- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>@@ -17,9 +17,10 @@ import           Control.Lens (Simple,Lens,lens) import qualified Data.ByteString.Char8 as B import qualified Data.Map as M-import           Data.Maybe  --  import           Data.Hoodle.Predefined+--+import           Hoodle.Util  -- | drawing efficiency data DrawFlag = Clear | BkgEfficient | Efficient@@ -81,6 +82,8 @@  data RotateDir = CW | CCW deriving (Show, Ord, Eq) +-- | +data NewPageModeType = NPPlain | NPLast | NPCycle deriving (Show, Ord, Eq)  -- -- lenses@@ -105,12 +108,12 @@                              , (ColorWhite, "white") ]  penColorRGBAmap :: M.Map PenColor (Double,Double,Double,Double)-penColorRGBAmap = M.fromList $ map (\x->(fst x,fromJust (M.lookup (snd x) predefined_pencolor))) +penColorRGBAmap = M.fromList $ map (\x->(fst x,fromJustError "penColorRGBAmap" (M.lookup (snd x) predefined_pencolor)))                               $ M.toList penColorNameMap   convertPenColorToRGBA :: PenColor -> (Double,Double,Double,Double) convertPenColorToRGBA (ColorRGBA r g b a) = (r,g,b,a)-convertPenColorToRGBA c = fromJust (M.lookup c penColorRGBAmap)+convertPenColorToRGBA c = fromJustError "convertPenColorToRGBA" (M.lookup c penColorRGBAmap)  convertRGBAToHex :: (Double,Double,Double,Double) -> B.ByteString  convertRGBAToHex = B.pack . rgbaToHEX
src/Hoodle/Type/Event.hs view
@@ -1,11 +1,12 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-}  ----------------------------------------------------------------------------- -- | -- Module      : Hoodle.Type.Event --- Copyright   : (c) 2011-2014 Ian-Woo Kim+-- Copyright   : (c) 2011-2015 Ian-Woo Kim ----- License     : GPL-3+-- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com> -- Stability   : experimental -- Portability : GHC@@ -21,10 +22,12 @@ import           Data.ByteString  import           Data.IORef import qualified Data.Text as T-import           Data.Time.Clock import           Data.UUID (UUID) import qualified Graphics.Rendering.Cairo as Cairo-import           Graphics.UI.Gtk hiding (Image)+import qualified Graphics.UI.Gtk as Gtk+#ifdef HUB+import           Data.Time.Clock+#endif -- from hoodle-platform import           Control.Monad.Trans.Crtn.Event  import           Data.Hoodle.BBox@@ -33,18 +36,24 @@ -- from this package import           Hoodle.Device  import           Hoodle.Type.Enum-import           Hoodle.Type.Canvas import           Hoodle.Type.PageArrangement+import           Hoodle.Util+#ifdef HUB+import           Hoodle.Type.Hub+import           Hoodle.Type.Synchronization+#endif  -- |  data AllEvent = UsrEv UserEvent | SysEv SystemEvent               deriving Show   instance Show (Cairo.Surface) where-  show _ = "surface"+  show _ = "cairo surface"  -- | -data SystemEvent = TestSystemEvent | ClockUpdateEvent | RenderCacheUpdate (UUID, (Double,Cairo.Surface))+data SystemEvent = TestSystemEvent +                 | ClockUpdateEvent +                 | RenderCacheUpdate (SurfaceID, (Double,Cairo.Surface))                  deriving Show                             -- | @@ -62,6 +71,7 @@                | PenWidthChanged Int                 | AssignPenMode (Either PenType SelectType)                 | BackgroundStyleChanged BackgroundStyle +               | AssignNewPageMode NewPageModeType                | HScrollBarMoved Int Double                | VScrollBarMoved Int Double                 | VScrollBarStart Int Double@@ -83,10 +93,13 @@                | LaTeXInput (Maybe (ByteString,ByteString))                | TextInput (Maybe String)                | AddLink (Maybe (String,FilePath))+               | OpenLink UrlPath (Maybe (T.Text,T.Text))+               | OpenShared UUID+               | OpenTemp UUID FilePath                | EventDisconnected                | GetHoodleFileInfo (IORef (Maybe String))+               | GetHoodleFileInfoFromTab UUID (IORef (Maybe String))                | GotLink (Maybe String) (Int,Int)-               | Sync UTCTime                 | FileReloadOrdered                | CustomKeyEvent String                 | GotRevision String String@@ -96,21 +109,37 @@                | GotRecogResult Bool T.Text                | MiniBuffer MiniBufferEvent                | MultiLine MultiLineEvent-               | NetworkProcess NetworkEvent-               | DBusEv DBusEvent                | RenderEv RenderEvent                | LinePosition (Maybe (Int,Int))                | Keyword (Maybe T.Text)+               | SwitchTab Int+               | CloseTab UUID+               | UIEv UIEvent +#ifdef HUB+               | DBusEv DBusEvent+               | NetworkProcess NetworkEvent+               | DisconnectedHub FilePath (FilePath,Maybe FilePath) HubInfo+               | SyncInfoUpdated UUID FileSyncStatus+               | FileSyncFromHub UUID FileSyncStatus+               | GotSyncEvent Bool UUID FileSyncStatus+               | Sync UTCTime +               | SyncFileFinished FileSyncStatus+#endif                deriving Show                        instance Show (IORef a) where                         show _ = "IORef" +data UIEvent = UIGetFlag Bool+             deriving Show++ data RenderEvent = GotRItem RItem                  | GotRItems [RItem]                  | GotRBackground RBackground                  | GotRHoodle RHoodle                  | GotNone+                 | FinishCommand SurfaceID                  deriving Show  -- | @@ -123,15 +152,15 @@                | MenuRecentDocument                | MenuLoadPNGorJPG                | MenuLoadSVG+               | MenuLoadImageBackground                | MenuText                | MenuEmbedTextSource                | MenuEditEmbedTextSource-               | MenuEditNetEmbedTextSource                | MenuTextFromSource                | MenuLaTeX-               | MenuLaTeXNetwork                | MenuCombineLaTeX-               | MenuLaTeXFromSource +               | MenuLaTeXFromSource+               | MenuUpdateLaTeX                | MenuEmbedPredefinedImage                | MenuEmbedPredefinedImage2                | MenuEmbedPredefinedImage3                 @@ -185,13 +214,10 @@                | MenuAddLink                | MenuAddAnchor                | MenuListAnchors-               --  | MenuShapeRecognizer-               --  | MenuRuler                | MenuHandwritingRecognitionDialog                | MenuSelectRegion                | MenuSelectRectangle                | MenuVerticalSpace-               --   | MenuHandTool                | MenuPenOptions                | MenuEraserOptions                 | MenuHighlighterOptions@@ -202,10 +228,11 @@                | MenuDefaultHighlighter                | MenuDefaultText                 | MenuSetAsDefaultOption+#ifdef DYRE                | MenuRelaunch+#endif                | MenuUseXInput                | MenuUseTouch -               | MenuSmoothScroll                | MenuUsePopUpMenu                | MenuEmbedImage                | MenuEmbedPDF@@ -215,23 +242,19 @@                | MenuTogglePanZoomWidget                | MenuToggleLayerWidget                | MenuToggleClockWidget-               | MenuDiscardCoreEvents -               | MenuEraserTip +               | MenuToggleScrollWidget                | MenuPressureSensitivity-               | MenuPageHighlight-               | MenuMultiplePageView-               | MenuMultiplePages-               | MenuButton2Mapping-               | MenuButton3Mapping -               | MenuAntialiasedBitmaps-               | MenuProgressiveBackgrounds-               | MenuPrintPaperRuling -               | MenuLeftHandedScrollbar-               | MenuShortenMenus-               | MenuAutoSavePreferences-               | MenuSavePreferences+               | MenuAddTab+               | MenuCloseTab                | MenuAbout                | MenuDefault+#ifdef HUB+               | MenuEditNetEmbedTextSource+               | MenuToggleNetworkEditSource+               | MenuLaTeXNetwork+               | MenuHub+--                | MenuHubSocket+#endif                deriving Show   -- |@@ -251,8 +274,10 @@                       | CMenuMakeLinkToAnchor Anchor                       | CMenuPangoConvert (Double,Double) T.Text                       | CMenuLaTeXConvert (Double,Double) T.Text+#ifdef HUB                       | CMenuLaTeXConvertNetwork (Double,Double) T.Text-                      | CMenuLaTeXUpdate (Double,Double) T.Text+#endif+                      | CMenuLaTeXUpdate (Double,Double) Dimension T.Text                       | CMenuCropImage (BBoxed Image)                       | CMenuRotate    RotateDir (BBoxed Image)                       | CMenuExport (BBoxed Image)@@ -263,19 +288,20 @@   -- | event for minibuffer operation (currently pen only) -data MiniBufferEvent = MiniBufferInitialized DrawWindow+data MiniBufferEvent = MiniBufferInitialized Gtk.DrawWindow                      | MiniBufferPenDown PenButton PointerCoord                      | MiniBufferPenUp PointerCoord                      | MiniBufferPenMove PointerCoord                      deriving Show -instance Show DrawWindow where+instance Show Gtk.DrawWindow where   show _ = "DrawWindow"  -- | event for multiline text view/buffer data MultiLineEvent = MultiLineChanged T.Text                     deriving Show +#ifdef HUB -- | event for network data NetworkEvent = NetworkDialog                    | NetworkInitialized ThreadId (MVar ())@@ -283,19 +309,22 @@                   | NetworkCloseDialog                   | NetworkClosed                   deriving Show+#endif  instance Show (MVar ()) where   show _ = "MVar" +#ifdef HUB data DBusEvent = DBusNetworkInput T.Text                | ImageFileDropped FilePath                | GoToLink (T.Text,T.Text)                deriving Show+#endif  -- | -viewModeToUserEvent :: RadioAction -> IO UserEvent+viewModeToUserEvent :: Gtk.RadioAction -> IO UserEvent viewModeToUserEvent a = do -    v <- radioActionGetCurrentValue a+    v <- Gtk.radioActionGetCurrentValue a     case v of        1 -> return ToSinglePage       0 -> return ToContSinglePage
src/Hoodle/Type/HoodleState.hs view
@@ -1,12 +1,13 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-}  ----------------------------------------------------------------------------- -- | -- Module      : Hoodle.Type.HoodleState --- Copyright   : (c) 2011-2014 Ian-Woo Kim+-- Copyright   : (c) 2011-2015 Ian-Woo Kim ----- License     : GPL-3+-- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com> -- Stability   : experimental -- Portability : GHC@@ -14,24 +15,33 @@ -----------------------------------------------------------------------------  module Hoodle.Type.HoodleState -( HoodleState(..)+( HoodleState , HoodleModeState(..)+, UnitHoodle , IsOneTimeSelectMode(..)-, Settings(..)-, UIComponentSignalHandler(..)+, Settings+, UIComponentSignalHandler+, FileStore(..) -- | labels+, unitKey+, unitUUID+, unitButton , hoodleModeState , hoodleFileControl , cvsInfoMap , currentCanvas+, isOneTimeSelectMode , frameState , rootWindow+, unitHoodles+, rootNotebook , rootContainer , rootOfRootWindow , currentPenDraw , callBack , deviceList , penInfo+, cursorInfo , selectInfo , gtkUIManager , isSaved@@ -40,41 +50,49 @@ , isFullScreen  , settings , uiComponentSignalHandler-, isOneTimeSelectMode , lastTimeCanvasConfigure , hookSet  , tempLog  , tempQueue  , statusBar-, renderCache+, renderCacheVar , pdfRenderQueue+, genRenderQueue , doesNotInvalidate--- , cursorInfo+, nextPdfBkgPageNum --  , hoodleFileName  , lastSavedTime+, syncMD5History -- , doesUseXInput  , doesUseTouch-, doesSmoothScroll  , doesUsePopUpMenu , doesEmbedImage , doesEmbedPDF , doesFollowLinks , doesKeepAspectRatio , doesUseVariableCursor+, newPageMode+, networkEditSourceInfo+#ifdef HUB+, sqliteFileName+#endif --  , penModeSignal , pageModeSignal , penPointSignal , penColorSignal+, newPageModeSignal+, switchTabSignal -- | others +, emptyUnitHoodle , emptyHoodleState , defaultSettings  , defaultUIComponentSignalHandler , getHoodle -- | additional lenses -, getCanvasInfoMap +--  , getCanvasInfoMap  , setCanvasInfoMap  , getCurrentCanvasId , setCurrentCanvasId@@ -89,22 +107,22 @@ , getCurrentPageFromHoodleModeState , getCurrentPageDimFromHoodleModeState -- | for debug-, showCanvasInfoMapViewPortBBox+-- , showCanvasInfoMapViewPortBBox+-- , getTheUnit+-- , putTheUnit+, currentUnit ) where -import           Control.Applicative hiding (empty) import           Control.Concurrent import           Control.Concurrent.STM-import           Control.Lens (Simple,Lens,view,set,lens)-import           Control.Monad.State hiding (get,modify)+import           Control.Lens (Simple,Lens,view,set,lens,(^.)) import           Data.Functor.Identity (Identity(..)) import qualified Data.HashMap.Strict as HM import qualified Data.IntMap as M-import           Data.Maybe import           Data.Sequence +import qualified Data.Text as T import           Data.Time.Clock import           Data.UUID (UUID)--- import qualified Graphics.Rendering.Cairo as Cairo import qualified Graphics.UI.Gtk as Gtk hiding (Clipboard, get,set) -- from hoodle-platform import           Control.Monad.Trans.Crtn.Event @@ -139,72 +157,115 @@                          | YesAfterSelect                          deriving (Show,Eq,Ord) +data UnitHoodle = UnitHoodle { _unitKey :: Int+                             , _unitUUID :: UUID+                             , _unitButton :: Gtk.Button+                             , _hoodleModeState :: HoodleModeState+                             , _hoodleFileControl :: HoodleFileControl+                             , _cvsInfoMap :: CanvasInfoMap +                             , _currentCanvas :: (CanvasId,CanvasInfoBox)+                             , _frameState :: WindowConfig +                             , _rootWindow :: Gtk.Widget+                             , _rootContainer :: Gtk.Box+                             , _isSaved :: Bool +                             , _undoTable :: UndoTable HoodleModeState+                             , _isOneTimeSelectMode :: IsOneTimeSelectMode+                             }++ data HoodleState = -    HoodleState { _hoodleModeState :: HoodleModeState-                , _hoodleFileControl :: HoodleFileControl-                , _cvsInfoMap :: CanvasInfoMap -                , _currentCanvas :: (CanvasId,CanvasInfoBox)-                , _frameState :: WindowConfig -                , _rootWindow :: Gtk.Widget-                , _rootContainer :: Gtk.Box+    HoodleState { _unitHoodles :: (Int, M.IntMap UnitHoodle)+                , _rootNotebook :: Gtk.Notebook                 , _rootOfRootWindow :: Gtk.Window                 , _currentPenDraw :: PenDraw                 , _callBack ::  AllEvent -> IO ()                 , _deviceList :: DeviceList                 , _penInfo :: PenInfo+                , _cursorInfo :: (PenColor,Double,Bool) -- ^ (pen color, pen width, use variable cursor)                 , _selectInfo :: SelectInfo                  , _gtkUIManager :: Gtk.UIManager -                , _isSaved :: Bool -                , _undoTable :: UndoTable HoodleModeState-                , _backgroundStyle :: BackgroundStyle                  , _isFullScreen :: Bool                  , _settings :: Settings +                , _backgroundStyle :: BackgroundStyle                  , _uiComponentSignalHandler :: UIComponentSignalHandler -                , _isOneTimeSelectMode :: IsOneTimeSelectMode                 , _lastTimeCanvasConfigure :: Maybe UTCTime                  , _hookSet :: Maybe Hook                 , _tempQueue :: Queue (Either (ActionOrder AllEvent) AllEvent)                 , _tempLog :: String -> String                  , _statusBar :: Maybe Gtk.Statusbar-                , _renderCache :: RenderCache-                , _pdfRenderQueue :: TVar (Seq (UUID,PDFCommand))+                , _renderCacheVar :: TVar RenderCache+                , _pdfRenderQueue :: PDFCommandQueue+                , _genRenderQueue :: GenCommandQueue                 , _doesNotInvalidate :: Bool-                -- , _cursorInfo :: Maybe Cursor+                , _nextPdfBkgPageNum :: Maybe Int                 }   --- | lens for hoodleModeState-hoodleModeState :: Simple Lens HoodleState HoodleModeState-hoodleModeState = lens _hoodleModeState (\f a -> f { _hoodleModeState = a } )+-- | current unit+currentUnit :: Simple Lens (Int,M.IntMap UnitHoodle) UnitHoodle+currentUnit = lens (\(k,m) -> fromJustError "currentUnit" (M.lookup k m)) (\(_,m) a -> (_unitKey a,M.insert (_unitKey a) a m)) +-- | lens for unitKey+unitKey :: Simple Lens UnitHoodle Int+unitKey = lens _unitKey (\f a -> f { _unitKey = a }) +-- | lens for unitKey+unitUUID :: Simple Lens UnitHoodle UUID+unitUUID = lens _unitUUID (\f a -> f { _unitUUID = a }) --- | -hoodleFileControl :: Simple Lens HoodleState HoodleFileControl-hoodleFileControl = lens _hoodleFileControl (\f a -> f { _hoodleFileControl = a })+-- | lens for unitKey+unitButton :: Simple Lens UnitHoodle Gtk.Button+unitButton = lens _unitButton (\f a -> f { _unitButton = a })  +-- | lens for hoodleModeState+hoodleModeState :: Simple Lens UnitHoodle HoodleModeState+hoodleModeState = lens _hoodleModeState (\f a -> f { _hoodleModeState = a } ) +-- | +hoodleFileControl :: Simple Lens UnitHoodle HoodleFileControl+hoodleFileControl = lens _hoodleFileControl (\f a -> f { _hoodleFileControl = a })+ -- | lens for cvsInfoMap-cvsInfoMap :: Simple Lens HoodleState CanvasInfoMap+cvsInfoMap :: Simple Lens UnitHoodle CanvasInfoMap cvsInfoMap = lens _cvsInfoMap (\f a -> f { _cvsInfoMap = a } )  -- | lens for currentCanvas-currentCanvas :: Simple Lens HoodleState (CanvasId,CanvasInfoBox)+currentCanvas :: Simple Lens UnitHoodle (CanvasId,CanvasInfoBox) currentCanvas = lens _currentCanvas (\f a -> f { _currentCanvas = a } )  -- | lens for frameState-frameState :: Simple Lens HoodleState WindowConfig+frameState :: Simple Lens UnitHoodle WindowConfig frameState = lens _frameState (\f a -> f { _frameState = a } )  -- | lens for rootWindow-rootWindow :: Simple Lens HoodleState Gtk.Widget+rootWindow :: Simple Lens UnitHoodle Gtk.Widget rootWindow = lens _rootWindow (\f a -> f { _rootWindow = a } )  -- | lens for rootContainer-rootContainer :: Simple Lens HoodleState Gtk.Box+rootContainer :: Simple Lens UnitHoodle Gtk.Box rootContainer = lens _rootContainer (\f a -> f { _rootContainer = a } ) +-- | lens for isSaved+isSaved :: Simple Lens UnitHoodle Bool+isSaved = lens _isSaved (\f a -> f { _isSaved = a } )++-- | lens for undoTable+undoTable :: Simple Lens UnitHoodle (UndoTable HoodleModeState)+undoTable = lens _undoTable (\f a -> f { _undoTable = a } )++-- | lens for isOneTimeSelectMode+isOneTimeSelectMode :: Simple Lens UnitHoodle IsOneTimeSelectMode+isOneTimeSelectMode = lens _isOneTimeSelectMode (\f a -> f { _isOneTimeSelectMode = a } )++-- | lens for unitHoodles +unitHoodles :: Simple Lens HoodleState (Int,M.IntMap UnitHoodle)+unitHoodles = lens _unitHoodles (\f a -> f { _unitHoodles = a } )++-- | lens for rootWindow+rootNotebook :: Simple Lens HoodleState Gtk.Notebook+rootNotebook = lens _rootNotebook (\f a -> f { _rootNotebook = a } )+ -- | lens for rootOfRootWindow rootOfRootWindow :: Simple Lens HoodleState Gtk.Window rootOfRootWindow = lens _rootOfRootWindow (\f a -> f { _rootOfRootWindow = a } )@@ -225,6 +286,11 @@ penInfo :: Simple Lens HoodleState PenInfo penInfo = lens _penInfo (\f a -> f { _penInfo = a } ) +-- | lens for cursorInfo+cursorInfo :: Simple Lens HoodleState (PenColor,Double,Bool)+cursorInfo = lens _cursorInfo (\f a -> f { _cursorInfo = a } )++ -- | lens for selectInfo selectInfo :: Simple Lens HoodleState SelectInfo selectInfo = lens _selectInfo (\f a -> f { _selectInfo = a } )@@ -233,14 +299,6 @@ gtkUIManager :: Simple Lens HoodleState Gtk.UIManager gtkUIManager = lens _gtkUIManager (\f a -> f { _gtkUIManager = a } ) --- | lens for isSaved-isSaved :: Simple Lens HoodleState Bool-isSaved = lens _isSaved (\f a -> f { _isSaved = a } )---- | lens for undoTable-undoTable :: Simple Lens HoodleState (UndoTable HoodleModeState)-undoTable = lens _undoTable (\f a -> f { _undoTable = a } )- -- | background style = plain, lined, ruled, graph backgroundStyle :: Simple Lens HoodleState BackgroundStyle backgroundStyle = lens _backgroundStyle (\f a -> f { _backgroundStyle = a } )@@ -257,12 +315,7 @@ uiComponentSignalHandler :: Simple Lens HoodleState UIComponentSignalHandler uiComponentSignalHandler = lens _uiComponentSignalHandler (\f a -> f { _uiComponentSignalHandler = a }) --- | lens for isOneTimeSelectMode-isOneTimeSelectMode :: Simple Lens HoodleState IsOneTimeSelectMode-isOneTimeSelectMode = lens _isOneTimeSelectMode (\f a -> f { _isOneTimeSelectMode = a } ) -- -- | lens for lastTimeCanvasConfigure lastTimeCanvasConfigure :: Simple Lens HoodleState (Maybe UTCTime) lastTimeCanvasConfigure = lens _lastTimeCanvasConfigure (\f a -> f { _lastTimeCanvasConfigure = a } )@@ -284,34 +337,46 @@ statusBar = lens _statusBar (\f a -> f { _statusBar = a })  -- | -renderCache :: Simple Lens HoodleState RenderCache-renderCache = lens _renderCache (\f a -> f { _renderCache = a })+renderCacheVar :: Simple Lens HoodleState (TVar RenderCache)+renderCacheVar = lens _renderCacheVar (\f a -> f { _renderCacheVar = a })  -- | -pdfRenderQueue :: Simple Lens HoodleState (TVar (Seq (UUID, PDFCommand)))+pdfRenderQueue :: Simple Lens HoodleState PDFCommandQueue pdfRenderQueue = lens _pdfRenderQueue (\f a -> f { _pdfRenderQueue = a }) +-- | +genRenderQueue :: Simple Lens HoodleState GenCommandQueue+genRenderQueue = lens _genRenderQueue (\f a -> f { _genRenderQueue = a }) + -- |  doesNotInvalidate :: Simple Lens HoodleState Bool doesNotInvalidate = lens _doesNotInvalidate (\f a -> f { _doesNotInvalidate = a }) +-- | +nextPdfBkgPageNum :: Simple Lens HoodleState (Maybe Int)+nextPdfBkgPageNum = lens _nextPdfBkgPageNum (\f a -> f { _nextPdfBkgPageNum = a })  + {- -- |  cursorInfo :: Simple Lens HoodleState (Maybe Cursor) cursorInfo = lens _cursorInfo (\f a -> f { _cursorInfo = a }) -} +data FileStore = LocalDir (Maybe FilePath)+               | TempDir FilePath+ -- |  data HoodleFileControl = -  HoodleFileControl { _hoodleFileName :: Maybe FilePath +  HoodleFileControl { _hoodleFileName :: FileStore -- Maybe FilePath                      , _lastSavedTime  :: Maybe UTCTime +                    , _syncMD5History :: [T.Text]                     }   -- | lens for currFileName-hoodleFileName :: Simple Lens HoodleFileControl (Maybe FilePath)+hoodleFileName :: Simple Lens HoodleFileControl FileStore -- (Maybe FilePath) hoodleFileName = lens _hoodleFileName (\f a -> f { _hoodleFileName = a } )  -- | lens for last saved time@@ -319,13 +384,20 @@ lastSavedTime = lens _lastSavedTime (\f a -> f { _lastSavedTime = a } )  +-- | lens for last saved time+syncMD5History :: Simple Lens HoodleFileControl [T.Text] +syncMD5History = lens _syncMD5History (\f a -> f { _syncMD5History = a } ) ++ -- |  data UIComponentSignalHandler = UIComponentSignalHandler        { _penModeSignal :: Maybe (Gtk.ConnectId Gtk.RadioAction)        , _pageModeSignal :: Maybe (Gtk.ConnectId Gtk.RadioAction)        , _penPointSignal :: Maybe (Gtk.ConnectId Gtk.RadioAction)        , _penColorSignal :: Maybe (Gtk.ConnectId Gtk.RadioAction)+       , _newPageModeSignal :: Maybe (Gtk.ConnectId Gtk.RadioAction)+       , _switchTabSignal :: Maybe (Gtk.ConnectId Gtk.Notebook)        }   -- | lens for penModeSignal@@ -344,18 +416,30 @@ penColorSignal :: Simple Lens UIComponentSignalHandler (Maybe (Gtk.ConnectId Gtk.RadioAction)) penColorSignal = lens _penColorSignal (\f a -> f { _penColorSignal = a } ) +-- | lens for newPageModeSignal+newPageModeSignal :: Simple Lens UIComponentSignalHandler (Maybe (Gtk.ConnectId Gtk.RadioAction))+newPageModeSignal = lens _newPageModeSignal (\f a -> f { _newPageModeSignal = a } ) +-- | lens for switchTabSignal+switchTabSignal :: Simple Lens UIComponentSignalHandler (Maybe (Gtk.ConnectId Gtk.Notebook))+switchTabSignal = lens _switchTabSignal (\f a -> f { _switchTabSignal = a } )++ -- | A set of Hoodle settings  data Settings =    Settings { _doesUseXInput :: Bool             , _doesUseTouch :: Bool -           , _doesSmoothScroll :: Bool             , _doesUsePopUpMenu :: Bool             , _doesEmbedImage :: Bool             , _doesEmbedPDF :: Bool             , _doesFollowLinks :: Bool             , _doesKeepAspectRatio :: Bool            , _doesUseVariableCursor :: Bool +           , _newPageMode :: NewPageModeType+           , _networkEditSourceInfo :: Maybe ThreadId+#ifdef HUB+           , _sqliteFileName :: Maybe FilePath+#endif            }     @@ -367,10 +451,6 @@ doesUseTouch :: Simple Lens Settings Bool doesUseTouch = lens _doesUseTouch (\f a -> f { _doesUseTouch = a } ) --- | flag for smooth scrolling -doesSmoothScroll :: Simple Lens Settings Bool-doesSmoothScroll = lens _doesSmoothScroll (\f a -> f { _doesSmoothScroll = a } )- -- | flag for using popup menu doesUsePopUpMenu :: Simple Lens Settings Bool doesUsePopUpMenu = lens _doesUsePopUpMenu (\f a -> f { _doesUsePopUpMenu = a } )@@ -395,54 +475,83 @@ doesUseVariableCursor :: Simple Lens Settings Bool doesUseVariableCursor = lens _doesUseVariableCursor (\f a -> f {_doesUseVariableCursor=a}) +-- | new page mode: plain | last | cycle+newPageMode :: Simple Lens Settings NewPageModeType+newPageMode = lens _newPageMode (\f a -> f {_newPageMode=a})++-- | network edit source mode+networkEditSourceInfo :: Simple Lens Settings (Maybe ThreadId)+networkEditSourceInfo = lens _networkEditSourceInfo (\f a -> f {_networkEditSourceInfo=a})++#ifdef HUB+-- | sqlite file+sqliteFileName :: Simple Lens Settings (Maybe FilePath)+sqliteFileName = lens _sqliteFileName (\f a -> f {_sqliteFileName=a})+#endif++-- |+emptyUnitHoodle :: IO UnitHoodle+emptyUnitHoodle = do+  hdl <- emptyGHoodle+  return $ +    UnitHoodle { _unitKey = 0+               , _unitUUID = error "unitUUID"+               , _unitButton = error "unitButton"+               , _hoodleModeState = ViewAppendState hdl +               , _hoodleFileControl = emptyHoodleFileControl +               , _cvsInfoMap = error "emptyHoodleState.cvsInfoMap"+               , _currentCanvas = error "emtpyHoodleState.currentCanvas"+               , _frameState = error "emptyHoodleState.frameState" +               , _rootWindow = error "emtpyHoodleState.rootWindow"+               , _rootContainer = error "emptyHoodleState.rootContainer"+               , _isSaved = False +               , _undoTable = emptyUndo 1 +               , _isOneTimeSelectMode = NoOneTimeSelectMode+               }+ -- | default hoodle state  emptyHoodleState :: IO HoodleState  emptyHoodleState = do-  hdl <- emptyGHoodle-  tvar <- atomically $ newTVar empty +  unit <- emptyUnitHoodle+  tvarpdf <- atomically $ newTVar empty +  tvargen <- atomically $ newTVar empty +  tvarcache <- atomically $ newTVar HM.empty   return $-    HoodleState  -    { _hoodleModeState = ViewAppendState hdl -    , _hoodleFileControl = emptyHoodleFileControl -    -- , _currFileName = Nothing -    , _cvsInfoMap = error "emptyHoodleState.cvsInfoMap"-    , _currentCanvas = error "emtpyHoodleState.currentCanvas"-    , _frameState = error "emptyHoodleState.frameState" -    , _rootWindow = error "emtpyHoodleState.rootWindow"-    , _rootContainer = error "emptyHoodleState.rootContainer"-    , _rootOfRootWindow = error "emptyHoodleState.rootOfRootWindow"-    , _currentPenDraw = emptyPenDraw -    -- , _clipboard = emptyClipboard-    , _callBack = error "emtpyHoodleState.callBack"-    , _deviceList = error "emtpyHoodleState.deviceList"-    , _penInfo = defaultPenInfo -    , _selectInfo = SelectInfo SelectLassoWork -    , _gtkUIManager = error "emptyHoodleState.gtkUIManager"-    , _isSaved = False -    , _undoTable = emptyUndo 1 -    -- , _isEventBlocked = False -    , _backgroundStyle = BkgStyleLined-    , _isFullScreen = False-    , _settings = defaultSettings-    , _uiComponentSignalHandler = defaultUIComponentSignalHandler -    , _isOneTimeSelectMode = NoOneTimeSelectMode-    -- , _pageModeSignal = Nothing-    -- , _penModeSignal = Nothing                        -    , _lastTimeCanvasConfigure = Nothing                      -    , _hookSet = Nothing-    , _tempQueue = emptyQueue-    , _tempLog = id -    , _statusBar = Nothing -    , _renderCache = HM.empty-    , _pdfRenderQueue = tvar-    , _doesNotInvalidate = False-    -- , _cursorInfo = Nothing-    }+    HoodleState { _unitHoodles = (0, M.singleton 0 unit)+                , _rootNotebook = error "emtpyHoodleState.rootNotebook"+                , _rootOfRootWindow = error "emptyHoodleState.rootOfRootWindow"+                , _currentPenDraw = emptyPenDraw +                , _callBack = error "emtpyHoodleState.callBack"+                , _deviceList = error "emtpyHoodleState.deviceList"+                , _penInfo = defaultPenInfo +                , _cursorInfo = (defaultPenInfo ^. penSet.currPen.penColor, defaultPenInfo ^. penSet.currPen.penWidth, False)+                , _selectInfo = SelectInfo SelectLassoWork +                , _gtkUIManager = error "emptyHoodleState.gtkUIManager"+                -- , _isEventBlocked = False +                , _backgroundStyle = BkgStyleLined+                , _isFullScreen = False+                , _settings = defaultSettings+                , _uiComponentSignalHandler = defaultUIComponentSignalHandler +                -- , _pageModeSignal = Nothing+                -- , _penModeSignal = Nothing                        +                , _lastTimeCanvasConfigure = Nothing                      +                , _hookSet = Nothing+                , _tempQueue = emptyQueue+                , _tempLog = id +                , _statusBar = Nothing +                , _renderCacheVar = tvarcache -- HM.empty+                , _pdfRenderQueue = tvarpdf+                , _genRenderQueue = tvargen+                , _doesNotInvalidate = False+                , _nextPdfBkgPageNum = Nothing+                -- , _cursorInfo = Nothing+                }  emptyHoodleFileControl :: HoodleFileControl  emptyHoodleFileControl = -  HoodleFileControl { _hoodleFileName = Nothing +  HoodleFileControl { _hoodleFileName = LocalDir Nothing                      , _lastSavedTime = Nothing +                    , _syncMD5History = []                     }   @@ -451,7 +560,9 @@   UIComponentSignalHandler{ _penModeSignal = Nothing                            , _pageModeSignal = Nothing                            , _penPointSignal = Nothing -                          , _penColorSignal = Nothing +                          , _penColorSignal = Nothing+                          , _newPageModeSignal = Nothing+                          , _switchTabSignal = Nothing                           }   @@ -461,51 +572,48 @@   Settings    { _doesUseXInput = False   , _doesUseTouch = True-  , _doesSmoothScroll = False   , _doesUsePopUpMenu = True    , _doesEmbedImage = True    , _doesEmbedPDF = True    , _doesFollowLinks = True   , _doesKeepAspectRatio = False   , _doesUseVariableCursor = False+  , _newPageMode = NPPlain+  , _networkEditSourceInfo = Nothing+#ifdef HUB+  , _sqliteFileName = Nothing+#endif    }      -- | -getHoodle :: HoodleState -> Hoodle EditMode +getHoodle :: UnitHoodle -> Hoodle EditMode  getHoodle = either id gSelect2GHoodle . hoodleModeStateEither . view hoodleModeState   -- | -getCurrentCanvasId :: HoodleState -> CanvasId+getCurrentCanvasId :: UnitHoodle -> CanvasId getCurrentCanvasId = fst . _currentCanvas     -- | --setCurrentCanvasId :: CanvasId -> HoodleState -> Maybe HoodleState+setCurrentCanvasId :: CanvasId -> UnitHoodle -> Maybe UnitHoodle setCurrentCanvasId a f = do      cinfobox <- M.lookup a (_cvsInfoMap f)     return (f { _currentCanvas = (a,cinfobox) })-     --- | -    -getCanvasInfoMap :: HoodleState -> CanvasInfoMap -getCanvasInfoMap = _cvsInfoMap   -- | --setCanvasInfoMap :: CanvasInfoMap -> HoodleState -> Maybe HoodleState -setCanvasInfoMap cmap xstate +setCanvasInfoMap :: CanvasInfoMap -> UnitHoodle -> Maybe UnitHoodle+setCanvasInfoMap cmap uhdl   | M.null cmap = Nothing   | otherwise = -      let (cid,_) = _currentCanvas xstate+      let (cid,_) = _currentCanvas uhdl           (cidmax,cinfomax) = M.findMax cmap           mcinfobox = M.lookup cid cmap -      in Just . maybe (xstate {_currentCanvas=(cidmax,cinfomax), _cvsInfoMap = cmap}) -                       (\cinfobox -> xstate {_currentCanvas = (cid,cinfobox)-                                            ,_cvsInfoMap = cmap }) +      in Just . maybe (uhdl {_currentCanvas=(cidmax,cinfomax), _cvsInfoMap = cmap}) +                       (\cinfobox -> uhdl { _currentCanvas = (cid,cinfobox)+                                          , _cvsInfoMap = cmap })                  $ mcinfobox -currentCanvasInfo :: Simple Lens HoodleState CanvasInfoBox+currentCanvasInfo :: Simple Lens UnitHoodle CanvasInfoBox currentCanvasInfo = lens getter setter    where      getter = snd . _currentCanvas @@ -515,48 +623,47 @@       in f { _currentCanvas = (cid,a), _cvsInfoMap = cmap' }  -- | -resetHoodleModeStateBuffers :: RenderCache -> HoodleModeState -> IO HoodleModeState -resetHoodleModeStateBuffers cache hdlmodestate1 = +resetHoodleModeStateBuffers :: CanvasId -> HoodleModeState -> Renderer ()+resetHoodleModeStateBuffers cid hdlmodestate1 =    case hdlmodestate1 of -    ViewAppendState hdl -> liftIO . liftM ViewAppendState . updateHoodleBuf cache $ hdl-    _ -> return hdlmodestate1+    ViewAppendState hdl -> updateHoodleBuf cid hdl+    _ -> return ()  -- |-getCanvasInfo :: CanvasId -> HoodleState -> CanvasInfoBox -getCanvasInfo cid xstate = -  let cinfoMap = getCanvasInfoMap xstate+getCanvasInfo :: CanvasId -> UnitHoodle -> CanvasInfoBox +getCanvasInfo cid uhdl = +  let cinfoMap = view cvsInfoMap uhdl       maybeCvs = M.lookup cid cinfoMap   in maybeError' ("no canvas with id = " ++ show cid) maybeCvs  -- | -setCanvasInfo :: (CanvasId,CanvasInfoBox) -> HoodleState -> HoodleState -setCanvasInfo (cid,cinfobox) xstate = -  let cmap = getCanvasInfoMap xstate+setCanvasInfo :: (CanvasId,CanvasInfoBox) -> UnitHoodle -> UnitHoodle+setCanvasInfo (cid,cinfobox) uhdl = +  let cmap = view cvsInfoMap uhdl       cmap' = M.insert cid cinfobox cmap -  in maybe xstate id $ setCanvasInfoMap cmap' xstate--+  in maybe uhdl id $ setCanvasInfoMap cmap' uhdl  -- | change current canvas. this is the master function  -updateFromCanvasInfoAsCurrentCanvas :: CanvasInfoBox -> HoodleState -> HoodleState-updateFromCanvasInfoAsCurrentCanvas cinfobox xstate = +updateFromCanvasInfoAsCurrentCanvas :: CanvasInfoBox -> UnitHoodle-> UnitHoodle+updateFromCanvasInfoAsCurrentCanvas cinfobox uhdl =    let cid = view (unboxLens canvasId) cinfobox -      cmap = getCanvasInfoMap xstate+      cmap = view cvsInfoMap uhdl       cmap' = M.insert cid cinfobox cmap -  in xstate { _currentCanvas = (cid,cinfobox)-            , _cvsInfoMap = cmap' }+  in uhdl { _currentCanvas = (cid,cinfobox)+          , _cvsInfoMap = cmap' }  -- |  setCanvasId :: CanvasId -> CanvasInfoBox -> CanvasInfoBox  setCanvasId cid = runIdentity . forBoth unboxBiXform (return . set canvasId cid)     -- | -modifyCanvasInfo :: CanvasId -> (CanvasInfoBox -> CanvasInfoBox) -> HoodleState-                    -> HoodleState-modifyCanvasInfo cid f xstate =  -    maybe xstate id . flip setCanvasInfoMap xstate -                    . M.adjust f cid . getCanvasInfoMap -    $ xstate +modifyCanvasInfo :: CanvasId -> (CanvasInfoBox -> CanvasInfoBox) +                 -> UnitHoodle+                 -> UnitHoodle+modifyCanvasInfo cid f uhdl =  +    maybe uhdl id . flip setCanvasInfoMap uhdl+                  . M.adjust f cid . view cvsInfoMap +    $ uhdl  -- |  hoodleModeStateEither :: HoodleModeState -> Either (Hoodle EditMode) (Hoodle SelectMode) @@ -584,11 +691,6 @@ getPageMapFromHoodleModeState = either (view gpages) (view gselAll) . hoodleModeStateEither           --- | -showCanvasInfoMapViewPortBBox :: HoodleState -> IO ()-showCanvasInfoMapViewPortBBox xstate = do -  let cmap = getCanvasInfoMap xstate-  print . map (view (unboxLens (viewInfo.pageArrangement.viewPortBBox))) . M.elems $ cmap
+ src/Hoodle/Type/Hub.hs view
@@ -0,0 +1,28 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Hoodle.Type.Hub+-- Copyright   : (c) 2014 Ian-Woo Kim+--+-- License     : BSD3+-- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability   : experimental+-- Portability : GHC+--+-----------------------------------------------------------------------------++module Hoodle.Type.Hub where++import Data.Text (Text)+--+++data HubInfo = HubInfo { googleClientId :: Text+                       , googleClientSecret :: Text+                       , googleAuthURL :: String+                       , hubURL :: String+                       , hubFileRoot :: FilePath+                       , hubSocketURL :: String+                       , hubSocketPort :: Int+                       , hubSocketPath :: String+                       } +             deriving (Show,Eq,Ord)
src/Hoodle/Type/PageArrangement.hs view
@@ -9,7 +9,7 @@ ----------------------------------------------------------------------------- -- | -- Module      : Hoodle.Type.PageArrangement--- Copyright   : (c) 2012, 2013 Ian-Woo Kim+-- Copyright   : (c) 2012-2014 Ian-Woo Kim -- -- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>
+ src/Hoodle/Type/Synchronization.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++-----------------------------------------------------------------------------+-- |+-- Module      : Hoodle.Type.Synchronization+-- Copyright   : (c) 2014, 2015 Ian-Woo Kim+--+-- License     : BSD3+-- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability   : experimental+-- Portability : GHC+--+-----------------------------------------------------------------------------++module Hoodle.Type.Synchronization where++import           Control.Applicative+import           Data.Aeson as AE+import           Data.Data+import qualified Data.HashMap.Strict as H+import           Data.Text+import           Data.Time.Clock (UTCTime)+import           Database.Persist.TH++share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|+FileSyncStatus+    uuid    Text+    md5     Text+    time    UTCTime+    UniqueFileSyncStatusUUID uuid+    deriving Typeable+    deriving Show+    deriving Eq+|]+++instance ToJSON FileSyncStatus where+  toJSON FileSyncStatus {..} = object [ "uuid" .= toJSON fileSyncStatusUuid +                                      , "md5"  .= toJSON fileSyncStatusMd5+                                      , "time" .= toJSON fileSyncStatusTime +                                      ]+instance FromJSON FileSyncStatus where+  parseJSON (Object v) = +    let r = do+          String uuid   <- H.lookup "uuid" v+          String md5txt <- H.lookup "md5" v+          eutime <- fromJSON <$> H.lookup "time" v+          utime <- case eutime of+                     Error _ -> Nothing+                     Success a -> a+          return (FileSyncStatus uuid md5txt utime)+    in maybe (fail "error in parsing FileSyncStatus") return r+  parseJSON _ = fail "error in parsing FileSyncStatus" +++data FileContent = FileContent { file_uuid :: Text+                               , file_path :: Maybe Text+                               , file_content :: Text +                               , file_rsync :: Maybe FileRsync+                               , client_uuid :: Text+                               }+                 deriving Show++instance ToJSON FileContent where+  toJSON FileContent {..} = object [ "uuid"    .= toJSON file_uuid+                                   , "path"    .= toJSON file_path+                                   , "content" .= toJSON file_content +                                   , "rsync"   .= toJSON file_rsync+                                   , "client"  .= toJSON client_uuid+                                   ]++instance FromJSON FileContent where+  parseJSON (Object v) = +    FileContent <$> v .: "uuid" +                <*> v .: "path" +                <*> v .: "content" +                <*> v .: "rsync" +                <*> v .: "client"+  parseJSON _ = fail "error in parsing FileContent"++data FileRsync = FileRsync { frsync_uuid :: Text +                           , frsync_sig :: Text+                           }+               deriving Show++instance ToJSON FileRsync where+  toJSON FileRsync {..} = object [ "uuid" .= toJSON frsync_uuid+                                 , "signature" .= toJSON frsync_sig ]++instance FromJSON FileRsync where+  parseJSON (Object v) = +    let r = do +          String uuid <- H.lookup "uuid" v+          String sig <- H.lookup "signature" v+          return (FileRsync uuid sig)+    in maybe (fail "error in parsing FileRsync") return r+  parseJSON _ = fail "error in parsing FileRsync"
src/Hoodle/Type/Widget.hs view
@@ -20,6 +20,7 @@ , WidgetConfig , LayerWidgetConfig  , ClockWidgetConfig+, ScrollWidgetConfig -- * lenses  , panZoomWidgetPosition , panZoomWidgetTouchIsZoom@@ -30,13 +31,15 @@ , clockWidgetConfig , clockWidgetPosition , clockWidgetTime+, scrollWidgetConfig , widgetConfig  , doesUsePanZoomWidget , doesUseLayerWidget , doesUseClockWidget+, doesUseScrollWidget -- * defaults  , defaultCanvasWidgets-, defaultLWConfig +, defaultLWConfig , defaultWidgetConfig -- * utility , allWidgets@@ -48,12 +51,12 @@   -- | -data WidgetItem = PanZoomWidget | LayerWidget | ClockWidget +data WidgetItem = PanZoomWidget | LayerWidget | ClockWidget | ScrollWidget                 deriving (Show,Eq,Ord)  -- |  allWidgets :: [WidgetItem] -allWidgets = [PanZoomWidget, LayerWidget, ClockWidget] +allWidgets = [PanZoomWidget, LayerWidget, ClockWidget, ScrollWidget]    -- | @@ -87,19 +90,24 @@                                    , _clockWidgetTime :: (Int,Int,Int)                                    }      -                         +-- | lens for position of clock widget                          clockWidgetPosition :: Simple Lens ClockWidgetConfig CanvasCoordinate clockWidgetPosition = lens _clockWidgetPosition (\f a -> f { _clockWidgetPosition = a } ) +-- | lens for time for clock widget clockWidgetTime :: Simple Lens ClockWidgetConfig (Int,Int,Int) clockWidgetTime = lens _clockWidgetTime (\f a -> f { _clockWidgetTime = a }) +-- |+data ScrollWidgetConfig = ScrWConfig + -- |  data CanvasWidgets =    CanvasWidgets { _panZoomWidgetConfig :: PanZoomWidgetConfig                 , _layerWidgetConfig :: LayerWidgetConfig -                , _clockWidgetConfig :: ClockWidgetConfig +                , _clockWidgetConfig :: ClockWidgetConfig+                , _scrollWidgetConfig :: ScrollWidgetConfig                  , _widgetConfig :: WidgetConfig                  }    @@ -115,7 +123,11 @@ clockWidgetConfig :: Simple Lens CanvasWidgets ClockWidgetConfig  clockWidgetConfig = lens _clockWidgetConfig (\f a -> f { _clockWidgetConfig = a }) +-- | +scrollWidgetConfig :: Simple Lens CanvasWidgets ScrollWidgetConfig+scrollWidgetConfig = lens _scrollWidgetConfig (\f a -> f { _scrollWidgetConfig = a }) + -- | default hoodle widgets defaultCanvasWidgets :: CanvasWidgets defaultCanvasWidgets = @@ -123,6 +135,7 @@   { _panZoomWidgetConfig = defaultPZWConfig    , _layerWidgetConfig = defaultLWConfig    , _clockWidgetConfig = defaultClkConfig+  , _scrollWidgetConfig = defaultScrWConfig   , _widgetConfig = defaultWidgetConfig    }    @@ -147,9 +160,15 @@             }  +-- | +defaultScrWConfig :: ScrollWidgetConfig +defaultScrWConfig = ScrWConfig++ data WidgetConfig = WidgetConfig { _doesUsePanZoomWidget :: Bool                                   , _doesUseLayerWidget :: Bool -                                 , _doesUseClockWidget :: Bool +                                 , _doesUseClockWidget :: Bool+                                 , _doesUseScrollWidget :: Bool                                  }   -- | flag for pan zoom widget @@ -164,12 +183,17 @@ doesUseClockWidget :: Simple Lens WidgetConfig Bool  doesUseClockWidget = lens _doesUseClockWidget (\f a -> f {_doesUseClockWidget = a})  +-- | flag for scroll widget+doesUseScrollWidget :: Simple Lens WidgetConfig Bool+doesUseScrollWidget = lens _doesUseScrollWidget (\f a -> f {_doesUseScrollWidget = a}) + -- | default widget configuration  defaultWidgetConfig :: WidgetConfig  defaultWidgetConfig = WidgetConfig { _doesUsePanZoomWidget = False                                    , _doesUseLayerWidget = False                                    , _doesUseClockWidget = False+                                   , _doesUseScrollWidget = False                                    }
src/Hoodle/Util.hs view
@@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module      : Hoodle.Util --- Copyright   : (c) 2013 Ian-Woo Kim+-- Copyright   : (c) 2013, 2014 Ian-Woo Kim -- -- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>@@ -15,7 +15,9 @@ module Hoodle.Util where  import Control.Applicative -import Data.Attoparsec.Char8 +import Control.Monad.IO.Class+import Control.Monad.Trans.Maybe+import Data.Attoparsec.ByteString.Char8 import qualified Data.ByteString.Char8 as B import Data.Maybe import Data.Time.Clock @@ -36,16 +38,30 @@ (#) = flip ($) infixr 0 # +-- safehead :: [a] -> Maybe a+-- safehead [] = Nothing+-- safehead (a:_) = a+ maybeFlip :: Maybe a -> b -> (a->b) -> b   maybeFlip m n j = maybe n j m    -uncurry4 :: (a->b->c->d->e)->(a,b,c,d)->e -uncurry4 f (x,y,z,w) = f x y z w - maybeRead :: Read a => String -> Maybe a  maybeRead = fmap fst . listToMaybe . reads  +runMaybeT_ :: (Monad m) => MaybeT m a -> m ()+runMaybeT_ m = runMaybeT m >> return ()  +fromJustError :: String -> Maybe a -> a+fromJustError _   (Just x) = x+fromJustError err Nothing = error err++either_ :: (Monad m) => (b -> m ()) -> Either a b -> m ()+either_ = either (const (return ()))+++uncurry4 :: (a->b->c->d->e)->(a,b,c,d)->e +uncurry4 f (x,y,z,w) = f x y z w + getLargestWidth :: Hoodle -> Double  getLargestWidth hdl =    let ws = map (dim_width . page_dim) (hoodle_pages hdl)  @@ -76,11 +92,15 @@   hPutStrLn outh str   hClose outh  ++-- | for debugging+msgShout :: (MonadIO m) => String -> m ()+msgShout = liftIO . putStrLn++ -- |  maybeError' :: String -> Maybe a -> a maybeError' str = maybe (error str) id--  data UrlPath = FileUrl FilePath | HttpUrl String               deriving (Show,Eq)
src/Hoodle/View/Coordinate.hs view
@@ -1,10 +1,11 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-}  {-# LANGUAGE TupleSections #-}  ----------------------------------------------------------------------------- -- | -- Module      : Hoodle.View.Coordinate--- Copyright   : (c) 2012, 2013 Ian-Woo Kim+-- Copyright   : (c) 2012-2014 Ian-Woo Kim -- -- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>@@ -22,7 +23,7 @@ import qualified Data.IntMap as M import           Data.Maybe import           Data.Monoid-import           Graphics.UI.Gtk hiding (get,set)+import qualified Graphics.UI.Gtk as Gtk -- from hoodle-platform import Data.Hoodle.Simple (Dimension(..)) import Data.Hoodle.Generic@@ -50,18 +51,23 @@   , page2Desktop :: (PageNum,PageCoordinate) -> DesktopCoordinate   }  + -- | make a canvas geometry data structure from current status  makeCanvasGeometry :: PageNum                        -> PageArrangement vm -                      -> DrawingArea +                      -> Gtk.DrawingArea                        -> IO CanvasGeometry  makeCanvasGeometry cpn arr canvas = do -  win <- widgetGetDrawWindow canvas+#ifdef GTK3  +  Just win <- Gtk.widgetGetWindow canvas+#else+  win <- Gtk.widgetGetDrawWindow canvas+#endif   let cdim@(CanvasDimension (Dim w' h')) = view canvasDimension arr-  screen <- widgetGetScreen canvas-  (ws,hs) <- (,) <$> (fromIntegral <$> screenGetWidth screen)-                 <*> (fromIntegral <$> screenGetHeight screen)-  (x0,y0) <- return . ((,) <$> fromIntegral.fst <*> fromIntegral.snd ) =<< drawWindowGetOrigin win+  screen <- Gtk.widgetGetScreen canvas+  (ws,hs) <- (,) <$> (fromIntegral <$> Gtk.screenGetWidth screen)+                 <*> (fromIntegral <$> Gtk.screenGetHeight screen)+  (x0,y0) <- return . ((,) <$> fromIntegral.fst <*> fromIntegral.snd ) =<< Gtk.drawWindowGetOrigin win   let corig = CanvasOrigin (x0,y0)       (deskdim, cvsvbbox, p2d, d2p) =          case arr of
src/Hoodle/View/Draw.hs view
@@ -1,14 +1,15 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE Rank2Types #-} -{-# LANGUAGE TypeFamilies #-}  {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilies #-}  ----------------------------------------------------------------------------- -- | -- Module      : Hoodle.View.Draw --- Copyright   : (c) 2011-2014 Ian-Woo Kim+-- Copyright   : (c) 2011-2015 Ian-Woo Kim ----- License     : GPL-3+-- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com> -- Stability   : experimental -- Portability : GHC@@ -28,14 +29,14 @@ import           Data.Monoid import           Data.Sequence import qualified Graphics.Rendering.Cairo as Cairo-import           Graphics.UI.Gtk hiding (get,set)+import qualified Graphics.UI.Gtk as Gtk -- from hoodle-platform  import Data.Hoodle.BBox import Data.Hoodle.Generic import Data.Hoodle.Predefined import Data.Hoodle.Select import Data.Hoodle.Simple (Dimension(..),Stroke(..))-import Data.Hoodle.Zipper (currIndex,current)+import Data.Hoodle.Zipper (currIndex) import Graphics.Hoodle.Render import Graphics.Hoodle.Render.Generic import Graphics.Hoodle.Render.Highlight@@ -63,8 +64,9 @@ newtype SinglePageDraw a =    SinglePageDraw    { unSinglePageDraw :: RenderCache +                     -> CanvasId                      -> Bool                               -- ^ isCurrentCanvas-                     -> (DrawingArea, Maybe Cairo.Surface) +                     -> (Gtk.DrawingArea, Maybe Cairo.Surface)                       -> (PageNum, Page a)                       -> ViewInfo SinglePage                       -> Maybe BBox @@ -131,8 +133,16 @@ doubleBufferFlush :: Cairo.Surface -> CanvasInfo a -> IO ()  doubleBufferFlush sfc cinfo = do        let canvas = view drawArea cinfo -      win <- widgetGetDrawWindow canvas-      renderWithDrawable win $ do +#ifdef GTK3+      Just win <- Gtk.widgetGetWindow canvas+#else +      win <- Gtk.widgetGetDrawWindow canvas+#endif+#ifdef GTK3+      Gtk.renderWithDrawWindow win $ do +#else +      Gtk.renderWithDrawable win $ do +#endif         Cairo.setSourceSurface sfc 0 0          Cairo.setOperator Cairo.OperatorSource          Cairo.paint@@ -140,11 +150,12 @@   -- | common routine for double buffering -doubleBufferDraw :: (DrawWindow, Maybe Cairo.Surface)  -                    -> CanvasGeometry -> Cairo.Render () -> Cairo.Render a+doubleBufferDraw :: (Gtk.DrawWindow, Maybe Cairo.Surface)  +                    -> CanvasGeometry +                    -> Cairo.Render a                     -> IntersectBBox                     -> IO (Maybe a)-doubleBufferDraw (win,msfc) geometry _xform rndr (Intersect ibbox) = do +doubleBufferDraw (win,msfc) geometry rndr (Intersect ibbox) = do    let Dim cw ch = unCanvasDimension . canvasDim $ geometry        mbbox' = case ibbox of          Top -> Just (BBox (0,0) (cw,ch))@@ -153,7 +164,11 @@   let action = do          case msfc of  	  Nothing -> do -	    renderWithDrawable win $ do +#ifdef GTK3            +            Gtk.renderWithDrawWindow win $ do+#else+	    Gtk.renderWithDrawable win $ do +#endif 	      clipBBox mbbox'               Cairo.setSourceRGBA 0.5 0.5 0.5 1               Cairo.rectangle 0 0 cw ch @@ -167,7 +182,11 @@               Cairo.fill               clipBBox mbbox'  	      rndr -	    renderWithDrawable win $ do +#ifdef GTK3+            Gtk.renderWithDrawWindow win $ do+#else+	    Gtk.renderWithDrawable win $ do +#endif  	      Cairo.setSourceSurface sfc 0 0    	      Cairo.setOperator Cairo.OperatorSource  	      Cairo.paint @@ -177,7 +196,7 @@     Middle _ -> Just <$> action      Bottom   -> return Nothing  -+-- | mkXform4Page :: CanvasGeometry -> PageNum -> Xform4Page mkXform4Page geometry pnum =      let CvsCoord (x0,y0) = desktop2Canvas geometry . page2Desktop geometry $ (pnum,PageCoord (0,0))@@ -186,27 +205,18 @@         sy = y1-y0     in Xform4Page x0 y0 sx sy - -- |  cairoXform4PageCoordinate :: Xform4Page -> Cairo.Render ()  cairoXform4PageCoordinate xform = do     Cairo.translate (transx xform) (transy xform)     Cairo.scale (scalex xform) (scaley xform) - {- do -  let CvsCoord (x0,y0) = desktop2Canvas geometry . page2Desktop geometry $ (pnum,PageCoord (0,0))-      CvsCoord (x1,y1) = desktop2Canvas geometry . page2Desktop geometry $ (pnum,PageCoord (1,1))-      sx = x1-x0 -      sy = y1-y0-  Cairo.translate x0 y0      -  Cairo.scale sx sy--} -- |    data PressureMode = NoPressure | Pressure    -- |  drawCurvebitGen  :: PressureMode -                    -> DrawingArea+                    -> Gtk.DrawingArea                     -> CanvasGeometry                      -> Double                      -> (Double,Double,Double,Double) @@ -216,9 +226,17 @@                     -> ((Double,Double),Double)                      -> IO ()  drawCurvebitGen pmode canvas geometry wdth (r,g,b,a) pnum pdraw ((x0,y0),z0) ((x,y),z) = do -  win <- widgetGetDrawWindow canvas-  renderWithDrawable win $ do-    cairoXform4PageCoordinate (mkXform4Page geometry pnum)+#ifdef GTK3  +  Just win <- Gtk.widgetGetWindow canvas+#else +  win <- Gtk.widgetGetDrawWindow canvas+#endif +#ifdef GTK3+  Gtk.renderWithDrawWindow win $ do +#else +  Gtk.renderWithDrawable win $ do+#endif+    cairoXform4PageCoordinate (mkXform4Page geometry pnum)      Cairo.setSourceRGBA r g b a     case pmode of        NoPressure -> do @@ -243,36 +261,40 @@  -- |  drawFuncGen :: em -               -> (RenderCache -> (PageNum,Page em) -> Maybe BBox +               -> (RenderCache -> CanvasId -> (PageNum,Page em) -> Maybe BBox                     -> DrawFlag -> Cairo.Render (Page em))                 -> DrawingFunction SinglePage em drawFuncGen _typ render = SinglePageDraw func -  where func cache isCurrentCvs (canvas,msfc) (pnum,page) vinfo mbbox flag = do +  where func cache cid isCurrentCvs (canvas,msfc) (pnum,page) vinfo mbbox flag = do            let arr = view pageArrangement vinfo           geometry <- makeCanvasGeometry pnum arr canvas-          win <- widgetGetDrawWindow canvas+#ifdef GTK3          +          Just win <- Gtk.widgetGetWindow canvas+#else+          win <- Gtk.widgetGetDrawWindow canvas+#endif            let ibboxnew = getViewableBBox geometry mbbox            let mbboxnew = toMaybe ibboxnew                xformfunc = cairoXform4PageCoordinate (mkXform4Page geometry pnum)               renderfunc = do                 xformfunc -                pg <- render cache (pnum,page) mbboxnew flag+                pg <- render cache cid (pnum,page) mbboxnew flag                 -- Start Widget                 when isCurrentCvs (emphasisCanvasRender ColorBlue geometry)                   -- End Widget                 Cairo.resetClip                  return pg -          doubleBufferDraw (win,msfc) geometry xformfunc renderfunc ibboxnew +          doubleBufferDraw (win,msfc) geometry renderfunc ibboxnew            >>= maybe (return page) return    -- | -drawFuncSelGen :: (RenderCache -> (PageNum,Page SelectMode) -> Maybe BBox +drawFuncSelGen :: (RenderCache -> CanvasId -> (PageNum,Page SelectMode) -> Maybe BBox                     -> DrawFlag -> Cairo.Render ()) -                  -> (RenderCache -> (PageNum,Page SelectMode) -> Maybe BBox +                  -> (RenderCache -> CanvasId -> (PageNum,Page SelectMode) -> Maybe BBox                        -> DrawFlag -> Cairo.Render ())                   -> DrawingFunction SinglePage SelectMode  -drawFuncSelGen rencont rensel = drawFuncGen SelectMode (\c x y f -> rencont c x y f >> rensel c x y f >> return (snd x)) +drawFuncSelGen rencont rensel = drawFuncGen SelectMode (\c i x y f -> rencont c i x y f >> rensel c i x y f >> return (snd x))   -- | emphasisCanvasRender :: PenColor -> CanvasGeometry -> Cairo.Render ()@@ -312,14 +334,15 @@   -- |-drawContPageGen :: (RenderCache -> (PageNum,Page EditMode) -> Maybe BBox +drawContPageGen :: (RenderCache -> CanvasId -> (PageNum,Page EditMode) -> Maybe BBox                      -> DrawFlag -> Cairo.Render (Int,Page EditMode))                     -> DrawingFunction ContinuousPage EditMode drawContPageGen render = ContPageDraw func    where func :: RenderCache -> Bool -> CanvasInfo ContinuousPage               -> Maybe BBox -> Hoodle EditMode -> DrawFlag -> IO (Hoodle EditMode)         func cache isCurrentCvs cinfo mbbox hdl flag = do -          let arr = view (viewInfo.pageArrangement) cinfo+          let cid = view canvasId cinfo+              arr = view (viewInfo.pageArrangement) cinfo               pnum = PageNum . view currentPageNum $ cinfo                canvas = view drawArea cinfo                msfc = view mDrawSurface cinfo@@ -330,7 +353,11 @@                         $ (getPagesInViewPortRange geometry hdl)                  where f k = maybe Nothing (\a->Just (k,a))                              . M.lookup (unPageNum k) $ pgs-          win <- widgetGetDrawWindow canvas+#ifdef GTK3          +          Just win <- Gtk.widgetGetWindow canvas+#else+          win <- Gtk.widgetGetDrawWindow canvas+#endif           let ibboxnew = getViewableBBox geometry mbbox            let mbboxnew = toMaybe ibboxnew                xformfunc = cairoXform4PageCoordinate (mkXform4Page geometry pnum)@@ -338,7 +365,7 @@                 Cairo.identityMatrix                  cairoXform4PageCoordinate (mkXform4Page geometry pn)                 let pgmbbox = fmap (getBBoxInPageCoord geometry pn) mbboxnew-                render cache (pn,pg) pgmbbox flag+                render cache cid (pn,pg) pgmbbox flag               renderfunc = do                 xformfunc                  ndrawpgs <- mapM onepagerender drawpgs @@ -352,21 +379,22 @@                 drawWidgets allWidgets hdl cinfo mbbox_canvas                  Cairo.resetClip                  return nhdl -          doubleBufferDraw (win,msfc) geometry xformfunc renderfunc ibboxnew+          doubleBufferDraw (win,msfc) geometry renderfunc ibboxnew           >>= maybe (return hdl) return     -- |-drawContPageSelGen :: (RenderCache -> (PageNum,Page EditMode) -> Maybe BBox +drawContPageSelGen :: (RenderCache -> CanvasId -> (PageNum,Page EditMode) -> Maybe BBox                         -> DrawFlag -> Cairo.Render (Int,Page EditMode)) -                   -> (RenderCache -> (PageNum, Page SelectMode) -> Maybe BBox +                   -> (RenderCache -> CanvasId -> (PageNum, Page SelectMode) -> Maybe BBox                         -> DrawFlag -> Cairo.Render (Int,Page SelectMode))                    -> DrawingFunction ContinuousPage SelectMode drawContPageSelGen rendergen rendersel = ContPageDraw func    where func :: RenderCache -> Bool -> CanvasInfo ContinuousPage               -> Maybe BBox -> Hoodle SelectMode ->DrawFlag -> IO (Hoodle SelectMode)          func cache isCurrentCvs cinfo mbbox thdl flag = do -          let arr = view (viewInfo.pageArrangement) cinfo+          let cid = view canvasId cinfo+              arr = view (viewInfo.pageArrangement) cinfo               pnum = PageNum . view currentPageNum $ cinfo                mtpage = view gselSelected thdl                canvas = view drawArea cinfo @@ -379,21 +407,25 @@                         $ (getPagesInViewPortRange geometry hdl)                  where f k = maybe Nothing (\a->Just (k,a))                              . M.lookup (unPageNum k) $ pgs-          win <- widgetGetDrawWindow canvas+#ifdef GTK3                            +          Just win <- Gtk.widgetGetWindow canvas+#else+          win <- Gtk.widgetGetDrawWindow canvas+#endif           let ibboxnew = getViewableBBox geometry mbbox               mbboxnew = toMaybe ibboxnew               onepagerender (pn,pg) = do                   Cairo.identityMatrix                                  let xform = mkXform4Page geometry pn                 cairoXform4PageCoordinate xform-                rendergen cache (pn,pg) (fmap (getBBoxInPageCoord geometry pn) mbboxnew) flag+                rendergen cache cid (pn,pg) (fmap (getBBoxInPageCoord geometry pn) mbboxnew) flag               selpagerender :: (PageNum, Page SelectMode)                              -> Cairo.Render (Int, Page SelectMode)                selpagerender (pn,pg) = do                  Cairo.identityMatrix                 let xform = mkXform4Page geometry pn                 cairoXform4PageCoordinate xform -                rendersel cache (pn,pg) (fmap (getBBoxInPageCoord geometry pn) mbboxnew) flag+                rendersel cache cid (pn,pg) (fmap (getBBoxInPageCoord geometry pn) mbboxnew) flag               renderfunc :: Cairo.Render (Hoodle SelectMode)               renderfunc = do                 let xform = mkXform4Page geometry pnum@@ -413,8 +445,7 @@                 drawWidgets allWidgets hdl cinfo mbbox_canvas                 Cairo.resetClip                  return nthdl2  -          doubleBufferDraw (win,msfc) geometry (cairoXform4PageCoordinate (mkXform4Page geometry pnum)) -            renderfunc ibboxnew+          doubleBufferDraw (win,msfc) geometry renderfunc ibboxnew           >>= maybe (return thdl) return   @@ -422,28 +453,28 @@ drawSinglePage :: CanvasGeometry -> DrawingFunction SinglePage EditMode drawSinglePage geometry = drawFuncGen EditMode f    where -    f cache (pnum,page) mbbox flag = do +    f cache cid (pnum,page) mbbox flag = do        let xform = mkXform4Page geometry pnum       case flag of-        Clear        -> do (pg',_) <- cairoRenderOption (RBkgDrawPDF,DrawFull) cache (page,Just xform) +        Clear        -> do (pg',_) <- cairoRenderOption (RBkgDrawPDF,DrawFull) cache cid (page,Just xform)                             return pg' -        BkgEfficient -> do (InBBoxBkgBuf pg',_) <- cairoRenderOption (InBBoxOption mbbox) cache (InBBoxBkgBuf page, Just xform) +        BkgEfficient -> do (InBBoxBkgBuf pg',_) <- cairoRenderOption (InBBoxOption mbbox) cache cid (InBBoxBkgBuf page, Just xform)                             return pg' -        Efficient    -> do (InBBox pg',_) <- cairoRenderOption (InBBoxOption mbbox) cache (InBBox page, Just xform)+        Efficient    -> do (InBBox pg',_) <- cairoRenderOption (InBBoxOption mbbox) cache cid (InBBox page, Just xform)                            return pg'   -- | drawSinglePageSel :: CanvasGeometry -> DrawingFunction SinglePage SelectMode     drawSinglePageSel geometry = drawFuncSelGen rendercontent renderselect-  where rendercontent cache (pnum,tpg) mbbox flag = do+  where rendercontent cache cid (pnum,tpg) mbbox flag = do           let pg' = hPage2RPage tpg                xform = mkXform4Page geometry pnum           case flag of -            Clear -> cairoRenderOption (RBkgDrawPDF,DrawFull) cache (pg',Just xform) >> return ()-            BkgEfficient -> cairoRenderOption (InBBoxOption mbbox) cache (InBBoxBkgBuf pg',Just xform) >> return ()-            Efficient -> cairoRenderOption (InBBoxOption mbbox) cache (InBBox pg',Just xform) >> return ()+            Clear -> cairoRenderOption (RBkgDrawPDF,DrawFull) cache cid (pg',Just xform) >> return ()+            BkgEfficient -> cairoRenderOption (InBBoxOption mbbox) cache cid (InBBoxBkgBuf pg',Just xform) >> return ()+            Efficient -> cairoRenderOption (InBBoxOption mbbox) cache cid (InBBox pg',Just xform) >> return ()           return ()-        renderselect _cache (_pnum,tpg) mbbox _flag = do +        renderselect _cache _cid (_pnum,tpg) mbbox _flag = do            cairoHittedBoxDraw geometry tpg mbbox           return () @@ -451,14 +482,14 @@ drawContHoodle :: CanvasGeometry -> DrawingFunction ContinuousPage EditMode drawContHoodle geometry = drawContPageGen f     where -    f cache (pnum@(PageNum n),page) mbbox flag = do +    f cache cid (pnum@(PageNum n),page) mbbox flag = do        let xform = mkXform4Page geometry pnum       case flag of-        Clear        -> do (p',_) <- cairoRenderOption (RBkgDrawPDF,DrawFull) cache (page, Just xform) +        Clear        -> do (p',_) <- cairoRenderOption (RBkgDrawPDF,DrawFull) cache cid (page, Just xform)                             return (n, p')-        BkgEfficient -> do (p',_) <- cairoRenderOption (InBBoxOption mbbox) cache (InBBoxBkgBuf page, Just xform)+        BkgEfficient -> do (p',_) <- cairoRenderOption (InBBoxOption mbbox) cache cid (InBBoxBkgBuf page, Just xform)                            return (n, unInBBoxBkgBuf p')-        Efficient    -> do (p',_) <- cairoRenderOption (InBBoxOption mbbox) cache (InBBox page, Just xform)+        Efficient    -> do (p',_) <- cairoRenderOption (InBBoxOption mbbox) cache cid (InBBox page, Just xform)                            return (n, unInBBox p')  @@ -466,13 +497,13 @@ drawContHoodleSel :: CanvasGeometry                    -> DrawingFunction ContinuousPage SelectMode drawContHoodleSel geometry = drawContPageSelGen renderother renderselect -  where renderother cache (pnum@(PageNum n),page) mbbox flag = do+  where renderother cache cid (pnum@(PageNum n),page) mbbox flag = do           let xform = mkXform4Page geometry pnum           case flag of -            Clear -> (,) n . fst <$> cairoRenderOption (RBkgDrawPDF,DrawFull) cache (page,Just xform) -            BkgEfficient -> (,) n . unInBBoxBkgBuf . fst <$> cairoRenderOption (InBBoxOption mbbox) cache (InBBoxBkgBuf page,Just xform)-            Efficient -> (,) n . unInBBox . fst <$> cairoRenderOption (InBBoxOption mbbox) cache (InBBox page,Just xform)-        renderselect _cache (PageNum n,tpg) mbbox _flag = do+            Clear -> (,) n . fst <$> cairoRenderOption (RBkgDrawPDF,DrawFull) cache cid (page,Just xform) +            BkgEfficient -> (,) n . unInBBoxBkgBuf . fst <$> cairoRenderOption (InBBoxOption mbbox) cache cid (InBBoxBkgBuf page,Just xform)+            Efficient -> (,) n . unInBBox . fst <$> cairoRenderOption (InBBoxOption mbbox) cache cid (InBBox page,Just xform)+        renderselect _cache _cid (PageNum n,tpg) mbbox _flag = do           cairoHittedBoxDraw geometry tpg mbbox            return (n,tpg) @@ -587,11 +618,12 @@  -- |  canvasImageSurface :: RenderCache+                   -> CanvasId                    -> Maybe Double  -- ^ multiply                     -> CanvasGeometry                    -> Hoodle EditMode                     -> IO (Cairo.Surface,Dimension)-canvasImageSurface cache mmulti geometry hdl = do +canvasImageSurface cache cid mmulti geometry hdl = do    let ViewPortBBox bbx_desk = getCanvasViewPort geometry        nbbx_desk = case mmulti of                     Nothing -> bbx_desk @@ -615,7 +647,7 @@             Cairo.translate (z*ws_cvs) (z*hs_cvs)         let xform = mkXform4Page geometry pn         cairoXform4PageCoordinate xform-        cairoRenderOption (InBBoxOption Nothing) cache (InBBox pg,Nothing :: Maybe Xform4Page)  -- Just xform+        cairoRenderOption (InBBoxOption Nothing) cache cid (InBBox pg, Nothing :: Maybe Xform4Page)       renderfunc = do          Cairo.setSourceRGBA 0.5 0.5 0.5 1         Cairo.rectangle 0 0 w_cvs h_cvs        @@ -646,8 +678,11 @@   when (ClockWidget `elem` witms && view (canvasWidgets.widgetConfig.doesUseClockWidget) cinfo) $     renderClockWidget mbbox (view (canvasWidgets.clockWidgetConfig) cinfo)     +  when (ScrollWidget `elem` witms && view (canvasWidgets.widgetConfig.doesUseScrollWidget) cinfo) $+    renderScrollWidget mbbox (view (canvasWidgets.scrollWidgetConfig) cinfo)      + --------------------- -- Pan Zoom Widget -- ---------------------@@ -698,12 +733,12 @@       pg <- MaybeT . return $ view (gpages.at cpn) hdl       let lyrs = view glayers pg           n = currIndex lyrs -          l = current lyrs -          LyBuf msfc = view gbuffer l+          -- l = current lyrs        lift $ renderLayerWidget (show n) mbbox cvscoord        when (view layerWidgetShowContent lc) $ do -        sfc <- MaybeT . return $ msfc -        lift $ renderLayerContent mbbox (view gdimension pg) sfc cvscoord+        liftIO $ putStrLn "drawLayerWidget: not implemented"+        -- sfc <- MaybeT . return $ msfc +        -- lift $ renderLayerContent mbbox (view gdimension pg) sfc cvscoord     return ()   renderLayerContent :: Maybe BBox @@ -763,28 +798,28 @@   Cairo.fill   --    Cairo.identityMatrix -  l1 <- createLayout "layer"-  updateLayout l1 -  (_,reclog) <- liftIO $ layoutGetExtents l1-  let PangoRectangle _ _ w1 h1 = reclog +  l1 <- Gtk.createLayout "layer"+  Gtk.updateLayout l1 +  (_,reclog) <- liftIO $ Gtk.layoutGetExtents l1+  let Gtk.PangoRectangle _ _ w1 h1 = reclog    Cairo.moveTo (x+15) y   let sx1 = 50 / w1        sy1 = 20 / h1    Cairo.scale sx1 sy1 -  layoutPath l1+  Gtk.layoutPath l1   Cairo.setSourceRGBA 0 0 0 0.4   Cairo.fill   --    Cairo.identityMatrix-  l <- createLayout str -  updateLayout l -  (_,reclog2) <- liftIO $ layoutGetExtents l-  let PangoRectangle _ _ w h = reclog2 +  l <- Gtk.createLayout str +  Gtk.updateLayout l +  (_,reclog2) <- liftIO $ Gtk.layoutGetExtents l+  let Gtk.PangoRectangle _ _ w h = reclog2    Cairo.moveTo (x+30) (y+20)   let sx = 40 / w        sy = 60 / h    Cairo.scale sx sy -  layoutPath l +  Gtk.layoutPath l   Cairo.setSourceRGBA 0 0 0 0.4   Cairo.fill @@ -822,6 +857,24 @@   Cairo.lineTo (x+30*sin (div2rad 12 h + div2rad 720 m))                 (y-30*cos (div2rad 12 h + div2rad 720 m))    Cairo.stroke+  -- +  Cairo.resetClip ++++------------------+-- Clock Widget --+------------------++renderScrollWidget :: Maybe BBox -> ScrollWidgetConfig -> Cairo.Render () +renderScrollWidget mbbox _cfg = do +  Cairo.identityMatrix +  clipBBox mbbox +  Cairo.setSourceRGBA 0.5 0.5 0.2 0.3 +  Cairo.moveTo 100 0+  Cairo.lineTo 0 50 +  Cairo.lineTo 200 50 +  Cairo.fill    --    Cairo.resetClip
src/Hoodle/Widget/Clock.hs view
@@ -1,9 +1,9 @@ ----------------------------------------------------------------------------- -- | -- Module      : Hoodle.Widget.Clock--- Copyright   : (c) 2013, 2014 Ian-Woo Kim+-- Copyright   : (c) 2013-2015 Ian-Woo Kim ----- License     : GPL-3+-- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com> -- Stability   : experimental -- Portability : GHC@@ -14,7 +14,7 @@  module Hoodle.Widget.Clock where -import           Control.Lens (view,set,over)+import           Control.Lens (view,set,over,(.~)) import           Control.Monad.State  import           Data.Functor.Identity (Identity(..)) import           Data.List (delete)@@ -25,6 +25,7 @@ import           Data.Hoodle.Simple  import           Graphics.Hoodle.Render.Util.HitTest --+import           Hoodle.Accessor import           Hoodle.Coroutine.Draw import           Hoodle.Coroutine.Pen import           Hoodle.Device@@ -62,11 +63,13 @@ startClockWidget :: (CanvasId,CanvasInfo a,CanvasGeometry)                  -> CWAction                   -> MainCoroutine () -startClockWidget (cid,cinfo,geometry) (Move (oxy,owxy)) = do +startClockWidget (_cid,cinfo,geometry) (Move (oxy,owxy)) = do      xst <- get -    let hdl = getHoodle xst-        cache = view renderCache xst-    (srcsfc,Dim wsfc hsfc) <- liftIO (canvasImageSurface cache Nothing geometry hdl)+    cache <- renderCache+    let uhdl = view (unitHoodles.currentUnit) xst+        hdl = getHoodle uhdl+        cid = getCurrentCanvasId uhdl+    (srcsfc,Dim wsfc hsfc) <- liftIO (canvasImageSurface cache cid Nothing geometry hdl)     -- need to draw other widgets here                                  let otherwidgets = delete ClockWidget allWidgets      liftIO $ Cairo.renderWith srcsfc (drawWidgets otherwidgets hdl cinfo Nothing) @@ -107,24 +110,26 @@                    -> MainCoroutine () moveClockWidget cid geometry (srcsfc,tgtsfc) (CvsCoord (xw,yw)) (CvsCoord (x0,y0)) pcoord = do      let CvsCoord (x,y) = (desktop2Canvas geometry . device2Desktop geometry) pcoord -    xst <- get -    let CanvasDimension (Dim cw ch) = canvasDim geometry -        cinfobox = getCanvasInfo cid xst -        nposx | xw+x-x0 < -50 = -50 -              | xw+x-x0 > cw-50 = cw-50 -              | otherwise = xw+x-x0-        nposy | yw+y-y0 < -50 = -50 -              | yw+y-y0 > ch-50 = ch-50 -              | otherwise = yw+y-y0                             -        nwpos = CvsCoord (nposx,nposy) -        changeact :: CanvasInfo a -> CanvasInfo a -        changeact cinfo =  -          set (canvasWidgets.clockWidgetConfig.clockWidgetPosition) nwpos $ cinfo-        ncinfobox = (runIdentity . forBoth unboxBiXform (return . changeact)) cinfobox-    put (setCanvasInfo (cid,ncinfobox) xst)+    modify $ \xst -> +      let uhdl = view (unitHoodles.currentUnit) xst+          CanvasDimension (Dim cw ch) = canvasDim geometry +          cinfobox = getCanvasInfo cid uhdl+          nposx | xw+x-x0 < -50 = -50 +                | xw+x-x0 > cw-50 = cw-50 +                | otherwise = xw+x-x0+          nposy | yw+y-y0 < -50 = -50 +                | yw+y-y0 > ch-50 = ch-50 +                | otherwise = yw+y-y0                             +          nwpos = CvsCoord (nposx,nposy) +          changeact :: CanvasInfo a -> CanvasInfo a +          changeact cinfo =  +            set (canvasWidgets.clockWidgetConfig.clockWidgetPosition) nwpos $ cinfo+          ncinfobox = (runIdentity . forBoth unboxBiXform (return . changeact)) cinfobox+      in (unitHoodles.currentUnit .~ (setCanvasInfo (cid,ncinfobox) uhdl)) xst     --      xst2 <- get -    let cinfobox2 = getCanvasInfo cid xst2 +    let uhdl = view (unitHoodles.currentUnit) xst2+        cinfobox2 = getCanvasInfo cid uhdl         cfg = view (unboxLens (canvasWidgets.clockWidgetConfig)) cinfobox2     liftIO $ forBoth' unboxBiAct (\cinfo-> virtualDoubleBufferDraw srcsfc tgtsfc (return ())                                      (renderClockWidget Nothing cfg) @@ -133,9 +138,10 @@ -- |  toggleClock :: CanvasId -> MainCoroutine ()  toggleClock cid = do -  modify (\xst -> -            let ncinfobox = (over (unboxLens (canvasWidgets.widgetConfig.doesUseClockWidget)) not -                             . getCanvasInfo cid ) xst -            in setCanvasInfo (cid,ncinfobox) xst)+  modify $ \xst ->+    let uhdl = view (unitHoodles.currentUnit) xst+        ncinfobox = (over (unboxLens (canvasWidgets.widgetConfig.doesUseClockWidget)) not +                           . getCanvasInfo cid ) uhdl+    in (unitHoodles.currentUnit .~ (setCanvasInfo (cid,ncinfobox) uhdl)) xst   invalidateInBBox Nothing Efficient cid
src/Hoodle/Widget/Dispatch.hs view
@@ -7,7 +7,7 @@ -- Module      : Hoodle.Widget.Dispatch  -- Copyright   : (c) 2011-2014 Ian-Woo Kim ----- License     : GPL-3+-- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com> -- Stability   : experimental -- Portability : GHC@@ -21,25 +21,22 @@ import Control.Monad.State hiding (forM_) import Control.Monad.Trans.Maybe import qualified Data.ByteString.Char8 as B+import qualified Data.Text.Encoding as TE import Data.Foldable (forM_)----- +-- import Data.Hoodle.BBox import Data.Hoodle.Simple  import Graphics.Hoodle.Render.Util.HitTest import Graphics.Hoodle.Render.Type.Item -- +import Hoodle.Coroutine.Link import Hoodle.Device -import Hoodle.ModelAction.ContextMenu import Hoodle.Type.Canvas import Hoodle.Type.Coroutine import Hoodle.Type.HoodleState- import Hoodle.Type.PageArrangement import Hoodle.Util import Hoodle.View.Coordinate - import Hoodle.Widget.Clock import Hoodle.Widget.Layer import Hoodle.Widget.PanZoom@@ -48,7 +45,8 @@                -> PointerCoord                 -> MainCoroutine ()    -- ^ default action                 -> MainCoroutine ()-widgetCheckPen cid pcoord defact = get >>= \xst -> forBoth' unboxBiAct (chk xst) (getCanvasInfo cid xst) +widgetCheckPen cid pcoord defact = +    get >>= \xst -> forBoth' unboxBiAct (chk xst) ((getCanvasInfo cid . view (unitHoodles.currentUnit)) xst)   where      chk :: HoodleState -> CanvasInfo a -> MainCoroutine ()      chk xstate cinfo = do @@ -74,12 +72,9 @@                      let lnk = bbxed_content lnkbbx                          loc = link_location lnk                          mid = case lnk of -                           LinkAnchor {..} -> Just (link_linkeddocid,link_anchorid)+                           LinkAnchor {..} -> Just (TE.decodeUtf8 link_linkeddocid,TE.decodeUtf8 link_anchorid)                            _ -> Nothing--                     forM_ -                       ((urlParse . B.unpack) loc)-                       (\url -> liftIO (openLinkAction url mid))+                     forM_  ((urlParse . B.unpack) loc) (\url -> lift (openLinkAction url mid))                      MaybeT (return (Just ()))                    _ -> MaybeT (return Nothing))       case m of
src/Hoodle/Widget/Layer.hs view
@@ -1,9 +1,9 @@ ----------------------------------------------------------------------------- -- | -- Module      : Hoodle.Widget.Layer--- Copyright   : (c) 2013, 2014 Ian-Woo Kim+-- Copyright   : (c) 2013-2015 Ian-Woo Kim ----- License     : GPL-3+-- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com> -- Stability   : experimental -- Portability : GHC@@ -14,7 +14,7 @@  module Hoodle.Widget.Layer where -import           Control.Lens (view,set,over)+import           Control.Lens (view,set,over,(.~)) import           Control.Monad.State  import           Data.Functor.Identity (Identity(..)) import           Data.List (delete)@@ -26,6 +26,7 @@ import           Data.Hoodle.Simple  import           Graphics.Hoodle.Render.Util.HitTest --+import           Hoodle.Accessor import           Hoodle.Coroutine.Draw import           Hoodle.Coroutine.Layer import           Hoodle.Coroutine.Pen@@ -67,14 +68,15 @@                  -> MainCoroutine ()  startLayerWidget (cid,_cinfo,_geometry) Close = toggleLayer cid  startLayerWidget (cid,_cinfo,_geometry) ToggleShowContent = do -    liftIO $ putStrLn "ToggleShowContent hitted"-    modify (over (currentCanvasInfo . unboxLens (canvasWidgets.layerWidgetConfig.layerWidgetShowContent)) not)+    modify $ over (unitHoodles.currentUnit)+             $ over (currentCanvasInfo . unboxLens (canvasWidgets.layerWidgetConfig.layerWidgetShowContent)) not     invalidate cid  startLayerWidget (cid,cinfo,geometry) (Move (oxy,owxy)) = do      xst <- get -    let hdl = getHoodle xst-        cache = view renderCache xst-    (srcsfc,Dim wsfc hsfc) <- liftIO (canvasImageSurface cache Nothing geometry hdl)+    cache <- renderCache+    let uhdl = view (unitHoodles.currentUnit) xst+        hdl = getHoodle uhdl+    (srcsfc,Dim wsfc hsfc) <- liftIO (canvasImageSurface cache cid Nothing geometry hdl)     -- need to draw other widgets here                                  let otherwidgets = delete LayerWidget allWidgets      liftIO $ Cairo.renderWith srcsfc (drawWidgets otherwidgets hdl cinfo Nothing) @@ -121,34 +123,36 @@                    -> MainCoroutine () moveLayerWidget cid geometry (srcsfc,tgtsfc) (CvsCoord (xw,yw)) (CvsCoord (x0,y0)) pcoord = do      let CvsCoord (x,y) = (desktop2Canvas geometry . device2Desktop geometry) pcoord -    xst <- get -    let CanvasDimension (Dim cw ch) = canvasDim geometry -        cinfobox = getCanvasInfo cid xst -        nposx | xw+x-x0 < -50 = -50 -              | xw+x-x0 > cw-50 = cw-50 -              | otherwise = xw+x-x0-        nposy | yw+y-y0 < -50 = -50 -              | yw+y-y0 > ch-50 = ch-50 -              | otherwise = yw+y-y0                             -        nwpos = CvsCoord (nposx,nposy) -        changeact :: CanvasInfo a -> CanvasInfo a -        changeact cinfo =  -          set (canvasWidgets.layerWidgetConfig.layerWidgetPosition) nwpos $ cinfo-        ncinfobox = (runIdentity . forBoth unboxBiXform (return . changeact)) cinfobox-    put (setCanvasInfo (cid,ncinfobox) xst)-    let hdl = getHoodle xst -    -- -    xst2 <- get -    let cinfobox2 = getCanvasInfo cid xst2 -    liftIO $ forBoth' unboxBiAct (\cinfo-> virtualDoubleBufferDraw srcsfc tgtsfc (return ()) -                                    (drawLayerWidget hdl cinfo Nothing nwpos) -                                  >> doubleBufferFlush tgtsfc cinfo) cinfobox2+    get >>= \xst -> do+      let uhdl = view (unitHoodles.currentUnit) xst+          CanvasDimension (Dim cw ch) = canvasDim geometry +          cinfobox = getCanvasInfo cid uhdl+          nposx | xw+x-x0 < -50 = -50 +                | xw+x-x0 > cw-50 = cw-50 +                | otherwise = xw+x-x0+          nposy | yw+y-y0 < -50 = -50 +                | yw+y-y0 > ch-50 = ch-50 +                | otherwise = yw+y-y0                             +          nwpos = CvsCoord (nposx,nposy) +          changeact :: CanvasInfo a -> CanvasInfo a +          changeact cinfo =  +            set (canvasWidgets.layerWidgetConfig.layerWidgetPosition) nwpos $ cinfo+          ncinfobox = (runIdentity . forBoth unboxBiXform (return . changeact)) cinfobox+      put $ (unitHoodles.currentUnit .~ setCanvasInfo (cid,ncinfobox) uhdl) xst+      -- +      xst2 <- get +      let uhdl2 = view (unitHoodles.currentUnit) xst2+          hdl2 = getHoodle uhdl2+          cinfobox2 = getCanvasInfo cid uhdl2+      liftIO $ forBoth' unboxBiAct (\cinfo-> virtualDoubleBufferDraw srcsfc tgtsfc (return ()) +                                      (drawLayerWidget hdl2 cinfo Nothing nwpos) +                                    >> doubleBufferFlush tgtsfc cinfo) cinfobox2    -- |  toggleLayer :: CanvasId -> MainCoroutine ()  toggleLayer cid = do -  modify (\xst -> -            let ncinfobox = (over (unboxLens (canvasWidgets.widgetConfig.doesUseLayerWidget)) not -                             . getCanvasInfo cid ) xst -            in setCanvasInfo (cid,ncinfobox) xst)-  invalidateInBBox Nothing Efficient cid+    pureUpdateUhdl $ \uhdl -> +      let ncinfobox = (over (unboxLens (canvasWidgets.widgetConfig.doesUseLayerWidget)) not +                      . getCanvasInfo cid ) uhdl+      in setCanvasInfo (cid,ncinfobox) uhdl+    invalidateInBBox Nothing Efficient cid
src/Hoodle/Widget/PanZoom.hs view
@@ -1,9 +1,11 @@+{-# LANGUAGE MultiWayIf #-}+ ----------------------------------------------------------------------------- -- | -- Module      : Hoodle.Widget.PanZoom--- Copyright   : (c) 2013, 2014 Ian-Woo Kim+-- Copyright   : (c) 2013-2015 Ian-Woo Kim ----- License     : GPL-3+-- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com> -- Stability   : experimental -- Portability : GHC@@ -15,6 +17,7 @@ module Hoodle.Widget.PanZoom where  -- from other packages+import           Control.Applicative import           Control.Lens (view,set,over,(.~)) import           Control.Monad.Identity  import           Control.Monad.State @@ -84,15 +87,15 @@ startPanZoomWidget tchmode (cid,cinfo,geometry) mmode = do      modify (doesNotInvalidate .~ True)     xst <- get -    let hdl = getHoodle xst-        cache = view renderCache xst+    cache <- renderCache+    let hdl = (getHoodle . view (unitHoodles.currentUnit)) xst     case mmode of        Nothing -> togglePanZoom cid       Just (mode,(oxy,owxy)) -> do          (srcsfc,Dim wsfc hsfc) <- case mode of -          Moving -> liftIO (canvasImageSurface cache Nothing geometry hdl)-          Zooming -> liftIO (canvasImageSurface cache (Just 1) geometry hdl)-          Panning _ -> liftIO (canvasImageSurface cache (Just 1) geometry hdl) +          Moving -> liftIO (canvasImageSurface cache cid Nothing geometry hdl)+          Zooming -> liftIO (canvasImageSurface cache cid (Just 1) geometry hdl)+          Panning _ -> liftIO (canvasImageSurface cache cid (Just 1) geometry hdl)          -- need to draw other widgets here                                      let otherwidgets = delete PanZoomWidget allWidgets          liftIO $ Cairo.renderWith @@ -114,16 +117,10 @@                -> (Double,(Double,Double)) findZoomXform (Dim w h) ((xo,yo),(x0,_y0),(x,_y)) =      let tx = x - x0 -        -- ty = y - y0          ztx = 1 + tx / 200-        -- zty = 1 + ty / 200         zx | ztx > 2 = 2              | ztx < 0.5 = 0.5            | otherwise = ztx-        -- zy | zty > 2 = 2  -        --    | zty < 0.5 = 0.5-        --    | otherwise = zty                                          -        -- simplified         z = zx          xtrans = (1 -z)*xo/z-w         ytrans = (1- z)*yo/z-h @@ -187,19 +184,20 @@           case mpnpgxy of              Nothing -> return ()              Just pnpgxy -> do -              xstate <- get-              geom' <- liftIO $ getCanvasGeometryCvsId cid xstate+              uhdl <- view (unitHoodles.currentUnit) <$> get+              geom' <- liftIO $ getCanvasGeometryCvsId cid uhdl               let DeskCoord (xd,yd) = page2Desktop geom' pnpgxy                   DeskCoord (xd0,yd0) = canvas2Desktop geom' ccoord -              moveViewPortBy (return ()) cid -                (\(xorig,yorig)->(xorig+xd-xd0,yorig+yd-yd0)) +              moveViewPortBy (return ()) cid (\(xorig,yorig)->(xorig+xd-xd0,yorig+yd-yd0))          Panning _ -> do            let (x_d,y_d) = (unDeskCoord . device2Desktop geometry) pcoord                 (x0_d,y0_d) = (unDeskCoord . canvas2Desktop geometry)                                (CvsCoord (x0,y0))-              (dx_d,dy_d) = (x_d-x0_d,y_d-y0_d)-          moveViewPortBy (return ()) cid -            (\(xorig,yorig)->(xorig-dx_d,yorig-dy_d))                 +              (dx_d,dy_d) = let (dx_d1,dy_d1) = (x_d-x0_d,y_d-y0_d)+                            in if | abs dx_d1 < 25 -> (0,dy_d1)+                                  | abs dy_d1 < 25 -> (dx_d1,0)+                                  | otherwise -> (dx_d1,dy_d1)+          moveViewPortBy (return ()) cid (\(xorig,yorig)->(xorig-dx_d,yorig-dy_d))                          _ -> return ()       invalidate cid  @@ -212,11 +210,11 @@              -> MainCoroutine ()  movingRender mode cid geometry (srcsfc,tgtsfc) (CvsCoord (xw,yw)) (CvsCoord (x0,y0)) pcoord = do      let CvsCoord (x,y) = (desktop2Canvas geometry . device2Desktop geometry) pcoord -    xst <- get +    uhdl <- view (unitHoodles.currentUnit) <$> get      case mode of       Moving -> do          let CanvasDimension (Dim cw ch) = canvasDim geometry -            cinfobox = getCanvasInfo cid xst +            cinfobox = getCanvasInfo cid uhdl             nposx | xw+x-x0 < -50 = -50                    | xw+x-x0 > cw-50 = cw-50                    | otherwise = xw+x-x0@@ -228,21 +226,21 @@             changeact cinfo =                 set (canvasWidgets.panZoomWidgetConfig.panZoomWidgetPosition) nwpos $ cinfo             ncinfobox = (runIdentity . forBoth unboxBiXform (return.changeact)) cinfobox-            isTouchZoom = view (unboxLens (canvasWidgets.panZoomWidgetConfig.panZoomWidgetTouchIsZoom)) cinfobox                         -        put (setCanvasInfo (cid,ncinfobox) xst)+            isTouchZoom = view (unboxLens (canvasWidgets.panZoomWidgetConfig.panZoomWidgetTouchIsZoom)) cinfobox+        pureUpdateUhdl $ setCanvasInfo (cid,ncinfobox)         virtualDoubleBufferDraw srcsfc tgtsfc (return ()) (renderPanZoomWidget isTouchZoom Nothing nwpos)       Zooming -> do -        let cinfobox = getCanvasInfo cid xst               +        let cinfobox = getCanvasInfo cid uhdl              let pos = runIdentity (forBoth' unboxBiAct (return.view (canvasWidgets.panZoomWidgetConfig.panZoomWidgetPosition)) cinfobox)         let (xo,yo) = (xw+50,yw+50)             CanvasDimension cdim = canvasDim geometry              (z,(xtrans,ytrans)) = findZoomXform cdim ((xo,yo),(x0,y0),(x,y))-            isTouchZoom = view (unboxLens (canvasWidgets.panZoomWidgetConfig.panZoomWidgetTouchIsZoom)) cinfobox             +            isTouchZoom = view (unboxLens (canvasWidgets.panZoomWidgetConfig.panZoomWidgetTouchIsZoom)) cinfobox         virtualDoubleBufferDraw srcsfc tgtsfc            (Cairo.save >> Cairo.scale z z >> Cairo.translate xtrans ytrans)           (Cairo.restore >> renderPanZoomWidget isTouchZoom Nothing pos)       Panning b -> do -        let cinfobox = getCanvasInfo cid xst               +        let cinfobox = getCanvasInfo cid uhdl                            CanvasDimension cdim = canvasDim geometry              (xtrans,ytrans) = findPanXform cdim ((x0,y0),(x,y))         let CanvasDimension (Dim cw ch) = canvasDim geometry @@ -258,29 +256,29 @@                       runIdentity (forBoth' unboxBiAct (return.view (canvasWidgets.panZoomWidgetConfig.panZoomWidgetPosition)) cinfobox)             ncinfobox = set (unboxLens (canvasWidgets.panZoomWidgetConfig.panZoomWidgetPosition)) nwpos cinfobox             isTouchZoom = view (unboxLens (canvasWidgets.panZoomWidgetConfig.panZoomWidgetTouchIsZoom)) cinfobox -        put (setCanvasInfo (cid,ncinfobox) xst)+        pureUpdateUhdl $ setCanvasInfo (cid,ncinfobox)         virtualDoubleBufferDraw srcsfc tgtsfc            (Cairo.save >> Cairo.translate xtrans ytrans)            (Cairo.restore >> renderPanZoomWidget isTouchZoom Nothing nwpos)     --        xst2 <- get -    let cinfobox = getCanvasInfo cid xst2 +    let cinfobox = getCanvasInfo cid . view (unitHoodles.currentUnit) $ xst2      liftIO $ forBoth' unboxBiAct (doubleBufferFlush tgtsfc) cinfobox     -- |  togglePanZoom :: CanvasId -> MainCoroutine ()  togglePanZoom cid = do -    modify $ \xst -> -      let cinfobox = getCanvasInfo cid xst +    pureUpdateUhdl $ \uhdl -> +      let cinfobox = getCanvasInfo cid uhdl           ncinfobox = over (unboxLens (canvasWidgets.widgetConfig.doesUsePanZoomWidget)) not cinfobox-      in setCanvasInfo (cid,ncinfobox) xst +      in setCanvasInfo (cid,ncinfobox) uhdl     invalidateInBBox Nothing Efficient cid    -- |  touchStart :: CanvasId -> PointerCoord -> MainCoroutine () -touchStart cid pcoord = forBoth' unboxBiAct chk =<< liftM (getCanvasInfo cid) get+touchStart cid pcoord = forBoth' unboxBiAct chk =<< (getCanvasInfo cid . view (unitHoodles.currentUnit) <$> get)   where     chk :: CanvasInfo a -> MainCoroutine ()      chk cinfo = do @@ -293,13 +291,13 @@           CvsCoord (x0,y0) = view (canvasWidgets.panZoomWidgetConfig.panZoomWidgetPosition) cinfo             obbox = BBox (x0,y0) (x0+100,y0+100)        xst <- get-                 if (isPointInBBox obbox (x,y))              then do -          let changeact :: CanvasInfo a -> CanvasInfo a -              changeact = over (canvasWidgets.panZoomWidgetConfig.panZoomWidgetTouchIsZoom) not -              ncinfobox = runIdentity . forBoth unboxBiXform (return . changeact) . getCanvasInfo cid $ xst-          put (setCanvasInfo (cid,ncinfobox) xst)+          pureUpdateUhdl $ \uhdl -> +            let changeact :: CanvasInfo a -> CanvasInfo a +                changeact = over (canvasWidgets.panZoomWidgetConfig.panZoomWidgetTouchIsZoom) not +                ncinfobox = runIdentity . forBoth unboxBiXform (return . changeact) . getCanvasInfo cid $ uhdl+            in setCanvasInfo (cid,ncinfobox) uhdl           invalidateInBBox Nothing Efficient cid          else do            let b = view (settings.doesUseTouch) xst@@ -310,7 +308,7 @@             else do                let devlst = view deviceList xst                doIOaction $ \_ -> do-                setToggleUIForFlag "HANDA" (settings.doesUseTouch) xst+                lensSetToggleUIForFlag "HANDA" (settings.doesUseTouch) xst                 -- ad hoc                  let touchstr = dev_touch_str devlst                 when (touchstr /= "touch") $ do @@ -326,16 +324,16 @@     updateFlagFromToggleUI "HANDA"  (settings.doesUseTouch)     xst <- get      let devlst = view deviceList xst -    let b = view (settings.doesUseTouch) xst-    when b $ do +        uhdl = view (unitHoodles.currentUnit) xst+        (cid,_cinfobox) = view currentCanvas uhdl+    when (view (settings.doesUseTouch) xst) $ do        -- ad hoc        let touchstr = dev_touch_str devlst             when (touchstr /= "touch") $ do          liftIO $ readProcess "xinput" [ "enable", dev_touch_str devlst ] ""            return ()       ---      let (cid,_cinfobox) = view currentCanvas xst -      put (set (currentCanvasInfo. unboxLens (canvasWidgets.widgetConfig.doesUsePanZoomWidget)) True xst)+      pureUpdateUhdl $ (currentCanvasInfo. unboxLens (canvasWidgets.widgetConfig.doesUsePanZoomWidget)) .~ True       invalidateInBBox Nothing Efficient cid          return ()
+ src/Hoodle/Widget/Scroll.hs view
@@ -0,0 +1,36 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Hoodle.Widget.Scroll+-- Copyright   : (c) 2014 Ian-Woo Kim+--+-- License     : BSD3+-- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability   : experimental+-- Portability : GHC+--+-- Pan-Zoom widget drawing and action+-- +-----------------------------------------------------------------------------++module Hoodle.Widget.Scroll where++import Control.Lens ((%~))+--+import Hoodle.Accessor+import Hoodle.Coroutine.Draw+import Hoodle.Type.Canvas+import Hoodle.Type.Coroutine+import Hoodle.Type.Enum+import Hoodle.Type.HoodleState+import Hoodle.Type.Widget+++-- | +toggleScroll :: CanvasId -> MainCoroutine () +toggleScroll cid = do +    pureUpdateUhdl $ \uhdl -> +      let ncinfobox = +            ( (unboxLens (canvasWidgets.widgetConfig.doesUseScrollWidget) %~ not)+            . getCanvasInfo cid ) uhdl +      in setCanvasInfo (cid,ncinfobox) uhdl+    invalidateInBBox Nothing Efficient cid