libhbb (empty) → 0.1.1.0
raw patch · 23 files changed
+3423/−0 lines, 23 filesdep +aesondep +basedep +bytestringsetup-changed
Dependencies added: aeson, base, bytestring, filepath, ghc, ghc-paths, hspec, libhbb, mtl, process, syb, text, time, unordered-containers
Files
- LICENSE +458/−0
- Language/Haskell/HBB/ApplyTo.hs +58/−0
- Language/Haskell/HBB/ExprType.hs +54/−0
- Language/Haskell/HBB/Inline.hs +128/−0
- Language/Haskell/HBB/Internal/AST.hs +47/−0
- Language/Haskell/HBB/Internal/GHC.hs +120/−0
- Language/Haskell/HBB/Internal/GHCHighlevel.hs +324/−0
- Language/Haskell/HBB/Internal/InternalTTree.hs +347/−0
- Language/Haskell/HBB/Internal/InternalTTreeCreation.hs +365/−0
- Language/Haskell/HBB/Internal/Lexer.hs +74/−0
- Language/Haskell/HBB/Internal/SrcSpan.hs +199/−0
- Language/Haskell/HBB/Internal/TTree.hs +177/−0
- Language/Haskell/HBB/Internal/TTreeColor.hs +97/−0
- Language/Haskell/HBB/Internal/TTreeJSON.hs +204/−0
- Language/Haskell/HBB/Locate.hs +70/−0
- Language/Haskell/HBB/OccurrencesOf.hs +314/−0
- Language/Haskell/HBB/SmartInline.hs +88/−0
- README.md +16/−0
- Setup.hs +2/−0
- editor-plugin/vim/hbb.vim +59/−0
- libhbb.cabal +129/−0
- src/HBBSimpleCLI.hs +86/−0
- test/Main.hs +7/−0
+ LICENSE view
@@ -0,0 +1,458 @@+ GNU LESSER GENERAL PUBLIC LICENSE+ Version 2.1, February 1999++ Copyright (C) 1991, 1999 Free Software Foundation, Inc.+ 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.++[This is the first released version of the Lesser GPL. It also counts+ as the successor of the GNU Library Public License, version 2, hence+ the version number 2.1.]++ Preamble++ The licenses for most software are designed to take away your+freedom to share and change it. By contrast, the GNU General Public+Licenses are intended to guarantee your freedom to share and change+free software--to make sure the software is free for all its users.++ This license, the Lesser General Public License, applies to some+specially designated software packages--typically libraries--of the+Free Software Foundation and other authors who decide to use it. You+can use it too, but we suggest you first think carefully about whether+this license or the ordinary General Public License is the better+strategy to use in any particular case, based on the explanations below.++ When we speak of free software, we are referring to freedom of use,+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 this service if you wish); that you receive source code or can get+it if you want it; that you can change the software and use pieces of+it in new free programs; and that you are informed that you can do+these things.++ To protect your rights, we need to make restrictions that forbid+distributors to deny you these rights or to ask you to surrender these+rights. These restrictions translate to certain responsibilities for+you if you distribute copies of the library or if you modify it.++ For example, if you distribute copies of the library, whether gratis+or for a fee, you must give the recipients all the rights that we gave+you. You must make sure that they, too, receive or can get the source+code. If you link other code with the library, you must provide+complete object files to the recipients, so that they can relink them+with the library after making changes to the library and recompiling+it. And you must show them these terms so they know their rights.++ We protect your rights with a two-step method: (1) we copyright the+library, and (2) we offer you this license, which gives you legal+permission to copy, distribute and/or modify the library.++ To protect each distributor, we want to make it very clear that+there is no warranty for the free library. Also, if the library is+modified by someone else and passed on, the recipients should know+that what they have is not the original version, so that the original+author's reputation will not be affected by problems that might be+introduced by others.++ Finally, software patents pose a constant threat to the existence of+any free program. We wish to make sure that a company cannot+effectively restrict the users of a free program by obtaining a+restrictive license from a patent holder. Therefore, we insist that+any patent license obtained for a version of the library must be+consistent with the full freedom of use specified in this license.++ Most GNU software, including some libraries, is covered by the+ordinary GNU General Public License. This license, the GNU Lesser+General Public License, applies to certain designated libraries, and+is quite different from the ordinary General Public License. We use+this license for certain libraries in order to permit linking those+libraries into non-free programs.++ When a program is linked with a library, whether statically or using+a shared library, the combination of the two is legally speaking a+combined work, a derivative of the original library. The ordinary+General Public License therefore permits such linking only if the+entire combination fits its criteria of freedom. The Lesser General+Public License permits more lax criteria for linking other code with+the library.++ We call this license the "Lesser" General Public License because it+does Less to protect the user's freedom than the ordinary General+Public License. It also provides other free software developers Less+of an advantage over competing non-free programs. These disadvantages+are the reason we use the ordinary General Public License for many+libraries. However, the Lesser license provides advantages in certain+special circumstances.++ For example, on rare occasions, there may be a special need to+encourage the widest possible use of a certain library, so that it becomes+a de-facto standard. To achieve this, non-free programs must be+allowed to use the library. A more frequent case is that a free+library does the same job as widely used non-free libraries. In this+case, there is little to gain by limiting the free library to free+software only, so we use the Lesser General Public License.++ In other cases, permission to use a particular library in non-free+programs enables a greater number of people to use a large body of+free software. For example, permission to use the GNU C Library in+non-free programs enables many more people to use the whole GNU+operating system, as well as its variant, the GNU/Linux operating+system.++ Although the Lesser General Public License is Less protective of the+users' freedom, it does ensure that the user of a program that is+linked with the Library has the freedom and the wherewithal to run+that program using a modified version of the Library.++ The precise terms and conditions for copying, distribution and+modification follow. Pay close attention to the difference between a+"work based on the library" and a "work that uses the library". The+former contains code derived from the library, whereas the latter must+be combined with the library in order to run.++ GNU LESSER GENERAL PUBLIC LICENSE+ TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION++ 0. This License Agreement applies to any software library or other+program which contains a notice placed by the copyright holder or+other authorized party saying it may be distributed under the terms of+this Lesser General Public License (also called "this License").+Each licensee is addressed as "you".++ A "library" means a collection of software functions and/or data+prepared so as to be conveniently linked with application programs+(which use some of those functions and data) to form executables.++ The "Library", below, refers to any such software library or work+which has been distributed under these terms. A "work based on the+Library" means either the Library or any derivative work under+copyright law: that is to say, a work containing the Library or a+portion of it, either verbatim or with modifications and/or translated+straightforwardly into another language. (Hereinafter, translation is+included without limitation in the term "modification".)++ "Source code" for a work means the preferred form of the work for+making modifications to it. For a library, complete source code means+all the source code for all modules it contains, plus any associated+interface definition files, plus the scripts used to control compilation+and installation of the library.++ Activities other than copying, distribution and modification are not+covered by this License; they are outside its scope. The act of+running a program using the Library is not restricted, and output from+such a program is covered only if its contents constitute a work based+on the Library (independent of the use of the Library in a tool for+writing it). Whether that is true depends on what the Library does+and what the program that uses the Library does.++ 1. You may copy and distribute verbatim copies of the Library's+complete source code as you receive it, in any medium, provided that+you conspicuously and appropriately publish on each copy an+appropriate copyright notice and disclaimer of warranty; keep intact+all the notices that refer to this License and to the absence of any+warranty; and distribute a copy of this License along with the+Library.++ You may charge a fee for the physical act of transferring a copy,+and you may at your option offer warranty protection in exchange for a+fee.++ 2. You may modify your copy or copies of the Library or any portion+of it, thus forming a work based on the Library, and copy and+distribute such modifications or work under the terms of Section 1+above, provided that you also meet all of these conditions:++ a) The modified work must itself be a software library.++ b) You must cause the files modified to carry prominent notices+ stating that you changed the files and the date of any change.++ c) You must cause the whole of the work to be licensed at no+ charge to all third parties under the terms of this License.++ d) If a facility in the modified Library refers to a function or a+ table of data to be supplied by an application program that uses+ the facility, other than as an argument passed when the facility+ is invoked, then you must make a good faith effort to ensure that,+ in the event an application does not supply such function or+ table, the facility still operates, and performs whatever part of+ its purpose remains meaningful.++ (For example, a function in a library to compute square roots has+ a purpose that is entirely well-defined independent of the+ application. Therefore, Subsection 2d requires that any+ application-supplied function or table used by this function must+ be optional: if the application does not supply it, the square+ root function must still compute square roots.)++These requirements apply to the modified work as a whole. If+identifiable sections of that work are not derived from the Library,+and can be reasonably considered independent and separate works in+themselves, then this License, and its terms, do not apply to those+sections when you distribute them as separate works. But when you+distribute the same sections as part of a whole which is a work based+on the Library, the distribution of the whole must be on the terms of+this License, whose permissions for other licensees extend to the+entire whole, and thus to each and every part regardless of who wrote+it.++Thus, it is not the intent of this section to claim rights or contest+your rights to work written entirely by you; rather, the intent is to+exercise the right to control the distribution of derivative or+collective works based on the Library.++In addition, mere aggregation of another work not based on the Library+with the Library (or with a work based on the Library) on a volume of+a storage or distribution medium does not bring the other work under+the scope of this License.++ 3. You may opt to apply the terms of the ordinary GNU General Public+License instead of this License to a given copy of the Library. To do+this, you must alter all the notices that refer to this License, so+that they refer to the ordinary GNU General Public License, version 2,+instead of to this License. (If a newer version than version 2 of the+ordinary GNU General Public License has appeared, then you can specify+that version instead if you wish.) Do not make any other change in+these notices.++ Once this change is made in a given copy, it is irreversible for+that copy, so the ordinary GNU General Public License applies to all+subsequent copies and derivative works made from that copy.++ This option is useful when you wish to copy part of the code of+the Library into a program that is not a library.++ 4. You may copy and distribute the Library (or a portion or+derivative of it, under Section 2) in object code or executable form+under the terms of Sections 1 and 2 above provided that you accompany+it with the complete corresponding machine-readable source code, which+must be distributed under the terms of Sections 1 and 2 above on a+medium customarily used for software interchange.++ If distribution of object code is made by offering access to copy+from a designated place, then offering equivalent access to copy the+source code from the same place satisfies the requirement to+distribute the source code, even though third parties are not+compelled to copy the source along with the object code.++ 5. A program that contains no derivative of any portion of the+Library, but is designed to work with the Library by being compiled or+linked with it, is called a "work that uses the Library". Such a+work, in isolation, is not a derivative work of the Library, and+therefore falls outside the scope of this License.++ However, linking a "work that uses the Library" with the Library+creates an executable that is a derivative of the Library (because it+contains portions of the Library), rather than a "work that uses the+library". The executable is therefore covered by this License.+Section 6 states terms for distribution of such executables.++ When a "work that uses the Library" uses material from a header file+that is part of the Library, the object code for the work may be a+derivative work of the Library even though the source code is not.+Whether this is true is especially significant if the work can be+linked without the Library, or if the work is itself a library. The+threshold for this to be true is not precisely defined by law.++ If such an object file uses only numerical parameters, data+structure layouts and accessors, and small macros and small inline+functions (ten lines or less in length), then the use of the object+file is unrestricted, regardless of whether it is legally a derivative+work. (Executables containing this object code plus portions of the+Library will still fall under Section 6.)++ Otherwise, if the work is a derivative of the Library, you may+distribute the object code for the work under the terms of Section 6.+Any executables containing that work also fall under Section 6,+whether or not they are linked directly with the Library itself.++ 6. As an exception to the Sections above, you may also combine or+link a "work that uses the Library" with the Library to produce a+work containing portions of the Library, and distribute that work+under terms of your choice, provided that the terms permit+modification of the work for the customer's own use and reverse+engineering for debugging such modifications.++ You must give prominent notice with each copy of the work that the+Library is used in it and that the Library and its use are covered by+this License. You must supply a copy of this License. If the work+during execution displays copyright notices, you must include the+copyright notice for the Library among them, as well as a reference+directing the user to the copy of this License. Also, you must do one+of these things:++ a) Accompany the work with the complete corresponding+ machine-readable source code for the Library including whatever+ changes were used in the work (which must be distributed under+ Sections 1 and 2 above); and, if the work is an executable linked+ with the Library, with the complete machine-readable "work that+ uses the Library", as object code and/or source code, so that the+ user can modify the Library and then relink to produce a modified+ executable containing the modified Library. (It is understood+ that the user who changes the contents of definitions files in the+ Library will not necessarily be able to recompile the application+ to use the modified definitions.)++ b) Use a suitable shared library mechanism for linking with the+ Library. A suitable mechanism is one that (1) uses at run time a+ copy of the library already present on the user's computer system,+ rather than copying library functions into the executable, and (2)+ will operate properly with a modified version of the library, if+ the user installs one, as long as the modified version is+ interface-compatible with the version that the work was made with.++ c) Accompany the work with a written offer, valid for at+ least three years, to give the same user the materials+ specified in Subsection 6a, above, for a charge no more+ than the cost of performing this distribution.++ d) If distribution of the work is made by offering access to copy+ from a designated place, offer equivalent access to copy the above+ specified materials from the same place.++ e) Verify that the user has already received a copy of these+ materials or that you have already sent this user a copy.++ For an executable, the required form of the "work that uses the+Library" must include any data and utility programs needed for+reproducing the executable from it. However, as a special exception,+the materials to be distributed need not include anything that is+normally distributed (in either source or binary form) with the major+components (compiler, kernel, and so on) of the operating system on+which the executable runs, unless that component itself accompanies+the executable.++ It may happen that this requirement contradicts the license+restrictions of other proprietary libraries that do not normally+accompany the operating system. Such a contradiction means you cannot+use both them and the Library together in an executable that you+distribute.++ 7. You may place library facilities that are a work based on the+Library side-by-side in a single library together with other library+facilities not covered by this License, and distribute such a combined+library, provided that the separate distribution of the work based on+the Library and of the other library facilities is otherwise+permitted, and provided that you do these two things:++ a) Accompany the combined library with a copy of the same work+ based on the Library, uncombined with any other library+ facilities. This must be distributed under the terms of the+ Sections above.++ b) Give prominent notice with the combined library of the fact+ that part of it is a work based on the Library, and explaining+ where to find the accompanying uncombined form of the same work.++ 8. You may not copy, modify, sublicense, link with, or distribute+the Library except as expressly provided under this License. Any+attempt otherwise to copy, modify, sublicense, link with, or+distribute the Library is void, and will automatically terminate your+rights under this License. However, parties who have received copies,+or rights, from you under this License will not have their licenses+terminated so long as such parties remain in full compliance.++ 9. You are not required to accept this License, since you have not+signed it. However, nothing else grants you permission to modify or+distribute the Library or its derivative works. These actions are+prohibited by law if you do not accept this License. Therefore, by+modifying or distributing the Library (or any work based on the+Library), you indicate your acceptance of this License to do so, and+all its terms and conditions for copying, distributing or modifying+the Library or works based on it.++ 10. Each time you redistribute the Library (or any work based on the+Library), the recipient automatically receives a license from the+original licensor to copy, distribute, link with or modify the Library+subject to these terms and conditions. You may not impose any further+restrictions on the recipients' exercise of the rights granted herein.+You are not responsible for enforcing compliance by third parties with+this License.++ 11. If, as a consequence of a court judgment or allegation of patent+infringement or for any other reason (not limited to patent issues),+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+distribute so as to satisfy simultaneously your obligations under this+License and any other pertinent obligations, then as a consequence you+may not distribute the Library at all. For example, if a patent+license would not permit royalty-free redistribution of the Library by+all those who receive copies directly or indirectly through you, then+the only way you could satisfy both it and this License would be to+refrain entirely from distribution of the Library.++If any portion of this section is held invalid or unenforceable under any+particular circumstance, the balance of the section is intended to apply,+and the section as a whole is intended to apply in other circumstances.++It is not the purpose of this section to induce you to infringe any+patents or other property right claims or to contest validity of any+such claims; this section has the sole purpose of protecting the+integrity of the free software distribution system which is+implemented by public license practices. Many people have made+generous contributions to the wide range of software distributed+through that system in reliance on consistent application of that+system; it is up to the author/donor to decide if he or she is willing+to distribute software through any other system and a licensee cannot+impose that choice.++This section is intended to make thoroughly clear what is believed to+be a consequence of the rest of this License.++ 12. If the distribution and/or use of the Library is restricted in+certain countries either by patents or by copyrighted interfaces, the+original copyright holder who places the Library under this License may add+an explicit geographical distribution limitation excluding those countries,+so that distribution is permitted only in or among countries not thus+excluded. In such case, this License incorporates the limitation as if+written in the body of this License.++ 13. The Free Software Foundation may publish revised and/or new+versions of the Lesser 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 Library+specifies a version number of this License which applies to it and+"any later version", you have the option of following the terms and+conditions either of that version or of any later version published by+the Free Software Foundation. If the Library does not specify a+license version number, you may choose any version ever published by+the Free Software Foundation.++ 14. If you wish to incorporate parts of the Library into other free+programs whose distribution conditions are incompatible with these,+write to the author to ask for permission. For software which is+copyrighted by the Free Software Foundation, write to the Free+Software Foundation; we sometimes make exceptions for this. Our+decision will be guided by the two goals of preserving the free status+of all derivatives of our free software and of promoting the sharing+and reuse of software generally.++ NO WARRANTY++ 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO+WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW.+EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR+OTHER PARTIES PROVIDE THE LIBRARY "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+LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME+THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION.++ 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN+WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY+AND/OR REDISTRIBUTE THE LIBRARY 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+LIBRARY (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 LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF+SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH+DAMAGES.++ END OF TERMS AND CONDITIONS
+ Language/Haskell/HBB/ApplyTo.hs view
@@ -0,0 +1,58 @@+{-# OPTIONS -Wall #-}++module Language.Haskell.HBB.ApplyTo (+ applyTo+ ) where++import System.Process+import System.IO+import Data.List (intercalate)++-- | This function applies a String to String function to a certain String+-- (everything in the context of the module "Prelude").+-- +-- It is expensive as it calls 'ghc' to produce its results. It has been+-- created to formally provide the mode 'applyto' but text editors should+-- instead use 'ghc' directly. The first argument control whether a warning+-- message describing this fact is contained in the result. If it is False then+-- the second tuple element of the result will contain an according warning+-- otherwise it Nothing.+--+-- The result is a tuple of which the first elements contains the+-- (stdout-)output of the call to the 'ghc' and the second element may contain+-- warning messages. If the first function argument is False then the second+-- tuple element will never be Nothing. Otherwise it may be Nothing or contain+-- a messages (for example when the executable GHC isn'f found).+applyTo :: Bool -> String -> String -> IO (String,Maybe String)+applyTo suppressGHCWarning stringToStringFun subject = do+ let exeName = "ghc"+ exeArgQ = "'(" ++ stringToStringFun ++ ") \"" ++ subject ++ "\"\'"+ exeArgQi = "'interact (\\stdin -> (unlines . map (" ++ stringToStringFun ++ ") . lines) stdin)'"++ spec = let base = proc exeName ("-e":["(" ++ stringToStringFun ++ ") " ++ '"':subject ++ "\""])+ in base { std_in = Inherit+ , std_out = CreatePipe+ , std_err = UseHandle stderr }++ warnMsg = unlines ["> Note that 'applyto' is a small wrapper around a call to 'ghc'."+ ,"> "+ ,"> The functionality provided here can also be reached by calling 'ghc' as follows:"+ ,"> "+ ,(intercalate " " (("> # " ++ exeName):"-e":exeArgQ:[]))+ ,"> "+ ,"> Moreover with GHC all request could be done in a simple session."+ ,"> In this case the subject strings are written to stdin and the results"+ ,"> are read from stdout (one per line):"+ ,"> "+ ,(intercalate " " (("> # " ++ exeName):"-e":exeArgQi:[]))+ ,"> "+ ,"> Use 'applyto -q' to suppress the writing of this message to stderr."]++ (_,Just childStdOut,_,_) <- createProcess spec+ res <- hGetContents childStdOut++ case (res,suppressGHCWarning) of ([],_ ) -> return ([],Just "Empty result (is the 'ghc' executable accessible?)")+ (xs,False) -> return (xs,Just warnMsg)+ (xs,True ) -> return (xs,Nothing )++
+ Language/Haskell/HBB/ExprType.hs view
@@ -0,0 +1,54 @@+{-# OPTIONS -Wall #-}++module Language.Haskell.HBB.ExprType (+ exprtype,+ exprtypeM,+ showExprTypeResult,+ Type+ ) where++import Language.Haskell.HBB.Internal.GHC+import Outputable+import GHC.Paths (libdir) -- GHC.Paths is available via cabal install ghc-paths+import GHC++-- | This function takes a filename and an expression and evaluates the type of+-- this expression in the context of the passed file. The result value is a+-- tuple where the first element is GHCs representation of the type and the+-- second one is the stringified version of the type.+--+-- The first two command line parameter is:+--+-- - The GHC options as string list (as they should appear on the command+-- line, e.g. @[\"-isrc\"]@)+exprtype :: [String] -> FilePath -> String -> IO (Type,String)+exprtype ghcOptions fn expr = + runGhcWithCmdLineFlags ghcOptions (Just libdir) $ exprtypeM fn expr++-- | This function creates a string of the result returned by exprtype or+-- exprtypeM.+--+-- The string has exactly the format that should be understood by text editors+-- that are using this mode.+showExprTypeResult :: (Type,String) -> String+showExprTypeResult = snd++-- | This is a variant of exprtype that runs within the GHC monad and therefore+-- allows a more fine-grained control over the behaviour of GHC.+exprtypeM :: GhcMonad m => FilePath -> String -> m (Type,String)+exprtypeM contextFile expr = do++ -- This function takes a file name and an expression (as string) and tries to+ -- get out the type of this expression in the context of the passed file.+ let getTypeOfExpr :: GhcMonad m => FilePath -> String -> m Type+ getTypeOfExpr filename e = do+ loadTargetsFromFilename filename+ (modName,_) <- searchModGraphFor (Left filename)+ setContext [IIModule modName]+ exprType e++ updateDynFlagsToSuppressFileOutput+ ty <- getTypeOfExpr contextFile expr+ flgs <- getSessionDynFlags+ let tyStr = showSDocForUser flgs neverQualify (pprParendType $ ty)+ return (ty,tyStr)
+ Language/Haskell/HBB/Inline.hs view
@@ -0,0 +1,128 @@+{-# OPTIONS -Wall #-}++module Language.Haskell.HBB.Inline (+ inline,+ inlineM,+ showInlineResult,+ InlineOptions(..),+ BufLoc(..),+ BufSpan(..),+ defaultInlineOptions+ ) where++import Language.Haskell.HBB.Internal.InternalTTreeCreation+import Language.Haskell.HBB.Internal.InternalTTree+import Language.Haskell.HBB.Internal.GHCHighlevel+import Language.Haskell.HBB.Internal.TTreeColor+import Language.Haskell.HBB.Internal.SrcSpan+import Language.Haskell.HBB.Internal.TTree+import Language.Haskell.HBB.Internal.GHC+import Control.Monad.Reader hiding (liftIO)+import FastString (unpackFS)+import GHC.Paths (libdir)+import GhcMonad (liftIO,GhcMonad)+import SrcLoc++-- | The data type InlineOptions is to alter the behviour of the function+-- 'inline'.+--+-- If 'showContext' is true 'inline' not only prints the inlined version of the+-- function or value binding but also the file context.+--+-- If 'showAnsiColored' is true 'inline' will use ANSI terminal colors to+-- highlight different logical informations in the inlined version. Colors are+-- used for areas that are identical with the original function or value+-- binding (displays) and a bold grey is used for areas that have been added+-- and do not occur in the original binding (additions).+data InlineOptions = InlineOptions { showContext :: Bool+ , showAnsiColored :: Bool }++-- | This value defines the default options for inlining.+--+-- Most text editors will need these settings. The inlined version of the+-- function or value binding is printed without ANSI colors and without context+-- but with non-first lines being indented to a level that allows a text editor+-- to replace the original name with the return value of mode 'inline'.+defaultInlineOptions :: InlineOptions+defaultInlineOptions = InlineOptions { showContext = False , showAnsiColored = False }++-- | This function implements the mode 'inline'.+--+-- Inline takes a location or a span within a file which should be a function+-- binding (as of 2014-09-16 excluding any parameter) and tries to produce an+-- inlined version of the function. The inlined version of the function then is+-- written to standard output.+--+-- @+-- main :: IO ()+-- main = inline [\"-iexample\"] defaultInlineOptions \"example/Example.hs\" 14 13+-- @+--+-- It is important to know that the indentation of non-first lines (as of+-- 2014-09-16) is always adapted to match the indentation of the location where+-- the name should be replaced.+-- If a second location isn't passed this function will use GHCs lexer to find+-- out where the end of the variable or function name is. Consequently to+-- inline a function and to simultaneously apply it to its arguments (which is+-- not supported as of 2014-09-16) the second location must be passed.+--+-- The first three command line parameters are:+--+-- - The GHC options as string list (as they should appear on the command line)+--+-- - Some options to the mode 'inline' that change the functions behaviour+--+-- - The path to the GHC library folder (the module GHC.Paths exports 'libdir'+-- which can be used here)+inline :: [String] -> InlineOptions -> FilePath -> BufLoc -> Maybe BufLoc -> IO (BufSpan,String)+inline ghcOptions iopts fn sl mbEndLoc = + runGhcWithCmdLineFlags ghcOptions (Just libdir) $ inlineM iopts fn sl mbEndLoc++-- | This function creates a string of the result returned by inline or+-- inlineM.+--+-- The string has exactly the format that should be understood by text editors+-- that are using the mode inline.+showInlineResult :: (BufSpan,String) -> String+showInlineResult = snd++-- | This is the monadic version of inline.+--+-- Instead of taking command line flags to alter the GHC environment this+-- function can be used with a custom GhcMonad instance which allows more+-- control about GHCs behaviour.+inlineM :: GhcMonad m => InlineOptions -> FilePath -> BufLoc -> Maybe BufLoc -> m (BufSpan,String)+inlineM (InlineOptions { showContext = sc , showAnsiColored = sa })+ occFileName+ startLoc+ mbEndLoc = do+ sti@(SearchedTokenInfo { result = (bindInfo,_) }) <- searchFunctionBindingM occFileName startLoc mbEndLoc+ occFileContent <- liftIO $ readFile occFileName+ (bindFileName,bindFileContent) <- do+ let (L (RealSrcSpan r) _) = bindInfo+ n = unpackFS $ srcSpanFile r+ content <- liftIO $ readFile n+ return (n,content)+ let tree@(TTree c childs) = + let produceClientTTree :: FunBindInfo -> ClientTTree+ produceClientTTree sti'@(SearchedTokenInfo { result = (bi,_) }) =+ let richTTree = runReader (toTTree bi) ProduceLambda+ inlCol = ((srcLocCol $ realSrcSpanStart $ occSpan sti'))+ in snd $ applyIndentation (IncInline (pointBufSpan 1 inlCol),richTTree)+ in produceClientTTree sti+ fileCache = if occFileName == bindFileName + then [( occFileName,str2LineBuf occFileContent)]+ else [( occFileName,str2LineBuf occFileContent)+ ,(bindFileName,str2LineBuf bindFileContent)]+ let alteredContent = case sc of+ True -> + let spn = toBufSpan $ occSpan sti+ in case sa of+ True -> applyColoredTTree fileCache (spn,tree) (str2LineBuf occFileContent)+ False -> applyTTree fileCache (spn,tree) (str2LineBuf occFileContent)+ False -> + let spn = pointBufSpan 1 1+ in case sa of+ True -> applyColoredTTree fileCache (spn,(TTree c childs)) [""]+ False -> applyTTree fileCache (spn,(TTree c childs)) [""]+ return (toBufSpan $ occSpan sti,lineBuf2Str alteredContent)
+ Language/Haskell/HBB/Internal/AST.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE RankNTypes #-}+{-# OPTIONS -Wall #-}+module Language.Haskell.HBB.Internal.AST (+ transformRenamedAST+ ,queryRenamedAST+ ,transformTypecheckedAST) where++import Data.Generics (GenericM,GenericQ,gmapM,Data,extQ,gmapQ)+import NameSet (NameSet)+import GHC++-- This function is similar to 'everythingBut' from the SYB schemes but uses a+-- neutral element and automatically omits elements of the renamed AST that+-- mustn't be evaluated.+queryRenamedAST :: r -> (r -> r -> r) -> GenericQ r -> GenericQ r+queryRenamedAST n m f x = if isPostTcType x+ then n+ else foldl m (f x) (gmapQ (queryRenamedAST n m f) x)+ where isPostTcType :: GenericQ Bool+ isPostTcType = (const False) `extQ` + ((const True) :: PostTcType -> Bool)++-- Uses SYB to create generic transformation that omits elements of type+-- 'PostTcType'. This is needed because after the renamer 'PostTcTypes' must+-- not be evaluated.+transformRenamedAST :: (Monad m, Data a) => GenericM m -> a -> m a+transformRenamedAST = everywhereButM isPostTcType+ where+ isPostTcType :: GenericQ Bool+ isPostTcType = extQ (const False) ((const True) :: PostTcType -> Bool)++-- Uses SYB to create generic transformation that omits elements of type+-- 'NameSet'. This is needed because after the renamer 'NameSet' (the element+-- 'bind_fvs' in function bindings) must not be evaluated.+transformTypecheckedAST :: (Monad m, Data a) => GenericM m -> a -> m a+transformTypecheckedAST = everywhereButM isNameSet+ where+ isNameSet :: GenericQ Bool+ isNameSet = extQ (const False) ((const True) :: NameSet -> Bool)++-- The default traversal functions of the SYB package lack a generic monadic+-- transformation where certain cases can be excluded. We want this case+-- because we want to use the Writer Monad and certain cases that should not be+-- evaluated must be omitted.+everywhereButM :: Monad m => GenericQ Bool -> GenericM m -> GenericM m+everywhereButM shouldExclude f x | (not . shouldExclude) x = do x' <- f x; gmapM (everywhereButM shouldExclude f) x'+everywhereButM _ _ x = return (id x)
+ Language/Haskell/HBB/Internal/GHC.hs view
@@ -0,0 +1,120 @@+module Language.Haskell.HBB.Internal.GHC where++import DynFlags (parseDynamicFlagsCmdLine)+import GhcMonad (liftIO)+import Bag (bagToList)+import GHC++-- | This is a wrapper around runGhc which allows to pass some command line+-- options.+--+-- This function takes ghc-specific command line flags and inserts them into+-- the GHC monad. The passed Ghc action is then executed in an environment+-- where these flags have been applied. Principally there are 3 types of+-- flags for GHC:+--+-- - dynamic flags+--+-- - static flags (they may change during one compiler run)+--+-- - mode flags (e.g. @--make@)+--+-- This function only processes dynamic and static flags. They should be passed+-- as specified on the command line:+--+-- @+-- runGhcWithCmdLineFlags ["-isrc","-XDeriveDataTypeable"] (Just libdir) someAction+-- @+--+-- This function will throw an exception if any of the specified options leads+-- to a warning or cannot be parsed.+runGhcWithCmdLineFlags :: [String] -> Maybe FilePath -> Ghc a -> IO a+runGhcWithCmdLineFlags cmdLineFlags mbLibDir ghcAction = do+ -- The static GHC flags are somehow rembembered in the Monad (IO in+ -- this case) and therefore need not to be passed explicitely to+ -- runGhc...+ _ <- do (_,warns) <- parseStaticFlags (map (mkGeneralLocated "on the command line") cmdLineFlags)+ case warns of [] -> return ()+ ((L _ x):_) -> error $ "Warnings at parsing (static) GHC flags: " ++ x+ runGhc mbLibDir $ do+ basicDFlags <- getSessionDynFlags+ let str2locStr :: String -> Located String+ str2locStr = (mkGeneralLocated "on the command line")+ dynFlags <- do+ (newDFlags,restArgs,errMsgs) <- parseDynamicFlagsCmdLine basicDFlags (map str2locStr cmdLineFlags)+ _ <- case restArgs of+ [] -> return ()+ ((L _ x):_) -> error $ "Unable to parse all GHC flags. E.g.: " ++ x+ _ <- case errMsgs of+ [] -> return ()+ ((L _ x):_) -> error $ "An error occured parsing the GHC flags at: " ++ x+ return newDFlags+ _ <- setSessionDynFlags dynFlags+ ghcAction++-- | Takes a module summary and returnes the renamed abstract syntax tree.+--+-- This is a small auxiliary function that takes a module summary and extracts+-- the renamed abstract syntax tree from it. The syntax tree is represented by+-- the data structure HsGroup in GHC.+extractRenamedAST :: GhcMonad m => ModSummary -> m RenamedSource+extractRenamedAST modSum = do+ t <- (parseModule modSum >>= typecheckModule)+ case tm_renamed_source t of Nothing -> error "internal failure (no hsgroup)"+ Just x -> return x++-- | A small auxiliary function that updates the dynamic flags to suppress file+-- output.+updateDynFlagsToSuppressFileOutput :: GhcMonad m => m ()+updateDynFlagsToSuppressFileOutput = do+ dflags <- getSessionDynFlags+ setSessionDynFlags dflags { + hscTarget = HscInterpreted , -- HscNothing disables the output of intermediate (*.o) files+ ghcLink = LinkInMemory -- NoLink disables linking (is required when using HscNothing)+ } + return ()++{--- | Searches the module grahp for the passed module-}+{-searchModGraphForModule :: GhcMonad m => Module -> m (ModuleName,ModSummary)-}+{-searchModGraphForModule mod = do-}+ {-modGraph <- getModuleGraph-}+ {-return $ searchModGraphInternal mod modGraph-}+ {-where-}++-- | This function takes a file name or a module and searches the+-- module-summary which is based on this source file out of the module graph.+searchModGraphFor :: GhcMonad m => Either FilePath Module -> m (ModuleName,ModSummary)+searchModGraphFor what = do+ modGraph <- getModuleGraph+ return $ case what of+ Left filename -> searchModGraphInternalFi filename modGraph+ Right mod -> searchModGraphInternalMo mod modGraph+ where+ searchModGraphInternalMo mo [] = error $ "Internal error (module isn't part of the module graph)"+ searchModGraphInternalMo mo (x:rest) | (ms_mod x) == mo = (ms_mod_name x,x)+ searchModGraphInternalMo mo (_:rest) = searchModGraphInternalMo mo rest++ searchModGraphInternalFi fn [] = error $ "Internal error (module for source file " ++ + fn ++ " isn't part of the module graph)"+ searchModGraphInternalFi fn (x:rest) = + case ml_hs_file (ms_location x) of+ Nothing -> searchModGraphInternalFi fn rest+ Just hs -> if fn == hs then (ms_mod_name x,x)+ else searchModGraphInternalFi fn rest++-- | This function creates a target from the passed file name by applying to+-- most common used settings.+fileToTarget :: FilePath -> Target+fileToTarget filename = Target { targetId = (TargetFile filename Nothing),+ targetAllowObjCode = False,+ targetContents = Nothing }++-- | Wrapper around 'setTargets' and 'load' that treats the common case of a+-- one-file-target.+loadTargetsFromFilename :: GhcMonad m => FilePath -> m ()+loadTargetsFromFilename filename = do+ setTargets [fileToTarget filename]+ _ <- load LoadAllTargets -- Depending on the HscTarget this will create+ -- intermediate files (set HscNothing to+ -- suppress)+ return ()
+ Language/Haskell/HBB/Internal/GHCHighlevel.hs view
@@ -0,0 +1,324 @@+{-# LANGUAGE RankNTypes,DeriveDataTypeable #-}+{-# OPTIONS -Wall #-}+module Language.Haskell.HBB.Internal.GHCHighlevel (+ searchFunctionBinding,+ searchFunctionBindingM,+ searchFunctionBindingForNameM,+ searchTokenForNameM,+ getThingsAt,+ getSortedLHsExprsAt, SearchTokenException(..),+ GetVariableLexerException(..),+ SearchedTokenInfo(..),+ FunBindInfo,+ BufSpan(..),+ BufLoc(..)+ ) where++-- This file contains a high-level wrapper for GHC functionalities. It uses+-- the lower-level functionalities from GHC, AST and Lexer to provide+-- easy-to-use blocks of functionalities.+--+-- +-----------------++-- | LibGHCHighlevel |+-- +-----------------++-- | | |+-- | | |+-- +---------+ | +-------+----------++-- | | | |+-- v v v v+-- +----+ +-----+ +-------+ +---------++-- |GHC | | AST | | Lexer | | SrcSpan |+-- +----+ +-----+ +-------+ +---------++--++import Language.Haskell.HBB.Internal.SrcSpan+import Language.Haskell.HBB.Internal.Lexer+import Language.Haskell.HBB.Internal.AST+import Language.Haskell.HBB.Internal.GHC+import Control.Exception (throw,Exception)+import Data.Generics+import FastString (mkFastString)+import Outputable+import Data.Maybe (fromJust)+import Data.List (sortBy)+import GHC.Paths (libdir) -- GHC.Paths is available via cabal install ghc-paths+import GhcMonad+import SrcLoc (realSrcSpanStart,realSrcSpanEnd,mkRealSrcSpan,mkRealSrcLoc)+import Name (nameModule_maybe)+import GHC++-- FunBindInfo is the type returned by the function 'searchFunctionBinding'.+data SearchedTokenInfo a = SearchedTokenInfo { + -- | GHC internally uses Outputable for things that may be+ -- printed to the user for example. As the printing functions+ -- depend on the DynFlags used at compilation they can't be+ -- used any more when the GHC run has finished. So 'printFun'+ -- uses a closure to save the DynFlags in a curried function+ -- to make it possible for clients to get a string+ -- representation of a GHC internal data type.+ printFun :: (forall b. Outputable b => b -> String)+ -- | This is the Src-Span covering the full function name the+ -- searchFunctionBinding function has determined (the+ -- function gets passed only a certain point in a file+ -- pointing to a (part) of the function name)+ , occSpan :: RealSrcSpan+ -- | The name that was at the location that has been passed to+ -- searchFunctionBinding(M). In the case of inlining the name+ -- is what is to be replaced by the function definition. This+ -- name is completely enclosed by occSpan.+ , name :: Name+ -- | The type of the result is determined by the GenericQ a+ -- passed as parameter.+ , result :: a }++type FunBindInfo = SearchedTokenInfo (LHsBindLR Name Name,Maybe (LSig Name))++-- | These are exceptions searchFunctionBinding(M) may throw.+--+-- Each exception can be converted to a meaningful string. Moreover+-- searchFunctionBinding is throwing internal errors via error (exception+-- ErrorCall must be catched).+data SearchTokenException = LexingSearchError GetVariableLexerException+ | TokenIsntAName+ | TokenNotEndingAccordingly+ | IsFunctionApplication+ | IsExternalName ModuleName+ | IsntNameOfABinding -- The name at this location refers to for example a function parameter+ deriving (Typeable)++instance Show SearchTokenException where+ show (LexingSearchError LexingFailed) = "Lexing failed. Input file isn't valid Haskell"+ show (LexingSearchError VarNotFound ) = "There is no variable at the specififed location"+ show TokenIsntAName = "Didn't find an name at the specified location.\n" +++ "(Is this really an expression or something like a function parameter?)"+ show TokenNotEndingAccordingly = "There is at least one name starting at the location but none ending accordingly.\n" +++ "Did you specify the end of the source-span correctly?"+ show IsFunctionApplication = "This seems to be a function application of which inlining isn't supported so far."+ show (IsExternalName m) = "The name refers to an external binding (module " ++ moduleNameString m ++ ")"+ show IsntNameOfABinding = "No according function binding found.\n" +++ "Is this really the name of a binding (or for example a parameter to a function)?"++instance Exception SearchTokenException++-- | Parses the renamed AST of the module and returns all elements that start+-- at the passed location sorted by length in increasing oder.+getThingsAt + :: (GhcMonad m,Typeable a) + -- | Tells how to extract the span of an a. If the a element is at the+ -- BufLoc specified then the according BufSpan is returned. Note that the+ -- results are sorted by the end location of the BufSpan that is returned+ -- here. So if this function returns weird data then the sorting of the+ -- results is not warranted.+ => (a -> BufLoc -> Maybe BufSpan) + -> FilePath -- ^ The filename of the module that should be considered.+ -> BufLoc -- ^ The required start-location of the tokens.+ -> m [a] -- ^ A sorted list of results.+getThingsAt isAtLoc filename location = do++ loadTargetsFromFilename filename++ let asTypeOf' :: a -> (a -> BufLoc -> Maybe BufSpan) -> a+ asTypeOf' a _ = a++ checkedMod <- searchModGraphFor (Left filename) >>= return . snd >>= parseModule >>= typecheckModule++ let (rnSource,_,_,_) = fromJust $ tm_renamed_source checkedMod++ locateIt s x = case isAtLoc x s of + Nothing -> []+ Just (BufSpan _ e) -> [(x,e)]++ collectedExprs = queryRenamedAST [] (++) (mkQ [] (\x -> locateIt location (asTypeOf' x isAtLoc))) rnSource++ return $ map fst $ sortBy sortByEnding collectedExprs+ where+ sortByEnding :: (a,BufLoc) -> (a,BufLoc) -> Ordering+ sortByEnding (_,end1) (_,end2) = end1 `compare` end2++-- | Returns a list of (LHsExpr Name) instances that start at the passed+-- position. The first instance is the shortest match which means that it spans+-- fewest character. This is the name of the function that should be applied or+-- the name of the value bindings.+getSortedLHsExprsAt :: GhcMonad m => FilePath -> BufLoc -> m [LHsExpr Name]+getSortedLHsExprsAt filename location = getThingsAt extractBufSpan filename location+ where extractBufSpan :: LHsExpr Name -> BufLoc -> Maybe BufSpan+ extractBufSpan (L (RealSrcSpan r) (HsVar _ )) bl = if (spanStart $ toBufSpan r) == bl then Just $ toBufSpan r else Nothing+ extractBufSpan (L (RealSrcSpan r) (HsApp _ _)) bl = if (spanStart $ toBufSpan r) == bl then Just $ toBufSpan r else Nothing+ extractBufSpan _ _ = Nothing++-- | This function takes a file name and the location that is of interest and+-- searches out the value or function binding for the name that stands at this+-- location. The returned value contains all informations that are needed to+-- inline the function definition or describe how to inline it (smart-inline).+--+-- If the name refers to a name that is not part of the module graph (because+-- it has been loaded by a library for example) this function will fail.+searchFunctionBinding :: FilePath -> BufLoc -> Maybe BufLoc -> IO FunBindInfo+searchFunctionBinding filename loc1 mbBL =+ runGhc (Just libdir) $ searchFunctionBindingM filename loc1 mbBL++-- | This is the monadic version of searchFunctionBinding which assumes that+-- there is a preconfigured GHC.+searchFunctionBindingM :: GhcMonad m => FilePath -> BufLoc -> Maybe BufLoc -> m FunBindInfo+searchFunctionBindingM filename loc1 mbBL = do++ updateDynFlagsToSuppressFileOutput++ (blStart,blEnd) <- case mbBL of+ Nothing -> do+ lexerResult <- getVariableIdUsingLexerAt (filename,loc1) ExcludeQualifiedVars++ let (_,rSpan) = case lexerResult of Right x -> x+ Left x -> throw (LexingSearchError x)+ return ((toBufLoc $ realSrcSpanStart rSpan) + ,(toBufLoc $ realSrcSpanEnd rSpan))+ Just loc2 -> return (loc1,loc2)++ -- We search out the name that is at the position specified.+ -- With the name it is possible to get out the module and the location+ -- where the function or value bindings is defined.+ ourName <- do++ -- getSortedLHsExprsAt returns a sorted list where the first element covers+ -- the smallest range (it is directly a (LHsExpr Name) and no function+ -- application).+ exprs <- getSortedLHsExprsAt filename blStart++ let endsAt :: SrcSpan -> BufLoc -> Bool+ endsAt (RealSrcSpan r) l = l == (toBufLoc $ realSrcSpanEnd r)+ endsAt _ _ = False++ case exprs of+ [] -> throw TokenIsntAName+ xs -> case [ e | (L l e) <- xs , l `endsAt` blEnd ] of+ [] -> throw TokenNotEndingAccordingly+ [(HsVar n)] -> return n+ [(HsApp _ _)] -> throw IsFunctionApplication+ _ -> error "Internal error (too much results for matching expressions)."++ searchFunctionBindingForNameM (ourName,(BufSpan blStart blEnd),filename)++data FunBindAndSig = FunBindAndSig [LHsBindLR Name Name] [LSig Name]++joinFunBindAndSig :: FunBindAndSig -> FunBindAndSig -> FunBindAndSig+joinFunBindAndSig (FunBindAndSig b1 s1) (FunBindAndSig b2 s2) = FunBindAndSig (b1 ++ b2) (s1 ++ s2)++-- | This version to search a function binding takes a Name and some details+-- about it.+searchFunctionBindingForNameM :: GhcMonad m => (Name,BufSpan,FilePath) -> m FunBindInfo+searchFunctionBindingForNameM (ourName,nameSpan,filename) = do++ let genericQuery :: BufLoc -> GenericQ FunBindAndSig+ genericQuery = ++ let hasSearchedStartLoc :: BufLoc -> SrcSpan -> Bool+ hasSearchedStartLoc loc (RealSrcSpan rss) =+ loc == (toBufLoc $ realSrcSpanStart rss)+ hasSearchedStartLoc _ _ = False+ + -- This function is used to create a generic SYB-query to collect the function+ -- bindings (usually only one) start start at a certain location.+ locateFunctionsQ :: BufLoc -> (LHsBindLR Name Name) -> FunBindAndSig+ locateFunctionsQ loc x@(L l (FunBind {})) | hasSearchedStartLoc loc l = FunBindAndSig [x] []+ -- Pattern bindings (e.g. sq :: Int -> Int = \x -> x * x)+ -- are also collected to be able to give a clear message to the user...+ locateFunctionsQ loc x@(L l (PatBind {})) | hasSearchedStartLoc loc l = FunBindAndSig [x] []+ locateFunctionsQ _ (L _ (VarBind {})) =+ error $ "Internal error (unexpected VarBind: " ++ + "GHC doc says that they are introduced by the typechecker)"+ locateFunctionsQ _ (L _ (AbsBinds {})) =+ error $ "Internal error (unexpected AbsBind: " ++ + "GHC doc says that they are introduced by the typechecker)"+ locateFunctionsQ _ _ = FunBindAndSig [] []+++ sigQ :: Name -> BufLoc -> HsValBindsLR Name Name -> FunBindAndSig -- [LSig Name]+ sigQ na _ (ValBindsOut _ x) = FunBindAndSig [] (filter isCorrectSig x)+ where+ -- Tests proved that the location stored within+ -- (LSig Name) contains weird data. Therefore the+ -- name is used for the comparison (which should be+ -- better anyway)...+ isCorrectSig :: LSig Name -> Bool+ isCorrectSig (L _ (TypeSig lNames _)) = any (\(L _ n) -> n == na) lNames+ isCorrectSig _ = False+ sigQ _ _ _ = FunBindAndSig [] []++ in (\x -> mkQ (FunBindAndSig [] []) (locateFunctionsQ x) `extQ` (sigQ ourName x))++ sti@(SearchedTokenInfo {+ result = (FunBindAndSig funBinds sigs)+ }) <- + searchTokenForNameM + (ourName,nameSpan,filename)+ (FunBindAndSig [] [])+ joinFunBindAndSig+ genericQuery++ let ourFun = case funBinds of + [] -> throw IsntNameOfABinding+ [b@(L _ (FunBind {}))] -> b+ [b@(L _ (PatBind {}))] -> b+ _ -> error "Internal error (more that one matching function binding found)"++ let ourSig = case sigs of + [] -> Nothing+ (x:_) -> Just x+ + fgs <- getSessionDynFlags++ return SearchedTokenInfo { printFun = showPpr fgs+ , occSpan = occSpan sti+ , name = name sti+ , result = (ourFun,ourSig) }++-- | This is a generic function that takes informations about a Name and+-- queries the renamed AST according to the parameters.+searchTokenForNameM + :: GhcMonad m + => (Name,BufSpan,FilePath) -- ^ informations about the Name instance, its location and the file + -> b -- ^ neutral result+ -> (b -> b -> b) -- ^ function to join 2 results+ -> (BufLoc -> GenericQ b) -- ^ generic query (special cases) for the+ -- result, produced by 'mkQ' for example...+ -> m (SearchedTokenInfo b)+searchTokenForNameM (ourName,nameSpan,filename) neutralResult joinResult queryResult = do++ let startLoc = case nameSrcSpan ourName of+ (RealSrcSpan rss) -> toBufLoc $ realSrcSpanStart rss+ _ -> + -- In this case the name doesn't refer to the current unit of compilation+ -- but to a library. We throw an exception but insert the module name.+ throw $ IsExternalName (moduleName $ nameModule ourName)++ renamedAST <- do+ modSum <- do+ -- Ok now there are two possibilities.+ -- Either the name refers to something at module scope (a name+ -- defined in this or another module) or it refers to a nested+ -- function binding.+ -- In the first case 'nameModule_maybe' will return the module of+ -- interest. In the second case the binding must be located in the+ -- same module as the name. We cycle through the module graph to+ -- find the current module and return it.+ modName <- case nameModule_maybe ourName of+ Just m -> return $ moduleName m+ Nothing -> searchModGraphFor (Left filename) >>= return . fst+ getModSummary modName+ + extractRenamedAST modSum++ let ourResult = queryRenamedAST neutralResult joinResult (queryResult startLoc) renamedAST++ occurrenceSpan :: RealSrcSpan+ occurrenceSpan = + let (BufLoc l1 c1) = spanStart nameSpan+ (BufLoc l2 c2) = spanEnd nameSpan+ in mkRealSrcSpan (mkRealSrcLoc (mkFastString filename) l1 c1) + (mkRealSrcLoc (mkFastString filename) l2 c2) ++ getSessionDynFlags >>= (\fgs -> return SearchedTokenInfo { + printFun = showPpr fgs+ , occSpan = occurrenceSpan+ , name = ourName+ , result = ourResult })
+ Language/Haskell/HBB/Internal/InternalTTree.hs view
@@ -0,0 +1,347 @@+{-# OPTIONS -Wall #-}+module Language.Haskell.HBB.Internal.InternalTTree (+ applyIndentation,+ applyInsertionInfo, {- only exported for the unit-tests -}+ InternalTTree,+ InsertionInfo(..)) where++import Language.Haskell.HBB.Internal.SrcSpan+import Language.Haskell.HBB.Internal.TTree+import Debug.Trace (trace)+import SrcLoc++-- [Internal TTree]+-- ================+--+-- Motivation+-- ----------+--+-- The internal TTree (the name has been chosen because this structure is used+-- by HBB internally) is an instance of TTree which is first produced by HBB.+-- The main goal of using an internal representation is because it is hard to+-- calculate the indentation of different elements in the transformation-tree.+-- By using a more adequate (than the one reported to the client)+-- representation the task of calculating the indentation (especially for+-- Displays where the client should be reported an according hint) is+-- considered to be easier.+type InternalTTree = TTree LineBuf RealSrcSpan InsertionInfo++-- We introduce a data type called InsertionInfo. Each element in the internal+-- TTree is attached such a InsertionInfo. When recursing in the TTree the+-- (parental) InsertionInfos make up a stack which (in combination with some+-- other factors) describes the current indentation.+--+-- An information that belongs to the insertion is whether a new section in the+-- source code should be started or not. All NewSection elements that are on+-- the same tree-level will have the same indentation.+data InsertionInfo = IncInline BufSpan -- Child should be inserted into the current parent+ -- BufSpan: The position the text should be inlined at+ | NewSection Int -- Child should open a new section. Int:+ -- The index (smallest first) of the new section+ -- Indices start from 1...+ deriving (Show)+++type RecElementOffset = Indentation+type AccLevelOffset = Indentation -- The sum of the recusive element indentation of all+ -- previously applied elements plus the element offset of+ -- the parent element.++-- This function converts an InternalTTree into the one that is reported to the+-- client. It is a thin wrapper around applyInsertionInfo which is the+-- (complex) heart of this module.+applyIndentation + :: (InsertionInfo,InternalTTree)+ -> (BufSpan ,ClientTTree)+applyIndentation tree = + let shouldTrace = False+ tree' = if shouldTrace then trace ("/*" ++ (show tree) ++ "*/") tree else tree+ ((bs,_),tree3) = head $ foldl (applyInsertionInfo 0 0 [] [] [] 0 1 0) [] [attachRecusiveElementOffsets tree']+ in (bs,tree3)++-- The ClientTTree is constructed in two phases. In the first phase+-- (represented by this function) each node is attached the recursive element+-- offset. This is the offset of an element after having applied all IncInline+-- child elements (and their IncInline childs as well...)+attachRecusiveElementOffsets+ :: ( InsertionInfo ,InternalTTree )+ -> ((InsertionInfo,Indentation),TTree LineBuf RealSrcSpan (InsertionInfo,Indentation))+attachRecusiveElementOffsets (insInfo,TTree content childs) =+ let newChilds = map attachRecusiveElementOffsets childs + totalChildOffset = sum [ i | ((IncInline _,i),_) <- newChilds ]+ offsetFromContent = elementOffset content+ in ((insInfo,totalChildOffset+offsetFromContent),TTree content newChilds)+ +-- This function turns the (internal) transformation-tree (with the recursive+-- elements offsets attached) into a transformation-tree the client+-- understands. This is mostly a task of making the indentation (which first is+-- attached implicitely) explicit which means that each addition begins with+-- enough spaces for example.+--+-- The (indentation-)calculations in applyInsertionInfo are kind of complex and+-- therefore 'indentation.markdown' is a concept-paper which describes some+-- details with the help of some examples.+applyInsertionInfo+ :: Indentation -- Element offset of the parent element+ -> Indentation -- The recursive element offset of the parent element+ -- if it is of type IncInline or 0 if it is of type+ -- NewSection+ -> [RecElementOffset] -- 'Recursive element offset' of all parents+ -- between the the current element and the root node+ -> [AccLevelOffset] -- The accumulated level offset stack+ -> [Int] -- Parent elemen trailing chars stack+ -> Indentation -- 'Effective indentation' of the parent element+ -> Int -- Number of lines in the parent element (for NewSection insertion position)+ -> Int -- Number of NewSection childs the parent element has (for NewSection insertion position)+ -> [((BufSpan ,RecElementOffset),ClientTTree )]+ -> ((InsertionInfo,RecElementOffset),TTree LineBuf RealSrcSpan (InsertionInfo,RecElementOffset))+ -> [((BufSpan ,RecElementOffset),ClientTTree )]+applyInsertionInfo+ parent_elemOffset+ parent_recElemOffset+ parent_recElemOffsetStack+ parent_accLevelOffsetStack+ parent_parentElemTrailingCharsStack+ parent_EffectiveIndentation+ nrOfLinesInParentElement+ nrOfNewSectionChildsInParent+ appliedNodesOnSameLvl+ ((currentElementsInsertionInfo,curElemRecElemOffs),(TTree _content childs)) =++ let samLvl_recElemOffsetStack = [ reo | ((_,reo),_) <- appliedNodesOnSameLvl ]++ currentAccLevelOffset = (sum samLvl_recElemOffsetStack) + parent_elemOffset++ recElemOffsetOfThisElement = case currentElementsInsertionInfo of+ (NewSection _) -> 0 {- NewSection mustn't have any influence on+ the indentation of the following nodes on+ the same level -}+ (IncInline _) -> curElemRecElemOffs++ currentElemParentElemTrailingchars = case currentElementsInsertionInfo of+ (NewSection _) -> 0+ (IncInline (BufSpan (BufLoc _ c1) _)) -> parent_elemOffset - c1 + 1++ -- The 'effective indentation' is the indentation that should be+ -- applied for non-first lines. The calculation of it is described+ -- in 'indentation.markdown'...+ currentEffInd = case currentElementsInsertionInfo of+ (NewSection _) -> (sum $ currentAccLevelOffset:parent_accLevelOffsetStack) -+ (sum $ currentElemParentElemTrailingchars:parent_parentElemTrailingCharsStack)+ (IncInline bs) -> + let (BufSpan (BufLoc _ c1) (BufLoc _ _)) = bs+ in (c1-1) + (sum samLvl_recElemOffsetStack) + parent_EffectiveIndentation++ -------------------------------------------------------------------+ -- TRACING+ -------------------------------------------------------------------++ shouldTrace = case _content of (Addition ["somefunction"]) -> False + (Display spn) -> (srcSpanStartLine spn == 2) && (srcSpanStartCol spn == 5)+ _ -> False++ txt = case currentElementsInsertionInfo of+ (NewSection n) -> "NewSection " ++ (show n) ++ " -> " ++ msgContentTxt ++ "\n" +++ restMsg+ (IncInline (BufSpan (BufLoc l1 c1) (BufLoc l2 c2))) -> + "IncInline (" ++ ((show l1) ++ "," ++ (show c1)) ++ + ") (" ++ ((show l2) ++ "," ++ (show c2)) ++ + ") -> " ++ msgContentTxt ++ "\n" +++ restMsg+ where+ msgContentTxt = case _content of+ (Addition []) -> "Addition \"\""+ (Addition ls) -> "Addition \"" ++ (head ls) ++ "\"..."+ (Display _) -> "Display"+ restMsg = unlines+ [" current elements recursive offset: " ++ (show curElemRecElemOffs)+ ," parent recursive element offset stack: " ++ (show parent_recElemOffsetStack)+ ," samlvl recursive element offset stack: " ++ (show samLvl_recElemOffsetStack)+ ," #lines in parent element: " ++ (show nrOfLinesInParentElement)+ ," parent eff. indentation: " ++ (show parent_EffectiveIndentation)+ ," calced eff. indentation: " ++ (show currentEffInd)+ ," parent accumulat. level offset stack: " ++ (show parent_accLevelOffsetStack)+ ," current level accum. level offset: " ++ (show currentAccLevelOffset)+ ," parent element trailing chars: " ++ (show parent_parentElemTrailingCharsStack)]++ content = if not shouldTrace then _content+ else trace ("/* applyInsertionInfo with " ++ txt ++ " */") _content++ -------------------------------------------------------------------+ -- END OF TRACING+ -------------------------------------------------------------------++ effectiveIndStr = replicate currentEffInd ' '++ newSecChilds = [ c | c@((NewSection _,_),_) <- childs ]+ otherChilds = [ c | c@((IncInline _,_),_) <- childs ]++ newSectionChildsIndentation = (sum $ currentAccLevelOffset:parent_accLevelOffsetStack) -+ (sum $ currentElemParentElemTrailingchars:parent_parentElemTrailingCharsStack) ++ curElemRecElemOffs+ --(elementOffset content)+ + newSecChildsAdditionalLines = + -- As described in 'indentation.markdown' a NewSections indentation+ -- is the sum of all accumulative level offsets between the current+ -- element and the root node (minus the trailing chars up to the+ -- root node). If we calculate the indentation string for our child+ -- NewSection elements, we have to consider our part as well...+ let childNewSecindStr = replicate newSectionChildsIndentation ' '+ in case length newSecChilds of+ -- The first NewSection is on the same line with the previous content+ 0 -> []+ 1 -> [] + n -> replicate (n-1) childNewSecindStr++ nrOfLinesWithoutNewSections = case content of+ (Addition ad) -> length ad+ (Display spn) -> srcSpanEndLine spn - srcSpanStartLine spn + 1++ insertionPosWithinParent = + let colAddedPart = sum parent_accLevelOffsetStack+ colSubtractedPart = sum parent_parentElemTrailingCharsStack+ in case currentElementsInsertionInfo of+ -- We have a NewSection element. From the parent+ -- element we know the number of lines it has. As+ -- the NewSection lines are always the last ones,+ -- we are able to detect on which line we should+ -- be inserted.+ --+ -- NewSection elements insertion column+ -- ------------------------------------+ --+ -- The insertion position of NewSection elements is a little+ -- tricky. In case of IncInline the positions are adapted by+ -- the parent elements but for NewSection the indentation+ -- of the parent element must be considered as well.+ --+ -- First NewSection within parent:+ -- <parent effective indentation> + parent_elemOffset + 1+ -- Non-First NewSection within parent:+ -- <parent effective indentation> + parent_recElemOffset + 1+ --+ -- The second part adds the insertion position within the+ -- parent element (NewSection are always inserted at the end+ -- but non-first lines are indented with the effective+ -- indentation).+ (NewSection 1) -> pointBufSpan + (nrOfLinesInParentElement - (nrOfNewSectionChildsInParent - 1)) + (colAddedPart - colSubtractedPart + parent_elemOffset + 1)+ (NewSection idx) -> pointBufSpan + (nrOfLinesInParentElement - (nrOfNewSectionChildsInParent - idx)) + (colAddedPart - colSubtractedPart + parent_recElemOffset + 1)+ (IncInline bs) -> bs++ -- Recursion function+ -- ------------------+ -- This function should only be used to apply all IncInline childs+ -- elements at once because it sets the 'Recursive element offset'+ -- stack for the previous childs to [].+ recurseWith + :: Int -- Number of lines in the parent element+ -> [((BufSpan ,RecElementOffset),ClientTTree )]+ -> [((InsertionInfo,RecElementOffset),TTree LineBuf RealSrcSpan (InsertionInfo,RecElementOffset))]+ -> [((BufSpan ,RecElementOffset),ClientTTree )]+ recurseWith nrOfLinesInParent acc ch = + foldl+ (applyInsertionInfo + (elementOffset content)+ (case currentElementsInsertionInfo of+ (NewSection _) -> 0+ (IncInline _) -> curElemRecElemOffs)+ (case currentElementsInsertionInfo of + (NewSection _) -> parent_recElemOffsetStack+ (IncInline _) -> curElemRecElemOffs:parent_recElemOffsetStack)+ (currentAccLevelOffset:parent_accLevelOffsetStack)+ (currentElemParentElemTrailingchars:parent_parentElemTrailingCharsStack)+ currentEffInd+ nrOfLinesInParent+ (length newSecChilds))+ acc+ ch++ in case content of+ (Addition ad) -> + let additionAdapted = ++ let addIndentation :: LineBuf -> LineBuf+ addIndentation xs = map (\x -> effectiveIndStr ++ x) xs++ baseIndented = case currentElementsInsertionInfo of+ -- The first NewSection is appended to the previous+ -- element and does not need to be indented...+ (NewSection _) -> case ad of [] -> [] + (x:xs) -> x:(addIndentation xs)+ -- IncInline elements are written 'inline' which means that+ -- the first line of them do not have to be indented+ (IncInline _) -> case ad of [] -> []+ (x:xs) -> x:(addIndentation xs)+ in baseIndented ++ newSecChildsAdditionalLines++ moveBufSpanByEffInd :: BufSpan -> BufSpan+ moveBufSpanByEffInd bs =+ -- + -- One non-first lines are prepended with spaces so we do not+ -- need to move things on the first line.+ --+ let (BufSpan (BufLoc l1 c1) (BufLoc l2 c2)) = bs+ newC1 = case l1 of 1 -> c1+ _ -> c1 + currentEffInd+ newC2 = case l2 of 1 -> c2+ _ -> c2 + currentEffInd+ in (BufSpan (BufLoc l1 newC1) (BufLoc l2 newC2))++ -- The childs need to be adapted because we have added spaces+ -- to our content and the BufSpans that are contained are+ -- referring to wrong positions...++ otherChildsMoved = [ (((IncInline (moveBufSpanByEffInd bs)),recInd),tree) | ((IncInline bs,recInd),tree ) <- otherChilds ]++ -- --------------------------------------+ -- RECURSIVE CALLS+ -- --------------------------------------+ newChilds = + recurseWith+ (nrOfLinesWithoutNewSections + (length newSecChildsAdditionalLines))+ []+ (otherChildsMoved ++ newSecChilds)+ -- --------------------------------------+ -- END RECURSIVE CALLS+ -- --------------------------------------++ childWithoutRecElemOffs = map (\((bs,_),ch) -> (bs,ch)) newChilds+ + in ((insertionPosWithinParent,recElemOffsetOfThisElement)+ ,TTree (Addition additionAdapted) childWithoutRecElemOffs):appliedNodesOnSameLvl++ (Display spn) -> + let -- --------------------------------------+ -- RECURSIVE CALLS+ -- --------------------------------------+ newDisplayChilds =+ recurseWith+ (srcSpanEndLine spn - srcSpanStartLine spn + 1)+ []+ (if length newSecChilds /= 0 + then error "NewSections within displays aren't supported"+ else childs)+ -- --------------------------------------+ -- END RECURSIVE CALLS+ -- --------------------------------------+ + newDisplayChildsWithoutRecElemOffs = map (\((bs,_),ch) -> (bs,ch)) newDisplayChilds++ clientDispOffsetHint = currentEffInd - (srcSpanStartCol spn) + 1++ in ((insertionPosWithinParent,recElemOffsetOfThisElement)+ ,TTree (Display (spn,clientDispOffsetHint)) newDisplayChildsWithoutRecElemOffs):appliedNodesOnSameLvl++-- Returns the number of characters the indentation will be higher after having+-- applied the passed tree-node +elementOffset :: TTreeNode LineBuf RealSrcSpan -> Indentation+elementOffset (Addition []) = 0+elementOffset (Addition ad) = length $ last ad+elementOffset (Display spn) = endCol - startCol+ where startCol = srcLocCol $ realSrcSpanStart spn+ endCol = srcLocCol $ realSrcSpanEnd spn
+ Language/Haskell/HBB/Internal/InternalTTreeCreation.hs view
@@ -0,0 +1,365 @@+{-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS -Wall #-}+module Language.Haskell.HBB.Internal.InternalTTreeCreation where++import Language.Haskell.HBB.Internal.InternalTTree+import Language.Haskell.HBB.Internal.SrcSpan+import Language.Haskell.HBB.Internal.TTree+import Control.Monad.Reader+import Data.List (sortBy,intersperse)+import SrcLoc+import Name+import GHC+import Bag++-- 'ConversionInfo' is the type the reader monad in ConvertibleToTTree is+-- parametrized with. It indicates whether the current element should be+-- transformed so that it forms a lambda context or not. As the source code is+-- recursive and self-containing the type 'HsBindLR Name Name' which usually+-- represents a function binding may occure several times. But of course the+-- (lower-level) function bindings should not be written in lambda style but+-- only the top one. ConversionInfo makes this distinction...+data ConversionInfo = ProduceLambda+ | ProduceEqual++-- This is the central type class of which instances can be converted to a+-- TTree that represents a lambda function. Potential instances of this class+-- are elements that are below the (GHC) type (HsBindsLR Name Name) which+-- represents a function binding.+class ConvertibleToTTree a where+ toTTree :: a -> Reader ConversionInfo InternalTTree++-- [LStmt Name] is for example the guard in a GRHS.+-- We use a single display for the guard by joining the src-spans.+instance ConvertibleToTTree [LStmt Name] where+ toTTree [] = return $ TTree (Addition [""]) []+ toTTree stmts = do+ let stmtsLoc :: [RealSrcSpan]+ stmtsLoc = [ r | (L (RealSrcSpan r) _) <- stmts ]+ wholeStmtsLoc = foldl1 combineRealSrcSpans stmtsLoc+ return $ TTree (Display wholeStmtsLoc) []++instance ConvertibleToTTree (LHsExpr Name) where+ toTTree (L (RealSrcSpan rspn) _) = return $ TTree (Display rspn) []+ toTTree _ = error "internal error (unexpected unhelpful src-span)"++-- Helper function to determine whether to RealSrcSpans+-- affect areas which are on separate lines...+onDifferentLines :: RealSrcSpan -> RealSrcSpan -> Bool+onDifferentLines s1 s2 =+ let startS1 = srcLocLine $ realSrcSpanStart s1+ endS1 = srcLocLine $ realSrcSpanEnd s1+ startS2 = srcLocLine $ realSrcSpanStart s2+ endS2 = srcLocLine $ realSrcSpanEnd s2+ in endS1 < startS2 || endS2 < startS1++type IsValueBinding = Bool++instance ConvertibleToTTree (IsValueBinding,GRHS Name) where++ -- [Indentation]+ --+ -- There is one case that must be discussed. If the code for 'expr' does+ -- start on a new line we have to make an exception. Example:+ --+ -- (l,x) | x /= 10 && l /= "" -> l ++ (show x) ++ "th world!"+ -- | otherwise ->+ -- l ++ (show x) ++ "th world, you are the winner!"+ --+ -- By simply using our join algorithms the result would be:+ --+ -- (l,x) | x /= 10 && l /= "" -> l ++ (show x) ++ "th world!"+ -- | otherwise -> l ++ (show x) ++ "th world, you are the winner!"+ --+ -- So we have to explicitely check whether the last line of the statements + -- is on the same line as the first expression. If this is not the case we+ -- have to add a newline and increment indentation.+ --+ -- [No patterns but a guard]+ --+ -- There are some cornercases that should be considered. The following+ -- example shows a binding with no patterns but one guard:+ --+ -- shouldTrace = False+ -- + -- fact | trace "calling 'fact'" False = undefined+ -- fact = (\a -> case a of 1 -> 1+ -- x -> x * fact (x-1))+ --+ -- If there are no matches then the function should be inlined with an+ -- alternatvie leading statement:+ --+ -- main = IO Int+ -- main = return $ fact 5+ --+ -- main = return $ (case isOk of True -> (\a -> case a of 1 -> 1+ -- x -> x * fact (x-1))) 5+ --++ toTTree (isValueBinding,GRHS stmts expr@(L (RealSrcSpan exprLoc) _)) = do+ lambdaStyle <- ask+ exprsTTree <- local (const ProduceEqual) (toTTree expr)+ case (isValueBinding,stmts,lambdaStyle) of+ (True ,(_:_),ProduceLambda) -> error $ "There is no support for inlining value bindings with guards (e.g. 'someVal | isOk = 3.14159')!"+ (True ,[] ,ProduceLambda) -> + {- Ok, this is a value binding. Value bindings are simply+ - represented by their value. -}+ return exprsTTree+ (_ ,[] ,_ ) -> do+ let (addition,exprInsPos) = case lambdaStyle of+ ProduceLambda -> (["-> "],pointBufSpan 1 4)+ ProduceEqual -> (["= "] ,pointBufSpan 1 3)+ return $ TTree (Addition addition) [(IncInline exprInsPos,exprsTTree)]+ (_ ,_ ,_ ) -> do+ stmtsTTree <- local (const ProduceEqual) (toTTree stmts)+ + let stmtsAndExprHaveCommonLine = + any (\(L (RealSrcSpan r) _) -> not $ onDifferentLines exprLoc r) stmts++ (addition,exprInsPos) = case (lambdaStyle,stmtsAndExprHaveCommonLine) of+ (ProduceLambda,True ) -> (["| -> "] ,pointBufSpan 1 7)+ (ProduceLambda,False) -> (["| ->"," "],pointBufSpan 2 5)+ (ProduceEqual ,True ) -> (["| = "] ,pointBufSpan 1 6)+ (ProduceEqual ,False) -> (["| =", " "],pointBufSpan 2 5)+ return $ TTree (Addition addition) [(IncInline $ pointBufSpan 1 3,stmtsTTree)+ ,(IncInline exprInsPos ,exprsTTree)]+ toTTree _ = error "internal error (unexpected unhelpful src-loc in expr)"+++instance ConvertibleToTTree (IsValueBinding,LGRHS Name) where+ toTTree (isValueBinding,L _ g) = toTTree (isValueBinding,g)++combineRealSrcSpans :: RealSrcSpan -> RealSrcSpan -> RealSrcSpan+combineRealSrcSpans s1 s2 = + case combineSrcSpans (RealSrcSpan s1) (RealSrcSpan s2) of+ (RealSrcSpan r) -> r+ _ -> error "expected real src-span from combineSrcSpans"++-- HsValBindsLR is a possible element of HsLocalBindsLR which is used for the+-- where-clause...+instance ConvertibleToTTree (HsValBindsLR Name Name) where+ toTTree (ValBindsIn _ _) = error "internal error (expected dependency analyzed where-clause)"+ toTTree (ValBindsOut binds _) =+ let -- [The Bag data structure]+ --+ -- GHC stores bindings in a Bag probably because all statements+ -- are mutually recursive (and therefore a list which has an order+ -- is inadequate).+ --+ -- [Avoid converting the local function bindings to lambdas as well]+ --+ -- Each of these bindings may contain function bindings (again). We+ -- would make the functions within these bindings lambda function+ -- as well if we would call 'toTTreeDep'. Furtunately we can copy only+ -- the text of them by looking at their src-spans. This is what is+ -- done in 'toTTreeDep' for (LHsBindLR Name)...++ allBags :: [Bag (LHsBindLR Name Name)]+ allBags = map (\(_,lHsBind) -> lHsBind) binds++ -- Ok, now we have the single bindings in Bag which is a GHC+ -- structure with no order. We need them in the order they appear+ -- in the source file so we convert them to a list and sort them.+ -- Additionally the content is not needed any more (we use the span+ -- to form our tree (with displays as childs)...++ asList :: [RealSrcSpan]+ asList = sortBy + compareByStartLoc+ [ r | (L (RealSrcSpan r) _) <- concatMap bagToList allBags]++ asSingleSpan :: RealSrcSpan+ asSingleSpan = foldl1 combineRealSrcSpans asList++ in return $ TTree (Display asSingleSpan) [] --topLevelAddition++instance ConvertibleToTTree (HsLocalBinds Name) where+ toTTree EmptyLocalBinds = return $ TTree (Addition [""]) []+ toTTree (HsIPBinds _) = error "What is IP-Binds?" -- TODO is this case relevant?+ toTTree (HsValBinds vb) = toTTree vb++instance ConvertibleToTTree (IsValueBinding,GRHSs Name) where+ toTTree (_,GRHSs { grhssGRHSs = [] }) = error "internal error (expected at least one grhs)"+ toTTree (isValueBinding+ ,GRHSs { grhssGRHSs = content+ , grhssLocalBinds = whereCl } ) = do+ grhssAsNewSections <- do+ let arg :: ((Int,Int),[(InsertionInfo,InternalTTree)] )+ -> LGRHS Name + -> Reader ConversionInfo ((Int,Int),[(InsertionInfo,InternalTTree)] )+ arg ((pos,tot),acc) grhs = do+ tr <- toTTree (isValueBinding,grhs)+ let insPos = NewSection pos+ return $ ((pos+1,tot),(insPos,tr):acc)+ (_,res) <- foldM arg ((1,length content),[]) content+ return res++ let grhssAsTree :: InternalTTree+ grhssAsTree = TTree (Addition [""]) grhssAsNewSections++ case whereCl of+ HsIPBinds _ -> error "what is HsIPBinds?"+ EmptyLocalBinds -> return $ grhssAsTree+ HsValBinds vb -> do+ whereTree <- toTTree vb+ return $ TTree (Addition [""]) [(NewSection 1,grhssAsTree)+ ,(NewSection 2,TTree (Addition ["where"+ ," "]) [(NewSection 1,whereTree)])]++{-+ - [Value bindings]+ -+ - Value bindings should be supported by HBB insofar as they do not contain+ - guards (have a look at the documentation). This means that HBB should be+ - able to inline following names:+ -+ - somevar = 12+ -+ - fact = (\a -> case a of 1 -> 1+ - x -> x * fact (x-1)+ -+ - In GHC value bindings are - as function bindings - represented by the type+ - 'HsBindLR Name Name'. The difference is that value bindings by nature must+ - only have one match and the length of the pattern list is zero (no value to+ - match against).+ -+ - For reasons described in the documentation value bindings with guards (which+ - are possible) are not supported by HBB (inlining 'mysine' of the following+ - example will raise an exception):+ -+ - mysine | useLookUpTable = \r -> lookUpSine r {- custom sine implementation -}+ - | otherwise = sin {- sine from prelude -}+ -}++instance ConvertibleToTTree ([LPat Name],(GRHSs Name)) where+ toTTree (patterns,grhss) = do++ -- Patterns in ordinary functions are given in the form <first elem>+ -- <second elem> (space separated). When converting to a lambda+ -- function the pattern must have the form (<first elem>,<second elem>)+ -- (it must be a tuple to match against).+ --+ -- At this point we must support both styles because function bindings+ -- local to our (newly created) lambda function should not be changed.+ + whatToProduce <- ask++ let patternspans :: [RealSrcSpan]+ patternspans = [ r | (L (RealSrcSpan r) _) <- patterns ]++ stmtsTree = case whatToProduce of+ ProduceEqual -> TTree (Display $ foldl1 combineRealSrcSpans patternspans) []+ ProduceLambda ->+ + -- We have to use a folde operation to create the individual+ -- childs of our top-level addition. The top-level addition is+ -- something like "(,,)". The insertion position whithin this+ -- top-level addition is accumulated during folding.+ let (_,childs) = let foldArg+ :: (Int,[(InsertionInfo,InternalTTree)])+ -> RealSrcSpan+ -> (Int,[(InsertionInfo,InternalTTree)])+ foldArg (curOffs,acc) curSpn =+ let curTree = TTree (Display curSpn) []+ in (curOffs+1,(IncInline $ pointBufSpan 1 curOffs,curTree):acc)+ in case length patterns of+ -- Have a look at the comment [Bindings+ -- with zero matches] for examples of+ -- zero-parameter bindings that should+ -- be supported.+ 0 -> (0,[])+ 1 -> foldl foldArg (1 ,[]) patternspans+ _ -> foldl foldArg (2 {- 2 means after "(" -},[]) patternspans+ topLvlAddition = case length patterns of+ 0 -> ""+ 1 -> ""+ _ -> "(" ++ (replicate ((length patterns) - 1) ',') ++ ")"+ in TTree (Addition [topLvlAddition]) childs+ let isValueBinding = (length patterns) == 0+ grhssTree <- toTTree (isValueBinding,grhss)+ return $ case isValueBinding of+ False -> TTree (Addition [" "]) [(IncInline $ pointBufSpan 1 1,stmtsTree)+ ,(IncInline $ pointBufSpan 1 2,grhssTree)]+ True -> grhssTree++instance ConvertibleToTTree (LHsBindLR Name Name) where+ toTTree (L _ (FunBind { fun_id = (L (RealSrcSpan nameSpan) _)+ , fun_matches = (MatchGroup matches@(firstMatch:_) _) })) = do++ whatToProduce <- ask++ let nrOfParameters = + let (L _ (Match pttrns _ _)) = firstMatch+ in length pttrns++ -- Prefix example: \a b c -> case (a,b,c) of ++ prefix = case nrOfParameters of+ -- Have a look at the comment [Bindings with zero matches] for+ -- examples of zero-parameter bindings that should be+ -- supported.+ 0 -> "" + 1 -> "\\a -> case a of "+ _ -> let caseParameters = take nrOfParameters ['a'..]+ in "\\" ++ (intersperse ' ' caseParameters) ++ + " -> case (" ++ (intersperse ',' caseParameters) ++ ") of "++ matches2lambda + :: ((Int,Int),[(InsertionInfo,InternalTTree)])+ -> (LMatch Name)+ -> Reader ConversionInfo ((Int,Int),[(InsertionInfo,InternalTTree)])+ matches2lambda ((nr,tot),acc) (L _ (Match patterns _ grhss)) = do++ innerTree <- toTTree (patterns,grhss)++ return $ case whatToProduce of+ ProduceEqual ->+ ((nr+1,tot),((+ (NewSection nr)+ ,TTree + (Addition [" "]) + [(IncInline (pointBufSpan 1 1),TTree (Display nameSpan) [])+ ,(IncInline (pointBufSpan 1 2),innerTree)]+ ):acc))+ ProduceLambda ->+ ((nr+1,tot),((NewSection nr,innerTree):acc))++ (_,allChilds) <- foldM matches2lambda ((1,length matches),[]) matches++ case whatToProduce of+ ProduceLambda -> + return $ TTree + (Addition ["()"])+ [(IncInline $ pointBufSpan 1 2,TTree (Addition [prefix]) allChilds)]+ ProduceEqual -> return $ TTree (Addition [""]) allChilds+ toTTree (L _ (FunBind {})) = error "internal error (unexpected function binding structure)"+ toTTree (L l (PatBind {})) = do++ -- A pattern bindings can have several forms:+ --+ -- let x :: Int = ...+ -- let tup :: (Int,Int) = ...+ -- let f :: Int -> Int = ...+ -- let ['a'] = ...+ --+ -- But not:+ --+ -- let x =+ -- let f = + -- + -- These forms parse as FunBind.++ whatToProduce <- ask+ case (whatToProduce,l) of + (ProduceLambda,_ ) -> error $ "The name referred to is bound by a so-called \"pattern binding\" " ++ + "for which inlining is not supported."+ (ProduceEqual ,RealSrcSpan r) -> return $ TTree (Display r) []+ (ProduceEqual ,_ ) -> error $ "internal error (Unexpected unhelpful src-span in PatBind)"++ toTTree (L _ (VarBind {})) = error "internal error (unexpected VarBind: ghc docs say VarBinds are produced by the typechecker)"+ toTTree (L _ (AbsBinds {})) = error "internal error (unexpected AbsBinds: ghc docs say AbsBinds are produced by the typechecker)"+++++
+ Language/Haskell/HBB/Internal/Lexer.hs view
@@ -0,0 +1,74 @@+{-# OPTIONS -Wall #-} ++module Language.Haskell.HBB.Internal.Lexer (+ getVariableIdUsingLexerAt,+ GetVariableLexerException(..),+ IncludeQualified(..)+ ) where++import Language.Haskell.HBB.Internal.SrcSpan+import StringBuffer+import FastString (unpackFS,mkFastString)+import GhcMonad (liftIO,GhcMonad)+import SrcLoc+import Lexer (lexTokenStream,ParseResult(..),Token(..))+import GHC (getSessionDynFlags)++-- | This type holds possible return values of getVariableIdUsingLexerAt.+data GetVariableLexerException = LexingFailed+ | VarNotFound++data IncludeQualified = IncludeQualifiedVars+ | ExcludeQualifiedVars+ deriving (Eq)++-- | This function uses GHCs lexer to determine the token that is under the+-- cursor (the passed SrcLoc).+--+-- Currently only the tokens ITvarid (a variable id) and ITqvarid (a qualified+-- variable id) are supported. If IncludeQualified euqal ExcludeQualifiedVars+-- then ITqvarid will be ignored. A token of type ITqvarid has two strings+-- attached, the name of the module (the qualifier) and the name of the+-- variable. Of these twos only the name is contained by the result.+getVariableIdUsingLexerAt :: GhcMonad m => (FilePath,BufLoc) -> IncludeQualified -> m (Either GetVariableLexerException (String,RealSrcSpan))+getVariableIdUsingLexerAt (filename,loc) behaviour = do+ let wholeFileLoc :: RealSrcLoc+ wholeFileLoc = mkRealSrcLoc (mkFastString filename) 1 1 + ghcDynFlags <- getSessionDynFlags+ fileContent <- liftIO $ hGetStringBuffer filename++ let isRelevantToken :: Token -> Bool+ isRelevantToken (ITvarid _) = True+ isRelevantToken (ITqvarid _) | (behaviour == IncludeQualifiedVars) = True+ isRelevantToken _ = False++ token2Result :: Token -> String+ token2Result (ITvarid s ) = unpackFS s+ token2Result (ITqvarid (_,s)) = unpackFS s+ token2Result _ = error "Internal error (unexected wrong token type)"++ case lexTokenStream fileContent wholeFileLoc ghcDynFlags of+ + -- Experiences showed that the lexer adds additional tokens+ -- to the token stream that have length 0 (e.g. ITvocurly or+ -- ITsemi). We want to filter the token stream for the+ -- (single) token that matches the SrcLoc passed as command+ -- line parameter. As this is obviously not enough+ -- (additional ITvocurly start at the same location), we have+ -- to filter them again. There are two possibilities:+ -- - only use non-zero-length tokens+ -- - only use ITvarid Tokens (variable IDs)+ --+ -- The current solution is to filter the tokens for elements that+ -- contain the passed source location and from the result only use+ -- the tokens of type ITvarid. This makes sense as we anyway have+ -- to extract the string from this token.+ + POk _ xs -> let relevantByLoc = [ tok | tok@(L (RealSrcSpan s) _) <- xs + , (toBufLoc $ realSrcSpanStart s) <= loc + , (toBufLoc $ realSrcSpanEnd s) > loc ]+ relevant = [ (token2Result t,r) | (L (RealSrcSpan r) t) <- relevantByLoc , isRelevantToken t ]+ in case relevant of [x] -> return $ Right x+ [] -> return $ Left VarNotFound+ _ -> error "internal error (too many tokens)"+ PFailed _ _ -> return $ Left LexingFailed
+ Language/Haskell/HBB/Internal/SrcSpan.hs view
@@ -0,0 +1,199 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# OPTIONS -Wall #-}+module Language.Haskell.HBB.Internal.SrcSpan where++import Data.Generics+import Data.Char (isSpace)+import SrcLoc++-- | This is just the combination of a line number and a column number.+data BufLoc = BufLoc Int Int -- ^ BufLoc line column+ deriving (Eq,Data,Typeable)++-- | BufLocs are shown by separating the line and the column number by a colon.+instance Show BufLoc where+ show (BufLoc l1 c1) = (show l1) ++ ':':(show c1)++instance Ord BufLoc where+ compare (BufLoc l1 _ ) (BufLoc l2 _ ) | l1 /= l2 = l1 `compare` l2+ compare (BufLoc _ c1) (BufLoc _ c2) = c1 `compare` c2++-- | A BufSpan is simply defined by two times a BufLoc.+data BufSpan = BufSpan BufLoc BufLoc -- ^ BufSpan startLoc endLoc+ deriving (Eq,Typeable,Data)++instance Show BufSpan where+ show (BufSpan l1 l2) = (show l1) ++ " - " ++ (show l2)++-- | This is a file/text portion buffered as list of lines.+--+-- Line buffers are used to avoid repeated IO operations and to describe+-- line-oriented content (for example at assembling the TTree).+type LineBuf = [String]++-- | Returns the start location of a BufSpan+spanStart :: BufSpan -> BufLoc+spanStart (BufSpan s _) = s+-- | Returns the end location of a BufSpan+spanEnd :: BufSpan -> BufLoc+spanEnd (BufSpan _ e) = e++-- | This is an auxiliary function that splits a string at all newlines.+--+-- Note that lines from Prelude cannot be used here. The reason is following+-- example:+--+-- @+-- lines \"| ->\\n\" = [\"| ->\"]+-- str2LineBuf \"| ->\\n\" = [\"| ->\",\"\"]+-- @+str2LineBuf :: String -> LineBuf+str2LineBuf x = str2LineBufAcc x [] + where+ str2LineBufAcc :: String -> LineBuf -> LineBuf+ str2LineBufAcc [] acc = reverse $ map reverse acc+ str2LineBufAcc ('\n':s) [] = str2LineBufAcc s ["",""] -- This is a special case!+ str2LineBufAcc ('\n':s) acc = str2LineBufAcc s ("":acc)+ str2LineBufAcc (c :s) [] = str2LineBufAcc s [(c:"")]+ str2LineBufAcc (c :s) (a:acc) = str2LineBufAcc s ((c:a):acc)++-- | Converts a line buffer to a string.+-- +-- Note that 'unlines' doesn't work here because it doesn't treat the last line+-- correctly.+lineBuf2Str :: LineBuf -> String+lineBuf2Str [] = ""+lineBuf2Str xs = (unlines (init xs)) ++ (last xs)++-- | This alias can be used to have a meaningful name for indentations.+type Indentation = Int++-- | For a line buffer this function returns the number of spaces charachters+-- of the line with the smallest indentation.+getIndentation :: LineBuf -> Indentation+getIndentation buf = minimum $ map (countInd 0) buf+ where+ -- FIXME Currently we are unable to count tabs with more than one+ -- space...+ countInd :: Indentation -> String -> Indentation+ countInd _ [] = 0 -- No non-space character at all on this line...!!+ countInd acc (c:s) | isSpace c = countInd (acc+1) s -- TODO tab is always 1 space currently+ countInd acc _ = acc++-- | Compares two non-overlapping RealSrcSpan elements by their starting+-- location.+compareByStartLoc :: RealSrcSpan -> RealSrcSpan -> Ordering+compareByStartLoc r1 r2 = compare s1 s2+ where s1 = realSrcSpanStart r1+ s2 = realSrcSpanStart r2++-- | Converts a RealSrcLoc into a BufLoc effectively throwing away the+-- filename.+toBufLoc :: RealSrcLoc -> BufLoc+toBufLoc x =+ let line = srcLocLine x+ col = srcLocCol x+ in BufLoc line col++-- | Converts a RealSrcSpan into a BufSpan effectively throwing away the+-- filename.+toBufSpan :: RealSrcSpan -> BufSpan+toBufSpan x = BufSpan startLoc endLoc+ where startLoc = toBufLoc $ realSrcSpanStart x+ endLoc = toBufLoc $ realSrcSpanEnd x++-- | Creates a BufSpan where the first and the last BufLoc is the same.+--+-- The first parameter is the line and the second one is the column.+pointBufSpan :: Int -> Int -> BufSpan+pointBufSpan line column = BufSpan loc loc+ where loc = BufLoc line column++-- | This function splits the passed lines (of a file-cache) at the position+-- passed as second parameter.+--+-- Note that the line- and column-counts start with 1 (this is GHC behaviour).+-- The split contains the character pointed to by the BufLoc in the right part+-- of the tuple.+--+-- This means that (in case of line=1 and column=1) following applies:+--+-- @+-- splitAtBufLoc \"hello world\" loc == ([\"\"],[\"hello world\"])+-- @+splitAtBufLoc :: LineBuf -> BufLoc -> (LineBuf,LineBuf)+splitAtBufLoc [] _ = ([],[])+splitAtBufLoc lns (BufLoc ln co) =+ let leftPart = + let firstPart = (take (max ln 0) lns)+ in (init firstPart) ++ [take (max (co-1) 0) (last firstPart)]+ in case (drop (max (ln-1) 0) lns) of + (r:rs) -> let rightPart = (drop (max (co-1) 0) r):rs in (leftPart,rightPart)+ _ -> (leftPart,[])++-- | This function splits a number of input lines in a way so that the area+-- located to by the passed source span is isolated.+--+-- The three areas in the return tuple are:+--+-- - Initial lines (they come first)+--+-- - Subject lines (they are between the locations)+--+-- - Trailing lines (they come after the last location)+--+-- The last line of initLines and the first line of subjLines must be joined to+-- reproduce the output. The same applies to subjLines and traiLines...+splitBufferedLinesAtBufSpan :: LineBuf -> BufSpan -> (LineBuf,LineBuf,LineBuf)+splitBufferedLinesAtBufSpan lns (BufSpan l1 l2) =+ let (rest,traiLines) = splitAtBufLoc lns l2+ (initLines,subjLines) = splitAtBufLoc rest l1+ in (initLines,subjLines,traiLines)+ +-- | This function returns true if the first RealSrcSpan points to a region that+-- is located before the one pointed to by the second RealSrcSpan.+--+-- The two spans must be disjoint otherwise the results are undefined (can be+-- checked with the function 'disjoint')!+leq :: RealSrcSpan -> RealSrcSpan -> Bool+s1 `leq` s2 =+ let endS1 = realSrcSpanEnd s1+ startS2 = realSrcSpanStart s2+ in endS1 <= startS2++-- | This function returns true when the two passed RealSrcSpans do not+-- overlap.+--+-- This means that the end of the first RealSrcSpan is smaller or equal to the+-- start of the second RealSrcSpan and vice versa.+disjoint :: RealSrcSpan -> RealSrcSpan -> Bool+disjoint s1 s2 =+ let startS1 = realSrcSpanStart s1+ endS1 = realSrcSpanEnd s1+ startS2 = realSrcSpanStart s2+ endS2 = realSrcSpanEnd s2+ in endS1 <= startS2 || endS2 <= startS1++-- | This function is the opposite of splitAtBufLoc.+--+-- It can rejoin a split concerning that the last and the first line in the+-- frist respective second element of the split tuple must be joined by string+-- concatenation. This function has been designed to run with linear time+-- complexity.+joinSplit :: ([String],[String]) -> [String]+joinSplit (lines1,[]) = lines1+joinSplit ([],lines2) = lines2+joinSplit t = joinSplitAcc [] t+ where+ joinSplitAcc :: [String] -> ([String],[String]) -> [String]+ joinSplitAcc acc ([],[]) = reverse acc+ joinSplitAcc acc ([],(l:lines2)) = joinSplitAcc (l:acc) ([],lines2)+ joinSplitAcc acc ((x:y@(_:_)),lines2) = joinSplitAcc (x:acc) (y ,lines2)+ joinSplitAcc acc ([x],(l:lines2)) = joinSplitAcc ((x ++ l):acc) ([],lines2)+ joinSplitAcc acc ([x],[]) = joinSplitAcc ( x :acc) ([],[])++-- | This function combines two times joinSplit to be able to join lines that+-- have been split by a SrcSpan.+reassembleSplit :: ([String],[String],[String]) -> [String]+reassembleSplit (initLines,subjLines,traiLines) =+ joinSplit (initLines,(joinSplit (subjLines,traiLines)))
+ Language/Haskell/HBB/Internal/TTree.hs view
@@ -0,0 +1,177 @@+{-# OPTIONS -XDeriveDataTypeable #-}+module Language.Haskell.HBB.Internal.TTree where++import Language.Haskell.HBB.Internal.SrcSpan+import Data.Generics+import FastString (unpackFS)+import Data.List (union,sort)+import Data.List (sortBy)+import SrcLoc+-- SrcLoc is a module from GHC which can be used to describe locations and+-- spans of the source code. It is used at this point to avoid the introduction+-- of (some) user-defined types to describe the transformation tree.++data TTreeNode a b = Addition a+ | Display b deriving (Show,Eq)++-- | This is the generic data structure representing a transformation tree.+--+-- /T/ransformation/Tree/+--+-- The transformation tree is a recursive data structure to represent+-- modifications to text (files). It is used to represent the changes to source+-- code made by the inlining function feature.+-- +-- /Cover-Range/+--+-- The cover-range is the snippet of code that should be hidden by the new+-- text. For the root of the tree this is a RealSrcSpan (which has a filename+-- attached). For other location the cover-range refers to the text inserted by+-- the parent element.+-- +-- /Children/+--+-- The text that has been added by for example an addition may be altered again+-- by the usage of nested transformations. These transformations always refer+-- to their parent transformation whichs means that the Cover-Range for example+-- contains lines- and column-indices which refer only to the snipped added by+-- their parent transformation (and not the whole text which is referred to by+-- the top-most addition or display). INVARIANT: Moreover the source-spans+-- elements of child-transformations must be disjoint. Reassembling the+-- transformation-tree can so be done by sorting the child-tranformations by+-- their cover-range in reverse order (so that the last position is taken+-- first) and applying them.+--+-- Instance of TTree produced by ConvertibleToTTree:+--+-- > TTree LineBuf RealSrcSpan InsertionInfo+--+-- Instance of TTree that is searialized to JSON:+--+-- > TTree LineBuf (RealSrcSpan,Int) BufSpan+data TTree a b c = TTree (TTreeNode a b) [(c,TTree a b c)] deriving (Show,Eq)++-- The ClientTTree is the data structure that is (as the name says) reported to+-- the client (in contrast to InternalTTree which is used by HBB internally).+-- It can be (de-)serialized to and from JSON with the functions from the+-- module Language.Haskell.HBB.Internal.TTreeJSON.+type ClientTTree = TTree LineBuf (RealSrcSpan,Int) BufSpan++-- This function takes a file cache, a transformation tree and a line buffer+-- and returns a modified verion of the line buffer to which all+-- transformations contained by the tree have been applied.+applyTTree :: [(FilePath,LineBuf)] -> (BufSpan,TTree LineBuf (RealSrcSpan,Int) BufSpan) -> LineBuf -> LineBuf+applyTTree fc tree lns = applyTTreeGeneric Nothing fc id tree lns++-- The following is the core function that applies a TTree to produce a certain+-- output text. This function has been made as generic as needed to use it+-- within the module LibTTreeColor for the function 'applyColoredTTree' as+-- well. By passing a non-Nothing value as first parameter the behaviour of+-- this function may be influenced.+applyTTreeGeneric :: Maybe (a,attr -> a,(a,attr) -> (LineBuf,LineBuf,LineBuf) -> (LineBuf,LineBuf,LineBuf)) + -> [(FilePath,LineBuf)] -- The file cache. An exception is thrown when it+ -- does not contain all files that occure in the tree.+ -- This obviously only needed for the displays.+ -> (attr -> BufSpan) -- The function to extract the BufSpan+ -> (attr,TTree LineBuf (RealSrcSpan,Int) attr) -- The tree itself. 'attr' will mostly be BufSpan.+ -> LineBuf -- The line buffer the transformation should be applied to+ -> LineBuf+applyTTreeGeneric info fc getSpan (attr,tree) lns = + let (initLines,subjLines,traiLines) = splitBufferedLinesAtBufSpan lns (getSpan attr)++ compareNonOverlSpns' (attr1,_) (attr2,_) =+ let (BufSpan l1 _) = getSpan attr1+ (BufSpan l2 _) = getSpan attr2+ in compare l1 l2++ -- This is special code currently only needed by the ANSI-coloring+ -- feature.++ newInfo = case info of+ Nothing -> Nothing+ Just (_,infoFun,finFun) -> Just (infoFun attr,infoFun,finFun)++ -- When this tree is an addition the string to add is given directly,+ -- when it is a display we have to extract it from the file cache.++ (focusStr,childs) = case tree of+ (TTree (Addition ad ) ch) -> (ad,ch)+ (TTree (Display (spn,offsHint)) ch) -> + let buf = getCacheElement (unpackFS $ srcSpanFile spn) fc+ (_,res,_) = splitBufferedLinesAtBufSpan buf (toBufSpan spn)+ res' = case res of + [] -> []+ (x:xs) -> if offsHint < 0+ then x:(map (\line -> drop (-offsHint) line ) xs)+ else x:(map (\line -> (replicate offsHint ' ') ++ line) xs)+ in (res',ch)++ -- Applying the childs one after another (may) move the indices within+ -- the original text. This must be considered by the implementation.+ -- Adding two times the string 'fac' will possible move the second+ -- addition by 3 letters...+ --+ -- To solve this problem we apply the children in reversed order which+ -- means that the children with the RealSrcSpan that is located the+ -- nearest from the back (last line) is applied first. This works as by+ -- the definition of TTree the RealSrcSpans of the childrens mustn't+ -- overlap (this is an invariant of the tree).+ --+ -- Note that foldr applies in reversed order!+ childsRes :: LineBuf+ childsRes = foldr + (applyTTreeGeneric newInfo fc getSpan) + focusStr + (sortBy compareNonOverlSpns' childs)++ (p1,p2,p3) = case info of+ Nothing -> (initLines,childsRes,traiLines)+ Just (i,_,finalizerFun) -> finalizerFun (i,attr) (initLines,childsRes,traiLines)+ in reassembleSplit (p1,p2,p3)++getCacheElement :: FilePath -> [(FilePath,LineBuf)] -> LineBuf+getCacheElement f1 c = case filter (\(f2,_) -> f2 == f1) c of+ [(_,x)] -> x+ [] -> error $ "internal error (File cache is incomplete. Missing element: " ++ f1 ++ ")"+ _ -> error "internal error (duplicates in the file cache)"+ +-- Collecting Filenames+-- ====================+--+-- This function collects the filenames within a TTree. File names may have two+-- origins. +-- -> The first one is the cover-range of the root-element (which points to the+-- file where the transformation is applied (all children refer to locations+-- relative to the next upper element in the tree)). +-- -> The second ones are the source-display elements of a Display.+--+-- The file names of the TTree are collected to read the individual files in+-- advance and cache their content for faster access.+--+-- Principally the tree should only contain two files it refers to as inlining+-- a function will have a source file and a (maybe identical) target file.+--+collectFilenames :: (a,TTree b (RealSrcSpan,Int) a) -> [FilePath]+collectFilenames tree = collectFilenames' tree []+ where+ collectFilenames' :: (a,TTree b (RealSrcSpan,Int) a) -> [String] -> [String]+ collectFilenames' (_,(TTree (Display (spn,_)) ch)) acc = + foldr collectFilenames' (union [(unpackFS (srcSpanFile spn))] acc) ch+ collectFilenames' (_,(TTree _ ch)) acc = + -- An addition doesn't ship a filename...+ foldr collectFilenames' acc ch++-- Caching Files+-- =============+--+-- This functions creates a cache from the list of filenames passed as first+-- argument. A file cache like the one created here is for example needed by+-- the functions that apply a TTree (like 'applyTTree' or 'applyColoredTTree').+cacheFiles :: [FilePath] -> IO [(FilePath,LineBuf)]+cacheFiles fs = cacheFilesAcc fs []+ where+ cacheFilesAcc :: [FilePath] -> [(FilePath,LineBuf)] -> IO [(FilePath,LineBuf)]+ cacheFilesAcc [] acc = return acc+ cacheFilesAcc (f:fs) acc = do+ content <- readFile f+ cacheFilesAcc fs ((f,str2LineBuf content):acc)
+ Language/Haskell/HBB/Internal/TTreeColor.hs view
@@ -0,0 +1,97 @@+module Language.Haskell.HBB.Internal.TTreeColor (+ applyColoredTTree+ ) where++import Language.Haskell.HBB.Internal.SrcSpan+import Language.Haskell.HBB.Internal.TTree+import Control.Monad.State.Lazy+import Data.List (sortBy)+import SrcLoc++data TTreeColor = Gray+ | Red | HlRed | Green | HlGreen+ | Yellow | HlYellow | Blue | HlBlue+ | Magenta | HlMagenta | Cyan | HlCyan+ | DefaultWhiteOnBlack ++additionColor = Gray+displayColors = cycle [ Red , Green , Yellow , Blue , Magenta , Cyan+ , HlRed , HlGreen , HlYellow , HlBlue , HlMagenta , HlCyan ]++ansiColorStr :: TTreeColor -> String+ansiColorStr Gray = "\ESC[1;30m"+ansiColorStr Red = "\ESC[0;31m"+ansiColorStr Green = "\ESC[0;32m"+ansiColorStr Yellow = "\ESC[0;33m"+ansiColorStr Blue = "\ESC[0;34m"+ansiColorStr Magenta = "\ESC[0;35m"+ansiColorStr Cyan = "\ESC[0;36m"++ansiColorStr HlRed = "\ESC[1;31m"+ansiColorStr HlGreen = "\ESC[1;32m"+ansiColorStr HlYellow = "\ESC[1;33m"+ansiColorStr HlBlue = "\ESC[1;34m"+ansiColorStr HlMagenta = "\ESC[1;35m"+ansiColorStr HlCyan = "\ESC[1;36m"++ansiColorStr DefaultWhiteOnBlack = "\ESC[0m"++attachColors + :: (BufSpan,ClientTTree) + -> ((BufSpan,TTreeColor),TTree LineBuf (RealSrcSpan,Int) (BufSpan,TTreeColor))+attachColors tree = ++ -- This is the axiliary function that transforms a tree into a colored one.+ -- All additions will be gray and displays will use the rest of the colors+ -- (except white which is used for the rest of the text).+ let colorStep + :: (BufSpan,TTree LineBuf (RealSrcSpan,Int) BufSpan) + -> State (Int,[(RealSrcSpan,TTreeColor)]) ((BufSpan,TTreeColor),TTree LineBuf (RealSrcSpan,Int) (BufSpan,TTreeColor))+ colorStep (l,(TTree content childs)) = do+ childs' <- mapM colorStep childs+ color <- case content of+ (Display (spn,_)) -> do+ -- Ok, this is a display.+ (colorIdx,alreadyKnown) <- get++ let (selectedColor,newState) = case filter (\(s,_) -> s == spn) alreadyKnown of+ [] -> let color2add = (displayColors !! colorIdx)+ in (color2add,(colorIdx+1,((spn,color2add):alreadyKnown)))+ [(_,c)] -> (c,(colorIdx,alreadyKnown))+ (_:_) -> error "internal error (more than one color for one src-span)"+ put newState+ return selectedColor+ (Addition _) -> return additionColor+ return $ ((l,color),(TTree content childs'))++ in evalState (colorStep tree) (0,[])++-- This function is the pendant to 'applyTTree' from+-- 'Language.Haskell.HBB.Internal.TTree'. It produces a TTree which contains ANSI+-- Escape sequences for a colored output in an according terminal.+--+-- Text that has not been altered by the transformation-tree is written with+-- the default settings. Additions are written in gray and Displays use the+-- rest of the color-space.+--+-- This function makes use of the function applyTTreeGeneric which has+-- intentionally been made as generic as needed to be used here.+applyColoredTTree :: + [(FilePath,LineBuf)] -- File cache + -> (BufSpan,ClientTTree) -- The tree itself+ -> LineBuf -- The file to transform+ -> LineBuf+applyColoredTTree fc tree lns = + applyTTreeGeneric+ (Just (DefaultWhiteOnBlack,(\(_,x) -> x),finFun)) + fc+ (\(s,_) -> s)+ (attachColors tree)+ lns++ where+ finFun :: (TTreeColor,(BufSpan,TTreeColor)) -> (LineBuf,LineBuf,LineBuf) -> (LineBuf,LineBuf,LineBuf)+ finFun (parColor,(_,color)) (initLines,childsRes,traiLines) = + ( initLines+ ,joinSplit ([ansiColorStr color],childsRes)+ ,joinSplit ([ansiColorStr parColor],traiLines))
+ Language/Haskell/HBB/Internal/TTreeJSON.hs view
@@ -0,0 +1,204 @@+{-# LANGUAGE OverloadedStrings #-}+module Language.Haskell.HBB.Internal.TTreeJSON (+ encodeTTreeToJSON,+ decodeTTreeFromJSON) where++-- This module allows the (de-)serialization of TTree to JSON.+-- The following example shows a serialized TTree which one child element:+-- {+-- "addition-text": "()",+-- "children": [+-- {+-- "addition-text": "\x -> \"hello \" ++ x",+-- "children": [],+-- "cover-range": "1:2-1:2"+-- }+-- ],+-- "cover-range": "examples/PlayHelloPattern.hs,17:16-17:21"+-- }++import Language.Haskell.HBB.Internal.SrcSpan+import Language.Haskell.HBB.Internal.TTree+import qualified Data.ByteString.Char8 as StrictByteString (ByteString)+import qualified Data.ByteString.Lazy as LazyByteString (ByteString)+import Data.HashMap.Strict (member)+import Data.Aeson.Types (Parser)+import Control.Monad+import FastString (mkFastString,unpackFS)+import Data.Aeson+import qualified Data.Text as Text+import SrcLoc+-- SrcLoc is a module from GHC which can be used to describe locations and+-- spans of the source code. It is used at this point to avoid the introduction+-- of (some) user-defined types to describe the transformation tree.++-- This is the (exported) function that allows the deserialization from JSON.+decodeTTreeFromJSON :: StrictByteString.ByteString -> Either String (RealSrcSpan,TTree LineBuf (RealSrcSpan,Int) BufSpan)+decodeTTreeFromJSON bs = case eitherDecodeStrict' bs of+ Right (JSON_RootTTree tree) -> Right tree+ Left msg -> Left msg++-- | This function converts the tranformation-tree to JSON.+--+-- This is an example of a tree containing two addition which has been+-- converted to JSON (the JSON-code has been layouted to make it more+-- readable):+--+-- +-- > {+-- > "addition-text": "()",+-- > "children": [+-- > {+-- > "addition-text": "\x -> \"hello \" ++ x",+-- > "children": [],+-- > "cover-range": "1:2-1:2"+-- > }+-- > ],+-- > "cover-range": "examples/PlayHelloPattern.hs,17:16-17:21"+-- > }+encodeTTreeToJSON :: (RealSrcSpan,TTree LineBuf (RealSrcSpan,Int) BufSpan) -> LazyByteString.ByteString+encodeTTreeToJSON tree = encode (JSON_RootTTree tree)++-- Wrapped data types+-- ==================+--+-- The JSON library aeson is based on the type classes FromJSON and ToJSON.+-- Types that are instances of these classes can be converted from and to JSON.+-- We want the type TTree to be encoded to and decoded from JSON. The first+-- solution would be to make it (and RealSrcSpan as it occurres within the+-- tree) an instance of these to type classes. This solution works but the+-- problem is that the compiler will issue "Orphaned Instance" errors as the+-- type class instances aren't defined in the module where the type is defined.+-- Especially for RealSrcSpan (which is defined in the module SrcLoc from GHC)+-- we can never reach this. To circumvent this issue this module defines its+-- own wrappers around these types prefixing them with "JSON_". For these (new)+-- types instances of FromJSON and ToJSON are defined.+data JSON_RealSrcSpan = JSON_RealSrcSpan RealSrcSpan+data JSON_DisplaySpan = JSON_DisplaySpan (RealSrcSpan,Int)+data JSON_TTree = JSON_TTree (BufSpan ,TTree LineBuf (RealSrcSpan,Int) BufSpan)+data JSON_RootTTree = JSON_RootTTree (RealSrcSpan,TTree LineBuf (RealSrcSpan,Int) BufSpan)+data JSON_BufLoc = JSON_BufLoc BufLoc+data JSON_BufSpan = JSON_BufSpan BufSpan++-- For the data type (JOSN_)RealSrcSpan (originally a GHC type) we use a more+-- narrow representation: '<filename>-<line>:<column>-<line>:<column>'. This+-- should make the JSON strings more compact and readable.++-- Splits a string at the first occurrence of the passed character+-- and returns the two substrings (without the character itself).+splitAtChar :: Char -> String -> Parser (String,String)+splitAtChar char x = case break (== char) x of + (xs,(c:ys)) | c == char -> return (xs,ys)+ _ -> mzero++-- BufLoc in JSON must have the form '<line>:<column>'+instance FromJSON JSON_BufLoc where+ parseJSON (String s) = do+ (l,c) <- splitAtChar ':' (Text.unpack s)+ return $ (JSON_BufLoc (BufLoc (read l) (read c)))+ parseJSON _ = mzero++instance ToJSON JSON_BufLoc where+ toJSON (JSON_BufLoc (BufLoc li co)) = + (String $ Text.pack $ (show li) ++ [':'] ++ (show co))++-- A BufSpan must have the form '<line>:<column>-<line>:<column>'+instance FromJSON JSON_BufSpan where+ parseJSON (String s) = do+ (l1,l2) <- splitAtChar '-' (Text.unpack s)+ loc1 <- parseJSON (String $ Text.pack l1)+ loc2 <- parseJSON (String $ Text.pack l2)+ let (JSON_BufLoc location1) = loc1+ (JSON_BufLoc location2) = loc2+ return $ (JSON_BufSpan (BufSpan location1 location2))+ parseJSON _ = mzero++-- BufSpan will have the form '<line>:<column>-<line>:<column>'+instance ToJSON JSON_BufSpan where+ toJSON (JSON_BufSpan (BufSpan l1 l2)) =+ let (String t1) = toJSON (JSON_BufLoc l1)+ (String t2) = toJSON (JSON_BufLoc l2)+ in String $ Text.append (Text.snoc t1 '-') t2++instance FromJSON JSON_DisplaySpan where+ parseJSON (String s) = do+ (revHint,revRealSrcSpan) <- splitAtChar ',' (reverse $ Text.unpack s)+ rSrcSpan <- parseJSON $ String $ Text.pack $ reverse revRealSrcSpan+ let hint = read (reverse revHint) :: Int+ (JSON_RealSrcSpan rspn) = rSrcSpan+ return $ JSON_DisplaySpan (rspn,hint)+ parseJSON _ = mzero++instance ToJSON JSON_DisplaySpan where+ toJSON (JSON_DisplaySpan (spn,hint)) =+ let (String txt) = toJSON (JSON_RealSrcSpan spn)+ in String $ Text.append (Text.snoc txt ',') (Text.pack (show hint))++-- This instance parses RealSrcSpans from JSON strings.+-- The format is: '<filename>,<line>:<column>-<line>:<column>'+instance FromJSON JSON_RealSrcSpan where+ parseJSON (String s) = do + (revSpan,revName) <- splitAtChar ',' (reverse $ Text.unpack s)+ span <- parseJSON $ String $ Text.pack (reverse revSpan)+ let (JSON_BufSpan (BufSpan (BufLoc l1 c1) (BufLoc l2 c2))) = span+ return $ JSON_RealSrcSpan (mkRealSrcSpan+ (mkRealSrcLoc (mkFastString (reverse revName)) l1 c1)+ (mkRealSrcLoc (mkFastString (reverse revName)) l2 c2))+ parseJSON _ = mzero++-- This instance serializes a RealSrcSpan to a JSON string.+-- The format is: '<filename>,<line>:<column>-<line>:<column>'+instance ToJSON JSON_RealSrcSpan where+ toJSON (JSON_RealSrcSpan spn) =+ let fromLoc = realSrcSpanStart spn+ toLoc = realSrcSpanEnd spn+ fn = Text.pack $ unpackFS $ srcLocFile fromLoc+ (l1,c1) = (srcLocLine fromLoc,srcLocCol fromLoc)+ (l2,c2) = (srcLocLine toLoc,srcLocCol toLoc)+ (String spanStr) = toJSON (JSON_BufSpan $ BufSpan (BufLoc l1 c1) (BufLoc l2 c2))+ in (String (Text.append fn (Text.cons ',' spanStr)))++-- This function parses a TTree from JSON. It is generic in a way that allows+-- its usage for the deserialization of either JSON_TTree or JSON_RootTTree.+parseJSONTTreeGeneric constr locExtract (Object o) | member "addition-text" o = do+ addition' <- parseJSON =<< (o .: "addition-text")+ coverrange' <- parseJSON =<< (o .: "cover-range")+ children' <- parseJSON =<< (o .: "children")+ let cr = locExtract coverrange'+ cldrn = [ tree | (JSON_TTree tree) <- children' ]+ return $ constr (cr,(TTree (Addition addition') cldrn))+parseJSONTTreeGeneric constr locExtract (Object o) | member "source-range" o = do+ sourcedisplay' <- parseJSON =<< (o .: "source-range")+ coverrange' <- parseJSON =<< (o .: "cover-range")+ children' <- parseJSON =<< (o .: "children")+ let (JSON_DisplaySpan ds) = sourcedisplay'+ cr = locExtract coverrange'+ cldrn = [ tree | (JSON_TTree tree) <- children' ]+ return $ constr (cr,(TTree (Display ds) cldrn))+parseJSONTTreeGeneric _ _ _ = mzero+ +instance FromJSON JSON_TTree where+ parseJSON = parseJSONTTreeGeneric JSON_TTree (\(JSON_BufSpan x) -> x)++instance FromJSON JSON_RootTTree where+ parseJSON = parseJSONTTreeGeneric JSON_RootTTree (\(JSON_RealSrcSpan x) -> x)++-- This function makes JSON from a TTree. It is generic in a way that allows+-- its usage for the serialization of either JSON_TTree or JSON_RootTTree.+toJSONTTreeGeneric extractor wrapLoc wrappedTree =+ case extractor wrappedTree of+ (bs,(TTree (Addition add) childs)) ->+ object [ "addition-text" .= add+ , "cover-range" .= (wrapLoc bs)+ , "children" .= [ JSON_TTree c | c <- childs] ]+ (bs,(TTree (Display display) childs)) ->+ object [ "source-range" .= (JSON_DisplaySpan display)+ , "cover-range" .= (wrapLoc bs)+ , "children" .= [ JSON_TTree c | c <- childs] ]+ ++instance ToJSON JSON_TTree where+ toJSON = toJSONTTreeGeneric (\(JSON_TTree x) -> x) JSON_BufSpan++instance ToJSON JSON_RootTTree where+ toJSON = toJSONTTreeGeneric (\(JSON_RootTTree x) -> x) JSON_RealSrcSpan
+ Language/Haskell/HBB/Locate.hs view
@@ -0,0 +1,70 @@+{-# OPTIONS -Wall #-}++module Language.Haskell.HBB.Locate (+ locate,+ locateM,+ showLocateResult,+ BufLoc(..),+ BufSpan(..)+ ) where++import Language.Haskell.HBB.Internal.GHCHighlevel+import Language.Haskell.HBB.Internal.SrcSpan+import Language.Haskell.HBB.Internal.GHC+import System.FilePath (normalise)+import FastString (unpackFS)+import GHC.Paths (libdir)+import SrcLoc+import GHC (GhcMonad)++-- | This function implements the mode 'locate'.+--+-- 'locate' takes the name of a file and a position within this file. If this+-- position points to a value or function binding this function returns the+-- source-range where the binding is defined. If the position doesn't point to+-- an according binding, the function will fail with an exception. In this+-- case nothing is written to standard output.+--+-- The first two command line parameters is:+--+-- - The GHC options as string list (as they should appear on the command+-- line, e.g. @[\"-isrc\"]@)+locate :: [String] -> FilePath -> BufLoc -> IO (FilePath,BufSpan)+locate ghcOptions filename reqLoc = + runGhcWithCmdLineFlags ghcOptions (Just libdir) $ locateM filename reqLoc++-- | This function creates a string of the result returned by locate or+-- locateM.+--+-- The string has exactly the format that should be understood by text editors+-- that are using the mode locate.+showLocateResult :: (FilePath,BufSpan) -> String+showLocateResult (f,(BufSpan (BufLoc sli sco) (BufLoc eli eco))) =+ ('"':(normalise f) ++ "\"") ++ (' ':(show sli)) ++ (' ':(show sco)) +++ (' ':(show eli)) ++ (' ':(show eco))++-- | This is a variant of locate that runs within the GHC monad and therefore+-- allows a more fine-grained control over the behaviour of GHC.+locateM :: GhcMonad m => FilePath -> BufLoc -> m (FilePath,BufSpan)+locateM filename reqLoc = do++ (SearchedTokenInfo { result = (searchedBinding,sig) }) <- searchFunctionBindingM filename reqLoc Nothing+ -- + -- The mode locate is only able to return one (single) source range.+ -- However in most cases the user will want to get shown the binding+ -- signature as well. So in cases where the signature is located directly+ -- before the binding (this will be in most cases) 'locate' returns a span+ -- that also coverts the function signature.+ --+ let (L (RealSrcSpan bindLoc) _) = searchedBinding+ r = case sig of+ Nothing -> toBufSpan bindLoc+ Just (L (RealSrcSpan l) _) ->+ let (BufSpan (BufLoc bl bc) end) = toBufSpan bindLoc+ (BufSpan (BufLoc sl sc) _ ) = toBufSpan l+ in if bc == sc && bl == (sl + 1)+ then BufSpan (BufLoc sl sc) end+ else toBufSpan bindLoc+ Just _ -> toBufSpan bindLoc+ bindingFile = unpackFS $ srcSpanFile bindLoc+ return (bindingFile,r)
+ Language/Haskell/HBB/OccurrencesOf.hs view
@@ -0,0 +1,314 @@+{-# OPTIONS -Wall #-}++module Language.Haskell.HBB.OccurrencesOf (+ occurrencesOf,+ occurrencesOfM,+ showOccurrencesOfResult,+ BufLoc(..),+ BufSpan(..)+ ) where++import Language.Haskell.HBB.Internal.GHCHighlevel+import Language.Haskell.HBB.Internal.SrcSpan+import Language.Haskell.HBB.Internal.Lexer+import Language.Haskell.HBB.Internal.GHC+import Language.Haskell.HBB.Internal.AST+import System.FilePath (normalise)+import Control.Monad (foldM)+import Data.Generics+import FastString (unpackFS,fsLit)+import System.IO (hPutStrLn,stderr)+import GHC.Paths (libdir)+import Data.List (union)+import GhcMonad (liftIO)+import HsBinds+import SrcLoc+import Name+import GHC++occurrencesOf :: [String] -> FilePath -> BufLoc -> [FilePath] -> IO [(FilePath,BufSpan)]+occurrencesOf ghcOptions filename reqLoc otherFiles = + runGhcWithCmdLineFlags ghcOptions (Just libdir) $ occurrencesOfM filename reqLoc otherFiles++occurrencesOfM :: GhcMonad m => FilePath -> BufLoc -> [FilePath] -> m [(FilePath,BufSpan)]+occurrencesOfM occFile' loc otherFiles' = do+ -- We normalize the filenames to be able to use 'union' from+ -- 'Data.List' to merge them.+ let occFile = normalise occFile'+ otherFiles = map normalise otherFiles'++ resLocs <- do++ updateDynFlagsToSuppressFileOutput++ res <- getVariableIdUsingLexerAt (occFile,loc) IncludeQualifiedVars+ let spanIdentifiedByLexer = case res of+ Left VarNotFound -> error "It seems that there is no variable at this point?!"+ Left LexingFailed -> error "Lexing failed. The source code seems to contain errors."+ Right (_,rSpn) -> toBufSpan rSpn++ processToken occFile spanIdentifiedByLexer otherFiles++ let convertResult :: RealSrcSpan -> (FilePath,BufSpan)+ convertResult r = (unpackFS $ srcSpanFile r,toBufSpan r)+ + return $ map (\x -> convertResult x) resLocs++showOccurrencesOfResult :: [(FilePath,BufSpan)] -> String+showOccurrencesOfResult elems = sOORAcc [] elems+ where+ sOORAcc :: [String] -> [(FilePath,BufSpan)] -> String+ sOORAcc acc [] = unlines $ reverse acc+ sOORAcc acc ((f,(BufSpan (BufLoc l1 c1) (BufLoc l2 c2))):r) = sOORAcc ((f ++ ' ':(show l1) ++ ' ':(show c1)+ ++ ' ':(show l2) ++ ' ':(show c2)):acc) r++-- | This function detects what is at the position specified (the token) and+-- according to this information it searches all references to this thing.+processToken :: GhcMonad m => FilePath -> BufSpan -> [FilePath] -> m [RealSrcSpan]+processToken occFile spn@(BufSpan (BufLoc _ c1) (BufLoc _ c2)) otherFiles = do++ what <- whatIsAt occFile spn++ let tryProcessTokenAsName4ABinding :: GhcMonad m => Name -> m [RealSrcSpan]+ tryProcessTokenAsName4ABinding n = do+ funBindInfo <- searchFunctionBindingForNameM (n,spn,occFile)++ let bindingFile :: [FilePath]+ bindingFile = + let ((L l _),_) = result funBindInfo+ in case srcSpanFileName_maybe l of Nothing -> []+ Just fs -> [normalise $ unpackFS fs]++ referrers <- foldM + (accumulateThingsThatRefer (name funBindInfo))+ [] (bindingFile `union` [occFile] `union` otherFiles)+ definitions <- case fst $ result funBindInfo of+ (L _ (FunBind { fun_infix = True })) -> do+ liftIO $ hPutStrLn stderr $ "The token refers to a infix binding which is not fully supported.\n" +++ "Some occurrences (especially the definition itself) may be missing."+ return []+ (L _ b@(FunBind { fun_infix = False })) -> return $ realSrcSpansOfBinding (c2 - c1) b+ (L _ (PatBind {})) -> do+ liftIO $ hPutStrLn stderr $ "The token refers to a so-called 'pattern binding' which is not fully supported\n." +++ "Some occurrences (especially the definition itself) may be missing."+ return []+ _ -> -- According to the docs VarBind and AbsBinds should only occure AFTER typechecking.+ error "Internal error (unexpected VarBind or AbsBinds)"++ return $ definitions ++ referrers++ let tryProcessTokenAsFunParam :: GhcMonad m => Name -> m [RealSrcSpan]+ tryProcessTokenAsFunParam nm = do++ let -- | This function is used to create a generic SYB-query to collect the function+ -- parameters (usually only one) that start at a certain location.+ locateFunParamsQ :: BufLoc -> LPat Name -> [LPat Name]+ locateFunParamsQ l x@(L (RealSrcSpan r) (VarPat _)) | l == (spanStart $ toBufSpan r) = [x]+ locateFunParamsQ _ _ = []++ funParamInfo <- searchTokenForNameM (nm,spn,occFile) [] (++) (\x -> mkQ [] (locateFunParamsQ x))++ definitionLoc <- + case result funParamInfo of+ [] -> error "Internal error (this is unexpectedly no function parameter)"+ [(L (RealSrcSpan l) _)] -> return l+ _ -> error "Internal error (unexpected ambiguity concerning function parameters)"++ referrers <- do+ setTargets [fileToTarget occFile]++ _ <- load LoadAllTargets -- Depending on the HscTarget this will create+ -- intermediate files (set HscNothing to+ -- suppress)++ (_,currentModSum) <- searchModGraphFor (Left occFile)++ renSource <- extractRenamedAST currentModSum++ let locateLHsExprThatReferTo :: BufLoc -> LHsExpr Name -> [LHsExpr Name]+ locateLHsExprThatReferTo l1 x@(L (RealSrcSpan _) (HsVar n)) =+ case nameSrcSpan n of+ UnhelpfulSpan _ -> []+ RealSrcSpan r -> if l1 == l2 then [x] else []+ where l2 = spanStart $ toBufSpan r+ locateLHsExprThatReferTo _ _ = []++ genericQuery :: GenericQ [LHsExpr Name]+ genericQuery = mkQ [] (locateLHsExprThatReferTo $ spanStart $ toBufSpan definitionLoc)++ let exprs = queryRenamedAST [] (++) genericQuery renSource++ return [ r | (L (RealSrcSpan r) _) <- exprs ]++ return $ [definitionLoc] ++ referrers++ case what of+ ThereIsAName n -> tryProcessTokenAsName4ABinding n `gcatch` + ((\_ -> tryProcessTokenAsFunParam n) :: GhcMonad m => SearchTokenException -> m [RealSrcSpan])+ ThereIsABinding n -> tryProcessTokenAsName4ABinding n+ ThereIsAFunParameter n -> tryProcessTokenAsFunParam n+ UnknownElement -> -- This point is currently never reached as+ -- the lexer function will throw if it doesn't find+ -- a qualified or non-qualified variable.+ error $ "Unsupported operation. " ++ + "Currently only names for bindings and function parameters are supported."++-- | This function is responsible to detect what kind of thing is located at+-- the passed src-span (the token).+whatIsAt :: GhcMonad m => FilePath -> BufSpan -> m WhatIsAtResult+whatIsAt filename (BufSpan startLoc@(BufLoc _ c1) (BufLoc _ c2)) = do+ + tokenIsName <- do+ let considerLHsExprVar :: LHsExpr Name -> BufLoc -> Maybe BufSpan+ considerLHsExprVar (L (RealSrcSpan r) (HsVar _ )) bl = if (spanStart $ toBufSpan r) == bl+ then Just $ toBufSpan r else Nothing+ considerLHsExprVar _ _ = Nothing++ things <- getThingsAt considerLHsExprVar filename startLoc+ case things of+ [(L _ (HsVar n))] -> return $ ThereIsAName n+ _ -> return $ UnknownElement++ tokenIsValBind <- do+ let considerBindsAt :: LHsBindLR Name Name -> BufLoc -> Maybe BufSpan+ considerBindsAt (L (RealSrcSpan r) b@(FunBind {})) bl = + let allSpansOfThisBinding = realSrcSpansOfBinding (c2 - c1) b++ foldArg :: Bool -> RealSrcSpan -> Bool+ foldArg True _ = True+ foldArg _ rs = (spanStart $ toBufSpan rs) == bl+ + in if foldl foldArg False allSpansOfThisBinding+ then Just $ toBufSpan r+ else Nothing+ considerBindsAt _ _ = Nothing+ + funBinds <- getThingsAt considerBindsAt filename startLoc++ case funBinds of+ [(L _ (FunBind { fun_id = (L _ n) }))] -> return $ ThereIsABinding n+ _ -> return $ UnknownElement++ tokenIsFunParameter <- do+ let considerLPat :: LPat Name -> BufLoc -> Maybe BufSpan+ considerLPat (L (RealSrcSpan r) (VarPat _)) bl = if (spanStart $ toBufSpan r) == bl+ then Just $ toBufSpan r else Nothing+ considerLPat _ _ = Nothing++ things <- getThingsAt considerLPat filename startLoc+ case things of+ [(L _ (VarPat n))] -> return $ ThereIsAFunParameter n+ _ -> return $ UnknownElement+ + + let orIfUnknown :: WhatIsAtResult -> WhatIsAtResult -> WhatIsAtResult+ orIfUnknown UnknownElement x = x+ orIfUnknown x _ = x++ return $ tokenIsName `orIfUnknown` tokenIsValBind `orIfUnknown` tokenIsFunParameter++-- | This function searches the passed file for variables, import- or export-+-- declarations that refer to the name passed as first parameter.+accumulateThingsThatRefer :: GhcMonad m => Name -> [RealSrcSpan] -> FilePath -> m [RealSrcSpan]+accumulateThingsThatRefer defName acc currentFile = do++ setTargets [fileToTarget currentFile]++ _ <- load LoadAllTargets -- Depending on the HscTarget this will create+ -- intermediate files (set HscNothing to+ -- suppress)++ (_,currentModSum) <- searchModGraphFor (Left currentFile)++ renSource <- extractRenamedAST currentModSum++ -- There is one problem when searching for 'Name's that refer to something.+ -- There is the possibility that it is qualified (like for example+ -- 'A.hello'). For these cases we have to remember how long the name+ -- actually is and have to shorten the RealSrcSpan by the prefix ('A.)'.++ let spanLength :: BufSpan -> Int+ spanLength (BufSpan (BufLoc _ c1) (BufLoc _ c2)) = (c2 - c1)++ originalLength :: Int+ originalLength = spanLength $ spanToBufSpan $ nameSrcSpan defName+ where+ spanToBufSpan :: SrcSpan -> BufSpan+ spanToBufSpan (RealSrcSpan r) = toBufSpan r+ spanToBufSpan _ = error "Internal error (unexpected unhelpful span in accumulateThingsThatRefer)"++ referrers :: [RealSrcSpan]+ referrers =+ let getReferrerFromIE :: Name -> LIE Name -> [RealSrcSpan]+ getReferrerFromIE refName (L (RealSrcSpan r) (IEVar n)) | (refName == n) = [r]+ getReferrerFromIE _ _ = []++ getReferrerFromTypeSig :: Name -> Sig Name -> [RealSrcSpan]+ getReferrerFromTypeSig refName (TypeSig lNames _) =+ case filter (\(L _ x) -> x == refName) lNames of+ [L (RealSrcSpan r) _] -> [r]+ _ -> []+ getReferrerFromTypeSig _ _ = []++ getReferrersFromExprs :: Name -> LHsExpr Name -> [RealSrcSpan]+ getReferrersFromExprs refName (L (RealSrcSpan r) (HsVar n)) | (refName == n) = + let oldEnd = realSrcSpanEnd r+ newBeg = mkRealSrcLoc (srcLocFile oldEnd) (srcLocLine oldEnd) ((srcLocCol oldEnd) - originalLength)+ in [mkRealSrcSpan newBeg oldEnd]+ getReferrersFromExprs _ _ = []++ genericQuery :: GenericQ [RealSrcSpan]+ genericQuery = mkQ [] (getReferrerFromIE defName) `extQ` + (getReferrerFromTypeSig defName) `extQ`+ (getReferrersFromExprs defName)++ in queryRenamedAST [] (++) genericQuery renSource++ return $ acc ++ referrers++data WhatIsAtResult = -- | Names are used for value- and function bindings+ -- as well as function parameters.+ ThereIsAName Name+ -- | FunBinds contain a 'fun_id' which contain a 'Name'+ -- that points to itself. This gives us the opportunity to+ -- treat names and function bindings equal (for both the+ -- occurrences are searched with a name in hand). The other+ -- possibility would be to have a 'HsBindLR Name Name'+ -- instance here.+ | ThereIsABinding Name+ -- | Function parameters are of type (LPat Name) at the+ -- location where they are defined.+ | ThereIsAFunParameter Name+ | UnknownElement++-- | This function extracts the RealSrcSpan elements of a function binding.+--+-- This is the heading @myfunction@ in @myfunction x = x * x@.+realSrcSpansOfBinding + :: Int -- ^ Length of the function name (determined by the lexer)+ -> HsBindLR Name Name -- ^ The actual binding+ -> [RealSrcSpan] -- ^ A list with one name for each match of the+ -- function (or [] if this is a pattern binding or+ -- infix declaration)+realSrcSpansOfBinding funNameLen (FunBind { fun_infix = False + , fun_matches = (MatchGroup lmatches _) }) =++ -- A function binding does not contain its Name instance explicitely. This+ -- is a problem at this point and the only way to surround it is to guess+ -- that the name of the function always starts with the match. This is also+ -- the reason why infix notation currently isn't supported (extracting the+ -- extract name of the function is a little tricky isn't it?)++ let extractNameSpanFromLMatch :: Int -> LMatch Name -> [RealSrcSpan]+ extractNameSpanFromLMatch len (L (RealSrcSpan l) _) = + let sta = realSrcSpanStart l+ (sl,sc) = (srcLocLine sta,srcLocCol sta)+ -- We extract the file name to be able to normalise it+ f = fsLit $ normalise $ unpackFS $ srcLocFile sta+ s = mkRealSrcLoc f sl sc+ e = mkRealSrcLoc f sl (sc + len)+ in [mkRealSrcSpan s e]+ extractNameSpanFromLMatch _ _ = []++ in concatMap (extractNameSpanFromLMatch funNameLen) lmatches+realSrcSpansOfBinding _ _ = []
+ Language/Haskell/HBB/SmartInline.hs view
@@ -0,0 +1,88 @@+{-# OPTIONS -Wall #-}++module Language.Haskell.HBB.SmartInline (+ smartinline,+ smartinlineM,+ showSmartInlineResult,+ showSmartInlineResultAsByteString,+ BufLoc(..),+ BufSpan(..),+ RealSrcSpan(..),+ TTree(..),+ LineBuf,+ encodeTTreeToJSON+ ) where++import Language.Haskell.HBB.Internal.InternalTTreeCreation+import Language.Haskell.HBB.Internal.InternalTTree+import Language.Haskell.HBB.Internal.GHCHighlevel+import Language.Haskell.HBB.Internal.TTreeJSON (encodeTTreeToJSON)+import Language.Haskell.HBB.Internal.SrcSpan+import Language.Haskell.HBB.Internal.TTree+import Language.Haskell.HBB.Internal.GHC+import qualified Data.ByteString.Lazy.Char8 as BL+import qualified Data.ByteString.Char8 as B+import Control.Monad.Reader+import GHC.Paths (libdir)+import SrcLoc+import GHC (GhcMonad)++-- | This function implements the mode 'smart-inline'.+--+-- Smart-inline takes a location or a span within a file which should be a+-- function binding (as of 2014-09-16 excluding any parameter) and tries to+-- produce an inlined version of the function. The inlined version of the+-- function is described as transformation to the original source code. The+-- transformation is a JSON string which is formatted according to the+-- descriptions in the documentation.+--+-- > main :: IO ()+-- > main = do+-- > res <- smartinline ["-isrc"] "example/Example.hs" 14 13+-- > LazyByteString.putStr $ encodeTTreeToJSON res+-- > putStrLn ""+--+-- If a second location isn't passed this function will use GHCs lexer to find+-- out where the end of the variable or function name is. Consequently to+-- smart-inline a function and to simultaneously apply it to its arguments+-- (which is not supported as of 2014-09-16) the second location must be+-- passed.+--+-- The first two command line parameters are:+--+-- - The GHC options as string list (as they should appear on the command line)+--+-- - Some options to the mode 'inline' that change the functions behaviour+--+smartinline :: [String] -> FilePath -> BufLoc -> Maybe BufLoc -> IO (RealSrcSpan,TTree LineBuf (RealSrcSpan,Int) BufSpan)+smartinline ghcOptions fn sl mbEndLoc = + runGhcWithCmdLineFlags ghcOptions (Just libdir) $ smartinlineM fn sl mbEndLoc++-- | Converts the result of smartinline and smartinlineM to JSON.+--+-- The resulting string has exactly the format that should be understood by+-- text editors that are using mode smart-inline.+showSmartInlineResult :: (RealSrcSpan,TTree LineBuf (RealSrcSpan,Int) BufSpan) -> String+showSmartInlineResult spanAndTree =+ B.unpack $ B.concat $ BL.toChunks $ showSmartInlineResultAsByteString spanAndTree++-- | This function is a performance optimization to showSmartInlineResult as+-- the resulting bytestring isn't converted back to string.+showSmartInlineResultAsByteString :: (RealSrcSpan,TTree LineBuf (RealSrcSpan,Int) BufSpan) -> BL.ByteString+showSmartInlineResultAsByteString spanAndTree =+ BL.snoc (encodeTTreeToJSON spanAndTree) '\n'++-- | This function is similar to smartinline except that it runs in a GhcMonad+-- instance.+smartinlineM :: GhcMonad m => FilePath -> BufLoc -> Maybe BufLoc -> m (RealSrcSpan,TTree LineBuf (RealSrcSpan,Int) BufSpan)+smartinlineM filename startLoc mbEndLoc = do++ sti@(SearchedTokenInfo { result = (binding,_) }) <- searchFunctionBindingM filename startLoc mbEndLoc++ let produceClientTTree :: FunBindInfo -> ClientTTree+ produceClientTTree bi =+ let richTTree = runReader (toTTree $ binding) ProduceLambda+ inlCol = ((srcLocCol $ realSrcSpanStart $ occSpan bi))+ in snd $ applyIndentation (IncInline (pointBufSpan 1 inlCol),richTTree)++ return (occSpan sti,produceClientTTree sti)
+ README.md view
@@ -0,0 +1,16 @@+# **hbb**: Extraordinary Haskell programming++This project aims to create a tool which should be easily embeddable in text+editors to assist them to provide extraordinary editing features for the+Haskell programming language. To archieve this, the tool is based on the+library of the Glasgow Haskell Compiler (GHC).++The name **hbb** is short for *h*askell *b*usy *b*ee and should remind one of+the programmers using it. It consists of the library *hbb* and a command line+tool which has the name *hbb-simple-cli*. *hbb-simple-cli* has been chosen+because in another repository the features of (the library) *hbb* and *ghc-mod*+are merged into an executable *hbb* which provides (many more) features than+*hbb-simple-cli*.++One outstanding feature of *hbb* is is the possibility to inline a function+binding.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ editor-plugin/vim/hbb.vim view
@@ -0,0 +1,59 @@++:let g:hbb_executable_name = "hbb"++" ghc options must be written in the same way they are passed to hbb which+" means that each option must be prepended by '-g'. For example+" let g:hbb_ghc_options = '-g -isrc -g -packageghc -g -XFlexibleInstances'+:let g:hbb_ghc_options = ""++" This function inlines the currently selected function or prints an error+" message if inlining fails.+" If any argument is passed then the file is saved after inlining.+function! HBBInlineSelection( ... )+ :let curline = getline('.')+ :let startpos = getpos( "'<" )+ :let endpos = getpos( "'>" )+ :let curfile = expand('%')+ :let commandstr = g:hbb_executable_name . " " . g:hbb_ghc_options . " inline " . curfile . " " . startpos[1] . " " . startpos[2] . " " . endpos[1] . " " . (endpos[2] + 1) . " 2>./.vim-hbb.log"+ :let fun = system( commandstr )+ :let errorreason = readfile( "./.vim-hbb.log" ) + :call delete("./.vim-hbb.log")+ :if len( fun ) == 0+ :let errorreason_copy = copy( errorreason )+ :let errorreason_copy[0] = "Inlining failed: " . errorreason[0]+ :echo join( errorreason_copy , "\n" )+ :else+ :let funnamelen = endpos[2] - startpos[2] + 1++ :if startpos[2] < 2+ :let curlineprefix = ""+ :else+ :let curlineprefix = curline[0:(startpos[2]-2)]+ :endif+ :let curlinesuffix = curline[startpos[2]+funnamelen-1:]+ :let content2insertAsList = split( fun , '\n' )+ :let firstlineEnd = content2insertAsList[0]+ :let lastlineStart = content2insertAsList[-1]+ :if len( content2insertAsList ) >= 2+ " This is a multiline entry...+ :call remove( content2insertAsList , 0 )+ :call remove( content2insertAsList , len( content2insertAsList ) - 1 )+ :call insert( content2insertAsList , curlineprefix . firstlineEnd )+ :call add( content2insertAsList , lastlineStart . curlinesuffix )+ :else+ " This is a single-line entry...+ :let content2insertAsList[0] = curlineprefix . content2insertAsList[0] . curlinesuffix+ :endif+ :call setline( '.' , content2insertAsList[0] )+ :call append( line('.') , content2insertAsList[1:] )++ :if len( a:000 ) != 0+ :w+ :endif++ :endif+ :call setpos( '.' , startpos )+endfunction++":vmap i :call HBBInlineSelection()<CR>+":vmap I :call HBBInlineSelection( "with saving" )<CR>
+ libhbb.cabal view
@@ -0,0 +1,129 @@+-- Initial htt.cabal generated by cabal init. For further documentation, +-- see http://haskell.org/cabal/users-guide/+-- The name of the package.+name: libhbb++-- The package version. See the Haskell package versioning policy (PVP) +-- for standards guiding when and how versions should be incremented.+-- http://www.haskell.org/haskellwiki/Package_versioning_policy+-- PVP summary: +-+------- breaking API changes+-- | | +----- non-breaking API additions+-- | | | +--- code changes with no API change+version: 0.1.1.0++-- A short (one-line) description of the package.+synopsis: Backend for text editors to provide better Haskell editing support.++-- A longer description of the package.+description: This project contains a library that utilizes the GHC API+ to provide some special features for Haskell text editors.+ Libhbb has been designed to extend ghc-mod (which does+ similar tasks) with certain features. However libhbb is+ completely independent of ghc-mod. The connection to+ ghc-mod is established in a package called hbb. The+ features of libhbb can be used standalone by the means of+ the executable hbb-simple-cli which is sipped as well.++ The big outstanding feature that libhbb provides is the+ ability to inline functions (their body is converted to a+ lambda function and written in place of the according+ name).++-- URL for the project homepage or repository.+homepage: https://bitbucket.org/bhris/libhbb++-- The license under which the package is released.+license: LGPL-2.1++-- The file containing the license text.+license-file: LICENSE++-- The package author(s).+author: Christian Wolf++-- An email address to which users can send suggestions, bug reports, and +-- patches.+maintainer: contact@wolf-kissendorf.de++-- A copyright notice.+-- copyright: ++category: Development++build-type: Simple++-- Constraint on the version of Cabal needed to build this package.+cabal-version: >= 1.8++extra-source-files: README.md+ editor-plugin/vim/hbb.vim++source-repository head+ type: git+ location: https://bitbucket.org/bhris/libhbb.git++-- This executable is named 'hbb-simple-cli' because it is a simple command+-- line client providing the features exposed by the library. There is also +-- an executable 'hbb' in another project which integrates the features of+-- 'ghc-mod' and 'libhbb' and therefore has much more features (as well as+-- cabal integration)+executable hbb-simple-cli+ -- .hs or .lhs file containing the Main module.+ main-is: HBBSimpleCLI.hs++ --Default-Language: Haskell2010+ + HS-Source-Dirs: ./src++ -- Default-Extensions: ConstraintKinds, FlexibleContexts+ + -- Other library packages from which modules are imported.+ build-depends: base == 4.* , libhbb >= 0.1, bytestring >= 0.10++library+ exposed-modules: Language.Haskell.HBB.Internal.InternalTTreeCreation+ Language.Haskell.HBB.Internal.InternalTTree+ Language.Haskell.HBB.Internal.GHCHighlevel+ Language.Haskell.HBB.Internal.TTreeColor+ Language.Haskell.HBB.Internal.TTreeJSON+ Language.Haskell.HBB.Internal.SrcSpan+ Language.Haskell.HBB.Internal.TTree+ Language.Haskell.HBB.Internal.Lexer+ Language.Haskell.HBB.Internal.GHC+ Language.Haskell.HBB.Internal.AST+ Language.Haskell.HBB.OccurrencesOf+ Language.Haskell.HBB.SmartInline+ Language.Haskell.HBB.ExprType+ Language.Haskell.HBB.ApplyTo+ Language.Haskell.HBB.Inline+ Language.Haskell.HBB.Locate++ -- Default-Language: Haskell2010++ HS-Source-Dirs: .++ build-depends: base,+ ghc >= 7.6,+ syb >= 0.4,+ ghc-paths >= 0.1,+ mtl >= 2.1,+ text >= 1.1,+ aeson >= 0.7,+ unordered-containers >= 0.2,+ bytestring >= 0.10,+ time >= 1.4,+ process >= 1.1,+ filepath >= 1.3++Test-Suite spec+ Main-Is: Main.hs+ Hs-Source-Dirs: test+ Type: exitcode-stdio-1.0+ Build-Depends: base+ , ghc+ , hspec >= 1.7.1+ , syb+ , libhbb+ , bytestring >= 0.10.0.2+ , ghc-paths+ , mtl
+ src/HBBSimpleCLI.hs view
@@ -0,0 +1,86 @@+{-# OPTIONS -Wall #-}++module Main where++import Language.Haskell.HBB.OccurrencesOf+import Language.Haskell.HBB.SmartInline+import Language.Haskell.HBB.ExprType+import Language.Haskell.HBB.ApplyTo+import Language.Haskell.HBB.Locate+import Language.Haskell.HBB.Inline+import qualified Data.ByteString.Lazy.Char8 as LB+import System.Console.GetOpt as O+import System.Environment (getArgs)+import System.Exit (exitFailure)+import System.IO+++usageStr :: String+usageStr = unlines+ ["Usage:"+ ,"hbb-simple-cli [-g ghcOpt1 -g ghcOpt2 ...] locate <filename> <line> <column>"+ ,"hbb-simple-cli [-g ghcOpt1 -g ghcOpt2 ...] inline [--print-context|--with-color] <filename> <line> <column> [<line> <column>]"+ ,"hbb-simple-cli [-g ghcOpt1 -g ghcOpt2 ...] smart-inline <filename> <line> <column> [<line> <column>]"+ ,"hbb-simple-cli [-g ghcOpt1 -g ghcOpt2 ...] occurrences-of <filename> <line> <column> [<filename> ...]"+ ,"hbb-simple-cli [-g ghcOpt1 -g ghcOpt2 ...] exprtype <filename> <expression>"+ ,"hbb-simple-cli applyto [-q] <function of type string to string> <string>"]++data OperationMode = ModeInline InlineOptions+ | ModeSmartInline+ | ModeLocate+ +-- | This function is responsible to parse the optional parameters (called+-- options). If there is a parameter that doesn't match an option this function+-- stops and returns its accumulated result. The extraneous arguments then will+-- be the description of the file and the line.+takeOptions :: ([String],InlineOptions) -> ([String],InlineOptions)+takeOptions (("--print-context":rest),ops) = takeOptions (rest,(ops { showContext = True }))+takeOptions (("--with-color" :rest),ops) = takeOptions (rest,(ops { showAnsiColored = True }))+takeOptions x@(_,_) = x++main :: IO ()+main = do+ programArgs <- getArgs++ -- First we want to filter out the options that GHC needs+ let (ghcOptions,otherArgs) = + let optdescr :: [OptDescr String]+ optdescr = [Option ['g'] [] (ReqArg id "ghc-option") "options passed to ghc"]+ in case O.getOpt RequireOrder optdescr programArgs of+ (_,_,(_:_)) -> error "Wrong usage of ghc-specific options (every -g must be followed by a GHC option)"+ (g,o,[] ) -> (g,o)++ putApplyToResult :: (String,Maybe String) -> IO ()+ putApplyToResult (res,Just wa) = hPutStr stderr wa >> putApplyToResult (res,Nothing)+ putApplyToResult (res,Nothing) = putStr res++ case (ghcOptions,otherArgs) of+ (_ ,("occurrences-of":f:l:c:others)) -> occurrencesOf ghcOptions f (BufLoc (read l) (read c)) others >>= putStr . showOccurrencesOfResult+ (_ ,["exprtype",f,expr]) -> exprtype ghcOptions f expr >>= putStrLn . showExprTypeResult+ ([],["applyto" ,"-q",f,str ]) -> applyTo True f str >>= putApplyToResult+ ([],["applyto" , f,str ]) -> applyTo False f str >>= putApplyToResult+ (_ ,("applyto":_)) -> error "Mode 'applyto' doesn't allow to specify ghc options (with -g)"+ _ -> do+ (opMode,occFilename,loc1,maybeLoc2) <- do+ case otherArgs of+ ["locate" ,f,l,c] -> return (ModeLocate ,f,(BufLoc (read l::Int) (read c::Int)),Nothing)+ ("smart-inline":rest) -> + case rest of+ (f:sl:sc:el:ec:[]) -> return (ModeSmartInline,f,(BufLoc (read sl::Int) (read sc::Int)),+ (Just $ BufLoc (read el::Int) (read ec::Int)))+ (f:sl:sc:[]) -> return (ModeSmartInline,f,(BufLoc (read sl::Int) (read sc::Int)),Nothing)+ _ -> do putStrLn "Invalid parameters."+ putStrLn usageStr; exitFailure+ ("inline":rest) -> do+ let (locspec,options) = takeOptions (rest,defaultInlineOptions)+ case locspec of+ (f:sl:sc:el:ec:[]) -> return (ModeInline options,f,(BufLoc (read sl::Int) (read sc::Int)),+ (Just $ BufLoc (read el::Int) (read ec::Int)))+ (f:sl:sc:[]) -> return (ModeInline options,f,(BufLoc (read sl::Int) (read sc::Int)),Nothing)+ _ -> do putStrLn "Invalid parameters."+ putStrLn usageStr; exitFailure+ _ -> do putStrLn usageStr; exitFailure+ case opMode of+ ModeInline options -> inline ghcOptions options occFilename loc1 maybeLoc2 >>= putStrLn . showInlineResult+ ModeSmartInline -> smartinline ghcOptions occFilename loc1 maybeLoc2 >>= LB.putStr . showSmartInlineResultAsByteString+ ModeLocate -> locate ghcOptions occFilename loc1 >>= putStrLn . showLocateResult
+ test/Main.hs view
@@ -0,0 +1,7 @@+module Main (main) where++import Test.Hspec+import Spec++main :: IO ()+main = hspec spec