{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wno-name-shadowing #-}

-- | Archive investigation
module CabalFix.Archive where

import Algebra.Graph
import Algebra.Graph.ToGraph qualified as ToGraph
import CabalFix
import CabalFix.FlatParse (depP, runParser_, untilP)
import Codec.Archive.Tar qualified as Tar
import Control.Category ((>>>))
import Data.Bifunctor
import Data.Bool
import Data.ByteString (ByteString)
import Data.ByteString.Lazy qualified as BSL
import Data.Either
import Data.Foldable
import Data.List qualified as List
import Data.Map.Strict qualified as Map
import Data.Maybe
import Data.Set qualified as Set
import Distribution.Parsec
import Distribution.Version
import DotParse qualified as Dot
import FlatParse.Basic qualified as FP
import GHC.Generics
import Optics.Extra
import System.Directory

-- | the cabal index
cabalIndex :: IO FilePath
cabalIndex :: IO String
cabalIndex = do
  String
h <- IO String
getHomeDirectory
  String -> IO String
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
h String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"/.cabal/packages/hackage.haskell.org/01-index.tar"

-- | all the tar entries that represent packages of some kind.
cabalEntries :: IO [Tar.Entry]
cabalEntries :: IO [Entry]
cabalEntries = GenEntries TarPath LinkTarget FormatError -> [Entry]
forall {e} {tarPath} {linkTarget}.
Show e =>
GenEntries tarPath linkTarget e -> [GenEntry tarPath linkTarget]
entryList (GenEntries TarPath LinkTarget FormatError -> [Entry])
-> (ByteString -> GenEntries TarPath LinkTarget FormatError)
-> ByteString
-> [Entry]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> GenEntries TarPath LinkTarget FormatError
Tar.read (ByteString -> [Entry]) -> IO ByteString -> IO [Entry]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> IO ByteString
BSL.readFile (String -> IO ByteString) -> IO String -> IO ByteString
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO String
cabalIndex)
  where
    entryList :: GenEntries tarPath linkTarget e -> [GenEntry tarPath linkTarget]
entryList GenEntries tarPath linkTarget e
es = (GenEntry tarPath linkTarget
 -> [GenEntry tarPath linkTarget] -> [GenEntry tarPath linkTarget])
-> [GenEntry tarPath linkTarget]
-> (e -> [GenEntry tarPath linkTarget])
-> GenEntries tarPath linkTarget e
-> [GenEntry tarPath linkTarget]
forall tarPath linkTarget a e.
(GenEntry tarPath linkTarget -> a -> a)
-> a -> (e -> a) -> GenEntries tarPath linkTarget e -> a
Tar.foldEntries (:) [] (String -> [GenEntry tarPath linkTarget]
forall a. HasCallStack => String -> a
error (String -> [GenEntry tarPath linkTarget])
-> (e -> String) -> e -> [GenEntry tarPath linkTarget]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> String
forall a. Show a => a -> String
show) GenEntries tarPath linkTarget e
es

-- | The naming convention in 01-index.tar
data FileName = FileName {FileName -> ByteString
nameFN :: ByteString, FileName -> ByteString
versionFN :: ByteString, FileName -> ByteString
filenameFN :: ByteString} deriving ((forall x. FileName -> Rep FileName x)
-> (forall x. Rep FileName x -> FileName) -> Generic FileName
forall x. Rep FileName x -> FileName
forall x. FileName -> Rep FileName x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. FileName -> Rep FileName x
from :: forall x. FileName -> Rep FileName x
$cto :: forall x. Rep FileName x -> FileName
to :: forall x. Rep FileName x -> FileName
Generic, FileName -> FileName -> Bool
(FileName -> FileName -> Bool)
-> (FileName -> FileName -> Bool) -> Eq FileName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FileName -> FileName -> Bool
== :: FileName -> FileName -> Bool
$c/= :: FileName -> FileName -> Bool
/= :: FileName -> FileName -> Bool
Eq, Eq FileName
Eq FileName =>
(FileName -> FileName -> Ordering)
-> (FileName -> FileName -> Bool)
-> (FileName -> FileName -> Bool)
-> (FileName -> FileName -> Bool)
-> (FileName -> FileName -> Bool)
-> (FileName -> FileName -> FileName)
-> (FileName -> FileName -> FileName)
-> Ord FileName
FileName -> FileName -> Bool
FileName -> FileName -> Ordering
FileName -> FileName -> FileName
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
$ccompare :: FileName -> FileName -> Ordering
compare :: FileName -> FileName -> Ordering
$c< :: FileName -> FileName -> Bool
< :: FileName -> FileName -> Bool
$c<= :: FileName -> FileName -> Bool
<= :: FileName -> FileName -> Bool
$c> :: FileName -> FileName -> Bool
> :: FileName -> FileName -> Bool
$c>= :: FileName -> FileName -> Bool
>= :: FileName -> FileName -> Bool
$cmax :: FileName -> FileName -> FileName
max :: FileName -> FileName -> FileName
$cmin :: FileName -> FileName -> FileName
min :: FileName -> FileName -> FileName
Ord, Int -> FileName -> String -> String
[FileName] -> String -> String
FileName -> String
(Int -> FileName -> String -> String)
-> (FileName -> String)
-> ([FileName] -> String -> String)
-> Show FileName
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> FileName -> String -> String
showsPrec :: Int -> FileName -> String -> String
$cshow :: FileName -> String
show :: FileName -> String
$cshowList :: [FileName] -> String -> String
showList :: [FileName] -> String -> String
Show)

