buildwrapper 0.6.2 → 0.6.3
raw patch · 10 files changed
+1901/−1913 lines, 10 filesdep +HTFdep −test-frameworkdep −test-framework-hunitPVP ok
version bump matches the API change (PVP)
Dependencies added: HTF
Dependencies removed: test-framework, test-framework-hunit
API changes (from Hackage documentation)
+ Language.Haskell.BuildWrapper.Cabal: getCabalLibraryVersion :: String
Files
- buildwrapper.cabal +2/−5
- src-exe/Language/Haskell/BuildWrapper/CMD.hs +2/−1
- src/Language/Haskell/BuildWrapper/Cabal.hs +4/−1
- src/Language/Haskell/BuildWrapper/GHC.hs +4/−2
- test/Language/Haskell/BuildWrapper/APITest.hs +55/−61
- test/Language/Haskell/BuildWrapper/CMDTests.hs +1706/−86
- test/Language/Haskell/BuildWrapper/GHCTests.hs +61/−64
- test/Language/Haskell/BuildWrapper/Tests.hs +0/−1612
- test/Language/Haskell/BuildWrapper/UsagesTests.hs +60/−65
- test/Main.hs +7/−16
buildwrapper.cabal view
@@ -1,5 +1,5 @@ name: buildwrapper -version: 0.6.2 +version: 0.6.3 cabal-version: >= 1.8 build-type: Simple license: BSD3 @@ -107,18 +107,15 @@ process, bytestring, attoparsec, - test-framework, - test-framework-hunit, + HTF > 0.9, transformers, vector, unordered-containers, containers main-is: Main.hs ghc-options: -Wall -fno-warn-unused-do-bind -optl -s - x-uses-tf: true other-modules: Language.Haskell.BuildWrapper.APITest, - Language.Haskell.BuildWrapper.Tests, Language.Haskell.BuildWrapper.CMDTests, Language.Haskell.BuildWrapper.GHCTests, Language.Haskell.BuildWrapper.UsagesTests
src-exe/Language/Haskell/BuildWrapper/CMD.hs view
@@ -13,6 +13,7 @@ module Language.Haskell.BuildWrapper.CMD where import Language.Haskell.BuildWrapper.API +import Language.Haskell.BuildWrapper.Cabal (getCabalLibraryVersion) import Language.Haskell.BuildWrapper.Base hiding (tempFolder,cabalPath, cabalFile, cabalFlags,verbosity) import Control.Monad.State import System.Console.CmdArgs hiding (Verbosity(..),verbosity) @@ -122,7 +123,7 @@ &= program "buildwrapper" &= summary- ("buildwrapper executable, version " ++ showVersion version))+ ("buildwrapper executable, version " ++ showVersion version++ "\nusing version "++getCabalLibraryVersion ++" of the Cabal library")) >>= handle where handle ::BWCmd -> IO () handle c@Synchronize{force=f}=runCmd c (synchronize f)
src/Language/Haskell/BuildWrapper/Cabal.hs view
@@ -57,6 +57,9 @@ import System.Process import Data.Functor.Identity (runIdentity) +getCabalLibraryVersion :: String +getCabalLibraryVersion = VERSION_Cabal + getFilesToCopy :: BuildWrapper(OpResult [FilePath]) getFilesToCopy =do (mfps,bwns)<-withCabal Source getAllFiles @@ -107,7 +110,7 @@ cd<-getCurrentDirectory setCurrentDirectory (takeDirectory cf) (ex,out,err)<-readProcessWithExitCode cp args "" - putStrLn err + -- putStrLn err if isInfixOf "cannot satisfy -package-id" err || isInfixOf "re-run the 'configure'" err then return Nothing
src/Language/Haskell/BuildWrapper/GHC.hs view
@@ -108,8 +108,10 @@ -> [String] -- ^ the GHC options -> IO (OpResult [a]) withASTNotes f ff base_dir contents options=do - let lflags=map noLoc options - -- print options + -- 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
test/Language/Haskell/BuildWrapper/APITest.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -F -pgmF htfpp #-} -- | -- Module : Language.Haskell.BuildWrapper.APITest -- Author : JP Moresmau @@ -12,82 +13,75 @@ -- Direct tests on the API code module Language.Haskell.BuildWrapper.APITest where -import qualified Language.Haskell.BuildWrapper.API as API import Language.Haskell.BuildWrapper.Base -import Language.Haskell.BuildWrapper.Tests import qualified Language.Haskell.BuildWrapper.Cabal as Cabal -import Control.Monad.State -import Test.HUnit +import Test.Framework +import Test.HUnit (Assertion) +--data DirectAPI=DirectAPI +-- +--instance APIFacade DirectAPI where +-- synchronize _ r ff= runAPI r $ API.synchronize ff +-- synchronize1 _ r ff fp= runAPI r $ API.synchronize1 ff fp +-- write _ r fp s= runAPI r $ API.write fp s +-- configure _ r t= runAPI r $ API.configure t +-- configureWithFlags _ r t fgs= runAPIFlags r (API.configure t) fgs +-- build _ r b wc= runAPI r $ API.build b wc +-- build1 _ r fp= runAPI r $ API.build1 fp Nothing +-- build1c _ r fp ccn= runAPI r $ API.build1 fp (Just ccn) +-- getBuildFlags _ r fp= runAPI r $ API.getBuildFlags fp Nothing +-- getOutline _ r fp= runAPI r $ API.getOutline fp Nothing +-- getTokenTypes _ r fp= runAPI r $ API.getTokenTypes fp +-- getOccurrences _ r fp s= runAPI r $ API.getOccurrences fp s Nothing +-- getThingAtPoint _ r fp l c= runAPI r $ API.getThingAtPoint fp l c Nothing +-- getNamesInScope _ r fp= runAPI r $ API.getNamesInScope fp Nothing +-- getCabalDependencies _ r= runAPI r API.getCabalDependencies +-- getCabalComponents _ r= runAPI r API.getCabalComponents +-- generateUsage _ r retAll cc=runAPI r $ API.generateUsage retAll $ cabalComponentName cc +-- +--runAPI:: FilePath -> StateT BuildWrapperState IO a -> IO a +--runAPI root f =runAPIFlags root f "" +-- +--runAPIFlags:: FilePath -> StateT BuildWrapperState IO a -> String -> IO a +--runAPIFlags root f flags = +-- evalStateT f (BuildWrapperState ".dist-buildwrapper" "cabal" (testCabalFile root) Normal flags []) -data DirectAPI=DirectAPI -instance APIFacade DirectAPI where - synchronize _ r ff= runAPI r $ API.synchronize ff - synchronize1 _ r ff fp= runAPI r $ API.synchronize1 ff fp - write _ r fp s= runAPI r $ API.write fp s - configure _ r t= runAPI r $ API.configure t - configureWithFlags _ r t fgs= runAPIFlags r (API.configure t) fgs - build _ r b wc= runAPI r $ API.build b wc - build1 _ r fp= runAPI r $ API.build1 fp Nothing - build1c _ r fp ccn= runAPI r $ API.build1 fp (Just ccn) - getBuildFlags _ r fp= runAPI r $ API.getBuildFlags fp Nothing - getOutline _ r fp= runAPI r $ API.getOutline fp Nothing - getTokenTypes _ r fp= runAPI r $ API.getTokenTypes fp - getOccurrences _ r fp s= runAPI r $ API.getOccurrences fp s Nothing - getThingAtPoint _ r fp l c= runAPI r $ API.getThingAtPoint fp l c Nothing - getNamesInScope _ r fp= runAPI r $ API.getNamesInScope fp Nothing - getCabalDependencies _ r= runAPI r API.getCabalDependencies - getCabalComponents _ r= runAPI r API.getCabalComponents - generateUsage _ r retAll cc=runAPI r $ API.generateUsage retAll $ cabalComponentName cc - -runAPI:: FilePath -> StateT BuildWrapperState IO a -> IO a -runAPI root f =runAPIFlags root f "" - -runAPIFlags:: FilePath -> StateT BuildWrapperState IO a -> String -> IO a -runAPIFlags root f flags = - evalStateT f (BuildWrapperState ".dist-buildwrapper" "cabal" (testCabalFile root) Normal flags []) - -unitTests :: [Test] -unitTests=[testGetBuiltPath,testParseBuildMessages,testParseBuildMessagesLinker,testParseBuildMessagesCabal - ,testParseConfigureMessages] - -testGetBuiltPath :: Test -testGetBuiltPath = TestLabel "testGetBuiltPath" (TestCase (do - assertEqual "backslash path" (Just "src\\Language\\Haskell\\BuildWrapper\\Cabal.hs") $ Cabal.getBuiltPath "[4 of 7] Compiling Language.Haskell.BuildWrapper.Cabal ( src\\Language\\Haskell\\BuildWrapper\\Cabal.hs, dist\\build\\Language\\Haskell\\BuildWrapper\\Cabal.o )" - assertEqual "forward slash path" (Just "src/Language/Haskell/BuildWrapper/Cabal.hs") $ Cabal.getBuiltPath "[4 of 7] Compiling Language.Haskell.BuildWrapper.Cabal ( src/Language/Haskell/BuildWrapper/Cabal.hs, dist/build/Language/Haskell/BuildWrapper/Cabal.o )" - assertEqual "no path" Nothing $ Cabal.getBuiltPath "something else" - )) +test_GetBuiltPath :: Assertion +test_GetBuiltPath = do + assertEqual (Just "src\\Language\\Haskell\\BuildWrapper\\Cabal.hs") $ Cabal.getBuiltPath "[4 of 7] Compiling Language.Haskell.BuildWrapper.Cabal ( src\\Language\\Haskell\\BuildWrapper\\Cabal.hs, dist\\build\\Language\\Haskell\\BuildWrapper\\Cabal.o )" + assertEqual (Just "src/Language/Haskell/BuildWrapper/Cabal.hs") $ Cabal.getBuiltPath "[4 of 7] Compiling Language.Haskell.BuildWrapper.Cabal ( src/Language/Haskell/BuildWrapper/Cabal.hs, dist/build/Language/Haskell/BuildWrapper/Cabal.o )" + assertEqual Nothing $ Cabal.getBuiltPath "something else" + -testParseBuildMessages :: Test -testParseBuildMessages = TestLabel "testParseBuildMessages" (TestCase (do +test_ParseBuildMessages :: Assertion +test_ParseBuildMessages = do let s="Main.hs:2:3:Warning: Top-level binding with no type signature:\n tests :: [test-framework-0.4.1.1:Test.Framework.Core.Test]\nLinking" let notes=Cabal.parseBuildMessages "test.cabal" "cabal.exe" "" s - assertEqual "not 1 note" 1 (length notes) - assertEqual "not expected note" (BWNote BWWarning "Top-level binding with no type signature:\n tests :: [test-framework-0.4.1.1:Test.Framework.Core.Test]\n" (mkEmptySpan "Main.hs" 2 3)) (head notes) - )) + assertEqual 1 (length notes) + assertEqual (BWNote BWWarning "Top-level binding with no type signature:\n tests :: [test-framework-0.4.1.1:Test.Framework.Core.Test]\n" (mkEmptySpan "Main.hs" 2 3)) (head notes) + -testParseBuildMessagesLinker :: Test -testParseBuildMessagesLinker = TestLabel "testParseBuildMessagesLinker" (TestCase (do +test_ParseBuildMessagesLinker :: Assertion +test_ParseBuildMessagesLinker = do let s="Linking D:\\Documents\\Perso\\workspace\\HJVM\\.dist-buildwrapper\\dist\\build\\hjvm-test\\hjvm-test.exe ...\nD:\\Documents\\Perso\\workspace\\HJVM\\.dist-buildwrapper\\dist\\build/libHSHJVM-0.1.a(hjvm.o):hjvm.c:(.text+0x1d): undefined reference to `_imp__JNI_GetCreatedJavaVMs@12'\ncollect2: ld returned 1 exit status\n" let notes=Cabal.parseBuildMessages "test.cabal" "cabal.exe" "D:\\Documents\\Perso\\workspace\\HJVM\\.dist-buildwrapper\\dist" s - assertEqual "not 1 note" 1 (length notes) - assertEqual "not expected note" (BWNote BWError "hjvm.c:(.text+0x1d): undefined reference to `_imp__JNI_GetCreatedJavaVMs@12'\n" (mkEmptySpan "test.cabal" 1 1)) (head notes) - )) + assertEqual 1 (length notes) + assertEqual (BWNote BWError "hjvm.c:(.text+0x1d): undefined reference to `_imp__JNI_GetCreatedJavaVMs@12'\n" (mkEmptySpan "test.cabal" 1 1)) (head notes) -testParseBuildMessagesCabal :: Test -testParseBuildMessagesCabal = TestLabel "testParseBuildMessagesCabal" (TestCase (do + +test_ParseBuildMessagesCabal :: Assertion +test_ParseBuildMessagesCabal = do let s="cabal.exe: HJVM-0.1: library-dirs: src is a relative path (use --force\nto override)\n" let notes=Cabal.parseBuildMessages "test.cabal" "cabal.exe" "" s - assertEqual "not 1 note" 1 (length notes) - assertEqual "not expected note" (BWNote BWError "HJVM-0.1: library-dirs: src is a relative path (use --force\nto override)\n" (mkEmptySpan "test.cabal" 1 1)) (head notes) - )) + assertEqual 1 (length notes) + assertEqual (BWNote BWError "HJVM-0.1: library-dirs: src is a relative path (use --force\nto override)\n" (mkEmptySpan "test.cabal" 1 1)) (head notes) + -testParseConfigureMessages :: Test -testParseConfigureMessages = TestLabel "testParseConfigureMessages" (TestCase (do +test_ParseConfigureMessages :: Assertion +test_ParseConfigureMessages = do let s="cabal.exe: Missing dependencies on foreign libraries:\n* Missing C libraries: tinfo, tinfo\n" let notes=Cabal.parseCabalMessages "test.cabal" "cabal.exe" s - assertEqual "not 1 note" 1 (length notes) - assertEqual "not expected note" (BWNote BWError "Missing dependencies on foreign libraries:\n* Missing C libraries: tinfo, tinfo\n" (mkEmptySpan "test.cabal" 1 1)) (head notes) - ))+ 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)
test/Language/Haskell/BuildWrapper/CMDTests.hs view
@@ -1,87 +1,1707 @@-{-# LANGUAGE CPP #-} --- | --- 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 -import Language.Haskell.BuildWrapper.Tests -import Test.HUnit - -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 System.FilePath -import System.Directory - -cmdTests::[Test] -cmdTests= map (\f->f CMDAPI) tests - -data CMDAPI=CMDAPI - -instance APIFacade CMDAPI where - synchronize _ r ff= runAPI r "synchronize" ["--force="++ show ff ] - synchronize1 _ r ff fp= runAPI r "synchronize1" ["--force="++show ff,"--file="++fp] - write _ r fp s= runAPI r "write" ["--file="++fp,"--contents="++s] - configure _ r t= runAPI r "configure" ["--cabaltarget="++ show t] - configureWithFlags _ r t fgs= runAPI r "configure" ["--cabaltarget="++ show t,"--cabalflags="++ fgs] - build _ r b wc= runAPI r "build" ["--output="++ show b,"--cabaltarget="++ show wc] - build1 _ r fp= runAPI r "build1" ["--file="++fp] - build1c _ r fp ccn= runAPI r "build1" ["--file="++fp,"--component="++ccn] - getBuildFlags _ r fp= runAPI r "getbuildflags" ["--file="++fp] - getOutline _ r fp= runAPI r "outline" ["--file="++fp] - getTokenTypes _ r fp= runAPI r "tokentypes" ["--file="++fp] - getOccurrences _ r fp s= runAPI r "occurrences" ["--file="++fp,"--token="++s] - getThingAtPoint _ r fp l c= fmap removeLayoutTAP $ runAPI r "thingatpoint" ["--file="++fp,"--line="++ show l,"--column="++ show c] - getNamesInScope _ r fp= runAPI r "namesinscope" ["--file="++fp] - getCabalDependencies _ r= runAPI r "dependencies" [] - getCabalComponents _ r= runAPI r "components" [] - generateUsage _ r retAll cc=runAPI r "generateusage" ["--returnall="++ show retAll,"--cabalcomponent="++ cabalComponentName cc] - -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 -> String -> [String] -> IO a -runAPI 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] - setCurrentDirectory root - (ex,out,err)<-readProcessWithExitCode (cd </> head exePath) fullargs "" - setCurrentDirectory cd - putStrLn ("out:"++out) - putStrLn ("err:"++err) - assertEqual ("returned error: "++show fullargs++"\n:"++show err) ExitSuccess ex - let res=map (drop $ length "build-wrapper-json:") $ filter (isPrefixOf "build-wrapper-json:") $ lines out - assertEqual ("no json: "++show fullargs++"\n:"++show out) 1 (length res) - let r=parse value $ BS.pack (head res) - case r of - Done _ js->do - let r1= fromJSON js - case r1 of - Success fin->return fin - a->do - assertFailure (show a) - error "" - a->do - assertFailure (show a) +{-# LANGUAGE CPP, OverloadedStrings #-} +{-# OPTIONS_GHC -F -pgmF htfpp #-} +{-# LINE 3 "test/Language/Haskell/BuildWrapper/CMDTests.hs" #-} +-- | +-- 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) + +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)) + getNamesInScope :: a -> FilePath -> FilePath-> IO (OpResult (Maybe [String])) + getCabalDependencies :: a -> FilePath -> IO (OpResult [(FilePath,[CabalPackage])]) + getCabalComponents :: a -> FilePath -> IO (OpResult [CabalComponent]) + generateUsage :: a -> FilePath -> Bool -> CabalComponent -> IO (OpResult (Maybe [FilePath])) + + +data CMDAPI=CMDAPI + +instance APIFacade CMDAPI where + synchronize _ r ff= runAPI r "synchronize" ["--force="++ show ff ] + synchronize1 _ r ff fp= runAPI r "synchronize1" ["--force="++show ff,"--file="++fp] + write _ r fp s= runAPI r "write" ["--file="++fp,"--contents="++s] + configure _ r t= runAPI r "configure" ["--cabaltarget="++ show t] + configureWithFlags _ r t fgs= runAPI r "configure" ["--cabaltarget="++ show t,"--cabalflags="++ fgs] + build _ r b wc= runAPI r "build" ["--output="++ show b,"--cabaltarget="++ show wc] + build1 _ r fp= runAPI r "build1" ["--file="++fp] + build1c _ r fp ccn= runAPI r "build1" ["--file="++fp,"--component="++ccn] + getBuildFlags _ r fp= runAPI r "getbuildflags" ["--file="++fp] + getOutline _ r fp= runAPI r "outline" ["--file="++fp] + getTokenTypes _ r fp= runAPI r "tokentypes" ["--file="++fp] + getOccurrences _ r fp s= runAPI r "occurrences" ["--file="++fp,"--token="++s] + getThingAtPoint _ r fp l c= fmap removeLayoutTAP $ runAPI r "thingatpoint" ["--file="++fp,"--line="++ show l,"--column="++ show c] + getNamesInScope _ r fp= runAPI r "namesinscope" ["--file="++fp] + getCabalDependencies _ r= runAPI r "dependencies" [] + getCabalComponents _ r= runAPI r "components" [] + generateUsage _ r retAll cc=runAPI r "generateusage" ["--returnall="++ show retAll,"--cabalcomponent="++ cabalComponentName cc] + + +exeExtension :: String +#ifdef mingw32_HOST_OS +exeExtension = "exe" +#else +exeExtension = "" +#endif + +test_SynchronizeAll :: Assertion +test_SynchronizeAll = do + let api=CMDAPI + 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=CMDAPI + 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=CMDAPI + 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=CMDAPI + 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=CMDAPI + 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=CMDAPI + 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=CMDAPI + 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=CMDAPI + 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=CMDAPI + 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, nsErrors2)<-build1 api root rel + assertBool (isJust ns) + + +test_ModuleNotInCabal :: Assertion +test_ModuleNotInCabal = do + let api=CMDAPI + 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=CMDAPI + 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=CMDAPI + 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=CMDAPI + 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=CMDAPI + 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=CMDAPI + 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=CMDAPI + 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=CMDAPI + 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=CMDAPI + 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=CMDAPI + 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=CMDAPI + 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=CMDAPI + 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="[{\"D\":[1,1,37]},{\"D\":[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]},{\"IV\":[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_ThingAtPoint :: Assertion +test_ThingAtPoint = do + let api=CMDAPI + 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=CMDAPI + 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=CMDAPI + 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=CMDAPI + 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=CMDAPI + 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_NamesInScope :: Assertion +test_NamesInScope = do + let api=CMDAPI + 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=CMDAPI + 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=CMDAPI + 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=CMDAPI + 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=CMDAPI + root<-createTestProject + synchronize api root False + (cps,nsOK)<-getCabalDependencies api root + 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 + + + +test_NoSourceDir :: Assertion +test_NoSourceDir = do + let api=CMDAPI + 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=CMDAPI + 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=CMDAPI + 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=CMDAPI + 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=CMDAPI + 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) + + +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 </> (testProjectName <.> ".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} + assertEqual 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 -> String -> [String] -> IO a +runAPI 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] + setCurrentDirectory root + (ex,out,err)<-readProcessWithExitCode (cd </> head exePath) fullargs "" + setCurrentDirectory cd + putStrLn ("out:"++out) + putStrLn ("err:"++err) + assertEqual ExitSuccess ex + let res=map (drop $ length ("build-wrapper-json:"::String)) $ filter (isPrefixOf "build-wrapper-json:") $ lines out + assertEqual 1 (length res) + let r=parse value $ BS.pack (head res) + case r of + Done _ js->do + let r1= fromJSON js + case r1 of + Data.Aeson.Success fin->return fin + a->do + assertFailure (show a) + error "" + a->do + assertFailure (show a) error ""
test/Language/Haskell/BuildWrapper/GHCTests.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -F -pgmF htfpp #-} -- | -- Module : Language.Haskell.BuildWrapper.GHCTests -- Author : JP Moresmau @@ -12,112 +13,108 @@ -- Test some specific GHC operations module Language.Haskell.BuildWrapper.GHCTests where -import Test.HUnit import Language.Haskell.BuildWrapper.Base import Language.Haskell.BuildWrapper.GHC - -ghcTests :: [Test] -ghcTests=[testNoPreproc,testPreproc,testPreprocContiguous,testPreproc2Lines,testLiterate,testLiterateLatex, - testPreprocPragma ,testKeepIndent] +import Test.Framework +import Test.HUnit (Assertion) -testNoPreproc:: Test -testNoPreproc=TestLabel "testNoPreproc" (TestCase ( +test_NoPreproc:: Assertion +test_NoPreproc= do let s="module Main\nwhere\nimport Data.Map\nmain=undefined\n" let (tt,s2)=preprocessSource s False - assertBool "tt is not empty" (null tt) - assertEqual ("content has changed: "++ s2) s s2 - )) + assertBool (null tt) + assertEqual s s2 -testPreproc:: Test -testPreproc=TestLabel "testPreproc" (TestCase ( +test_Preproc:: Assertion +test_Preproc= do let s="\nmodule Main\nwhere\n#if GHC_VERSION=612\nimport Data.Map\n#endif\nmain=undefined\n" let (tt,s2)=preprocessSource s False - assertEqual "tt is not 2" 2 (length tt) + assertEqual 2 (length tt) let (t1:t2:[])=tt - assertEqual "first tt is not correct" (TokenDef "PP" (mkLocation 4 1 4 20)) t1 - assertEqual "second tt is not correct" (TokenDef "PP" (mkLocation 6 1 6 7)) t2 - assertEqual ("content is not what expected: "++ s2) "\nmodule Main\nwhere\n\nimport Data.Map\n\nmain=undefined\n" s2 - )) + assertEqual (TokenDef "PP" (mkLocation 4 1 4 20)) t1 + assertEqual (TokenDef "PP" (mkLocation 6 1 6 7)) t2 + assertEqual "\nmodule Main\nwhere\n\nimport Data.Map\n\nmain=undefined\n" s2 + -testPreprocContiguous:: Test -testPreprocContiguous=TestLabel "testPreprocContiguous" (TestCase ( +test_PreprocContiguous:: Assertion +test_PreprocContiguous= do let s="\nmodule Main\nwhere\n#if GHC_VERSION=612\nimport Data.Map\n#endif\n#if GHC_VERSION=612\nimport Data.Maybe\n#endif\nmain=undefined\n" let (tt,s2)=preprocessSource s False - assertEqual "tt is not 4" 4 (length tt) + assertEqual 4 (length tt) let (t1:t2:t3:t4:[])=tt - assertEqual "first tt is not correct" (TokenDef "PP" (mkLocation 4 1 4 20)) t1 - assertEqual "second tt is not correct" (TokenDef "PP" (mkLocation 6 1 6 7)) t2 - assertEqual "third tt is not correct" (TokenDef "PP" (mkLocation 7 1 7 20)) t3 - assertEqual "fourth tt is not correct" (TokenDef "PP" (mkLocation 9 1 9 7)) t4 - assertEqual ("content is not what expected: "++ s2) "\nmodule Main\nwhere\n\nimport Data.Map\n\n\nimport Data.Maybe\n\nmain=undefined\n" s2 - )) + assertEqual (TokenDef "PP" (mkLocation 4 1 4 20)) t1 + assertEqual (TokenDef "PP" (mkLocation 6 1 6 7)) t2 + assertEqual (TokenDef "PP" (mkLocation 7 1 7 20)) t3 + assertEqual (TokenDef "PP" (mkLocation 9 1 9 7)) t4 + assertEqual "\nmodule Main\nwhere\n\nimport Data.Map\n\n\nimport Data.Maybe\n\nmain=undefined\n" s2 -testPreprocPragma:: Test -testPreprocPragma=TestLabel "testPreprocPragma" (TestCase ( + +test_PreprocPragma:: Assertion +test_PreprocPragma= do let s="#if GHC_VERSION=612\n{-# LANGUAGE OverloadedStrings #-}\n#endif\nmodule Main\n" let (tt,s2)=preprocessSource s False - assertEqual "tt is not 3" 3 (length tt) + assertEqual 3 (length tt) let (t1:t2:t3:[])=tt - assertEqual "first tt is not correct" (TokenDef "PP" (mkLocation 1 1 1 20)) t1 - assertEqual "second tt is not correct" (TokenDef "D" (mkLocation 2 1 2 35)) t2 - assertEqual "third tt is not correct" (TokenDef "PP" (mkLocation 3 1 3 7)) t3 - assertEqual ("content is not what expected: "++ s2) "\n\n\nmodule Main\n" s2 - )) + assertEqual (TokenDef "PP" (mkLocation 1 1 1 20)) t1 + assertEqual (TokenDef "D" (mkLocation 2 1 2 35)) t2 + assertEqual (TokenDef "PP" (mkLocation 3 1 3 7)) t3 + assertEqual "\n\n\nmodule Main\n" s2 -testPreproc2Lines:: Test -testPreproc2Lines=TestLabel "testPreproc2Lines" (TestCase ( + +test_Preproc2Lines:: Assertion +test_Preproc2Lines= do let s="\nmodule Main\nwhere\n#if GHC_VERSION\\\n=612\nimport Data.Map\n#endif\nmain=undefined\n" let (tt,s2)=preprocessSource s False - assertEqual "tt is not 3" 3 (length tt) + assertEqual 3 (length tt) let (t1:t2:t3:[])=tt --putStrLn $ show tt - assertEqual "first tt is not correct" (TokenDef "PP" (mkLocation 4 1 4 17)) t1 - assertEqual "second tt is not correct" (TokenDef "PP" (mkLocation 5 1 5 5)) t2 - assertEqual "third tt is not correct" (TokenDef "PP" (mkLocation 7 1 7 7)) t3 - assertEqual ("content is not what expected: "++ s2) "\nmodule Main\nwhere\n\n\nimport Data.Map\n\nmain=undefined\n" s2 - )) + assertEqual (TokenDef "PP" (mkLocation 4 1 4 17)) t1 + assertEqual (TokenDef "PP" (mkLocation 5 1 5 5)) t2 + assertEqual (TokenDef "PP" (mkLocation 7 1 7 7)) t3 + assertEqual "\nmodule Main\nwhere\n\n\nimport Data.Map\n\nmain=undefined\n" s2 + -testLiterate:: Test -testLiterate= TestLabel "testLiterate" (TestCase ( +test_Literate:: Assertion +test_Literate= do let s="comment for literate module\n> module Main\n2nd comment\n> where\n> import Data.Map\n" let (tt,s2)=preprocessSource s True - assertEqual "tt is not 2" 2 (length tt) + assertEqual 2 (length tt) let (t1:t2:[])=tt - assertEqual "first tt is not correct" (TokenDef "DL" (mkLocation 1 1 1 28)) t1 - assertEqual "second tt is not correct" (TokenDef "DL" (mkLocation 3 1 3 12)) t2 - assertEqual ("content is not what expected: "++ s2) "\n module Main\n\n where\n import Data.Map\n" s2 - )) + assertEqual (TokenDef "DL" (mkLocation 1 1 1 28)) t1 + assertEqual (TokenDef "DL" (mkLocation 3 1 3 12)) t2 + assertEqual "\n module Main\n\n where\n import Data.Map\n" s2 -testLiterateLatex:: Test -testLiterateLatex= TestLabel "testLiterateLatex" (TestCase ( + +test_LiterateLatex:: Assertion +test_LiterateLatex= do - assertEqual "lines does not give 2" 2 (length $ lines "line1\r\nline2") + assertEqual 2 (length $ lines "line1\r\nline2") let s="\\begin{code}\r\n module Main\n where\n import Data.Map\n\\end{code}\n" let (tt,s2)=preprocessSource s True - assertEqual "tt is not 2" 2 (length tt) + assertEqual 2 (length tt) let (t1:t2:[])=tt - assertEqual "first tt is not correct" (TokenDef "DL" (mkLocation 1 1 1 13)) t1 - assertEqual "second tt is not correct" (TokenDef "DL" (mkLocation 5 1 5 11)) t2 - assertEqual ("content is not what expected: "++ s2) "\n module Main\n where\n import Data.Map\n\n" s2 - )) + assertEqual (TokenDef "DL" (mkLocation 1 1 1 13)) t1 + assertEqual (TokenDef "DL" (mkLocation 5 1 5 11)) t2 + assertEqual "\n module Main\n where\n import Data.Map\n\n" s2 + -testKeepIndent :: Test -testKeepIndent = TestLabel "testKeepIndent" (TestCase ( do +test_KeepIndent :: Assertion +test_KeepIndent = do let s="\nmodule Main\nwhere\nmain=do\n#if GHC_VERSION=612\n do1\n#endif\n do2\n" let (tt,s2)=preprocessSource s False - assertEqual "tt is not 2" 2 (length tt) + assertEqual 2 (length tt) let (t1:t2:[])=tt - assertEqual "first tt is not correct" (TokenDef "PP" (mkLocation 5 1 5 20)) t1 - assertEqual "second tt is not correct" (TokenDef "PP" (mkLocation 7 1 7 7)) t2 - assertEqual ("content is not what expected: "++ s2) "\nmodule Main\nwhere\nmain=do\n \n do1\n \n do2\n" s2 - )) + assertEqual (TokenDef "PP" (mkLocation 5 1 5 20)) t1 + assertEqual (TokenDef "PP" (mkLocation 7 1 7 7)) t2 + assertEqual "\nmodule Main\nwhere\nmain=do\n \n do1\n \n do2\n" s2 + mkLocation :: Int -> Int -> Int -> Int -> InFileSpan mkLocation sl sc el ec=InFileSpan (InFileLoc sl sc) (InFileLoc el ec)
− test/Language/Haskell/BuildWrapper/Tests.hs
@@ -1,1612 +0,0 @@-{-# LANGUAGE CPP, OverloadedStrings #-} --- | --- Module : Language.Haskell.BuildWrapper.Tests --- Author : JP Moresmau --- Copyright : (c) JP Moresmau 2011 --- License : BSD3 --- --- Maintainer : jpmoresmau@gmail.com --- Stability : beta --- Portability : portable --- --- Abstract tests of the behavior -module Language.Haskell.BuildWrapper.Tests where - -import Language.Haskell.BuildWrapper.Base hiding (writeFile,readFile) - -import Data.ByteString.Lazy () -import Data.ByteString.Lazy.Char8() - -import Data.Maybe -import Data.Aeson -import Data.Char - -import Test.HUnit - -import System.Directory -import System.FilePath -import System.Info - -import Control.Monad - ---import System.Time -tests :: (APIFacade a)=> [a -> Test] -tests= [ - testSynchronizeAll, - testSynchronizeDelete, - testSynchronizeExtraFiles, - testConfigureWarnings, - testConfigureErrors, - testBuildErrors, - testBuildWarnings, - testBuildOutput, - testModuleNotInCabal, - testOutline, - testOutlinePreproc, - testOutlineImportExport, - testOutlineLiterate, - testOutlineComments, - testOutlineMultiParam, - testOutlineOperator, - testOutlinePatternGuards, - testOutlineExtension, - testOutlineOptions, - testPreviewTokenTypes, - testThingAtPoint, - testThingAtPointTypeReduction, - testThingAtPointNotInCabal, - testThingAtPointMain, - testThingAtPointMainSubFolder, - testNamesInScope, - testNameDefsInScope, - testInPlaceReference, - testCabalComponents, - testCabalDependencies, - testNoSourceDir, - testFlags, - testBuildFlags, - testExplicitComponent, - testExplicitComponentUnRef - ] - -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)) - getNamesInScope :: a -> FilePath -> FilePath-> IO (OpResult (Maybe [String])) - getCabalDependencies :: a -> FilePath -> IO (OpResult [(FilePath,[CabalPackage])]) - getCabalComponents :: a -> FilePath -> IO (OpResult [CabalComponent]) - generateUsage :: a -> FilePath -> Bool -> CabalComponent -> IO (OpResult (Maybe [FilePath])) - -exeExtension :: String -#ifdef mingw32_HOST_OS -exeExtension = "exe" -#else -exeExtension = "" -#endif - -testSynchronizeAll :: (APIFacade a)=> a -> Test -testSynchronizeAll api= TestLabel "testSynchronizeAll" (TestCase ( do - root<-createTestProject - ((fps,dels),_)<-synchronize api root False - assertBool "no file path on creation" (not $ null fps) - assertBool "deletions!" (null dels) - assertEqual "no cabal file" (testProjectName <.> ".cabal") (head fps) - assertBool "no A" (("src" </> "A.hs") `elem` fps) - assertBool "no C" (("src" </> "B" </> "C.hs") `elem` fps) - assertBool "no Main" (("src" </> "Main.hs") `elem` fps) - assertBool "no D" (("src" </> "B" </> "D.hs") `elem` fps) - assertBool "no Main test" (("test" </> "Main.hs") `elem` fps) - assertBool "no TestA" (("test" </> "TestA.hs") `elem` fps) - )) - -testSynchronizeDelete :: (APIFacade a)=> a -> Test -testSynchronizeDelete api= TestLabel "testSynchronizeDelete" (TestCase ( do - root<-createTestProject - ((fps0,dels0),_)<-synchronize api root False - assertBool "no file path on creation" (not $ null fps0) - assertBool "deletions!" (null dels0) - let new=root </> ".dist-buildwrapper" </> "New.hs" - writeFile new "module New where" - ex1<-doesFileExist new - assertBool "new does not exist" ex1 - ((_,dels),_)<-synchronize api root False - assertBool "no deletions" (not $ null dels) - assertBool "no New.hs" ("New.hs" `elem` dels) - ex2<-doesFileExist new - assertBool "new does still exist" (not ex2) - )) - -testSynchronizeExtraFiles :: (APIFacade a)=> a -> Test -testSynchronizeExtraFiles api= TestLabel "testSynchronizeAll" (TestCase ( do - 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 "new does exist before synchronize" (not ex1) - ((fps,_),_)<-synchronize api root False - assertBool "no new in sync result" (("src" </> "a.txt") `elem` fps) - ex2<-doesFileExist new - assertBool "new does not exist after synchronize" ex2 - )) - -testConfigureErrors :: (APIFacade a)=> a -> Test -testConfigureErrors api= TestLabel "testConfigureErrors" (TestCase ( do - root<-createTestProject - (boolNoCabal,nsNoCabal)<- configure api root Target - assertBool "configure returned true on no cabal" (not boolNoCabal) - --assertEqual "errors or warnings on no cabal (should be ignored)" 0 (length nsNoCabal) - let bw=head nsNoCabal - assertEqual "wrong error on no cabal" BWError (bwnStatus bw) - - synchronize api root False - (boolOK,nsOK)<-configure api root Target - assertBool "configure returned false" boolOK - assertBool ("errors or warnings:"++show nsOK) (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 "bool1 returned true" (not bool1) - assertEqual "no errors on no name" 2 (length nsErrors1) - let (nsError1:nsError2:[])=nsErrors1 - assertEqual "not proper error 1" (BWNote BWError "No 'name' field.\n" (mkEmptySpan cfn 1 1)) nsError1 - assertEqual "not proper error 2" (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 "bool2 returned true" (not bool2) - assertEqual "no errors on invalid name" 1 (length nsErrors2) - let (nsError3:[])=nsErrors2 - assertEqual "not proper error 3" (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 "bool3 returned true" (not bool3) - assertEqual "no errors on unknown dependency" 1 (length nsErrors3) - let (nsError4:[])=nsErrors3 - assertEqual "not proper error 4" (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 "bool4 returned true" (not bool4) - assertEqual "no errors on unknown dependencies" 1 (length nsErrors4) - let (nsError5:[])=nsErrors4 - assertEqual "not proper error 5" (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 "bool4b returned true" (not bool4b) - assertEqual "no errors on unknown dependencies" 1 (length nsErrors4b) - let (nsError5b:[])=nsErrors4b - assertEqual "not proper error 5b" (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 "bool5 returned true" (not bool5) - assertEqual "no errors on no main" 1 (length nsErrors5) - let (nsError6:[])=nsErrors5 - assertEqual "not proper error 6" (BWNote BWError "No 'Main-Is' field found for executable BWTest\n" (mkEmptySpan cfn 1 1)) nsError6 - - )) - -testConfigureWarnings :: (APIFacade a)=> a -> Test -testConfigureWarnings api = TestLabel "testConfigureWarnings" (TestCase ( do - 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 ("returned false 1 " ++ show ns1) bool1 - assertEqual ("didn't return 1 warning: " ++ show ns1) 1 (length ns1) - let (nsWarning1:[])=ns1 - assertEqual "not proper warning 1" (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 ("returned false 2 " ++ show ns2) bool2 - assertEqual ("didn't return 1 warning: " ++ show ns1) 1 (length ns2) - let (nsWarning2:[])=ns2 - assertEqual "not proper warning 2" (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 ("returned false 3 " ++ show ns3) bool3 - assertEqual ("didn't return 1 warning: " ++ show ns1) 1 (length ns3) - let (nsWarning3:[])=ns3 - assertEqual "not proper warning 3" (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 - - )) - -testBuildErrors :: (APIFacade a)=> a -> Test -testBuildErrors api = TestLabel "testBuildErrors" (TestCase ( do - root<-createTestProject - synchronize api root False - (boolOKc,nsOKc)<-configure api root Target - assertBool "returned false on configure" boolOKc - assertBool ("errors or warnings on configure:"++show nsOKc) (null nsOKc) - (BuildResult boolOK _,nsOK)<-build api root False Source - assertBool "returned false on build" boolOK - assertBool ("errors or warnings on build:"++show nsOK) (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 "returned true on bool1_1" (isNothing bool11) - assertBool "no errors or warnings on nsErrors11" (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 "returned true on bool1" (not bool1) - assertBool "no errors or warnings on nsErrors1" (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 "mf2 not just" (isJust mf2) - (BuildResult bool2 _,nsErrors2)<-build api root False Source - assertBool "returned true on bool2" (not bool2) - assertBool "no errors or warnings on nsErrors2" (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 "returned true on bool21" (isNothing bool21) - assertBool "no errors or warnings on nsErrors2_1" (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 ("errors or warnings on nsErrors3f:" ++ show nsErrors3f) (null nsErrors3f) - (bool3,nsErrors3)<-build1 api root rel - assertBool "returned true on bool3" (isNothing bool3) - assertBool "no errors or warnings on nsErrors3" (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 - - )) - -testBuildWarnings :: (APIFacade a)=> a -> Test -testBuildWarnings api = TestLabel "testBuildWarnings" (TestCase ( do - 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 "returned false" boolOK - assertBool ("errors or warnings:"++show nsOK) (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 "mf2 not just" (isJust mf2) - (BuildResult bool1 fps1,nsErrors1)<-build api root False Source - assertBool "returned false on bool1" bool1 - assertBool "no errors or warnings on nsErrors1" (not $ null nsErrors1) - assertBool ("no rel in fps1: " ++ show fps1) (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 "errors or warnings on nsErrors3f" (null nsErrors3f) - (bool3,nsErrors3)<-build1 api root rel - assertBool "returned false on bool3" (isJust bool3) - assertEqual "not 2 errors or warnings on nsErrors3" 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 "mf3 not just" (isJust mf3) - (bool4,nsErrors4)<-build1 api root rel - assertBool "returned false on bool4" (isJust bool4) - assertBool "no errors or warnings on nsErrors4" (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 - )) - -testBuildOutput :: (APIFacade a)=> a -> Test -testBuildOutput api = TestLabel "testBuildOutput" (TestCase ( do - 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 ("exe does not exist on build output: "++exeF) exeE1 - removeFile exeF - exeE2<-doesFileExist exeF - assertBool ("exe does still exist after deletion: "++exeF) (not exeE2) - build api root False Source - exeE3<-doesFileExist exeF - assertBool ("exe exists after build no output: "++exeF) (not exeE3) - )) - -testModuleNotInCabal :: (APIFacade a)=> a -> Test -testModuleNotInCabal api = TestLabel "testModuleNotInCabal" (TestCase ( do - 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 "returned false on bool1" bool1 - assertBool "errors or warnings on nsErrors1" (null nsErrors1) - (_,nsErrors2f)<-getBuildFlags api root rel - assertBool "no errors or warnings on nsErrors2f" (null nsErrors2f) - (bool2, nsErrors2)<-build1 api root rel - assertBool ("returned false on bool2: " ++ show nsErrors2) (isJust bool2) - assertBool ("errors or warnings on nsErrors2: " ++ show nsErrors2) (null nsErrors2) - - )) - - -testOutline :: (APIFacade a)=> a -> Test -testOutline api= TestLabel "testOutline" (TestCase ( do - 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 "errors or warnings on nsErrors3f" (null nsErrors3f) - (OutlineResult defs es is,nsErrors1)<-getOutline api root rel - assertBool ("errors or warnings on getOutline:"++show nsErrors1) (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" (length expected) (length defs) - mapM_ (uncurry (assertEqual "outline")) (zip expected defs) - assertEqual "exports" [] es - assertEqual "imports" [ImportDef "Data.Char" Nothing (InFileSpan (InFileLoc 5 1)(InFileLoc 5 17)) False False "" Nothing] is - )) - -testOutlineComments :: (APIFacade a)=> a -> Test -testOutlineComments api= TestLabel "testOutlineComments" (TestCase ( do - 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 "errors or warnings on nsErrors3f" (null nsErrors3f) - (OutlineResult defs es is,nsErrors1)<-getOutline api root rel - assertBool ("errors or warnings on getOutline:"++show nsErrors1) (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:" ++ show defs) (length expected) (length defs) - mapM_ (uncurry (assertEqual "outline")) (zip expected defs) - assertEqual "exports" [] es - assertEqual "imports" [ImportDef "Data.Char" Nothing (InFileSpan (InFileLoc 5 1)(InFileLoc 5 17)) False False "" Nothing] is - )) - -testOutlinePreproc :: (APIFacade a)=> a -> Test -testOutlinePreproc api= TestLabel "testOutlinePreproc" (TestCase ( do - 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 "errors or warnings on nsErrors3f" (null nsErrors3f) - (OutlineResult defs1 _ _,nsErrors1)<-getOutline api root rel - assertBool ("errors or warnings on getOutlinePreproc 1:"++show nsErrors1) (null nsErrors1) - let expected1=[ - mkOutlineDef "testfunc1" [Function] (InFileSpan (InFileLoc 6 1)(InFileLoc 6 25)) - ] - assertEqual "length of expected1" (length expected1) (length defs1) - mapM_ (uncurry (assertEqual "outline")) (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 ("errors or warnings on getOutlinePreproc:"++show nsErrors2) (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 of expected2" (length expected2) (length defs2) - mapM_ (uncurry (assertEqual "outline")) (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 ("errors or warnings on getOutlinePreproc 3:"++show nsErrors3) (null nsErrors3) - let expected3=[ - mkOutlineDef "testfunc1" [Function] (InFileSpan (InFileLoc 6 1)(InFileLoc 6 25)) - ] - assertEqual "length of expected3" (length expected3) (length defs3) - mapM_ (uncurry (assertEqual "outline")) (zip expected3 defs3) - )) - - -testOutlineLiterate :: (APIFacade a)=> a -> Test -testOutlineLiterate api= TestLabel "testOutlineLiterate" (TestCase ( do - 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 "errors or warnings on nsErrors3f" (null nsErrors3f) - (OutlineResult defs1 _ _,nsErrors1)<-getOutline api root rel - assertBool ("errors or warnings on testOutlineLiterate 1:"++show nsErrors1) (null nsErrors1) - let expected1=[ - mkOutlineDef "testfunc1" [Function] (InFileSpan (InFileLoc 6 3)(InFileLoc 6 27)) - ] - assertEqual "length of expected1" (length expected1) (length defs1) - mapM_ (uncurry (assertEqual "outline")) (zip expected1 defs1) - )) - -testOutlineImportExport :: (APIFacade a)=> a -> Test -testOutlineImportExport api= TestLabel "testOutlineImportExport" (TestCase ( do - 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 "errors or warnings on nsErrors3f" (null nsErrors3f) - (OutlineResult _ es is,nsErrors1)<-getOutline api root rel - assertBool ("errors or warnings on getOutline:"++show nsErrors1) (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 "exports")) (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 "imports")) (zip imps is) - - )) - -testOutlineMultiParam :: (APIFacade a)=> a -> Test -testOutlineMultiParam api= TestLabel "testOutlineMultiParam" (TestCase ( do - 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 "errors or warnings on nsErrors3f" (null nsErrors3f) - (OutlineResult ors _ _,nsErrors1)<-getOutline api root rel2 - assertBool ("errors or warnings on getOutline:"++show nsErrors1) (null nsErrors1) - assertBool "no outline" (not $ null ors) - )) - -testOutlineOperator :: (APIFacade a)=> a -> Test -testOutlineOperator api= TestLabel "testOutlineMultiParam" (TestCase ( do - 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 "errors or warnings on nsErrors3f" (null nsErrors3f) - (OutlineResult ors _ _,nsErrors1)<-getOutline api root rel - assertBool ("errors or warnings on getOutline:"++show nsErrors1) (null nsErrors1) - assertBool "no outline" (not $ null ors) - )) - - -testOutlinePatternGuards :: (APIFacade a)=> a -> Test -testOutlinePatternGuards api= TestLabel "testOutlinePatternGuards" (TestCase ( do - 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 "errors or warnings on nsErrors3f" (null nsErrors3f) - (bool3,nsErrors3)<-build1 api root rel - assertBool "returned false on bool3" (isJust bool3) - assertBool ("errors on nsErrors3"++ show nsErrors3) (not (any (\ x -> BWError == bwnStatus x) nsErrors3)) - (OutlineResult ors _ _,nsErrors1)<-getOutline api root rel - assertBool ("errors or warnings on getOutline:"++show nsErrors1) (null nsErrors1) - assertBool "no outline" (not $ null ors) - )) - -testOutlineExtension :: (APIFacade a)=> a -> Test -testOutlineExtension api= TestLabel "testOutlineExtension" (TestCase ( do - 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 "errors or warnings on nsErrors3f" (null nsErrors3f) - (bool3,nsErrors3)<-build1 api root rel - assertBool "returned false on bool3" (isJust bool3) - assertBool ("errors on nsErrors3"++ show nsErrors3) (not (any (\ x -> BWError == bwnStatus x) nsErrors3)) - (OutlineResult ors _ _,nsErrors1)<-getOutline api root rel - assertBool ("errors or warnings on getOutline:"++show nsErrors1) (null nsErrors1) - assertBool "no outline" (not $ null ors) - )) - -testOutlineOptions :: (APIFacade a)=> a -> Test -testOutlineOptions api= TestLabel "testOutlineOptions" (TestCase ( do - 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 "errors or warnings on nsErrors3f" (null nsErrors3f) - (bool3,nsErrors3)<-build1 api root rel - assertBool "returned false on bool3" (isJust bool3) - assertBool ("errors on nsErrors3"++ show nsErrors3) (not (any (\ x -> BWError == bwnStatus x) nsErrors3)) - (OutlineResult ors _ _,nsErrors1)<-getOutline api root rel - assertBool ("errors or warnings on getOutline:"++show nsErrors1) (null nsErrors1) - assertBool "no outline" (not $ null ors) - )) - -testPreviewTokenTypes :: (APIFacade a)=> a -> Test -testPreviewTokenTypes api= TestLabel "testPreviewTokenTypes" (TestCase ( do - 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 ("errors or warnings on getTokenTypes:"++show nsErrors1) (null nsErrors1) - let expectedS="[{\"D\":[1,1,37]},{\"D\":[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]},{\"IV\":[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) - )) - -testThingAtPoint :: (APIFacade a)=> a -> Test -testThingAtPoint api= TestLabel "testThingAtPoint" (TestCase ( do - 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 "errors or warnings on nsErrors3f" (null nsErrors3f) - (tap1,nsErrors1)<-getThingAtPoint api root rel 2 16 - assertBool ("errors or warnings on getThingAtPoint1:"++show nsErrors1) (null nsErrors1) - assertBool "not just tap1" (isJust tap1) - assertEqual "not map" "map" (tapName $ fromJust tap1) - assertEqual "not GHC.Base" (Just "GHC.Base") (tapModule $ fromJust tap1) - assertEqual "not qtype" (Just "(GHC.Types.Char -> GHC.Types.Char) -> [GHC.Types.Char] -> [GHC.Types.Char]") (tapQType $ fromJust tap1) - assertEqual "not type" (Just "(Char -> Char) -> [Char] -> [Char]") (tapType $ fromJust tap1) - assertEqual "not htype" (Just "v") (tapHType $ fromJust tap1) - assertEqual "not gtype" (Just "Var") (tapGType $ fromJust tap1) - - - (tap2,nsErrors2)<-getThingAtPoint api root rel 2 20 - assertBool ("errors or warnings on getThingAtPoint2:"++show nsErrors2) (null nsErrors2) - assertBool "not just tap2" (isJust tap2) - assertEqual "not id" "id" (tapName $ fromJust tap2) - assertEqual "not GHC.Base" (Just "GHC.Base") (tapModule $ fromJust tap2) - assertEqual "not htype2" (Just "v") (tapHType $ fromJust tap2) - assertEqual "not qtype" (Just "GHC.Types.Char -> GHC.Types.Char") (tapQType $ fromJust tap2) - - (tap3,nsErrors3)<-getThingAtPoint api root rel 4 7 - assertBool ("errors or warnings on getThingAtPoint3:"++show nsErrors3) (null nsErrors3) - assertBool "not just tap3" (isJust tap3) - assertEqual "not DataT" "DataT" (tapName $ fromJust tap3) - assertEqual "not Main" (Just "Main") (tapModule $ fromJust tap3) - assertEqual "not htype3" (Just "t") (tapHType $ fromJust tap3) - assertEqual "qtype DataT" 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 ("errors or warnings on getThingAtPoint4:"++show nsErrors4) (null nsErrors4) - assertBool "not just tap4" (isJust tap4) - assertEqual "not MkData" "MkData" (tapName $ fromJust tap4) - assertEqual "not Main" (Just "Main") (tapModule $ fromJust tap4) - assertEqual "not htype4" (Just "v") (tapHType $ fromJust tap4) - assertEqual "gtype MkData" (Just "DataCon") (tapGType $ fromJust tap4) - assertEqual "type MkData" (Just "String -> DataT") (tapType $ fromJust tap4) - assertEqual "qtype MkData" (Just "GHC.Base.String -> Main.DataT") (tapQType $ fromJust tap4) -#endif - - (tap5,nsErrors5)<-getThingAtPoint api root rel 4 22 - assertBool ("errors or warnings on getThingAtPoint5:"++show nsErrors5) (null nsErrors5) - assertBool "not just tap5" (isJust tap5) - assertEqual "not name" "name" (tapName $ fromJust tap5) - assertEqual "not Main" (Just "Main") (tapModule $ fromJust tap5) - assertEqual "not htype5" (Just "v") (tapHType $ fromJust tap5) - assertEqual "qtype name" (Just "Main.DataT -> GHC.Base.String") (tapQType $ fromJust tap5) - - (tap6,nsErrors6)<-getThingAtPoint api root rel 6 7 - assertBool ("errors or warnings on getThingAtPoint6:"++show nsErrors6) (null nsErrors6) - assertBool "not just tap6" (isJust tap6) - assertEqual "not Toot" "Toot" (tapName $ fromJust tap6) - assertEqual "not Main" (Just "Main") (tapModule $ fromJust tap6) - assertEqual "not htype6" (Just "t") (tapHType $ fromJust tap6) - assertEqual "qtype Toot" 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 ("errors or warnings on getThingAtPoint7:"++show nsErrors7) (null nsErrors7) - assertBool "not just tap7" (isJust tap7) - assertEqual "not Toot" "Toot" (tapName $ fromJust tap7) - assertEqual "not Main" (Just "Main") (tapModule $ fromJust tap7) - assertEqual "not htype7" (Just "v") (tapHType $ fromJust tap7) - assertEqual "qtype Toot" (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 ("errors or warnings on getThingAtPoint8:"++show nsErrors8) (null nsErrors8) - assertBool "not just tap8" (isJust tap8) - assertEqual "not toot" "toot" (tapName $ fromJust tap8) - assertEqual "not Main" (Just "Main") (tapModule $ fromJust tap8) - assertEqual "not htype8" (Just "v") (tapHType $ fromJust tap8) - assertEqual "qtype toot" (Just "Main.Toot -> GHC.Base.String") (tapQType $ fromJust tap8) -#endif - - (tap9,nsErrors9)<-getThingAtPoint api root rel 9 5 - assertBool ("errors or warnings on getThingAtPoint9:"++show nsErrors9) (null nsErrors9) - assertBool "not just tap9" (isJust tap9) - assertEqual "not l2" "l2" (tapName $ fromJust tap9) - assertEqual "not empty module" (Just "") (tapModule $ fromJust tap9) - assertEqual "not htype9" (Just "v") (tapHType $ fromJust tap9) - assertEqual "qtype l2" (Just "[GHC.Types.Char]") (tapQType $ fromJust tap9) - )) - -testThingAtPointTypeReduction :: (APIFacade a)=> a -> Test -testThingAtPointTypeReduction api= TestLabel "testThingAtPointTypeReduction" (TestCase ( do - 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 "errors or warnings on nsErrorsMf" (null nsErrorsMf) - (tapM,nsErrorsM)<-getThingAtPoint api root rel 6 13 - assertBool ("errors or warnings on getThingAtPointM:"++show nsErrorsM) (null nsErrorsM) - assertBool "not just tapM" (isJust tapM) - assertEqual "not insert" "insert" (tapName $ fromJust tapM) -#if __GLASGOW_HASKELL__ >= 706 - assertEqual "not Data.Map.Base module" (Just "Data.Map.Base") (tapModule $ fromJust tapM) - assertEqual "not htypeM" (Just "v") (tapHType $ fromJust tapM) - assertEqual "qtype insert" (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 "not Data.Map module" (Just "Data.Map") (tapModule $ fromJust tapM) - assertEqual "not htypeM" (Just "v") (tapHType $ fromJust tapM) - assertEqual "qtype insert" (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 - )) - -testThingAtPointNotInCabal :: (APIFacade a)=> a -> Test -testThingAtPointNotInCabal api= TestLabel "testThingAtPointNotInCabal" (TestCase ( do - 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 "errors or warnings on nsErrors3f" (null nsErrors3f) - (tap1,nsErrors1)<-getThingAtPoint api root rel2 2 8 - assertBool ("errors or warnings on getThingAtPoint1:"++show nsErrors1) (null nsErrors1) - assertBool "not just tap1" (isJust tap1) - assertEqual "not head" "head" (tapName $ fromJust tap1) - assertEqual "not GHC.List" (Just "GHC.List") (tapModule $ fromJust tap1) - assertEqual "not qtype" (Just "[GHC.Integer.Type.Integer] -> GHC.Integer.Type.Integer") (tapQType $ fromJust tap1) - )) - -testThingAtPointMain :: (APIFacade a)=> a -> Test -testThingAtPointMain api= TestLabel "testThingAtPointMain" (TestCase ( do - 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 "errors or warnings on nsErrors3f" (null nsErrors3f) - assertEqual "not main module" (Just "Main") (bfModName bf3) - (tap1,nsErrors1)<-getThingAtPoint api root rel 3 16 - assertBool ("errors or warnings on getThingAtPoint1:"++show nsErrors1) (null nsErrors1) - assertBool "not just tap1" (isJust tap1) - assertEqual "not head" "head" (tapName $ fromJust tap1) - assertEqual "not GHC.List" (Just "GHC.List") (tapModule $ fromJust tap1) - assertEqual "not qtype" (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) --- - - )) - -testThingAtPointMainSubFolder :: (APIFacade a)=> a -> Test -testThingAtPointMainSubFolder api= TestLabel "testThingAtPointMainSubFolder" (TestCase ( do - 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 "errors or warnings on nsErrors3f" (null nsErrors3f) - assertEqual "not main module" (Just "Main") (bfModName bf3) - (tap1,nsErrors1)<-getThingAtPoint api root rel 3 16 - assertBool ("errors or warnings on getThingAtPoint1:"++show nsErrors1) (null nsErrors1) - assertBool "not just tap1" (isJust tap1) - assertEqual "not head" "head" (tapName $ fromJust tap1) - assertEqual "not GHC.List" (Just "GHC.List") (tapModule $ fromJust tap1) - assertEqual "not qtype" (Just "[GHC.Integer.Type.Integer] -> GHC.Integer.Type.Integer") (tapQType $ fromJust tap1) - - )) - -testNamesInScope :: (APIFacade a)=> a -> Test -testNamesInScope api= TestLabel "testNamesInScope" (TestCase ( do - 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 ("errors or warnings on getNamesInScope:"++show nsErrors1) (null nsErrors1) - assertBool "getNamesInScope not just" (isJust mtts) - let tts=fromJust mtts - assertBool "does not contain Main.main" ("Main.main" `elem` tts) - assertBool "does not contain B.D.fD" ("B.D.fD" `elem` tts) - assertBool "does not contain GHC.Types.Char" ("GHC.Types.Char" `elem` tts) - )) - -testNameDefsInScope :: (APIFacade a)=> a -> Test -testNameDefsInScope api= TestLabel "testNameDefsInScope" (TestCase ( do - 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 "getNameDefsInScope not just" (isJust mtts) - let tts=fromJust mtts - assertBool "does not contain Main.main" (NameDef "Main.main" [Function] (Just "IO [Char]") `elem` tts) - assertBool "does not contain B.D.fD" (NameDef "B.D.fD" [Function] (Just "forall a. a") `elem` tts) - assertBool "does not contain Main.Type1" (NameDef "Main.Type1" [Type] Nothing `elem` tts) - assertBool "does not contain Main.MkType1_1" (NameDef "Main.MkType1_1" [Constructor] (Just "Int -> Type1") `elem` tts) - assertBool "does not contain GHC.Types.Char" (NameDef "GHC.Types.Char" [Type] Nothing `elem` tts) - )) - - -testInPlaceReference :: (APIFacade a)=> a -> Test -testInPlaceReference api= TestLabel "testInPlaceReference" (TestCase ( do - 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 ("returned false on configure:"++show nsOKc) boolOKc - assertBool ("errors or warnings on configure:"++show nsOKc) (null nsOKc) - (BuildResult boolOK _,nsOK)<-build api root True Source - assertBool "returned false on build" boolOK - assertBool ("errors or warnings on build:"++show nsOK) (null nsOK) - synchronize api root True - (mtts,nsErrors1)<-getNamesInScope api root rel - assertBool ("errors or warnings on getNamesInScope in place:"++show nsErrors1) (null nsErrors1) - assertBool "getNamesInScope in place not just" (isJust mtts) - let tts=fromJust mtts - assertBool "getNamesInScope in place 1 does not contain Main.main" ("Main.main" `elem` tts) - assertBool "getNamesInScope in place 1 does not contain B.C.fC" ("B.C.fC" `elem` tts) - (_,nsErrors3f)<-getBuildFlags api root rel - assertBool "errors or warnings on nsErrors3f" (null nsErrors3f) - (tap1,nsErrorsTap1)<-getThingAtPoint api root rel 3 16 - assertBool ("errors or warnings on getThingAtPoint1 in place:"++show nsErrorsTap1) (null nsErrorsTap1) - assertBool "not just tap1" (isJust tap1) - assertEqual "not map" "map" (tapName $ fromJust tap1) - assertEqual "not GHC.Base" (Just "GHC.Base") (tapModule $ fromJust tap1) - assertEqual "not qtype" (Just "(GHC.Types.Char -> GHC.Types.Char) -> [GHC.Types.Char] -> [GHC.Types.Char]") (tapQType $ fromJust tap1) - (mtts2,nsErrors2)<-getNamesInScope api root rel2 - assertBool ("errors or warnings on getNamesInScope in place 2:"++show nsErrors2) (null nsErrors2) - assertBool "getNamesInScope in place 2 not just" (isJust mtts2) - let tts2=fromJust mtts2 - assertBool "getNamesInScope in place 2 does not contain A.fA" ("A.fA" `elem` tts2) - assertBool "getNamesInScope in place 2 does not contain B.C.fC" ("B.C.fC" `elem` tts2) - - (mtts3,nsErrors3)<-getNamesInScope api root rel3 - assertBool ("errors or warnings on getNamesInScope in place 3:"++show nsErrors3) (null nsErrors3) - assertBool "getNamesInScope in place 3 not just" (isJust mtts3) - let tts3=fromJust mtts3 - assertBool "getNamesInScope in place 3 does not contain A.fA" ("A.fA" `elem` tts3) - )) - -testCabalComponents :: (APIFacade a)=> a -> Test -testCabalComponents api= TestLabel "testCabalComponents" (TestCase ( do - root<-createTestProject - synchronize api root False - (cps,nsOK)<-getCabalComponents api root - assertBool ("errors or warnings on getCabalComponents:"++show nsOK) (null nsOK) - assertEqual "not three components" 3 (length cps) - let (l:ex:ts:[])=cps - assertEqual "not library true" (CCLibrary True) l - assertEqual "not executable true" (CCExecutable "BWTest" True) ex - assertEqual "not test suite true" (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 ("errors or warnings on getCabalComponents:"++show nsOK2) (null nsOK2) - assertEqual "not three components" 3 (length cps2) - let (l2:ex2:ts2:[])=cps2 - assertEqual "not library false" (CCLibrary False) l2 - assertEqual "not executable false" (CCExecutable "BWTest" False) ex2 - assertEqual "not test suite false" (CCTestSuite "BWTest-test" False) ts2 - )) - -testCabalDependencies :: (APIFacade a)=> a -> Test -testCabalDependencies api= TestLabel "testCabalDependencies" (TestCase ( do - root<-createTestProject - synchronize api root False - (cps,nsOK)<-getCabalDependencies api root - assertBool ("errors or warnings on getCabalDependencies:"++show nsOK) (null nsOK) - assertEqual "not two databases" 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 "not 1 base" 1 (length base) - let (l:ex:ts:[])=cpDependent $ head base - assertEqual "not library true" (CCLibrary True) l - assertEqual "not executable true" (CCExecutable "BWTest" True) ex - assertEqual "not test suite true" (CCTestSuite "BWTest-test" True) ts - )) - - -testNoSourceDir :: (APIFacade a)=> a -> Test -testNoSourceDir api=TestLabel "testNoSourceDir" (TestCase (do - 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 "git exists before synchronize" (not d1) - - let bwInBw=root </> ".dist-buildwrapper" </> ".dist-buildwrapper" - d1b<-doesDirectoryExist bwInBw - assertBool ".dist-buildwrapper exists before synchronize" (not d1b) - - synchronize api root False - d2<-doesDirectoryExist gitInBW - assertBool "git exists after synchronize" (not d2) - - d2b<-doesDirectoryExist bwInBw - assertBool ".dist-buildwrapper exists after synchronize" (not d2b) - - )) - -testFlags :: (APIFacade a)=> a -> Test -testFlags api=TestLabel "testFlags" (TestCase (do - 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 "exe exists!" (not ex1) - - configureWithFlags api root Source "server" - build api root True Source - ex2<-doesFileExist exePath - assertBool "exe doesn't exist!" ex2 - - )) - -testBuildFlags :: (APIFacade a)=> a -> Test -testBuildFlags api=TestLabel "testFlags" (TestCase (do - 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 "errors or warnings on nsErrors3f" (null nsErrors3f) - let ast=bfAst flgs - assertBool "no package-name" ("-package-name" `elem` ast) - assertBool "no package name" ("BWTest-0.1" `elem` ast) - assertBool "no -XOverlappingInstances" ("-XOverlappingInstances" `elem` ast) - assertBool "OverlappingInstances" ("OverlappingInstances" `notElem` ast) - )) - -testExplicitComponent :: (APIFacade a)=> a -> Test -testExplicitComponent api=TestLabel "testExplicitComponent" (TestCase (do - 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 "returned nothing on bool1" (isJust names1) - assertBool "errors or warnings on nsErrors1" (null nsErrors1) - (names2,nsErrors2)<-build1c api root rel "BWTest" - assertBool "returned nothing on bool2" (isJust names2) - assertBool "errors or warnings on nsErrors2" (null nsErrors2) - (names3,nsErrors3)<-build1c api root rel "BWTest2" - assertBool "returned nothing on bool3" (isNothing names3) - assertBool "no errors or warnings on nsErrors2" (not $ null nsErrors3) - )) - -testExplicitComponentUnRef :: (APIFacade a)=> a -> Test -testExplicitComponentUnRef api=TestLabel "testExplicitComponentUnRef" (TestCase (do - 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 "returned nothing on bool1" (isJust names1) - assertBool "errors or warnings on nsErrors1" (null nsErrors1) - (names2,nsErrors2)<-build1c api root rel "BWTest" - assertBool "returned nothing on bool2" (isJust names2) - assertBool "errors or warnings on nsErrors2" (null nsErrors2) - (names3,nsErrors3)<-build1c api root rel "BWTest2" - assertBool "returned nothing on bool3" (isNothing names3) - assertBool "no errors or warnings on nsErrors2" (not $ null nsErrors3) - )) - -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 </> (testProjectName <.> ".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} - assertEqual msg n1' n2'
test/Language/Haskell/BuildWrapper/UsagesTests.hs view
@@ -1,11 +1,12 @@ {-# LANGUAGE CPP,OverloadedStrings,PatternGuards #-} +{-# OPTIONS_GHC -F -pgmF htfpp #-} module Language.Haskell.BuildWrapper.UsagesTests where import Language.Haskell.BuildWrapper.Base hiding (readFile,writeFile) -import Language.Haskell.BuildWrapper.Tests import Language.Haskell.BuildWrapper.CMDTests -import Test.HUnit +import Test.Framework hiding (Success) +import Test.HUnit (Assertion) import System.Directory import System.FilePath @@ -24,54 +25,45 @@ import qualified Data.Vector as V import qualified Data.Aeson.Types (parse) -usageTests::[Test] -usageTests= map (\f->f CMDAPI) utests -utests :: (APIFacade a)=> [a -> Test] -utests= [ testGenerateBWUsage, - testGenerateReferencesSimple, - testGenerateReferencesImports, - testGenerateReferencesExports, - testGenerateReferencesExportAlias, - testIncorrectModuleFileName - ] - -testGenerateBWUsage :: (APIFacade a)=> a -> Test -testGenerateBWUsage api= TestLabel "testGenerateBWUsage" (TestCase ( do +test_GenerateBWUsage :: Assertion +test_GenerateBWUsage = do + let api=CMDAPI root<-createTestProject ((fps,dels),_)<-synchronize api root False - assertBool "no file path on creation" (not $ null fps) - assertBool "deletions" (null dels) - assertEqual "no cabal file" (testProjectName <.> ".cabal") (head fps) + assertBool (not $ null fps) + assertBool (null dels) + assertEqual (testProjectName <.> ".cabal") (head fps) let rel="src" </> "A.hs" - assertBool "no A" (rel `elem` fps) + assertBoolVerbose "no A" (rel `elem` fps) let bwI1=getUsageFile (root </> ".dist-buildwrapper" </> rel) ef1<-doesFileExist bwI1 - assertBool (bwI1 ++ " file exists before build") (not ef1) + assertBoolVerbose (bwI1 ++ " file exists before build") (not ef1) (BuildResult bool1 fps1,nsErrors1)<-build api root False Source - assertBool "returned false on bool1" bool1 - assertBool "no errors or warnings on nsErrors1" (null nsErrors1) - assertBool ("no rel in fps1: " ++ show fps1) (rel `elem` fps1) - assertBool (bwI1 ++ " file exists after build") (not ef1) + assertBool bool1 + assertBool (null nsErrors1) + assertBool (rel `elem` fps1) + assertBoolVerbose (bwI1 ++ " file exists after build") (not ef1) (comps,_)<-getCabalComponents api root - c1<-getClockTime + --c1<-getClockTime gar<-mapM (generateUsage api root False) comps let fs=concat $ mapMaybe fst gar - assertBool "fs doesn't contain rel" (rel `elem` fs) - c2<-getClockTime - putStrLn ("generateUsage: " ++ timeDiffToString (diffClockTimes c2 c1)) + assertBool (rel `elem` fs) + --c2<-getClockTime + -- putStrLn ("generateUsage: " ++ timeDiffToString (diffClockTimes c2 c1)) ef2<-doesFileExist bwI1 - assertBool (bwI1 ++ " file doesn't exist after generateAST") ef2 + assertBoolVerbose (bwI1 ++ " file doesn't exist after generateAST") ef2 gar2<-mapM (generateUsage api root False) comps let fs2=concat $ mapMaybe fst gar2 - assertBool "fs2 contains rel" (rel `notElem` fs2) + assertBool (rel `notElem` fs2) gar3<-mapM (generateUsage api root True) comps let fs3=concat $ mapMaybe fst gar3 - assertBool "fs3 doesn't contain rel" (rel `elem` fs3) - )) + assertBool (rel `elem` fs3) -testGenerateReferencesSimple :: (APIFacade a)=> a -> Test -testGenerateReferencesSimple api= TestLabel "testGenerateReferencesSimple" (TestCase ( do + +test_GenerateReferencesSimple :: Assertion +test_GenerateReferencesSimple = do + let api=CMDAPI root<-createTestProject let relMain="src"</>"Main.hs" writeFile (root</> relMain) $ unlines [ @@ -101,17 +93,17 @@ ] _<-synchronize api root True (BuildResult bool1 _,nsErrors1)<-build api root False Source - assertBool ("returned false on bool1:" ++ show nsErrors1) bool1 - assertBool "no errors or warnings on nsErrors1" (null nsErrors1) + assertBoolVerbose ("returned false on bool1:" ++ show nsErrors1) bool1 + assertBool (null nsErrors1) (lib:exe:_,_)<-getCabalComponents api root --mapM_ (generateUsage api root False) comps generateUsage api root False lib let uf=getUsageFile $ root </> ".dist-buildwrapper" </> relMain euf1<-doesFileExist uf - assertBool "main usage file exists after lib" (not euf1) + assertBool (not euf1) generateUsage api root False exe euf2<-doesFileExist uf - assertBool "main usage file does not exist after exe" euf2 + assertBool euf2 --sI<-fmap formatJSON (readFile $ getInfoFile(root </> ".dist-buildwrapper" </> rel)) --putStrLn sI v<-readStoredUsage (root </> ".dist-buildwrapper" </> rel) @@ -150,10 +142,11 @@ assertVarUsage "base" "System.IO" "print" [("main",False,[3,6,3,11])] vMain assertVarUsage "base" "GHC.Base" "$" [("main",False,[3,12,3,13]),("main",False,[3,20,3,21])] vMain return () - )) -testGenerateReferencesImports :: (APIFacade a)=> a -> Test -testGenerateReferencesImports api= TestLabel "testGenerateReferencesImports" (TestCase ( do + +test_GenerateReferencesImports :: Assertion +test_GenerateReferencesImports = do + let api=CMDAPI root<-createTestProject let relMain="src"</>"Main.hs" writeFile (root</> relMain) $ unlines [ @@ -166,8 +159,8 @@ ] _<-synchronize api root True (BuildResult bool1 _,nsErrors1)<-build api root False Source - assertBool ("returned false on bool1:" ++ show nsErrors1) bool1 - assertBool "no errors or warnings on nsErrors1" (null nsErrors1) + assertBoolVerbose ("returned false on bool1:" ++ show nsErrors1) bool1 + assertBool (null nsErrors1) (comps,_)<-getCabalComponents api root mapM_ (generateUsage api root False) comps vMain<-readStoredUsage (root </> ".dist-buildwrapper" </> relMain) @@ -179,10 +172,11 @@ assertTypeUsage "base" "Data.Maybe" "Maybe" [("import",False,[3,20,3,29])] vMain assertTypeUsage "base" "Data.Complex" "Complex" [("import",False,[4,22,4,35])] vMain assertVarUsage "base" "Data.Complex" ":+" [("import",False,[4,22,4,35])] vMain - )) -testGenerateReferencesExports :: (APIFacade a)=> a -> Test -testGenerateReferencesExports api= TestLabel "testGenerateReferencesExports" (TestCase ( do + +test_GenerateReferencesExports :: Assertion +test_GenerateReferencesExports = do + let api=CMDAPI root<-createTestProject let rel="src" </> "A.hs" writeFile (root</> rel) $ unlines [ @@ -216,8 +210,8 @@ ] _<-synchronize api root True (BuildResult bool1 _,nsErrors1)<-build api root False Source - assertBool ("returned false on bool1:" ++ show nsErrors1) bool1 - assertBool "no errors or warnings on nsErrors1" (null nsErrors1) + assertBoolVerbose ("returned false on bool1:" ++ show nsErrors1) bool1 + assertBool (null nsErrors1) (comps,_)<-getCabalComponents api root mapM_ (generateUsage api root False) comps v<-readStoredUsage (root </> ".dist-buildwrapper" </> rel) @@ -245,10 +239,11 @@ assertTypeUsage "BWTest-0.1" "A" "MyData2" [("export",False,[3,5,3,16]),("MyData2",True,[20,6,20,13])] v assertTypeUsage "BWTest-0.1" "A" "MyData3" [("export",False,[4,5,4,20]),("MyData3",True,[24,6,24,13])] v assertTypeUsage "ghc-prim" "GHC.Types" "Int" [("Cons2",False,[11,15,11,18]),("Cons22",False,[22,16,22,19]),("Cons32",False,[26,16,26,19])] v - )) + -testGenerateReferencesExportAlias :: (APIFacade a)=> a -> Test -testGenerateReferencesExportAlias api= TestLabel "testGenerateReferencesExportAlias" (TestCase ( do +test_GenerateReferencesExportAlias :: Assertion +test_GenerateReferencesExportAlias = do + let api=CMDAPI root<-createTestProject let relMain="src"</>"Main.hs" writeFile (root</> relMain) $ unlines [ @@ -259,18 +254,19 @@ ] _<-synchronize api root True (BuildResult bool1 _,nsErrors1)<-build api root False Source - assertBool ("returned false on bool1:" ++ show nsErrors1) bool1 - assertBool "no errors or warnings on nsErrors1" (null nsErrors1) + assertBoolVerbose ("returned false on bool1:" ++ show nsErrors1) bool1 + assertBool (null nsErrors1) (comps,_)<-getCabalComponents api root mapM_ (generateUsage api root False) comps vMain<-readStoredUsage (root </> ".dist-buildwrapper" </> relMain) -- sUMain<-fmap formatJSON (readFile $ getUsageFile(root </> ".dist-buildwrapper" </> relMain)) -- putStrLn sUMain assertVarUsage "base" "Data.Ord" "" [("export",False,[1,14,1,22]),("import",False,[2,8,2,16])] vMain - )) + -testIncorrectModuleFileName :: (APIFacade a)=> a -> Test -testIncorrectModuleFileName api= TestLabel "testIncorrectModuleFileName" (TestCase ( do +test_IncorrectModuleFileName :: Assertion +test_IncorrectModuleFileName = do + let api=CMDAPI root<-createTestProject let relMain="src"</>"Main.hs" let relMain2="src"</>"Main-exe.hs" @@ -306,9 +302,8 @@ (comps,_)<-getCabalComponents api root gar<-mapM (generateUsage api root False) comps let fs=concat $ mapMaybe fst gar - assertBool "fs doesn't contain relMain2" (relMain2 `elem` fs) - )) - + assertBool (relMain2 `elem` fs) + getUsageFile :: FilePath -- ^ the source file -> FilePath getUsageFile fp= let @@ -370,9 +365,9 @@ let (Success ifl)=fromJSON arr2 return (section,def,ifl::InFileSpan)) v2 in r) $ V.toList arr - assertEqual (T.unpack modu ++ "." ++ T.unpack name ++ ": " ++ show lins) expected actual + assertEqualVerbose (T.unpack modu ++ "." ++ T.unpack name ++ ": " ++ show lins) expected actual --V.elem (Number (I line)) arr=return () -assertUsage _ _ modu name line _=assertBool (T.unpack modu ++ "." ++ T.unpack name ++ ": " ++ show line) False +assertUsage _ _ modu name line _=assertFailure (T.unpack modu ++ "." ++ T.unpack name ++ ": " ++ show line) assertPackageModule :: T.Text -> T.Text -> [Int] -> Value -> IO() assertPackageModule pkg modu [sl,sc,el,ec] (Array v) | @@ -380,8 +375,8 @@ (String s0) <-v V.! 0, (String s1) <-v V.! 1, arr<- v V.! 2= do - assertEqual (T.unpack pkg) pkg s0 - assertEqual (T.unpack modu) modu s1 + assertEqualVerbose (T.unpack pkg) pkg s0 + assertEqualVerbose (T.unpack modu) modu s1 let (Success ifs)=fromJSON arr - assertEqual (show ifs) (InFileSpan (InFileLoc sl sc) (InFileLoc el ec)) ifs -assertPackageModule pkg modu _ _= assertBool (T.unpack pkg ++ "." ++ T.unpack modu) False + assertEqualVerbose (show ifs) (InFileSpan (InFileLoc sl sc) (InFileLoc el ec)) ifs +assertPackageModule pkg modu _ _= assertFailure (T.unpack pkg ++ "." ++ T.unpack modu)
test/Main.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -F -pgmF htfpp #-} -- | -- Module : Main -- Author : JP Moresmau @@ -11,22 +12,12 @@ -- Testing exe entry point module Main where -import Language.Haskell.BuildWrapper.APITest -import Language.Haskell.BuildWrapper.UsagesTests -import Language.Haskell.BuildWrapper.CMDTests -import Language.Haskell.BuildWrapper.GHCTests +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 Test.Framework (defaultMain, testGroup,Test) -import Test.Framework.Providers.HUnit +import Test.Framework main :: IO() -main = defaultMain tests - -tests :: [Test] -tests = [ - testGroup "Unit Tests" (concatMap hUnitTestToTests unitTests), - testGroup "GHC Tests" (concatMap hUnitTestToTests ghcTests), - testGroup "Command Tests" (concatMap hUnitTestToTests cmdTests) , - testGroup "Usages Tests" (concatMap hUnitTestToTests usageTests) - ] - +main = htfMain htf_importedTests