{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wno-name-shadowing #-}
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
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"
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
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)
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
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
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
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
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')
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)
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')
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
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)
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_ :: (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_ :: (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
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
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
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"
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
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)