-- | Convert a ByteString to a FileName. Errors on failure.
filename :: ByteString -> FileName
filename :: ByteString -> FileName
filename = Parser String FileName -> ByteString -> FileName
forall a. Parser String a -> ByteString -> a
runParser_ Parser String FileName
forall e. Parser e FileName
filenameP

-- | FileName parser
filenameP :: FP.Parser e FileName
filenameP :: forall e. Parser e FileName
filenameP = ByteString -> ByteString -> ByteString -> FileName
FileName (ByteString -> ByteString -> ByteString -> FileName)
-> ParserT PureMode e ByteString
-> ParserT PureMode e (ByteString -> ByteString -> FileName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> ParserT PureMode e ByteString
forall e. Char -> Parser e ByteString
untilP Char
'/' ParserT PureMode e (ByteString -> ByteString -> FileName)
-> ParserT PureMode e ByteString
-> ParserT PureMode e (ByteString -> FileName)
forall a b.
ParserT PureMode e (a -> b)
-> ParserT PureMode e a -> ParserT PureMode e b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Char -> ParserT PureMode e ByteString
forall e. Char -> Parser e ByteString
untilP Char
'/' ParserT PureMode e (ByteString -> FileName)
-> ParserT PureMode e ByteString -> ParserT PureMode e FileName
forall a b.
ParserT PureMode e (a -> b)
-> ParserT PureMode e a -> ParserT PureMode e b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParserT PureMode e ByteString
forall (st :: ZeroBitType) e. ParserT st e ByteString
FP.takeRest

-- | cabal files
--
-- Discards stale versions with later revisions
cabals :: IO [(FileName, ByteString)]
cabals :: IO [(FileName, ByteString)]
cabals = do
  [Entry]
es <- IO [Entry]
cabalEntries
  let cs :: [(FileName, ByteString)]
cs = (String -> FileName)
-> (String, ByteString) -> (FileName, ByteString)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Parser String FileName -> ByteString -> FileName
forall a. Parser String a -> ByteString -> a
runParser_ Parser String FileName
forall e. Parser e FileName
filenameP (ByteString -> FileName)
-> (String -> ByteString) -> String -> FileName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
FP.strToUtf8) ((String, ByteString) -> (FileName, ByteString))
-> [(String, ByteString)] -> [(FileName, ByteString)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((String, ByteString) -> Bool)
-> [(String, ByteString)] -> [(String, ByteString)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
"package.json") (ByteString -> Bool)
-> ((String, ByteString) -> ByteString)
-> (String, ByteString)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileName -> ByteString
filenameFN (FileName -> ByteString)
-> ((String, ByteString) -> FileName)
-> (String, ByteString)
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser String FileName -> ByteString -> FileName
forall a. Parser String a -> ByteString -> a
runParser_ Parser String FileName
forall e. Parser e FileName
filenameP (ByteString -> FileName)
-> ((String, ByteString) -> ByteString)
-> (String, ByteString)
-> FileName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
FP.strToUtf8 (String -> ByteString)
-> ((String, ByteString) -> String)
-> (String, ByteString)
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, ByteString) -> String
forall a b. (a, b) -> a
fst) (((String, ByteString) -> Bool)
-> [(String, ByteString)] -> [(String, ByteString)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((String, ByteString) -> Bool) -> (String, ByteString) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
List.isSuffixOf String
"preferred-versions" (String -> Bool)
-> ((String, ByteString) -> String) -> (String, ByteString) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, ByteString) -> String
forall a b. (a, b) -> a
fst) ([(String, ByteString)] -> [(String, ByteString)])
-> [(String, ByteString)] -> [(String, ByteString)]
forall a b. (a -> b) -> a -> b
$ [(String
fp, ByteString -> ByteString
BSL.toStrict ByteString
bs) | (String
fp, Tar.NormalFile ByteString
bs FileSize
_) <- (\Entry
e -> (Entry -> String
forall linkTarget. GenEntry TarPath linkTarget -> String
Tar.entryPath Entry
e, Entry -> GenEntryContent LinkTarget
forall tarPath linkTarget.
GenEntry tarPath linkTarget -> GenEntryContent linkTarget
Tar.entryContent Entry
e)) (Entry -> (String, GenEntryContent LinkTarget))
-> [Entry] -> [(String, GenEntryContent LinkTarget)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Entry]
es])
  [(FileName, ByteString)] -> IO [(FileName, ByteString)]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(FileName, ByteString)] -> IO [(FileName, ByteString)])
