buildwrapper-0.2.2: test/Language/Haskell/BuildWrapper/Tests.hs
{-# LANGUAGE 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
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,
testConfigureWarnings , testConfigureErrors ,
testBuildErrors ,
testBuildWarnings ,
testBuildOutput,
testModuleNotInCabal,
testOutline,
testOutlinePreproc,
testPreviewTokenTypes,
testThingAtPoint,
testThingAtPointNotInCabal,
testNamesInScope,
testInPlaceReference,
testCabalComponents,
testCabalDependencies
]
class APIFacade a where
synchronize :: a -> FilePath -> Bool -> IO (OpResult [FilePath])
synchronize1 :: a -> FilePath -> Bool -> FilePath -> IO (Maybe FilePath)
write :: a -> FilePath -> FilePath -> String -> IO ()
configure :: a -> FilePath -> WhichCabal -> IO (OpResult Bool)
build :: a -> FilePath -> Bool -> WhichCabal -> IO (OpResult BuildResult)
build1 :: a -> FilePath -> FilePath -> IO (OpResult Bool)
getOutline :: a -> FilePath -> FilePath -> IO (OpResult [OutlineDef])
getTokenTypes :: a -> FilePath -> FilePath -> IO (OpResult [TokenDef])
getOccurrences :: a -> FilePath -> FilePath -> String -> IO (OpResult [TokenDef])
getThingAtPoint :: a -> FilePath -> FilePath -> Int -> Int -> Bool -> Bool -> IO (OpResult (Maybe String))
getNamesInScope :: a -> FilePath -> FilePath-> IO (OpResult (Maybe [String]))
getCabalDependencies :: a -> FilePath -> IO (OpResult [(FilePath,[CabalPackage])])
getCabalComponents :: a -> FilePath -> IO (OpResult [CabalComponent])
testSynchronizeAll :: (APIFacade a)=> a -> Test
testSynchronizeAll api= TestLabel "testSynchronizeAll" (TestCase ( do
root<-createTestProject
(fps,_)<-synchronize api root False
assertBool "no file path on creation" (not $ null fps)
assertEqual "no cabal file" (testProjectName <.> ".cabal") (head fps)
assertBool "no A" (elem ("src" </> "A.hs") fps)
assertBool "no C" (elem ("src" </> "B" </> "C.hs") fps)
assertBool "no Main" (elem ("src" </> "Main.hs") fps)
assertBool "no D" (elem ("src" </> "B" </> "D.hs") fps)
assertBool "no Main test" (elem ("test" </> "Main.hs") fps)
assertBool "no TestA" (elem ("test" </> "TestA.hs") fps)
))
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)
-- assertEqual ("wrong error on no cabal") (BWNote BWError "No cabal file found.\nPlease create a package description file <pkgname>.cabal\n" (BWLocation "" 0 1)) (head nsNoCabal)
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" (BWLocation cfn 1 1)) nsError1
assertEqual "not proper error 2" (BWNote BWError "No executables and no library found. Nothing to do.\n" (BWLocation 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" (BWLocation 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" (BWLocation 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" (BWLocation 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" (BWLocation 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" (BWLocation 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") 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" (BWLocation 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") 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" (BWLocation 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") 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" (BWLocation 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 srcF=root </> "src"
let rel="src"</>"A.hs"
-- write source file
writeFile (root </> rel) $ unlines ["module A where","import toto","fA=undefined"]
--mf1<-runAPI root $ synchronize1 rel False
--assertBool ("mf1 not just") (isJust mf1)
(BuildResult bool1 _,nsErrors1)<-build api root False Source
assertBool ("returned true on bool1") (not bool1)
assertBool ("no errors or warnings on nsErrors") (not $ null nsErrors1)
-- assertBool ("no rel in fps1: "++(show fps1)) (elem rel fps1)
let (nsError1:[])=nsErrors1
assertEqualNotesWithoutSpaces "not proper error 1" (BWNote BWError "parse error on input `toto'\n" (BWLocation 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)
-- assertBool ("no rel in fps2: "++(show fps2)) (elem rel fps1)
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" (BWLocation rel 2 8)) nsError2
(bool3,nsErrors3)<-build1 api root ("src"</>"A.hs")
assertBool ("returned true on bool3") (not bool3)
assertBool ("no errors or warnings on nsErrors3") (not $ null nsErrors3)
-- assertBool ("no rel in fps2: "++(show fps2)) (elem rel fps1)
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." (BWLocation 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)) (elem rel 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" (BWLocation rel 2 1)) nsError1
assertEqualNotesWithoutSpaces "not proper error 2" (BWNote BWWarning "Top-level binding with no type signature:\n fA :: forall a. a\n" (BWLocation rel 3 1)) nsError2
(bool3,nsErrors3)<-build1 api root rel
assertBool ("returned false on bool3") bool3
assertBool ("no errors or warnings on nsErrors3") (not $ null 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()" (BWLocation rel 2 1)) nsError3
assertEqualNotesWithoutSpaces "not proper error 4" (BWNote BWWarning "Top-level binding with no type signature:\n fA :: forall a. a" (BWLocation 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 mf2)
(bool4,nsErrors4)<-build1 api root rel
assertBool ("returned false on bool4") 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 src\\A.hs:3:1" (BWLocation 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"]
(fps,ns)<-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)
(bool2, nsErrors2)<-build1 api root rel
assertBool ("returned false on bool2: "++(show nsErrors2)) bool2
assertBool ("errors or warnings on nsErrors2: "++(show nsErrors2)) (null nsErrors2)
))
--testAST :: Test
--testAST = TestLabel "testAST" (TestCase ( do
-- root<-createTestProject
-- runAPI root synchronize False
-- (boolOKc,nsOKc)<-runAPI root $ configure Target
-- assertBool ("returned false on configure") boolOKc
-- assertBool ("errors or warnings on configure:"++show nsOKc) (null nsOKc)
--
-- (boolOK,nsOK)<-runAPI root $ build False
-- assertBool ("returned false on build") boolOK
-- assertBool ("errors or warnings on build:"++show nsOK) (null nsOK)
-- (mast,nsOK2)<-runAPI root $ getAST ("src" </> "A.hs")
-- assertBool ("errors or warnings on getAST:"++show nsOK2) (null nsOK2)
-- case mast of
-- Just ast->do
-- let json=makeObj [("parse" , (showJSON $ ast))]
-- putStrLn $ show $ encode json
-- Nothing -> assertFailure "no ast"
-- ))
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",
" }" ]
(defs,nsErrors1)<-getOutline api root rel
assertBool ("errors or warnings on getOutline:"++show nsErrors1) (null nsErrors1)
let expected=[
OutlineDef "XList" [Data,Family] (InFileSpan (InFileLoc 8 1)(InFileLoc 8 20)) []
,OutlineDef "XList Char" [Data,Instance] (InFileSpan (InFileLoc 11 1)(InFileLoc 11 60)) [
OutlineDef "XCons" [Constructor] (InFileSpan (InFileLoc 11 28)(InFileLoc 11 53)) []
,OutlineDef "XNil" [Constructor] (InFileSpan (InFileLoc 11 56)(InFileLoc 11 60)) []
]
,OutlineDef "Elem" [Type,Family] (InFileSpan (InFileLoc 13 1)(InFileLoc 13 19)) []
,OutlineDef "Elem [e]" [Type,Instance] (InFileSpan (InFileLoc 15 1)(InFileLoc 15 27)) []
,OutlineDef "testfunc1" [Function] (InFileSpan (InFileLoc 18 1)(InFileLoc 18 25)) []
,OutlineDef "testfunc1bis" [Function] (InFileSpan (InFileLoc 21 1)(InFileLoc 22 25)) []
,OutlineDef "testMethod" [Function] (InFileSpan (InFileLoc 25 1)(InFileLoc 27 13)) []
,OutlineDef "ToString" [Class] (InFileSpan (InFileLoc 29 1)(InFileLoc 32 0)) [
OutlineDef "toString" [Function] (InFileSpan (InFileLoc 30 5)(InFileLoc 30 28)) []
]
,OutlineDef "ToString String" [Instance] (InFileSpan (InFileLoc 32 1)(InFileLoc 35 0)) [
OutlineDef "toString" [Function] (InFileSpan (InFileLoc 33 5)(InFileLoc 33 18)) []
]
,OutlineDef "Str" [Type] (InFileSpan (InFileLoc 35 1)(InFileLoc 35 16)) []
,OutlineDef "Type1" [Data] (InFileSpan (InFileLoc 37 1)(InFileLoc 41 10)) [
OutlineDef "MkType1_1" [Constructor] (InFileSpan (InFileLoc 37 12)(InFileLoc 37 25)) []
,OutlineDef "MkType1_2" [Constructor] (InFileSpan (InFileLoc 38 7)(InFileLoc 41 10)) [
OutlineDef "mkt2_s" [Field] (InFileSpan (InFileLoc 39 9)(InFileLoc 39 25)) []
,OutlineDef "mkt2_i" [Field] (InFileSpan (InFileLoc 40 9)(InFileLoc 40 22)) []
]
]
]
assertEqual "length" (length expected) (length defs)
mapM_ (\(e,c)->assertEqual "outline" e c) (zip expected defs)
))
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",
""
]
(defs1,nsErrors1)<-getOutline api root rel
assertBool ("errors or warnings on getOutlinePreproc 1:"++show nsErrors1) (null nsErrors1)
let expected1=[
OutlineDef "testfunc1" [Function] (InFileSpan (InFileLoc 6 1)(InFileLoc 6 25)) []
]
assertEqual "length of expected1" (length expected1) (length defs1)
mapM_ (\(e,c)->assertEqual "outline" e c) (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",
""
]
(defs2,nsErrors2)<-getOutline api root rel
assertBool ("errors or warnings on getOutlinePreproc:"++show nsErrors2) (null nsErrors2)
let expected2=[
OutlineDef "Name" [Data] (InFileSpan (InFileLoc 5 1)(InFileLoc 9 38)) [
OutlineDef "Ident" [Constructor] (InFileSpan (InFileLoc 6 6)(InFileLoc 6 18)) [],
OutlineDef "Symbol" [Constructor] (InFileSpan (InFileLoc 7 6)(InFileLoc 7 19)) []
]
]
assertEqual "length of expected2" (length expected2) (length defs2)
mapM_ (\(e,c)->assertEqual "outline" e c) (zip expected2 defs2)
write api root rel $ unlines [
"{-# LANGUAGE CPP #-}",
"",
"module Module1 where",
"",
"#ifdef __GLASGOW_HASKELL__",
"testfunc1=reverse \"test\"",
"#else",
"testfunc2=reverse \"test\"",
"#endif",
""
]
(defs3,nsErrors3)<-getOutline api root rel
assertBool ("errors or warnings on getOutlinePreproc 3:"++show nsErrors3) (null nsErrors3)
let expected3=[
OutlineDef "testfunc1" [Function] (InFileSpan (InFileLoc 6 1)(InFileLoc 6 25)) []
]
assertEqual "length of expected3" (length expected3) (length defs3)
mapM_ (\(e,c)->assertEqual "outline" e c) (zip expected3 defs3)
))
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,1,37]},{\"D\":[2,1,2,13]},{\"K\":[3,1,3,7]},{\"IC\":[3,8,3,12]},{\"K\":[3,13,3,18]},{\"IV\":[5,1,5,5]},{\"S\":[5,6,5,8]},{\"IC\":[5,9,5,11]},{\"SS\":[5,12,5,13]},{\"IC\":[5,13,5,16]},{\"SS\":[5,16,5,17]},{\"IV\":[6,1,6,5]},{\"S\":[6,6,6,7]},{\"K\":[6,8,6,10]},{\"IV\":[7,9,7,15]},{\"SS\":[7,16,7,17]},{\"LC\":[7,17,7,20]},{\"S\":[7,20,7,21]},{\"LS\":[7,21,7,34]},{\"SS\":[7,34,7,35]},{\"IV\":[8,9,8,15]},{\"SS\":[8,16,8,17]},{\"LI\":[8,17,8,18]},{\"IV\":[8,19,8,20]},{\"LI\":[8,21,8,22]},{\"SS\":[8,22,8,23]},{\"PP\":[10,1,10,11]},{\"TH\":[11,1,11,3]},{\"IV\":[11,4,11,10]},{\"IV\":[11,11,11,23]},{\"TH\":[11,24,11,26]},{\"IC\":[11,26,11,35]},{\"SS\":[11,36,11,37]},{\"PP\":[12,1,12,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\""
]
(tap1,nsErrors1)<-getThingAtPoint api root rel 2 16 True True
assertBool ("errors or warnings on getThingAtPoint1:"++show nsErrors1) (null nsErrors1)
assertEqual "not just typed qualified" (Just "GHC.Base.map :: forall a b.\n (a -> b) -> [a] -> [b] GHC.Types.Char GHC.Types.Char") tap1
(tap2,nsErrors2)<-getThingAtPoint api root rel 2 16 False True
assertBool ("errors or warnings on getThingAtPoint2:"++show nsErrors2) (null nsErrors2)
assertEqual "not just typed unqualified" (Just "map :: forall a b. (a -> b) -> [a] -> [b] Char Char") tap2
(tap3,nsErrors3)<-getThingAtPoint api root rel 2 16 True False
assertBool ("errors or warnings on getThingAtPoint3:"++show nsErrors3) (null nsErrors3)
assertEqual "not just untyped qualified" (Just "GHC.Base.map v") tap3
(tap4,nsErrors4)<-getThingAtPoint api root rel 2 16 False False
assertBool ("errors or warnings on getThingAtPoint4:"++show nsErrors4) (null nsErrors4)
assertEqual "not just untyped unqualified" (Just "map v") tap4
))
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]"]
(fps,ns)<-synchronize api root False
(tap1,nsErrors1)<-getThingAtPoint api root rel2 2 8 True True
assertBool ("errors or warnings on getThingAtPoint1:"++show nsErrors1) (null nsErrors1)
assertEqual "not just typed qualified" (Just "GHC.List.head :: [GHC.Integer.Type.Integer]\n -> GHC.Integer.Type.Integer") 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" (elem "Main.main" tts)
assertBool "does not contain B.D.fD" (elem "B.D.fD" tts)
assertBool "does not contain GHC.Types.Char" (elem "GHC.Types.Char" 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" (elem "Main.main" tts)
assertBool "getNamesInScope in place 1 does not contain B.C.fC" (elem "B.C.fC" tts)
(tap1,nsErrorsTap1)<-getThingAtPoint api root rel 3 16 True True
assertBool ("errors or warnings on getThingAtPoint1 in place:"++show nsErrorsTap1) (null nsErrorsTap1)
assertEqual "not just typed qualified" (Just "GHC.Base.map :: forall a b.\n (a -> b) -> [a] -> [b] GHC.Types.Char GHC.Types.Char") 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" (elem "A.fA" tts2)
assertBool "getNamesInScope in place 2 does not contain B.C.fC" (elem "B.C.fC" 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" (elem "A.fA" 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 (_:(_,pkgs):[])=cps
let base=filter (\pkg->(cp_name pkg)=="base") pkgs
assertEqual "not 1 base" 1 (length base)
let (l:ex:ts:[])=cp_dependent $ 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
))
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"]
createTestProject :: IO(FilePath)
createTestProject = do
temp<-getTemporaryDirectory
let root=temp </> testProjectName
ex<-(doesDirectoryExist root)
when ex (removeDirectoryRecursive root)
createDirectory root
writeFile (testCabalFile root) testCabalContents
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{bwn_title=removeSpaces $ bwn_title n1}
n2'=n1{bwn_title=removeSpaces $ bwn_title n2}
assertEqual msg n1' n2'