Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP

Comparing changes

Choose two branches to see what's changed or to start a new pull request. If you need to, you can also compare across forks.

Open a pull request

Create a new pull request by comparing changes across two branches. If you need to, you can also compare across forks.
...
Checking mergeability… Don't worry, you can still create the pull request.
  • 8 commits
  • 3 files changed
  • 0 commit comments
  • 1 contributor
Showing with 195 additions and 36 deletions.
  1. +6 −7 Master.cabal
  2. +86 −29 Master.hs
  3. +103 −0 MasterPipe.hs
View
13 Master.cabal
@@ -16,18 +16,17 @@ cabal-version: >=1.10
executable Master
main-is: Master.hs
- other-modules: ExtractPackageList,
- DownloadPackages,
- DownloadPackage,
- ExtractPackages,
- ExtractPackage
+ other-modules: MasterPipe
build-depends: base,
hackage-db,
containers,
Cabal,
shake,
- directory
+ directory,
+ errors,
+ pipes,
+ pipes-safe
default-language: Haskell2010
- ghc-options: -rtsopts -threaded
+ ghc-options: -rtsopts -threaded -auto-all -caf-all
View
115 Master.hs
@@ -9,6 +9,8 @@ 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 qualified Data.Version as V
@@ -21,6 +23,8 @@ import Distribution.PackageDescription.Configuration
import Distribution.System
import Distribution.Compiler
+import qualified MasterPipe
+
newtype Package = Package (Name,Version) deriving (Show,Typeable,Eq,Hashable,Binary,NFData)
type Name = String
@@ -34,7 +38,11 @@ newtype PackageArchive = PackageArchive Package deriving (Show,Typeable,Eq,Hasha
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)
instance Rule ExtractedPackage () where
storedValue (ExtractedPackage (Package (name,version))) = do
@@ -49,10 +57,21 @@ instance Rule PackageArchive () where
instance Rule GetPackageList PackageList where
storedValue (GetPackageList ()) = return Nothing
-instance Rule GetModulesInPackage ModuleList where
- storedValue (GetModulesInPackage package) = do
+instance Rule CreateModuleList () where
+ storedValue (CreateModuleList package) = do
exists <- IO.doesFileExist (moduleListFile package)
- if exists then readFile (moduleListFile package) >>= return . Just . read else return Nothing
+ if exists then return (Just ()) else return Nothing
+
+instance Rule CreatePackageList () where
+ storedValue _ = do
+ exists <- IO.doesFileExist "packages.list"
+ if exists then return (Just ()) else return Nothing
+
+instance Rule RunMasterPipe () where
+ storedValue _ = return Nothing
+
+instance Rule GetAST () where
+ storedValue = undefined
packageIdentifier :: Package -> String
packageIdentifier (Package (name,version)) = name++"-"++version
@@ -69,12 +88,18 @@ 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"]
+convertPackage :: Package -> MasterPipe.Package
+convertPackage (package@(Package (name,version))) = MasterPipe.Package name version path where
+ path = extractedDirectory ++ packageIdentifier package ++ "/"
+
main :: IO ()
main = shakeArgs shakeOptions {shakeThreads = 4} $ do
action (do
PackageList packages <- apply1 (GetPackageList ())
- apply (map GetModulesInPackage packages) :: Action [ModuleList])
+ apply (map ExtractedPackage packages) :: Action [()]
+ apply1 (CreatePackageList ()) :: Action ()
+ apply1 (RunMasterPipe ()) :: Action ())
rule (\(GetPackageList ()) -> Just (do
need ["00-index.tar"]
@@ -82,39 +107,42 @@ main = shakeArgs shakeOptions {shakeThreads = 4} $ do
let packages = [Package (name,renderVersion version)| name <- M.keys hackage, version <- M.keys (hackage M.! name)]
return (PackageList (every 1 packages))))
- rule (\(ExtractedPackage package) -> Just $ do
- liftIO (IO.createDirectoryIfMissing True extractedDirectory)
- () <- apply1 (PackageArchive package)
- system' "tar" ["xzf",archiveDirectory package,"-C",extractedDirectory])
+ 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])
rule (\(PackageArchive package) -> Just $ do
- liftIO (IO.createDirectoryIfMissing True (takeDirectory (archiveDirectory package)))
- system' "wget" ["-nv","-O",archiveDirectory package,packageUrl package])
+ 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])
"00-index.tar" *> (\out -> do
system' "wget" ["-nv","hackage.haskell.org/packages/archive/00-index.tar.gz"]
system' "gunzip" ["-f","00-index.tar.gz"])
- rule (\(GetModulesInPackage package@(Package (name,version))) -> Just $ do
+ rule (\(CreatePackageList ()) -> Just $ 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]
- genericpackagedescription <- liftIO (readPackageDescription silent cabalfile)
- let eitherPackagedescription = finalizePackageDescription
- [] (const True) (Platform I386 Linux) (CompilerId GHC (V.Version [7,6,2] [])) [] genericpackagedescription
- packagedescription = either (const []) ((:[]).fst) eitherPackagedescription
- modulenames = packagedescription >>= maybeToList . library >>= libModules
- sourcedirs = packagedescription >>= maybeToList . library >>= hsSourceDirs . libBuildInfo
- potentialModules = do
- name <- modulenames
- directory <- sourcedirs
- extension <- [".hs",".lhs"]
- return (Module (show (disp name),packagedirectory++directory++"/"++toFilePath name++extension))
- valid (Module (_,path)) = doesFileExist path
- modules <- filterM valid potentialModules
- liftIO (IO.createDirectoryIfMissing True (takeDirectory (moduleListFile package)))
- writeFile' (moduleListFile package) (show (ModuleList modules))
- return (ModuleList modules))
+ liftIO (createModuleList package))
+
+ rule (\(RunMasterPipe ()) -> Just (liftIO MasterPipe.masterpipe))
+
+ rule (\(GetAST (package,modul))-> Just $ do
+ return ())
+
return ()
@@ -130,8 +158,37 @@ 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
103 MasterPipe.hs
@@ -0,0 +1,103 @@
+module MasterPipe where
+
+import Control.Proxy
+import Control.Proxy.Safe
+import Control.Proxy.Safe.Prelude
+
+import Control.Monad (filterM)
+import System.Directory (doesFileExist)
+
+import Distribution.PackageDescription
+ (PackageDescription(..),Library(..),libModules,BuildInfo(..),
+ FlagAssignment,GenericPackageDescription)
+import Distribution.PackageDescription.Configuration (finalizePackageDescription)
+import Distribution.Package (Dependency)
+import Distribution.Verbosity (silent)
+import Distribution.PackageDescription.Parse (readPackageDescription)
+import Distribution.System (Platform(Platform),Arch(I386),OS(Linux))
+import Distribution.Compiler (CompilerId(CompilerId),CompilerFlavor(GHC))
+import Distribution.Text (disp)
+import Distribution.ModuleName (toFilePath)
+import qualified Data.Version as V (Version(Version))
+
+
+masterpipe :: IO ()
+masterpipe = runSafeIO $ runProxy $ runEitherK $
+ packages >->
+ tryK (loadConfigurations >-> leftD configurations >-> mapD (either id id) >-> saveConfigurations)
+
+data Package = Package Name Version FilePath deriving (Show,Read,Eq)
+type Name = String
+type Version = String
+
+packages :: (Proxy p) => () -> Producer (ExceptionP p) Package SafeIO ()
+packages = readFileS "packages.list" >-> mapD read
+
+data Configuration = Configuration (Either NoModulesReason ([Module],CPPOptions)) deriving (Show,Read)
+data NoModulesReason = ConfigureFailure | NoLibrary deriving (Show,Read)
+
+loadConfigurations :: (Proxy p,CheckP p) => () -> Pipe p Package (Either Package (Package,Configuration)) IO ()
+loadConfigurations () = runIdentityP $ forever $ do
+ package <- request ()
+ let path = configurationpath package
+ exists <- lift (doesFileExist path)
+ if exists
+ then do
+ configuration <- fmap read (lift (readFile path))
+ respond (Right (package,configuration))
+ else respond (Left package)
+
+configurationpath :: Package -> FilePath
+configurationpath (Package name version _) = "Configurations/" ++ name ++ "-" ++ version ++ ".configuration"
+
+saveConfigurations :: (Proxy p,CheckP p) => () -> Pipe p (Package,Configuration) (Package,Configuration) IO ()
+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)
+
+configurations :: (Proxy p,CheckP p) => () -> Pipe p Package (Package,Configuration) IO ()
+configurations () = runIdentityP $ forever $ do
+ package <- request ()
+ let Package packagename version packagepath = package
+ let cabalfile = packagepath ++ packagename ++ ".cabal"
+ genericpackagedescription <- lift (readPackageDescription silent cabalfile)
+ case configure genericpackagedescription of
+ Left _ -> respond (package,Configuration (Left ConfigureFailure))
+ Right (packagedescription,_) -> do
+ case library packagedescription of
+ Nothing -> respond (package,Configuration (Left NoLibrary))
+ Just librarysection -> do
+ let modulenames = libModules librarysection
+ sourcedirs = hsSourceDirs (libBuildInfo librarysection)
+ potentialModules = do
+ modulename <- modulenames
+ directory <- sourcedirs
+ extension <- [".hs",".lhs"]
+ return (Module (show (disp modulename)) (packagepath ++ directory ++ "/" ++ toFilePath modulename ++ extension))
+ valid (Module _ path) = doesFileExist path
+ cppoptions = CPPOptions (cppOptions (libBuildInfo librarysection))
+ modules <- lift (filterM valid potentialModules)
+ respond (package,Configuration (Right (modules,cppoptions)))
+
+configure :: GenericPackageDescription -> Either [Dependency] (PackageDescription,FlagAssignment)
+configure = finalizePackageDescription [] (const True) (Platform I386 Linux) (CompilerId GHC (V.Version [7,6,2] [])) []
+
+data Module = Module Name FilePath deriving (Show,Read)
+data CPPOptions = CPPOptions [String] deriving (Show,Read)
+
+modules :: (Proxy p,CheckP p,Monad m) => () -> Pipe p (Package,Configuration) (Package,Module,CPPOptions) m ()
+modules = undefined
+
+data AST = AST
+
+asts :: (Proxy p,CheckP p) => () -> Pipe p (Package,Module,CPPOptions) (Package,Module,AST) IO ()
+asts = undefined
+
+

No commit comments for this range

Something went wrong with that request. Please try again.