diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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 diff --git a/Language/Haskell/HBB/ApplyTo.hs b/Language/Haskell/HBB/ApplyTo.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/HBB/ApplyTo.hs @@ -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 ) + + diff --git a/Language/Haskell/HBB/ExprType.hs b/Language/Haskell/HBB/ExprType.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/HBB/ExprType.hs @@ -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) diff --git a/Language/Haskell/HBB/Inline.hs b/Language/Haskell/HBB/Inline.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/HBB/Inline.hs @@ -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) diff --git a/Language/Haskell/HBB/Internal/AST.hs b/Language/Haskell/HBB/Internal/AST.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/HBB/Internal/AST.hs @@ -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) diff --git a/Language/Haskell/HBB/Internal/GHC.hs b/Language/Haskell/HBB/Internal/GHC.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/HBB/Internal/GHC.hs @@ -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 () diff --git a/Language/Haskell/HBB/Internal/GHCHighlevel.hs b/Language/Haskell/HBB/Internal/GHCHighlevel.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/HBB/Internal/GHCHighlevel.hs @@ -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 }) diff --git a/Language/Haskell/HBB/Internal/InternalTTree.hs b/Language/Haskell/HBB/Internal/InternalTTree.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/HBB/Internal/InternalTTree.hs @@ -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_elemOffset + 1 + -- Non-First NewSection within parent: + -- + 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 diff --git a/Language/Haskell/HBB/Internal/InternalTTreeCreation.hs b/Language/Haskell/HBB/Internal/InternalTTreeCreation.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/HBB/Internal/InternalTTreeCreation.hs @@ -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 + -- (space separated). When converting to a lambda + -- function the pattern must have the form (,) + -- (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)" + + + + + diff --git a/Language/Haskell/HBB/Internal/Lexer.hs b/Language/Haskell/HBB/Internal/Lexer.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/HBB/Internal/Lexer.hs @@ -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 diff --git a/Language/Haskell/HBB/Internal/SrcSpan.hs b/Language/Haskell/HBB/Internal/SrcSpan.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/HBB/Internal/SrcSpan.hs @@ -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))) diff --git a/Language/Haskell/HBB/Internal/TTree.hs b/Language/Haskell/HBB/Internal/TTree.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/HBB/Internal/TTree.hs @@ -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) diff --git a/Language/Haskell/HBB/Internal/TTreeColor.hs b/Language/Haskell/HBB/Internal/TTreeColor.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/HBB/Internal/TTreeColor.hs @@ -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)) diff --git a/Language/Haskell/HBB/Internal/TTreeJSON.hs b/Language/Haskell/HBB/Internal/TTreeJSON.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/HBB/Internal/TTreeJSON.hs @@ -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: '-:-:'. 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 ':' +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 ':-:' +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 ':-:' +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: ',:-:' +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: ',:-:' +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 diff --git a/Language/Haskell/HBB/Locate.hs b/Language/Haskell/HBB/Locate.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/HBB/Locate.hs @@ -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) diff --git a/Language/Haskell/HBB/OccurrencesOf.hs b/Language/Haskell/HBB/OccurrencesOf.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/HBB/OccurrencesOf.hs @@ -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 _ _ = [] diff --git a/Language/Haskell/HBB/SmartInline.hs b/Language/Haskell/HBB/SmartInline.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/HBB/SmartInline.hs @@ -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) diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/editor-plugin/vim/hbb.vim b/editor-plugin/vim/hbb.vim new file mode 100644 --- /dev/null +++ b/editor-plugin/vim/hbb.vim @@ -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() +":vmap I :call HBBInlineSelection( "with saving" ) diff --git a/libhbb.cabal b/libhbb.cabal new file mode 100644 --- /dev/null +++ b/libhbb.cabal @@ -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 diff --git a/src/HBBSimpleCLI.hs b/src/HBBSimpleCLI.hs new file mode 100644 --- /dev/null +++ b/src/HBBSimpleCLI.hs @@ -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 " + ,"hbb-simple-cli [-g ghcOpt1 -g ghcOpt2 ...] inline [--print-context|--with-color] [ ]" + ,"hbb-simple-cli [-g ghcOpt1 -g ghcOpt2 ...] smart-inline [ ]" + ,"hbb-simple-cli [-g ghcOpt1 -g ghcOpt2 ...] occurrences-of [ ...]" + ,"hbb-simple-cli [-g ghcOpt1 -g ghcOpt2 ...] exprtype " + ,"hbb-simple-cli applyto [-q] "] + +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 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,7 @@ +module Main (main) where + +import Test.Hspec +import Spec + +main :: IO () +main = hspec spec