diff --git a/buildwrapper.cabal b/buildwrapper.cabal --- a/buildwrapper.cabal +++ b/buildwrapper.cabal @@ -1,5 +1,5 @@ name: buildwrapper -version: 0.1 +version: 0.2 cabal-version: >= 1.8 build-type: Simple license: BSD3 @@ -18,7 +18,7 @@ library hs-source-dirs: src build-depends: base < 5 , filepath, mtl, directory, Cabal, process, regex-tdfa, ghc, ghc-paths, syb, ghc-syb-utils, - text, containers, vector, haskell-src-exts, cpphs, old-time, aeson + text, containers, vector, haskell-src-exts, cpphs, old-time, aeson-native ghc-options: -Wall -fno-warn-unused-do-bind exposed-modules: Language.Haskell.BuildWrapper.API,Language.Haskell.BuildWrapper.Base,Language.Haskell.BuildWrapper.Cabal extensions: CPP @@ -28,14 +28,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, bytestring + ,vector, containers, syb, process, regex-tdfa, text, aeson-native, 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, text, process, bytestring, attoparsec, test-framework, test-framework-hunit + build-depends: base < 5, buildwrapper, HUnit, mtl, filepath, directory, Cabal, old-time, aeson-native, 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 diff --git a/src/Language/Haskell/BuildWrapper/API.hs b/src/Language/Haskell/BuildWrapper/API.hs --- a/src/Language/Haskell/BuildWrapper/API.hs +++ b/src/Language/Haskell/BuildWrapper/API.hs @@ -23,6 +23,7 @@ import Language.Haskell.Exts.Annotated import Language.Preprocessor.Cpphs import Data.Maybe +import System.Directory import System.FilePath --import System.Time import GHC (TypecheckedSource) @@ -101,10 +102,11 @@ case mcbi of Just(cbi)->do let (_,opts)=cabalExtensions $ snd cbi + (_,opts2)<-fileGhcOptions cbi tgt<-getTargetPath fp --let modS=moduleToString modName input<-liftIO $ preproc (snd cbi) tgt - pr<- liftIO $ getHSEAST input opts + pr<- liftIO $ getHSEAST input (opts++opts2) --let json=makeObj [("parse" , (showJSON $ pr))] return (Just pr,bwns) Nothing-> do @@ -118,21 +120,41 @@ return (Just pr,[]) getGHCAST :: FilePath -> BuildWrapper (OpResult (Maybe TypecheckedSource)) -getGHCAST fp = do - (mcbi,bwns)<-getBuildInfo fp - case mcbi of - Just(cbi)->do - let (modName,opts)=cabalExtensions $ snd cbi - (_,opts2)<-fileGhcOptions cbi - tgt<-getTargetPath fp - temp<-getFullTempDir - let modS=moduleToString modName - (pr,bwns2)<- liftIO $ BwGHC.getAST tgt temp modS (opts++opts2) - return (pr,bwns2) - Nothing-> return (Nothing,bwns) +getGHCAST fp = withGHCAST' fp (\_->BwGHC.getAST) +--do +-- (mcbi,bwns)<-getBuildInfo fp +-- case mcbi of +-- Just(cbi)->do +-- let (modName,opts)=cabalExtensions $ snd cbi +-- (_,opts2)<-fileGhcOptions cbi +-- tgt<-getTargetPath fp +-- temp<-getFullTempDir +-- let modS=moduleToString modName +-- (pr,bwns2)<- liftIO $ BwGHC.getAST tgt temp modS (opts++opts2) +-- return (pr,bwns2) +-- Nothing-> return (Nothing,bwns) + withGHCAST :: FilePath -> (FilePath -> FilePath -> String -> [String] -> IO a) -> BuildWrapper (OpResult (Maybe a)) -withGHCAST fp f= do +withGHCAST fp f=withGHCAST' fp (\n a b c d->do + r<- f a b c d + return $ ((Just r),n)) +--do +-- (mcbi,bwns)<-getBuildInfo fp +-- case mcbi of +-- Just(cbi)->do +-- let (modName,opts)=cabalExtensions $ snd cbi +-- (_,opts2)<-fileGhcOptions cbi +-- tgt<-getTargetPath fp +-- temp<-getFullTempDir +-- let modS=moduleToString modName +-- pr<- liftIO $ f tgt temp modS (opts++opts2) +-- return (Just pr,bwns) +-- Nothing-> return (Nothing,bwns) + + +withGHCAST' :: FilePath -> ([BWNote] -> FilePath -> FilePath -> String -> [String] -> IO (OpResult (Maybe a))) -> BuildWrapper (OpResult (Maybe a)) +withGHCAST' fp f= do (mcbi,bwns)<-getBuildInfo fp case mcbi of Just(cbi)->do @@ -140,9 +162,13 @@ (_,opts2)<-fileGhcOptions cbi tgt<-getTargetPath fp temp<-getFullTempDir - let modS=moduleToString modName - pr<- liftIO $ f tgt temp modS (opts++opts2) - return (Just pr,bwns) + liftIO $ do + cd<-getCurrentDirectory + setCurrentDirectory temp + let modS=moduleToString modName + (pr,bwns2)<- f bwns tgt temp modS (opts++opts2) + setCurrentDirectory cd + return (pr,bwns2) Nothing-> return (Nothing,bwns) getOutline :: FilePath -> BuildWrapper (OpResult [OutlineDef]) 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 @@ -106,7 +106,8 @@ Type | Instance | Field | - Constructor + Constructor | + Splice deriving (Show,Read,Eq,Ord,Enum) instance ToJSON OutlineDefType where 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 @@ -104,12 +104,12 @@ cabalBuild :: Bool -> WhichCabal -> BuildWrapper (OpResult BuildResult) cabalBuild output srcOrTgt= do + dist_dir<-getDistDir (mr,n)<-withCabal srcOrTgt (\_->do cf<-getCabalFile srcOrTgt cp<-gets cabalPath v<-cabalV - dist_dir<-getDistDir - + let args=[ "build", "--verbose="++(show $ fromEnum v), @@ -127,17 +127,26 @@ -- putStrLn "cabal build start" (ex,out,err)<-readProcessWithExitCode cp args "" putStrLn err - --putStrLn ("build out:" ++ out) - let fps=catMaybes $ map getBuiltPath $ lines out - -- c2<-getClockTime - -- putStrLn ("cabal build end" ++ (timeDiffToString $ diffClockTimes c2 c1)) - let ret=parseBuildMessages err - setCurrentDirectory cd - return (ex==ExitSuccess,ret,fps) + if (isInfixOf "cannot satisfy -package-id" err) || (isInfixOf "re-run the 'configure'" err) + then + return Nothing + else + do + --putStrLn ("build out:" ++ out) + let fps=catMaybes $ map getBuiltPath $ lines out + -- c2<-getClockTime + -- putStrLn ("cabal build end" ++ (timeDiffToString $ diffClockTimes c2 c1)) + let ret=parseBuildMessages err + setCurrentDirectory cd + return $ Just (ex==ExitSuccess,ret,fps) ) - return $ case mr of - Nothing -> ((BuildResult False []),n) - Just (r,n2,fps) -> ((BuildResult r fps),n++n2) + case mr of + Nothing -> return ((BuildResult False []),n) + Just Nothing->do + let setup_config = DSC.localBuildInfoFile dist_dir + liftIO $ removeFile setup_config + cabalBuild output srcOrTgt + Just (Just (r,n2,fps)) -> return ((BuildResult r fps),n++n2) cabalConfigure :: WhichCabal-> BuildWrapper (OpResult (Maybe LocalBuildInfo)) cabalConfigure srcOrTgt= do @@ -264,6 +273,13 @@ Nothing -> ls Just (bwn,msgs)->ls++[makeNote bwn msgs] where + setupExe :: String + setupExe=addExtension "setup" $ takeExtension cabalExe + dropPrefixes :: [String] -> String -> Maybe String + dropPrefixes prfxs s=foldr (stripPrefixIfNeeded s) Nothing prfxs + stripPrefixIfNeeded :: String -> String -> Maybe String -> Maybe String + stripPrefixIfNeeded _ _ j@(Just r)=j + stripPrefixIfNeeded s prfx _=stripPrefix prfx s parseCabalLine :: (Maybe (BWNote,[String]),[BWNote]) -> String ->(Maybe (BWNote,[String]),[BWNote]) parseCabalLine (currentNote,ls) l | isPrefixOf "Error:" l=(Just (BWNote BWError "" (BWLocation cf 1 1),[dropWhile isSpace $ drop 6 l]),addCurrent currentNote ls) @@ -273,9 +289,9 @@ then dropWhile isSpace $ drop ((length cf) + 1) msg else msg in (Just (BWNote BWWarning "" (BWLocation cf (extractLine msg2) 1),[msg2]),addCurrent currentNote ls) - | isPrefixOf (cabalExe++":") l= + | Just s <- dropPrefixes [cabalExe,setupExe] l= let - s2=(dropWhile isSpace $ drop ((length cabalExe)+1) l) + s2=dropWhile isSpace $ drop 1 s -- drop 1 for ":" that follows file name in if isPrefixOf "At least the following" s2 then (Just $ (BWNote BWError "" (BWLocation cf 1 1),[s2]),addCurrent currentNote ls) else @@ -314,7 +330,7 @@ parseBuildLine :: (Maybe (BWNote,[String]),[BWNote]) -> String ->(Maybe (BWNote,[String]),[BWNote]) parseBuildLine (currentNote,ls) l | Just (jcn,msgs)<-currentNote= - if (not $ null l) + if (not $ null l) && (' ' ==(head l)) then (Just (jcn,l:msgs),ls) else (Nothing,ls++[makeNote jcn msgs]) -- | Just fp<-getBuiltPath l=(currentNote,ls,fp:fps) 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 @@ -64,12 +64,13 @@ withASTNotes :: (TypecheckedModule -> Ghc a) -> FilePath -> FilePath -> String -> [String] -> IO (OpResult (Maybe a)) withASTNotes f fp base_dir mod options=do let lflags=map noLoc options + --putStrLn $ show options (_leftovers, _) <- parseStaticFlags lflags runGhc (Just libdir) $ do flg <- getSessionDynFlags (flg', _, _) <- parseDynamicFlags flg _leftovers ref <- GMU.liftIO $ newIORef [] - setSessionDynFlags flg' { hscTarget = HscNothing, ghcLink = NoLink , ghcMode = OneShot, log_action = logAction ref } + setSessionDynFlags flg' { hscTarget = HscNothing, ghcLink = NoLink , ghcMode = CompManager, log_action = logAction ref } -- $ dopt_set (flg' { ghcLink = NoLink , ghcMode = CompManager }) Opt_ForceRecomp addTarget Target { targetId = TargetFile fp Nothing, targetAllowObjCode = True, targetContents = Nothing } --c1<-GMU.liftIO getClockTime 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 @@ -25,9 +25,14 @@ getHSEAST :: String -> [String] -> IO (ParseResult (Module SrcSpanInfo, [Comment])) getHSEAST input options=do + --putStrLn $ show options let exts=map classifyExtension options - -- putStrLn $ show exts - let mode=defaultParseMode {extensions=exts,ignoreLinePragmas=False,ignoreLanguagePragmas=False} + let extsFull=if elem "-fglasgow-exts" options + then exts ++ glasgowExts + else exts + --putStrLn input + --putStrLn $ show exts + let mode=defaultParseMode {extensions=extsFull,ignoreLinePragmas=False,ignoreLanguagePragmas=False} return $ parseFileContentsWithComments mode input --return $ makeObj [("parse" , (showJSON $ pr))] @@ -47,6 +52,7 @@ declOutline (FunBind l matches) = [OutlineDef (matchDecl $ head matches) [Function] (makeSpan l) []] declOutline (PatBind l (PVar _ n) _ _ _)=[OutlineDef (nameDecl n) [Function] (makeSpan l) []] declOutline (InstDecl l _ h idecls)=[OutlineDef (iheadDecl h) [Instance] (makeSpan l) (maybe [] (concatMap instDecl) idecls)] + declOutline (SpliceDecl l e)=[OutlineDef (spliceDecl e) [Splice] (makeSpan l) []] declOutline _ = [] qualConDeclOutline :: QualConDecl SrcSpanInfo-> OutlineDef qualConDeclOutline (QualConDecl l _ _ con)=let @@ -93,6 +99,14 @@ instDecl :: InstDecl SrcSpanInfo -> [OutlineDef] instDecl (InsDecl _ d) = declOutlineInClass d instDecl _ = [] + spliceDecl :: Exp SrcSpanInfo -> T.Text + spliceDecl (SpliceExp _ sp)= spliceName sp + spliceDecl (App _ e1 _)=spliceDecl e1 + spliceDecl (Var _ qn)=qnameDecl qn + spliceDecl _ = "" + spliceName :: Splice SrcSpanInfo -> T.Text + spliceName (IdSplice _ n)=T.pack n + spliceName (ParenSplice _ e)=spliceDecl e getHSEOutline _ = [] diff --git a/test/Language/Haskell/BuildWrapper/APITest.hs b/test/Language/Haskell/BuildWrapper/APITest.hs --- a/test/Language/Haskell/BuildWrapper/APITest.hs +++ b/test/Language/Haskell/BuildWrapper/APITest.hs @@ -12,13 +12,14 @@ -- Direct tests on the API code module Language.Haskell.BuildWrapper.APITest where +import Language.Haskell.BuildWrapper.Base import qualified Language.Haskell.BuildWrapper.Cabal as Cabal import Test.HUnit unitTests :: [Test] -unitTests=[testGetBuiltPath] +unitTests=[testGetBuiltPath,testParseBuildMessages] --apiTests::Test --apiTests=TestList $ map (\f->f DirectAPI) tests @@ -48,4 +49,12 @@ 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" - )) + )) + +testParseBuildMessages :: Test +testParseBuildMessages = TestLabel "testParseBuildMessages" (TestCase (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 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" (BWLocation "Main.hs" 2 3)) (head notes) + )) diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -15,13 +15,16 @@ import Language.Haskell.BuildWrapper.APITest import Language.Haskell.BuildWrapper.CMDTests -import Test.Framework (defaultMain, testGroup) +import Test.Framework (defaultMain, testGroup,Test) import Test.Framework.Providers.HUnit +main :: IO() main = defaultMain tests -tests = [testGroup "Unit Tests" (concatMap (hUnitTestToTests) unitTests), - testGroup "Command Tests" (concatMap (hUnitTestToTests) cmdTests)] +tests :: [Test] +tests = [testGroup "Unit Tests" (concatMap (hUnitTestToTests) unitTests) + ,testGroup "Command Tests" (concatMap (hUnitTestToTests) cmdTests) + ] --import Language.Haskell.BuildWrapper.APITest --import Language.Haskell.BuildWrapper.CMDTests