-> [(FileName, ByteString)] -> IO [(FileName, ByteString)]
forall a b. (a -> b) -> a -> b
$ Map FileName ByteString -> [(FileName, ByteString)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map FileName ByteString -> [(FileName, ByteString)])
-> Map FileName ByteString -> [(FileName, ByteString)]
forall a b. (a -> b) -> a -> b
$ [(FileName, ByteString)] -> Map FileName ByteString
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(FileName, ByteString)]
cs

-- | Assumes cabal entries are in chronological order and that the last version encountered is the
-- latest valid one.
latestCabals :: IO (Map.Map ByteString (Version, ByteString))
latestCabals :: IO (Map ByteString (Version, ByteString))
latestCabals = do
  [(FileName, ByteString)]
cs <- IO [(FileName, ByteString)]
CabalFix.Archive.cabals
  Map ByteString (Version, ByteString)
-> IO (Map ByteString (Version, ByteString))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map ByteString (Version, ByteString)
 -> IO (Map ByteString (Version, ByteString)))
-> Map ByteString (Version, ByteString)
-> IO (Map ByteString (Version, ByteString))
forall a b. (a -> b) -> a -> b
$ ((Version, ByteString)
 -> (Version, ByteString) -> (Version, ByteString))
-> [(ByteString, (Version, ByteString))]
-> Map ByteString (Version, ByteString)
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith (\(Version, ByteString)
new (Version, ByteString)
old -> (Version, ByteString)
-> (Version, ByteString) -> Bool -> (Version, ByteString)
forall a. a -> a -> Bool -> a
bool (Version, ByteString)
old (Version, ByteString)
new ((Version, ByteString) -> Version
forall a b. (a, b) -> a
fst (Version, ByteString)
new Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= (Version, ByteString) -> Version
forall a b. (a, b) -> a
fst (Version, ByteString)
old)) ([(ByteString, (Version, ByteString))]
 -> Map ByteString (Version, ByteString))
-> [(ByteString, (Version, ByteString))]
-> Map ByteString (Version, ByteString)
forall a b. (a -> b) -> a -> b
$ (\(FileName
fn, ByteString
bs) -> (FileName -> ByteString
nameFN FileName
fn, (FileName -> Version
getVersion FileName
fn, ByteString
bs))) ((FileName, ByteString) -> (ByteString, (Version, ByteString)))
-> [(FileName, ByteString)]
-> [(ByteString, (Version, ByteString))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(FileName, ByteString)]
cs
  where
    getVersion :: FileName -> Version
getVersion = Version -> Maybe Version -> Version
forall a. a -> Maybe a -> a
fromMaybe Version
forall a. HasCallStack => a
undefined (Maybe Version -> Version)
-> (FileName -> Maybe Version) -> FileName -> Version
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Maybe Version
forall a. Parsec a => ByteString -> Maybe a
simpleParsecBS (ByteString -> Maybe Version)
-> (FileName -> ByteString) -> FileName -> Maybe Version
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileName -> ByteString
versionFN

-- | Latest successfully parsing 'CabalFields'
latestCabalFields :: Config -> IO (Map.Map ByteString (Version, CabalFields))
latestCabalFields :: Config -> IO (Map ByteString (Version, CabalFields))
latestCabalFields Config
cfg = do
  Map ByteString (Version, ByteString)
lcs <- IO (Map ByteString (Version, ByteString))
latestCabals
  let lcs' :: Map ByteString (Version, Either ByteString CabalFields)
lcs' = (ByteString -> Either ByteString CabalFields)
-> (Version, ByteString)
-> (Version, Either ByteString CabalFields)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (Config -> ByteString -> Either ByteString CabalFields
parseCabalFields Config
cfg) ((Version, ByteString) -> (Version, Either ByteString CabalFields))
-> Map ByteString (Version, ByteString)
-> Map ByteString (Version, Either ByteString CabalFields)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map ByteString (Version, ByteString)
lcs
  Map ByteString (Version, CabalFields)
-> IO (Map ByteString (Version, CabalFields))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Either ByteString CabalFields -> CabalFields)
-> (Version, Either ByteString CabalFields)
-> (Version, CabalFields)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (CabalFields -> Either ByteString CabalFields -> CabalFields
forall b a. b -> Either a b -> b
fromRight CabalFields
forall a. HasCallStack => a
undefined) ((Version, Either ByteString CabalFields)
 -> (Version, CabalFields))
