diff --git a/buildwrapper.cabal b/buildwrapper.cabal --- a/buildwrapper.cabal +++ b/buildwrapper.cabal @@ -1,5 +1,5 @@ name: buildwrapper -version: 0.7.7 +version: 0.8.0 cabal-version: >= 1.8 build-type: Simple license: BSD3 @@ -24,6 +24,7 @@ mtl, directory, Cabal, + dynamic-cabal >=0.3 && <0.4, process, regex-tdfa, ghc, @@ -35,11 +36,11 @@ haskell-src-exts >= 1.12 && <1.15, cpphs, old-time, - aeson >=0.4, + aeson >=0.7 && <0.8, unordered-containers, utf8-string, bytestring, - attoparsec, + attoparsec>=0.11 && <0.12, transformers, deepseq ghc-options: -Wall -fno-warn-unused-do-bind @@ -67,6 +68,7 @@ cmdargs, filepath, Cabal, + dynamic-cabal >=0.3 && <0.4, directory, mtl, ghc, @@ -100,6 +102,7 @@ filepath, directory, Cabal, + dynamic-cabal, old-time, aeson >=0.4, text, diff --git a/src-exe/Language/Haskell/BuildWrapper/CMD.hs b/src-exe/Language/Haskell/BuildWrapper/CMD.hs --- a/src-exe/Language/Haskell/BuildWrapper/CMD.hs +++ b/src-exe/Language/Haskell/BuildWrapper/CMD.hs @@ -18,6 +18,7 @@ import System.Console.CmdArgs hiding (Verbosity(..),verbosity) import System.Directory (canonicalizePath) import Paths_buildwrapper +import System.IO import Data.Aeson import qualified Data.ByteString.Lazy as BS @@ -44,6 +45,7 @@ | Occurrences {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, cabalOption::[String], file:: FilePath,token::String, component:: Maybe String, logCabal::Bool} | ThingAtPointCmd {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, cabalOption::[String], file:: FilePath, line::Int, column::Int, component:: Maybe String, logCabal::Bool} | Locals {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, cabalOption::[String], file:: FilePath, sline::Int, scolumn::Int,eline::Int, ecolumn::Int, component:: Maybe String, logCabal::Bool} + | Eval {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, cabalOption::[String], file:: FilePath, expression::String, component:: Maybe String, logCabal::Bool} | NamesInScope {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, cabalOption::[String], file:: FilePath, component:: Maybe String, logCabal::Bool} | Dependencies {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, cabalOption::[String], sandbox::FilePath, logCabal::Bool} | Components {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, cabalOption::[String], logCabal::Bool} @@ -51,6 +53,7 @@ | GenerateUsage {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, cabalOption::[String], returnAll:: Bool, cabalComponent::String, logCabal::Bool} | CleanImports {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, cabalOption::[String], file:: FilePath, format :: Bool, component:: Maybe String, logCabal::Bool} | Clean {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, cabalOption::[String], everything:: Bool, logCabal::Bool} + deriving (Show,Read,Data,Typeable) @@ -126,6 +129,10 @@ (def &= help "start column" &= name "start column") (def &= help "end line" &= name "end line") (def &= help "end column" &= name "end column") mcc lc +meval :: BWCmd +meval=Eval tf cp cf uf co fp + (def &= help "expression to evaluation" &= name "expression") + mcc lc mnamesInScope :: BWCmd mnamesInScope=NamesInScope tf cp cf uf co fp mcc lc mdependencies :: BWCmd @@ -142,7 +149,7 @@ cmdMain = cmdArgs (modes [msynchronize, msynchronize1, mconfigure, mwrite, mbuild, mbuild1, - mgetbf,mcleanimports, moutline, mtokenTypes, moccurrences, mthingAtPoint, mlocals, + mgetbf,mcleanimports, moutline, mtokenTypes, moccurrences, mthingAtPoint, mlocals, meval, mnamesInScope, mdependencies, mcomponents, mgenerateUsage,mclean] &= helpArg [explicit, name "help", name "h"] &= help "buildwrapper executable" @@ -167,8 +174,9 @@ handle c@Occurrences{file=fi,token=t,component=mcomp}=runCmd c (getOccurrences fi t mcomp) handle c@ThingAtPointCmd{file=fi,line=l,column=col,component=mcomp}=runCmd c (getThingAtPoint fi l col mcomp) handle c@Locals{file=fi,sline=sl,scolumn=scol,eline=el,ecolumn=ecol,component=mcomp}=runCmd c (getLocals fi sl scol el ecol mcomp) + handle c@Eval{file=fi,expression=expr,component=mcomp}=runCmd c (evalExpression fi expr mcomp) handle c@NamesInScope{file=fi,component=mcomp}=runCmd c (getNamesInScope fi mcomp) - handle c@Dependencies{sandbox=sd}=runCmd c (getCabalDependencies sd) + handle c@Dependencies{sandbox=sd'}=runCmd c (getCabalDependencies sd') handle c@Components{}=runCmd c getCabalComponents handle c@GenerateUsage{returnAll=reta,cabalComponent=comp}=runCmd c (generateUsage reta comp) handle c@Clean{everything=e}=runCmd c (clean e) @@ -176,7 +184,8 @@ runCmd=runCmdV Normal runCmdV:: (ToJSON a) => Verbosity -> BWCmd -> StateT BuildWrapperState IO a -> IO () runCmdV vb cmd f= - do { cabalFile' <- (canonicalizePath $ cabalFile cmd) `catch` ((\_->return $ cabalFile cmd)::(IOException -> IO String)) -- canonicalize cabal-file path because Eclipse does not correctly keep track of case changes on the project path, but for preview the file does not exist! + do { cabalFile' <- canonicalizePath (cabalFile cmd) `catch` ((\_->return $ cabalFile cmd)::(IOException -> IO String)) -- canonicalize cabal-file path because Eclipse does not correctly keep track of case changes on the project path, but for preview the file does not exist! ; resultJson <- evalStateT f (BuildWrapperState (tempFolder cmd) (cabalPath cmd) cabalFile' vb (cabalFlags cmd) (cabalOption cmd) (logCabal cmd)) + ; hFlush stdout; hFlush stderr; BSC.putStrLn "" -- ensure streams are flushed, and prefix and start of the line ; BSC.putStrLn . BS.append "build-wrapper-json:" . encode $ resultJson } diff --git a/src-exe/Main.hs b/src-exe/Main.hs --- a/src-exe/Main.hs +++ b/src-exe/Main.hs @@ -11,7 +11,10 @@ module Main where import Language.Haskell.BuildWrapper.CMD +import System.IO (hSetBuffering, stdout, BufferMode(..)) -- | main entry point main::IO() -main = cmdMain +main = do + hSetBuffering stdout LineBuffering + cmdMain 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 @@ -11,9 +11,6 @@ -- API entry point, with all exposed methods module Language.Haskell.BuildWrapper.API where -import Distribution.Simple.LocalBuildInfo (localPkgDescr) -import Distribution.Package (packageId) -import Distribution.Text (display) import Language.Haskell.BuildWrapper.Base import Language.Haskell.BuildWrapper.Cabal import qualified Language.Haskell.BuildWrapper.GHC as BwGHC @@ -43,6 +40,7 @@ import Outputable (ppr) import Data.Foldable (foldrM) import qualified MonadUtils as GMU (liftIO) +import Control.Arrow (first) -- | copy all files from the project to the temporary folder @@ -100,7 +98,7 @@ temp<-getFullTempDir let dir=takeDirectory cf - let pkg=T.pack $ display $ packageId $ localPkgDescr lbi + pkg<-liftM T.pack getPackageName allMps<-mapM (\cbi->do let mps1=map (\(m,f)->(f,moduleToString $ fromJust m)) $ filter (isJust . fst) $ cbiModulePaths cbi @@ -112,11 +110,13 @@ ) $ filter (\(f,_)->fitForUsage f ) mps1 - opts<-fileGhcOptions (lbi,cbi) + + opts<-fileGhcOptions cbi modules<-liftIO $ do cd<-getCurrentDirectory setCurrentDirectory dir - (mods,_)<-BwGHC.withASTNotes (getModule pkg) (temp ) dir (MultipleFile mps) opts + (mods,notes)<-BwGHC.withASTNotes (getModule pkg) (temp ) dir (MultipleFile mps) opts + print notes setCurrentDirectory cd return mods mapM_ (generate pkg) modules @@ -334,7 +334,7 @@ --liftIO $ print mcbi ret<-case mcbi of Just cbi->do - opts2<-fileGhcOptions cbi + opts2<-fileGhcOptions $ snd cbi -- liftIO $ Prelude.print fp -- liftIO $ Prelude.print $ cbiModulePaths $ snd cbi -- liftIO $ Prelude.print opts2 @@ -390,6 +390,7 @@ r<- f a b c d return (Just r,[])) +-- | perform an action on the GHC AST, returning notes alonside with the result withGHCAST' :: FilePath -- ^ the source file -> Maybe String -- ^ the cabal component to use, or Nothing if not specified -> (FilePath -- ^ the source file @@ -424,9 +425,9 @@ then do mv<-liftIO $ getUsageInfo tgt return $ case mv of - (Array arr) | V.length arr==5->let + Array arr | V.length arr==5->let (Success r)= fromJSON (arr V.! 4) - in (Just r) + in Just r _->Nothing else return Nothing case mods of @@ -455,7 +456,7 @@ Left bw -> return ([],[bw]) --- ^ get all occurrences of a token in the file +-- | get all occurrences of a token in the file getOccurrences :: FilePath -- ^ the source file -> String -- ^ the token to search for -> Maybe String -- ^ the cabal component to use, or Nothing if not specified @@ -478,11 +479,8 @@ -- -> Bool -- ^ do we want the result qualified? -- -> Bool -- ^ do we want the result typed? -> BuildWrapper (OpResult (Maybe ThingAtPoint)) -getThingAtPoint fp line col mccn=do - mm<-withGHCAST fp mccn $ BwGHC.getThingAtPointJSON line col - return $ case mm of - (Just m,ns)->(m,ns) - (Nothing,ns)-> (Nothing,ns) +getThingAtPoint fp line col mccn= + liftM (first (fromMaybe Nothing)) $ withGHCAST fp mccn $ BwGHC.getThingAtPointJSON line col -- | get locals identifiers getLocals :: FilePath -- ^ the source file @@ -491,12 +489,18 @@ -> Int -- ^ the end line -> Int -- ^ the end column -> Maybe String -- ^ the cabal component to use, or Nothing if not specified - -> BuildWrapper (OpResult ([ThingAtPoint])) -getLocals fp sline scol eline ecol mccn=do - mm<-withGHCAST fp mccn $ BwGHC.getLocalsJSON sline scol eline ecol - return $ case mm of - (Just m,ns)->(m,ns) - (Nothing,ns)-> ([],ns) + -> BuildWrapper (OpResult [ThingAtPoint]) +getLocals fp sline scol eline ecol mccn= + liftM (first (fromMaybe [])) $ withGHCAST fp mccn $ BwGHC.getLocalsJSON sline scol eline ecol + +-- | evaluate an expression +evalExpression :: FilePath -- ^ the source file + -> String -- ^ expression + -> Maybe String -- ^ the cabal component to use, or Nothing if not specified + -> BuildWrapper (OpResult [EvalResult]) +evalExpression fp expression mccn= + liftM (first (fromMaybe [])) $ withGHCAST fp mccn $ BwGHC.eval expression + -- | get all names in scope (GHC API) getNamesInScope :: FilePath @@ -534,7 +538,8 @@ setCurrentDirectory cd return (m,ns ++ bwns2) _ -> return ([],ns) - + +-- | clean generated and copied files clean :: Bool -- ^ everything? -> BuildWrapper Bool clean everything=do 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 @@ -30,7 +30,7 @@ import System.IO.UTF8 (hPutStr,hGetContents) import System.IO (IOMode, openBinaryFile, IOMode(..), Handle, hClose) -import Control.DeepSeq (rnf) +import Control.DeepSeq (rnf, NFData) -- | State type type BuildWrapper=StateT BuildWrapperState IO @@ -74,6 +74,9 @@ } deriving (Show,Read,Eq) +instance NFData BWLocation + where rnf (BWLocation src sl sc el ec)=rnf src `seq` rnf sl `seq` rnf sc `seq` rnf el `seq` rnf ec + -- | build an empty span in a given file at a given location mkEmptySpan :: FilePath -> Int -> Int -> BWLocation mkEmptySpan src line col = BWLocation src line col line col @@ -98,6 +101,9 @@ } deriving (Show,Read,Eq) +instance NFData BWNote + where rnf (BWNote _ t l)=rnf t `seq` rnf l + -- | is a note an error? isBWNoteError :: BWNote -> Bool isBWNoteError bw=bwnStatus bw == BWError @@ -548,18 +554,24 @@ { ccTestName :: String -- ^ test suite name , ccBuildable :: Bool -- ^ is the test suite buildable } -- ^ test suite + | CCBenchmark + { ccBenchName :: String -- ^ benchmark name + , ccBuildable :: Bool -- ^ is the be buildabnchmarkle + } -- ^ test suite deriving (Eq, Show, Read,Ord) instance ToJSON CabalComponent where toJSON (CCLibrary b)= object ["Library" .= b] toJSON (CCExecutable e b)= object ["Executable" .= b,"e" .= e] toJSON (CCTestSuite t b)= object ["TestSuite" .= b,"t" .= t] + toJSON (CCBenchmark t b)= object ["Benchmark" .= b,"b" .= t] instance FromJSON CabalComponent where parseJSON (Object v) | Just b <- M.lookup "Library" v =CCLibrary <$> parseJSON b | Just b <- M.lookup "Executable" v =CCExecutable <$> v .: "e" <*> parseJSON b | Just b <- M.lookup "TestSuite" v =CCTestSuite <$> v .: "t" <*> parseJSON b + | Just b <- M.lookup "Benchmark" v =CCBenchmark <$> v .: "b" <*> parseJSON b | otherwise = mzero parseJSON _= mzero @@ -568,6 +580,7 @@ cabalComponentName CCLibrary{}="" cabalComponentName CCExecutable{ccExeName}=ccExeName cabalComponentName CCTestSuite{ccTestName}=ccTestName +cabalComponentName CCBenchmark{ccBenchName}=ccBenchName -- | a cabal package data CabalPackage=CabalPackage { @@ -778,10 +791,41 @@ -- | write string to file writeFile :: FilePath -> String -> IO () -writeFile n s = withBinaryFile n WriteMode (\ h -> hPutStr h s) +writeFile n s = withBinaryFile n WriteMode (`hPutStr` s) -- | perform operation on a binary opened file withBinaryFile :: FilePath -> IOMode -> (Handle -> IO a) -> IO a -withBinaryFile n m f = bracket (openBinaryFile n m) hClose f +withBinaryFile n m = bracket (openBinaryFile n m) hClose - +-- | Evaluation of result +-- using String since we get them from GHC API +-- this can be fully evaluated via deepseq to make sure any side effect are evaluated +data EvalResult = EvalResult { + erType :: Maybe String + ,erResult :: Maybe String + ,erError :: Maybe String + } deriving (Show,Read,Eq,Ord) + +instance NFData EvalResult + where rnf (EvalResult t r e)=rnf t `seq` rnf r `seq` rnf e + +instance ToJSON EvalResult where + toJSON (EvalResult mt mr me)=object ["t" .= mt, "r" .= mr, "e" .= me] + +instance FromJSON EvalResult where + parseJSON (Object v)=EvalResult <$> + v .: "t" <*> + v .: "r" <*> + v .: "e" + parseJSON _=mzero + +-- | splits a string at the first occurence of prefix +splitString :: Eq a => [a] -> [a] -> ([a],[a]) +splitString prf str=go str [] + where + go [] a=(reverse a,[]) + go s@(x:xs) a= + if prf `isPrefixOf` s + then (reverse a,s) + else go xs (x:a) + 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 @@ -22,25 +22,15 @@ import Data.List import Data.Maybe -#if MIN_VERSION_Cabal(1,15,0) -import Data.Version (parseVersion) -import Text.ParserCombinators.ReadP(readP_to_S) -#endif - import qualified Data.Map as DM import qualified Data.Set as DS import Exception (ghandle) import Distribution.ModuleName -import Distribution.PackageDescription ( otherModules,library,executables,testSuites,Library,hsSourceDirs,libBuildInfo,Executable(..),exeName,modulePath,buildInfo,TestSuite(..),testName,TestSuiteInterface(..),testInterface,testBuildInfo,BuildInfo,cppOptions,defaultExtensions,otherExtensions,oldExtensions ) -import Distribution.Simple.GHC -#if MIN_VERSION_Cabal(1,15,0) -import Distribution.Simple.Program.GHC -#endif -import Distribution.Simple.LocalBuildInfo -import Distribution.Simple.Compiler(OptimisationLevel(..)) + import qualified Distribution.PackageDescription as PD +import qualified Distribution.PackageDescription.Parse as PD import Distribution.Package import Distribution.InstalledPackageInfo as IPI import Distribution.Version @@ -57,9 +47,14 @@ import System.Process import Data.Functor.Identity (runIdentity) + +import qualified Distribution.Client.Dynamic as DCD + +-- | get the version of the cabal library getCabalLibraryVersion :: String getCabalLibraryVersion = VERSION_Cabal +-- | get all files to copy to temp folder getFilesToCopy :: BuildWrapper(OpResult [FilePath]) getFilesToCopy =do (mfps,bwns)<-withCabal Source getAllFiles @@ -67,7 +62,7 @@ Just fps->(nub $ concatMap (map snd . cbiModulePaths) fps,bwns) Nothing ->([],bwns); - +-- | get cabal verbose level cabalV :: BuildWrapper V.Verbosity cabalV =do v<-gets verbosity @@ -112,7 +107,7 @@ cd<-getCurrentDirectory setCurrentDirectory (takeDirectory cf) (ex,out,err)<-readProcessWithExitCode cp args "" - -- putStrLn err + putStrLn err if isInfixOf "cannot satisfy -package-id" err || isInfixOf "re-run the 'configure'" err then return Nothing @@ -133,9 +128,13 @@ else return (BuildResult False [],n) Just (Just (r,n2,fps)) -> return (BuildResult r fps, n ++ n2) +-- | the file where we save the targets +targetFile :: String +targetFile="dynamic_targets" + -- | run cabal configure cabalConfigure :: WhichCabal -- ^ use original cabal or temp cabal file - -> BuildWrapper (OpResult (Maybe LocalBuildInfo)) -- ^ return the build info on success, or Nothing on failure + -> BuildWrapper (OpResult (Maybe [DCD.Target])) -- ^ return the build info on success, or Nothing on failure cabalConfigure srcOrTgt= do cf<-getCabalFile srcOrTgt cp<-gets cabalPath @@ -153,6 +152,7 @@ "--verbose=" ++ show (fromEnum v), "--user", "--enable-tests", + "--enable-benchmarks", "--builddir="++dist_dir ] ++ (if null uf then [] else ["--flags="++uf]) @@ -168,11 +168,16 @@ ExitSuccess -> if any isBWNoteError msgs then return (Nothing,msgs) else do - lbi<-DSC.getPersistBuildConfig dist_dir - return (Just lbi,msgs) - ExitFailure ec -> if null msgs - then return (Nothing,[BWNote BWError ("Cabal configure returned error code " ++ show ec) (mkEmptySpan cf 1 1)]) - else return (Nothing, msgs) + --lbi<-DSC.getPersistBuildConfig dist_dir + let setup_config = DSC.localBuildInfoFile dist_dir + tgs <- DCD.runQuery (DCD.on DCD.localPkgDesc DCD.targets) setup_config + tgs'<- setOptions dist_dir tgs + let tgsF=dist_dir targetFile + Prelude.writeFile tgsF $ show tgs' + return (Just tgs',msgs) + ExitFailure ec -> return $ if null msgs + then (Nothing,[BWNote BWError ("Cabal configure returned error code " ++ show ec) (mkEmptySpan cf 1 1)]) + else (Nothing, msgs) setCurrentDirectory cd return ret else do @@ -187,36 +192,46 @@ getCabalFile Target= fmap takeFileName (gets cabalFile) >>=getTargetPath +-- | get package name from cabal file +getPackageName :: BuildWrapper String +getPackageName = do + cf<-gets cabalFile + gpd<-liftIO $ PD.readPackageDescription V.silent cf + return $ display $ packageId $ PD.packageDescription gpd + -- | get Cabal build info, running configure if needed cabalInit :: WhichCabal -- ^ use original cabal or temp cabal file - -> BuildWrapper (OpResult (Maybe LocalBuildInfo)) + -> BuildWrapper (OpResult (Maybe [DCD.Target])) cabalInit srcOrTgt= do cabal_file<-getCabalFile srcOrTgt dist_dir<-getDistDir - let setup_config = DSC.localBuildInfoFile dist_dir - conf'd <- liftIO $ doesFileExist setup_config + -- let setup_config = DSC.localBuildInfoFile dist_dir + let tgtF=dist_dir targetFile + conf'd <- liftIO $ doesFileExist tgtF if not conf'd then do liftIO $ putStrLn "configuring because setup_config not present" cabalConfigure srcOrTgt else do cabal_time <- liftIO $ getModificationTime cabal_file - conf_time <- liftIO $ getModificationTime setup_config + conf_time <- liftIO $ getModificationTime tgtF if cabal_time > conf_time then do liftIO $ putStrLn "configuring because setup_config too old" cabalConfigure srcOrTgt else do - mb_lbi <- liftIO $ DSC.maybeGetPersistBuildConfig dist_dir - case mb_lbi of - Nothing -> do + tgs <-liftM tryReadList $ liftIO $ Prelude.readFile tgtF + -- tgs <- liftIO $ DCD.runQuery (DCD.on DCD.localPkgDesc DCD.targets) setup_config + --mb_lbi <- liftIO $ DSC.maybeGetPersistBuildConfig dist_dir + case tgs of + [] -> do liftIO $ putStrLn "configuring because persist build config not present" cabalConfigure srcOrTgt - Just _lbi -> return (Just _lbi, []) + _ -> return (Just tgs, []) -- | run a action with the cabal build info withCabal :: WhichCabal -- ^ use original cabal or temp cabal file - -> (LocalBuildInfo -> BuildWrapper a) -- ^ action to run if we get a build info + -> ([DCD.Target] -> BuildWrapper a) -- ^ action to run if we get a build info -> BuildWrapper (OpResult (Maybe a)) -- ^ the result of the action, or Nothing if we could get Cabal info withCabal srcOrTgt f=do (mlbi,notes)<-cabalInit srcOrTgt @@ -246,7 +261,7 @@ then dropWhile isSpace $ drop (length cf + 1) msg else msg in (Just (BWNote BWWarning "" (mkEmptySpan cf (extractLine msg2) 1),[msg2]),addCurrent currentNote ls) - | Just (bw,n)<- cabalErrorLine cf cabalExe l=(Just (bw,n),addCurrent currentNote ls) + | Just (bw,n)<- cabalErrorLine cf cabalExe l (not (any isBWNoteError ls))=(Just (bw,n),addCurrent currentNote ls) | Just (jcn,msgs)<-currentNote= if not $ null l then (Just (jcn,l:msgs),ls) @@ -257,32 +272,39 @@ in if null ls then 1 else readInt (head ls) 1 - + +-- | get the setup exe file name setupExe :: FilePath -- ^ path to cabal executable -> FilePath setupExe cabalExe=addExtension "setup" $ takeExtension cabalExe +-- | get cabal executable from cabal-dev fromCabalDevExe :: FilePath -- ^ path to cabal executable -> FilePath fromCabalDevExe cabalExe | "cabal-dev"<-dropExtension cabalExe=addExtension "cabal" $ takeExtension cabalExe fromCabalDevExe cabalExe=cabalExe +-- | drop all potential prefixes from the given string dropPrefixes :: [String] -> String -> Maybe String dropPrefixes prfxs s2=foldr (stripPrefixIfNeeded s2) Nothing prfxs +-- | stop prefix if the given string starts by it stripPrefixIfNeeded :: String -> String -> Maybe String -> Maybe String stripPrefixIfNeeded _ _ j@(Just _)=j stripPrefixIfNeeded s3 prfx _=stripPrefix prfx s3 +-- | add a note with a potential additional message addCurrent :: Maybe (BWNote, [String]) -> [BWNote] -> [BWNote] addCurrent Nothing xs=xs addCurrent (Just (n,msgs)) xs=xs++[makeNote n msgs] +-- | parse a Cabal error line cabalErrorLine :: FilePath -- ^ cabal file -> FilePath -- ^ path to cabal executable -> String -- ^ line + -> Bool -- ^ first error? -> Maybe (BWNote,[String]) -cabalErrorLine cf cabalExe l +cabalErrorLine cf cabalExe l fstErr | Just s4 <- dropPrefixes [cabalExe,setupExe cabalExe,fromCabalDevExe cabalExe] l= let s2=dropWhile isSpace $ drop 1 s4 -- drop 1 for ":" that follows file name @@ -292,7 +314,7 @@ let (loc1,_)=span (/= '\'') s2 (loc2,rest2)=span (/= ':') s2 - (loc,rest)=if (length loc1 Just $ BWNote BWError (drop (length loc2 + length ext1 + 1) el) (mkEmptySpan (validLoc cf distDir loc2) 1 1) _ -> Nothing - + +-- | get a valid path validLoc :: FilePath -- ^ the cabal file -> FilePath -- ^ the dist dir -> FilePath @@ -346,12 +370,20 @@ validLoc cf distDir f=if distDir `isPrefixOf` f then cf else f - + +-- | read an integer and return a default value if not readable readInt :: String -> Int -> Int readInt s def=let parses=reads s ::[(Int,String)] in if null parses then def else fst $ head parses + +-- | read a list and return the empty list if not readable +tryReadList :: Read a => String -> [a] +tryReadList s=let parses=reads s + in if null parses + then [] + else fst $ head parses -- | add a message to the note makeNote :: BWNote -- ^ original note @@ -374,8 +406,7 @@ -- | the cabal build info for a specific component data CabalBuildInfo=CabalBuildInfo { - cbiBuildInfo::BuildInfo -- ^ the build info - ,cbiComponentBuildInfo :: ComponentLocalBuildInfo -- ^ the component local build info + cbiTarget :: DCD.Target -- ^ the target ,cbiBuildFolder::FilePath -- ^ the folder to build that component into ,cbiIsLibrary::Bool -- ^ is the component the library ,cbiModulePaths::[(Maybe ModuleName,FilePath)] -- ^ the module name and corresponding source file for each contained Haskell module @@ -409,8 +440,8 @@ -- if a source file is in several component, get the first one getBuildInfo :: FilePath -- ^ the source file -> Maybe String -- ^ the cabal component to use, or Nothing if not specified - -> BuildWrapper (OpResult (Maybe (LocalBuildInfo,CabalBuildInfo))) -getBuildInfo fp mccn=do + -> BuildWrapper (OpResult (Maybe ([DCD.Target],CabalBuildInfo))) +getBuildInfo fp mccn= case mccn of Nothing -> do (mmr,bwns)<-go getReferencedFiles Nothing @@ -443,80 +474,127 @@ getComp (Just ccn) fps= return $ filter (\cbi->cabalComponentName (cbiComponent cbi) == ccn) fps +-- | set the GHC options on targets +setOptions :: FilePath -> [DCD.Target] -> IO [DCD.Target] +setOptions dist_dir tgs=do + let setup_config = DSC.localBuildInfoFile dist_dir + cv<-DCD.getCabalVersion setup_config + let optStr=if cv>=Version [1,15,0] [] + then " let opts=renderGhcOptions ((fst $ head $ readP_to_S parseVersion \""++VERSION_ghc++"\") :: Version) $ componentGhcOptions V.silent lbi{withOptimization=NoOptimisation} b clbi fp" + else " let opts=ghcOptions lbi{withOptimization=NoOptimisation} b clbi fp" + let withStr=if cv>=Version [1,17,0] [] + then "withAllComponentsInBuildOrder" + else "withComponentsLBI" + let bd=dist_dir "build" + let fmp=foldr (\t m->DM.insert (DCD.targetName t) (getBuildDir bd t) m) DM.empty tgs + let src= unlines [ + "module DynamicCabalQuery where" + ,"import Distribution.PackageDescription" + ,"import Distribution.Simple.LocalBuildInfo" + ,"import Data.IORef" + ,"import qualified Data.Map as DM" + ,"import qualified Distribution.Verbosity as V" + ,"import Data.Version (parseVersion)" + ,"import Text.ParserCombinators.ReadP(readP_to_S)" + ,"import Distribution.Simple.Program.GHC" + ,"import Distribution.Simple.GHC" + ,"import Distribution.Version" + ,"import Control.Monad" + ,"import Distribution.Simple.Compiler(OptimisationLevel(..))" + ,"import Data.Maybe" + ,"" + ,"result :: IO (DM.Map String [String])" + ,"result=do" + ,"lbi<-liftM (read . Prelude.unlines . drop 1 . lines) $ Prelude.readFile "++show setup_config + ,"let pkg=localPkgDescr lbi" + ,"r<-newIORef DM.empty" + ,"let fmp=DM."++ show fmp + ,withStr++" pkg lbi (\\c clbi->do" + ," let b=componentBuildInfo c" + ," let n=foldComponent (const \"\") exeName testName benchmarkName c" + ," let fp=fromJust $ DM.lookup n fmp" + , optStr + ," modifyIORef r (DM.insert n opts)" + ," return ()" + ," )" + ,"readIORef r" ] + -- print src + m::DM.Map String [String]<-liftIO $ DCD.runRawQuery src setup_config + return $ map (set m)tgs + where + set mOpts t=case DM.lookup (DCD.targetName t) mOpts of + Just opts->t{DCD.ghcOptions=opts} + _->t + + -- | get GHC options for a file -fileGhcOptions :: (LocalBuildInfo,CabalBuildInfo) -- ^ the cabal info +fileGhcOptions :: CabalBuildInfo -- ^ the cabal info -> BuildWrapper [String] -- ^ the module name and the options to pass GHC -fileGhcOptions (lbi,CabalBuildInfo bi clbi fp isLib _ _)=do +fileGhcOptions (CabalBuildInfo tgt _ isLib _ _)=do dist_dir<-getDistDir let inplace=dist_dir "package.conf.inplace" inplaceExist<-liftIO $ doesFileExist inplace -#if MIN_VERSION_Cabal(1,15,0) - v<-cabalV - let opts l b c f=renderGhcOptions ((fst $ head $ readP_to_S parseVersion VERSION_ghc) :: Version) $ componentGhcOptions v l b c f -#else - let opts=ghcOptions -#endif + n<-getPackageName let pkg | isLib = - ["-package-name", display $ packageId $ localPkgDescr lbi] + ["-package-name",n] | inplaceExist = ["-package-conf", inplace] | otherwise = [] - return (pkg ++ opts (lbi{withOptimization=NoOptimisation}) bi clbi fp) - + return (pkg ++ DCD.ghcOptions tgt) - -- | get CPP options for a file fileCppOptions :: CabalBuildInfo -- ^ the cabal info -> [String] -- ^ the list of CPP options -fileCppOptions cbi=cppOptions $ cbiBuildInfo cbi +fileCppOptions cbi=DCD.cppOptions $ cbiTarget cbi -- | get the cabal extensions cabalExtensions :: CabalBuildInfo -- ^ the cabal info -> (ModuleName,[String]) -- ^ the module name and cabal extensions -cabalExtensions CabalBuildInfo{cbiBuildInfo=bi,cbiModulePaths=ls}=(fromJust $ fst $ head ls,map show (otherExtensions bi ++ defaultExtensions bi ++ oldExtensions bi)) +cabalExtensions CabalBuildInfo{cbiTarget=bi,cbiModulePaths=ls}=(fromJust $ fst $ head ls,DCD.extensions bi) -- | get the source directory from a build info -getSourceDirs :: BuildInfo -- ^ the build info +getSourceDirs :: DCD.Target -- ^ the build info -> [FilePath] -- ^ the source paths, guaranteed non null getSourceDirs bi=let - hsd=hsSourceDirs bi + hsd=DCD.sourceDirs bi in case hsd of [] -> ["."] _ -> hsd -- | get all components, referencing all the files found in the source folders -getAllFiles :: LocalBuildInfo -- ^ the build info +getAllFiles :: [DCD.Target] -- ^ the build info -> BuildWrapper [CabalBuildInfo] -getAllFiles lbi= do - let pd=localPkgDescr lbi - let libs=maybe [] extractFromLib $ library pd - let exes=map extractFromExe $ executables pd - let tests=map extractFromTest $ testSuites pd - cbis<-mapM (\(a,b,c,isLib,d,cc)->do +getAllFiles tgs= do + dist_dir<-getDistDir + let bd=dist_dir "build" + let libs=map (extractFromLib bd) $ filter DCD.isLibrary tgs + let exes=map (extractFromExe bd) $ filter DCD.isExecutable tgs + let tests=map (extractFromTest bd) $ filter DCD.isTest tgs + let benches=map (extractFromBench bd) $ filter DCD.isBench tgs + cbis<-mapM (\(a,c,isLib,d,cc)->do mf<-copyAll d - return (CabalBuildInfo a b c isLib mf cc)) (libs ++ exes ++ tests) - cbis2<-getReferencedFiles lbi + return (CabalBuildInfo a c isLib mf cc)) (libs ++ exes ++ tests ++benches) + cbis2<-getReferencedFiles tgs return $ zipWith (\c1@CabalBuildInfo{cbiModulePaths=cb1} CabalBuildInfo{cbiModulePaths=cb2}->c1{cbiModulePaths=nubOrd $ cb1++cb2}) cbis cbis2 -- return cbis where - extractFromLib :: Library -> [(BuildInfo,ComponentLocalBuildInfo,FilePath,Bool,[FilePath],CabalComponent)] - extractFromLib l=let - lib=libBuildInfo l - in [(lib, fromJustDebug "extractFromLibAll" $ libraryConfig lbi,buildDir lbi, True, getSourceDirs lib,cabalComponentFromLibrary l)] - extractFromExe :: Executable -> (BuildInfo,ComponentLocalBuildInfo,FilePath,Bool,[FilePath],CabalComponent) - extractFromExe e@Executable{exeName=exeName'}=let - ebi=buildInfo e - targetDir = buildDir lbi exeName' - exeDir = targetDir (exeName' ++ "-tmp") - hsd=getSourceDirs ebi - in (ebi,fromJustDebug "extractFromExeAll" $ lookup exeName' $ executableConfigs lbi,exeDir,False, hsd,cabalComponentFromExecutable e) - extractFromTest :: TestSuite -> (BuildInfo,ComponentLocalBuildInfo,FilePath,Bool,[FilePath],CabalComponent) - extractFromTest t@TestSuite {testName=testName'} =let - tbi=testBuildInfo t - targetDir = buildDir lbi testName' - testDir = targetDir (testName' ++ "-tmp") - hsd=getSourceDirs tbi - in (tbi,fromJustDebug "extractFromTestAll" $ lookup testName' $ testSuiteConfigs lbi,testDir,False,hsd,cabalComponentFromTestSuite t) + extractFromLib :: FilePath-> DCD.Target -> (DCD.Target,FilePath,Bool,[FilePath],CabalComponent) + extractFromLib bd l=(l,bd, True, getSourceDirs l,cabalComponentFromLibrary l) + extractFromExe :: FilePath-> DCD.Target -> (DCD.Target,FilePath,Bool,[FilePath],CabalComponent) + extractFromExe bd e=let + exeDir = getBuildDir bd e + hsd=getSourceDirs e + in (e,exeDir,False, hsd,cabalComponentFromExecutable e) + extractFromTest :: FilePath-> DCD.Target -> (DCD.Target,FilePath,Bool,[FilePath],CabalComponent) + extractFromTest bd t=let + testDir = getBuildDir bd t + hsd=getSourceDirs t + in (t,testDir,False,hsd,cabalComponentFromTestSuite t) + extractFromBench :: FilePath-> DCD.Target -> (DCD.Target,FilePath,Bool,[FilePath],CabalComponent) + extractFromBench bd t=let + benchDir = getBuildDir bd t + hsd=getSourceDirs t + in (t,benchDir,False,hsd,cabalComponentFromBenchmark t) copyAll :: [FilePath] -> BuildWrapper [(Maybe ModuleName,FilePath)] copyAll fps= do allF<-mapM copyAll' fps @@ -535,49 +613,67 @@ let notMyself=filter (\x->not $ any (`isInfixOf` x) [cabalDevDist, cabalDist, tf]) allF return $ map (\f->(simpleParse $ fileToModule $ makeRelative fullFP f,makeRelative dir f)) notMyself -- return $ map (\(x,y)->(fromJust x,y)) $ filter (isJust . fst) $ map (\f->(simpleParse $ fileToModule $ makeRelative fullFP f,makeRelative dir f)) notMyself + +-- | get build dir for a target +getBuildDir :: FilePath -> DCD.Target -> FilePath +getBuildDir bd t=case DCD.info t of + DCD.Library _-> bd + DCD.Executable n _->bd n (n ++ "-tmp") + DCD.TestSuite n _->bd n (n ++ "-tmp") + DCD.BenchSuite n _->bd n (n ++ "-tmp") -- | get all components, referencing only the files explicitely indicated in the cabal file -getReferencedFiles :: LocalBuildInfo -> BuildWrapper [CabalBuildInfo] -getReferencedFiles lbi= do - let pd=localPkgDescr lbi - let libs=maybe [] extractFromLib $ library pd - let exes=map extractFromExe $ executables pd - let tests=map extractFromTest $ testSuites pd - let cbis=libs ++ exes ++ tests +getReferencedFiles :: [DCD.Target] -> BuildWrapper [CabalBuildInfo] +getReferencedFiles tgs= do + dist_dir<-getDistDir + let bd=dist_dir "build" + let libs=map (extractFromLib bd) $ filter DCD.isLibrary tgs + let exes=map (extractFromExe bd) $ filter DCD.isExecutable tgs + let tests=map (extractFromTest bd) $ filter DCD.isTest tgs + let benches=map (extractFromBench bd) $ filter DCD.isBench tgs + let cbis=libs ++ exes ++ tests ++ benches mapM (\c1@CabalBuildInfo{cbiModulePaths=cb1}->do cb2<-filterM (\(_,f)->do fs<-getFullSrc f liftIO $ doesFileExist fs) cb1 return c1{cbiModulePaths=cb2}) cbis where - extractFromLib :: Library -> [CabalBuildInfo] - extractFromLib l=let - lib=libBuildInfo l - modules=PD.exposedModules l ++ otherModules lib - in [CabalBuildInfo lib (fromJustDebug "extractFromLibRef" $ libraryConfig lbi) - (buildDir lbi) True (copyModules modules (getSourceDirs lib)) (cabalComponentFromLibrary l)] - extractFromExe :: Executable ->CabalBuildInfo - extractFromExe e@Executable{exeName=exeName'}=let - ebi=buildInfo e - targetDir = buildDir lbi exeName' - exeDir = targetDir (exeName' ++ "-tmp") - modules= (otherModules ebi) - hsd=getSourceDirs ebi - in CabalBuildInfo ebi (fromJustDebug "extractFromExeRef" $ lookup exeName' $ executableConfigs lbi) exeDir False (copyMain (modulePath e) hsd ++ copyModules modules hsd) (cabalComponentFromExecutable e) - extractFromTest :: TestSuite -> CabalBuildInfo - extractFromTest t@TestSuite {testName=testName'} =let - tbi=testBuildInfo t - targetDir = buildDir lbi testName' - testDir = targetDir (testName' ++ "-tmp") - modules= (otherModules tbi ) - hsd=getSourceDirs tbi - extras=case testInterface t of - (TestSuiteExeV10 _ mp) -> copyMain mp hsd - (TestSuiteLibV09 _ mn) -> copyModules [mn] hsd + extractFromLib :: FilePath -> DCD.Target -> CabalBuildInfo + extractFromLib bd l=let + DCD.Library mods=DCD.info l + modules=mods ++ DCD.otherModules l + in CabalBuildInfo l + bd True (copyModules modules (getSourceDirs l)) (cabalComponentFromLibrary l) + extractFromExe :: FilePath -> DCD.Target ->CabalBuildInfo + extractFromExe bd e=let + DCD.Executable _ mp=DCD.info e + exeDir = getBuildDir bd e + modules= DCD.otherModules e + hsd=getSourceDirs e + in CabalBuildInfo e exeDir False (copyMain mp hsd ++ copyModules modules hsd) (cabalComponentFromExecutable e) + extractFromTest :: FilePath -> DCD.Target -> CabalBuildInfo + extractFromTest bd t =let + DCD.TestSuite _ mmp=DCD.info t + testDir = getBuildDir bd t + modules= DCD.otherModules t + hsd=getSourceDirs t + extras=case mmp of + Just mp -> copyMain mp hsd _ -> [] - in CabalBuildInfo tbi (fromJustDebug ("extractFromTestRef:"++testName' ++ show (testSuiteConfigs lbi)) $ lookup testName' $ testSuiteConfigs lbi) testDir False (extras ++ copyModules modules hsd) (cabalComponentFromTestSuite t) - copyModules :: [ModuleName] -> [FilePath] -> [(Maybe ModuleName,FilePath)] - copyModules mods=copyFiles (concatMap (\m->[toFilePath m <.> "hs", toFilePath m <.> "lhs"]) mods) + in CabalBuildInfo t testDir False (extras ++ copyModules modules hsd) (cabalComponentFromTestSuite t) + extractFromBench :: FilePath -> DCD.Target -> CabalBuildInfo + extractFromBench bd t =let + DCD.BenchSuite _ mmp=DCD.info t + benchDir = getBuildDir bd t + modules= DCD.otherModules t + hsd=getSourceDirs t + extras=case mmp of + Just mp -> copyMain mp hsd + _ -> [] + in CabalBuildInfo t benchDir False (extras ++ copyModules modules hsd) (cabalComponentFromBenchmark t) + + copyModules :: [String] -> [FilePath] -> [(Maybe ModuleName,FilePath)] + copyModules mods=copyFiles (concatMap (\m->[toFilePath m <.> "hs", toFilePath m <.> "lhs"]) $ mapMaybe stringToModuleName mods) copyFiles :: [FilePath] -> [FilePath] -> [(Maybe ModuleName,FilePath)] copyFiles mods dirs=let rmods=filter (isJust . snd ) $ map (\x->(x,simpleParse $ fileToModule x)) mods @@ -585,7 +681,7 @@ copyMain :: FilePath ->[FilePath] -> [(Maybe ModuleName,FilePath)] copyMain fs = map (\ d -> (Just $ fromString "Main", d fs)) - +-- | parse a string into a module name stringToModuleName :: String -> Maybe ModuleName stringToModuleName=simpleParse @@ -596,14 +692,14 @@ -- | get all components in the Cabal file cabalComponents :: BuildWrapper (OpResult [CabalComponent]) cabalComponents = do - (rs,ns)<-withCabal Source (return . cabalComponentsFromDescription . localPkgDescr) + (rs,ns)<-withCabal Source (return . cabalComponentsFromDescription) return (fromMaybe [] rs,ns) -- | get all the dependencies in the cabal file cabalDependencies :: Maybe FilePath -- ^ the path to the cabal-dev sandbox if any -> BuildWrapper (OpResult [(FilePath,[CabalPackage])]) -- ^ the result is an array of tuples: the path to the package database, the list of packages in that db that the Cabal file references cabalDependencies msandbox= do - (rs,ns)<-withCabal Source (\lbi-> liftIO $ + (rs,ns)<-withCabal Source (\tgs-> liftIO $ ghandle (\ (e :: IOError) -> do print e @@ -611,17 +707,17 @@ $ do pkgs <- liftIO $ getPkgInfos msandbox - --let m=cabalComponentsDependencies (localPkgDescr lbi) - --print m + --let m=cabalComponentsDependencies tgs + --print msandbox --let deps=PD.buildDepends (localPkgDescr lbi) --print deps --liftIO $ mapM_ (\d->print $ (show d) ++ (show $ DM.lookup (show $ simplifyDependency d) m)) deps - return $ dependencies (localPkgDescr lbi) pkgs + return $ dependencies tgs pkgs ) return (fromMaybe [] rs,ns) -- | get all dependencies from the package description and the list of installed packages -dependencies :: PD.PackageDescription -- ^ the cabal description +dependencies :: [DCD.Target] -- ^ the cabal description -> [(FilePath,[InstalledPackageInfo])] -- ^ the installed packages, by package database location -> [(FilePath,[CabalPackage])] -- ^ the referenced packages, by package database location dependencies pd pkgs=let @@ -643,7 +739,7 @@ Just l->sortBy (flip (comparing (pkgVersion . sourcePackageId . snd))) ((fp,i):l) in DM.insert key newvals dm ) m ipis - getDep :: DM.Map CabalComponent [Dependency] -> [(FilePath,InstalledPackageInfo)] -> [(FilePath,CabalPackage)] -> [(FilePath,CabalPackage)] + getDep :: DM.Map CabalComponent [(String, Maybe Version)] -> [(FilePath,InstalledPackageInfo)] -> [(FilePath,CabalPackage)] -> [(FilePath,CabalPackage)] getDep _ [] acc= acc getDep allC ((fp,InstalledPackageInfo{sourcePackageId=i,exposed=e,IPI.exposedModules=ems,IPI.hiddenModules=hms}):xs) acc= let (s,m)=DM.foldrWithKey (splitMatching i) (DS.empty,DM.empty) allC @@ -654,7 +750,7 @@ mns=map display (ems++hms) in getDep m xs ((fp,CabalPackage (display $ pkgName i) (display $ pkgVersion i) e cps mns): acc) -- build CabalPackage structure splitMatching pkgId comp deps (s,m)=let - (ds,_)=partition (\(Dependency n v)->(pkgName pkgId == n) && withinRange (pkgVersion pkgId) v) deps + (ds,_)=partition (\(n,mv)->(pkgName pkgId == PackageName n) && isJust mv && pkgVersion pkgId == fromJust mv) deps s'=if null ds then s else DS.insert comp s @@ -662,33 +758,53 @@ in (s',m') -- | get all components from the package description -cabalComponentsFromDescription :: PD.PackageDescription -- ^ the package description +cabalComponentsFromDescription :: [DCD.Target] -- ^ the package description -> [CabalComponent] -cabalComponentsFromDescription pd= [cabalComponentFromLibrary $ fromJust (PD.library pd) - | isJust (PD.library pd)] ++ - map cabalComponentFromExecutable (PD.executables pd) ++ - map cabalComponentFromTestSuite (PD.testSuites pd) - -cabalComponentsDependencies :: PD.PackageDescription -- ^ the package description - -> DM.Map CabalComponent [Dependency] -cabalComponentsDependencies pd=let - mLib=case PD.library pd of - Nothing -> DM.empty - Just lib->DM.singleton (cabalComponentFromLibrary lib) (PD.targetBuildDepends $ PD.libBuildInfo lib) - mExe=DM.fromList $ map (\e->((cabalComponentFromExecutable e),(PD.targetBuildDepends $ PD.buildInfo e))) (PD.executables pd) - mTs=DM.fromList $ map (\ts->((cabalComponentFromTestSuite ts),(PD.targetBuildDepends $ PD.testBuildInfo ts))) (PD.testSuites pd) - in DM.unionWith (++) mTs $ DM.unionWith (++) mLib mExe +cabalComponentsFromDescription = map cabalComponentFromTarget + +-- | get dependencies for all stanzas +cabalComponentsDependencies :: [DCD.Target] -- ^ the package description + -> DM.Map CabalComponent [(String, Maybe Version)] +cabalComponentsDependencies =foldr f DM.empty + where + f tg =DM.insert (cabalComponentFromTarget tg) (DCD.dependencies tg) +-- let +-- mLib=case PD.library pd of +-- Nothing -> DM.empty +-- Just lib->DM.singleton (cabalComponentFromLibrary lib) (PD.targetBuildDepends $ PD.libBuildInfo lib) +-- mExe=DM.fromList $ map (\e->((cabalComponentFromExecutable e),(PD.targetBuildDepends $ PD.buildInfo e))) (PD.executables pd) +-- mTs=DM.fromList $ map (\ts->((cabalComponentFromTestSuite ts),(PD.targetBuildDepends $ PD.testBuildInfo ts))) (PD.testSuites pd) +-- in DM.unionWith (++) mTs $ DM.unionWith (++) mLib mExe -- where mapDep cc bi=DM.fromList $ map (\x->(cc)) (PD.targetBuildDepends bi) - - -cabalComponentFromLibrary :: Library -> CabalComponent -cabalComponentFromLibrary =CCLibrary . PD.buildable . PD.libBuildInfo +-- | convert a dynamic cabla target into a CabalComponent +cabalComponentFromTarget :: DCD.Target -> CabalComponent +cabalComponentFromTarget t=let + b=DCD.buildable t + in case DCD.info t of + DCD.Library _-> CCLibrary b + DCD.Executable n _->CCExecutable n b + DCD.TestSuite n _->CCTestSuite n b + DCD.BenchSuite n _->CCBenchmark n b -cabalComponentFromExecutable :: Executable -> CabalComponent -cabalComponentFromExecutable e =CCExecutable (PD.exeName e) (PD.buildable $ PD.buildInfo e) +-- | transform a library target into a CabalComponent +cabalComponentFromLibrary :: DCD.Target -> CabalComponent +cabalComponentFromLibrary =CCLibrary . DCD.buildable -cabalComponentFromTestSuite :: TestSuite -> CabalComponent -cabalComponentFromTestSuite ts=CCTestSuite (PD.testName ts) (PD.buildable $ PD.testBuildInfo ts) +-- | transform an executable target into a CabalComponent +cabalComponentFromExecutable :: DCD.Target -> CabalComponent +cabalComponentFromExecutable e =let + DCD.Executable exeName' _=DCD.info e + in CCExecutable exeName' (DCD.buildable e) +-- | transform a test suite target into a CabalComponent +cabalComponentFromTestSuite :: DCD.Target -> CabalComponent +cabalComponentFromTestSuite ts=let + DCD.TestSuite testName' _=DCD.info ts + in CCTestSuite testName' (DCD.buildable ts) +-- | transform a benchmark target into a CabalComponent +cabalComponentFromBenchmark :: DCD.Target -> CabalComponent +cabalComponentFromBenchmark ts=let + DCD.BenchSuite benchName' _=DCD.info ts + in CCBenchmark benchName' (DCD.buildable ts) 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 @@ -13,9 +13,9 @@ module Language.Haskell.BuildWrapper.GHC where import Language.Haskell.BuildWrapper.Base hiding (Target,ImportExportType(..)) import Language.Haskell.BuildWrapper.GHCStorage -import Language.Haskell.BuildWrapper.Src import Prelude hiding (readFile, writeFile) +import Control.Applicative ((<$>)) import Data.Char import Data.Generics hiding (Fixity, typeOf, empty) import Data.Maybe @@ -34,19 +34,30 @@ import qualified Data.ByteString.Lazy.Char8 as BSC import DynFlags +import ErrUtils + ( ErrMsg(..), WarnMsg, mkPlainErrMsg,Messages,ErrorMessages,WarningMessages #if __GLASGOW_HASKELL__ > 704 -import ErrUtils ( ErrMsg(..), WarnMsg, mkPlainErrMsg,Messages,ErrorMessages,WarningMessages,MsgDoc) + , MsgDoc #else -import ErrUtils ( ErrMsg(..), WarnMsg, mkPlainErrMsg,Messages,ErrorMessages,WarningMessages,Message) + , Message #endif + ) import GHC import GHC.Paths ( libdir ) -import HscTypes ( srcErrorMessages, SourceError, GhcApiError) +import HscTypes (srcErrorMessages, SourceError, GhcApiError, extendInteractiveContext, hsc_IC) import Outputable import FastString (FastString,unpackFS,concatFS,fsLit,mkFastString, lengthFS) import Lexer hiding (loc) import Bag +import Linker +import RtClosureInspect +import GhcMonad +import Id +import Var hiding (varName) +import UniqSupply +import PprTyThing + #if __GLASGOW_HASKELL__ >= 702 import SrcLoc #endif @@ -58,31 +69,27 @@ import System.FilePath import qualified MonadUtils as GMU -import Name (isTyVarName,isDataConName,isVarName,isTyConName) -import Var (varType, Var) -import PprTyThing (pprTypeForUser) -import Control.Monad (when, liftM, unless) +import Name (isTyVarName,isDataConName,isVarName,isTyConName, mkInternalName) +import Control.Monad (when, liftM, liftM2) import qualified Data.Vector as V (foldr) import Module (moduleNameFS) -- import System.Time (getClockTime, diffClockTimes, timeDiffToString) -import System.IO (hFlush, stdout) +import System.IO (hFlush, stdout, stderr) import System.Directory (getModificationTime) #if __GLASGOW_HASKELL__ < 706 import System.Time (ClockTime(TOD)) -import Unsafe.Coerce (unsafeCoerce) - #else import Data.Time.Clock (UTCTime(UTCTime)) import Data.Time.Calendar (Day(ModifiedJulianDay)) #endif import Control.Exception (SomeException) -import Debugger (showTerm) import Exception (gtry) -import qualified CoreUtils as CoreUtils (exprType) -import Control.Applicative ((<$>)) -import Desugar (deSugarExpr) -import TcRnTypes (tcg_rdr_env, tcg_type_env) +import Control.Arrow ((&&&)) +import Unsafe.Coerce (unsafeCoerce) +import OccName (mkOccName, varName) + +-- | a function taking the file name and typechecked module as parameters type GHCApplyFunction a=FilePath -> TypecheckedModule -> Ghc a -- | get the GHC typechecked AST @@ -103,7 +110,7 @@ -> [String] -- ^ the GHC options -> IO (Maybe a) withAST f fp base_dir modul options= do - (a,_)<-withASTNotes (\_ ->f) id base_dir (SingleFile fp modul) options + (a,_)<-withASTNotes (const f) id base_dir (SingleFile fp modul) options return $ listToMaybe a -- | perform an action on the GHC JSON AST @@ -134,27 +141,9 @@ -> LoadContents -- ^ what to load -> [String] -- ^ the GHC options -> IO (OpResult [a]) -withASTNotes f ff base_dir contents options=initGHC (ghcWithASTNotes f ff base_dir contents True) options +withASTNotes f ff base_dir contents =initGHC (ghcWithASTNotes f ff base_dir contents True) --- do --- -- http://hackage.haskell.org/trac/ghc/ticket/7380#comment:1 : -O2 is removed from the options --- let cleaned=filter (not . List.isInfixOf "-O") options --- let lflags=map noLoc cleaned --- -- print cleaned --- (_leftovers, _) <- parseStaticFlags lflags --- runGhc (Just libdir) $ do --- flg <- getSessionDynFlags --- (flg', _, _) <- parseDynamicFlags flg _leftovers --- GHC.defaultCleanupHandler flg' $ do --- -- our options here --- -- if we use OneShot, we need the other modules to be built --- -- so we can't use hscTarget = HscNothing --- -- and it takes a while to actually generate the o and hi files for big modules --- -- if we use CompManager, it's slower for modules with lots of dependencies but we can keep hscTarget= HscNothing which makes it better for bigger modules --- -- we use target interpreted so that it works with TemplateHaskell --- setSessionDynFlags flg' {hscTarget = HscInterpreted, ghcLink = NoLink , ghcMode = CompManager} --- ghcWithASTNotes f ff base_dir contents - +-- | init GHC session initGHC :: Ghc a -> [String] -- ^ the GHC options -> IO a @@ -174,9 +163,11 @@ -- and it takes a while to actually generate the o and hi files for big modules -- if we use CompManager, it's slower for modules with lots of dependencies but we can keep hscTarget= HscNothing which makes it better for bigger modules -- we use target interpreted so that it works with TemplateHaskell - setSessionDynFlags flg' {hscTarget = HscInterpreted, ghcLink = NoLink , ghcMode = CompManager} - f - + -- LinkInMemory needed for evaluation after reload + setSessionDynFlags flg' {hscTarget = HscInterpreted, ghcLink = LinkInMemory , ghcMode = CompManager} + f + +-- | run a GHC action and get results with notes ghcWithASTNotes :: GHCApplyFunction a -- ^ the final action to perform on the result -> (FilePath -> FilePath) -- ^ transform given file path to find bwinfo path @@ -219,9 +210,9 @@ -- GMU.liftIO $ print fps a<-case sf of Failed-> return [] - _ ->fmap catMaybes $ mapM (\(fp,m)->(do + _ -> catMaybes <$> mapM (\(fp,m)->(do modSum <- getModSummary $ mkModuleName m - fmap Just $ workOnResult f fp modSum) + Just <$> workOnResult f fp modSum) `gcatch` (\(se :: SourceError) -> do dumpError ref contents se return Nothing) @@ -238,7 +229,7 @@ df <- getSessionDynFlags return (a,List.nub $ notes ++ reverse (ghcMessagesToNotes df base_dir (warns, emptyBag))) #else - return $ (a,List.nub $ notes) + return (a,List.nub notes) #endif where processError :: LoadContents -> String -> Bool @@ -264,6 +255,7 @@ d <- desugarModule t -- to get warnings l <- loadModule d --c3<-GMU.liftIO getClockTime + -- GMU.liftIO $ putStrLn "Set context..." #if __GLASGOW_HASKELL__ < 704 setContext [ms_mod modSum] [] #else @@ -274,10 +266,13 @@ #endif #endif let fullfp=ff fp - opts<-getSessionDynFlags + -- use the dyn flags including pragmas from module, etc. + let opts=ms_hspp_opts modSum + setSessionDynFlags opts env <- getSession -- GMU.liftIO $ putStrLn ("writing " ++ fullfp) GMU.liftIO $ storeGHCInfo opts env fullfp (dm_typechecked_module l) + -- GMU.liftIO $ putStrLn ("written " ++ fullfp) --GMU.liftIO $ putStrLn ("parse, typecheck load: " ++ (timeDiffToString $ diffClockTimes c3 c2)) f2 fp $ dm_typechecked_module l @@ -367,40 +362,37 @@ (x:_)->(Just x,ns) _->(Nothing, ns) --- | get all names in scope, packaged in NameDefs +-- | get all names in scope, packaged in NameDefs, and keep running a loop listening to commands getGhcNameDefsInScopeLongRunning :: FilePath -- ^ source path -> FilePath -- ^ base directory -> String -- ^ module name -> [String] -- ^ build options -> IO () -getGhcNameDefsInScopeLongRunning fp base_dir modul options=do +getGhcNameDefsInScopeLongRunning fp base_dir modul = #if __GLASGOW_HASKELL__ < 706 - initGHC (go (TOD 0 0)) options + initGHC (go (TOD 0 0)) +#else + initGHC (go (UTCTime (ModifiedJulianDay 0) 0)) +#endif where - go :: - ClockTime - -> Ghc () +#if __GLASGOW_HASKELL__ < 706 + go :: ClockTime -> Ghc () +#else + go :: UTCTime -> Ghc () +#endif go t1 = do - t2<- GMU.liftIO $ getModificationTime fp let hasLoaded=case t1 of +#if __GLASGOW_HASKELL__ < 706 TOD 0 _ -> False - _ -> True #else - initGHC (go (UTCTime (ModifiedJulianDay 0) 0)) options - where - go :: - UTCTime - -> Ghc () - go t1 = do - t2<- GMU.liftIO $ getModificationTime fp - let hasLoaded=case t1 of UTCTime (ModifiedJulianDay 0) _ -> False - _ -> True #endif - + _ -> True + t2<- GMU.liftIO $ getModificationTime fp (ns1,add2)<-if hasLoaded && t2==t1 then -- modification time is only precise to the second in GHC 7.6 or above, see http://hackage.haskell.org/trac/ghc/ticket/7473 (do + -- GMU.liftIO $ print "reloading" removeTarget (TargetFile fp Nothing) load LoadAllTargets return ([],True) @@ -426,29 +418,17 @@ "q"->return () -- eval an expression 'e':' ':expr->do - s<-handleSourceError (return . show) - (do - rr<- runStmt expr RunToCompletion - case rr of - RunOk ns->do - df<-getSessionDynFlags - ls<-mapM (\n->do - mty<-lookupName n - case mty of - Just (AnId aid)->do - t<-gtry $ GHC.obtainTermFromId 100 False aid - case t of - Right term -> showTerm term - Left exn -> return (text "*** Exception:" <+> - text (show (exn :: SomeException))) - _->return empty - ) ns - return $ showSDDump df $ vcat ls - RunException e ->return $ show e - _->return "") - GMU.liftIO $ BSC.putStrLn $ BS.append "build-wrapper-json:" $ encode s - GMU.liftIO $ hFlush stdout - r1 t2 + s<-getEvalResults expr + GMU.liftIO $ do + let js=encode (s,[]::[BWNote]) + -- ensure streams are flushed, and prefix and start of the line + hFlush stdout + hFlush stderr + BSC.putStrLn "" + BSC.putStrLn $ BS.append "build-wrapper-json:" js + hFlush stdout + r1 t2 + -- token types "t"->do input<- GMU.liftIO $ readFile fp ett<-tokenTypesArbitrary' fp input (".lhs" == takeExtension fp) @@ -459,6 +439,7 @@ BSC.putStrLn $ BS.append "build-wrapper-json:" $ encode ret hFlush stdout r1 t2 + -- thing at point 'p':xs->do GMU.liftIO $ do let (line,col)=read xs @@ -471,9 +452,107 @@ _-> Nothing BSC.putStrLn $ BS.append "build-wrapper-json:" $ encode (mm,[]::[BWNote]) hFlush stdout - r1 t2 + r1 t2 + -- locals + 'l':xs->do + GMU.liftIO $ do + let (sline,scol,eline,ecol)=read xs + mv<-readGHCInfo fp + let mm=case mv of + Just v->let + cont=contains sline (scionColToGhcCol scol) eline (scionColToGhcCol ecol) + isVar=isGHCType "Var" + mf=findAllInJSON (\x->cont x && isVar x) v + in mapMaybe (findInJSONData . Just) mf + _-> [] + BSC.putStrLn $ BS.append "build-wrapper-json:" $ encode (mm,[]::[BWNote]) + hFlush stdout + r1 t2 _ ->go t2 - + + +-- | evaluate expression in the GHC monad +getEvalResults :: forall (m :: * -> *). + GhcMonad m => + String -> m [EvalResult] +getEvalResults expr=handleSourceError (\e->return [EvalResult Nothing Nothing (Just $ show e)]) + (do + df<-getSessionDynFlags + -- GMU.liftIO $ print $ xopt Opt_OverloadedStrings df + do + -- setSessionDynFlags $ xopt_set df Opt_OverloadedStrings + rr<- runStmt expr RunToCompletion + case rr of + RunOk ns->do + + let q=(qualName &&& qualModule) defaultUserStyle + mapM (\n->do + mty<-lookupName n + case mty of + Just (AnId aid)->do + let pprTyp = (pprTypeForUser True . idType) aid + t<-gtry $ GHC.obtainTermFromId maxBound True aid + evalDoc<-case t of + Right term -> showTerm term + Left exn -> return (text "*** Exception:" <+> + text (show (exn :: SomeException))) + return $ EvalResult (Just $ showSDUser q df pprTyp) (Just $ showSDUser neverQualify df evalDoc) Nothing + _->return $ EvalResult Nothing Nothing Nothing + ) ns + RunException e ->return [EvalResult Nothing Nothing (Just $ show e)] + _->return [] + `gfinally` + setSessionDynFlags df) + where + -- A custom Term printer to enable the use of Show instances + -- this is a copy of the GHC Debugger.hs code + -- except that we force evaluation and always use show + showTerm :: GhcMonad m => Term -> m SDoc + showTerm = + cPprTerm (liftM2 (++) (const [cPprShowable]) cPprTermBase) + cPprShowable prec Term{ty=ty, val=val} = + do + hsc_env <- getSession + dflags <- GHC.getSessionDynFlags + do + (new_env, bname) <- bindToFreshName hsc_env ty "showme" + setSession new_env + let exprS = "show " ++ showPpr dflags bname + txt_ <- withExtendedLinkEnv [(bname, val)] + (GHC.compileExpr exprS) + let myprec = 10 -- application precedence. TODO Infix constructors + let txt = unsafeCoerce txt_ + return $ if not (null txt) + then Just $ cparen (prec >= myprec && needsParens txt) + (text txt) + else Nothing + `gfinally` + setSession hsc_env + cPprShowable prec NewtypeWrap{ty=new_ty,wrapped_term=t} = + cPprShowable prec t{ty=new_ty} + cPprShowable _ _ = return Nothing + + needsParens ('"':_) = False -- some simple heuristics to see whether parens + -- are redundant in an arbitrary Show output + needsParens ('(':_) = False + needsParens txt = ' ' `elem` txt + + bindToFreshName hsc_env ty userName = do + name <- newGrimName userName + let mkid = AnId $ mkVanillaGlobal name ty + new_ic = extendInteractiveContext (hsc_IC hsc_env) [mkid] + return (hsc_env {hsc_IC = new_ic }, name) + + -- Create new uniques and give them sequentially numbered names + newGrimName :: GMU.MonadIO m => String -> m Name + newGrimName userName = do + us <- liftIO $ mkSplitUniqSupply 'b' + let unique = uniqFromSupply us + occname = mkOccName varName userName + name = mkInternalName unique occname noSrcSpan + return name + +-- | convert a Name int a NameDef name2nd :: GhcMonad m=> DynFlags -> Name -> m NameDef name2nd df n=do m<- getInfo n @@ -494,6 +573,8 @@ ty2t (ADataCon dc)=Just $ T.pack $ showSD False df $ pprTypeForUser True $ dataConUserType dc ty2t _ = Nothing + + -- | get the "thing" at a particular point (line/column) in the source -- this is using the saved JSON info if available getThingAtPointJSON :: Int -- ^ line @@ -532,7 +613,17 @@ return $ mapMaybe (findInJSONData . Just) mf ) fp base_dir modul options return $ fromMaybe [] mmf - + +-- | evaluate an expression +eval :: String -- ^ the expression + -> FilePath -- ^ source file path + -> FilePath -- ^ base directory + -> String -- ^ module name + -> [String] -- ^ build flags + -> IO [EvalResult] +eval expression fp base_dir modul options= do + mf<-withASTNotes (\_ _->getEvalResults expression) id base_dir (SingleFile fp modul) options + return $ concat $ fst mf -- | convert a GHC SrcSpan to a Span, ignoring the actual file info ghcSpanToLocation ::GHC.SrcSpan @@ -614,7 +705,7 @@ #endif let prTS = lexTokenStreamH sb lexLoc dflags1 case prTS of - POk _ toks -> do + POk _ toks -> -- GMU.liftIO $ print $ map (show . unLoc) toks return $ Right $ filter ofInterest toks PFailed loc msg -> return $ Left $ ghcErrMsgToNote dflags1 base_dir $ @@ -643,7 +734,7 @@ #endif let prTS = lexTokenStreamH sb lexLoc dflags1 case prTS of - POk _ toks -> do + POk _ toks -> -- GMU.liftIO $ print $ map (show . unLoc) toks return $ Right $ filter ofInterest toks PFailed loc msg -> return $ Left $ ghcErrMsgToNote dflags1 base_dir $ @@ -664,7 +755,7 @@ L _ ITeof -> return [] _ -> liftM (ltok:) go - +-- | get lexer initial location #if __GLASGOW_HASKELL__ < 702 lexLoc :: SrcLoc lexLoc = mkSrcLoc (mkFastString "") 1 (scionColToGhcCol 1) @@ -673,7 +764,7 @@ lexLoc = mkRealSrcLoc (mkFastString "") 1 (scionColToGhcCol 1) #endif - +-- | get lexer flags #if __GLASGOW_HASKELL__ >= 700 lexerFlags :: [ExtensionFlag] #else @@ -721,12 +812,13 @@ tokenToType :: Located Token -> TokenDef tokenToType (L sp t) = TokenDef (tokenType t) (ghcSpanToLocation sp) --- | Generate the interactive token list used by EclipseFP for syntax highlighting +-- | Generate the interactive token list used by EclipseFP for syntax highlighting, in the IO monad tokenTypesArbitrary :: FilePath -> String -> Bool -> [String] -> IO (Either BWNote [TokenDef]) tokenTypesArbitrary projectRoot contents literate options = generateTokens projectRoot contents literate options convertTokens id where convertTokens = map tokenToType +-- | Generate the interactive token list used by EclipseFP for syntax highlighting, when already in a GHC session tokenTypesArbitrary' :: FilePath -> String -> Bool -> Ghc (Either BWNote [TokenDef]) tokenTypesArbitrary' projectRoot contents literate = generateTokens' projectRoot contents literate convertTokens id where @@ -778,7 +870,7 @@ -> Ghc (Either BWNote a) generateTokens' projectRoot contents literate xform filterFunc =do let (ppTs, ppC) = preprocessSource contents literate - -- putStrLn ppC + -- GMU.liftIO $ putStrLn ppC result<- ghctokensArbitrary' projectRoot ppC case result of Right toks ->do @@ -805,7 +897,9 @@ | (Continue _)<-f = addPPToken "PP" (l,c) (ts2,l2,lineBehavior l f) | (ContinuePragma f2) <-f= addPPToken "P" (l,c) (ts2,"":l2,pragmaBehavior l f2) | ('#':_)<-l =addPPToken "PP" (l,c) (ts2,l2,lineBehavior l f) - | "{-# " `List.isPrefixOf` l=addPPToken "P" (l,c) (ts2,"":l2,pragmaBehavior l f) + | Just (l',s,e,f2)<-pragmaExtract l f= + (TokenDef "P" (mkFileSpan c s c e) : ts2 ,l':l2,f2) + -- | "{-# " `List.isPrefixOf` l=addPPToken "P" (l,c) (ts2,"":l2,pragmaBehavior l f) | (Indent n)<-f=(ts2,l:(replicate n (takeWhile (== ' ') l) ++ l2),Start) | otherwise =(ts2,l:l2,Start) ppSLit :: ([TokenDef],[String],PPBehavior) -> (String,Int) -> ([TokenDef],[String],PPBehavior) @@ -829,7 +923,25 @@ pragmaBehavior l f | "-}" `List.isInfixOf` l = f | otherwise = ContinuePragma f + pragmaExtract :: String -> PPBehavior -> Maybe (String,Int,Int,PPBehavior) + pragmaExtract l f= + let + (spl1,spl2)=splitString "{-# " l + in if not $ null spl2 + then + let + startIdx= length spl1 + (spl3,spl4)=splitString "-}" spl2 + in if not $ null spl4 + then + let + endIdx= length spl3 + 2 + len=endIdx + in Just (spl1++ replicate len ' ' ++ drop 2 spl4,startIdx+1,startIdx+len+1,f) + else Just (spl1,startIdx+1,length l+1,ContinuePragma f) + else Nothing +-- | preprocessor behavior data data PPBehavior=Continue Int | Indent Int | Start | ContinuePragma PPBehavior deriving Eq @@ -841,6 +953,7 @@ ghcWarnMsgToNote :: DynFlags -> FilePath -> WarnMsg -> BWNote ghcWarnMsgToNote df= ghcMsgToNote df BWWarning +-- | convert a GHC message to our note type -- Note that we do *not* include the extra info, since that information is -- only useful in the case where we do not show the error location directly -- in the source. @@ -881,10 +994,8 @@ -> T.Text mkQualifiedTokenValue q a = (T.pack . unpackFS . concatFS) [q, dotFS, a] --- | Make a token definition from its source location and Lexer.hs token type. ---mkTokenDef :: Located Token -> TokenDef ---mkTokenDef (L sp t) = TokenDef (mkTokenName t) (ghcSpanToLocation sp) +-- | make a text name from a token mkTokenName :: Token -> T.Text mkTokenName = T.pack . showConstr . toConstr @@ -896,7 +1007,7 @@ deriving instance Data StringBuffer #endif - +-- | get token type from Token tokenType :: Token -> T.Text tokenType ITas = "K" -- Haskell keywords tokenType ITcase = "K" @@ -1098,9 +1209,11 @@ tokenType (ITqQuasiQuote {}) = "TH" -- [Qual.quoter| quote |] #endif +-- | a dot as a FastString dotFS :: FastString dotFS = fsLit "." +-- | generate a token value tokenValue :: Bool -> Token -> T.Text tokenValue _ t | tokenType t `elem` ["K", "EK"] = T.drop 2 $ mkTokenName t tokenValue _ (ITvarid a) = mkUnqualTokenValue a @@ -1128,8 +1241,10 @@ - -start, end :: SrcSpan -> (Int,Int) +-- | extract start line and column from SrcSpan +start :: SrcSpan -> (Int,Int) +-- | extract end line and column from SrcSpan +end :: SrcSpan -> (Int,Int) #if __GLASGOW_HASKELL__ < 702 start ss= (srcSpanStartLine ss, srcSpanStartCol ss) end ss= (srcSpanEndLine ss, srcSpanEndCol ss) @@ -1139,10 +1254,11 @@ end (RealSrcSpan ss)= (srcSpanEndLine ss, srcSpanEndCol ss) end (UnhelpfulSpan _)=error "UnhelpfulSpan in cmpOverlap start" #endif - -type AliasMap=DM.Map ModuleName [ModuleName] +-- | map of module aliases +type AliasMap=DM.Map ModuleName [ModuleName] +-- | get usages from GHC imports ghcImportToUsage :: T.Text -> LImportDecl Name -> ([Usage],AliasMap) -> Ghc ([Usage],AliasMap) ghcImportToUsage myPkg (L _ imp) (ls,moduMap)=(do let L src modu=ideclName imp @@ -1164,7 +1280,8 @@ `gcatch` (\(se :: SourceError) -> do GMU.liftIO $ print se return ([],moduMap)) - + +-- | get usages from GHC IE ghcLIEToUsage :: DynFlags -> Maybe T.Text -> T.Text -> T.Text -> LIE Name -> [Usage] ghcLIEToUsage df tpkg tmod tsection (L src (IEVar nm))=[ghcNameToUsage df tpkg tmod tsection nm src False] ghcLIEToUsage df tpkg tmod tsection (L src (IEThingAbs nm))=[ghcNameToUsage df tpkg tmod tsection nm src True ] @@ -1173,7 +1290,8 @@ map (\ x -> ghcNameToUsage df tpkg tmod tsection x src False) cons ghcLIEToUsage _ tpkg tmod tsection (L src (IEModuleContents _))= [Usage tpkg tmod "" tsection False (toJSON $ ghcSpanToLocation src) False] ghcLIEToUsage _ _ _ _ _=[] - + +-- | get usage from GHC exports ghcExportToUsage :: DynFlags -> T.Text -> T.Text ->AliasMap -> LIE Name -> Ghc [Usage] ghcExportToUsage df myPkg myMod moduMap lie@(L _ name)=(do ls<-case name of @@ -1191,12 +1309,15 @@ `gcatch` (\(se :: SourceError) -> do GMU.liftIO $ print se return []) - + +-- | generate a usage for a name ghcNameToUsage :: DynFlags -> Maybe T.Text -> T.Text -> T.Text -> Name -> SrcSpan -> Bool -> Usage ghcNameToUsage df tpkg tmod tsection nm src typ=Usage tpkg tmod (T.pack $ showSD False df $ ppr nm) tsection typ (toJSON $ ghcSpanToLocation src) False +-- | map of imports type ImportMap=DM.Map T.Text (LImportDecl Name,[T.Text]) +-- | build an import map from all imports ghcImportMap :: LImportDecl Name -> Ghc ImportMap ghcImportMap l@(L _ imp)=(do let L _ modu=ideclName imp @@ -1225,7 +1346,7 @@ then mmx else DM.insertWith (\(_,xs1) (_,xs2)->(l,xs1++xs2)) expM (l,[nT]) mmx return $ if ideclImplicit imp - then DM.insert "" (l,(concatMap snd $ DM.elems fullM)) fullM + then DM.insert "" (l, concatMap snd $ DM.elems fullM) fullM else fullM ) `gcatch` (\(se :: SourceError) -> do @@ -1259,7 +1380,9 @@ -- | module, function/type, constructors type TypeMap=DM.Map T.Text (DM.Map T.Text (DS.Set T.Text)) +-- | mapping to import declaration to actually needed names type FinalImportValue=(LImportDecl Name,DM.Map T.Text (DS.Set T.Text)) +-- | map from original text to needed names type FinalImportMap=DM.Map T.Text FinalImportValue @@ -1284,10 +1407,10 @@ (Array vs)<- GMU.liftIO $ generateGHCInfo df env tm impMaps<-mapM ghcImportMap imps -- let impMap=DM.unions impMaps - let implicit=DS.fromList $ concatMap (maybe [] snd . (DM.lookup "")) impMaps + let implicit=DS.fromList $ concatMap (maybe [] snd . DM.lookup "") impMaps let allImps=concatMap DM.assocs impMaps -- GMU.liftIO $ putStrLn $ show $ map (\(n,(_,ns))->(n,ns)) allImps - GMU.liftIO $ print vs + -- GMU.liftIO $ print vs let usgMap=V.foldr ghcValToUsgMap DM.empty vs let usgMapWithoutMe=DM.delete modu usgMap -- GMU.liftIO $ print usgMapWithoutMe @@ -1363,7 +1486,7 @@ | DS.null cs=pprName n | otherwise =let nameList= T.intercalate ", " $ List.sortBy (comparing T.toLower) $ map pprName $ DS.toList cs - in (pprName n) `mappend` " (" `mappend` nameList `mappend` ")" + in pprName n `mappend` " (" `mappend` nameList `mappend` ")" getRemovedImports :: [(T.Text,(LImportDecl Name,[T.Text]))] -> FinalImportMap -> [ImportClean] getRemovedImports allImps ftm= let cleanedLines=DS.fromList $ map (\(L l _,_)->iflLine $ifsStart $ ghcSpanToLocation l) $ DM.elems ftm 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 @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP,OverloadedStrings,PatternGuards,RankNTypes #-} +{-# LANGUAGE CPP,OverloadedStrings,PatternGuards,RankNTypes, ScopedTypeVariables #-} -- | -- Module : Language.Haskell.BuildWrapper.GHCStorage -- Copyright : (c) JP Moresmau 2012 @@ -52,7 +52,7 @@ --import GHC.SYB.Utils (Stage(..), showData) import qualified MonadUtils as GMU import TcRnTypes (tcg_type_env,tcg_rdr_env) -import qualified CoreUtils as CoreUtils (exprType) +import qualified CoreUtils (exprType) import Desugar (deSugarExpr) import Control.Monad (liftM) import Data.Aeson.Types (Pair) @@ -93,6 +93,7 @@ -- print tcvals -- store objects with type annotations in a map keyed by module, name, line and column let tcByNameLoc=foldr buildMap DM.empty tcvals + -- print tcByNameLoc -- extract usages from renamed source rnvals<-liftM extractUsages $ dataToJSON df env tcm $ tm_renamed_source tcm -- print rnvals @@ -100,6 +101,7 @@ let typedVals=map (addType tcByNameLoc) rnvals return (Array $ V.fromList typedVals) where + mn=T.pack $ showSD True df $ ppr $ moduleName $ ms_mod $ pm_mod_summary $ tm_parsed_module tcm buildMap v@(Object m) dm | Just pos<-HM.lookup "Pos" m, Success ifs <- fromJSON pos, @@ -122,7 +124,10 @@ mv2=case mv of Nothing -> DM.lookup (mo,s,iflLine $ ifsStart ifs,0) dm a->a - in case mv2 of + mv3=if mn==mo && isNothing mv2 + then DM.lookup ("",s,iflLine $ ifsStart ifs,0) dm + else mv2 + in case mv3 of Just (Object m2) | Just qt<-HM.lookup "QType" m2, Just t<-HM.lookup "Type" m2, @@ -140,7 +145,7 @@ -> FilePath -- ^ the source file -> TypecheckedModule -- ^ the GHC AST -> IO() -storeGHCInfo df env fp tcm= do +storeGHCInfo df env fp tcm = -- putStrLn $ showData TypeChecker 4 $ typecheckedSource tcm -- putStrLn "Typechecked" -- BSC.putStrLn $ encode $ dataToJSON $ typecheckedSource tcm @@ -276,11 +281,11 @@ bagVar = liftM (simpleV "Bag(Located (HsBind Var))") . list . bagToList exprVar :: HsExpr Var ->IO Value exprVar ev = do - mt<- getType env tcm (L noSrcSpan ev) + -- https://github.com/JPMoresmau/BuildWrapper/issues/23 : catch panics + mt<- getType env tcm (L noSrcSpan ev) `gcatch` (\(_::(GhcException))->return Nothing) case mt of Just t-> case identOfExpr ev of - (Just v)->do - return $ typedVar v t + Just v -> return $ typedVar v t Nothing->generic ev --do --val<-generic ev @@ -319,14 +324,17 @@ -- | get type of an expression, inspired by the code in ghc-mod getType :: HscEnv -> TypecheckedModule -> LHsExpr Var -> IO(Maybe Type) +--getType _ _ (L _ (HsDo ArrowExpr _ _))=return Nothing +--getType _ _ (L _ (HsArrApp {}))=return Nothing getType hs_env tcm e = do (_, mbe) <- GMU.liftIO $ deSugarExpr hs_env modu rn_env ty_env e - return $ fmap (CoreUtils.exprType) mbe + return $ fmap CoreUtils.exprType mbe where 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 +-- | show SDoc wrapper showSD :: Bool -> DynFlags -> SDoc @@ -339,6 +347,7 @@ showSD False df =showSDocUnqual df #endif +-- | show SDoc for user wrapper showSDUser :: PrintUnqualified -> DynFlags -> SDoc @@ -349,6 +358,7 @@ showSDUser unqual df =showSDocForUser df unqual #endif +-- | show SDoc for dump wrapper showSDDump :: DynFlags -> SDoc -> String @@ -358,10 +368,13 @@ showSDDump df =showSDocDump df #endif +-- | convert a SrcSpan to a JSON Value srcSpanToJSON :: SrcSpan -> Value srcSpanToJSON src | isGoodSrcSpan src = object[ "SrcSpan" .= toJSON [srcLocToJSON $ srcSpanStart src, srcLocToJSON $ srcSpanEnd src]] | otherwise = Null + +-- | convert a SrcLoc to a JSON Value #if __GLASGOW_HASKELL__ < 702 srcLocToJSON :: SrcLoc -> Value srcLocToJSON sl @@ -373,7 +386,7 @@ srcLocToJSON _ = Null #endif - +-- | get all types contained by another type typesInsideType :: Type -> [Type] typesInsideType t=let (f1,f2)=splitFunTys t @@ -425,6 +438,7 @@ addDot _=error "expected String value for Module key" findInJSONFormatted _ _ _="no info" +-- | find a named value in JSON data findInJSONData :: Maybe Value -> Maybe ThingAtPoint findInJSONData (Just o@(Object m)) | Just (String _)<-HM.lookup "Name" m=case fromJSON o of Success tap->tap @@ -488,6 +502,7 @@ isGHCType _ _ =False +-- | extract usages from a global JSON Value extractUsages :: Value -- ^ the root object containing the AST -> [Value] extractUsages (Array arr) | not $ V.null arr=let @@ -500,6 +515,7 @@ -- (extractName o) : extractUsages _= [] +-- | Extract name values from a JSON Value extractName :: Value -> Value -> [Value] extractName src (Object m) | Just ifl<-extractSource src, @@ -520,6 +536,7 @@ in [object atts] extractName _ _=[] +-- | extract source information from a JSON Value extractSource :: Value -> Maybe InFileSpan extractSource (Object m) | Just pos<-HM.lookup "SrcSpan" m, @@ -539,8 +556,8 @@ -- | extract the source location from JSON extractSourceLoc :: Value -> Maybe (Int,Int) extractSourceLoc (Object m) | - Just (Number(I l))<-HM.lookup "line" m, - Just (Number(I c))<-HM.lookup "column" m=Just (fromIntegral l,fromIntegral c) + Just (Number l)<-HM.lookup "line" m, + Just (Number c)<-HM.lookup "column" m=Just (round l,round c) extractSourceLoc _ = Nothing -- | resolve the ident in an expression diff --git a/src/Language/Haskell/BuildWrapper/Packages.hs b/src/Language/Haskell/BuildWrapper/Packages.hs --- a/src/Language/Haskell/BuildWrapper/Packages.hs +++ b/src/Language/Haskell/BuildWrapper/Packages.hs @@ -58,6 +58,9 @@ path_dir = dir "package.conf.d" path_file = dir "package.conf" path_sd_dir= dir ("packages-" ++ ghcVersion ++ ".conf") + -- cabal sandboxes + path_ghc_dir= dir currentArch ++ '-' : currentOS ++ "-ghc-" ++ ghcVersion ++ "-packages.conf.d" + in do exists_dir <- doesDirectoryExist path_dir if exists_dir @@ -76,8 +79,13 @@ then do pkgs <- readContents (PkgDirectory path_sd_dir) return $ Just pkgs - else return Nothing - + else do + exists_dirGhc <- doesDirectoryExist path_ghc_dir + if exists_dirGhc + then do + pkgs <- readContents (PkgDirectory path_ghc_dir) + return $ Just pkgs + else return Nothing currentArch :: String currentArch = System.Info.arch @@ -150,7 +158,7 @@ -- fix the encoding to UTF-8 hSetEncoding h utf8 Exc.catch (hGetContents h) (\(err :: Exc.IOException)->do - putStrLn $ show err + print err hClose h h' <- openFile file ReadMode hSetEncoding h' localeEncoding 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 @@ -26,7 +26,7 @@ -- | get the AST getHSEAST :: String -- ^ input text -> [String] -- ^ options - -> (ParseResult (Module SrcSpanInfo, [Comment])) + -> ParseResult (Module SrcSpanInfo, [Comment]) getHSEAST input options=do -- we add MultiParamTypeClasses because we may need it if the module we're parsing uses a type class with multiple parameters, which doesn't require the PRAGMA (only in the module DEFINING the type class) -- we add PatternGuards since GHC only gives a warning if not explicit @@ -40,9 +40,9 @@ optionsPragmas = [ optionsPragma | S.OptionsPragma _ _ optionsPragma <- topPragmas ] optionsFromPragmas = concatMap words optionsPragmas #if MIN_VERSION_haskell_src_exts(1,14,0) - exts=EnableExtension MultiParamTypeClasses : EnableExtension PatternGuards : (map (\x->classifyExtension $ if "-X" `isPrefixOf` x then tail $ tail x else x) $ options ++ optionsFromPragmas) + exts=EnableExtension MultiParamTypeClasses : EnableExtension PatternGuards : map (\x->classifyExtension $ if "-X" `isPrefixOf` x then tail $ tail x else x) (options ++ optionsFromPragmas) #else - exts=MultiParamTypeClasses : PatternGuards : (map (\x->classifyExtension $ if "-X" `isPrefixOf` x then tail $ tail x else x) $ options ++ optionsFromPragmas) + exts=MultiParamTypeClasses : PatternGuards : map (\x->classifyExtension $ if "-X" `isPrefixOf` x then tail $ tail x else x) (options ++ optionsFromPragmas) #endif extsFull=if "-fglasgow-exts" `elem` options ++ optionsFromPragmas then exts ++ glasgowExts @@ -154,7 +154,8 @@ pl=DM.lookup (st-1) cm (cm2,od2)= case pl of -- | stc <= iflColumn (ifsStart $ odLoc od) - Just (stc,stl,t)-> ( DM.delete (st-1) cm,od{odComment=Just t,odStartLineComment=Just stl}) + -- stc ) + Just (_,stl,t)-> ( DM.delete (st-1) cm,od{odComment=Just t,odStartLineComment=Just stl}) _ -> let -- search for comment after declaration (same line) pl2=DM.lookup st cm @@ -227,16 +228,20 @@ child (IThingWith l n cns) = ImportSpecDef (nameDecl n) IEThingWith (makeSpan l) (map cnameDecl cns) getHSEImportExport _=([],[]) +-- | extract name nameDecl :: Name a -> T.Text nameDecl (Ident _ s)=T.pack s nameDecl (Symbol _ s)=T.pack s +-- | extract class name cnameDecl :: CName a -> T.Text cnameDecl (VarName _ s)=nameDecl s cnameDecl (ConName _ s)=nameDecl s +-- | extract qualified name qnameDecl :: QName a -> T.Text qnameDecl (Qual _ _ n)=nameDecl n qnameDecl (UnQual _ n)=nameDecl n qnameDecl _ ="" +-- | extract module name mnnameDecl :: ModuleName a -> T.Text mnnameDecl (ModuleName _ s)=T.pack s 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 @@ -20,26 +20,13 @@ import Data.ByteString.Lazy.Char8() import Data.Maybe -import Data.Char +import Data.List -import System.Directory import System.FilePath -import System.Info -import Control.Monad - -import Data.Attoparsec -import Data.Aeson -import Data.Aeson.Parser -import qualified Data.ByteString.Char8 as BS -import Data.List -import System.Exit -import System.Process - import Test.Framework import Test.HUnit (Assertion) -import System.IO (Handle, hPutStrLn, hFlush) import Control.Concurrent (threadDelay) test_NameDefsInScopeLongRunning :: Assertion @@ -58,7 +45,7 @@ build api root True Source synchronize api root False (inp,out,_,_)<-build1lr root rel - (mtts,ns)<-(readResult out) :: IO (OpResult (Maybe [NameDef])) + (mtts,ns)<- readResult out :: IO (OpResult (Maybe [NameDef])) assertBool (isJust mtts) assertBool (not $ notesInError ns) let tts=fromJust mtts @@ -126,20 +113,88 @@ build api root True Source synchronize api root False (inp,out,_,_)<-build1lr root rel - (mtts,ns)<-(readResult out) :: IO (OpResult (Maybe [NameDef])) + (mtts,ns)<- readResult out :: IO (OpResult (Maybe [NameDef])) assertBool (isJust mtts) assertBool (not $ notesInError ns) - eval inp "reverse \"toto\"" - s1<- readResult out :: IO (String) - assertEqual "\"otot\"" s1 - eval inp "main" - s2<- readResult out :: IO (String) - assertEqual "\"toto\"" s2 - eval inp "MkType1_1" - s3<- readResult out :: IO (String) - assertBool $ "No instance for" `isPrefixOf` s3 + evalLR inp "reverse \"toto\"" + (s1,_)<- readResult out :: IO (OpResult [EvalResult]) + assertEqual [EvalResult (Just "[GHC.Types.Char]") (Just "\"otot\"") Nothing] s1 + evalLR inp "main" + (s2,_)<- readResult out :: IO (OpResult [EvalResult]) + assertEqual [EvalResult (Just "[GHC.Types.Char]") (Just "\"toto\"") Nothing] s2 + evalLR inp "MkType1_1" + (s3,_)<- readResult out :: IO (OpResult [EvalResult]) + assertBool $ isPrefixOf "No instance for" $ (\(EvalResult _ _ (Just err))->err) $ head s3 + threadDelay 1000000 + write api root rel $ unlines [ + "module Main where", + "import B.D", + "main=return $ map id \"titi\"", + "data Type1=MkType1_1 Int", + "data Type2=MkType2_1 Int" + ] + continue inp + readResult out :: IO (OpResult (Maybe [NameDef])) + evalLR inp "main" + (s4,_)<- readResult out :: IO (OpResult [EvalResult]) + assertEqual [EvalResult (Just "[GHC.Types.Char]") (Just "\"titi\"") Nothing] s4 end inp + +test_EvalTextLongRunning :: Assertion +test_EvalTextLongRunning = do + let api=cabalAPI + root<-createTestProject + 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", + "", + "executable BWTest", + " hs-source-dirs: src", + " main-is: Main.hs", + " other-modules: B.D", + " build-depends: base, text", + "", + "test-suite BWTest-test", + " type: exitcode-stdio-1.0", + " hs-source-dirs: test", + " main-is: Main.hs", + " other-modules: TestA", + " build-depends: base", + "" + ] + + synchronize api root False + configure api root Source + let rel="src""Main.hs" + writeFile (root rel) $ unlines [ + "{-# LANGUAGE OverloadedStrings #-}", + "module Main where", + "import qualified Data.Text as T", + "t=T.pack \"test\"" + ] + 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) + evalLR inp "t" + (s1,_)<- readResult out :: IO (OpResult [EvalResult]) + assertEqual [EvalResult (Just "Data.Text.Internal.Text") (Just "\"test\"") Nothing] s1 + evalLR inp "T.breakOnEnd \"/\" \"a/b\"" + (s2,_)<- readResult out :: IO (OpResult [EvalResult]) + assertEqual [EvalResult (Just "(Data.Text.Internal.Text, Data.Text.Internal.Text)") (Just "(\"a/\",\"b\")") Nothing] s2 + end inp + test_TokenTypesLongRunning :: Assertion test_TokenTypesLongRunning = do let api=cabalAPI @@ -156,7 +211,7 @@ build api root True Source synchronize api root False (inp,out,_,_)<-build1lr root rel - (mtts,ns)<-(readResult out) :: IO (OpResult (Maybe [NameDef])) + (mtts,ns)<- readResult out :: IO (OpResult (Maybe [NameDef])) assertBool (isJust mtts) assertBool (not $ notesInError ns) tokenTypesLR inp @@ -185,7 +240,7 @@ build api root True Source synchronize api root False (inp,out,_,_)<-build1lr root rel - (mtts,ns)<-(readResult out) :: IO (OpResult (Maybe [NameDef])) + (mtts,ns)<- readResult out :: IO (OpResult (Maybe [NameDef])) assertBool (isJust mtts) assertBool (not $ notesInError ns) tokenTypesLR inp @@ -202,3 +257,36 @@ assertBool (not $ notesInError ns2) assertBool (isJust mtts2) end inp + +test_LocalsLongRunning :: Assertion +test_LocalsLongRunning = 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", + "main=return $ map id \"toto\"", + "", + "fun1 l1=let", + " l2=reverse \"toto\"", + " in head l2" + ] + 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) + localsLR inp 4 1 6 10 + (tap1,nsErrorsTap)<-readResult out :: IO (OpResult [ThingAtPoint]) + assertBool (null nsErrorsTap) + let namesM=map tapName tap1 + assertBool ("l2" `elem` namesM) + assertBool ("l1" `elem` namesM) + continue inp + (mtts2,ns2)<-readResult out :: IO (OpResult (Maybe [NameDef])) + assertBool (not $ notesInError ns2) + assertBool (isJust mtts2) + end inp 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 @@ -24,6 +24,7 @@ import System.FilePath import System.Info +import Control.Applicative ((<$>)) import Control.Monad @@ -54,12 +55,13 @@ getOccurrences :: a -> FilePath -> FilePath -> String -> IO (OpResult [TokenDef]) getThingAtPoint :: a -> FilePath -> FilePath -> Int -> Int -> IO (OpResult (Maybe ThingAtPoint)) getLocals :: a -> FilePath -> FilePath -> Int -> Int -> Int -> Int -> IO (OpResult [ThingAtPoint]) + eval :: a -> FilePath -> FilePath -> String-> IO (OpResult [EvalResult]) getNamesInScope :: a -> FilePath -> FilePath-> IO (OpResult (Maybe [String])) getCabalDependencies :: a -> FilePath -> Maybe FilePath -> IO (OpResult [(FilePath,[CabalPackage])]) getCabalComponents :: a -> FilePath -> IO (OpResult [CabalComponent]) generateUsage :: a -> FilePath -> Bool -> CabalComponent -> IO (OpResult (Maybe [FilePath])) cleanImports :: a -> FilePath -> FilePath -> Bool -> IO (OpResult [ImportClean]) - clean :: a -> FilePath -> Bool -> IO(Bool) + clean :: a -> FilePath -> Bool -> IO Bool data CMDAPI=CMDAPI { @@ -70,10 +72,10 @@ instance APIFacade CMDAPI where - synchronize (CMDAPI c o) r ff= runAPI c r "synchronize" (["--force="++ show ff ] ++ cmdOpts o) + synchronize (CMDAPI c o) r ff= runAPI c r "synchronize" (("--force="++ show ff) : cmdOpts o) synchronize1 (CMDAPI c o) r ff fp= runAPI c r "synchronize1" (["--force="++show ff,"--file="++fp]++ cmdOpts o) write (CMDAPI c _) r fp s= runAPI c r "write" ["--file="++fp,"--contents="++s] - configure (CMDAPI c o) r t= runAPI c r "configure" (["--cabaltarget="++ show t]++ cmdOpts o) + configure (CMDAPI c o) r t= runAPI c r "configure" (("--cabaltarget="++ show t) : cmdOpts o) configureWithFlags (CMDAPI c o) r t fgs= runAPI c r "configure" (["--cabaltarget="++ show t,"--cabalflags="++ fgs]++ cmdOpts o) build (CMDAPI c o) r b wc= runAPI c r "build" (["--output="++ show b,"--cabaltarget="++ show wc]++ cmdOpts o) build1 (CMDAPI c _) r fp= runAPI c r "build1" ["--file="++fp] @@ -82,19 +84,21 @@ getOutline (CMDAPI c _) r fp= runAPI c r "outline" ["--file="++fp] getTokenTypes (CMDAPI c _) r fp= runAPI c r "tokentypes" ["--file="++fp] getOccurrences (CMDAPI c _) r fp s= runAPI c r "occurrences" ["--file="++fp,"--token="++s] - getThingAtPoint (CMDAPI c _) r fp l cl= fmap removeLayoutTAP $ runAPI c r "thingatpoint" ["--file="++fp,"--line="++ show l,"--column="++ show cl] + getThingAtPoint (CMDAPI c _) r fp l cl= removeLayoutTAP <$> runAPI c r "thingatpoint" ["--file="++fp,"--line="++ show l,"--column="++ show cl] getLocals (CMDAPI c _) r fp sl sc el ec= runAPI c r "locals" ["--file="++fp,"--sline="++ show sl,"--scolumn="++ show sc,"--eline="++ show el,"--ecolumn="++ show ec] + eval (CMDAPI c _) r fp ex= runAPI c r "eval" ["--file="++fp,"--expression="++ ex] getNamesInScope (CMDAPI c _) r fp= runAPI c r "namesinscope" ["--file="++fp] - getCabalDependencies (CMDAPI c o) r mfp= runAPI c r "dependencies" ((maybe [] (\x->["--sandbox="++x]) mfp)++ cmdOpts o) + getCabalDependencies (CMDAPI c o) r mfp= runAPI c r "dependencies" (maybe [] (\x->["--sandbox="++x]) mfp ++ cmdOpts o) getCabalComponents (CMDAPI c _) r= runAPI c r "components" [] generateUsage (CMDAPI c _) r retAll cc=runAPI c r "generateusage" ["--returnall="++ show retAll,"--cabalcomponent="++ cabalComponentName cc] cleanImports (CMDAPI c _) r fp fo= runAPI c r "cleanimports" ["--file="++fp,"--format="++ show fo] clean (CMDAPI c _) r e=runAPI c r "clean" ["--everything="++show e] build1lr :: FilePath - -> [Char] -> IO (Handle, Handle, Handle, ProcessHandle) + -> String -> IO (Handle, Handle, Handle, ProcessHandle) build1lr r fp= startAPIProcess r "build1" ["--file="++fp,"--longrunning=true"] - + +cabalAPI :: CMDAPI cabalAPI= CMDAPI "cabal" [] exeExtension :: String @@ -238,7 +242,7 @@ assertBool (not bool5) assertEqual 1 (length nsErrors5) let (nsError6:[])=nsErrors5 - assertEqual (BWNote BWError "No 'Main-Is' field found for executable BWTest\n" (mkEmptySpan cfn 1 1)) nsError6 + assertEqual (BWNote BWError "no 'main-is' field found for executable bwtest\n" (mkEmptySpan cfn 1 1)) (nsError6{bwnTitle=map toLower $ bwnTitle nsError6}) writeFile cf $ unlines ["name: "++testProjectName, "version:0.1", "cabal-version: >= 1.2", @@ -285,7 +289,7 @@ assertBool bool1 assertEqual 1 (length ns1) let (nsWarning1:[])=ns1 - assertEqual (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" (mkEmptySpan cfn 5 1)) nsWarning1 + assertEqual (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, extra-doc-files\n" (mkEmptySpan cfn 5 1)) nsWarning1 writeFile cf $ unlines ["name: "++testProjectName, "version:0.1", "build-type: Simple", @@ -583,7 +587,7 @@ ] ] assertEqual (length expected) (length defs) - mapM_ (uncurry (assertEqual)) (zip expected defs) + mapM_ (uncurry assertEqual) (zip expected defs) assertEqual [] es assertEqual [ImportDef "Data.Char" Nothing (InFileSpan (InFileLoc 5 1)(InFileLoc 5 17)) False False "" Nothing] is @@ -653,7 +657,7 @@ ] Nothing (Just "Type1 haddock") (Just 29) ] assertEqual (length expected) (length defs) - mapM_ (uncurry (assertEqual )) (zip expected defs) + mapM_ (uncurry assertEqual) (zip expected defs) assertEqual [] es assertEqual [ImportDef "Data.Char" Nothing (InFileSpan (InFileLoc 5 1)(InFileLoc 5 17)) False False "" Nothing] is @@ -695,7 +699,7 @@ ] Nothing (Just "This is the documentation for the FV") (Just 7) ] Nothing (Just "Type for an entry in file") (Just 3)] assertEqual (length expected) (length defs) - mapM_ (uncurry (assertEqual )) (zip expected defs) + mapM_ (uncurry assertEqual) (zip expected defs) test_OutlinePreproc :: Assertion test_OutlinePreproc = do @@ -735,7 +739,7 @@ mkOutlineDef "testfunc1" [Function] (InFileSpan (InFileLoc 6 1)(InFileLoc 6 25)) ] assertEqual (length expected1) (length defs1) - mapM_ (uncurry (assertEqual )) (zip expected1 defs1) + mapM_ (uncurry assertEqual) (zip expected1 defs1) write api root rel $ unlines [ "{-# LANGUAGE CPP #-}", "", @@ -760,7 +764,7 @@ ] ] assertEqual (length expected2) (length defs2) - mapM_ (uncurry (assertEqual )) (zip expected2 defs2) + mapM_ (uncurry assertEqual) (zip expected2 defs2) write api root rel $ unlines [ "{-# LANGUAGE CPP #-}", "", @@ -779,7 +783,7 @@ mkOutlineDef "testfunc1" [Function] (InFileSpan (InFileLoc 6 1)(InFileLoc 6 25)) ] assertEqual (length expected3) (length defs3) - mapM_ (uncurry (assertEqual )) (zip expected3 defs3) + mapM_ (uncurry assertEqual) (zip expected3 defs3) @@ -808,7 +812,7 @@ mkOutlineDef "testfunc1" [Function] (InFileSpan (InFileLoc 6 3)(InFileLoc 6 27)) ] assertEqual (length expected1) (length defs1) - mapM_ (uncurry (assertEqual)) (zip expected1 defs1) + mapM_ (uncurry assertEqual) (zip expected1 defs1) test_OutlineImportExport :: Assertion @@ -835,14 +839,14 @@ ExportDef "Data.Char" IEModule (InFileSpan (InFileLoc 1 23)(InFileLoc 1 39)) [], ExportDef "MkTest" IEThingAll (InFileSpan (InFileLoc 1 40)(InFileLoc 1 50)) [] ] - mapM_ (uncurry (assertEqual)) (zip exps es) + mapM_ (uncurry assertEqual) (zip exps es) let imps=[ ImportDef "Data.Char" Nothing (InFileSpan (InFileLoc 3 1)(InFileLoc 3 17)) False False "" Nothing, ImportDef "Data.Map" Nothing (InFileSpan (InFileLoc 4 1)(InFileLoc 4 30)) False False "DM" (Just [ImportSpecDef "empty" IEVar (InFileSpan (InFileLoc 4 24)(InFileLoc 4 29)) []]), ImportDef "Data.List" Nothing (InFileSpan (InFileLoc 5 1)(InFileLoc 5 42)) False True "" (Just [ImportSpecDef "orderBy" IEVar (InFileSpan (InFileLoc 5 26)(InFileLoc 5 33)) [],ImportSpecDef "groupBy" IEVar (InFileSpan (InFileLoc 5 34)(InFileLoc 5 41)) []]), ImportDef "Data.Maybe" Nothing (InFileSpan (InFileLoc 6 1)(InFileLoc 6 42)) True False "" (Just [ImportSpecDef "Maybe" IEThingWith (InFileSpan (InFileLoc 6 30)(InFileLoc 6 41)) ["Just"]]) ] - mapM_ (uncurry (assertEqual)) (zip imps is) + mapM_ (uncurry assertEqual) (zip imps is) @@ -1041,6 +1045,44 @@ assertBool (null nsErrors1) let expectedS="[{\"P\":[1,1,26]},{\"C\":[2,1,13]},{\"K\":[3,1,7]},{\"IC\":[3,8,12]},{\"K\":[3,13,18]},{\"IV\":[5,1,5]},{\"S\":[5,6,8]},{\"IC\":[5,9,11]},{\"SS\":[5,12]},{\"IC\":[5,13,16]},{\"SS\":[5,16]},{\"IV\":[6,1,5]},{\"S\":[6,6]},{\"K\":[6,8,10]},{\"IV\":[7,9,15]},{\"SS\":[7,16]},{\"LC\":[7,17,20]},{\"S\":[7,20]},{\"LS\":[7,21,34]},{\"SS\":[7,34]},{\"IV\":[8,9,15]},{\"SS\":[8,16]},{\"LI\":[8,17]},{\"VS\":[8,19]},{\"LI\":[8,21]},{\"SS\":[8,22]},{\"PP\":[10,1,11]},{\"TH\":[11,1,3]},{\"IV\":[11,4,10]},{\"IV\":[11,11,23]},{\"TH\":[11,24,26]},{\"IC\":[11,26,35]},{\"SS\":[11,36]},{\"PP\":[12,1,7]}]" assertEqual expectedS (encode $ toJSON tts) + write api root rel $ unlines [ + "-- a comment", + "module Main where", + "{-# LINE 2 \"d:\\\\toot\\\\titi\\\\Foo.vhs\" #-}", + "", + "main :: IO (Int)", + "main = do" , + " putStr ('h':\"ello Prefs!\")", + " return (2 + 2)", + "", + "#if USE_TH", + "$( derive makeTypeable ''Extension )", + "#endif", + "" + ] + (tts2,nsErrors2)<-getTokenTypes api root rel + assertBool (null nsErrors2) + let expectedS2="[{\"C\":[1,1,13]},{\"K\":[2,1,7]},{\"IC\":[2,8,12]},{\"K\":[2,13,18]},{\"P\":[3,1,41]},{\"IV\":[5,1,5]},{\"S\":[5,6,8]},{\"IC\":[5,9,11]},{\"SS\":[5,12]},{\"IC\":[5,13,16]},{\"SS\":[5,16]},{\"IV\":[6,1,5]},{\"S\":[6,6]},{\"K\":[6,8,10]},{\"IV\":[7,9,15]},{\"SS\":[7,16]},{\"LC\":[7,17,20]},{\"S\":[7,20]},{\"LS\":[7,21,34]},{\"SS\":[7,34]},{\"IV\":[8,9,15]},{\"SS\":[8,16]},{\"LI\":[8,17]},{\"VS\":[8,19]},{\"LI\":[8,21]},{\"SS\":[8,22]},{\"PP\":[10,1,11]},{\"TH\":[11,1,3]},{\"IV\":[11,4,10]},{\"IV\":[11,11,23]},{\"TH\":[11,24,26]},{\"IC\":[11,26,35]},{\"SS\":[11,36]},{\"PP\":[12,1,7]}]" + assertEqual expectedS2 (encode $ toJSON tts2) + write api root rel $ unlines [ + "-- a comment", + "module Main ({-# LINE 24 \"d:\\\\toot\\\\titi\\\\Foo.vhs\" #-})", + "where", + "", + "main :: IO (Int)", + "main = do" , + " putStr ('h':\"ello Prefs!\")", + " return (2 + 2)", + "", + "#if USE_TH", + "$( derive makeTypeable ''Extension )", + "#endif", + "" + ] + (tts3,nsErrors3)<-getTokenTypes api root rel + assertBool (null nsErrors3) + let expectedS3="[{\"C\":[1,1,13]},{\"K\":[2,1,7]},{\"IC\":[2,8,12]},{\"SS\":[2,13]},{\"P\":[2,14,55]},{\"SS\":[2,55]},{\"K\":[3,1,6]},{\"IV\":[5,1,5]},{\"S\":[5,6,8]},{\"IC\":[5,9,11]},{\"SS\":[5,12]},{\"IC\":[5,13,16]},{\"SS\":[5,16]},{\"IV\":[6,1,5]},{\"S\":[6,6]},{\"K\":[6,8,10]},{\"IV\":[7,9,15]},{\"SS\":[7,16]},{\"LC\":[7,17,20]},{\"S\":[7,20]},{\"LS\":[7,21,34]},{\"SS\":[7,34]},{\"IV\":[8,9,15]},{\"SS\":[8,16]},{\"LI\":[8,17]},{\"VS\":[8,19]},{\"LI\":[8,21]},{\"SS\":[8,22]},{\"PP\":[10,1,11]},{\"TH\":[11,1,3]},{\"IV\":[11,4,10]},{\"IV\":[11,11,23]},{\"TH\":[11,24,26]},{\"IC\":[11,26,35]},{\"SS\":[11,36]},{\"PP\":[12,1,7]}]" + assertEqual expectedS3 (encode $ toJSON tts3) test_PreviewTokenTypesHaddock :: Assertion test_PreviewTokenTypesHaddock = do @@ -1373,8 +1415,8 @@ assertBool (null nsErrors1) assertBool (not $ null loc1) let names=map tapName loc1 - assertBool (elem "l2" names) - assertBool (elem "l1" names) + assertBool ("l2" `elem` names) + assertBool ("l1" `elem` names) write api root rel $ unlines [ "module Main where", "main=return $ map id \"toto\"", @@ -1389,11 +1431,36 @@ assertBool (null nsErrors2) assertBool (not $ null loc2) let namesM=map tapName loc2 - assertBool (elem "l2" namesM) - assertBool (elem "l1" namesM) + assertBool ("l2" `elem` namesM) + assertBool ("l1" `elem` namesM) return () +test_Eval :: Assertion +test_Eval = 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" + ] + build api root True Source + synchronize api root False + (_,nsErrors)<-getBuildFlags api root rel + assertBool (null nsErrors) + (s1,_)<-eval api root rel "reverse \"toto\"" + assertEqual [EvalResult (Just "[GHC.Types.Char]") (Just "\"otot\"") Nothing] s1 + (s2,_)<-eval api root rel "main" + assertEqual [EvalResult (Just "[GHC.Types.Char]") (Just "\"toto\"") Nothing] s2 + (s3,_)<-eval api root rel "MkType1_1" + assertBool $ isPrefixOf "No instance for" $ (\(EvalResult _ _ (Just err))->err) $ head s3 + return () + test_NamesInScope :: Assertion test_NamesInScope = do let api=cabalAPI @@ -1571,6 +1638,54 @@ assertEqual (CCTestSuite "BWTest-test" False) ts2 +test_CabalBenchmark :: Assertion +test_CabalBenchmark= do + let api=cabalAPI + root<-createTestProject + synchronize api root False + 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", + "", + "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", + "", + "benchmark BWTest-bench", + " type: exitcode-stdio-1.0", + " hs-source-dirs: test", + " main-is: Main.hs", + " other-modules: TestA", + " build-depends: base", + "" + ] + configure api root Source + (cps2,nsOK2)<-getCabalComponents api root + assertBool (null nsOK2) + assertEqual 4 (length cps2) + let (l2:ex2:ts2:b2:[])=cps2 + assertEqual (CCLibrary True) l2 + assertEqual (CCExecutable "BWTest" True) ex2 + assertEqual (CCTestSuite "BWTest-test" True) ts2 + assertEqual (CCBenchmark "BWTest-bench" True) b2 + test_CabalDependencies :: Assertion test_CabalDependencies = do let api=cabalAPI @@ -1883,7 +1998,7 @@ ] testCabalFile :: FilePath -> FilePath -testCabalFile root =root ((last $ splitDirectories root) <.> ".cabal") +testCabalFile root =root (last (splitDirectories root) <.> ".cabal") testAContents :: String testAContents=unlines ["module A where","fA=undefined"] @@ -1969,8 +2084,7 @@ a->do assertFailure (show a) error "" - a->do - assertFailure (show a) + a-> assertFailure (show a) startAPIProcess :: FilePath -> String -> [String] -> IO (Handle, Handle, Handle, ProcessHandle) startAPIProcess root command args= do @@ -1984,7 +2098,7 @@ readResult h= do l<-BS.hGetLine h BS.putStrLn l - if BS.isPrefixOf "build-wrapper-json:" l + if "build-wrapper-json:" `BS.isPrefixOf` l then do let r=parse value $ BS.drop (BS.length "build-wrapper-json:") l -- print r @@ -1993,10 +2107,8 @@ let r1= fromJSON js case r1 of Data.Aeson.Success fin->return fin - a->do - assertFailure (show a) - a->do - assertFailure (show a) + a-> assertFailure (show a) + a-> assertFailure (show a) else readResult h @@ -2005,8 +2117,8 @@ hPutStrLn h "." hFlush h -eval :: Handle -> String -> IO () -eval h expr=do +evalLR :: Handle -> String -> IO () +evalLR h expr=do hPutStrLn h ("e "++expr) hFlush h @@ -2025,9 +2137,14 @@ hPutStrLn h ('p':show (l,c)) hFlush h +localsLR:: Handle -> Int -> Int -> Int -> Int -> IO() +localsLR h l c el ec=do + hPutStrLn h ('l':show (l,c,el,ec)) + hFlush h + cmdOpts :: [String] -> [String] cmdOpts =map ("--cabaloption=" ++) notesInError :: [BWNote] -> Bool -notesInError ns=not $ null $ filter (\x->BWError == bwnStatus x) ns +notesInError = any (\ x -> BWError == bwnStatus x) diff --git a/test/Language/Haskell/BuildWrapper/CabalDevTests.hs b/test/Language/Haskell/BuildWrapper/CabalDevTests.hs --- a/test/Language/Haskell/BuildWrapper/CabalDevTests.hs +++ b/test/Language/Haskell/BuildWrapper/CabalDevTests.hs @@ -39,7 +39,7 @@ assertBool (null dels) configure api root2 Source (BuildResult bool1b _,nsErrors1b)<-build api root2 True Source - assertBool (bool1b) + assertBool bool1b assertEqual 0 (length nsErrors1b) let relB="src""B.hs" (mtts1,nsErrors1)<-getNamesInScope api root2 relB @@ -59,7 +59,7 @@ synchronize api root2 False configure api root2 Source (BuildResult bool2b _,nsErrors2b)<-build api root2 True Source - assertBool (bool2b) + assertBool bool2b assertEqual 0 (length nsErrors2b) (mtts2,nsErrors2)<-getNamesInScope api root2 relB assertBool (null nsErrors2) @@ -81,7 +81,7 @@ assertBool (null dels) configure api root2 Source (BuildResult bool1b _,nsErrors1b)<-build api root2 True Source - assertBool (bool1b) + assertBool bool1b assertEqual 0 (length nsErrors1b) (cps,nsOK)<-getCabalDependencies api root2 (Just "./.dist-buildwrapper/cabal-dev") assertBool (null nsOK) diff --git a/test/Language/Haskell/BuildWrapper/GHCTests.hs b/test/Language/Haskell/BuildWrapper/GHCTests.hs --- a/test/Language/Haskell/BuildWrapper/GHCTests.hs +++ b/test/Language/Haskell/BuildWrapper/GHCTests.hs @@ -62,7 +62,17 @@ assertEqual (TokenDef "PP" (mkLocation 1 1 1 20)) t1 assertEqual (TokenDef "P" (mkLocation 2 1 2 35)) t2 assertEqual (TokenDef "PP" (mkLocation 3 1 3 7)) t3 - assertEqual "\n\n\nmodule Main\n" s2 + assertEqual " \n\n\nmodule Main\n" s2 + +test_PreprocPragmaInside:: Assertion +test_PreprocPragmaInside= + do + let s="module Main({-# LANGUAGE OverloadedStrings #-})\n" + let (tt,s2)=preprocessSource s False + assertEqual 1 (length tt) + let (t1:[])=tt + assertEqual (TokenDef "P" (mkLocation 1 13 1 47)) t1 + assertEqual "module Main( )\n" s2 test_PreprocPragma2Lines:: Assertion test_PreprocPragma2Lines=