Permalink
Browse files

some cleanup

  • Loading branch information...
phischu committed Mar 25, 2013
1 parent 5016090 commit 8ec592b9e96bd4a577da01dcf891034d16c1794a
Showing with 18 additions and 91 deletions.
  1. +1 −0 Master.cabal
  2. +10 −83 Master.hs
  3. +7 −8 MasterPipe.hs
View
@@ -23,6 +23,7 @@ executable Master
Cabal,
shake,
directory,
+ filepath,
errors,
pipes,
pipes-safe
View
@@ -7,40 +7,23 @@ import Development.Shake.Classes
import qualified System.Directory as IO
import qualified Data.Map as M
-import Data.Maybe
-import Control.Monad
-import Control.Error
-import Control.Exception.Base
-import Distribution.Text
+import Control.Monad (when)
+import Distribution.Text (disp)
import qualified Data.Version as V
import Distribution.Hackage.DB (readHackage')
-import Distribution.PackageDescription.Parse
-import Distribution.PackageDescription
-import Distribution.ModuleName hiding (main)
-import Distribution.Verbosity
-import Distribution.PackageDescription.Configuration
-import Distribution.System
-import Distribution.Compiler
-import qualified MasterPipe
+import qualified MasterPipe (masterpipe,Package(Package))
newtype Package = Package (Name,Version) deriving (Show,Typeable,Eq,Hashable,Binary,NFData)
type Name = String
type Version = String
-newtype Module = Module (Name,Location) deriving (Show,Typeable,Eq,Hashable,Binary,NFData,Read)
-type Location = FilePath
-
newtype ExtractedPackage = ExtractedPackage Package deriving (Show,Typeable,Eq,Hashable,Binary,NFData)
newtype PackageArchive = PackageArchive Package deriving (Show,Typeable,Eq,Hashable,Binary,NFData)
newtype GetPackageList = GetPackageList () deriving (Show,Typeable,Eq,Hashable,Binary,NFData)
newtype PackageList = PackageList [Package] deriving (Show,Typeable,Eq,Hashable,Binary,NFData)
-newtype GetModulesInPackage = GetModulesInPackage Package deriving (Show,Typeable,Eq,Hashable,Binary,NFData)
-newtype CreateModuleList = CreateModuleList Package deriving (Show,Typeable,Eq,Hashable,Binary,NFData)
-newtype ModuleList = ModuleList [Module] deriving (Show,Typeable,Eq,Hashable,Binary,NFData,Read)
-newtype GetAST = GetAST (Package,Module) deriving (Show,Typeable,Eq,Hashable,Binary,NFData)
newtype CreatePackageList = CreatePackageList () deriving (Show,Typeable,Eq,Hashable,Binary,NFData)
newtype RunMasterPipe = RunMasterPipe () deriving (Show,Typeable,Eq,Hashable,Binary,NFData)
@@ -57,11 +40,6 @@ instance Rule PackageArchive () where
instance Rule GetPackageList PackageList where
storedValue (GetPackageList ()) = return Nothing
-instance Rule CreateModuleList () where
- storedValue (CreateModuleList package) = do
- exists <- IO.doesFileExist (moduleListFile package)
- if exists then return (Just ()) else return Nothing
-
instance Rule CreatePackageList () where
storedValue _ = do
exists <- IO.doesFileExist "packages.list"
@@ -70,9 +48,6 @@ instance Rule CreatePackageList () where
instance Rule RunMasterPipe () where
storedValue _ = return Nothing
-instance Rule GetAST () where
- storedValue = undefined
-
packageIdentifier :: Package -> String
packageIdentifier (Package (name,version)) = name++"-"++version
@@ -82,9 +57,6 @@ extractedDirectory = "Packages/"
archiveDirectory :: Package -> FilePath
archiveDirectory package = "Archives/"++packageIdentifier package++".tar.gz"
-moduleListFile :: Package -> FilePath
-moduleListFile package = "ModuleLists/"++packageIdentifier package++".modulelist"
-
packageUrl :: Package -> String
packageUrl (Package (name,version)) = concat ["hackage.haskell.org/packages/archive/",name,"/",version,"/",name,"-",version,".tar.gz"]
@@ -109,20 +81,16 @@ main = shakeArgs shakeOptions {shakeThreads = 4} $ do
rule (\(ExtractedPackage package@(Package (name,version))) -> Just $ do
exists <- liftIO (IO.doesDirectoryExist (extractedDirectory++name++"-"++version))
- if exists
- then return ()
- else do
- liftIO (IO.createDirectoryIfMissing True extractedDirectory)
- () <- apply1 (PackageArchive package)
- system' "tar" ["xzf",archiveDirectory package,"-C",extractedDirectory])
+ when (not exists) (do
+ liftIO (IO.createDirectoryIfMissing True extractedDirectory)
+ () <- apply1 (PackageArchive package)
+ system' "tar" ["xzf",archiveDirectory package,"-C",extractedDirectory]))
rule (\(PackageArchive package) -> Just $ do
exists <- liftIO (IO.doesFileExist (archiveDirectory package))
- if exists
- then return ()
- else do
- liftIO (IO.createDirectoryIfMissing True (takeDirectory (archiveDirectory package)))
- system' "wget" ["-nv","-O",archiveDirectory package,packageUrl package])
+ when (not exists) (do
+ liftIO (IO.createDirectoryIfMissing True (takeDirectory (archiveDirectory package)))
+ system' "wget" ["-nv","-O",archiveDirectory package,packageUrl package]))
"00-index.tar" *> (\out -> do
system' "wget" ["-nv","hackage.haskell.org/packages/archive/00-index.tar.gz"]
@@ -132,18 +100,8 @@ main = shakeArgs shakeOptions {shakeThreads = 4} $ do
PackageList packages <- apply1 (GetPackageList ())
writeFileLines "packages.list" (map (show . convertPackage) packages))
- rule (\(CreateModuleList package@(Package (name,version))) -> Just $ do
- let packagedirectory = extractedDirectory++packageIdentifier package++"/"
- cabalfile = packagedirectory++name++".cabal"
- need [cabalfile]
- liftIO (createModuleList package))
-
rule (\(RunMasterPipe ()) -> Just (liftIO MasterPipe.masterpipe))
- rule (\(GetAST (package,modul))-> Just $ do
- return ())
-
-
return ()
@@ -158,37 +116,6 @@ addtags :: [String] -> String -> String
addtags [] s = s
addtags (x:xs) s = addtags xs (s++"-"++x)
-data NoModuleListReason = ConfigureFailure |
- NoLibrary |
- IOFailure IOException deriving (Show,Eq)
-
-configurePackage :: Package -> IO (Either () PackageDescription)
-configurePackage package@(Package (name,version)) = do
- let packagedirectory = extractedDirectory++packageIdentifier package++"/"
- cabalfile = packagedirectory++name++".cabal"
- genericpackagedescription <- readPackageDescription silent cabalfile
- let eitherpackagedescription = finalizePackageDescription
- [] (const True) (Platform I386 Linux) (CompilerId GHC (V.Version [7,6,2] [])) [] genericpackagedescription
- return (fmapL (const ()) (fmapR fst (eitherpackagedescription)))
-
-createModuleList :: Package -> IO ()
-createModuleList package@(Package (name,version)) = do
- modulelist <- runEitherT $ do
- packagedescription <- fmapLT (const ConfigureFailure) (EitherT (configurePackage package))
- librarysection <- noteT NoLibrary (hoistMaybe (library packagedescription))
- let modulenames = libModules librarysection
- sourcedirs = hsSourceDirs (libBuildInfo librarysection)
- potentialModules = do
- name <- modulenames
- directory <- sourcedirs
- extension <- [".hs",".lhs"]
- let packagedirectory = extractedDirectory++packageIdentifier package++"/"
- return (Module (show (disp name),packagedirectory++directory++"/"++toFilePath name++extension))
- valid (Module (_,path)) = IO.doesFileExist path
- modules <- liftIO (filterM valid potentialModules)
- return (ModuleList modules)
- IO.createDirectoryIfMissing True (takeDirectory (moduleListFile package))
- writeFile (moduleListFile package) (show modulelist)
View
@@ -4,8 +4,9 @@ import Control.Proxy
import Control.Proxy.Safe
import Control.Proxy.Safe.Prelude
-import Control.Monad (filterM)
-import System.Directory (doesFileExist)
+import Control.Monad (filterM,when)
+import System.Directory (doesFileExist,createDirectoryIfMissing)
+import System.FilePath
import Distribution.PackageDescription
(PackageDescription(..),Library(..),libModules,BuildInfo(..),
@@ -55,12 +56,10 @@ saveConfigurations () = runIdentityP $ forever $ do
(package,configuration) <- request ()
let path = configurationpath package
exists <- lift (doesFileExist path)
- if exists
- then respond (package,configuration)
- else do
- createDirectoryIfMissing True path
- lift (writeFile path (show configuration))
- respond (package,configuration)
+ when (not exists) (do
+ lift (createDirectoryIfMissing True (dropFileName path))
+ lift (writeFile path (show configuration)))
+ respond (package,configuration)
configurations :: (Proxy p,CheckP p) => () -> Pipe p Package (Package,Configuration) IO ()
configurations () = runIdentityP $ forever $ do

0 comments on commit 8ec592b

Please sign in to comment.