-> Map ByteString (Version, Either ByteString CabalFields)
-> Map ByteString (Version, CabalFields)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Version, Either ByteString CabalFields) -> Bool)
-> Map ByteString (Version, Either ByteString CabalFields)
-> Map ByteString (Version, Either ByteString CabalFields)
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter ((Version, Either ByteString CabalFields)
-> Either ByteString CabalFields
forall a b. (a, b) -> b
snd ((Version, Either ByteString CabalFields)
 -> Either ByteString CabalFields)
-> (Either ByteString CabalFields -> Bool)
-> (Version, Either ByteString CabalFields)
-> Bool
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Either ByteString CabalFields -> Bool
forall a b. Either a b -> Bool
isRight) Map ByteString (Version, Either ByteString CabalFields)
lcs')

-- | extract library build-deps from a Field list, also looking in common stanzas
libDeps :: CabalFields -> [Dep]
libDeps :: CabalFields -> [Dep]
libDeps CabalFields
cf = [Dep]
deps
  where
    libFields :: [Field Comment]
libFields = CabalFields
cf CabalFields -> (CabalFields -> [Field Comment]) -> [Field Comment]
forall a b. a -> (a -> b) -> b
& Optic' A_Fold '[Int] CabalFields [Field Comment]
-> CabalFields -> [Field Comment]
forall k a (is :: IxList) s.
(Is k A_Fold, Monoid a) =>
Optic' k is s a -> s -> a
foldOf (Optic
  A_Lens
  '[]
  CabalFields
  CabalFields
  (Vector (Field Comment))
  (Vector (Field Comment))
#fields Optic
  A_Lens
  '[]
  CabalFields
  CabalFields
  (Vector (Field Comment))
  (Vector (Field Comment))
-> Optic
     An_Iso
     '[]
     (Vector (Field Comment))
     (Vector (Field Comment))
     [Field Comment]
     [Field Comment]
-> Optic
     A_Lens '[] CabalFields CabalFields [Field Comment] [Field Comment]
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic
  An_Iso
  '[]
  (Vector (Field Comment))
  (Vector (Field Comment))
  [Field Comment]
  [Field Comment]
fieldList' Optic
  A_Lens '[] CabalFields CabalFields [Field Comment] [Field Comment]
-> Optic
     A_Getter
     '[]
     [Field Comment]
     [Field Comment]
     [Field Comment]
     [Field Comment]
-> Optic
     A_Getter
     '[]
     CabalFields
     CabalFields
     [Field Comment]
     [Field Comment]
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% ByteString
-> Optic
     A_Getter
     '[]
     [Field Comment]
     [Field Comment]
     [Field Comment]
     [Field Comment]
forall ann. ByteString -> Getter [Field ann] [Field ann]
section' ByteString
"library" Optic
  A_Getter
  '[]
  CabalFields
  CabalFields
  [Field Comment]
  [Field Comment]
-> Optic
     A_Traversal
     '[Int]
     [Field Comment]
     [Field Comment]
     (Field Comment)
     (Field Comment)
-> Optic
     A_Fold
     '[Int]
     CabalFields
     CabalFields
     (Field Comment)
     (Field Comment)
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic
  A_Traversal
  '[Int]
  [Field Comment]
  [Field Comment]
  (Field Comment)
  (Field Comment)
forall i s t a b. Each i s t a b => IxTraversal i s t a b
each Optic
  A_Fold
  '[Int]
  CabalFields
  CabalFields
  (Field Comment)
  (Field Comment)
-> Optic
     A_Lens
     '[]
     (Field Comment)
     (Field Comment)
     [Field Comment]
     [Field Comment]
-> Optic' A_Fold '[Int] CabalFields [Field Comment]
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic
  A_Lens
  '[]
  (Field Comment)
  (Field Comment)
  [Field Comment]
  [Field Comment]
forall ann. Lens' (Field ann) [Field ann]
secFields')
    libBds :: ByteString
libBds = [Field Comment]
libFields [Field Comment] -> ([Field Comment] -> ByteString) -> ByteString
forall a b. a -> (a -> b) -> b
& Optic' A_Fold '[Int, Int] [Field Comment] ByteString
-> [Field Comment] -> ByteString
forall k a (is :: IxList) s.
(Is k A_Fold, Monoid a) =>
Optic' k is s a -> s -> a
foldOf (ByteString -> Optic' A_Fold '[Int, Int] [Field Comment] ByteString
fieldValues' ByteString
"build-depends")
    libDeps :: [(ByteString, ByteString)]
libDeps = Parser String [(ByteString, ByteString)]
-> ByteString -> [(ByteString, ByteString)]
forall a. Parser String a -> ByteString -> a
runParser_ (ParserT PureMode String (ByteString, ByteString)
-> Parser String [(ByteString, ByteString)]
forall a. ParserT PureMode String a -> ParserT PureMode String [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
FP.many ParserT PureMode String (ByteString, ByteString)
forall e. Parser e (ByteString, ByteString)
depP) ByteString
libBds
    libImports :: Comment
libImports = [Field Comment]
libFields [Field Comment] -> ([Field Comment] -> Comment) -> Comment
forall a b. a -> (a -> b) -> b
& Optic' A_Fold '[Int, Int] [Field Comment] ByteString
-> [Field Comment] -> Comment
forall k (is :: IxList) s a.
Is k A_Fold =>
Optic' k is s a -> s -> [a]
toListOf (ByteString -> Optic' A_Fold '[Int, Int] [Field Comment] ByteString
fieldValues' ByteString
"import")
    cs :: [Field Comment]
cs = CabalFields
cf CabalFields -> (CabalFields -> [Field Comment]) -> [Field Comment]
forall a b. a -> (a -> b) -> b
& Optic
  A_Getter
  '[]
  CabalFields
  CabalFields
  [Field Comment]
  [Field Comment]
-> CabalFields -> [Field Comment]
forall k a (is :: IxList) s.
(Is k A_Fold, Monoid a) =>
Optic' k is s a -> s -> a
foldOf (Optic
  A_Lens
  '[]
  CabalFields
  CabalFields
  (Vector (Field Comment))
  (Vector (Field Comment))
#fields Optic
  A_Lens
  '[]
  CabalFields
  CabalFields
  (Vector (Field Comment))
  (Vector (Field Comment))
-> Optic
     An_Iso
     '[]
     (Vector (Field Comment))
     (Vector (Field Comment))
     [Field Comment]
     [Field Comment]
-> Optic
     A_Lens '[] CabalFields CabalFields [Field Comment] [Field Comment]
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic
  An_Iso
  '[]
  (Vector (Field Comment))
  (Vector (Field Comment))
  [Field Comment]
  [Field Comment]
fieldList' Optic
  A_Lens '[] CabalFields CabalFields [Field Comment] [Field Comment]
-> Optic
     A_Getter
     '[]
     [Field Comment]
     [Field Comment]
     [Field Comment]
     [Field Comment]
-> Optic
     A_Getter
     '[]
     CabalFields
     CabalFields
     [Field Comment]
     [Field Comment]
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% ByteString
-> Optic
     A_Getter
     '[]
     [Field Comment]
     [Field Comment]
     [Field Comment]
     [Field Comment]
forall ann. ByteString -> Getter [Field ann] [Field ann]
section' ByteString
"common")
    libCommons :: [Field Comment]
libCommons = [Field Comment]
cs [Field Comment]
-> ([Field Comment] -> [Field Comment]) -> [Field Comment]
forall a b. a -> (a -> b) -> b
& (Field Comment -> Bool) -> [Field Comment] -> [Field Comment]
forall a. (a -> Bool) -> [a] -> [a]
filter ((ByteString -> Bool) -> Comment -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (ByteString -> Comment -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Comment
libImports) (Comment -> Bool)
-> (Field Comment -> Comment) -> Field Comment -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Optic' A_Traversal '[Int] (Field Comment) ByteString
-> Field Comment -> Comment
forall k (is :: IxList) s a.
Is k A_Fold =>
Optic' k is s a -> s -> [a]
toListOf (Lens' (Field Comment) [SectionArg Comment]
forall ann. Lens' (Field ann) [SectionArg ann]
secArgs' Lens' (Field Comment) [SectionArg Comment]
-> Optic
     A_Traversal
     '[Int]
     [SectionArg Comment]
     [SectionArg Comment]
     (SectionArg Comment)
     (SectionArg Comment)
-> Optic
     A_Traversal
     '[Int]
     (Field Comment)
     (Field Comment)
     (SectionArg Comment)
     (SectionArg Comment)
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic
  A_Traversal
  '[Int]
  [SectionArg Comment]
  [SectionArg Comment]
  (SectionArg Comment)
  (SectionArg Comment)
forall i s t a b. Each i s t a b => IxTraversal i s t a b
each Optic
  A_Traversal
  '[Int]
  (Field Comment)
  (Field Comment)
  (SectionArg Comment)
  (SectionArg Comment)
-> Optic
     A_Lens
     '[]
     (SectionArg Comment)
     (SectionArg Comment)
     (ByteString, ByteString)
     (ByteString, ByteString)
-> Optic
     A_Traversal
     '[Int]
     (Field Comment)
     (Field Comment)
     (ByteString, ByteString)
     (ByteString, ByteString)
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic
  A_Lens
  '[]
  (SectionArg Comment)
  (SectionArg Comment)
  (ByteString, ByteString)
  (ByteString, ByteString)
forall ann. Lens' (SectionArg ann) (ByteString, ByteString)
secArgBS' Optic
  A_Traversal
  '[Int]
  (Field Comment)
  (Field Comment)
  (ByteString, ByteString)
  (ByteString, ByteString)
-> Optic
     A_Lens
     '[]
     (ByteString, ByteString)
     (ByteString, ByteString)
     ByteString
     ByteString
-> Optic' A_Traversal '[Int] (Field Comment) ByteString
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic
  A_Lens
  '[]
  (ByteString, ByteString)
  (ByteString, ByteString)
  ByteString
  ByteString
forall s t a b. Field2 s t a b => Lens s t a b
_2))
    commonsBds :: ByteString
commonsBds = [Field Comment]
libCommons [Field Comment] -> ([Field Comment] -> ByteString) -> ByteString
forall a b. a -> (a -> b) -> b
& Optic' A_Fold '[Int, Int] [Field Comment] ByteString
-> [Field Comment] -> ByteString
forall k a (is :: IxList) s.
(Is k A_Fold, Monoid a) =>
Optic' k is s a -> s -> a
foldOf (ByteString -> Optic' A_Fold '[Int, Int] [Field Comment] ByteString
fieldValues' ByteString
"build-depends")
    commonsDeps :: [(ByteString, ByteString)]
commonsDeps = Parser String [(ByteString, ByteString)]
-> ByteString -> [(ByteString, ByteString)]
forall a. Parser String a -> ByteString -> a
runParser_ (ParserT PureMode String (ByteString, ByteString)
-> Parser String [(ByteString, ByteString)]
forall a. ParserT PureMode String a -> ParserT PureMode String [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
FP.many ParserT PureMode String (ByteString, ByteString)
forall e. Parser e (ByteString, ByteString)
depP) ByteString
commonsBds
    deps :: [Dep]
deps = ((ByteString, ByteString) -> Dep)
-> [(ByteString, ByteString)] -> [Dep]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((ByteString -> ByteString -> Dep)
-> (ByteString, ByteString) -> Dep
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ByteString -> ByteString -> Dep
Dep) ([(ByteString, ByteString)]
libDeps [(ByteString, ByteString)]
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. Semigroup a => a -> a -> a
<> [(ByteString, ByteString)]
commonsDeps)

-- | Map of valid dependencies
validLibDeps :: Map.Map ByteString CabalFields -> Map.Map ByteString [ByteString]
validLibDeps :: Map ByteString CabalFields -> Map ByteString Comment
validLibDeps Map ByteString CabalFields
cs = Map ByteString Comment
ldeps
  where
    vlls :: Map ByteString CabalFields
vlls = Map ByteString CabalFields
cs Map ByteString CabalFields
-> (Map ByteString CabalFields -> Map ByteString CabalFields)
-> Map ByteString CabalFields
forall a b. a -> (a -> b) -> b
& (CabalFields -> Bool)
-> Map ByteString CabalFields -> Map ByteString CabalFields
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (Optic
  A_Getter
  '[]
  CabalFields
  CabalFields
  [Field Comment]
  [Field Comment]
-> CabalFields -> [Field Comment]
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view (Optic
  A_Lens
  '[]
  CabalFields
  CabalFields
  (Vector (Field Comment))
  (Vector (Field Comment))
#fields Optic
  A_Lens
  '[]
  CabalFields
  CabalFields
  (Vector (Field Comment))
  (Vector (Field Comment))
-> Optic
     An_Iso
     '[]
     (Vector (Field Comment))
     (Vector (Field Comment))
     [Field Comment]
     [Field Comment]
-> Optic
     A_Lens '[] CabalFields CabalFields [Field Comment] [Field Comment]
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic
  An_Iso
  '[]
  (Vector (Field Comment))
  (Vector (Field Comment))
  [Field Comment]
  [Field Comment]
fieldList' Optic
  A_Lens '[] CabalFields CabalFields [Field Comment] [Field Comment]
-> Optic
     A_Getter
     '[]
     [Field Comment]
     [Field Comment]
     [Field Comment]
     [Field Comment]
-> Optic
     A_Getter
     '[]
     CabalFields
     CabalFields
     [Field Comment]
     [Field Comment]
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% ByteString
-> Optic
     A_Getter
     '[]
     [Field Comment]
     [Field Comment]
     [Field Comment]
     [Field Comment]
forall ann. ByteString -> Getter [Field ann] [Field ann]
section' ByteString
"library") (CabalFields -> [Field Comment])
-> ([Field Comment] -> Bool) -> CabalFields -> Bool
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> [Field Comment] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Field Comment] -> Int)
-> (Int -> Bool) -> [Field Comment] -> Bool
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0))
    ldeps' :: Map ByteString Comment
