buildwrapper 0.2.1 → 0.2.2
raw patch · 9 files changed
+125/−41 lines, 9 filesdep +aesondep +unordered-containersdep +utf8-stringdep −aeson-native
Dependencies added: aeson, unordered-containers, utf8-string
Dependencies removed: aeson-native
Files
- buildwrapper.cabal +6/−4
- src/Language/Haskell/BuildWrapper/API.hs +4/−0
- src/Language/Haskell/BuildWrapper/Base.hs +22/−3
- src/Language/Haskell/BuildWrapper/Cabal.hs +31/−17
- src/Language/Haskell/BuildWrapper/GHC.hs +6/−5
- src/Language/Haskell/BuildWrapper/Packages.hs +3/−3
- test/Language/Haskell/BuildWrapper/CMDTests.hs +14/−1
- test/Language/Haskell/BuildWrapper/GHCTests.hs +15/−1
- test/Language/Haskell/BuildWrapper/Tests.hs +24/−7
buildwrapper.cabal view
@@ -1,5 +1,5 @@ name: buildwrapper -version: 0.2.1 +version: 0.2.2 cabal-version: >= 1.8 build-type: Simple license: BSD3 @@ -35,7 +35,9 @@ haskell-src-exts, cpphs, old-time, - aeson-native + aeson >=0.4, + unordered-containers, + utf8-string ghc-options: -Wall -fno-warn-unused-do-bind exposed-modules: Language.Haskell.BuildWrapper.API, @@ -52,14 +54,14 @@ hs-source-dirs: src-exe main-is: Main.hs build-depends: base < 5, buildwrapper, cmdargs, filepath, Cabal, directory, mtl, ghc, cpphs,haskell-src-exts, old-time, ghc-syb-utils, ghc-paths - ,vector, containers, syb, process, regex-tdfa, text, aeson-native, bytestring + ,vector, containers, syb, process, regex-tdfa, text, aeson >=0.4, bytestring ghc-options: -Wall -fno-warn-unused-do-bind other-modules: Language.Haskell.BuildWrapper.CMD test-suite buildwrapper-test type: exitcode-stdio-1.0 hs-source-dirs: test - build-depends: base < 5, buildwrapper, HUnit, mtl, filepath, directory, Cabal, old-time, aeson-native, text, process, bytestring, attoparsec, test-framework, test-framework-hunit + build-depends: base < 5, buildwrapper, HUnit, mtl, filepath, directory, Cabal, old-time, aeson >=0.4, text, process, bytestring, attoparsec, test-framework, test-framework-hunit main-is: Main.hs ghc-options: -Wall -fno-warn-unused-do-bind x-uses-tf: true
src/Language/Haskell/BuildWrapper/API.hs view
@@ -19,6 +19,10 @@ import qualified Data.Text as T +import Prelude hiding (readFile, writeFile) + +import System.IO.UTF8 + import Control.Monad.State import Language.Haskell.Exts.Annotated import Language.Preprocessor.Cpphs
src/Language/Haskell/BuildWrapper/Base.hs view
@@ -19,7 +19,7 @@ import Data.Data import Data.Aeson import qualified Data.Text as T -import qualified Data.Map as M +import qualified Data.HashMap.Lazy as M import qualified Data.Vector as V import System.Directory @@ -169,7 +169,7 @@ instance FromJSON TokenDef where parseJSON (Object o) | - ((a,b):[])<-M.assocs o, + ((a,b):[])<-M.toList o, Success v0 <- fromJSON b=return $ TokenDef a v0 parseJSON _= mzero --withCabal :: (GenericPackageDescription -> BuildWrapper a) -> BuildWrapper (Either BWNote a) @@ -299,4 +299,23 @@ if isDirectory then getRecursiveContents path else return [path] - return (concat paths) + return (concat paths) + + +fromJustDebug :: String -> Maybe a -> a +fromJustDebug s Nothing=error ("fromJust:" ++ s) +fromJustDebug _ (Just a)=a + + +removeBaseDir :: FilePath -> String -> String +removeBaseDir base_dir s= loop s + where + loop [] = [] + loop str = + let (prefix, rest) = splitAt n str + in + if base_dir_sep == prefix -- found an occurrence? + then loop rest -- yes: drop it + else head str : loop (tail str) -- no: keep looking + n = length base_dir_sep + base_dir_sep=base_dir ++ [pathSeparator]
src/Language/Haskell/BuildWrapper/Cabal.hs view
@@ -362,18 +362,21 @@ getBuildInfo fp=do (mmr,bwns)<-go getReferencedFiles case mmr of - Nothing-> do + Just (Just a)->return $ ((Just a),bwns) + _ -> do (mmr2,bwns2)<-go getAllFiles return $ case mmr2 of - Nothing-> (Nothing,bwns) - Just a-> (a,bwns2) - Just a->return $ (a,bwns) + Just (Just a)-> (Just a,bwns2) + _-> (Nothing,bwns) where go f=withCabal Source (\lbi->do fps<-f lbi - --liftIO $ mapM_ (\(_,_,_,ls)->mapM_ (putStrLn . snd) ls) fps + --liftIO $ putStrLn $ (show $ length fps) + -- liftIO $ mapM_ (\(_,_,_,_,ls)->mapM_ (putStrLn . snd) ls) fps let ok=filter (\(_,_,_,_,ls)->not $ null ls ) $ - map (\(n1,n2,n3,n4,ls)->(n1,n2,n3,n4,filter (\(_,b)->b==fp) ls) ) + map (\(n1,n2,n3,n4,ls)->(n1,n2,n3,n4,filter (\(_,b)->b==fp || b==("." </> fp)) ls) ) fps + --liftIO $ putStrLn $ (show $ length ok) + --liftIO $ mapM_ (\(_,_,_,_,ls)->mapM_ (putStrLn . snd) ls) ok return $ if null ok then Nothing else Just $ (lbi,head ok)) @@ -408,6 +411,13 @@ cabalExtensions :: CabalBuildInfo -> (ModuleName,[String]) cabalExtensions (bi,_,_,_,ls)=(fst $ head ls,map show $ ((otherExtensions bi) ++ (defaultExtensions bi) ++ (oldExtensions bi))) +getSourceDirs :: BuildInfo -> [FilePath] +getSourceDirs bi=let + hsd=hsSourceDirs bi + in case hsd of + [] -> ["."] + _ -> hsd + getAllFiles :: LocalBuildInfo -> BuildWrapper [CabalBuildInfo] getAllFiles lbi= do let pd=localPkgDescr lbi @@ -421,21 +431,21 @@ extractFromLib :: Library -> [(BuildInfo,ComponentLocalBuildInfo,FilePath,Bool,[FilePath])] extractFromLib l=let lib=libBuildInfo l - in [(lib,fromJust $ libraryConfig lbi,buildDir lbi,True,(hsSourceDirs lib))] + in [(lib,fromJustDebug "extractFromLibAll" $ libraryConfig lbi,buildDir lbi,True,(getSourceDirs lib))] extractFromExe :: Executable -> (BuildInfo,ComponentLocalBuildInfo,FilePath,Bool,[FilePath]) extractFromExe e@Executable{exeName=exeName'}=let ebi=buildInfo e targetDir = buildDir lbi </> exeName' exeDir = targetDir </> (exeName' ++ "-tmp") - hsd=hsSourceDirs ebi - in (ebi,fromJust $ lookup exeName' $ executableConfigs lbi,exeDir,False, hsd) + hsd=getSourceDirs ebi + in (ebi,fromJustDebug "extractFromExeAll" $ lookup exeName' $ executableConfigs lbi,exeDir,False, hsd) extractFromTest :: TestSuite -> (BuildInfo,ComponentLocalBuildInfo,FilePath,Bool,[FilePath]) extractFromTest t@TestSuite {testName=testName'} =let tbi=testBuildInfo t targetDir = buildDir lbi </> testName' testDir = targetDir </> (testName' ++ "-tmp") - hsd=hsSourceDirs tbi - in (tbi,fromJust $ lookup testName' $ testSuiteConfigs lbi,testDir,False,hsd) + hsd=getSourceDirs tbi + in (tbi,fromJustDebug "extractFromTestAll" $ lookup testName' $ testSuiteConfigs lbi,testDir,False,hsd) copyAll :: [FilePath] -> BuildWrapper [(ModuleName,FilePath)] copyAll fps= do -- cf<-gets cabalFile @@ -452,7 +462,11 @@ let dir=(takeDirectory cf) fullFP<-getFullSrc fp allF<-liftIO $ getRecursiveContents fullFP - return $ map (\f->(fromString $ fileToModule $ makeRelative fullFP f,makeRelative dir f)) allF + tf<-gets tempFolder + -- exclude every file containing the temp folder name (".buildwrapper" by default) + -- which may happen if . is a source path + let notMyself=filter (\f->(not $ isInfixOf tf f)) allF + return $ map (\f->(fromString $ fileToModule $ makeRelative fullFP f,makeRelative dir f)) notMyself getReferencedFiles :: LocalBuildInfo -> BuildWrapper [CabalBuildInfo] getReferencedFiles lbi= do @@ -466,27 +480,27 @@ extractFromLib l=let lib=libBuildInfo l modules=(PD.exposedModules l) ++ (otherModules lib) - in [(lib,fromJust $ libraryConfig lbi,buildDir lbi,True,(copyModules modules (hsSourceDirs lib)))] + in [(lib,fromJustDebug "extractFromLibRef" $ libraryConfig lbi,buildDir lbi,True,(copyModules modules (getSourceDirs lib)))] extractFromExe :: Executable ->CabalBuildInfo extractFromExe e@Executable{exeName=exeName'}=let ebi=buildInfo e targetDir = buildDir lbi </> exeName' exeDir = targetDir </> (exeName' ++ "-tmp") modules= (otherModules ebi) - hsd=hsSourceDirs ebi - in (ebi,fromJust $ lookup exeName' $ executableConfigs lbi,exeDir,False, copyFiles [modulePath e] hsd++ (copyModules modules hsd) ) + hsd=getSourceDirs ebi + in (ebi,fromJustDebug "extractFromExeRef" $ lookup exeName' $ executableConfigs lbi,exeDir,False, copyFiles [modulePath e] hsd++ (copyModules modules hsd) ) extractFromTest :: TestSuite -> CabalBuildInfo extractFromTest t@TestSuite {testName=testName'} =let tbi=testBuildInfo t targetDir = buildDir lbi </> testName' testDir = targetDir </> (testName' ++ "-tmp") modules= (otherModules tbi ) - hsd=hsSourceDirs tbi + hsd=getSourceDirs tbi extras=case testInterface t of (TestSuiteExeV10 _ mp)->(copyFiles [mp] hsd) (TestSuiteLibV09 _ mn)->copyModules [mn] hsd _->[] - in (tbi,fromJust $ lookup testName' $ testSuiteConfigs lbi,testDir,False,extras++ (copyModules modules hsd) ) + in (tbi,fromJustDebug ("extractFromTestRef:"++testName'++(show $ testSuiteConfigs lbi)) $ lookup testName' $ testSuiteConfigs lbi,testDir,False,extras++ (copyModules modules hsd) ) copyModules :: [ModuleName] -> [FilePath] -> [(ModuleName,FilePath)] copyModules mods=copyFiles (concatMap (\m->[(toFilePath m) <.> "hs",((toFilePath m) <.> "lhs")]) mods) copyFiles :: [FilePath] -> [FilePath] -> [(ModuleName,FilePath)]
src/Language/Haskell/BuildWrapper/GHC.hs view
@@ -97,7 +97,7 @@ a<-f (dm_typechecked_module l) #if __GLASGOW_HASKELL__ < 702 warns <- getWarnings - return $ (Just a,notes++ (reverse $ ghcMessagesToNotes base_dir (warns, emptyBag))) + return $ (Just a,List.nub $ notes++ (reverse $ ghcMessagesToNotes base_dir (warns, emptyBag))) #else notes2 <- GMU.liftIO $ readIORef ref return $ (Just a,notes2) @@ -133,7 +133,7 @@ | (Just status)<-bwSeverity s=do let n=BWNote { bwn_location = ghcSpanToBWLocation base_dir loc , bwn_status = status - , bwn_title = removeStatus status $ showSDocForUser (qualName ppr,qualModule ppr) msg + , bwn_title = removeBaseDir base_dir $ removeStatus status $ showSDocForUser (qualName ppr,qualModule ppr) msg } modifyIORef ref $ \ns -> ( ns ++ [n]) | otherwise=do @@ -184,7 +184,7 @@ --(if typed then (doThingAtPointTyped $ typecheckedSource tcm) -- else doThingAtPointTyped (renamedSource tcm) loc qual tcm return tap) fp base_dir mod options - return $ fromMaybe "" t + return $ fromMaybe "no info" t where doThingAtPointTyped :: TypecheckedSource -> SrcSpan -> Bool -> TypecheckedModule -> PrintUnqualified -> String doThingAtPointTyped src loc qual tcm uq=let @@ -562,6 +562,7 @@ _ -> Continue 1 | otherwise = case f of Continue n->Indent (n+1) + Indent n->Indent (n+1) _ -> Indent 1 data PPBehavior=Continue Int | Indent Int | Start @@ -580,14 +581,14 @@ ghcMsgToNote note_kind base_dir msg = BWNote { bwn_location = ghcSpanToBWLocation base_dir loc , bwn_status = note_kind - , bwn_title = removeStatus note_kind $ show_msg (errMsgShortDoc msg) + , bwn_title = removeBaseDir base_dir $ removeStatus note_kind $ show_msg (errMsgShortDoc msg) } where loc | (s:_) <- errMsgSpans msg = s | otherwise = GHC.noSrcSpan unqual = errMsgContext msg show_msg = showSDocForUser unqual - + removeStatus :: BWNoteStatus -> String -> String removeStatus BWWarning s | List.isPrefixOf "Warning:" s = List.dropWhile isSpace $ drop 8 s
src/Language/Haskell/BuildWrapper/Packages.hs view
@@ -155,9 +155,9 @@ convertPackageInfoIn (pkgconf@(InstalledPackageInfo { exposedModules = e, hiddenModules = h })) = - pkgconf{ exposedModules = map convert e, - hiddenModules = map convert h } - where convert = fromJust . simpleParse + pkgconf{ exposedModules = convert e, + hiddenModules = convert h } + where convert = mapMaybe simpleParse -- | Utility function that just flips the arguments to Control.Exception.catch catchError :: IO a -> (String -> IO a) -> IO a
test/Language/Haskell/BuildWrapper/CMDTests.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} -- | -- Module : Language.Haskell.BuildWrapper.CMDTests -- Author : JP Moresmau @@ -14,6 +15,8 @@ import Language.Haskell.BuildWrapper.Tests import Test.HUnit +import Control.Monad + import Data.Attoparsec import Data.Aeson import Data.Aeson.Parser @@ -21,6 +24,8 @@ import Data.List import System.Exit import System.Process +import System.FilePath +import System.Directory cmdTests::[Test] cmdTests= map (\f->f CMDAPI) tests @@ -42,10 +47,18 @@ getCabalDependencies _ r= runAPI r "dependencies" [] getCabalComponents _ r= runAPI r "components" [] +exeExtension :: String +#ifdef mingw32_HOST_OS +exeExtension = "exe" +#else +exeExtension = "" +#endif + runAPI:: (FromJSON a,Show a) => FilePath -> String -> [String] -> IO a runAPI root command args= do let fullargs=[command,"--tempfolder=.dist-buildwrapper","--cabalpath=cabal","--cabalfile="++(testCabalFile root)] ++ args - (ex,out,err)<-readProcessWithExitCode ".dist-buildwrapper/dist/build/buildwrapper/buildwrapper" fullargs "" + exePath<-filterM doesFileExist [".dist-buildwrapper/dist/build/buildwrapper/buildwrapper" <.> exeExtension,"dist/build/buildwrapper/buildwrapper" <.> exeExtension] + (ex,out,err)<-readProcessWithExitCode (head exePath) fullargs "" putStrLn ("out:"++out) putStrLn ("err:"++err) assertEqual ("returned error: "++show fullargs++"\n:"++show err) ExitSuccess ex
test/Language/Haskell/BuildWrapper/GHCTests.hs view
@@ -7,7 +7,7 @@ ghcTests :: [Test] -ghcTests=[testNoPreproc,testPreproc,testPreproc2Lines,testLiterate,testLiterateLatex +ghcTests=[testNoPreproc,testPreproc,testPreprocContiguous,testPreproc2Lines,testLiterate,testLiterateLatex ,testKeepIndent] testNoPreproc:: Test @@ -30,6 +30,20 @@ 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 )) + +testPreprocContiguous:: Test +testPreprocContiguous=TestLabel "testPreprocContiguous" (TestCase ( + 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) + 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 + )) testPreproc2Lines:: Test testPreproc2Lines=TestLabel "testPreproc2Lines" (TestCase (
test/Language/Haskell/BuildWrapper/Tests.hs view
@@ -27,19 +27,19 @@ import Control.Monad --import System.Time - tests :: (APIFacade a)=> [(a -> Test)] tests= [ testSynchronizeAll, testConfigureWarnings , testConfigureErrors , testBuildErrors , - testBuildWarnings, + testBuildWarnings , testBuildOutput, testModuleNotInCabal, testOutline, testOutlinePreproc, testPreviewTokenTypes, testThingAtPoint, + testThingAtPointNotInCabal, testNamesInScope, testInPlaceReference, testCabalComponents, @@ -298,7 +298,14 @@ 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 @@ -327,13 +334,9 @@ let rel="src"</>"A.hs" writeFile (root </> rel) $ unlines ["module A where","import Auto","fA=undefined"] let rel2="src"</>"Auto.hs" - putStrLn (root </> rel2) writeFile (root </> rel2) $ unlines ["module Auto where","fAuto=undefined"] (fps,ns)<-synchronize api root False - putStrLn $ show fps - putStrLn $ show ns (BuildResult bool1 _,nsErrors1)<-build api root True Source - putStrLn $ show nsErrors1 assertBool ("returned false on bool1") bool1 assertBool ("errors or warnings on nsErrors1") (null nsErrors1) (bool2, nsErrors2)<-build1 api root rel @@ -576,6 +579,20 @@ (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 ))