@@ -5,13 +5,20 @@ module Main where
55import Control.Monad.IfElse
66import Control.Monad.Reader
77import Control.Monad.State hiding ( State )
8−import Distribution.Hackage.DB
9−import Options.Applicative
10−import System.IO
11−import Data.Monoid
128import Data.Maybe
9+import Data.Monoid
10+import Distribution.Version
1311import Distribution.Compiler
12+import Distribution.Hackage.DB
13+import Distribution.PackageDescription.Configuration
14+import Distribution.System
1415import Distribution.Text
16+import Options.Applicative
17+import System.IO
18+import Data.List ( reverse, intercalate )
19+import Text.PrettyPrint ( text )
20+import qualified Distribution.Compat.ReadP as Parse
21+import Data.Char
1522
1623data Options = Options
1724 { verbose :: Bool
@@ -23,10 +30,27 @@ data Options = Options
2330data Config = Config
2431 { _verbose :: Bool
2532 , _hackage :: Hackage
33+ , _compiler :: CompilerId
2634 }
2735 deriving (Show)
2836
29−data State = State
37+newtype Nixpkg = Nixpkg String
38+ deriving (Eq, Ord, Read, Show)
39+
40+instance Text Nixpkg where
41+ disp (Nixpkg name) = text name
42+ parse = do
43+ ns <- Parse.sepBy1 component (Parse.char '-')
44+ return (Nixpkg (intercalate "-" ns))
45+ where
46+ -- Each component must contain an alphabetic character, to avoid
47+ -- ambiguity in identifiers like foo-1 (the 1 is the version number).
48+ component :: Parse.ReadP r String
49+ component = do
50+ cs <- Parse.munch1 isAlphaNum
51+ if all isDigit cs then Parse.pfail else return cs
52+
53+data State = State (Map PackageIdentifier ())
3054 deriving (Show)
3155
3256type Compile a = MonadIO m => StateT State (ReaderT Config m) a
@@ -34,8 +58,9 @@ type Compile a = MonadIO m => StateT State (ReaderT Config m) a
3458yell :: String -> Compile ()
3559yell = liftIO . hPutStrLn stderr
3660
37−msgInfo, msgWarn :: String -> Compile ()
61+msgInfo, msgNote, msgWarn :: String -> Compile ()
3862msgInfo = whenM (asks _verbose) . yell . showString "INFO: "
63+msgNote = yell . showString "NOTE: "
3964msgWarn = yell . showString "WARN: "
4065
4166runCompiler :: MonadIO m => Compile a -> Options -> m a
@@ -44,13 +69,22 @@ runCompiler f opts = do
4469 let cfg = Config
4570 { _verbose = verbose opts
4671 , _hackage = db
72+ , _compiler = compiler opts
4773 }
48− st = State
74+ st = State Distribution.Hackage.DB.empty
4975 f' = msgInfo (showString "options = " (show opts)) >> f
5076 runReaderT (evalStateT f' st) cfg
5177
78+-- | A convenience variant of 'runCompiler' that's probably good enough
79+-- for quick-fire testing in ghci.
80+run :: Compile a -> IO a
81+run f = runCompiler f Options
82+ { verbose = True, overlay = []
83+ , compiler = CompilerId GHC (Version {versionBranch = [7,8,2], versionTags = []})
84+ }
85+
5286main :: IO ()
53−main = execParser mainOptions >>= runCompiler (msgInfo "starting up")
87+main = execParser mainOptions >>= runCompiler buildPackageSet
5488 where
5589 parseCompilerId :: Parser CompilerId
5690 parseCompilerId = nullOption
@@ -73,3 +107,80 @@ main = execParser mainOptions >>= runCompiler (msgInfo "starting up")
73107 ( fullDesc
74108 <> header "hackage2nix -- convert the Hackage database into Nix build instructions"
75109 )
110+
111+resolveName :: PackageName -> Compile (Map Version GenericPackageDescription)
112+resolveName (PackageName name) = do
113+ versions <- asks (Distribution.Hackage.DB.lookup name . _hackage)
114+ maybe (fail $ "resolve: unknown package " ++ show name) return versions
115+
116+resolve :: Dependency -> Compile (Map Version GenericPackageDescription)
117+resolve dep@(Dependency pkgname@(PackageName name) versionRange) = do
118+ vdb <- resolveName pkgname
119+ -- msgInfo $ "resolve: " ++ name ++ " has versions: " ++ displayList (keys vdb)
120+ let matches = Distribution.Hackage.DB.filterWithKey (\k _ -> k `withinRange` versionRange) vdb
121+ case Distribution.Hackage.DB.null matches of
122+ True -> fail $ "resolve: cannot satisfy " ++ display dep ++ " from versions " ++ displayList (keys vdb)
123+ False -> do -- msgInfo $ "resolve: " ++ display dep ++ " matches versions: " ++ displayList (keys matches)
124+ return matches
125+
126+addPackage :: Dependency -> Compile ()
127+addPackage dep = do
128+ known <- gets $ \(State pkgDb) -> dep `isKnownPackage` pkgDb
129+ case known of
130+ True -> do -- msgWarn (display dep ++ " is already registered!")
131+ return ()
132+ False -> do
133+ vdb <- resolve dep
134+ r <- compile (last (elems vdb))
135+ case r of
136+ Left missingDeps -> mapM_ addPackage missingDeps
137+ Right (pdesc, _) -> registerPackage (packageId pdesc)
138+
139+isKnownPackage :: Dependency -> Map PackageIdentifier () -> Bool
140+isKnownPackage (Dependency (PackageName name) versionRange) pkgDb =
141+ not (Distribution.Hackage.DB.null (filterWithKey (\(PackageIdentifier (PackageName name') version) _ -> name' == name && version `withinRange` versionRange) pkgDb))
142+
143+compile :: GenericPackageDescription -> Compile (Either [Dependency] (PackageDescription, FlagAssignment))
144+compile gpdesc = do
145+ State knownPackages <- get
146+ platformId <- return (Platform X86_64 Linux)
147+ compilerId <- asks _compiler
148+ return $ finalizePackageDescription
149+ ([] :: FlagAssignment)
150+ (`isKnownPackage` knownPackages)
151+ platformId
152+ compilerId
153+ (Prelude.map thisPackageVersion (keys knownPackages))
154+ gpdesc
155+
156+registerPackage :: PackageIdentifier -> Compile ()
157+registerPackage pkgid = do
158+ msgInfo $ "registerPackage: " ++ display pkgid
159+ modify $ \(State db) -> State (insert pkgid () db)
160+
161+buildPackageSet :: Compile ()
162+buildPackageSet = do
163+ mapM_ registerPackage corePackages
164+ addPackage (fromJust (simpleParse "hackage-db") :: Dependency)
165+ addPackage (fromJust (simpleParse "hledger") :: Dependency)
166+ -- addPackage (fromJust (simpleParse "git-annex") :: Dependency)
167+
168+ -- Right (tpkg, _) = finalizePackageDescription
169+ -- (configureCabalFlags pkg)
170+ -- (const True)
171+ -- (Platform I386 Linux) -- shouldn't be hardcoded
172+ -- (CompilerId GHC (Version [7,6,3] [])) -- dito
173+ -- [] cabal
174+ State pkgDb <- get
175+ mapM_ (msgNote . display) (keys pkgDb)
176+
177+
178+displayList :: Text a => [a] -> String
179+displayList = intercalate ", " . Prelude.map display
180+
181+corePackages :: [PackageIdentifier]
182+corePackages = Prelude.map (fromJust . simpleParse)
183+ [ "ghc-prim-0.3.1"
184+ , "integer-simple-0.1.2"
185+ , "rts-1.0.1"
186+ ]