ldeps' = Map ByteString CabalFields
vlls Map ByteString CabalFields
-> (Map ByteString CabalFields -> Map ByteString Comment)
-> Map ByteString Comment
forall a b. a -> (a -> b) -> b
& (CabalFields -> Comment)
-> Map ByteString CabalFields -> Map ByteString Comment
forall a b. (a -> b) -> Map ByteString a -> Map ByteString b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (CabalFields -> [Dep]
libDeps (CabalFields -> [Dep])
-> ([Dep] -> Comment) -> CabalFields -> Comment
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (Dep -> ByteString) -> [Dep] -> Comment
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Dep -> ByteString
dep ([Dep] -> Comment) -> (Comment -> Comment) -> [Dep] -> Comment
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Comment -> Comment
forall a. Eq a => [a] -> [a]
List.nub)
    bdnames :: Comment
bdnames = Comment -> Comment
forall a. Eq a => [a] -> [a]
List.nub (Comment -> Comment) -> Comment -> Comment
forall a b. (a -> b) -> a -> b
$ [Comment] -> Comment
forall a. Monoid a => [a] -> a
mconcat ((ByteString, Comment) -> Comment
forall a b. (a, b) -> b
snd ((ByteString, Comment) -> Comment)
-> [(ByteString, Comment)] -> [Comment]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map ByteString Comment -> [(ByteString, Comment)]
forall k a. Map k a -> [(k, a)]
Map.toList Map ByteString Comment
ldeps')
    -- dependencies that do not exist in the main library list
    bdnames0 :: Comment
bdnames0 = (ByteString -> Bool) -> Comment -> Comment
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (ByteString -> Bool) -> ByteString -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Comment -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Map ByteString Comment -> Comment
forall k a. Map k a -> [k]
Map.keys Map ByteString Comment
ldeps')) Comment
bdnames
    -- Exclude any library that has dependencies outside the universe.
    ldeps :: Map ByteString Comment
ldeps = Map ByteString Comment
ldeps' Map ByteString Comment
-> (Map ByteString Comment -> Map ByteString Comment)
-> Map ByteString Comment
forall a b. a -> (a -> b) -> b
& (Comment -> Bool)
-> Map ByteString Comment -> Map ByteString Comment
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter ((ByteString -> Bool) -> Comment -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (ByteString -> Comment -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`List.elem` Comment
bdnames0) (Comment -> Bool) -> (Bool -> Bool) -> Comment -> Bool
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Bool -> Bool
not)

-- | Graph of all valid dependencies
allDepGraph :: Map.Map ByteString CabalFields -> Graph ByteString
allDepGraph :: Map ByteString CabalFields -> Graph ByteString
allDepGraph Map ByteString CabalFields
cs = Graph ByteString -> Graph ByteString
forall a. Graph a -> Graph a
transpose (Graph ByteString -> Graph ByteString)
-> Graph ByteString -> Graph ByteString
forall a b. (a -> b) -> a -> b
$ [(ByteString, Comment)] -> Graph ByteString
forall a. [(a, [a])] -> Graph a
stars (Map ByteString Comment -> [(ByteString, Comment)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map ByteString CabalFields -> Map ByteString Comment
validLibDeps Map ByteString CabalFields
cs))

-- | count distinct elements of a list.
count_ :: (Ord a) => [a] -> Map.Map a Int
count_ :: forall a. Ord a => [a] -> Map a Int
count_ = (Map a Int -> a -> Map a Int) -> Map a Int -> [a] -> Map a Int
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Map a Int
x a
a -> (Int -> Int -> Int) -> a -> Int -> Map a Int -> Map a Int
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) a
a Int
1 Map a Int
x) Map a Int
forall k a. Map k a
Map.empty

