@@ -2,26 +2,25 @@
22
33module Main where
44
5+import Control.DeepSeq
56import Control.Monad.IfElse
67import Control.Monad.Reader
78import Control.Monad.State.Strict hiding ( State )
9+import Data.Char
10+import Data.List ( intercalate )
11+import qualified Data.Map as Map
812import Data.Maybe
9−import qualified Data.Set as Set
1013import Data.Monoid
11−import Distribution.Version
14+import qualified Distribution.Compat.ReadP as Parse
1215import Distribution.Compiler
1316import Distribution.Hackage.DB
1417import Distribution.PackageDescription.Configuration
1518import Distribution.System
1619import Distribution.Text
20+import Distribution.Version
1721import Options.Applicative
1822import System.IO
19−import Data.List ( reverse, intercalate )
2023import Text.PrettyPrint ( text )
21−import qualified Distribution.Compat.ReadP as Parse
22−import Data.Char
23−import qualified Data.Map as Map
24−import Control.DeepSeq
2524
2625data Options = Options
2726 { verbose :: Bool
@@ -91,7 +90,7 @@ incDepth f = local (\cfg -> cfg { _recursionDepth = 1 + _recursionDepth cfg }) f
9190run :: Compile a -> IO a
9291run f = runCompiler f Options
9392 { verbose = True, overlay = []
94− , compiler = CompilerId GHC (Version {versionBranch = [7,8,2], versionTags = []})
93+ , compiler = CompilerId GHC Version {versionBranch = [7,8,2], versionTags = []}
9594 }
9695
9796main :: IO ()
@@ -129,24 +128,22 @@ resolve dep@(Dependency pkgname@(PackageName name) versionRange) = do
129128 vdb <- resolveName pkgname
130129 msgInfo $ "resolve: " ++ name ++ " has versions: " ++ displayList (keys vdb)
131130 let matches = Distribution.Hackage.DB.filterWithKey (\k _ -> k `withinRange` versionRange) vdb
132− case Distribution.Hackage.DB.null matches of
133− True -> fail $ "resolve: cannot satisfy " ++ display dep ++ " from versions " ++ displayList (keys vdb)
134− False -> do msgInfo $ "resolve: " ++ display dep ++ " matches versions: " ++ displayList (keys matches)
135− return matches
131+ if Distribution.Hackage.DB.null matches
132+ then fail $ "resolve: cannot satisfy " ++ display dep ++ " from versions " ++ displayList (keys vdb)
133+ else do msgInfo $ "resolve: " ++ display dep ++ " matches versions: " ++ displayList (keys matches)
134+ return matches
136135
137136addPackage :: Dependency -> Compile ()
138−addPackage dep@(Dependency name vers) = do
137+addPackage dep@(Dependency name _) = do
139138 msgInfo $ "try to register " ++ display dep
140139 known <- gets $ \(State pkgDb) -> dep `isKnownPackage` pkgDb
141− case known of
142− True -> return ()
143− False -> do
144− vdb <- resolve dep
145− r <- compile (last (elems vdb))
146− case r of
147− Left missingDeps -> incDepth $ do mapM_ addPackage (Prelude.filter (\(Dependency n _) -> n /= name) missingDeps)
148− addPackage dep
149− Right (pdesc, _) -> do registerPackage (packageId pdesc)
140+ unless known $ do
141+ vdb <- resolve dep
142+ r <- compile (last (elems vdb))
143+ case r of
144+ Left missingDeps -> incDepth $ do mapM_ addPackage (Prelude.filter (\(Dependency n _) -> n /= name) missingDeps)
145+ addPackage dep
146+ Right (pdesc, _) -> registerPackage (packageId pdesc)
150147
151148isKnownPackage :: Dependency -> Map PackageName Version -> Bool
152149isKnownPackage (Dependency name versionRange) pkgDb =
@@ -158,7 +155,7 @@ compile :: GenericPackageDescription -> Compile (Either [Dependency] (PackageDes
158155compile gpdesc = do
159156 let PackageIdentifier name vers = packageId gpdesc
160157 knownPackages <- gets (\(State pkgDb) -> force $ Map.insert name vers pkgDb)
161− platformId <- return (Platform X86_64 Linux)
158+ let platformId = Platform X86_64 Linux
162159 compilerId <- asks _compiler
163160 return $ finalizePackageDescription
164161 ([] :: FlagAssignment)
@@ -171,7 +168,7 @@ compile gpdesc = do
171168registerPackage :: PackageIdentifier -> Compile ()
172169registerPackage pkgid@(PackageIdentifier name vers) = do
173170 msgNote $ "add " ++ display pkgid
174− modify' $ \(State db) -> State $!! (Map.insert name vers db)
171+ modify' $ \(State db) -> State (Map.insert name vers db)
175172
176173buildPackageSet :: Compile ()
177174buildPackageSet = do
@@ -227,4 +224,5 @@ corePackages = Prelude.map (fromJust . simpleParse)
227224instance NFData State where
228225 rnf (State db) = rnf db
229226
227+modify' :: (State -> State) -> Compile ()
230228modify' f = get >>= \st -> put $!! f st