diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -94,6 +94,20 @@ - file: the relative path of the file to update (relative to the project root) +## locals +Returns the list of names defined locally to a point in the source (inside the function, say) + +- file: the relative path of the file to update (relative to the project root) +- sline: the start line of the defining scope +- scolumn: the start column of the defining scope +- eline: the end line of the defining scope +- ecolumn: the end column of the defining scope + +## cleanimports +Returns the cleaned imports line: the location and import text for the minimal required imports + +- file: the relative path of the file to update (relative to the project root) + ## dependencies Returns the list of all package dependencies for all cabal components in the cabal file, with the package database they are registered in diff --git a/buildwrapper.cabal b/buildwrapper.cabal --- a/buildwrapper.cabal +++ b/buildwrapper.cabal @@ -1,5 +1,5 @@ name: buildwrapper -version: 0.6.4 +version: 0.7.0 cabal-version: >= 1.8 build-type: Simple license: BSD3 @@ -118,7 +118,9 @@ Language.Haskell.BuildWrapper.APITest, Language.Haskell.BuildWrapper.CMDTests, Language.Haskell.BuildWrapper.GHCTests, - Language.Haskell.BuildWrapper.UsagesTests + Language.Haskell.BuildWrapper.UsagesTests, + Language.Haskell.BuildWrapper.ImportsTests, + Language.Haskell.BuildWrapper.CabalDevTests if impl(ghc >= 7.6) build-depends: time 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 @@ -36,17 +36,19 @@ | Write {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, cabalOption::[String], file:: FilePath, contents::String} | Configure {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, cabalOption::[String], verbosity::Verbosity,cabalTarget::WhichCabal} | Build {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, cabalOption::[String], verbosity::Verbosity,output::Bool,cabalTarget::WhichCabal} - | Build1 {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, cabalOption::[String], file:: FilePath, component:: Maybe String} + | Build1 {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, cabalOption::[String], file:: FilePath, component:: Maybe String, longRunning :: Bool} | Outline {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, cabalOption::[String], file:: FilePath, component:: Maybe String} | TokenTypes {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, cabalOption::[String], file:: FilePath, component:: Maybe String} | Occurrences {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, cabalOption::[String], file:: FilePath,token::String, component:: Maybe String} | ThingAtPointCmd {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, cabalOption::[String], file:: FilePath, line::Int, column::Int, component:: Maybe String} | Locals {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, cabalOption::[String], file:: FilePath, sline::Int, scolumn::Int,eline::Int, ecolumn::Int, component:: Maybe String} | NamesInScope {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, cabalOption::[String], file:: FilePath, component:: Maybe String} - | Dependencies {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, cabalOption::[String]} + | Dependencies {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, cabalOption::[String], sandbox::FilePath} | Components {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, cabalOption::[String]} | GetBuildFlags {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, cabalOption::[String], file:: FilePath, component:: Maybe String} | GenerateUsage {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, cabalOption::[String], returnAll:: Bool, cabalComponent::String} + | CleanImports {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, cabalOption::[String], file:: FilePath, format :: Bool, component:: Maybe String} + | Clean {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, cabalOption::[String], everything:: Bool} deriving (Show,Read,Data,Typeable) @@ -58,6 +60,8 @@ cf=def &= typFile &= help "cabal file" fp :: FilePath fp=def &= typFile &= help "relative path of file to process" +sd :: FilePath +sd=def &= typDir &= help "path of the sandbox" ff :: Bool ff=def &= help "overwrite newer file" uf :: String @@ -65,6 +69,12 @@ co :: [String] co=def &= help "cabal extra parameters" +formatF :: Bool +formatF=def &= help "format imports" + +longRunningF :: Bool +longRunningF=def &= help "long running process" + v :: Verbosity v=Normal &= help "verbosity" wc :: WhichCabal @@ -90,9 +100,11 @@ mbuild :: BWCmd mbuild = Build tf cp cf uf co v (def &= help "output compilation and linking result") wc mbuild1 :: BWCmd -mbuild1 = Build1 tf cp cf uf co fp mcc +mbuild1 = Build1 tf cp cf uf co fp mcc longRunningF mgetbf :: BWCmd mgetbf = GetBuildFlags tf cp cf uf co fp mcc +mcleanimports :: BWCmd +mcleanimports = CleanImports tf cp cf uf co fp formatF mcc moutline :: BWCmd moutline = Outline tf cp cf uf co fp mcc mtokenTypes :: BWCmd @@ -112,19 +124,21 @@ mnamesInScope :: BWCmd mnamesInScope=NamesInScope tf cp cf uf co fp mcc mdependencies :: BWCmd -mdependencies=Dependencies tf cp cf uf co +mdependencies=Dependencies tf cp cf uf co sd mcomponents :: BWCmd mcomponents=Components tf cp cf uf co mgenerateUsage :: BWCmd mgenerateUsage=GenerateUsage tf cp cf uf co ra cc +mclean :: BWCmd +mclean=Clean tf cp cf uf co (def &= help "delete everything or only generated files" &= name "everything") -- | main method for command handling cmdMain :: IO () cmdMain = cmdArgs (modes [msynchronize, msynchronize1, mconfigure, mwrite, mbuild, mbuild1, - mgetbf, moutline, mtokenTypes, moccurrences, mthingAtPoint, mlocals, - mnamesInScope, mdependencies, mcomponents, mgenerateUsage] + mgetbf,mcleanimports, moutline, mtokenTypes, moccurrences, mthingAtPoint, mlocals, + mnamesInScope, mdependencies, mcomponents, mgenerateUsage,mclean] &= helpArg [explicit, name "help", name "h"] &= help "buildwrapper executable" &= program "buildwrapper" @@ -138,17 +152,21 @@ handle c@Write{file=fi,contents=s}=runCmd c (write fi s) handle c@Configure{cabalTarget=w}=runCmd c (configure w) handle c@Build{verbosity=ve,output=o,cabalTarget=w}=runCmdV ve c (build o w) - handle c@Build1{file=fi,component=mcomp}=runCmd c (build1 fi mcomp) + handle c@Build1{file=fi,component=mcomp}=if longRunning c + then runCmd c $ build1LongRunning fi mcomp + else runCmd c $ build1 fi mcomp handle c@GetBuildFlags{file=fi,component=mcomp}=runCmd c (getBuildFlags fi mcomp) + handle c@CleanImports{file=fi,format=fo,component=mcomp}=runCmd c (cleanImports fi fo mcomp) handle c@Outline{file=fi,component=mcomp}=runCmd c (getOutline fi mcomp) handle c@TokenTypes{file=fi}=runCmd c (getTokenTypes fi) 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@NamesInScope{file=fi,component=mcomp}=runCmd c (getNamesInScope fi mcomp) - handle c@Dependencies{}=runCmd c getCabalDependencies + 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) runCmd :: (ToJSON a) => BWCmd -> StateT BuildWrapperState IO a -> IO () runCmd=runCmdV Normal runCmdV:: (ToJSON a) => Verbosity -> BWCmd -> StateT BuildWrapperState IO a -> IO () 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 @@ -44,12 +44,7 @@ import Outputable (ppr) import Data.Foldable (foldrM) ---import qualified MonadUtils as GMU - - - - -- | copy all files from the project to the temporary folder synchronize :: Bool -- ^ if true copy all files, if false only copy files newer than their corresponding temp files -> BuildWrapper(OpResult ([FilePath],[FilePath])) -- ^ return the list of files copied, the list of files deleted @@ -289,9 +284,14 @@ -- | build one source file in GHC build1 :: FilePath -- ^ the source file -> Maybe String -- ^ the cabal component to use, or Nothing if not specified - -> BuildWrapper (OpResult (Maybe [NameDef])) -- ^ True if build is successful + -> BuildWrapper (OpResult (Maybe [NameDef])) -- ^ Just names in scope if build is successful build1 fp mccn=withGHCAST' fp mccn BwGHC.getGhcNameDefsInScope +-- | build one source file in GHC +build1LongRunning :: FilePath -- ^ the source file + -> Maybe String -- ^ the cabal component to use, or Nothing if not specified + -> BuildWrapper (OpResult (Maybe ())) -- ^ True if build is successful +build1LongRunning fp mccn=withGHCAST fp mccn BwGHC.getGhcNameDefsInScopeLongRunning -- | preprocess a file preproc :: BuildFlags -- ^ the build flags @@ -490,9 +490,41 @@ getNamesInScope fp mccn=withGHCAST fp mccn BwGHC.getGhcNamesInScope -- | get cabal dependencies -getCabalDependencies :: BuildWrapper (OpResult [(FilePath,[CabalPackage])]) -getCabalDependencies = cabalDependencies +getCabalDependencies :: FilePath -> BuildWrapper (OpResult [(FilePath,[CabalPackage])]) +getCabalDependencies fp=do + msd<-case fp of + ""-> return Nothing + _-> liftM Just $ getFullSrc fp + cabalDependencies msd -- | get cabal components getCabalComponents :: BuildWrapper (OpResult [CabalComponent]) getCabalComponents = cabalComponents + +-- | clean imports in a source file +cleanImports :: FilePath -- ^ the source file + -> Bool -- ^ format? + -> Maybe String -- ^ the cabal component to use, or Nothing if not specified + -> BuildWrapper (OpResult [ImportClean]) +cleanImports fp doFormat mccn=do + (bf,ns)<-getBuildFlags fp mccn + case bf of + (BuildFlags opts _ (Just modS) _)-> do + tgt<-getTargetPath fp + temp<-getFullTempDir + liftIO $ do + cd<-getCurrentDirectory + setCurrentDirectory temp + (m,bwns2)<-BwGHC.ghcCleanImports tgt temp modS opts doFormat + setCurrentDirectory cd + return (m,ns ++ bwns2) + _ -> return ([],ns) + +clean :: Bool -- ^ everything? + -> BuildWrapper Bool +clean everything=do + if everything + then deleteTemp + else deleteGenerated + return everything + 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 @@ -539,7 +539,7 @@ { ccTestName :: String -- ^ test suite name , ccBuildable :: Bool -- ^ is the test suite buildable } -- ^ test suite - deriving (Eq, Show, Read) + deriving (Eq, Show, Read,Ord) instance ToJSON CabalComponent where toJSON (CCLibrary b)= object ["Library" .= b] @@ -581,6 +581,41 @@ v .: "m" parseJSON _= mzero +--data ImportClean=ImportClean { +-- imports :: DM.Map Int T.Text +-- } +-- deriving (Show,Read) +-- +--instance ToJSON ImportClean where +-- toJSON (ImportClean i)=object["i" .= (map (\(k,v)->toJSON $ object ["l" .= k,"t" .= v]) $ DM.assocs i)] +-- +--instance FromJSON ImportClean where +-- parseJSON (Object v)| Just (Array m) <- M.lookup "i" v =do +-- is<-foldrM f DM.empty m +-- return $ ImportClean is +-- where +-- f :: Value -> DM.Map Int T.Text -> Parser (DM.Map Int T.Text) +-- f (Object v2) m | +-- Just l<- M.lookup "l" v2, +-- Just t<- M.lookup "t" v2=DM.insert <$> parseJSON l <*> parseJSON t <*> return m +-- f _ m=return m +-- parseJSON _= mzero + +data ImportClean = ImportClean { + icSpan :: InFileSpan, + icText :: T.Text + } + deriving (Show,Read,Eq,Ord) + +instance ToJSON ImportClean where + toJSON (ImportClean sp txt)=object ["l" .= sp, "t" .= txt] + +instance FromJSON ImportClean where + parseJSON (Object v)=ImportClean <$> + v .: "l" <*> + v .: "t" + parseJSON _=mzero + data LoadContents = SingleFile { lmFile :: FilePath ,lmModule :: String @@ -610,6 +645,23 @@ return (concat paths) else return [] +-- | http://book.realworldhaskell.org/read/io-case-study-a-library-for-searching-the-filesystem.html +getRecursiveContentsHidden :: FilePath -> IO [FilePath] +getRecursiveContentsHidden topdir = do + ex<-doesDirectoryExist topdir + if ex + then do + names <- getDirectoryContents topdir + let properNames = filter (not . flip elem [".",".."]) names + paths <- forM properNames $ \name -> do + let path = topdir name + isDirectory <- doesDirectoryExist path + if isDirectory + then getRecursiveContentsHidden path + else return [path] + return (concat paths) + else return [] + -- | delete files in temp folder but not in real folder anymore deleteGhosts :: [FilePath] -> BuildWrapper [FilePath] deleteGhosts copied=do @@ -623,7 +675,9 @@ deleteIfGhost :: FilePath -> FilePath -> S.Set FilePath -> FilePath -> IO (Maybe FilePath) deleteIfGhost rt tmp cs f=do let rel=makeRelative tmp f - if "dist" `isPrefixOf` rel || S.member rel cs + let cabalDist="dist" + let cabalDevDist="cabal-dev" + if cabalDist `isPrefixOf` rel || cabalDevDist `isPrefixOf` rel || S.member rel cs then return Nothing else do let fullSrc=rt rel @@ -633,6 +687,25 @@ else do removeFile (tmp f) return $ Just rel + +deleteTemp :: BuildWrapper() +deleteTemp = do + temp<-getFullTempDir + liftIO $ removeDirectoryRecursive temp + +deleteGenerated :: BuildWrapper() +deleteGenerated = do + temp<-getFullTempDir + fs<-liftIO $ getRecursiveContentsHidden temp + liftIO $ mapM_ deleteIfGenerated fs + where + deleteIfGenerated :: FilePath -> IO() + deleteIfGenerated f=do + let del=case takeExtension f of + ".bwinfo"->True + ".bwusage"->True + _->False + when del (removeFile f) -- | debug method: fromJust with a message to display when we get Nothing fromJustDebug :: String -> Maybe a -> 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 @@ -29,6 +29,7 @@ #endif import qualified Data.Map as DM +import qualified Data.Set as DS import Exception (ghandle) @@ -96,7 +97,7 @@ cf<-getCabalFile srcOrTgt cp<-gets cabalPath v<-cabalV - + copts<-gets cabalOpts let args=[ "build", "--verbose=" ++ show (fromEnum v), @@ -105,8 +106,9 @@ ] ++ (if output then [] else ["--ghc-option=-c"]) - + ++ copts liftIO $ do + -- print args cd<-getCurrentDirectory setCurrentDirectory (takeDirectory cf) (ex,out,err)<-readProcessWithExitCode cp args "" @@ -155,6 +157,7 @@ ++ (if null uf then [] else ["--flags="++uf]) ++ copts liftIO $ do + -- print args cd<-getCurrentDirectory setCurrentDirectory (takeDirectory cf) (ex,_,err)<-readProcessWithExitCode cp args "" @@ -518,9 +521,10 @@ allF<-liftIO $ getRecursiveContents fullFP tf<-gets tempFolder let cabalDist=takeDirectory tf "dist" + let cabalDevDist=takeDirectory tf "cabal-dev" -- exclude every file containing the temp folder name (".buildwrapper" by default) -- which may happen if . is a source path - let notMyself=filter (not . isInfixOf cabalDist) $ filter (not . isInfixOf tf) allF + 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 @@ -588,15 +592,22 @@ return (fromMaybe [] rs,ns) -- | get all the dependencies in the cabal file -cabalDependencies :: 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 = do +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 $ ghandle (\ (e :: IOError) -> do print e return []) $ - do pkgs <- liftIO getPkgInfos + do + pkgs <- liftIO $ getPkgInfos msandbox + --let m=cabalComponentsDependencies (localPkgDescr lbi) + --print m + --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 (fromMaybe [] rs,ns) @@ -607,9 +618,10 @@ -> [(FilePath,[CabalPackage])] -- ^ the referenced packages, by package database location dependencies pd pkgs=let pkgsMap=foldr buildPkgMap DM.empty pkgs -- build the map of package by name with ordered version (more recent first) - allC= cabalComponentsFromDescription pd - gdeps=PD.buildDepends pd - cpkgs=concat $ DM.elems $ DM.map (\ipis->getDep allC ipis gdeps []) pkgsMap + -- allC= cabalComponentsFromDescription pd + compDeps=cabalComponentsDependencies pd + -- gdeps=PD.buildDepends pd + cpkgs=concat $ DM.elems $ DM.map (\ipis->getDep compDeps ipis []) pkgsMap in DM.assocs $ DM.fromListWith (++) (map (\ (a, b) -> (a, [b])) cpkgs ++ map (\ (a, _) -> (a, [])) pkgs) @@ -623,14 +635,23 @@ Just l->sortBy (flip (comparing (pkgVersion . sourcePackageId . snd))) ((fp,i):l) in DM.insert key newvals dm ) m ipis - getDep :: [CabalComponent] -> [(FilePath,InstalledPackageInfo)] -> [Dependency]-> [(FilePath,CabalPackage)] -> [(FilePath,CabalPackage)] - getDep _ [] _ acc= acc - getDep allC ((fp,InstalledPackageInfo{sourcePackageId=i,exposed=e,IPI.exposedModules=ems,IPI.hiddenModules=hms}):xs) deps acc= let - (ds,deps2)=partition (\(Dependency n v)->(pkgName i == n) && withinRange (pkgVersion i) v) deps -- find if version is referenced, remove the referencing component so that it doesn't match an older version - cps=if null ds then [] else allC + getDep :: DM.Map CabalComponent [Dependency] -> [(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 + --(ds,deps2)=partition (\(Dependency n v)->(pkgName i == n) && withinRange (pkgVersion i) v) deps -- find if version is referenced, remove the referencing component so that it doesn't match an older version + cps=DS.elems s + --if null ds then [] else allC + --filter (\c->not $ null ((PD.targetBuildDepends c) `intersect` ds)) allC mns=map display (ems++hms) - in getDep allC xs deps2 ((fp,CabalPackage (display $ pkgName i) (display $ pkgVersion i) e cps mns): acc) -- build CabalPackage structure - + 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,deps2)=partition (\(Dependency n v)->(pkgName pkgId == n) && withinRange (pkgVersion pkgId) v) deps + s'=if null ds + then s + else DS.insert comp s + m'=DM.insertWith (++) comp deps m + in (s',m') -- | get all components from the package description cabalComponentsFromDescription :: PD.PackageDescription -- ^ the package description @@ -640,6 +661,18 @@ 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 + where mapDep cc bi=DM.fromList $ map (\x->(cc)) (PD.targetBuildDepends bi) + + cabalComponentFromLibrary :: Library -> CabalComponent cabalComponentFromLibrary =CCLibrary . PD.buildable . PD.libBuildInfo 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 @@ -26,7 +26,12 @@ import Data.Ord (comparing) import qualified Data.Text as T import qualified Data.Map as DM +import qualified Data.Set as DS +import qualified Data.HashMap.Lazy as HM +import qualified Data.ByteString.Lazy as BS +import qualified Data.ByteString.Lazy.Char8 as BSC + import DynFlags #if __GLASGOW_HASKELL__ > 704 import ErrUtils ( ErrMsg(..), WarnMsg, mkPlainErrMsg,Messages,ErrorMessages,WarningMessages,MsgDoc) @@ -37,7 +42,7 @@ import GHC.Paths ( libdir ) import HscTypes ( srcErrorMessages, SourceError, GhcApiError) import Outputable -import FastString (FastString,unpackFS,concatFS,fsLit,mkFastString) +import FastString (FastString,unpackFS,concatFS,fsLit,mkFastString, lengthFS) import Lexer hiding (loc) import Bag @@ -55,7 +60,13 @@ import Name (isTyVarName,isDataConName,isVarName,isTyConName) import Var (varType) import PprTyThing (pprTypeForUser) -import Control.Monad (when) +import Control.Monad (when, liftM, unless) +import qualified Data.Vector as V (foldr) +import Module (moduleNameFS) +-- import System.Time (getClockTime, diffClockTimes, timeDiffToString) +import System.IO (hFlush, stdout) +import System.Directory (getModificationTime) +import System.Time (ClockTime(TOD)) type GHCApplyFunction a=FilePath -> TypecheckedModule -> Ghc a @@ -107,7 +118,31 @@ -> LoadContents -- ^ what to load -> [String] -- ^ the GHC options -> IO (OpResult [a]) -withASTNotes f ff base_dir contents options=do +withASTNotes f ff base_dir contents options=initGHC (ghcWithASTNotes f ff base_dir contents True) options + +-- 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 + +initGHC :: Ghc a + -> [String] -- ^ the GHC options + -> IO a +initGHC f options= 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 @@ -117,25 +152,39 @@ flg <- getSessionDynFlags (flg', _, _) <- parseDynamicFlags flg _leftovers GHC.defaultCleanupHandler flg' $ do - ref <- GMU.liftIO $ newIORef [] -- 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} + f + +ghcWithASTNotes :: + GHCApplyFunction a -- ^ the final action to perform on the result + -> (FilePath -> FilePath) -- ^ transform given file path to find bwinfo path + -> FilePath -- ^ the base directory + -> LoadContents -- ^ what to load + -> Bool -- ^ add the target? + -> Ghc (OpResult [a]) +ghcWithASTNotes f ff base_dir contents shouldAddTargets= do + ref <- GMU.liftIO $ newIORef [] + cflg <- getSessionDynFlags #if __GLASGOW_HASKELL__ > 704 - setSessionDynFlags flg' {hscTarget = HscInterpreted, ghcLink = NoLink , ghcMode = CompManager, log_action = logAction ref } + setSessionDynFlags cflg {log_action = logAction ref } #else - setSessionDynFlags flg' {hscTarget = HscInterpreted, ghcLink = NoLink , ghcMode = CompManager, log_action = logAction ref flg' } + setSessionDynFlags cflg {log_action = logAction ref cflg } #endif -- $ dopt_set (flg' { ghcLink = NoLink , ghcMode = CompManager }) Opt_ForceRecomp let fps=getLoadFiles contents - mapM_ (\(fp,_)-> addTarget Target { targetId = TargetFile fp Nothing, targetAllowObjCode = True, targetContents = Nothing }) fps + when shouldAddTargets + (mapM_ (\(fp,_)-> addTarget Target { targetId = TargetFile fp Nothing, targetAllowObjCode = False, targetContents = Nothing }) fps) --c1<-GMU.liftIO getClockTime - let howMuch=case contents of - SingleFile{lmModule=m}->LoadUpTo $ mkModuleName m - MultipleFile{}->LoadAllTargets +-- let howMuch=case contents of +-- SingleFile{lmModule=m}->LoadUpTo $ mkModuleName m +-- MultipleFile{}->LoadAllTargets + let howMuch=LoadAllTargets -- GMU.liftIO $ putStrLn "Loading..." load howMuch `gcatch` (\(e :: SourceError) -> handle_error ref e) @@ -175,7 +224,7 @@ processError MultipleFile{} "Module not part of module graph"=False -- we ignore the error when we process several files and some we can't find processError _ _=True - + workOnResult :: GHCApplyFunction a -> FilePath -> ModSummary -> Ghc a workOnResult f2 fp modSum= do p <- parseModule modSum @@ -270,36 +319,78 @@ -> [String] -- ^ build options -> IO (OpResult (Maybe [NameDef])) getGhcNameDefsInScope fp base_dir modul options=do + -- c0<-getClockTime (nns,ns)<-withASTNotes (\_ _->do - --c1<-GMU.liftIO getClockTime - --GMU.liftIO $ putStrLn "getGhcNameDefsInScope" + -- c1<-GMU.liftIO getClockTime + -- GMU.liftIO $ putStrLn "getGhcNameDefsInScope" names<-getNamesInScope - --c2<-GMU.liftIO getClockTime - --GMU.liftIO $ putStrLn ("getNamesInScope: " ++ (timeDiffToString $ diffClockTimes c2 c1)) - mapM name2nd names) id base_dir (SingleFile fp modul) options + df<-getSessionDynFlags + -- c2<-GMU.liftIO getClockTime + -- GMU.liftIO $ putStrLn ("getNamesInScope: " ++ (timeDiffToString $ diffClockTimes c2 c1)) + mapM (name2nd df) names) id base_dir (SingleFile fp modul) options + -- c4<-getClockTime + -- putStrLn ("getNamesInScopeAll: " ++ (timeDiffToString $ diffClockTimes c4 c0)) return $ case nns of (x:_)->(Just x,ns) _->(Nothing, ns) - where name2nd :: GhcMonad m=> Name -> m NameDef - name2nd n=do - m<- getInfo n - df<-getSessionDynFlags - let ty=case m of - Just (tyt,_,_)->ty2t df tyt - Nothing->Nothing - return $ NameDef (T.pack $ showSDDump df $ ppr n) (name2t n) ty +-- | get all names in scope, packaged in NameDefs +getGhcNameDefsInScopeLongRunning :: FilePath -- ^ source path + -> FilePath -- ^ base directory + -> String -- ^ module name + -> [String] -- ^ build options + -> IO () +getGhcNameDefsInScopeLongRunning fp base_dir modul options=do + initGHC (go (TOD 0 0)) options + where + go :: ClockTime -> Ghc () + go t1 = do + t2<- GMU.liftIO $ getModificationTime fp + let hasLoaded=case t1 of + TOD 0 _ -> False + _ -> True + (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 + removeTarget (TargetFile fp Nothing) + load LoadAllTargets + return ([],True) + ) `gcatch` (\(e :: SourceError) -> do + let errs = srcErrorMessages e + df <- getSessionDynFlags + return (ghcMessagesToNotes df base_dir (emptyBag, errs),True) + ) + else return ([],not hasLoaded) + (nns,ns)<- ghcWithASTNotes (\_ _->do + names<-getNamesInScope + df<-getSessionDynFlags + mapM (name2nd df) names) id base_dir (SingleFile fp modul) add2 + let res=case nns of + (x:_) -> (Just x,ns1 ++ ns) + _ -> (Nothing,ns1 ++ ns) + GMU.liftIO $ BSC.putStrLn $ BS.append "build-wrapper-json:" $ encode res + GMU.liftIO $ hFlush stdout + l<- GMU.liftIO getLine + unless ("q" == l) (go t2) + +name2nd :: GhcMonad m=> DynFlags -> Name -> m NameDef +name2nd df n=do + m<- getInfo n + let ty=case m of + Just (tyt,_,_)->ty2t tyt + Nothing->Nothing + return $ NameDef (T.pack $ showSDDump df $ ppr n) (name2t n) ty + where name2t :: Name -> [OutlineDefType] - name2t n - | isTyVarName n=[Type] - | isTyConName n=[Type] - | isDataConName n = [Constructor] - | isVarName n = [Function] + name2t n2 + | isTyVarName n2=[Type] + | isTyConName n2=[Type] + | isDataConName n2 = [Constructor] + | isVarName n2 = [Function] | otherwise =[] - ty2t :: DynFlags -> TyThing -> Maybe T.Text - ty2t df (AnId aid)=Just $ T.pack $ showSD False df $ pprTypeForUser True $ varType aid - ty2t df (ADataCon dc)=Just $ T.pack $ showSD False df $ pprTypeForUser True $ dataConUserType dc - ty2t _ _ = Nothing + ty2t :: TyThing -> Maybe T.Text + ty2t (AnId aid)=Just $ T.pack $ showSD False df $ pprTypeForUser True $ varType aid + 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 @@ -330,7 +421,7 @@ -> FilePath -- ^ base directory -> String -- ^ module name -> [String] -- ^ build flags - -> IO ([ThingAtPoint]) + -> IO [ThingAtPoint] getLocalsJSON sline scol eline ecol fp base_dir modul options= do mmf<-withJSONAST (\v->do let cont=contains sline (scionColToGhcCol scol) eline (scionColToGhcCol ecol) @@ -419,9 +510,11 @@ #else let dflags1 = List.foldl' dopt_set flg' lexerFlags #endif - let prTS = lexTokenStream sb lexLoc dflags1 + let prTS = lexTokenStreamH sb lexLoc dflags1 case prTS of - POk _ toks -> return $ Right $ filter ofInterest toks + POk _ toks -> do + -- GMU.liftIO $ print $ map (show . unLoc) toks + return $ Right $ filter ofInterest toks PFailed loc msg -> return $ Left $ ghcErrMsgToNote dflags1 base_dir $ #if __GLASGOW_HASKELL__ < 706 mkPlainErrMsg loc msg @@ -429,7 +522,18 @@ mkPlainErrMsg dflags1 loc msg #endif +-- | like lexTokenStream, but keep Haddock flag +lexTokenStreamH :: StringBuffer -> RealSrcLoc -> DynFlags -> ParseResult [Located Token] +lexTokenStreamH buf loc dflags = unP go initState + where dflags' = dopt_set (dopt_set dflags Opt_KeepRawTokenStream) Opt_Haddock + initState = mkPState dflags' buf loc + go = do + ltok <- lexer return + case ltok of + L _ ITeof -> return [] + _ -> liftM (ltok:) go + #if __GLASGOW_HASKELL__ < 702 lexLoc :: SrcLoc lexLoc = mkSrcLoc (mkFastString "") 1 (scionColToGhcCol 1) @@ -457,9 +561,6 @@ , Opt_ImplicitParams , Opt_BangPatterns , Opt_TypeFamilies -#if __GLASGOW_HASKELL__ < 700 - , Opt_Haddock -#endif , Opt_MagicHash , Opt_KindSignatures , Opt_RecursiveDo @@ -523,6 +624,7 @@ -> IO (Either BWNote a) generateTokens projectRoot contents literate options xform filterFunc =do let (ppTs, ppC) = preprocessSource contents literate + -- putStrLn ppC result<- ghctokensArbitrary projectRoot ppC options case result of Right toks ->do @@ -549,7 +651,7 @@ ppSCpp (ts2,l2,f) (l,c) | (Continue _)<-f = addPPToken "PP" (l,c) (ts2,l2,lineBehavior l f) | ('#':_)<-l =addPPToken "PP" (l,c) (ts2,l2,lineBehavior l f) - | "{-# " `List.isPrefixOf` l=addPPToken "D" (l,c) (ts2,"":l2,f) + | "{-# " `List.isPrefixOf` l=addPPToken "P" (l,c) (ts2,"":l2,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) @@ -750,13 +852,13 @@ tokenType (ITvarid {})="IV" -- identifiers tokenType (ITconid {})="IC" -tokenType (ITvarsym {})="IV" +tokenType (ITvarsym {})="VS" tokenType (ITconsym {})="IC" tokenType (ITqvarid {})="IV" tokenType (ITqconid {})="IC" -tokenType (ITqvarsym {})="IV" +tokenType (ITqvarsym {})="VS" tokenType (ITqconsym {})="IC" -tokenType (ITprefixqvarsym {})="IV" +tokenType (ITprefixqvarsym {})="VS" tokenType (ITprefixqconsym {})="IC" tokenType (ITdupipvarid {})="EI" -- GHC extension: implicit param: ?x @@ -812,8 +914,8 @@ tokenType (ITdocSection {})="D" -- a section heading tokenType (ITdocOptions {})="D" -- doc options (prune, ignore-exports, etc) tokenType (ITdocOptionsOld {})="D" -- doc options declared "-- # ..."-style -tokenType (ITlineComment {})="D" -- comment starting by "--" -tokenType (ITblockComment {})="D" -- comment in {- -} +tokenType (ITlineComment {})="C" -- comment starting by "--" +tokenType (ITblockComment {})="C" -- comment in {- -} -- 7.2 new token types #if __GLASGOW_HASKELL__ >= 702 @@ -918,7 +1020,6 @@ let realModus=fromMaybe [modu] (DM.lookup modu moduMap) mapM (\modu2->do pkg<-lookupModule modu2 Nothing - df<-getSessionDynFlags let tpkg=T.pack $ showSD True df $ ppr $ modulePackageId pkg let tmod=T.pack $ showSD True df $ ppr modu2 return (tpkg,tmod) @@ -932,7 +1033,44 @@ 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 - + +type ImportMap=DM.Map T.Text (LImportDecl Name,[T.Text]) + +ghcImportMap :: LImportDecl Name -> Ghc ImportMap +ghcImportMap l@(L _ imp)=(do + let L _ modu=ideclName imp + let moduS=T.pack $ moduleNameString modu + --GMU.liftIO $ putStrLn $ show moduS + let mm=DM.singleton moduS (l,[]) + m<-lookupModule modu Nothing + mmi<-getModuleInfo m + df <- getSessionDynFlags + let maybeHiding=ideclHiding imp + let hidden=case maybeHiding of + Just(True,ns)->map (T.pack . showSD False df . ppr . unLoc) ns + _ ->[] + let fullM =case mmi of + Nothing -> mm + Just mi->let + exps=modInfoExports mi + -- extExps=filter (\x->(nameModule x) /= m) exps + in foldr insertImport mm exps + where insertImport :: Name -> ImportMap -> ImportMap + insertImport x mmx= + let + expM=T.pack $ moduleNameString $ moduleName $ nameModule x + nT=T.pack $ showSD False df $ ppr x + in if nT `elem` hidden + 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 + else fullM + ) + `gcatch` (\(se :: SourceError) -> do + GMU.liftIO $ print se + return DM.empty) + --getGHCOutline :: ParsedSource -- -> [OutlineDef] --getGHCOutline (L src mod)=concatMap ldeclOutline (hsmodDecls mod) @@ -957,5 +1095,142 @@ -- commentDecl (Just st)=Just $ T.pack $ showSDoc $ ppr st -- commentDecl _=Nothing -- ghcSpanToLocation - - + +-- | module, function/type, constructors +type TypeMap=DM.Map T.Text (DM.Map T.Text (DS.Set T.Text)) +type FinalImportValue=(LImportDecl Name,DM.Map T.Text (DS.Set T.Text)) +type FinalImportMap=DM.Map T.Text FinalImportValue + + +-- | clean imports +ghcCleanImports :: FilePath -- ^ source path + -> FilePath -- ^ base directory + -> String -- ^ module name + -> [String] -- ^ build options + -> Bool -- ^ format? + -> IO (OpResult [ImportClean]) +ghcCleanImports f base_dir modul options doFormat = do + (m,bwns)<-withASTNotes clean (base_dir ) base_dir (SingleFile f modul) options + return (if null m then [] else head m,bwns) + where + -- | main clean method: get the usage, the existing imports, and retrieve only the needed names for each import + clean :: GHCApplyFunction [ImportClean] + clean _ tm=do + let (_,imps,_,_)=fromJust $ tm_renamed_source tm + df <- getSessionDynFlags + let modu=T.pack $ showSD True df $ ppr $ moduleName $ ms_mod $ pm_mod_summary $ tm_parsed_module tm + let (Array vs)= generateGHCInfo df tm + impMaps<-mapM ghcImportMap imps + -- let impMap=DM.unions 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 implicit + let usgMap=V.foldr ghcValToUsgMap DM.empty vs + let usgMapWithoutMe=DM.delete modu usgMap + -- GMU.liftIO $ print usgMapWithoutMe + -- GMU.liftIO $ putStrLn $ show $ usgMapWithoutMe + --let ics=foldr (buildImportClean usgMapWithoutMe df) [] (DM.assocs impMap) + let ftm=foldr (buildImportCleanMap usgMapWithoutMe implicit) DM.empty allImps + + let missingCleans=getRemovedImports allImps ftm + let formatF=if doFormat then formatImports else map (dumpImportMap df) + -- GMU.liftIO $ putStrLn $ show $ DM.keys ftm + let allCleans=formatF (DM.elems ftm) ++ missingCleans + return allCleans + -- | all used names by module + ghcValToUsgMap :: Value -> TypeMap -> TypeMap + ghcValToUsgMap (Object m) um | + Just (String n)<-HM.lookup "Name" m, + Just (String mo)<-HM.lookup "Module" m, + not $ T.null mo, -- ignore local objects + mst<-HM.lookup "Type" m, + Just (String ht)<-HM.lookup "HType" m + =let + mm=DM.lookup mo um + isType=ht=="t" + isConstructor=not isType && isUpper (T.head n) && isJust mst + key=if isConstructor + then let + Just (String t)=mst + in fst $ T.breakOn " " $ T.strip $ snd $ T.breakOnEnd "->" t + else n + val=if isConstructor + then DS.singleton n + else DS.empty + in case mm of + Just usgM1->DM.insert mo (DM.insertWith DS.union key val usgM1) um + Nothing->DM.insert mo (DM.singleton key val) um + ghcValToUsgMap _ um=um + -- | reconcile the usage map and the import to generate the final import map: module -> names to import + buildImportCleanMap :: TypeMap -> DS.Set T.Text ->(T.Text,(LImportDecl Name,[T.Text])) -> FinalImportMap -> FinalImportMap + buildImportCleanMap usgMap implicit (cmod,(l@(L _ imp),ns)) tm | + Just namesMap<-DM.lookup cmod usgMap, -- used names for module + namesMapFiltered<-foldr (keepKeys namesMap) DM.empty ns, -- only names really exported by the import name + namesWithoutImplicit<-if ideclQualified imp + then namesMapFiltered + else DM.map (`DS.difference` implicit) $ foldr DM.delete namesMapFiltered $ DS.elems implicit, + not $ DM.null namesWithoutImplicit, + not $ ideclImplicit imp = let -- ignore implicit prelude + L _ modu=ideclName imp + moduS=T.pack $ moduleNameString modu + in DM.insertWith mergeTypeMap moduS (l,namesWithoutImplicit) tm + buildImportCleanMap _ _ _ tm = tm + -- | copy the key and value from one map to the other + keepKeys :: Ord k => DM.Map k v -> k -> DM.Map k v -> DM.Map k v + keepKeys m1 k m2=case DM.lookup k m1 of + Nothing -> m2 + Just v1->DM.insert k v1 m2 + -- | merge the map containing the set of names + mergeTypeMap :: FinalImportValue -> FinalImportValue -> FinalImportValue + mergeTypeMap (l1,m1) (_,m2)= (l1,DM.unionWith DS.union m1 m2) + -- | generate final import string from names map + dumpImportMap :: DynFlags -> FinalImportValue -> ImportClean + dumpImportMap df (L loc imp,ns)=let + txt= T.pack $ showSDDump df $ ppr (imp{ideclHiding=Nothing} :: ImportDecl Name) -- rely on GHC for the initial bit of the import, without the names + nameList= T.intercalate ", " $ List.sortBy (comparing T.toLower) $ map buildName $ DM.assocs ns -- build explicit import list + full=txt `mappend` " (" `mappend` nameList `mappend` ")" + in ImportClean (ghcSpanToLocation loc) full + pprName :: T.Text -> T.Text + pprName n | T.null n =n + | isAlpha $ T.head n=n + | otherwise=T.concat ["(",n,")"] + -- build the name with the constructors list if any + buildName :: (T.Text,DS.Set T.Text)->T.Text + buildName (n,cs) + | 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` ")" + 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 + missingImps=filter (\(_,(L l imp,_))->not $ ideclImplicit imp || DS.member (iflLine $ifsStart $ ghcSpanToLocation l) cleanedLines) allImps + in nubOrd $ map (\(_,(L l _,_))-> ImportClean (ghcSpanToLocation l) "") missingImps + getFormatInfo :: FinalImportValue -> (Int,Int,Int,Int,Int)->(Int,Int,Int,Int,Int) + getFormatInfo (L _ imp,_) (szSafe,szQualified,szPkg,szName,szAs)=let + szSafe2=if ideclSafe imp then 5 else szSafe + szQualified2=if ideclQualified imp then 10 else szQualified + szPkg2=maybe szPkg (\p->max szPkg (3 + lengthFS p)) $ ideclPkgQual imp + L _ mo=ideclName imp + szName2=max szName (1 + lengthFS (moduleNameFS mo)) + szAs2=maybe szAs (\m->max szAs (3 + lengthFS (moduleNameFS m))) $ ideclAs imp + in (szSafe2,szQualified2,szPkg2,szName2,szAs2) + formatImport :: (Int,Int,Int,Int,Int)-> FinalImportValue -> ImportClean + formatImport (szSafe,szQualified,szPkg,szName,szAs) (L loc imp,ns) =let + st="import " + saf=if ideclSafe imp then "safe " else T.justifyLeft szSafe ' ' "" + qual=if ideclQualified imp then "qualified " else T.justifyLeft szQualified ' ' "" + pkg=maybe (T.justifyLeft szPkg ' ' "") (\p->"\"" `mappend` T.pack (unpackFS p) `mappend` "\" ") $ ideclPkgQual imp + L _ mo=ideclName imp + nm=T.justifyLeft szName ' ' $ T.pack $ moduleNameString mo + ast=maybe (T.justifyLeft szAs ' ' "") (\m->"as " `mappend` T.pack (moduleNameString m)) $ ideclAs imp + nameList= T.intercalate ", " $ List.sortBy (comparing T.toLower) $ map buildName $ DM.assocs ns -- build explicit import list + full=st `mappend` saf `mappend` qual `mappend` pkg `mappend` nm `mappend` ast `mappend` " (" `mappend` nameList `mappend` ")" + in ImportClean (ghcSpanToLocation loc) full + formatImports :: [FinalImportValue] -> [ImportClean] + formatImports fivs = let + formatInfo=foldr getFormatInfo (0,0,0,0,0) fivs + in map (formatImport formatInfo) fivs + + 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 @@ -46,8 +46,9 @@ -- | Fetch the installed package info from the global and user package.conf -- databases, mimicking the functionality of ghc-pkg. -getPkgInfos :: IO InstalledPackagesList -getPkgInfos = +getPkgInfos :: Maybe FilePath -- ^ the path to the cabal-dev sandbox if any + -> IO InstalledPackagesList +getPkgInfos msandbox= let -- | Test for package database's presence in a given directory -- NB: The directory is returned for later scanning by listConf, @@ -57,6 +58,7 @@ let path_dir = dir "package.conf.d" path_file = dir "package.conf" + path_sd_dir= dir ("packages-" ++ ghcVersion ++ ".conf") in do exists_dir <- doesDirectoryExist path_dir if exists_dir @@ -69,7 +71,13 @@ then do pkgs <- readContents (PkgFile path_file) return $ Just pkgs - else return Nothing + else do + exists_dirSd <- doesDirectoryExist path_sd_dir + if exists_dirSd + then do + pkgs <- readContents (PkgDirectory path_sd_dir) + return $ Just pkgs + else return Nothing currentArch :: String currentArch = System.Info.arch @@ -88,8 +96,10 @@ Just pkgs -> return pkgs -- Get the user package configuration database - e_appdir <- Exc.try $ getAppUserDataDirectory "ghc" - user_conf <- case e_appdir of + user_conf <- case msandbox of + Nothing -> do + e_appdir <- Exc.try $ getAppUserDataDirectory "ghc" + case e_appdir of Left (_::Exc.IOException) -> return [] Right appdir -> do let subdir @@ -99,7 +109,11 @@ case r of Nothing -> return [] Just pkgs -> return pkgs - + Just sd->do + r <- lookForPackageDBIn sd + case r of + Nothing -> return [] + Just pkgs -> return pkgs -- Process GHC_PACKAGE_PATH, if present: e_pkg_path <- Exc.try (getEnv "GHC_PACKAGE_PATH") env_stack <- case e_pkg_path of 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 @@ -38,6 +38,8 @@ import Test.Framework import Test.HUnit (Assertion) +import System.IO (Handle, hPutStrLn, hFlush) +import Control.Concurrent (threadDelay) class APIFacade a where synchronize :: a -> FilePath -> Bool -> IO (OpResult ([FilePath],[FilePath])) @@ -55,34 +57,48 @@ getThingAtPoint :: a -> FilePath -> FilePath -> Int -> Int -> IO (OpResult (Maybe ThingAtPoint)) getLocals :: a -> FilePath -> FilePath -> Int -> Int -> Int -> Int -> IO (OpResult [ThingAtPoint]) getNamesInScope :: a -> FilePath -> FilePath-> IO (OpResult (Maybe [String])) - getCabalDependencies :: a -> FilePath -> IO (OpResult [(FilePath,[CabalPackage])]) + 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) -data CMDAPI=CMDAPI +data CMDAPI=CMDAPI { + cabalExe :: String, + cabalOpts :: [String] + } -instance APIFacade CMDAPI where - synchronize _ r ff= runAPI r "synchronize" ["--force="++ show ff ] - synchronize1 _ r ff fp= runAPI r "synchronize1" ["--force="++show ff,"--file="++fp] - write _ r fp s= runAPI r "write" ["--file="++fp,"--contents="++s] - configure _ r t= runAPI r "configure" ["--cabaltarget="++ show t] - configureWithFlags _ r t fgs= runAPI r "configure" ["--cabaltarget="++ show t,"--cabalflags="++ fgs] - build _ r b wc= runAPI r "build" ["--output="++ show b,"--cabaltarget="++ show wc] - build1 _ r fp= runAPI r "build1" ["--file="++fp] - build1c _ r fp ccn= runAPI r "build1" ["--file="++fp,"--component="++ccn] - getBuildFlags _ r fp= runAPI r "getbuildflags" ["--file="++fp] - getOutline _ r fp= runAPI r "outline" ["--file="++fp] - getTokenTypes _ r fp= runAPI r "tokentypes" ["--file="++fp] - getOccurrences _ r fp s= runAPI r "occurrences" ["--file="++fp,"--token="++s] - getThingAtPoint _ r fp l c= fmap removeLayoutTAP $ runAPI r "thingatpoint" ["--file="++fp,"--line="++ show l,"--column="++ show c] - getLocals _ r fp sl sc el ec= runAPI r "locals" ["--file="++fp,"--sline="++ show sl,"--scolumn="++ show sc,"--eline="++ show el,"--ecolumn="++ show ec] - getNamesInScope _ r fp= runAPI r "namesinscope" ["--file="++fp] - getCabalDependencies _ r= runAPI r "dependencies" [] - getCabalComponents _ r= runAPI r "components" [] - generateUsage _ r retAll cc=runAPI r "generateusage" ["--returnall="++ show retAll,"--cabalcomponent="++ cabalComponentName cc] +instance APIFacade CMDAPI where + 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) + 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] + build1c (CMDAPI c _) r fp ccn= runAPI c r "build1" ["--file="++fp,"--component="++ccn] + getBuildFlags (CMDAPI c _) r fp= runAPI c r "getbuildflags" ["--file="++fp] + 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] + 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] + 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) + 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) +build1lr r fp= startAPIProcess r "build1" ["--file="++fp,"--longrunning=true"] + +cabalAPI= CMDAPI "cabal" [] + exeExtension :: String #ifdef mingw32_HOST_OS exeExtension = "exe" @@ -92,7 +108,7 @@ test_SynchronizeAll :: Assertion test_SynchronizeAll = do - let api=CMDAPI + let api=cabalAPI root<-createTestProject ((fps,dels),_)<-synchronize api root False assertBool (not $ null fps) @@ -107,7 +123,7 @@ test_SynchronizeDelete :: Assertion test_SynchronizeDelete = do - let api=CMDAPI + let api=cabalAPI root<-createTestProject ((fps0,dels0),_)<-synchronize api root False assertBool (not $ null fps0) @@ -125,7 +141,7 @@ test_SynchronizeExtraFiles :: Assertion test_SynchronizeExtraFiles = do - let api=CMDAPI + let api=cabalAPI root<-createTestProject let extra=root "src" -- need to be in hs-source-dirs writeFile (extra "a.txt") "contents" @@ -140,7 +156,7 @@ test_ConfigureErrors :: Assertion test_ConfigureErrors = do - let api=CMDAPI + let api=cabalAPI root<-createTestProject (boolNoCabal,nsNoCabal)<- configure api root Target assertBool (not boolNoCabal) @@ -230,7 +246,7 @@ test_ConfigureWarnings :: Assertion test_ConfigureWarnings = do - let api=CMDAPI + let api=cabalAPI root<-createTestProject synchronize api root False let cf=testCabalFile root @@ -288,7 +304,7 @@ test_BuildErrors :: Assertion test_BuildErrors = do - let api=CMDAPI + let api=cabalAPI root<-createTestProject synchronize api root False (boolOKc,nsOKc)<-configure api root Target @@ -340,7 +356,7 @@ test_BuildWarnings :: Assertion test_BuildWarnings = do - let api=CMDAPI + let api=cabalAPI root<-createTestProject synchronize api root False --let cf=testCabalFile root @@ -389,7 +405,7 @@ test_BuildOutput :: Assertion test_BuildOutput = do - let api=CMDAPI + let api=cabalAPI root<-createTestProject synchronize api root False build api root True Source @@ -409,7 +425,7 @@ -- | http://hackage.haskell.org/trac/ghc/ticket/7380#comment:1 : -O2 is removed from the options test_BuildO2 :: Assertion test_BuildO2 = do - let api=CMDAPI + let api=cabalAPI root<-createTestProject write api root (testProjectName <.> ".cabal") $ unlines ["name: "++testProjectName, "version:0.1", @@ -441,13 +457,13 @@ let rel="src""Main.hs" writeFile (root rel) $ unlines ["module Main where","main :: IO()","main= putStrLn \"Hello World\""] synchronize api root False - (ns, nsErrors2)<-build1 api root rel + (ns, _)<-build1 api root rel assertBool (isJust ns) test_ModuleNotInCabal :: Assertion test_ModuleNotInCabal = do - let api=CMDAPI + let api=cabalAPI root<-createTestProject synchronize api root False let rel="src""A.hs" @@ -469,7 +485,7 @@ test_Outline :: Assertion test_Outline = do - let api=CMDAPI + let api=cabalAPI root<-createTestProject synchronize api root False let rel="src""A.hs" @@ -556,7 +572,7 @@ test_OutlineComments :: Assertion test_OutlineComments= do - let api=CMDAPI + let api=cabalAPI root<-createTestProject synchronize api root False let rel="src""A.hs" @@ -626,7 +642,7 @@ test_OutlinePreproc :: Assertion test_OutlinePreproc = do - let api=CMDAPI + let api=cabalAPI root<-createTestProject synchronize api root False let rel="src""A.hs" @@ -712,7 +728,7 @@ test_OutlineLiterate :: Assertion test_OutlineLiterate = do - let api=CMDAPI + let api=cabalAPI root<-createTestProject synchronize api root False let rel="src""A.lhs" @@ -740,7 +756,7 @@ test_OutlineImportExport :: Assertion test_OutlineImportExport = do - let api=CMDAPI + let api=cabalAPI root<-createTestProject synchronize api root False let rel="src""A.hs" @@ -775,7 +791,7 @@ test_OutlineMultiParam :: Assertion test_OutlineMultiParam = do - let api=CMDAPI + let api=cabalAPI root<-createTestProject synchronize api root False let rel="src""A.hs" @@ -807,7 +823,7 @@ test_OutlineOperator :: Assertion test_OutlineOperator = do - let api=CMDAPI + let api=cabalAPI root<-createTestProject synchronize api root False let rel="src""A.hs" @@ -829,7 +845,7 @@ test_OutlinePatternGuards :: Assertion test_OutlinePatternGuards = do - let api=CMDAPI + let api=cabalAPI root<-createTestProject synchronize api root False let rel="src""A.hs" @@ -851,7 +867,7 @@ test_OutlineExtension :: Assertion test_OutlineExtension = do - let api=CMDAPI + let api=cabalAPI root<-createTestProject let cf=testCabalFile root writeFile cf $ unlines ["name: "++testProjectName, @@ -885,7 +901,7 @@ test_OutlineOptions :: Assertion test_OutlineOptions = do - let api=CMDAPI + let api=cabalAPI root<-createTestProject synchronize api root False let rel="src""A.hs" @@ -917,7 +933,7 @@ test_PreviewTokenTypes :: Assertion test_PreviewTokenTypes = do - let api=CMDAPI + let api=cabalAPI root<-createTestProject synchronize api root False configure api root Target @@ -939,13 +955,62 @@ ] (tts,nsErrors1)<-getTokenTypes api root rel assertBool (null nsErrors1) - let expectedS="[{\"D\":[1,1,37]},{\"D\":[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]},{\"IV\":[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]}]" + let expectedS="[{\"P\":[1,1,37]},{\"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) +test_PreviewTokenTypesLine :: Assertion +test_PreviewTokenTypesLine = do + let api=cabalAPI + root<-createTestProject + synchronize api root False + configure api root Target + let rel="src""Main.hs" + write api root rel $ unlines [ + "{-# LINE 42 \"Foo.vhs\" #-}", + "-- a comment", + "module Main where", + "", + "main :: IO (Int)", + "main = do" , + " putStr ('h':\"ello Prefs!\")", + " return (2 + 2)", + "", + "#if USE_TH", + "$( derive makeTypeable ''Extension )", + "#endif", + "" + ] + (tts,nsErrors1)<-getTokenTypes api root rel + 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) + +test_PreviewTokenTypesHaddock :: Assertion +test_PreviewTokenTypesHaddock = do + let api=cabalAPI + root<-createTestProject + synchronize api root False + configure api root Target + let rel="src""Main.hs" + write api root rel $ unlines [ + "{-# LINE 42 \"Foo.vhs\" #-}", + "-- | a comment", + "module Main where", + "", + "main :: IO (Int)", + "main = do" , + " putStr ('h':\"ello Prefs!\")", + " return (2 + 2)", + "" + ] + (tts,nsErrors1)<-getTokenTypes api root rel + assertBool (null nsErrors1) + let expectedS="[{\"P\":[1,1,26]},{\"D\":[2,1,15]},{\"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]}]" + assertEqual expectedS (encode $ toJSON tts) test_ThingAtPoint :: Assertion test_ThingAtPoint = do - let api=CMDAPI + let api=cabalAPI root<-createTestProject synchronize api root False configure api root Target @@ -1051,7 +1116,7 @@ test_ThingAtPointTypeReduction :: Assertion test_ThingAtPointTypeReduction = do - let api=CMDAPI + let api=cabalAPI root<-createTestProject let cf=testCabalFile root writeFile cf $ unlines ["name: "++testProjectName, @@ -1093,7 +1158,7 @@ test_ThingAtPointNotInCabal :: Assertion test_ThingAtPointNotInCabal = do - let api=CMDAPI + let api=cabalAPI root<-createTestProject synchronize api root False configure api root Target @@ -1112,7 +1177,7 @@ test_ThingAtPointMain :: Assertion test_ThingAtPointMain = do - let api=CMDAPI + let api=cabalAPI root<-createTestProject let cf=testCabalFile root writeFile cf $ unlines ["name: "++testProjectName, @@ -1154,7 +1219,7 @@ test_ThingAtPointMainSubFolder :: Assertion test_ThingAtPointMainSubFolder = do - let api=CMDAPI + let api=cabalAPI root<-createTestProject let cf=testCabalFile root writeFile cf $ unlines ["name: "++testProjectName, @@ -1189,7 +1254,7 @@ test_Locals :: Assertion test_Locals = do - let api=CMDAPI + let api=cabalAPI root<-createTestProject synchronize api root False configure api root Target @@ -1231,7 +1296,7 @@ test_NamesInScope :: Assertion test_NamesInScope = do - let api=CMDAPI + let api=cabalAPI root<-createTestProject synchronize api root False configure api root Source @@ -1257,7 +1322,7 @@ test_NameDefsInScope :: Assertion test_NameDefsInScope = do - let api=CMDAPI + let api=cabalAPI root<-createTestProject synchronize api root False configure api root Source @@ -1279,11 +1344,77 @@ assertBool (NameDef "Main.MkType1_1" [Constructor] (Just "Int -> Type1") `elem` tts) assertBool (NameDef "GHC.Types.Char" [Type] Nothing `elem` tts) - - +test_NameDefsInScopeLongRunning :: Assertion +test_NameDefsInScopeLongRunning = 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 + (inp,out,_,_)<-build1lr root rel + (mtts,ns)<-(readResult out) :: IO (OpResult (Maybe [NameDef])) + assertBool (isJust mtts) + assertBool (not $ notesInError ns) + let tts=fromJust mtts + assertBool (NameDef "Main.main" [Function] (Just "IO [Char]") `elem` tts) + assertBool (NameDef "B.D.fD" [Function] (Just "forall a. a") `elem` tts) + assertBool (NameDef "Main.Type1" [Type] Nothing `elem` tts) + assertBool (NameDef "Main.MkType1_1" [Constructor] (Just "Int -> Type1") `elem` tts) + assertBool (NameDef "GHC.Types.Char" [Type] Nothing `elem` tts) + assertBool (NameDef "Main.Type2" [Type] Nothing `notElem` tts) + threadDelay 1000000 + write api root rel $ unlines [ + "module Main where", + "import B.D", + "main=return $ map id \"toto\"", + "data Type1=MkType1_1 Int", + "data Type2=MkType2_1 Int" + ] + continue inp + (mtts2,ns2)<-readResult out :: IO (OpResult (Maybe [NameDef])) + assertBool (not $ notesInError ns2) + assertBool (isJust mtts2) + let tts2=fromJust mtts2 + assertBool (NameDef "Main.Type1" [Type] Nothing `elem` tts2) + assertBool (NameDef "Main.Type2" [Type] Nothing `elem` tts2) + write api root rel $ unlines [ + "module Main where", + "import B.D", + "main=return $ map id \"toto\"", + "data Type1=MkType1_1 Int", + "data Type2=MkType2_1 Int2" + ] + continue inp + (_,ns3)<-readResult out :: IO (OpResult (Maybe [NameDef])) + assertBool (notesInError ns3) + threadDelay 1000000 + write api root rel $ unlines [ + "module Main where", + "import B.D", + "main=return $ map id \"toto\"", + "data Type1=MkType1_1 Int", + "data Type2=MkType2_1 Int" + ] + continue inp + (mtts4,ns4)<-readResult out :: IO (OpResult (Maybe [NameDef])) + assertBool (not $ notesInError ns4) + assertBool (isJust mtts4) + let tts4=fromJust mtts4 + assertBool (NameDef "Main.Type1" [Type] Nothing `elem` tts4) + assertBool (NameDef "Main.Type2" [Type] Nothing `elem` tts4) + end inp + test_InPlaceReference :: Assertion test_InPlaceReference = do - let api=CMDAPI + let api=cabalAPI root<-createTestProject synchronize api root False writeFile (root (testProjectName <.> ".cabal")) $ unlines ["name: "++testProjectName, @@ -1357,7 +1488,7 @@ test_CabalComponents :: Assertion test_CabalComponents= do - let api=CMDAPI + let api=cabalAPI root<-createTestProject synchronize api root False (cps,nsOK)<-getCabalComponents api root @@ -1408,10 +1539,35 @@ test_CabalDependencies :: Assertion test_CabalDependencies = do - let api=CMDAPI + 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", + "", + "test-suite BWTest-test", + " type: exitcode-stdio-1.0", + " hs-source-dirs: test", + " main-is: Main.hs", + " other-modules: TestA", + " build-depends: base,filepath", + ""] synchronize api root False - (cps,nsOK)<-getCabalDependencies api root + (cps,nsOK)<-getCabalDependencies api root Nothing assertBool (null nsOK) assertEqual 2 (length cps) let [(_,pkgs1),(_,pkgs2)] = cps -- One is global and one is local, but the order depends on the paths, @@ -1422,12 +1578,15 @@ assertEqual (CCLibrary True) l assertEqual (CCExecutable "BWTest" True) ex assertEqual (CCTestSuite "BWTest-test" True) ts - + let fp=filter (\pkg->cpName pkg == "filepath") pkgs + assertEqual 1 (length fp) + let (lfp:[])=cpDependent $ head fp + assertEqual (CCTestSuite "BWTest-test" True) lfp test_NoSourceDir :: Assertion test_NoSourceDir = do - let api=CMDAPI + let api=cabalAPI root<-createTestProject let cf=testCabalFile root writeFile cf $ unlines ["name: "++testProjectName, @@ -1467,7 +1626,7 @@ test_Flags :: Assertion test_Flags = do - let api=CMDAPI + let api=cabalAPI root<-createTestProject let cf=testCabalFile root writeFile cf $ unlines ["name: "++testProjectName, @@ -1509,7 +1668,7 @@ test_BuildFlags :: Assertion test_BuildFlags =do - let api=CMDAPI + let api=cabalAPI root<-createTestProject let cf=testCabalFile root writeFile cf $ unlines ["name: "++testProjectName, @@ -1527,7 +1686,7 @@ configure api root Source let rel="src""A.hs" (flgs,nsErrors3f)<-getBuildFlags api root rel - print flgs + -- print flgs assertBool (null nsErrors3f) let ast=bfAst flgs assertBool ("-package-name" `elem` ast) @@ -1538,7 +1697,7 @@ test_ExplicitComponent :: Assertion test_ExplicitComponent =do - let api=CMDAPI + let api=cabalAPI root<-createTestProject let cf=testCabalFile root writeFile cf $ unlines ["name: "++testProjectName, @@ -1586,7 +1745,7 @@ test_ExplicitComponentUnRef :: Assertion test_ExplicitComponentUnRef =do - let api=CMDAPI + let api=cabalAPI root<-createTestProject let cf=testCabalFile root writeFile cf $ unlines ["name: "++testProjectName, @@ -1628,6 +1787,36 @@ assertBool (isNothing names3) assertBool (not $ null nsErrors3) +test_CleanFiles :: Assertion +test_CleanFiles =do + let api=cabalAPI + root<-createTestProject + synchronize api root False + let fldr=root ".dist-buildwrapper" + let file=fldr "src" ".A.hs.bwinfo" + exf1<-doesFileExist file + assertBool $ not exf1 + exd1<-doesDirectoryExist fldr + assertBool exd1 + let rel="src" "A.hs" + build1 api root rel + getThingAtPoint api root rel 1 1 + exf2<-doesFileExist file + assertBool exf2 + clean api root False + exf3<-doesFileExist file + assertBool $ not exf3 + exd2<-doesDirectoryExist fldr + assertBool exd2 + build1 api root rel + getThingAtPoint api root rel 1 1 + exf4<-doesFileExist file + assertBool exf4 + clean api root True + exf5<-doesFileExist file + assertBool $ not exf5 + exd3<-doesDirectoryExist fldr + assertBool $ not exd3 testProjectName :: String testProjectName="BWTest" @@ -1660,7 +1849,7 @@ ] testCabalFile :: FilePath -> FilePath -testCabalFile root =root (testProjectName <.> ".cabal") +testCabalFile root =root ((last $ splitDirectories root) <.> ".cabal") testAContents :: String testAContents=unlines ["module A where","fA=undefined"] @@ -1712,7 +1901,7 @@ let n1'=n1{bwnTitle=removeSpaces $ bwnTitle n1} n2'=n1{bwnTitle=removeSpaces $ bwnTitle n2} - assertEqual n1' n2' + assertEqualVerbose msg n1' n2' removeLayoutTAP :: OpResult (Maybe ThingAtPoint) -> OpResult (Maybe ThingAtPoint) removeLayoutTAP res = case res of @@ -1722,12 +1911,13 @@ where removeLayout (Just tp) = Just $ unwords . concatMap words . lines $ tp -- replace sequences of spaces and newlines by single space removeLayout Nothing = Nothing - -runAPI:: (FromJSON a,Show a) => FilePath -> String -> [String] -> IO a -runAPI root command args= do + +runAPI:: (FromJSON a,Show a) => FilePath -> FilePath -> String -> [String] -> IO a +runAPI cabal root command args= do cd<-getCurrentDirectory - let fullargs=[command,"--tempfolder=.dist-buildwrapper","--cabalpath=cabal","--cabalfile="++ testCabalFile root] ++ args + let fullargs=[command,"--tempfolder=.dist-buildwrapper","--cabalpath="++cabal,"--cabalfile="++ testCabalFile root] ++ args exePath<-filterM doesFileExist [".dist-buildwrapper/dist/build/buildwrapper/buildwrapper" <.> exeExtension,"dist/build/buildwrapper/buildwrapper" <.> exeExtension] + assertBool (0 head exePath) fullargs "" setCurrentDirectory cd @@ -1746,5 +1936,50 @@ assertFailure (show a) error "" a->do + assertFailure (show a) + +startAPIProcess :: FilePath -> String -> [String] -> IO (Handle, Handle, Handle, ProcessHandle) +startAPIProcess root command args= do + cd<-getCurrentDirectory + let fullargs=[command,"--tempfolder=.dist-buildwrapper","--cabalpath=cabal","--cabalfile="++ testCabalFile root] ++ args + exePath<-filterM doesFileExist [".dist-buildwrapper/dist/build/buildwrapper/buildwrapper" <.> exeExtension,"dist/build/buildwrapper/buildwrapper" <.> exeExtension] + assertBool (0 head exePath) fullargs (Just root) Nothing + +readResult :: (FromJSON a,Show a) => Handle -> IO a +readResult h= do + l<-BS.hGetLine h + BS.putStrLn l + if BS.isPrefixOf "build-wrapper-json:" l + then do + let r=parse value $ BS.drop (BS.length "build-wrapper-json:") l + -- print r + case r of + Done _ js->do + let r1= fromJSON js + case r1 of + Data.Aeson.Success fin->return fin + a->do + assertFailure (show a) + a->do assertFailure (show a) - error "" + else + readResult h + +continue :: Handle -> IO () +continue h=do + hPutStrLn h "." + hFlush h + + +end :: Handle -> IO () +end h =do + hPutStrLn h "q" + hFlush h + +cmdOpts :: [String] -> [String] +cmdOpts =map ("--cabaloption=" ++) + +notesInError :: [BWNote] -> Bool +notesInError ns=not $ null $ filter (\x->BWError == bwnStatus x) ns + diff --git a/test/Language/Haskell/BuildWrapper/CabalDevTests.hs b/test/Language/Haskell/BuildWrapper/CabalDevTests.hs new file mode 100644 --- /dev/null +++ b/test/Language/Haskell/BuildWrapper/CabalDevTests.hs @@ -0,0 +1,182 @@ +{-# OPTIONS_GHC -F -pgmF htfpp #-} +module Language.Haskell.BuildWrapper.CabalDevTests where + +import Language.Haskell.BuildWrapper.Base hiding (readFile,writeFile) + +import Language.Haskell.BuildWrapper.CMDTests + +import Data.Maybe + +import System.Directory (createDirectory, doesDirectoryExist, getCurrentDirectory, getTemporaryDirectory, removeDirectoryRecursive, setCurrentDirectory) +import System.FilePath ((<.>), ()) + +import Control.Monad (when) + +import Test.Framework (assertBool_, assertEqual_, makeLoc, makeTestSuite, makeUnitTest, TestSuite) +import Test.HUnit (Assertion) +import System.Exit (ExitCode (ExitSuccess)) +import System.Process (readProcessWithExitCode) +import Data.List (isInfixOf) + +test_CabalDev2Projects :: Assertion +test_CabalDev2Projects= do + let api=cabalDevAPI + (root1,root2)<-createTestProjects + runCabalDev root2 ["install",root1] + runCabalDev root2 ["install-deps"] + ((fps,dels),_)<-synchronize api root2 False + assertBool (not $ null fps) + assertBool (null dels) + configure api root2 Source + (BuildResult bool1b _,nsErrors1b)<-build api root2 True Source + assertBool (bool1b) + assertEqual 0 (length nsErrors1b) + let relB="src""B.hs" + (mtts1,nsErrors1)<-getNamesInScope api root2 relB + assertBool (null nsErrors1) + assertBool (isJust mtts1) + let tts1=fromJust mtts1 + assertBool ("B.fB" `elem` tts1) + assertBool ("A.fA1" `elem` tts1) + let relA="src""A.hs" + writeFile (root1 relA) $ unlines [ + "module A where", + "fA1=reverse", + "fA2=head" + ] + synchronize api root1 False + runCabalDev root2 ["install",root1,"--force-reinstalls"] + synchronize api root2 False + configure api root2 Source + (BuildResult bool2b _,nsErrors2b)<-build api root2 True Source + assertBool (bool2b) + assertEqual 0 (length nsErrors2b) + (mtts2,nsErrors2)<-getNamesInScope api root2 relB + assertBool (null nsErrors2) + assertBool (isJust mtts2) + let tts2=fromJust mtts2 + assertBool ("B.fB" `elem` tts2) + assertBool ("A.fA1" `elem` tts2) + assertBool ("A.fA2" `elem` tts2) + return () + +test_CabalDevDependencies :: Assertion +test_CabalDevDependencies= do + let api=cabalDevAPI + (root1,root2)<-createTestProjects + runCabalDev root2 ["install",root1] --,"-s","cabal-dev" + runCabalDev root2 ["install-deps"] + ((fps,dels),_)<-synchronize api root2 False + assertBool (not $ null fps) + assertBool (null dels) + configure api root2 Source + (BuildResult bool1b _,nsErrors1b)<-build api root2 True Source + assertBool (bool1b) + assertEqual 0 (length nsErrors1b) + (cps,nsOK)<-getCabalDependencies api root2 (Just "./.dist-buildwrapper/cabal-dev") + assertBool (null nsOK) + assertEqual 2 (length cps) + let sbs=filter (\(f,_)->"dist-buildwrapper/cabal-dev" `isInfixOf` f) cps + assertEqual 1 (length sbs) + let bwt1=filter (\pkg->cpName pkg == testProject1Name) $ concatMap snd sbs + assertEqual 1 (length bwt1) + let deps=cpDependent $ head bwt1 + assertEqual [CCLibrary True] deps + return () + +cabalDevAPI :: CMDAPI +cabalDevAPI= CMDAPI "cabal-dev" ["--sandbox=./.dist-buildwrapper/cabal-dev"] + +testProject1Name :: String +testProject1Name="BWTest1" + +testProject2Name :: String +testProject2Name="BWTest2" + +testCabalContents1 :: String +testCabalContents1 = unlines ["name: "++testProject1Name, + "version:0.1", + "cabal-version: >= 1.8", + "build-type: Simple", + "", + "library", + " hs-source-dirs: src", + " exposed-modules: A", + " build-depends: base", + "" + ] + +testCabalContents2 :: String +testCabalContents2 = unlines ["name: "++testProject2Name, + "version:0.1", + "cabal-version: >= 1.8", + "build-type: Simple", + "", + "library", + " hs-source-dirs: src", + " exposed-modules: B", + " build-depends: base,"++testProject1Name, + "" + ] + +testCabalFile1 :: FilePath -> FilePath +testCabalFile1 root =root (testProject1Name <.> ".cabal") + +testCabalFile2 :: FilePath -> FilePath +testCabalFile2 root =root (testProject2Name <.> ".cabal") + +testAContents1 :: String +testAContents1=unlines ["module A where","fA1=reverse"] + +testBContents2 :: String +testBContents2=unlines ["module B where","import A","fB=fA1"] + + +createTestProjects :: IO (FilePath,FilePath) +createTestProjects = do + temp<-getTemporaryDirectory + + let root1=temp testProject1Name + ex1<-doesDirectoryExist root1 + when ex1 (removeDirectoryRecursive root1) + createDirectory root1 + writeFile (testCabalFile1 root1) testCabalContents1 + writeFile (root1 "Setup.hs") testSetupContents + let srcF1=root1 "src" + createDirectory srcF1 + writeFile (srcF1 "A.hs") testAContents1 + + let root2=temp testProject2Name + ex2<-doesDirectoryExist root2 + when ex2 (removeDirectoryRecursive root2) + createDirectory root2 + writeFile (testCabalFile2 root2) testCabalContents2 + writeFile (root2 "Setup.hs") testSetupContents + let srcF2=root2 "src" + createDirectory srcF2 + writeFile (srcF2 "B.hs") testBContents2 + + return (root1,root2) + + +runCabalDev:: FilePath -> [String] -> IO () +runCabalDev root args= do + cd<-getCurrentDirectory + setCurrentDirectory root + (ex,out,err)<-readProcessWithExitCode "cabal-dev" ("--sandbox=./.dist-buildwrapper/cabal-dev":args) "" + setCurrentDirectory cd + putStrLn ("cabal-dev out:"++out) + putStrLn ("cabal-dev err:"++err) + assertEqual ExitSuccess ex + + +{-- +$ cabal-dev install --sandbox= + +should do what you're accomplishing with: + +$ cabal-dev add-source +$ cabal-dev install --reinstall --force-reinstalls + +With the added benefit that you don't need the --force to install direct to a sandbox :) +--} 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 @@ -61,7 +61,7 @@ assertEqual 3 (length tt) let (t1:t2:t3:[])=tt assertEqual (TokenDef "PP" (mkLocation 1 1 1 20)) t1 - assertEqual (TokenDef "D" (mkLocation 2 1 2 35)) t2 + 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 diff --git a/test/Language/Haskell/BuildWrapper/ImportsTests.hs b/test/Language/Haskell/BuildWrapper/ImportsTests.hs new file mode 100644 --- /dev/null +++ b/test/Language/Haskell/BuildWrapper/ImportsTests.hs @@ -0,0 +1,362 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -F -pgmF htfpp #-} +-- | +-- Module : Language.Haskell.BuildWrapper.ImportsTests +-- Author : JP Moresmau +-- Copyright : (c) JP Moresmau 2013 +-- License : BSD3 +-- +-- Maintainer : jpmoresmau@gmail.com +-- Stability : beta +-- Portability : portable +-- +-- Test import cleaning and such +module Language.Haskell.BuildWrapper.ImportsTests where + +import Language.Haskell.BuildWrapper.Base hiding (writeFile) +import Language.Haskell.BuildWrapper.CMDTests + +import System.FilePath + +import Test.Framework +import Test.HUnit (Assertion) + +test_CleanImportsNothing :: Assertion +test_CleanImportsNothing = do + let api=cabalAPI + root<-createTestProject + synchronize api root False + let rel="src""A.hs" + -- use api to write temp file + write api root rel $ unlines [ + "module A where", + "", + "f :: IO()", + "f=putStrLn \"hello\"" + ] + (ics,ns)<-cleanImports api root rel False + assertBool $ null ns + assertBool $ null ics + +test_CleanImportsFunction :: Assertion +test_CleanImportsFunction = do + let api=cabalAPI + root<-createTestProject + synchronize api root False + let rel="src""A.hs" + -- use api to write temp file + write api root rel $ unlines [ + "module A where", + "", + "import Data.Unique", + "f = newUnique" + ] + (ics,ns)<-cleanImports api root rel False + assertBool $ null ns + assertEqual [ImportClean (InFileSpan (InFileLoc 3 1) (InFileLoc 3 19)) "import Data.Unique (newUnique)"] ics + +test_CleanImportsRemove :: Assertion +test_CleanImportsRemove = do + let api=cabalAPI + root<-createTestProject + synchronize api root False + let rel="src""A.hs" + -- use api to write temp file + write api root rel $ unlines [ + "module A where", + "", + "import Data.Unique", + "f = putStrLn \"hello\"" + ] + (ics,ns)<-cleanImports api root rel False + assertBool $ null ns + assertEqual [ImportClean (InFileSpan (InFileLoc 3 1) (InFileLoc 3 19)) ""] ics + + +test_CleanImportsFunctionType :: Assertion +test_CleanImportsFunctionType = do + let api=cabalAPI + root<-createTestProject + synchronize api root False + let rel="src""A.hs" + -- use api to write temp file + write api root rel $ unlines [ + "module A where", + "", + "import Data.Unique", + "f :: IO Unique", + "f = newUnique" + ] + (ics,ns)<-cleanImports api root rel False + assertBool $ null ns + assertEqual [ImportClean (InFileSpan (InFileLoc 3 1) (InFileLoc 3 19)) "import Data.Unique (newUnique, Unique)"] ics + + +test_CleanImportsConstructor :: Assertion +test_CleanImportsConstructor = do + let api=cabalAPI + root<-createTestProject + synchronize api root False + let rel="src""A.hs" + -- use api to write temp file + write api root rel $ unlines [ + "module A where", + "", + "data MyData=MyCons Int" + ] + let rel2="src""B""C.hs" + write api root rel2 $ unlines [ + "module B.C where", + "", + "import A", + "f = MyCons 2" + ] + (ics,ns)<-cleanImports api root rel2 False + assertBool $ null ns + assertEqual [ImportClean (InFileSpan (InFileLoc 3 1) (InFileLoc 3 9)) "import A (MyData (MyCons))"] ics + +test_CleanImportsConstructorTyped :: Assertion +test_CleanImportsConstructorTyped = 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, attoparsec"] + synchronize api root False + configure api root Target + let rel2="src""B""C.hs" + write api root rel2 $ unlines [ + "module B.C where", + "", + "import Data.Attoparsec", + "f r= case r of", + " Done _ js->True", + " _->False" + ] + (ics,ns)<-cleanImports api root rel2 False + assertBool $ null ns + assertEqual [ImportClean (InFileSpan (InFileLoc 3 1) (InFileLoc 3 23)) "import Data.Attoparsec (IResult (Done))"] ics + +test_CleanImportsFunctionInExport :: Assertion +test_CleanImportsFunctionInExport = do + let api=cabalAPI + root<-createTestProject + synchronize api root False + let rel="src""A.hs" + -- use api to write temp file + write api root rel $ unlines [ + "module A where", + "", + "data MyData=MyCons Int", + "myUnCons (MyCons i)=i" + ] + let rel2="src""B""C.hs" + write api root rel2 $ unlines [ + "module B.C (f,myUnCons) where", + "", + "import A", + "f = MyCons 2" + ] + (ics,ns)<-cleanImports api root rel2 False + assertBool $ null ns + assertEqual [ImportClean (InFileSpan (InFileLoc 3 1) (InFileLoc 3 9)) "import A (MyData (MyCons), myUnCons)"] ics + + +test_CleanImportsConstructorQualified :: Assertion +test_CleanImportsConstructorQualified = do + let api=cabalAPI + root<-createTestProject + synchronize api root False + let rel="src""A.hs" + -- use api to write temp file + write api root rel $ unlines [ + "module A where", + "", + "data MyData=MyCons Int" + ] + let rel2="src""B""C.hs" + write api root rel2 $ unlines [ + "module B.C where", + "", + "import qualified A as MyA", + "f = MyA.MyCons 2" + ] + (ics,ns)<-cleanImports api root rel2 False + assertBool $ null ns + assertEqual [ImportClean (InFileSpan (InFileLoc 3 1) (InFileLoc 3 26)) "import qualified A as MyA (MyData (MyCons))"] ics + +test_CleanImportsFunctionReExported :: Assertion +test_CleanImportsFunctionReExported = do + let api=cabalAPI + root<-createTestProject + synchronize api root False + let rel="src""A.hs" + -- use api to write temp file + write api root rel $ unlines [ + "module A where", + "", + "import Data.Char", + "f = toUpper" + ] + (ics,ns)<-cleanImports api root rel False + assertBool $ null ns + assertEqual [ImportClean (InFileSpan (InFileLoc 3 1) (InFileLoc 3 17)) "import Data.Char (toUpper)"] ics + +test_CleanImportsFunctionReExportedInExport :: Assertion +test_CleanImportsFunctionReExportedInExport = do + let api=cabalAPI + root<-createTestProject + synchronize api root False + let rel="src""A.hs" + -- use api to write temp file + write api root rel $ unlines [ + "module A (f,toLower) where", + "", + "import Data.Char", + "f = toUpper" + ] + (ics,ns)<-cleanImports api root rel False + assertBool $ null ns + assertEqual [ImportClean (InFileSpan (InFileLoc 3 1) (InFileLoc 3 17)) "import Data.Char (toLower, toUpper)"] ics + +test_CleanImportsFunctionReExportedWithOthers :: Assertion +test_CleanImportsFunctionReExportedWithOthers = do + let api=cabalAPI + root<-createTestProject + synchronize api root False + let rel="src""A.hs" + -- use api to write temp file + write api root rel $ unlines [ + "module A where", + "", + "import Data.Char", + "import Data.List", + "f = toUpper", + "f2 = unzip5", + "f3 = isSeparator" + ] + (ics,ns)<-cleanImports api root rel False + assertBool $ null ns + assertEqual [ImportClean (InFileSpan (InFileLoc 3 1) (InFileLoc 3 17)) + "import Data.Char (isSeparator, toUpper)", + ImportClean (InFileSpan (InFileLoc 4 1) (InFileLoc 4 17)) + "import Data.List (unzip5)"] + ics + +test_CleanImportsFormat :: Assertion +test_CleanImportsFormat = do + let api=cabalAPI + root<-createTestProject + synchronize api root False + let rel="src""A.hs" + -- use api to write temp file + write api root rel $ unlines [ + "module A where", + "", + "import Data.Char", + "import qualified Data.Unique as U", + "f = toUpper", + "f2 = U.newUnique", + "f3 = isSeparator" + ] + (ics,ns)<-cleanImports api root rel True + assertBool $ null ns + assertEqual [ImportClean (InFileSpan (InFileLoc 3 1) (InFileLoc 3 17)) + "import Data.Char (isSeparator, toUpper)", + ImportClean (InFileSpan (InFileLoc 4 1) (InFileLoc 4 34)) + "import qualified Data.Unique as U (newUnique)"] + ics + +test_CleanImportsInfix :: Assertion +test_CleanImportsInfix = do + let api=cabalAPI + root<-createTestProject + synchronize api root False + let rel="src""A.hs" + 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, filepath"] + synchronize api root False + configure api root Target + -- use api to write temp file + write api root rel $ unlines [ + "module A where", + "", + "import System.FilePath", + "f = \"dir\" \"file\"" + ] + (ics,ns)<-cleanImports api root rel True + assertBool $ null ns + assertEqual [ImportClean (InFileSpan (InFileLoc 3 1) (InFileLoc 3 23)) + "import System.FilePath (())" + ] + ics + +test_CleanImportsHiding :: Assertion +test_CleanImportsHiding = do + let api=cabalAPI + root<-createTestProject + synchronize api root False + let rel="src""A.hs" + 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, bytestring"] + synchronize api root False + configure api root Target + -- use api to write temp file + write api root rel $ unlines [ + "module A where", + "", + "import Data.ByteString.Lazy.Char8 hiding (writeFile)", + "f s= writeFile \"file\" s" + ] + (ics,ns)<-cleanImports api root rel True + assertBool $ null ns + assertEqual [ImportClean (InFileSpan (InFileLoc 3 1) (InFileLoc 3 53)) + "" + ] + ics + +test_CleanImportsPrelude :: Assertion +test_CleanImportsPrelude = do + let api=cabalAPI + root<-createTestProject + synchronize api root False + let rel="src""A.hs" + -- use api to write temp file + write api root rel $ unlines [ + "module A where", + "", + "import Data.List", + "f = map id" + ] + (ics,ns)<-cleanImports api root rel True + assertBool $ null ns + assertEqual [ImportClean (InFileSpan (InFileLoc 3 1) (InFileLoc 3 17)) + ""] + ics + diff --git a/test/Language/Haskell/BuildWrapper/UsagesTests.hs b/test/Language/Haskell/BuildWrapper/UsagesTests.hs --- a/test/Language/Haskell/BuildWrapper/UsagesTests.hs +++ b/test/Language/Haskell/BuildWrapper/UsagesTests.hs @@ -28,7 +28,7 @@ test_GenerateBWUsage :: Assertion test_GenerateBWUsage = do - let api=CMDAPI + let api=cabalAPI root<-createTestProject ((fps,dels),_)<-synchronize api root False assertBool (not $ null fps) @@ -63,7 +63,7 @@ test_GenerateReferencesSimple :: Assertion test_GenerateReferencesSimple = do - let api=CMDAPI + let api=cabalAPI root<-createTestProject let relMain="src""Main.hs" writeFile (root relMain) $ unlines [ @@ -146,7 +146,7 @@ test_GenerateReferencesImports :: Assertion test_GenerateReferencesImports = do - let api=CMDAPI + let api=cabalAPI root<-createTestProject let relMain="src""Main.hs" writeFile (root relMain) $ unlines [ @@ -176,7 +176,7 @@ test_GenerateReferencesExports :: Assertion test_GenerateReferencesExports = do - let api=CMDAPI + let api=cabalAPI root<-createTestProject let rel="src" "A.hs" writeFile (root rel) $ unlines [ @@ -243,7 +243,7 @@ test_GenerateReferencesExportAlias :: Assertion test_GenerateReferencesExportAlias = do - let api=CMDAPI + let api=cabalAPI root<-createTestProject let relMain="src""Main.hs" writeFile (root relMain) $ unlines [ @@ -263,10 +263,35 @@ -- putStrLn sUMain assertVarUsage "base" "Data.Ord" "" [("export",False,[1,14,1,22]),("import",False,[2,8,2,16])] vMain +test_GenerateReferencesPattern :: Assertion +test_GenerateReferencesPattern = do + let api=cabalAPI + root<-createTestProject + let relMain="src""Main.hs" + writeFile (root relMain) $ unlines [ + "module Main where", + "", + "main=undefined", + "f :: Maybe String -> String", + "f mf=case mf of", + " Just x->x", + " _->\"\"" + ] + _<-synchronize api root True + (BuildResult bool1 _,nsErrors1)<-build api root False Source + assertBoolVerbose ("returned false on bool1:" ++ show nsErrors1) bool1 + assertBool (null nsErrors1) + (comps,_)<-getCabalComponents api root + mapM_ (generateUsage api root False) comps + vMain<-readStoredUsage (root ".dist-buildwrapper" relMain) + -- sUMain<-fmap formatJSON (readFile $ getUsageFile(root ".dist-buildwrapper" relMain)) + -- putStrLn sUMain + assertVarUsage "base" "Data.Maybe" "Just" [("f",False,[6,3,6,7])] vMain + test_IncorrectModuleFileName :: Assertion test_IncorrectModuleFileName = do - let api=CMDAPI + let api=cabalAPI root<-createTestProject let relMain="src""Main.hs" let relMain2="src""Main-exe.hs" diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -16,6 +16,8 @@ import {-@ HTF_TESTS @-} Language.Haskell.BuildWrapper.CMDTests import {-@ HTF_TESTS @-} Language.Haskell.BuildWrapper.GHCTests import {-@ HTF_TESTS @-} Language.Haskell.BuildWrapper.UsagesTests +import {-@ HTF_TESTS @-} Language.Haskell.BuildWrapper.ImportsTests +import {-@ HTF_TESTS @-} Language.Haskell.BuildWrapper.CabalDevTests import Test.Framework