-- | collect distinct monoidal values
collect_ :: (Ord k) => [(k, v)] -> Map.Map k [v]
collect_ :: forall k v. Ord k => [(k, v)] -> Map k [v]
collect_ = (Map k [v] -> (k, v) -> Map k [v])
-> Map k [v] -> [(k, v)] -> Map k [v]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Map k [v]
x (k
k, v
v) -> ([v] -> [v] -> [v]) -> k -> [v] -> Map k [v] -> Map k [v]
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith [v] -> [v] -> [v]
forall a. Semigroup a => a -> a -> a
(<>) k
k [v
v] Map k [v]
x) Map k [v]
forall k a. Map k a
Map.empty

-- | Get the set of upstream projects
upstreams :: ByteString -> Graph ByteString -> Set.Set ByteString
upstreams :: ByteString -> Graph ByteString -> Set ByteString
upstreams ByteString
x Graph ByteString
g = ByteString -> Set ByteString -> Set ByteString
forall a. Ord a => a -> Set a -> Set a
Set.delete ByteString
"base" (Set ByteString -> Set ByteString)
-> Set ByteString -> Set ByteString
forall a b. (a -> b) -> a -> b
$ ToVertex (Graph ByteString)
-> Graph ByteString -> Set (ToVertex (Graph ByteString))
forall t.
(ToGraph t, Ord (ToVertex t)) =>
ToVertex t -> t -> Set (ToVertex t)
ToGraph.preSet ByteString
ToVertex (Graph ByteString)
x Graph ByteString
g

