diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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. diff --git a/buildwrapper.cabal b/buildwrapper.cabal --- a/buildwrapper.cabal +++ b/buildwrapper.cabal @@ -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 -author: JP Moresmau , 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 +author: JP Moresmau , 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 diff --git a/src-exe/Language/Haskell/BuildWrapper/CMD.hs b/src-exe/Language/Haskell/BuildWrapper/CMD.hs --- a/src-exe/Language/Haskell/BuildWrapper/CMD.hs +++ b/src-exe/Language/Haskell/BuildWrapper/CMD.hs @@ -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 } diff --git a/src-exe/Main.hs b/src-exe/Main.hs --- a/src-exe/Main.hs +++ b/src-exe/Main.hs @@ -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 diff --git a/src/Language/Haskell/BuildWrapper/Base.hs b/src/Language/Haskell/BuildWrapper/Base.hs --- a/src/Language/Haskell/BuildWrapper/Base.hs +++ b/src/Language/Haskell/BuildWrapper/Base.hs @@ -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) diff --git a/src/Language/Haskell/BuildWrapper/Cabal.hs b/src/Language/Haskell/BuildWrapper/Cabal.hs --- a/src/Language/Haskell/BuildWrapper/Cabal.hs +++ b/src/Language/Haskell/BuildWrapper/Cabal.hs @@ -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) diff --git a/src/Language/Haskell/BuildWrapper/GHC.hs b/src/Language/Haskell/BuildWrapper/GHC.hs --- a/src/Language/Haskell/BuildWrapper/GHC.hs +++ b/src/Language/Haskell/BuildWrapper/GHC.hs @@ -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 "") 1 (scionColToGhcCol 1) -#else -lexLoc :: RealSrcLoc -lexLoc = mkRealSrcLoc (mkFastString "") 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 "") 1 (scionColToGhcCol 1) +#else +lexLoc :: RealSrcLoc +lexLoc = mkRealSrcLoc (mkFastString "") 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 + diff --git a/test/Language/Haskell/BuildWrapper/APITest.hs b/test/Language/Haskell/BuildWrapper/APITest.hs --- a/test/Language/Haskell/BuildWrapper/APITest.hs +++ b/test/Language/Haskell/BuildWrapper/APITest.hs @@ -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) + diff --git a/test/Language/Haskell/BuildWrapper/CMDLongRunningTests.hs b/test/Language/Haskell/BuildWrapper/CMDLongRunningTests.hs new file mode 100644 --- /dev/null +++ b/test/Language/Haskell/BuildWrapper/CMDLongRunningTests.hs @@ -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 diff --git a/test/Language/Haskell/BuildWrapper/CMDTests.hs b/test/Language/Haskell/BuildWrapper/CMDTests.hs --- a/test/Language/Haskell/BuildWrapper/CMDTests.hs +++ b/test/Language/Haskell/BuildWrapper/CMDTests.hs @@ -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 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 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 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 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 diff --git a/test/Language/Haskell/BuildWrapper/GHCTests.hs b/test/Language/Haskell/BuildWrapper/GHCTests.hs --- a/test/Language/Haskell/BuildWrapper/GHCTests.hs +++ b/test/Language/Haskell/BuildWrapper/GHCTests.hs @@ -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= diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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