diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,5 +1,7 @@ # BuildWrapper +[![Build Status](https://travis-ci.org/JPMoresmau/BuildWrapper.svg?branch=master)](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. diff --git a/buildwrapper.cabal b/buildwrapper.cabal --- a/buildwrapper.cabal +++ b/buildwrapper.cabal @@ -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, diff --git a/src/Language/Haskell/BuildWrapper/Base.hs b/src/Language/Haskell/BuildWrapper/Base.hs --- a/src/Language/Haskell/BuildWrapper/Base.hs +++ b/src/Language/Haskell/BuildWrapper/Base.hs @@ -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) diff --git a/src/Language/Haskell/BuildWrapper/Cabal.hs b/src/Language/Haskell/BuildWrapper/Cabal.hs --- a/src/Language/Haskell/BuildWrapper/Cabal.hs +++ b/src/Language/Haskell/BuildWrapper/Cabal.hs @@ -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} diff --git a/src/Language/Haskell/BuildWrapper/GHC.hs b/src/Language/Haskell/BuildWrapper/GHC.hs --- a/src/Language/Haskell/BuildWrapper/GHC.hs +++ b/src/Language/Haskell/BuildWrapper/GHC.hs @@ -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 diff --git a/src/Language/Haskell/BuildWrapper/GHCStorage.hs b/src/Language/Haskell/BuildWrapper/GHCStorage.hs --- a/src/Language/Haskell/BuildWrapper/GHCStorage.hs +++ b/src/Language/Haskell/BuildWrapper/GHCStorage.hs @@ -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 diff --git a/src/Language/Haskell/BuildWrapper/Src.hs b/src/Language/Haskell/BuildWrapper/Src.hs --- a/src/Language/Haskell/BuildWrapper/Src.hs +++ b/src/Language/Haskell/BuildWrapper/Src.hs @@ -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 diff --git a/test/Language/Haskell/BuildWrapper/CMDLongRunningTests.hs b/test/Language/Haskell/BuildWrapper/CMDLongRunningTests.hs --- a/test/Language/Haskell/BuildWrapper/CMDLongRunningTests.hs +++ b/test/Language/Haskell/BuildWrapper/CMDLongRunningTests.hs @@ -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) + diff --git a/test/Language/Haskell/BuildWrapper/CMDTests.hs b/test/Language/Haskell/BuildWrapper/CMDTests.hs --- a/test/Language/Haskell/BuildWrapper/CMDTests.hs +++ b/test/Language/Haskell/BuildWrapper/CMDTests.hs @@ -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