-- | Get the set of downstream projects.
downstreams :: ByteString -> Graph ByteString -> Set.Set ByteString
downstreams :: ByteString -> Graph ByteString -> Set ByteString
downstreams ByteString
x Graph ByteString
g = ToVertex (Graph ByteString)
-> Graph ByteString -> Set (ToVertex (Graph ByteString))
forall t.
(ToGraph t, Ord (ToVertex t)) =>
ToVertex t -> t -> Set (ToVertex t)
ToGraph.postSet ByteString
ToVertex (Graph ByteString)
x Graph ByteString
g

-- | Get the upstream graph of a library. text, for example:
upstreamG :: ByteString -> Graph ByteString -> Graph ByteString
upstreamG :: ByteString -> Graph ByteString -> Graph ByteString
upstreamG ByteString
lib Graph ByteString
g = (ByteString -> Bool) -> Graph ByteString -> Graph ByteString
forall a. (a -> Bool) -> Graph a -> Graph a
induce (ByteString -> Comment -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Set ByteString -> Comment
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Set ByteString
supers) Graph ByteString
g
  where
    supers :: Set ByteString
supers = ByteString -> Graph ByteString -> Set ByteString
upstreams ByteString
lib Graph ByteString
g Set ByteString -> Set ByteString -> Set ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> Set ByteString
forall a. a -> Set a
Set.singleton ByteString
"text"

