Skip to content

Commit b374efc

Browse files
snoybergsnoyberg
committed
Refactoring around cabal file parsing
This is a large change that fell out from trying to clean up the mess left from the previous commit. The result here should be signficant simplification of the code paths around parsing cabal files. In fact, there are a few existing TODOs that got hit by this.
1 parent 5308723 commit b374efc

10 files changed

Lines changed: 159 additions & 212 deletions

File tree

‎src/Stack/Build.hs‎

Lines changed: 4 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -44,7 +44,7 @@ import Stack.Build.Source
4444
import Stack.Build.Target
4545
import Stack.Fetch as Fetch
4646
import Stack.Package
47-
import Stack.PackageLocation (loadSingleRawCabalFile)
47+
import Stack.PackageLocation (parseSingleCabalFileIndex)
4848
import Stack.Types.Build
4949
import Stack.Types.BuildPlan
5050
import Stack.Types.Config
@@ -281,17 +281,10 @@ withLoadPackage inner = do
281281
root <- view projectRootL
282282
run <- askRunInIO
283283
withCabalLoader $ \loadFromIndex ->
284-
inner $ \loc flags ghcOptions ->
285-
run $ readPackageBS
284+
inner $ \loc flags ghcOptions -> run $
285+
resolvePackage
286286
(depPackageConfig econfig flags ghcOptions)
287-
loc
288-
289-
-- Intentionally ignore warnings, as it's not really
290-
-- appropriate to print a bunch of warnings out while
291-
-- resolving the package index.
292-
CWNoPrint
293-
294-
(loadSingleRawCabalFile loadFromIndex root loc)
287+
<$> parseSingleCabalFileIndex loadFromIndex root loc
295288
where
296289
-- | Package config to be used for dependencies
297290
depPackageConfig :: EnvConfig -> Map FlagName Bool -> [Text] -> PackageConfig

‎src/Stack/Build/Source.hs‎

