shaker 0.5.0 → 0.5.1
raw patch · 18 files changed
+435/−294 lines, 18 filesdep +parsec3dep −haskell98dep −parsecdep ~Cabaldep ~QuickCheckdep ~containers
Dependencies added: parsec3
Dependencies removed: haskell98, parsec
Dependency ranges changed: Cabal, QuickCheck, containers, directory, filepath, ghc, regex-posix, template-haskell, test-framework
Files
- shaker.cabal +26/−28
- src/Shaker/Action/Compile.hs +17/−6
- src/Shaker/Action/Standard.hs +12/−12
- src/Shaker/Action/Test.hs +32/−16
- src/Shaker/CabalInfo.hs +34/−29
- src/Shaker/CabalInterface.hs +22/−4
- src/Shaker/Cli.hs +9/−10
- src/Shaker/CommonUtil.hs +14/−0
- src/Shaker/Conductor.hs +29/−29
- src/Shaker/Config.hs +18/−17
- src/Shaker/GhcInterface.hs +114/−17
- src/Shaker/HsHelper.hs +1/−12
- src/Shaker/ModuleData.hs +7/−3
- src/Shaker/Parser.hs +5/−2
- src/Shaker/Reflexivite.hs +15/−74
- src/Shaker/TestHelper.hs +0/−19
- src/Shaker/TestTH.hs +38/−9
- src/Shaker/Type.hs +42/−7
shaker.cabal view
@@ -1,5 +1,5 @@ name: shaker-version: 0.5.0+version: 0.5.1 cabal-version: >= 1.8 build-type: Custom license: BSD3@@ -10,7 +10,7 @@ homepage: http://github.com/bonnefoa/Shaker bug-reports: http://github.com/bonnefoa/Shaker/issues Stability:alpha-Tested-With:GHC == 6.12.3+Tested-With:GHC >= 7 category: Development synopsis: simple and interactive command-line build tool description: @@ -89,11 +89,11 @@ source-repository this type: git location: git://github.com/bonnefoa/Shaker.git - tag: 0.4.3+ tag: 0.5.1 Library ghc-options: -Wall -fno-warn-orphans - hs-source-dirs: src+ hs-source-dirs: src exposed-modules: Shaker.Action.Compile Shaker.Action.Standard@@ -101,6 +101,7 @@ Shaker.CabalInfo Shaker.CabalInterface Shaker.Cli+ Shaker.CommonUtil Shaker.Conductor Shaker.Config Shaker.GhcInterface@@ -112,54 +113,51 @@ Shaker.PluginConfig Shaker.Reflexivite Shaker.Regex- Shaker.TestHelper Shaker.TestTH Shaker.Type build-depends: base == 4.* ,bytestring == 0.9.*- ,Cabal == 1.8.*- ,containers == 0.3.*- ,directory == 1.0.*- ,filepath == 1.1.*- ,ghc == 6.*+ ,Cabal == 1.10.*+ ,containers == 0.4.*+ ,directory == 1.*+ ,filepath == 1.*+ ,ghc == 7.* ,ghc-paths == 0.1.* ,haskeline == 0.6.*- ,haskell98 == 1.0.* ,haskell-src == 1.0.* ,HUnit == 1.2.* ,mtl == 2.* ,old-time >= 1.0.0- ,parsec == 3.*- ,QuickCheck == 2.3.*- ,regex-posix == 0.94.*- ,template-haskell >= 2.4.0.0- ,test-framework == 0.3.*+ ,parsec3 == 1.*+ ,QuickCheck == 2.4.*+ ,regex-posix == 0.95.*+ ,template-haskell >= 2.5.0.0+ ,test-framework == 0.4.* ,test-framework-hunit == 0.2.* ,test-framework-quickcheck2 == 0.2.* Executable shaker Main-Is: Shaker.hs ghc-options: -Wall -fno-warn-orphans - hs-source-dirs: prog src+ hs-source-dirs: prog src build-depends: base == 4.* ,bytestring == 0.9.*- ,Cabal == 1.8.*- ,containers == 0.3.*- ,directory == 1.0.*- ,filepath == 1.1.*- ,ghc == 6.*+ ,Cabal == 1.10.*+ ,containers == 0.4.*+ ,directory == 1.*+ ,filepath == 1.*+ ,ghc == 7.* ,ghc-paths == 0.1.* ,haskeline == 0.6.*- ,haskell98 == 1.0.* ,haskell-src ,HUnit == 1.2.* ,mtl == 2.* ,old-time >= 1.0.0- ,parsec == 3.*- ,QuickCheck == 2.3.*- ,regex-posix == 0.94.*- ,template-haskell >= 2.4.0.0- ,test-framework == 0.3.*+ ,parsec3 == 1.*+ ,QuickCheck == 2.4.*+ ,regex-posix == 0.95.*+ ,template-haskell >= 2.5.0.0+ ,test-framework == 0.4.* ,test-framework-hunit == 0.2.* ,test-framework-quickcheck2 == 0.2.*
src/Shaker/Action/Compile.hs view
@@ -3,7 +3,7 @@ where import Control.Monad.Reader-import DynFlags +import DynFlags import GHC import GHC.Paths import Shaker.CabalInterface@@ -13,20 +13,31 @@ -- | Run haskell compilation on given CompileInput list runCompile :: Plugin-runCompile = applyPreprocessSources >> asks shakerCompileInputs >>= foldM runUntilFail Succeeded >> return ()+runCompile = applyPreprocessSources+ >> asks shakerCompileInputs+ >>= foldM runUntilFail Succeeded+ >> return () runUntilFail :: SuccessFlag -> CompileInput -> Shaker IO SuccessFlag runUntilFail Succeeded cpIn = runSingleCompileInput cpIn runUntilFail Failed _ = return Failed- + -- | Run haskell compilation on all haskell files runFullCompile :: Plugin-runFullCompile = applyPreprocessSources >> convertModuleDataToFullCompileInput >>= foldM runUntilFail Succeeded >> return()+runFullCompile = applyPreprocessSources+ >> convertModuleDataToFullCompileInput+ >>= foldM runUntilFail Succeeded+ >> return() +printArguments :: CompileInput -> Verbosity -> IO ()+printArguments _ Silent = return()+printArguments cplInp Debug = putStrLn $ concat ["--", "Arguments :"++ show (compileInputCommandLineFlags cplInp) ,"--"]+ runSingleCompileInput :: CompileInput -> Shaker IO SuccessFlag runSingleCompileInput cplInp = do lift $ putStrLn "" lift $ putStrLn $ concat ["--", "Compiling target : "++ show (compileInputTargetFiles cplInp) ,"--"]- lift $ defaultErrorHandler defaultDynFlags $ - runGhc (Just libdir) $ ghcCompile cplInp + asks shakerVerbosity >>= lift . printArguments cplInp+ lift $ defaultErrorHandler defaultDynFlags $+ runGhc (Just libdir) $ ghcCompile cplInp
src/Shaker/Action/Standard.hs view
@@ -10,13 +10,13 @@ -- | Print the list of available actions runHelp :: Plugin-runHelp = do - commands <- asks shakerCommandMap - lift $ do +runHelp = do+ commands <- asks shakerCommandMap+ lift $ do putStrLn "Following actions are available : " print $ M.keys commands putStrLn "use ~[actionName] for continuous launch"- + -- | Print exit. The real exit management is made in conductor runExit :: Plugin runExit = do@@ -26,7 +26,7 @@ -- | Print a begin action notification runStartAction :: Plugin-runStartAction = lift $ +runStartAction = lift $ putStrLn "-- Begin action --" runEmpty :: Plugin@@ -34,18 +34,18 @@ -- | Print an end action notification runEndAction :: Plugin-runEndAction = lift $ +runEndAction = lift $ putStrLn "-- End action --" --- | Clean action is responsible to delete fileListenInfoDirectory containing temporary .o and .hi files -runClean :: Plugin +-- | Clean action is responsible to delete fileListenInfoDirectory containing temporary .o and .hi files+runClean :: Plugin runClean = do- toClean <- asks $ map compileInputBuildDirectory . shakerCompileInputs - lift$ mapM_ action toClean + toClean <- asks $ map compileInputBuildDirectory . shakerCompileInputs+ lift$ mapM_ action toClean where action toClean = do ex <- doesDirectoryExist toClean- when ex $ removeDirectoryRecursive toClean + when ex $ removeDirectoryRecursive toClean -runInvalidAction :: Plugin +runInvalidAction :: Plugin runInvalidAction = lift $ putStrLn "Invalid action, use help to display available actions"
src/Shaker/Action/Test.hs view
@@ -1,19 +1,29 @@ module Shaker.Action.Test where +import Data.Monoid+import Shaker.CabalInterface import Shaker.Type import Shaker.Reflexivite import Shaker.ModuleData+import Shaker.TestTH+import Shaker.GhcInterface import Control.Monad.Reader import Language.Haskell.TH -runTestFramework :: Plugin -runTestFramework = getModulesWithFunctionFiltering >>= runTestFramework'+runTestFramework :: Plugin+runTestFramework = applyPreprocessSources+ >> getModulesWithFunctionFiltering+ >>= fillModuleDataTest+ >>= processModuleDataList -runModuleTestFramework :: Plugin -runModuleTestFramework = getModulesWithModuleFiltering >>= runTestFramework' +runModuleTestFramework :: Plugin+runModuleTestFramework = applyPreprocessSources+ >> getModulesWithModuleFiltering+ >>= fillModuleDataTest+ >>= processModuleDataList -getModulesWithModuleFiltering :: Shaker IO [ModuleData] +getModulesWithModuleFiltering :: Shaker IO [ModuleData] getModulesWithModuleFiltering = do listModuleData <- asks shakerModuleData args <- asks shakerArgument@@ -21,21 +31,27 @@ where process module_list [] = module_list process module_list list = concatMap (filterModulesWithPattern module_list) list -getModulesWithFunctionFiltering :: Shaker IO [ModuleData] +getModulesWithFunctionFiltering :: Shaker IO [ModuleData] getModulesWithFunctionFiltering = do listModuleData <- asks shakerModuleData args <- asks shakerArgument return $ filterFunctionsWithPatterns listModuleData args- -runTestFramework' :: [ModuleData] -> Plugin-runTestFramework' [] = lift $ putStrLn "No test to run"-runTestFramework' modules = do- let import_modules = base_modules ++ map moduleDataName filtered_modules- resolvedExp <- lift $ runQ (listTestFrameworkGroupList filtered_modules)++processModuleDataList :: [[ModuleData]] -> Plugin+processModuleDataList [] = lift $ putStrLn "No test to run"+processModuleDataList lst = mapM_ executeTest lst++executeTest :: [ModuleData] -> Plugin+executeTest moduleDatas = do+ let import_modules = base_modules ++ map moduleDataName moduleDatas+ resolvedExp <- lift $ runQ (listTestFrameworkGroupList moduleDatas) let function = filter (/= '\n') $ pprint resolvedExp lift $ putStrLn function- runFunction $ RunnableFunction import_modules listTestLibs ("defaultMain $ " ++ function) - return () - where base_modules =["Data.Maybe","Shaker.TestHelper","Test.Framework", "Test.Framework.Providers.HUnit", "Test.Framework.Providers.QuickCheck2", "Test.QuickCheck", "Test.HUnit", "Prelude" ] - filtered_modules = removeNonTestModules modules+ baseCpIn <- fmap mconcat (asks shakerCompileInputs)+ let cpIn = baseCpIn {+ compileInputTargetFiles = map moduleDataFileName moduleDatas+ }+ runFunction cpIn $ RunnableFunction import_modules listTestLibs ("defaultMain $ " ++ function)+ return ()+ where base_modules =["Data.Maybe","Shaker.TestHelper","Test.Framework", "Test.Framework.Providers.HUnit", "Test.Framework.Providers.QuickCheck2", "Test.QuickCheck", "Test.HUnit", "Prelude" ]
src/Shaker/CabalInfo.hs view
@@ -10,15 +10,14 @@ import Control.Monad.Reader import Data.List(nub,isSuffixOf, find, isPrefixOf) import Data.Maybe-import Data.Monoid +import Data.Monoid import Distribution.ModuleName import Distribution.PackageDescription import Distribution.PackageDescription.Parse import Distribution.Package (PackageName(PackageName), pkgName) import Distribution.Simple.Compiler (PackageDB(..)) import Distribution.Simple.Configure (maybeGetPersistBuildConfig, configure, writePersistBuildConfig, getInstalledPackages)-import Distribution.Simple.GHC(ghcOptions)-import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.LocalBuildInfo import Distribution.Simple.Program import Distribution.Simple.Setup import Distribution.Simple.Utils@@ -35,9 +34,14 @@ -- | Read the build information from cabal and output a shakerInput from it defaultCabalInput :: IO ShakerInput-defaultCabalInput = readConf >>= \lbi -> - generateAutogenFiles lbi >> - localBuildInfoToShakerInput lbi >>= exposeNeededPackages lbi >>= checkInvalidMain >>= fillModuleData >>= fillPackageIndex+defaultCabalInput = readConf+ >>= \lbi -> generateAutogenFiles lbi+ >> localBuildInfoToShakerInput lbi+ {->>= exposeNeededPackages lbi-}+ >>= checkInvalidMain+ >>= fillModuleData+ >>= fillPackageIndex+ readConf :: IO LocalBuildInfo readConf = maybeGetPersistBuildConfig "dist" >>= \my_lbi -> case my_lbi of@@ -46,18 +50,17 @@ callConfigure :: IO LocalBuildInfo callConfigure = do- genericPackageDescription <- defaultPackageDesc silent >>= readPackageDescription silent - lbi <- configure (genericPackageDescription ,emptyHookedBuildInfo) (defaultConfigFlags defaultProgramConfiguration) + genericPackageDescription <- defaultPackageDesc silent >>= readPackageDescription silent+ lbi <- configure (genericPackageDescription ,emptyHookedBuildInfo) (defaultConfigFlags defaultProgramConfiguration) writePersistBuildConfig "dist" lbi return lbi -- | Extract useful information from localBuildInfo to a ShakerInput localBuildInfoToShakerInput :: LocalBuildInfo -> IO ShakerInput-localBuildInfoToShakerInput lbi = do - defInput <- defaultInputInitialized - let cplInputs = localBuildInfoToCompileInputs lbi +localBuildInfoToShakerInput lbi = do+ defInput <- defaultInputInitialized+ let cplInputs = localBuildInfoToCompileInputs lbi let listenerInput = compileInputsToListenerInput cplInputs- --lstHsFiles <- fmap listenerInputFiles (asks shakerListenerInput) >>= recurseMultipleListFiles return defInput { shakerCompileInputs = cplInputs ,shakerListenerInput = listenerInput@@ -67,12 +70,12 @@ compileInputsToListenerInput :: [CompileInput] -> ListenerInput compileInputsToListenerInput cplInputs = mempty { listenerInputFiles = nub $ map (\a -> FileListenInfo a defaultExclude defaultHaskellPatterns) concatSources- } + } where concatSources = concatMap compileInputSourceDirs cplInputs- + -- * Converter to CompileInput --- | Extract informations : Convert executable and library to +-- | Extract informations : Convert executable and library to -- compile inputs localBuildInfoToCompileInputs :: LocalBuildInfo -> [CompileInput] localBuildInfoToCompileInputs lbi = executableAndLibToCompileInput lbi libraryTuple executablesTuples@@ -90,9 +93,9 @@ -- | Convert a cabal executable to a compileInput -- The target of compilation will the main file executableToCompileInput :: LocalBuildInfo -> (Executable, ComponentLocalBuildInfo) -> CompileInput-executableToCompileInput lbi (executable, componentLocalBuildInfo) = mempty { +executableToCompileInput lbi (executable, componentLocalBuildInfo) = mempty { compileInputSourceDirs = mySourceDir- ,compileInputCommandLineFlags = ghcOptions lbi bldInfo componentLocalBuildInfo defaultDistDir+ ,compileInputCommandLineFlags = getCompileFlagsForExecutable lbi executable componentLocalBuildInfo ,compileInputTargetFiles = map (</> modulePath executable ) mySourceDir ,compileInputDynFlags = toDynFlags mySourceDir (getLibDependencies componentLocalBuildInfo) }@@ -104,15 +107,15 @@ libraryToCompileInput :: LocalBuildInfo -> (Library, ComponentLocalBuildInfo) -> CompileInput libraryToCompileInput lbi (lib, componentLocalBuildInfo) = mempty { compileInputSourceDirs = mySourceDir- ,compileInputCommandLineFlags = ghcOptions lbi bldInfo componentLocalBuildInfo defaultDistDir+ ,compileInputCommandLineFlags = getCompileFlagsForLibrary lbi lib componentLocalBuildInfo ,compileInputTargetFiles = myModules ,compileInputDynFlags = toDynFlags mySourceDir (getLibDependencies componentLocalBuildInfo) } where bldInfo = libBuildInfo lib myModules = map convertModuleNameToString $ exposedModules lib- mySourceDir = "dist/build/autogen": hsSourceDirs bldInfo + mySourceDir = "dist/build/autogen": hsSourceDirs bldInfo --- | Create a dynFlags for ghc from a source fileListenInfoDirectory and +-- | Create a dynFlags for ghc from a source fileListenInfoDirectory and -- a liste of packages toDynFlags :: [String] -> [String] -> DynFlags -> DynFlags toDynFlags sourceDirs packagesToExpose dnFlags = dnFlags {@@ -120,24 +123,26 @@ ,verbosity = 1 ,ghcLink = NoLink ,packageFlags = nub $ map ExposePackageId packagesToExpose ++ oldPackageFlags- } + } where oldPackageFlags = packageFlags dnFlags oldImportPaths = importPaths dnFlags -- * Helper methods getLibDependencies :: ComponentLocalBuildInfo -> [String]-getLibDependencies = componentPackageDeps >>> map (fst >>> installedPackageIdString ) +getLibDependencies =+ componentPackageDeps+ >>> map (fst >>> installedPackageIdString ) convertModuleNameToString :: ModuleName -> String convertModuleNameToString modName | null modArr = "" | otherwise = foldr1 (\w s -> w ++ '.':s) modArr- where modArr = components modName + where modArr = components modName -- | Check and filter all invalid main definission-checkInvalidMain :: ShakerInput -> IO ShakerInput +checkInvalidMain :: ShakerInput -> IO ShakerInput checkInvalidMain shIn = mapM checkInvalidMain' (shakerCompileInputs shIn) >>= \newCplInp -> return $ shIn {shakerCompileInputs = newCplInp } @@ -150,26 +155,26 @@ where oldTargets = compileInputTargetFiles cplInput -- | Expose needed package-exposeNeededPackages :: LocalBuildInfo -> ShakerInput -> IO ShakerInput +exposeNeededPackages :: LocalBuildInfo -> ShakerInput -> IO ShakerInput exposeNeededPackages lbi shIn = do listPackages <- runReaderT getListNeededPackages shIn putStrLn $ "Exposing packages " ++ show listPackages let packageFlagsToAdd = map ExposePackageId $ filter ( \ name -> not $ currentPackage `isPrefixOf` name ) listPackages let oldListenerInput = shakerListenerInput shIn- let listenerInputFilesToMerge = mempty + let listenerInputFilesToMerge = mempty let newCpIns = map ( \a -> mappend a $ mempty { compileInputDynFlags = addPackageToDynFlags packageFlagsToAdd } ) (shakerCompileInputs shIn) let newListFileListenInfo = map ( `mappend` listenerInputFilesToMerge) (listenerInputFiles oldListenerInput ) let newListenerInput = oldListenerInput { listenerInputFiles = newListFileListenInfo } return $ shIn {shakerCompileInputs = newCpIns, shakerListenerInput= newListenerInput } where addPackageToDynFlags packageFlagToAdd dynFlags = dynFlags { packageFlags = packageFlags dynFlags ++ packageFlagToAdd- } + } currentPackage = localPkgDescr >>> package >>> pkgName >>> unPackageName $ lbi unPackageName (PackageName v) = v -fillPackageIndex :: ShakerInput -> IO ShakerInput +fillPackageIndex :: ShakerInput -> IO ShakerInput fillPackageIndex shIn = do- (Just pkgIndex) <- getInstalledPackages normal lbi_compiler [GlobalPackageDB] lbi_programConfiguration + pkgIndex <- getInstalledPackages normal lbi_compiler [GlobalPackageDB] lbi_programConfiguration return shIn { shakerPackageIndex = pkgIndex } where lbi_compiler = shakerLocalBuildInfo >>> compiler $ shIn lbi_programConfiguration = shakerLocalBuildInfo >>> withPrograms $ shIn
src/Shaker/CabalInterface.hs view
@@ -1,19 +1,37 @@-module Shaker.CabalInterface +module Shaker.CabalInterface where import Control.Monad.Reader+import Control.Arrow+import Distribution.PackageDescription import Distribution.Simple.Build-import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.GHC(ghcOptions)+import Distribution.Simple.LocalBuildInfo import Distribution.Simple.PreProcess import Distribution.Verbosity import Shaker.Type+import System.FilePath generateAutogenFiles :: LocalBuildInfo -> IO () generateAutogenFiles lbi = writeAutogenFiles normal (localPkgDescr lbi) lbi applyPreprocessSources :: Shaker IO () applyPreprocessSources = do- lbi <- asks shakerLocalBuildInfo + lbi <- asks shakerLocalBuildInfo let pkgDescription = localPkgDescr lbi- lift $ preprocessSources pkgDescription lbi False normal knownSuffixHandlers + lift $ preprocessSources pkgDescription lbi False normal knownSuffixHandlers++getPreprocessorDirectory :: LocalBuildInfo -> Executable -> FilePath+getPreprocessorDirectory lbi Executable {exeName = exeName'}=+ buildDir lbi </> exeName' </> exeName' ++ "-tmp"++getCompileFlagsForExecutable :: LocalBuildInfo -> Executable -> ComponentLocalBuildInfo -> [String]+getCompileFlagsForExecutable lbi executable componentLocalBuildInfo =+ ghcOptions lbi (buildInfo executable) componentLocalBuildInfo defaultDistDir ++ preprocessLocation+ where preprocessLocation = ["-i" ++ getPreprocessorDirectory lbi executable]++getCompileFlagsForLibrary :: LocalBuildInfo -> Library -> ComponentLocalBuildInfo -> [String]+getCompileFlagsForLibrary lbi lib componentLocalBuildInfo =+ preprocessLocation : ghcOptions lbi (libBuildInfo lib) componentLocalBuildInfo defaultDistDir+ where preprocessLocation = "-i" ++getPreprocessorDirectory lbi (localPkgDescr >>> executables >>> head $ lbi)
src/Shaker/Cli.hs view
@@ -14,6 +14,7 @@ import Data.Char import Data.List import qualified Data.Map as M+import Shaker.CommonUtil import Shaker.Parser import Shaker.Type import System.Console.Haskeline@@ -21,23 +22,23 @@ -- | Listen to keyboard input and parse command getInput :: Shaker IO( IO() ) getInput = do- shIn <- ask - return $ runInputT (myDefaultSettings shIn) $ withInterrupt $ processInput shIn + shIn <- ask+ return $ runInputT (myDefaultSettings shIn) $ withInterrupt $ processInput shIn --- | Execute the entered command +-- | Execute the entered command processInput :: ShakerInput -> InputT IO() processInput shIn = do let (InputState inputMv tokenMv) = shakerInputState shIn- _ <- lift $ takeMVar tokenMv + _ <- lift $ takeMVar tokenMv minput <- handleInterrupt (return (Just "quit")) $ getInputLine "% "- case minput of - Nothing -> lift $ tryPutMVar inputMv (Just exitCommand ) >> return () + case minput of+ Nothing -> lift $ tryPutMVar inputMv (Just exitCommand ) >> return () Just str -> either error_action normal_action (parseCommand str shIn) where error_action err = lift $ print err >> tryPutMVar inputMv Nothing >> return() normal_action val = lift $ tryPutMVar inputMv (Just val) >> return() --- * Auto-completion management +-- * Auto-completion management -- | Settings for haskeline myDefaultSettings :: MonadIO m => ShakerInput-> Settings m@@ -57,11 +58,9 @@ autocompleteFunction cmdMap [] = map simpleCompletion $ M.keys cmdMap autocompleteFunction cmdMap cliInput = map simpleCompletion compleListProp where inpWords = (words . map toLower) cliInput- lastWord = last inpWords + lastWord = last inpWords listProp = filter (lastWord `isPrefixOf`) $ M.keys cmdMap commonPref = unwords (init inpWords) compleListProp = trimList $ map (\a -> commonPref ++ " " ++ a) listProp -trimList :: [String] -> [String]-trimList = map (dropWhile (== ' '))
+ src/Shaker/CommonUtil.hs view
@@ -0,0 +1,14 @@+module Shaker.CommonUtil+ where++separateEqual :: Eq a => [a] -> [[a]]+separateEqual [] = []+separateEqual lst = foldl separateEqual' [] lst++separateEqual' :: Eq a => [[a]] -> a -> [[a]]+separateEqual' [] el = [[el]]+separateEqual' (fstLst:xs) el | el `elem` fstLst = fstLst : separateEqual' xs el+ | otherwise = (fstLst++[el]):xs++trimList :: [String] -> [String]+trimList = map (dropWhile (== ' '))
src/Shaker/Conductor.hs view
@@ -1,4 +1,4 @@--- | Conductor is responsible to control the command-line listener, +-- | Conductor is responsible to control the command-line listener, -- the listener manager and the action to execute module Shaker.Conductor (initThread, executeCommand)@@ -15,84 +15,84 @@ import Shaker.Listener import Shaker.ModuleData import Shaker.Type- --- | Initialize the master thread ++-- | Initialize the master thread -- Once quit is called, all threads are killed initThread :: Shaker IO() initThread = do shIn <- ask- input_action <- getInput - lift ( forkIO ( forever input_action) ) >>= addThreadIdToQuitMVar - let main_loop = runReaderT mainThread shIn + input_action <- getInput+ lift ( forkIO ( forever input_action) ) >>= addThreadIdToQuitMVar+ let main_loop = runReaderT mainThread shIn lift ( forkIO (forever main_loop) ) >>= addThreadIdToQuitMVar quit_token <- asks (threadDataQuitToken . shakerThreadData) _ <- lift $ takeMVar quit_token- cleanAllThreads - --- | The main thread. + cleanAllThreads++-- | The main thread. mainThread :: Shaker IO() mainThread = do (InputState inputMv tokenMv) <- asks shakerInputState _ <- lift $ tryPutMVar tokenMv 42- maybe_cmd <- lift $ takeMVar inputMv + maybe_cmd <- lift $ takeMVar inputMv executeCommand maybe_cmd -initializeConductorData :: Shaker IO () -> Shaker IO ConductorData +initializeConductorData :: Shaker IO () -> Shaker IO ConductorData initializeConductorData fun = do shIn <- ask- lstState <- initializeListener - mapM_ addThreadIdToListenMVar $ threadIds lstState + lstState <- initializeListener+ mapM_ addThreadIdToListenMVar $ threadIds lstState let theFun a = runReaderT fun shIn {shakerModifiedInfoFiles = a} return $ ConductorData lstState theFun- + cleanAllThreads :: Shaker IO ()-cleanAllThreads = do +cleanAllThreads = do asks ( threadDataListenList . shakerThreadData ) >>= cleanThreads asks ( threadDataQuitList . shakerThreadData ) >>= cleanThreads cleanThreads :: ThreadIdList -> Shaker IO()-cleanThreads thrdList = lift (readMVar thrdList) >>= lift . mapM_ killThread +cleanThreads thrdList = lift (readMVar thrdList) >>= lift . mapM_ killThread -- | Execute the given action when the modified MVar is filled-threadExecutor :: ConductorData -> Shaker IO () -threadExecutor conductorData = do +threadExecutor :: ConductorData -> Shaker IO ()+threadExecutor conductorData = do shIn <- ask res <- lift $ handleContinuousInterrupt $ runReaderT (threadExecutor' conductorData) shIn when res $ threadExecutor conductorData asks ( threadDataListenList . shakerThreadData ) >>= cleanThreads- + threadExecutor' :: ConductorData -> Shaker IO Bool threadExecutor' (ConductorData listenState fun) = lift $ takeMVar (mvModifiedFiles listenState) >>= fun >> return True -- | Execute Given Command in a new thread executeCommand :: Maybe Command -> Shaker IO ()-executeCommand Nothing = executeAction [Action InvalidAction] -executeCommand (Just (Command OneShot act_list)) = executeAction act_list -executeCommand (Just (Command Continuous act)) = initializeConductorData ( executeAction act ) >>= threadExecutor +executeCommand Nothing = executeAction [Action InvalidAction]+executeCommand (Just (Command OneShot act_list)) = executeAction act_list+executeCommand (Just (Command Continuous act)) = initializeConductorData ( executeAction act ) >>= threadExecutor -- | Execute given action executeAction :: [Action] -> Shaker IO()-executeAction acts = do +executeAction acts = do shIn <- ask let allActs = runReaderT (mapM_ executeAction' acts) shIn lift $ handleActionInterrupt allActs- return () + return () -- | Execute a single action with argument executeAction' :: Action -> Shaker IO()-executeAction' (ActionWithArg actKey args) = +executeAction' (ActionWithArg actKey args) = local (\shIn -> shIn {shakerArgument = args} ) (executeAction' (Action actKey)) -- | Execute a single action without argument executeAction' (Action actKey) = do- plMap <- asks shakerPluginMap + plMap <- asks shakerPluginMap mdatas <- parseAllModuleData local (\shIn -> shIn {shakerModuleData = mdatas} ) (fromJust $ actKey `M.lookup` plMap) --- * Handlers +-- * Handlers handleContinuousInterrupt :: IO Bool -> IO Bool-handleContinuousInterrupt = C.handle catchAll +handleContinuousInterrupt = C.handle catchAll where catchAll :: C.SomeException -> IO Bool catchAll e = putStrLn ("Shaker caught " ++ show e ) >> return False @@ -108,5 +108,5 @@ -- | Add the given threadId to the mvar list addThreadIdToMVar :: ThreadIdList -> ThreadId -> Shaker IO ()-addThreadIdToMVar thrdList thrId = lift $ modifyMVar_ thrdList (\b -> return $ thrId:b) +addThreadIdToMVar thrdList thrId = lift $ modifyMVar_ thrdList (\b -> return $ thrId:b)
src/Shaker/Config.hs view
@@ -9,7 +9,7 @@ import Shaker.Cli(InputState(..)) import Control.Concurrent -defaultInput ::ShakerInput +defaultInput ::ShakerInput defaultInput = ShakerInput { shakerCompileInputs = [mempty] ,shakerListenerInput= mempty@@ -22,34 +22,35 @@ ,shakerLocalBuildInfo = undefined ,shakerPackageIndex = mempty ,shakerModuleData = []+ ,shakerVerbosity = Silent } -defaultInputInitialized :: IO ShakerInput -defaultInputInitialized = do +defaultInputInitialized :: IO ShakerInput+defaultInputInitialized = do defThrdData <- defaultThreadData- input_state <- defaultInputState - return defaultInput { - shakerThreadData = defThrdData - ,shakerInputState = input_state + input_state <- defaultInputState+ return defaultInput {+ shakerThreadData = defThrdData+ ,shakerInputState = input_state } -defaultThreadData :: IO ThreadData -defaultThreadData = do - thread_listen <- newMVar [] :: IO ThreadIdList - thread_quit <- newMVar [] :: IO ThreadIdList - listen_token <- newEmptyMVar - quit_token <- newEmptyMVar +defaultThreadData :: IO ThreadData+defaultThreadData = do+ thread_listen <- newMVar [] :: IO ThreadIdList+ thread_quit <- newMVar [] :: IO ThreadIdList+ listen_token <- newEmptyMVar+ quit_token <- newEmptyMVar return ThreadData { threadDataListenToken = listen_token ,threadDataQuitToken = quit_token ,threadDataListenList = thread_listen ,threadDataQuitList = thread_quit- } + } defaultInputState :: IO InputState defaultInputState = do- inputMv <- newEmptyMVar - tokenMv <- newEmptyMVar - return InputState { shakerInputStateCommand = inputMv, shakerInputStateToken = tokenMv } + inputMv <- newEmptyMVar+ tokenMv <- newEmptyMVar+ return InputState { shakerInputStateCommand = inputMv, shakerInputStateToken = tokenMv }
src/Shaker/GhcInterface.hs view
@@ -3,55 +3,69 @@ initializeGhc ,ghcCompile ,getListNeededPackages- ,installedPackageIdString + ,installedPackageIdString+ ,fillModuleDataTest+ ,addLibraryToDynFlags+ ,searchInstalledPackageId ) where +import Distribution.InstalledPackageInfo+import Distribution.Simple.PackageIndex import Control.Arrow import Control.Monad.Reader(lift, asks ) import Data.List+import Data.Monoid+import Data.Maybe+import Digraph import Distribution.Package (InstalledPackageId(..)) import DynFlags import GHC hiding (parseModule, HsModule) import GHC.Paths-import Linker import HscTypes-import Packages (lookupModuleInAllPackages, exposed, installedPackageId, PackageConfig)+import Linker+import Name (nameOccName)+import OccName (occNameString)+import Outputable+import Packages (lookupModuleInAllPackages, PackageConfig) import qualified Data.Map as M import Shaker.Io import Shaker.Type+import Shaker.ModuleData+import Shaker.CommonUtil+import Var (varName) type ImportToPackages = [ ( String, [PackageConfig] ) ] --- | Get the list of unresolved import and +-- | Get the list of unresolved import and -- unexposed yet needed packages getListNeededPackages :: Shaker IO [String] getListNeededPackages = do cpIn <- fmap head (asks shakerCompileInputs) (PackageData map_import_modules list_project_modules) <- lift mapImportToModules- import_to_packages <- lift $ runGhc (Just libdir) $ do + import_to_packages <- lift $ runGhc (Just libdir) $ do initializeGhc cpIn dyn_flags <- getSessionDynFlags- return $ map ( \ imp -> (imp , lookupModuleInAllPackages dyn_flags . mkModuleName $ imp) ) + return $ map ( \ imp -> (imp , lookupModuleInAllPackages dyn_flags . mkModuleName $ imp) ) >>> map ( second (map fst) )- $ (M.keys map_import_modules \\ list_project_modules) + $ (M.keys map_import_modules \\ list_project_modules) return $ getPackagesToExpose import_to_packages getPackagesToExpose :: ImportToPackages -> [String] getPackagesToExpose = map snd >>> filter (not . null)- >>> filter (all (not . exposed) ) - >>> map head - >>> nubBy (\a b -> getPackage a == getPackage b ) + >>> filter (all (not . exposed) )+ >>> map head+ >>> nubBy (\a b -> getPackage a == getPackage b ) >>> filter (not . exposed)- >>> map getPackage + >>> map getPackage where getPackage = installedPackageId >>> installedPackageIdString installedPackageIdString :: InstalledPackageId -> String-installedPackageIdString (InstalledPackageId v) = v +installedPackageIdString (InstalledPackageId v) = v initializeGhc :: GhcMonad m => CompileInput -> m ()-initializeGhc cpIn@(CompileInput _ _ procFlags strflags targetFiles) = do +initializeGhc cpIn@(CompileInput _ _ procFlags strflags targetFiles) = do modifySession (\h -> h {hsc_HPT = emptyHomePackageTable} ) dflags <- getSessionDynFlags (newFlags,_,_) <- parseDynamicFlags dflags (map noLoc strflags)@@ -60,18 +74,18 @@ target <- mapM (`guessTarget` Nothing) targetFiles setTargets target --- | Configure and load targets of compilation. +-- | Configure and load targets of compilation. -- It is possible to exploit the compilation result after this step. ghcCompile :: GhcMonad m => CompileInput -> m SuccessFlag-ghcCompile cpIn = do +ghcCompile cpIn = do initializeGhc cpIn dflags <- getSessionDynFlags liftIO $ unload dflags [] load LoadAllTargets --- | Change the dynflags with information from the CompileInput like importPaths +-- | Change the dynflags with information from the CompileInput like importPaths -- and .o and .hi fileListenInfoDirectory-configureDynFlagsWithCompileInput :: CompileInput -> DynFlags -> DynFlags +configureDynFlagsWithCompileInput :: CompileInput -> DynFlags -> DynFlags configureDynFlagsWithCompileInput cpIn dflags = dflags{ importPaths = sourceDirs ,objectDir = Just compileTarget@@ -79,4 +93,87 @@ } where compileTarget = compileInputBuildDirectory cpIn sourceDirs = compileInputSourceDirs cpIn++-- * Test discovering++fillModuleDataTest :: [ModuleData] -> Shaker IO [[ModuleData]]+fillModuleDataTest = separateEqual+ >>> mapM fillModuleDataTest'++fillModuleDataTest' :: [ModuleData] -> Shaker IO [ModuleData]+fillModuleDataTest' modDatas = do+ cpIn <- fmap mconcat (asks shakerCompileInputs)+ let newCpIn = cpIn {+ compileInputTargetFiles = map moduleDataFileName modDatas+ }+ ghcModuleDatas <- lift $ runGhc (Just libdir) $ do+ _ <- ghcCompile newCpIn+ mss <- depanal [] False+ let sort_mss = flattenSCCs $ topSortModuleGraph True mss Nothing+ mapM convertModSummaryToModuleData sort_mss+ mergeMdatas+ >>> filter (\a -> moduleDataName a /= "")+ >>> removeNonTestModules+ >>> return $ (modDatas ++ ghcModuleDatas)++mergeMdatas :: [ModuleData] -> [ModuleData]+mergeMdatas lstMdatas = map (\mdata -> filter (==mdata) >>> mconcat $ lstMdatas) uniqueMdata+ where uniqueMdata = nub lstMdatas++-- | Collect module name and tests name for the given module+convertModSummaryToModuleData :: (GhcMonad m) => ModSummary -> m ModuleData+convertModSummaryToModuleData modSum = do+ mayModuleInfo <- getModuleInfo $ ms_mod modSum+ let assertions = getHunitAssertions mayModuleInfo+ let testCases = getHunitTestCase mayModuleInfo+ return GhcModuleData {+ ghcModuleDataName = modName+ ,ghcModuleDataAssertions = assertions+ ,ghcModuleDataTestCase = testCases+ }+ where modName = (moduleNameString . moduleName . ms_mod) modSum++getHunitAssertions :: Maybe ModuleInfo -> [String]+getHunitAssertions = getFunctionTypeWithPredicate (== "Test.HUnit.Lang.Assertion")++getHunitTestCase :: Maybe ModuleInfo -> [String]+getHunitTestCase = getFunctionTypeWithPredicate (== "Test.HUnit.Base.Test")++getFunctionTypeWithPredicate :: (String -> Bool) -> Maybe ModuleInfo -> [String]+getFunctionTypeWithPredicate _ Nothing = []+getFunctionTypeWithPredicate predicat (Just modInfo) =+ getIdExportedList+ >>> map ((showPpr . idType) &&& getFunctionNameFromId )+ >>> filter (predicat . fst)+ >>> map snd $ modInfo++getFunctionNameFromId :: Id -> String+getFunctionNameFromId = occNameString . nameOccName . varName++getIdExportedList :: ModuleInfo -> [Id]+getIdExportedList modInfo = modInfoTyThings+ >>> mapMaybe tyThingToId+ >>> filter (\a -> varName a `elem` lstExportedNames)+ $ modInfo+ where lstExportedNames = modInfoExports modInfo++tyThingToId :: TyThing -> Maybe Id+tyThingToId (AnId tyId) = Just tyId+tyThingToId _ = Nothing++addLibraryToDynFlags :: [String] -> DynFlags -> DynFlags+addLibraryToDynFlags listInstalledPkgId dflags = dflags {+ packageFlags = nub $ map ExposePackageId listInstalledPkgId ++ oldPackageFlags+ }+ where oldPackageFlags = packageFlags dflags++searchInstalledPackageId :: String -> Shaker IO (Maybe String)+searchInstalledPackageId pkgName = do+ pkgIndex <- asks shakerPackageIndex+ let srchRes = searchByName pkgIndex pkgName+ return $ processSearchResult srchRes+ where processSearchResult None = Nothing+ processSearchResult (Unambiguous a) = Just $ installedPackageId >>> installedPackageIdString $ last a+ processSearchResult (Ambiguous (a:_)) = Just $ installedPackageId >>> installedPackageIdString $ last a+ processSearchResult _ = Nothing
src/Shaker/HsHelper.hs view
@@ -26,7 +26,6 @@ ParseOk val -> Just val _ -> Nothing - hsModuleCollectProperties :: HsModule -> [String] hsModuleCollectProperties = getListFunction >>> filter (isPrefixOf "prop_") @@ -35,16 +34,6 @@ >>> filterSnd fun >>> map fst -hsModuleCollectTest :: HsModule -> [String]-hsModuleCollectTest = abstractCollectFunctionWithUnqualifiedType predicat- where predicat (HsQualType _ (HsTyCon (UnQual hsName) ) ) = hsName == HsIdent "Test"- predicat _ = False--hsModuleCollectAssertions :: HsModule -> [String]-hsModuleCollectAssertions = abstractCollectFunctionWithUnqualifiedType predicat- where predicat (HsQualType _ (HsTyCon (UnQual hsName) ) ) = hsName == HsIdent "Assertion"- predicat _ = False- filterSnd :: (b -> Bool) -> [(a,b)] -> [(a,b)] filterSnd fun = filter (snd >>> fun) @@ -63,7 +52,7 @@ getFunBindName :: HsDecl -> Maybe String getFunBindName (HsPatBind _ (HsPVar (HsIdent funName))_ _) = Just funName-getFunBindName (HsFunBind ((HsMatch _ (HsIdent funName) _ _ _ ) :_) ) = Just funName+getFunBindName (HsFunBind (HsMatch _ (HsIdent funName) _ _ _ :_) ) = Just funName getFunBindName _ = Nothing getIdentFromHsName :: HsName -> String
src/Shaker/ModuleData.hs view
@@ -62,6 +62,7 @@ -- * Module data util methods + convertModuleDataToFullCompileInput :: Shaker IO [CompileInput] convertModuleDataToFullCompileInput = do baseCpIn <- fmap mconcat (asks shakerCompileInputs)@@ -89,13 +90,11 @@ return shIn { shakerModuleData = map constructModuleData lstHsModules } constructModuleData :: HsModule -> ModuleData-constructModuleData hsModule = ModuleData {+constructModuleData hsModule = mempty { moduleDataName = hsModuleName hsModule ,moduleDataFileName = hsModuleFileName hsModule ,moduleDataHasMain = getTupleFunctionNameType >>> map fst >>> any (=="main") $ hsModule ,moduleDataProperties = hsModuleCollectProperties hsModule- ,moduleDataAssertions = hsModuleCollectAssertions hsModule- ,moduleDataTestCase = hsModuleCollectTest hsModule } hsModuleDataHasTest :: ModuleData -> Bool@@ -111,6 +110,10 @@ filterFunctionsWithPatterns mod_map patterns = map (`filterFunctionsWithPatterns'` patterns) mod_map filterFunctionsWithPatterns' :: ModuleData -> [String] -> ModuleData+filterFunctionsWithPatterns' moduleData@(GhcModuleData _ listAssertions listTestCase) patterns = moduleData {+ ghcModuleDataAssertions = processListWithRegexp listAssertions [] patterns+ ,ghcModuleDataTestCase = processListWithRegexp listTestCase [] patterns+ } filterFunctionsWithPatterns' moduleData@(ModuleData _ _ _ properties hunitAssertions hunitTestCases) patterns = moduleData { moduleDataAssertions = processListWithRegexp hunitAssertions [] patterns ,moduleDataTestCase = processListWithRegexp hunitTestCases [] patterns@@ -120,4 +123,5 @@ removeNonTestModules :: [ModuleData] -> [ModuleData] removeNonTestModules = filter ( \ moduleData -> any notEmpty [moduleDataProperties moduleData, moduleDataAssertions moduleData, moduleDataTestCase moduleData] ) where notEmpty = not . null+
src/Shaker/Parser.hs view
@@ -6,13 +6,16 @@ import Data.Char -import Text.ParserCombinators.Parsec+import Text.Parsec.Combinator+import Text.Parsec+import Text.Parsec.ByteString import Shaker.Type import qualified Data.Map as M+import qualified Data.ByteString.Char8 as B -- | Parse the given string to a Command parseCommand :: String -> ShakerInput -> Either ParseError Command-parseCommand str shIn = parse (typeCommand cmd_map) "parseCommand" str+parseCommand str shIn = parse (typeCommand cmd_map) "parseCommand" (B.pack str) where cmd_map = shakerCommandMap shIn -- | Parse a Command
src/Shaker/Reflexivite.hs view
@@ -2,30 +2,18 @@ RunnableFunction(..) -- * Collect module information functions ,runFunction- ,searchInstalledPackageId- -- * Template haskell generator- ,listAllTestFrameworkGroupList- ,filterModulesWithPattern- ,filterFunctionsWithPatterns- ,listTestFrameworkGroupList ) where -import Control.Arrow import Control.Exception as C import Control.Monad.Reader-import Data.List import Data.Maybe-import Distribution.InstalledPackageInfo-import Distribution.Simple.PackageIndex import DynFlags import GHC import GHC.Paths-import Language.Haskell.TH import Shaker.Action.Compile import Shaker.GhcInterface-import Shaker.ModuleData-import Shaker.Type +import Shaker.Type import Unsafe.Coerce data RunnableFunction = RunnableFunction {@@ -36,78 +24,31 @@ deriving Show -- | Compile, load and run the given function-runFunction :: RunnableFunction -> Shaker IO()-runFunction (RunnableFunction importModuleList listLibs fun) = do- cpIn <- getNonMainCompileInput+runFunction :: CompileInput -> RunnableFunction -> Shaker IO()+runFunction cpIn (RunnableFunction importModuleList listLibs fun) = do listInstalledPkgId <- fmap catMaybes (mapM searchInstalledPackageId listLibs) dynFun <- lift $ runGhc (Just libdir) $ do dflags <- getSessionDynFlags- _ <- setSessionDynFlags (addShakerLibraryAsImport listInstalledPkgId (dopt_set dflags Opt_HideAllPackages))- _ <- ghcCompile cpIn + _ <- setSessionDynFlags (addLibraryToDynFlags listInstalledPkgId (dopt_set dflags Opt_HideAllPackages))+ _ <- ghcCompile cpIn configureContext importModuleList value <- compileExpr fun do let value' = unsafeCoerce value :: a return value' _ <- lift $ handleActionInterrupt dynFun return ()- where - configureContext [] = getModuleGraph >>= \mGraph -> setContext [] $ map ms_mod mGraph- configureContext imports = mapM (\a -> findModule (mkModuleName a) Nothing ) imports >>= \m -> setContext [] m--addShakerLibraryAsImport :: [String] -> DynFlags -> DynFlags-addShakerLibraryAsImport listInstalledPkgId dflags = dflags {- packageFlags = nub $ map ExposePackageId listInstalledPkgId ++ oldPackageFlags- }- where oldPackageFlags = packageFlags dflags--searchInstalledPackageId :: String -> Shaker IO (Maybe String)-searchInstalledPackageId pkgName = do - pkgIndex <- asks shakerPackageIndex- let srchRes = searchByName pkgIndex pkgName - return $ processSearchResult srchRes- where processSearchResult None = Nothing- processSearchResult (Unambiguous a) = Just $ installedPackageId >>> installedPackageIdString $ head a- processSearchResult (Ambiguous (a:_)) = Just $ installedPackageId >>> installedPackageIdString $ head a- processSearchResult _ = Nothing+ where+ genTuple :: ModSummary -> (Module, Maybe (ImportDecl RdrName))+ genTuple modSummary = (ms_mod modSummary, Nothing)+ configureContext [] = do+ modGraph <- getModuleGraph+ setContext [] (map genTuple modGraph)+ configureContext imports = do+ mods <- mapM (\a -> findModule (mkModuleName a) Nothing) imports+ setContext [] $ map (\m -> (m, Nothing) ) mods handleActionInterrupt :: IO() -> IO() handleActionInterrupt = C.handle catchAll where catchAll :: C.SomeException -> IO ()- catchAll e = putStrLn ("Shaker caught " ++ show e ) >> return () ---- | List all test group of the project.--- see "Shaker.TestTH" -listAllTestFrameworkGroupList :: ShakerInput -> ExpQ-listAllTestFrameworkGroupList = shakerModuleData >>> removeNonTestModules >>> listTestFrameworkGroupList ---- | List all test group for test-framework from the list of modules-listTestFrameworkGroupList :: [ModuleData] -> ExpQ-listTestFrameworkGroupList = return . ListE . map getSingleTestFrameworkGroup---- * Test framework integration ---- | Generate a test group for a given module-getSingleTestFrameworkGroup :: ModuleData -> Exp-getSingleTestFrameworkGroup moduleData = foldl1 AppE [process_to_group_exp, test_case_tuple_list, list_assertion, list_prop]- where process_to_group_exp = AppE (VarE .mkName $ "processToTestGroup") (LitE (StringL $ moduleDataName moduleData))- list_prop = ListE $ map getSingleFrameworkQuickCheck $ moduleDataProperties moduleData- list_assertion = ListE $ map getSingleFrameworkHunit $ moduleDataAssertions moduleData- test_case_tuple_list = convertHunitTestCaseToTuples (moduleDataTestCase moduleData)--convertHunitTestCaseToTuples :: [String] -> Exp-convertHunitTestCaseToTuples = ListE . map convertToTuple - where convertToTuple name = TupE [LitE (StringL name), VarE $ mkName name ]---- | Generate an expression for a single hunit test-getSingleFrameworkHunit :: String -> Exp -getSingleFrameworkHunit hunitName = AppE testcase_with_name_exp assertion_exp- where testcase_with_name_exp = AppE ( VarE $ mkName "testCase") (LitE $ StringL hunitName)- assertion_exp = VarE . mkName $ hunitName---- | Generate an expression for a single quickcheck property-getSingleFrameworkQuickCheck :: String -> Exp-getSingleFrameworkQuickCheck propName = AppE testproperty_with_name_exp property_exp - where canonical_name = tail . dropWhile (/= '_') $ propName - testproperty_with_name_exp = AppE ( VarE $ mkName "testProperty") (LitE $ StringL canonical_name)- property_exp = VarE . mkName $ propName+ catchAll e = putStrLn ("Shaker caught " ++ show e ) >> return ()
− src/Shaker/TestHelper.hs
@@ -1,19 +0,0 @@-module Shaker.TestHelper (- processToTestGroup- ) where--import Data.Maybe--import Test.HUnit as H-import Test.Framework.Providers.API as T (Test, testGroup)-import Test.Framework.Providers.HUnit --convertTestCaseToTestFrameworkTestCase :: (String, H.Test) -> Maybe T.Test-convertTestCaseToTestFrameworkTestCase (name, TestCase assertion) = Just $ testCase name assertion-convertTestCaseToTestFrameworkTestCase (_, TestLabel name hunit_test) = convertTestCaseToTestFrameworkTestCase (name, hunit_test)-convertTestCaseToTestFrameworkTestCase _ = Nothing--processToTestGroup :: String -> [(String, H.Test)] -> [T.Test] -> [T.Test] -> T.Test-processToTestGroup testName testCaseList assertionList propertyList = testGroup testName $ concat [listHunitTestCase, assertionList, propertyList]- where listHunitTestCase = mapMaybe convertTestCaseToTestFrameworkTestCase testCaseList-
src/Shaker/TestTH.hs view
@@ -3,15 +3,44 @@ module Shaker.TestTH where -import Shaker.Reflexivite+import Control.Arrow import Language.Haskell.TH-import Shaker.CabalInfo+import Shaker.ModuleData+import Shaker.Type --- | Template for the test group.--- Currently generate a list of type [Test] with a test group per module----thListTestFramework :: ExpQ -thListTestFramework = do- shIn <- runIO defaultCabalInput - listAllTestFrameworkGroupList shIn+-- | List all test group of the project.+-- see "Shaker.TestTH" +listAllTestFrameworkGroupList :: ShakerInput -> ExpQ+listAllTestFrameworkGroupList = shakerModuleData >>> removeNonTestModules >>> listTestFrameworkGroupList ++-- | List all test group for test-framework from the list of modules+listTestFrameworkGroupList :: [ModuleData] -> ExpQ+listTestFrameworkGroupList = return . ListE . map getSingleTestFrameworkGroup++-- * Test framework integration ++-- | Generate a test group for a given module+getSingleTestFrameworkGroup :: ModuleData -> Exp+getSingleTestFrameworkGroup moduleData = foldl1 AppE [process_to_group_exp, test_case_tuple_list, list_assertion, list_prop]+ where process_to_group_exp = AppE (VarE .mkName $ "processToTestGroup") (LitE (StringL $ moduleDataName moduleData))+ list_prop = ListE $ map getSingleFrameworkQuickCheck $ moduleDataProperties moduleData+ list_assertion = ListE $ map getSingleFrameworkHunit $ moduleDataAssertions moduleData+ test_case_tuple_list = convertHunitTestCaseToTuples (moduleDataTestCase moduleData)++convertHunitTestCaseToTuples :: [String] -> Exp+convertHunitTestCaseToTuples = ListE . map convertToTuple + where convertToTuple name = TupE [LitE (StringL name), VarE $ mkName name ]++-- | Generate an expression for a single hunit test+getSingleFrameworkHunit :: String -> Exp +getSingleFrameworkHunit hunitName = AppE testcase_with_name_exp assertion_exp+ where testcase_with_name_exp = AppE ( VarE $ mkName "testCase") (LitE $ StringL hunitName)+ assertion_exp = VarE . mkName $ hunitName++-- | Generate an expression for a single quickcheck property+getSingleFrameworkQuickCheck :: String -> Exp+getSingleFrameworkQuickCheck propName = AppE testproperty_with_name_exp property_exp + where canonical_name = tail . dropWhile (/= '_') $ propName + testproperty_with_name_exp = AppE ( VarE $ mkName "testProperty") (LitE $ StringL canonical_name)+ property_exp = VarE . mkName $ propName
src/Shaker/Type.hs view
@@ -84,6 +84,10 @@ data Command = Command Duration [Action] deriving (Show,Eq) +data Verbosity = + Silent+ | Debug+ -- | Represents the global configuration of the system data ShakerInput = ShakerInput { shakerCompileInputs :: [CompileInput]@@ -97,6 +101,7 @@ ,shakerLocalBuildInfo :: LocalBuildInfo ,shakerPackageIndex :: PackageIndex ,shakerModuleData :: [ModuleData]+ ,shakerVerbosity :: Verbosity } data ThreadData = ThreadData {@@ -194,8 +199,40 @@ ,moduleDataProperties :: [String] ,moduleDataAssertions :: [String] ,moduleDataTestCase :: [String]- } deriving (Show, Read)+ } | GhcModuleData { + ghcModuleDataName :: String+ ,ghcModuleDataAssertions :: [String]+ ,ghcModuleDataTestCase :: [String]+ }+ deriving (Read, Show) +instance Monoid ModuleData where+ mempty = ModuleData "" "" False [] [] []+ mappend fstModData@(GhcModuleData _ _ _) sndModData@(ModuleData _ _ _ _ _ _) = sndModData `mappend` fstModData+ mappend fstModData@(ModuleData _ _ _ fstProps fstAsserts fstTestCases) sndModData = + fstModData {+ moduleDataProperties = nub $ fstProps ++ sndProps+ ,moduleDataAssertions = nub $ fstAsserts ++ sndAsserts+ ,moduleDataTestCase = nub $ fstTestCases ++ sndTestCases+ }+ where (sndProps, sndAsserts, sndTestCases) = getModuleDataTests sndModData+ mappend fstModData@(GhcModuleData _ fstTestCases fstAsserts) sndModData = fstModData {+ ghcModuleDataTestCase = nub $ fstTestCases ++ sndTestCases+ ,ghcModuleDataAssertions = nub $ fstAsserts ++ sndAsserts+ }+ where (_, sndAsserts, sndTestCases) = getModuleDataTests sndModData++instance Eq ModuleData where+ mod1 == mod2 = getModuleDataName mod1 == getModuleDataName mod2++getModuleDataTests :: ModuleData -> ([String], [String], [String])+getModuleDataTests (ModuleData _ _ _ prps asserts tests)= (prps, asserts, tests)+getModuleDataTests (GhcModuleData _ asserts tests)= ([], asserts, tests)++getModuleDataName :: ModuleData -> String+getModuleDataName (ModuleData name _ _ _ _ _) = name+getModuleDataName (GhcModuleData name _ _) = name+ type MapImportToModules = M.Map String [String] -- | Represents the mapping beetween an action and the function to execute type PluginMap = M.Map ShakerAction Plugin@@ -227,17 +264,15 @@ exitCommand :: Command exitCommand = Command OneShot [Action Quit] -emptyCommand :: Command -emptyCommand = Command OneShot [Action Empty] +emptyCommand :: Command+emptyCommand = Command OneShot [Action Empty] listTestLibs :: [String]-listTestLibs = ["QuickCheck","HUnit","test-framework-hunit","test-framework","test-framework-quickcheck2","shaker"] --instance Eq ModuleData where- mod1 == mod2 = moduleDataName mod1 == moduleDataName mod2+listTestLibs = ["QuickCheck","HUnit","test-framework-hunit","test-framework","test-framework-quickcheck2","shaker-test-provider"] moduleDataExtension :: String moduleDataExtension = ".mdata" defaultDistDir :: String defaultDistDir = "dist/shakerTarget"+