buildwrapper 0.8.11 → 0.9.0
raw patch · 9 files changed
+170/−38 lines, 9 filesdep +asyncdep +conduitdep +conduit-extraPVP ok
version bump matches the API change (PVP)
Dependencies added: async, conduit, conduit-extra
API changes (from Hackage documentation)
+ Language.Haskell.BuildWrapper.Base: getTargetPath' :: FilePath -> FilePath -> IO FilePath
+ Language.Haskell.BuildWrapper.Base: runAndPrint :: FilePath -> [String] -> IO (ExitCode, String, String)
Files
- README.md +2/−0
- buildwrapper.cabal +22/−7
- src/Language/Haskell/BuildWrapper/Base.hs +37/−4
- src/Language/Haskell/BuildWrapper/Cabal.hs +6/−7
- src/Language/Haskell/BuildWrapper/GHC.hs +21/−14
- src/Language/Haskell/BuildWrapper/GHCStorage.hs +3/−3
- src/Language/Haskell/BuildWrapper/Src.hs +6/−1
- test/Language/Haskell/BuildWrapper/CMDLongRunningTests.hs +46/−0
- test/Language/Haskell/BuildWrapper/CMDTests.hs +27/−2
README.md view
@@ -1,5 +1,7 @@ # BuildWrapper +[](https://travis-ci.org/JPMoresmau/BuildWrapper) + BuildWrapper is a program designed to help an IDE deal with a Haskell project. It combines several tools under a simple API: - Cabal to configure and build the project. BuildWrapper works best on project that provide a cabal file.
buildwrapper.cabal view
@@ -1,5 +1,5 @@ name: buildwrapper-version: 0.8.11+version: 0.9.0 cabal-version: >= 1.8 build-type: Custom license: BSD3@@ -17,6 +17,10 @@ extra-source-files: README.md CHANGELOG +flag lib-Werror+ default: False+ manual: True+ library hs-source-dirs: src build-depends: @@ -44,7 +48,10 @@ attoparsec>=0.11 && <0.13, transformers, deepseq,- ghc-pkg-lib+ ghc-pkg-lib,+ conduit,+ conduit-extra,+ async ghc-options: -Wall -fno-warn-unused-do-bind exposed-modules: Language.Haskell.BuildWrapper.API,@@ -58,6 +65,8 @@ if impl(ghc >= 7.6) build-depends: time+ if flag(lib-Werror)+ ghc-options: -Werror executable buildwrapper@@ -86,10 +95,13 @@ aeson, bytestring, transformers,- ghc-pkg-lib- ghc-options: -Wall -fno-warn-unused-do-bind -optl -s+ ghc-pkg-lib,+ conduit,+ conduit-extra,+ async+ ghc-options: -Wall -fno-warn-unused-do-bind -optl -s -threaded -- see https://ghc.haskell.org/trac/ghc/ticket/8376--- if impl(ghc >= 7.8) && impl(ghc < 7.8.4)+-- if impl(ghc >= 7.8) && impl(ghc < 7.10) -- ghc-options: -- -dynamic other-modules: Language.Haskell.BuildWrapper.CMD@@ -120,9 +132,12 @@ vector, unordered-containers, containers,- ghc-pkg-lib+ ghc-pkg-lib,+ conduit,+ conduit-extra,+ async main-is: Main.hs- ghc-options: -Wall -fno-warn-unused-do-bind -optl -s+ ghc-options: -Wall -fno-warn-unused-do-bind -optl -s -threaded other-modules: Language.Haskell.BuildWrapper.APITest, Language.Haskell.BuildWrapper.CMDTests,
src/Language/Haskell/BuildWrapper/Base.hs view
@@ -14,7 +14,14 @@ import Control.Monad import Control.Monad.State import Control.Exception (bracket) - +import Control.Concurrent.Async (Concurrently (..)) +import qualified Data.ByteString as BS +import Data.Conduit (($=),($$)) +import qualified Data.Conduit.List as CL +import Data.Conduit.Process (Inherited (..), proc, + streamingProcess, + waitForStreamingProcess) +import System.Exit (ExitCode) import Data.Data import Data.Aeson @@ -29,7 +36,8 @@ import Data.Maybe (catMaybes) import System.IO.UTF8 (hPutStr,hGetContents) -import System.IO (IOMode, openBinaryFile, IOMode(..), Handle, hClose) +import Data.ByteString.UTF8 (toString) +import System.IO (IOMode, openBinaryFile, IOMode(..), Handle, hClose, hFlush, stdout) import Control.DeepSeq (rnf, NFData) -- | State type @@ -479,10 +487,18 @@ -> BuildWrapper FilePath getTargetPath src=do temp<-getFullTempDir + liftIO $ getTargetPath' src temp + +-- | get full path in temporary folder for source file (i.e. where we're going to write the temporary contents of an edited file) +getTargetPath' :: FilePath -- ^ relative path of source file + -> FilePath + -> IO FilePath +getTargetPath' src temp=do let path=temp </> src - liftIO $ createDirectoryIfMissing True (takeDirectory path) + createDirectoryIfMissing True (takeDirectory path) return path + -- | get the full, canonicalized path of a source canonicalizeFullPath :: FilePath -- ^ relative path of source file -> BuildWrapper FilePath @@ -828,4 +844,21 @@ if prf `isPrefixOf` s then (reverse a,s) else go xs (x:a) - + +-- | run a program, writing the output/error to standard output as we go +runAndPrint :: FilePath -> [String] -> IO (ExitCode,String,String) +runAndPrint prog args = do + (Inherited,outP,errP,cph) <- streamingProcess (proc prog args) + let + bsw bs = do + BS.putStr bs + hFlush stdout + return bs + output = outP $$ CL.mapM bsw $= CL.consume + err = errP $$ CL.mapM bsw $= CL.consume + + (outb,errb,ec) <- runConcurrently $ (,,) + <$> Concurrently output + <*> Concurrently err + <*> Concurrently (waitForStreamingProcess cph) + return (ec,toString $ BS.concat outb,toString $ BS.concat errb)
src/Language/Haskell/BuildWrapper/Cabal.hs view
@@ -106,8 +106,7 @@ when logC (putStrLn $ showCommandForUser cp args) cd<-getCurrentDirectory setCurrentDirectory (takeDirectory cf) - (ex,out,err)<-readProcessWithExitCode cp args "" - putStrLn err + (ex,out,err)<-runAndPrint cp args if isInfixOf "cannot satisfy -package-id" err || isInfixOf "re-run the 'configure'" err then return Nothing @@ -163,8 +162,7 @@ when logC (putStrLn $ showCommandForUser cp args) cd<-getCurrentDirectory setCurrentDirectory (takeDirectory cf) - (ex,_,err)<-readProcessWithExitCode cp args "" - putStrLn err + (ex,_,err)<-runAndPrint cp args let msgs=parseCabalMessages (takeFileName cf) (takeFileName cp) err -- ++ (parseCabalMessages (takeFileName cf) out) ret<-case ex of ExitSuccess -> if any isBWNoteError msgs @@ -500,6 +498,7 @@ "module DynamicCabalQuery where" ,"import Distribution.PackageDescription" ,"import Distribution.Simple.LocalBuildInfo" + ,"import Distribution.Simple.Configure (maybeGetPersistBuildConfig)" ,"import Data.IORef" ,"import qualified Data.Map as DM" ,"import qualified Distribution.Verbosity as V" @@ -516,7 +515,8 @@ ,"" ,"result :: IO (DM.Map String [String])" ,"result=do" - ,"lbi<-liftM (read . Prelude.unlines . drop 1 . lines) $ Prelude.readFile "++show setup_config + --,"lbi<-liftM (read . Prelude.unlines . drop 1 . lines) $ Prelude.readFile "++show setup_config + ,"Just lbi <- maybeGetPersistBuildConfig "++show dist_dir ,"let pkg=localPkgDescr lbi" ,"r<-newIORef DM.empty" ,"let fmp=DM."++ show fmp @@ -530,9 +530,8 @@ ," return ()" ," )" ,"readIORef r" ] - -- print src m::DM.Map String [String]<-liftIO $ DCD.runRawQuery src setup_config - return $ map (set m)tgs + return $ map (set m) tgs where set mOpts t=case DM.lookup (DCD.targetName t) mOpts of Just opts->t{DCD.ghcOptions=opts}
src/Language/Haskell/BuildWrapper/GHC.hs view
@@ -379,20 +379,20 @@ -> String -- ^ module name -> [String] -- ^ build options -> IO ()-getGhcNameDefsInScopeLongRunning fp base_dir modul =+getGhcNameDefsInScopeLongRunning fp0 base_dir modul0 = #if __GLASGOW_HASKELL__ < 706- initGHC (go (TOD 0 0))+ initGHC (go (fp0,modul0) (TOD 0 0)) #else- initGHC (go (UTCTime (ModifiedJulianDay 0) 0))+ initGHC (go (fp0,modul0) (UTCTime (ModifiedJulianDay 0) 0)) #endif where #if __GLASGOW_HASKELL__ < 706- go :: ClockTime -> Ghc ()+ go :: (FilePath,String) -> ClockTime -> Ghc () #else- go :: UTCTime -> Ghc ()+ go :: (FilePath,String) -> UTCTime -> Ghc () #endif- go t1 = do+ go (fp,modul) t1 = do let hasLoaded=case t1 of #if __GLASGOW_HASKELL__ < 706 TOD 0 _ -> False@@ -422,8 +422,8 @@ _ -> (Nothing,ns1 ++ ns) GMU.liftIO $ BSC.putStrLn $ BS.append "build-wrapper-json:" $ encode res GMU.liftIO $ hFlush stdout- r1 t2- r1 t2=do+ r1 (fp,modul) t2+ r1 (fp,modul) t2=do l<- GMU.liftIO getLine case l of "q"->return ()@@ -438,7 +438,7 @@ BSC.putStrLn "" BSC.putStrLn $ BS.append "build-wrapper-json:" js hFlush stdout- r1 t2 + r1 (fp,modul) t2 -- token types "t"->do input<- GMU.liftIO $ readFile fp@@ -449,7 +449,7 @@ GMU.liftIO $ do BSC.putStrLn $ BS.append "build-wrapper-json:" $ encode ret hFlush stdout- r1 t2 + r1 (fp,modul) t2 -- occurrences 'o':xs->do input<- GMU.liftIO $ readFile fp@@ -460,7 +460,7 @@ GMU.liftIO $ do BSC.putStrLn $ BS.append "build-wrapper-json:" $ encode ret hFlush stdout- r1 t2 + r1 (fp,modul) t2 -- thing at point 'p':xs->do GMU.liftIO $ do@@ -474,7 +474,7 @@ _-> Nothing BSC.putStrLn $ BS.append "build-wrapper-json:" $ encode (mm,[]::[BWNote]) hFlush stdout- r1 t2+ r1 (fp,modul) t2 -- locals 'l':xs->do GMU.liftIO $ do@@ -489,8 +489,15 @@ _-> [] BSC.putStrLn $ BS.append "build-wrapper-json:" $ encode (mm,[]::[BWNote]) hFlush stdout- r1 t2- _ ->go t2+ r1 (fp,modul) t2+ -- change current+ 'c':xs -> do+ -- removeTarget (TargetFile fp Nothing) + let (fp1,modul1) = read xs+ tgt<-GMU.liftIO $ getTargetPath' fp1 base_dir+ t3<- GMU.liftIO $ getModificationTime tgt+ go (tgt,modul1) t3+ _ -> go (fp,modul) t2 -- | evaluate expression in the GHC monad
src/Language/Haskell/BuildWrapper/GHCStorage.hs view
@@ -352,9 +352,9 @@ (_, mbe) <- GMU.liftIO $ deSugarExpr hs_env e #else getType hs_env tcm e = do - modu = ms_mod $ pm_mod_summary $ tm_parsed_module tcm - rn_env = tcg_rdr_env $ fst $ tm_internals_ tcm - ty_env = tcg_type_env $ fst $ tm_internals_ tcm + let modu = ms_mod $ pm_mod_summary $ tm_parsed_module tcm + rn_env = tcg_rdr_env $ fst $ tm_internals_ tcm + ty_env = tcg_type_env $ fst $ tm_internals_ tcm (_, mbe) <- GMU.liftIO $ deSugarExpr hs_env modu rn_env ty_env e #endif return $ fmap CoreUtils.exprType mbe
src/Language/Haskell/BuildWrapper/Src.hs view
@@ -169,9 +169,14 @@ in case m of Nothing->(Nothing,ss1) -- the type ends just before us: merge src info - Just (ty,ss2)->if srcSpanEndLine (srcInfoSpan ss2) == (srcSpanStartLine (srcInfoSpan ss1) - 1) + Just (ty,ss2)->let + end = lastEnd $ srcSpanEndLine (srcInfoSpan ss2) + in if end == (srcSpanStartLine (srcInfoSpan ss1) - 1) then (Just ty,combSpanInfo ss2 ss1) else (Just ty,ss1) + lastEnd end + | (end+1) `DM.member` commentMap= lastEnd $ end+1 + | otherwise = end commentMap:: DM.Map Int (Int,Int,Bool,T.Text) commentMap = foldl' buildCommentMap DM.empty comments addComment:: Bool -> OutlineDef -> State (DM.Map Int (Int,Int,Bool,T.Text)) OutlineDef
test/Language/Haskell/BuildWrapper/CMDLongRunningTests.hs view
@@ -296,3 +296,49 @@ assertBool (not $ notesInError ns2) assertBool (isJust mtts2) end inp + +test_ChangeLongRunning :: Assertion+test_ChangeLongRunning = do+ let api=cabalAPI+ root<-createTestProject+ synchronize api root False+ configure api root Source + let rel="src"</>"Main.hs"+ writeFile (root </> rel) $ unlines [ + "module Main where",+ "import B.D",+ "main=return $ map id \"toto\"",+ "data Type1=MkType1_1 Int"+ ] + let rel2="src" </> "B" </> "D.hs"+ writeFile (root </> rel2) $ unlines ["module B.D where","fD=reverse"] + build api root True Source+ synchronize api root False+ (inp,out,_,_)<-build1lr root rel+ (mtts,ns)<- readResult out :: IO (OpResult (Maybe [NameDef]))+ assertBool (isJust mtts)+ assertBool (not $ notesInError ns) + tapLR inp 3 16+ (tap1,nsErrorsTap)<-readResult out :: IO (OpResult (Maybe ThingAtPoint))+ assertBool (null nsErrorsTap)+ assertBool $ isJust tap1+ assertEqual "map" (tapName $ fromJust tap1)+ changeLR inp rel2 "B.D"+ (mtts2,ns2)<- readResult out :: IO (OpResult (Maybe [NameDef]))+ assertBool (isJust mtts2)+ assertBool (not $ notesInError ns2) + tapLR inp 2 6+ (tap2,nsErrorsTap2)<-readResult out :: IO (OpResult (Maybe ThingAtPoint))+ assertBool (null nsErrorsTap2)+ assertBool $ isJust tap2+ assertEqual "reverse" (tapName $ fromJust tap2)+ changeLR inp rel "Main"+ (mtts3,ns3)<- readResult out :: IO (OpResult (Maybe [NameDef]))+ assertBool (isJust mtts3)+ assertBool (not $ notesInError ns3) + tapLR inp 3 16+ (tap3,nsErrorsTap3)<-readResult out :: IO (OpResult (Maybe ThingAtPoint))+ assertBool (null nsErrorsTap3)+ assertBool $ isJust tap3+ assertEqual "map" (tapName $ fromJust tap3)+
test/Language/Haskell/BuildWrapper/CMDTests.hs view
@@ -755,7 +755,28 @@ ] Nothing (Just "Type for an entry in file") (Just 3)] assertEqual (length expected) (length defs) mapM_ (uncurry assertEqual) (zip expected defs)- + -- use api to write temp file+ write api root rel $ unlines [+ "module Module1 where",+ "", + "f1",+ " :: [a]",+ " -> [a]",+ " -- ^ The returned list",+ "f1 a=let",+ " f2 = reverse a",+ " in reverse f2" ]+ (_,nsErrors4f)<-getBuildFlags api root rel+ assertBool (null nsErrors4f) + (OutlineResult defs2 es2 is2,nsErrors2)<-getOutline api root rel+ assertBool (null nsErrors2)+ assertEqual [] es2+ assertEqual [] is2+ let expected2=[+ OutlineDef "f1" [Function] (InFileSpan (InFileLoc 3 1)(InFileLoc 9 18)) [] + (Just "[a] -> [a]") Nothing Nothing]+ assertEqual (length expected2) (length defs2)+ mapM_ (uncurry assertEqual) (zip expected2 defs2) test_OutlinePreproc :: Assertion test_OutlinePreproc = do@@ -2217,4 +2238,8 @@ notesInError :: [BWNote] -> Bool notesInError = any (\ x -> BWError == bwnStatus x)- ++changeLR :: Handle -> String -> String -> IO()+changeLR h fp m=do+ hPutStrLn h ('c':show (fp,m)) + hFlush h