buildwrapper 0.7.1 → 0.7.2
raw patch · 12 files changed
+3799/−3493 lines, 12 filesdep +deepseq
Dependencies added: deepseq
Files
- LICENSE +32/−32
- buildwrapper.cabal +130/−130
- src-exe/Language/Haskell/BuildWrapper/CMD.hs +44/−40
- src-exe/Main.hs +17/−17
- src/Language/Haskell/BuildWrapper/Base.hs +9/−1
- src/Language/Haskell/BuildWrapper/Cabal.hs +13/−6
- src/Language/Haskell/BuildWrapper/GHC.hs +1367/−1258
- test/Language/Haskell/BuildWrapper/APITest.hs +12/−0
- test/Language/Haskell/BuildWrapper/CMDLongRunningTests.hs +205/−0
- test/Language/Haskell/BuildWrapper/CMDTests.hs +1931/−1984
- test/Language/Haskell/BuildWrapper/GHCTests.hs +13/−0
- test/Main.hs +26/−25
LICENSE view
@@ -1,32 +1,32 @@-Copyright 2011, JP Moresmau -Copyright 2008, Thiago Arrais -Copyright 2008, Thomas Schilling -Copyright 2008, Simon Marlow -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -- Redistributions of source code must retain the above copyright notice, -this list of conditions and the following disclaimer. - -- Redistributions in binary form must reproduce the above copyright notice, -this list of conditions and the following disclaimer in the documentation -and/or other materials provided with the distribution. - -- Neither name of the author nor the names of its contributors may be -used to endorse or promote products derived from this software without -specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE AUTHOR(S) AND THE CONTRIBUTORS "AS -IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A -PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE UNIVERSITY -COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE FOR -ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE -GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER -IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR -OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +Copyright 2011, JP Moresmau+Copyright 2008, Thiago Arrais+Copyright 2008, Thomas Schilling+Copyright 2008, Simon Marlow+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++- Redistributions of source code must retain the above copyright notice,+this list of conditions and the following disclaimer.+ +- Redistributions in binary form must reproduce the above copyright notice,+this list of conditions and the following disclaimer in the documentation+and/or other materials provided with the distribution.+ +- Neither name of the author nor the names of its contributors may be+used to endorse or promote products derived from this software without+specific prior written permission. ++THIS SOFTWARE IS PROVIDED BY THE AUTHOR(S) AND THE CONTRIBUTORS "AS+IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED+TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A+PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE UNIVERSITY+COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE+GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS+INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER+IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR+OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
buildwrapper.cabal view
@@ -1,130 +1,130 @@-name: buildwrapper -version: 0.7.1 -cabal-version: >= 1.8 -build-type: Simple -license: BSD3 -license-file: LICENSE -synopsis: A library and an executable that provide an easy API for a Haskell IDE -description: Buildwrapper is an alternative to scion. - It provides services to configure, build and give information on source files to help IDEs manage Haskell projects. - You can use buildwrapper to build project and retrieve errors, get outline for each module source, get the type of something inside a source file, get lexer tokens, etc. - Buildwrapper is used in the EclipseFP project (Eclipse plugins for Haskell development) -category: Development -stability: beta -maintainer: JP Moresmau <jpmoresmau@gmail.com> -author: JP Moresmau <jpmoresmau@gmail.com>, based on the work of Thomas Schilling and others -homepage: https://github.com/JPMoresmau/BuildWrapper -extra-source-files: README.md - -library - hs-source-dirs: src - build-depends: - base < 5, - filepath, - mtl, - directory, - Cabal, - process, - regex-tdfa, - ghc, - ghc-paths, - syb, - -- ghc-syb-utils, - text, - containers, - vector >= 0.8, - haskell-src-exts, - cpphs, - old-time, - aeson >=0.4, - unordered-containers, - utf8-string, - bytestring, - attoparsec, - transformers - ghc-options: -Wall -fno-warn-unused-do-bind - exposed-modules: - Language.Haskell.BuildWrapper.API, - Language.Haskell.BuildWrapper.Base, - Language.Haskell.BuildWrapper.Cabal, - Language.Haskell.BuildWrapper.GHC - extensions: CPP - other-modules: - Language.Haskell.BuildWrapper.GHCStorage, - Language.Haskell.BuildWrapper.Packages, - Language.Haskell.BuildWrapper.Src - if impl(ghc >= 7.6) - build-depends: - time - - -executable buildwrapper - hs-source-dirs: src-exe - main-is: Main.hs - build-depends: - base < 5, - buildwrapper, - cmdargs, - filepath, - Cabal, - directory, - mtl, - ghc, - cpphs, - haskell-src-exts, - old-time, - -- ghc-syb-utils, - ghc-paths, - vector >= 0.8, - containers, - syb, - process, - regex-tdfa, - text, - aeson >=0.4, - bytestring, - transformers - ghc-options: -Wall -fno-warn-unused-do-bind -optl -s - other-modules: Language.Haskell.BuildWrapper.CMD - if impl(ghc >= 7.6) - build-depends: - time - -test-suite buildwrapper-test - type: exitcode-stdio-1.0 - hs-source-dirs: test - build-depends: - base < 5, - buildwrapper, - HUnit, - mtl, - filepath, - directory, - Cabal, - old-time, - aeson >=0.4, - text, - process, - bytestring, - attoparsec, - HTF > 0.9, - transformers, - vector, - unordered-containers, - containers - main-is: Main.hs - ghc-options: -Wall -fno-warn-unused-do-bind -optl -s - other-modules: - Language.Haskell.BuildWrapper.APITest, - Language.Haskell.BuildWrapper.CMDTests, - Language.Haskell.BuildWrapper.GHCTests, - Language.Haskell.BuildWrapper.UsagesTests, - Language.Haskell.BuildWrapper.ImportsTests, - Language.Haskell.BuildWrapper.CabalDevTests - if impl(ghc >= 7.6) - build-depends: - time - -source-repository head - type: git - location: git://github.com/JPMoresmau/BuildWrapper.git +name: buildwrapper+version: 0.7.2+cabal-version: >= 1.8+build-type: Simple+license: BSD3+license-file: LICENSE+synopsis: A library and an executable that provide an easy API for a Haskell IDE+description: Buildwrapper is an alternative to scion. + It provides services to configure, build and give information on source files to help IDEs manage Haskell projects.+ You can use buildwrapper to build project and retrieve errors, get outline for each module source, get the type of something inside a source file, get lexer tokens, etc.+ Buildwrapper is used in the EclipseFP project (Eclipse plugins for Haskell development)+category: Development+stability: beta+maintainer: JP Moresmau <jpmoresmau@gmail.com>+author: JP Moresmau <jpmoresmau@gmail.com>, based on the work of Thomas Schilling and others+homepage: https://github.com/JPMoresmau/BuildWrapper+extra-source-files: README.md++library+ hs-source-dirs: src+ build-depends: + base < 5,+ filepath,+ mtl,+ directory,+ Cabal,+ process,+ regex-tdfa,+ ghc,+ ghc-paths,+ syb,+ text,+ containers,+ vector >= 0.8,+ haskell-src-exts,+ cpphs,+ old-time,+ aeson >=0.4,+ unordered-containers,+ utf8-string,+ bytestring,+ attoparsec,+ transformers,+ deepseq+ ghc-options: -Wall -fno-warn-unused-do-bind+ exposed-modules: + Language.Haskell.BuildWrapper.API,+ Language.Haskell.BuildWrapper.Base,+ Language.Haskell.BuildWrapper.Cabal,+ Language.Haskell.BuildWrapper.GHC+ extensions: CPP+ other-modules: + Language.Haskell.BuildWrapper.GHCStorage,+ Language.Haskell.BuildWrapper.Packages,+ Language.Haskell.BuildWrapper.Src+ if impl(ghc >= 7.6)+ build-depends: + time+++executable buildwrapper+ hs-source-dirs: src-exe+ main-is: Main.hs+ build-depends: + base < 5,+ buildwrapper,+ cmdargs,+ filepath,+ Cabal,+ directory,+ mtl,+ ghc,+ cpphs,+ haskell-src-exts,+ old-time,+ ghc-paths,+ vector >= 0.8,+ containers,+ syb,+ process,+ regex-tdfa,+ text,+ aeson >=0.4,+ bytestring,+ transformers+ ghc-options: -Wall -fno-warn-unused-do-bind -optl -s+ other-modules: Language.Haskell.BuildWrapper.CMD+ if impl(ghc >= 7.6)+ build-depends: + time++test-suite buildwrapper-test+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ build-depends: + base < 5,+ buildwrapper,+ HUnit,+ mtl,+ filepath,+ directory,+ Cabal,+ old-time,+ aeson >=0.4,+ text,+ process,+ bytestring,+ attoparsec,+ HTF > 0.9,+ transformers,+ vector,+ unordered-containers,+ containers+ main-is: Main.hs+ ghc-options: -Wall -fno-warn-unused-do-bind -optl -s+ other-modules: + Language.Haskell.BuildWrapper.APITest,+ Language.Haskell.BuildWrapper.CMDTests,+ Language.Haskell.BuildWrapper.GHCTests,+ Language.Haskell.BuildWrapper.UsagesTests,+ Language.Haskell.BuildWrapper.ImportsTests,+ Language.Haskell.BuildWrapper.CabalDevTests,+ Language.Haskell.BuildWrapper.CMDLongRunningTests+ if impl(ghc >= 7.6)+ build-depends: + time++source-repository head+ type: git+ location: git://github.com/JPMoresmau/BuildWrapper.git
src-exe/Language/Haskell/BuildWrapper/CMD.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveDataTypeable,OverloadedStrings #-} +{-# LANGUAGE DeriveDataTypeable,OverloadedStrings, NamedFieldPuns #-} -- | -- Module : Language.Haskell.BuildWrapper.CMD -- Author : JP Moresmau @@ -24,6 +24,7 @@ import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Lazy.Char8 as BSC import Data.Version (showVersion)+import Control.Exception.Base (catch, IOException) type CabalFile = FilePath @@ -31,24 +32,24 @@ type TempFolder = FilePath -- | all the different actions and their parameters -data BWCmd=Synchronize {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, cabalOption::[String], force::Bool} - | Synchronize1 {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, cabalOption::[String], force::Bool, file:: FilePath} - | Write {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, cabalOption::[String], file:: FilePath, contents::String} - | Configure {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, cabalOption::[String], verbosity::Verbosity,cabalTarget::WhichCabal} - | Build {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, cabalOption::[String], verbosity::Verbosity,output::Bool,cabalTarget::WhichCabal} - | Build1 {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, cabalOption::[String], file:: FilePath, component:: Maybe String, longRunning :: Bool} - | Outline {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, cabalOption::[String], file:: FilePath, component:: Maybe String} - | TokenTypes {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, cabalOption::[String], file:: FilePath, component:: Maybe String} - | Occurrences {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, cabalOption::[String], file:: FilePath,token::String, component:: Maybe String} - | ThingAtPointCmd {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, cabalOption::[String], file:: FilePath, line::Int, column::Int, component:: Maybe String} - | Locals {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, cabalOption::[String], file:: FilePath, sline::Int, scolumn::Int,eline::Int, ecolumn::Int, component:: Maybe String} - | NamesInScope {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, cabalOption::[String], file:: FilePath, component:: Maybe String} - | Dependencies {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, cabalOption::[String], sandbox::FilePath} - | Components {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, cabalOption::[String]} - | GetBuildFlags {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, cabalOption::[String], file:: FilePath, component:: Maybe String} - | GenerateUsage {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, cabalOption::[String], returnAll:: Bool, cabalComponent::String} - | CleanImports {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, cabalOption::[String], file:: FilePath, format :: Bool, component:: Maybe String} - | Clean {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, cabalOption::[String], everything:: Bool} +data BWCmd=Synchronize {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, cabalOption::[String], force::Bool, logCabal::Bool} + | Synchronize1 {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, cabalOption::[String], force::Bool, file:: FilePath, logCabal::Bool} + | Write {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, cabalOption::[String], file:: FilePath, contents::String, logCabal::Bool} + | Configure {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, cabalOption::[String], verbosity::Verbosity,cabalTarget::WhichCabal, logCabal::Bool} + | Build {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, cabalOption::[String], verbosity::Verbosity,output::Bool,cabalTarget::WhichCabal, logCabal::Bool} + | Build1 {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, cabalOption::[String], file:: FilePath, component:: Maybe String, longRunning :: Bool, logCabal::Bool} + | Outline {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, cabalOption::[String], file:: FilePath, component:: Maybe String, logCabal::Bool} + | TokenTypes {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, cabalOption::[String], file:: FilePath, component:: Maybe String, logCabal::Bool} + | Occurrences {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, cabalOption::[String], file:: FilePath,token::String, component:: Maybe String, logCabal::Bool} + | ThingAtPointCmd {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, cabalOption::[String], file:: FilePath, line::Int, column::Int, component:: Maybe String, logCabal::Bool} + | Locals {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, cabalOption::[String], file:: FilePath, sline::Int, scolumn::Int,eline::Int, ecolumn::Int, component:: Maybe String, logCabal::Bool} + | NamesInScope {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, cabalOption::[String], file:: FilePath, component:: Maybe String, logCabal::Bool} + | Dependencies {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, cabalOption::[String], sandbox::FilePath, logCabal::Bool} + | Components {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, cabalOption::[String], logCabal::Bool} + | GetBuildFlags {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, cabalOption::[String], file:: FilePath, component:: Maybe String, logCabal::Bool} + | GenerateUsage {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, cabalOption::[String], returnAll:: Bool, cabalComponent::String, logCabal::Bool} + | CleanImports {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, cabalOption::[String], file:: FilePath, format :: Bool, component:: Maybe String, logCabal::Bool} + | Clean {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, cabalOption::[String], everything:: Bool, logCabal::Bool} deriving (Show,Read,Data,Typeable) @@ -69,6 +70,9 @@ co :: [String] co=def &= help "cabal extra parameters" +lc :: Bool +lc=def &= help "log calls to cabal?" + formatF :: Bool formatF=def &= help "format imports" @@ -90,47 +94,47 @@ ra=def &= help "return all source paths" msynchronize :: BWCmd -msynchronize = Synchronize tf cp cf uf co ff +msynchronize = Synchronize tf cp cf uf co ff lc msynchronize1 :: BWCmd -msynchronize1 = Synchronize1 tf cp cf uf co ff fp +msynchronize1 = Synchronize1 tf cp cf uf co ff fp lc mconfigure :: BWCmd -mconfigure = Configure tf cp cf uf co v wc +mconfigure = Configure tf cp cf uf co v wc lc mwrite :: BWCmd -mwrite= Write tf cp cf uf co fp (def &= help "file contents") +mwrite= Write tf cp cf uf co fp (def &= help "file contents") lc mbuild :: BWCmd -mbuild = Build tf cp cf uf co v (def &= help "output compilation and linking result") wc +mbuild = Build tf cp cf uf co v (def &= help "output compilation and linking result") wc lc mbuild1 :: BWCmd -mbuild1 = Build1 tf cp cf uf co fp mcc longRunningF +mbuild1 = Build1 tf cp cf uf co fp mcc longRunningF lc mgetbf :: BWCmd -mgetbf = GetBuildFlags tf cp cf uf co fp mcc +mgetbf = GetBuildFlags tf cp cf uf co fp mcc lc mcleanimports :: BWCmd -mcleanimports = CleanImports tf cp cf uf co fp formatF mcc +mcleanimports = CleanImports tf cp cf uf co fp formatF mcc lc moutline :: BWCmd -moutline = Outline tf cp cf uf co fp mcc +moutline = Outline tf cp cf uf co fp mcc lc mtokenTypes :: BWCmd -mtokenTypes= TokenTypes tf cp cf uf co fp mcc +mtokenTypes= TokenTypes tf cp cf uf co fp mcc lc moccurrences :: BWCmd -moccurrences=Occurrences tf cp cf uf co fp (def &= help "text to search occurrences of" &= name "token") mcc +moccurrences=Occurrences tf cp cf uf co fp (def &= help "text to search occurrences of" &= name "token") mcc lc mthingAtPoint :: BWCmd mthingAtPoint=ThingAtPointCmd tf cp cf uf co fp (def &= help "line" &= name "line") - (def &= help "column" &= name "column") mcc + (def &= help "column" &= name "column") mcc lc mlocals :: BWCmd mlocals=Locals tf cp cf uf co fp (def &= help "start line" &= name "start line") (def &= help "start column" &= name "start column") (def &= help "end line" &= name "end line") - (def &= help "end column" &= name "end column") mcc + (def &= help "end column" &= name "end column") mcc lc mnamesInScope :: BWCmd -mnamesInScope=NamesInScope tf cp cf uf co fp mcc +mnamesInScope=NamesInScope tf cp cf uf co fp mcc lc mdependencies :: BWCmd -mdependencies=Dependencies tf cp cf uf co sd +mdependencies=Dependencies tf cp cf uf co sd lc mcomponents :: BWCmd -mcomponents=Components tf cp cf uf co +mcomponents=Components tf cp cf uf co lc mgenerateUsage :: BWCmd -mgenerateUsage=GenerateUsage tf cp cf uf co ra cc +mgenerateUsage=GenerateUsage tf cp cf uf co ra cc lc mclean :: BWCmd -mclean=Clean tf cp cf uf co (def &= help "delete everything or only generated files" &= name "everything") +mclean=Clean tf cp cf uf co (def &= help "delete everything or only generated files" &= name "everything") lc -- | main method for command handling cmdMain :: IO () @@ -170,8 +174,8 @@ runCmd :: (ToJSON a) => BWCmd -> StateT BuildWrapperState IO a -> IO () runCmd=runCmdV Normal runCmdV:: (ToJSON a) => Verbosity -> BWCmd -> StateT BuildWrapperState IO a -> IO () - runCmdV vb cmd f= - do { cabalFile' <- canonicalizePath $ cabalFile cmd -- canonicalize cabal-file path because Eclipse does not correctly keep track of case changes on the project path - ; resultJson <- evalStateT f (BuildWrapperState (tempFolder cmd) (cabalPath cmd) cabalFile' vb (cabalFlags cmd) (cabalOption cmd)) + runCmdV vb cmd f= + do { cabalFile' <- (canonicalizePath $ cabalFile cmd) `catch` ((\_->return $ cabalFile cmd)::(IOException -> IO String)) -- canonicalize cabal-file path because Eclipse does not correctly keep track of case changes on the project path, but for preview the file does not exist! + ; resultJson <- evalStateT f (BuildWrapperState (tempFolder cmd) (cabalPath cmd) cabalFile' vb (cabalFlags cmd) (cabalOption cmd) (logCabal cmd)) ; BSC.putStrLn . BS.append "build-wrapper-json:" . encode $ resultJson }
src-exe/Main.hs view
@@ -1,18 +1,18 @@--- | --- Module : Main --- Author : JP Moresmau --- Copyright : (c) JP Moresmau 2011 --- License : BSD3 --- --- Maintainer : jpmoresmau@gmail.com --- Stability : beta --- Portability : portable --- --- Executable entry point -module Main where - -import Language.Haskell.BuildWrapper.CMD - --- | main entry point -main::IO() +-- |+-- Module : Main+-- Author : JP Moresmau+-- Copyright : (c) JP Moresmau 2011+-- License : BSD3+-- +-- Maintainer : jpmoresmau@gmail.com+-- Stability : beta+-- Portability : portable+-- +-- Executable entry point+module Main where++import Language.Haskell.BuildWrapper.CMD++-- | main entry point+main::IO() main = cmdMain
src/Language/Haskell/BuildWrapper/Base.hs view
@@ -32,6 +32,7 @@ import System.IO.UTF8 (hPutStr,hGetContents) import System.IO (IOMode, openBinaryFile, IOMode(..), Handle, hClose) +import Control.DeepSeq (rnf) -- | State type type BuildWrapper=StateT BuildWrapperState IO @@ -44,6 +45,7 @@ ,verbosity::Verbosity -- ^ verbosity of logging ,cabalFlags::String -- ^ flags to pass cabal ,cabalOpts::[String] -- ^ extra arguments to cabal configure + ,logCabalArgs :: Bool -- ^ log call to cabal } -- | status of notes: error or warning @@ -752,7 +754,13 @@ deriving (Show,Eq) readFile :: FilePath -> IO String -readFile n = hGetContents =<< openBinaryFile n ReadMode +-- readFile n=hGetContents =<< openBinaryFile n ReadMode +readFile n = do + inFile<- openBinaryFile n ReadMode + contents <- hGetContents inFile + rnf contents `seq` hClose inFile -- force the whole file to be read, then close http://stackoverflow.com/a/297630/827593 + return contents + writeFile :: FilePath -> String -> IO () writeFile n s = withBinaryFile n WriteMode (\ h -> hPutStr h s)
src/Language/Haskell/BuildWrapper/Cabal.hs view
@@ -97,6 +97,7 @@ cf<-getCabalFile srcOrTgt cp<-gets cabalPath v<-cabalV + logC<-gets logCabalArgs copts<-gets cabalOpts let args=[ "build", @@ -108,7 +109,7 @@ else ["--ghc-option=-c"]) ++ copts liftIO $ do - -- print args + when logC (putStrLn $ showCommandForUser cp args) cd<-getCurrentDirectory setCurrentDirectory (takeDirectory cf) (ex,out,err)<-readProcessWithExitCode cp args "" @@ -146,6 +147,7 @@ v<-cabalV dist_dir<-getDistDir uf<-gets cabalFlags + logC<-gets logCabalArgs copts<-gets cabalOpts let args=[ "configure", @@ -157,7 +159,7 @@ ++ (if null uf then [] else ["--flags="++uf]) ++ copts liftIO $ do - -- print args + when logC (putStrLn $ showCommandForUser cp args) cd<-getCurrentDirectory setCurrentDirectory (takeDirectory cf) (ex,_,err)<-readProcessWithExitCode cp args "" @@ -170,7 +172,7 @@ lbi<-DSC.getPersistBuildConfig dist_dir return (Just lbi,msgs) ExitFailure ec -> if null msgs - then return (Nothing,[BWNote BWError ("Cabal configure returned error code " ++ show ec) (mkEmptySpan cf 0 1)]) + then return (Nothing,[BWNote BWError ("Cabal configure returned error code " ++ show ec) (mkEmptySpan cf 1 1)]) else return (Nothing, msgs) setCurrentDirectory cd return ret @@ -261,6 +263,11 @@ -> FilePath setupExe cabalExe=addExtension "setup" $ takeExtension cabalExe +fromCabalDevExe :: FilePath -- ^ path to cabal executable + -> FilePath +fromCabalDevExe cabalExe | "cabal-dev"<-dropExtension cabalExe=addExtension "cabal" $ takeExtension cabalExe +fromCabalDevExe cabalExe=cabalExe + dropPrefixes :: [String] -> String -> Maybe String dropPrefixes prfxs s2=foldr (stripPrefixIfNeeded s2) Nothing prfxs @@ -277,7 +284,7 @@ -> String -- ^ line -> Maybe (BWNote,[String]) cabalErrorLine cf cabalExe l - | Just s4 <- dropPrefixes [cabalExe,setupExe cabalExe] l= + | Just s4 <- dropPrefixes [cabalExe,setupExe cabalExe,fromCabalDevExe cabalExe] l= let s2=dropWhile isSpace $ drop 1 s4 -- drop 1 for ":" that follows file name in if "At least the following" `isPrefixOf` s2 @@ -646,7 +653,7 @@ mns=map display (ems++hms) in getDep m xs ((fp,CabalPackage (display $ pkgName i) (display $ pkgVersion i) e cps mns): acc) -- build CabalPackage structure splitMatching pkgId comp deps (s,m)=let - (ds,deps2)=partition (\(Dependency n v)->(pkgName pkgId == n) && withinRange (pkgVersion pkgId) v) deps + (ds,_)=partition (\(Dependency n v)->(pkgName pkgId == n) && withinRange (pkgVersion pkgId) v) deps s'=if null ds then s else DS.insert comp s @@ -670,7 +677,7 @@ mExe=DM.fromList $ map (\e->((cabalComponentFromExecutable e),(PD.targetBuildDepends $ PD.buildInfo e))) (PD.executables pd) mTs=DM.fromList $ map (\ts->((cabalComponentFromTestSuite ts),(PD.targetBuildDepends $ PD.testBuildInfo ts))) (PD.testSuites pd) in DM.unionWith (++) mTs $ DM.unionWith (++) mLib mExe - where mapDep cc bi=DM.fromList $ map (\x->(cc)) (PD.targetBuildDepends bi) + -- where mapDep cc bi=DM.fromList $ map (\x->(cc)) (PD.targetBuildDepends bi)
src/Language/Haskell/BuildWrapper/GHC.hs view
@@ -1,1259 +1,1368 @@-{-# LANGUAGE CPP, OverloadedStrings, TypeSynonymInstances,StandaloneDeriving,DeriveDataTypeable,ScopedTypeVariables, MultiParamTypeClasses, PatternGuards, NamedFieldPuns #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} --- | --- Module : Language.Haskell.BuildWrapper.GHC --- Author : JP Moresmau --- Copyright : (c) JP Moresmau 2011 --- License : BSD3 --- --- Maintainer : jpmoresmau@gmail.com --- Stability : beta --- Portability : portable --- --- Load relevant module in the GHC AST and get GHC messages and thing at point info. Also use the GHC lexer for syntax highlighting. -module Language.Haskell.BuildWrapper.GHC where -import Language.Haskell.BuildWrapper.Base hiding (Target,ImportExportType(..)) -import Language.Haskell.BuildWrapper.GHCStorage - -import Data.Char -import Data.Generics hiding (Fixity, typeOf) -import Data.Maybe -import Data.Monoid -import Data.Aeson - -import Data.IORef -import qualified Data.List as List -import Data.Ord (comparing) -import qualified Data.Text as T -import qualified Data.Map as DM -import qualified Data.Set as DS -import qualified Data.HashMap.Lazy as HM - -import qualified Data.ByteString.Lazy as BS -import qualified Data.ByteString.Lazy.Char8 as BSC - -import DynFlags -#if __GLASGOW_HASKELL__ > 704 -import ErrUtils ( ErrMsg(..), WarnMsg, mkPlainErrMsg,Messages,ErrorMessages,WarningMessages,MsgDoc) -#else -import ErrUtils ( ErrMsg(..), WarnMsg, mkPlainErrMsg,Messages,ErrorMessages,WarningMessages,Message) -#endif -import GHC -import GHC.Paths ( libdir ) -import HscTypes ( srcErrorMessages, SourceError, GhcApiError) -import Outputable -import FastString (FastString,unpackFS,concatFS,fsLit,mkFastString, lengthFS) -import Lexer hiding (loc) -import Bag - -#if __GLASGOW_HASKELL__ >= 702 -import SrcLoc -#endif - -#if __GLASGOW_HASKELL__ >= 610 -import StringBuffer -#endif - -import System.FilePath - -import qualified MonadUtils as GMU -import Name (isTyVarName,isDataConName,isVarName,isTyConName) -import Var (varType) -import PprTyThing (pprTypeForUser) -import Control.Monad (when, liftM, unless) -import qualified Data.Vector as V (foldr) -import Module (moduleNameFS) --- import System.Time (getClockTime, diffClockTimes, timeDiffToString) -import System.IO (hFlush, stdout) -import System.Directory (getModificationTime) -#if __GLASGOW_HASKELL__ < 706 -import System.Time (ClockTime(TOD)) -#else -import Data.Time.Clock (UTCTime(UTCTime)) -import Data.Time.Calendar (Day(ModifiedJulianDay)) -#endif - - -type GHCApplyFunction a=FilePath -> TypecheckedModule -> Ghc a - --- | get the GHC typechecked AST -getAST :: FilePath -- ^ the source file - -> FilePath -- ^ the base directory - -> String -- ^ the module name - -> [String] -- ^ the GHC options - -> IO (OpResult (Maybe TypecheckedSource)) -getAST fp base_dir modul opts=do - (a,n)<-withASTNotes (\_ -> return . tm_typechecked_source) id base_dir (SingleFile fp modul) opts - return (listToMaybe a,n) - --- | perform an action on the GHC Typechecked module -withAST :: (TypecheckedModule -> Ghc a) -- ^ the action - -> FilePath -- ^ the source file - -> FilePath -- ^ the base directory - -> String -- ^ the module name - -> [String] -- ^ the GHC options - -> IO (Maybe a) -withAST f fp base_dir modul options= do - (a,_)<-withASTNotes (\_ ->f) id base_dir (SingleFile fp modul) options - return $ listToMaybe a - --- | perform an action on the GHC JSON AST -withJSONAST :: (Value -> IO a) -- ^ the action - -> FilePath -- ^ the source file - -> FilePath -- ^ the base directory - -> String -- ^ the module name - -> [String] -- ^ the GHC options - -> IO (Maybe a) -withJSONAST f fp base_dir modul options=do - mv<-readGHCInfo fp - case mv of - Just v-> fmap Just (f v) - Nothing->do - mv2<-withAST gen fp base_dir modul options - case mv2 of - Just v2->fmap Just (f v2) - Nothing-> return Nothing - where gen tc=do - df<-getSessionDynFlags - return $ generateGHCInfo df tc - --- | the main method loading the source contents into GHC -withASTNotes :: GHCApplyFunction a -- ^ the final action to perform on the result - -> (FilePath -> FilePath) -- ^ transform given file path to find bwinfo path - -> FilePath -- ^ the base directory - -> LoadContents -- ^ what to load - -> [String] -- ^ the GHC options - -> IO (OpResult [a]) -withASTNotes f ff base_dir contents options=initGHC (ghcWithASTNotes f ff base_dir contents True) options - --- do --- -- http://hackage.haskell.org/trac/ghc/ticket/7380#comment:1 : -O2 is removed from the options --- let cleaned=filter (not . List.isInfixOf "-O") options --- let lflags=map noLoc cleaned --- -- print cleaned --- (_leftovers, _) <- parseStaticFlags lflags --- runGhc (Just libdir) $ do --- flg <- getSessionDynFlags --- (flg', _, _) <- parseDynamicFlags flg _leftovers --- GHC.defaultCleanupHandler flg' $ do --- -- our options here --- -- if we use OneShot, we need the other modules to be built --- -- so we can't use hscTarget = HscNothing --- -- and it takes a while to actually generate the o and hi files for big modules --- -- if we use CompManager, it's slower for modules with lots of dependencies but we can keep hscTarget= HscNothing which makes it better for bigger modules --- -- we use target interpreted so that it works with TemplateHaskell --- setSessionDynFlags flg' {hscTarget = HscInterpreted, ghcLink = NoLink , ghcMode = CompManager} --- ghcWithASTNotes f ff base_dir contents - -initGHC :: Ghc a - -> [String] -- ^ the GHC options - -> IO a -initGHC f options= do - -- http://hackage.haskell.org/trac/ghc/ticket/7380#comment:1 : -O2 is removed from the options - let cleaned=filter (not . List.isInfixOf "-O") options - let lflags=map noLoc cleaned - -- print cleaned - (_leftovers, _) <- parseStaticFlags lflags - runGhc (Just libdir) $ do - flg <- getSessionDynFlags - (flg', _, _) <- parseDynamicFlags flg _leftovers - GHC.defaultCleanupHandler flg' $ do - -- our options here - -- if we use OneShot, we need the other modules to be built - -- so we can't use hscTarget = HscNothing - -- and it takes a while to actually generate the o and hi files for big modules - -- if we use CompManager, it's slower for modules with lots of dependencies but we can keep hscTarget= HscNothing which makes it better for bigger modules - -- we use target interpreted so that it works with TemplateHaskell - setSessionDynFlags flg' {hscTarget = HscInterpreted, ghcLink = NoLink , ghcMode = CompManager} - f - -ghcWithASTNotes :: - GHCApplyFunction a -- ^ the final action to perform on the result - -> (FilePath -> FilePath) -- ^ transform given file path to find bwinfo path - -> FilePath -- ^ the base directory - -> LoadContents -- ^ what to load - -> Bool -- ^ add the target? - -> Ghc (OpResult [a]) -ghcWithASTNotes f ff base_dir contents shouldAddTargets= do - ref <- GMU.liftIO $ newIORef [] - cflg <- getSessionDynFlags -#if __GLASGOW_HASKELL__ > 704 - setSessionDynFlags cflg {log_action = logAction ref } -#else - setSessionDynFlags cflg {log_action = logAction ref cflg } -#endif - -- $ dopt_set (flg' { ghcLink = NoLink , ghcMode = CompManager }) Opt_ForceRecomp - let fps=getLoadFiles contents - when shouldAddTargets - (mapM_ (\(fp,_)-> addTarget Target { targetId = TargetFile fp Nothing, targetAllowObjCode = False, targetContents = Nothing }) fps) - --c1<-GMU.liftIO getClockTime --- let howMuch=case contents of --- SingleFile{lmModule=m}->LoadUpTo $ mkModuleName m --- MultipleFile{}->LoadAllTargets - let howMuch=LoadAllTargets - -- GMU.liftIO $ putStrLn "Loading..." - load howMuch - `gcatch` (\(e :: SourceError) -> handle_error ref e) - -- GMU.liftIO $ putStrLn "Loaded..." - --(warns, errs) <- GMU.liftIO $ readIORef ref - --let notes = ghcMessagesToNotes base_dir (warns, errs) - notes <- GMU.liftIO $ readIORef ref - --c2<-GMU.liftIO getClockTime - --GMU.liftIO $ putStrLn ("load all targets: " ++ (timeDiffToString $ diffClockTimes c2 c1)) - -- GMU.liftIO $ print fps - a<-fmap catMaybes $ mapM (\(fp,m)->(do - modSum <- getModSummary $ mkModuleName m - fmap Just $ workOnResult f fp modSum) - `gcatch` (\(se :: SourceError) -> do - when (processError contents (show se)) (do - GMU.liftIO $ print m - GMU.liftIO $ print se - ) - return Nothing) - `gcatch` (\(ae :: GhcApiError) -> do - when (processError contents (show ae)) (do - GMU.liftIO $ print m - GMU.liftIO $ print ae - ) - return Nothing) - ) fps -#if __GLASGOW_HASKELL__ < 702 - warns <- getWarnings - df <- getSessionDynFlags - return (a,List.nub $ notes ++ reverse (ghcMessagesToNotes df base_dir (warns, emptyBag))) -#else - notes2 <- GMU.liftIO $ readIORef ref - return $ (a,List.nub $ notes2) -#endif - where - processError :: LoadContents -> String -> Bool - processError MultipleFile{} "Module not part of module graph"=False -- we ignore the error when we process several files and some we can't find - processError _ _=True - - - workOnResult :: GHCApplyFunction a -> FilePath -> ModSummary -> Ghc a - workOnResult f2 fp modSum= do - p <- parseModule modSum - t <- typecheckModule p - d <- desugarModule t -- to get warnings - l <- loadModule d - --c3<-GMU.liftIO getClockTime -#if __GLASGOW_HASKELL__ < 704 - setContext [ms_mod modSum] [] -#else -#if __GLASGOW_HASKELL__ < 706 - setContext [IIModule $ ms_mod modSum] -#else - setContext [IIModule $ moduleName $ ms_mod modSum] -#endif -#endif - let fullfp=ff fp - opts<-getSessionDynFlags - -- GMU.liftIO $ putStrLn ("writing " ++ fullfp) - GMU.liftIO $ storeGHCInfo opts fullfp (dm_typechecked_module l) - --GMU.liftIO $ putStrLn ("parse, typecheck load: " ++ (timeDiffToString $ diffClockTimes c3 c2)) - f2 fp $ dm_typechecked_module l - - add_warn_err :: GhcMonad m => IORef [BWNote] -> WarningMessages -> ErrorMessages -> m() - add_warn_err ref warns errs = do - df <- getSessionDynFlags - let notes = ghcMessagesToNotes df base_dir (warns, errs) - GMU.liftIO $ modifyIORef ref $ - \ ns -> ns ++ notes - - handle_error :: GhcMonad m => IORef [BWNote] -> SourceError -> m SuccessFlag - handle_error ref e = do - let errs = srcErrorMessages e - add_warn_err ref emptyBag errs - return Failed -#if __GLASGOW_HASKELL__ > 704 - logAction :: IORef [BWNote] -> DynFlags -> Severity -> SrcSpan -> PprStyle -> MsgDoc -> IO () -#else - logAction :: IORef [BWNote] -> DynFlags -> Severity -> SrcSpan -> PprStyle -> Message -> IO () -#endif - logAction ref df s loc style msg - | (Just status)<-bwSeverity s=do - let n=BWNote { bwnLocation = ghcSpanToBWLocation base_dir loc - , bwnStatus = status - , bwnTitle = removeBaseDir base_dir $ removeStatus status $ showSDUser (qualName style,qualModule style) df msg - } - modifyIORef ref $ \ ns -> ns ++ [n] - | otherwise=return () - - bwSeverity :: Severity -> Maybe BWNoteStatus - bwSeverity SevWarning = Just BWWarning - bwSeverity SevError = Just BWError - bwSeverity SevFatal = Just BWError - bwSeverity _ = Nothing - - --- | Convert 'GHC.Messages' to '[BWNote]'. --- --- This will mix warnings and errors, but you can split them back up --- by filtering the '[BWNote]' based on the 'bw_status'. -ghcMessagesToNotes :: DynFlags -> - FilePath -- ^ base directory - -> Messages -- ^ GHC messages - -> [BWNote] -ghcMessagesToNotes df base_dir (warns, errs) = map_bag2ms (ghcWarnMsgToNote df base_dir) warns ++ - map_bag2ms (ghcErrMsgToNote df base_dir) errs - where - map_bag2ms f = map f . Bag.bagToList - - --- | get all names in scope -getGhcNamesInScope :: FilePath -- ^ source path - -> FilePath -- ^ base directory - -> String -- ^ module name - -> [String] -- ^ build options - -> IO [String] -getGhcNamesInScope f base_dir modul options=do - names<-withAST (\_->do - --c1<-GMU.liftIO getClockTime - names<-getNamesInScope - df<-getSessionDynFlags - --c2<-GMU.liftIO getClockTime - --GMU.liftIO $ putStrLn ("getNamesInScope: " ++ (timeDiffToString $ diffClockTimes c2 c1)) - return $ map (showSDDump df . ppr ) names) f base_dir modul options - return $ fromMaybe[] names - - --- | get all names in scope, packaged in NameDefs -getGhcNameDefsInScope :: FilePath -- ^ source path - -> FilePath -- ^ base directory - -> String -- ^ module name - -> [String] -- ^ build options - -> IO (OpResult (Maybe [NameDef])) -getGhcNameDefsInScope fp base_dir modul options=do - -- c0<-getClockTime - (nns,ns)<-withASTNotes (\_ _->do - -- c1<-GMU.liftIO getClockTime - -- GMU.liftIO $ putStrLn "getGhcNameDefsInScope" - names<-getNamesInScope - df<-getSessionDynFlags - -- c2<-GMU.liftIO getClockTime - -- GMU.liftIO $ putStrLn ("getNamesInScope: " ++ (timeDiffToString $ diffClockTimes c2 c1)) - mapM (name2nd df) names) id base_dir (SingleFile fp modul) options - -- c4<-getClockTime - -- putStrLn ("getNamesInScopeAll: " ++ (timeDiffToString $ diffClockTimes c4 c0)) - return $ case nns of - (x:_)->(Just x,ns) - _->(Nothing, ns) - --- | get all names in scope, packaged in NameDefs -getGhcNameDefsInScopeLongRunning :: FilePath -- ^ source path - -> FilePath -- ^ base directory - -> String -- ^ module name - -> [String] -- ^ build options - -> IO () -getGhcNameDefsInScopeLongRunning fp base_dir modul options=do - -#if __GLASGOW_HASKELL__ < 706 - initGHC (go (TOD 0 0)) options - where - go :: - ClockTime - -> Ghc () - go t1 = do - t2<- GMU.liftIO $ getModificationTime fp - let hasLoaded=case t1 of - TOD 0 _ -> False - _ -> True -#else - initGHC (go (UTCTime (ModifiedJulianDay 0) 0)) options - where - go :: - UTCTime - -> Ghc () - go t1 = do - t2<- GMU.liftIO $ getModificationTime fp - let hasLoaded=case t1 of - UTCTime (ModifiedJulianDay 0) _ -> False - _ -> True -#endif - - (ns1,add2)<-if hasLoaded && t2==t1 then -- modification time is only precise to the second in GHC 7.6 or above, see http://hackage.haskell.org/trac/ghc/ticket/7473 - (do - removeTarget (TargetFile fp Nothing) - load LoadAllTargets - return ([],True) - ) `gcatch` (\(e :: SourceError) -> do - let errs = srcErrorMessages e - df <- getSessionDynFlags - return (ghcMessagesToNotes df base_dir (emptyBag, errs),True) - ) - else return ([],not hasLoaded) - (nns,ns)<- ghcWithASTNotes (\_ _->do - names<-getNamesInScope - df<-getSessionDynFlags - mapM (name2nd df) names) id base_dir (SingleFile fp modul) add2 - let res=case nns of - (x:_) -> (Just x,ns1 ++ ns) - _ -> (Nothing,ns1 ++ ns) - GMU.liftIO $ BSC.putStrLn $ BS.append "build-wrapper-json:" $ encode res - GMU.liftIO $ hFlush stdout - l<- GMU.liftIO getLine - unless ("q" == l) (go t2) - -name2nd :: GhcMonad m=> DynFlags -> Name -> m NameDef -name2nd df n=do - m<- getInfo n - let ty=case m of - Just (tyt,_,_)->ty2t tyt - Nothing->Nothing - return $ NameDef (T.pack $ showSDDump df $ ppr n) (name2t n) ty - where - name2t :: Name -> [OutlineDefType] - name2t n2 - | isTyVarName n2=[Type] - | isTyConName n2=[Type] - | isDataConName n2 = [Constructor] - | isVarName n2 = [Function] - | otherwise =[] - ty2t :: TyThing -> Maybe T.Text - ty2t (AnId aid)=Just $ T.pack $ showSD False df $ pprTypeForUser True $ varType aid - ty2t (ADataCon dc)=Just $ T.pack $ showSD False df $ pprTypeForUser True $ dataConUserType dc - ty2t _ = Nothing - --- | get the "thing" at a particular point (line/column) in the source --- this is using the saved JSON info if available -getThingAtPointJSON :: Int -- ^ line - -> Int -- ^ column --- -> Bool ^ do we want the result qualified by the module --- -> Bool ^ do we want the full type or just the haddock type - -> FilePath -- ^ source file path - -> FilePath -- ^ base directory - -> String -- ^ module name - -> [String] -- ^ build flags - -> IO (Maybe ThingAtPoint) -getThingAtPointJSON line col fp base_dir modul options= do - mmf<-withJSONAST (\v->do - let f=overlap line (scionColToGhcCol col) - let mf=findInJSON f v - return $ findInJSONData mf - ) fp base_dir modul options - return $ fromMaybe Nothing mmf - --- | get the "thing" at a particular point (line/column) in the source --- this is using the saved JSON info if available -getLocalsJSON ::Int -- ^ start line - -> Int -- ^ start column - -> Int -- ^ end line - -> Int -- ^ end column - -> FilePath -- ^ source file path - -> FilePath -- ^ base directory - -> String -- ^ module name - -> [String] -- ^ build flags - -> IO [ThingAtPoint] -getLocalsJSON sline scol eline ecol fp base_dir modul options= do - mmf<-withJSONAST (\v->do - let cont=contains sline (scionColToGhcCol scol) eline (scionColToGhcCol ecol) - let isVar=isGHCType "Var" - let mf=findAllInJSON (\x->cont x && isVar x) v - return $ mapMaybe (findInJSONData . Just) mf - ) fp base_dir modul options - return $ fromMaybe [] mmf - - --- | convert a GHC SrcSpan to a Span, ignoring the actual file info -ghcSpanToLocation ::GHC.SrcSpan - -> InFileSpan -ghcSpanToLocation sp - | GHC.isGoodSrcSpan sp =let - (stl,stc)=start sp - (enl,enc)=end sp - in mkFileSpan - stl - (ghcColToScionCol stc) - enl - (ghcColToScionCol enc) - | otherwise = mkFileSpan 0 0 0 0 - - --- | convert a GHC SrcSpan to a BWLocation -ghcSpanToBWLocation :: FilePath -- ^ Base directory - -> GHC.SrcSpan - -> BWLocation -ghcSpanToBWLocation baseDir sp - | GHC.isGoodSrcSpan sp = - let (stl,stc)=start sp - (enl,enc)=end sp - in BWLocation (makeRelative baseDir $ foldr f [] $ normalise $ unpackFS (sfile sp)) - stl - (ghcColToScionCol stc) - enl - (ghcColToScionCol enc) - | otherwise = mkEmptySpan "" 1 1 - where - f c (x:xs) - | c=='\\' && x=='\\'=x:xs -- WHY do we get two slashed after the drive sometimes? - | otherwise=c:x:xs - f c s=c:s -#if __GLASGOW_HASKELL__ < 702 - sfile = GHC.srcSpanFile -#else - sfile (RealSrcSpan ss)= GHC.srcSpanFile ss -#endif - --- | convert a column info from GHC to our system (1 based) -ghcColToScionCol :: Int -> Int -#if __GLASGOW_HASKELL__ < 700 -ghcColToScionCol c=c+1 -- GHC 6.x starts at 0 for columns -#else -ghcColToScionCol c=c -- GHC 7 starts at 1 for columns -#endif - --- | convert a column info from our system (1 based) to GHC -scionColToGhcCol :: Int -> Int -#if __GLASGOW_HASKELL__ < 700 -scionColToGhcCol c=c-1 -- GHC 6.x starts at 0 for columns -#else -scionColToGhcCol c=c -- GHC 7 starts at 1 for columns -#endif - --- | Get a stream of tokens generated by the GHC lexer from the current document -ghctokensArbitrary :: FilePath -- ^ The file path to the document - -> String -- ^ The document's contents - -> [String] -- ^ The options - -> IO (Either BWNote [Located Token]) -ghctokensArbitrary base_dir contents options= do -#if __GLASGOW_HASKELL__ < 702 - sb <- stringToStringBuffer contents -#else - let sb=stringToStringBuffer contents -#endif - let lflags=map noLoc options - (_leftovers, _) <- parseStaticFlags lflags - runGhc (Just libdir) $ do - flg <- getSessionDynFlags - (flg', _, _) <- parseDynamicFlags flg _leftovers - -#if __GLASGOW_HASKELL__ >= 700 - let dflags1 = List.foldl' xopt_set flg' lexerFlags -#else - let dflags1 = List.foldl' dopt_set flg' lexerFlags -#endif - let prTS = lexTokenStreamH sb lexLoc dflags1 - case prTS of - POk _ toks -> do - -- GMU.liftIO $ print $ map (show . unLoc) toks - return $ Right $ filter ofInterest toks - PFailed loc msg -> return $ Left $ ghcErrMsgToNote dflags1 base_dir $ -#if __GLASGOW_HASKELL__ < 706 - mkPlainErrMsg loc msg -#else - mkPlainErrMsg dflags1 loc msg -#endif - --- | like lexTokenStream, but keep Haddock flag -lexTokenStreamH :: StringBuffer -> RealSrcLoc -> DynFlags -> ParseResult [Located Token] -lexTokenStreamH buf loc dflags = unP go initState - where dflags' = dopt_set (dopt_set dflags Opt_KeepRawTokenStream) Opt_Haddock - initState = mkPState dflags' buf loc - go = do - ltok <- lexer return - case ltok of - L _ ITeof -> return [] - _ -> liftM (ltok:) go - - -#if __GLASGOW_HASKELL__ < 702 -lexLoc :: SrcLoc -lexLoc = mkSrcLoc (mkFastString "<interactive>") 1 (scionColToGhcCol 1) -#else -lexLoc :: RealSrcLoc -lexLoc = mkRealSrcLoc (mkFastString "<interactive>") 1 (scionColToGhcCol 1) -#endif - - -#if __GLASGOW_HASKELL__ >= 700 -lexerFlags :: [ExtensionFlag] -#else -lexerFlags :: [DynFlag] -#endif -lexerFlags = - [ Opt_ForeignFunctionInterface - , Opt_Arrows -#if __GLASGOW_HASKELL__ < 702 - , Opt_PArr -#else - , Opt_ParallelArrays -#endif - , Opt_TemplateHaskell - , Opt_QuasiQuotes - , Opt_ImplicitParams - , Opt_BangPatterns - , Opt_TypeFamilies - , Opt_MagicHash - , Opt_KindSignatures - , Opt_RecursiveDo - , Opt_UnicodeSyntax - , Opt_UnboxedTuples - , Opt_StandaloneDeriving - , Opt_TransformListComp -#if __GLASGOW_HASKELL__ < 702 - , Opt_NewQualifiedOperators -#endif -#if GHC_VERSION > 611 - , Opt_ExplicitForAll -- 6.12 - , Opt_DoRec -- 6.12 -#endif - ] - --- | Filter tokens whose span appears legitimate (start line is less than end line, start column is --- less than end column.) -ofInterest :: Located Token -> Bool -ofInterest (L loc _) = - let (sl,sc) = start loc - (el,ec) = end loc - in (sl < el) || (sc < ec) - - --- | Convert a GHC token to an interactive token (abbreviated token type) -tokenToType :: Located Token -> TokenDef -tokenToType (L sp t) = TokenDef (tokenType t) (ghcSpanToLocation sp) - --- | Generate the interactive token list used by EclipseFP for syntax highlighting -tokenTypesArbitrary :: FilePath -> String -> Bool -> [String] -> IO (Either BWNote [TokenDef]) -tokenTypesArbitrary projectRoot contents literate options = generateTokens projectRoot contents literate options convertTokens id - where - convertTokens = map tokenToType - --- | Extract occurrences based on lexing -occurrences :: FilePath -- ^ Project root or base directory for absolute path conversion - -> String -- ^ Contents to be parsed - -> T.Text -- ^ Token value to find - -> Bool -- ^ Literate source flag (True = literate, False = ordinary) - -> [String] -- ^ Options - -> IO (Either BWNote [TokenDef]) -occurrences projectRoot contents query literate options = - let - qualif = isJust $ T.find (=='.') query - -- Get the list of tokens matching the query for relevant token types - tokensMatching :: [TokenDef] -> [TokenDef] - tokensMatching = filter matchingVal - matchingVal :: TokenDef -> Bool - matchingVal (TokenDef v _)=query==v - mkToken (L sp t)=TokenDef (tokenValue qualif t) (ghcSpanToLocation sp) - in generateTokens projectRoot contents literate options (map mkToken) tokensMatching - --- | Parse the current document, generating a TokenDef list, filtered by a function -generateTokens :: FilePath -- ^ The project's root directory - -> String -- ^ The current document contents, to be parsed - -> Bool -- ^ Literate Haskell flag - -> [String] -- ^ The options - -> ([Located Token] -> [TokenDef]) -- ^ Transform function from GHC tokens to TokenDefs - -> ([TokenDef] -> a) -- ^ The TokenDef filter function - -> IO (Either BWNote a) -generateTokens projectRoot contents literate options xform filterFunc =do - let (ppTs, ppC) = preprocessSource contents literate - -- putStrLn ppC - result<- ghctokensArbitrary projectRoot ppC options - case result of - Right toks ->do - let filterResult = filterFunc $ List.sortBy (comparing tdLoc) (ppTs ++ xform toks) - return $ Right filterResult - Left n -> return $ Left n - - --- | Preprocess some source, returning the literate and Haskell source as tuple. -preprocessSource :: String -- ^ the source contents - -> Bool -- ^ is the source literate Haskell - -> ([TokenDef],String) -- ^ the preprocessor tokens and the final valid Haskell source -preprocessSource contents literate= - let - (ts1,s2)=if literate then ppSF contents ppSLit else ([],contents) - (ts2,s3)=ppSF s2 ppSCpp - in (ts1++ts2,s3) - where - ppSF contents2 p= let - linesWithCount=zip (lines contents2) [1..] - (ts,nc,_)= List.foldl' p ([],[],Start) linesWithCount - in (reverse ts, unlines $ reverse nc) - ppSCpp :: ([TokenDef],[String],PPBehavior) -> (String,Int) -> ([TokenDef],[String],PPBehavior) - ppSCpp (ts2,l2,f) (l,c) - | (Continue _)<-f = addPPToken "PP" (l,c) (ts2,l2,lineBehavior l f) - | ('#':_)<-l =addPPToken "PP" (l,c) (ts2,l2,lineBehavior l f) - | "{-# " `List.isPrefixOf` l=addPPToken "P" (l,c) (ts2,"":l2,f) - | (Indent n)<-f=(ts2,l:(replicate n (takeWhile (== ' ') l) ++ l2),Start) - | otherwise =(ts2,l:l2,Start) - ppSLit :: ([TokenDef],[String],PPBehavior) -> (String,Int) -> ([TokenDef],[String],PPBehavior) - ppSLit (ts2,l2,f) (l,c) - | "\\begin{code}" `List.isPrefixOf` l=addPPToken "DL" ("\\begin{code}",c) (ts2,"":l2,Continue 1) - | "\\end{code}" `List.isPrefixOf` l=addPPToken "DL" ("\\end{code}",c) (ts2,"":l2,Start) - | (Continue n)<-f = (ts2,l:l2,Continue (n+1)) - | ('>':lCode)<-l=(ts2, (' ':lCode ):l2,f) - | otherwise =addPPToken "DL" (l,c) (ts2,"":l2,f) - addPPToken :: T.Text -> (String,Int) -> ([TokenDef],[String],PPBehavior) -> ([TokenDef],[String],PPBehavior) - addPPToken name (l,c) (ts2,l2,f) =(TokenDef name (mkFileSpan c 1 c (length l + 1)) : ts2 ,l2,f) - lineBehavior l f - | '\\' == last l = case f of - Continue n->Continue (n+1) - _ -> Continue 1 - | otherwise = case f of - Continue n->Indent (n+1) - Indent n->Indent (n+1) - _ -> Indent 1 - -data PPBehavior=Continue Int | Indent Int | Start - deriving Eq - --- | convert a GHC error message to our note type -ghcErrMsgToNote :: DynFlags -> FilePath -> ErrMsg -> BWNote -ghcErrMsgToNote df= ghcMsgToNote df BWError - --- | convert a GHC warning message to our note type -ghcWarnMsgToNote :: DynFlags -> FilePath -> WarnMsg -> BWNote -ghcWarnMsgToNote df= ghcMsgToNote df BWWarning - --- Note that we do *not* include the extra info, since that information is --- only useful in the case where we do not show the error location directly --- in the source. -ghcMsgToNote :: DynFlags -> BWNoteStatus -> FilePath -> ErrMsg -> BWNote -ghcMsgToNote df note_kind base_dir msg = - BWNote { bwnLocation = ghcSpanToBWLocation base_dir loc - , bwnStatus = note_kind - , bwnTitle = removeBaseDir base_dir $ removeStatus note_kind $ show_msg (errMsgShortDoc msg) - } - where - loc | (s:_) <- errMsgSpans msg = s - | otherwise = GHC.noSrcSpan - unqual = errMsgContext msg - show_msg = showSDUser unqual df - --- | remove the initial status text from a message -removeStatus :: BWNoteStatus -> String -> String -removeStatus BWWarning s - | "Warning:" `List.isPrefixOf` s = List.dropWhile isSpace $ drop 8 s - | otherwise = s -removeStatus BWError s - | "Error:" `List.isPrefixOf` s = List.dropWhile isSpace $ drop 6 s - | otherwise = s - -#if CABAL_VERSION == 106 -deriving instance Typeable StringBuffer -deriving instance Data StringBuffer -#endif - --- | make unqualified token -mkUnqualTokenValue :: FastString -- ^ the name - -> T.Text -mkUnqualTokenValue = T.pack . unpackFS - --- | make qualified token: join the qualifier and the name by a dot -mkQualifiedTokenValue :: FastString -- ^ the qualifier - -> FastString -- ^ the name - -> T.Text -mkQualifiedTokenValue q a = (T.pack . unpackFS . concatFS) [q, dotFS, a] - --- | Make a token definition from its source location and Lexer.hs token type. ---mkTokenDef :: Located Token -> TokenDef ---mkTokenDef (L sp t) = TokenDef (mkTokenName t) (ghcSpanToLocation sp) - -mkTokenName :: Token -> T.Text -mkTokenName = T.pack . showConstr . toConstr - -deriving instance Typeable Token -deriving instance Data Token - -#if CABAL_VERSION == 106 -deriving instance Typeable StringBuffer -deriving instance Data StringBuffer -#endif - - -tokenType :: Token -> T.Text -tokenType ITas = "K" -- Haskell keywords -tokenType ITcase = "K" -tokenType ITclass = "K" -tokenType ITdata = "K" -tokenType ITdefault = "K" -tokenType ITderiving = "K" -tokenType ITdo = "K" -tokenType ITelse = "K" -tokenType IThiding = "K" -tokenType ITif = "K" -tokenType ITimport = "K" -tokenType ITin = "K" -tokenType ITinfix = "K" -tokenType ITinfixl = "K" -tokenType ITinfixr = "K" -tokenType ITinstance = "K" -tokenType ITlet = "K" -tokenType ITmodule = "K" -tokenType ITnewtype = "K" -tokenType ITof = "K" -tokenType ITqualified = "K" -tokenType ITthen = "K" -tokenType ITtype = "K" -tokenType ITwhere = "K" -tokenType ITscc = "K" -- ToDo: remove (we use {-# SCC "..." #-} now) - -tokenType ITforall = "EK" -- GHC extension keywords -tokenType ITforeign = "EK" -tokenType ITexport= "EK" -tokenType ITlabel= "EK" -tokenType ITdynamic= "EK" -tokenType ITsafe= "EK" -#if __GLASGOW_HASKELL__ < 702 -tokenType ITthreadsafe= "EK" -#endif -tokenType ITunsafe= "EK" -tokenType ITstdcallconv= "EK" -tokenType ITccallconv= "EK" -#if __GLASGOW_HASKELL__ >= 612 -tokenType ITprimcallconv= "EK" -#endif -tokenType ITmdo= "EK" -tokenType ITfamily= "EK" -tokenType ITgroup= "EK" -tokenType ITby= "EK" -tokenType ITusing= "EK" - - -- Pragmas -tokenType (ITinline_prag {})="P" -- True <=> INLINE, False <=> NOINLINE -#if __GLASGOW_HASKELL__ >= 612 && __GLASGOW_HASKELL__ < 700 -tokenType (ITinline_conlike_prag {})="P" -- same -#endif -tokenType ITspec_prag="P" -- SPECIALISE -tokenType (ITspec_inline_prag {})="P" -- SPECIALISE INLINE (or NOINLINE) -tokenType ITsource_prag="P" -tokenType ITrules_prag="P" -tokenType ITwarning_prag="P" -tokenType ITdeprecated_prag="P" -tokenType ITline_prag="P" -tokenType ITscc_prag="P" -tokenType ITgenerated_prag="P" -tokenType ITcore_prag="P" -- hdaume: core annotations -tokenType ITunpack_prag="P" -#if __GLASGOW_HASKELL__ >= 612 -tokenType ITann_prag="P" -#endif -tokenType ITclose_prag="P" -tokenType (IToptions_prag {})="P" -tokenType (ITinclude_prag {})="P" -tokenType ITlanguage_prag="P" - -tokenType ITdotdot="S" -- reserved symbols -tokenType ITcolon="S" -tokenType ITdcolon="S" -tokenType ITequal="S" -tokenType ITlam="S" -tokenType ITvbar="S" -tokenType ITlarrow="S" -tokenType ITrarrow="S" -tokenType ITat="S" -tokenType ITtilde="S" -tokenType ITdarrow="S" -tokenType ITminus="S" -tokenType ITbang="S" -tokenType ITstar="S" -tokenType ITdot="S" - -tokenType ITbiglam="ES" -- GHC-extension symbols - -tokenType ITocurly="SS" -- special symbols -tokenType ITccurly="SS" -#if __GLASGOW_HASKELL__ < 706 -tokenType ITocurlybar="SS" -- "{|", for type applications -tokenType ITccurlybar="SS" -- "|}", for type applications -#endif -tokenType ITvocurly="SS" -tokenType ITvccurly="SS" -tokenType ITobrack="SS" -tokenType ITopabrack="SS" -- [:, for parallel arrays with -XParr -tokenType ITcpabrack="SS" -- :], for parallel arrays with -XParr -tokenType ITcbrack="SS" -tokenType IToparen="SS" -tokenType ITcparen="SS" -tokenType IToubxparen="SS" -tokenType ITcubxparen="SS" -tokenType ITsemi="SS" -tokenType ITcomma="SS" -tokenType ITunderscore="SS" -tokenType ITbackquote="SS" - -tokenType (ITvarid {})="IV" -- identifiers -tokenType (ITconid {})="IC" -tokenType (ITvarsym {})="VS" -tokenType (ITconsym {})="IC" -tokenType (ITqvarid {})="IV" -tokenType (ITqconid {})="IC" -tokenType (ITqvarsym {})="VS" -tokenType (ITqconsym {})="IC" -tokenType (ITprefixqvarsym {})="VS" -tokenType (ITprefixqconsym {})="IC" - -tokenType (ITdupipvarid {})="EI" -- GHC extension: implicit param: ?x - -tokenType (ITchar {})="LC" -tokenType (ITstring {})="LS" -tokenType (ITinteger {})="LI" -tokenType (ITrational {})="LR" - -tokenType (ITprimchar {})="LC" -tokenType (ITprimstring {})="LS" -tokenType (ITprimint {})="LI" -tokenType (ITprimword {})="LW" -tokenType (ITprimfloat {})="LF" -tokenType (ITprimdouble {})="LD" - - -- Template Haskell extension tokens -tokenType ITopenExpQuote="TH" -- [| or [e| -tokenType ITopenPatQuote="TH" -- [p| -tokenType ITopenDecQuote="TH" -- [d| -tokenType ITopenTypQuote="TH" -- [t| -tokenType ITcloseQuote="TH" --tokenType ] -tokenType (ITidEscape {})="TH" -- $x -tokenType ITparenEscape="TH" -- $( -#if __GLASGOW_HASKELL__ < 704 -tokenType ITvarQuote="TH" -- ' -#endif -tokenType ITtyQuote="TH" -- '' -tokenType (ITquasiQuote {})="TH" -- [:...|...|] - - -- Arrow notation extension -tokenType ITproc="A" -tokenType ITrec="A" -tokenType IToparenbar="A" -- (| -tokenType ITcparenbar="A" --tokenType ) -tokenType ITlarrowtail="A" -- -< -tokenType ITrarrowtail="A" -- >- -tokenType ITLarrowtail="A" -- -<< -tokenType ITRarrowtail="A" -- >>- - -#if __GLASGOW_HASKELL__ <= 611 -tokenType ITdotnet="SS" -- ?? -tokenType (ITpragma _) = "SS" -- ?? -#endif - -tokenType (ITunknown {})="" -- Used when the lexer can't make sense of it -tokenType ITeof="" -- end of file token - - -- Documentation annotations -tokenType (ITdocCommentNext {})="D" -- something beginning '-- |' -tokenType (ITdocCommentPrev {})="D" -- something beginning '-- ^' -tokenType (ITdocCommentNamed {})="D" -- something beginning '-- $' -tokenType (ITdocSection {})="D" -- a section heading -tokenType (ITdocOptions {})="D" -- doc options (prune, ignore-exports, etc) -tokenType (ITdocOptionsOld {})="D" -- doc options declared "-- # ..."-style -tokenType (ITlineComment {})="C" -- comment starting by "--" -tokenType (ITblockComment {})="C" -- comment in {- -} - - -- 7.2 new token types -#if __GLASGOW_HASKELL__ >= 702 -tokenType (ITinterruptible {})="EK" -tokenType (ITvect_prag {})="P" -tokenType (ITvect_scalar_prag {})="P" -tokenType (ITnovect_prag {})="P" -#endif - - -- 7.4 new token types -#if __GLASGOW_HASKELL__ >= 704 -tokenType ITcapiconv= "EK" -tokenType ITnounpack_prag= "P" -tokenType ITtildehsh= "S" -tokenType ITsimpleQuote="SS" -#endif - --- 7.6 new token types -#if __GLASGOW_HASKELL__ >= 706 -tokenType ITctype= "P" -tokenType ITlcase= "S" -tokenType (ITqQuasiQuote {}) = "TH" -- [Qual.quoter| quote |] -#endif - -dotFS :: FastString -dotFS = fsLit "." - -tokenValue :: Bool -> Token -> T.Text -tokenValue _ t | tokenType t `elem` ["K", "EK"] = T.drop 2 $ mkTokenName t -tokenValue _ (ITvarid a) = mkUnqualTokenValue a -tokenValue _ (ITconid a) = mkUnqualTokenValue a -tokenValue _ (ITvarsym a) = mkUnqualTokenValue a -tokenValue _ (ITconsym a) = mkUnqualTokenValue a -tokenValue False (ITqvarid (_,a)) = mkUnqualTokenValue a -tokenValue True (ITqvarid (q,a)) = mkQualifiedTokenValue q a -tokenValue False(ITqconid (_,a)) = mkUnqualTokenValue a -tokenValue True (ITqconid (q,a)) = mkQualifiedTokenValue q a -tokenValue False (ITqvarsym (_,a)) = mkUnqualTokenValue a -tokenValue True (ITqvarsym (q,a)) = mkQualifiedTokenValue q a -tokenValue False (ITqconsym (_,a)) = mkUnqualTokenValue a -tokenValue True (ITqconsym (q,a)) = mkQualifiedTokenValue q a -tokenValue False (ITprefixqvarsym (_,a)) = mkUnqualTokenValue a -tokenValue True (ITprefixqvarsym (q,a)) = mkQualifiedTokenValue q a -tokenValue False (ITprefixqconsym (_,a)) = mkUnqualTokenValue a -tokenValue True (ITprefixqconsym (q,a)) = mkQualifiedTokenValue q a -tokenValue _ _= "" - -instance Monoid (Bag a) where - mempty = emptyBag - mappend = unionBags - mconcat = unionManyBags - -start, end :: SrcSpan -> (Int,Int) -#if __GLASGOW_HASKELL__ < 702 -start ss= (srcSpanStartLine ss, srcSpanStartCol ss) -end ss= (srcSpanEndLine ss, srcSpanEndCol ss) -#else -start (RealSrcSpan ss)= (srcSpanStartLine ss, srcSpanStartCol ss) -start (UnhelpfulSpan _)=error "UnhelpfulSpan in cmpOverlap start" -end (RealSrcSpan ss)= (srcSpanEndLine ss, srcSpanEndCol ss) -end (UnhelpfulSpan _)=error "UnhelpfulSpan in cmpOverlap start" -#endif - -type AliasMap=DM.Map ModuleName [ModuleName] - - -ghcImportToUsage :: T.Text -> LImportDecl Name -> ([Usage],AliasMap) -> Ghc ([Usage],AliasMap) -ghcImportToUsage myPkg (L _ imp) (ls,moduMap)=(do - let L src modu=ideclName imp - pkg<-lookupModule modu (ideclPkgQual imp) - df<-getSessionDynFlags - let tmod=T.pack $ showSD True df $ ppr modu - tpkg=T.pack $ showSD True df $ ppr $ modulePackageId pkg - nomain=if tpkg=="main" then myPkg else tpkg - subs=concatMap (ghcLIEToUsage df (Just nomain) tmod "import") $ maybe [] snd $ ideclHiding imp - moduMap2=maybe moduMap (\alias->let - mlmods=DM.lookup alias moduMap - newlmods=case mlmods of - Just lmods->modu:lmods - Nothing->[modu] - in DM.insert alias newlmods moduMap) $ ideclAs imp - usg =Usage (Just nomain) tmod "" "import" False (toJSON $ ghcSpanToLocation src) False - return (usg:subs++ls,moduMap2) - ) - `gcatch` (\(se :: SourceError) -> do - GMU.liftIO $ print se - return ([],moduMap)) - -ghcLIEToUsage :: DynFlags -> Maybe T.Text -> T.Text -> T.Text -> LIE Name -> [Usage] -ghcLIEToUsage df tpkg tmod tsection (L src (IEVar nm))=[ghcNameToUsage df tpkg tmod tsection nm src False] -ghcLIEToUsage df tpkg tmod tsection (L src (IEThingAbs nm))=[ghcNameToUsage df tpkg tmod tsection nm src True ] -ghcLIEToUsage df tpkg tmod tsection (L src (IEThingAll nm))=[ghcNameToUsage df tpkg tmod tsection nm src True] -ghcLIEToUsage df tpkg tmod tsection (L src (IEThingWith nm cons))=ghcNameToUsage df tpkg tmod tsection nm src True : - map (\ x -> ghcNameToUsage df tpkg tmod tsection x src False) cons -ghcLIEToUsage _ tpkg tmod tsection (L src (IEModuleContents _))= [Usage tpkg tmod "" tsection False (toJSON $ ghcSpanToLocation src) False] -ghcLIEToUsage _ _ _ _ _=[] - -ghcExportToUsage :: DynFlags -> T.Text -> T.Text ->AliasMap -> LIE Name -> Ghc [Usage] -ghcExportToUsage df myPkg myMod moduMap lie@(L _ name)=(do - ls<-case name of - (IEModuleContents modu)-> do - let realModus=fromMaybe [modu] (DM.lookup modu moduMap) - mapM (\modu2->do - pkg<-lookupModule modu2 Nothing - let tpkg=T.pack $ showSD True df $ ppr $ modulePackageId pkg - let tmod=T.pack $ showSD True df $ ppr modu2 - return (tpkg,tmod) - ) realModus - _ -> return [(myPkg,myMod)] - return $ concatMap (\(tpkg,tmod)->ghcLIEToUsage df (Just tpkg) tmod "export" lie) ls - ) - `gcatch` (\(se :: SourceError) -> do - GMU.liftIO $ print se - return []) - -ghcNameToUsage :: DynFlags -> Maybe T.Text -> T.Text -> T.Text -> Name -> SrcSpan -> Bool -> Usage -ghcNameToUsage df tpkg tmod tsection nm src typ=Usage tpkg tmod (T.pack $ showSD False df $ ppr nm) tsection typ (toJSON $ ghcSpanToLocation src) False - -type ImportMap=DM.Map T.Text (LImportDecl Name,[T.Text]) - -ghcImportMap :: LImportDecl Name -> Ghc ImportMap -ghcImportMap l@(L _ imp)=(do - let L _ modu=ideclName imp - let moduS=T.pack $ moduleNameString modu - --GMU.liftIO $ putStrLn $ show moduS - let mm=DM.singleton moduS (l,[]) - m<-lookupModule modu Nothing - mmi<-getModuleInfo m - df <- getSessionDynFlags - let maybeHiding=ideclHiding imp - let hidden=case maybeHiding of - Just(True,ns)->map (T.pack . showSD False df . ppr . unLoc) ns - _ ->[] - let fullM =case mmi of - Nothing -> mm - Just mi->let - exps=modInfoExports mi - -- extExps=filter (\x->(nameModule x) /= m) exps - in foldr insertImport mm exps - where insertImport :: Name -> ImportMap -> ImportMap - insertImport x mmx= - let - expM=T.pack $ moduleNameString $ moduleName $ nameModule x - nT=T.pack $ showSD False df $ ppr x - in if nT `elem` hidden - then mmx - else DM.insertWith (\(_,xs1) (_,xs2)->(l,xs1++xs2)) expM (l,[nT]) mmx - return $ if ideclImplicit imp - then DM.insert "" (l,(concatMap snd $ DM.elems fullM)) fullM - else fullM - ) - `gcatch` (\(se :: SourceError) -> do - GMU.liftIO $ print se - return DM.empty) - ---getGHCOutline :: ParsedSource --- -> [OutlineDef] ---getGHCOutline (L src mod)=concatMap ldeclOutline (hsmodDecls mod) --- where --- ldeclOutline :: LHsDecl RdrName -> [OutlineDef] --- ldeclOutline (L src1 (TyClD decl))=ltypeOutline decl --- ldeclOutline _ = [] --- ltypeOutline :: TyClDecl RdrName -> [OutlineDef] --- ltypeOutline (TyFamily{tcdLName})=[mkOutlineDef (nameDecl $ unLoc tcdLName) [Type,Family] (ghcSpanToLocation $ getLoc tcdLName)] --- ltypeOutline (TyData{tcdLName,tcdCons})=[mkOutlineDef (nameDecl $ unLoc tcdLName) [Data] (ghcSpanToLocation $ getLoc tcdLName)] --- ++ concatMap lconOutline tcdCons --- lconOutline :: LConDecl RdrName -> [OutlineDef] --- lconOutline (L src ConDecl{con_name,con_doc,con_details})=[(mkOutlineDef (nameDecl $ unLoc con_name) [Constructor] (ghcSpanToLocation $ getLoc con_name)){od_comment=commentDecl con_doc}] --- ++ detailOutline con_details --- detailOutline (RecCon fields)=concatMap lfieldOutline fields --- detailOutline _=[] --- lfieldOutline (ConDeclField{cd_fld_name,cd_fld_doc})=[(mkOutlineDef (nameDecl $ unLoc cd_fld_name) [Function] (ghcSpanToLocation $ getLoc cd_fld_name)){od_comment=commentDecl cd_fld_doc}] --- nameDecl:: RdrName -> T.Text --- nameDecl (Unqual occ)=T.pack $ showSDoc $ ppr occ --- nameDecl (Qual _ occ)=T.pack $ showSDoc $ ppr occ --- commentDecl :: Maybe LHsDocString -> Maybe T.Text --- commentDecl (Just st)=Just $ T.pack $ showSDoc $ ppr st --- commentDecl _=Nothing - -- ghcSpanToLocation - --- | module, function/type, constructors -type TypeMap=DM.Map T.Text (DM.Map T.Text (DS.Set T.Text)) -type FinalImportValue=(LImportDecl Name,DM.Map T.Text (DS.Set T.Text)) -type FinalImportMap=DM.Map T.Text FinalImportValue - - --- | clean imports -ghcCleanImports :: FilePath -- ^ source path - -> FilePath -- ^ base directory - -> String -- ^ module name - -> [String] -- ^ build options - -> Bool -- ^ format? - -> IO (OpResult [ImportClean]) -ghcCleanImports f base_dir modul options doFormat = do - (m,bwns)<-withASTNotes clean (base_dir </>) base_dir (SingleFile f modul) options - return (if null m then [] else head m,bwns) - where - -- | main clean method: get the usage, the existing imports, and retrieve only the needed names for each import - clean :: GHCApplyFunction [ImportClean] - clean _ tm=do - let (_,imps,_,_)=fromJust $ tm_renamed_source tm - df <- getSessionDynFlags - let modu=T.pack $ showSD True df $ ppr $ moduleName $ ms_mod $ pm_mod_summary $ tm_parsed_module tm - let (Array vs)= generateGHCInfo df tm - impMaps<-mapM ghcImportMap imps - -- let impMap=DM.unions impMaps - let implicit=DS.fromList $ concatMap (maybe [] snd . (DM.lookup "")) impMaps - let allImps=concatMap DM.assocs impMaps - -- GMU.liftIO $ putStrLn $ show $ map (\(n,(_,ns))->(n,ns)) allImps - -- GMU.liftIO $ print implicit - let usgMap=V.foldr ghcValToUsgMap DM.empty vs - let usgMapWithoutMe=DM.delete modu usgMap - -- GMU.liftIO $ print usgMapWithoutMe - -- GMU.liftIO $ putStrLn $ show $ usgMapWithoutMe - --let ics=foldr (buildImportClean usgMapWithoutMe df) [] (DM.assocs impMap) - let ftm=foldr (buildImportCleanMap usgMapWithoutMe implicit) DM.empty allImps - - let missingCleans=getRemovedImports allImps ftm - let formatF=if doFormat then formatImports else map (dumpImportMap df) - -- GMU.liftIO $ putStrLn $ show $ DM.keys ftm - let allCleans=formatF (DM.elems ftm) ++ missingCleans - return allCleans - -- | all used names by module - ghcValToUsgMap :: Value -> TypeMap -> TypeMap - ghcValToUsgMap (Object m) um | - Just (String n)<-HM.lookup "Name" m, - Just (String mo)<-HM.lookup "Module" m, - not $ T.null mo, -- ignore local objects - mst<-HM.lookup "Type" m, - Just (String ht)<-HM.lookup "HType" m - =let - mm=DM.lookup mo um - isType=ht=="t" - isConstructor=not isType && isUpper (T.head n) && isJust mst - key=if isConstructor - then let - Just (String t)=mst - in fst $ T.breakOn " " $ T.strip $ snd $ T.breakOnEnd "->" t - else n - val=if isConstructor - then DS.singleton n - else DS.empty - in case mm of - Just usgM1->DM.insert mo (DM.insertWith DS.union key val usgM1) um - Nothing->DM.insert mo (DM.singleton key val) um - ghcValToUsgMap _ um=um - -- | reconcile the usage map and the import to generate the final import map: module -> names to import - buildImportCleanMap :: TypeMap -> DS.Set T.Text ->(T.Text,(LImportDecl Name,[T.Text])) -> FinalImportMap -> FinalImportMap - buildImportCleanMap usgMap implicit (cmod,(l@(L _ imp),ns)) tm | - Just namesMap<-DM.lookup cmod usgMap, -- used names for module - namesMapFiltered<-foldr (keepKeys namesMap) DM.empty ns, -- only names really exported by the import name - namesWithoutImplicit<-if ideclQualified imp - then namesMapFiltered - else DM.map (`DS.difference` implicit) $ foldr DM.delete namesMapFiltered $ DS.elems implicit, - not $ DM.null namesWithoutImplicit, - not $ ideclImplicit imp = let -- ignore implicit prelude - L _ modu=ideclName imp - moduS=T.pack $ moduleNameString modu - in DM.insertWith mergeTypeMap moduS (l,namesWithoutImplicit) tm - buildImportCleanMap _ _ _ tm = tm - -- | copy the key and value from one map to the other - keepKeys :: Ord k => DM.Map k v -> k -> DM.Map k v -> DM.Map k v - keepKeys m1 k m2=case DM.lookup k m1 of - Nothing -> m2 - Just v1->DM.insert k v1 m2 - -- | merge the map containing the set of names - mergeTypeMap :: FinalImportValue -> FinalImportValue -> FinalImportValue - mergeTypeMap (l1,m1) (_,m2)= (l1,DM.unionWith DS.union m1 m2) - -- | generate final import string from names map - dumpImportMap :: DynFlags -> FinalImportValue -> ImportClean - dumpImportMap df (L loc imp,ns)=let - txt= T.pack $ showSDDump df $ ppr (imp{ideclHiding=Nothing} :: ImportDecl Name) -- rely on GHC for the initial bit of the import, without the names - nameList= T.intercalate ", " $ List.sortBy (comparing T.toLower) $ map buildName $ DM.assocs ns -- build explicit import list - full=txt `mappend` " (" `mappend` nameList `mappend` ")" - in ImportClean (ghcSpanToLocation loc) full - pprName :: T.Text -> T.Text - pprName n | T.null n =n - | isAlpha $ T.head n=n - | otherwise=T.concat ["(",n,")"] - -- build the name with the constructors list if any - buildName :: (T.Text,DS.Set T.Text)->T.Text - buildName (n,cs) - | DS.null cs=pprName n - | otherwise =let - nameList= T.intercalate ", " $ List.sortBy (comparing T.toLower) $ map pprName $ DS.toList cs - in (pprName n) `mappend` " (" `mappend` nameList `mappend` ")" - getRemovedImports :: [(T.Text,(LImportDecl Name,[T.Text]))] -> FinalImportMap -> [ImportClean] - getRemovedImports allImps ftm= let - cleanedLines=DS.fromList $ map (\(L l _,_)->iflLine $ifsStart $ ghcSpanToLocation l) $ DM.elems ftm - missingImps=filter (\(_,(L l imp,_))->not $ ideclImplicit imp || DS.member (iflLine $ifsStart $ ghcSpanToLocation l) cleanedLines) allImps - in nubOrd $ map (\(_,(L l _,_))-> ImportClean (ghcSpanToLocation l) "") missingImps - getFormatInfo :: FinalImportValue -> (Int,Int,Int,Int,Int)->(Int,Int,Int,Int,Int) - getFormatInfo (L _ imp,_) (szSafe,szQualified,szPkg,szName,szAs)=let - szSafe2=if ideclSafe imp then 5 else szSafe - szQualified2=if ideclQualified imp then 10 else szQualified - szPkg2=maybe szPkg (\p->max szPkg (3 + lengthFS p)) $ ideclPkgQual imp - L _ mo=ideclName imp - szName2=max szName (1 + lengthFS (moduleNameFS mo)) - szAs2=maybe szAs (\m->max szAs (3 + lengthFS (moduleNameFS m))) $ ideclAs imp - in (szSafe2,szQualified2,szPkg2,szName2,szAs2) - formatImport :: (Int,Int,Int,Int,Int)-> FinalImportValue -> ImportClean - formatImport (szSafe,szQualified,szPkg,szName,szAs) (L loc imp,ns) =let - st="import " - saf=if ideclSafe imp then "safe " else T.justifyLeft szSafe ' ' "" - qual=if ideclQualified imp then "qualified " else T.justifyLeft szQualified ' ' "" - pkg=maybe (T.justifyLeft szPkg ' ' "") (\p->"\"" `mappend` T.pack (unpackFS p) `mappend` "\" ") $ ideclPkgQual imp - L _ mo=ideclName imp - nm=T.justifyLeft szName ' ' $ T.pack $ moduleNameString mo - ast=maybe (T.justifyLeft szAs ' ' "") (\m->"as " `mappend` T.pack (moduleNameString m)) $ ideclAs imp - nameList= T.intercalate ", " $ List.sortBy (comparing T.toLower) $ map buildName $ DM.assocs ns -- build explicit import list - full=st `mappend` saf `mappend` qual `mappend` pkg `mappend` nm `mappend` ast `mappend` " (" `mappend` nameList `mappend` ")" - in ImportClean (ghcSpanToLocation loc) full - formatImports :: [FinalImportValue] -> [ImportClean] - formatImports fivs = let - formatInfo=foldr getFormatInfo (0,0,0,0,0) fivs - in map (formatImport formatInfo) fivs - +{-# LANGUAGE CPP, OverloadedStrings, TypeSynonymInstances,StandaloneDeriving,DeriveDataTypeable,ScopedTypeVariables, MultiParamTypeClasses, PatternGuards, NamedFieldPuns #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- |+-- Module : Language.Haskell.BuildWrapper.GHC+-- Author : JP Moresmau+-- Copyright : (c) JP Moresmau 2011+-- License : BSD3+-- +-- Maintainer : jpmoresmau@gmail.com+-- Stability : beta+-- Portability : portable+-- +-- Load relevant module in the GHC AST and get GHC messages and thing at point info. Also use the GHC lexer for syntax highlighting.+module Language.Haskell.BuildWrapper.GHC where+import Language.Haskell.BuildWrapper.Base hiding (Target,ImportExportType(..))+import Language.Haskell.BuildWrapper.GHCStorage+import Language.Haskell.BuildWrapper.Src++import Prelude hiding (readFile, writeFile)+import Data.Char+import Data.Generics hiding (Fixity, typeOf, empty)+import Data.Maybe+import Data.Monoid+import Data.Aeson++import Data.IORef+import qualified Data.List as List+import Data.Ord (comparing)+import qualified Data.Text as T+import qualified Data.Map as DM+import qualified Data.Set as DS+import qualified Data.HashMap.Lazy as HM++import qualified Data.ByteString.Lazy as BS+import qualified Data.ByteString.Lazy.Char8 as BSC++import DynFlags+#if __GLASGOW_HASKELL__ > 704+import ErrUtils ( ErrMsg(..), WarnMsg, mkPlainErrMsg,Messages,ErrorMessages,WarningMessages,MsgDoc)+#else+import ErrUtils ( ErrMsg(..), WarnMsg, mkPlainErrMsg,Messages,ErrorMessages,WarningMessages,Message)+#endif+import GHC+import GHC.Paths ( libdir )+import HscTypes ( srcErrorMessages, SourceError, GhcApiError)+import Outputable+import FastString (FastString,unpackFS,concatFS,fsLit,mkFastString, lengthFS)+import Lexer hiding (loc)+import Bag++#if __GLASGOW_HASKELL__ >= 702+import SrcLoc+#endif++#if __GLASGOW_HASKELL__ >= 610+import StringBuffer+#endif++import System.FilePath++import qualified MonadUtils as GMU+import Name (isTyVarName,isDataConName,isVarName,isTyConName)+import Var (varType)+import PprTyThing (pprTypeForUser)+import Control.Monad (when, liftM, unless)+import qualified Data.Vector as V (foldr)+import Module (moduleNameFS)+-- import System.Time (getClockTime, diffClockTimes, timeDiffToString)+import System.IO (hFlush, stdout)+import System.Directory (getModificationTime)+#if __GLASGOW_HASKELL__ < 706+import System.Time (ClockTime(TOD))+import Unsafe.Coerce (unsafeCoerce)++#else+import Data.Time.Clock (UTCTime(UTCTime))+import Data.Time.Calendar (Day(ModifiedJulianDay))+#endif+import Control.Exception (SomeException)+import Debugger (showTerm)+import Exception (gtry)++type GHCApplyFunction a=FilePath -> TypecheckedModule -> Ghc a++-- | get the GHC typechecked AST+getAST :: FilePath -- ^ the source file+ -> FilePath -- ^ the base directory+ -> String -- ^ the module name + -> [String] -- ^ the GHC options + -> IO (OpResult (Maybe TypecheckedSource))+getAST fp base_dir modul opts=do+ (a,n)<-withASTNotes (\_ -> return . tm_typechecked_source) id base_dir (SingleFile fp modul) opts+ return (listToMaybe a,n) ++-- | perform an action on the GHC Typechecked module+withAST :: (TypecheckedModule -> Ghc a) -- ^ the action+ -> FilePath -- ^ the source file+ -> FilePath -- ^ the base directory+ -> String -- ^ the module name+ -> [String] -- ^ the GHC options+ -> IO (Maybe a)+withAST f fp base_dir modul options= do+ (a,_)<-withASTNotes (\_ ->f) id base_dir (SingleFile fp modul) options+ return $ listToMaybe a++-- | perform an action on the GHC JSON AST+withJSONAST :: (Value -> IO a) -- ^ the action+ -> FilePath -- ^ the source file+ -> FilePath -- ^ the base directory+ -> String -- ^ the module name + -> [String] -- ^ the GHC options+ -> IO (Maybe a)+withJSONAST f fp base_dir modul options=do+ mv<-readGHCInfo fp+ case mv of + Just v-> fmap Just (f v) + Nothing->do+ mv2<-withAST gen fp base_dir modul options+ case mv2 of+ Just v2->fmap Just (f v2) + Nothing-> return Nothing+ where gen tc=do+ df<-getSessionDynFlags+ return $ generateGHCInfo df tc ++-- | the main method loading the source contents into GHC+withASTNotes :: GHCApplyFunction a -- ^ the final action to perform on the result+ -> (FilePath -> FilePath) -- ^ transform given file path to find bwinfo path+ -> FilePath -- ^ the base directory+ -> LoadContents -- ^ what to load+ -> [String] -- ^ the GHC options + -> IO (OpResult [a])+withASTNotes f ff base_dir contents options=initGHC (ghcWithASTNotes f ff base_dir contents True) options++-- do+-- -- http://hackage.haskell.org/trac/ghc/ticket/7380#comment:1 : -O2 is removed from the options +-- let cleaned=filter (not . List.isInfixOf "-O") options+-- let lflags=map noLoc cleaned+-- -- print cleaned+-- (_leftovers, _) <- parseStaticFlags lflags+-- runGhc (Just libdir) $ do+-- flg <- getSessionDynFlags+-- (flg', _, _) <- parseDynamicFlags flg _leftovers+-- GHC.defaultCleanupHandler flg' $ do+-- -- our options here+-- -- if we use OneShot, we need the other modules to be built+-- -- so we can't use hscTarget = HscNothing+-- -- and it takes a while to actually generate the o and hi files for big modules+-- -- if we use CompManager, it's slower for modules with lots of dependencies but we can keep hscTarget= HscNothing which makes it better for bigger modules+-- -- we use target interpreted so that it works with TemplateHaskell+-- setSessionDynFlags flg' {hscTarget = HscInterpreted, ghcLink = NoLink , ghcMode = CompManager} +-- ghcWithASTNotes f ff base_dir contents+ +initGHC :: Ghc a + -> [String] -- ^ the GHC options+ -> IO a +initGHC f options= do+ -- http://hackage.haskell.org/trac/ghc/ticket/7380#comment:1 : -O2 is removed from the options + let cleaned=filter (not . List.isInfixOf "-O") options+ let lflags=map noLoc cleaned+ -- print cleaned+ (_leftovers, _) <- parseStaticFlags lflags+ runGhc (Just libdir) $ do+ flg <- getSessionDynFlags+ (flg', _, _) <- parseDynamicFlags flg _leftovers+ GHC.defaultCleanupHandler flg' $ do+ -- our options here+ -- if we use OneShot, we need the other modules to be built+ -- so we can't use hscTarget = HscNothing+ -- and it takes a while to actually generate the o and hi files for big modules+ -- if we use CompManager, it's slower for modules with lots of dependencies but we can keep hscTarget= HscNothing which makes it better for bigger modules+ -- we use target interpreted so that it works with TemplateHaskell+ setSessionDynFlags flg' {hscTarget = HscInterpreted, ghcLink = NoLink , ghcMode = CompManager} + f + +ghcWithASTNotes :: + GHCApplyFunction a -- ^ the final action to perform on the result+ -> (FilePath -> FilePath) -- ^ transform given file path to find bwinfo path+ -> FilePath -- ^ the base directory+ -> LoadContents -- ^ what to load+ -> Bool -- ^ add the target?+ -> Ghc (OpResult [a]) +ghcWithASTNotes f ff base_dir contents shouldAddTargets= do + ref <- GMU.liftIO $ newIORef []+ cflg <- getSessionDynFlags+#if __GLASGOW_HASKELL__ > 704 + setSessionDynFlags cflg {log_action = logAction ref }+#else + setSessionDynFlags cflg {log_action = logAction ref cflg }+#endif+ -- $ dopt_set (flg' { ghcLink = NoLink , ghcMode = CompManager }) Opt_ForceRecomp+ let fps=getLoadFiles contents+ when shouldAddTargets+ (mapM_ (\(fp,_)-> addTarget Target { targetId = TargetFile fp Nothing, targetAllowObjCode = False, targetContents = Nothing }) fps)+ --c1<-GMU.liftIO getClockTime+-- let howMuch=case contents of+-- SingleFile{lmModule=m}->LoadUpTo $ mkModuleName m+-- MultipleFile{}->LoadAllTargets+ let howMuch=LoadAllTargets+ -- GMU.liftIO $ putStrLn "Loading..."+ load howMuch+ `gcatch` (\(e :: SourceError) -> handle_error ref e)+ -- GMU.liftIO $ putStrLn "Loaded..." + --(warns, errs) <- GMU.liftIO $ readIORef ref+ --let notes = ghcMessagesToNotes base_dir (warns, errs)+ notes <- GMU.liftIO $ readIORef ref+ --c2<-GMU.liftIO getClockTime+ --GMU.liftIO $ putStrLn ("load all targets: " ++ (timeDiffToString $ diffClockTimes c2 c1))+ -- GMU.liftIO $ print fps+ a<-fmap catMaybes $ mapM (\(fp,m)->(do+ modSum <- getModSummary $ mkModuleName m+ fmap Just $ workOnResult f fp modSum)+ `gcatch` (\(se :: SourceError) -> do+ when (processError contents (show se)) (do+ GMU.liftIO $ print m+ GMU.liftIO $ print se + )+ return Nothing)+ `gcatch` (\(ae :: GhcApiError) -> do+ when (processError contents (show ae)) (do+ GMU.liftIO $ print m+ GMU.liftIO $ print ae + )+ return Nothing)+ ) fps+#if __GLASGOW_HASKELL__ < 702 + warns <- getWarnings+ df <- getSessionDynFlags+ return (a,List.nub $ notes ++ reverse (ghcMessagesToNotes df base_dir (warns, emptyBag)))+#else+ notes2 <- GMU.liftIO $ readIORef ref+ return $ (a,List.nub $ notes2)+#endif+ where+ processError :: LoadContents -> String -> Bool+ processError MultipleFile{} "Module not part of module graph"=False -- we ignore the error when we process several files and some we can't find+ processError _ _=True+ + + workOnResult :: GHCApplyFunction a -> FilePath -> ModSummary -> Ghc a+ workOnResult f2 fp modSum= do+ p <- parseModule modSum+ t <- typecheckModule p+ d <- desugarModule t -- to get warnings+ l <- loadModule d+ --c3<-GMU.liftIO getClockTime+#if __GLASGOW_HASKELL__ < 704+ setContext [ms_mod modSum] []+#else+#if __GLASGOW_HASKELL__ < 706+ setContext [IIModule $ ms_mod modSum]+#else+ setContext [IIModule $ moduleName $ ms_mod modSum] +#endif +#endif + let fullfp=ff fp+ opts<-getSessionDynFlags+ -- GMU.liftIO $ putStrLn ("writing " ++ fullfp)+ GMU.liftIO $ storeGHCInfo opts fullfp (dm_typechecked_module l)+ --GMU.liftIO $ putStrLn ("parse, typecheck load: " ++ (timeDiffToString $ diffClockTimes c3 c2))+ f2 fp $ dm_typechecked_module l + + add_warn_err :: GhcMonad m => IORef [BWNote] -> WarningMessages -> ErrorMessages -> m()+ add_warn_err ref warns errs = do+ df <- getSessionDynFlags+ let notes = ghcMessagesToNotes df base_dir (warns, errs)+ GMU.liftIO $ modifyIORef ref $+ \ ns -> ns ++ notes+ + handle_error :: GhcMonad m => IORef [BWNote] -> SourceError -> m SuccessFlag+ handle_error ref e = do+ let errs = srcErrorMessages e+ add_warn_err ref emptyBag errs+ return Failed+#if __GLASGOW_HASKELL__ > 704 + logAction :: IORef [BWNote] -> DynFlags -> Severity -> SrcSpan -> PprStyle -> MsgDoc -> IO ()+#else+ logAction :: IORef [BWNote] -> DynFlags -> Severity -> SrcSpan -> PprStyle -> Message -> IO ()+#endif+ logAction ref df s loc style msg+ | (Just status)<-bwSeverity s=do+ let n=BWNote { bwnLocation = ghcSpanToBWLocation base_dir loc+ , bwnStatus = status+ , bwnTitle = removeBaseDir base_dir $ removeStatus status $ showSDUser (qualName style,qualModule style) df msg+ }+ modifyIORef ref $ \ ns -> ns ++ [n]+ | otherwise=return ()+ + bwSeverity :: Severity -> Maybe BWNoteStatus+ bwSeverity SevWarning = Just BWWarning + bwSeverity SevError = Just BWError+ bwSeverity SevFatal = Just BWError+ bwSeverity _ = Nothing+ + +-- | Convert 'GHC.Messages' to '[BWNote]'.+--+-- This will mix warnings and errors, but you can split them back up+-- by filtering the '[BWNote]' based on the 'bw_status'.+ghcMessagesToNotes :: DynFlags -> + FilePath -- ^ base directory+ -> Messages -- ^ GHC messages+ -> [BWNote]+ghcMessagesToNotes df base_dir (warns, errs) = map_bag2ms (ghcWarnMsgToNote df base_dir) warns +++ map_bag2ms (ghcErrMsgToNote df base_dir) errs+ where+ map_bag2ms f = map f . Bag.bagToList + + +-- | get all names in scope+getGhcNamesInScope :: FilePath -- ^ source path+ -> FilePath -- ^ base directory+ -> String -- ^ module name+ -> [String] -- ^ build options+ -> IO [String]+getGhcNamesInScope f base_dir modul options=do+ names<-withAST (\_->do+ --c1<-GMU.liftIO getClockTime+ names<-getNamesInScope+ df<-getSessionDynFlags+ --c2<-GMU.liftIO getClockTime+ --GMU.liftIO $ putStrLn ("getNamesInScope: " ++ (timeDiffToString $ diffClockTimes c2 c1))+ return $ map (showSDDump df . ppr ) names) f base_dir modul options+ return $ fromMaybe[] names++ +-- | get all names in scope, packaged in NameDefs+getGhcNameDefsInScope :: FilePath -- ^ source path+ -> FilePath -- ^ base directory+ -> String -- ^ module name+ -> [String] -- ^ build options+ -> IO (OpResult (Maybe [NameDef]))+getGhcNameDefsInScope fp base_dir modul options=do+ -- c0<-getClockTime+ (nns,ns)<-withASTNotes (\_ _->do+ -- c1<-GMU.liftIO getClockTime+ -- GMU.liftIO $ putStrLn "getGhcNameDefsInScope"+ names<-getNamesInScope+ df<-getSessionDynFlags+ -- c2<-GMU.liftIO getClockTime+ -- GMU.liftIO $ putStrLn ("getNamesInScope: " ++ (timeDiffToString $ diffClockTimes c2 c1))+ mapM (name2nd df) names) id base_dir (SingleFile fp modul) options+ -- c4<-getClockTime+ -- putStrLn ("getNamesInScopeAll: " ++ (timeDiffToString $ diffClockTimes c4 c0))+ return $ case nns of+ (x:_)->(Just x,ns)+ _->(Nothing, ns)+ +-- | get all names in scope, packaged in NameDefs+getGhcNameDefsInScopeLongRunning :: FilePath -- ^ source path+ -> FilePath -- ^ base directory+ -> String -- ^ module name+ -> [String] -- ^ build options+ -> IO ()+getGhcNameDefsInScopeLongRunning fp base_dir modul options=do++#if __GLASGOW_HASKELL__ < 706+ initGHC (go (TOD 0 0)) options+ where + go :: + ClockTime+ -> Ghc ()+ go t1 = do+ t2<- GMU.liftIO $ getModificationTime fp+ let hasLoaded=case t1 of+ TOD 0 _ -> False+ _ -> True+#else+ initGHC (go (UTCTime (ModifiedJulianDay 0) 0)) options+ where + go :: + UTCTime+ -> Ghc ()+ go t1 = do+ t2<- GMU.liftIO $ getModificationTime fp+ let hasLoaded=case t1 of+ UTCTime (ModifiedJulianDay 0) _ -> False+ _ -> True+#endif++ (ns1,add2)<-if hasLoaded && t2==t1 then -- modification time is only precise to the second in GHC 7.6 or above, see http://hackage.haskell.org/trac/ghc/ticket/7473+ (do + removeTarget (TargetFile fp Nothing) + load LoadAllTargets+ return ([],True)+ ) `gcatch` (\(e :: SourceError) -> do+ let errs = srcErrorMessages e+ df <- getSessionDynFlags+ return (ghcMessagesToNotes df base_dir (emptyBag, errs),True)+ )+ else return ([],not hasLoaded)+ (nns,ns)<- ghcWithASTNotes (\_ _->do+ names<-getNamesInScope+ df<-getSessionDynFlags+ mapM (name2nd df) names) id base_dir (SingleFile fp modul) add2 + let res=case nns of+ (x:_) -> (Just x,ns1 ++ ns)+ _ -> (Nothing,ns1 ++ ns)+ GMU.liftIO $ BSC.putStrLn $ BS.append "build-wrapper-json:" $ encode res+ GMU.liftIO $ hFlush stdout+ r1 t2+ r1 t2=do+ l<- GMU.liftIO getLine + case l of+ "q"->return ()+ -- | eval an expression+ 'e':' ':expr->do+ s<-handleSourceError (return . show)+ (do+ rr<- runStmt expr RunToCompletion+ case rr of+ RunOk ns->do+ df<-getSessionDynFlags+ ls<-mapM (\n->do+ mty<-lookupName n+ case mty of+ Just (AnId aid)->do+ t<-gtry $ GHC.obtainTermFromId 100 False aid+ case t of+ Right term -> showTerm term+ Left exn -> return (text "*** Exception:" <+>+ text (show (exn :: SomeException)))+ _->return empty+ ) ns+ return $ showSDDump df $ vcat ls+ RunException e ->return $ show e+ _->return "")+ GMU.liftIO $ BSC.putStrLn $ BS.append "build-wrapper-json:" $ encode s+ GMU.liftIO $ hFlush stdout+ r1 t2+ "t"->do+ input<- GMU.liftIO $ readFile fp+ ett<-tokenTypesArbitrary' fp input (".lhs" == takeExtension fp)+ let ret= case ett of+ Right tt-> (tt,[])+ Left bw -> ([],[bw])+ GMU.liftIO $ do+ BSC.putStrLn $ BS.append "build-wrapper-json:" $ encode ret+ hFlush stdout+ r1 t2 + 'p':xs->do+ GMU.liftIO $ do+ let (line,col)=read xs+ mv<-readGHCInfo fp+ let mm=case mv of + Just v->let + f=overlap line (scionColToGhcCol col)+ mf=findInJSON f v+ in findInJSONData mf + _-> Nothing + BSC.putStrLn $ BS.append "build-wrapper-json:" $ encode (mm,[]::[BWNote])+ hFlush stdout+ r1 t2 + _ ->go t2+ +name2nd :: GhcMonad m=> DynFlags -> Name -> m NameDef+name2nd df n=do+ m<- getInfo n+ let ty=case m of+ Just (tyt,_,_)->ty2t tyt+ Nothing->Nothing+ return $ NameDef (T.pack $ showSDDump df $ ppr n) (name2t n) ty+ where + name2t :: Name -> [OutlineDefType]+ name2t n2 + | isTyVarName n2=[Type]+ | isTyConName n2=[Type]+ | isDataConName n2 = [Constructor]+ | isVarName n2 = [Function]+ | otherwise =[]+ ty2t :: TyThing -> Maybe T.Text+ ty2t (AnId aid)=Just $ T.pack $ showSD False df $ pprTypeForUser True $ varType aid+ ty2t (ADataCon dc)=Just $ T.pack $ showSD False df $ pprTypeForUser True $ dataConUserType dc+ ty2t _ = Nothing++-- | get the "thing" at a particular point (line/column) in the source+-- this is using the saved JSON info if available+getThingAtPointJSON :: Int -- ^ line+ -> Int -- ^ column+-- -> Bool ^ do we want the result qualified by the module+-- -> Bool ^ do we want the full type or just the haddock type+ -> FilePath -- ^ source file path+ -> FilePath -- ^ base directory+ -> String -- ^ module name+ -> [String] -- ^ build flags+ -> IO (Maybe ThingAtPoint)+getThingAtPointJSON line col fp base_dir modul options= do+ mmf<-withJSONAST (\v->do+ let f=overlap line (scionColToGhcCol col)+ let mf=findInJSON f v+ return $ findInJSONData mf + ) fp base_dir modul options+ return $ fromMaybe Nothing mmf+ +-- | get the "thing" at a particular point (line/column) in the source+-- this is using the saved JSON info if available+getLocalsJSON ::Int -- ^ start line+ -> Int -- ^ start column+ -> Int -- ^ end line+ -> Int -- ^ end column+ -> FilePath -- ^ source file path+ -> FilePath -- ^ base directory+ -> String -- ^ module name+ -> [String] -- ^ build flags+ -> IO [ThingAtPoint]+getLocalsJSON sline scol eline ecol fp base_dir modul options= do+ mmf<-withJSONAST (\v->do+ let cont=contains sline (scionColToGhcCol scol) eline (scionColToGhcCol ecol)+ let isVar=isGHCType "Var"+ let mf=findAllInJSON (\x->cont x && isVar x) v+ return $ mapMaybe (findInJSONData . Just) mf + ) fp base_dir modul options+ return $ fromMaybe [] mmf + + +-- | convert a GHC SrcSpan to a Span, ignoring the actual file info+ghcSpanToLocation ::GHC.SrcSpan+ -> InFileSpan+ghcSpanToLocation sp+ | GHC.isGoodSrcSpan sp =let+ (stl,stc)=start sp+ (enl,enc)=end sp+ in mkFileSpan + stl+ (ghcColToScionCol stc)+ enl+ (ghcColToScionCol enc)+ | otherwise = mkFileSpan 0 0 0 0++ +-- | convert a GHC SrcSpan to a BWLocation +ghcSpanToBWLocation :: FilePath -- ^ Base directory+ -> GHC.SrcSpan+ -> BWLocation+ghcSpanToBWLocation baseDir sp+ | GHC.isGoodSrcSpan sp =+ let (stl,stc)=start sp+ (enl,enc)=end sp+ in BWLocation (makeRelative baseDir $ foldr f [] $ normalise $ unpackFS (sfile sp))+ stl+ (ghcColToScionCol stc)+ enl+ (ghcColToScionCol enc)+ | otherwise = mkEmptySpan "" 1 1 + where + f c (x:xs) + | c=='\\' && x=='\\'=x:xs -- WHY do we get two slashed after the drive sometimes?+ | otherwise=c:x:xs+ f c s=c:s+#if __GLASGOW_HASKELL__ < 702 + sfile = GHC.srcSpanFile+#else + sfile (RealSrcSpan ss)= GHC.srcSpanFile ss+#endif + +-- | convert a column info from GHC to our system (1 based) +ghcColToScionCol :: Int -> Int+#if __GLASGOW_HASKELL__ < 700+ghcColToScionCol c=c+1 -- GHC 6.x starts at 0 for columns+#else+ghcColToScionCol c=c -- GHC 7 starts at 1 for columns+#endif++-- | convert a column info from our system (1 based) to GHC +scionColToGhcCol :: Int -> Int+#if __GLASGOW_HASKELL__ < 700+scionColToGhcCol c=c-1 -- GHC 6.x starts at 0 for columns+#else+scionColToGhcCol c=c -- GHC 7 starts at 1 for columns+#endif + +-- | Get a stream of tokens generated by the GHC lexer from the current document+ghctokensArbitrary :: FilePath -- ^ The file path to the document+ -> String -- ^ The document's contents+ -> [String] -- ^ The options+ -> IO (Either BWNote [Located Token])+ghctokensArbitrary base_dir contents options= do+#if __GLASGOW_HASKELL__ < 702+ sb <- stringToStringBuffer contents+#else+ let sb=stringToStringBuffer contents+#endif+ let lflags=map noLoc options+ (_leftovers, _) <- parseStaticFlags lflags+ runGhc (Just libdir) $ do+ flg <- getSessionDynFlags+ (flg', _, _) <- parseDynamicFlags flg _leftovers+ +#if __GLASGOW_HASKELL__ >= 700+ let dflags1 = List.foldl' xopt_set flg' lexerFlags+#else+ let dflags1 = List.foldl' dopt_set flg' lexerFlags+#endif+ let prTS = lexTokenStreamH sb lexLoc dflags1+ case prTS of+ POk _ toks -> do+ -- GMU.liftIO $ print $ map (show . unLoc) toks+ return $ Right $ filter ofInterest toks+ PFailed loc msg -> return $ Left $ ghcErrMsgToNote dflags1 base_dir $ +#if __GLASGOW_HASKELL__ < 706+ mkPlainErrMsg loc msg+#else+ mkPlainErrMsg dflags1 loc msg+#endif++-- | Get a stream of tokens generated by the GHC lexer from the current document+ghctokensArbitrary' :: FilePath -- ^ The file path to the document+ -> String -- ^ The document's contents+ -> Ghc (Either BWNote [Located Token])+ghctokensArbitrary' base_dir contents= do+#if __GLASGOW_HASKELL__ < 702+ sb <- stringToStringBuffer contents+#else+ let sb=stringToStringBuffer contents+#endif++ dflags1 <- getSessionDynFlags+ let prTS = lexTokenStreamH sb lexLoc dflags1+ case prTS of+ POk _ toks -> do+ -- GMU.liftIO $ print $ map (show . unLoc) toks+ return $ Right $ filter ofInterest toks+ PFailed loc msg -> return $ Left $ ghcErrMsgToNote dflags1 base_dir $ +#if __GLASGOW_HASKELL__ < 706+ mkPlainErrMsg loc msg+#else+ mkPlainErrMsg dflags1 loc msg+#endif++-- | like lexTokenStream, but keep Haddock flag+lexTokenStreamH :: StringBuffer -> RealSrcLoc -> DynFlags -> ParseResult [Located Token]+lexTokenStreamH buf loc dflags = unP go initState+ where dflags' = dopt_set (dopt_set dflags Opt_KeepRawTokenStream) Opt_Haddock+ initState = mkPState dflags' buf loc+ go = do+ ltok <- lexer return+ case ltok of+ L _ ITeof -> return []+ _ -> liftM (ltok:) go+++#if __GLASGOW_HASKELL__ < 702+lexLoc :: SrcLoc+lexLoc = mkSrcLoc (mkFastString "<interactive>") 1 (scionColToGhcCol 1)+#else+lexLoc :: RealSrcLoc+lexLoc = mkRealSrcLoc (mkFastString "<interactive>") 1 (scionColToGhcCol 1)+#endif+++#if __GLASGOW_HASKELL__ >= 700+lexerFlags :: [ExtensionFlag]+#else+lexerFlags :: [DynFlag]+#endif+lexerFlags =+ [ Opt_ForeignFunctionInterface+ , Opt_Arrows+#if __GLASGOW_HASKELL__ < 702 + , Opt_PArr+#else+ , Opt_ParallelArrays+#endif + , Opt_TemplateHaskell+ , Opt_QuasiQuotes+ , Opt_ImplicitParams+ , Opt_BangPatterns+ , Opt_TypeFamilies+ , Opt_MagicHash+ , Opt_KindSignatures+ , Opt_RecursiveDo+ , Opt_UnicodeSyntax+ , Opt_UnboxedTuples+ , Opt_StandaloneDeriving+ , Opt_TransformListComp+#if __GLASGOW_HASKELL__ < 702 + , Opt_NewQualifiedOperators+#endif +#if GHC_VERSION > 611 + , Opt_ExplicitForAll -- 6.12+ , Opt_DoRec -- 6.12+#endif+ ] + +-- | Filter tokens whose span appears legitimate (start line is less than end line, start column is+-- less than end column.)+ofInterest :: Located Token -> Bool+ofInterest (L loc _) =+ let (sl,sc) = start loc+ (el,ec) = end loc+ in (sl < el) || (sc < ec)++ +-- | Convert a GHC token to an interactive token (abbreviated token type)+tokenToType :: Located Token -> TokenDef+tokenToType (L sp t) = TokenDef (tokenType t) (ghcSpanToLocation sp) + +-- | Generate the interactive token list used by EclipseFP for syntax highlighting+tokenTypesArbitrary :: FilePath -> String -> Bool -> [String] -> IO (Either BWNote [TokenDef])+tokenTypesArbitrary projectRoot contents literate options = generateTokens projectRoot contents literate options convertTokens id+ where+ convertTokens = map tokenToType ++tokenTypesArbitrary' :: FilePath -> String -> Bool -> Ghc (Either BWNote [TokenDef])+tokenTypesArbitrary' projectRoot contents literate = generateTokens' projectRoot contents literate convertTokens id+ where+ convertTokens = map tokenToType + +-- | Extract occurrences based on lexing +occurrences :: FilePath -- ^ Project root or base directory for absolute path conversion+ -> String -- ^ Contents to be parsed+ -> T.Text -- ^ Token value to find+ -> Bool -- ^ Literate source flag (True = literate, False = ordinary)+ -> [String] -- ^ Options+ -> IO (Either BWNote [TokenDef])+occurrences projectRoot contents query literate options = + let + qualif = isJust $ T.find (=='.') query+ -- Get the list of tokens matching the query for relevant token types+ tokensMatching :: [TokenDef] -> [TokenDef]+ tokensMatching = filter matchingVal+ matchingVal :: TokenDef -> Bool+ matchingVal (TokenDef v _)=query==v+ mkToken (L sp t)=TokenDef (tokenValue qualif t) (ghcSpanToLocation sp)+ in generateTokens projectRoot contents literate options (map mkToken) tokensMatching + +-- | Parse the current document, generating a TokenDef list, filtered by a function+generateTokens :: FilePath -- ^ The project's root directory+ -> String -- ^ The current document contents, to be parsed+ -> Bool -- ^ Literate Haskell flag+ -> [String] -- ^ The options+ -> ([Located Token] -> [TokenDef]) -- ^ Transform function from GHC tokens to TokenDefs+ -> ([TokenDef] -> a) -- ^ The TokenDef filter function+ -> IO (Either BWNote a)+generateTokens projectRoot contents literate options xform filterFunc =do+ let (ppTs, ppC) = preprocessSource contents literate+ -- putStrLn ppC+ result<- ghctokensArbitrary projectRoot ppC options+ case result of + Right toks ->do+ let filterResult = filterFunc $ List.sortBy (comparing tdLoc) (ppTs ++ xform toks)+ return $ Right filterResult+ Left n -> return $ Left n+ + +-- | Parse the current document, generating a TokenDef list, filtered by a function+generateTokens' :: FilePath -- ^ The project's root directory+ -> String -- ^ The current document contents, to be parsed+ -> Bool -- ^ Literate Haskell flag+ -> ([Located Token] -> [TokenDef]) -- ^ Transform function from GHC tokens to TokenDefs+ -> ([TokenDef] -> a) -- ^ The TokenDef filter function+ -> Ghc (Either BWNote a)+generateTokens' projectRoot contents literate xform filterFunc =do+ let (ppTs, ppC) = preprocessSource contents literate+ -- putStrLn ppC+ result<- ghctokensArbitrary' projectRoot ppC+ case result of + Right toks ->do+ let filterResult = filterFunc $ List.sortBy (comparing tdLoc) (ppTs ++ xform toks)+ return $ Right filterResult+ Left n -> return $ Left n + +-- | Preprocess some source, returning the literate and Haskell source as tuple.+preprocessSource :: String -- ^ the source contents+ -> Bool -- ^ is the source literate Haskell+ -> ([TokenDef],String) -- ^ the preprocessor tokens and the final valid Haskell source+preprocessSource contents literate=+ let + (ts1,s2)=if literate then ppSF contents ppSLit else ([],contents) + (ts2,s3)=ppSF s2 ppSCpp+ in (ts1++ts2,s3)+ where+ ppSF contents2 p= let+ linesWithCount=zip (lines contents2) [1..]+ (ts,nc,_)= List.foldl' p ([],[],Start) linesWithCount+ in (reverse ts, unlines $ reverse nc)+ ppSCpp :: ([TokenDef],[String],PPBehavior) -> (String,Int) -> ([TokenDef],[String],PPBehavior)+ ppSCpp (ts2,l2,f) (l,c) + | (Continue _)<-f = addPPToken "PP" (l,c) (ts2,l2,lineBehavior l f)+ | (ContinuePragma f2) <-f= addPPToken "P" (l,c) (ts2,"":l2,pragmaBehavior l f2)+ | ('#':_)<-l =addPPToken "PP" (l,c) (ts2,l2,lineBehavior l f) + | "{-# " `List.isPrefixOf` l=addPPToken "P" (l,c) (ts2,"":l2,pragmaBehavior l f) + | (Indent n)<-f=(ts2,l:(replicate n (takeWhile (== ' ') l) ++ l2),Start)+ | otherwise =(ts2,l:l2,Start)+ ppSLit :: ([TokenDef],[String],PPBehavior) -> (String,Int) -> ([TokenDef],[String],PPBehavior)+ ppSLit (ts2,l2,f) (l,c) + | "\\begin{code}" `List.isPrefixOf` l=addPPToken "DL" ("\\begin{code}",c) (ts2,"":l2,Continue 1)+ | "\\end{code}" `List.isPrefixOf` l=addPPToken "DL" ("\\end{code}",c) (ts2,"":l2,Start)+ | (Continue n)<-f = (ts2,l:l2,Continue (n+1))+ | ('>':lCode)<-l=(ts2, (' ':lCode ):l2,f)+ | otherwise =addPPToken "DL" (l,c) (ts2,"":l2,f) + addPPToken :: T.Text -> (String,Int) -> ([TokenDef],[String],PPBehavior) -> ([TokenDef],[String],PPBehavior)+ addPPToken name (l,c) (ts2,l2,f) =(TokenDef name (mkFileSpan c 1 c (length l + 1)) : ts2 ,l2,f)+ lineBehavior l f + | '\\' == last l = case f of+ Continue n->Continue (n+1)+ _ -> Continue 1+ | otherwise = case f of+ Continue n->Indent (n+1)+ ContinuePragma p->p+ Indent n->Indent (n+1)+ _ -> Indent 1+ pragmaBehavior l f+ | "-}" `List.isInfixOf` l = f+ | otherwise = ContinuePragma f++data PPBehavior=Continue Int | Indent Int | Start | ContinuePragma PPBehavior+ deriving Eq++-- | convert a GHC error message to our note type+ghcErrMsgToNote :: DynFlags -> FilePath -> ErrMsg -> BWNote+ghcErrMsgToNote df= ghcMsgToNote df BWError++-- | convert a GHC warning message to our note type+ghcWarnMsgToNote :: DynFlags -> FilePath -> WarnMsg -> BWNote+ghcWarnMsgToNote df= ghcMsgToNote df BWWarning++-- Note that we do *not* include the extra info, since that information is+-- only useful in the case where we do not show the error location directly+-- in the source.+ghcMsgToNote :: DynFlags -> BWNoteStatus -> FilePath -> ErrMsg -> BWNote+ghcMsgToNote df note_kind base_dir msg =+ BWNote { bwnLocation = ghcSpanToBWLocation base_dir loc+ , bwnStatus = note_kind+ , bwnTitle = removeBaseDir base_dir $ removeStatus note_kind $ show_msg (errMsgShortDoc msg)+ }+ where+ loc | (s:_) <- errMsgSpans msg = s+ | otherwise = GHC.noSrcSpan+ unqual = errMsgContext msg+ show_msg = showSDUser unqual df++-- | remove the initial status text from a message+removeStatus :: BWNoteStatus -> String -> String+removeStatus BWWarning s + | "Warning:" `List.isPrefixOf` s = List.dropWhile isSpace $ drop 8 s+ | otherwise = s+removeStatus BWError s + | "Error:" `List.isPrefixOf` s = List.dropWhile isSpace $ drop 6 s+ | otherwise = s ++#if CABAL_VERSION == 106+deriving instance Typeable StringBuffer+deriving instance Data StringBuffer+#endif++-- | make unqualified token+mkUnqualTokenValue :: FastString -- ^ the name+ -> T.Text+mkUnqualTokenValue = T.pack . unpackFS++-- | make qualified token: join the qualifier and the name by a dot+mkQualifiedTokenValue :: FastString -- ^ the qualifier+ -> FastString -- ^ the name+ -> T.Text+mkQualifiedTokenValue q a = (T.pack . unpackFS . concatFS) [q, dotFS, a]++-- | Make a token definition from its source location and Lexer.hs token type.+--mkTokenDef :: Located Token -> TokenDef+--mkTokenDef (L sp t) = TokenDef (mkTokenName t) (ghcSpanToLocation sp)++mkTokenName :: Token -> T.Text+mkTokenName = T.pack . showConstr . toConstr++deriving instance Typeable Token+deriving instance Data Token++#if CABAL_VERSION == 106+deriving instance Typeable StringBuffer+deriving instance Data StringBuffer+#endif+++tokenType :: Token -> T.Text+tokenType ITas = "K" -- Haskell keywords+tokenType ITcase = "K"+tokenType ITclass = "K"+tokenType ITdata = "K"+tokenType ITdefault = "K"+tokenType ITderiving = "K"+tokenType ITdo = "K"+tokenType ITelse = "K"+tokenType IThiding = "K"+tokenType ITif = "K"+tokenType ITimport = "K"+tokenType ITin = "K"+tokenType ITinfix = "K"+tokenType ITinfixl = "K"+tokenType ITinfixr = "K"+tokenType ITinstance = "K"+tokenType ITlet = "K"+tokenType ITmodule = "K"+tokenType ITnewtype = "K"+tokenType ITof = "K"+tokenType ITqualified = "K"+tokenType ITthen = "K"+tokenType ITtype = "K"+tokenType ITwhere = "K"+tokenType ITscc = "K" -- ToDo: remove (we use {-# SCC "..." #-} now)++tokenType ITforall = "EK" -- GHC extension keywords+tokenType ITforeign = "EK"+tokenType ITexport= "EK"+tokenType ITlabel= "EK"+tokenType ITdynamic= "EK"+tokenType ITsafe= "EK"+#if __GLASGOW_HASKELL__ < 702+tokenType ITthreadsafe= "EK"+#endif+tokenType ITunsafe= "EK"+tokenType ITstdcallconv= "EK"+tokenType ITccallconv= "EK"+#if __GLASGOW_HASKELL__ >= 612+tokenType ITprimcallconv= "EK"+#endif+tokenType ITmdo= "EK"+tokenType ITfamily= "EK"+tokenType ITgroup= "EK"+tokenType ITby= "EK"+tokenType ITusing= "EK"++ -- Pragmas+tokenType (ITinline_prag {})="P" -- True <=> INLINE, False <=> NOINLINE+#if __GLASGOW_HASKELL__ >= 612 && __GLASGOW_HASKELL__ < 700 +tokenType (ITinline_conlike_prag {})="P" -- same+#endif+tokenType ITspec_prag="P" -- SPECIALISE +tokenType (ITspec_inline_prag {})="P" -- SPECIALISE INLINE (or NOINLINE)+tokenType ITsource_prag="P"+tokenType ITrules_prag="P"+tokenType ITwarning_prag="P"+tokenType ITdeprecated_prag="P"+tokenType ITline_prag="P"+tokenType ITscc_prag="P"+tokenType ITgenerated_prag="P"+tokenType ITcore_prag="P" -- hdaume: core annotations+tokenType ITunpack_prag="P"+#if __GLASGOW_HASKELL__ >= 612+tokenType ITann_prag="P"+#endif+tokenType ITclose_prag="P"+tokenType (IToptions_prag {})="P"+tokenType (ITinclude_prag {})="P"+tokenType ITlanguage_prag="P"++tokenType ITdotdot="S" -- reserved symbols+tokenType ITcolon="S"+tokenType ITdcolon="S"+tokenType ITequal="S"+tokenType ITlam="S"+tokenType ITvbar="S"+tokenType ITlarrow="S"+tokenType ITrarrow="S"+tokenType ITat="S"+tokenType ITtilde="S"+tokenType ITdarrow="S"+tokenType ITminus="S"+tokenType ITbang="S"+tokenType ITstar="S"+tokenType ITdot="S"++tokenType ITbiglam="ES" -- GHC-extension symbols++tokenType ITocurly="SS" -- special symbols+tokenType ITccurly="SS" +#if __GLASGOW_HASKELL__ < 706 +tokenType ITocurlybar="SS" -- "{|", for type applications+tokenType ITccurlybar="SS" -- "|}", for type applications+#endif+tokenType ITvocurly="SS" +tokenType ITvccurly="SS" +tokenType ITobrack="SS" +tokenType ITopabrack="SS" -- [:, for parallel arrays with -XParr+tokenType ITcpabrack="SS" -- :], for parallel arrays with -XParr+tokenType ITcbrack="SS" +tokenType IToparen="SS" +tokenType ITcparen="SS" +tokenType IToubxparen="SS" +tokenType ITcubxparen="SS" +tokenType ITsemi="SS" +tokenType ITcomma="SS" +tokenType ITunderscore="SS" +tokenType ITbackquote="SS" ++tokenType (ITvarid {})="IV" -- identifiers+tokenType (ITconid {})="IC"+tokenType (ITvarsym {})="VS"+tokenType (ITconsym {})="IC"+tokenType (ITqvarid {})="IV"+tokenType (ITqconid {})="IC"+tokenType (ITqvarsym {})="VS"+tokenType (ITqconsym {})="IC"+tokenType (ITprefixqvarsym {})="VS"+tokenType (ITprefixqconsym {})="IC"++tokenType (ITdupipvarid {})="EI" -- GHC extension: implicit param: ?x++tokenType (ITchar {})="LC"+tokenType (ITstring {})="LS"+tokenType (ITinteger {})="LI"+tokenType (ITrational {})="LR"++tokenType (ITprimchar {})="LC"+tokenType (ITprimstring {})="LS"+tokenType (ITprimint {})="LI"+tokenType (ITprimword {})="LW"+tokenType (ITprimfloat {})="LF"+tokenType (ITprimdouble {})="LD"++ -- Template Haskell extension tokens+tokenType ITopenExpQuote="TH" -- [| or [e|+tokenType ITopenPatQuote="TH" -- [p|+tokenType ITopenDecQuote="TH" -- [d|+tokenType ITopenTypQuote="TH" -- [t| +tokenType ITcloseQuote="TH" --tokenType ]+tokenType (ITidEscape {})="TH" -- $x+tokenType ITparenEscape="TH" -- $( +#if __GLASGOW_HASKELL__ < 704+tokenType ITvarQuote="TH" -- '+#endif+tokenType ITtyQuote="TH" -- ''+tokenType (ITquasiQuote {})="TH" -- [:...|...|]++ -- Arrow notation extension+tokenType ITproc="A"+tokenType ITrec="A"+tokenType IToparenbar="A" -- (|+tokenType ITcparenbar="A" --tokenType )+tokenType ITlarrowtail="A" -- -<+tokenType ITrarrowtail="A" -- >-+tokenType ITLarrowtail="A" -- -<<+tokenType ITRarrowtail="A" -- >>-++#if __GLASGOW_HASKELL__ <= 611+tokenType ITdotnet="SS" -- ??+tokenType (ITpragma _) = "SS" -- ??+#endif++tokenType (ITunknown {})="" -- Used when the lexer can't make sense of it+tokenType ITeof="" -- end of file token++ -- Documentation annotations+tokenType (ITdocCommentNext {})="D" -- something beginning '-- |'+tokenType (ITdocCommentPrev {})="D" -- something beginning '-- ^'+tokenType (ITdocCommentNamed {})="D" -- something beginning '-- $'+tokenType (ITdocSection {})="D" -- a section heading+tokenType (ITdocOptions {})="D" -- doc options (prune, ignore-exports, etc)+tokenType (ITdocOptionsOld {})="D" -- doc options declared "-- # ..."-style+tokenType (ITlineComment {})="C" -- comment starting by "--"+tokenType (ITblockComment {})="C" -- comment in {- -}++ -- 7.2 new token types +#if __GLASGOW_HASKELL__ >= 702+tokenType (ITinterruptible {})="EK"+tokenType (ITvect_prag {})="P"+tokenType (ITvect_scalar_prag {})="P"+tokenType (ITnovect_prag {})="P"+#endif++ -- 7.4 new token types +#if __GLASGOW_HASKELL__ >= 704+tokenType ITcapiconv= "EK"+tokenType ITnounpack_prag= "P"+tokenType ITtildehsh= "S"+tokenType ITsimpleQuote="SS"+#endif++-- 7.6 new token types +#if __GLASGOW_HASKELL__ >= 706+tokenType ITctype= "P"+tokenType ITlcase= "S"+tokenType (ITqQuasiQuote {}) = "TH" -- [Qual.quoter| quote |]+#endif++dotFS :: FastString+dotFS = fsLit "."++tokenValue :: Bool -> Token -> T.Text+tokenValue _ t | tokenType t `elem` ["K", "EK"] = T.drop 2 $ mkTokenName t+tokenValue _ (ITvarid a) = mkUnqualTokenValue a+tokenValue _ (ITconid a) = mkUnqualTokenValue a+tokenValue _ (ITvarsym a) = mkUnqualTokenValue a+tokenValue _ (ITconsym a) = mkUnqualTokenValue a+tokenValue False (ITqvarid (_,a)) = mkUnqualTokenValue a+tokenValue True (ITqvarid (q,a)) = mkQualifiedTokenValue q a+tokenValue False(ITqconid (_,a)) = mkUnqualTokenValue a+tokenValue True (ITqconid (q,a)) = mkQualifiedTokenValue q a+tokenValue False (ITqvarsym (_,a)) = mkUnqualTokenValue a+tokenValue True (ITqvarsym (q,a)) = mkQualifiedTokenValue q a+tokenValue False (ITqconsym (_,a)) = mkUnqualTokenValue a+tokenValue True (ITqconsym (q,a)) = mkQualifiedTokenValue q a+tokenValue False (ITprefixqvarsym (_,a)) = mkUnqualTokenValue a+tokenValue True (ITprefixqvarsym (q,a)) = mkQualifiedTokenValue q a+tokenValue False (ITprefixqconsym (_,a)) = mkUnqualTokenValue a+tokenValue True (ITprefixqconsym (q,a)) = mkQualifiedTokenValue q a+tokenValue _ _= "" + +instance Monoid (Bag a) where+ mempty = emptyBag+ mappend = unionBags+ mconcat = unionManyBags + +start, end :: SrcSpan -> (Int,Int) +#if __GLASGOW_HASKELL__ < 702 +start ss= (srcSpanStartLine ss, srcSpanStartCol ss)+end ss= (srcSpanEndLine ss, srcSpanEndCol ss)+#else +start (RealSrcSpan ss)= (srcSpanStartLine ss, srcSpanStartCol ss)+start (UnhelpfulSpan _)=error "UnhelpfulSpan in cmpOverlap start"+end (RealSrcSpan ss)= (srcSpanEndLine ss, srcSpanEndCol ss) +end (UnhelpfulSpan _)=error "UnhelpfulSpan in cmpOverlap start" +#endif+ +type AliasMap=DM.Map ModuleName [ModuleName]+++ghcImportToUsage :: T.Text -> LImportDecl Name -> ([Usage],AliasMap) -> Ghc ([Usage],AliasMap)+ghcImportToUsage myPkg (L _ imp) (ls,moduMap)=(do+ let L src modu=ideclName imp+ pkg<-lookupModule modu (ideclPkgQual imp)+ df<-getSessionDynFlags+ let tmod=T.pack $ showSD True df $ ppr modu+ tpkg=T.pack $ showSD True df $ ppr $ modulePackageId pkg+ nomain=if tpkg=="main" then myPkg else tpkg+ subs=concatMap (ghcLIEToUsage df (Just nomain) tmod "import") $ maybe [] snd $ ideclHiding imp+ moduMap2=maybe moduMap (\alias->let+ mlmods=DM.lookup alias moduMap+ newlmods=case mlmods of+ Just lmods->modu:lmods+ Nothing->[modu]+ in DM.insert alias newlmods moduMap) $ ideclAs imp+ usg =Usage (Just nomain) tmod "" "import" False (toJSON $ ghcSpanToLocation src) False+ return (usg:subs++ls,moduMap2)+ )+ `gcatch` (\(se :: SourceError) -> do+ GMU.liftIO $ print se+ return ([],moduMap))+ +ghcLIEToUsage :: DynFlags -> Maybe T.Text -> T.Text -> T.Text -> LIE Name -> [Usage]+ghcLIEToUsage df tpkg tmod tsection (L src (IEVar nm))=[ghcNameToUsage df tpkg tmod tsection nm src False]+ghcLIEToUsage df tpkg tmod tsection (L src (IEThingAbs nm))=[ghcNameToUsage df tpkg tmod tsection nm src True ] +ghcLIEToUsage df tpkg tmod tsection (L src (IEThingAll nm))=[ghcNameToUsage df tpkg tmod tsection nm src True] +ghcLIEToUsage df tpkg tmod tsection (L src (IEThingWith nm cons))=ghcNameToUsage df tpkg tmod tsection nm src True :+ map (\ x -> ghcNameToUsage df tpkg tmod tsection x src False) cons +ghcLIEToUsage _ tpkg tmod tsection (L src (IEModuleContents _))= [Usage tpkg tmod "" tsection False (toJSON $ ghcSpanToLocation src) False] +ghcLIEToUsage _ _ _ _ _=[]+ +ghcExportToUsage :: DynFlags -> T.Text -> T.Text ->AliasMap -> LIE Name -> Ghc [Usage] +ghcExportToUsage df myPkg myMod moduMap lie@(L _ name)=(do+ ls<-case name of+ (IEModuleContents modu)-> do+ let realModus=fromMaybe [modu] (DM.lookup modu moduMap)+ mapM (\modu2->do+ pkg<-lookupModule modu2 Nothing+ let tpkg=T.pack $ showSD True df $ ppr $ modulePackageId pkg+ let tmod=T.pack $ showSD True df $ ppr modu2+ return (tpkg,tmod)+ ) realModus+ _ -> return [(myPkg,myMod)]+ return $ concatMap (\(tpkg,tmod)->ghcLIEToUsage df (Just tpkg) tmod "export" lie) ls+ )+ `gcatch` (\(se :: SourceError) -> do+ GMU.liftIO $ print se+ return [])+ +ghcNameToUsage :: DynFlags -> Maybe T.Text -> T.Text -> T.Text -> Name -> SrcSpan -> Bool -> Usage +ghcNameToUsage df tpkg tmod tsection nm src typ=Usage tpkg tmod (T.pack $ showSD False df $ ppr nm) tsection typ (toJSON $ ghcSpanToLocation src) False++type ImportMap=DM.Map T.Text (LImportDecl Name,[T.Text])++ghcImportMap :: LImportDecl Name -> Ghc ImportMap+ghcImportMap l@(L _ imp)=(do+ let L _ modu=ideclName imp+ let moduS=T.pack $ moduleNameString modu+ --GMU.liftIO $ putStrLn $ show moduS+ let mm=DM.singleton moduS (l,[])+ m<-lookupModule modu Nothing+ mmi<-getModuleInfo m+ df <- getSessionDynFlags+ let maybeHiding=ideclHiding imp+ let hidden=case maybeHiding of+ Just(True,ns)->map (T.pack . showSD False df . ppr . unLoc) ns+ _ ->[]+ let fullM =case mmi of+ Nothing -> mm+ Just mi->let+ exps=modInfoExports mi+ -- extExps=filter (\x->(nameModule x) /= m) exps+ in foldr insertImport mm exps+ where insertImport :: Name -> ImportMap -> ImportMap+ insertImport x mmx=+ let+ expM=T.pack $ moduleNameString $ moduleName $ nameModule x+ nT=T.pack $ showSD False df $ ppr x+ in if nT `elem` hidden + then mmx + else DM.insertWith (\(_,xs1) (_,xs2)->(l,xs1++xs2)) expM (l,[nT]) mmx+ return $ if ideclImplicit imp+ then DM.insert "" (l,(concatMap snd $ DM.elems fullM)) fullM+ else fullM+ )+ `gcatch` (\(se :: SourceError) -> do+ GMU.liftIO $ print se+ return DM.empty) + +--getGHCOutline :: ParsedSource+-- -> [OutlineDef]+--getGHCOutline (L src mod)=concatMap ldeclOutline (hsmodDecls mod)+-- where +-- ldeclOutline :: LHsDecl RdrName -> [OutlineDef]+-- ldeclOutline (L src1 (TyClD decl))=ltypeOutline decl+-- ldeclOutline _ = []+-- ltypeOutline :: TyClDecl RdrName -> [OutlineDef]+-- ltypeOutline (TyFamily{tcdLName})=[mkOutlineDef (nameDecl $ unLoc tcdLName) [Type,Family] (ghcSpanToLocation $ getLoc tcdLName)]+-- ltypeOutline (TyData{tcdLName,tcdCons})=[mkOutlineDef (nameDecl $ unLoc tcdLName) [Data] (ghcSpanToLocation $ getLoc tcdLName)]+-- ++ concatMap lconOutline tcdCons+-- lconOutline :: LConDecl RdrName -> [OutlineDef]+-- lconOutline (L src ConDecl{con_name,con_doc,con_details})=[(mkOutlineDef (nameDecl $ unLoc con_name) [Constructor] (ghcSpanToLocation $ getLoc con_name)){od_comment=commentDecl con_doc}]+-- ++ detailOutline con_details+-- detailOutline (RecCon fields)=concatMap lfieldOutline fields+-- detailOutline _=[]+-- lfieldOutline (ConDeclField{cd_fld_name,cd_fld_doc})=[(mkOutlineDef (nameDecl $ unLoc cd_fld_name) [Function] (ghcSpanToLocation $ getLoc cd_fld_name)){od_comment=commentDecl cd_fld_doc}]+-- nameDecl:: RdrName -> T.Text+-- nameDecl (Unqual occ)=T.pack $ showSDoc $ ppr occ+-- nameDecl (Qual _ occ)=T.pack $ showSDoc $ ppr occ+-- commentDecl :: Maybe LHsDocString -> Maybe T.Text+-- commentDecl (Just st)=Just $ T.pack $ showSDoc $ ppr st+-- commentDecl _=Nothing+ -- ghcSpanToLocation++-- | module, function/type, constructors+type TypeMap=DM.Map T.Text (DM.Map T.Text (DS.Set T.Text))+type FinalImportValue=(LImportDecl Name,DM.Map T.Text (DS.Set T.Text))+type FinalImportMap=DM.Map T.Text FinalImportValue+ + +-- | clean imports +ghcCleanImports :: FilePath -- ^ source path+ -> FilePath -- ^ base directory+ -> String -- ^ module name+ -> [String] -- ^ build options+ -> Bool -- ^ format?+ -> IO (OpResult [ImportClean]) +ghcCleanImports f base_dir modul options doFormat = do+ (m,bwns)<-withASTNotes clean (base_dir </>) base_dir (SingleFile f modul) options+ return (if null m then [] else head m,bwns)+ where+ -- | main clean method: get the usage, the existing imports, and retrieve only the needed names for each import+ clean :: GHCApplyFunction [ImportClean]+ clean _ tm=do+ let (_,imps,_,_)=fromJust $ tm_renamed_source tm+ df <- getSessionDynFlags+ let modu=T.pack $ showSD True df $ ppr $ moduleName $ ms_mod $ pm_mod_summary $ tm_parsed_module tm+ let (Array vs)= generateGHCInfo df tm+ impMaps<-mapM ghcImportMap imps+ -- let impMap=DM.unions impMaps+ let implicit=DS.fromList $ concatMap (maybe [] snd . (DM.lookup "")) impMaps+ let allImps=concatMap DM.assocs impMaps+ -- GMU.liftIO $ putStrLn $ show $ map (\(n,(_,ns))->(n,ns)) allImps+ -- GMU.liftIO $ print implicit+ let usgMap=V.foldr ghcValToUsgMap DM.empty vs+ let usgMapWithoutMe=DM.delete modu usgMap+ -- GMU.liftIO $ print usgMapWithoutMe+ -- GMU.liftIO $ putStrLn $ show $ usgMapWithoutMe+ --let ics=foldr (buildImportClean usgMapWithoutMe df) [] (DM.assocs impMap)+ let ftm=foldr (buildImportCleanMap usgMapWithoutMe implicit) DM.empty allImps+ + let missingCleans=getRemovedImports allImps ftm+ let formatF=if doFormat then formatImports else map (dumpImportMap df)+ -- GMU.liftIO $ putStrLn $ show $ DM.keys ftm+ let allCleans=formatF (DM.elems ftm) ++ missingCleans+ return allCleans+ -- | all used names by module + ghcValToUsgMap :: Value -> TypeMap -> TypeMap+ ghcValToUsgMap (Object m) um |+ Just (String n)<-HM.lookup "Name" m,+ Just (String mo)<-HM.lookup "Module" m,+ not $ T.null mo, -- ignore local objects+ mst<-HM.lookup "Type" m,+ Just (String ht)<-HM.lookup "HType" m+ =let+ mm=DM.lookup mo um+ isType=ht=="t"+ isConstructor=not isType && isUpper (T.head n) && isJust mst+ key=if isConstructor+ then let+ Just (String t)=mst+ in fst $ T.breakOn " " $ T.strip $ snd $ T.breakOnEnd "->" t+ else n+ val=if isConstructor+ then DS.singleton n+ else DS.empty+ in case mm of+ Just usgM1->DM.insert mo (DM.insertWith DS.union key val usgM1) um+ Nothing->DM.insert mo (DM.singleton key val) um+ ghcValToUsgMap _ um=um+ -- | reconcile the usage map and the import to generate the final import map: module -> names to import+ buildImportCleanMap :: TypeMap -> DS.Set T.Text ->(T.Text,(LImportDecl Name,[T.Text])) -> FinalImportMap -> FinalImportMap+ buildImportCleanMap usgMap implicit (cmod,(l@(L _ imp),ns)) tm |+ Just namesMap<-DM.lookup cmod usgMap, -- used names for module+ namesMapFiltered<-foldr (keepKeys namesMap) DM.empty ns, -- only names really exported by the import name+ namesWithoutImplicit<-if ideclQualified imp + then namesMapFiltered+ else DM.map (`DS.difference` implicit) $ foldr DM.delete namesMapFiltered $ DS.elems implicit,+ not $ DM.null namesWithoutImplicit,+ not $ ideclImplicit imp = let -- ignore implicit prelude+ L _ modu=ideclName imp+ moduS=T.pack $ moduleNameString modu+ in DM.insertWith mergeTypeMap moduS (l,namesWithoutImplicit) tm+ buildImportCleanMap _ _ _ tm = tm + -- | copy the key and value from one map to the other+ keepKeys :: Ord k => DM.Map k v -> k -> DM.Map k v -> DM.Map k v+ keepKeys m1 k m2=case DM.lookup k m1 of+ Nothing -> m2+ Just v1->DM.insert k v1 m2 + -- | merge the map containing the set of names + mergeTypeMap :: FinalImportValue -> FinalImportValue -> FinalImportValue+ mergeTypeMap (l1,m1) (_,m2)= (l1,DM.unionWith DS.union m1 m2) + -- | generate final import string from names map + dumpImportMap :: DynFlags -> FinalImportValue -> ImportClean+ dumpImportMap df (L loc imp,ns)=let+ txt= T.pack $ showSDDump df $ ppr (imp{ideclHiding=Nothing} :: ImportDecl Name) -- rely on GHC for the initial bit of the import, without the names+ nameList= T.intercalate ", " $ List.sortBy (comparing T.toLower) $ map buildName $ DM.assocs ns -- build explicit import list+ full=txt `mappend` " (" `mappend` nameList `mappend` ")"+ in ImportClean (ghcSpanToLocation loc) full+ pprName :: T.Text -> T.Text+ pprName n | T.null n =n+ | isAlpha $ T.head n=n+ | otherwise=T.concat ["(",n,")"]+ -- build the name with the constructors list if any+ buildName :: (T.Text,DS.Set T.Text)->T.Text+ buildName (n,cs) + | DS.null cs=pprName n+ | otherwise =let+ nameList= T.intercalate ", " $ List.sortBy (comparing T.toLower) $ map pprName $ DS.toList cs+ in (pprName n) `mappend` " (" `mappend` nameList `mappend` ")" + getRemovedImports :: [(T.Text,(LImportDecl Name,[T.Text]))] -> FinalImportMap -> [ImportClean]+ getRemovedImports allImps ftm= let + cleanedLines=DS.fromList $ map (\(L l _,_)->iflLine $ifsStart $ ghcSpanToLocation l) $ DM.elems ftm+ missingImps=filter (\(_,(L l imp,_))->not $ ideclImplicit imp || DS.member (iflLine $ifsStart $ ghcSpanToLocation l) cleanedLines) allImps+ in nubOrd $ map (\(_,(L l _,_))-> ImportClean (ghcSpanToLocation l) "") missingImps+ getFormatInfo :: FinalImportValue -> (Int,Int,Int,Int,Int)->(Int,Int,Int,Int,Int)+ getFormatInfo (L _ imp,_) (szSafe,szQualified,szPkg,szName,szAs)=let+ szSafe2=if ideclSafe imp then 5 else szSafe+ szQualified2=if ideclQualified imp then 10 else szQualified+ szPkg2=maybe szPkg (\p->max szPkg (3 + lengthFS p)) $ ideclPkgQual imp+ L _ mo=ideclName imp+ szName2=max szName (1 + lengthFS (moduleNameFS mo))+ szAs2=maybe szAs (\m->max szAs (3 + lengthFS (moduleNameFS m))) $ ideclAs imp+ in (szSafe2,szQualified2,szPkg2,szName2,szAs2)+ formatImport :: (Int,Int,Int,Int,Int)-> FinalImportValue -> ImportClean+ formatImport (szSafe,szQualified,szPkg,szName,szAs) (L loc imp,ns) =let+ st="import "+ saf=if ideclSafe imp then "safe " else T.justifyLeft szSafe ' ' ""+ qual=if ideclQualified imp then "qualified " else T.justifyLeft szQualified ' ' ""+ pkg=maybe (T.justifyLeft szPkg ' ' "") (\p->"\"" `mappend` T.pack (unpackFS p) `mappend` "\" ") $ ideclPkgQual imp+ L _ mo=ideclName imp+ nm=T.justifyLeft szName ' ' $ T.pack $ moduleNameString mo+ ast=maybe (T.justifyLeft szAs ' ' "") (\m->"as " `mappend` T.pack (moduleNameString m)) $ ideclAs imp+ nameList= T.intercalate ", " $ List.sortBy (comparing T.toLower) $ map buildName $ DM.assocs ns -- build explicit import list+ full=st `mappend` saf `mappend` qual `mappend` pkg `mappend` nm `mappend` ast `mappend` " (" `mappend` nameList `mappend` ")"+ in ImportClean (ghcSpanToLocation loc) full+ formatImports :: [FinalImportValue] -> [ImportClean]+ formatImports fivs = let+ formatInfo=foldr getFormatInfo (0,0,0,0,0) fivs+ in map (formatImport formatInfo) fivs+
test/Language/Haskell/BuildWrapper/APITest.hs view
@@ -85,3 +85,15 @@ let notes=Cabal.parseCabalMessages "test.cabal" "cabal.exe" s assertEqual 1 (length notes) assertEqual (BWNote BWError "Missing dependencies on foreign libraries:\n* Missing C libraries: tinfo, tinfo\n" (mkEmptySpan "test.cabal" 1 1)) (head notes) + let sx="cabal.exe: Missing dependencies on foreign libraries:\n* Missing C libraries: tinfo, tinfo\n" + let notesx=Cabal.parseCabalMessages "test.cabal" "cabal-dev.exe" sx + assertEqual 1 (length notesx) + assertEqual (BWNote BWError "Missing dependencies on foreign libraries:\n* Missing C libraries: tinfo, tinfo\n" (mkEmptySpan "test.cabal" 1 1)) (head notesx) + let s1="cabal: At least the following dependencies are missing:\npgsql -any, pgsql-simple -any, psql-simple -any\n" + let notes1=Cabal.parseCabalMessages "test.cabal" "cabal" s1 + assertEqual 1 (length notes1) + assertEqual (BWNote BWError "At least the following dependencies are missing:\npgsql -any, pgsql-simple -any, psql-simple -any\n" (mkEmptySpan "test.cabal" 1 1)) (head notes1) + let notes2=Cabal.parseCabalMessages "test.cabal" "cabal-dev" s1 + assertEqual 1 (length notes2) + assertEqual (BWNote BWError "At least the following dependencies are missing:\npgsql -any, pgsql-simple -any, psql-simple -any\n" (mkEmptySpan "test.cabal" 1 1)) (head notes2) +
+ test/Language/Haskell/BuildWrapper/CMDLongRunningTests.hs view
@@ -0,0 +1,205 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -F -pgmF htfpp #-}+-- |+-- Module : Language.Haskell.BuildWrapper.CMDTests+-- Author : JP Moresmau+-- Copyright : (c) JP Moresmau 2013+-- License : BSD3+-- +-- Maintainer : jpmoresmau@gmail.com+-- Stability : beta+-- Portability : portable+-- +-- Testing for long running operations+module Language.Haskell.BuildWrapper.CMDLongRunningTests where++import Language.Haskell.BuildWrapper.CMDTests ++import Language.Haskell.BuildWrapper.Base hiding (writeFile,readFile)++import Data.ByteString.Lazy ()+import Data.ByteString.Lazy.Char8()++import Data.Maybe+import Data.Char++import System.Directory+import System.FilePath+import System.Info++import Control.Monad+++import Data.Attoparsec+import Data.Aeson+import Data.Aeson.Parser+import qualified Data.ByteString.Char8 as BS+import Data.List+import System.Exit+import System.Process++import Test.Framework+import Test.HUnit (Assertion)+import System.IO (Handle, hPutStrLn, hFlush)+import Control.Concurrent (threadDelay)++test_NameDefsInScopeLongRunning :: Assertion+test_NameDefsInScopeLongRunning = do+ let api=cabalAPI+ root<-createTestProject+ synchronize api root False+ configure api root Source + let rel="src"</>"Main.hs"+ writeFile (root </> rel) $ unlines [ + "module Main where",+ "import B.D",+ "main=return $ map id \"toto\"",+ "data Type1=MkType1_1 Int"+ ] + build api root True Source+ synchronize api root False+ (inp,out,_,_)<-build1lr root rel+ (mtts,ns)<-(readResult out) :: IO (OpResult (Maybe [NameDef]))+ assertBool (isJust mtts)+ assertBool (not $ notesInError ns)+ let tts=fromJust mtts+ assertBool (NameDef "Main.main" [Function] (Just "IO [Char]") `elem` tts)+ assertBool (NameDef "B.D.fD" [Function] (Just "forall a. a") `elem` tts)+ assertBool (NameDef "Main.Type1" [Type] Nothing `elem` tts)+ assertBool (NameDef "Main.MkType1_1" [Constructor] (Just "Int -> Type1") `elem` tts)+ assertBool (NameDef "GHC.Types.Char" [Type] Nothing `elem` tts) + assertBool (NameDef "Main.Type2" [Type] Nothing `notElem` tts)+ threadDelay 1000000+ write api root rel $ unlines [ + "module Main where",+ "import B.D",+ "main=return $ map id \"toto\"",+ "data Type1=MkType1_1 Int",+ "data Type2=MkType2_1 Int"+ ]+ continue inp+ (mtts2,ns2)<-readResult out :: IO (OpResult (Maybe [NameDef])) + assertBool (not $ notesInError ns2)+ assertBool (isJust mtts2)+ let tts2=fromJust mtts2+ assertBool (NameDef "Main.Type1" [Type] Nothing `elem` tts2)+ assertBool (NameDef "Main.Type2" [Type] Nothing `elem` tts2)+ write api root rel $ unlines [ + "module Main where",+ "import B.D",+ "main=return $ map id \"toto\"",+ "data Type1=MkType1_1 Int",+ "data Type2=MkType2_1 Int2"+ ]+ continue inp+ (_,ns3)<-readResult out :: IO (OpResult (Maybe [NameDef])) + assertBool (notesInError ns3)+ threadDelay 1000000+ write api root rel $ unlines [ + "module Main where",+ "import B.D",+ "main=return $ map id \"toto\"",+ "data Type1=MkType1_1 Int",+ "data Type2=MkType2_1 Int"+ ]+ continue inp+ (mtts4,ns4)<-readResult out :: IO (OpResult (Maybe [NameDef])) + assertBool (not $ notesInError ns4)+ assertBool (isJust mtts4)+ let tts4=fromJust mtts4+ assertBool (NameDef "Main.Type1" [Type] Nothing `elem` tts4)+ assertBool (NameDef "Main.Type2" [Type] Nothing `elem` tts4)+ end inp+ +test_EvalLongRunning :: Assertion+test_EvalLongRunning = do+ let api=cabalAPI+ root<-createTestProject+ synchronize api root False+ configure api root Source + let rel="src"</>"Main.hs"+ writeFile (root </> rel) $ unlines [ + "module Main where",+ "import B.D",+ "main=return $ map id \"toto\"",+ "data Type1=MkType1_1 Int"+ ] + build api root True Source+ synchronize api root False+ (inp,out,_,_)<-build1lr root rel+ (mtts,ns)<-(readResult out) :: IO (OpResult (Maybe [NameDef]))+ assertBool (isJust mtts)+ assertBool (not $ notesInError ns) + eval inp "reverse \"toto\"" + s1<- readResult out :: IO (String)+ assertEqual "\"otot\"" s1+ eval inp "main" + s2<- readResult out :: IO (String)+ assertEqual "\"toto\"" s2 + eval inp "MkType1_1"+ s3<- readResult out :: IO (String)+ assertBool $ "No instance for" `isPrefixOf` s3 + end inp + +test_TokenTypesLongRunning :: Assertion+test_TokenTypesLongRunning = do+ let api=cabalAPI+ root<-createTestProject+ synchronize api root False+ configure api root Source + let rel="src"</>"Main.hs"+ writeFile (root </> rel) $ unlines [ + "module Main where",+ "import B.D",+ "main=return $ map id \"toto\"",+ "data Type1=MkType1_1 Int"+ ] + build api root True Source+ synchronize api root False+ (inp,out,_,_)<-build1lr root rel+ (mtts,ns)<-(readResult out) :: IO (OpResult (Maybe [NameDef]))+ assertBool (isJust mtts)+ assertBool (not $ notesInError ns) + tokenTypesLR inp+ (tts,nsErrors1)<-readResult out ::IO (OpResult [TokenDef])+ assertBool (null nsErrors1)+ assertBool (not $ null tts)+ continue inp+ (mtts2,ns2)<-readResult out :: IO (OpResult (Maybe [NameDef])) + assertBool (not $ notesInError ns2)+ assertBool (isJust mtts2)+ end inp+ +test_ThingAtPointLongRunning :: Assertion+test_ThingAtPointLongRunning = do+ let api=cabalAPI+ root<-createTestProject+ synchronize api root False+ configure api root Source + let rel="src"</>"Main.hs"+ writeFile (root </> rel) $ unlines [ + "module Main where",+ "import B.D",+ "main=return $ map id \"toto\"",+ "data Type1=MkType1_1 Int"+ ] + build api root True Source+ synchronize api root False+ (inp,out,_,_)<-build1lr root rel+ (mtts,ns)<-(readResult out) :: IO (OpResult (Maybe [NameDef]))+ assertBool (isJust mtts)+ assertBool (not $ notesInError ns) + tokenTypesLR inp+ (tts,nsErrors1)<-readResult out ::IO (OpResult [TokenDef])+ assertBool (null nsErrors1)+ assertBool (not $ null tts)+ tapLR inp 3 16+ (tap1,nsErrorsTap)<-readResult out :: IO (OpResult (Maybe ThingAtPoint))+ assertBool (null nsErrorsTap)+ assertBool $ isJust tap1+ assertEqual "map" (tapName $ fromJust tap1)+ continue inp+ (mtts2,ns2)<-readResult out :: IO (OpResult (Maybe [NameDef])) + assertBool (not $ notesInError ns2)+ assertBool (isJust mtts2)+ end inp
test/Language/Haskell/BuildWrapper/CMDTests.hs view
@@ -1,1985 +1,1932 @@-{-# LANGUAGE CPP, OverloadedStrings #-} -{-# OPTIONS_GHC -F -pgmF htfpp #-} --- | --- Module : Language.Haskell.BuildWrapper.CMDTests --- Author : JP Moresmau --- Copyright : (c) JP Moresmau 2011 --- License : BSD3 --- --- Maintainer : jpmoresmau@gmail.com --- Stability : beta --- Portability : portable --- --- Testing via the executable interface -module Language.Haskell.BuildWrapper.CMDTests where - -import Language.Haskell.BuildWrapper.Base hiding (writeFile,readFile) - -import Data.ByteString.Lazy () -import Data.ByteString.Lazy.Char8() - -import Data.Maybe -import Data.Char - -import System.Directory -import System.FilePath -import System.Info - -import Control.Monad - - -import Data.Attoparsec -import Data.Aeson -import Data.Aeson.Parser -import qualified Data.ByteString.Char8 as BS -import Data.List -import System.Exit -import System.Process - -import Test.Framework -import Test.HUnit (Assertion) -import System.IO (Handle, hPutStrLn, hFlush) -import Control.Concurrent (threadDelay) - -class APIFacade a where - synchronize :: a -> FilePath -> Bool -> IO (OpResult ([FilePath],[FilePath])) - synchronize1 :: a -> FilePath -> Bool -> FilePath -> IO (Maybe FilePath) - write :: a -> FilePath -> FilePath -> String -> IO () - configure :: a -> FilePath -> WhichCabal -> IO (OpResult Bool) - configureWithFlags :: a -> FilePath -> WhichCabal -> String -> IO (OpResult Bool) - build :: a -> FilePath -> Bool -> WhichCabal -> IO (OpResult BuildResult) - build1 :: a -> FilePath -> FilePath -> IO (OpResult (Maybe [NameDef])) - build1c :: a -> FilePath -> FilePath -> String -> IO (OpResult (Maybe [NameDef])) - getBuildFlags :: a -> FilePath -> FilePath -> IO (OpResult BuildFlags) - getOutline :: a -> FilePath -> FilePath -> IO (OpResult OutlineResult) - getTokenTypes :: a -> FilePath -> FilePath -> IO (OpResult [TokenDef]) - getOccurrences :: a -> FilePath -> FilePath -> String -> IO (OpResult [TokenDef]) - getThingAtPoint :: a -> FilePath -> FilePath -> Int -> Int -> IO (OpResult (Maybe ThingAtPoint)) - getLocals :: a -> FilePath -> FilePath -> Int -> Int -> Int -> Int -> IO (OpResult [ThingAtPoint]) - getNamesInScope :: a -> FilePath -> FilePath-> IO (OpResult (Maybe [String])) - getCabalDependencies :: a -> FilePath -> Maybe FilePath -> IO (OpResult [(FilePath,[CabalPackage])]) - getCabalComponents :: a -> FilePath -> IO (OpResult [CabalComponent]) - generateUsage :: a -> FilePath -> Bool -> CabalComponent -> IO (OpResult (Maybe [FilePath])) - cleanImports :: a -> FilePath -> FilePath -> Bool -> IO (OpResult [ImportClean]) - clean :: a -> FilePath -> Bool -> IO(Bool) - - -data CMDAPI=CMDAPI { - cabalExe :: String, - cabalOpts :: [String] - } - - - -instance APIFacade CMDAPI where - synchronize (CMDAPI c o) r ff= runAPI c r "synchronize" (["--force="++ show ff ] ++ cmdOpts o) - synchronize1 (CMDAPI c o) r ff fp= runAPI c r "synchronize1" (["--force="++show ff,"--file="++fp]++ cmdOpts o) - write (CMDAPI c _) r fp s= runAPI c r "write" ["--file="++fp,"--contents="++s] - configure (CMDAPI c o) r t= runAPI c r "configure" (["--cabaltarget="++ show t]++ cmdOpts o) - configureWithFlags (CMDAPI c o) r t fgs= runAPI c r "configure" (["--cabaltarget="++ show t,"--cabalflags="++ fgs]++ cmdOpts o) - build (CMDAPI c o) r b wc= runAPI c r "build" (["--output="++ show b,"--cabaltarget="++ show wc]++ cmdOpts o) - build1 (CMDAPI c _) r fp= runAPI c r "build1" ["--file="++fp] - build1c (CMDAPI c _) r fp ccn= runAPI c r "build1" ["--file="++fp,"--component="++ccn] - getBuildFlags (CMDAPI c _) r fp= runAPI c r "getbuildflags" ["--file="++fp] - getOutline (CMDAPI c _) r fp= runAPI c r "outline" ["--file="++fp] - getTokenTypes (CMDAPI c _) r fp= runAPI c r "tokentypes" ["--file="++fp] - getOccurrences (CMDAPI c _) r fp s= runAPI c r "occurrences" ["--file="++fp,"--token="++s] - getThingAtPoint (CMDAPI c _) r fp l cl= fmap removeLayoutTAP $ runAPI c r "thingatpoint" ["--file="++fp,"--line="++ show l,"--column="++ show cl] - getLocals (CMDAPI c _) r fp sl sc el ec= runAPI c r "locals" ["--file="++fp,"--sline="++ show sl,"--scolumn="++ show sc,"--eline="++ show el,"--ecolumn="++ show ec] - getNamesInScope (CMDAPI c _) r fp= runAPI c r "namesinscope" ["--file="++fp] - getCabalDependencies (CMDAPI c o) r mfp= runAPI c r "dependencies" ((maybe [] (\x->["--sandbox="++x]) mfp)++ cmdOpts o) - getCabalComponents (CMDAPI c _) r= runAPI c r "components" [] - generateUsage (CMDAPI c _) r retAll cc=runAPI c r "generateusage" ["--returnall="++ show retAll,"--cabalcomponent="++ cabalComponentName cc] - cleanImports (CMDAPI c _) r fp fo= runAPI c r "cleanimports" ["--file="++fp,"--format="++ show fo] - clean (CMDAPI c _) r e=runAPI c r "clean" ["--everything="++show e] - -build1lr :: FilePath- -> [Char] -> IO (Handle, Handle, Handle, ProcessHandle) -build1lr r fp= startAPIProcess r "build1" ["--file="++fp,"--longrunning=true"] - -cabalAPI= CMDAPI "cabal" [] - -exeExtension :: String -#ifdef mingw32_HOST_OS -exeExtension = "exe" -#else -exeExtension = "" -#endif - -test_SynchronizeAll :: Assertion -test_SynchronizeAll = do - let api=cabalAPI - root<-createTestProject - ((fps,dels),_)<-synchronize api root False - assertBool (not $ null fps) - assertBool (null dels) - assertEqual (testProjectName <.> ".cabal") (head fps) - assertBool (("src" </> "A.hs") `elem` fps) - assertBool (("src" </> "B" </> "C.hs") `elem` fps) - assertBool (("src" </> "Main.hs") `elem` fps) - assertBool (("src" </> "B" </> "D.hs") `elem` fps) - assertBool (("test" </> "Main.hs") `elem` fps) - assertBool (("test" </> "TestA.hs") `elem` fps) - -test_SynchronizeDelete :: Assertion -test_SynchronizeDelete = do - let api=cabalAPI - root<-createTestProject - ((fps0,dels0),_)<-synchronize api root False - assertBool (not $ null fps0) - assertBool (null dels0) - let new=root </> ".dist-buildwrapper" </> "New.hs" - writeFile new "module New where" - ex1<-doesFileExist new - assertBool ex1 - ((_,dels),_)<-synchronize api root False - assertBool (not $ null dels) - assertBool ("New.hs" `elem` dels) - ex2<-doesFileExist new - assertBool (not ex2) - - -test_SynchronizeExtraFiles :: Assertion -test_SynchronizeExtraFiles = do - let api=cabalAPI - root<-createTestProject - let extra=root </> "src" -- need to be in hs-source-dirs - writeFile (extra </> "a.txt") "contents" - let new=root </> ".dist-buildwrapper" </> "src" </> "a.txt" - ex1<-doesFileExist new - assertBool (not ex1) - ((fps,_),_)<-synchronize api root False - assertBool (("src" </> "a.txt") `elem` fps) - ex2<-doesFileExist new - assertBool ex2 - - -test_ConfigureErrors :: Assertion -test_ConfigureErrors = do - let api=cabalAPI - root<-createTestProject - (boolNoCabal,nsNoCabal)<- configure api root Target - assertBool (not boolNoCabal) - --assertEqual 0 (length nsNoCabal) - let bw=head nsNoCabal - assertEqual BWError (bwnStatus bw) - - synchronize api root False - (boolOK,nsOK)<-configure api root Target - assertBool boolOK - assertBool (null nsOK) - let cf=testCabalFile root - let cfn=takeFileName cf - writeFile cf $ unlines ["version:0.1", - "build-type: Simple"] - synchronize api root False - (bool1,nsErrors1)<-configure api root Target - assertBool (not bool1) - assertEqual 2 (length nsErrors1) - let (nsError1:nsError2:[])=nsErrors1 - assertEqual (BWNote BWError "No 'name' field.\n" (mkEmptySpan cfn 1 1)) nsError1 - assertEqual (BWNote BWError "No executables and no library found. Nothing to do.\n" (mkEmptySpan cfn 1 1)) nsError2 - writeFile cf $ unlines ["name: 4 P1", - "version:0.1", - "build-type: Simple"] - synchronize api root False - (bool2,nsErrors2)<-configure api root Target - assertBool (not bool2) - assertEqual 1 (length nsErrors2) - let (nsError3:[])=nsErrors2 - assertEqual (BWNote BWError "Parse of field 'name' failed.\n" (mkEmptySpan cfn 1 1)) nsError3 - writeFile cf $ unlines ["name: "++testProjectName, - "version:0.1", - "cabal-version: >= 1.8", - "build-type: Simple", - "", - "library", - " hs-source-dirs: src", - " exposed-modules: A", - " other-modules: B.C", - " build-depends: base, toto"] - synchronize api root False - (bool3,nsErrors3)<-configure api root Target - assertBool (not bool3) - assertEqual 1 (length nsErrors3) - let (nsError4:[])=nsErrors3 - assertEqual (BWNote BWError "At least the following dependencies are missing:\ntoto -any\n" (mkEmptySpan cfn 1 1)) nsError4 - - writeFile cf $ unlines ["name: "++testProjectName, - "version:0.1", - "cabal-version: >= 1.8", - "build-type: Simple", - "", - "library", - " hs-source-dirs: src", - " exposed-modules: A", - " other-modules: B.C", - " build-depends: base, toto, titi"] - synchronize api root False - (bool4,nsErrors4)<-configure api root Target - assertBool (not bool4) - assertEqual 1 (length nsErrors4) - let (nsError5:[])=nsErrors4 - assertEqual (BWNote BWError "At least the following dependencies are missing:\ntiti -any, toto -any\n" (mkEmptySpan cfn 1 1)) nsError5 - (BuildResult bool4b _,nsErrors4b)<-build api root False Source - assertBool (not bool4b) - assertEqual 1 (length nsErrors4b) - let (nsError5b:[])=nsErrors4b - assertEqual (BWNote BWError "At least the following dependencies are missing:\ntiti -any, toto -any\n" (mkEmptySpan cfn 1 1)) nsError5b - writeFile cf $ unlines ["name: "++testProjectName, - "version:0.1", - "cabal-version: >= 1.8", - "build-type: Simple", - "", - "executable BWTest", - " hs-source-dirs: src", - " other-modules: B.D", - " build-depends: base"] - synchronize api root False - (bool5,nsErrors5)<-configure api root Target - assertBool (not bool5) - assertEqual 1 (length nsErrors5) - let (nsError6:[])=nsErrors5 - assertEqual (BWNote BWError "No 'Main-Is' field found for executable BWTest\n" (mkEmptySpan cfn 1 1)) nsError6 - - - -test_ConfigureWarnings :: Assertion -test_ConfigureWarnings = do - let api=cabalAPI - root<-createTestProject - synchronize api root False - let cf=testCabalFile root - let cfn=takeFileName cf - writeFile cf $ unlines ["name: "++testProjectName, - "version:0.1", - "cabal-version: >= 1.8", - "build-type: Simple", - "field1: toto", - "", - "library", - " hs-source-dirs: src", - " exposed-modules: A", - " other-modules: B.C", - " build-depends: base"] - synchronize api root False - (bool1,ns1)<- configure api root Target - assertBool bool1 - assertEqual 1 (length ns1) - let (nsWarning1:[])=ns1 - assertEqual (BWNote BWWarning "Unknown fields: field1 (line 5)\nFields allowed in this section:\nname, version, cabal-version, build-type, license, license-file,\ncopyright, maintainer, build-depends, stability, homepage,\npackage-url, bug-reports, synopsis, description, category, author,\ntested-with, data-files, data-dir, extra-source-files,\nextra-tmp-files\n" (mkEmptySpan cfn 5 1)) nsWarning1 - writeFile cf $ unlines ["name: "++testProjectName, - "version:0.1", - "build-type: Simple", - "", - "library", - " hs-source-dirs: src", - " exposed-modules: A", - " other-modules: B.C", - " build-depends: base"] - synchronize api root False - (bool2,ns2)<- configure api root Target - assertBool bool2 - assertEqual 1 (length ns2) - let (nsWarning2:[])=ns2 - assertEqual (BWNote BWWarning "A package using section syntax must specify at least\n'cabal-version: >= 1.2'.\n" (mkEmptySpan cfn 1 1)) nsWarning2 - writeFile cf $ unlines ["name: "++testProjectName, - "version:0.1", - "cabal-version: >= 1.2", - "", - "library", - " hs-source-dirs: src", - " exposed-modules: A", - " other-modules: B.C", - " build-depends: base"] - writeFile (takeDirectory cf </> "Setup.hs") $ unlines ["import Distribution.Simple", - "main = defaultMain"] - synchronize api root False - (bool3,ns3)<- configure api root Target - assertBool bool3 - assertEqual 1 (length ns3) - let (nsWarning3:[])=ns3 - assertEqual (BWNote BWWarning "No 'build-type' specified. If you do not need a custom Setup.hs or\n./configure script then use 'build-type: Simple'.\n" (mkEmptySpan cfn 1 1)) nsWarning3 - - -test_BuildErrors :: Assertion -test_BuildErrors = do - let api=cabalAPI - root<-createTestProject - synchronize api root False - (boolOKc,nsOKc)<-configure api root Target - assertBool boolOKc - assertBool (null nsOKc) - (BuildResult boolOK _,nsOK)<-build api root False Source - assertBool boolOK - assertBool (null nsOK) - let rel="src"</>"A.hs" - -- write source file - - writeFile (root </> rel) $ unlines ["module A where","import toto","fA=undefined"] - synchronize1 api root True rel - (bool11,nsErrors11)<-build1 api root rel - assertBool (isNothing bool11) - assertBool (not $ null nsErrors11) - let (nsError11:[])=nsErrors11 - assertEqualNotesWithoutSpaces "not proper error 1_1" (BWNote BWError "parse error on input `toto'\n" (mkEmptySpan rel 2 8)) nsError11 - (BuildResult bool1 _,nsErrors1)<-build api root False Source - assertBool (not bool1) - assertBool (not $ null nsErrors1) - let (nsError1:[])=nsErrors1 - assertEqualNotesWithoutSpaces "not proper error 1" (BWNote BWError "parse error on input `toto'\n" (mkEmptySpan rel 2 8)) nsError1 - - -- write file and synchronize - writeFile (root </> "src"</>"A.hs")$ unlines ["module A where","import Toto","fA=undefined"] - mf2<-synchronize1 api root True rel - assertBool (isJust mf2) - (BuildResult bool2 _,nsErrors2)<-build api root False Source - assertBool (not bool2) - assertBool (not $ null nsErrors2) - let (nsError2:[])=nsErrors2 - assertEqualNotesWithoutSpaces "not proper error 2" (BWNote BWError "Could not find module `Toto':\n Use -v to see a list of the files searched for.\n" (mkEmptySpan rel 2 8)) nsError2 - synchronize1 api root True rel - (bool21,nsErrors21)<-build1 api root rel - assertBool (isNothing bool21) - assertBool (not $ null nsErrors21) - let (nsError21:[])=nsErrors21 - assertEqualNotesWithoutSpaces "not proper error 2_1" (BWNote BWError "Could not find module `Toto':\n Use -v to see a list of the files searched for.\n" (mkEmptySpan rel 2 8)) nsError21 - (_,nsErrors3f)<- getBuildFlags api root ("src"</>"A.hs") - assertBool (null nsErrors3f) - (bool3,nsErrors3)<-build1 api root rel - assertBool (isNothing bool3) - assertBool (not $ null nsErrors3) - let (nsError3:[])=nsErrors3 - assertEqualNotesWithoutSpaces "not proper error 3" (BWNote BWError "Could not find module `Toto':\n Use -v to see a list of the files searched for." (mkEmptySpan rel 2 8)) nsError3 - - - -test_BuildWarnings :: Assertion -test_BuildWarnings = do - let api=cabalAPI - root<-createTestProject - synchronize api root False - --let cf=testCabalFile root - writeFile (root </> (testProjectName <.> ".cabal")) $ unlines ["name: "++testProjectName, - "version:0.1", - "cabal-version: >= 1.8", - "build-type: Simple", - "", - "library", - " hs-source-dirs: src", - " exposed-modules: A", - " build-depends: base", - " ghc-options: -Wall"] - --let srcF=root </> "src" - (boolOK,nsOK)<-configure api root Source - assertBool boolOK - assertBool (null nsOK) - let rel="src"</>"A.hs" - writeFile (root </> rel) $ unlines ["module A where","import Data.List","fA=undefined"] - mf2<-synchronize1 api root True rel - assertBool (isJust mf2) - (BuildResult bool1 fps1,nsErrors1)<-build api root False Source - assertBool bool1 - assertBool (not $ null nsErrors1) - assertBool (rel `elem` fps1) - let (nsError1:nsError2:[])=nsErrors1 - assertEqualNotesWithoutSpaces "not proper error 1" (BWNote BWWarning "The import of `Data.List' is redundant\n except perhaps to import instances from `Data.List'\n To import instances alone, use: import Data.List()\n" (mkEmptySpan rel 2 1)) nsError1 - assertEqualNotesWithoutSpaces "not proper error 2" (BWNote BWWarning "Top-level binding with no type signature:\n fA :: forall a. a\n" (mkEmptySpan rel 3 1)) nsError2 - (_,nsErrors3f)<-getBuildFlags api root rel - assertBool (null nsErrors3f) - (bool3,nsErrors3)<-build1 api root rel - assertBool (isJust bool3) - assertEqual 2 (length nsErrors3) - let (nsError3:nsError4:[])=nsErrors3 - assertEqualNotesWithoutSpaces "not proper error 3" (BWNote BWWarning "The import of `Data.List' is redundant\n except perhaps to import instances from `Data.List'\n To import instances alone, use: import Data.List()" (mkEmptySpan rel 2 1)) nsError3 - assertEqualNotesWithoutSpaces "not proper error 4" (BWNote BWWarning "Top-level binding with no type signature:\n fA :: forall a. a" (mkEmptySpan rel 3 1)) nsError4 - writeFile (root </> rel) $ unlines ["module A where","pats:: String -> String","pats a=reverse a","fB:: String -> Char","fB pats=head pats"] - mf3<-synchronize1 api root True rel - assertBool (isJust mf3) - (bool4,nsErrors4)<-build1 api root rel - assertBool (isJust bool4) - assertBool (not $ null nsErrors4) - let (nsError5:[])=nsErrors4 - assertEqualNotesWithoutSpaces "not proper error 5" (BWNote BWWarning ("This binding for `pats' shadows the existing binding\n defined at "++rel++":3:1") (mkEmptySpan rel 4 5)) nsError5 - - -test_BuildOutput :: Assertion -test_BuildOutput = do - let api=cabalAPI - root<-createTestProject - synchronize api root False - build api root True Source - let exeN=case os of - "mingw32" -> addExtension testProjectName "exe" - _ -> testProjectName - let exeF=root </> ".dist-buildwrapper" </> "dist" </> "build" </> testProjectName </> exeN - exeE1<-doesFileExist exeF - assertBool exeE1 - removeFile exeF - exeE2<-doesFileExist exeF - assertBool (not exeE2) - build api root False Source - exeE3<-doesFileExist exeF - assertBool (not exeE3) - --- | http://hackage.haskell.org/trac/ghc/ticket/7380#comment:1 : -O2 is removed from the options -test_BuildO2 :: Assertion -test_BuildO2 = do - let api=cabalAPI - root<-createTestProject - write api root (testProjectName <.> ".cabal") $ unlines ["name: "++testProjectName, - "version:0.1", - "cabal-version: >= 1.8", - "build-type: Simple", - "", - "library", - " hs-source-dirs: src", - " exposed-modules: A", - " other-modules: B.C", - " build-depends: base", - "", - "executable BWTest", - " hs-source-dirs: src", - " main-is: Main.hs", - " other-modules: B.D", - " build-depends: base", - " ghc-options: -O2", - "", - "test-suite BWTest-test", - " type: exitcode-stdio-1.0", - " hs-source-dirs: test", - " main-is: Main.hs", - " other-modules: TestA", - " build-depends: base", - "" - ] - configure api root Target - let rel="src"</>"Main.hs" - writeFile (root </> rel) $ unlines ["module Main where","main :: IO()","main= putStrLn \"Hello World\""] - synchronize api root False - (ns, _)<-build1 api root rel - assertBool (isJust ns) - - -test_ModuleNotInCabal :: Assertion -test_ModuleNotInCabal = do - let api=cabalAPI - root<-createTestProject - synchronize api root False - let rel="src"</>"A.hs" - writeFile (root </> rel) $ unlines ["module A where","import Auto","fA=undefined"] - let rel2="src"</>"Auto.hs" - writeFile (root </> rel2) $ unlines ["module Auto where","fAuto=undefined"] - synchronize api root False - (BuildResult bool1 _,nsErrors1)<-build api root True Source - assertBool bool1 - assertBool (null nsErrors1) - (_,nsErrors2f)<-getBuildFlags api root rel - assertBool (null nsErrors2f) - (bool2, nsErrors2)<-build1 api root rel - assertBool (isJust bool2) - assertBool (null nsErrors2) - - - - -test_Outline :: Assertion -test_Outline = do - let api=cabalAPI - root<-createTestProject - synchronize api root False - let rel="src"</>"A.hs" - -- use api to write temp file - write api root rel $ unlines [ - "{-# LANGUAGE RankNTypes, TypeSynonymInstances, TypeFamilies #-}", - "", - "module Module1 where", - "", - "import Data.Char", - "", - "-- Declare a list-like data family", - "data family XList a", - "", - "-- Declare a list-like instance for Char", - "data instance XList Char = XCons !Char !(XList Char) | XNil", - "", - "type family Elem c", - "", - "type instance Elem [e] = e", - "", - "testfunc1 :: [Char]", - "testfunc1=reverse \"test\"", - "", - "testfunc1bis :: String -> [Char]", - "testfunc1bis []=\"nothing\"", - "testfunc1bis s=reverse s", - "", - "testMethod :: forall a. (Num a) => a -> a -> a", - "testMethod a b=", - " let e=a + (fromIntegral $ length testfunc1)", - " in e * 2", - "", - "class ToString a where", - " toString :: a -> String", - "", - "instance ToString String where", - " toString = id", - "", - "type Str=String", - "", - "data Type1=MkType1_1 Int", - " | MkType1_2 {", - " mkt2_s :: String,", - " mkt2_i :: Int", - " }" ] - (_,nsErrors3f)<-getBuildFlags api root rel - assertBool (null nsErrors3f) - (OutlineResult defs es is,nsErrors1)<-getOutline api root rel - assertBool (null nsErrors1) - let expected=[ - mkOutlineDefWithChildren "XList" [Data,Family] (InFileSpan (InFileLoc 8 1)(InFileLoc 8 20)) [] - ,mkOutlineDefWithChildren "XList Char" [Data,Instance] (InFileSpan (InFileLoc 11 1)(InFileLoc 11 60)) [ - mkOutlineDef "XCons" [Constructor] (InFileSpan (InFileLoc 11 28)(InFileLoc 11 53)) - ,mkOutlineDef "XNil" [Constructor] (InFileSpan (InFileLoc 11 56)(InFileLoc 11 60)) - ] - ,mkOutlineDef "Elem" [Type,Family] (InFileSpan (InFileLoc 13 1)(InFileLoc 13 19)) - ,mkOutlineDef "Elem [e]" [Type,Instance] (InFileSpan (InFileLoc 15 1)(InFileLoc 15 27)) - ,OutlineDef "testfunc1" [Function] (InFileSpan (InFileLoc 17 1)(InFileLoc 18 25)) [] (Just "[Char]") Nothing - ,OutlineDef "testfunc1bis" [Function] (InFileSpan (InFileLoc 20 1)(InFileLoc 22 25)) [] (Just "String -> [Char]") Nothing - ,OutlineDef "testMethod" [Function] (InFileSpan (InFileLoc 24 1)(InFileLoc 27 13)) [] (Just "forall a . (Num a) => a -> a -> a") Nothing - ,mkOutlineDefWithChildren "ToString" [Class] (InFileSpan (InFileLoc 29 1)(InFileLoc 32 0)) [ - mkOutlineDef "toString" [Function] (InFileSpan (InFileLoc 30 5)(InFileLoc 30 28)) - ] - ,mkOutlineDefWithChildren "ToString String" [Instance] (InFileSpan (InFileLoc 32 1)(InFileLoc 35 0)) [ - mkOutlineDef "toString" [Function] (InFileSpan (InFileLoc 33 5)(InFileLoc 33 18)) - ] - ,OutlineDef "Str" [Type] (InFileSpan (InFileLoc 35 1)(InFileLoc 35 16)) [] (Just "String") Nothing - ,mkOutlineDefWithChildren "Type1" [Data] (InFileSpan (InFileLoc 37 1)(InFileLoc 41 10)) [ - mkOutlineDef "MkType1_1" [Constructor] (InFileSpan (InFileLoc 37 12)(InFileLoc 37 25)) - ,mkOutlineDefWithChildren "MkType1_2" [Constructor] (InFileSpan (InFileLoc 38 7)(InFileLoc 41 10)) [ - mkOutlineDef "mkt2_s" [Field] (InFileSpan (InFileLoc 39 9)(InFileLoc 39 25)) - ,mkOutlineDef "mkt2_i" [Field] (InFileSpan (InFileLoc 40 9)(InFileLoc 40 22)) - - ] - - ] - ] - assertEqual (length expected) (length defs) - mapM_ (uncurry (assertEqual)) (zip expected defs) - assertEqual [] es - assertEqual [ImportDef "Data.Char" Nothing (InFileSpan (InFileLoc 5 1)(InFileLoc 5 17)) False False "" Nothing] is - - -test_OutlineComments :: Assertion -test_OutlineComments= do - let api=cabalAPI - root<-createTestProject - synchronize api root False - let rel="src"</>"A.hs" - -- use api to write temp file - write api root rel $ unlines [ - "{-# LANGUAGE RankNTypes, TypeSynonymInstances, TypeFamilies #-}", - "", - "module Module1 where", - "", - "import Data.Char", - "", - "-- testFunc1 comment", - "testfunc1 :: [Char]", - "testfunc1=reverse \"test\"", - "", - "-- | testFunc1bis haddock", - "testfunc1bis :: String -> [Char]", - "testfunc1bis []=\"nothing\"", - "testfunc1bis s=reverse s", - "", - "-- | testMethod", - "-- haddock", - "testMethod :: forall a. (Num a) => a -> a -> a", - "testMethod a b=", - " let e=a + (fromIntegral $ length testfunc1)", - " in e * 2", - "", - "class ToString a where", - " toString :: a -> String -- ^ toString comment", - "", - "-- | Str haddock", - "type Str=String", - "", - "-- | Type1 haddock", - "data Type1=MkType1_1 Int -- ^ MkType1 comment", - " | MkType1_2 {", - " mkt2_s :: String,", - " mkt2_i :: Int", - " }" ] - (_,nsErrors3f)<-getBuildFlags api root rel - assertBool (null nsErrors3f) - (OutlineResult defs es is,nsErrors1)<-getOutline api root rel - assertBool (null nsErrors1) - let expected=[ - OutlineDef "testfunc1" [Function] (InFileSpan (InFileLoc 8 1)(InFileLoc 9 25)) [] (Just "[Char]") Nothing - ,OutlineDef "testfunc1bis" [Function] (InFileSpan (InFileLoc 12 1)(InFileLoc 14 25)) [] (Just "String -> [Char]") (Just "testFunc1bis haddock") - ,OutlineDef "testMethod" [Function] (InFileSpan (InFileLoc 18 1)(InFileLoc 21 13)) [] (Just "forall a . (Num a) => a -> a -> a") (Just "testMethod\n haddock") - ,mkOutlineDefWithChildren "ToString" [Class] (InFileSpan (InFileLoc 23 1)(InFileLoc 27 0)) [ - OutlineDef "toString" [Function] (InFileSpan (InFileLoc 24 5)(InFileLoc 24 28)) [] Nothing (Just "toString comment") - ] - ,OutlineDef "Str" [Type] (InFileSpan (InFileLoc 27 1)(InFileLoc 27 16)) [] (Just "String") (Just "Str haddock") - ,OutlineDef "Type1" [Data] (InFileSpan (InFileLoc 30 1)(InFileLoc 34 10)) [ - OutlineDef "MkType1_1" [Constructor] (InFileSpan (InFileLoc 30 12)(InFileLoc 30 25)) [] Nothing (Just "MkType1 comment") - ,mkOutlineDefWithChildren "MkType1_2" [Constructor] (InFileSpan (InFileLoc 31 7)(InFileLoc 34 10)) [ - mkOutlineDef "mkt2_s" [Field] (InFileSpan (InFileLoc 32 9)(InFileLoc 32 25)) - ,mkOutlineDef "mkt2_i" [Field] (InFileSpan (InFileLoc 33 9)(InFileLoc 33 22)) - - ] - - ] Nothing (Just "Type1 haddock") - ] - assertEqual (length expected) (length defs) - mapM_ (uncurry (assertEqual )) (zip expected defs) - assertEqual [] es - assertEqual [ImportDef "Data.Char" Nothing (InFileSpan (InFileLoc 5 1)(InFileLoc 5 17)) False False "" Nothing] is - - -test_OutlinePreproc :: Assertion -test_OutlinePreproc = do - let api=cabalAPI - root<-createTestProject - synchronize api root False - let rel="src"</>"A.hs" - write api root (testProjectName <.> ".cabal") $ unlines ["name: "++testProjectName, - "version:0.1", - "cabal-version: >= 1.8", - "build-type: Simple", - "", - "library", - " hs-source-dirs: src", - " exposed-modules: A", - " build-depends: base", - " extensions: CPP", - " ghc-options: -Wall", - " cpp-options: -DCABAL_VERSION=112"] - configure api root Target - -- use api to write temp file - write api root rel $ unlines [ - "{-# LANGUAGE CPP #-}", - "", - "module Module1 where", - "", - "#if CABAL_VERSION > 110", - "testfunc1=reverse \"test\"", - "#endif", - "" - ] - (_,nsErrors3f)<-getBuildFlags api root rel - assertBool (null nsErrors3f) - (OutlineResult defs1 _ _,nsErrors1)<-getOutline api root rel - assertBool (null nsErrors1) - let expected1=[ - mkOutlineDef "testfunc1" [Function] (InFileSpan (InFileLoc 6 1)(InFileLoc 6 25)) - ] - assertEqual (length expected1) (length defs1) - mapM_ (uncurry (assertEqual )) (zip expected1 defs1) - write api root rel $ unlines [ - "{-# LANGUAGE CPP #-}", - "", - "module Module1 where", - "", - "data Name", - " = Ident String -- ^ /varid/ or /conid/.", - " | Symbol String -- ^ /varsym/ or /consym/", - "#ifdef __GLASGOW_HASKELL__", - " deriving (Eq,Ord,Show,Typeable,Data)", - "#else", - " deriving (Eq,Ord,Show)", - "#endif", - "" - ] - (OutlineResult defs2 _ _,nsErrors2)<-getOutline api root rel - assertBool (null nsErrors2) - let expected2=[ - mkOutlineDefWithChildren "Name" [Data] (InFileSpan (InFileLoc 5 1)(InFileLoc 9 38)) [ - OutlineDef "Ident" [Constructor] (InFileSpan (InFileLoc 6 6)(InFileLoc 6 18)) [] Nothing (Just "/varid/ or /conid/."), - OutlineDef "Symbol" [Constructor] (InFileSpan (InFileLoc 7 6)(InFileLoc 7 19)) [] Nothing (Just "/varsym/ or /consym/") - ] - ] - assertEqual (length expected2) (length defs2) - mapM_ (uncurry (assertEqual )) (zip expected2 defs2) - write api root rel $ unlines [ - "{-# LANGUAGE CPP #-}", - "", - "module Module1 where", - "", - "#ifdef __GLASGOW_HASKELL__", - "testfunc1=reverse \"test\"", - "#else", - "testfunc2=reverse \"test\"", - "#endif", - "" - ] - (OutlineResult defs3 _ _,nsErrors3)<-getOutline api root rel - assertBool (null nsErrors3) - let expected3=[ - mkOutlineDef "testfunc1" [Function] (InFileSpan (InFileLoc 6 1)(InFileLoc 6 25)) - ] - assertEqual (length expected3) (length defs3) - mapM_ (uncurry (assertEqual )) (zip expected3 defs3) - - - -test_OutlineLiterate :: Assertion -test_OutlineLiterate = do - let api=cabalAPI - root<-createTestProject - synchronize api root False - let rel="src"</>"A.lhs" - -- use api to write temp file - write api root rel $ unlines [ - "comment 1", - "", - "> module Module1 where", - "", - "", - "> testfunc1=reverse \"test\"", - "", - "" - ] - (_,nsErrors3f)<-getBuildFlags api root rel - assertBool (null nsErrors3f) - (OutlineResult defs1 _ _,nsErrors1)<-getOutline api root rel - assertBool (null nsErrors1) - let expected1=[ - mkOutlineDef "testfunc1" [Function] (InFileSpan (InFileLoc 6 3)(InFileLoc 6 27)) - ] - assertEqual (length expected1) (length defs1) - mapM_ (uncurry (assertEqual)) (zip expected1 defs1) - - -test_OutlineImportExport :: Assertion -test_OutlineImportExport = do - let api=cabalAPI - root<-createTestProject - synchronize api root False - let rel="src"</>"A.hs" - -- use api to write temp file - write api root rel $ unlines [ - "module Module1 (dummy,module Data.Char,MkTest(..)) where", - "", - "import Data.Char", - "import Data.Map as DM (empty) ", - "import Data.List hiding (orderBy,groupBy)", - "import qualified Data.Maybe (Maybe(Just))" - ] - (_,nsErrors3f)<-getBuildFlags api root rel - assertBool (null nsErrors3f) - (OutlineResult _ es is,nsErrors1)<-getOutline api root rel - assertBool (null nsErrors1) - let exps=[ - ExportDef "dummy" IEVar (InFileSpan (InFileLoc 1 17)(InFileLoc 1 22)) [], - ExportDef "Data.Char" IEModule (InFileSpan (InFileLoc 1 23)(InFileLoc 1 39)) [], - ExportDef "MkTest" IEThingAll (InFileSpan (InFileLoc 1 40)(InFileLoc 1 50)) [] - ] - mapM_ (uncurry (assertEqual)) (zip exps es) - let imps=[ - ImportDef "Data.Char" Nothing (InFileSpan (InFileLoc 3 1)(InFileLoc 3 17)) False False "" Nothing, - ImportDef "Data.Map" Nothing (InFileSpan (InFileLoc 4 1)(InFileLoc 4 30)) False False "DM" (Just [ImportSpecDef "empty" IEVar (InFileSpan (InFileLoc 4 24)(InFileLoc 4 29)) []]), - ImportDef "Data.List" Nothing (InFileSpan (InFileLoc 5 1)(InFileLoc 5 42)) False True "" (Just [ImportSpecDef "orderBy" IEVar (InFileSpan (InFileLoc 5 26)(InFileLoc 5 33)) [],ImportSpecDef "groupBy" IEVar (InFileSpan (InFileLoc 5 34)(InFileLoc 5 41)) []]), - ImportDef "Data.Maybe" Nothing (InFileSpan (InFileLoc 6 1)(InFileLoc 6 42)) True False "" (Just [ImportSpecDef "Maybe" IEThingWith (InFileSpan (InFileLoc 6 30)(InFileLoc 6 41)) ["Just"]]) - ] - mapM_ (uncurry (assertEqual)) (zip imps is) - - - -test_OutlineMultiParam :: Assertion -test_OutlineMultiParam = do - let api=cabalAPI - root<-createTestProject - synchronize api root False - let rel="src"</>"A.hs" - write api root rel $ unlines [ - "{-# LANGUAGE MultiParamTypeClasses #-}", - "module A where", - "", - "class C a b", - " where", - " c :: a -> b" - ] - let rel2="src"</>"B"</>"C.hs" - write api root rel2 $ unlines [ - "module B.C where", - "", - "import A", - "myC ::", - " (C a b)", - " => ", - " a -> b", - "myC = c" - ] - (_,nsErrors3f)<-getBuildFlags api root rel2 - assertBool (null nsErrors3f) - (OutlineResult ors _ _,nsErrors1)<-getOutline api root rel2 - assertBool (null nsErrors1) - assertBool (not $ null ors) - - -test_OutlineOperator :: Assertion -test_OutlineOperator = do - let api=cabalAPI - root<-createTestProject - synchronize api root False - let rel="src"</>"A.hs" - write api root rel $ unlines [ - "{-# LANGUAGE MultiParamTypeClasses #-}", - "module A ( Collection (", - " (>-)", - " )", - " )where", - " infixl 5 >-", - " class Collection a where", - " (>-) :: Eq b => a b -> a b -> a b" - ] - (_,nsErrors3f)<-getBuildFlags api root rel - assertBool (null nsErrors3f) - (OutlineResult ors _ _,nsErrors1)<-getOutline api root rel - assertBool (null nsErrors1) - assertBool (not $ null ors) - -test_OutlinePatternGuards :: Assertion -test_OutlinePatternGuards = do - let api=cabalAPI - root<-createTestProject - synchronize api root False - let rel="src"</>"A.hs" - write api root rel $ unlines [ - "module A", - " where", - "toto o | Just s<-o=s", - "toto _=\"\" " - ] - (_,nsErrors3f)<-getBuildFlags api root rel - assertBool (null nsErrors3f) - (bool3,nsErrors3)<-build1 api root rel - assertBool (isJust bool3) - assertBool (not (any (\ x -> BWError == bwnStatus x) nsErrors3)) - (OutlineResult ors _ _,nsErrors1)<-getOutline api root rel - assertBool (null nsErrors1) - assertBool (not $ null ors) - - -test_OutlineExtension :: Assertion -test_OutlineExtension = do - let api=cabalAPI - root<-createTestProject - let cf=testCabalFile root - writeFile cf $ unlines ["name: "++testProjectName, - "version:0.1", - "cabal-version: >= 1.8", - "build-type: Simple", - "", - "library", - " hs-source-dirs: src", - " exposed-modules: A", - " other-modules: B.C", - " build-depends: base", - " extensions: EmptyDataDecls"] - let rel="src"</>"A.hs" - write api root rel $ unlines [ - "module A", - " where", - "data B" - ] - synchronize api root False - configure api root Source - (_,nsErrors3f)<-getBuildFlags api root rel - assertBool (null nsErrors3f) - (bool3,nsErrors3)<-build1 api root rel - assertBool (isJust bool3) - assertBool (not (any (\ x -> BWError == bwnStatus x) nsErrors3)) - (OutlineResult ors _ _,nsErrors1)<-getOutline api root rel - assertBool (null nsErrors1) - assertBool (not $ null ors) - - -test_OutlineOptions :: Assertion -test_OutlineOptions = do - let api=cabalAPI - root<-createTestProject - synchronize api root False - let rel="src"</>"A.hs" - write api root rel $ unlines [ - "{-# OPTIONS -XMultiParamTypeClasses -XTupleSections -XRank2Types -XScopedTypeVariables -XTypeOperators #-}", - "module A where", - "-- MultiParamTypeClasses", - "class C a b", - "-- TupleSections", - "test1 = ((),)", - "-- Rank2Types", - "test2 :: (forall a . a) -> b", - "test2 a = undefined", - "-- TypeOperators", - "type a :-: b = (a,b)", - "-- ScopedTypeVariables", - "test3 :: forall a . a -> a", - "test3 x = x :: a" - ] - (_,nsErrors3f)<-getBuildFlags api root rel - assertBool (null nsErrors3f) - (bool3,nsErrors3)<-build1 api root rel - assertBool (isJust bool3) - assertBool (not (any (\ x -> BWError == bwnStatus x) nsErrors3)) - (OutlineResult ors _ _,nsErrors1)<-getOutline api root rel - assertBool (null nsErrors1) - assertBool (not $ null ors) - - -test_PreviewTokenTypes :: Assertion -test_PreviewTokenTypes = do - let api=cabalAPI - root<-createTestProject - synchronize api root False - configure api root Target - let rel="src"</>"Main.hs" - write api root rel $ unlines [ - "{-# LANGUAGE TemplateHaskell,CPP #-}", - "-- a comment", - "module Main where", - "", - "main :: IO (Int)", - "main = do" , - " putStr ('h':\"ello Prefs!\")", - " return (2 + 2)", - "", - "#if USE_TH", - "$( derive makeTypeable ''Extension )", - "#endif", - "" - ] - (tts,nsErrors1)<-getTokenTypes api root rel - assertBool (null nsErrors1) - let expectedS="[{\"P\":[1,1,37]},{\"C\":[2,1,13]},{\"K\":[3,1,7]},{\"IC\":[3,8,12]},{\"K\":[3,13,18]},{\"IV\":[5,1,5]},{\"S\":[5,6,8]},{\"IC\":[5,9,11]},{\"SS\":[5,12]},{\"IC\":[5,13,16]},{\"SS\":[5,16]},{\"IV\":[6,1,5]},{\"S\":[6,6]},{\"K\":[6,8,10]},{\"IV\":[7,9,15]},{\"SS\":[7,16]},{\"LC\":[7,17,20]},{\"S\":[7,20]},{\"LS\":[7,21,34]},{\"SS\":[7,34]},{\"IV\":[8,9,15]},{\"SS\":[8,16]},{\"LI\":[8,17]},{\"VS\":[8,19]},{\"LI\":[8,21]},{\"SS\":[8,22]},{\"PP\":[10,1,11]},{\"TH\":[11,1,3]},{\"IV\":[11,4,10]},{\"IV\":[11,11,23]},{\"TH\":[11,24,26]},{\"IC\":[11,26,35]},{\"SS\":[11,36]},{\"PP\":[12,1,7]}]" - assertEqual expectedS (encode $ toJSON tts) - -test_PreviewTokenTypesLine :: Assertion -test_PreviewTokenTypesLine = do - let api=cabalAPI - root<-createTestProject - synchronize api root False - configure api root Target - let rel="src"</>"Main.hs" - write api root rel $ unlines [ - "{-# LINE 42 \"Foo.vhs\" #-}", - "-- a comment", - "module Main where", - "", - "main :: IO (Int)", - "main = do" , - " putStr ('h':\"ello Prefs!\")", - " return (2 + 2)", - "", - "#if USE_TH", - "$( derive makeTypeable ''Extension )", - "#endif", - "" - ] - (tts,nsErrors1)<-getTokenTypes api root rel - assertBool (null nsErrors1) - let expectedS="[{\"P\":[1,1,26]},{\"C\":[2,1,13]},{\"K\":[3,1,7]},{\"IC\":[3,8,12]},{\"K\":[3,13,18]},{\"IV\":[5,1,5]},{\"S\":[5,6,8]},{\"IC\":[5,9,11]},{\"SS\":[5,12]},{\"IC\":[5,13,16]},{\"SS\":[5,16]},{\"IV\":[6,1,5]},{\"S\":[6,6]},{\"K\":[6,8,10]},{\"IV\":[7,9,15]},{\"SS\":[7,16]},{\"LC\":[7,17,20]},{\"S\":[7,20]},{\"LS\":[7,21,34]},{\"SS\":[7,34]},{\"IV\":[8,9,15]},{\"SS\":[8,16]},{\"LI\":[8,17]},{\"VS\":[8,19]},{\"LI\":[8,21]},{\"SS\":[8,22]},{\"PP\":[10,1,11]},{\"TH\":[11,1,3]},{\"IV\":[11,4,10]},{\"IV\":[11,11,23]},{\"TH\":[11,24,26]},{\"IC\":[11,26,35]},{\"SS\":[11,36]},{\"PP\":[12,1,7]}]" - assertEqual expectedS (encode $ toJSON tts) - -test_PreviewTokenTypesHaddock :: Assertion -test_PreviewTokenTypesHaddock = do - let api=cabalAPI - root<-createTestProject - synchronize api root False - configure api root Target - let rel="src"</>"Main.hs" - write api root rel $ unlines [ - "{-# LINE 42 \"Foo.vhs\" #-}", - "-- | a comment", - "module Main where", - "", - "main :: IO (Int)", - "main = do" , - " putStr ('h':\"ello Prefs!\")", - " return (2 + 2)", - "" - ] - (tts,nsErrors1)<-getTokenTypes api root rel - assertBool (null nsErrors1) - let expectedS="[{\"P\":[1,1,26]},{\"D\":[2,1,15]},{\"K\":[3,1,7]},{\"IC\":[3,8,12]},{\"K\":[3,13,18]},{\"IV\":[5,1,5]},{\"S\":[5,6,8]},{\"IC\":[5,9,11]},{\"SS\":[5,12]},{\"IC\":[5,13,16]},{\"SS\":[5,16]},{\"IV\":[6,1,5]},{\"S\":[6,6]},{\"K\":[6,8,10]},{\"IV\":[7,9,15]},{\"SS\":[7,16]},{\"LC\":[7,17,20]},{\"S\":[7,20]},{\"LS\":[7,21,34]},{\"SS\":[7,34]},{\"IV\":[8,9,15]},{\"SS\":[8,16]},{\"LI\":[8,17]},{\"VS\":[8,19]},{\"LI\":[8,21]},{\"SS\":[8,22]}]" - assertEqual expectedS (encode $ toJSON tts) - -test_ThingAtPoint :: Assertion -test_ThingAtPoint = do - let api=cabalAPI - root<-createTestProject - synchronize api root False - configure api root Target - let rel="src"</>"Main.hs" - write api root rel $ unlines [ - "module Main where", - "main=return $ map id \"toto\"", - "", - "data DataT=MkData {name :: String}", - "", - "data Toot=Toot {toot :: String}", - "", - "fun1=let", - " l2=reverse \"toto\"", - " in head l2" - ] - (_,nsErrors3f)<-getBuildFlags api root rel - assertBool (null nsErrors3f) - (tap1,nsErrors1)<-getThingAtPoint api root rel 2 16 - assertBool (null nsErrors1) - assertBool (isJust tap1) - assertEqual "map" (tapName $ fromJust tap1) - assertEqual (Just "GHC.Base") (tapModule $ fromJust tap1) - assertEqual (Just "(GHC.Types.Char -> GHC.Types.Char) -> [GHC.Types.Char] -> [GHC.Types.Char]") (tapQType $ fromJust tap1) - assertEqual (Just "(Char -> Char) -> [Char] -> [Char]") (tapType $ fromJust tap1) - assertEqual (Just "v") (tapHType $ fromJust tap1) - assertEqual (Just "Var") (tapGType $ fromJust tap1) - - - (tap2,nsErrors2)<-getThingAtPoint api root rel 2 20 - assertBool (null nsErrors2) - assertBool (isJust tap2) - assertEqual "id" (tapName $ fromJust tap2) - assertEqual (Just "GHC.Base") (tapModule $ fromJust tap2) - assertEqual (Just "v") (tapHType $ fromJust tap2) - assertEqual (Just "GHC.Types.Char -> GHC.Types.Char") (tapQType $ fromJust tap2) - - (tap3,nsErrors3)<-getThingAtPoint api root rel 4 7 - assertBool (null nsErrors3) - assertBool (isJust tap3) - assertEqual "DataT" (tapName $ fromJust tap3) - assertEqual (Just "Main") (tapModule $ fromJust tap3) - assertEqual (Just "t") (tapHType $ fromJust tap3) - assertEqual Nothing (tapQType $ fromJust tap3) - -#if __GLASGOW_HASKELL__ != 704 - -- type information for constructors at the declaration is not supported by ghc 7.4 - (tap4,nsErrors4)<-getThingAtPoint api root rel 4 14 - assertBool (null nsErrors4) - assertBool (isJust tap4) - assertEqual "MkData" (tapName $ fromJust tap4) - assertEqual (Just "Main") (tapModule $ fromJust tap4) - assertEqual (Just "v") (tapHType $ fromJust tap4) - assertEqual (Just "DataCon") (tapGType $ fromJust tap4) - assertEqual (Just "String -> DataT") (tapType $ fromJust tap4) - assertEqual (Just "GHC.Base.String -> Main.DataT") (tapQType $ fromJust tap4) -#endif - - (tap5,nsErrors5)<-getThingAtPoint api root rel 4 22 - assertBool (null nsErrors5) - assertBool (isJust tap5) - assertEqual "name" (tapName $ fromJust tap5) - assertEqual (Just "Main") (tapModule $ fromJust tap5) - assertEqual (Just "v") (tapHType $ fromJust tap5) - assertEqual (Just "Main.DataT -> GHC.Base.String") (tapQType $ fromJust tap5) - - (tap6,nsErrors6)<-getThingAtPoint api root rel 6 7 - assertBool (null nsErrors6) - assertBool (isJust tap6) - assertEqual "Toot" (tapName $ fromJust tap6) - assertEqual (Just "Main") (tapModule $ fromJust tap6) - assertEqual (Just "t") (tapHType $ fromJust tap6) - assertEqual Nothing (tapQType $ fromJust tap6) - -#if __GLASGOW_HASKELL__ != 704 - -- type information for constructors at the declaration is not supported by ghc 7.4 - (tap7,nsErrors7)<-getThingAtPoint api root rel 6 14 - assertBool (null nsErrors7) - assertBool (isJust tap7) - assertEqual "Toot" (tapName $ fromJust tap7) - assertEqual (Just "Main") (tapModule $ fromJust tap7) - assertEqual (Just "v") (tapHType $ fromJust tap7) - assertEqual (Just "GHC.Base.String -> Main.Toot") (tapQType $ fromJust tap7) - - -- type information for field names at the declaration is not supported by ghc 7.4 - (tap8,nsErrors8)<-getThingAtPoint api root rel 6 19 - assertBool (null nsErrors8) - assertBool (isJust tap8) - assertEqual "toot" (tapName $ fromJust tap8) - assertEqual (Just "Main") (tapModule $ fromJust tap8) - assertEqual (Just "v") (tapHType $ fromJust tap8) - assertEqual (Just "Main.Toot -> GHC.Base.String") (tapQType $ fromJust tap8) -#endif - - (tap9,nsErrors9)<-getThingAtPoint api root rel 9 5 - assertBool (null nsErrors9) - assertBool (isJust tap9) - assertEqual "l2" (tapName $ fromJust tap9) - assertEqual (Just "") (tapModule $ fromJust tap9) - assertEqual (Just "v") (tapHType $ fromJust tap9) - assertEqual (Just "[GHC.Types.Char]") (tapQType $ fromJust tap9) - - -test_ThingAtPointTypeReduction :: Assertion -test_ThingAtPointTypeReduction = do - let api=cabalAPI - root<-createTestProject - let cf=testCabalFile root - writeFile cf $ unlines ["name: "++testProjectName, - "version:0.1", - "cabal-version: >= 1.8", - "build-type: Simple", - "", - "executable BWTest", - " hs-source-dirs: src", - " main-is: Main.hs", - " build-depends: base, containers"] - let rel="src"</>"Main.hs" - synchronize api root False - configure api root Source - write api root rel $ unlines [ - "module Main where", - "import qualified Data.Map as M", - "main=putStrLn \"M\"", - "", - "fun1 :: M.Map String Int", - "fun1 = M.insert \"key\" 1 M.empty" - ] - (_,nsErrorsMf)<-getBuildFlags api root rel - assertBool (null nsErrorsMf) - (tapM,nsErrorsM)<-getThingAtPoint api root rel 6 13 - assertBool (null nsErrorsM) - assertBool (isJust tapM) - assertEqual "insert" (tapName $ fromJust tapM) -#if __GLASGOW_HASKELL__ >= 706 - assertEqual (Just "Data.Map.Base") (tapModule $ fromJust tapM) - assertEqual (Just "v") (tapHType $ fromJust tapM) - assertEqual (Just "GHC.Base.String -> GHC.Types.Int -> Data.Map.Base.Map GHC.Base.String GHC.Types.Int -> Data.Map.Base.Map GHC.Base.String GHC.Types.Int") (tapQType $ fromJust tapM) -#else - assertEqual (Just "Data.Map") (tapModule $ fromJust tapM) - assertEqual (Just "v") (tapHType $ fromJust tapM) - assertEqual (Just "GHC.Base.String -> GHC.Types.Int -> Data.Map.Map GHC.Base.String GHC.Types.Int -> Data.Map.Map GHC.Base.String GHC.Types.Int") (tapQType $ fromJust tapM) -#endif - - -test_ThingAtPointNotInCabal :: Assertion -test_ThingAtPointNotInCabal = do - let api=cabalAPI - root<-createTestProject - synchronize api root False - configure api root Target - let rel2="src"</>"Auto.hs" - writeFile (root </> rel2) $ unlines ["module Auto where","fAuto=head [2,3,4]"] - synchronize api root False - (_,nsErrors3f)<-getBuildFlags api root rel2 - assertBool (null nsErrors3f) - (tap1,nsErrors1)<-getThingAtPoint api root rel2 2 8 - assertBool (null nsErrors1) - assertBool (isJust tap1) - assertEqual "head" (tapName $ fromJust tap1) - assertEqual (Just "GHC.List") (tapModule $ fromJust tap1) - assertEqual (Just "[GHC.Integer.Type.Integer] -> GHC.Integer.Type.Integer") (tapQType $ fromJust tap1) - - -test_ThingAtPointMain :: Assertion -test_ThingAtPointMain = do - let api=cabalAPI - root<-createTestProject - let cf=testCabalFile root - writeFile cf $ unlines ["name: "++testProjectName, - "version:0.1", - "cabal-version: >= 1.8", - "build-type: Simple", - "", - "executable BWTest", - " hs-source-dirs: src", - " main-is: A.hs", - " other-modules: B.D", - " build-depends: base"] - let rel="src"</>"A.hs" - writeFile (root </> rel) $ unlines [ - "module Main where", - "import B.D", - "main=return $ head [2,3,4]" - ] - synchronize api root False - configure api root Target - (bf3,nsErrors3f)<-getBuildFlags api root rel - assertBool (null nsErrors3f) - assertEqual (Just "Main") (bfModName bf3) - (tap1,nsErrors1)<-getThingAtPoint api root rel 3 16 - assertBool (null nsErrors1) - assertBool (isJust tap1) - assertEqual "head" (tapName $ fromJust tap1) - assertEqual (Just "GHC.List") (tapModule $ fromJust tap1) - assertEqual (Just "[GHC.Integer.Type.Integer] -> GHC.Integer.Type.Integer") (tapQType $ fromJust tap1) - --- (tap2,nsErrors2)<-getThingAtPoint api root rel 2 8 --- assertBool ("errors or warnings on getThingAtPoint2:"++show nsErrors2) (null nsErrors2) --- assertBool "not just tap2" (isJust tap2) --- assertEqual "not B.D" "B.D" (tapName $ fromJust tap2) --- assertEqual "not ModuleName" (Just "ModuleName") (tapGType $ fromJust tap2) --- assertEqual "not m" (Just "m") (tapHType $ fromJust tap2) --- - - -test_ThingAtPointMainSubFolder :: Assertion -test_ThingAtPointMainSubFolder = do - let api=cabalAPI - root<-createTestProject - let cf=testCabalFile root - writeFile cf $ unlines ["name: "++testProjectName, - "version:0.1", - "cabal-version: >= 1.8", - "build-type: Simple", - "", - "executable BWTest", - " hs-source-dirs: src", - " main-is: src2/A.hs", - " other-modules: B.D", - " build-depends: base"] - let sf=root </> "src" </> "src2" - createDirectory sf - let rel="src" </> "src2" </> "A.hs" - writeFile (root </> rel) $ unlines [ - "module Main where", - "import B.D", - "main=return $ head [2,3,4]" - ] - synchronize api root False - configure api root Target - (bf3,nsErrors3f)<-getBuildFlags api root rel - assertBool (null nsErrors3f) - assertEqual (Just "Main") (bfModName bf3) - (tap1,nsErrors1)<-getThingAtPoint api root rel 3 16 - assertBool (null nsErrors1) - assertBool (isJust tap1) - assertEqual "head" (tapName $ fromJust tap1) - assertEqual (Just "GHC.List") (tapModule $ fromJust tap1) - assertEqual (Just "[GHC.Integer.Type.Integer] -> GHC.Integer.Type.Integer") (tapQType $ fromJust tap1) - -test_Locals :: Assertion -test_Locals = do- let api=cabalAPI - root<-createTestProject - synchronize api root False - configure api root Target - let rel="src"</>"Main.hs" - write api root rel $ unlines [ - "module Main where", - "main=return $ map id \"toto\"", - "", - "fun1 l1=let", - " l2=reverse \"toto\"", - " in head l2" - ] - (_,nsErrors)<-getBuildFlags api root rel - assertBool (null nsErrors) - (loc1,nsErrors1)<-getLocals api root rel 4 1 6 15 - assertBool (null nsErrors1) - assertBool (not $ null loc1) - let names=map tapName loc1 - assertBool (elem "l2" names) - assertBool (elem "l1" names) - write api root rel $ unlines [ - "module Main where", - "main=return $ map id \"toto\"", - "", - "fun1 l1=do", - " let l2=reverse \"toto\"", - " reverse head l2" - ] - (_,nsErrorsM)<-getBuildFlags api root rel - assertBool (null nsErrorsM) - (loc2,nsErrors2)<-getLocals api root rel 4 1 6 15 - assertBool (null nsErrors2) - assertBool (not $ null loc2) - let namesM=map tapName loc2 - assertBool (elem "l2" namesM) - assertBool (elem "l1" namesM)- return ()- - -test_NamesInScope :: Assertion -test_NamesInScope = do - let api=cabalAPI - root<-createTestProject - synchronize api root False - configure api root Source - let rel="src"</>"Main.hs" - writeFile (root </> rel) $ unlines [ - "module Main where", - "import B.D", - "main=return $ map id \"toto\"" - ] - build api root True Source - synchronize api root False - --c1<-getClockTime - (mtts,nsErrors1)<-getNamesInScope api root rel - --c2<-getClockTime - --putStrLn ("testNamesInScope: " ++ (timeDiffToString $ diffClockTimes c2 c1)) - assertBool (null nsErrors1) - assertBool (isJust mtts) - let tts=fromJust mtts - assertBool ("Main.main" `elem` tts) - assertBool ("B.D.fD" `elem` tts) - assertBool ("GHC.Types.Char" `elem` tts) - - -test_NameDefsInScope :: Assertion -test_NameDefsInScope = do - let api=cabalAPI - root<-createTestProject - synchronize api root False - configure api root Source - let rel="src"</>"Main.hs" - writeFile (root </> rel) $ unlines [ - "module Main where", - "import B.D", - "main=return $ map id \"toto\"", - "data Type1=MkType1_1 Int" - ] - build api root True Source - synchronize api root False - (mtts,_)<-build1 api root rel - assertBool (isJust mtts) - let tts=fromJust mtts - assertBool (NameDef "Main.main" [Function] (Just "IO [Char]") `elem` tts) - assertBool (NameDef "B.D.fD" [Function] (Just "forall a. a") `elem` tts) - assertBool (NameDef "Main.Type1" [Type] Nothing `elem` tts) - assertBool (NameDef "Main.MkType1_1" [Constructor] (Just "Int -> Type1") `elem` tts) - assertBool (NameDef "GHC.Types.Char" [Type] Nothing `elem` tts) - -test_NameDefsInScopeLongRunning :: Assertion -test_NameDefsInScopeLongRunning = do - let api=cabalAPI - root<-createTestProject - synchronize api root False - configure api root Source - let rel="src"</>"Main.hs" - writeFile (root </> rel) $ unlines [ - "module Main where", - "import B.D", - "main=return $ map id \"toto\"", - "data Type1=MkType1_1 Int" - ] - build api root True Source - synchronize api root False - (inp,out,_,_)<-build1lr root rel - (mtts,ns)<-(readResult out) :: IO (OpResult (Maybe [NameDef])) - assertBool (isJust mtts) - assertBool (not $ notesInError ns) - let tts=fromJust mtts - assertBool (NameDef "Main.main" [Function] (Just "IO [Char]") `elem` tts) - assertBool (NameDef "B.D.fD" [Function] (Just "forall a. a") `elem` tts) - assertBool (NameDef "Main.Type1" [Type] Nothing `elem` tts) - assertBool (NameDef "Main.MkType1_1" [Constructor] (Just "Int -> Type1") `elem` tts) - assertBool (NameDef "GHC.Types.Char" [Type] Nothing `elem` tts) - assertBool (NameDef "Main.Type2" [Type] Nothing `notElem` tts) - threadDelay 1000000 - write api root rel $ unlines [ - "module Main where", - "import B.D", - "main=return $ map id \"toto\"", - "data Type1=MkType1_1 Int", - "data Type2=MkType2_1 Int" - ] - continue inp - (mtts2,ns2)<-readResult out :: IO (OpResult (Maybe [NameDef])) - assertBool (not $ notesInError ns2) - assertBool (isJust mtts2) - let tts2=fromJust mtts2 - assertBool (NameDef "Main.Type1" [Type] Nothing `elem` tts2) - assertBool (NameDef "Main.Type2" [Type] Nothing `elem` tts2) - write api root rel $ unlines [ - "module Main where", - "import B.D", - "main=return $ map id \"toto\"", - "data Type1=MkType1_1 Int", - "data Type2=MkType2_1 Int2" - ] - continue inp - (_,ns3)<-readResult out :: IO (OpResult (Maybe [NameDef])) - assertBool (notesInError ns3) - threadDelay 1000000 - write api root rel $ unlines [ - "module Main where", - "import B.D", - "main=return $ map id \"toto\"", - "data Type1=MkType1_1 Int", - "data Type2=MkType2_1 Int" - ] - continue inp - (mtts4,ns4)<-readResult out :: IO (OpResult (Maybe [NameDef])) - assertBool (not $ notesInError ns4) - assertBool (isJust mtts4) - let tts4=fromJust mtts4 - assertBool (NameDef "Main.Type1" [Type] Nothing `elem` tts4) - assertBool (NameDef "Main.Type2" [Type] Nothing `elem` tts4) - end inp - -test_InPlaceReference :: Assertion -test_InPlaceReference = do - let api=cabalAPI - root<-createTestProject - synchronize api root False - writeFile (root </> (testProjectName <.> ".cabal")) $ unlines ["name: "++testProjectName, - "version:0.1", - "cabal-version: >= 1.8", - "build-type: Simple", - "", - "library", - " hs-source-dirs: src", - " exposed-modules: A,B.C", - " build-depends: base", - "", - "executable BWTest", - " hs-source-dirs: src", - " main-is: Main.hs", - " other-modules: B.D", - " build-depends: base, BWTest", - "", - "test-suite BWTest-test", - " type: exitcode-stdio-1.0", - " hs-source-dirs: test", - " main-is: Main.hs", - " other-modules: TestA", - " build-depends: base, BWTest", - "" - ] - let rel="src"</>"Main.hs" - writeFile (root </> rel) $ unlines [ - "module Main where", - "import B.C", - "main=return $ map id \"toto\"" - ] - let rel3="test"</>"TestA.hs" - writeFile (root </> rel3) $ unlines ["module TestA where","import A","fTA=undefined"] - let rel2="src"</>"A.hs" - writeFile (root </> rel2) $ unlines ["module A where","import B.C","fA=undefined"] - (boolOKc,nsOKc)<-configure api root Source - assertBool boolOKc - assertBool (null nsOKc) - (BuildResult boolOK _,nsOK)<-build api root True Source - assertBool boolOK - assertBool (null nsOK) - synchronize api root True - (mtts,nsErrors1)<-getNamesInScope api root rel - assertBool (null nsErrors1) - assertBool (isJust mtts) - let tts=fromJust mtts - assertBool ("Main.main" `elem` tts) - assertBool ("B.C.fC" `elem` tts) - (_,nsErrors3f)<-getBuildFlags api root rel - assertBool (null nsErrors3f) - (tap1,nsErrorsTap1)<-getThingAtPoint api root rel 3 16 - assertBool (null nsErrorsTap1) - assertBool (isJust tap1) - assertEqual "map" (tapName $ fromJust tap1) - assertEqual (Just "GHC.Base") (tapModule $ fromJust tap1) - assertEqual (Just "(GHC.Types.Char -> GHC.Types.Char) -> [GHC.Types.Char] -> [GHC.Types.Char]") (tapQType $ fromJust tap1) - (mtts2,nsErrors2)<-getNamesInScope api root rel2 - assertBool (null nsErrors2) - assertBool (isJust mtts2) - let tts2=fromJust mtts2 - assertBool ("A.fA" `elem` tts2) - assertBool ("B.C.fC" `elem` tts2) - - (mtts3,nsErrors3)<-getNamesInScope api root rel3 - assertBool (null nsErrors3) - assertBool (isJust mtts3) - let tts3=fromJust mtts3 - assertBool ("A.fA" `elem` tts3) - - -test_CabalComponents :: Assertion -test_CabalComponents= do - let api=cabalAPI - root<-createTestProject - synchronize api root False - (cps,nsOK)<-getCabalComponents api root - assertBool (null nsOK) - assertEqual 3 (length cps) - let (l:ex:ts:[])=cps - assertEqual (CCLibrary True) l - assertEqual (CCExecutable "BWTest" True) ex - assertEqual (CCTestSuite "BWTest-test" True) ts - let cf=testCabalFile root - writeFile cf $ unlines ["name: "++testProjectName, - "version:0.1", - "cabal-version: >= 1.8", - "build-type: Simple", - "", - "library", - " hs-source-dirs: src", - " exposed-modules: A", - " other-modules: B.C", - " build-depends: base", - " buildable: False", - "", - "executable BWTest", - " hs-source-dirs: src", - " main-is: Main.hs", - " other-modules: B.D", - " build-depends: base", - " buildable: False", - "", - "test-suite BWTest-test", - " type: exitcode-stdio-1.0", - " hs-source-dirs: test", - " main-is: Main.hs", - " other-modules: TestA", - " build-depends: base", - " buildable: False", - "" - ] - configure api root Source - (cps2,nsOK2)<-getCabalComponents api root - assertBool (null nsOK2) - assertEqual 3 (length cps2) - let (l2:ex2:ts2:[])=cps2 - assertEqual (CCLibrary False) l2 - assertEqual (CCExecutable "BWTest" False) ex2 - assertEqual (CCTestSuite "BWTest-test" False) ts2 - - -test_CabalDependencies :: Assertion -test_CabalDependencies = do - let api=cabalAPI - root<-createTestProject - let cf=testCabalFile root - writeFile cf $ unlines ["name: "++testProjectName, - "version:0.1", - "cabal-version: >= 1.8", - "build-type: Simple", - "", - "library", - " hs-source-dirs: src", - " exposed-modules: A", - " other-modules: B.C", - " build-depends: base", - "", - "executable BWTest", - " hs-source-dirs: src", - " main-is: Main.hs", - " other-modules: B.D", - " build-depends: base", - "", - "test-suite BWTest-test", - " type: exitcode-stdio-1.0", - " hs-source-dirs: test", - " main-is: Main.hs", - " other-modules: TestA", - " build-depends: base,filepath", - ""] - synchronize api root False - (cps,nsOK)<-getCabalDependencies api root Nothing - assertBool (null nsOK) - assertEqual 2 (length cps) - let [(_,pkgs1),(_,pkgs2)] = cps -- One is global and one is local, but the order depends on the paths, - pkgs = pkgs1 ++ pkgs2 -- so we concatenate the two. - let base=filter (\pkg->cpName pkg == "base") pkgs - assertEqual 1 (length base) - let (l:ex:ts:[])=cpDependent $ head base - assertEqual (CCLibrary True) l - assertEqual (CCExecutable "BWTest" True) ex - assertEqual (CCTestSuite "BWTest-test" True) ts - let fp=filter (\pkg->cpName pkg == "filepath") pkgs - assertEqual 1 (length fp) - let (lfp:[])=cpDependent $ head fp - assertEqual (CCTestSuite "BWTest-test" True) lfp - - -test_NoSourceDir :: Assertion -test_NoSourceDir = do - let api=cabalAPI - root<-createTestProject - let cf=testCabalFile root - writeFile cf $ unlines ["name: "++testProjectName, - "version:0.1", - "cabal-version: >= 1.8", - "build-type: Simple", - "", - "library", - " exposed-modules: A", - " other-modules: B.C", - " build-depends: base", - "", - "executable BWTest", - " main-is: src/Main.hs", - " other-modules: B.D", - " build-depends: base", - ""] - let git=root </> ".git" - createDirectoryIfMissing False git - let gitInBW=root </> ".dist-buildwrapper" </> ".git" - writeFile (git </> "testfile") "test" - d1<-doesDirectoryExist gitInBW - assertBool (not d1) - - let bwInBw=root </> ".dist-buildwrapper" </> ".dist-buildwrapper" - d1b<-doesDirectoryExist bwInBw - assertBool (not d1b) - - synchronize api root False - d2<-doesDirectoryExist gitInBW - assertBool (not d2) - - d2b<-doesDirectoryExist bwInBw - assertBool (not d2b) - - - -test_Flags :: Assertion -test_Flags = do - let api=cabalAPI - root<-createTestProject - let cf=testCabalFile root - writeFile cf $ unlines ["name: "++testProjectName, - "version:0.1", - "cabal-version: >= 1.8", - "build-type: Simple", - "", - "flag server", - " description: Install the scion-server.", - " default: False", - "", - "library", - " hs-source-dirs: src", - " exposed-modules: A", - " other-modules: B.C", - " build-depends: base", - "", - "executable BWTest", - " if !flag(server)", - " buildable: False", - " hs-source-dirs: src", - " main-is: Main.hs", - " other-modules: B.D", - " build-depends: base", - "" - ] - configure api root Source - build api root True Source - let exePath=root </> ".dist-buildwrapper" </> "dist" </> "build" </> testProjectName </> "BWTest" <.> exeExtension - ex1<-doesFileExist exePath - assertBool (not ex1) - - configureWithFlags api root Source "server" - build api root True Source - ex2<-doesFileExist exePath - assertBool ex2 - - - -test_BuildFlags :: Assertion -test_BuildFlags =do - let api=cabalAPI - root<-createTestProject - let cf=testCabalFile root - writeFile cf $ unlines ["name: "++testProjectName, - "version:0.1", - "cabal-version: >= 1.8", - "build-type: Simple", - "", - "library", - " hs-source-dirs: src", - " exposed-modules: A", - " other-modules: B.C", - " build-depends: base", - " extensions: OverlappingInstances" - ] - configure api root Source - let rel="src"</>"A.hs" - (flgs,nsErrors3f)<-getBuildFlags api root rel - -- print flgs - assertBool (null nsErrors3f) - let ast=bfAst flgs - assertBool ("-package-name" `elem` ast) - assertBool ("BWTest-0.1" `elem` ast) - assertBool ("-XOverlappingInstances" `elem` ast) - assertBool ("OverlappingInstances" `notElem` ast) - - -test_ExplicitComponent :: Assertion -test_ExplicitComponent =do - let api=cabalAPI - root<-createTestProject - let cf=testCabalFile root - writeFile cf $ unlines ["name: "++testProjectName, - "version:0.1", - "cabal-version: >= 1.8", - "build-type: Simple", - "", - "library", - " hs-source-dirs: src", - " exposed-modules: A", - " other-modules: B", - " build-depends: base,containers", - "executable BWTest", - " hs-source-dirs: src", - " main-is: Main.hs", - " other-modules: B", - " build-depends: base,containers", - "", - "executable BWTest2", - " hs-source-dirs: src", - " main-is: Main2.hs", - " other-modules: B", - " build-depends: base" - ] - let rel="src"</>"B.hs" - writeFile (root </> rel) $ unlines [ - "module B where", - "import qualified Data.Map as M", - "ins=M.insert 'k' 0 M.empty" - ] - configure api root Source - - synchronize1 api root True rel - --build1 api root rel - (names1,nsErrors1)<-build1c api root rel "" - assertBool (isJust names1) - assertBool (null nsErrors1) - (names2,nsErrors2)<-build1c api root rel "BWTest" - assertBool (isJust names2) - assertBool (null nsErrors2) - (names3,nsErrors3)<-build1c api root rel "BWTest2" - assertBool (isNothing names3) - assertBool (not $ null nsErrors3) - - -test_ExplicitComponentUnRef :: Assertion -test_ExplicitComponentUnRef =do - let api=cabalAPI - root<-createTestProject - let cf=testCabalFile root - writeFile cf $ unlines ["name: "++testProjectName, - "version:0.1", - "cabal-version: >= 1.8", - "build-type: Simple", - "", - "library", - " hs-source-dirs: src", - " exposed-modules: A", - " build-depends: base,containers", - "executable BWTest", - " hs-source-dirs: src", - " main-is: Main.hs", - " build-depends: base,containers", - "", - "executable BWTest2", - " hs-source-dirs: src", - " main-is: Main2.hs", - " build-depends: base" - ] - let rel="src"</>"B.hs" - writeFile (root </> rel) $ unlines [ - "module B where", - "import qualified Data.Map as M", - "ins=M.insert 'k' 0 M.empty" - ] - configure api root Source - - synchronize1 api root True rel - --build1 api root rel - (names1,nsErrors1)<-build1c api root rel "" - assertBool (isJust names1) - assertBool (null nsErrors1) - (names2,nsErrors2)<-build1c api root rel "BWTest" - assertBool (isJust names2) - assertBool (null nsErrors2) - (names3,nsErrors3)<-build1c api root rel "BWTest2" - assertBool (isNothing names3) - assertBool (not $ null nsErrors3) - -test_CleanFiles :: Assertion -test_CleanFiles =do - let api=cabalAPI - root<-createTestProject - synchronize api root False - let fldr=root </> ".dist-buildwrapper" - let file=fldr </> "src" </> ".A.hs.bwinfo" - exf1<-doesFileExist file - assertBool $ not exf1 - exd1<-doesDirectoryExist fldr - assertBool exd1 - let rel="src"</> "A.hs" - build1 api root rel - getThingAtPoint api root rel 1 1 - exf2<-doesFileExist file - assertBool exf2 - clean api root False - exf3<-doesFileExist file - assertBool $ not exf3 - exd2<-doesDirectoryExist fldr - assertBool exd2 - build1 api root rel - getThingAtPoint api root rel 1 1 - exf4<-doesFileExist file - assertBool exf4 - clean api root True - exf5<-doesFileExist file - assertBool $ not exf5 - exd3<-doesDirectoryExist fldr - assertBool $ not exd3 - -testProjectName :: String -testProjectName="BWTest" - -testCabalContents :: String -testCabalContents = unlines ["name: "++testProjectName, - "version:0.1", - "cabal-version: >= 1.8", - "build-type: Simple", - "", - "library", - " hs-source-dirs: src", - " exposed-modules: A", - " other-modules: B.C", - " build-depends: base", - "", - "executable BWTest", - " hs-source-dirs: src", - " main-is: Main.hs", - " other-modules: B.D", - " build-depends: base", - "", - "test-suite BWTest-test", - " type: exitcode-stdio-1.0", - " hs-source-dirs: test", - " main-is: Main.hs", - " other-modules: TestA", - " build-depends: base", - "" - ] - -testCabalFile :: FilePath -> FilePath -testCabalFile root =root </> ((last $ splitDirectories root) <.> ".cabal") - -testAContents :: String -testAContents=unlines ["module A where","fA=undefined"] -testCContents :: String -testCContents=unlines ["module B.C where","fC=undefined"] -testDContents :: String -testDContents=unlines ["module B.D where","fD=undefined"] -testMainContents :: String -testMainContents=unlines ["module Main where","main=undefined"] -testMainTestContents :: String -testMainTestContents=unlines ["module Main where","main=undefined"] -testTestAContents :: String -testTestAContents=unlines ["module TestA where","fTA=undefined"] - -testSetupContents ::String -testSetupContents = unlines ["#!/usr/bin/env runhaskell", - "import Distribution.Simple", - "main :: IO ()", - "main = defaultMain"] - -createTestProject :: IO FilePath -createTestProject = do - temp<-getTemporaryDirectory - let root=temp </> testProjectName - ex<-doesDirectoryExist root - when ex (removeDirectoryRecursive root) - createDirectory root - writeFile (testCabalFile root) testCabalContents - writeFile (root </> "Setup.hs") testSetupContents - let srcF=root </> "src" - createDirectory srcF - writeFile (srcF </> "A.hs") testAContents - let b=srcF </> "B" - createDirectory b - writeFile (b </> "C.hs") testCContents - writeFile (b </> "D.hs") testDContents - writeFile (srcF </> "Main.hs") testMainContents - let testF=root </> "test" - createDirectory testF - writeFile (testF </> "Main.hs") testMainTestContents - writeFile (testF </> "TestA.hs") testTestAContents - return root - -removeSpaces :: String -> String -removeSpaces = filter (/= ':') . filter (not . isSpace) - -assertEqualNotesWithoutSpaces :: String -> BWNote -> BWNote -> IO() -assertEqualNotesWithoutSpaces msg n1 n2=do - let - n1'=n1{bwnTitle=removeSpaces $ bwnTitle n1} - n2'=n1{bwnTitle=removeSpaces $ bwnTitle n2} - assertEqualVerbose msg n1' n2' - -removeLayoutTAP :: OpResult (Maybe ThingAtPoint) -> OpResult (Maybe ThingAtPoint) -removeLayoutTAP res = case res of - (Just tap@ThingAtPoint{tapType=tp,tapQType=qtp},xs) -> - (Just tap{tapType=removeLayout tp, tapQType=removeLayout qtp},xs) - _ -> res - where removeLayout (Just tp) = Just $ unwords . concatMap words . lines $ tp -- replace sequences of spaces and newlines by single space - removeLayout Nothing = Nothing - - -runAPI:: (FromJSON a,Show a) => FilePath -> FilePath -> String -> [String] -> IO a -runAPI cabal root command args= do - cd<-getCurrentDirectory - let fullargs=[command,"--tempfolder=.dist-buildwrapper","--cabalpath="++cabal,"--cabalfile="++ testCabalFile root] ++ args - exePath<-filterM doesFileExist [".dist-buildwrapper/dist/build/buildwrapper/buildwrapper" <.> exeExtension,"dist/build/buildwrapper/buildwrapper" <.> exeExtension] - assertBool (0<length exePath) - setCurrentDirectory root - (ex,out,err)<-readProcessWithExitCode (cd </> head exePath) fullargs "" - setCurrentDirectory cd - putStrLn ("out:"++out) - putStrLn ("err:"++err) - assertEqual ExitSuccess ex - let res=map (drop $ length ("build-wrapper-json:"::String)) $ filter (isPrefixOf "build-wrapper-json:") $ lines out - assertEqual 1 (length res) - let r=parse value $ BS.pack (head res) - case r of - Done _ js->do - let r1= fromJSON js - case r1 of - Data.Aeson.Success fin->return fin - a->do - assertFailure (show a) - error "" - a->do - assertFailure (show a) - -startAPIProcess :: FilePath -> String -> [String] -> IO (Handle, Handle, Handle, ProcessHandle) -startAPIProcess root command args= do - cd<-getCurrentDirectory - let fullargs=[command,"--tempfolder=.dist-buildwrapper","--cabalpath=cabal","--cabalfile="++ testCabalFile root] ++ args - exePath<-filterM doesFileExist [".dist-buildwrapper/dist/build/buildwrapper/buildwrapper" <.> exeExtension,"dist/build/buildwrapper/buildwrapper" <.> exeExtension] - assertBool (0<length exePath) - runInteractiveProcess (cd </> head exePath) fullargs (Just root) Nothing - -readResult :: (FromJSON a,Show a) => Handle -> IO a -readResult h= do- l<-BS.hGetLine h - BS.putStrLn l - if BS.isPrefixOf "build-wrapper-json:" l - then do - let r=parse value $ BS.drop (BS.length "build-wrapper-json:") l - -- print r - case r of - Done _ js->do - let r1= fromJSON js - case r1 of - Data.Aeson.Success fin->return fin - a->do - assertFailure (show a) - a->do - assertFailure (show a) - else - readResult h - -continue :: Handle -> IO () -continue h=do - hPutStrLn h "." - hFlush h - - -end :: Handle -> IO () -end h =do - hPutStrLn h "q" - hFlush h - -cmdOpts :: [String] -> [String] -cmdOpts =map ("--cabaloption=" ++) - -notesInError :: [BWNote] -> Bool -notesInError ns=not $ null $ filter (\x->BWError == bwnStatus x) ns +{-# LANGUAGE CPP, OverloadedStrings #-}+{-# OPTIONS_GHC -F -pgmF htfpp #-}+-- |+-- Module : Language.Haskell.BuildWrapper.CMDTests+-- Author : JP Moresmau+-- Copyright : (c) JP Moresmau 2011+-- License : BSD3+-- +-- Maintainer : jpmoresmau@gmail.com+-- Stability : beta+-- Portability : portable+-- +-- Testing via the executable interface+module Language.Haskell.BuildWrapper.CMDTests where++import Language.Haskell.BuildWrapper.Base hiding (writeFile,readFile)++import Data.ByteString.Lazy ()+import Data.ByteString.Lazy.Char8()++import Data.Maybe+import Data.Char++import System.Directory+import System.FilePath+import System.Info++import Control.Monad+++import Data.Attoparsec+import Data.Aeson+import Data.Aeson.Parser+import qualified Data.ByteString.Char8 as BS+import Data.List+import System.Exit+import System.Process++import Test.Framework+import Test.HUnit (Assertion)+import System.IO (Handle, hPutStrLn, hFlush)++class APIFacade a where+ synchronize :: a -> FilePath -> Bool -> IO (OpResult ([FilePath],[FilePath]))+ synchronize1 :: a -> FilePath -> Bool -> FilePath -> IO (Maybe FilePath)+ write :: a -> FilePath -> FilePath -> String -> IO ()+ configure :: a -> FilePath -> WhichCabal -> IO (OpResult Bool)+ configureWithFlags :: a -> FilePath -> WhichCabal -> String -> IO (OpResult Bool)+ build :: a -> FilePath -> Bool -> WhichCabal -> IO (OpResult BuildResult)+ build1 :: a -> FilePath -> FilePath -> IO (OpResult (Maybe [NameDef]))+ build1c :: a -> FilePath -> FilePath -> String -> IO (OpResult (Maybe [NameDef]))+ getBuildFlags :: a -> FilePath -> FilePath -> IO (OpResult BuildFlags)+ getOutline :: a -> FilePath -> FilePath -> IO (OpResult OutlineResult)+ getTokenTypes :: a -> FilePath -> FilePath -> IO (OpResult [TokenDef])+ getOccurrences :: a -> FilePath -> FilePath -> String -> IO (OpResult [TokenDef])+ getThingAtPoint :: a -> FilePath -> FilePath -> Int -> Int -> IO (OpResult (Maybe ThingAtPoint))+ getLocals :: a -> FilePath -> FilePath -> Int -> Int -> Int -> Int -> IO (OpResult [ThingAtPoint])+ getNamesInScope :: a -> FilePath -> FilePath-> IO (OpResult (Maybe [String]))+ getCabalDependencies :: a -> FilePath -> Maybe FilePath -> IO (OpResult [(FilePath,[CabalPackage])])+ getCabalComponents :: a -> FilePath -> IO (OpResult [CabalComponent])+ generateUsage :: a -> FilePath -> Bool -> CabalComponent -> IO (OpResult (Maybe [FilePath]))+ cleanImports :: a -> FilePath -> FilePath -> Bool -> IO (OpResult [ImportClean])+ clean :: a -> FilePath -> Bool -> IO(Bool)+++data CMDAPI=CMDAPI {+ cabalExe :: String,+ cabalOpts :: [String]+ }++++instance APIFacade CMDAPI where+ synchronize (CMDAPI c o) r ff= runAPI c r "synchronize" (["--force="++ show ff ] ++ cmdOpts o)+ synchronize1 (CMDAPI c o) r ff fp= runAPI c r "synchronize1" (["--force="++show ff,"--file="++fp]++ cmdOpts o)+ write (CMDAPI c _) r fp s= runAPI c r "write" ["--file="++fp,"--contents="++s]+ configure (CMDAPI c o) r t= runAPI c r "configure" (["--cabaltarget="++ show t]++ cmdOpts o)+ configureWithFlags (CMDAPI c o) r t fgs= runAPI c r "configure" (["--cabaltarget="++ show t,"--cabalflags="++ fgs]++ cmdOpts o)+ build (CMDAPI c o) r b wc= runAPI c r "build" (["--output="++ show b,"--cabaltarget="++ show wc]++ cmdOpts o)+ build1 (CMDAPI c _) r fp= runAPI c r "build1" ["--file="++fp]+ build1c (CMDAPI c _) r fp ccn= runAPI c r "build1" ["--file="++fp,"--component="++ccn]+ getBuildFlags (CMDAPI c _) r fp= runAPI c r "getbuildflags" ["--file="++fp]+ getOutline (CMDAPI c _) r fp= runAPI c r "outline" ["--file="++fp]+ getTokenTypes (CMDAPI c _) r fp= runAPI c r "tokentypes" ["--file="++fp]+ getOccurrences (CMDAPI c _) r fp s= runAPI c r "occurrences" ["--file="++fp,"--token="++s]+ getThingAtPoint (CMDAPI c _) r fp l cl= fmap removeLayoutTAP $ runAPI c r "thingatpoint" ["--file="++fp,"--line="++ show l,"--column="++ show cl]+ getLocals (CMDAPI c _) r fp sl sc el ec= runAPI c r "locals" ["--file="++fp,"--sline="++ show sl,"--scolumn="++ show sc,"--eline="++ show el,"--ecolumn="++ show ec]+ getNamesInScope (CMDAPI c _) r fp= runAPI c r "namesinscope" ["--file="++fp]+ getCabalDependencies (CMDAPI c o) r mfp= runAPI c r "dependencies" ((maybe [] (\x->["--sandbox="++x]) mfp)++ cmdOpts o)+ getCabalComponents (CMDAPI c _) r= runAPI c r "components" []+ generateUsage (CMDAPI c _) r retAll cc=runAPI c r "generateusage" ["--returnall="++ show retAll,"--cabalcomponent="++ cabalComponentName cc]+ cleanImports (CMDAPI c _) r fp fo= runAPI c r "cleanimports" ["--file="++fp,"--format="++ show fo]+ clean (CMDAPI c _) r e=runAPI c r "clean" ["--everything="++show e]+ +build1lr :: FilePath+ -> [Char] -> IO (Handle, Handle, Handle, ProcessHandle)+build1lr r fp= startAPIProcess r "build1" ["--file="++fp,"--longrunning=true"]+ +cabalAPI= CMDAPI "cabal" [] ++exeExtension :: String+#ifdef mingw32_HOST_OS+exeExtension = "exe"+#else+exeExtension = ""+#endif ++test_SynchronizeAll :: Assertion+test_SynchronizeAll = do+ let api=cabalAPI+ root<-createTestProject+ ((fps,dels),_)<-synchronize api root False+ assertBool (not $ null fps) + assertBool (null dels) + assertEqual (testProjectName <.> ".cabal") (head fps)+ assertBool (("src" </> "A.hs") `elem` fps)+ assertBool (("src" </> "B" </> "C.hs") `elem` fps)+ assertBool (("src" </> "Main.hs") `elem` fps)+ assertBool (("src" </> "B" </> "D.hs") `elem` fps)+ assertBool (("test" </> "Main.hs") `elem` fps)+ assertBool (("test" </> "TestA.hs") `elem` fps)+ +test_SynchronizeDelete :: Assertion+test_SynchronizeDelete = do+ let api=cabalAPI+ root<-createTestProject+ ((fps0,dels0),_)<-synchronize api root False+ assertBool (not $ null fps0) + assertBool (null dels0) + let new=root </> ".dist-buildwrapper" </> "New.hs"+ writeFile new "module New where"+ ex1<-doesFileExist new+ assertBool ex1+ ((_,dels),_)<-synchronize api root False+ assertBool (not $ null dels) + assertBool ("New.hs" `elem` dels)+ ex2<-doesFileExist new+ assertBool (not ex2)+++test_SynchronizeExtraFiles :: Assertion+test_SynchronizeExtraFiles = do+ let api=cabalAPI+ root<-createTestProject+ let extra=root </> "src" -- need to be in hs-source-dirs+ writeFile (extra </> "a.txt") "contents"+ let new=root </> ".dist-buildwrapper" </> "src" </> "a.txt"+ ex1<-doesFileExist new+ assertBool (not ex1)+ ((fps,_),_)<-synchronize api root False+ assertBool (("src" </> "a.txt") `elem` fps)+ ex2<-doesFileExist new+ assertBool ex2+++test_ConfigureErrors :: Assertion+test_ConfigureErrors = do+ let api=cabalAPI+ root<-createTestProject+ (boolNoCabal,nsNoCabal)<- configure api root Target+ assertBool (not boolNoCabal)+ --assertEqual 0 (length nsNoCabal) + let bw=head nsNoCabal+ assertEqual BWError (bwnStatus bw) + + synchronize api root False+ (boolOK,nsOK)<-configure api root Target+ assertBool boolOK+ assertBool (null nsOK)+ let cf=testCabalFile root+ let cfn=takeFileName cf+ writeFile cf $ unlines ["version:0.1",+ "build-type: Simple"]+ synchronize api root False+ (bool1,nsErrors1)<-configure api root Target+ assertBool (not bool1)+ assertEqual 2 (length nsErrors1)+ let (nsError1:nsError2:[])=nsErrors1+ assertEqual (BWNote BWError "No 'name' field.\n" (mkEmptySpan cfn 1 1)) nsError1+ assertEqual (BWNote BWError "No executables and no library found. Nothing to do.\n" (mkEmptySpan cfn 1 1)) nsError2+ writeFile cf $ unlines ["name: 4 P1",+ "version:0.1",+ "build-type: Simple"]+ synchronize api root False+ (bool2,nsErrors2)<-configure api root Target+ assertBool (not bool2)+ assertEqual 1 (length nsErrors2)+ let (nsError3:[])=nsErrors2+ assertEqual (BWNote BWError "Parse of field 'name' failed.\n" (mkEmptySpan cfn 1 1)) nsError3+ writeFile cf $ unlines ["name: "++testProjectName,+ "version:0.1",+ "cabal-version: >= 1.8",+ "build-type: Simple",+ "",+ "library",+ " hs-source-dirs: src",+ " exposed-modules: A",+ " other-modules: B.C",+ " build-depends: base, toto"]+ synchronize api root False+ (bool3,nsErrors3)<-configure api root Target+ assertBool (not bool3)+ assertEqual 1 (length nsErrors3)+ let (nsError4:[])=nsErrors3+ assertEqual (BWNote BWError "At least the following dependencies are missing:\ntoto -any\n" (mkEmptySpan cfn 1 1)) nsError4+ + writeFile cf $ unlines ["name: "++testProjectName,+ "version:0.1",+ "cabal-version: >= 1.8",+ "build-type: Simple",+ "",+ "library",+ " hs-source-dirs: src",+ " exposed-modules: A",+ " other-modules: B.C",+ " build-depends: base, toto, titi"]+ synchronize api root False+ (bool4,nsErrors4)<-configure api root Target+ assertBool (not bool4)+ assertEqual 1 (length nsErrors4)+ let (nsError5:[])=nsErrors4+ assertEqual (BWNote BWError "At least the following dependencies are missing:\ntiti -any, toto -any\n" (mkEmptySpan cfn 1 1)) nsError5+ (BuildResult bool4b _,nsErrors4b)<-build api root False Source+ assertBool (not bool4b)+ assertEqual 1 (length nsErrors4b)+ let (nsError5b:[])=nsErrors4b+ assertEqual (BWNote BWError "At least the following dependencies are missing:\ntiti -any, toto -any\n" (mkEmptySpan cfn 1 1)) nsError5b+ writeFile cf $ unlines ["name: "++testProjectName,+ "version:0.1",+ "cabal-version: >= 1.8",+ "build-type: Simple",+ "",+ "executable BWTest",+ " hs-source-dirs: src",+ " other-modules: B.D",+ " build-depends: base"]+ synchronize api root False+ (bool5,nsErrors5)<-configure api root Target+ assertBool (not bool5)+ assertEqual 1 (length nsErrors5)+ let (nsError6:[])=nsErrors5+ assertEqual (BWNote BWError "No 'Main-Is' field found for executable BWTest\n" (mkEmptySpan cfn 1 1)) nsError6+ ++ +test_ConfigureWarnings :: Assertion+test_ConfigureWarnings = do+ let api=cabalAPI+ root<-createTestProject+ synchronize api root False+ let cf=testCabalFile root+ let cfn=takeFileName cf+ writeFile cf $ unlines ["name: "++testProjectName,+ "version:0.1",+ "cabal-version: >= 1.8",+ "build-type: Simple",+ "field1: toto",+ "",+ "library",+ " hs-source-dirs: src",+ " exposed-modules: A",+ " other-modules: B.C",+ " build-depends: base"]+ synchronize api root False+ (bool1,ns1)<- configure api root Target+ assertBool bool1+ assertEqual 1 (length ns1)+ let (nsWarning1:[])=ns1+ assertEqual (BWNote BWWarning "Unknown fields: field1 (line 5)\nFields allowed in this section:\nname, version, cabal-version, build-type, license, license-file,\ncopyright, maintainer, build-depends, stability, homepage,\npackage-url, bug-reports, synopsis, description, category, author,\ntested-with, data-files, data-dir, extra-source-files,\nextra-tmp-files\n" (mkEmptySpan cfn 5 1)) nsWarning1+ writeFile cf $ unlines ["name: "++testProjectName,+ "version:0.1",+ "build-type: Simple",+ "",+ "library",+ " hs-source-dirs: src",+ " exposed-modules: A",+ " other-modules: B.C",+ " build-depends: base"]+ synchronize api root False+ (bool2,ns2)<- configure api root Target+ assertBool bool2+ assertEqual 1 (length ns2)+ let (nsWarning2:[])=ns2+ assertEqual (BWNote BWWarning "A package using section syntax must specify at least\n'cabal-version: >= 1.2'.\n" (mkEmptySpan cfn 1 1)) nsWarning2+ writeFile cf $ unlines ["name: "++testProjectName,+ "version:0.1",+ "cabal-version: >= 1.2",+ "",+ "library",+ " hs-source-dirs: src",+ " exposed-modules: A",+ " other-modules: B.C",+ " build-depends: base"]+ writeFile (takeDirectory cf </> "Setup.hs") $ unlines ["import Distribution.Simple",+ "main = defaultMain"]+ synchronize api root False+ (bool3,ns3)<- configure api root Target+ assertBool bool3+ assertEqual 1 (length ns3)+ let (nsWarning3:[])=ns3+ assertEqual (BWNote BWWarning "No 'build-type' specified. If you do not need a custom Setup.hs or\n./configure script then use 'build-type: Simple'.\n" (mkEmptySpan cfn 1 1)) nsWarning3++ +test_BuildErrors :: Assertion+test_BuildErrors = do+ let api=cabalAPI+ root<-createTestProject+ synchronize api root False+ (boolOKc,nsOKc)<-configure api root Target+ assertBool boolOKc+ assertBool (null nsOKc)+ (BuildResult boolOK _,nsOK)<-build api root False Source+ assertBool boolOK+ assertBool (null nsOK)+ let rel="src"</>"A.hs"+ -- write source file+ + writeFile (root </> rel) $ unlines ["module A where","import toto","fA=undefined"]+ synchronize1 api root True rel+ (bool11,nsErrors11)<-build1 api root rel+ assertBool (isNothing bool11)+ assertBool (not $ null nsErrors11)+ let (nsError11:[])=nsErrors11+ assertEqualNotesWithoutSpaces "not proper error 1_1" (BWNote BWError "parse error on input `toto'\n" (mkEmptySpan rel 2 8)) nsError11+ (BuildResult bool1 _,nsErrors1)<-build api root False Source+ assertBool (not bool1)+ assertBool (not $ null nsErrors1)+ let (nsError1:[])=nsErrors1+ assertEqualNotesWithoutSpaces "not proper error 1" (BWNote BWError "parse error on input `toto'\n" (mkEmptySpan rel 2 8)) nsError1+ + -- write file and synchronize+ writeFile (root </> "src"</>"A.hs")$ unlines ["module A where","import Toto","fA=undefined"]+ mf2<-synchronize1 api root True rel+ assertBool (isJust mf2)+ (BuildResult bool2 _,nsErrors2)<-build api root False Source+ assertBool (not bool2)+ assertBool (not $ null nsErrors2)+ let (nsError2:[])=nsErrors2+ assertEqualNotesWithoutSpaces "not proper error 2" (BWNote BWError "Could not find module `Toto':\n Use -v to see a list of the files searched for.\n" (mkEmptySpan rel 2 8)) nsError2+ synchronize1 api root True rel+ (bool21,nsErrors21)<-build1 api root rel+ assertBool (isNothing bool21)+ assertBool (not $ null nsErrors21)+ let (nsError21:[])=nsErrors21+ assertEqualNotesWithoutSpaces "not proper error 2_1" (BWNote BWError "Could not find module `Toto':\n Use -v to see a list of the files searched for.\n" (mkEmptySpan rel 2 8)) nsError21+ (_,nsErrors3f)<- getBuildFlags api root ("src"</>"A.hs")+ assertBool (null nsErrors3f)+ (bool3,nsErrors3)<-build1 api root rel+ assertBool (isNothing bool3)+ assertBool (not $ null nsErrors3)+ let (nsError3:[])=nsErrors3+ assertEqualNotesWithoutSpaces "not proper error 3" (BWNote BWError "Could not find module `Toto':\n Use -v to see a list of the files searched for." (mkEmptySpan rel 2 8)) nsError3+ + + +test_BuildWarnings :: Assertion+test_BuildWarnings = do+ let api=cabalAPI+ root<-createTestProject+ synchronize api root False+ --let cf=testCabalFile root + writeFile (root </> (testProjectName <.> ".cabal")) $ unlines ["name: "++testProjectName,+ "version:0.1",+ "cabal-version: >= 1.8",+ "build-type: Simple",+ "",+ "library",+ " hs-source-dirs: src",+ " exposed-modules: A",+ " build-depends: base",+ " ghc-options: -Wall"]+ --let srcF=root </> "src"+ (boolOK,nsOK)<-configure api root Source+ assertBool boolOK+ assertBool (null nsOK)+ let rel="src"</>"A.hs"+ writeFile (root </> rel) $ unlines ["module A where","import Data.List","fA=undefined"] + mf2<-synchronize1 api root True rel+ assertBool (isJust mf2)+ (BuildResult bool1 fps1,nsErrors1)<-build api root False Source+ assertBool bool1+ assertBool (not $ null nsErrors1)+ assertBool (rel `elem` fps1)+ let (nsError1:nsError2:[])=nsErrors1+ assertEqualNotesWithoutSpaces "not proper error 1" (BWNote BWWarning "The import of `Data.List' is redundant\n except perhaps to import instances from `Data.List'\n To import instances alone, use: import Data.List()\n" (mkEmptySpan rel 2 1)) nsError1+ assertEqualNotesWithoutSpaces "not proper error 2" (BWNote BWWarning "Top-level binding with no type signature:\n fA :: forall a. a\n" (mkEmptySpan rel 3 1)) nsError2+ (_,nsErrors3f)<-getBuildFlags api root rel+ assertBool (null nsErrors3f)+ (bool3,nsErrors3)<-build1 api root rel+ assertBool (isJust bool3)+ assertEqual 2 (length nsErrors3)+ let (nsError3:nsError4:[])=nsErrors3+ assertEqualNotesWithoutSpaces "not proper error 3" (BWNote BWWarning "The import of `Data.List' is redundant\n except perhaps to import instances from `Data.List'\n To import instances alone, use: import Data.List()" (mkEmptySpan rel 2 1)) nsError3+ assertEqualNotesWithoutSpaces "not proper error 4" (BWNote BWWarning "Top-level binding with no type signature:\n fA :: forall a. a" (mkEmptySpan rel 3 1)) nsError4+ writeFile (root </> rel) $ unlines ["module A where","pats:: String -> String","pats a=reverse a","fB:: String -> Char","fB pats=head pats"] + mf3<-synchronize1 api root True rel+ assertBool (isJust mf3)+ (bool4,nsErrors4)<-build1 api root rel+ assertBool (isJust bool4)+ assertBool (not $ null nsErrors4)+ let (nsError5:[])=nsErrors4+ assertEqualNotesWithoutSpaces "not proper error 5" (BWNote BWWarning ("This binding for `pats' shadows the existing binding\n defined at "++rel++":3:1") (mkEmptySpan rel 4 5)) nsError5++ +test_BuildOutput :: Assertion+test_BuildOutput = do + let api=cabalAPI + root<-createTestProject+ synchronize api root False+ build api root True Source+ let exeN=case os of+ "mingw32" -> addExtension testProjectName "exe"+ _ -> testProjectName+ let exeF=root </> ".dist-buildwrapper" </> "dist" </> "build" </> testProjectName </> exeN+ exeE1<-doesFileExist exeF+ assertBool exeE1+ removeFile exeF+ exeE2<-doesFileExist exeF+ assertBool (not exeE2)+ build api root False Source+ exeE3<-doesFileExist exeF+ assertBool (not exeE3)+ +-- | http://hackage.haskell.org/trac/ghc/ticket/7380#comment:1 : -O2 is removed from the options +test_BuildO2 :: Assertion+test_BuildO2 = do + let api=cabalAPI + root<-createTestProject+ write api root (testProjectName <.> ".cabal") $ unlines ["name: "++testProjectName,+ "version:0.1",+ "cabal-version: >= 1.8",+ "build-type: Simple",+ "",+ "library",+ " hs-source-dirs: src",+ " exposed-modules: A",+ " other-modules: B.C",+ " build-depends: base",+ "",+ "executable BWTest",+ " hs-source-dirs: src",+ " main-is: Main.hs",+ " other-modules: B.D",+ " build-depends: base",+ " ghc-options: -O2",+ "",+ "test-suite BWTest-test",+ " type: exitcode-stdio-1.0",+ " hs-source-dirs: test",+ " main-is: Main.hs",+ " other-modules: TestA",+ " build-depends: base",+ ""+ ]+ configure api root Target+ let rel="src"</>"Main.hs"+ writeFile (root </> rel) $ unlines ["module Main where","main :: IO()","main= putStrLn \"Hello World\""] + synchronize api root False+ (ns, _)<-build1 api root rel + assertBool (isJust ns)++ +test_ModuleNotInCabal :: Assertion+test_ModuleNotInCabal = do+ let api=cabalAPI+ root<-createTestProject+ synchronize api root False+ let rel="src"</>"A.hs"+ writeFile (root </> rel) $ unlines ["module A where","import Auto","fA=undefined"] + let rel2="src"</>"Auto.hs"+ writeFile (root </> rel2) $ unlines ["module Auto where","fAuto=undefined"] + synchronize api root False+ (BuildResult bool1 _,nsErrors1)<-build api root True Source+ assertBool bool1+ assertBool (null nsErrors1)+ (_,nsErrors2f)<-getBuildFlags api root rel+ assertBool (null nsErrors2f)+ (bool2, nsErrors2)<-build1 api root rel+ assertBool (isJust bool2)+ assertBool (null nsErrors2)+ + + + +test_Outline :: Assertion+test_Outline = do+ let api=cabalAPI+ root<-createTestProject+ synchronize api root False+ let rel="src"</>"A.hs"+ -- use api to write temp file+ write api root rel $ unlines [+ "{-# LANGUAGE RankNTypes, TypeSynonymInstances, TypeFamilies #-}",+ "",+ "module Module1 where",+ "",+ "import Data.Char",+ "",+ "-- Declare a list-like data family",+ "data family XList a",+ "",+ "-- Declare a list-like instance for Char",+ "data instance XList Char = XCons !Char !(XList Char) | XNil",+ "",+ "type family Elem c",+ "",+ "type instance Elem [e] = e",+ "",+ "testfunc1 :: [Char]",+ "testfunc1=reverse \"test\"",+ "",+ "testfunc1bis :: String -> [Char]",+ "testfunc1bis []=\"nothing\"",+ "testfunc1bis s=reverse s",+ "",+ "testMethod :: forall a. (Num a) => a -> a -> a",+ "testMethod a b=",+ " let e=a + (fromIntegral $ length testfunc1)",+ " in e * 2",+ "",+ "class ToString a where",+ " toString :: a -> String",+ "",+ "instance ToString String where",+ " toString = id",+ "", + "type Str=String",+ "",+ "data Type1=MkType1_1 Int",+ " | MkType1_2 {",+ " mkt2_s :: String,",+ " mkt2_i :: Int",+ " }" ]+ (_,nsErrors3f)<-getBuildFlags api root rel+ assertBool (null nsErrors3f) + (OutlineResult defs es is,nsErrors1)<-getOutline api root rel+ assertBool (null nsErrors1)+ let expected=[+ mkOutlineDefWithChildren "XList" [Data,Family] (InFileSpan (InFileLoc 8 1)(InFileLoc 8 20)) []+ ,mkOutlineDefWithChildren "XList Char" [Data,Instance] (InFileSpan (InFileLoc 11 1)(InFileLoc 11 60)) [+ mkOutlineDef "XCons" [Constructor] (InFileSpan (InFileLoc 11 28)(InFileLoc 11 53))+ ,mkOutlineDef "XNil" [Constructor] (InFileSpan (InFileLoc 11 56)(InFileLoc 11 60)) + ]+ ,mkOutlineDef "Elem" [Type,Family] (InFileSpan (InFileLoc 13 1)(InFileLoc 13 19))+ ,mkOutlineDef "Elem [e]" [Type,Instance] (InFileSpan (InFileLoc 15 1)(InFileLoc 15 27)) + ,OutlineDef "testfunc1" [Function] (InFileSpan (InFileLoc 17 1)(InFileLoc 18 25)) [] (Just "[Char]") Nothing+ ,OutlineDef "testfunc1bis" [Function] (InFileSpan (InFileLoc 20 1)(InFileLoc 22 25)) [] (Just "String -> [Char]") Nothing + ,OutlineDef "testMethod" [Function] (InFileSpan (InFileLoc 24 1)(InFileLoc 27 13)) [] (Just "forall a . (Num a) => a -> a -> a") Nothing + ,mkOutlineDefWithChildren "ToString" [Class] (InFileSpan (InFileLoc 29 1)(InFileLoc 32 0)) [+ mkOutlineDef "toString" [Function] (InFileSpan (InFileLoc 30 5)(InFileLoc 30 28))+ ] + ,mkOutlineDefWithChildren "ToString String" [Instance] (InFileSpan (InFileLoc 32 1)(InFileLoc 35 0)) [+ mkOutlineDef "toString" [Function] (InFileSpan (InFileLoc 33 5)(InFileLoc 33 18)) + ] + ,OutlineDef "Str" [Type] (InFileSpan (InFileLoc 35 1)(InFileLoc 35 16)) [] (Just "String") Nothing + ,mkOutlineDefWithChildren "Type1" [Data] (InFileSpan (InFileLoc 37 1)(InFileLoc 41 10)) [+ mkOutlineDef "MkType1_1" [Constructor] (InFileSpan (InFileLoc 37 12)(InFileLoc 37 25)) + ,mkOutlineDefWithChildren "MkType1_2" [Constructor] (InFileSpan (InFileLoc 38 7)(InFileLoc 41 10)) [+ mkOutlineDef "mkt2_s" [Field] (InFileSpan (InFileLoc 39 9)(InFileLoc 39 25)) + ,mkOutlineDef "mkt2_i" [Field] (InFileSpan (InFileLoc 40 9)(InFileLoc 40 22)) + + ]+ + ]+ ]+ assertEqual (length expected) (length defs)+ mapM_ (uncurry (assertEqual)) (zip expected defs)+ assertEqual [] es+ assertEqual [ImportDef "Data.Char" Nothing (InFileSpan (InFileLoc 5 1)(InFileLoc 5 17)) False False "" Nothing] is+ + +test_OutlineComments :: Assertion+test_OutlineComments= do+ let api=cabalAPI+ root<-createTestProject+ synchronize api root False+ let rel="src"</>"A.hs"+ -- use api to write temp file+ write api root rel $ unlines [+ "{-# LANGUAGE RankNTypes, TypeSynonymInstances, TypeFamilies #-}",+ "",+ "module Module1 where",+ "",+ "import Data.Char",+ "",+ "-- testFunc1 comment",+ "testfunc1 :: [Char]",+ "testfunc1=reverse \"test\"",+ "",+ "-- | testFunc1bis haddock",+ "testfunc1bis :: String -> [Char]",+ "testfunc1bis []=\"nothing\"",+ "testfunc1bis s=reverse s",+ "",+ "-- | testMethod",+ "-- haddock",+ "testMethod :: forall a. (Num a) => a -> a -> a",+ "testMethod a b=",+ " let e=a + (fromIntegral $ length testfunc1)",+ " in e * 2",+ "",+ "class ToString a where",+ " toString :: a -> String -- ^ toString comment",+ "",+ "-- | Str haddock", + "type Str=String",+ "",+ "-- | Type1 haddock",+ "data Type1=MkType1_1 Int -- ^ MkType1 comment",+ " | MkType1_2 {",+ " mkt2_s :: String,",+ " mkt2_i :: Int",+ " }" ]+ (_,nsErrors3f)<-getBuildFlags api root rel+ assertBool (null nsErrors3f) + (OutlineResult defs es is,nsErrors1)<-getOutline api root rel+ assertBool (null nsErrors1)+ let expected=[+ OutlineDef "testfunc1" [Function] (InFileSpan (InFileLoc 8 1)(InFileLoc 9 25)) [] (Just "[Char]") Nothing+ ,OutlineDef "testfunc1bis" [Function] (InFileSpan (InFileLoc 12 1)(InFileLoc 14 25)) [] (Just "String -> [Char]") (Just "testFunc1bis haddock") + ,OutlineDef "testMethod" [Function] (InFileSpan (InFileLoc 18 1)(InFileLoc 21 13)) [] (Just "forall a . (Num a) => a -> a -> a") (Just "testMethod\n haddock") + ,mkOutlineDefWithChildren "ToString" [Class] (InFileSpan (InFileLoc 23 1)(InFileLoc 27 0)) [+ OutlineDef "toString" [Function] (InFileSpan (InFileLoc 24 5)(InFileLoc 24 28)) [] Nothing (Just "toString comment")+ ] + ,OutlineDef "Str" [Type] (InFileSpan (InFileLoc 27 1)(InFileLoc 27 16)) [] (Just "String") (Just "Str haddock") + ,OutlineDef "Type1" [Data] (InFileSpan (InFileLoc 30 1)(InFileLoc 34 10)) [+ OutlineDef "MkType1_1" [Constructor] (InFileSpan (InFileLoc 30 12)(InFileLoc 30 25)) [] Nothing (Just "MkType1 comment") + ,mkOutlineDefWithChildren "MkType1_2" [Constructor] (InFileSpan (InFileLoc 31 7)(InFileLoc 34 10)) [+ mkOutlineDef "mkt2_s" [Field] (InFileSpan (InFileLoc 32 9)(InFileLoc 32 25)) + ,mkOutlineDef "mkt2_i" [Field] (InFileSpan (InFileLoc 33 9)(InFileLoc 33 22)) + + ]+ + ] Nothing (Just "Type1 haddock") + ]+ assertEqual (length expected) (length defs)+ mapM_ (uncurry (assertEqual )) (zip expected defs)+ assertEqual [] es+ assertEqual [ImportDef "Data.Char" Nothing (InFileSpan (InFileLoc 5 1)(InFileLoc 5 17)) False False "" Nothing] is+ + +test_OutlinePreproc :: Assertion+test_OutlinePreproc = do+ let api=cabalAPI+ root<-createTestProject+ synchronize api root False+ let rel="src"</>"A.hs"+ write api root (testProjectName <.> ".cabal") $ unlines ["name: "++testProjectName,+ "version:0.1",+ "cabal-version: >= 1.8",+ "build-type: Simple",+ "",+ "library",+ " hs-source-dirs: src",+ " exposed-modules: A",+ " build-depends: base",+ " extensions: CPP",+ " ghc-options: -Wall",+ " cpp-options: -DCABAL_VERSION=112"]+ configure api root Target + -- use api to write temp file+ write api root rel $ unlines [+ "{-# LANGUAGE CPP #-}",+ "",+ "module Module1 where",+ "",+ "#if CABAL_VERSION > 110",+ "testfunc1=reverse \"test\"",+ "#endif",+ ""+ ]+ (_,nsErrors3f)<-getBuildFlags api root rel+ assertBool (null nsErrors3f) + (OutlineResult defs1 _ _,nsErrors1)<-getOutline api root rel+ assertBool (null nsErrors1)+ let expected1=[+ mkOutlineDef "testfunc1" [Function] (InFileSpan (InFileLoc 6 1)(InFileLoc 6 25))+ ]+ assertEqual (length expected1) (length defs1)+ mapM_ (uncurry (assertEqual )) (zip expected1 defs1)+ write api root rel $ unlines [+ "{-# LANGUAGE CPP #-}",+ "",+ "module Module1 where",+ "",+ "data Name",+ " = Ident String -- ^ /varid/ or /conid/.",+ " | Symbol String -- ^ /varsym/ or /consym/",+ "#ifdef __GLASGOW_HASKELL__",+ " deriving (Eq,Ord,Show,Typeable,Data)",+ "#else",+ " deriving (Eq,Ord,Show)",+ "#endif",+ ""+ ]+ (OutlineResult defs2 _ _,nsErrors2)<-getOutline api root rel+ assertBool (null nsErrors2)+ let expected2=[+ mkOutlineDefWithChildren "Name" [Data] (InFileSpan (InFileLoc 5 1)(InFileLoc 9 38)) [+ OutlineDef "Ident" [Constructor] (InFileSpan (InFileLoc 6 6)(InFileLoc 6 18)) [] Nothing (Just "/varid/ or /conid/."),+ OutlineDef "Symbol" [Constructor] (InFileSpan (InFileLoc 7 6)(InFileLoc 7 19)) [] Nothing (Just "/varsym/ or /consym/")+ ]+ ] + assertEqual (length expected2) (length defs2)+ mapM_ (uncurry (assertEqual )) (zip expected2 defs2)+ write api root rel $ unlines [+ "{-# LANGUAGE CPP #-}",+ "",+ "module Module1 where",+ "",+ "#ifdef __GLASGOW_HASKELL__",+ "testfunc1=reverse \"test\"",+ "#else",+ "testfunc2=reverse \"test\"",+ "#endif",+ ""+ ]+ (OutlineResult defs3 _ _,nsErrors3)<-getOutline api root rel+ assertBool (null nsErrors3)+ let expected3=[+ mkOutlineDef "testfunc1" [Function] (InFileSpan (InFileLoc 6 1)(InFileLoc 6 25)) + ]+ assertEqual (length expected3) (length defs3)+ mapM_ (uncurry (assertEqual )) (zip expected3 defs3)+ + + +test_OutlineLiterate :: Assertion+test_OutlineLiterate = do+ let api=cabalAPI+ root<-createTestProject+ synchronize api root False+ let rel="src"</>"A.lhs"+ -- use api to write temp file+ write api root rel $ unlines [+ "comment 1",+ "",+ "> module Module1 where",+ "",+ "",+ "> testfunc1=reverse \"test\"",+ "",+ ""+ ]+ (_,nsErrors3f)<-getBuildFlags api root rel+ assertBool (null nsErrors3f)+ (OutlineResult defs1 _ _,nsErrors1)<-getOutline api root rel+ assertBool (null nsErrors1)+ let expected1=[+ mkOutlineDef "testfunc1" [Function] (InFileSpan (InFileLoc 6 3)(InFileLoc 6 27)) + ]+ assertEqual (length expected1) (length defs1)+ mapM_ (uncurry (assertEqual)) (zip expected1 defs1)+ + +test_OutlineImportExport :: Assertion+test_OutlineImportExport = do+ let api=cabalAPI+ root<-createTestProject+ synchronize api root False+ let rel="src"</>"A.hs"+ -- use api to write temp file+ write api root rel $ unlines [+ "module Module1 (dummy,module Data.Char,MkTest(..)) where",+ "",+ "import Data.Char",+ "import Data.Map as DM (empty) ",+ "import Data.List hiding (orderBy,groupBy)",+ "import qualified Data.Maybe (Maybe(Just))"+ ]+ (_,nsErrors3f)<-getBuildFlags api root rel+ assertBool (null nsErrors3f)+ (OutlineResult _ es is,nsErrors1)<-getOutline api root rel+ assertBool (null nsErrors1)+ let exps=[+ ExportDef "dummy" IEVar (InFileSpan (InFileLoc 1 17)(InFileLoc 1 22)) [],+ ExportDef "Data.Char" IEModule (InFileSpan (InFileLoc 1 23)(InFileLoc 1 39)) [],+ ExportDef "MkTest" IEThingAll (InFileSpan (InFileLoc 1 40)(InFileLoc 1 50)) []+ ]+ mapM_ (uncurry (assertEqual)) (zip exps es)+ let imps=[+ ImportDef "Data.Char" Nothing (InFileSpan (InFileLoc 3 1)(InFileLoc 3 17)) False False "" Nothing,+ ImportDef "Data.Map" Nothing (InFileSpan (InFileLoc 4 1)(InFileLoc 4 30)) False False "DM" (Just [ImportSpecDef "empty" IEVar (InFileSpan (InFileLoc 4 24)(InFileLoc 4 29)) []]),+ ImportDef "Data.List" Nothing (InFileSpan (InFileLoc 5 1)(InFileLoc 5 42)) False True "" (Just [ImportSpecDef "orderBy" IEVar (InFileSpan (InFileLoc 5 26)(InFileLoc 5 33)) [],ImportSpecDef "groupBy" IEVar (InFileSpan (InFileLoc 5 34)(InFileLoc 5 41)) []]),+ ImportDef "Data.Maybe" Nothing (InFileSpan (InFileLoc 6 1)(InFileLoc 6 42)) True False "" (Just [ImportSpecDef "Maybe" IEThingWith (InFileSpan (InFileLoc 6 30)(InFileLoc 6 41)) ["Just"]])+ ] + mapM_ (uncurry (assertEqual)) (zip imps is)+ + + +test_OutlineMultiParam :: Assertion+test_OutlineMultiParam = do+ let api=cabalAPI+ root<-createTestProject+ synchronize api root False+ let rel="src"</>"A.hs" + write api root rel $ unlines [+ "{-# LANGUAGE MultiParamTypeClasses #-}",+ "module A where",+ "",+ "class C a b",+ " where",+ " c :: a -> b"+ ]+ let rel2="src"</>"B"</>"C.hs" + write api root rel2 $ unlines [+ "module B.C where",+ "",+ "import A",+ "myC ::", + " (C a b)", + " => ",+ " a -> b", + "myC = c"+ ] + (_,nsErrors3f)<-getBuildFlags api root rel2+ assertBool (null nsErrors3f)+ (OutlineResult ors _ _,nsErrors1)<-getOutline api root rel2+ assertBool (null nsErrors1)+ assertBool (not $ null ors)++ +test_OutlineOperator :: Assertion+test_OutlineOperator = do+ let api=cabalAPI+ root<-createTestProject+ synchronize api root False+ let rel="src"</>"A.hs" + write api root rel $ unlines [+ "{-# LANGUAGE MultiParamTypeClasses #-}",+ "module A ( Collection (",+ " (>-)",+ " )",+ " )where",+ " infixl 5 >-",+ " class Collection a where", + " (>-) :: Eq b => a b -> a b -> a b"+ ]+ (_,nsErrors3f)<-getBuildFlags api root rel+ assertBool (null nsErrors3f)+ (OutlineResult ors _ _,nsErrors1)<-getOutline api root rel+ assertBool (null nsErrors1)+ assertBool (not $ null ors)++test_OutlinePatternGuards :: Assertion+test_OutlinePatternGuards = do+ let api=cabalAPI+ root<-createTestProject+ synchronize api root False+ let rel="src"</>"A.hs" + write api root rel $ unlines [+ "module A",+ " where",+ "toto o | Just s<-o=s",+ "toto _=\"\" "+ ]+ (_,nsErrors3f)<-getBuildFlags api root rel+ assertBool (null nsErrors3f)+ (bool3,nsErrors3)<-build1 api root rel+ assertBool (isJust bool3)+ assertBool (not (any (\ x -> BWError == bwnStatus x) nsErrors3))+ (OutlineResult ors _ _,nsErrors1)<-getOutline api root rel+ assertBool (null nsErrors1)+ assertBool (not $ null ors)++ +test_OutlineExtension :: Assertion+test_OutlineExtension = do+ let api=cabalAPI+ root<-createTestProject+ let cf=testCabalFile root+ writeFile cf $ unlines ["name: "++testProjectName,+ "version:0.1",+ "cabal-version: >= 1.8",+ "build-type: Simple",+ "",+ "library",+ " hs-source-dirs: src",+ " exposed-modules: A",+ " other-modules: B.C",+ " build-depends: base",+ " extensions: EmptyDataDecls"]+ let rel="src"</>"A.hs" + write api root rel $ unlines [+ "module A",+ " where",+ "data B"+ ]+ synchronize api root False + configure api root Source+ (_,nsErrors3f)<-getBuildFlags api root rel+ assertBool (null nsErrors3f)+ (bool3,nsErrors3)<-build1 api root rel+ assertBool (isJust bool3)+ assertBool (not (any (\ x -> BWError == bwnStatus x) nsErrors3))+ (OutlineResult ors _ _,nsErrors1)<-getOutline api root rel+ assertBool (null nsErrors1)+ assertBool (not $ null ors)+ + +test_OutlineOptions :: Assertion+test_OutlineOptions = do+ let api=cabalAPI+ root<-createTestProject+ synchronize api root False+ let rel="src"</>"A.hs" + write api root rel $ unlines [+ "{-# OPTIONS -XMultiParamTypeClasses -XTupleSections -XRank2Types -XScopedTypeVariables -XTypeOperators #-}",+ "module A where",+ "-- MultiParamTypeClasses",+ "class C a b", + "-- TupleSections",+ "test1 = ((),)", + "-- Rank2Types",+ "test2 :: (forall a . a) -> b",+ "test2 a = undefined",+ "-- TypeOperators",+ "type a :-: b = (a,b)",+ "-- ScopedTypeVariables",+ "test3 :: forall a . a -> a",+ "test3 x = x :: a"+ ]+ (_,nsErrors3f)<-getBuildFlags api root rel+ assertBool (null nsErrors3f)+ (bool3,nsErrors3)<-build1 api root rel+ assertBool (isJust bool3)+ assertBool (not (any (\ x -> BWError == bwnStatus x) nsErrors3))+ (OutlineResult ors _ _,nsErrors1)<-getOutline api root rel+ assertBool (null nsErrors1)+ assertBool (not $ null ors)+ + +test_PreviewTokenTypes :: Assertion+test_PreviewTokenTypes = do+ let api=cabalAPI+ root<-createTestProject+ synchronize api root False+ configure api root Target + let rel="src"</>"Main.hs"+ write api root rel $ unlines [+ "{-# LANGUAGE TemplateHaskell,CPP #-}",+ "-- a comment",+ "module Main where", + "",+ "main :: IO (Int)",+ "main = do" ,+ " putStr ('h':\"ello Prefs!\")",+ " return (2 + 2)",+ "",+ "#if USE_TH",+ "$( derive makeTypeable ''Extension )",+ "#endif",+ ""+ ]+ (tts,nsErrors1)<-getTokenTypes api root rel+ assertBool (null nsErrors1)+ let expectedS="[{\"P\":[1,1,37]},{\"C\":[2,1,13]},{\"K\":[3,1,7]},{\"IC\":[3,8,12]},{\"K\":[3,13,18]},{\"IV\":[5,1,5]},{\"S\":[5,6,8]},{\"IC\":[5,9,11]},{\"SS\":[5,12]},{\"IC\":[5,13,16]},{\"SS\":[5,16]},{\"IV\":[6,1,5]},{\"S\":[6,6]},{\"K\":[6,8,10]},{\"IV\":[7,9,15]},{\"SS\":[7,16]},{\"LC\":[7,17,20]},{\"S\":[7,20]},{\"LS\":[7,21,34]},{\"SS\":[7,34]},{\"IV\":[8,9,15]},{\"SS\":[8,16]},{\"LI\":[8,17]},{\"VS\":[8,19]},{\"LI\":[8,21]},{\"SS\":[8,22]},{\"PP\":[10,1,11]},{\"TH\":[11,1,3]},{\"IV\":[11,4,10]},{\"IV\":[11,11,23]},{\"TH\":[11,24,26]},{\"IC\":[11,26,35]},{\"SS\":[11,36]},{\"PP\":[12,1,7]}]"+ assertEqual expectedS (encode $ toJSON tts)++test_PreviewTokenTypesLine :: Assertion+test_PreviewTokenTypesLine = do+ let api=cabalAPI+ root<-createTestProject+ synchronize api root False+ configure api root Target + let rel="src"</>"Main.hs"+ write api root rel $ unlines [+ "{-# LINE 42 \"Foo.vhs\" #-}",+ "-- a comment",+ "module Main where", + "",+ "main :: IO (Int)",+ "main = do" ,+ " putStr ('h':\"ello Prefs!\")",+ " return (2 + 2)",+ "",+ "#if USE_TH",+ "$( derive makeTypeable ''Extension )",+ "#endif",+ ""+ ]+ (tts,nsErrors1)<-getTokenTypes api root rel+ assertBool (null nsErrors1)+ let expectedS="[{\"P\":[1,1,26]},{\"C\":[2,1,13]},{\"K\":[3,1,7]},{\"IC\":[3,8,12]},{\"K\":[3,13,18]},{\"IV\":[5,1,5]},{\"S\":[5,6,8]},{\"IC\":[5,9,11]},{\"SS\":[5,12]},{\"IC\":[5,13,16]},{\"SS\":[5,16]},{\"IV\":[6,1,5]},{\"S\":[6,6]},{\"K\":[6,8,10]},{\"IV\":[7,9,15]},{\"SS\":[7,16]},{\"LC\":[7,17,20]},{\"S\":[7,20]},{\"LS\":[7,21,34]},{\"SS\":[7,34]},{\"IV\":[8,9,15]},{\"SS\":[8,16]},{\"LI\":[8,17]},{\"VS\":[8,19]},{\"LI\":[8,21]},{\"SS\":[8,22]},{\"PP\":[10,1,11]},{\"TH\":[11,1,3]},{\"IV\":[11,4,10]},{\"IV\":[11,11,23]},{\"TH\":[11,24,26]},{\"IC\":[11,26,35]},{\"SS\":[11,36]},{\"PP\":[12,1,7]}]"+ assertEqual expectedS (encode $ toJSON tts)+ +test_PreviewTokenTypesHaddock :: Assertion+test_PreviewTokenTypesHaddock = do+ let api=cabalAPI+ root<-createTestProject+ synchronize api root False+ configure api root Target + let rel="src"</>"Main.hs"+ write api root rel $ unlines [+ "{-# LINE 42 \"Foo.vhs\" #-}",+ "-- | a comment",+ "module Main where", + "",+ "main :: IO (Int)",+ "main = do" ,+ " putStr ('h':\"ello Prefs!\")",+ " return (2 + 2)",+ ""+ ]+ (tts,nsErrors1)<-getTokenTypes api root rel+ assertBool (null nsErrors1)+ let expectedS="[{\"P\":[1,1,26]},{\"D\":[2,1,15]},{\"K\":[3,1,7]},{\"IC\":[3,8,12]},{\"K\":[3,13,18]},{\"IV\":[5,1,5]},{\"S\":[5,6,8]},{\"IC\":[5,9,11]},{\"SS\":[5,12]},{\"IC\":[5,13,16]},{\"SS\":[5,16]},{\"IV\":[6,1,5]},{\"S\":[6,6]},{\"K\":[6,8,10]},{\"IV\":[7,9,15]},{\"SS\":[7,16]},{\"LC\":[7,17,20]},{\"S\":[7,20]},{\"LS\":[7,21,34]},{\"SS\":[7,34]},{\"IV\":[8,9,15]},{\"SS\":[8,16]},{\"LI\":[8,17]},{\"VS\":[8,19]},{\"LI\":[8,21]},{\"SS\":[8,22]}]"+ assertEqual expectedS (encode $ toJSON tts) + +test_ThingAtPoint :: Assertion+test_ThingAtPoint = do+ let api=cabalAPI+ root<-createTestProject+ synchronize api root False+ configure api root Target + let rel="src"</>"Main.hs"+ write api root rel $ unlines [ + "module Main where",+ "main=return $ map id \"toto\"",+ "",+ "data DataT=MkData {name :: String}",+ "",+ "data Toot=Toot {toot :: String}",+ "",+ "fun1=let",+ " l2=reverse \"toto\"",+ " in head l2"+ ] + (_,nsErrors3f)<-getBuildFlags api root rel+ assertBool (null nsErrors3f) + (tap1,nsErrors1)<-getThingAtPoint api root rel 2 16+ assertBool (null nsErrors1)+ assertBool (isJust tap1)+ assertEqual "map" (tapName $ fromJust tap1)+ assertEqual (Just "GHC.Base") (tapModule $ fromJust tap1)+ assertEqual (Just "(GHC.Types.Char -> GHC.Types.Char) -> [GHC.Types.Char] -> [GHC.Types.Char]") (tapQType $ fromJust tap1)+ assertEqual (Just "(Char -> Char) -> [Char] -> [Char]") (tapType $ fromJust tap1)+ assertEqual (Just "v") (tapHType $ fromJust tap1)+ assertEqual (Just "Var") (tapGType $ fromJust tap1)+ + + (tap2,nsErrors2)<-getThingAtPoint api root rel 2 20+ assertBool (null nsErrors2)+ assertBool (isJust tap2)+ assertEqual "id" (tapName $ fromJust tap2)+ assertEqual (Just "GHC.Base") (tapModule $ fromJust tap2)+ assertEqual (Just "v") (tapHType $ fromJust tap2)+ assertEqual (Just "GHC.Types.Char -> GHC.Types.Char") (tapQType $ fromJust tap2)+ + (tap3,nsErrors3)<-getThingAtPoint api root rel 4 7+ assertBool (null nsErrors3)+ assertBool (isJust tap3)+ assertEqual "DataT" (tapName $ fromJust tap3)+ assertEqual (Just "Main") (tapModule $ fromJust tap3)+ assertEqual (Just "t") (tapHType $ fromJust tap3)+ assertEqual Nothing (tapQType $ fromJust tap3)+ +#if __GLASGOW_HASKELL__ != 704+ -- type information for constructors at the declaration is not supported by ghc 7.4 + (tap4,nsErrors4)<-getThingAtPoint api root rel 4 14+ assertBool (null nsErrors4)+ assertBool (isJust tap4)+ assertEqual "MkData" (tapName $ fromJust tap4)+ assertEqual (Just "Main") (tapModule $ fromJust tap4)+ assertEqual (Just "v") (tapHType $ fromJust tap4)+ assertEqual (Just "DataCon") (tapGType $ fromJust tap4)+ assertEqual (Just "String -> DataT") (tapType $ fromJust tap4)+ assertEqual (Just "GHC.Base.String -> Main.DataT") (tapQType $ fromJust tap4)+#endif++ (tap5,nsErrors5)<-getThingAtPoint api root rel 4 22+ assertBool (null nsErrors5)+ assertBool (isJust tap5)+ assertEqual "name" (tapName $ fromJust tap5)+ assertEqual (Just "Main") (tapModule $ fromJust tap5)+ assertEqual (Just "v") (tapHType $ fromJust tap5)+ assertEqual (Just "Main.DataT -> GHC.Base.String") (tapQType $ fromJust tap5)+ + (tap6,nsErrors6)<-getThingAtPoint api root rel 6 7+ assertBool (null nsErrors6)+ assertBool (isJust tap6)+ assertEqual "Toot" (tapName $ fromJust tap6)+ assertEqual (Just "Main") (tapModule $ fromJust tap6)+ assertEqual (Just "t") (tapHType $ fromJust tap6)+ assertEqual Nothing (tapQType $ fromJust tap6)++#if __GLASGOW_HASKELL__ != 704+ -- type information for constructors at the declaration is not supported by ghc 7.4 + (tap7,nsErrors7)<-getThingAtPoint api root rel 6 14+ assertBool (null nsErrors7)+ assertBool (isJust tap7)+ assertEqual "Toot" (tapName $ fromJust tap7)+ assertEqual (Just "Main") (tapModule $ fromJust tap7)+ assertEqual (Just "v") (tapHType $ fromJust tap7)+ assertEqual (Just "GHC.Base.String -> Main.Toot") (tapQType $ fromJust tap7)+ + -- type information for field names at the declaration is not supported by ghc 7.4 + (tap8,nsErrors8)<-getThingAtPoint api root rel 6 19+ assertBool (null nsErrors8)+ assertBool (isJust tap8)+ assertEqual "toot" (tapName $ fromJust tap8)+ assertEqual (Just "Main") (tapModule $ fromJust tap8)+ assertEqual (Just "v") (tapHType $ fromJust tap8)+ assertEqual (Just "Main.Toot -> GHC.Base.String") (tapQType $ fromJust tap8)+#endif + + (tap9,nsErrors9)<-getThingAtPoint api root rel 9 5+ assertBool (null nsErrors9)+ assertBool (isJust tap9)+ assertEqual "l2" (tapName $ fromJust tap9)+ assertEqual (Just "") (tapModule $ fromJust tap9)+ assertEqual (Just "v") (tapHType $ fromJust tap9)+ assertEqual (Just "[GHC.Types.Char]") (tapQType $ fromJust tap9)+++test_ThingAtPointTypeReduction :: Assertion+test_ThingAtPointTypeReduction = do+ let api=cabalAPI+ root<-createTestProject+ let cf=testCabalFile root+ writeFile cf $ unlines ["name: "++testProjectName,+ "version:0.1",+ "cabal-version: >= 1.8",+ "build-type: Simple",+ "",+ "executable BWTest",+ " hs-source-dirs: src",+ " main-is: Main.hs",+ " build-depends: base, containers"]+ let rel="src"</>"Main.hs"+ synchronize api root False+ configure api root Source + write api root rel $ unlines [ + "module Main where",+ "import qualified Data.Map as M",+ "main=putStrLn \"M\"",+ "",+ "fun1 :: M.Map String Int",+ "fun1 = M.insert \"key\" 1 M.empty"+ ] + (_,nsErrorsMf)<-getBuildFlags api root rel+ assertBool (null nsErrorsMf) + (tapM,nsErrorsM)<-getThingAtPoint api root rel 6 13+ assertBool (null nsErrorsM)+ assertBool (isJust tapM)+ assertEqual "insert" (tapName $ fromJust tapM)+#if __GLASGOW_HASKELL__ >= 706+ assertEqual (Just "Data.Map.Base") (tapModule $ fromJust tapM)+ assertEqual (Just "v") (tapHType $ fromJust tapM)+ assertEqual (Just "GHC.Base.String -> GHC.Types.Int -> Data.Map.Base.Map GHC.Base.String GHC.Types.Int -> Data.Map.Base.Map GHC.Base.String GHC.Types.Int") (tapQType $ fromJust tapM)+#else+ assertEqual (Just "Data.Map") (tapModule $ fromJust tapM)+ assertEqual (Just "v") (tapHType $ fromJust tapM)+ assertEqual (Just "GHC.Base.String -> GHC.Types.Int -> Data.Map.Map GHC.Base.String GHC.Types.Int -> Data.Map.Map GHC.Base.String GHC.Types.Int") (tapQType $ fromJust tapM)+#endif+++test_ThingAtPointNotInCabal :: Assertion+test_ThingAtPointNotInCabal = do+ let api=cabalAPI+ root<-createTestProject+ synchronize api root False+ configure api root Target + let rel2="src"</>"Auto.hs"+ writeFile (root </> rel2) $ unlines ["module Auto where","fAuto=head [2,3,4]"] + synchronize api root False+ (_,nsErrors3f)<-getBuildFlags api root rel2+ assertBool (null nsErrors3f)+ (tap1,nsErrors1)<-getThingAtPoint api root rel2 2 8+ assertBool (null nsErrors1)+ assertBool (isJust tap1)+ assertEqual "head" (tapName $ fromJust tap1)+ assertEqual (Just "GHC.List") (tapModule $ fromJust tap1)+ assertEqual (Just "[GHC.Integer.Type.Integer] -> GHC.Integer.Type.Integer") (tapQType $ fromJust tap1)+++test_ThingAtPointMain :: Assertion+test_ThingAtPointMain = do+ let api=cabalAPI+ root<-createTestProject+ let cf=testCabalFile root+ writeFile cf $ unlines ["name: "++testProjectName,+ "version:0.1",+ "cabal-version: >= 1.8",+ "build-type: Simple",+ "",+ "executable BWTest",+ " hs-source-dirs: src",+ " main-is: A.hs",+ " other-modules: B.D",+ " build-depends: base"]+ let rel="src"</>"A.hs" + writeFile (root </> rel) $ unlines [ + "module Main where",+ "import B.D",+ "main=return $ head [2,3,4]"+ ]+ synchronize api root False+ configure api root Target + (bf3,nsErrors3f)<-getBuildFlags api root rel+ assertBool (null nsErrors3f)+ assertEqual (Just "Main") (bfModName bf3)+ (tap1,nsErrors1)<-getThingAtPoint api root rel 3 16+ assertBool (null nsErrors1)+ assertBool (isJust tap1)+ assertEqual "head" (tapName $ fromJust tap1)+ assertEqual (Just "GHC.List") (tapModule $ fromJust tap1)+ assertEqual (Just "[GHC.Integer.Type.Integer] -> GHC.Integer.Type.Integer") (tapQType $ fromJust tap1)+ +-- (tap2,nsErrors2)<-getThingAtPoint api root rel 2 8+-- assertBool ("errors or warnings on getThingAtPoint2:"++show nsErrors2) (null nsErrors2)+-- assertBool "not just tap2" (isJust tap2)+-- assertEqual "not B.D" "B.D" (tapName $ fromJust tap2)+-- assertEqual "not ModuleName" (Just "ModuleName") (tapGType $ fromJust tap2)+-- assertEqual "not m" (Just "m") (tapHType $ fromJust tap2)+-- ++ +test_ThingAtPointMainSubFolder :: Assertion+test_ThingAtPointMainSubFolder = do+ let api=cabalAPI+ root<-createTestProject+ let cf=testCabalFile root+ writeFile cf $ unlines ["name: "++testProjectName,+ "version:0.1",+ "cabal-version: >= 1.8",+ "build-type: Simple",+ "",+ "executable BWTest",+ " hs-source-dirs: src",+ " main-is: src2/A.hs",+ " other-modules: B.D",+ " build-depends: base"]+ let sf=root </> "src" </> "src2"+ createDirectory sf + let rel="src" </> "src2" </> "A.hs" + writeFile (root </> rel) $ unlines [ + "module Main where",+ "import B.D",+ "main=return $ head [2,3,4]"+ ]+ synchronize api root False+ configure api root Target + (bf3,nsErrors3f)<-getBuildFlags api root rel+ assertBool (null nsErrors3f)+ assertEqual (Just "Main") (bfModName bf3)+ (tap1,nsErrors1)<-getThingAtPoint api root rel 3 16+ assertBool (null nsErrors1)+ assertBool (isJust tap1)+ assertEqual "head" (tapName $ fromJust tap1)+ assertEqual (Just "GHC.List") (tapModule $ fromJust tap1)+ assertEqual (Just "[GHC.Integer.Type.Integer] -> GHC.Integer.Type.Integer") (tapQType $ fromJust tap1)+ +test_Locals :: Assertion+test_Locals = do+ let api=cabalAPI+ root<-createTestProject+ synchronize api root False+ configure api root Target + let rel="src"</>"Main.hs"+ write api root rel $ unlines [ + "module Main where",+ "main=return $ map id \"toto\"",+ "",+ "fun1 l1=let",+ " l2=reverse \"toto\"",+ " in head l2"+ ] + (_,nsErrors)<-getBuildFlags api root rel+ assertBool (null nsErrors) + (loc1,nsErrors1)<-getLocals api root rel 4 1 6 15+ assertBool (null nsErrors1)+ assertBool (not $ null loc1)+ let names=map tapName loc1+ assertBool (elem "l2" names)+ assertBool (elem "l1" names)+ write api root rel $ unlines [ + "module Main where",+ "main=return $ map id \"toto\"",+ "",+ "fun1 l1=do",+ " let l2=reverse \"toto\"",+ " reverse head l2"+ ] + (_,nsErrorsM)<-getBuildFlags api root rel+ assertBool (null nsErrorsM) + (loc2,nsErrors2)<-getLocals api root rel 4 1 6 15+ assertBool (null nsErrors2)+ assertBool (not $ null loc2)+ let namesM=map tapName loc2+ assertBool (elem "l2" namesM)+ assertBool (elem "l1" namesM)+ return ()+++test_NamesInScope :: Assertion+test_NamesInScope = do+ let api=cabalAPI+ root<-createTestProject+ synchronize api root False+ configure api root Source + let rel="src"</>"Main.hs"+ writeFile (root </> rel) $ unlines [ + "module Main where",+ "import B.D",+ "main=return $ map id \"toto\""+ ] + build api root True Source+ synchronize api root False+ --c1<-getClockTime+ (mtts,nsErrors1)<-getNamesInScope api root rel+ --c2<-getClockTime+ --putStrLn ("testNamesInScope: " ++ (timeDiffToString $ diffClockTimes c2 c1))+ assertBool (null nsErrors1)+ assertBool (isJust mtts)+ let tts=fromJust mtts+ assertBool ("Main.main" `elem` tts)+ assertBool ("B.D.fD" `elem` tts)+ assertBool ("GHC.Types.Char" `elem` tts)++ +test_NameDefsInScope :: Assertion+test_NameDefsInScope = do+ let api=cabalAPI+ root<-createTestProject+ synchronize api root False+ configure api root Source + let rel="src"</>"Main.hs"+ writeFile (root </> rel) $ unlines [ + "module Main where",+ "import B.D",+ "main=return $ map id \"toto\"",+ "data Type1=MkType1_1 Int"+ ] + build api root True Source+ synchronize api root False+ (mtts,_)<-build1 api root rel+ assertBool (isJust mtts)+ let tts=fromJust mtts+ assertBool (NameDef "Main.main" [Function] (Just "IO [Char]") `elem` tts)+ assertBool (NameDef "B.D.fD" [Function] (Just "forall a. a") `elem` tts)+ assertBool (NameDef "Main.Type1" [Type] Nothing `elem` tts)+ assertBool (NameDef "Main.MkType1_1" [Constructor] (Just "Int -> Type1") `elem` tts)+ assertBool (NameDef "GHC.Types.Char" [Type] Nothing `elem` tts)+++ +test_InPlaceReference :: Assertion+test_InPlaceReference = do+ let api=cabalAPI+ root<-createTestProject+ synchronize api root False+ writeFile (root </> (testProjectName <.> ".cabal")) $ unlines ["name: "++testProjectName,+ "version:0.1",+ "cabal-version: >= 1.8",+ "build-type: Simple",+ "",+ "library",+ " hs-source-dirs: src",+ " exposed-modules: A,B.C",+ " build-depends: base",+ "",+ "executable BWTest",+ " hs-source-dirs: src",+ " main-is: Main.hs",+ " other-modules: B.D",+ " build-depends: base, BWTest",+ "",+ "test-suite BWTest-test",+ " type: exitcode-stdio-1.0",+ " hs-source-dirs: test",+ " main-is: Main.hs",+ " other-modules: TestA",+ " build-depends: base, BWTest",+ ""+ ] + let rel="src"</>"Main.hs" + writeFile (root </> rel) $ unlines [ + "module Main where",+ "import B.C",+ "main=return $ map id \"toto\""+ ] + let rel3="test"</>"TestA.hs" + writeFile (root </> rel3) $ unlines ["module TestA where","import A","fTA=undefined"]+ let rel2="src"</>"A.hs"+ writeFile (root </> rel2) $ unlines ["module A where","import B.C","fA=undefined"] + (boolOKc,nsOKc)<-configure api root Source+ assertBool boolOKc+ assertBool (null nsOKc)+ (BuildResult boolOK _,nsOK)<-build api root True Source+ assertBool boolOK+ assertBool (null nsOK)+ synchronize api root True+ (mtts,nsErrors1)<-getNamesInScope api root rel+ assertBool (null nsErrors1)+ assertBool (isJust mtts)+ let tts=fromJust mtts+ assertBool ("Main.main" `elem` tts)+ assertBool ("B.C.fC" `elem` tts)+ (_,nsErrors3f)<-getBuildFlags api root rel+ assertBool (null nsErrors3f)+ (tap1,nsErrorsTap1)<-getThingAtPoint api root rel 3 16+ assertBool (null nsErrorsTap1)+ assertBool (isJust tap1)+ assertEqual "map" (tapName $ fromJust tap1)+ assertEqual (Just "GHC.Base") (tapModule $ fromJust tap1)+ assertEqual (Just "(GHC.Types.Char -> GHC.Types.Char) -> [GHC.Types.Char] -> [GHC.Types.Char]") (tapQType $ fromJust tap1)+ (mtts2,nsErrors2)<-getNamesInScope api root rel2+ assertBool (null nsErrors2)+ assertBool (isJust mtts2)+ let tts2=fromJust mtts2+ assertBool ("A.fA" `elem` tts2) + assertBool ("B.C.fC" `elem` tts2) + + (mtts3,nsErrors3)<-getNamesInScope api root rel3+ assertBool (null nsErrors3)+ assertBool (isJust mtts3)+ let tts3=fromJust mtts3+ assertBool ("A.fA" `elem` tts3) +++test_CabalComponents :: Assertion+test_CabalComponents= do+ let api=cabalAPI+ root<-createTestProject+ synchronize api root False+ (cps,nsOK)<-getCabalComponents api root+ assertBool (null nsOK)+ assertEqual 3 (length cps)+ let (l:ex:ts:[])=cps+ assertEqual (CCLibrary True) l+ assertEqual (CCExecutable "BWTest" True) ex+ assertEqual (CCTestSuite "BWTest-test" True) ts+ let cf=testCabalFile root+ writeFile cf $ unlines ["name: "++testProjectName,+ "version:0.1",+ "cabal-version: >= 1.8",+ "build-type: Simple",+ "",+ "library",+ " hs-source-dirs: src",+ " exposed-modules: A",+ " other-modules: B.C",+ " build-depends: base",+ " buildable: False",+ "",+ "executable BWTest",+ " hs-source-dirs: src",+ " main-is: Main.hs",+ " other-modules: B.D",+ " build-depends: base",+ " buildable: False",+ "",+ "test-suite BWTest-test",+ " type: exitcode-stdio-1.0",+ " hs-source-dirs: test",+ " main-is: Main.hs",+ " other-modules: TestA",+ " build-depends: base",+ " buildable: False",+ ""+ ]+ configure api root Source+ (cps2,nsOK2)<-getCabalComponents api root+ assertBool (null nsOK2)+ assertEqual 3 (length cps2)+ let (l2:ex2:ts2:[])=cps2+ assertEqual (CCLibrary False) l2+ assertEqual (CCExecutable "BWTest" False) ex2+ assertEqual (CCTestSuite "BWTest-test" False) ts2 +++test_CabalDependencies :: Assertion+test_CabalDependencies = do+ let api=cabalAPI+ root<-createTestProject+ let cf=testCabalFile root+ writeFile cf $ unlines ["name: "++testProjectName,+ "version:0.1",+ "cabal-version: >= 1.8",+ "build-type: Simple",+ "",+ "library",+ " hs-source-dirs: src",+ " exposed-modules: A",+ " other-modules: B.C",+ " build-depends: base",+ "",+ "executable BWTest",+ " hs-source-dirs: src",+ " main-is: Main.hs",+ " other-modules: B.D",+ " build-depends: base",+ "",+ "test-suite BWTest-test",+ " type: exitcode-stdio-1.0",+ " hs-source-dirs: test",+ " main-is: Main.hs",+ " other-modules: TestA",+ " build-depends: base,filepath",+ ""]+ synchronize api root False+ (cps,nsOK)<-getCabalDependencies api root Nothing+ assertBool (null nsOK)+ assertEqual 2 (length cps)+ let [(_,pkgs1),(_,pkgs2)] = cps -- One is global and one is local, but the order depends on the paths, + pkgs = pkgs1 ++ pkgs2 -- so we concatenate the two.+ let base=filter (\pkg->cpName pkg == "base") pkgs+ assertEqual 1 (length base)+ let (l:ex:ts:[])=cpDependent $ head base+ assertEqual (CCLibrary True) l+ assertEqual (CCExecutable "BWTest" True) ex+ assertEqual (CCTestSuite "BWTest-test" True) ts+ let fp=filter (\pkg->cpName pkg == "filepath") pkgs+ assertEqual 1 (length fp)+ let (lfp:[])=cpDependent $ head fp+ assertEqual (CCTestSuite "BWTest-test" True) lfp+++test_NoSourceDir :: Assertion+test_NoSourceDir = do+ let api=cabalAPI+ root<-createTestProject+ let cf=testCabalFile root+ writeFile cf $ unlines ["name: "++testProjectName,+ "version:0.1",+ "cabal-version: >= 1.8",+ "build-type: Simple",+ "",+ "library",+ " exposed-modules: A",+ " other-modules: B.C",+ " build-depends: base",+ "",+ "executable BWTest",+ " main-is: src/Main.hs",+ " other-modules: B.D",+ " build-depends: base",+ ""]+ let git=root </> ".git"+ createDirectoryIfMissing False git+ let gitInBW=root </> ".dist-buildwrapper" </> ".git"+ writeFile (git </> "testfile") "test"+ d1<-doesDirectoryExist gitInBW+ assertBool (not d1)+ + let bwInBw=root </> ".dist-buildwrapper" </> ".dist-buildwrapper"+ d1b<-doesDirectoryExist bwInBw+ assertBool (not d1b)+ + synchronize api root False+ d2<-doesDirectoryExist gitInBW+ assertBool (not d2)+ + d2b<-doesDirectoryExist bwInBw+ assertBool (not d2b)+ +++test_Flags :: Assertion+test_Flags = do+ let api=cabalAPI+ root<-createTestProject+ let cf=testCabalFile root+ writeFile cf $ unlines ["name: "++testProjectName,+ "version:0.1",+ "cabal-version: >= 1.8",+ "build-type: Simple",+ "",+ "flag server",+ " description: Install the scion-server.",+ " default: False",+ "",+ "library",+ " hs-source-dirs: src",+ " exposed-modules: A",+ " other-modules: B.C",+ " build-depends: base",+ "",+ "executable BWTest",+ " if !flag(server)",+ " buildable: False",+ " hs-source-dirs: src",+ " main-is: Main.hs",+ " other-modules: B.D",+ " build-depends: base",+ ""+ ]+ configure api root Source+ build api root True Source+ let exePath=root </> ".dist-buildwrapper" </> "dist" </> "build" </> testProjectName </> "BWTest" <.> exeExtension+ ex1<-doesFileExist exePath+ assertBool (not ex1)+ + configureWithFlags api root Source "server"+ build api root True Source+ ex2<-doesFileExist exePath+ assertBool ex2+ + ++test_BuildFlags :: Assertion+test_BuildFlags =do+ let api=cabalAPI+ root<-createTestProject+ let cf=testCabalFile root+ writeFile cf $ unlines ["name: "++testProjectName,+ "version:0.1",+ "cabal-version: >= 1.8",+ "build-type: Simple",+ "",+ "library",+ " hs-source-dirs: src",+ " exposed-modules: A",+ " other-modules: B.C",+ " build-depends: base",+ " extensions: OverlappingInstances"+ ]+ configure api root Source + let rel="src"</>"A.hs" + (flgs,nsErrors3f)<-getBuildFlags api root rel+ -- print flgs+ assertBool (null nsErrors3f)+ let ast=bfAst flgs + assertBool ("-package-name" `elem` ast)+ assertBool ("BWTest-0.1" `elem` ast)+ assertBool ("-XOverlappingInstances" `elem` ast)+ assertBool ("OverlappingInstances" `notElem` ast)+ + +test_ExplicitComponent :: Assertion+test_ExplicitComponent =do+ let api=cabalAPI+ root<-createTestProject+ let cf=testCabalFile root+ writeFile cf $ unlines ["name: "++testProjectName,+ "version:0.1",+ "cabal-version: >= 1.8",+ "build-type: Simple",+ "",+ "library",+ " hs-source-dirs: src",+ " exposed-modules: A",+ " other-modules: B",+ " build-depends: base,containers",+ "executable BWTest",+ " hs-source-dirs: src",+ " main-is: Main.hs",+ " other-modules: B",+ " build-depends: base,containers",+ "",+ "executable BWTest2",+ " hs-source-dirs: src",+ " main-is: Main2.hs",+ " other-modules: B",+ " build-depends: base"+ ]+ let rel="src"</>"B.hs" + writeFile (root </> rel) $ unlines [+ "module B where",+ "import qualified Data.Map as M",+ "ins=M.insert 'k' 0 M.empty"+ ]+ configure api root Source + + synchronize1 api root True rel+ --build1 api root rel+ (names1,nsErrors1)<-build1c api root rel ""+ assertBool (isJust names1)+ assertBool (null nsErrors1)+ (names2,nsErrors2)<-build1c api root rel "BWTest"+ assertBool (isJust names2)+ assertBool (null nsErrors2)+ (names3,nsErrors3)<-build1c api root rel "BWTest2"+ assertBool (isNothing names3)+ assertBool (not $ null nsErrors3)+ + +test_ExplicitComponentUnRef :: Assertion+test_ExplicitComponentUnRef =do+ let api=cabalAPI+ root<-createTestProject+ let cf=testCabalFile root+ writeFile cf $ unlines ["name: "++testProjectName,+ "version:0.1",+ "cabal-version: >= 1.8",+ "build-type: Simple",+ "",+ "library",+ " hs-source-dirs: src",+ " exposed-modules: A",+ " build-depends: base,containers",+ "executable BWTest",+ " hs-source-dirs: src",+ " main-is: Main.hs",+ " build-depends: base,containers",+ "",+ "executable BWTest2",+ " hs-source-dirs: src",+ " main-is: Main2.hs",+ " build-depends: base"+ ]+ let rel="src"</>"B.hs" + writeFile (root </> rel) $ unlines [+ "module B where",+ "import qualified Data.Map as M",+ "ins=M.insert 'k' 0 M.empty"+ ]+ configure api root Source + + synchronize1 api root True rel+ --build1 api root rel+ (names1,nsErrors1)<-build1c api root rel ""+ assertBool (isJust names1)+ assertBool (null nsErrors1)+ (names2,nsErrors2)<-build1c api root rel "BWTest"+ assertBool (isJust names2)+ assertBool (null nsErrors2)+ (names3,nsErrors3)<-build1c api root rel "BWTest2"+ assertBool (isNothing names3)+ assertBool (not $ null nsErrors3)+ +test_CleanFiles :: Assertion+test_CleanFiles =do+ let api=cabalAPI+ root<-createTestProject+ synchronize api root False+ let fldr=root </> ".dist-buildwrapper"+ let file=fldr </> "src" </> ".A.hs.bwinfo"+ exf1<-doesFileExist file+ assertBool $ not exf1+ exd1<-doesDirectoryExist fldr+ assertBool exd1+ let rel="src"</> "A.hs"+ build1 api root rel+ getThingAtPoint api root rel 1 1+ exf2<-doesFileExist file+ assertBool exf2+ clean api root False+ exf3<-doesFileExist file+ assertBool $ not exf3+ exd2<-doesDirectoryExist fldr+ assertBool exd2+ build1 api root rel+ getThingAtPoint api root rel 1 1+ exf4<-doesFileExist file+ assertBool exf4+ clean api root True+ exf5<-doesFileExist file+ assertBool $ not exf5+ exd3<-doesDirectoryExist fldr+ assertBool $ not exd3+ +testProjectName :: String+testProjectName="BWTest" + +testCabalContents :: String+testCabalContents = unlines ["name: "++testProjectName,+ "version:0.1",+ "cabal-version: >= 1.8",+ "build-type: Simple",+ "",+ "library",+ " hs-source-dirs: src",+ " exposed-modules: A",+ " other-modules: B.C",+ " build-depends: base",+ "",+ "executable BWTest",+ " hs-source-dirs: src",+ " main-is: Main.hs",+ " other-modules: B.D",+ " build-depends: base",+ "",+ "test-suite BWTest-test",+ " type: exitcode-stdio-1.0",+ " hs-source-dirs: test",+ " main-is: Main.hs",+ " other-modules: TestA",+ " build-depends: base",+ ""+ ] + +testCabalFile :: FilePath -> FilePath+testCabalFile root =root </> ((last $ splitDirectories root) <.> ".cabal") + +testAContents :: String +testAContents=unlines ["module A where","fA=undefined"]+testCContents :: String+testCContents=unlines ["module B.C where","fC=undefined"] +testDContents :: String+testDContents=unlines ["module B.D where","fD=undefined"] +testMainContents :: String+testMainContents=unlines ["module Main where","main=undefined"] +testMainTestContents :: String+testMainTestContents=unlines ["module Main where","main=undefined"] +testTestAContents :: String+testTestAContents=unlines ["module TestA where","fTA=undefined"] + +testSetupContents ::String+testSetupContents = unlines ["#!/usr/bin/env runhaskell",+ "import Distribution.Simple",+ "main :: IO ()",+ "main = defaultMain"] + +createTestProject :: IO FilePath+createTestProject = do+ temp<-getTemporaryDirectory+ let root=temp </> testProjectName+ ex<-doesDirectoryExist root+ when ex (removeDirectoryRecursive root)+ createDirectory root+ writeFile (testCabalFile root) testCabalContents+ writeFile (root </> "Setup.hs") testSetupContents+ let srcF=root </> "src"+ createDirectory srcF+ writeFile (srcF </> "A.hs") testAContents+ let b=srcF </> "B"+ createDirectory b+ writeFile (b </> "C.hs") testCContents+ writeFile (b </> "D.hs") testDContents+ writeFile (srcF </> "Main.hs") testMainContents+ let testF=root </> "test"+ createDirectory testF+ writeFile (testF </> "Main.hs") testMainTestContents+ writeFile (testF </> "TestA.hs") testTestAContents+ return root+ +removeSpaces :: String -> String+removeSpaces = filter (/= ':') . filter (not . isSpace)++assertEqualNotesWithoutSpaces :: String -> BWNote -> BWNote -> IO()+assertEqualNotesWithoutSpaces msg n1 n2=do+ let+ n1'=n1{bwnTitle=removeSpaces $ bwnTitle n1}+ n2'=n1{bwnTitle=removeSpaces $ bwnTitle n2}+ assertEqualVerbose msg n1' n2'++removeLayoutTAP :: OpResult (Maybe ThingAtPoint) -> OpResult (Maybe ThingAtPoint) +removeLayoutTAP res = case res of+ (Just tap@ThingAtPoint{tapType=tp,tapQType=qtp},xs) ->+ (Just tap{tapType=removeLayout tp, tapQType=removeLayout qtp},xs)+ _ -> res+ where removeLayout (Just tp) = Just $ unwords . concatMap words . lines $ tp -- replace sequences of spaces and newlines by single space+ removeLayout Nothing = Nothing++ +runAPI:: (FromJSON a,Show a) => FilePath -> FilePath -> String -> [String] -> IO a+runAPI cabal root command args= do+ cd<-getCurrentDirectory+ let fullargs=[command,"--tempfolder=.dist-buildwrapper","--cabalpath="++cabal,"--cabalfile="++ testCabalFile root] ++ args+ exePath<-filterM doesFileExist [".dist-buildwrapper/dist/build/buildwrapper/buildwrapper" <.> exeExtension,"dist/build/buildwrapper/buildwrapper" <.> exeExtension]+ assertBool (0<length exePath)+ setCurrentDirectory root+ (ex,out,err)<-readProcessWithExitCode (cd </> head exePath) fullargs ""+ setCurrentDirectory cd+ putStrLn ("out:"++out)+ putStrLn ("err:"++err)+ assertEqual ExitSuccess ex+ let res=map (drop $ length ("build-wrapper-json:"::String)) $ filter (isPrefixOf "build-wrapper-json:") $ lines out+ assertEqual 1 (length res)+ let r=parse value $ BS.pack (head res)+ case r of+ Done _ js->do + let r1= fromJSON js+ case r1 of + Data.Aeson.Success fin->return fin+ a->do+ assertFailure (show a) + error ""+ a->do+ assertFailure (show a) + +startAPIProcess :: FilePath -> String -> [String] -> IO (Handle, Handle, Handle, ProcessHandle)+startAPIProcess root command args= do+ cd<-getCurrentDirectory+ let fullargs=[command,"--tempfolder=.dist-buildwrapper","--cabalpath=cabal","--cabalfile="++ testCabalFile root] ++ args+ exePath<-filterM doesFileExist [".dist-buildwrapper/dist/build/buildwrapper/buildwrapper" <.> exeExtension,"dist/build/buildwrapper/buildwrapper" <.> exeExtension]+ assertBool (0<length exePath)+ runInteractiveProcess (cd </> head exePath) fullargs (Just root) Nothing + +readResult :: (FromJSON a,Show a) => Handle -> IO a +readResult h= do+ l<-BS.hGetLine h+ BS.putStrLn l+ if BS.isPrefixOf "build-wrapper-json:" l+ then do+ let r=parse value $ BS.drop (BS.length "build-wrapper-json:") l+ -- print r+ case r of+ Done _ js->do + let r1= fromJSON js+ case r1 of + Data.Aeson.Success fin->return fin+ a->do+ assertFailure (show a) + a->do+ assertFailure (show a) + else+ readResult h + +continue :: Handle -> IO ()+continue h=do+ hPutStrLn h "."+ hFlush h++eval :: Handle -> String -> IO ()+eval h expr=do+ hPutStrLn h ("e "++expr)+ hFlush h++end :: Handle -> IO ()+end h =do+ hPutStrLn h "q" + hFlush h + +tokenTypesLR :: Handle -> IO ()+tokenTypesLR h =do+ hPutStrLn h "t" + hFlush h + +tapLR :: Handle -> Int -> Int -> IO()+tapLR h l c=do+ hPutStrLn h ('p':show (l,c)) + hFlush h + +cmdOpts :: [String] -> [String] +cmdOpts =map ("--cabaloption=" ++) + +notesInError :: [BWNote] -> Bool+notesInError ns=not $ null $ filter (\x->BWError == bwnStatus x) ns
test/Language/Haskell/BuildWrapper/GHCTests.hs view
@@ -65,6 +65,19 @@ assertEqual (TokenDef "PP" (mkLocation 3 1 3 7)) t3 assertEqual "\n\n\nmodule Main\n" s2 +test_PreprocPragma2Lines:: Assertion +test_PreprocPragma2Lines= + do + let s="#if GHC_VERSION=612\n{-# LANGUAGE OverloadedStrings,\n RankNTypes,\n MultiParamTypeClasses #-}\n#endif\nmodule Main\n" + let (tt,s2)=preprocessSource s False + assertEqual 5 (length tt) + let (t1:t2:t3:t4:t5:[])=tt + assertEqual (TokenDef "PP" (mkLocation 1 1 1 20)) t1 + assertEqual (TokenDef "P" (mkLocation 2 1 2 32)) t2 + assertEqual (TokenDef "P" (mkLocation 3 1 3 14)) t3 + assertEqual (TokenDef "P" (mkLocation 4 1 4 28)) t4 + assertEqual (TokenDef "PP" (mkLocation 5 1 5 7)) t5 + assertEqual "\n\n\n\n\nmodule Main\n" s2 test_Preproc2Lines:: Assertion test_Preproc2Lines=
test/Main.hs view
@@ -1,25 +1,26 @@-{-# OPTIONS_GHC -F -pgmF htfpp #-} --- | --- Module : Main --- Author : JP Moresmau --- Copyright : (c) JP Moresmau 2011 --- License : BSD3 --- --- Maintainer : jpmoresmau@gmail.com --- Stability : beta --- Portability : portable --- --- Testing exe entry point -module Main where - -import {-@ HTF_TESTS @-} Language.Haskell.BuildWrapper.APITest -import {-@ HTF_TESTS @-} Language.Haskell.BuildWrapper.CMDTests -import {-@ HTF_TESTS @-} Language.Haskell.BuildWrapper.GHCTests -import {-@ HTF_TESTS @-} Language.Haskell.BuildWrapper.UsagesTests -import {-@ HTF_TESTS @-} Language.Haskell.BuildWrapper.ImportsTests -import {-@ HTF_TESTS @-} Language.Haskell.BuildWrapper.CabalDevTests - -import Test.Framework - -main :: IO() -main = htfMain htf_importedTests +{-# OPTIONS_GHC -F -pgmF htfpp #-}+-- |+-- Module : Main+-- Author : JP Moresmau+-- Copyright : (c) JP Moresmau 2011+-- License : BSD3+-- +-- Maintainer : jpmoresmau@gmail.com+-- Stability : beta+-- Portability : portable+-- +-- Testing exe entry point+module Main where++import {-@ HTF_TESTS @-} Language.Haskell.BuildWrapper.APITest+import {-@ HTF_TESTS @-} Language.Haskell.BuildWrapper.CMDTests+import {-@ HTF_TESTS @-} Language.Haskell.BuildWrapper.CMDLongRunningTests+import {-@ HTF_TESTS @-} Language.Haskell.BuildWrapper.GHCTests+import {-@ HTF_TESTS @-} Language.Haskell.BuildWrapper.UsagesTests+import {-@ HTF_TESTS @-} Language.Haskell.BuildWrapper.ImportsTests+import {-@ HTF_TESTS @-} Language.Haskell.BuildWrapper.CabalDevTests++import Test.Framework ++main :: IO()+main = htfMain htf_importedTests