{-# LANGUAGE DataKinds        #-}
{-# LANGUAGE DeriveGeneric    #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeApplications #-}

module HaskellWorks.CabalCache.Topology
  ( PlanData(..)
  , buildPlanData
  , canShare
  ) where

import Control.Arrow                 ((&&&))
import Control.Lens                  (view, (&), (<&>), (^.))
import Control.Monad                 (join)
import Data.Either                   (fromRight)
import Data.Generics.Product.Any     (the)
import Data.Map.Strict               (Map)
import Data.Maybe                    (fromMaybe)
import Data.Set                      (Set)
import GHC.Generics                  (Generic)
import HaskellWorks.CabalCache.Types (Package, PackageId, PlanJson)

import qualified Data.Map.Strict as M
import qualified Data.Set        as S
import qualified Topograph       as TG

newtype PlanData = PlanData
  { PlanData -> Set PackageId
nonShareable :: Set PackageId
  } deriving (forall x. PlanData -> Rep PlanData x)
-> (forall x. Rep PlanData x -> PlanData) -> Generic PlanData
forall x. Rep PlanData x -> PlanData
forall x. PlanData -> Rep PlanData x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep PlanData x -> PlanData
$cfrom :: forall x. PlanData -> Rep PlanData x
Generic

buildPlanData :: PlanJson   -- ^ The original plan
  -> [PackageId]            -- ^ Packages that are known to be non-shareable
  -> PlanData               -- ^ Updated plan
buildPlanData :: PlanJson -> [PackageId] -> PlanData
buildPlanData PlanJson
plan [PackageId]
nonShareablePkgs =
  let dm :: Map PackageId (Set PackageId)
dm = [Package] -> Map PackageId (Set PackageId)
dependenciesMap (PlanJson
plan PlanJson -> Getting [Package] PlanJson [Package] -> [Package]
forall s a. s -> Getting a s a -> a
^. forall k (sel :: k) s t a b. HasAny sel s t a b => Lens s t a b
forall s t a b. HasAny "installPlan" s t a b => Lens s t a b
the @"installPlan")
  in Map PackageId (Set PackageId) -> [PackageId] -> PlanData
buildPlanData' Map PackageId (Set PackageId)
dm [PackageId]
nonShareablePkgs

canShare :: PlanData -> PackageId -> Bool
canShare :: PlanData -> PackageId -> Bool
canShare PlanData
planData PackageId
pkgId = PackageId -> Set PackageId -> Bool
forall a. Ord a => a -> Set a -> Bool
S.notMember PackageId
pkgId (PlanData -> Set PackageId
nonShareable PlanData
planData)

-------------------------------------------------------------------------------

dependenciesMap :: [Package] -> Map PackageId (Set PackageId)
dependenciesMap :: [Package] -> Map PackageId (Set PackageId)
dependenciesMap [Package]
plan = [Package]
plan
  [Package]
-> (Package -> (PackageId, [PackageId]))
-> [(PackageId, [PackageId])]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Getting PackageId Package PackageId -> Package -> PackageId
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (forall k (sel :: k) s t a b. HasAny sel s t a b => Lens s t a b
forall s t a b. HasAny "id" s t a b => Lens s t a b
the @"id") (Package -> PackageId)
-> (Package -> [PackageId]) -> Package -> (PackageId, [PackageId])
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Getting [PackageId] Package [PackageId] -> Package -> [PackageId]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (forall k (sel :: k) s t a b. HasAny sel s t a b => Lens s t a b
forall s t a b. HasAny "depends" s t a b => Lens s t a b
the @"depends"))
  [(PackageId, [PackageId])]
-> ((PackageId, [PackageId]) -> (PackageId, Set PackageId))
-> [(PackageId, Set PackageId)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> ([PackageId] -> Set PackageId)
-> (PackageId, [PackageId]) -> (PackageId, Set PackageId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [PackageId] -> Set PackageId
forall a. Ord a => [a] -> Set a
S.fromList [(PackageId, Set PackageId)]
-> ([(PackageId, Set PackageId)] -> Map PackageId (Set PackageId))
-> Map PackageId (Set PackageId)
forall a b. a -> (a -> b) -> b
& [(PackageId, Set PackageId)] -> Map PackageId (Set PackageId)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList

buildPlanData' :: Map PackageId (Set PackageId) -- ^ Dependencies map
  -> [PackageId]                                -- ^ Packages to exclude
  -> PlanData                                   -- ^ All package ids to exclude
buildPlanData' :: Map PackageId (Set PackageId) -> [PackageId] -> PlanData
buildPlanData' Map PackageId (Set PackageId)
plan [PackageId]
knownNonShareable =
  PlanData -> Either [PackageId] PlanData -> PlanData
forall b a. b -> Either a b -> b
fromRight ([Char] -> PlanData
forall a. HasCallStack => [Char] -> a
error [Char]
"Could not process dependencies") (Either [PackageId] PlanData -> PlanData)
-> Either [PackageId] PlanData -> PlanData
forall a b. (a -> b) -> a -> b
$
    Map PackageId (Set PackageId)
-> (forall i. Ord i => G PackageId i -> PlanData)
-> Either [PackageId] PlanData
forall v r.
Ord v =>
Map v (Set v) -> (forall i. Ord i => G v i -> r) -> Either [v] r
TG.runG Map PackageId (Set PackageId)
plan ((forall i. Ord i => G PackageId i -> PlanData)
 -> Either [PackageId] PlanData)
-> (forall i. Ord i => G PackageId i -> PlanData)
-> Either [PackageId] PlanData
forall a b. (a -> b) -> a -> b
$ \G PackageId i
g ->
      let tg :: G PackageId (Down i)
tg        = G PackageId i -> G PackageId (Down i)
forall v i. Ord i => G v i -> G v (Down i)
TG.transpose G PackageId i
g
          nsPaths :: [[PackageId]]
nsPaths   = (PackageId -> [[PackageId]]) -> [PackageId] -> [[PackageId]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([[PackageId]] -> Maybe [[PackageId]] -> [[PackageId]]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [[PackageId]] -> [[PackageId]])
-> (PackageId -> Maybe [[PackageId]]) -> PackageId -> [[PackageId]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. G PackageId (Down i) -> PackageId -> Maybe [[PackageId]]
forall i v. Ord i => G v i -> v -> Maybe [[v]]
paths G PackageId (Down i)
tg) [PackageId]
knownNonShareable
          nsAll :: Set PackageId
nsAll     = [PackageId] -> Set PackageId
forall a. Ord a => [a] -> Set a
S.fromList ([[PackageId]] -> [PackageId]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join [[PackageId]]
nsPaths)
      in PlanData :: Set PackageId -> PlanData
PlanData { nonShareable :: Set PackageId
nonShareable = Set PackageId
nsAll }
  where paths :: G v i -> v -> Maybe [[v]]
paths G v i
g v
x = (([[i]] -> [[v]]) -> Maybe [[i]] -> Maybe [[v]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([[i]] -> [[v]]) -> Maybe [[i]] -> Maybe [[v]])
-> ((i -> v) -> [[i]] -> [[v]])
-> (i -> v)
-> Maybe [[i]]
-> Maybe [[v]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([i] -> [v]) -> [[i]] -> [[v]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([i] -> [v]) -> [[i]] -> [[v]])
-> ((i -> v) -> [i] -> [v]) -> (i -> v) -> [[i]] -> [[v]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (i -> v) -> [i] -> [v]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) (G v i -> i -> v
forall v i. G v i -> i -> v
TG.gFromVertex G v i
g) (Maybe [[i]] -> Maybe [[v]]) -> Maybe [[i]] -> Maybe [[v]]
forall a b. (a -> b) -> a -> b
$ G v i -> i -> [[i]]
forall v i. Ord i => G v i -> i -> [[i]]
TG.dfs G v i
g (i -> [[i]]) -> Maybe i -> Maybe [[i]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> G v i -> v -> Maybe i
forall v i. G v i -> v -> Maybe i
TG.gToVertex G v i
g v
x