{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE RecordWildCards #-}
module BuildEnv.CabalPlan
(
CabalPlan(..), mapMaybePlanUnits
, CabalPlanBinary(..), parsePlanBinary
, PkgName(..)
, pkgNameVersion, validPackageName
, mangledPkgName
, AllowNewer(..)
, PkgSpecs, PkgSpec(..)
, emptyPkgSpec, parsePkgSpec
, unionPkgSpecsOverriding
, Constraints(..)
, FlagSpec(..)
, showFlagSpec, flagSpecIsEmpty
, PkgSrc(..)
, UnitId(..)
, PlanUnit(..)
, planUnitUnitId, planUnitPkgName, planUnitVersion
, PreexistingUnit(..)
, ConfiguredUnit(..)
, configuredUnitMaybe, cuComponentType
, allDepends, unitDepends
, UnitSpecs
, unionUnitSpecsCombining
, ComponentName(..)
, cabalComponent, parsePkgComponent
, ComponentType(..)
, cabalComponentType, parseComponentType
)
where
import Data.Char
( isAlphaNum )
import Data.Maybe
( fromMaybe, mapMaybe )
import Data.Version
( Version, showVersion )
import Data.Aeson
import qualified Data.ByteString.Lazy as Lazy
( ByteString )
import qualified Data.Map.Strict as Strict
( Map )
import qualified Data.Map.Strict as Map
import Data.Set
( Set )
import Data.Text
( Text )
import qualified Data.Text as Text
newtype CabalPlan = CabalPlan { CabalPlan -> [PlanUnit]
planUnits :: [PlanUnit] }
mapMaybePlanUnits :: (PlanUnit -> Maybe a) -> CabalPlan -> [a]
mapMaybePlanUnits :: forall a. (PlanUnit -> Maybe a) -> CabalPlan -> [a]
mapMaybePlanUnits PlanUnit -> Maybe a
f (CabalPlan [PlanUnit]
units) = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe PlanUnit -> Maybe a
f [PlanUnit]
units
instance Show CabalPlan where
show :: CabalPlan -> [Char]
show (CabalPlan [PlanUnit]
us)
= [[Char]] -> [Char]
unlines forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> [Char]
show [PlanUnit]
us
instance FromJSON CabalPlan where
parseJSON :: Value -> Parser CabalPlan
parseJSON = forall a. [Char] -> (Object -> Parser a) -> Value -> Parser a
withObject [Char]
"cabal plan" \ Object
o ->
[PlanUnit] -> CabalPlan
CabalPlan forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"install-plan"
newtype CabalPlanBinary = CabalPlanBinary Lazy.ByteString
parsePlanBinary :: CabalPlanBinary -> CabalPlan
parsePlanBinary :: CabalPlanBinary -> CabalPlan
parsePlanBinary (CabalPlanBinary ByteString
pb) =
case forall a. FromJSON a => ByteString -> Either [Char] a
eitherDecode ByteString
pb of
Left [Char]
err -> forall a. HasCallStack => [Char] -> a
error ([Char]
"parsePlanBinary: failed to parse plan JSON\n" forall a. [a] -> [a] -> [a]
++ [Char]
err)
Right CabalPlan
plan -> CabalPlan
plan
newtype PkgName = PkgName { PkgName -> Text
unPkgName :: Text }
deriving stock Int -> PkgName -> ShowS
[PkgName] -> ShowS
PkgName -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [PkgName] -> ShowS
$cshowList :: [PkgName] -> ShowS
show :: PkgName -> [Char]
$cshow :: PkgName -> [Char]
showsPrec :: Int -> PkgName -> ShowS
$cshowsPrec :: Int -> PkgName -> ShowS
Show
deriving newtype (PkgName -> PkgName -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PkgName -> PkgName -> Bool
$c/= :: PkgName -> PkgName -> Bool
== :: PkgName -> PkgName -> Bool
$c== :: PkgName -> PkgName -> Bool
Eq, Eq PkgName
PkgName -> PkgName -> Bool
PkgName -> PkgName -> Ordering
PkgName -> PkgName -> PkgName
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: PkgName -> PkgName -> PkgName
$cmin :: PkgName -> PkgName -> PkgName
max :: PkgName -> PkgName -> PkgName
$cmax :: PkgName -> PkgName -> PkgName
>= :: PkgName -> PkgName -> Bool
$c>= :: PkgName -> PkgName -> Bool
> :: PkgName -> PkgName -> Bool
$c> :: PkgName -> PkgName -> Bool
<= :: PkgName -> PkgName -> Bool
$c<= :: PkgName -> PkgName -> Bool
< :: PkgName -> PkgName -> Bool
$c< :: PkgName -> PkgName -> Bool
compare :: PkgName -> PkgName -> Ordering
$ccompare :: PkgName -> PkgName -> Ordering
Ord, Value -> Parser [PkgName]
Value -> Parser PkgName
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [PkgName]
$cparseJSONList :: Value -> Parser [PkgName]
parseJSON :: Value -> Parser PkgName
$cparseJSON :: Value -> Parser PkgName
FromJSON, FromJSONKeyFunction [PkgName]
FromJSONKeyFunction PkgName
forall a.
FromJSONKeyFunction a -> FromJSONKeyFunction [a] -> FromJSONKey a
fromJSONKeyList :: FromJSONKeyFunction [PkgName]
$cfromJSONKeyList :: FromJSONKeyFunction [PkgName]
fromJSONKey :: FromJSONKeyFunction PkgName
$cfromJSONKey :: FromJSONKeyFunction PkgName
FromJSONKey)
pkgNameVersion :: PkgName -> Version -> Text
pkgNameVersion :: PkgName -> Version -> Text
pkgNameVersion (PkgName Text
n) Version
v = Text
n forall a. Semigroup a => a -> a -> a
<> Text
"-" forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
Text.pack (Version -> [Char]
showVersion Version
v)
validPackageName :: Text -> Bool
validPackageName :: Text -> Bool
validPackageName = (Char -> Bool) -> Text -> Bool
Text.all ( \ Char
x -> Char -> Bool
isAlphaNum Char
x Bool -> Bool -> Bool
|| Char
x forall a. Eq a => a -> a -> Bool
== Char
'-' )
mangledPkgName :: PkgName -> String
mangledPkgName :: PkgName -> [Char]
mangledPkgName = forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
fixupChar forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
Text.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. PkgName -> Text
unPkgName
where
fixupChar :: Char -> Char
fixupChar Char
'-' = Char
'_'
fixupChar Char
c = Char
c
newtype AllowNewer = AllowNewer ( Set (Text, Text) )
deriving stock Int -> AllowNewer -> ShowS
[AllowNewer] -> ShowS
AllowNewer -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [AllowNewer] -> ShowS
$cshowList :: [AllowNewer] -> ShowS
show :: AllowNewer -> [Char]
$cshow :: AllowNewer -> [Char]
showsPrec :: Int -> AllowNewer -> ShowS
$cshowsPrec :: Int -> AllowNewer -> ShowS
Show
deriving newtype ( NonEmpty AllowNewer -> AllowNewer
AllowNewer -> AllowNewer -> AllowNewer
forall b. Integral b => b -> AllowNewer -> AllowNewer
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> AllowNewer -> AllowNewer
$cstimes :: forall b. Integral b => b -> AllowNewer -> AllowNewer
sconcat :: NonEmpty AllowNewer -> AllowNewer
$csconcat :: NonEmpty AllowNewer -> AllowNewer
<> :: AllowNewer -> AllowNewer -> AllowNewer
$c<> :: AllowNewer -> AllowNewer -> AllowNewer
Semigroup, Semigroup AllowNewer
AllowNewer
[AllowNewer] -> AllowNewer
AllowNewer -> AllowNewer -> AllowNewer
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [AllowNewer] -> AllowNewer
$cmconcat :: [AllowNewer] -> AllowNewer
mappend :: AllowNewer -> AllowNewer -> AllowNewer
$cmappend :: AllowNewer -> AllowNewer -> AllowNewer
mempty :: AllowNewer
$cmempty :: AllowNewer
Monoid )
type PkgSpecs = Strict.Map PkgName PkgSpec
data PkgSpec = PkgSpec { PkgSpec -> Maybe Constraints
psConstraints :: !( Maybe Constraints )
, PkgSpec -> FlagSpec
psFlags :: !FlagSpec
}
deriving stock Int -> PkgSpec -> ShowS
[PkgSpec] -> ShowS
PkgSpec -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [PkgSpec] -> ShowS
$cshowList :: [PkgSpec] -> ShowS
show :: PkgSpec -> [Char]
$cshow :: PkgSpec -> [Char]
showsPrec :: Int -> PkgSpec -> ShowS
$cshowsPrec :: Int -> PkgSpec -> ShowS
Show
emptyPkgSpec :: PkgSpec
emptyPkgSpec :: PkgSpec
emptyPkgSpec = Maybe Constraints -> FlagSpec -> PkgSpec
PkgSpec forall a. Maybe a
Nothing forall a. Monoid a => a
mempty
parsePkgSpec :: Text -> PkgSpec
parsePkgSpec :: Text -> PkgSpec
parsePkgSpec Text
l = Map Text Bool -> [Text] -> PkgSpec
parseSpec forall k a. Map k a
Map.empty ( Text -> [Text]
Text.words Text
l )
where
parseSpec :: Strict.Map Text Bool -> [Text] -> PkgSpec
parseSpec :: Map Text Bool -> [Text] -> PkgSpec
parseSpec Map Text Bool
flags []
= PkgSpec { $sel:psConstraints:PkgSpec :: Maybe Constraints
psConstraints = forall a. Maybe a
Nothing
, $sel:psFlags:PkgSpec :: FlagSpec
psFlags = Map Text Bool -> FlagSpec
FlagSpec Map Text Bool
flags }
parseSpec Map Text Bool
flags (Text
w:[Text]
ws)
| Just (Char
s,Text
f) <- Text -> Maybe (Char, Text)
Text.uncons Text
w
, Char
s forall a. Eq a => a -> a -> Bool
== Char
'+' Bool -> Bool -> Bool
|| Char
s forall a. Eq a => a -> a -> Bool
== Char
'-'
= Map Text Bool -> [Text] -> PkgSpec
parseSpec (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
f (Char
s forall a. Eq a => a -> a -> Bool
== Char
'+') Map Text Bool
flags) [Text]
ws
| Bool
otherwise
= PkgSpec { $sel:psConstraints:PkgSpec :: Maybe Constraints
psConstraints = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text -> Constraints
Constraints ([Text] -> Text
Text.unwords (Text
wforall a. a -> [a] -> [a]
:[Text]
ws))
, $sel:psFlags:PkgSpec :: FlagSpec
psFlags = Map Text Bool -> FlagSpec
FlagSpec Map Text Bool
flags }
instance Semigroup PkgSpec where
( PkgSpec Maybe Constraints
c1 FlagSpec
f1 ) <> :: PkgSpec -> PkgSpec -> PkgSpec
<> ( PkgSpec Maybe Constraints
c2 FlagSpec
f2 ) =
Maybe Constraints -> FlagSpec -> PkgSpec
PkgSpec ( Maybe Constraints
c1 forall a. Semigroup a => a -> a -> a
<> Maybe Constraints
c2 )
( FlagSpec
f1 forall a. Semigroup a => a -> a -> a
<> FlagSpec
f2 )
unionPkgSpecsOverriding :: PkgSpecs -> PkgSpecs -> PkgSpecs
unionPkgSpecsOverriding :: PkgSpecs -> PkgSpecs -> PkgSpecs
unionPkgSpecsOverriding = forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith PkgSpec -> PkgSpec -> PkgSpec
unionPkgSpec
unionUnitSpecsCombining :: UnitSpecs -> UnitSpecs -> UnitSpecs
unionUnitSpecsCombining :: UnitSpecs -> UnitSpecs -> UnitSpecs
unionUnitSpecsCombining = forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith forall a. Semigroup a => a -> a -> a
(<>)
unionPkgSpec :: PkgSpec -> PkgSpec -> PkgSpec
unionPkgSpec :: PkgSpec -> PkgSpec -> PkgSpec
unionPkgSpec (PkgSpec Maybe Constraints
strongCts FlagSpec
strongFlags) (PkgSpec Maybe Constraints
weakCts FlagSpec
weakFlags)
= Maybe Constraints -> FlagSpec -> PkgSpec
PkgSpec Maybe Constraints
cts (FlagSpec
strongFlags forall a. Semigroup a => a -> a -> a
<> FlagSpec
weakFlags)
where
cts :: Maybe Constraints
cts = case Maybe Constraints
strongCts of
Maybe Constraints
Nothing -> Maybe Constraints
weakCts
Maybe Constraints
_ -> Maybe Constraints
strongCts
newtype Constraints = Constraints Text
deriving stock Int -> Constraints -> ShowS
[Constraints] -> ShowS
Constraints -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Constraints] -> ShowS
$cshowList :: [Constraints] -> ShowS
show :: Constraints -> [Char]
$cshow :: Constraints -> [Char]
showsPrec :: Int -> Constraints -> ShowS
$cshowsPrec :: Int -> Constraints -> ShowS
Show
instance Semigroup Constraints where
Constraints Text
c1 <> :: Constraints -> Constraints -> Constraints
<> Constraints Text
c2 =
Text -> Constraints
Constraints ( Text
" ( " forall a. Semigroup a => a -> a -> a
<> Text
c1 forall a. Semigroup a => a -> a -> a
<> Text
" ) && ( " forall a. Semigroup a => a -> a -> a
<> Text
c2 forall a. Semigroup a => a -> a -> a
<> Text
" )" )
newtype FlagSpec = FlagSpec (Strict.Map Text Bool)
deriving stock Int -> FlagSpec -> ShowS
[FlagSpec] -> ShowS
FlagSpec -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [FlagSpec] -> ShowS
$cshowList :: [FlagSpec] -> ShowS
show :: FlagSpec -> [Char]
$cshow :: FlagSpec -> [Char]
showsPrec :: Int -> FlagSpec -> ShowS
$cshowsPrec :: Int -> FlagSpec -> ShowS
Show
deriving newtype (FlagSpec -> FlagSpec -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FlagSpec -> FlagSpec -> Bool
$c/= :: FlagSpec -> FlagSpec -> Bool
== :: FlagSpec -> FlagSpec -> Bool
$c== :: FlagSpec -> FlagSpec -> Bool
Eq, Eq FlagSpec
FlagSpec -> FlagSpec -> Bool
FlagSpec -> FlagSpec -> Ordering
FlagSpec -> FlagSpec -> FlagSpec
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: FlagSpec -> FlagSpec -> FlagSpec
$cmin :: FlagSpec -> FlagSpec -> FlagSpec
max :: FlagSpec -> FlagSpec -> FlagSpec
$cmax :: FlagSpec -> FlagSpec -> FlagSpec
>= :: FlagSpec -> FlagSpec -> Bool
$c>= :: FlagSpec -> FlagSpec -> Bool
> :: FlagSpec -> FlagSpec -> Bool
$c> :: FlagSpec -> FlagSpec -> Bool
<= :: FlagSpec -> FlagSpec -> Bool
$c<= :: FlagSpec -> FlagSpec -> Bool
< :: FlagSpec -> FlagSpec -> Bool
$c< :: FlagSpec -> FlagSpec -> Bool
compare :: FlagSpec -> FlagSpec -> Ordering
$ccompare :: FlagSpec -> FlagSpec -> Ordering
Ord, NonEmpty FlagSpec -> FlagSpec
FlagSpec -> FlagSpec -> FlagSpec
forall b. Integral b => b -> FlagSpec -> FlagSpec
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> FlagSpec -> FlagSpec
$cstimes :: forall b. Integral b => b -> FlagSpec -> FlagSpec
sconcat :: NonEmpty FlagSpec -> FlagSpec
$csconcat :: NonEmpty FlagSpec -> FlagSpec
<> :: FlagSpec -> FlagSpec -> FlagSpec
$c<> :: FlagSpec -> FlagSpec -> FlagSpec
Semigroup, Semigroup FlagSpec
FlagSpec
[FlagSpec] -> FlagSpec
FlagSpec -> FlagSpec -> FlagSpec
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [FlagSpec] -> FlagSpec
$cmconcat :: [FlagSpec] -> FlagSpec
mappend :: FlagSpec -> FlagSpec -> FlagSpec
$cmappend :: FlagSpec -> FlagSpec -> FlagSpec
mempty :: FlagSpec
$cmempty :: FlagSpec
Monoid, Value -> Parser [FlagSpec]
Value -> Parser FlagSpec
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [FlagSpec]
$cparseJSONList :: Value -> Parser [FlagSpec]
parseJSON :: Value -> Parser FlagSpec
$cparseJSON :: Value -> Parser FlagSpec
FromJSON)
showFlagSpec :: FlagSpec -> Text
showFlagSpec :: FlagSpec -> Text
showFlagSpec (FlagSpec Map Text Bool
fs) =
[Text] -> Text
Text.unwords
[ Text
sign forall a. Semigroup a => a -> a -> a
<> Text
flag
| (Text
flag, Bool
value) <- forall k a. Map k a -> [(k, a)]
Map.toList Map Text Bool
fs
, let sign :: Text
sign = if Bool
value then Text
"+" else Text
"-"
]
flagSpecIsEmpty :: FlagSpec -> Bool
flagSpecIsEmpty :: FlagSpec -> Bool
flagSpecIsEmpty (FlagSpec Map Text Bool
fs) = forall (t :: * -> *) a. Foldable t => t a -> Bool
null Map Text Bool
fs
data PkgSrc
= Remote
| Local !FilePath
deriving stock Int -> PkgSrc -> ShowS
[PkgSrc] -> ShowS
PkgSrc -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [PkgSrc] -> ShowS
$cshowList :: [PkgSrc] -> ShowS
show :: PkgSrc -> [Char]
$cshow :: PkgSrc -> [Char]
showsPrec :: Int -> PkgSrc -> ShowS
$cshowsPrec :: Int -> PkgSrc -> ShowS
Show
instance Semigroup PkgSrc where
PkgSrc
Remote <> :: PkgSrc -> PkgSrc -> PkgSrc
<> PkgSrc
b = PkgSrc
b
PkgSrc
a <> PkgSrc
_ = PkgSrc
a
instance Monoid PkgSrc where
mempty :: PkgSrc
mempty = PkgSrc
Remote
instance FromJSON PkgSrc where
parseJSON :: Value -> Parser PkgSrc
parseJSON = forall a. [Char] -> (Object -> Parser a) -> Value -> Parser a
withObject [Char]
"package source" \ Object
o -> do
Text
ty <- Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"type"
case Text
ty :: Text of
Text
"local" -> [Char] -> PkgSrc
Local forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"path"
Text
"repo-tar" -> forall (m :: * -> *) a. Monad m => a -> m a
return PkgSrc
Remote
Text
_ ->
forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$
[Char]
"parseJSON PkgSrc: unsupported 'pkg-src' field: "
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
Text.unpack Text
ty
newtype UnitId = UnitId { UnitId -> Text
unUnitId :: Text }
deriving stock Int -> UnitId -> ShowS
[UnitId] -> ShowS
UnitId -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [UnitId] -> ShowS
$cshowList :: [UnitId] -> ShowS
show :: UnitId -> [Char]
$cshow :: UnitId -> [Char]
showsPrec :: Int -> UnitId -> ShowS
$cshowsPrec :: Int -> UnitId -> ShowS
Show
deriving newtype (UnitId -> UnitId -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UnitId -> UnitId -> Bool
$c/= :: UnitId -> UnitId -> Bool
== :: UnitId -> UnitId -> Bool
$c== :: UnitId -> UnitId -> Bool
Eq, Eq UnitId
UnitId -> UnitId -> Bool
UnitId -> UnitId -> Ordering
UnitId -> UnitId -> UnitId
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: UnitId -> UnitId -> UnitId
$cmin :: UnitId -> UnitId -> UnitId
max :: UnitId -> UnitId -> UnitId
$cmax :: UnitId -> UnitId -> UnitId
>= :: UnitId -> UnitId -> Bool
$c>= :: UnitId -> UnitId -> Bool
> :: UnitId -> UnitId -> Bool
$c> :: UnitId -> UnitId -> Bool
<= :: UnitId -> UnitId -> Bool
$c<= :: UnitId -> UnitId -> Bool
< :: UnitId -> UnitId -> Bool
$c< :: UnitId -> UnitId -> Bool
compare :: UnitId -> UnitId -> Ordering
$ccompare :: UnitId -> UnitId -> Ordering
Ord, Value -> Parser [UnitId]
Value -> Parser UnitId
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [UnitId]
$cparseJSONList :: Value -> Parser [UnitId]
parseJSON :: Value -> Parser UnitId
$cparseJSON :: Value -> Parser UnitId
FromJSON, FromJSONKeyFunction [UnitId]
FromJSONKeyFunction UnitId
forall a.
FromJSONKeyFunction a -> FromJSONKeyFunction [a] -> FromJSONKey a
fromJSONKeyList :: FromJSONKeyFunction [UnitId]
$cfromJSONKeyList :: FromJSONKeyFunction [UnitId]
fromJSONKey :: FromJSONKeyFunction UnitId
$cfromJSONKey :: FromJSONKeyFunction UnitId
FromJSONKey)
data PlanUnit
= PU_Preexisting !PreexistingUnit
| PU_Configured !ConfiguredUnit
deriving stock Int -> PlanUnit -> ShowS
[PlanUnit] -> ShowS
PlanUnit -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [PlanUnit] -> ShowS
$cshowList :: [PlanUnit] -> ShowS
show :: PlanUnit -> [Char]
$cshow :: PlanUnit -> [Char]
showsPrec :: Int -> PlanUnit -> ShowS
$cshowsPrec :: Int -> PlanUnit -> ShowS
Show
planUnitUnitId :: PlanUnit -> UnitId
planUnitUnitId :: PlanUnit -> UnitId
planUnitUnitId (PU_Preexisting (PreexistingUnit { UnitId
$sel:puId:PreexistingUnit :: PreexistingUnit -> UnitId
puId :: UnitId
puId })) = UnitId
puId
planUnitUnitId (PU_Configured (ConfiguredUnit { UnitId
$sel:puId:ConfiguredUnit :: ConfiguredUnit -> UnitId
puId :: UnitId
puId })) = UnitId
puId
planUnitPkgName :: PlanUnit -> PkgName
planUnitPkgName :: PlanUnit -> PkgName
planUnitPkgName (PU_Preexisting (PreexistingUnit { PkgName
$sel:puPkgName:PreexistingUnit :: PreexistingUnit -> PkgName
puPkgName :: PkgName
puPkgName })) = PkgName
puPkgName
planUnitPkgName (PU_Configured (ConfiguredUnit { PkgName
$sel:puPkgName:ConfiguredUnit :: ConfiguredUnit -> PkgName
puPkgName :: PkgName
puPkgName })) = PkgName
puPkgName
planUnitVersion :: PlanUnit -> Version
planUnitVersion :: PlanUnit -> Version
planUnitVersion (PU_Preexisting (PreexistingUnit { Version
$sel:puVersion:PreexistingUnit :: PreexistingUnit -> Version
puVersion :: Version
puVersion })) = Version
puVersion
planUnitVersion (PU_Configured (ConfiguredUnit { Version
$sel:puVersion:ConfiguredUnit :: ConfiguredUnit -> Version
puVersion :: Version
puVersion })) = Version
puVersion
instance FromJSON PlanUnit where
parseJSON :: Value -> Parser PlanUnit
parseJSON = forall a. [Char] -> (Object -> Parser a) -> Value -> Parser a
withObject [Char]
"plan unit" \ Object
o -> do
Text
ty <- Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"type"
case Text
ty :: Text of
Text
"pre-existing" -> PreexistingUnit -> PlanUnit
PU_Preexisting forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Parser PreexistingUnit
preExisting Object
o
Text
"configured" -> ConfiguredUnit -> PlanUnit
PU_Configured forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Parser ConfiguredUnit
configured Object
o
Text
_ -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$
[Char]
"parseJSON PlanUnit: unexpected type " forall a. [a] -> [a] -> [a]
++ Text -> [Char]
Text.unpack Text
ty forall a. [a] -> [a] -> [a]
++ [Char]
",\n\
\expecting 'pre-existing' or 'configured'"
where
preExisting :: Object -> Parser PreexistingUnit
preExisting Object
o = do
UnitId
puId <- Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"id"
PkgName
puPkgName <- Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"pkg-name"
Version
puVersion <- Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"pkg-version"
[UnitId]
puDepends <- Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"depends"
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ PreexistingUnit {[UnitId]
Version
UnitId
PkgName
$sel:puDepends:PreexistingUnit :: [UnitId]
puDepends :: [UnitId]
puVersion :: Version
puPkgName :: PkgName
puId :: UnitId
$sel:puVersion:PreexistingUnit :: Version
$sel:puPkgName:PreexistingUnit :: PkgName
$sel:puId:PreexistingUnit :: UnitId
..}
configured :: Object -> Parser ConfiguredUnit
configured Object
o = do
UnitId
puId <- Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"id"
PkgName
puPkgName <- Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"pkg-name"
Version
puVersion <- Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"pkg-version"
FlagSpec
puFlags <- forall a. a -> Maybe a -> a
fromMaybe (Map Text Bool -> FlagSpec
FlagSpec forall k a. Map k a
Map.empty) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"flags"
Maybe Object
mbComps <- Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"components"
PkgSrc
puPkgSrc <- Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"pkg-src"
(ComponentName
puComponentName, [UnitId]
puDepends, [UnitId]
puExeDepends, [UnitId]
puSetupDepends) <-
case Maybe Object
mbComps of
Maybe Object
Nothing -> do
[UnitId]
deps <- Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"depends"
[UnitId]
exeDeps <- Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"exe-depends"
Text
compName <- Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"component-name"
let
comp :: ComponentName
comp
| Text
compName forall a. Eq a => a -> a -> Bool
== Text
"lib"
= ComponentType -> Text -> ComponentName
ComponentName ComponentType
Lib (PkgName -> Text
unPkgName PkgName
puPkgName)
| (Text
ty,Text
nm) <- (Char -> Bool) -> Text -> (Text, Text)
Text.break (forall a. Eq a => a -> a -> Bool
== Char
':') Text
compName
, Just ComponentType
compTy <- Text -> Maybe ComponentType
parseComponentType Text
ty
, Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Text -> Bool
Text.null Text
nm
= ComponentType -> Text -> ComponentName
ComponentName ComponentType
compTy (Int -> Text -> Text
Text.drop Int
1 Text
nm)
| Bool
otherwise
= forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"parseJSON PlanUnit: unsupported component name "
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
Text.unpack Text
compName
forall (m :: * -> *) a. Monad m => a -> m a
return (ComponentName
comp, [UnitId]
deps, [UnitId]
exeDeps, [])
Just Object
comps -> do
Object
lib <- Object
comps forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"lib"
[UnitId]
deps <- Object
lib forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"depends"
[UnitId]
exeDeps <- Object
lib forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"exe-depends"
Maybe Object
mbSetup <- Object
comps forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"setup"
[UnitId]
setupDeps <-
case Maybe Object
mbSetup of
Maybe Object
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return []
Just Object
setup -> Object
setup forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"depends"
forall (m :: * -> *) a. Monad m => a -> m a
return (ComponentType -> Text -> ComponentName
ComponentName ComponentType
Lib (PkgName -> Text
unPkgName PkgName
puPkgName), [UnitId]
deps, [UnitId]
exeDeps, [UnitId]
setupDeps)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ConfiguredUnit {[UnitId]
Version
ComponentName
UnitId
PkgSrc
FlagSpec
PkgName
$sel:puPkgSrc:ConfiguredUnit :: PkgSrc
$sel:puSetupDepends:ConfiguredUnit :: [UnitId]
$sel:puExeDepends:ConfiguredUnit :: [UnitId]
$sel:puDepends:ConfiguredUnit :: [UnitId]
$sel:puFlags:ConfiguredUnit :: FlagSpec
$sel:puComponentName:ConfiguredUnit :: ComponentName
puSetupDepends :: [UnitId]
puExeDepends :: [UnitId]
puDepends :: [UnitId]
puComponentName :: ComponentName
puPkgSrc :: PkgSrc
puFlags :: FlagSpec
puVersion :: Version
puPkgName :: PkgName
puId :: UnitId
$sel:puVersion:ConfiguredUnit :: Version
$sel:puPkgName:ConfiguredUnit :: PkgName
$sel:puId:ConfiguredUnit :: UnitId
..}
data PreexistingUnit
= PreexistingUnit
{ PreexistingUnit -> UnitId
puId :: !UnitId
, PreexistingUnit -> PkgName
puPkgName :: !PkgName
, PreexistingUnit -> Version
puVersion :: !Version
, PreexistingUnit -> [UnitId]
puDepends :: ![UnitId]
}
deriving stock Int -> PreexistingUnit -> ShowS
[PreexistingUnit] -> ShowS
PreexistingUnit -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [PreexistingUnit] -> ShowS
$cshowList :: [PreexistingUnit] -> ShowS
show :: PreexistingUnit -> [Char]
$cshow :: PreexistingUnit -> [Char]
showsPrec :: Int -> PreexistingUnit -> ShowS
$cshowsPrec :: Int -> PreexistingUnit -> ShowS
Show
data ConfiguredUnit
= ConfiguredUnit
{ ConfiguredUnit -> UnitId
puId :: !UnitId
, ConfiguredUnit -> PkgName
puPkgName :: !PkgName
, ConfiguredUnit -> Version
puVersion :: !Version
, ConfiguredUnit -> ComponentName
puComponentName :: !ComponentName
, ConfiguredUnit -> FlagSpec
puFlags :: !FlagSpec
, ConfiguredUnit -> [UnitId]
puDepends :: ![UnitId]
, ConfiguredUnit -> [UnitId]
puExeDepends :: ![UnitId]
, ConfiguredUnit -> [UnitId]
puSetupDepends :: ![UnitId]
, ConfiguredUnit -> PkgSrc
puPkgSrc :: !PkgSrc
}
deriving stock Int -> ConfiguredUnit -> ShowS
[ConfiguredUnit] -> ShowS
ConfiguredUnit -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ConfiguredUnit] -> ShowS
$cshowList :: [ConfiguredUnit] -> ShowS
show :: ConfiguredUnit -> [Char]
$cshow :: ConfiguredUnit -> [Char]
showsPrec :: Int -> ConfiguredUnit -> ShowS
$cshowsPrec :: Int -> ConfiguredUnit -> ShowS
Show
configuredUnitMaybe :: PlanUnit -> Maybe ConfiguredUnit
configuredUnitMaybe :: PlanUnit -> Maybe ConfiguredUnit
configuredUnitMaybe (PU_Configured ConfiguredUnit
pu) = forall a. a -> Maybe a
Just ConfiguredUnit
pu
configuredUnitMaybe (PU_Preexisting {}) = forall a. Maybe a
Nothing
cuComponentType :: ConfiguredUnit -> ComponentType
cuComponentType :: ConfiguredUnit -> ComponentType
cuComponentType = ComponentName -> ComponentType
componentType forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConfiguredUnit -> ComponentName
puComponentName
allDepends :: ConfiguredUnit -> [UnitId]
allDepends :: ConfiguredUnit -> [UnitId]
allDepends (ConfiguredUnit { [UnitId]
puDepends :: [UnitId]
$sel:puDepends:ConfiguredUnit :: ConfiguredUnit -> [UnitId]
puDepends, [UnitId]
puExeDepends :: [UnitId]
$sel:puExeDepends:ConfiguredUnit :: ConfiguredUnit -> [UnitId]
puExeDepends, [UnitId]
puSetupDepends :: [UnitId]
$sel:puSetupDepends:ConfiguredUnit :: ConfiguredUnit -> [UnitId]
puSetupDepends }) =
[UnitId]
puDepends forall a. [a] -> [a] -> [a]
++ [UnitId]
puExeDepends forall a. [a] -> [a] -> [a]
++ [UnitId]
puSetupDepends
unitDepends :: ConfiguredUnit -> [UnitId]
unitDepends :: ConfiguredUnit -> [UnitId]
unitDepends (ConfiguredUnit { [UnitId]
puDepends :: [UnitId]
$sel:puDepends:ConfiguredUnit :: ConfiguredUnit -> [UnitId]
puDepends, [UnitId]
puExeDepends :: [UnitId]
$sel:puExeDepends:ConfiguredUnit :: ConfiguredUnit -> [UnitId]
puExeDepends }) =
[UnitId]
puDepends forall a. [a] -> [a] -> [a]
++ [UnitId]
puExeDepends
type UnitSpecs = Strict.Map PkgName (PkgSrc, PkgSpec, Set ComponentName)
data ComponentName =
ComponentName { ComponentName -> ComponentType
componentType :: !ComponentType
, ComponentName -> Text
componentName :: !Text
}
deriving stock (ComponentName -> ComponentName -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ComponentName -> ComponentName -> Bool
$c/= :: ComponentName -> ComponentName -> Bool
== :: ComponentName -> ComponentName -> Bool
$c== :: ComponentName -> ComponentName -> Bool
Eq, Eq ComponentName
ComponentName -> ComponentName -> Bool
ComponentName -> ComponentName -> Ordering
ComponentName -> ComponentName -> ComponentName
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ComponentName -> ComponentName -> ComponentName
$cmin :: ComponentName -> ComponentName -> ComponentName
max :: ComponentName -> ComponentName -> ComponentName
$cmax :: ComponentName -> ComponentName -> ComponentName
>= :: ComponentName -> ComponentName -> Bool
$c>= :: ComponentName -> ComponentName -> Bool
> :: ComponentName -> ComponentName -> Bool
$c> :: ComponentName -> ComponentName -> Bool
<= :: ComponentName -> ComponentName -> Bool
$c<= :: ComponentName -> ComponentName -> Bool
< :: ComponentName -> ComponentName -> Bool
$c< :: ComponentName -> ComponentName -> Bool
compare :: ComponentName -> ComponentName -> Ordering
$ccompare :: ComponentName -> ComponentName -> Ordering
Ord, Int -> ComponentName -> ShowS
[ComponentName] -> ShowS
ComponentName -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ComponentName] -> ShowS
$cshowList :: [ComponentName] -> ShowS
show :: ComponentName -> [Char]
$cshow :: ComponentName -> [Char]
showsPrec :: Int -> ComponentName -> ShowS
$cshowsPrec :: Int -> ComponentName -> ShowS
Show)
cabalComponent :: ComponentName -> Text
cabalComponent :: ComponentName -> Text
cabalComponent (ComponentName ComponentType
ty Text
nm) = ComponentType -> Text
cabalComponentType ComponentType
ty forall a. Semigroup a => a -> a -> a
<> Text
":" forall a. Semigroup a => a -> a -> a
<> Text
nm
parsePkgComponent :: Text -> Maybe ( PkgName, ComponentName )
parsePkgComponent :: Text -> Maybe (PkgName, ComponentName)
parsePkgComponent Text
txt = case Text -> Text -> [Text]
Text.splitOn Text
":" Text
txt of
Text
ty:Text
pkg:[]
| Just ComponentType
t <- Text -> Maybe ComponentType
parseComponentType Text
ty
, Text -> Bool
validPackageName Text
pkg
-> forall a. a -> Maybe a
Just ( Text -> PkgName
PkgName Text
pkg, ComponentType -> Text -> ComponentName
ComponentName ComponentType
t Text
pkg )
Text
pkg:Text
ty:Text
comp:[]
| Maybe ComponentType
Nothing <- Text -> Maybe ComponentType
parseComponentType Text
pkg
, Text -> Bool
validPackageName Text
pkg
, Just ComponentType
t <- Text -> Maybe ComponentType
parseComponentType Text
ty
, Text -> Bool
validPackageName Text
comp
-> forall a. a -> Maybe a
Just ( Text -> PkgName
PkgName Text
pkg, ComponentType -> Text -> ComponentName
ComponentName ComponentType
t Text
comp )
Text
pkg:Text
comp:[]
| Maybe ComponentType
Nothing <- Text -> Maybe ComponentType
parseComponentType Text
pkg
, Text -> Bool
validPackageName Text
pkg
, Text -> Bool
validPackageName Text
comp
-> forall a. a -> Maybe a
Just ( Text -> PkgName
PkgName Text
comp, ComponentType -> Text -> ComponentName
ComponentName ComponentType
Lib Text
comp )
Text
pkg:[]
| Maybe ComponentType
Nothing <- Text -> Maybe ComponentType
parseComponentType Text
pkg
, Text -> Bool
validPackageName Text
pkg
-> forall a. a -> Maybe a
Just ( Text -> PkgName
PkgName Text
pkg, ComponentType -> Text -> ComponentName
ComponentName ComponentType
Lib Text
pkg )
[Text]
_ -> forall a. Maybe a
Nothing
data ComponentType
= Lib
| FLib
| Exe
| Test
| Bench
| Setup
deriving stock (ComponentType -> ComponentType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ComponentType -> ComponentType -> Bool
$c/= :: ComponentType -> ComponentType -> Bool
== :: ComponentType -> ComponentType -> Bool
$c== :: ComponentType -> ComponentType -> Bool
Eq, Eq ComponentType
ComponentType -> ComponentType -> Bool
ComponentType -> ComponentType -> Ordering
ComponentType -> ComponentType -> ComponentType
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ComponentType -> ComponentType -> ComponentType
$cmin :: ComponentType -> ComponentType -> ComponentType
max :: ComponentType -> ComponentType -> ComponentType
$cmax :: ComponentType -> ComponentType -> ComponentType
>= :: ComponentType -> ComponentType -> Bool
$c>= :: ComponentType -> ComponentType -> Bool
> :: ComponentType -> ComponentType -> Bool
$c> :: ComponentType -> ComponentType -> Bool
<= :: ComponentType -> ComponentType -> Bool
$c<= :: ComponentType -> ComponentType -> Bool
< :: ComponentType -> ComponentType -> Bool
$c< :: ComponentType -> ComponentType -> Bool
compare :: ComponentType -> ComponentType -> Ordering
$ccompare :: ComponentType -> ComponentType -> Ordering
Ord, Int -> ComponentType -> ShowS
[ComponentType] -> ShowS
ComponentType -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ComponentType] -> ShowS
$cshowList :: [ComponentType] -> ShowS
show :: ComponentType -> [Char]
$cshow :: ComponentType -> [Char]
showsPrec :: Int -> ComponentType -> ShowS
$cshowsPrec :: Int -> ComponentType -> ShowS
Show)
cabalComponentType :: ComponentType -> Text
cabalComponentType :: ComponentType -> Text
cabalComponentType ComponentType
Lib = Text
"lib"
cabalComponentType ComponentType
FLib = Text
"flib"
cabalComponentType ComponentType
Exe = Text
"exe"
cabalComponentType ComponentType
Test = Text
"test"
cabalComponentType ComponentType
Bench = Text
"bench"
cabalComponentType ComponentType
Setup = Text
"setup"
parseComponentType :: Text -> Maybe ComponentType
parseComponentType :: Text -> Maybe ComponentType
parseComponentType Text
"lib" = forall a. a -> Maybe a
Just ComponentType
Lib
parseComponentType Text
"flib" = forall a. a -> Maybe a
Just ComponentType
FLib
parseComponentType Text
"exe" = forall a. a -> Maybe a
Just ComponentType
Exe
parseComponentType Text
"test" = forall a. a -> Maybe a
Just ComponentType
Test
parseComponentType Text
"bench" = forall a. a -> Maybe a
Just ComponentType
Bench
parseComponentType Text
"setup" = forall a. a -> Maybe a
Just ComponentType
Setup
parseComponentType Text
_ = forall a. Maybe a
Nothing