-- | Create a dot graph from an algebraic graph of dependencies
dotUpstream :: Graph ByteString -> ByteString
dotUpstream :: Graph ByteString -> ByteString
dotUpstream Graph ByteString
g = DotConfig -> Graph -> ByteString
forall a. DotParse a => DotConfig -> a -> ByteString
Dot.dotPrint DotConfig
Dot.defaultDotConfig Graph
g'
  where
    baseGraph :: Graph
baseGraph = Graph
Dot.defaultGraph Graph -> (Graph -> Graph) -> Graph
forall a b. a -> (a -> b) -> b
& AttributeType -> ID -> Lens' Graph (Maybe ID)
Dot.attL AttributeType
Dot.GraphType (ByteString -> ID
Dot.ID ByteString
"size") Lens' Graph (Maybe ID) -> Maybe ID -> Graph -> Graph
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ ID -> Maybe ID
forall a. a -> Maybe a
Just (ByteString -> ID
Dot.IDQuoted ByteString
"5!") Graph -> (Graph -> Graph) -> Graph
forall a b. a -> (a -> b) -> b
& AttributeType -> ID -> Lens' Graph (Maybe ID)
Dot.attL AttributeType
Dot.NodeType (ByteString -> ID
Dot.ID ByteString
"shape") Lens' Graph (Maybe ID) -> Maybe ID -> Graph -> Graph
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ ID -> Maybe ID
forall a. a -> Maybe a
Just (ByteString -> ID
Dot.ID ByteString
"box") Graph -> (Graph -> Graph) -> Graph
forall a b. a -> (a -> b) -> b
& AttributeType -> ID -> Lens' Graph (Maybe ID)
Dot.attL AttributeType
Dot.NodeType (ByteString -> ID
Dot.ID ByteString
"height") Lens' Graph (Maybe ID) -> Maybe ID -> Graph -> Graph
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ ID -> Maybe ID
forall a. a -> Maybe a
Just (ByteString -> ID
Dot.ID ByteString
"2") Graph -> (Graph -> Graph) -> Graph
forall a b. a -> (a -> b) -> b
& ID -> Lens' Graph (Maybe ID)
Dot.gattL (ByteString -> ID
Dot.ID ByteString
"rankdir") Lens' Graph (Maybe ID) -> Maybe ID -> Graph -> Graph
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ ID -> Maybe ID
forall a. a -> Maybe a
Just (ByteString -> ID
Dot.IDQuoted ByteString
"TB")
    g' :: Graph
g' = Directed -> Graph -> Graph ByteString -> Graph
Dot.toDotGraphWith Directed
Dot.Directed Graph
baseGraph Graph ByteString
g

-- | make an svg file of a dependency graph
--
-- ![text example](other/textdeps.svg)
dotUpstreamSvg :: Graph ByteString -> FilePath -> IO ByteString
dotUpstreamSvg :: Graph ByteString -> String -> IO ByteString
dotUpstreamSvg Graph ByteString
g String
svg = Directed -> [String] -> ByteString -> IO ByteString
Dot.processDotWith Directed
Dot.Directed [String
"-Tsvg", String
"-o" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
svg] (Graph ByteString -> ByteString
dotUpstream Graph ByteString
g)