Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
tree: 94e59d9c16
Fetching contributors…

Cannot retrieve contributors at this time

175 lines (149 sloc) 5.697 kb
module FindBench(findLocalBenchmarks) where
--module Main where
import Control.Exception
import Control.Monad (filterM, when, liftM)
import Data.List
import System.Directory
import System.FilePath
import System.IO
{-
-- for standalone testing
main = do
findLocalBenchmarks "benchmarks"
-}
benchmarksModule = ["Fibon", "Benchmarks"]
benchmarksInstanceModule = "Fibon.Instance"
findLocalBenchmarks :: FilePath -> IO ()
findLocalBenchmarks baseDir = do
let searchPath = join ([pathSeparator]) (baseDir : benchmarksModule)
putStr $ "Looking for benchmarks in "++searchPath
groups <- sort `liftM` bmGroups searchPath
bms <- bmInstances searchPath groups
let allBms = (sort . concat) bms
qualifiedBms =
concat $ zipWith (\g bs -> map ((,)g) (sort bs)) groups bms
outFile = searchPath ++ ".hs"
when (null groups) printNoBenchmarksWarning
putStrLn $ "... found ("++ (show.length$ allBms)++")"
putStrLn $ " writing benchmark manifest to "++outFile
createDirectoryIfMissing True (baseDir </> "Fibon")
h <- openFile outFile WriteMode
hPutStrLn h moduleHeader
hPutStrLn h $ moduleImports (join "." benchmarksModule) qualifiedBms
hPutStrLn h ""
hPutStrLn h $ benchDataDecl allBms
hPutStrLn h ""
hPutStrLn h $ groupDataDecl groups
hPutStrLn h ""
hPutStrLn h $ allBenchmarksDecl allBms
hPutStrLn h ""
hPutStrLn h $ benchGroupDecl qualifiedBms
hPutStrLn h ""
hPutStrLn h $ benchInstanceDecl qualifiedBms
hPutStrLn h ""
hPutStrLn h $ benchPathDecl qualifiedBms
hClose h
bmGroups :: FilePath -> IO [FilePath]
bmGroups baseDir = do
dirs <- try (getDirectoryContents baseDir) :: IO (Either IOError [FilePath])
case dirs of
Left _ -> return []
Right ds -> removeBadEntries baseDir ds
bmInstances :: FilePath -> [FilePath] -> IO [[String]]
bmInstances baseDir groups = do
let paths = map (baseDir </>) groups
bms <- mapM getDirectoryContents paths
mapM (\(p, bm) -> removeBadEntries p bm) (zip paths bms)
removeDotFiles :: [FilePath] -> [FilePath]
removeDotFiles = filter (\d -> not ("." `isPrefixOf` d))
removeBadEntries :: FilePath -> [FilePath] -> IO [FilePath]
removeBadEntries baseDir dirs = do
let paths = map (baseDir </>) dirs
noFiles <- filterM (\d -> doesDirectoryExist (baseDir </> d)) dirs
let noUnderscores = filter (\d -> not ("_" `isPrefixOf` d)) noFiles
return (removeDotFiles noUnderscores)
moduleHeader :: String
moduleHeader = join "\n" [
"module "++modName++" (",
" FibonBenchmark(..)",
" , FibonGroup(..)",
" , allBenchmarks",
" , benchGroup",
" , benchInstance",
" , benchPath",
")",
"where",
"import Fibon.InputSize",
"import Fibon.BenchmarkInstance",
"import System.FilePath"
]
where
modName = join "." benchmarksModule
moduleImports :: String -> [(String, String)] -> String
moduleImports baseMod bms = join "\n" imports
where
imports = map importStmt bms
importStmt (g,bm) =
"import qualified "
++baseMod++"."++g++"."++bm++"."++benchmarksInstanceModule
++" as "++(importAs g bm)
importAs :: String -> String -> String
importAs _grp modu = modu ++ "_bm"
groupName :: String -> String
groupName g = g
benchDataDecl :: [String] -> String
benchDataDecl bms = "data FibonBenchmark = " ++ datas bms ++ derivings
where derivings = "\n deriving(Read, Show, Eq, Ord, Enum)"
datas [] = "NoBenchmarksFound"
datas bms = "\n " ++ (join ("\n | ") bms)
groupDataDecl :: [String] -> String
groupDataDecl grps = "data FibonGroup = " ++ datas grps ++ derivings
where derivings = "\n deriving(Read, Show, Eq, Ord, Enum)"
datas [] = "NoGroupsFound"
datas grps = "\n "++ (join ("\n | ") (map groupName grps))
allBenchmarksDecl :: [String] -> String
allBenchmarksDecl bms =
"allBenchmarks :: [FibonBenchmark]\n"++
"allBenchmarks = [\n "++
(join ("\n , ") bms) ++
"\n ]"
benchGroupDecl :: [(String, String)] -> String
benchGroupDecl [] = benchGroupTypeDecl ++ "benchGroup = "++ emptyError
benchGroupDecl qBms = benchGroupTypeDecl ++ (join ("\n") $ map defn qBms)
where
defn (g,bm) = "benchGroup " ++ bm ++ " = " ++ (groupName g)
benchGroupTypeDecl :: String
benchGroupTypeDecl = "benchGroup :: FibonBenchmark -> FibonGroup\n"
benchInstanceDecl :: [(String, String)] -> String
benchInstanceDecl [] = benchInstanceTypeDecl ++ "benchInstance = "++ emptyError
benchInstanceDecl qBms = benchInstanceTypeDecl ++ (join ("\n") $ map defn qBms)
where
defn (g,bm) =
"benchInstance " ++ bm ++ " = " ++ (importAs g bm) ++ ".mkInstance"
benchInstanceTypeDecl :: String
benchInstanceTypeDecl =
"benchInstance :: FibonBenchmark -> InputSize -> BenchmarkInstance\n"
benchPathDecl :: [(String, String)] -> String
benchPathDecl [] = benchPathTypeDecl ++ "benchPath = " ++ emptyError
benchPathDecl qBms = benchPathTypeDecl ++ (join ("\n") $ map defn qBms)
where
defn (g,bm) = "benchPath " ++ bm ++ " = " ++ s g ++ " </> " ++ s bm
s x = "\"" ++ x ++"\""
benchPathTypeDecl :: String
benchPathTypeDecl = "benchPath :: FibonBenchmark -> FilePath\n"
join :: String -> [String] -> String
join s ss = concat (intersperse s ss)
emptyError :: String
emptyError = "error \"No benchmarks found. Need to re-run cabal config step\""
printNoBenchmarksWarning :: IO ()
printNoBenchmarksWarning = do
putStrLn "\n"
putStrLn banner
putStrLn $cap("! No benchmarks found.")
putStrLn $cap("! You will not be able to run collect results with fibon-run")
putStrLn banner
putStrLn ""
where
banner = line++"WARNING"++line
line = take 30 (repeat '-')
cap s = s ++ take ((length banner) - (length s) - 1) (repeat ' ') ++ "!"
Jump to Line
Something went wrong with that request. Please try again.