Lines changed: 3 additions & 19 deletions
Original file line numberDiff line numberDiff line change
@@ -30,7 +30,7 @@ import qualified Data.Map.Strict as M
3030
import qualified Data.Set as Set
3131
import Stack.Build.Cache
3232
import Stack.Build.Target
33-
import Stack.Config (getLocalPackages, getNamedComponents)
33+
import Stack.Config (getLocalPackages)
3434
import Stack.Constants (wiredInPackages)
3535
import Stack.Package
3636
import Stack.PackageLocation
@@ -94,25 +94,9 @@ loadSourceMapFull needTargets boptsCli = do
9494
-- NOTE: configOpts includes lpiGhcOptions for now, this may get refactored soon
9595
PLIndex pir -> return $ PSIndex loc (lpiFlags lpi) configOpts pir
9696
PLOther pl -> do
97-
-- FIXME lots of code duplication with getLocalPackages
9897
root <- view projectRootL
99-
dir <- resolveSinglePackageLocation root pl
100-
cabalfp <- findOrGenerateCabalFile dir
101-
eres <- cachedCabalFileParse
102-
(PLOther pl)
103-
(CWPrint (toFilePath cabalfp))
104-
(liftIO (S.readFile (toFilePath cabalfp)))
105-
gpd <-
106-
case eres of
107-
Left e -> throwM $ InvalidCabalFileInLocal (Left cabalfp) e
108-
Right x -> return x
109-
lp' <- loadLocalPackage False boptsCli targets (n, LocalPackageView
110-
{ lpvVersion = lpiVersion lpi
111-
, lpvCabalFP = cabalfp
112-
, lpvComponents = getNamedComponents gpd
113-
, lpvGPD = gpd
114-
, lpvLoc = pl
115-
})
98+
lpv <- parseSingleCabalFile root True pl
99+
lp' <- loadLocalPackage False boptsCli targets (n, lpv)
116100
return $ PSFiles lp' loc
117101
sourceMap' <- Map.unions <$> sequence
118102
[ return $ Map.fromList $ map (\lp' -> (packageName $ lpPackage lp', PSFiles lp' Local)) locals

‎src/Stack/Build/Target.hs‎

Lines changed: 2 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -80,7 +80,6 @@ import Path.Extra (rejectMissingDir)
8080
import Path.IO
8181
import Stack.Config (getLocalPackages)
8282
import Stack.Fetch (withCabalLoader)
83-
import Stack.Package
8483
import Stack.PackageIndex
8584
import Stack.PackageLocation
8685
import Stack.Snapshot (calculatePackagePromotion)
@@ -512,13 +511,8 @@ parseTargets needTargets boptscli = do
512511

513512
(globals', snapshots, locals') <- withCabalLoader $ \loadFromIndex -> do
514513
addedDeps' <- fmap Map.fromList $ forM (Map.toList addedDeps) $ \(name, loc) -> do
515-
eres <- cachedCabalFileParse
516-
loc
517-
CWNoPrint
518-
(loadSingleRawCabalFile loadFromIndex root loc)
519-
case eres of
520-
Left e -> throwIO $ InvalidCabalFileInLocal (Right loc) e
521-
Right gpd -> return (name, (gpd, loc, Nothing))
514+
gpd <- parseSingleCabalFileIndex loadFromIndex root loc
515+
return (name, (gpd, loc, Nothing))
522516

523517
-- Calculate a list of all of the locals, based on the project
524518
-- packages, local dependencies, and added deps found from the

‎src/Stack/Config.hs‎

Lines changed: 7 additions & 49 deletions
Original file line numberDiff line numberDiff line change
@@ -45,7 +45,6 @@ module Stack.Config
4545
,defaultConfigYaml
4646
,getProjectConfig
4747
,LocalConfigStatus(..)
48-
,getNamedComponents
4948
) where
5049

5150
import Control.Monad.Extra (firstJustM)
@@ -54,12 +53,10 @@ import Data.Aeson.Extended
5453
import qualified Data.ByteString as S
5554
import qualified Data.IntMap as IntMap
5655
import qualified Data.Map as Map
57-
import qualified Data.Set as Set
5856
import qualified Data.Text as T
5957
import Data.Text.Encoding (encodeUtf8)
6058
import qualified Data.Yaml as Yaml
6159
import qualified Distribution.PackageDescription as C
62-
import qualified Distribution.Types.UnqualComponentName as C
6360
import Distribution.System (OS (..), Platform (..), buildPlatform, Arch(OtherArch))
6461
import qualified Distribution.Text
6562
import Distribution.Version (simplifyVersionRange, mkVersion')
@@ -80,7 +77,6 @@ import Stack.Config.Urls
8077
import Stack.Constants
8178
import Stack.Fetch
8279
import qualified Stack.Image as Image
83-
import Stack.Package
8480
import Stack.PackageLocation
8581
import Stack.Snapshot
8682
import Stack.Types.BuildPlan
@@ -656,42 +652,17 @@ getLocalPackages = do
656652
bc <- view buildConfigL
657653

658654
packages <- do
659-
bss <- concat <$> mapM (loadMultiRawCabalFiles root) (bcPackages bc)
660-
forM bss $ \(cabalfp, loc) -> do
661-
eres <- cachedCabalFileParse
662-
(PLOther loc)
663-
(CWPrint (toFilePath cabalfp))
664-
(liftIO (S.readFile (toFilePath cabalfp)))
665-
gpd <-
666-
case eres of
667-
Left e -> throwM $ InvalidCabalFileInLocal (Left cabalfp) e
668-
Right x -> return x
669-
let PackageIdentifier name version =
670-
fromCabalPackageIdentifier
671-
$ C.package
672-
$ C.packageDescription gpd
673-
checkCabalFileName name cabalfp
674-
let lpv = LocalPackageView
675-
{ lpvVersion = version
676-
, lpvCabalFP = cabalfp
677-
, lpvComponents = getNamedComponents gpd
678-
, lpvGPD = gpd
679-
, lpvLoc = loc
680-
}
681-
return (name, lpv)
682-
683-
deps <- mapM (loadMultiRawCabalFilesIndex loadFromIndex root) (bcDependencies bc)
684-
>>= mapM (\(bs, loc :: PackageLocationIndex FilePath) -> do
685-
eres <- cachedCabalFileParse loc CWNoPrint (return bs)
686-
gpd <- do
687-
case eres of
688-
Left e -> throwM $ InvalidCabalFileInLocal (Right loc) e
689-
Right x -> return x
655+
let withName lpv = (lpvName lpv, lpv)
656+
map withName . concat <$> mapM (parseMultiCabalFiles root True) (bcPackages bc)
657+
658+
let wrapGPD (gpd, loc) =
690659
let PackageIdentifier name _version =
691660
fromCabalPackageIdentifier
692661
$ C.package
693662
$ C.packageDescription gpd
694-
return (name, (gpd, loc))) . concat
663+
in (name, (gpd, loc))
664+
deps <- fmap (map wrapGPD . concat)
665+
$ mapM (parseMultiCabalFilesIndex loadFromIndex root) (bcDependencies bc)
695666

696667
checkDuplicateNames $
697668
map (second (PLOther . lpvLoc)) packages ++
@@ -702,19 +673,6 @@ getLocalPackages = do
702673
, lpDependencies = Map.fromList deps
703674
}
704675

705-
getNamedComponents :: C.GenericPackageDescription -> Set NamedComponent
706-
getNamedComponents gpkg = Set.fromList $ concat
707-
[ maybe [] (const [CLib]) (C.condLibrary gpkg)
708-
, go CExe (map fst . C.condExecutables)
709-
, go CTest (map fst . C.condTestSuites)
710-
, go CBench (map fst . C.condBenchmarks)
711-
]
712-
where
713-
go :: (T.Text -> NamedComponent)
714-
-> (C.GenericPackageDescription -> [C.UnqualComponentName])
715-
-> [NamedComponent]
716-
go wrapper f = map (wrapper . T.pack . C.unUnqualComponentName) $ f gpkg
717-
718676
-- | Check if there are any duplicate package names and, if so, throw an
719677
-- exception.
720678
checkDuplicateNames :: MonadThrow m => [(PackageName, PackageLocationIndex FilePath)] -> m ()

‎src/Stack/Package.hs‎

Lines changed: 36 additions & 37 deletions
Original file line numberDiff line numberDiff line change
@@ -17,12 +17,11 @@
1717

1818
module Stack.Package
1919
(readPackage
20-
,readPackageBS
2120
,readPackageDescriptionDir
2221
,readDotBuildinfo
2322
,readPackageUnresolved
23+
,readPackageUnresolvedFromIndex
2424
,resolvePackage
25-
,cachedCabalFileParse
2625
,CabalWarnings(..)
2726
,packageFromPackageDescription
2827
,findOrGenerateCabalFile
@@ -38,7 +37,6 @@ module Stack.Package
3837
,packageDescTools
3938
,packageDependencies
4039
,autogenDir
41-
,checkCabalFileName
4240
,cabalFilePackageId)
4341
where
4442

@@ -85,7 +83,7 @@ import Stack.Constants.Config
8583
import Stack.Prelude
8684
import Stack.PrettyPrint
8785
import Stack.Types.Build
88-
import Stack.Types.BuildPlan (PackageLocationIndex (..), PackageLocation (..), ExeName (..))
86+
import Stack.Types.BuildPlan (ExeName (..))
8987
import Stack.Types.Compiler
9088
import Stack.Types.Config
9189
import Stack.Types.FlagName
@@ -119,7 +117,7 @@ instance HasEnvConfig Ctx where
119117

120118
data CabalWarnings
121119
= CWNoPrint
122-
| CWPrint !String
120+
| CWPrint !(Path Abs File)
123121

124122
-- | Parse a cabal file from the given location. This performs caching
125123
-- (based on the 'PackageLocationIndex'), and will only use the second
@@ -128,10 +126,10 @@ data CabalWarnings
128126
-- 'True', then they will be printed.
129127
cachedCabalFileParse
130128
:: forall env. HasRunner env
131-
=> PackageLocationIndex FilePath
129+
=> Either PackageIdentifierRevision (Path Abs File)
132130
-> CabalWarnings
133131
-> RIO env BS.ByteString -- ^ get the bytestring contents
134-
-> RIO env (Either PError GenericPackageDescription)
132+
-> RIO env GenericPackageDescription
135133
cachedCabalFileParse key cw getBS = do
136134
ref <- view $ runnerL.to runnerParsedCabalFiles
137135
m0 <- readIORef ref
@@ -141,12 +139,12 @@ cachedCabalFileParse key cw getBS = do
141139
bs <- getBS
142140
val <-
143141
case rawParseGPD bs of
144-
Left e -> return $ Left e
142+
Left e -> throwM $ PackageInvalidCabalFile key e
145143
Right (warnings, gpd) -> do
146144
case cw of
147145
CWNoPrint -> return ()
148-
CWPrint src -> mapM_ (prettyWarnL . toPretty src) warnings
149-
return $ Right gpd
146+
CWPrint src -> mapM_ (prettyWarnL . toPretty (toFilePath src)) warnings
147+
return gpd
150148
atomicModifyIORef' ref $ \m -> (M.insert key val m, ())
151149
return val
152150
where
@@ -182,23 +180,36 @@ readPackageUnresolved
182180
=> Path Abs File -- ^ cabal file location
183181
-> Bool -- ^ print warnings?
184182
-> RIO env GenericPackageDescription
185-
readPackageUnresolved cabalfp printWarnings = readPackageUnresolvedBS
186-
(PLOther $ PLFilePath $ toFilePath cabalfp)
187-
(if printWarnings then CWPrint (toFilePath cabalfp) else CWNoPrint)
188-
(liftIO (BS.readFile (FL.toFilePath cabalfp)))
189-
190-
-- | Read the raw, unresolved package information from a ByteString.
191-
readPackageUnresolvedBS
183+
readPackageUnresolved cabalfp printWarnings = do
184+
gpd <- cachedCabalFileParse
185+
(Right cabalfp)
186+
(if printWarnings then CWPrint cabalfp else CWNoPrint)
187+
(liftIO (BS.readFile (FL.toFilePath cabalfp)))
188+
let PackageIdentifier name _version =
189+
fromCabalPackageIdentifier
190+
$ D.package
191+
$ D.packageDescription gpd
192+
checkCabalFileName name cabalfp
193+
return gpd
194+
195+
-- | Read the 'GenericPackageDescription' from the given
196+
-- 'PackageIdentifierRevision'.
197+
readPackageUnresolvedFromIndex
192198
:: forall env. HasRunner env
193-
=> PackageLocationIndex FilePath
194-
-> CabalWarnings
195-
-> RIO env BS.ByteString -- ^ get the contents
199+
=> (PackageIdentifierRevision -> IO ByteString) -- ^ load the raw bytes
200+
-> PackageIdentifierRevision
196201
-> RIO env GenericPackageDescription
197-
readPackageUnresolvedBS loc cw getBS = do
198-
eres <- cachedCabalFileParse loc cw getBS
199-
case eres of
200-
Left e -> throwM $ PackageInvalidCabalFile loc e
201-
Right x -> return x
202+
readPackageUnresolvedFromIndex loadFromIndex pir@(PackageIdentifierRevision pi' _) = do
203+
gpd <- cachedCabalFileParse
204+
(Left pir)
205+
CWNoPrint
206+
(liftIO $ loadFromIndex pir)
207+
let foundPI =
208+
fromCabalPackageIdentifier
209+
$ D.package
210+
$ D.packageDescription gpd
211+
unless (pi' == foundPI) $ error $ "Mismatched package identifiers found: " ++ show (pi', foundPI) -- FIXME better error message
212+
return gpd
202213

203214
-- | Reads and exposes the package information
204215
readPackage
@@ -210,18 +221,6 @@ readPackage
210221
readPackage packageConfig cabalfp printWarnings =
211222
resolvePackage packageConfig <$> readPackageUnresolved cabalfp printWarnings
212223

213-
-- | Reads and exposes the package information, from a ByteString
214-
readPackageBS
215-
:: forall env. HasRunner env
216-
=> PackageConfig
217-
-> PackageLocationIndex FilePath
218-
-> CabalWarnings
219-
-> RIO env BS.ByteString
220-
-> RIO env Package
221-
readPackageBS packageConfig loc cw getBS =
222-
cachedCabalFileParse loc cw getBS >>=
223-
either (throwM . PackageInvalidCabalFile loc) (return . resolvePackage packageConfig)
224-
225224
-- | Get 'GenericPackageDescription' and 'PackageDescription' reading info
226225
-- from given directory.
227226
readPackageDescriptionDir

0 commit comments

Comments
 (0)