@@ -4,8 +4,9 @@ module Main where
44
55import Control.Monad.IfElse
66import Control.Monad.Reader
7−import Control.Monad.State hiding ( State )
7+import Control.Monad.State.Strict hiding ( State )
88import Data.Maybe
9+import qualified Data.Set as Set
910import Data.Monoid
1011import Distribution.Version
1112import Distribution.Compiler
@@ -19,6 +20,8 @@ import Data.List ( reverse, intercalate )
1920import Text.PrettyPrint ( text )
2021import qualified Distribution.Compat.ReadP as Parse
2122import Data.Char
23+import qualified Data.Map as Map
24+import Control.DeepSeq
2225
2326data Options = Options
2427 { verbose :: Bool
@@ -30,6 +33,7 @@ data Options = Options
3033data Config = Config
3134 { _verbose :: Bool
3235 , _hackage :: Hackage
36+ , _recursionDepth :: Int
3337 , _compiler :: CompilerId
3438 }
3539 deriving (Show)
@@ -50,13 +54,16 @@ instance Text Nixpkg where
5054 cs <- Parse.munch1 isAlphaNum
5155 if all isDigit cs then Parse.pfail else return cs
5256
53−data State = State (Map PackageIdentifier ())
57+data State = State (Map PackageName Version)
5458 deriving (Show)
5559
5660type Compile a = MonadIO m => StateT State (ReaderT Config m) a
5761
5862yell :: String -> Compile ()
59−yell = liftIO . hPutStrLn stderr
63+yell msg = do
64+ d <- asks _recursionDepth
65+ let prefix = replicate d ' '
66+ liftIO (hPutStrLn stderr (prefix ++ msg))
6067
6168msgInfo, msgNote, msgWarn :: String -> Compile ()
6269msgInfo = whenM (asks _verbose) . yell . showString "INFO: "
@@ -69,12 +76,16 @@ runCompiler f opts = do
6976 let cfg = Config
7077 { _verbose = verbose opts
7178 , _hackage = db
79+ , _recursionDepth = 0
7280 , _compiler = compiler opts
7381 }
74− st = State Distribution.Hackage.DB.empty
82+ st = State Map.empty
7583 f' = msgInfo (showString "options = " (show opts)) >> f
7684 runReaderT (evalStateT f' st) cfg
7785
86+incDepth :: Compile a -> Compile a
87+incDepth f = local (\cfg -> cfg { _recursionDepth = 1 + _recursionDepth cfg }) f
88+
7889-- | A convenience variant of 'runCompiler' that's probably good enough
7990-- for quick-fire testing in ghci.
8091run :: Compile a -> IO a
@@ -116,33 +127,37 @@ resolveName (PackageName name) = do
116127resolve :: Dependency -> Compile (Map Version GenericPackageDescription)
117128resolve dep@(Dependency pkgname@(PackageName name) versionRange) = do
118129 vdb <- resolveName pkgname
119− -- msgInfo $ "resolve: " ++ name ++ " has versions: " ++ displayList (keys vdb)
130+ msgInfo $ "resolve: " ++ name ++ " has versions: " ++ displayList (keys vdb)
120131 let matches = Distribution.Hackage.DB.filterWithKey (\k _ -> k `withinRange` versionRange) vdb
121132 case Distribution.Hackage.DB.null matches of
122133 True -> fail $ "resolve: cannot satisfy " ++ display dep ++ " from versions " ++ displayList (keys vdb)
123− False -> do -- msgInfo $ "resolve: " ++ display dep ++ " matches versions: " ++ displayList (keys matches)
134+ False -> do msgInfo $ "resolve: " ++ display dep ++ " matches versions: " ++ displayList (keys matches)
124135 return matches
125136
126137addPackage :: Dependency -> Compile ()
127−addPackage dep = do
138+addPackage dep@(Dependency name vers) = do
139+ msgInfo $ "try to register " ++ display dep
128140 known <- gets $ \(State pkgDb) -> dep `isKnownPackage` pkgDb
129141 case known of
130− True -> do -- msgWarn (display dep ++ " is already registered!")
131− return ()
142+ True -> return ()
132143 False -> do
133144 vdb <- resolve dep
134145 r <- compile (last (elems vdb))
135146 case r of
136− Left missingDeps -> mapM_ addPackage missingDeps
137− Right (pdesc, _) -> registerPackage (packageId pdesc)
147+ Left missingDeps -> incDepth $ do mapM_ addPackage (Prelude.filter (\(Dependency n _) -> n /= name) missingDeps)
148+ addPackage dep
149+ Right (pdesc, _) -> do registerPackage (packageId pdesc)
138150
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))
151+isKnownPackage :: Dependency -> Map PackageName Version -> Bool
152+isKnownPackage (Dependency name versionRange) pkgDb =
153+ case Map.lookup name pkgDb of
154+ Nothing -> False
155+ Just v -> v `withinRange` versionRange
142156
143157compile :: GenericPackageDescription -> Compile (Either [Dependency] (PackageDescription, FlagAssignment))
144158compile gpdesc = do
145− State knownPackages <- get
159+ let PackageIdentifier name vers = packageId gpdesc
160+ knownPackages <- gets (\(State pkgDb) -> force $ Map.insert name vers pkgDb)
146161 platformId <- return (Platform X86_64 Linux)
147162 compilerId <- asks _compiler
148163 return $ finalizePackageDescription
@@ -150,37 +165,69 @@ compile gpdesc = do
150165 (`isKnownPackage` knownPackages)
151166 platformId
152167 compilerId
153− (Prelude.map thisPackageVersion (keys knownPackages))
168+ [] -- [ thisPackageVersion (PackageIdentifier n v) | (n,v) <- Map.toList knownPackages ]
154169 gpdesc
155170
156171registerPackage :: PackageIdentifier -> Compile ()
157−registerPackage pkgid = do
158− msgInfo $ "registerPackage: " ++ display pkgid
159− modify $ \(State db) -> State (insert pkgid () db)
172+registerPackage pkgid@(PackageIdentifier name vers) = do
173+ msgNote $ "add " ++ display pkgid
174+ modify' $ \(State db) -> State $!! (Map.insert name vers db)
160175
161176buildPackageSet :: Compile ()
162177buildPackageSet = do
163178 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)
179+ mapM_ (addPackage . fromJust . simpleParse)
180+ [ "network < 2.5" -- required because of hslogger
181+ -- here comes the actual payload
182+ , "cabal2nix"
183+ , "hledger"
184+ , "hledger-web"
185+ , "idris"
186+ , "Elm"
187+ , "Agda"
188+ , "git-annex"
189+ ]
176190
191+ State pkgDb <- get
192+ mapM_ (liftIO . putStrLn . display . uncurry PackageIdentifier) (Map.toList pkgDb)
177193
178194displayList :: Text a => [a] -> String
179195displayList = intercalate ", " . Prelude.map display
180196
181197corePackages :: [PackageIdentifier]
182198corePackages = Prelude.map (fromJust . simpleParse)
183− [ "ghc-prim-0.3.1"
184− , "integer-simple-0.1.2"
185− , "rts-1.0.1"
199+ [ "Cabal-1.18.1.3"
200+ , "array-0.5.0.0"
201+ , "base-4.7.0.0"
202+ , "bin-package-db-0.0.0.0"
203+ , "binary-0.7.1.0"
204+ , "bytestring-0.10.4.0"
205+ , "containers-0.5.5.1"
206+ , "deepseq-1.3.0.2"
207+ , "directory-1.2.1.0"
208+ , "filepath-1.3.0.2"
209+ , "ghc-7.8.2"
210+ , "ghc-prim-0.3.1.0"
211+ , "haskell2010-1.1.2.0"
212+ , "haskell98-2.0.0.3"
213+ , "hoopl-3.10.0.1"
214+ , "hpc-0.6.0.1"
215+ , "integer-gmp-0.5.1.0"
216+ , "old-locale-1.0.0.6"
217+ , "old-time-1.1.0.2"
218+ , "pretty-1.1.1.1"
219+ , "process-1.2.0.0"
220+ , "rts-1.0"
221+ , "template-haskell-2.9.0.0"
222+ , "time-1.4.2"
223+ , "transformers-0.3.0.0"
224+ , "unix-2.7.0.1"
186225 ]
226+
227+instance NFData PackageName where
228+ rnf (PackageName name) = rnf name
229+
230+instance NFData State where
231+ rnf (State db) = rnf db
232+
233+modify' f = get >>= \st -> put $!! f st